Fixed an ugly bug in FCF support. Now for real?

regression/Makefile

@@ -8,9 +8,9 @@ check: $(TESTS)
 
 $(TESTS): %: %.expr
 	@echo $@
-	$(RC) $< && cat $@.input | ./$@ > $@.log && diff $@.log orig/$@.log
 	cat $@.input | $(RC) -i $< > $@.log && diff $@.log orig/$@.log
 	cat $@.input | $(RC) -s $< > $@.log && diff $@.log orig/$@.log
+	$(RC) $< && cat $@.input | ./$@ > $@.log && diff $@.log orig/$@.log
 
 clean:
 	$(RM) test*.log *.s *~ $(TESTS)

src/SM.ml

@@ -22,6 +22,8 @@ open Language
 (* end procedure definition                  *) | END
 (* create a closure                          *) | CLOSURE of string * Value.designation list
 (* proto closure                             *) | PROTO   of string * string
+(* proto closure to a possible constant      *) | PPROTO  of string * string
+(* proto call                                *) | PCALLC  of int  
 (* calls a closure                           *) | CALLC   of int  
 (* calls a function/procedure                *) | CALL    of string * int 
 (* returns from a function                   *) | RET     
@@ -737,14 +739,16 @@ 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)] 
+                                       let env = env#register_call name in
+                                       let env, f, code = add_code (compile_list lcall env args) lcall false [PCALLC (List.length args)]  in
+                                       env, f, PPROTO (name, env#current_function) :: code
                                     | _ ->
                                        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)]
                                )
@@ -830,14 +834,12 @@ let compile cmd ((imports, infixes), p) =
     (* 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    
-    
     (*Printf.eprintf "Lookup: %s\n%!" (try show(Value.designation) @@ snd (env#lookup "inner") with _ -> "no inner..."); *)
-
     let env             = List.fold_left (fun env arg -> env#add_arg arg) env args in 
     let lend, env       = env#get_label in
     let env, flag, code = compile_expr lend env stmt in
     let env, funcode    = compile_fundefs [] env in
-    Printf.eprintf "Function: %s, closure: %s\n%!" name (show(list) (show(Value.designation)) env#closure);
+    (*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)] @
@@ -853,7 +855,24 @@ 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 fix_closures env prg =
+    let rec inner state = function
+    | []                  -> []
+    | PROTO (f, c) :: tl  -> CLOSURE (f, env#get_closure (f, c)) :: inner state tl                             
+    | PPROTO (f, c) :: tl ->
+       (match env#get_closure (f, c) with
+        | []      -> inner (Some f :: state) tl
+        | closure -> CLOSURE (f, closure) :: inner (None :: state) tl
+       )
+    | PCALLC n :: tl ->
+       (match state with
+        | None :: state'   -> CALLC n  :: inner state' tl
+        | Some f :: state' -> CALL (f, n) :: inner state' tl
+       )
+    | insn :: tl -> insn :: inner state tl
+    in
+    inner [] 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
@@ -861,11 +880,15 @@ 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 "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;
+   *)
+  (*Printf.eprintf "Before fix:\n%s\n" (show_prg prg);  *)
   let prg = fix_closures env prg in
   cmd#dump_SM prg;
   prg

src/X86.ml

@@ -155,13 +155,6 @@ let compile cmd env code =
       let y, env = env#allocate in env, code @ [Mov (eax, y)]
     in
     let call env f n =
-      let closure =
-        (*try
-          let BEGIN (_, _, _, closure) :: _ = env#labeled f in closure
-        with Not_found ->*) [] (* !!! *)
-      in
-      match closure with
-      | [] ->
       let f =
         match f.[0] with '.' -> "B" ^ String.sub f 1 (String.length f - 1) | _ -> f
       in
@@ -186,36 +179,6 @@ let compile cmd env code =
         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)]
-      | _ ->
-         let pushr, popr =
-           List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers n)
-         in
-         let pushr, popr = env#save_closure @ pushr, env#rest_closure @ popr in      
-         let rec push_args env acc = function
-           | 0 -> env, acc
-           | n -> let x, env = env#pop in
-                  push_args env ((Push x)::acc) (n-1)
-         in         
-         let env, push_args = push_args env [] n in
-         let push_args      = List.rev push_args  in         
-         let closure_len    = List.length closure in 
-         let push_closure =
-           List.map (fun d -> Push (env#loc d)) @@ List.rev closure
-         in
-         let s, env = env#allocate in             
-         (env, pushr @
-               push_args @
-               push_closure @
-              [Push (M ("$" ^ f));
-               Push (L closure_len);
-               Call "Bclosure";
-               Binop ("+", L (word_size * (closure_len + 2)), esp); 
-               Mov (eax, edx);
-               CallI edx;
-               Binop ("+", L (word_size * List.length push_args), esp);
-               Mov (eax, s)
-               ] @
-               List.rev popr) 
     in
     match scode with
     | [] -> env, []