Preallocation des fermetures pour les fonctions closes

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@2249 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

2 files changed, 50 insertions, 42 deletions

diff --git a/asmcomp/all.ml b/asmcomp/all.ml
deleted file mode 100644
index b8347e925..000000000
--- a/asmcomp/all.ml
+++ /dev/null
@@ -1,42 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
-(*                                                                     *)
-(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
-(*  Automatique.  Distributed only by permission.                      *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-#directory "../utils";;
-#directory "../typing";;
-#load "../utils/misc.cmo";;
-#load "../utils/tbl.cmo";;
-#load "../typing/ident.cmo";;
-#load "arch.cmo";;
-#load "cmm.cmo";;
-#load "printcmm.cmo";;
-#load "reg.cmo";;
-#load "mach.cmo";;
-#load "proc.cmo";;
-(*********
-#load "printmach.cmo";;
-#load "selection.cmo";;
-#load "sequence.cmo";;
-#load "liveness.cmo";;
-#load "spill.cmo";;
-#load "split.cmo";;
-#load "interf.cmo";;
-#load "coloring.cmo";;
-#load "reload.cmo";;
-#load "linearize.cmo";;
-#load "emitaux.cmo";;
-#load "emit.cmo";;
-#load "parsecmmaux.cmo";;
-#load "parsecmm.cmo";;
-#load "lexcmm.cmo";;
-#load "codegen.cmo";;
-***********)
diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
index 7843100df..430aa02fd 100644
--- a/asmcomp/cmmgen.ml
+++ b/asmcomp/cmmgen.ml
@@ -381,6 +381,11 @@ let transl_constant = function
           lbl
       in Cconst_symbol lbl
 
+(* Translate constant closures *)
+
+let constant_closures =
+  ref ([] : (string * (string * int * Ident.t list * ulambda) list) list)
+
 (* Translate an expression *)
 
 let functions = (Queue.create() : (string * Ident.t list * ulambda) Queue.t)
@@ -390,6 +395,14 @@ let rec transl = function
       Cvar id
   | Uconst sc ->
       transl_constant sc
+  | Uclosure(fundecls, []) ->
+      let lbl = new_const_symbol() in
+      constant_closures := (lbl, fundecls) :: !constant_closures;
+      List.iter
+        (fun (label, arity, params, body) ->
+            Queue.add (label, params, body) functions)
+        fundecls;
+      Cconst_symbol lbl
   | Uclosure(fundecls, clos_vars) ->
       let block_size =
         fundecls_size fundecls + List.length clos_vars in
@@ -952,6 +965,38 @@ and emit_string_constant s cont =
   let n = size_int - 1 - (String.length s) mod size_int in
   Cstring s :: Cskip n :: Cint8 n :: cont
 
+(* Emit constant closures *)
+
+let emit_constant_closure symb fundecls cont =
+  match fundecls with
+    [] -> assert false
+  | (label, arity, params, body) :: remainder ->
+      let rec emit_others pos = function
+        [] -> cont
+      | (label, arity, params, body) :: rem ->
+          if arity = 1 then
+            Cint(infix_header pos) ::
+            Csymbol_address label ::
+            Cint(Nativeint.from 3) ::
+            emit_others (pos + 3) rem
+          else
+            Cint(infix_header pos) ::
+            Csymbol_address(curry_function arity) ::
+            Cint(Nativeint.from (arity lsl 1 + 1)) ::
+            Csymbol_address label ::
+            emit_others (pos + 4) rem in
+      Cint(closure_header (fundecls_size fundecls)) ::
+      Cdefine_symbol symb ::
+      if arity = 1 then
+        Csymbol_address label ::
+        Cint(Nativeint.from 3) ::
+        emit_others 3 remainder
+      else
+        Csymbol_address(curry_function arity) ::
+        Cint(Nativeint.from (arity lsl 1 + 1)) ::
+        Csymbol_address label ::
+        emit_others 4 remainder
+
 (* Emit all structured constants *)
 
 let emit_all_constants cont =
@@ -960,6 +1005,11 @@ let emit_all_constants cont =
     (fun cst lbl -> c := Cdata(emit_constant lbl cst []) :: !c)
     structured_constants;
   Hashtbl.clear structured_constants;
+  List.iter
+    (fun (symb, fundecls) ->
+        c := Cdata(emit_constant_closure symb fundecls []) :: !c)
+    !constant_closures;
+  constant_closures := [];
   !c
 
 (* Translate a compilation unit *)