flambda-backend: Remove remaining layout_top after #1084 (#1138)

ocaml-flambda · Feb 28, 2023 · 56d014e · 56d014e
1 parent dc1c1ce
commit 56d014e
Show file tree

Hide file tree

Showing 23 changed files with 335 additions and 231 deletions.
diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml
@@ -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 | Pignore
   | Pgetglobal _ | Psetglobal _ | Pgetpredef _
@@ -522,7 +522,7 @@ 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 _
@@ -703,7 +703,7 @@ 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(Pignore, [arg], _) ->
       comp_expr env arg sz (add_const_unit cont)

diff --git a/lambda/lambda.ml b/lambda/lambda.ml
@@ -233,12 +233,12 @@ type primitive =
   (* Integer to external pointer *)
   | Pint_as_pointer
   (* Inhibition of optimisation *)
-  | Popaque
+  | Popaque of layout
   (* Statically-defined probes *)
   | Pprobe_is_enabled of { name: string }
   (* Primitives for [Obj] *)
   | Pobj_dup
-  | Pobj_magic
+  | Pobj_magic of layout
 
 and integer_comparison =
     Ceq | Cne | Clt | Cgt | Cle | Cge
@@ -1349,10 +1349,10 @@ let primitive_may_allocate : primitive -> alloc_mode option = function
   | Pbswap16 -> None
   | Pbbswap (_, m) -> Some m
   | Pint_as_pointer -> None
-  | Popaque -> None
+  | Popaque _ -> None
   | Pprobe_is_enabled _ -> None
   | Pobj_dup -> Some alloc_heap
-  | Pobj_magic -> None
+  | Pobj_magic _ -> None
 
 let constant_layout = function
   | Const_int _ | Const_char _ -> Pvalue Pintval
@@ -1367,4 +1367,77 @@ let structured_constant_layout = function
   | Const_block _ | Const_immstring _ -> Pvalue Pgenval
   | Const_float_array _ | Const_float_block _ -> Pvalue (Parrayval Pfloatarray)
 
