Merge pull request #289 from garrigue/require-external

Fix PR4166 and PR6956: force linking when calling external C primitives

7 files changed, 79 insertions, 22 deletions

diff --git a/Changes b/Changes
index d7069b6e8f..d5857cb89e 100644
--- a/Changes
+++ b/Changes
@@ -192,6 +192,8 @@ OCamlbuild:
 Bug fixes:
 - PR#3612: memory leak in bigarray read from file
   (Pierre Chambart, report by Gary Huber)
+* PR#4166, PR#6956: force linking when calling external C primitives
+  (Jacques Garrigue, reports by Markus Mottl and Christophe Troestler)
 * PR#4539: change exception string raised when comparing functional values
   (Nicolas Braud-Santoni, report by Eric Cooper)
 - PR#4832: Filling bigarrays may block out runtime
diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml
index 2ea3f689b7..b2fc4c9d83 100644
--- a/bytecomp/bytelink.ml
+++ b/bytecomp/bytelink.ml
@@ -82,11 +82,7 @@ let add_ccobjs origin l =
 
 (* First pass: determine which units are needed *)
 
-module IdentSet =
-  Set.Make(struct
-    type t = Ident.t
-    let compare = compare
-  end)
+module IdentSet = Lambda.IdentSet
 
 let missing_globals = ref IdentSet.empty
 
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 4c67e684a7..c369053f29 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -395,10 +395,22 @@ let specialize_primitive loc p env ty ~has_constant_constructor =
 
 (* Eta-expand a primitive *)
 
-let transl_primitive loc p env ty =
+let used_primitives = Hashtbl.create 7
+let add_used_primitive loc p env path =
+  match path with
+    Some (Path.Pdot _ as path) ->
+      let path = Env.normalize_path (Some loc) env path in
+      let unit = Path.head path in
+      if Ident.global unit && not (Hashtbl.mem used_primitives path)
+      then Hashtbl.add used_primitives path loc
+  | _ -> ()
+
+let transl_primitive loc p env ty path =
   let prim =
     try specialize_primitive loc p env ty ~has_constant_constructor:false
-    with Not_found -> Pccall p
+    with Not_found ->
+      add_used_primitive loc p env path;
+      Pccall p
   in
   match prim with
   | Plazyforce ->
@@ -425,7 +437,7 @@ let transl_primitive loc p env ty =
                  attr = default_function_attribute;
                  body = Lprim(prim, List.map (fun id -> Lvar id) params) }
 
-let transl_primitive_application loc prim env ty args =
+let transl_primitive_application loc prim env ty path args =
   let prim_name = prim.prim_name in
   try
     let has_constant_constructor = match args with
@@ -439,6 +451,7 @@ let transl_primitive_application loc prim env ty args =
   with Not_found ->
     if String.length prim_name > 0 && prim_name.[0] = '%' then
       raise(Error(loc, Unknown_builtin_primitive prim_name));
+    add_used_primitive loc prim env path;
     Pccall prim
 
 
@@ -682,7 +695,7 @@ and transl_exp0 e =
                   body = Lsend(Cached, Lvar meth, Lvar obj,
                                [Lvar cache; Lvar pos], e.exp_loc)}
       else
-        transl_primitive e.exp_loc p e.exp_env e.exp_type
+        transl_primitive e.exp_loc p e.exp_env e.exp_type (Some path)
   | Texp_ident(path, _, {val_kind = Val_anc _}) ->
       raise(Error(e.exp_loc, Free_super_var))
   | Texp_ident(path, _, {val_kind = Val_reg | Val_self _}) ->
@@ -740,7 +753,7 @@ and transl_exp0 e =
         | _ -> assert false
       else begin
         let prim = transl_primitive_application
-            e.exp_loc p e.exp_env prim_type args in
+            e.exp_loc p e.exp_env prim_type (Some path) args in
         match (prim, args) with
           (Praise k, [arg1]) ->
             let targ = List.hd argl in
diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli
index 38b076d752..9d3394ca96 100644
--- a/bytecomp/translcore.mli
+++ b/bytecomp/translcore.mli
@@ -24,10 +24,12 @@ val transl_apply: ?should_be_tailcall:bool
                   -> Location.t -> lambda
 val transl_let: rec_flag -> value_binding list -> lambda -> lambda
 val transl_primitive: Location.t -> Primitive.description -> Env.t
-                      -> Types.type_expr -> lambda
+                      -> Types.type_expr -> Path.t option -> lambda
 
 val check_recursive_lambda: Ident.t list -> lambda -> bool
 
+val used_primitives: (Path.t, Location.t) Hashtbl.t
+
 type error =
     Illegal_letrec_pat
   | Illegal_letrec_expr
diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml
index de0392b399..ff86f3fd7f 100644
--- a/bytecomp/translmod.ml
+++ b/bytecomp/translmod.ml
@@ -97,7 +97,7 @@ let rec apply_coercion strict restr arg =
                                    [apply_coercion Alias cc_arg (Lvar param)],
                                    no_apply_info))})
   | Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } ->
-      transl_primitive pc_loc pc_desc pc_env pc_type
+      transl_primitive pc_loc pc_desc pc_env pc_type None
   | Tcoerce_alias (path, cc) ->
       name_lambda strict arg
         (fun id -> apply_coercion Alias cc (transl_normal_path path))
