Ajout de asmlibrarian, MAJ de asmlink.

clambda, closure: meilleure detection des fonctions closes.
selection: correction de storechunk.
spill: spill retarde dans les conditionnelles.


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

15 files changed, 240 insertions, 62 deletions

diff --git a/asmcomp/asmlibrarian.ml b/asmcomp/asmlibrarian.ml
new file mode 100644
index 000000000..012e270ef
--- /dev/null
+++ b/asmcomp/asmlibrarian.ml
@@ -0,0 +1,46 @@
+(* Build libraries of .cmx files *)
+
+open Misc
+open Config
+open Compilenv
+
+type error =
+    File_not_found of string
+  | Archiver_error
+
+exception Error of error
+
+let read_info name =
+  let filename =
+    try
+      find_in_path !load_path name
+    with Not_found ->
+      raise(Error(File_not_found name)) in
+  (Filename.chop_suffix filename ".cmx" ^ ".o",
+   Compilenv.read_unit_info filename)
+
+let create_archive file_list lib_name =
+  let archive_name = Filename.chop_suffix lib_name ".cmxa" ^ ".a" in
+  let outchan = open_out_bin lib_name in
+  try
+    output_string outchan cmxa_magic_number;
+    let (objfile_list, descr_list) =
+      List.split (List.map read_info file_list) in
+    output_value outchan descr_list;
+    if Proc.create_archive archive_name objfile_list <> 0
+    then raise(Error(Archiver_error));
+    close_out outchan
+  with x ->
+    close_out outchan;
+    remove_file lib_name;
+    remove_file archive_name;
+    raise x
+
+open Format
+
+let report_error = function
+    File_not_found name ->
+      print_string "Cannot find file "; print_string name
+  | Archiver_error ->
+      print_string "Error while writing the .a file"
+
diff --git a/asmcomp/asmlibrarian.mli b/asmcomp/asmlibrarian.mli
new file mode 100644
index 000000000..d82e0d8cf
--- /dev/null
+++ b/asmcomp/asmlibrarian.mli
@@ -0,0 +1,11 @@
+(* Build libraries of .cmx files *)
+
+val create_archive: string list -> string -> unit
+
+type error =
+    File_not_found of string
+  | Archiver_error
+
+exception Error of error
+
+val report_error: error -> unit
diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml
index e5fdf5b3d..486aff116 100644
--- a/asmcomp/asmlink.ml
+++ b/asmcomp/asmlink.ml
@@ -8,6 +8,7 @@ open Compilenv
 type error =
     File_not_found of string
   | Not_an_object_file of string
+  | Missing_implementations of string list
   | Inconsistent_interface of string * string * string
   | Inconsistent_implementation of string * string * string
   | Assembler_error of string
@@ -65,40 +66,37 @@ let scan_file tolink obj_name =
       find_in_path !load_path obj_name
     with Not_found ->
       raise(Error(File_not_found obj_name)) in
