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

Tail-call optimization

Browse source
This commit is contained in:
Dmitry Boulytchev 2020-03-23 00:49:20 +03:00
parent eeab48ed33
commit b1d851ff40
4 changed files with 137 additions and 94 deletions
Download patch file Download diff file Expand all files Collapse all files

2
regression/Makefile
View file

@ -9,7 +9,7 @@ check: $(TESTS)
$(TESTS): %: %.lama $(TESTS): %: %.lama
@echo $@ @echo $@
cat $@.input | LAMA=../runtime $(LAMAC) -i $< > $@.log && diff $@.log orig/$@.log cat $@.input | LAMA=../runtime $(LAMAC) -i $< > $@.log && diff $@.log orig/$@.log
cat $@.input | LAMA=../runtime $(LAMAC) -s $< > $@.log && diff $@.log orig/$@.log cat $@.input | LAMA=../runtime $(LAMAC) -ds -s $< > $@.log && diff $@.log orig/$@.log
LAMA=../runtime $(LAMAC) $< && cat $@.input | ./$@ > $@.log && diff $@.log orig/$@.log LAMA=../runtime $(LAMAC) $< && cat $@.input | ./$@ > $@.log && diff $@.log orig/$@.log
clean: clean:

84
src/SM.ml
View file

@ -23,9 +23,9 @@ open Language
(* create a closure *) | CLOSURE of string * Value.designation list (* create a closure *) | CLOSURE of string * Value.designation list
(* proto closure *) | PROTO of string * string (* proto closure *) | PROTO of string * string
(* proto closure to a possible constant *) | PPROTO of string * string (* proto closure to a possible constant *) | PPROTO of string * string
(* proto call *) | PCALLC of int (* proto call *) | PCALLC of int * bool
(* calls a closure *) | CALLC of int (* calls a closure *) | CALLC of int * bool
(* calls a function/procedure *) | CALL of string * int (* calls a function/procedure *) | CALL of string * int * bool
(* returns from a function *) | RET (* 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
@ -154,12 +154,12 @@ let rec eval env (((cstack, stack, glob, loc, i, o) as conf) : config) = functio
in in
eval env (cstack, (Value.Closure ([], name, closure)) :: stack, glob, loc, i, o) prg' eval env (cstack, (Value.Closure ([], name, closure)) :: stack, glob, loc, i, o) prg'
| CALL (f, n) -> let args, stack' = split n stack in | CALL (f, n, _) -> let args, stack' = split n stack in
if env#is_label f if env#is_label f
then eval env ((prg', loc)::cstack, stack', glob, {args = Array.of_list (List.rev args); locals = [||]; closure = [||]}, i, o) (env#labeled f) then eval env ((prg', loc)::cstack, stack', glob, {args = Array.of_list (List.rev args); locals = [||]; closure = [||]}, i, o) (env#labeled f)
else eval env (env#builtin f args ((cstack, stack', glob, loc, i, o) : config)) prg' else eval env (env#builtin f args ((cstack, stack', glob, loc, i, o) : config)) prg'
| CALLC n -> let vs, stack' = split (n+1) stack in | CALLC (n, _) -> let vs, stack' = split (n+1) stack in
let f::args = List.rev vs in let f::args = List.rev vs in
(match f with (match f with
| Value.Builtin f -> | Value.Builtin f ->
@ -662,7 +662,7 @@ let compile cmd ((imports, infixes), p) =
List.fold_left List.fold_left
(fun (i, env, code) p -> (fun (i, env, code) p ->
let env, _, pcode = pattern env ldrop p in let env, _, pcode = pattern env ldrop p in
i+1, env, ([DUP; CONST i; CALL (".elem", 2)] @ pcode) :: code i+1, env, ([DUP; CONST i; CALL (".elem", 2, false)] @ pcode) :: code
) )
(0, env, []) (0, env, [])
ps ps
@ -696,7 +696,7 @@ let compile cmd ((imports, infixes), p) =
let env, dsg = env#lookup name in let env, dsg = env#lookup name in
env, env,
([DUP] @ ([DUP] @
List.concat (List.map (fun i -> [CONST i; CALL (".elem", 2)]) path) @ List.concat (List.map (fun i -> [CONST i; CALL (".elem", 2, false)]) path) @
[ST dsg; DROP]) :: acc [ST dsg; DROP]) :: acc
) )
(env, []) (env, [])
@ -704,15 +704,15 @@ let compile cmd ((imports, infixes), p) =
in in
env, (List.flatten code) @ [DROP] env, (List.flatten code) @ [DROP]
and add_code (env, flag, s) l f s' = env, f, s @ (if flag then [LABEL l] else []) @ s' and add_code (env, flag, s) l f s' = env, f, s @ (if flag then [LABEL l] else []) @ s'
and compile_list l env = function and compile_list tail l env = function
| [] -> env, false, [] | [] -> env, false, []
| [e] -> compile_expr l env e | [e] -> compile_expr tail l env e
| e::es -> | e::es ->
let les, env = env#get_label in let les, env = env#get_label in
let env, flag1, s1 = compile_expr les env e in let env, flag1, s1 = compile_expr false les env e in
let env, flag2, s2 = compile_list l env es in let env, flag2, s2 = compile_list tail 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 tail l env = function
| Expr.Lambda (args, b) -> | Expr.Lambda (args, b) ->
let env, name = env#add_lambda args b in let env, name = env#add_lambda args b in
env#register_call name, false, [PROTO (name, env#current_function)] env#register_call name, false, [PROTO (name, env#current_function)]
@ -731,21 +731,21 @@ let compile cmd ((imports, infixes), p) =
(List.rev ds) (List.rev ds)
in in
let env = List.fold_left (fun env (name, args, m, b) -> env#add_fun name args m b) env funs in let env = List.fold_left (fun env (name, args, m, b) -> env#add_fun name args m b) env funs in
let env, flag, code = compile_expr l env e in let env, flag, code = compile_expr tail l env e in
env#pop_scope, flag, code env#pop_scope, flag, code
| Expr.Unit -> env, false, [CONST 0] | Expr.Unit -> env, false, [CONST 0]
| Expr.Ignore s -> let ls, env = env#get_label in | Expr.Ignore s -> let ls, env = env#get_label in
add_code (compile_expr ls env s) ls false [DROP] add_code (compile_expr tail ls env s) ls false [DROP]
| Expr.ElemRef (x, i) -> compile_list l env [x; i] | Expr.ElemRef (x, i) -> compile_list tail l env [x; i]
| Expr.Var x -> let env, acc = env#lookup x in (match acc with Value.Fun name -> env#register_call name, false, [PROTO (name, env#current_function)] | _ -> env, false, [LD acc]) | Expr.Var x -> let env, acc = env#lookup x in (match acc with Value.Fun name -> env#register_call name, false, [PROTO (name, env#current_function)] | _ -> env, false, [LD acc])
| Expr.Ref x -> let env, acc = env#lookup x in env, false, [LDA acc] | Expr.Ref x -> let env, acc = env#lookup x in env, false, [LDA acc]
| Expr.Const n -> env, false, [CONST n] | Expr.Const n -> env, false, [CONST n]
| Expr.String s -> env, false, [STRING s] | Expr.String s -> env, false, [STRING s]
| Expr.Binop (op, x, y) -> let lop, env = env#get_label in | Expr.Binop (op, x, y) -> let lop, env = env#get_label in
add_code (compile_list lop env [x; y]) lop false [BINOP op] add_code (compile_list false lop env [x; y]) lop false [BINOP op]
| Expr.Call (f, args) -> let lcall, env = env#get_label in | Expr.Call (f, args) -> let lcall, env = env#get_label in
(match f with (match f with
@ -754,60 +754,60 @@ let compile cmd ((imports, infixes), p) =
(match acc with (match acc with
| Value.Fun name -> | Value.Fun name ->
let env = env#register_call name in let env = env#register_call name in
let env, f, code = add_code (compile_list lcall env args) lcall false [PCALLC (List.length args)] in let env, f, code = add_code (compile_list false lcall env args) lcall false [PCALLC (List.length args, tail)] in
env, f, PPROTO (name, env#current_function) :: code env, f, PPROTO (name, env#current_function) :: code
| _ -> | _ ->
add_code (compile_list lcall env (f :: args)) lcall false [CALLC (List.length args)] add_code (compile_list false lcall env (f :: args)) lcall false [CALLC (List.length args, tail)]
) )
| _ -> add_code (compile_list lcall env (f :: args)) lcall false [CALLC (List.length args)] | _ -> add_code (compile_list false lcall env (f :: args)) lcall false [CALLC (List.length args, tail)]
) )
| Expr.Array xs -> let lar, env = env#get_label in | Expr.Array xs -> let lar, env = env#get_label in
add_code (compile_list lar env xs) lar false [CALL (".array", List.length xs)] add_code (compile_list false lar env xs) lar false [CALL (".array", List.length xs, tail)]
| Expr.Sexp (t, xs) -> let lsexp, env = env#get_label in | Expr.Sexp (t, xs) -> let lsexp, env = env#get_label in
add_code (compile_list lsexp env xs) lsexp false [SEXP (t, List.length xs)] add_code (compile_list false lsexp env xs) lsexp false [SEXP (t, List.length xs)]
| Expr.Elem (a, i) -> let lelem, env = env#get_label in | Expr.Elem (a, i) -> let lelem, env = env#get_label in
add_code (compile_list lelem env [a; i]) lelem false [CALL (".elem", 2)] add_code (compile_list false lelem env [a; i]) lelem false [CALL (".elem", 2, tail)]
| Expr.Length e -> let llen, env = env#get_label in | Expr.Length e -> let llen, env = env#get_label in
add_code (compile_expr llen env e) llen false [CALL (".length", 1)] add_code (compile_expr false llen env e) llen false [CALL (".length", 1, tail)]
| Expr.StringVal e -> let lsv, env = env#get_label in | Expr.StringVal e -> let lsv, env = env#get_label in
add_code (compile_expr lsv env e) lsv false [CALL (".stringval", 1)] add_code (compile_expr false lsv env e) lsv false [CALL (".stringval", 1, tail)]
| Expr.Assign (x, e) -> let lassn, env = env#get_label in | Expr.Assign (x, e) -> let lassn, env = env#get_label in
add_code (compile_list lassn env [x; e]) lassn false [match x with Expr.ElemRef _ -> STA | _ -> STI] add_code (compile_list false lassn env [x; e]) lassn false [match x with Expr.ElemRef _ -> STA | _ -> STI]
| Expr.Skip -> env, false, [] | Expr.Skip -> env, false, []
| Expr.Seq (s1, s2) -> compile_list l env [s1; s2] | Expr.Seq (s1, s2) -> compile_list tail l env [s1; s2]
| Expr.If (c, s1, s2) -> let le, env = env#get_label in | Expr.If (c, s1, s2) -> let le, env = env#get_label in
let l2, env = env#get_label in let l2, env = env#get_label in
let env, fe , se = compile_expr le env c in let env, fe , se = compile_expr false le env c in
let env, flag1, s1 = compile_expr l env s1 in let env, flag1, s1 = compile_expr tail l env s1 in
let env, flag2, s2 = compile_expr l env s2 in let env, flag2, s2 = compile_expr tail l env s2 in
env, true, se @ (if fe then [LABEL le] else []) @ [CJMP ("z", l2)] @ s1 @ (if flag1 then [] else [JMP l]) @ [LABEL l2] @ s2 @ (if flag2 then [] else [JMP l]) env, true, se @ (if fe then [LABEL le] else []) @ [CJMP ("z", l2)] @ s1 @ (if flag1 then [] else [JMP l]) @ [LABEL l2] @ s2 @ (if flag2 then [] else [JMP l])
| Expr.While (c, s) -> let lexp, env = env#get_label in | Expr.While (c, s) -> let lexp, env = env#get_label in
let loop, env = env#get_label in let loop, env = env#get_label in
let cond, env = env#get_label in let cond, env = env#get_label in
let env, fe, se = compile_expr lexp env c in let env, fe, se = compile_expr false lexp env c in
let env, _ , s = compile_expr cond env s in let env, _ , s = compile_expr false cond env s in
env, false, [JMP cond; LABEL loop] @ s @ [LABEL cond] @ se @ (if fe then [LABEL lexp] else []) @ [CJMP ("nz", loop)] env, false, [JMP cond; LABEL loop] @ s @ [LABEL cond] @ se @ (if fe then [LABEL lexp] else []) @ [CJMP ("nz", loop)]
| Expr.Repeat (s, c) -> let lexp , env = env#get_label in | Expr.Repeat (s, c) -> let lexp , env = env#get_label in
let loop , env = env#get_label in let loop , env = env#get_label in
let check, env = env#get_label in let check, env = env#get_label in
let env, fe , se = compile_expr lexp env c in let env, fe , se = compile_expr false lexp env c in
let env, flag, body = compile_expr check env s in let env, flag, body = compile_expr false check env s in
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] add_code (compile_expr true lret env e) lret false [RET]
| Expr.Return None -> env, false, [CONST 0; RET] | Expr.Return None -> env, false, [CONST 0; RET]
@ -817,7 +817,7 @@ let compile cmd ((imports, infixes), p) =
let n = List.length brs - 1 in let n = List.length brs - 1 in
let lfail, env = env#get_label in let lfail, env = env#get_label in
let lexp , env = env#get_label in let lexp , env = env#get_label in
let env , fe , se = compile_expr lexp env e in let env , fe , se = compile_expr false lexp env e in
let env , _, _, code, fail = let env , _, _, code, fail =
List.fold_left List.fold_left
(fun ((env, lab, i, code, continue) as acc) (p, s) -> (fun ((env, lab, i, code, continue) as acc) (p, s) ->
@ -831,7 +831,7 @@ let compile cmd ((imports, infixes), p) =
let env, lfalse', pcode = pattern env lfalse p in let env, lfalse', pcode = pattern env lfalse p in
let env = env#push_scope in let env = env#push_scope in
let env, bindcode = bindings env p in let env, bindcode = bindings env p in
let env, l' , scode = compile_expr l env s in let env, l' , scode = compile_expr tail l env s in
let env = env#pop_scope in let env = env#pop_scope in
(env, Some lfalse, i+1, ((match lab with None -> [] | Some l -> [LABEL l; DUP]) @ pcode @ bindcode @ scode @ jmp) :: code, lfalse') (env, Some lfalse, i+1, ((match lab with None -> [] | Some l -> [LABEL l; DUP]) @ pcode @ bindcode @ scode @ jmp) :: code, lfalse')
else acc else acc
@ -847,7 +847,7 @@ let compile cmd ((imports, infixes), p) =
(*Printf.eprintf "Lookup: %s\n%!" (try show(Value.designation) @@ snd (env#lookup "inner") with _ -> "no inner..."); *) (*Printf.eprintf "Lookup: %s\n%!" (try show(Value.designation) @@ snd (env#lookup "inner") with _ -> "no inner..."); *)
let env = List.fold_left (fun env arg -> env#add_arg arg) env args in let env = List.fold_left (fun env arg -> env#add_arg arg) env args in
let lend, env = env#get_label in let lend, env = env#get_label in
let env, flag, code = compile_expr lend env stmt in let env, flag, code = compile_expr true lend env stmt in
let env, funcode = compile_fundefs [] env in let env, funcode = compile_fundefs [] env in
(*Printf.eprintf "Function: %s, closure: %s\n%!" name (show(list) (show(Value.designation)) env#closure);*) (*Printf.eprintf "Function: %s, closure: %s\n%!" name (show(list) (show(Value.designation)) env#closure);*)
let env = env#register_closure name in let env = env#register_closure name in
@ -875,10 +875,10 @@ let compile cmd ((imports, infixes), p) =
| [] -> inner (Some f :: state) tl | [] -> inner (Some f :: state) tl
| closure -> CLOSURE (f, closure) :: inner (None :: state) tl | closure -> CLOSURE (f, closure) :: inner (None :: state) tl
) )
| PCALLC n :: tl -> | PCALLC (n, tail) :: tl ->
(match state with (match state with
| None :: state' -> CALLC n :: inner state' tl | None :: state' -> CALLC (n, tail) :: inner state' tl
| Some f :: state' -> CALL (f, n) :: inner state' tl | Some f :: state' -> CALL (f, n, tail) :: inner state' tl
) )
| insn :: tl -> insn :: inner state tl | insn :: tl -> insn :: inner state tl
in in
@ -886,10 +886,10 @@ let compile cmd ((imports, infixes), p) =
in in
let env = new env cmd imports in let env = new env cmd imports in
let lend, env = env#get_label in let lend, env = env#get_label in
let env, flag, code = compile_expr lend env p in let env, flag, code = compile_expr false lend env p in
let code = if flag then code @ [LABEL lend] else code in let code = if flag then code @ [LABEL lend] else code in
let topname = cmd#topname in let topname = cmd#topname in
let env, prg = compile_fundefs [[LABEL topname; BEGIN (topname, 0, env#nlocals, [])] @ code @ [END]] env in let env, prg = compile_fundefs [[LABEL topname; BEGIN (topname, (if topname = "main" then 2 else 0), env#nlocals, [])] @ code @ [END]] env in
let prg = [PUBLIC topname] @ env#get_decls @ List.flatten prg in let prg = [PUBLIC topname] @ env#get_decls @ List.flatten prg in
(*Printf.eprintf "Before propagating closures:\n"; (*Printf.eprintf "Before propagating closures:\n";
Printf.eprintf "%s\n%!" env#show_funinfo; Printf.eprintf "%s\n%!" env#show_funinfo;

143
src/X86.ml
View file

@ -133,54 +133,92 @@ let compile cmd env imports code =
let rec compile' env scode = let rec compile' env scode =
let on_stack = function S _ -> true | _ -> false in let on_stack = function S _ -> true | _ -> false in
let mov x s = if on_stack x && on_stack s then [Mov (x, eax); Mov (eax, s)] else [Mov (x, s)] in let mov x s = if on_stack x && on_stack s then [Mov (x, eax); Mov (eax, s)] else [Mov (x, s)] in
let callc env n = let callc env n tail =
let pushr, popr = let tail = tail && env#nargs = n in
List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers n) if tail
in then (
let pushr, popr = env#save_closure @ pushr, env#rest_closure @ popr in
let env, code =
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
push_args env ((Push x)::acc) (n-1) if x = env#loc (Value.Arg (n-1))
then push_args env acc (n-1)
else push_args env ((mov x (env#loc (Value.Arg (n-1)))) @ acc) (n-1)
in in
let env, pushs = push_args env [] n in let env , pushs = push_args env [] n in
let pushs = List.rev pushs in let closure, env = env#pop in
let closure, env = env#pop in let y , env = env#allocate in
let call_closure = env, pushs @ [Mov (closure, edx);
if on_stack closure Mov (I(0, edx), eax);
then [Mov (closure, edx); Mov (edx, eax); CallI eax] Mov (ebp, esp);
else [Mov (closure, edx); CallI closure] Pop (ebp)] @
(if env#has_closure then [Pop ebx] else []) @
[Jmp "*%eax"] (* UGLY!!! *)
)
else (
let pushr, popr =
List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers n)
in in
env, pushr @ pushs @ call_closure @ [Binop ("+", L (word_size * List.length pushs), esp)] @ (List.rev popr) let pushr, popr = env#save_closure @ pushr, env#rest_closure @ popr in
in let env, code =
let y, env = env#allocate in env, code @ [Mov (eax, y)] let rec push_args env acc = function
in
let call env f n =
let f =
match f.[0] with '.' -> "B" ^ String.sub f 1 (String.length f - 1) | _ -> f
in
let pushr, popr =
List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers n)
in
let pushr, popr = env#save_closure @ pushr, env#rest_closure @ popr in
let env, code =
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
push_args env ((Push x)::acc) (n-1) push_args env ((Push x)::acc) (n-1)
in
let env, pushs = push_args env [] n in
let pushs = List.rev pushs in
let closure, env = env#pop in
let call_closure =
if on_stack closure
then [Mov (closure, edx); Mov (edx, eax); CallI eax]
else [Mov (closure, edx); CallI closure]
in
env, pushr @ pushs @ call_closure @ [Binop ("+", L (word_size * List.length pushs), esp)] @ (List.rev popr)
in
let y, env = env#allocate in env, code @ [Mov (eax, y)]
)
in
let call env f n tail =
let tail = tail && env#nargs = n && f.[0] <> '.' in
let f =
match f.[0] with '.' -> "B" ^ String.sub f 1 (String.length f - 1) | _ -> f
in
if tail
then (
let rec push_args env acc = function
| 0 -> env, acc
| n -> let x, env = env#pop in
if x = env#loc (Value.Arg (n-1))
then push_args env acc (n-1)
else push_args env ((mov x (env#loc (Value.Arg (n-1)))) @ acc) (n-1)
in in
let env, pushs = push_args env [] n in let env, pushs = push_args env [] n in
let pushs = let y, env = env#allocate in
match f with env, pushs @ [Mov (ebp, esp); Pop (ebp); Jmp f]
| "Barray" -> List.rev @@ (Push (L (box n))) :: pushs )
| "Bsexp" -> List.rev @@ (Push (L (box n))) :: pushs else (
| "Bsta" -> pushs let pushr, popr =
| _ -> List.rev pushs List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers n)
in in
env, pushr @ pushs @ [Call f; Binop ("+", L (word_size * List.length pushs), esp)] @ (List.rev popr) let pushr, popr = env#save_closure @ pushr, env#rest_closure @ popr in
in let env, code =
let y, env = env#allocate in env, code @ [Mov (eax, y)] let rec push_args env acc = function
| 0 -> env, acc
| n -> let x, env = env#pop in
push_args env ((Push x)::acc) (n-1)
in
let env, pushs = push_args env [] n in
let pushs =
match f with
| "Barray" -> List.rev @@ (Push (L (box n))) :: pushs
| "Bsexp" -> List.rev @@ (Push (L (box n))) :: pushs
| "Bsta" -> pushs
| _ -> List.rev pushs
in
env, pushr @ pushs @ [Call f; Binop ("+", L (word_size * List.length pushs), esp)] @ (List.rev popr)
in
let y, env = env#allocate in env, code @ [Mov (eax, y)]
)
in in
match scode with match scode with
| [] -> env, [] | [] -> env, []
@ -217,7 +255,7 @@ let compile cmd env imports code =
| STRING s -> | STRING s ->
let s, env = env#string s in let s, env = env#string s in
let l, env = env#allocate in let l, env = env#allocate in
let env, call = call env ".string" 1 in let env, call = call env ".string" 1 false in
(env, Mov (M ("$" ^ s), l) :: call) (env, Mov (M ("$" ^ s), l) :: call)
| LDA x -> | LDA x ->
@ -246,7 +284,7 @@ let compile cmd env imports code =
) )
| STA -> | STA ->
call env ".sta" 3 call env ".sta" 3 false
| STI -> | STI ->
let v, x, env' = env#pop2 in let v, x, env' = env#pop2 in
@ -356,7 +394,7 @@ let compile cmd env imports code =
| BEGIN (f, nargs, nlocals, closure) -> | BEGIN (f, nargs, nlocals, closure) ->
env#assert_empty_stack; env#assert_empty_stack;
let has_closure = closure <> [] in let has_closure = closure <> [] in
let env = env#enter f nlocals has_closure in let env = env#enter f nargs nlocals has_closure in
env, (if has_closure then [Push edx] else []) @ env, (if has_closure then [Push edx] else []) @
(if f = cmd#topname (if f = cmd#topname
then then
@ -407,13 +445,13 @@ let compile cmd env imports code =
let x = env#peek in let x = env#peek in
env, [Mov (x, eax); Jmp env#epilogue] env, [Mov (x, eax); Jmp env#epilogue]
| CALL (f, n) -> call env f n | CALL (f, n, tail) -> call env f n tail
| CALLC n -> callc env n | CALLC (n, tail) -> callc env n tail
| SEXP (t, n) -> | SEXP (t, n) ->
let s, env = env#allocate in let s, env = env#allocate in
let env, code = call env ".sexp" (n+1) in let env, code = call env ".sexp" (n+1) false in
env, [Mov (L env#hash t, s)] @ code env, [Mov (L env#hash t, s)] @ code
| DROP -> | DROP ->
@ -431,15 +469,15 @@ let compile cmd env imports code =
| TAG (t, n) -> | TAG (t, n) ->
let s1, env = env#allocate in let s1, env = env#allocate in
let s2, env = env#allocate in let s2, env = env#allocate in
let env, code = call env ".tag" 3 in let env, code = call env ".tag" 3 false in
env, [Mov (L (box (env#hash t)), s1); Mov (L (box n), s2)] @ code env, [Mov (L (box (env#hash t)), s1); Mov (L (box n), s2)] @ code
| ARRAY n -> | ARRAY n ->
let s, env = env#allocate in let s, env = env#allocate in
let env, code = call env ".array_patt" 2 in let env, code = call env ".array_patt" 2 false in
env, [Mov (L (box n), s)] @ code env, [Mov (L (box n), s)] @ code
| PATT StrCmp -> call env ".string_patt" 2 | PATT StrCmp -> call env ".string_patt" 2 false
| PATT patt -> | PATT patt ->
call env call env
@ -450,7 +488,7 @@ let compile cmd env imports code =
| String -> ".string_tag_patt" | String -> ".string_tag_patt"
| Sexp -> ".sexp_tag_patt" | Sexp -> ".sexp_tag_patt"
| Closure -> ".closure_tag_patt" | Closure -> ".closure_tag_patt"
) 1 ) 1 false
| FAIL ((line, col), value) -> | FAIL ((line, col), value) ->
let v, env = if value then env#peek, env else env#pop in let v, env = if value then env#peek, env else env#pop in
@ -482,9 +520,11 @@ class env prg =
val stringm = M.empty (* a string map *) val stringm = M.empty (* a string map *)
val scount = 0 (* string count *) val scount = 0 (* string count *)
val stack_slots = 0 (* maximal number of stack positions *) val stack_slots = 0 (* maximal number of stack positions *)
val static_size = 0 (* static data size *) val static_size = 0 (* static data size *)
val stack = [] (* symbolic stack *) val stack = [] (* symbolic stack *)
val args = [] (* function arguments *) val nargs = 0 (* number of function arguments *)
(* val args = [] (* function arguments *) *)
val locals = [] (* function local variables *) val locals = [] (* function local variables *)
val fname = "" (* function name *) val fname = "" (* function name *)
val stackmap = M.empty (* labels to stack map *) val stackmap = M.empty (* labels to stack map *)
@ -629,6 +669,9 @@ class env prg =
let m = M.add x y stringm in let m = M.add x y stringm in
y, {< scount = scount + 1; stringm = m>} y, {< scount = scount + 1; stringm = m>}
(* gets number of arguments in the current function *)
method nargs = nargs
(* gets all global variables *) (* gets all global variables *)
method globals = S.elements (S.diff globals externs) method globals = S.elements (S.diff globals externs)
@ -641,8 +684,8 @@ class env prg =
method allocated_size = Printf.sprintf "LS%s_SIZE" fname method allocated_size = Printf.sprintf "LS%s_SIZE" fname
(* enters a function *) (* enters a function *)
method enter f nlocals has_closure = method enter f nargs nlocals has_closure =
{< static_size = nlocals; stack_slots = nlocals; stack = []; fname = f; has_closure = has_closure >} {< nargs = nargs; static_size = nlocals; stack_slots = nlocals; stack = []; fname = f; has_closure = has_closure >}
(* returns a label for the epilogue *) (* returns a label for the epilogue *)
method epilogue = Printf.sprintf "L%s_epilogue" fname method epilogue = Printf.sprintf "L%s_epilogue" fname

2
src/version.ml
View file

@ -1 +1 @@
let version = "Version 1.00, e4b34a3ec, Sat Mar 21 13:05:14 2020 +0300" let version = "Version 1.00, eeab48ed3, Sun Mar 22 21:58:11 2020 +0300"