Simpler implementation in Translprim

Changes

@@ -126,7 +126,7 @@ Working version
 
 - #10419: Add %frame_pointers primitive which is true only in native code with
   frame pointers mode enabled.
-  (David Allsopp, review by Mark Shinwell)
+  (David Allsopp, review by Vincent Laviron and Mark Shinwell)
 
 ### Type system:
 

bytecomp/bytegen.ml

@@ -384,7 +384,6 @@ let comp_bint_primitive bi suff args =
   Kccall(pref ^ suff, List.length args)
 
 let comp_primitive p args =
-  let runtime_const const_name = Kccall("caml_sys_const_" ^ const_name, 1) in
   match p with
     Pgetglobal id -> Kgetglobal id
   | Psetglobal id -> Ksetglobal id
@@ -451,15 +450,17 @@ let comp_primitive p args =
   | Parraysetu Pgenarray -> Kccall("caml_array_unsafe_set", 3)
   | Parraysetu Pfloatarray -> Kccall("caml_floatarray_unsafe_set", 3)
   | Parraysetu _ -> Ksetvectitem
-  | Pctconst Big_endian -> runtime_const "big_endian"
-  | Pctconst Word_size -> runtime_const "word_size"
-  | Pctconst Int_size -> runtime_const "int_size"
-  | Pctconst Max_wosize -> runtime_const "max_wosize"
-  | Pctconst Ostype_unix -> runtime_const "ostype_unix"
-  | Pctconst Ostype_win32 -> runtime_const "ostype_win32"
-  | Pctconst Ostype_cygwin -> runtime_const "ostype_cygwin"
-  | Pctconst Backend_type -> runtime_const "backend_type"
-  | Pctconst Frame_pointers -> Kconst(Const_base(Const_int 0)) (* false *)
+  | Pctconst c ->
+     let const_name = match c with
+       | Big_endian -> "big_endian"
+       | Word_size -> "word_size"
+       | Int_size -> "int_size"
+       | Max_wosize -> "max_wosize"
+       | Ostype_unix -> "ostype_unix"
+       | Ostype_win32 -> "ostype_win32"
+       | Ostype_cygwin -> "ostype_cygwin"
+       | Backend_type -> "backend_type" in
+     Kccall(Printf.sprintf "caml_sys_const_%s" const_name, 1)
   | Pisint -> Kisint
   | Pisout -> Kisout
   | Pbintofint bi -> comp_bint_primitive bi "of_int" args

lambda/lambda.ml

@@ -25,7 +25,6 @@ type compile_time_constant =
   | Ostype_win32
   | Ostype_cygwin
   | Backend_type
-  | Frame_pointers
 
 type immediate_or_pointer =
   | Immediate

lambda/lambda.mli

@@ -26,7 +26,6 @@ type compile_time_constant =
   | Ostype_win32
   | Ostype_cygwin
   | Backend_type
-  | Frame_pointers
 
 type immediate_or_pointer =
   | Immediate

lambda/printlambda.ml

@@ -258,8 +258,7 @@ let primitive ppf = function
        | Ostype_unix -> "ostype_unix"
        | Ostype_win32 -> "ostype_win32"
        | Ostype_cygwin -> "ostype_cygwin"
-       | Backend_type -> "backend_type"
-       | Frame_pointers -> "frame_pointers" in
+       | Backend_type -> "backend_type" in
      fprintf ppf "sys.constant_%s" const_name
   | Pisint -> fprintf ppf "isint"
   | Pisout -> fprintf ppf "isout"

lambda/translprim.ml

@@ -88,6 +88,7 @@ type prim =
   | Send
   | Send_self
   | Send_cache
+  | Frame_pointers
 
 let used_primitives = Hashtbl.create 7
 let add_used_primitive loc env path =
@@ -143,7 +144,7 @@ let primitives_table =
     "%ostype_unix", Primitive ((Pctconst Ostype_unix), 1);
     "%ostype_win32", Primitive ((Pctconst Ostype_win32), 1);
     "%ostype_cygwin", Primitive ((Pctconst Ostype_cygwin), 1);
-    "%frame_pointers", Primitive ((Pctconst Frame_pointers), 0);
+    "%frame_pointers", Frame_pointers;
     "%negint", Primitive (Pnegint, 1);
     "%succint", Primitive ((Poffsetint 1), 1);
     "%predint", Primitive ((Poffsetint(-1)), 1);
@@ -696,9 +697,14 @@ let lambda_of_prim prim_name prim loc args arg_exps =
         Lsend(Cached, meth, obj, [cache; pos], loc)
       else
         Lsend(Public, meth, obj, [], loc)
+  | Frame_pointers, [] ->
+      let frame_pointers =
+        if !Clflags.native_code && Config.with_frame_pointers then 1 else 0
+      in
+      Lconst (const_int frame_pointers)
   | (Raise _ | Raise_with_backtrace
     | Lazy_force | Loc _ | Primitive _ | Comparison _
-    | Send | Send_self | Send_cache), _ ->
+    | Send | Send_self | Send_cache | Frame_pointers), _ ->
       raise(Error(to_location loc, Wrong_arity_builtin_primitive prim_name))
 
 let check_primitive_arity loc p =
@@ -714,6 +720,7 @@ let check_primitive_arity loc p =
     | Loc _ -> p.prim_arity = 1 || p.prim_arity = 0
     | Send | Send_self -> p.prim_arity = 2
     | Send_cache -> p.prim_arity = 4
+    | Frame_pointers -> p.prim_arity = 0
   in
   if not ok then raise(Error(loc, Wrong_arity_builtin_primitive p.prim_name))
 
@@ -783,7 +790,7 @@ let primitive_needs_event_after = function
   | Comparison(comp, knd) ->
       lambda_primitive_needs_event_after (comparison_primitive comp knd)
   | Lazy_force | Send | Send_self | Send_cache -> true
-  | Raise _ | Raise_with_backtrace | Loc _ -> false
+  | Raise _ | Raise_with_backtrace | Loc _ | Frame_pointers -> false
 
 let transl_primitive_application loc p env ty path exp args arg_exps =
   let prim =

middle_end/closure/closure.ml

@@ -1047,8 +1047,6 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam =
         (Uletrec(udefs, ubody), approx)
       end
   (* Compile-time constants *)
-  | Lprim(Pctconst Frame_pointers, [], _loc) ->
-      make_const_bool Config.with_frame_pointers
   | Lprim(Pctconst c, [arg], _loc) ->
       let cst, approx =
         match c with
@@ -1061,7 +1059,6 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam =
         | Ostype_cygwin -> make_const_bool (Sys.os_type = "Cygwin")
         | Backend_type ->
             make_const_int 0 (* tag 0 is the same as Native here *)
-        | Frame_pointers -> assert false
       in
       let arg, _approx = close env arg in
       let id = Ident.create_local "dummy" in

middle_end/flambda/closure_conversion.ml

@@ -438,10 +438,6 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t =
       (name_expr
         (Prim (Praise kind, [arg_var], dbg))
         ~name:Names.raise)
-  | Lprim (Pctconst Frame_pointers, [], _loc) ->
-      let cst = lambda_const_bool Config.with_frame_pointers in
-      let cst, name = close_const t cst in
-      name_expr cst ~name
   | Lprim (Pctconst c, [arg], _loc) ->
       let module Backend = (val t.backend) in
       let const =
@@ -456,7 +452,6 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t =
         | Ostype_cygwin -> lambda_const_bool (String.equal Sys.os_type "Cygwin")
         | Backend_type ->
             Lambda.const_int 0 (* tag 0 is the same as Native *)
-        | Frame_pointers -> assert false
         end
       in
       close t env