Merge flambda-backend changes

Author: ccasin

asmcomp/amd64/emit.mlp

@@ -1429,6 +1429,7 @@ let end_assembly() =
   emit_global_label "data_end";
   D.qword (const 0);
 
+  D.text ();
   D.align 8;                            (* PR#7591 *)
   emit_global_label "frametable";
 
@@ -1465,6 +1466,7 @@ let end_assembly() =
     D.size frametable (ConstSub (ConstThis, ConstLabel frametable))
   end;
 
+  D.data ();
   emit_probe_notes ();
 
   if system = S_linux then

asmcomp/cmm_helpers.ml

@@ -666,11 +666,14 @@ let field_address ptr n dbg =
   then ptr
   else Cop(Cadda, [ptr; Cconst_int(n * size_addr, dbg)], dbg)
 
+let get_field_gen_given_memory_chunk memory_chunk mut ptr n dbg =
+  Cop (Cload (memory_chunk, mut), [field_address ptr n dbg], dbg)
+
 let get_field_gen mut ptr n dbg =
-  Cop(Cload (Word_val, mut), [field_address ptr n dbg], dbg)
+  get_field_gen_given_memory_chunk Word_val mut ptr n dbg
 
 let get_field_codepointer mut ptr n dbg =
-  Cop (Cload (Word_int, mut), [field_address ptr n dbg], dbg)
+  get_field_gen_given_memory_chunk Word_int mut ptr n dbg
 
 let set_field ptr n newval init dbg =
   Cop(Cstore (Word_val, init), [field_address ptr n dbg; newval], dbg)
@@ -2239,7 +2242,15 @@ let rec make_curry_apply result narity args_type args clos n =
           :: args)
           newclos (n - 1) )
 
-let machtype_of_layout = function Lambda.Pvalue _ -> typ_val
+let machtype_of_layout (layout : Lambda.layout) =
+  match layout with
+  | Ptop -> Misc.fatal_error "No machtype for layout [Ptop]"
+  | Pbottom -> Misc.fatal_error "No unique machtype for layout [Pbottom]"
+  | Punboxed_float -> typ_float
+  | Punboxed_int _ ->
+    (* Only 64-bit architectures, so this is always [typ_int] *)
+    typ_int
+  | Pvalue _ -> typ_val
 
 let final_curry_function nlocal arity result =
   let last_arg = V.create_local "arg" in
@@ -3140,5 +3151,11 @@ let emit_preallocated_blocks preallocated_blocks cont =
   let c1 = emit_gc_roots_table ~symbols cont in
   List.fold_left preallocate_block c1 preallocated_blocks
 
-let kind_of_layout (Lambda.Pvalue kind) = Vval kind
-
+let kind_of_layout (layout : Lambda.layout) =
+  match layout with
+  | Ptop | Pbottom ->
+    (* This is incorrect but only used for unboxing *)
+    Vval Pgenval
+  | Punboxed_float -> Vfloat
+  | Punboxed_int _ -> Vint
+  | Pvalue kind -> Vval kind

asmcomp/cmm_helpers.mli

@@ -194,10 +194,20 @@ val remove_unit : expression -> expression
 val field_address : expression -> int -> Debuginfo.t -> expression
 
 (** [get_field_gen mut ptr n dbg] returns an expression for the access to the
-    [n]th field of the block pointed to by [ptr] *)
+    [n]th field of the block pointed to by [ptr].  The [memory_chunk] used is
+    always [Word_val]. *)
 val get_field_gen :
   Asttypes.mutable_flag -> expression -> int -> Debuginfo.t -> expression
 
+(** Like [get_field_gen] but allows use of a different [memory_chunk]. *)
+val get_field_gen_given_memory_chunk :
+  Cmm.memory_chunk ->
+  Asttypes.mutable_flag ->
+  expression ->
+  int ->
+  Debuginfo.t ->
+  expression
+
 (** [set_field ptr n newval init dbg] returns an expression for setting the
     [n]th field of the block pointed to by [ptr] to [newval] *)
 val set_field :

