mirror of
https://github.com/ProgramSnail/Lama.git
synced 2025-12-06 06:48:48 +00:00
Added static call
This commit is contained in:
Dmitry Boulytchev
parent
2bfebc93f8
commit
e529ba1472
8 changed files with 134 additions and 70 deletions
|
|
@ -10,7 +10,7 @@ $(TESTS): %: %.expr
|
|||
@echo $@
|
||||
# @$(RC) $< && cat $@.input | ./$@ > $@.log && diff $@.log orig/$@.log
|
||||
cat $@.input | $(RC) -i $< > $@.log && diff $@.log orig/$@.log
|
||||
cat $@.input | $(RC) -s $< 2> /dev/null > $@.log && diff $@.log orig/$@.log
|
||||
cat $@.input | $(RC) -s $< > $@.log && diff $@.log orig/$@.log
|
||||
|
||||
clean:
|
||||
$(RM) test*.log *.s *~ $(TESTS)
|
||||
|
|
|
|||
1
regression/orig/test067.log
Normal file
1
regression/orig/test067.log
Normal file
|
|
@ -0,0 +1 @@
|
|||
> 12
|
||||
5
regression/test067.expr
Normal file
5
regression/test067.expr
Normal file
|
|
@ -0,0 +1,5 @@
|
|||
infixr "**" before "*" (f, g) {
|
||||
return fun (x) {return f (g (x))}
|
||||
}
|
||||
|
||||
write ((fun (x) {return x+2} ** fun (x) {return x+3})(7))
|
||||
1
regression/test067.input
Normal file
1
regression/test067.input
Normal file
|
|
@ -0,0 +1 @@
|
|||
5
|
||||
|
|
@ -43,7 +43,7 @@ let main =
|
|||
if to_compile
|
||||
then (
|
||||
let basename = Filename.chop_suffix infile ".expr" in
|
||||
(* ignore @@ X86.build prog basename *) (* TODO! *) ()
|
||||
ignore @@ X86.build prog basename
|
||||
)
|
||||
else (
|
||||
(* Printf.printf "Program:\n%s\n" (GT.show(Language.Expr.t) prog);*)
|
||||
|
|
|
|||
|
|
@ -102,7 +102,7 @@ module Value =
|
|||
module Builtin =
|
||||
struct
|
||||
|
||||
let list = ["read"; "write"; ".elem"; ".length"; ".array"; ".stringval"]
|
||||
let list = ["read"; "write"; ".elem"; ".length"; ".array"; ".stringval"; "__gc_init"; "raw"]
|
||||
let bindings () = List.map (fun name -> name, Value.Builtin name) list
|
||||
let names = List.map (fun name -> name, false) list
|
||||
|
||||
|
|
@ -120,6 +120,8 @@ module Builtin =
|
|||
| ".length" -> (st, i, o, (Value.of_int (match List.hd args with Value.Sexp (_, a) | Value.Array a -> Array.length a | Value.String s -> Bytes.length s))::vs)
|
||||
| ".array" -> (st, i, o, (Value.of_array @@ Array.of_list args)::vs)
|
||||
| ".stringval" -> let [a] = args in (st, i, o, (Value.of_string @@ Value.string_val a)::vs)
|
||||
| "_gc_init" -> (st, i, o, vs)
|
||||
| "raw" -> let [a] = args in (st, i, o, a :: vs)
|
||||
|
||||
end
|
||||
|
||||
|
|
|
|||
54
src/SM.ml
54
src/SM.ml
|
|
@ -21,7 +21,8 @@ open Language
|
|||
(* begins procedure definition *) | BEGIN of string * int * int * Value.designation list
|
||||
(* end procedure definition *) | END
|
||||
(* create a closure *) | CLOSURE of string
|
||||
(* calls a function/procedure *) | CALL of int
|
||||
(* calls a closure *) | CALLC of int
|
||||
(* calls a function/procedure *) | CALL of string * int
|
||||
(* returns from a function *) | RET
|
||||
(* drops the top element off *) | DROP
|
||||
(* duplicates the top element *) | DUP
|
||||
|
|
@ -126,7 +127,28 @@ let rec eval env (((cstack, stack, glob, loc, i, o) as conf) : config) = functio
|
|||
in
|
||||
eval env (cstack, (Value.Closure ([], name, closure)) :: stack, glob, loc, i, o) prg'
|
||||
|
||||
| CALL n -> let vs, stack' = split (n+1) stack in
|
||||
| CALL (f, n) -> let args, stack' = split n stack in
|
||||
if env#is_label f
|
||||
then (
|
||||
let BEGIN (_, _, _, dgs) :: _ = env#labeled f in
|
||||
match dgs with
|
||||
| [] -> eval env ((prg', loc)::cstack, stack', glob, {args = Array.of_list (List.rev args); locals = [||]; closure = [||]}, i, o) (env#labeled f)
|
||||
| _ ->
|
||||
let closure =
|
||||
Array.of_list @@
|
||||
List.map (
|
||||
function
|
||||
| Value.Arg i -> loc.args.(i)
|
||||
| Value.Local i -> loc.locals.(i)
|
||||
| Value.Access i -> loc.closure.(i)
|
||||
| _ -> invalid_arg "wrong value in CLOSURE")
|
||||
dgs
|
||||
in
|
||||
eval env ((prg', loc)::cstack, stack', glob, {args = Array.of_list (List.rev args); locals = [||]; closure = closure}, i, o) (env#labeled f)
|
||||
)
|
||||
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
|
||||
let f::args = List.rev vs in
|
||||
(match f with
|
||||
| Value.Builtin f ->
|
||||
|
|
@ -313,7 +335,7 @@ object (self : 'self)
|
|||
| State.I ->
|
||||
State.G (Builtin.names,
|
||||
List.fold_left
|
||||
(fun s (name, value) -> State.bind name (Value.Global name) s)
|
||||
(fun s (name, value) -> State.bind name (Value.Fun name) s)
|
||||
State.undefined
|
||||
(Builtin.bindings ()))
|
||||
| _ ->
|
||||
|
|
@ -420,7 +442,6 @@ object (self : 'self)
|
|||
| Value.Access n when n = ~-1 ->
|
||||
let index = scope.acc_index in
|
||||
let fundefs', loc = propagate_acc fundefs name in
|
||||
(* let enclosing_loc = (*State.eval enclosing_st name*) in *)
|
||||
{<
|
||||
fundefs = fundefs';
|
||||
scope = {
|
||||
|
|
@ -470,7 +491,7 @@ let compile p =
|
|||
List.fold_left
|
||||
(fun (i, env, code) p ->
|
||||
let env, _, pcode = pattern env ldrop p in
|
||||
i+1, env, ([DUP; LD (Value.Global ".elem"); SWAP; CONST i; CALL 2] @ pcode) :: code
|
||||
i+1, env, ([DUP; CONST i; CALL (".elem", 2)] @ pcode) :: code
|
||||
)
|
||||
(0, env, [])
|
||||
ps
|
||||
|
|
@ -504,7 +525,7 @@ let compile p =
|
|||
let env, dsg = env#lookup name in
|
||||
env,
|
||||
([DUP] @
|
||||
List.concat (List.map (fun i -> [LD (Value.Global ".elem"); SWAP; CONST i; CALL 2]) path) @
|
||||
List.concat (List.map (fun i -> [CONST i; CALL (".elem", 2)]) path) @
|
||||
[ST dsg; DROP]) :: acc
|
||||
)
|
||||
(env, [])
|
||||
|
|
@ -556,22 +577,33 @@ let compile p =
|
|||
add_code (compile_list lop env [x; y]) lop false [BINOP op]
|
||||
|
||||
| Expr.Call (f, args) -> let lcall, env = env#get_label in
|
||||
add_code (compile_list lcall env (f :: args)) lcall false [CALL (List.length args)]
|
||||
(match f with
|
||||
| Expr.Var name ->
|
||||
let env, acc = env#lookup name in
|
||||
(match acc with
|
||||
| Value.Fun name ->
|
||||
add_code (compile_list lcall env args) lcall false [CALL (name, List.length args)]
|
||||
| _ ->
|
||||
add_code (compile_list lcall env (f :: args)) lcall false [CALLC (List.length args)]
|
||||
)
|
||||
|
||||
| _ -> add_code (compile_list lcall env (f :: args)) lcall false [CALLC (List.length args)]
|
||||
)
|
||||
|
||||
| Expr.Array xs -> let lar, env = env#get_label in
|
||||
add_code (compile_list lar env ((Expr.Var ".array") :: xs)) lar false [CALL (List.length xs)]
|
||||
add_code (compile_list lar env xs) lar false [CALL (".array", List.length xs)]
|
||||
|
||||
| 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)]
|
||||
|
||||
| Expr.Elem (a, i) -> let lelem, env = env#get_label in
|
||||
add_code (compile_list lelem env [Expr.Var ".elem"; a; i]) lelem false [CALL 2]
|
||||
add_code (compile_list lelem env [a; i]) lelem false [CALL (".elem", 2)]
|
||||
|
||||
| Expr.Length e -> let llen, env = env#get_label in
|
||||
add_code (compile_list llen env [Expr.Var ".length"; e]) llen false [CALL 1]
|
||||
add_code (compile_expr llen env e) llen false [CALL (".length", 1)]
|
||||
|
||||
| Expr.StringVal e -> let lsv, env = env#get_label in
|
||||
add_code (compile_list lsv env [Expr.Var ".stringval"; e]) lsv false [CALL 1]
|
||||
add_code (compile_expr lsv env e) lsv false [CALL (".stringval", 1)]
|
||||
|
||||
| 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]
|
||||
|
|
|
|||
107
src/X86.ml
107
src/X86.ml
|
|
@ -1,4 +1,6 @@
|
|||
open GT
|
||||
open Language
|
||||
open SM
|
||||
|
||||
(* X86 codegeneration interface *)
|
||||
|
||||
|
|
@ -120,11 +122,14 @@ let compile env code =
|
|||
| ">=" -> "ge"
|
||||
| ">" -> "g"
|
||||
| _ -> failwith "unknown operator"
|
||||
in (*
|
||||
in
|
||||
let rec compile' env scode =
|
||||
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 call env f n =
|
||||
let call env n =
|
||||
let f = "foo" in
|
||||
Printf.eprintf "Stack in call: %s\n%!" env#show_stack;
|
||||
invalid_arg "CALL not yet supported.\n";
|
||||
let f =
|
||||
match f.[0] with '.' -> "B" ^ String.sub f 1 (String.length f - 1) | _ -> f
|
||||
in
|
||||
|
|
@ -162,7 +167,7 @@ let compile env code =
|
|||
| STRING s ->
|
||||
let s, env = env#string s in
|
||||
let l, env = env#allocate in
|
||||
let env, call = call env ".string" 1 in
|
||||
let env, call = call env (* TODO!!! ".string" *) 1 in
|
||||
(env, Mov (M ("$" ^ s), l) :: call)
|
||||
|
||||
| LDA x ->
|
||||
|
|
@ -191,7 +196,7 @@ let compile env code =
|
|||
)
|
||||
|
||||
| STA ->
|
||||
call env ".sta" 3
|
||||
call env (* TODO! ".sta" *) 3
|
||||
|
||||
| STI ->
|
||||
let v, x, env' = env#pop2 in
|
||||
|
|
@ -298,7 +303,19 @@ let compile env code =
|
|||
let x, env = env#pop in
|
||||
env#set_stack l, [Sar1 x; (*!!!*) Binop ("cmp", L 0, x); CJmp (s, l)]
|
||||
|
||||
| BEGIN (f, a, l) ->
|
||||
| BEGIN (f, nargs, nlocals, closure) ->
|
||||
env#assert_empty_stack;
|
||||
let env = env#enter f nlocals in
|
||||
let size = Printf.sprintf "$%d" (word_size * (nlocals + if closure = [] then 0 else 1)) in
|
||||
env, [Push ebp; Mov (esp, ebp); Binop ("-", M size, esp);
|
||||
Mov (esp, edi);
|
||||
Mov (M "$filler", esi);
|
||||
Mov (M size, ecx);
|
||||
Repmovsl
|
||||
]
|
||||
|
||||
(*
|
||||
| BEGIN (f, nargs, nlocals, closure) ->
|
||||
env#assert_empty_stack;
|
||||
let env = env#enter f a l in
|
||||
env, [Push ebp; Mov (esp, ebp); Binop ("-", M ("$" ^ env#lsize), esp);
|
||||
|
|
@ -307,25 +324,26 @@ let compile env code =
|
|||
Mov (M ("$" ^ (env#allocated_size)), ecx);
|
||||
Repmovsl
|
||||
]
|
||||
|
||||
*)
|
||||
| END ->
|
||||
env#endfunc, [Label env#epilogue;
|
||||
Mov (ebp, esp);
|
||||
Pop ebp;
|
||||
Ret;
|
||||
Ret (*;
|
||||
Meta (Printf.sprintf "\t.set\t%s,\t%d" env#lsize (env#allocated * word_size));
|
||||
Meta (Printf.sprintf "\t.set\t%s,\t%d" env#allocated_size env#allocated)
|
||||
*)
|
||||
]
|
||||
|
||||
| RET ->
|
||||
let x, env = env#pop in
|
||||
env, [Mov (x, eax); Jmp env#epilogue]
|
||||
|
||||
| CALL (f, n) -> call env f n
|
||||
| CALL (f, n) -> call env n
|
||||
|
||||
| SEXP (t, n) ->
|
||||
let s, env = env#allocate in
|
||||
let env, code = call env ".sexp" (n+1) in
|
||||
let env, code = call env (* TODO! ".sexp" *) (n+1) in
|
||||
env, [Mov (L env#hash t, s)] @ code
|
||||
|
||||
| DROP ->
|
||||
|
|
@ -343,44 +361,33 @@ let compile env code =
|
|||
| TAG (t, n) ->
|
||||
let s1, env = env#allocate in
|
||||
let s2, env = env#allocate in
|
||||
let env, code = call env ".tag" 3 in
|
||||
let env, code = call env (* TODO! ".tag" *) 3 in
|
||||
env, [Mov (L env#hash t, s1); Mov (L n, s2)] @ code
|
||||
|
||||
| ARRAY n ->
|
||||
let s, env = env#allocate in
|
||||
let env, code = call env ".array_patt" 2 in
|
||||
let env, code = call env (* TODO! ".array_patt" *) 2 in
|
||||
env, [Mov (L n, s)] @ code
|
||||
|
||||
| PATT StrCmp -> call env ".string_patt" 2
|
||||
| PATT StrCmp -> call env (* TODO!!! ".string_patt" *) 2
|
||||
|
||||
| PATT patt ->
|
||||
call env
|
||||
call env (* TODO!!!
|
||||
(match patt with
|
||||
| Boxed -> ".boxed_patt"
|
||||
| UnBoxed -> ".unboxed_patt"
|
||||
| Array -> ".array_tag_patt"
|
||||
| String -> ".string_tag_patt"
|
||||
| Sexp -> ".sexp_tag_patt"
|
||||
) 1
|
||||
) *)1
|
||||
|
||||
| ENTER xs ->
|
||||
let env, code =
|
||||
List.fold_left
|
||||
(fun (env, code) v ->
|
||||
let s, env = env#pop in
|
||||
env, (mov s @@ env#loc v) :: code
|
||||
)
|
||||
(env#scope @@ List.rev xs, []) xs
|
||||
in
|
||||
env, List.flatten @@ List.rev code
|
||||
|
||||
| LEAVE -> env#unscope, []
|
||||
| i ->
|
||||
invalid_arg (Printf.sprintf "invalid SM insn: %s\n" (GT.show(insn) i))
|
||||
in
|
||||
let env'', code'' = compile' env' scode' in
|
||||
env'', [Meta (Printf.sprintf "# %s / % s" (GT.show(SM.insn) instr) stack)] @ code' @ code''
|
||||
in
|
||||
compile' env code
|
||||
*) invalid_arg "not implemented"
|
||||
|
||||
(* A set of strings *)
|
||||
module S = Set.Make (String)
|
||||
|
|
@ -448,9 +455,18 @@ class env =
|
|||
|
||||
(* gets a name for a global variable *)
|
||||
method loc x =
|
||||
match x with
|
||||
| Value.Global name -> M ("global_" ^ name)
|
||||
| Value.Fun name -> M name
|
||||
| Value.Local i -> S i
|
||||
| Value.Arg i -> S (- (i+1))
|
||||
| Value.Access i -> invalid_arg "closure access not yet implemented"
|
||||
|
||||
(*
|
||||
try S (- (List.assoc x args) - 1)
|
||||
with Not_found ->
|
||||
try S (assoc x locals) with Not_found -> M ("global_" ^ x)
|
||||
*)
|
||||
|
||||
(* allocates a fresh position on a symbolic stack *)
|
||||
method allocate =
|
||||
|
|
@ -490,8 +506,8 @@ class env =
|
|||
|
||||
(* registers a variable in the environment *)
|
||||
method variable x =
|
||||
match self#loc x with
|
||||
| M name -> {< globals = S.add name globals >}
|
||||
match x with
|
||||
| Value.Global name -> {< globals = S.add name globals >}
|
||||
| _ -> self
|
||||
|
||||
(* registers a string constant *)
|
||||
|
|
@ -511,13 +527,15 @@ class env =
|
|||
(* gets a number of stack positions allocated *)
|
||||
method allocated = stack_slots
|
||||
|
||||
(*
|
||||
method allocated_size = Printf.sprintf "LS%s_SIZE" fname
|
||||
*)
|
||||
|
||||
(* enters a function *)
|
||||
method enter f a l =
|
||||
let n = List.length l in
|
||||
{< static_size = n; stack_slots = n; stack = []; locals = [make_assoc l 0]; args = make_assoc a 0; fname = f >}
|
||||
method enter f nlocals =
|
||||
{< static_size = nlocals; stack_slots = nlocals; stack = []; fname = f >}
|
||||
|
||||
(*
|
||||
(* enters a scope *)
|
||||
method scope vars =
|
||||
let n = List.length vars in
|
||||
|
|
@ -528,12 +546,14 @@ class env =
|
|||
method unscope =
|
||||
let n = List.length (List.hd locals) in
|
||||
{< static_size = static_size - n; locals = List.tl locals >}
|
||||
|
||||
*)
|
||||
(* returns a label for the epilogue *)
|
||||
method epilogue = Printf.sprintf "L%s_epilogue" fname
|
||||
|
||||
(*
|
||||
(* returns a name for local size meta-symbol *)
|
||||
method lsize = Printf.sprintf "L%s_SIZE" fname
|
||||
*)
|
||||
|
||||
(* returns a list of live registers *)
|
||||
method live_registers depth =
|
||||
|
|
@ -549,18 +569,21 @@ class env =
|
|||
(* Generates an assembler text for a program: first compiles the program into
|
||||
the stack code, then generates x86 assember code, then prints the assembler file
|
||||
*)
|
||||
let genasm (ds, stmt) =
|
||||
let stmt =
|
||||
Language.Expr.Seq (
|
||||
Language.Expr.Ignore (Language.Expr.Call (Language.Expr.Var "__gc_init", [])),
|
||||
Language.Expr.Seq (stmt, Language.Expr.Return (Some (Language.Expr.Call (Language.Expr.Var "raw", [Language.Expr.Const 0]))))
|
||||
let genasm prog =
|
||||
let decorate e =
|
||||
Expr.Seq (
|
||||
Expr.Ignore (Expr.Call (Expr.Var "__gc_init", [])),
|
||||
Expr.Seq (e, Expr.Return (Some (Expr.Call (Expr.Var "raw", [Expr.Const 0]))))
|
||||
)
|
||||
in
|
||||
let env, code =
|
||||
compile
|
||||
(new env)
|
||||
((LABEL "main") :: (BEGIN ("main", 0, 0, [])) :: [] (* TODO! SM.compile (ds, stmt) *))
|
||||
let expr =
|
||||
match prog with
|
||||
| Expr.Scope (defs, e) -> Expr.Scope (defs, decorate e)
|
||||
| _ -> decorate prog
|
||||
in
|
||||
let sm = SM.compile expr in
|
||||
Printf.eprintf "SM:\n"; print_prg sm;
|
||||
let env, code = compile (new env) sm in
|
||||
let gc_start, gc_end = "__gc_data_start", "__gc_data_end" in
|
||||
let data = [Meta "\t.data";
|
||||
Meta (Printf.sprintf "filler:\t.fill\t%d, 4, 1" env#max_locals_size);
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue