3.09.1 updategcaml3090

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

5 files changed, 88 insertions, 71 deletions

diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp
index a5ef1dcdd0..74ce9c24ab 100644
--- a/asmcomp/amd64/emit.mlp
+++ b/asmcomp/amd64/emit.mlp
@@ -534,7 +534,12 @@ let emit_instr fallthrough i =
             end
     | Lswitch jumptbl ->
         let lbl = new_label() in
-        `	jmp	*{emit_label lbl}(, {emit_reg i.arg.(0)}, 8)\n`;
+        if !pic_code then begin
+          `	leaq	{emit_label lbl}(%rip), %r11\n`;
+          `	jmp	*(%r11, {emit_reg i.arg.(0)}, 8)\n`
+        end else begin
+          `	jmp	*{emit_label lbl}(, {emit_reg i.arg.(0)}, 8)\n`
+        end;
         `	.section .rodata\n`;
         emit_align 8;
         `{emit_label lbl}:`;
diff --git a/asmcomp/amd64/proc.ml b/asmcomp/amd64/proc.ml
index 856e4655a6..0e274b4f4e 100644
--- a/asmcomp/amd64/proc.ml
+++ b/asmcomp/amd64/proc.ml
@@ -92,6 +92,7 @@ let phys_reg n =
 let rax = phys_reg 0
 let rcx = phys_reg 5
 let rdx = phys_reg 4
+let r11 = phys_reg 9
 let rxmm15 = phys_reg 115
 
 let stack_slot slot ty =
@@ -169,6 +170,7 @@ let destroyed_at_oper = function
   | Iop(Istore(Single, _)) -> [| rxmm15 |]
   | Iop(Ialloc _ | Iintop(Icomp _) | Iintop_imm((Idiv|Imod|Icomp _), _))
         -> [| rax |]
+  | Iswitch(_, _) when !pic_code -> [| r11 |]
   | _ -> [||]
 
 let destroyed_at_raise = all_phys_regs
diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml
index 71ffa9b1a8..abc8b5b051 100644
--- a/asmcomp/asmpackager.ml
+++ b/asmcomp/asmpackager.ml
@@ -97,7 +97,7 @@ let make_package_object ppf members targetobj targetname coercion =
       (List.filter (fun m -> m.pm_kind <> PM_intf) members) in
   let ld_cmd =
     sprintf "%s -o %s %s %s"
-            Config.native_pack_linker 
+            Config.native_pack_linker
             (Filename.quote targetobj)
             (Filename.quote objtemp)
             (Ccomp.quote_files objfiles) in
@@ -118,17 +118,17 @@ let build_package_cmx members cmxfile =
           (fun accu n -> if List.mem n accu then accu else n :: accu))
       [] lst in
   let units =
-    List.fold_left
-      (fun accu m ->
+    List.fold_right
+      (fun m accu ->
         match m.pm_kind with PM_intf -> accu | PM_impl info -> info :: accu)
-      [] members in
+      members [] in
   let ui = Compilenv.current_unit_infos() in
   let pkg_infos =
     { ui_name = ui.ui_name;
       ui_symbol = ui.ui_symbol;
       ui_defines =
-          ui.ui_symbol ::
-          union (List.map (fun info -> info.ui_defines) units);
+          List.flatten (List.map (fun info -> info.ui_defines) units) @
+          [ui.ui_symbol];
       ui_imports_cmi =
           (ui.ui_name, Env.crc_of_unit ui.ui_name) ::
           filter(Asmlink.extract_crc_interfaces());
@@ -148,7 +148,7 @@ let build_package_cmx members cmxfile =
 
 (* Make the .cmx and the .o for the package *)
 
-let package_object_files ppf files targetcmx 
+let package_object_files ppf files targetcmx
                          targetobj targetname coercion =
   let pack_path =
     match !Clflags.for_package with
@@ -194,7 +194,7 @@ let report_error ppf = function
   | Forward_reference(file, ident) ->
       fprintf ppf "Forward reference to %s in file %s" ident file
   | Wrong_for_pack(file, path) ->
-      fprintf ppf "File %s@ was not compiled with the `-pack %s' option"
+      fprintf ppf "File %s@ was not compiled with the `-for-pack %s' option"
               file path
   | File_not_found file ->
       fprintf ppf "File %s not found" file
diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml
index c4232bcd27..216f273565 100644
--- a/asmcomp/closure.ml
+++ b/asmcomp/closure.ml
@@ -33,9 +33,18 @@ let rec split_list n l =
 let rec build_closure_env env_param pos = function
     [] -> Tbl.empty
   | id :: rem ->
-      Tbl.add id (Uprim(Pfield pos, [Uvar env_param])) 
+      Tbl.add id (Uprim(Pfield pos, [Uvar env_param]))
               (build_closure_env env_param (pos+1) rem)
 
+(* Auxiliary for accessing globals.  We change the name of the global
+   to the name of the corresponding asm symbol.  This is done here
+   and no longer in Cmmgen so that approximations stored in .cmx files
+   contain the right names if the -for-pack option is active. *)
+
+let getglobal id =
+  Uprim(Pgetglobal (Ident.create_persistent (Compilenv.symbol_for_global id)),
+        [])
+
 (* Check if a variable occurs in a [clambda] term. *)
 
 let occurs_var var u =
@@ -62,7 +71,7 @@ let occurs_var var u =
     | Uwhile(cond, body) -> occurs cond || occurs body
     | Ufor(id, lo, hi, dir, body) -> occurs lo || occurs hi || occurs body
     | Uassign(id, u) -> id = var || occurs u
-    | Usend(_, met, obj, args) -> 
+    | Usend(_, met, obj, args) ->
         occurs met || occurs obj || List.exists occurs args
   and occurs_array a =
     try
@@ -103,7 +112,7 @@ let prim_size prim args =
   | _ -> 2 (* arithmetic and comparisons *)
 
 (* Very raw approximation of switch cost *)
-  
+
 let lambda_smaller lam threshold =
   let size = ref 0 in
   let rec lambda_size lam =
@@ -276,7 +285,7 @@ let rec substitute sb ulam =
       let bindings1 =
         List.map (fun (id, rhs) -> (id, Ident.rename id, rhs)) bindings in
       let sb' =
-        List.fold_right 
+        List.fold_right
           (fun (id, id', _) s -> Tbl.add id (Uvar id') s)
           bindings1 sb in
       Uletrec(
@@ -529,7 +538,8 @@ let rec close fenv cenv = function
       end
   | Lprim(Pgetglobal id, []) as lam ->
       check_constant_result lam
-          (Uprim(Pgetglobal id, [])) (Compilenv.global_approx id)
+                            (getglobal id)
+                            (Compilenv.global_approx id)
   | Lprim(Pmakeblock(tag, mut) as prim, lams) ->
       let (ulams, approxs) = List.split (List.map (close fenv cenv) lams) in
       (Uprim(prim, ulams),
@@ -547,7 +557,7 @@ let rec close fenv cenv = function
   | Lprim(Psetfield(n, _), [Lprim(Pgetglobal id, []); lam]) ->
       let (ulam, approx) = close fenv cenv lam in
       (!global_approx).(n) <- approx;
-      (Uprim(Psetfield(n, false), [Uprim(Pgetglobal id, []); ulam]),
+      (Uprim(Psetfield(n, false), [getglobal id; ulam]),
        Value_unknown)
   | Lprim(p, args) ->
       simplif_prim p (close_list_approx fenv cenv args)
@@ -558,7 +568,7 @@ let rec close fenv cenv = function
         close_switch fenv cenv sw.sw_consts sw.sw_numconsts sw.sw_failaction
       and block_index, block_actions =
         close_switch fenv cenv sw.sw_blocks sw.sw_numblocks sw.sw_failaction in
-      (Uswitch(uarg, 
+      (Uswitch(uarg,
                {us_index_consts = const_index;
                 us_actions_consts = const_actions;
                 us_index_blocks = block_index;
@@ -579,7 +589,7 @@ let rec close fenv cenv = function
         (uarg, Value_constptr n) ->
           sequence_constant_expr arg uarg
             (close fenv cenv (if n = 0 then ifnot else ifso))
-      | (uarg, _ ) ->    
+      | (uarg, _ ) ->
           let (uifso, _) = close fenv cenv ifso in
           let (uifnot, _) = close fenv cenv ifnot in
           (Uifthenelse(uarg, uifso, uifnot), Value_unknown)
diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
index 1a3824f22e..caf69738b6 100644
--- a/asmcomp/cmmgen.ml
+++ b/asmcomp/cmmgen.ml
@@ -27,7 +27,7 @@ open Cmm
 
 let bind name arg fn =
   match arg with
-    Cvar _ | Cconst_int _ | Cconst_natint _ | Cconst_symbol _ 
+    Cvar _ | Cconst_int _ | Cconst_natint _ | Cconst_symbol _
   | Cconst_pointer _ | Cconst_natpointer _ -> fn arg
   | _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id))
 
@@ -343,7 +343,7 @@ let make_alloc_generic set_fn tag wordsize args =
       [] -> Cvar id
     | e1::el -> Csequence(set_fn (Cvar id) (Cconst_int idx) e1,
                           fill_fields (idx + 2) el) in
-    Clet(id, 
+    Clet(id,
          Cop(Cextcall("caml_alloc", typ_addr, true),
                  [Cconst_int wordsize; Cconst_int tag]),
          fill_fields 1 args)
@@ -423,7 +423,7 @@ let transl_constant = function
       int_const n
   | Const_base(Const_char c) ->
       Cconst_int(((Char.code c) lsl 1) + 1)
-  | Const_pointer n ->      
+  | Const_pointer n ->
       if n <= max_repr_int && n >= min_repr_int
       then Cconst_pointer((n lsl 1) + 1)
       else Cconst_natpointer
@@ -477,7 +477,7 @@ let unbox_int bi arg =
     when bi = Pint32 && size_int = 8 && not big_endian ->
       (* Force sign-extension of low 32 bits *)
       Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32]); Cconst_int 32])
-  | Cop(Calloc, [hdr; ops; contents]) -> 
+  | Cop(Calloc, [hdr; ops; contents]) ->
       contents
   | _ ->
       Cop(Cload(if bi = Pint32 then Thirtytwo_signed else Word),
@@ -645,7 +645,7 @@ let make_switch_gen arg cases acts =
   let lcases = Array.length cases in
   let new_cases = Array.create lcases 0 in
   let store = Switch.mk_store (=) in
-            
+
   for i = 0 to Array.length cases-1 do
     let act = cases.(i) in
     let new_act = store.Switch.act_store act in
@@ -741,7 +741,7 @@ let subst_boxed_number unbox_fn boxed_id unboxed_id exp =
       Cvar id as e ->
         if Ident.same id boxed_id then need_boxed := true; e
     | Clet(id, arg, body) -> Clet(id, subst arg, subst body)
-    | Cassign(id, arg) -> 
+    | Cassign(id, arg) ->
         if Ident.same id boxed_id then begin
           assigned := true;
           Cassign(unboxed_id, subst(unbox_fn arg))
@@ -759,11 +759,11 @@ let subst_boxed_number unbox_fn boxed_id unboxed_id exp =
         Cswitch(subst arg, index, Array.map subst cases)
     | Cloop e -> Cloop(subst e)
     | Ccatch(nfail, ids, e1, e2) -> Ccatch(nfail, ids, subst e1, subst e2)
-    | Cexit (nfail, el) -> Cexit (nfail, List.map subst el)        
+    | Cexit (nfail, el) -> Cexit (nfail, List.map subst el)
     | Ctrywith(e1, id, e2) -> Ctrywith(subst e1, id, subst e2)
     | e -> e in
   let res = subst exp in
-  (res, !need_boxed, !assigned)  
+  (res, !need_boxed, !assigned)
 
 (* Translate an expression *)
 
@@ -820,20 +820,20 @@ let rec transl = function
       Cop(Capply typ_addr, cargs)
   | Usend(kind, met, obj, args) ->
       let call_met obj args clos =
-	if args = [] then Cop(Capply typ_addr,[get_field clos 0;obj;clos]) else
-	let arity = List.length args + 1 in
+        if args = [] then Cop(Capply typ_addr,[get_field clos 0;obj;clos]) else
+        let arity = List.length args + 1 in
         let cargs = Cconst_symbol(apply_function arity) :: obj ::
-	  (List.map transl args) @ [clos] in
+          (List.map transl args) @ [clos] in
         Cop(Capply typ_addr, cargs)
       in
       bind "obj" (transl obj) (fun obj ->
-	match kind, args with
-	  Self, _ ->
+        match kind, args with
+          Self, _ ->
             bind "met" (lookup_label obj (transl met)) (call_met obj args)
-	| Cached, cache :: pos :: args ->
+        | Cached, cache :: pos :: args ->
             call_cached_method obj (transl met) (transl cache) (transl pos)
               (List.map transl args)
-	| _ ->
+        | _ ->
             bind "met" (lookup_tag obj (transl met)) (call_met obj args))
   | Ulet(id, exp, body) ->
       begin match is_unboxed_number exp with
@@ -853,7 +853,7 @@ let rec transl = function
   | Uprim(prim, args) ->
       begin match (simplif_primitive prim, args) with
         (Pgetglobal id, []) ->
-          Cconst_symbol (Compilenv.symbol_for_global id)
+          Cconst_symbol (Ident.name id)
       | (Pmakeblock(tag, mut), []) ->
           transl_constant(Const_block(tag, []))
       | (Pmakeblock(tag, mut), args) ->
@@ -961,7 +961,7 @@ let rec transl = function
         (exit_if_false cond (transl ifso) raise_num)
         (transl ifnot)
   | Uifthenelse(Uprim(Psequor, _) as cond, ifso, ifnot) ->
-      let raise_num = next_raise_count () in      
+      let raise_num = next_raise_count () in
       make_catch
         raise_num
         (exit_if_true cond raise_num (transl ifnot))
@@ -1007,7 +1007,7 @@ let rec transl = function
                          (remove_unit(transl body),
                          Clet(id_prev, Cvar id,
                           Csequence
-                            (Cassign(id, 
+                            (Cassign(id,
                                Cop(inc, [Cvar id; Cconst_int 2])),
                              Cifthenelse
                                (Cop(Ccmpi Ceq, [Cvar id_prev; high]),
@@ -1152,7 +1152,7 @@ and transl_prim_2 p arg1 arg2 =
   | Pintcomp cmp ->
       tag_int(Cop(Ccmpi(transl_comparison cmp), [transl arg1; transl arg2]))
   | Pisout ->
-      transl_isout (transl arg1) (transl arg2)        
+      transl_isout (transl arg1) (transl arg2)
   (* Float operations *)
   | Paddfloat ->
       box_float(Cop(Caddf,
@@ -1216,7 +1216,7 @@ and transl_prim_2 p arg1 arg2 =
           box_float(
             bind "index" (transl arg2) (fun idx ->
               bind "arr" (transl arg1) (fun arr ->
-                Csequence(Cop(Ccheckbound, 
+                Csequence(Cop(Ccheckbound,
                               [float_array_length(header arr); idx]),
                           unboxed_float_array_ref arr idx))))
       end
@@ -1239,7 +1239,7 @@ and transl_prim_2 p arg1 arg2 =
       box_int bi (Cop(Csubi,
                       [transl_unbox_int bi arg1; transl_unbox_int bi arg2]))
   | Pmulbint bi ->
-      box_int bi (Cop(Cmuli, 
+      box_int bi (Cop(Cmuli,
                       [transl_unbox_int bi arg1; transl_unbox_int bi arg2]))
   | Pdivbint bi ->
       box_int bi (safe_divmod Cdivi
@@ -1366,7 +1366,7 @@ and transl_unbox_let box_fn unbox_fn transl_unbox_fn id exp body =
 
 and make_catch ncatch body handler = match body with
 | Cexit (nexit,[]) when nexit=ncatch -> handler
-| _ ->  Ccatch (ncatch, [], body, handler) 
+| _ ->  Ccatch (ncatch, [], body, handler)
 
 and make_catch2 mk_body handler = match handler with
 | Cexit (_,[])|Ctuple []|Cconst_int _|Cconst_pointer _ ->
@@ -1377,7 +1377,7 @@ and make_catch2 mk_body handler = match handler with
       nfail
       (mk_body (Cexit (nfail,[])))
       handler
-  
+
 and exit_if_true cond nfail otherwise =
   match cond with
   | Uconst (Const_pointer 0) -> otherwise
@@ -1387,14 +1387,14 @@ and exit_if_true cond nfail otherwise =
   | Uprim(Psequand, _) ->
       begin match otherwise with
       | Cexit (raise_num,[]) ->
-          exit_if_false cond (Cexit (nfail,[])) raise_num 
+          exit_if_false cond (Cexit (nfail,[])) raise_num
       | _ ->
           let raise_num = next_raise_count () in
           make_catch
             raise_num
             (exit_if_false cond (Cexit (nfail,[])) raise_num)
             otherwise
-      end   
+      end
   | Uprim(Pnot, [arg]) ->
       exit_if_false arg otherwise nfail
   | Uifthenelse (cond, ifso, ifnot) ->
@@ -1444,7 +1444,7 @@ and transl_switch arg index cases = match Array.length cases with
 | _ ->
     let n_index = Array.length index in
     let actions = Array.map transl cases in
-      
+
     let inters = ref []
     and this_high = ref (n_index-1)
     and this_low = ref (n_index-1)
@@ -1576,17 +1576,17 @@ and emit_constant_field field cont =
   | Const_base(Const_string s) ->
       let lbl = new_const_label() in
       (Clabel_address lbl,
-       Cint(string_header (String.length s)) :: Cdefine_label lbl :: 
+       Cint(string_header (String.length s)) :: Cdefine_label lbl ::
        emit_string_constant s cont)
   | Const_immstring s ->
       begin try
-	(Clabel_address (Hashtbl.find immstrings s), cont)
+        (Clabel_address (Hashtbl.find immstrings s), cont)
       with Not_found ->
-	let lbl = new_const_label() in
-	Hashtbl.add immstrings s lbl;
-	(Clabel_address lbl,
-	 Cint(string_header (String.length s)) :: Cdefine_label lbl :: 
-	 emit_string_constant s cont)
+        let lbl = new_const_label() in
+        Hashtbl.add immstrings s lbl;
+        (Clabel_address lbl,
+         Cint(string_header (String.length s)) :: Cdefine_label lbl ::
+         emit_string_constant s cont)
       end
   | Const_base(Const_int32 n) ->
       let lbl = new_const_label() in
@@ -1733,22 +1733,22 @@ let cache_public_method meths tag cache =
     (raise_num, [],
      Cloop
        (Clet(
-	mi,
-	Cop(Cor,
-	    [Cop(Clsr, [Cop(Caddi, [Cvar li; Cvar hi]); Cconst_int 1]);
-	     Cconst_int 1]),
-	Csequence(
-	Cifthenelse
-	  (Cop (Ccmpi Clt,
-		[tag;
-		 Cop(Cload Word,
-		     [Cop(Cadda,
-			  [meths; lsl_const (Cvar mi) log2_size_addr])])]),
-	   Cassign(hi, Cop(Csubi, [Cvar mi; Cconst_int 2])),
-	   Cassign(li, Cvar mi)),
-	Cifthenelse
-	  (Cop(Ccmpi Cge, [Cvar li; Cvar hi]), Cexit (raise_num, []),
-	   Ctuple [])))),
+        mi,
+        Cop(Cor,
+            [Cop(Clsr, [Cop(Caddi, [Cvar li; Cvar hi]); Cconst_int 1]);
+             Cconst_int 1]),
+        Csequence(
+        Cifthenelse
+          (Cop (Ccmpi Clt,
+                [tag;
+                 Cop(Cload Word,
+                     [Cop(Cadda,
+                          [meths; lsl_const (Cvar mi) log2_size_addr])])]),
+           Cassign(hi, Cop(Csubi, [Cvar mi; Cconst_int 2])),
+           Cassign(li, Cvar mi)),
+        Cifthenelse
+          (Cop(Ccmpi Cge, [Cvar li; Cvar hi]), Cexit (raise_num, []),
+           Ctuple [])))),
      Ctuple []),
   Clet (
   tagged, Cop(Cadda, [lsl_const (Cvar li) log2_size_addr;
@@ -1811,13 +1811,13 @@ let send_function arity =
     Clet (
     cached, Cop(Cand, [Cop(Cload Word, [cache]); mask]),
     Clet (
-    real,     
+    real,
     Cifthenelse(Cop(Ccmpa Cne, [tag'; tag]),
-	        cache_public_method (Cvar meths) tag cache,
+                cache_public_method (Cvar meths) tag cache,
                 cached_pos),
     Cop(Cload Word, [Cop(Cadda, [Cop (Cadda, [Cvar real; Cvar meths]);
                                  Cconst_int(2*size_addr-1)])]))))
-    
+
   in
   let body = Clet(clos', clos, body) in
   let fun_args =
@@ -1904,13 +1904,13 @@ let rec intermediate_curry_functions arity num =
      {fun_name = name2;
       fun_args = [arg, typ_addr; clos, typ_addr];
       fun_body = Cop(Calloc,
-                     [alloc_closure_header 4; 
+                     [alloc_closure_header 4;
                       Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1));
                       int_const 1; Cvar arg; Cvar clos]);
       fun_fast = true}
     :: intermediate_curry_functions arity (num+1)
   end
-    
+
 let curry_function arity =
   if arity >= 0
   then intermediate_curry_functions arity 0