Merge pull request ocaml#422 from chambart/flambda_prereq-preallocated_blocks

GPR#422: Change the interface of Cmmgen to accept preallocated blocks and constants as argument

Author: mshinwell

asmcomp/asmgen.ml

@@ -125,10 +125,19 @@ let compile_unit ~source_provenance asm_filename keep_asm obj_filename gen =
     raise exn
 
 let gen_implementation ?toplevel ~source_provenance ppf (size, lam) =
+  let main_module_block =
+    {
+      Clambda.symbol = Compilenv.make_symbol None;
+      exported = true;
+      tag = 0;
+      size;
+    }
+  in
   Emit.begin_assembly ();
   Timings.(time (Clambda source_provenance)) (Closure.intro size) lam
   ++ clambda_dump_if ppf
-  ++ Timings.(time (Cmm source_provenance)) (Cmmgen.compunit size)
+  ++ Timings.(time (Cmm source_provenance))
+       (fun clam -> Cmmgen.compunit (clam, [main_module_block], []))
   ++ Timings.(time (Compile_phrases source_provenance))
        (List.iter (compile_phrase ppf))
   ++ (fun () -> ());

asmcomp/clambda.ml

@@ -89,6 +89,21 @@ type value_approximation =
   | Value_const of uconstant
   | Value_global_field of string * int
 
