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

x86 up to closures

Browse source
This commit is contained in:
Dmitry Boulytchev 2019-10-15 01:54:57 +03:00
parent e529ba1472
commit 763f5fe486
4 changed files with 49 additions and 48 deletions
Download patch file Download diff file Expand all files Collapse all files

4
regression/Makefile
View file

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

2
src/Language.ml
View file

@ -120,7 +120,7 @@ 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) | "__gc_init" -> (st, i, o, vs)
| "raw" -> let [a] = args in (st, i, o, a :: vs) | "raw" -> let [a] = args in (st, i, o, a :: vs)
end end

34
src/SM.ml
View file

@ -82,9 +82,17 @@ let print_stack memo s =
List.iter (fun v -> Printf.eprintf "%s " @@ show(value) v) s; List.iter (fun v -> Printf.eprintf "%s " @@ show(value) v) s;
Printf.eprintf "\n%!" Printf.eprintf "\n%!"
let show_insn = show insn
let rec eval env (((cstack, stack, glob, loc, i, o) as conf) : config) = function let rec eval env (((cstack, stack, glob, loc, i, o) as conf) : config) = function
| [] -> conf | [] -> conf
| insn :: prg' -> | insn :: prg' ->
(*
Printf.eprintf "eval\n";
Printf.eprintf " insn=%s\n" (show_insn insn);
Printf.eprintf " stack=%s\n" (show(list) (show(value)) stack);
Printf.eprintf "end\n";
*)
(match insn with (match insn with
| BINOP op -> let y::x::stack' = stack in eval env (cstack, (Value.of_int @@ Expr.to_func op (Value.to_int x) (Value.to_int y)) :: stack', glob, loc, i, o) prg' | BINOP op -> let y::x::stack' = stack in eval env (cstack, (Value.of_int @@ Expr.to_func op (Value.to_int x) (Value.to_int y)) :: stack', glob, loc, i, o) prg'
| CONST n -> eval env (cstack, (Value.of_int n)::stack, glob, loc, i, o) prg' | CONST n -> eval env (cstack, (Value.of_int n)::stack, glob, loc, i, o) prg'
@ -201,7 +209,6 @@ let rec eval env (((cstack, stack, glob, loc, i, o) as conf) : config) = functio
Takes a program, an input stream, and returns an output stream this program calculates Takes a program, an input stream, and returns an output stream this program calculates
*) *)
let run p i = let run p i =
(* print_prg p; *)
let module M = Map.Make (String) in let module M = Map.Make (String) in
let rec make_env (m, s) = function let rec make_env (m, s) = function
| [] -> (m, s) | [] -> (m, s)
@ -219,7 +226,7 @@ let run p i =
let (st, i, o, r) = Language.Builtin.eval (State.I, i, o, []) (List.map Obj.magic @@ List.rev args) f in let (st, i, o, r) = Language.Builtin.eval (State.I, i, o, []) (List.map Obj.magic @@ List.rev args) f in
(cstack, (match r with [r] -> (Obj.magic r)::stack | _ -> Value.Empty :: stack), glob, loc, i, o) (cstack, (match r with [r] -> (Obj.magic r)::stack | _ -> Value.Empty :: stack), glob, loc, i, o)
end end
([], [Value.Closure ([], "main", [||])], (List.fold_left (fun s (name, value) -> State.bind name value s) glob (Builtin.bindings ())), {locals=[||]; args=[||]; closure=[||]}, i, []) ([], [], (List.fold_left (fun s (name, value) -> State.bind name value s) glob (Builtin.bindings ())), {locals=[||]; args=[||]; closure=[||]}, i, [])
p p
in in
o o
@ -335,7 +342,13 @@ 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.Fun name) s) (fun s (name, value) ->
let name' =
match name.[0] with
| '.' -> name
| _ -> "L" ^ name
in
State.bind name (Value.Fun name') s)
State.undefined State.undefined
(Builtin.bindings ())) (Builtin.bindings ()))
| _ -> | _ ->
@ -640,19 +653,6 @@ let compile p =
| Expr.Leave -> env, false, [] | Expr.Leave -> env, false, []
| Expr.Case (e, [p, s]) ->
let lexp , env = env#get_label in
let ldrop, env = env#get_label in
let env, fe , se = compile_expr lexp env e in
let env, ldrop' , pcode = pattern env ldrop p in
let env = env#push_scope in
let env, bindcode = bindings env p in
let env, ldrop'', scode = compile_expr ldrop env s in
let env = env#pop_scope in
if ldrop' || ldrop''
then env, true , se @ (if fe then [LABEL lexp] else []) @ [DUP] @ pcode @ bindcode @ scode @ [JMP l; LABEL ldrop; DROP]
else env, false, se @ (if fe then [LABEL lexp] else []) @ [DUP] @ pcode @ bindcode @ scode
| Expr.Case (e, brs) -> | Expr.Case (e, brs) ->
let n = List.length brs - 1 in let n = List.length brs - 1 in
let lexp, env = env#get_label in let lexp, env = env#get_label in
@ -700,6 +700,6 @@ let compile p =
let env = new env in let env = new env 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 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 [[LABEL "main"; 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

51
src/X86.ml
View file

@ -126,10 +126,7 @@ let compile env 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 call env n = let call env f 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
@ -167,7 +164,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 (* TODO!!! ".string" *) 1 in let env, call = call env ".string" 1 in
(env, Mov (M ("$" ^ s), l) :: call) (env, Mov (M ("$" ^ s), l) :: call)
| LDA x -> | LDA x ->
@ -196,7 +193,7 @@ let compile env code =
) )
| STA -> | STA ->
call env (* TODO! ".sta" *) 3 call env ".sta" 3
| STI -> | STI ->
let v, x, env' = env#pop2 in let v, x, env' = env#pop2 in
@ -305,14 +302,21 @@ let compile env code =
| BEGIN (f, nargs, nlocals, closure) -> | BEGIN (f, nargs, nlocals, closure) ->
env#assert_empty_stack; env#assert_empty_stack;
let env = env#enter f nlocals in let env = env#enter f (nlocals + if closure = [] then 0 else 1) in
let size = Printf.sprintf "$%d" (word_size * (nlocals + if closure = [] then 0 else 1)) in env, [Push ebp; Mov (esp, ebp); Binop ("-", M ("$" ^ env#lsize), esp);
env, [Push ebp; Mov (esp, ebp); Binop ("-", M size, esp);
Mov (esp, edi); Mov (esp, edi);
Mov (M "$filler", esi); Mov (M "$filler", esi);
Mov (M size, ecx); Mov (M ("$" ^ (env#allocated_size)), ecx);
Repmovsl Repmovsl
] ]
(*
env, [Push ebp; Mov (esp, ebp); Binop ("-", M ("$" ^ string_of_int @@ word_size * size), esp);
Mov (esp, edi);
Mov (M "$filler", esi);
Mov (M ("$" ^ string_of_int size), ecx);
Repmovsl
]
*)
(* (*
| BEGIN (f, nargs, nlocals, closure) -> | BEGIN (f, nargs, nlocals, closure) ->
@ -329,21 +333,23 @@ let compile env code =
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 n | CALL (f, n) -> call env f n
| CALLC n ->
invalid_arg "CALLC not supported yet"
| SEXP (t, n) -> | SEXP (t, n) ->
let s, env = env#allocate in let s, env = env#allocate in
let env, code = call env (* TODO! ".sexp" *) (n+1) in let env, code = call env ".sexp" (n+1) in
env, [Mov (L env#hash t, s)] @ code env, [Mov (L env#hash t, s)] @ code
| DROP -> | DROP ->
@ -361,25 +367,25 @@ 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 (* TODO! ".tag" *) 3 in let env, code = call env ".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 (* TODO! ".array_patt" *) 2 in let env, code = call env ".array_patt" 2 in
env, [Mov (L n, s)] @ code env, [Mov (L n, s)] @ code
| PATT StrCmp -> call env (* TODO!!! ".string_patt" *) 2 | PATT StrCmp -> call env ".string_patt" 2
| PATT patt -> | PATT patt ->
call env (* TODO!!! call env
(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
| i -> | i ->
invalid_arg (Printf.sprintf "invalid SM insn: %s\n" (GT.show(insn) i)) invalid_arg (Printf.sprintf "invalid SM insn: %s\n" (GT.show(insn) i))
@ -507,7 +513,7 @@ class env =
(* registers a variable in the environment *) (* registers a variable in the environment *)
method variable x = method variable x =
match x with match x with
| Value.Global name -> {< globals = S.add name globals >} | Value.Global name -> {< globals = S.add ("global_" ^ name) globals >}
| _ -> self | _ -> self
(* registers a string constant *) (* registers a string constant *)
@ -527,9 +533,7 @@ 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 nlocals = method enter f nlocals =
@ -550,10 +554,8 @@ class env =
(* 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 =
@ -582,7 +584,6 @@ let genasm prog =
| _ -> decorate prog | _ -> decorate prog
in in
let sm = SM.compile expr in let sm = SM.compile expr in
Printf.eprintf "SM:\n"; print_prg sm;
let env, code = compile (new env) sm in 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";