asmcomp/cmmgen.ml

@@ -117,9 +117,20 @@ let mut_from_env env ptr =
       else Asttypes.Mutable
     | _ -> Asttypes.Mutable
 
-let get_field env ptr n dbg =
+let get_field env layout ptr n dbg =
   let mut = mut_from_env env ptr in
-  get_field_gen mut ptr n dbg
+  let memory_chunk =
+    match layout with
+    | Pvalue Pintval | Punboxed_int _ -> Word_int
+    | Pvalue _ -> Word_val
+    | Punboxed_float -> Double
+    | Ptop ->
+        Misc.fatal_errorf "get_field with Ptop: %a" Debuginfo.print_compact dbg
+    | Pbottom ->
+        Misc.fatal_errorf "get_field with Pbottom: %a" Debuginfo.print_compact
+          dbg
+  in
+  get_field_gen_given_memory_chunk memory_chunk mut ptr n dbg
 
 type rhs_kind =
   | RHS_block of Lambda.alloc_mode * int
@@ -448,9 +459,19 @@ let rec transl env e =
   | Ugeneric_apply(clos, args, args_layout, result_layout, kind, dbg) ->
       let clos = transl env clos in
       let args = List.map (transl env) args in
-      let args_type = List.map machtype_of_layout args_layout in
-      let return = machtype_of_layout result_layout in
-      generic_apply (mut_from_env env clos) clos args args_type return kind dbg
+      if List.mem Pbottom args_layout then
+        (* [machtype_of_layout] will fail on Pbottom, convert it to a sequence
+           and remove the call, preserving the execution order. *)
+        List.fold_left2 (fun rest arg arg_layout ->
+            if arg_layout = Pbottom then
+              arg
+            else
+              Csequence(remove_unit arg, rest)
+          ) (Ctuple []) args args_layout
+      else
+        let args_type = List.map machtype_of_layout args_layout in
+        let return = machtype_of_layout result_layout in
+        generic_apply (mut_from_env env clos) clos args args_type return kind dbg
   | Usend(kind, met, obj, args, args_layout, result_layout, pos, dbg) ->
       let met = transl env met in
       let obj = transl env obj in
@@ -596,6 +617,7 @@ let rec transl env e =
          | Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _
          | Pasrbint _ | Pbintcomp (_, _) | Pstring_load _ | Pbytes_load _
          | Pbytes_set _ | Pbigstring_load _ | Pbigstring_set _
+         | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _
          | Pbbswap _), _)
         ->
           fatal_error "Cmmgen.transl:prim"
@@ -731,27 +753,38 @@ and transl_catch (kind : Cmm.value_kind) env nfail ids body handler dbg =
      each argument.  *)
   let report args =
     List.iter2
