Support far relocations in Win64, using a custom local implementation of something similar to the GOT table. This allows loading .cmxs units far from the main process. Might fix #6594 as well.

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

1 files changed, 46 insertions, 17 deletions

diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp
index b3c7b04b80..0ce2e423e1 100644
--- a/asmcomp/amd64/emit.mlp
+++ b/asmcomp/amd64/emit.mlp
@@ -100,26 +100,53 @@ let symbols_used = ref StringSet.empty
 let add_def_symbol s = symbols_defined := StringSet.add s !symbols_defined
 let add_used_symbol s = symbols_used := StringSet.add s !symbols_used
 
-let rel_plt s =
-  let use_plt =
-    match system with
-    | S_macosx | S_mingw64 | S_cygwin | S_win64 -> false
-    | _ -> !Clflags.dlcode
+let imp_table = Hashtbl.create 16
+
+let reset_imp_table () = Hashtbl.clear imp_table
+
+let get_imp_symbol s =
+  match Hashtbl.find imp_table s with
+  | exception Not_found ->
+      let imps = "__caml_imp_" ^ s in
+      Hashtbl.add imp_table s imps;
+      imps
+  | imps -> imps
+
+let emit_imp_table () =
+  let f s imps =
+    _label (emit_symbol imps);
+    D.qword (ConstLabel (emit_symbol s))
   in
-  sym (if use_plt then emit_symbol s ^ "@PLT" else emit_symbol s)
+  D.data();
+  D.comment "relocation table start";
+  D.align 8;
+  Hashtbl.iter f imp_table;
+  D.comment "relocation table end"
+
+let mem__imp s =
+  let imp_s = get_imp_symbol s in
+  mem64_rip QWORD (emit_symbol imp_s)
+
+let rel_plt s =
+  if windows && !Clflags.dlcode then mem__imp s
+  else
+    let use_plt =
+      match system with
+      | S_macosx | S_mingw64 | S_cygwin | S_win64 -> false
+      | _ -> !Clflags.dlcode
+    in
+    sym (if use_plt then emit_symbol s ^ "@PLT" else emit_symbol s)
 
 let emit_call s = I.call (rel_plt s)
 
 let emit_jump s = I.jmp (rel_plt s)
 
-let windows =
-  match system with
-  | S_mingw64 | S_cygwin | S_win64 -> true
-  | _ -> false
-
 let load_symbol_addr s arg =
-  if !Clflags.dlcode && not windows then
-    I.mov (mem64_rip QWORD (emit_symbol s ^ "@GOTPCREL")) arg
+  if !Clflags.dlcode then
+    if windows then begin
+      (* I.mov (mem__imp s) arg (\* mov __caml_imp_foo(%rip), ... *\) *)
+      I.mov (sym (emit_symbol s)) arg (* movabsq $foo, ... *)
+    end else I.mov (mem64_rip QWORD (emit_symbol s ^ "@GOTPCREL")) arg
   else if !Clflags.pic_code then
     I.lea (mem64_rip NONE (emit_symbol s)) arg
   else
@@ -529,7 +556,7 @@ let emit_instr fallthrough i =
         let lbl_redo = new_label() in
         def_label lbl_redo;
         I.sub (int n) r15;
-        if !Clflags.dlcode && system <> S_win64 then begin
+        if !Clflags.dlcode then begin
           load_symbol_addr "caml_young_limit" rax;
           I.cmp (mem64 QWORD 0 RAX) r15;
         end else
@@ -835,13 +862,12 @@ let data l =
 let begin_assembly() =
   X86_proc.reset_asm_code ();
   reset_debug_info();                   (* PR#5603 *)
+  reset_imp_table();
   float_constants := [];
   if system = S_win64 then begin
     D.extrn "caml_young_ptr" QWORD;
     D.extrn "caml_young_limit" QWORD;
     D.extrn "caml_exception_pointer" QWORD;
-    D.extrn "caml_absf_mask" QWORD;
-    D.extrn "caml_negf_mask" QWORD;
     D.extrn "caml_call_gc" NEAR;
     D.extrn "caml_c_call" NEAR;
     D.extrn "caml_allocN" NEAR;
@@ -854,11 +880,12 @@ let begin_assembly() =
   end;
 
 
-  if !Clflags.dlcode && system <> S_win64 then begin
+  if !Clflags.dlcode then begin
     (* from amd64.S; could emit these constants on demand *)
     begin match system with
     | S_macosx -> D.section ["__TEXT";"__literal16"] None ["16byte_literals"]
     | S_mingw64 | S_cygwin -> D.section [".rdata"] (Some "dr") []
+    | S_win64 -> D.data ()
     | _ -> D.section [".rodata.cst8"] (Some "a") ["@progbits"]
     end;
     D.align 16;
@@ -896,6 +923,8 @@ let end_assembly() =
 
   emit_global_label "code_end";
 
+  emit_imp_table();
+
   D.data ();
   emit_global_label "data_end";
   D.long (const 0);