st/lama_byterun
1
0
Fork 0
mirror of https://github.com/ProgramSnail/Lama.git synced 2025-12-06 14:58:50 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

Better value control

Browse source
This commit is contained in:
Dmitry Boulytchev 2019-04-10 22:15:08 +03:00
parent d8ddf25a7f
commit 9bec185603
14 changed files with 147 additions and 100 deletions
Download patch file Download diff file Expand all files Collapse all files

2
regression/test013.expr
View file

@ -13,4 +13,4 @@ elif n == 4 then write (3)
n := n - 1 n := n - 1
until n == 0 until (n == 0)

2
regression/test016.expr
View file

@ -7,6 +7,6 @@ repeat
s := s * n; s := s * n;
n := n - 1 n := n - 1
until n == 0; until (n == 0);
write (s) write (s)

2
regression/test023.expr
View file

@ -3,6 +3,6 @@ s := 0;
repeat repeat
n := read (); n := read ();
s := s + n s := s + n
until n == 0; until (n == 0);
write (s) write (s)

2
regression/test030.expr
View file

@ -2,7 +2,7 @@ fun fib (n) {
if n <= 1 if n <= 1
then return 1 then return 1
else else
return fib (n-1) + fib (n-2) return (fib (n-1) + fib (n-2))
fi fi
} }

2
regression/test031.expr
View file

@ -2,7 +2,7 @@ fun fact (n) {
if n <= 1 if n <= 1
then return 1 then return 1
else else
return n * fact (n-1) return (n * fact (n-1))
fi fi
} }

2
regression/test032.expr
View file

@ -1,5 +1,5 @@
fun ack (m, n) { 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) elif m > 0 && n == 0 then return ack (m-1, 1)
else return ack (m-1, ack (m, n-1)) else return ack (m-1, ack (m, n-1))
fi fi

2
regression/test043.expr
View file

@ -1,7 +1,7 @@
fun sum (x) { fun sum (x) {
case x of case x of
Nil -> return 0 Nil -> return 0
| Cons (x, tl) -> return x + sum (tl) | Cons (x, tl) -> return (x + sum (tl))
esac esac
} }

3
regression/test049.expr
View file

@ -11,9 +11,10 @@ fun test (n, m) local i, s {
n := read (); 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))))))))); 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)))))))); 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 (t);
write (y2); write (y2);
write (y) write (y)

6
regression/test053.expr
View file