+(* Preallocated globals *)
+
+type preallocated_block = {
+  symbol : string;
+  exported : bool;
+  tag : int;
+  size : int;
+}
+
+type preallocated_constant = {
+  symbol : string;
+  exported : bool;
+  definition : ustructured_constant;
+}
+
 (* Comparison functions for constants.  We must not use Pervasives.compare
    because it compares "0.0" and "-0.0" equal.  (PR#6442) *)
 

asmcomp/clambda.mli

@@ -95,3 +95,16 @@ val compare_structured_constants:
         ustructured_constant -> ustructured_constant -> int
 val compare_constants:
         uconstant -> uconstant -> int
+
+type preallocated_block = {
+  symbol : string;
+  exported : bool;
+  tag : int;
+  size : int;
+}
+
+type preallocated_constant = {
+  symbol : string;
+  exported : bool;
+  definition : ustructured_constant;
+}

asmcomp/cmmgen.ml

@@ -740,8 +740,10 @@ let transl_structured_constant cst =
 
 (* Translate constant closures *)
 
+type is_global = Global | Not_global
+
 let constant_closures =
-  ref ([] : (string * ufunction list * uconstant list) list)
+  ref ([] : ((string * is_global) * ufunction list * uconstant list) list)
 
 (* Boxed integers *)
 
@@ -1423,7 +1425,7 @@ let rec transl env e =
       transl_constant sc
   | Uclosure(fundecls, []) ->
       let lbl = Compilenv.new_const_symbol() in
-      constant_closures := (lbl, fundecls, []) :: !constant_closures;
+      constant_closures := ((lbl, Not_global), fundecls, []) :: !constant_closures;
       List.iter (fun f -> Queue.add f functions) fundecls;
       Cconst_symbol lbl
   | Uclosure(fundecls, clos_vars) ->
@@ -2426,14 +2428,19 @@ let rec transl_all_functions already_translated cont =
   with Queue.Empty ->
     cont, already_translated
 
+let cdefine_symbol (symb, global) =
+  match global with
+  | Global -> [Cglobal_symbol symb; Cdefine_symbol symb]
+  | Not_global -> [Cdefine_symbol symb]
+
 (* Emit structured constants *)
 
 let rec emit_structured_constant symb cst cont =
   let emit_block white_header symb cont =
     (* Headers for structured constants must be marked black in case we
        are in no-naked-pointers mode.  See [caml_darken]. *)
     let black_header = Nativeint.logor white_header caml_black in
-    Cint black_header :: Cdefine_symbol symb :: cont
+    Cint black_header :: cdefine_symbol symb @ cont
   in
   match cst with
   | Uconst_float s->
@@ -2457,7 +2464,8 @@ let rec emit_structured_constant symb cst cont =
       emit_block (floatarray_header (List.length fields)) symb
         (Misc.map_end (fun f -> Cdouble f) fields cont)
   | Uconst_closure(fundecls, lbl, fv) ->
-      constant_closures := (lbl, fundecls, fv) :: !constant_closures;
+      assert(lbl = fst symb);
+      constant_closures := (symb, fundecls, fv) :: !constant_closures;
       List.iter (fun f -> Queue.add f functions) fundecls;
       cont
 
@@ -2518,7 +2526,7 @@ let emit_constant_closure symb fundecls clos_vars cont =
             emit_others (pos + 4) rem in
       Cint(black_closure_header (fundecls_size fundecls
                                  + List.length clos_vars)) ::
-      Cdefine_symbol symb ::
+      cdefine_symbol symb @
       if f1.arity = 1 || f1.arity = 0 then
         Csymbol_address f1.label ::
         cint_const f1.arity ::
@@ -2531,24 +2539,26 @@ let emit_constant_closure symb fundecls clos_vars cont =
 
 (* Emit all structured constants *)
 
-let emit_all_constants cont =
+let emit_constants cont (constants:Clambda.preallocated_constant list) =
   let c = ref cont in
   List.iter
-    (fun (lbl, global, cst) ->
-       let cst = emit_structured_constant lbl cst [] in
-       let cst = if global then
-         Cglobal_symbol lbl :: cst
-       else cst in
+    (fun { symbol = lbl; exported; definition = cst } ->
+       let global = if exported then Global else Not_global in
+       let cst = emit_structured_constant (lbl, global) cst [] in
          c:= Cdata(cst):: !c)
-    (Compilenv.structured_constants());
+    constants;
   List.iter
     (fun (symb, fundecls, clos_vars) ->
         c := Cdata(emit_constant_closure symb fundecls clos_vars []) :: !c)
     !constant_closures;
   constant_closures := [];
-  Compilenv.clear_structured_constants ();
   !c
 
+let emit_all_constants cont =
+  let constants = Compilenv.structured_constants () in
+  Compilenv.clear_structured_constants ();
+  emit_constants cont constants
+
 let transl_all_functions_and_emit_all_constants cont =
   let rec aux already_translated cont =
     if Compilenv.structured_constants () = [] &&
@@ -2571,17 +2581,10 @@ let emit_module_roots_table ~symbols cont =
         [Cint 0n])
   :: cont
 
-(* Translate a compilation unit *)
+(* Build preallocated blocks (used for Flambda [Initialize_symbol]
+   constructs, and Clambda global module) *)
 
-let compunit size ulam =
-  let glob = Compilenv.make_symbol None in
-  let init_code = transl empty_env ulam in
-  let c1 = [Cfunction {fun_name = Compilenv.make_symbol (Some "entry");
-                       fun_args = [];
-                       fun_body = init_code; fun_fast = false;
-                       fun_dbg  = Debuginfo.none }] in
-  let c2 = transl_all_functions_and_emit_all_constants c1 in
-  let c3 = emit_module_roots_table ~symbols:[glob] c2 in
+let preallocate_block cont { Clambda.symbol; exported; tag; size } =
   let space =
     (* These words will be registered as roots and as such must contain
        valid values, in case we are in no-naked-pointers mode.  Likewise
@@ -2591,9 +2594,35 @@ let compunit size ulam =
       (Array.init size (fun _index ->
         Cint (Nativeint.of_int 1 (* Val_unit *))))
   in
-  Cdata ([Cint(black_block_header 0 size);
-         Cglobal_symbol glob;
-         Cdefine_symbol glob] @ space) :: c3
+  let data =
+    Cint(black_block_header tag size) ::
+    if exported then
+      Cglobal_symbol symbol ::
+      Cdefine_symbol symbol :: space
+    else
+      Cdefine_symbol symbol :: space
+  in
+  Cdata data :: cont
+
+let emit_preallocated_blocks preallocated_blocks cont =
+  let symbols =
+    List.map (fun ({ Clambda.symbol }:Clambda.preallocated_block) -> symbol)
+      preallocated_blocks
+  in
+  let c1 = emit_module_roots_table ~symbols cont in
+  List.fold_left preallocate_block c1 preallocated_blocks
+
+(* Translate a compilation unit *)
+
+let compunit (ulam, preallocated_blocks, constants) =
+  let init_code = transl empty_env ulam in
+  let c1 = [Cfunction {fun_name = Compilenv.make_symbol (Some "entry");
+                       fun_args = [];
+                       fun_body = init_code; fun_fast = false;
+                       fun_dbg  = Debuginfo.none }] in
+  let c2 = emit_constants c1 constants in
+  let c3 = transl_all_functions_and_emit_all_constants c2 in
+  emit_preallocated_blocks preallocated_blocks c3
 
 (*
 CAMLprim value caml_cache_public_method (value meths, value tag, value *cache)
@@ -2938,8 +2967,7 @@ let reference_symbols namelist =
   Cdata(List.map mksym namelist)
 
 let global_data name v =
-  Cdata(Cglobal_symbol name ::
-          emit_structured_constant name
+  Cdata(emit_structured_constant (name, Global)
           (Uconst_string (Marshal.to_string v [])) [])
 
 let globals_map v = global_data "caml_globals_map" v
@@ -2979,9 +3007,8 @@ let predef_exception i name =
   let symname = "caml_exn_" ^ name in
   let cst = Uconst_string name in
   let label = Compilenv.new_const_symbol () in
-  let cont = emit_structured_constant label cst [] in
-  Cdata(Cglobal_symbol symname ::
-        emit_structured_constant symname
+  let cont = emit_structured_constant (label, Not_global) cst [] in
+  Cdata(emit_structured_constant (symname, Global)
           (Uconst_block(Obj.object_tag,
                        [
                          Uconst_ref(label, Some cst);

asmcomp/cmmgen.mli

@@ -12,7 +12,11 @@
 
 (* Translation from closed lambda to C-- *)
 
-val compunit: int -> Clambda.ulambda -> Cmm.phrase list
+val compunit:
+    Clambda.ulambda
+    * Clambda.preallocated_block list
+    * Clambda.preallocated_constant list
+  -> Cmm.phrase list
 
 val apply_function: int -> Cmm.phrase
 val send_function: int -> Cmm.phrase

asmcomp/compilenv.ml

@@ -294,9 +294,13 @@ let clear_structured_constants () =
 
 let structured_constants () =
   List.map
-    (fun (lbl, cst) ->
-       (lbl, Hashtbl.mem exported_constants lbl, cst)
-    ) (!structured_constants).strcst_all
+    (fun (symbol, definition) ->
+       {
+         Clambda.symbol;
+         exported = Hashtbl.mem exported_constants symbol;
+         definition;
+       })
+    (!structured_constants).strcst_all
 
 (* Error report *)
 

asmcomp/compilenv.mli

@@ -65,7 +65,7 @@ val new_structured_constant:
   shared:bool -> (* can be shared with another structually equal constant *)
   string
 val structured_constants:
-  unit -> (string * bool * Clambda.ustructured_constant) list
+  unit -> Clambda.preallocated_constant list
 val clear_structured_constants: unit -> unit
 val add_exported_constant: string -> unit