-  let ic = open_in_bin file_name in
-  try
-    let buffer = String.create (String.length cmx_magic_number) in
-    really_input ic buffer 0 (String.length cmx_magic_number);
-    if buffer = cmx_magic_number then begin
-      (* This is a .cmx file. It must be linked in any case.
-         Read the infos to see which modules it
-         requires. *)
-      let info = (input_value ic : unit_infos) in
-      let crc = input_binary_int ic in
-      close_in ic;
-      check_consistency file_name info crc;
-      List.iter add_required info.ui_imports;
-      info :: tolink
-    end
-    else if buffer = cmxa_magic_number then begin
-      (* This is an archive file. Each unit contained in it will be linked
-         in only if needed. *)
-      let info_crc_list = (input_value ic : (unit_infos * int) list) in
-      close_in ic;
-      List.fold_left
-        (fun reqd (info, crc) ->
-          if is_required info.ui_name then begin
-            check_consistency file_name info crc;
-            remove_required info.ui_name;
-            List.iter add_required info.ui_imports;
-            info :: reqd
-          end else
-            reqd)
-      tolink info_crc_list
-    end
-    else raise(Error(Not_an_object_file file_name))
-  with x ->
-    close_in ic; raise x
+  if Filename.check_suffix file_name ".cmx" then begin
+    (* This is a .cmx file. It must be linked in any case.
+       Read the infos to see which modules it requires. *)
+    let (info, crc) = Compilenv.read_unit_info file_name in
+    check_consistency file_name info crc;
+    remove_required info.ui_name;
+    List.iter add_required info.ui_imports;
+    info :: tolink
+  end
+  else if Filename.check_suffix file_name ".cmxa" then begin
+    (* This is an archive file. Each unit contained in it will be linked
+       in only if needed. *)
+    let ic = open_in_bin file_name in
+    let buffer = String.create (String.length cmxa_magic_number) in
+    really_input ic buffer 0 (String.length cmxa_magic_number);
+    if buffer <> cmxa_magic_number then
+      raise(Error(Not_an_object_file file_name));
+    let info_crc_list = (input_value ic : (unit_infos * int) list) in
+    close_in ic;
+    List.fold_right
+      (fun (info, crc) reqd ->
+        if is_required info.ui_name then begin
+          check_consistency file_name info crc;
+          remove_required info.ui_name;
+          List.iter add_required info.ui_imports;
+          info :: reqd
+        end else
+          reqd)
+    info_crc_list tolink
+  end
+  else raise(Error(Not_an_object_file file_name))
 
 (* Second pass: generate the startup file and link it with everything else *)
 
@@ -138,9 +136,14 @@ let make_startup_file filename info_list =
   close_out oc
 
 let call_linker file_list startup_file =
+  let runtime_lib =
+    try
+      find_in_path !load_path "libasmrun.a"
+    with Not_found ->
+      raise(Error(File_not_found "libasmrun.a")) in
   if Sys.command
    (Printf.sprintf
-      "%s -I%s -o %s %s %s %s -L%s %s %s"
+      "%s -I%s -o %s %s %s %s -L%s %s %s %s"
       Config.c_compiler
       Config.standard_library
       !Clflags.exec_name
@@ -149,22 +152,30 @@ let call_linker file_list startup_file =
       startup_file
       Config.standard_library
       (String.concat " " (List.rev !Clflags.ccobjs))
+      runtime_lib
       Config.c_libraries) <> 0
   then raise(Error Linking_error)
 
 let object_file_name name =
-  if Filename.check_suffix name ".cmx" then
-    Filename.chop_suffix name ".cmx" ^ ".o"
-  else if Filename.check_suffix name ".cmxa" then
-    Filename.chop_suffix name ".cmxa" ^ ".a"
+  let file_name =
+    try
+      find_in_path !load_path name
+    with Not_found ->
+      fatal_error "Asmlink.object_file_name: not found" in
+  if Filename.check_suffix file_name ".cmx" then
+    Filename.chop_suffix file_name ".cmx" ^ ".o"
+  else if Filename.check_suffix file_name ".cmxa" then
+    Filename.chop_suffix file_name ".cmxa" ^ ".a"
   else
-    fatal_error "Asmlink.object_file_name"
+    fatal_error "Asmlink.object_file_name: bad ext"
 
 (* Main entry point *)
 
 let link objfiles =
-(**  let objfiles = "stdlib.cmxa" :: objfiles in **)
+  let objfiles = "stdlib.cmxa" :: objfiles in
   let units_tolink = List.fold_left scan_file [] (List.rev objfiles) in
+  if not (StringSet.is_empty !missing_globals) then
+    raise(Error(Missing_implementations(StringSet.elements !missing_globals)));
   let startup = temp_file "camlstartup" ".s" in
   make_startup_file startup units_tolink;
   let startup_obj = temp_file "camlstartup" ".o" in
@@ -188,6 +199,12 @@ let report_error = function
   | Not_an_object_file name ->
       print_string "The file "; print_string name;
       print_string " is not a compilation unit description"
+  | Missing_implementations l ->
+      open_hovbox 0;
+      print_string
+        "No implementation(s) provided for the following module(s):";
+      List.iter (fun s -> print_space(); print_string s) l;
+      close_box()
   | Inconsistent_interface(intf, file1, file2) ->
       open_hvbox 0;
       print_string "Files "; print_string file1; print_string " and ";
