Not yet, but almost

regression/orig/test071.log

@@ -0,0 +1 @@
+> 5

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)())

regression/test071.input

@@ -0,0 +1 @@
+5

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; i++) {
     ai = va_arg(args, int);

src/Language.ml

@@ -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

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
+    | CLOSURE (name, dgs)    -> let closure =
-                                 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 (
+                                 then eval env ((prg', loc)::cstack, stack', glob, {args = Array.of_list (List.rev args); locals = [||]; closure = [||]}, i, o) (env#labeled f)
-                                   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)
-                                 )
                                  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
@@ -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,6 +415,22 @@ 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
@@ -503,7 +585,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); 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
@@ -512,7 +594,7 @@ object (self : '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
@@ -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 (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, 
+    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

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
+        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
       | [] ->
@@ -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