cslopt: modif. initialisation des structures toplevel

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

bytecomp/translmod.ml

@@ -116,7 +116,7 @@ and transl_structure fields cc = function
   | Tstr_eval expr :: rem ->
       Lsequence(transl_exp expr, transl_structure fields cc rem)
   | Tstr_value(rec_flag, pat_expr_list) :: rem ->
-      let ext_fields = let_bound_idents pat_expr_list @ fields in
+      let ext_fields = rev_let_bound_idents pat_expr_list @ fields in
       transl_let rec_flag pat_expr_list (transl_structure ext_fields cc rem)
   | Tstr_primitive(id, descr) :: rem ->
       begin match descr.val_prim with
@@ -145,6 +145,100 @@ let transl_implementation module_name str cc =
   let module_id = Ident.new_persistent module_name in
   Lprim(Psetglobal module_id, [transl_structure [] cc str])
 
+(* A variant of transl_structure used to compile toplevel structure definitions
+   for the native-code compiler. Store the defined values in the fields
+   of the global as soon as they are defined, in order to reduce register
+   pressure.
+   "map" is a table from idents to (position in global block, coercion). *)
+
+let rec transl_store_structure glob map = function
+    [] ->
+      lambda_unit
+  | Tstr_eval expr :: rem ->
+      Lsequence(transl_exp expr, transl_store_structure glob map rem)
+  | Tstr_value(rec_flag, pat_expr_list) :: rem ->
+      transl_let rec_flag pat_expr_list
+        (store_idents glob map (let_bound_idents pat_expr_list)
+          (transl_store_structure glob map rem))
+  | Tstr_primitive(id, descr) :: rem ->
+      begin match descr.val_prim with
+        None -> ()
+      | Some p -> primitive_declarations :=
+                    p.Primitive.prim_name :: !primitive_declarations
+      end;
+      store_ident glob map id (transl_store_structure glob map rem)
+  | Tstr_type(decls) :: rem ->
+      transl_store_structure glob map rem
+  | Tstr_exception(id, decl) :: rem ->
+      Llet(Strict, id, transl_exception id decl,
+           store_ident glob map id (transl_store_structure glob map rem))
+  | Tstr_module(id, modl) :: rem ->
+      Llet(Strict, id, transl_module Tcoerce_none modl,
+           store_ident glob map id (transl_store_structure glob map rem))
+  | Tstr_modtype(id, decl) :: rem ->
+      transl_store_structure glob map rem
+  | Tstr_open path :: rem ->
+      transl_store_structure glob map rem
+
+and store_ident glob map id cont =
+  try
+    let (pos, cc) = Ident.find_same id map in
+    let init_val =
+      match cc with
+        Tcoerce_primitive p -> transl_primitive p
+      | _ -> apply_coercion cc (Lvar id) in
+    Lsequence
+     (Lprim(Psetfield(pos, false), [Lprim(Pgetglobal glob, []); init_val]),
+      cont)
+  with Not_found ->
+    cont
+
+and store_idents glob map idlist cont =
+  List.fold_right (store_ident glob map) idlist cont
+
+(* Build the list of value identifiers defined by a toplevel structure *)
+
+let rec defined_idents = function
+    [] -> []
+  | Tstr_eval expr :: rem -> defined_idents rem
+  | Tstr_value(rec_flag, pat_expr_list) :: rem ->
+      let_bound_idents pat_expr_list @ defined_idents rem
+  | Tstr_primitive(id, descr) :: rem -> defined_idents rem
+  | Tstr_type decls :: rem -> defined_idents rem
+  | Tstr_exception(id, decl) :: rem -> id :: defined_idents rem
+  | Tstr_module(id, modl) :: rem -> id :: defined_idents rem
+  | Tstr_modtype(id, decl) :: rem -> defined_idents rem
+  | Tstr_open path :: rem -> defined_idents rem
+
+(* Distribute a coercion over the list of value identifiers built above. *)
+
+let distribute_coercion restr idlist =
+  match restr with
+    Tcoerce_none ->
+      List.map (fun id -> (id, Tcoerce_none)) idlist
+  | Tcoerce_structure pos_cc_list ->
+      let idarray = Array.of_list idlist in
+      List.map (fun (pos, cc) -> (idarray.(pos), cc)) pos_cc_list
+  | _->
+      fatal_error "Translmod.distribute_coercion"
+
+(* Transform the list (id, coercion) built above into a table
+   id -> (pos, coercion). *)
+
+let rec build_ident_map pos = function
+    [] -> Ident.empty
+  | (id, cc) :: rem -> Ident.add id (pos, cc) (build_ident_map (pos+1) rem)
+
+(* Compile an implementation using transl_store_structure 
+   (for the native-code compiler). *)
+
+let transl_store_implementation module_name str cc =
+  primitive_declarations := [];
+  let module_id = Ident.new_persistent module_name in
+  let id_cc_list = distribute_coercion cc (defined_idents str) in
+  let map = build_ident_map 0 id_cc_list in
+  (List.length id_cc_list, transl_store_structure module_id map str)
+
 (* Compile a sequence of expressions *)
 
 let rec make_sequence fn = function
@@ -159,9 +253,11 @@ let transl_toplevel_item = function
       transl_exp expr
   | Tstr_value(rec_flag, pat_expr_list) ->
       let idents = let_bound_idents pat_expr_list in
+      let lam =
+        transl_let rec_flag pat_expr_list
+          (make_sequence (fun id -> Lprim(Psetglobal id, [Lvar id])) idents) in
       List.iter Ident.make_global idents;
-      transl_let rec_flag pat_expr_list
-        (make_sequence (fun id -> Lprim(Psetglobal id, [Lvar id])) idents)
+      lam
   | Tstr_primitive(id, descr) ->
       lambda_unit
   | Tstr_type(decls) ->

bytecomp/translmod.mli

@@ -18,6 +18,8 @@ open Typedtree
 open Lambda
 
 val transl_implementation: string -> structure -> module_coercion -> lambda
+val transl_store_implementation:
+      string -> structure -> module_coercion -> int * lambda
 val transl_toplevel_definition: structure -> lambda
 
 val primitive_declarations: string list ref

driver/optcompile.ml

@@ -86,11 +86,12 @@ let implementation sourcefile =
         (Tcoerce_none, crc)
       end in
     Compilenv.reset modulename crc;
-    Asmgen.compile_implementation prefixname
+    let (compunit_size, lam) =
+      Translmod.transl_store_implementation modulename str coercion in
+    Asmgen.compile_implementation prefixname compunit_size
       (print_if Clflags.dump_lambda Printlambda.lambda
         (Simplif.simplify_lambda
-          (print_if Clflags.dump_rawlambda Printlambda.lambda
-            (Translmod.transl_implementation modulename str coercion))));
+          (print_if Clflags.dump_rawlambda Printlambda.lambda lam)));
     Compilenv.save_unit_info (prefixname ^ ".cmx");
     close_in ic
   with x ->