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

Added static call

Browse source
This commit is contained in:
Dmitry Boulytchev 2019-10-14 19:44:33 +03:00
parent 2bfebc93f8
commit e529ba1472
8 changed files with 134 additions and 70 deletions
Download patch file Download diff file Expand all files Collapse all files

2
regression/Makefile
View file

@ -10,7 +10,7 @@ $(TESTS): %: %.expr
@echo $@ @echo $@
# @$(RC) $< && cat $@.input | ./$@ > $@.log && diff $@.log orig/$@.log # @$(RC) $< && cat $@.input | ./$@ > $@.log && diff $@.log orig/$@.log
cat $@.input | $(RC) -i $< > $@.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: clean:
$(RM) test*.log *.s *~ $(TESTS) $(RM) test*.log *.s *~ $(TESTS)

1
regression/orig/test067.log Normal file
View file

@ -0,0 +1 @@
> 12

5
regression/test067.expr Normal file
View 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
View file

@ -0,0 +1 @@
5

2
src/Driver.ml
View file

@ -43,7 +43,7 @@ let main =
if to_compile if to_compile
then ( then (
let basename = Filename.chop_suffix infile ".expr" in let basename = Filename.chop_suffix infile ".expr" in
(* ignore @@ X86.build prog basename *) (* TODO! *) () ignore @@ X86.build prog basename
) )
else ( else (
(* Printf.printf "Program:\n%s\n" (GT.show(Language.Expr.t) prog);*) (* Printf.printf "Program:\n%s\n" (GT.show(Language.Expr.t) prog);*)

4
src/Language.ml
View file

@ -102,7 +102,7 @@ module Value =
module Builtin = module Builtin =
struct 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 bindings () = List.map (fun name -> name, Value.Builtin name) list
let names = List.map (fun name -> name, false) 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) | ".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) | ".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) | ".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 end

60
src/SM.ml
View file