@ -16,14 +16,14 @@ infix "===" at "==" (v1, v2) local s1, s2, i {
infix "?" before "+" (v, l) { infix "?" before "+" (v, l) {
case l of case l of
{} -> return 0 {} -> 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 esac
} }
infix "+++" at "+" (l1, l2) { infix "+++" at "+" (l1, l2) {
case l1 of case l1 of
{} -> return l2 {} -> return l2
| h : tl -> return h : tl +++ l2 | h : tl -> return (h : tl +++ l2)
esac esac
} }
@ -35,5 +35,3 @@ write (1+2 ? {1, 2, 3});
write (1*3+2 ? {1, 2, 3}); write (1*3+2 ? {1, 2, 3});
write (1*3+2 ? {1, 2, 5}); write (1*3+2 ? {1, 2, 5});
write (8*4 ? {1, 2, 3} +++ {5, 7, 32, 6}) write (8*4 ? {1, 2, 3} +++ {5, 7, 32, 6})

7
runtime/runtime.c
View file

@ -339,7 +339,7 @@ extern int Bsexp_tag_patt (void *x) {
return BOX(TAG(TO_DATA(x)->tag) == SEXP_TAG); return BOX(TAG(TO_DATA(x)->tag) == SEXP_TAG);
} }
/*
extern void Bsta (int n, int v, void *s, ...) { extern void Bsta (int n, int v, void *s, ...) {
va_list args = (va_list) BOX (NULL); va_list args = (va_list) BOX (NULL);
int i = 0, k = 0; 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); if (TAG(a->tag) == STRING_TAG)((char*) s)[k] = (char) UNBOX(v);
else ((int*) s)[k] = 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) { extern int Lraw (int x) {
return UNBOX(x); return UNBOX(x);

46
src/Language.ml
View file

@ -153,7 +153,7 @@ module Builtin =
let eval (st, i, o, vs) args = function 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") | "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 | ".elem" -> let [b; j] = args in
(st, i, o, let i = Value.to_int j in (st, i, o, let i = Value.to_int j in
(match b with (match b with
@ -254,6 +254,8 @@ module Expr =
(* loop with a post-condition *) | Repeat of t * t (* loop with a post-condition *) | Repeat of t * t
(* pattern-matching *) | Case of t * (Pattern.t * t) list (* pattern-matching *) | Case of t * (Pattern.t * t) list
(* return statement *) | Return of t option (* return statement *) | Return of t option
(* ignore a value *) | Ignore of t
(* unit value *) | Unit
(* leave a scope *) | Leave (* leave a scope *) | Leave
(* intrinsic (for evaluation) *) | Intrinsic of (config -> config) (* intrinsic (for evaluation) *) | Intrinsic of (config -> config)
(* control (for control flow) *) | Control of (config -> t * 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 = let rec eval env ((st, i, o, vs) as conf) k expr =
match expr with 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 -> | Control f ->
let s, conf' = f conf in let s, conf' = f conf in
eval env conf' k s eval env conf' k s
@ -348,7 +352,7 @@ module Expr =
env#definition env f (List.rev es) (st, i, o, vs'))])) env#definition env f (List.rev es) (st, i, o, vs'))]))
| Leave -> eval env (State.drop st, i, o, vs) Skip k | Leave -> eval env (State.drop st, i, o, vs) Skip k
| Assign (x, e) -> | 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) -> | Seq (s1, s2) ->
eval env conf (seq s2 k) s1 eval env conf (seq s2 k) s1
| Skip -> | Skip ->
@ -412,6 +416,38 @@ module Expr =
| Case (e, bs) -> Case (e, List.map (fun (p, e) -> p, propagate_ref e) bs) | Case (e, bs) -> Case (e, List.map (fun (p, e) -> p, propagate_ref e) bs)
| _ -> raise (Semantic_error "not a destination") | _ -> 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 ( ostap (
parse[infix]: h:basic[infix] t:(-";" parse[infix])? {match t with None -> h | Some t -> Seq (h, t)}; parse[infix]: h:basic[infix] t:(-";" parse[infix])? {match t with None -> h | Some t -> Seq (h, t)};
basic[infix]: basic[infix]:
@ -588,7 +624,7 @@ module Definition =
<(name, infix')> : head[infix] "(" args:!(Util.list0 arg) ")" <(name, infix')> : head[infix] "(" args:!(Util.list0 arg) ")"
locs:(%"local" !(Util.list arg))? locs:(%"local" !(Util.list arg))?
"{" body:!(Expr.parse infix') "}" { "{" 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 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' = 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 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 with Not_found -> Builtin.eval conf args f
end) end)
(State.empty, i, [], []) (State.empty, i, [], [])
@ -627,7 +663,7 @@ let eval (defs, body) i =
(* Top-level parser *) (* Top-level parser *)
ostap ( 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]: definitions[infix]:
<(def, infix')> : !(Definition.parse infix) <(defs, infix'')> : definitions[infix'] {def::defs, infix''} <(def, infix')> : !(Definition.parse infix) <(defs, infix'')> : definitions[infix'] {def::defs, infix''}
| empty {[], infix} | empty {[], infix}

25
src/SM.ml
View file

@ -20,7 +20,7 @@ open Language
(* begins procedure definition *) | BEGIN of string * string list * string list (* begins procedure definition *) | BEGIN of string * string list * string list
(* end procedure definition *) | END (* end procedure definition *) | END
(* calls a function/procedure *) | CALL of string * int (* 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 (* drops the top element off *) | DROP
(* duplicates the top element *) | DUP (* duplicates the top element *) | DUP
(* swaps two top elements *) | SWAP (* 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' eval env (cstack, (Value.sexp s @@ List.rev vs)::stack', c) prg'
| LD x -> eval env (cstack, State.eval st x :: 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' | 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' | 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, stack', (Expr.update st (Value.Elem (x, Value.to_int j)) v, 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' | LABEL _ -> eval env conf prg'
| JMP l -> eval env conf (env#labeled l) | 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') | 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 | BEGIN (_, args, locals) -> let vs, stack' = split (List.length args) stack in
let state = List.combine args @@ List.rev vs 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' 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' | (prg', st')::cstack' -> eval env (cstack', stack, (State.leave st st', i, o)) prg'
| [] -> conf | [] -> conf
) )
| DROP -> eval env (cstack, List.tl stack, c) prg' | DROP -> eval env (cstack, List.tl stack, c) prg'
| DUP -> eval env (cstack, List.hd stack :: stack, c) prg' | DUP -> eval env (cstack, List.hd stack :: stack, c) prg'
| SWAP -> let x::y::stack' = stack in | SWAP -> let x::y::stack' = stack in
@ -132,7 +138,7 @@ let run p i =
let args, stack' = split n stack in let args, stack' = split n stack in
let (st, i, o, r) = Language.Builtin.eval (st, i, o, []) (List.rev args) f in let (st, i, o, r) = Language.Builtin.eval (st, i, o, []) (List.rev args) f in
(*Printf.printf "Builtin:\n";*) (*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 end
) )
([], [], (State.empty, i, [])) ([], [], (State.empty, i, []))
@ -222,6 +228,11 @@ let compile (defs, p) =
let env, flag2, s2 = compile_list l env es in let env, flag2, s2 = compile_list l env es in
add_code (env, flag1, s1) les flag2 s2 add_code (env, flag1, s1) les flag2 s2
and compile_expr l env = function 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.ElemRef (x, i) -> compile_list l env [x; i]
| Expr.Var x -> env, false, [LD x] | Expr.Var x -> env, false, [LD x]
| Expr.Ref x -> env, false, [LDA 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)] 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 | 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] | Expr.Leave -> env, false, [LEAVE]

56
src/X86.ml
View file

@ -17,6 +17,7 @@ let word_size = 4;;
| S of int (* a position on the hardware stack *) | S of int (* a position on the hardware stack *)
| M of string (* a named memory location *) | M of string (* a named memory location *)
| L of int (* an immediate operand *) | L of int (* an immediate operand *)
| I of opnd (* an indirect operand *)
with show with show
let show_opnd = show(opnd) let show_opnd = show(opnd)
@ -34,6 +35,7 @@ let esp = R 7
(* Now x86 instruction (we do not need all of them): *) (* Now x86 instruction (we do not need all of them): *)
type instr = type instr =
(* copies a value from the first to the second operand *) | Mov of opnd * opnd (* 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 (* makes a binary operation; note, the first operand *) | Binop of string * opnd * opnd
(* designates x86 operator, not the source language one *) (* designates x86 operator, not the source language one *)
(* x86 integer division, see instruction set reference *) | IDiv of opnd (* 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: shl 1 *) | Sal1 of opnd
(* arithmetic correction: shr 1 *) | Sar1 of opnd (* arithmetic correction: shr 1 *) | Sar1 of opnd
| Repmovsl | Repmovsl
(* Instruction printer *) (* Instruction printer *)
let show instr = let show instr =
let binop = function let binop = function
@ -68,13 +69,14 @@ let show instr =
| "cmp" -> "cmpl" | "cmp" -> "cmpl"
| _ -> failwith "unknown binary operator" | _ -> failwith "unknown binary operator"
in in
let opnd = function let rec opnd = function
| R i -> regs.(i) | R i -> regs.(i)
| S i -> if i >= 0 | S i -> if i >= 0
then Printf.sprintf "-%d(%%ebp)" ((i+1) * word_size) then Printf.sprintf "-%d(%%ebp)" ((i+1) * word_size)
else Printf.sprintf "%d(%%ebp)" (8+(-i-1) * word_size) else Printf.sprintf "%d(%%ebp)" (8+(-i-1) * word_size)
| M x -> x | M x -> x
| L i -> Printf.sprintf "$%d" i | L i -> Printf.sprintf "$%d" i
| I x -> Printf.sprintf "(%s)" (opnd x)
in in
match instr with match instr with
| Cltd -> "\tcltd" | Cltd -> "\tcltd"
@ -82,6 +84,7 @@ let show instr =
| IDiv s1 -> Printf.sprintf "\tidivl\t%s" (opnd s1) | 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) | 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) | 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) | Push s -> Printf.sprintf "\tpushl\t%s" (opnd s)
| Pop s -> Printf.sprintf "\tpopl\t%s" (opnd s) | Pop s -> Printf.sprintf "\tpopl\t%s" (opnd s)
| Ret -> "\tret" | Ret -> "\tret"
@ -107,7 +110,7 @@ open SM
of x86 instructions of x86 instructions
*) *)
let compile env code = let compile env code =
(*SM.print_prg code;*) SM.print_prg code;
flush stdout; flush stdout;
let suffix = function let suffix = function
| "<" -> "l" | "<" -> "l"
@ -129,9 +132,6 @@ let compile env code =
List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers n) List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers n)
in in
let env, code = let env, code =
if n = 0
then env, pushr @ [Call f] @ (List.rev popr)
else
let rec push_args env acc = function let rec push_args env acc = function
| 0 -> env, acc | 0 -> env, acc
| n -> let x, env = env#pop in | n -> let x, env = env#pop in
@ -142,9 +142,7 @@ let compile env code =
match f with match f with
| "Barray" -> List.rev @@ (Push (L n)) :: pushs | "Barray" -> List.rev @@ (Push (L n)) :: pushs
| "Bsexp" -> List.rev @@ (Push (L n)) :: pushs | "Bsexp" -> List.rev @@ (Push (L n)) :: pushs
| "Bsta" -> | "Bsta" -> pushs
let x::v::is = List.rev pushs in
is @ [x; v] @ [Push (L (n-2))]
| _ -> List.rev pushs | _ -> List.rev pushs
in in
env, pushr @ pushs @ [Call f; Binop ("+", L (4 * List.length pushs), esp)] @ (List.rev popr) 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 let env, call = call env ".string" 1 false in
(env, Mov (M ("$" ^ s), l) :: call) (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 -> | LD x ->
let s, env' = (env#variable x)#allocate in let s, env' = (env#variable x)#allocate in
env', env',
@ -175,25 +181,16 @@ let compile env code =
| _ -> [Mov (env'#loc x, s)] | _ -> [Mov (env'#loc x, s)]
) )
(* TODO | STA ->
| STA (x, n) -> call env ".sta" 3 true
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
| ST x -> | ST ->
let s, env' = (env#variable x)#pop in let v, x, env' = env#pop2 in
env', env',
(match s with (match x with
| S _ | M _ -> [Mov (s, eax); Mov (eax, env'#loc x)] | S _ | M _ -> [Mov (v, edx); Mov (x, eax); Mov (edx, I eax)]
| _ -> [Mov (s, env'#loc x)] | _ -> [Mov (v, eax); Mov (eax, I x)]
) )
*)
| BINOP op -> | BINOP op ->
let x, y, env' = env#pop2 in 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) Meta (Printf.sprintf "\t.set\t%s,\t%d" env#allocated_size env#allocated)
] ]
| RET b -> | RET ->
if b let x, env = env#pop in
then let x, env = env#pop in env, [Mov (x, eax); Jmp env#epilogue] env, [Mov (x, eax); Jmp env#epilogue]
else env, [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) -> | SEXP (t, n) ->
let s, env = env#allocate in let s, env = env#allocate in