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

merge

Browse source
This commit is contained in:
danyaberezun 2018-11-12 16:15:48 +03:00
parent 0dd8ae8a7a
commit 2ba7a95f86
2 changed files with 66 additions and 45 deletions
Download patch file Download diff file Expand all files Collapse all files

84
src/SM.ml
View file

@ -95,7 +95,7 @@ let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function
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; (*print_prg p;*)
let module M = Map.Make (String) in let module M = Map.Make (String) in
let rec make_map m = function let rec make_map m = function
| [] -> m | [] -> m
@ -134,36 +134,44 @@ let compile (defs, p) =
let rec call f args p = let rec call f args p =
let args_code = List.concat @@ List.map expr args in let args_code = List.concat @@ List.map expr args in
args_code @ [CALL (label f, List.length args, p)] args_code @ [CALL (label f, List.length args, p)]
and pattern lfalse = function and pattern env lfalse = function
| Stmt.Pattern.Wildcard -> false, [DROP] | Stmt.Pattern.Wildcard -> env, false, [DROP]
| Stmt.Pattern.Ident n -> false, [DROP] | Stmt.Pattern.Ident n -> env, false, [DROP]
| Stmt.Pattern.Sexp (t, ps) -> | Stmt.Pattern.Sexp (t, ps) ->
true, let ltag , env = env#get_label in
[DUP; TAG t; CJMP ("z", lfalse)] @ let ldrop, env = env#get_label in
(List.concat @@ let tag = [DUP; TAG t; CJMP ("nz", ltag); LABEL ldrop; DROP; JMP lfalse; LABEL ltag] in
List.mapi let _, env, code =
(fun i p -> List.fold_left
[DUP; CONST i; CALL (".elem", 2, false)] @ (fun (i, env, code) p ->
snd @@ pattern lfalse p let env, _, pcode = pattern env ldrop p in
) i+1, env, ([DUP; CONST i; CALL (".elem", 2, false)] @ pcode) :: code
ps )
) (0, env, [])
ps
in
env, true, tag @ List.flatten (List.rev code) @ [DROP]
and bindings p = and bindings p =
let rec inner = function let bindings =
| Stmt.Pattern.Ident n -> [SWAP] transform(Stmt.Pattern.t)
| Stmt.Pattern.Wildcard -> [DROP] (object inherit [int list, (string * int list) list] @Stmt.Pattern.t
| Stmt.Pattern.Sexp (_, ps) -> method c_Wildcard path _ = []
(List.flatten @@ method c_Ident path _ s = [s, path]
List.mapi method c_Sexp path x _ ps = List.concat @@ List.mapi (fun i p -> x.GT.f (path @ [i]) p) ps
(fun i p -> end)
[DUP; CONST i; CALL (".elem", 2, false)] @ []
inner p p
)
ps
) @
[DROP]
in in
inner p @ [ENTER (Stmt.Pattern.vars p)] List.concat
(List.map
(fun (name, path) ->
[DUP] @
List.concat (List.map (fun i -> [CONST i; CALL (".elem", 2, false)]) path) @
[SWAP]
)
(List.rev bindings)
) @
[DROP; ENTER (List.map fst bindings)]
and expr = function and expr = function
| Expr.Var x -> [LD x] | Expr.Var x -> [LD x]
| Expr.Const n -> [CONST n] | Expr.Const n -> [CONST n]
@ -207,12 +215,14 @@ let compile (defs, p) =
| Stmt.Leave -> env, false, [LEAVE] | Stmt.Leave -> env, false, [LEAVE]
| Stmt.Case (e, [p, s]) -> | Stmt.Case (e, [p, s]) ->
let pflag, pcode = pattern l p in let ldrop, env = env#get_label in
let env, sflag, scode = compile_stmt l env (Stmt.Seq (s, Stmt.Leave)) in let env, _, pcode = pattern env ldrop p in
env, pflag || sflag, expr e @ pcode @ bindings p @ scode let env, _, scode = compile_stmt ldrop env (Stmt.Seq (s, Stmt.Leave)) in
env, true, expr e @ [DUP] @ pcode @ bindings p @ scode @ [JMP l; LABEL ldrop; DROP]
| Stmt.Case (e, brs) -> | Stmt.Case (e, brs) ->
let n = List.length brs - 1 in let n = List.length brs - 1 in
let ldrop, env = env#get_label in
let env, _, _, code = let env, _, _, code =
List.fold_left List.fold_left
(fun (env, lab, i, code) (p, s) -> (fun (env, lab, i, code) (p, s) ->
@ -221,13 +231,13 @@ let compile (defs, p) =
then (l, env), [] then (l, env), []
else env#get_label, [JMP l] else env#get_label, [JMP l]
in in
let _, pcode = pattern lfalse p in let env, _, pcode = pattern env lfalse p in
let env, _, scode = compile_stmt l env (Stmt.Seq (s, Stmt.Leave)) in let env, _, scode = compile_stmt ldrop env (Stmt.Seq (s, Stmt.Leave)) in
(env, Some lfalse, i+1, ((match lab with None -> [] | Some l -> [LABEL l]) @ pcode @ bindings p @ scode @ jmp) :: code) (env, Some lfalse, i+1, ((match lab with None -> [] | Some l -> [LABEL l; DUP]) @ pcode @ bindings p @ scode @ jmp) :: code)
) )
(env, None, 0, []) brs (env, None, 0, []) brs
in in
env, true, expr e @ List.flatten @@ List.rev code env, true, expr e @ [DUP] @ (List.flatten @@ List.rev code) @ [JMP l; LABEL ldrop; DROP]
in in
let compile_def env (name, (args, locals, stmt)) = let compile_def env (name, (args, locals, stmt)) =
let lend, env = env#get_label in let lend, env = env#get_label in

27
src/X86.ml
View file

@ -251,6 +251,18 @@ let compile env code =
else env, [Jmp env#epilogue] else env, [Jmp env#epilogue]
| CALL (f, n, p) -> call env f n p | CALL (f, n, p) -> call env f n p
(*
| SEXP (t, n) ->
| DROP -> snd env#pop, []
| DUP -> let x = env#peek in
let s, env = env#allocate in
env, [Mov (x, s)]
| SWAP -> let x, y = env#peek2 in
env, [Push x; Push y; Pop x; Pop y]
| TAG t
| ENTER xs
| LEAVE *)
in in
let env'', code'' = compile' env' scode' in let env'', code'' = compile' env' scode' in
env'', code' @ code'' env'', code' @ code''
@ -286,14 +298,13 @@ class env =
(* allocates a fresh position on a symbolic stack *) (* allocates a fresh position on a symbolic stack *)
method allocate = method allocate =
let x, n = let x, n =
let rec allocate' = function let rec allocate' = function
| [] -> R 0 , 0 | [] -> ebx , 0
| (S n)::_ -> S (n+1) , n+2 | (S n)::_ -> S (n+1) , n+2
| (R n)::_ when n < num_of_regs -> R (n+1) , stack_slots | (R n)::_ when n < num_of_regs -> R (n+1) , stack_slots
| (M _)::s -> allocate' s | _ -> S stack_slots, stack_slots+1
| _ -> let n = List.length locals in S n, n+1 in
in allocate' stack
allocate' stack
in in
x, {< stack_slots = max n stack_slots; stack = x::stack >} x, {< stack_slots = max n stack_slots; stack = x::stack >}