@@ -400,7 +400,7 @@ and transl_structure fields cc rootpath = function
                     match cc with
                       Tcoerce_primitive p ->
                         transl_primitive p.pc_loc
-                          p.pc_desc p.pc_env p.pc_type
+                          p.pc_desc p.pc_env p.pc_type None
                     | _ -> apply_coercion Strict cc (get_field pos))
                   pos_cc_list))
           and id_pos_list =
@@ -479,15 +479,49 @@ and pure_module m =
 let _ =
   Translcore.transl_module := transl_module
 
+let scan_used_globals lam =
+  let globals = ref IdentSet.empty in
+  let rec scan lam =
+    Lambda.iter scan lam;
+    match lam with
+      Lprim ((Pgetglobal id | Psetglobal id), _) ->
+        globals := IdentSet.add id !globals
+    | _ -> ()
+  in
+  scan lam; !globals
+
+let wrap_globals body =
+  let globals = scan_used_globals body in
+  let add_global id req =
+    if IdentSet.mem id globals then req else IdentSet.add id req in
+  let required =
+    Hashtbl.fold (fun path loc -> add_global (Path.head path))
+      used_primitives IdentSet.empty
+  in
+  let required =
+    List.fold_right add_global (Env.get_required_globals ()) required
+  in
+  Env.reset_required_globals ();
+  Hashtbl.clear used_primitives;
+  IdentSet.fold
+    (fun id expr -> Lsequence(Lprim(Pgetglobal id, []), expr))
+    required body
+  (* Location.prerr_warning loc
+        (Warnings.Nonrequired_global (Ident.name (Path.head path),
+                                      "uses the primitive " ^
+                                      Printtyp.string_of_path path))) *)
+
 (* Compile an implementation *)
 
 let transl_implementation module_name (str, cc) =
   reset_labels ();
   primitive_declarations := [];
+  Hashtbl.clear used_primitives;
   let module_id = Ident.create_persistent module_name in
-  Lprim(Psetglobal module_id,
-        [transl_label_init
-            (transl_struct [] cc (global_path module_id) str)])
+  let body =
+    transl_label_init
+      (transl_struct [] cc (global_path module_id) str) in
+  Lprim(Psetglobal module_id, [wrap_globals body])
 
 
 (* Build the list of value identifiers defined by a toplevel structure
@@ -708,7 +742,7 @@ let transl_store_structure glob map prims str =
     Lsequence(Lprim(Psetfield(pos, false),
                     [Lprim(Pgetglobal glob, []);
                      transl_primitive Location.none
-                       prim.pc_desc prim.pc_env prim.pc_type]),
+                       prim.pc_desc prim.pc_env prim.pc_type None]),
               cont)
 
   in List.fold_right store_primitive prims
@@ -760,6 +794,7 @@ let build_ident_map restr idlist more_ids =
 let transl_store_gen module_name ({ str_items = str }, restr) topl =
   reset_labels ();
   primitive_declarations := [];
+  Hashtbl.clear used_primitives;
   let module_id = Ident.create_persistent module_name in
   let (map, prims, size) =
     build_ident_map restr (defined_idents str) (more_idents str) in
@@ -777,9 +812,9 @@ let transl_store_phrases module_name str =
 let transl_store_implementation module_name (str, restr) =
   let s = !transl_store_subst in
   transl_store_subst := Ident.empty;
-  let r = transl_store_gen module_name (str, restr) false in
+  let (i, r) = transl_store_gen module_name (str, restr) false in
   transl_store_subst := s;
-  r
+  (i, wrap_globals r)
 
 (* Compile a toplevel phrase *)
 
@@ -878,6 +913,7 @@ let transl_toplevel_item_and_close itm =
 
 let transl_toplevel_definition str =
   reset_labels ();
+  Hashtbl.clear used_primitives;
   make_sequence transl_toplevel_item_and_close str.str_items
 
 (* Compile the initialization code for a packed library *)
@@ -970,4 +1006,6 @@ let reset () =
   primitive_declarations := [];
   transl_store_subst := Ident.empty;
   toploop_ident.Ident.flags <- 0;
-  aliased_idents := Ident.empty
+  aliased_idents := Ident.empty;
+  Env.reset_required_globals ();
+  Hashtbl.clear used_primitives
diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml
index 64daa3d956..3bd1939212 100644
--- a/bytecomp/translobj.ml
+++ b/bytecomp/translobj.ml
@@ -97,12 +97,12 @@ let transl_label_init expr =
       (fun c id expr -> Llet(Alias, id, Lconst c, expr))
       consts expr
   in
-  let expr =
+  (*let expr =
     List.fold_right
       (fun id expr -> Lsequence(Lprim(Pgetglobal id, []), expr))
       (Env.get_required_globals ()) expr
   in
-  Env.reset_required_globals ();
+  Env.reset_required_globals ();*)
   reset_labels ();
   expr
 
diff --git a/byterun/meta.c b/byterun/meta.c
index 32cd6dd717..0e0864a3ac 100644
--- a/byterun/meta.c
+++ b/byterun/meta.c
@@ -210,6 +210,12 @@ value caml_reify_bytecode(value prog, value len)
   return Val_unit; /* not reached */
 }
 
+value caml_static_release_bytecode(value prog, value len)
+{
+  caml_invalid_argument("Meta.static_release_bytecode");
+  return Val_unit; /* not reached */
+}
+
 value * caml_stack_low;
 value * caml_stack_high;
 value * caml_stack_threshold;