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

Rolled back

Browse source
This commit is contained in:
Dmitry Boulytchev 2019-12-28 01:59:04 +03:00
parent d475fe390d
commit 02dee40262
2 changed files with 16 additions and 35 deletions
Download patch file Download diff file Expand all files Collapse all files

45
src/SM.ml
View file

@ -18,7 +18,7 @@ open Language
(* a label *) | LABEL of string
(* unconditional jump *) | JMP of string
(* conditional jump *) | CJMP of string * string
(* begins procedure definition *) | BEGIN of string * int * int * Value.designation list * int
(* begins procedure definition *) | BEGIN of string * int * int * Value.designation list
(* end procedure definition *) | END
(* create a closure *) | CLOSURE of string
(* calls a closure *) | CALLC of int
@ -99,17 +99,6 @@ let rec eval env (((cstack, stack, glob, loc, i, o) as conf) : config) = functio
Printf.eprintf " stack=%s\n" (show(list) (show(value)) stack);
Printf.eprintf "end\n";
*)
let closure_at_level clo n =
let rec inner = function
| [] -> [], 0
| h :: tl ->
let tl', m = inner tl in
if m = n
then tl', n
else h :: tl, m + 1
in
fst (inner clo)
in
(match insn with
| PUBLIC _ | EXTERN _ -> eval env conf 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'
@ -140,7 +129,7 @@ let rec eval env (((cstack, stack, glob, loc, i, o) as conf) : config) = functio
| CJMP (c, l) -> let x::stack' = stack in
eval env (cstack, stack', glob, loc, i, o) (if (c = "z" && Value.to_int x = 0) || (c = "nz" && Value.to_int x <> 0) then env#labeled l else prg')
| CLOSURE name -> let BEGIN (_, _, _, dgs, level) :: _ = env#labeled name in
| CLOSURE name -> let BEGIN (_, _, _, dgs) :: _ = env#labeled name in
let closure =
Array.of_list @@
List.map (
@ -156,7 +145,7 @@ let rec eval env (((cstack, stack, glob, loc, i, o) as conf) : config) = functio
| CALL (f, n) -> let args, stack' = split n stack in
if env#is_label f
then (
let BEGIN (_, _, _, dgs, level) :: _ = env#labeled f in
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 = [||];
@ -186,7 +175,7 @@ let rec eval env (((cstack, stack, glob, loc, i, o) as conf) : config) = functio
| _ -> invalid_arg "not a closure (or a builtin) in CALL: %s\n" @@ show(value) f
)
| BEGIN (_, _, locals, _, level) -> eval (env#set_level level) (cstack, stack, glob, {loc with locals = Array.init locals (fun _ -> Value.Empty)}, i, o) prg'
| BEGIN (_, _, locals, _) -> eval env (cstack, stack, glob, {loc with locals = Array.init locals (fun _ -> Value.Empty)}, i, o) prg'
| END -> (match cstack with
| (prg', loc')::cstack' -> eval env (cstack', Value.Empty :: stack, glob, loc', i, o) prg'
@ -241,11 +230,8 @@ class indexer prg =
in
let m = make_env M.empty prg in
object
val level = 0
method is_label l = M.mem l m
method labeled l = M.find l m
method set_level l = {< level = l >}
method get_level = level
end
let run p i =
@ -295,7 +281,6 @@ let check_name_and_add names name mut =
args : string list;
body : Expr.t;
scope : funscope;
level : int
} with show
@type context =
@ -312,15 +297,14 @@ let init_scope st = {
closure = []
}
let to_fundef name args body st level = {
let to_fundef name args body st = {
name = name;
args = args;
body = body;
scope = init_scope st;
level = level;
}
let from_fundef fd = (fd.name, fd.args, fd.body, fd.scope.st, fd.level)
let from_fundef fd = (fd.name, fd.args, fd.body, fd.scope.st)
let open_scope c fd =
match c with
@ -365,7 +349,6 @@ object (self : 'self)
val scope = init_scope State.I
val fundefs = Top []
val decls = []
val level = 0
method private import_imports =
let paths = cmd#get_include_paths in
@ -437,15 +420,13 @@ object (self : 'self)
}
>}
method open_fun_scope (name, args, body, st', level) =
method open_fun_scope (name, args, body, st') =
{<
level = level + 1;
fundefs = open_scope fundefs {
name = name;
args = args;
body = body;
scope = {scope with st = st'};
level = level + 1
scope = {scope with st = st'};
};
scope = init_scope (
let rec readdress_to_closure = function
@ -522,7 +503,7 @@ object (self : 'self)
method add_lambda (args : string list) (body : Expr.t) =
let name' = self#fun_internal_name (Printf.sprintf "lambda_%d" lam_index) in
{< fundefs = add_fun fundefs (to_fundef name' args body scope.st level); lam_index = lam_index + 1 >}, name'
{< fundefs = add_fun fundefs (to_fundef name' args body scope.st); lam_index = lam_index + 1 >}, name'
method add_fun (name : string) (args : string list) (m : [`Local | `Extern | `Public | `PublicExtern]) (body : Expr.t) =
let name' = self#fun_internal_name name in
@ -530,7 +511,7 @@ object (self : 'self)
| `Extern -> self
| _ ->
{<
fundefs = add_fun fundefs (to_fundef name' args body scope.st level)
fundefs = add_fun fundefs (to_fundef name' args body scope.st)
>}
method lookup name =
@ -763,7 +744,7 @@ let compile cmd ((imports, infixes), p) =
in
env, true, se @ (if fe then [LABEL lexp] else []) @ [DUP] @ (List.flatten @@ List.rev code) @ [JMP l] @ if fail then [LABEL lfail; FAIL (loc, atr != Expr.Void); JMP l] else []
in
let rec compile_fundef env ((name, args, stmt, st, level) as fd) =
let rec compile_fundef env ((name, args, stmt, st) as fd) =
(* Printf.eprintf "Compile fundef: %s, state=%s\n" name (show(State.t) (show(Value.designation)) st); *)
(* Printf.eprintf "st (inner) = %s\n" (try show(Value.designation) @@ State.eval st "inner" with _ -> " not found"); *)
let env = env#open_fun_scope fd in
@ -775,7 +756,7 @@ let compile cmd ((imports, infixes), p) =
let env, flag, code = compile_expr lend env stmt in
let env, funcode = compile_fundefs [] env in
env#close_fun_scope,
([LABEL name; BEGIN (name, env#nargs, env#nlocals, env#closure, level)] @
([LABEL name; BEGIN (name, env#nargs, env#nlocals, env#closure)] @
code @
(if flag then [LABEL lend] else []) @
[END]) :: funcode
@ -791,7 +772,7 @@ let compile cmd ((imports, infixes), p) =
let env, flag, code = compile_expr lend env p in
let code = if flag then code @ [LABEL lend] else code in
let has_main = List.length code > 0 in
let env, prg = compile_fundefs [if has_main then [LABEL "main"; BEGIN ("main", 0, env#nlocals, [], 0)] @ code @ [END] else []] env in
let env, prg = compile_fundefs [if has_main then [LABEL "main"; BEGIN ("main", 0, env#nlocals, [])] @ code @ [END] else []] env in
let prg = (if has_main then [PUBLIC "main"] else []) @ env#get_decls @ List.flatten prg in
cmd#dump_SM prg;
prg

6
src/X86.ml
View file

@ -151,7 +151,7 @@ let compile cmd env code =
let call env f n =
let closure =
try
let BEGIN (_, _, _, closure, level) :: _ = env#labeled f in closure
let BEGIN (_, _, _, closure) :: _ = env#labeled f in closure
with Not_found -> []
in
match closure with
@ -224,7 +224,7 @@ let compile cmd env code =
let pushr, popr =
List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers 0)
in
let BEGIN (_, _, _, closure, level) :: _ = env#labeled name in
let BEGIN (_, _, _, closure) :: _ = env#labeled name in
let closure_len = List.length closure in
let push_closure =
List.map (fun d -> Push (env#loc d)) @@ List.rev closure
@ -383,7 +383,7 @@ let compile cmd env code =
let x, env = env#pop in
env#set_stack l, [Sar1 x; (*!!!*) Binop ("cmp", L 0, x); CJmp (s, l)]
| BEGIN (f, nargs, nlocals, closure, level) ->
| BEGIN (f, nargs, nlocals, closure) ->
env#assert_empty_stack;
let has_closure = closure <> [] in
let env = env#enter f nlocals has_closure in