st/lama_byterun
1
0
Fork 0
mirror of https://github.com/ProgramSnail/Lama.git synced 2025-12-05 22:38:44 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

Not yet, but almost

Browse source
This commit is contained in:
Dmitry Boulytchev 2019-12-29 01:12:40 +03:00
parent 02dee40262
commit 39437712c7
7 changed files with 159 additions and 50 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -0,0 +1 @@
> 5

9
regression/test071.expr Normal file
View file

@ -0,0 +1,9 @@
fun f (x) {
fun g () {return x}
fun h () {return g}
return g
}
local n = read ();
write (f(5)())

1
regression/test071.input Normal file
View file

@ -0,0 +1 @@
5

2
runtime/runtime.c
View file

@ -434,7 +434,7 @@ extern void* Bclosure (int n, void *entry, ...) {
r->tag = CLOSURE_TAG | ((n + 1) << 3);
((void**) r->contents)[0] = entry;
va_start(args, n);
va_start(args, entry); // n);
for (i = 0; i<n; i++) {
ai = va_arg(args, int);

4
src/Language.ml
View file

@ -29,7 +29,7 @@ module Value =
| Arg of int
| Access of int
| Fun of string
with show,html
with show, html
@type ('a, 'b) t =
| Empty
@ -42,7 +42,7 @@ module Value =
| Closure of string list * 'a * 'b
| FunRef of string * string list * 'a * int
| Builtin of string
with show,html
with show, html
let to_int = function
| Int n -> n

167
src/SM.ml
View file

@ -20,7 +20,8 @@ open Language
(* conditional jump *) | CJMP of string * string
(* begins procedure definition *) | BEGIN of string * int * int * Value.designation list
(* end procedure definition *) | END
(* create a closure *) | CLOSURE of string
(* create a closure *) | CLOSURE of string * Value.designation list
(* proto closure *) | PROTO of string * string
(* calls a closure *) | CALLC of int
(* calls a function/procedure *) | CALL of string * int
(* returns from a function *) | RET
@ -129,8 +130,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) :: _ = env#labeled name in
let closure =
| CLOSURE (name, dgs) -> let closure =
Array.of_list @@
List.map (
function
@ -144,25 +144,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) :: _ = 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)
)
then eval env ((prg', loc)::cstack, stack', glob, {args = Array.of_list (List.rev args); locals = [||]; 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
@ -175,7 +157,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, _) -> eval env (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'
@ -288,6 +270,8 @@ let check_name_and_add names name mut =
| Item of fundef * fundef list * context
with show
(* @type funinfo = {parent : string; closure : Value.designation list} with show *)
let init_scope st = {
st = st;
arg_index = 0;
@ -341,6 +325,88 @@ let rec propagate_acc (Item (p, fds, up) as item) name =
}}, fds, up'), Value.Access index
| other -> item, other
module FC = Map.Make (struct type t = string * string let compare = Pervasives.compare end)
class funinfo =
object (self : 'self)
val funtree = (Pervasives.ref M.empty : string M.t ref)
val closures = (Pervasives.ref M.empty : Value.designation list M.t ref)
val functx = (Pervasives.ref FC.empty : Value.designation list FC.t ref)
method show_funinfo =
Printf.sprintf "funtree: %s\nclosures: %s\ncontexts: %s\n"
(show(list) (fun (x, y) -> x ^ ": " ^ y) @@ M.bindings !funtree)
(show(list) (fun (x, y) -> x ^ ": " ^ show(list) (show(Value.designation)) y) @@ M.bindings !closures)
(show(list) (fun ((x, y), v) -> "(" ^ x ^ ", " ^ y ^ ")" ^ show(list) (show(Value.designation)) v) @@ FC.bindings !functx)
method lookup_closure p = FC.find p !functx
method register_call f c = functx := FC.add (f, c) [] !functx; self
method register_fun f p = funtree := M.add f p !funtree; self
method register_closure f c = closures := M.add f c !closures; self
method private get_parent f = M.find f !funtree
method private get_closure f = M.find f !closures
method private propagate_for_call (f, c) =
try
let fp = self#get_parent f in
let rec find_path current =
if fp = current
then []
else find_path (self#get_parent current) @ [current]
in
let path = find_path c in
let changed = Pervasives.ref false in
let rec propagate_downwards current_closure = function
| [] -> current_closure
| f :: tl ->
let fclosure = self#get_closure f in
let delta = Pervasives.ref fclosure in
let index = Pervasives.ref (List.length fclosure) in
let added = Pervasives.ref false in
let add_to_closure loc =
added := true;
delta := !delta @ [loc];
let loc' = Value.Access !index in
incr index;
loc'
in
let next_closure =
List.map
(fun loc ->
let rec find_index i = function
| [] -> raise Not_found
| loc' :: tl ->
if loc' = loc
then Value.Access i
else find_index (i+1) tl
in
try find_index 0 fclosure with Not_found -> add_to_closure loc
)
current_closure
in
if !added then (
changed := true;
closures := M.add f !delta !closures
);
propagate_downwards next_closure tl
in
let closure = propagate_downwards (self#get_closure f) path in
functx := FC.add (f, c) closure !functx;
!changed
with Not_found -> false
method propagate_closures =
while List.fold_left (fun flag (call, _) -> flag || self#propagate_for_call call) false @@ FC.bindings !functx
do () done;
self
end
class env cmd imports =
object (self : 'self)
val label_index = 0
@ -349,7 +415,23 @@ object (self : 'self)
val scope = init_scope State.I
val fundefs = Top []
val decls = []
val funinfo = new funinfo
method show_funinfo = funinfo#show_funinfo
method get_closure p = try funinfo#lookup_closure p with Not_found -> []
method propagate_closures = {< funinfo = funinfo#propagate_closures >}
method register_call f = {< funinfo = funinfo#register_call f self#current_function >}
method register_fun f = {< funinfo = funinfo#register_fun f self#current_function >}
method register_closure f = {< funinfo = funinfo#register_closure f self#closure >}
method current_function =
match fundefs with Top _ -> "main" | Item (fd, _, _) -> fd.name
method private import_imports =
let paths = cmd#get_include_paths in
let env = List.fold_left
@ -503,16 +585,16 @@ 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); lam_index = lam_index + 1 >}, name'
{< fundefs = add_fun fundefs (to_fundef name' args body scope.st); lam_index = lam_index + 1 >} # register_fun name', 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
match m with
| `Extern -> self
| _ ->
{<
{<
fundefs = add_fun fundefs (to_fundef name' args body scope.st)
>}
>} # register_fun name'
method lookup name =
match State.eval scope.st name with
@ -535,7 +617,7 @@ object (self : 'self)
| fds, None -> None
| fds, Some fd -> Some ({< fundefs = fds >}, from_fundef fd)
method closure = List.rev scope.closure
method closure = List.rev scope.closure
end
@ -621,7 +703,7 @@ let compile cmd ((imports, infixes), p) =
and compile_expr l env = function
| Expr.Lambda (args, b) ->
let env, name = env#add_lambda args b in
env, false, [CLOSURE name]
env#register_call name, false, [PROTO (name, env#current_function)]
| Expr.Scope (ds, e) ->
let env = env#push_scope in
@ -646,7 +728,7 @@ let compile cmd ((imports, infixes), p) =
add_code (compile_expr ls env s) ls false [DROP]
| Expr.ElemRef (x, i) -> compile_list l env [x; i]
| Expr.Var x -> let env, acc = env#lookup x in env, false, [match acc with Value.Fun name -> CLOSURE name | _ -> LD acc]
| Expr.Var x -> let env, acc = env#lookup x in (match acc with Value.Fun name -> env#register_call name, false, [PROTO (name, env#current_function)] | _ -> env, false, [LD acc])
| Expr.Ref x -> let env, acc = env#lookup x in env, false, [LDA acc]
| Expr.Const n -> env, false, [CONST n]
| Expr.String s -> env, false, [STRING s]
@ -655,14 +737,14 @@ let compile cmd ((imports, infixes), p) =
| Expr.Call (f, args) -> let lcall, env = env#get_label in
(match f with
| Expr.Var name ->
(*| 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 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)]
)
@ -755,11 +837,15 @@ let compile cmd ((imports, infixes), p) =
let lend, env = env#get_label in
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)] @
code @
(if flag then [LABEL lend] else []) @
[END]) :: funcode
Printf.eprintf "Function: %s, closure: %s\n%!" name (show(list) (show(Value.designation)) env#closure);
let env = env#register_closure name in
let code =
([LABEL name; BEGIN (name, env#nargs, env#nlocals, env#closure)] @
code @
(if flag then [LABEL lend] else []) @
[END]) :: funcode
in
env#close_fun_scope, code
and compile_fundefs acc env =
match env#next_definition with
| None -> env, acc
@ -767,6 +853,7 @@ let compile cmd ((imports, infixes), p) =
let env, code = compile_fundef env def in
compile_fundefs (acc @ code) env
in
let rec fix_closures env prg = List.map (function PROTO (f, c) -> CLOSURE (f, env#get_closure (f, c)) | insn -> insn) prg in
let env = new env cmd imports in
let lend, env = env#get_label in
let env, flag, code = compile_expr lend env p in
@ -774,5 +861,11 @@ let compile cmd ((imports, infixes), p) =
let has_main = List.length code > 0 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
Printf.eprintf "Before propagating closures:\n";
Printf.eprintf "%s\n%!" env#show_funinfo;
let env = env#propagate_closures in
Printf.eprintf "After propagating closures:\n";
Printf.eprintf "%s\n%!" env#show_funinfo;
let prg = fix_closures env prg in
cmd#dump_SM prg;
prg

25
src/X86.ml
View file

@ -17,6 +17,7 @@ let word_size = 4;;
@type opnd =
| R of int (* hard register *)
| S of int (* a position on the hardware stack *)
| C (* a saved closure *)
| M of string (* a named memory location *)
| L of int (* an immediate operand *)
| I of int * opnd (* an indirect operand with offset *)
@ -74,6 +75,7 @@ let show instr =
in
let rec opnd = function
| R i -> regs.(i)
| C -> "4(%ebp)"
| S i -> if i >= 0
then Printf.sprintf "-%d(%%ebp)" ((i+1) * word_size)
else Printf.sprintf "%d(%%ebp)" (8+(-i-1) * word_size)
@ -143,16 +145,20 @@ let compile cmd env code =
let env, pushs = push_args env [] n in
let pushs = List.rev pushs in
let closure, env = env#pop in
let call_closure = [Mov (closure, edx); CallI closure] in
env, pushr @ pushs @ call_closure @ [Binop ("+", L (word_size * List.length pushs), esp)] @ (List.rev popr)
let call_closure =
if on_stack closure
then [Mov (closure, edx); Mov (edx, eax); CallI eax]
else [Mov (closure, edx); CallI closure]
in
env, pushr @ pushs @ call_closure @ [Binop ("+", L (word_size * List.length pushs), esp)] @ (List.rev popr)
in
let y, env = env#allocate in env, code @ [Mov (eax, y)]
in
let call env f n =
let closure =
try
(*try
let BEGIN (_, _, _, closure) :: _ = env#labeled f in closure
with Not_found -> []
with Not_found ->*) [] (* !!! *)
in
match closure with
| [] ->
@ -177,7 +183,7 @@ let compile cmd env code =
| "Bsta" -> pushs
| _ -> List.rev pushs
in
env, pushr @ pushs @ [Call f; Binop ("+", L (word_size * List.length pushs), esp)] @ (List.rev popr)
env, pushr @ pushs @ [Call f; Binop ("+", L (word_size * List.length pushs), esp)] @ (List.rev popr)
in
let y, env = env#allocate in env, code @ [Mov (eax, y)]
| _ ->
@ -209,7 +215,7 @@ let compile cmd env code =
Binop ("+", L (word_size * List.length push_args), esp);
Mov (eax, s)
] @
List.rev popr)
List.rev popr)
in
match scode with
| [] -> env, []
@ -220,11 +226,10 @@ let compile cmd env code =
| PUBLIC name -> env#register_public name, []
| EXTERN name -> env#register_extern name, []
| CLOSURE name ->
| CLOSURE (name, closure) ->
let pushr, popr =
List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers 0)
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
@ -238,7 +243,7 @@ let compile cmd env code =
Call "Bclosure";
Binop ("+", L (word_size * (closure_len + 2)), esp);
Mov (eax, s)] @
List.rev popr)
List.rev popr @ env#reload_closure)
| CONST n ->
let s, env' = env#allocate in
@ -521,7 +526,7 @@ class env prg =
if has_closure then [Pop edx] else []
method reload_closure =
if has_closure then [Mov (S 0, edx)] else []
if has_closure then [Mov (C (*S 0*), edx)] else []
method fname = fname