@ -21,7 +21,8 @@ open Language
(* begins procedure definition *) | BEGIN of string * int * int * Value.designation list (* begins procedure definition *) | BEGIN of string * int * int * Value.designation list
(* end procedure definition *) | END (* end procedure definition *) | END
(* create a closure *) | CLOSURE of string (* 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 (* 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
@ -121,12 +122,33 @@ let rec eval env (((cstack, stack, glob, loc, i, o) as conf) : config) = functio
| Value.Arg i -> loc.args.(i) | Value.Arg i -> loc.args.(i)
| Value.Local i -> loc.locals.(i) | Value.Local i -> loc.locals.(i)
| Value.Access i -> loc.closure.(i) | Value.Access i -> loc.closure.(i)
| _ -> invalid_arg "wrong value in CLOSURE") | _ -> invalid_arg "wrong value in CLOSURE")
dgs dgs
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 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 let f::args = List.rev vs in
(match f with (match f with
| Value.Builtin f -> | Value.Builtin f ->
@ -313,7 +335,7 @@ object (self : 'self)
| State.I -> | State.I ->
State.G (Builtin.names, State.G (Builtin.names,
List.fold_left 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 State.undefined
(Builtin.bindings ())) (Builtin.bindings ()))
| _ -> | _ ->
@ -420,7 +442,6 @@ object (self : 'self)
| Value.Access n when n = ~-1 -> | Value.Access n when n = ~-1 ->
let index = scope.acc_index in let index = scope.acc_index in
let fundefs', loc = propagate_acc fundefs name in let fundefs', loc = propagate_acc fundefs name in
(* let enclosing_loc = (*State.eval enclosing_st name*) in *)
{< {<
fundefs = fundefs'; fundefs = fundefs';
scope = { scope = {
@ -470,7 +491,7 @@ let compile 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; LD (Value.Global ".elem"); SWAP; CONST i; CALL 2] @ pcode) :: code i+1, env, ([DUP; CONST i; CALL (".elem", 2)] @ pcode) :: code
) )
(0, env, []) (0, env, [])
ps ps
@ -504,7 +525,7 @@ let compile 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 -> [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 [ST dsg; DROP]) :: acc
) )
(env, []) (env, [])
@ -555,23 +576,34 @@ let compile p =
| 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 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
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 | 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 | 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 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 [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 | 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 | 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 | 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 lassn env [x; e]) lassn false [match x with Expr.ElemRef _ -> STA | _ -> STI]
@ -669,5 +701,5 @@ let compile p =
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 lend env p in
let env, prg = compile_fundefs [[BEGIN ("main", 0, env#nlocals, [])] @(if flag then code @ [LABEL lend] else code) @ [END]] env in let env, prg = compile_fundefs [[BEGIN ("main", 0, env#nlocals, [])] @(if flag then code @ [LABEL lend] else code) @ [END]] env in
let prg = List.flatten prg in let prg = List.flatten prg in
prg prg

109
src/X86.ml
View file

@ -1,4 +1,6 @@
open GT open GT
open Language
open SM
(* X86 codegeneration interface *) (* X86 codegeneration interface *)
@ -120,11 +122,14 @@ let compile env code =
| ">=" -> "ge" | ">=" -> "ge"
| ">" -> "g" | ">" -> "g"
| _ -> failwith "unknown operator" | _ -> failwith "unknown operator"
in (* in
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 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 = let f =
match f.[0] with '.' -> "B" ^ String.sub f 1 (String.length f - 1) | _ -> f match f.[0] with '.' -> "B" ^ String.sub f 1 (String.length f - 1) | _ -> f
in in
@ -162,7 +167,7 @@ let compile env 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 (* TODO!!! ".string" *) 1 in
(env, Mov (M ("$" ^ s), l) :: call) (env, Mov (M ("$" ^ s), l) :: call)
| LDA x -> | LDA x ->
@ -191,7 +196,7 @@ let compile env code =
) )
| STA -> | STA ->
call env ".sta" 3 call env (* TODO! ".sta" *) 3
| STI -> | STI ->
let v, x, env' = env#pop2 in let v, x, env' = env#pop2 in
@ -298,7 +303,19 @@ let compile env code =
let x, env = env#pop in let x, env = env#pop in
env#set_stack l, [Sar1 x; (*!!!*) Binop ("cmp", L 0, x); CJmp (s, l)] 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; env#assert_empty_stack;
let env = env#enter f a l in let env = env#enter f a l in
env, [Push ebp; Mov (esp, ebp); Binop ("-", M ("$" ^ env#lsize), esp); 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); Mov (M ("$" ^ (env#allocated_size)), ecx);
Repmovsl Repmovsl
] ]
*)
| END -> | END ->
env#endfunc, [Label env#epilogue; env#endfunc, [Label env#epilogue;
Mov (ebp, esp); Mov (ebp, esp);
Pop ebp; 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#lsize (env#allocated * word_size));
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 -> | RET ->
let x, env = env#pop in let x, env = env#pop 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) -> call env n
| 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 (* TODO! ".sexp" *) (n+1) in
env, [Mov (L env#hash t, s)] @ code env, [Mov (L env#hash t, s)] @ code
| DROP -> | DROP ->
@ -343,44 +361,33 @@ let compile env 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 (* TODO! ".tag" *) 3 in
env, [Mov (L env#hash t, s1); Mov (L n, s2)] @ code env, [Mov (L env#hash t, s1); Mov (L 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 (* TODO! ".array_patt" *) 2 in
env, [Mov (L n, s)] @ code env, [Mov (L n, s)] @ code
| PATT StrCmp -> call env ".string_patt" 2 | PATT StrCmp -> call env (* TODO!!! ".string_patt" *) 2
| PATT patt -> | PATT patt ->
call env call env (* TODO!!!
(match patt with (match patt with
| Boxed -> ".boxed_patt" | Boxed -> ".boxed_patt"
| UnBoxed -> ".unboxed_patt" | UnBoxed -> ".unboxed_patt"
| Array -> ".array_tag_patt" | Array -> ".array_tag_patt"
| String -> ".string_tag_patt" | String -> ".string_tag_patt"
| Sexp -> ".sexp_tag_patt" | Sexp -> ".sexp_tag_patt"
) 1 ) *)1
| ENTER xs -> | i ->
let env, code = invalid_arg (Printf.sprintf "invalid SM insn: %s\n" (GT.show(insn) i))
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, []
in in
let env'', code'' = compile' env' scode' in let env'', code'' = compile' env' scode' in
env'', [Meta (Printf.sprintf "# %s / % s" (GT.show(SM.insn) instr) stack)] @ code' @ code'' env'', [Meta (Printf.sprintf "# %s / % s" (GT.show(SM.insn) instr) stack)] @ code' @ code''
in in
compile' env code compile' env code
*) invalid_arg "not implemented"
(* A set of strings *) (* A set of strings *)
module S = Set.Make (String) module S = Set.Make (String)
@ -448,9 +455,18 @@ class env =
(* gets a name for a global variable *) (* gets a name for a global variable *)
method loc x = 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) try S (- (List.assoc x args) - 1)
with Not_found -> with Not_found ->
try S (assoc x locals) with Not_found -> M ("global_" ^ x) try S (assoc x locals) with Not_found -> M ("global_" ^ x)
*)
(* allocates a fresh position on a symbolic stack *) (* allocates a fresh position on a symbolic stack *)
method allocate = method allocate =
@ -490,9 +506,9 @@ class env =
(* registers a variable in the environment *) (* registers a variable in the environment *)
method variable x = method variable x =
match self#loc x with match x with
| M name -> {< globals = S.add name globals >} | Value.Global name -> {< globals = S.add name globals >}
| _ -> self | _ -> self
(* registers a string constant *) (* registers a string constant *)
method string x = method string x =
@ -511,13 +527,15 @@ class env =
(* gets a number of stack positions allocated *) (* gets a number of stack positions allocated *)
method allocated = stack_slots method allocated = stack_slots
(*
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 a l = method enter f nlocals =
let n = List.length l in {< static_size = nlocals; stack_slots = nlocals; stack = []; fname = f >}
{< static_size = n; stack_slots = n; stack = []; locals = [make_assoc l 0]; args = make_assoc a 0; fname = f >}
(*
(* enters a scope *) (* enters a scope *)
method scope vars = method scope vars =
let n = List.length vars in let n = List.length vars in
@ -528,12 +546,14 @@ class env =
method unscope = method unscope =
let n = List.length (List.hd locals) in let n = List.length (List.hd locals) in
{< static_size = static_size - n; locals = List.tl locals >} {< static_size = static_size - n; locals = List.tl locals >}
*)
(* 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
(*
(* returns a name for local size meta-symbol *) (* returns a name for local size meta-symbol *)
method lsize = Printf.sprintf "L%s_SIZE" fname method lsize = Printf.sprintf "L%s_SIZE" fname
*)
(* returns a list of live registers *) (* returns a list of live registers *)
method live_registers depth = method live_registers depth =
@ -549,18 +569,21 @@ class env =
(* Generates an assembler text for a program: first compiles the program into (* 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 the stack code, then generates x86 assember code, then prints the assembler file
*) *)
let genasm (ds, stmt) = let genasm prog =
let stmt = let decorate e =
Language.Expr.Seq ( Expr.Seq (
Language.Expr.Ignore (Language.Expr.Call (Language.Expr.Var "__gc_init", [])), Expr.Ignore (Expr.Call (Expr.Var "__gc_init", [])),
Language.Expr.Seq (stmt, Language.Expr.Return (Some (Language.Expr.Call (Language.Expr.Var "raw", [Language.Expr.Const 0])))) Expr.Seq (e, Expr.Return (Some (Expr.Call (Expr.Var "raw", [Expr.Const 0]))))
) )
in in
let env, code = let expr =
compile match prog with
(new env) | Expr.Scope (defs, e) -> Expr.Scope (defs, decorate e)
((LABEL "main") :: (BEGIN ("main", 0, 0, [])) :: [] (* TODO! SM.compile (ds, stmt) *)) | _ -> decorate prog
in 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 gc_start, gc_end = "__gc_data_start", "__gc_data_end" in
let data = [Meta "\t.data"; let data = [Meta "\t.data";
Meta (Printf.sprintf "filler:\t.fill\t%d, 4, 1" env#max_locals_size); Meta (Printf.sprintf "filler:\t.fill\t%d, 4, 1" env#max_locals_size);