-      (fun (_id, Pvalue kind, u) c ->
-         let strict =
-           match kind with
-           | Pfloatval | Pboxedintval _ -> false
-           | Pintval | Pgenval | Pvariant _ | Parrayval _ -> true
-         in
-         u := join_unboxed_number_kind ~strict !u
-             (is_unboxed_number_cmm ~strict c)
+      (fun (id, (layout : Lambda.layout), u) c ->
+         match layout with
+         | Ptop ->
+           Misc.fatal_errorf "Variable %a with layout [Ptop] can't be compiled"
+             VP.print id
+         | Pbottom ->
+           Misc.fatal_errorf
+             "Variable %a with layout [Pbottom] can't be compiled"
+             VP.print id
+         | Punboxed_float | Punboxed_int _ ->
+           u := No_unboxing
+         | Pvalue kind ->
+           let strict =
+             match kind with
+             | Pfloatval | Pboxedintval _ -> false
+             | Pintval | Pgenval | Pvariant _ | Parrayval _ -> true
+           in
+           u := join_unboxed_number_kind ~strict !u
+               (is_unboxed_number_cmm ~strict c)
       )
       ids args
   in
   let env_body = add_notify_catch nfail report env in
   let body = transl env_body body in
   let new_env, rewrite, ids =
     List.fold_right
-      (fun (id, _kind, u) (env, rewrite, ids) ->
+      (fun (id, layout, u) (env, rewrite, ids) ->
          match !u with
          | No_unboxing | Boxed (_, true) | No_result ->
              env,
              (fun x -> x) :: rewrite,
-             (id, Cmm.typ_val) :: ids
+             (id, machtype_of_layout layout) :: ids
          | Boxed (bn, false) ->
              let unboxed_id = V.create_local (VP.name id) in
              add_unboxed_id (VP.var id) unboxed_id bn env,
@@ -847,8 +880,8 @@ and transl_prim_1 env p arg dbg =
     Popaque ->
       opaque (transl env arg) dbg
   (* Heap operations *)
-  | Pfield n ->
-      get_field env (transl env arg) n dbg
+  | Pfield (n, layout) ->
+      get_field env layout (transl env arg) n dbg
   | Pfloatfield (n,mode) ->
       let ptr = transl env arg in
       box_float dbg mode (floatfield n ptr dbg)
@@ -864,7 +897,15 @@ and transl_prim_1 env p arg dbg =
       offsetint n (transl env arg) dbg
   | Poffsetref n ->
       offsetref n (transl env arg) dbg
+  | Punbox_int bi ->
+    transl_unbox_int dbg env bi arg
+  | Pbox_int (bi, m) ->
+    box_int dbg bi m (transl env arg)
   (* Floating-point operations *)
+  | Punbox_float ->
+      transl_unbox_float dbg env arg
+  | Pbox_float m ->
+      box_float dbg m (transl env arg)
   | Pfloatofint m ->
       box_float dbg m (Cop(Cfloatofint, [untag_int(transl env arg) dbg], dbg))
   | Pintoffloat ->
@@ -1099,6 +1140,7 @@ and transl_prim_2 env p arg1 arg2 dbg =
   | Pnegbint _ | Pbigarrayref (_, _, _, _) | Pbigarrayset (_, _, _, _)
   | Pbigarraydim _ | Pbytes_set _ | Pbigstring_set _ | Pbbswap _
   | Pprobe_is_enabled _
+  | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _
     ->
       fatal_errorf "Cmmgen.transl_prim_2: %a"
         Printclambda_primitives.primitive p
@@ -1159,6 +1201,7 @@ and transl_prim_3 env p arg1 arg2 arg3 dbg =
   | Pbigarrayref (_, _, _, _) | Pbigarrayset (_, _, _, _) | Pbigarraydim _
   | Pstring_load _ | Pbytes_load _ | Pbigstring_load _ | Pbbswap _
   | Pprobe_is_enabled _
+  | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _
     ->
       fatal_errorf "Cmmgen.transl_prim_3: %a"
         Printclambda_primitives.primitive p
@@ -1181,7 +1224,7 @@ and transl_unbox_sized size dbg env exp =
   | Thirty_two -> transl_unbox_int dbg env Pint32 exp
   | Sixty_four -> transl_unbox_int dbg env Pint64 exp
 
-and transl_let env str (Pvalue kind : Lambda.layout) id exp transl_body =
+and transl_let_value env str (kind : Lambda.value_kind) id exp transl_body =
   let dbg = Debuginfo.none in
   let cexp = transl env exp in
   let unboxing =
@@ -1233,6 +1276,30 @@ and transl_let env str (Pvalue kind : Lambda.layout) id exp transl_body =
       | Mutable, bn -> Clet_mut (v, typ_of_boxed_number bn, cexp, body)
       end
 
+and transl_let env str (layout : Lambda.layout) id exp transl_body =
+  match layout with
+  | Ptop ->
+      Misc.fatal_errorf "Variable %a with layout [Ptop] can't be compiled"
+        VP.print id
+  | Pbottom ->
+      let cexp = transl env exp in
+      (* N.B. [body] must still be traversed even if [exp] will never return:
+         there may be constant closures inside that need lifting out. *)
+      let _cbody : expression = transl_body env in
+      cexp
+  | Punboxed_float | Punboxed_int _ -> begin
+      let cexp = transl env exp in
+      let cbody = transl_body env in
+      match str with
+      | (Immutable | Immutable_unique) ->
+        Clet(id, cexp, cbody)
+      | Mutable ->
+        let typ = machtype_of_layout layout in
+        Clet_mut(id, typ, cexp, cbody)
+  end
+  | Pvalue kind ->
+      transl_let_value env str kind id exp transl_body
+
 and make_catch (kind : Cmm.value_kind) ncatch body handler dbg = match body with
 | Cexit (nexit,[]) when nexit=ncatch -> handler
 | _ ->  ccatch (ncatch, [], body, handler, dbg, kind)

asmcomp/emitaux.ml

@@ -203,7 +203,7 @@ let emit_frames a =
              not (Debuginfo.is_none d.Debuginfo.alloc_dbg)) dbgs
         then 3 else 2
     in
-    a.efa_code_label fd.fd_lbl;
+    a.efa_label_rel fd.fd_lbl 0l;
     efa_16_checked (fd.fd_frame_size + flags);
     efa_16_checked (List.length fd.fd_live_offset);
     List.iter efa_16_checked fd.fd_live_offset;

boot/ocamlc

@@ -109,8 +109,8 @@ let rec is_tailcall = function
    from the tail call optimization? *)
 
 let preserve_tailcall_for_prim = function
-    Popaque | Psequor | Psequand
-  | Pobj_magic ->
+    Popaque _ | Psequor | Psequand
+  | Pobj_magic _ ->
       true
   | Pbytes_to_string | Pbytes_of_string
   | Parray_to_iarray | Parray_of_iarray
@@ -123,6 +123,7 @@ let preserve_tailcall_for_prim = function
   | Pdivint _ | Pmodint _ | Pandint | Porint | Pxorint | Plslint | Plsrint
   | Pasrint | Pintcomp _ | Poffsetint _ | Poffsetref _ | Pintoffloat
   | Pfloatofint _ | Pnegfloat _ | Pabsfloat _ | Paddfloat _ | Psubfloat _ | Pmulfloat _
+  | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _
   | Pdivfloat _ | Pfloatcomp _ | Pstringlength | Pstringrefu  | Pstringrefs
   | Pcompare_ints | Pcompare_floats | Pcompare_bints _
   | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets
@@ -526,14 +527,15 @@ let comp_primitive p args =
   (* The cases below are handled in [comp_expr] before the [comp_primitive] call
      (in the order in which they appear below),
      so they should never be reached in this function. *)
-  | Pignore | Popaque | Pobj_magic
+  | Pignore | Popaque _ | Pobj_magic _
   | Pnot | Psequand | Psequor
   | Praise _
   | Pmakearray _ | Pduparray _
   | Pfloatcomp _
   | Pmakeblock _
   | Pmakefloatblock _
   | Pprobe_is_enabled _
+  | Punbox_float | Pbox_float _ | Punbox_int _ | Pbox_int _
     ->
       fatal_error "Bytegen.comp_primitive"
 
@@ -707,7 +709,11 @@ let rec comp_expr env exp sz cont =
         in
         comp_init env sz decl_size
       end
-  | Lprim((Popaque | Pobj_magic), [arg], _) ->
+  | Lprim((Popaque _ | Pobj_magic _), [arg], _) ->
+      comp_expr env arg sz cont
+  | Lprim((Pbox_float _ | Punbox_float), [arg], _) ->
+      comp_expr env arg sz cont
+  | Lprim((Pbox_int _ | Punbox_int _), [arg], _) ->
       comp_expr env arg sz cont
   | Lprim(Pignore, [arg], _) ->
       comp_expr env arg sz (add_const_unit cont)