diff --git a/asmcomp/asmlink.mli b/asmcomp/asmlink.mli
index 2f7ef5cc5..2a7bc2f13 100644
--- a/asmcomp/asmlink.mli
+++ b/asmcomp/asmlink.mli
@@ -5,6 +5,7 @@ val link: string list -> unit
 type error =
     File_not_found of string
   | Not_an_object_file of string
+  | Missing_implementations of string list
   | Inconsistent_interface of string * string * string
   | Inconsistent_implementation of string * string * string
   | Assembler_error of string
diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml
index 5938c035d..73edc25f4 100644
--- a/asmcomp/clambda.ml
+++ b/asmcomp/clambda.ml
@@ -31,7 +31,7 @@ type ulambda =
 type function_description =
   { fun_label: function_label;          (* Label of direct entry point *)
     fun_arity: int;                     (* Number of arguments *)
-    fun_closed: bool }                  (* True if environment not used *)
+    mutable fun_closed: bool }          (* True if environment not used *)
 
 (* Approximation of values *)
 
diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli
index 5938c035d..73edc25f4 100644
--- a/asmcomp/clambda.mli
+++ b/asmcomp/clambda.mli
@@ -31,7 +31,7 @@ type ulambda =
 type function_description =
   { fun_label: function_label;          (* Label of direct entry point *)
     fun_arity: int;                     (* Number of arguments *)
-    fun_closed: bool }                  (* True if environment not used *)
+    mutable fun_closed: bool }          (* True if environment not used *)
 
 (* Approximation of values *)
 
diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml
index a103c22e2..2f5abbe99 100644
--- a/asmcomp/closure.ml
+++ b/asmcomp/closure.ml
@@ -25,6 +25,40 @@ let rec build_closure_env env_param pos = function
       Tbl.add id (Uprim(Pfield pos, [Uvar env_param])) 
               (build_closure_env env_param (pos+1) rem)
 
+(* Check if a variable occurs in a [clambda] term. *)
+
+let occurs_var var u =
+  let rec occurs = function
+      Uvar v -> v = var
+    | Uconst cst -> false
+    | Udirect_apply(lbl, args) -> List.exists occurs args
+    | Ugeneric_apply(funct, args) -> occurs funct or List.exists occurs args
+    | Uclosure(fundecls, clos) -> List.exists occurs clos
+    | Uoffset(u, ofs) -> occurs u
+    | Ulet(id, def, body) -> occurs def or occurs body
+    | Uletrec(decls, body) ->
+        List.exists (fun (id, u) -> occurs u) decls or occurs body
+    | Uprim(p, args) -> List.exists occurs args
+    | Uswitch(arg, const_index, const_cases, block_index, block_cases) ->
+        occurs arg or occurs_array const_cases or occurs_array block_cases
+    | Ustaticfail -> false
+    | Ucatch(body, hdlr) -> occurs body or occurs hdlr
+    | Utrywith(body, exn, hdlr) -> occurs body or occurs hdlr
+    | Uifthenelse(cond, ifso, ifnot) ->
+        occurs cond or occurs ifso or occurs ifnot
+    | Usequence(u1, u2) -> occurs u1 or occurs u2
+    | Uwhile(cond, body) -> occurs cond or occurs body
+    | Ufor(id, lo, hi, dir, body) -> occurs lo or occurs hi or occurs body
+  and occurs_array a =
+    try
+      for i = 0 to Array.length a - 1 do
+        if occurs a.(i) then raise Exit
+      done;
+      false
+    with Exit ->
+      true
+  in occurs u
+
 (* Uncurry an expression and explicitate closures.
    Also return the approximation of the expression.
    The approximation environment [fenv] maps idents to approximations.
@@ -175,6 +209,8 @@ and close_functions fenv cenv fun_defs =
   let fv =
     IdentSet.elements (free_variables (Lletrec(fun_defs, lambda_unit))) in
   (* Uncurry the definitions and build their fundesc *)
+  (* Initially all functions are assumed not to need their environment
+     parameter. *)
   let uncurried_defs =
     List.map
       (fun (id, def) ->
@@ -185,7 +221,7 @@ and close_functions fenv cenv fun_defs =
           {fun_label = Compilenv.current_unit_name() ^ "_" ^
                        Ident.unique_name id;
            fun_arity = List.length params;
-           fun_closed = IdentSet.is_empty(free_variables def)} in
+           fun_closed = true } in
         (id, params, body, fundesc))
       fun_defs in
   (* Build an approximate fenv for compiling the functions *)
