Fix PR#5735: %apply and %revapply not first class citizens

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

Changes

@@ -17,7 +17,7 @@ Bug fixes:
 - PR#5698: remove harcoded limit of 200000 labels in emitaux.ml
 - PR#5708: catch Failure"int_of_string" in ocamldebug
 - PR#5731: instruction scheduling forgot to account for destroyed registers
-
+- PR#5735: %apply and %revapply not first class citizens
 Internals:
 - Moved debugger/envaux.ml to typing/envaux.ml to publish env_of_only_summary
    as part of compilerlibs, to be used on bin-annot files.

bytecomp/translcore.ml

@@ -285,6 +285,12 @@ let prim_obj_dup =
   { prim_name = "caml_obj_dup"; prim_arity = 1; prim_alloc = true;
     prim_native_name = ""; prim_native_float = false }
 
+let find_primitive loc prim_name =
+  match prim_name with
+      "%revapply" -> Prevapply loc
+    | "%apply" -> Pdirapply loc
+    | name -> Hashtbl.find primitives_table name
+
 let transl_prim loc prim args =
   let prim_name = prim.prim_name in
   try
@@ -323,11 +329,7 @@ let transl_prim loc prim args =
     end
   with Not_found ->
   try
-    let p =
-      match prim_name with
-          "%revapply" -> Prevapply loc
-        | "%apply" -> Pdirapply loc
-        | name -> Hashtbl.find primitives_table name in
+    let p = find_primitive loc prim_name in
     (* Try strength reduction based on the type of the argument *)
     begin match (p, args) with
         (Psetfield(n, _), [arg1; arg2]) -> Psetfield(n, maybe_pointer arg2)
@@ -354,7 +356,7 @@ let transl_prim loc prim args =
 
 (* Eta-expand a primitive without knowing the types of its arguments *)
 
-let transl_primitive p =
+let transl_primitive loc p =
   let prim =
     try
       let (gencomp, _, _, _, _, _, _, _) =
@@ -362,7 +364,7 @@ let transl_primitive p =
       gencomp
     with Not_found ->
     try
-      Hashtbl.find primitives_table p.prim_name
+      find_primitive loc p.prim_name
     with Not_found ->
       Pccall p in
   match prim with
@@ -583,7 +585,7 @@ and transl_exp0 e =
         Lfunction(Curried, [obj; meth; cache; pos],
                   Lsend(Cached, Lvar meth, Lvar obj, [Lvar cache; Lvar pos], e.exp_loc))
       else
-        transl_primitive p
+        transl_primitive e.exp_loc p
   | Texp_ident(path, _, {val_kind = Val_anc _}) ->
       raise(Error(e.exp_loc, Free_super_var))
   | Texp_ident(path, _, {val_kind = Val_reg | Val_self _}) ->

bytecomp/translcore.mli

@@ -26,7 +26,7 @@ val transl_apply: lambda -> (label * expression option * optional) list
                   -> Location.t -> lambda
 val transl_let:
       rec_flag -> (pattern * expression) list -> lambda -> lambda
-val transl_primitive: Primitive.description -> lambda
+val transl_primitive: Location.t -> Primitive.description -> lambda
 val transl_exception:
       Ident.t -> Path.t option -> exception_declaration -> lambda
 

bytecomp/translmod.ml

@@ -49,7 +49,7 @@ let rec apply_coercion restr arg =
             (Lapply(Lvar id, [apply_coercion cc_arg (Lvar param)],
                     Location.none))))
   | Tcoerce_primitive p ->
-      transl_primitive p
+      transl_primitive Location.none p
 
 and apply_coercion_field id (pos, cc) =
   apply_coercion cc (Lprim(Pfield pos, [Lvar id]))
@@ -278,7 +278,7 @@ and transl_structure fields cc rootpath = function
                 List.map
                   (fun (pos, cc) ->
                     match cc with
-                      Tcoerce_primitive p -> transl_primitive p
+                      Tcoerce_primitive p -> transl_primitive Location.none p
                     | _ -> apply_coercion cc (Lvar v.(pos)))
                   pos_cc_list)
       | _ ->
@@ -479,7 +479,8 @@ let transl_store_structure glob map prims str =
 
   and store_primitive (pos, prim) cont =
     Lsequence(Lprim(Psetfield(pos, false),
-                    [Lprim(Pgetglobal glob, []); transl_primitive prim]),
+                    [Lprim(Pgetglobal glob, []);
+                     transl_primitive Location.none prim]),
               cont)
 
   in List.fold_right store_primitive prims (transl_store !transl_store_subst str)