-let primitive_result_layout (_p : primitive) = layout_top
+let primitive_result_layout (p : primitive) =
+  match p with
+  | Popaque layout | Pobj_magic layout -> layout
+  | Pbytes_to_string | Pbytes_of_string -> layout_string
+  | Pignore | Psetfield _ | Psetfield_computed _ | Psetfloatfield _ | Poffsetref _
+  | Pbytessetu | Pbytessets | Parraysetu _ | Parraysets _ | Pbigarrayset _
+  | Pbytes_set_16 _ | Pbytes_set_32 _ | Pbytes_set_64 _
+  | Pbigstring_set_16 _ | Pbigstring_set_32 _ | Pbigstring_set_64 _
+    -> layout_unit
+  | Pgetglobal _ | Psetglobal _ | Pgetpredef _ -> layout_module_field
+  | Pmakeblock _ | Pmakefloatblock _ | Pmakearray _ | Pduprecord _
+  | Pduparray _ | Pbigarraydim _ | Pobj_dup -> layout_block
+  | Pfield _ | Pfield_computed _ -> layout_field
+  | Pfloatfield _ | Pfloatofint _ | Pnegfloat _ | Pabsfloat _
+  | Paddfloat _ | Psubfloat _ | Pmulfloat _ | Pdivfloat _ -> layout_float
+  | Pccall _p ->
+      (* CR ncourant: use native_repr *)
+      layout_any_value
+  | Praise _ -> layout_bottom
+  | Psequor | Psequand | Pnot
+  | Pnegint | Paddint | Psubint | Pmulint
+  | Pdivint _ | Pmodint _
+  | Pandint | Porint | Pxorint
+  | Plslint | Plsrint | Pasrint
+  | Pintcomp _
+  | Pcompare_ints | Pcompare_floats | Pcompare_bints _
+  | Poffsetint _ | Pintoffloat | Pfloatcomp _
+  | Pstringlength | Pstringrefu | Pstringrefs
+  | Pbyteslength | Pbytesrefu | Pbytesrefs
+  | Parraylength _ | Pisint _ | Pisout | Pintofbint _
+  | Pbintcomp _
+  | Pstring_load_16 _ | Pbytes_load_16 _ | Pbigstring_load_16 _
+  | Pprobe_is_enabled _ | Pbswap16
+    -> layout_int
+  | Parrayrefu array_kind | Parrayrefs array_kind ->
+      (match array_kind with
+       | Pintarray -> layout_int
+       | Pfloatarray -> layout_float
+       | Pgenarray | Paddrarray -> layout_field)
+  | Pbintofint (bi, _) | Pcvtbint (_,bi,_)
+  | Pnegbint (bi, _) | Paddbint (bi, _) | Psubbint (bi, _)
+  | Pmulbint (bi, _) | Pdivbint {size = bi} | Pmodbint {size = bi}
+  | Pandbint (bi, _) | Porbint (bi, _) | Pxorbint (bi, _)
+  | Plslbint (bi, _) | Plsrbint (bi, _) | Pasrbint (bi, _)
+  | Pbbswap (bi, _) ->
+      layout_boxedint bi
+  | Pstring_load_32 _ | Pbytes_load_32 _ | Pbigstring_load_32 _ ->
+      layout_boxedint Pint32
+  | Pstring_load_64 _ | Pbytes_load_64 _ | Pbigstring_load_64 _ ->
+      layout_boxedint Pint64
+  | Pbigarrayref (_, _, kind, _) ->
+      begin match kind with
+      | Pbigarray_unknown -> layout_any_value
+      | Pbigarray_float32 | Pbigarray_float64 -> layout_float
+      | Pbigarray_sint8 | Pbigarray_uint8
+      | Pbigarray_sint16 | Pbigarray_uint16
+      | Pbigarray_caml_int -> layout_int
+      | Pbigarray_int32 -> layout_boxedint Pint32
+      | Pbigarray_int64 -> layout_boxedint Pint64
+      | Pbigarray_native_int -> layout_boxedint Pnativeint
+      | Pbigarray_complex32 | Pbigarray_complex64 ->
+          layout_block
+      end
+  | Pctconst (
+      Big_endian | Word_size | Int_size | Max_wosize
+      | Ostype_unix | Ostype_cygwin | Ostype_win32 | Backend_type
+    ) ->
+      (* Compile-time constants only ever return ints for now,
+         enumerate them all to be sure to modify this if it becomes wrong. *)
+      layout_int
+  | Pint_as_pointer ->
+      (* CR ncourant: use an unboxed int64 here when it exists *)
+      layout_any_value
+
diff --git a/lambda/lambda.mli b/lambda/lambda.mli
@@ -184,12 +184,12 @@ type primitive =
   (* Integer to external pointer *)
   | Pint_as_pointer
   (* Inhibition of optimisation *)
-  | Popaque
+  | Popaque of layout
   (* Statically-defined probes *)
   | Pprobe_is_enabled of { name: string }
   (* Primitives for [Obj] *)
   | Pobj_dup
-  | Pobj_magic
+  | Pobj_magic of layout
 
 and integer_comparison =
     Ceq | Cne | Clt | Cgt | Cle | Cge

diff --git a/lambda/printlambda.ml b/lambda/printlambda.ml
@@ -437,10 +437,10 @@ let primitive ppf = function
   | Pbswap16 -> fprintf ppf "bswap16"
   | Pbbswap(bi,m) -> print_boxed_integer "bswap" ppf bi m
   | Pint_as_pointer -> fprintf ppf "int_as_pointer"
-  | Popaque -> fprintf ppf "opaque"
+  | Popaque _ -> fprintf ppf "opaque"
   | Pprobe_is_enabled {name} -> fprintf ppf "probe_is_enabled[%s]" name
   | Pobj_dup -> fprintf ppf "obj_dup"
-  | Pobj_magic -> fprintf ppf "obj_magic"
+  | Pobj_magic _ -> fprintf ppf "obj_magic"
 
 let name_of_primitive = function
   | Pbytes_of_string -> "Pbytes_of_string"
@@ -545,10 +545,10 @@ let name_of_primitive = function
   | Pbswap16 -> "Pbswap16"
   | Pbbswap _ -> "Pbbswap"
   | Pint_as_pointer -> "Pint_as_pointer"
-  | Popaque -> "Popaque"
+  | Popaque _ -> "Popaque"
   | Pprobe_is_enabled _ -> "Pprobe_is_enabled"
   | Pobj_dup -> "Pobj_dup"
-  | Pobj_magic -> "Pobj_magic"
+  | Pobj_magic _ -> "Pobj_magic"
 
 let check_attribute ppf check =
   let check_property = function

diff --git a/lambda/tmc.ml b/lambda/tmc.ml
@@ -842,12 +842,12 @@ let rec choice ctx t =
         choice_makeblock ctx ~tail (tag, flag, shape, mode) primargs loc
 
     (* Some primitives have arguments in tail-position *)
-    | Popaque ->
+    | Popaque layout ->
         let l1 = match primargs with
           |  [l1] -> l1
           | _ -> invalid_arg "choice_prim" in
         let+ l1 = choice ctx ~tail l1 in
-        Lprim (Popaque, [l1], loc)
+        Lprim (Popaque layout, [l1], loc)
     | (Psequand | Psequor) as shortcutop ->
         let l1, l2 = match primargs with
           |  [l1; l2] -> l1, l2
@@ -891,7 +891,7 @@ let rec choice ctx t =
     | Pmakefloatblock _
 
     | Pobj_dup
-    | Pobj_magic
+    | Pobj_magic _
     | Pprobe_is_enabled _
 
     (* operations returning boxed values could be considered

diff --git a/lambda/translclass.ml b/lambda/translclass.ml
@@ -68,7 +68,7 @@ let lapply ap =
 
 let mkappl (func, args, layout) =
   Lprim
-    (Popaque,
+    (Popaque layout,
      [Lapply {
          ap_loc=Loc_unknown;
          ap_func=func;
@@ -290,7 +290,8 @@ let output_methods tbl methods lam =
         Lprim(Pmakeblock(0,Immutable,None,alloc_heap), methods, Loc_unknown)
       in
       lsequence (mkappl(oo_prim "set_methods",
-                        [Lvar tbl; Lprim (Popaque, [methods], Loc_unknown)], layout_unit))
+                        [Lvar tbl; Lprim (Popaque layout_block,
+                                          [methods], Loc_unknown)], layout_unit))
         lam
 
 let rec ignore_cstrs cl =

diff --git a/lambda/translcore.ml b/lambda/translcore.ml
@@ -770,7 +770,7 @@ and transl_exp0 ~in_new_scope ~scopes e =
             optimisation in Flambda, but the concept of a mutable
             block doesn't really match what is going on here.  This
             value may subsequently turn into an immediate... *)
-         Lprim (Popaque,
+         Lprim (Popaque Lambda.layout_lazy,
                 [Lprim(Pmakeblock(Obj.forward_tag, Immutable, None,
                                   alloc_heap),
                        [transl_exp ~scopes e],
@@ -1006,7 +1006,7 @@ and transl_apply ~scopes
         }
   in
   let rec build_apply lam args loc pos ap_mode = function
-    | Omitted { mode_closure; mode_arg; mode_ret } :: l ->
+    | Omitted { mode_closure; mode_arg; mode_ret; ty_arg; ty_env } :: l ->
         assert (pos = Rc_normal);
         let defs = ref [] in
         let protect name (lam, layout) =
@@ -1049,8 +1049,8 @@ and transl_apply ~scopes
             | Alloc_local -> false
             | Alloc_heap -> true
           in
-          (* CR ncourant: need layout of the omitted parameter *)
-          lfunction ~kind:(Curried {nlocal}) ~params:[id_arg, Lambda.layout_top]
+          let layout_arg = Typeopt.layout ty_env ty_arg in
+          lfunction ~kind:(Curried {nlocal}) ~params:[id_arg, layout_arg]
                     ~return:result_layout ~body ~mode ~region
                     ~attr:default_stub_attribute ~loc
         in

diff --git a/lambda/translobj.ml b/lambda/translobj.ml
@@ -92,13 +92,14 @@ let transl_label_init_general f =
   let expr =
     Hashtbl.fold
       (fun c id expr ->
+         let layout = Lambda.structured_constant_layout c in
          let const =
-           Lprim (Popaque, [Lconst c], Debuginfo.Scoped_location.Loc_unknown)
+           Lprim (Popaque layout, [Lconst c], Debuginfo.Scoped_location.Loc_unknown)
          in
          (* CR ncourant: this *should* not be too precise for the moment,
             but we should take care, or fix the underlying cause that led
             us to using [Popaque]. *)
-         Llet(Alias, Lambda.structured_constant_layout c, id, const, expr))
+         Llet(Alias, layout, id, const, expr))
       consts expr
   in
   (*let expr =
@@ -190,7 +191,7 @@ let oo_wrap env req f x =
                         Loc_unknown)
                 in
                 Llet(StrictOpt, Lambda.layout_class, id,
-                     Lprim (Popaque, [cl], Loc_unknown),
+                     Lprim (Popaque Lambda.layout_class, [cl], Loc_unknown),
                      lambda))
              lambda !classes
          in

diff --git a/lambda/translprim.ml b/lambda/translprim.ml
@@ -86,9 +86,9 @@ type prim =
   | Raise_with_backtrace
   | Lazy_force of Lambda.region_close
   | Loc of loc_kind
-  | Send of Lambda.region_close
-  | Send_self of Lambda.region_close
-  | Send_cache of Lambda.region_close
+  | Send of Lambda.region_close * Lambda.layout
+  | Send_self of Lambda.region_close * Lambda.layout
+  | Send_cache of Lambda.region_close * Lambda.layout
   | Frame_pointers
   | Identity
   | Apply of Lambda.region_close * Lambda.layout
@@ -385,11 +385,11 @@ let lookup_primitive loc poly pos p =
     | "%bswap_int64" -> Primitive ((Pbbswap(Pint64, mode)), 1)
     | "%bswap_native" -> Primitive ((Pbbswap(Pnativeint, mode)), 1)
     | "%int_as_pointer" -> Primitive (Pint_as_pointer, 1)
-    | "%opaque" -> Primitive (Popaque, 1)
+    | "%opaque" -> Primitive (Popaque Lambda.layout_any_value, 1)
     | "%sys_argv" -> Sys_argv
-    | "%send" -> Send pos
-    | "%sendself" -> Send_self pos
-    | "%sendcache" -> Send_cache pos
+    | "%send" -> Send (pos, Lambda.layout_any_value)
+    | "%sendself" -> Send_self (pos, Lambda.layout_any_value)
+    | "%sendcache" -> Send_cache (pos, Lambda.layout_any_value)
     | "%equal" -> Comparison(Equal, Compare_generic)
     | "%notequal" -> Comparison(Not_equal, Compare_generic)
     | "%lessequal" -> Comparison(Less_equal, Compare_generic)
@@ -398,7 +398,7 @@ let lookup_primitive loc poly pos p =
     | "%greaterthan" -> Comparison(Greater_than, Compare_generic)
     | "%compare" -> Comparison(Compare, Compare_generic)
     | "%obj_dup" -> Primitive(Pobj_dup, 1)
-    | "%obj_magic" -> Primitive(Pobj_magic, 1)
+    | "%obj_magic" -> Primitive(Pobj_magic Lambda.layout_any_value, 1)
     | s when String.length s > 0 && s.[0] = '%' ->
        raise(Error(loc, Unknown_builtin_primitive s))
     | _ -> External p
@@ -727,16 +727,16 @@ let lambda_of_prim prim_name prim loc args arg_exps =
   | Loc kind, [arg] ->
       let lam = lambda_of_loc kind loc in
       Lprim(Pmakeblock(0, Immutable, None, alloc_heap), [lam; arg], loc)
-  | Send pos, [obj; meth] ->
-      Lsend(Public, meth, obj, [], pos, alloc_heap, loc, Lambda.layout_top)
-  | Send_self pos, [obj; meth] ->
-      Lsend(Self, meth, obj, [], pos, alloc_heap, loc, Lambda.layout_top)
-  | Send_cache apos, [obj; meth; cache; pos] ->
+  | Send (pos, layout), [obj; meth] ->
+      Lsend(Public, meth, obj, [], pos, alloc_heap, loc, layout)
+  | Send_self (pos, layout), [obj; meth] ->
+      Lsend(Self, meth, obj, [], pos, alloc_heap, loc, layout)
+  | Send_cache (apos, layout), [obj; meth; cache; pos] ->
       (* Cached mode only works in the native backend *)
       if !Clflags.native_code then
-        Lsend(Cached, meth, obj, [cache; pos], apos, alloc_heap, loc, Lambda.layout_top)
+        Lsend(Cached, meth, obj, [cache; pos], apos, alloc_heap, loc, layout)
       else
-        Lsend(Public, meth, obj, [], apos, alloc_heap, loc, Lambda.layout_top)
+        Lsend(Public, meth, obj, [], apos, alloc_heap, loc, layout)
   | Frame_pointers, [] ->
       let frame_pointers =
         if !Clflags.native_code && Config.with_frame_pointers then 1 else 0
@@ -805,17 +805,18 @@ let transl_primitive loc p env ty ~poly_mode path =
     | Some prim -> prim
   in
   let rec make_params ty n =
-    if n <= 0 then []
+    if n <= 0 then [], Typeopt.layout env ty
     else
       match Typeopt.is_function_type env ty with
       | None ->
           Misc.fatal_errorf "Primitive %s type does not correspond to arity"
             (Primitive.byte_name p)
       | Some (arg_ty, ret_ty) ->
           let arg_layout = Typeopt.layout env arg_ty in
-          (Ident.create_local "prim", arg_layout) :: make_params ret_ty (n-1)
+          let params, return = make_params ret_ty (n-1) in
+          (Ident.create_local "prim", arg_layout) :: params, return
   in
-  let params = make_params ty p.prim_arity in
+  let params, return = make_params ty p.prim_arity in
   let args = List.map (fun (id, _) -> Lvar id) params in
   match params with
   | [] -> lambda_of_prim p.prim_name prim loc args None
@@ -843,7 +844,7 @@ let transl_primitive loc p env ty ~poly_mode path =
      lfunction
        ~kind:(Curried {nlocal})
        ~params
-       ~return:Lambda.layout_top
+       ~return
        ~attr:default_stub_attribute
        ~loc
        ~body
@@ -881,8 +882,8 @@ let lambda_primitive_needs_event_after = function
   | Pbytessetu | Pmakearray ((Pintarray | Paddrarray | Pfloatarray), _, _)
   | Parraylength _ | Parrayrefu _ | Parraysetu _ | Pisint _ | Pisout
   | Pprobe_is_enabled _
-  | Pintofbint _ | Pctconst _ | Pbswap16 | Pint_as_pointer | Popaque
-  | Pobj_magic -> false
+  | Pintofbint _ | Pctconst _ | Pbswap16 | Pint_as_pointer | Popaque _
+  | Pobj_magic _ -> false
 
 (* Determine if a primitive should be surrounded by an "after" debug event *)
 let primitive_needs_event_after = function