@@ -204,6 +240,9 @@ and close_functions fenv cenv fun_defs =
         pos)
       uncurried_defs in
   let fv_pos = !env_pos in
+  (* This reference will be set to false if the hypothesis that a function
+     does not use its environment parameter is invalidated. *)
+  let useless_env = ref true in
   (* Translate each function definition *)
   let clos_fundef (id, params, body, fundesc) env_pos =
     let env_param = Ident.new "env" in
@@ -215,12 +254,24 @@ and close_functions fenv cenv fun_defs =
           Tbl.add id (Uoffset(Uvar env_param, pos - env_pos)) env)
         uncurried_defs clos_offsets cenv_fv in
     let (ubody, approx) = close fenv_rec cenv_body body in
+    if !useless_env & occurs_var env_param ubody then useless_env := false;
     ((fundesc.fun_label, fundesc.fun_arity, params @ [env_param], ubody),
      (id, env_pos, Value_closure(fundesc, approx))) in
-  (* Translate all function definitions. Return the Uclosure node and
-     the list of all identifiers defined, with offsets and approximations. *)
-  let (clos, infos) =
-    List.split (List.map2 clos_fundef uncurried_defs clos_offsets) in
+  (* Translate all function definitions. *)
+  let clos_info_list = 
+    let cl = List.map2 clos_fundef uncurried_defs clos_offsets in
+    (* If the hypothesis that the environment parameters are useless has been
+       invalidated, then set [fun_closed] to false in all descriptions and
+       recompile *)
+    if !useless_env then cl else begin
+      List.iter
+        (fun (id, params, body, fundesc) -> fundesc.fun_closed <- false)
+        uncurried_defs;
+      List.map2 clos_fundef uncurried_defs clos_offsets
+    end in
+  (* Return the Uclosure node and the list of all identifiers defined,
+     with offsets and approximations. *)
+  let (clos, infos) = List.split clos_info_list in
   (Uclosure(clos, List.map (close_var cenv) fv), infos)
 
 (* Same, for one function *)
diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
index 045f8408d..7e005705f 100644
--- a/asmcomp/cmmgen.ml
+++ b/asmcomp/cmmgen.ml
@@ -398,7 +398,7 @@ let rec transl = function
   | Uprim(Psetstringchar, [arg1; arg2; arg3]) ->
       return_unit(Cop(Cstorechunk Byte_unsigned,
                       [add_int (transl arg1) (untag_int(transl arg2));
-                       transl arg3]))
+                       untag_int(transl arg3)]))
   | Uprim(Psafegetstringchar, [arg1; arg2]) ->
       tag_int
         (bind "str" (transl arg1) (fun str ->
@@ -413,7 +413,7 @@ let rec transl = function
             Csequence(
               Cop(Ccheckbound, [string_length str; idx]),
               Cop(Cstorechunk Byte_unsigned,
-                  [add_int str idx; transl arg3])))))
+                  [add_int str idx; untag_int(transl arg3)])))))
   | Uprim(Pvectlength, [arg]) ->
       Cop(Cor, [Cop(Clsr, [get_field (transl arg) (-1); Cconst_int 9]);
                 Cconst_int 1])
diff --git a/asmcomp/compilenv.ml b/asmcomp/compilenv.ml
index 804601189..ecbd650e7 100644
--- a/asmcomp/compilenv.ml
+++ b/asmcomp/compilenv.ml
@@ -51,7 +51,7 @@ let reset name crc_intf =
 let current_unit_name () =
   current_unit.ui_name
 
-let read_unit_info modname filename =
+let read_unit_info filename =
   let ic = open_in_bin filename in
   try
     let buffer = String.create (String.length cmx_magic_number) in
@@ -63,10 +63,7 @@ let read_unit_info modname filename =
     let ui = (input_value ic : unit_infos) in
     let crc = input_binary_int ic in
     close_in ic;
-    if ui.ui_name <> modname then
-      raise(Error(Illegal_renaming(modname, filename)));
-    current_unit.ui_imports <- (modname, crc) :: current_unit.ui_imports;
-    ui
+    (ui, crc)
   with End_of_file | Failure _ ->
     close_in ic;
     raise(Error(Corrupted_unit_info(filename)))
@@ -80,10 +77,16 @@ let global_approx global_ident =
   with Not_found ->
     let approx =
       try
-        let ui = read_unit_info modname
-                   (find_in_path !load_path (lowercase modname ^ ".cmx")) in
+        let filename =
+          find_in_path !load_path (lowercase modname ^ ".cmx") in
+        let (ui, crc) = read_unit_info filename in
+        if ui.ui_name <> modname then
+          raise(Error(Illegal_renaming(modname, filename)));
+        current_unit.ui_imports <-
+          (modname, crc) :: current_unit.ui_imports;
         ui.ui_approx
-      with Not_found -> Value_unknown in
+      with Not_found ->
+        Value_unknown in
     Hashtbl.add global_approx_table modname approx;
     approx
 
diff --git a/asmcomp/compilenv.mli b/asmcomp/compilenv.mli
index 24b687a41..0b4212370 100644
--- a/asmcomp/compilenv.mli
+++ b/asmcomp/compilenv.mli
@@ -28,6 +28,8 @@ val need_apply_fun: int -> unit
         (* Record the need of a currying (resp. application) function
            with the given arity *)
 
+val read_unit_info: string -> unit_infos * int
+        (* Read infos and CRC from a [.cmx] file. *)
 val save_unit_info: string -> unit
         (* Save the infos for the current unit in the given file *)
 
diff --git a/asmcomp/proc.mli b/asmcomp/proc.mli
index 0066794dc..62250dcf1 100644
--- a/asmcomp/proc.mli
+++ b/asmcomp/proc.mli
@@ -53,5 +53,6 @@ val reload_operation:
 val num_stack_slots: int array
 val contains_calls: bool ref
 
-(* Calling the assembler *)
+(* Calling the assembler and the archiver *)
 val assemble_file: string -> string -> int
+val create_archive: string -> string list -> int
diff --git a/asmcomp/proc_alpha.ml b/asmcomp/proc_alpha.ml
index 1fd47742a..4edbcc43d 100644
--- a/asmcomp/proc_alpha.ml
+++ b/asmcomp/proc_alpha.ml
@@ -248,3 +248,9 @@ let slot_offset loc class =
 
 let assemble_file infile outfile =
   Sys.command ("as -O2 -o " ^ outfile ^ " " ^ infile)
+
+(* Calling the archiver *)
+
+let create_archive archive file_list =
+  Misc.remove_file archive;
+  Sys.command ("ar rcs " ^ archive ^ " " ^ String.concat " " file_list)
diff --git a/asmcomp/proc_i386.ml b/asmcomp/proc_i386.ml
index b05a37c0c..0f908d6eb 100644
--- a/asmcomp/proc_i386.ml
+++ b/asmcomp/proc_i386.ml
@@ -323,3 +323,10 @@ let contains_calls = ref false
 
 let assemble_file infile outfile =
   Sys.command ("as -o " ^ outfile ^ " " ^ infile)
+
+(* Calling the archiver *)
+
+let create_archive archive file_list =
+  Misc.remove_file archive;
+  Sys.command ("ar rc " ^ archive ^ " " ^ String.concat " " file_list ^
+               " && ranlib " ^ archive)
diff --git a/asmcomp/selection.ml b/asmcomp/selection.ml
index b2c4a4f9b..62a91b014 100644
--- a/asmcomp/selection.ml
+++ b/asmcomp/selection.ml
@@ -316,6 +316,8 @@ let rec emit_expr env exp seq =
       insert (Iop Imove) r1 rd seq;
       insert Iraise rd [||] seq;
       [||]
+  | Cop(Ccmpf comp, args) ->
+      emit_expr env (Cifthenelse(exp, Cconst_int 1, Cconst_int 0)) seq
   | Cop(op, args) ->
       let (simple_args, env) = emit_parts_list env args seq in
       let ty = oper_result_type op in
@@ -373,6 +375,15 @@ let rec emit_expr env exp seq =
               emit_stores env args_data seq ra addr;
               [||]
           end
+      | Istore(chunk, addr) ->
+          begin match new_args with
+            [arg_addr; arg_data] ->
+              let ra = emit_expr env arg_addr seq in
+              let rd = emit_expr env arg_data seq in
+              insert (Iop(Istore(chunk, addr))) (Array.append rd ra) [||] seq;
+              [||]
+          | _ -> fatal_error "Selection.Istorechunk"
+          end
       | Ialloc _ ->
           Proc.contains_calls := true;
           let rd = Reg.newv typ_addr in
diff --git a/asmcomp/spill.ml b/asmcomp/spill.ml
index ff5126f8d..5f4a057d5 100644
--- a/asmcomp/spill.ml
+++ b/asmcomp/spill.ml
@@ -212,8 +212,15 @@ let rec reload i before =
    That is, any register that may be reloaded in the future must be spilled
    just after its definition. *)
 
+(* As an optimization, if a register needs to be spilled in one branch of
+   a conditional but not in the other, then we spill it late on entrance
+   in the branch that needs it spilled.
+   This strategy is turned off in loops, as it may prevent a spill from
+   being lifted up all the way out of the loop. *)
+
 let spill_at_exit = ref Reg.Set.empty
 let spill_at_raise = ref Reg.Set.empty
+let inside_loop = ref false
 
 let add_spills regset i =
   Reg.Set.fold
@@ -247,10 +254,22 @@ let rec spill i finally =
       let (new_next, at_join) = spill i.next finally in
       let (new_ifso, before_ifso) = spill ifso at_join in
       let (new_ifnot, before_ifnot) = spill ifnot at_join in
-      (instr_cons (Iifthenelse(test, new_ifso, new_ifnot))
-                  i.arg i.res new_next,
-       Reg.Set.union before_ifso before_ifnot)
+      if !inside_loop then
+        (instr_cons (Iifthenelse(test, new_ifso, new_ifnot))
+                    i.arg i.res new_next,
+         Reg.Set.union before_ifso before_ifnot)
+      else
+        (instr_cons
+            (Iifthenelse(test,
+              add_spills (Reg.Set.diff before_ifso before_ifnot) new_ifso,
+              add_spills (Reg.Set.diff before_ifnot before_ifso) new_ifnot))
+            i.arg i.res new_next,
+         Reg.Set.inter before_ifso before_ifnot)
   | Iswitch(index, cases) ->
+      (* Could spill early as for ifthenelse, but then it's less clear
+         when to do it (e.g. if all cases except one require a register
+         to be spilled, it's a bit wasteful to do the spill in all cases
+         minus one). *)
       let (new_next, at_join) = spill i.next finally in
       let before = ref Reg.Set.empty in
       let new_cases =
@@ -263,6 +282,8 @@ let rec spill i finally =
       (instr_cons (Iswitch(index, new_cases)) i.arg i.res new_next,
        !before)
   | Iloop(body) ->
+      let saved_inside_loop = !inside_loop in
+      inside_loop := true;
       let (new_next, _) = spill i.next finally in
       let at_head = ref Reg.Set.empty in
       let final_body = ref body in
@@ -277,6 +298,7 @@ let rec spill i finally =
         done
       with Exit -> ()
       end;
+      inside_loop := saved_inside_loop;
       (instr_cons (Iloop(!final_body)) i.arg i.res new_next,
        !at_head)
   | Icatch(body, handler) ->