diff --git a/regression/orig/test071.log b/regression/orig/test071.log new file mode 100644 index 000000000..3af13cd74 --- /dev/null +++ b/regression/orig/test071.log @@ -0,0 +1 @@ +> 5 diff --git a/regression/test071.expr b/regression/test071.expr new file mode 100644 index 000000000..5f615d8c3 --- /dev/null +++ b/regression/test071.expr @@ -0,0 +1,9 @@ +fun f (x) { + fun g () {return x} + fun h () {return g} + return g +} + +local n = read (); + +write (f(5)()) \ No newline at end of file diff --git a/regression/test071.input b/regression/test071.input new file mode 100644 index 000000000..7ed6ff82d --- /dev/null +++ b/regression/test071.input @@ -0,0 +1 @@ +5 diff --git a/runtime/runtime.c b/runtime/runtime.c index ec18b5fb0..d75b8fdad 100644 --- a/runtime/runtime.c +++ b/runtime/runtime.c @@ -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 diff --git a/src/SM.ml b/src/SM.ml index 4ba40887e..fae5df5d0 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -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 diff --git a/src/X86.ml b/src/X86.ml index 859d596b6..5afb61378 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -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