mirror of
https://github.com/ProgramSnail/Lama.git
synced 2025-12-06 14:58:50 +00:00
Better value control
This commit is contained in:
Dmitry Boulytchev
parent
d8ddf25a7f
commit
9bec185603
14 changed files with 147 additions and 100 deletions
|
|
@ -13,4 +13,4 @@ elif n == 4 then write (3)
|
|||
|
||||
n := n - 1
|
||||
|
||||
until n == 0
|
||||
until (n == 0)
|
||||
|
|
@ -7,6 +7,6 @@ repeat
|
|||
s := s * n;
|
||||
n := n - 1
|
||||
|
||||
until n == 0;
|
||||
until (n == 0);
|
||||
|
||||
write (s)
|
||||
|
|
@ -3,6 +3,6 @@ s := 0;
|
|||
repeat
|
||||
n := read ();
|
||||
s := s + n
|
||||
until n == 0;
|
||||
until (n == 0);
|
||||
|
||||
write (s)
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ fun fib (n) {
|
|||
if n <= 1
|
||||
then return 1
|
||||
else
|
||||
return fib (n-1) + fib (n-2)
|
||||
return (fib (n-1) + fib (n-2))
|
||||
fi
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ fun fact (n) {
|
|||
if n <= 1
|
||||
then return 1
|
||||
else
|
||||
return n * fact (n-1)
|
||||
return (n * fact (n-1))
|
||||
fi
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
fun ack (m, n) {
|
||||
if m == 0 then return n+1
|
||||
if m == 0 then return (n+1)
|
||||
elif m > 0 && n == 0 then return ack (m-1, 1)
|
||||
else return ack (m-1, ack (m, n-1))
|
||||
fi
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
fun sum (x) {
|
||||
case x of
|
||||
Nil -> return 0
|
||||
| Cons (x, tl) -> return x + sum (tl)
|
||||
| Cons (x, tl) -> return (x + sum (tl))
|
||||
esac
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -11,9 +11,10 @@ fun test (n, m) local i, s {
|
|||
n := read ();
|
||||
y := ((((((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))))) + (((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))))) + ((((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))))) + (((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))))))) + (((((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))))) + (((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))))) + ((((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))))) + (((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + test(10, 100)))))))));
|
||||
|
||||
t := test(10, 100);
|
||||
t := test (10, 100);
|
||||
y2 := ((((((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))))) + (((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))))) + ((((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))))) + (((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))))))) + (((((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))))) + (((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))))) + ((((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))))) + (((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + t))))))));
|
||||
|
||||
write (t);
|
||||
write (y2);
|
||||
write (y)
|
||||
|
||||
|
|
|
|||
|
|
@ -16,14 +16,14 @@ infix "===" at "==" (v1, v2) local s1, s2, i {
|
|||
infix "?" before "+" (v, l) {
|
||||
case l of
|
||||
{} -> return 0
|
||||
| h : tl -> if h === v then return 1 else return v ? tl fi
|
||||
| h : tl -> if h === v then return 1 else return (v ? tl) fi
|
||||
esac
|
||||
}
|
||||
|
||||
infix "+++" at "+" (l1, l2) {
|
||||
case l1 of
|
||||
{} -> return l2
|
||||
| h : tl -> return h : tl +++ l2
|
||||
| h : tl -> return (h : tl +++ l2)
|
||||
esac
|
||||
}
|
||||
|
||||
|
|
@ -35,5 +35,3 @@ write (1+2 ? {1, 2, 3});
|
|||
write (1*3+2 ? {1, 2, 3});
|
||||
write (1*3+2 ? {1, 2, 5});
|
||||
write (8*4 ? {1, 2, 3} +++ {5, 7, 32, 6})
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -339,7 +339,7 @@ extern int Bsexp_tag_patt (void *x) {
|
|||
|
||||
return BOX(TAG(TO_DATA(x)->tag) == SEXP_TAG);
|
||||
}
|
||||
|
||||
/*
|
||||
extern void Bsta (int n, int v, void *s, ...) {
|
||||
va_list args = (va_list) BOX (NULL);
|
||||
int i = 0, k = 0;
|
||||
|
|
@ -358,6 +358,11 @@ extern void Bsta (int n, int v, void *s, ...) {
|
|||
if (TAG(a->tag) == STRING_TAG)((char*) s)[k] = (char) UNBOX(v);
|
||||
else ((int*) s)[k] = v;
|
||||
}
|
||||
*/
|
||||
extern void Bsta (void *v, int i, void *x) {
|
||||
if (TAG(TO_DATA(x)->tag) == STRING_TAG)((char*) x)[UNBOX(i)] = (char) UNBOX(v);
|
||||
else ((int*) x)[UNBOX(i)] = v;
|
||||
}
|
||||
|
||||
extern int Lraw (int x) {
|
||||
return UNBOX(x);
|
||||
|
|
|
|||
|
|
@ -153,7 +153,7 @@ module Builtin =
|
|||
|
||||
let eval (st, i, o, vs) args = function
|
||||
| "read" -> (match i with z::i' -> (st, i', o, (Value.of_int z)::vs) | _ -> failwith "Unexpected end of input")
|
||||
| "write" -> (st, i, o @ [Value.to_int @@ List.hd args], (*Value.Empty ::*) vs)
|
||||
| "write" -> (st, i, o @ [Value.to_int @@ List.hd args], Value.Empty :: vs)
|
||||
| ".elem" -> let [b; j] = args in
|
||||
(st, i, o, let i = Value.to_int j in
|
||||
(match b with
|
||||
|
|
@ -254,6 +254,8 @@ module Expr =
|
|||
(* loop with a post-condition *) | Repeat of t * t
|
||||
(* pattern-matching *) | Case of t * (Pattern.t * t) list
|
||||
(* return statement *) | Return of t option
|
||||
(* ignore a value *) | Ignore of t
|
||||
(* unit value *) | Unit
|
||||
(* leave a scope *) | Leave
|
||||
(* intrinsic (for evaluation) *) | Intrinsic of (config -> config)
|
||||
(* control (for control flow) *) | Control of (config -> t * config)
|
||||
|
|
@ -316,6 +318,8 @@ module Expr =
|
|||
|
||||
let rec eval env ((st, i, o, vs) as conf) k expr =
|
||||
match expr with
|
||||
| Unit -> eval env (st, i, o, Value.Empty :: vs) Skip k
|
||||
| Ignore s -> eval env conf k (schedule_list [s; Intrinsic (fun (st, i, o, vs) -> (st, i, o, List.tl vs))])
|
||||
| Control f ->
|
||||
let s, conf' = f conf in
|
||||
eval env conf' k s
|
||||
|
|
@ -348,7 +352,7 @@ module Expr =
|
|||
env#definition env f (List.rev es) (st, i, o, vs'))]))
|
||||
| Leave -> eval env (State.drop st, i, o, vs) Skip k
|
||||
| Assign (x, e) ->
|
||||
eval env conf k (schedule_list [x; e; Intrinsic (fun (st, i, o, v::x::vs) -> (update st x v, i, o, vs))])
|
||||
eval env conf k (schedule_list [x; e; Intrinsic (fun (st, i, o, v::x::vs) -> (update st x v, i, o, v::vs))])
|
||||
| Seq (s1, s2) ->
|
||||
eval env conf (seq s2 k) s1
|
||||
| Skip ->
|
||||
|
|
@ -412,6 +416,38 @@ module Expr =
|
|||
| Case (e, bs) -> Case (e, List.map (fun (p, e) -> p, propagate_ref e) bs)
|
||||
| _ -> raise (Semantic_error "not a destination")
|
||||
|
||||
(* Balance values *)
|
||||
let rec balance_value = function
|
||||
| Array es -> Array (List.map balance_value es)
|
||||
| Sexp (s, es) -> Sexp (s, List.map balance_value es)
|
||||
| Binop (o, l, r) -> Binop (o, balance_value l, balance_value r)
|
||||
| Elem (b, i) -> Elem (balance_value b, balance_value i)
|
||||
| ElemRef (b, i) -> ElemRef (balance_value b, balance_value i)
|
||||
| Length x -> Length (balance_value x)
|
||||
| StringVal x -> StringVal (balance_value x)
|
||||
| Call (f, es) -> Call (balance_value f, List.map balance_value es)
|
||||
| Assign (d, s) -> Assign (balance_value d, balance_value s)
|
||||
| Seq (l, r) -> Seq (balance_void l, balance_value r)
|
||||
| If (c, t, e) -> If (balance_value c, balance_value t, balance_value e)
|
||||
| Case (e, ps) -> Case (balance_value e, List.map (fun (p, e) -> p, balance_value e) ps)
|
||||
|
||||
| Return _
|
||||
| While _
|
||||
| Repeat _
|
||||
| Skip -> raise (Semantic_error "missing value")
|
||||
|
||||
| e -> e
|
||||
and balance_void = function
|
||||
| If (c, t, e) -> If (balance_value c, balance_void t, balance_void e)
|
||||
| Seq (l, r) -> Seq (balance_void l, balance_void r)
|
||||
| Case (e, ps) -> Case (balance_value e, List.map (fun (p, e) -> p, balance_void e) ps)
|
||||
| While (e, s) -> While (balance_value e, balance_void s)
|
||||
| Repeat (s, e) -> Repeat (balance_void s, balance_value e)
|
||||
| Return (Some e) -> Return (Some (balance_value e))
|
||||
| Return None -> Return None
|
||||
| Skip -> Skip
|
||||
| e -> Ignore (balance_value e)
|
||||
|
||||
ostap (
|
||||
parse[infix]: h:basic[infix] t:(-";" parse[infix])? {match t with None -> h | Some t -> Seq (h, t)};
|
||||
basic[infix]:
|
||||
|
|
@ -588,7 +624,7 @@ module Definition =
|
|||
<(name, infix')> : head[infix] "(" args:!(Util.list0 arg) ")"
|
||||
locs:(%"local" !(Util.list arg))?
|
||||
"{" body:!(Expr.parse infix') "}" {
|
||||
(name, (args, (match locs with None -> [] | Some l -> l), body)), infix'
|
||||
(name, (args, (match locs with None -> [] | Some l -> l), Expr.balance_void body)), infix'
|
||||
}
|
||||
)
|
||||
|
||||
|
|
@ -616,7 +652,7 @@ let eval (defs, body) i =
|
|||
let xs, locs, s = snd @@ M.find f m in
|
||||
let st' = List.fold_left (fun st (x, a) -> State.update x a st) (State.enter st (xs @ locs)) (List.combine xs args) in
|
||||
let st'', i', o', vs' = Expr.eval env (st', i, o, []) Skip s in
|
||||
(State.leave st'' st, i', o', match vs' with [v] -> v::vs | _ -> vs)
|
||||
(State.leave st'' st, i', o', match vs' with [v] -> v::vs | _ -> Value.Empty :: vs)
|
||||
with Not_found -> Builtin.eval conf args f
|
||||
end)
|
||||
(State.empty, i, [], [])
|
||||
|
|
@ -627,7 +663,7 @@ let eval (defs, body) i =
|
|||
|
||||
(* Top-level parser *)
|
||||
ostap (
|
||||
parse[infix]: <(defs, infix')> : definitions[infix] body:!(Expr.parse infix') {defs, body};
|
||||
parse[infix]: <(defs, infix')> : definitions[infix] body:!(Expr.parse infix') {defs, Expr.balance_void body};
|
||||
definitions[infix]:
|
||||
<(def, infix')> : !(Definition.parse infix) <(defs, infix'')> : definitions[infix'] {def::defs, infix''}
|
||||
| empty {[], infix}
|
||||
|
|
|
|||
25
src/SM.ml
25
src/SM.ml
|
|
@ -20,7 +20,7 @@ open Language
|
|||
(* begins procedure definition *) | BEGIN of string * string list * string list
|
||||
(* end procedure definition *) | END
|
||||
(* calls a function/procedure *) | CALL of string * int
|
||||
(* returns from a function *) | RET of bool
|
||||
(* returns from a function *) | RET
|
||||
(* drops the top element off *) | DROP
|
||||
(* duplicates the top element *) | DUP
|
||||
(* swaps two top elements *) | SWAP
|
||||
|
|
@ -67,8 +67,8 @@ let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function
|
|||
eval env (cstack, (Value.sexp s @@ List.rev vs)::stack', c) prg'
|
||||
| LD x -> eval env (cstack, State.eval st x :: stack, c) prg'
|
||||
| LDA x -> eval env (cstack, (Value.Var x) :: stack, c) prg'
|
||||
| ST -> let z::r::stack' = stack in eval env (cstack, stack', (Expr.update st r z, i, o)) prg'
|
||||
| STA -> let v::j::x::stack' = stack in eval env (cstack, stack', (Expr.update st (Value.Elem (x, Value.to_int j)) v, i, o)) prg'
|
||||
| ST -> let z::r::stack' = stack in eval env (cstack, z::stack', (Expr.update st r z, i, o)) prg'
|
||||
| STA -> let v::j::x::stack' = stack in eval env (cstack, v::stack', (Expr.update st (Value.Elem (x, Value.to_int j)) v, i, o)) prg'
|
||||
| LABEL _ -> eval env conf prg'
|
||||
| JMP l -> eval env conf (env#labeled l)
|
||||
| CJMP (c, l) -> let x::stack' = stack in eval env (cstack, stack', (st, i, o)) (if (c = "z" && Value.to_int x = 0) || (c = "nz" && Value.to_int x <> 0) then env#labeled l else prg')
|
||||
|
|
@ -78,10 +78,16 @@ let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function
|
|||
| BEGIN (_, args, locals) -> let vs, stack' = split (List.length args) stack in
|
||||
let state = List.combine args @@ List.rev vs in
|
||||
eval env (cstack, stack', (List.fold_left (fun s (x, v) -> State.update x v s) (State.enter st (args @ locals)) state, i, o)) prg'
|
||||
| END | RET _ -> (match cstack with
|
||||
| END -> (match cstack with
|
||||
| (prg', st')::cstack' -> eval env (cstack', Value.Empty :: stack, (State.leave st st', i, o)) prg'
|
||||
| [] -> conf
|
||||
)
|
||||
|
||||
| RET -> (match cstack with
|
||||
| (prg', st')::cstack' -> eval env (cstack', stack, (State.leave st st', i, o)) prg'
|
||||
| [] -> conf
|
||||
)
|
||||
|
||||
| DROP -> eval env (cstack, List.tl stack, c) prg'
|
||||
| DUP -> eval env (cstack, List.hd stack :: stack, c) prg'
|
||||
| SWAP -> let x::y::stack' = stack in
|
||||
|
|
@ -132,7 +138,7 @@ let run p i =
|
|||
let args, stack' = split n stack in
|
||||
let (st, i, o, r) = Language.Builtin.eval (st, i, o, []) (List.rev args) f in
|
||||
(*Printf.printf "Builtin:\n";*)
|
||||
(cstack, (match r with [r] -> r::stack' | _ -> stack'), (st, i, o))
|
||||
(cstack, (match r with [r] -> r::stack' | _ -> Value.Empty :: stack'), (st, i, o))
|
||||
end
|
||||
)
|
||||
([], [], (State.empty, i, []))
|
||||
|
|
@ -222,6 +228,11 @@ let compile (defs, p) =
|
|||
let env, flag2, s2 = compile_list l env es in
|
||||
add_code (env, flag1, s1) les flag2 s2
|
||||
and compile_expr l env = function
|
||||
| Expr.Unit -> env, false, [CONST 0]
|
||||
|
||||
| Expr.Ignore s -> let ls, env = env#get_label in
|
||||
add_code (compile_expr ls env s) ls false [DROP]
|
||||
|
||||
| Expr.ElemRef (x, i) -> compile_list l env [x; i]
|
||||
| Expr.Var x -> env, false, [LD x]
|
||||
| Expr.Ref x -> env, false, [LDA x]
|
||||
|
|
@ -278,9 +289,9 @@ let compile (defs, p) =
|
|||
env, false, [LABEL loop] @ body @ (if flag then [LABEL check] else []) @ se @ (if fe then [LABEL lexp] else []) @ [CJMP ("z", loop)]
|
||||
|
||||
| Expr.Return (Some e) -> let lret, env = env#get_label in
|
||||
add_code (compile_expr lret env e) lret false [RET true]
|
||||
add_code (compile_expr lret env e) lret false [RET]
|
||||
|
||||
| Expr.Return None -> env, false, [RET false]
|
||||
| Expr.Return None -> env, false, [CONST 0; RET]
|
||||
|
||||
| Expr.Leave -> env, false, [LEAVE]
|
||||
|
||||
|
|
|
|||
56
src/X86.ml
56
src/X86.ml
|
|
@ -17,6 +17,7 @@ let word_size = 4;;
|
|||
| S of int (* a position on the hardware stack *)
|
||||
| M of string (* a named memory location *)
|
||||
| L of int (* an immediate operand *)
|
||||
| I of opnd (* an indirect operand *)
|
||||
with show
|
||||
|
||||
let show_opnd = show(opnd)
|
||||
|
|
@ -34,6 +35,7 @@ let esp = R 7
|
|||
(* Now x86 instruction (we do not need all of them): *)
|
||||
type instr =
|
||||
(* copies a value from the first to the second operand *) | Mov of opnd * opnd
|
||||
(* loads an address of the first operand into the second *) | Lea of opnd * opnd
|
||||
(* makes a binary operation; note, the first operand *) | Binop of string * opnd * opnd
|
||||
(* designates x86 operator, not the source language one *)
|
||||
(* x86 integer division, see instruction set reference *) | IDiv of opnd
|
||||
|
|
@ -55,7 +57,6 @@ type instr =
|
|||
(* arithmetic correction: shl 1 *) | Sal1 of opnd
|
||||
(* arithmetic correction: shr 1 *) | Sar1 of opnd
|
||||
| Repmovsl
|
||||
|
||||
(* Instruction printer *)
|
||||
let show instr =
|
||||
let binop = function
|
||||
|
|
@ -68,13 +69,14 @@ let show instr =
|
|||
| "cmp" -> "cmpl"
|
||||
| _ -> failwith "unknown binary operator"
|
||||
in
|
||||
let opnd = function
|
||||
let rec opnd = function
|
||||
| R i -> regs.(i)
|
||||
| S i -> if i >= 0
|
||||
then Printf.sprintf "-%d(%%ebp)" ((i+1) * word_size)
|
||||
else Printf.sprintf "%d(%%ebp)" (8+(-i-1) * word_size)
|
||||
| M x -> x
|
||||
| L i -> Printf.sprintf "$%d" i
|
||||
| I x -> Printf.sprintf "(%s)" (opnd x)
|
||||
in
|
||||
match instr with
|
||||
| Cltd -> "\tcltd"
|
||||
|
|
@ -82,6 +84,7 @@ let show instr =
|
|||
| IDiv s1 -> Printf.sprintf "\tidivl\t%s" (opnd s1)
|
||||
| Binop (op, s1, s2) -> Printf.sprintf "\t%s\t%s,\t%s" (binop op) (opnd s1) (opnd s2)
|
||||
| Mov (s1, s2) -> Printf.sprintf "\tmovl\t%s,\t%s" (opnd s1) (opnd s2)
|
||||
| Lea (x, y) -> Printf.sprintf "\tleal\t%s,\t%s" (opnd x) (opnd y)
|
||||
| Push s -> Printf.sprintf "\tpushl\t%s" (opnd s)
|
||||
| Pop s -> Printf.sprintf "\tpopl\t%s" (opnd s)
|
||||
| Ret -> "\tret"
|
||||
|
|
@ -107,7 +110,7 @@ open SM
|
|||
of x86 instructions
|
||||
*)
|
||||
let compile env code =
|
||||
(*SM.print_prg code;*)
|
||||
SM.print_prg code;
|
||||
flush stdout;
|
||||
let suffix = function
|
||||
| "<" -> "l"
|
||||
|
|
@ -129,9 +132,6 @@ let compile env code =
|
|||
List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers n)
|
||||
in
|
||||
let env, code =
|
||||
if n = 0
|
||||
then env, pushr @ [Call f] @ (List.rev popr)
|
||||
else
|
||||
let rec push_args env acc = function
|
||||
| 0 -> env, acc
|
||||
| n -> let x, env = env#pop in
|
||||
|
|
@ -142,9 +142,7 @@ let compile env code =
|
|||
match f with
|
||||
| "Barray" -> List.rev @@ (Push (L n)) :: pushs
|
||||
| "Bsexp" -> List.rev @@ (Push (L n)) :: pushs
|
||||
| "Bsta" ->
|
||||
let x::v::is = List.rev pushs in
|
||||
is @ [x; v] @ [Push (L (n-2))]
|
||||
| "Bsta" -> pushs
|
||||
| _ -> List.rev pushs
|
||||
in
|
||||
env, pushr @ pushs @ [Call f; Binop ("+", L (4 * List.length pushs), esp)] @ (List.rev popr)
|
||||
|
|
@ -167,6 +165,14 @@ let compile env code =
|
|||
let env, call = call env ".string" 1 false in
|
||||
(env, Mov (M ("$" ^ s), l) :: call)
|
||||
|
||||
| LDA x ->
|
||||
let s, env' = (env#variable x)#allocate in
|
||||
env',
|
||||
(match s with
|
||||
| S _ | M _ -> [Lea (env'#loc x, eax); Mov (eax, s)]
|
||||
| _ -> [Lea (env'#loc x, s)]
|
||||
)
|
||||
|
||||
| LD x ->
|
||||
let s, env' = (env#variable x)#allocate in
|
||||
env',
|
||||
|
|
@ -175,25 +181,16 @@ let compile env code =
|
|||
| _ -> [Mov (env'#loc x, s)]
|
||||
)
|
||||
|
||||
(* TODO
|
||||
| STA (x, n) ->
|
||||
let s, env = (env#variable x)#allocate in
|
||||
let push =
|
||||
match s with
|
||||
| S _ | M _ -> [Mov (env#loc x, eax); Mov (eax, s)]
|
||||
| _ -> [Mov (env#loc x, s)]
|
||||
in
|
||||
let env, code = call env ".sta" (n+2) true in
|
||||
env, push @ code
|
||||
| STA ->
|
||||
call env ".sta" 3 true
|
||||
|
||||
| ST x ->
|
||||
let s, env' = (env#variable x)#pop in
|
||||
| ST ->
|
||||
let v, x, env' = env#pop2 in
|
||||
env',
|
||||
(match s with
|
||||
| S _ | M _ -> [Mov (s, eax); Mov (eax, env'#loc x)]
|
||||
| _ -> [Mov (s, env'#loc x)]
|
||||
(match x with
|
||||
| S _ | M _ -> [Mov (v, edx); Mov (x, eax); Mov (edx, I eax)]
|
||||
| _ -> [Mov (v, eax); Mov (eax, I x)]
|
||||
)
|
||||
*)
|
||||
|
||||
| BINOP op ->
|
||||
let x, y, env' = env#pop2 in
|
||||
|
|
@ -310,12 +307,11 @@ let compile env code =
|
|||
Meta (Printf.sprintf "\t.set\t%s,\t%d" env#allocated_size env#allocated)
|
||||
]
|
||||
|
||||
| RET b ->
|
||||
if b
|
||||
then let x, env = env#pop in env, [Mov (x, eax); Jmp env#epilogue]
|
||||
else env, [Jmp env#epilogue]
|
||||
| RET ->
|
||||
let x, env = env#pop in
|
||||
env, [Mov (x, eax); Jmp env#epilogue]
|
||||
|
||||
| CALL (f, n) -> call env f n (* p *) false (* TODO!!! *)
|
||||
| CALL (f, n) -> call env f n (f <> "Lraw" && f <> "Lcollect_ints" && f <> "Lcollect_ints_acc" && f <> "Lread" && f <> ".elem" && f <> ".array" && f <> ".length")
|
||||
|
||||
| SEXP (t, n) ->
|
||||
let s, env = env#allocate in
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue