flambda-backend: Add layout type in Lambda (#1032)

asmcomp/cmm_helpers.ml

@@ -1573,7 +1573,8 @@ struct
   type arg = expression
   type test = expression
   type act = expression
-  type nonrec value_kind = value_kind
+
+  type layout = value_kind
 
   (* CR mshinwell: GPR#2294 will fix the Debuginfo here *)
 
@@ -2997,3 +2998,6 @@ let emit_preallocated_blocks preallocated_blocks cont =
   in
   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
+

asmcomp/cmm_helpers.mli

@@ -658,3 +658,5 @@ val emit_preallocated_blocks :
   Clambda.preallocated_block list -> phrase list -> phrase list
 
 val make_symbol : ?compilation_unit:Compilation_unit.t -> string -> string
+
+val kind_of_layout : Lambda.layout -> value_kind

asmcomp/cmmgen.ml

@@ -596,41 +596,41 @@ let rec transl env e =
           (untag_int (transl env arg) dbg)
           s.us_index_consts
           (Array.map (fun expr -> transl env expr, dbg) s.us_actions_consts)
-          dbg (Vval kind)
+          dbg (kind_of_layout kind)
       else if Array.length s.us_index_consts = 0 then
         bind "switch" (transl env arg) (fun arg ->
-          transl_switch dbg (Vval kind) env (get_tag arg dbg)
+          transl_switch dbg (kind_of_layout kind) env (get_tag arg dbg)
             s.us_index_blocks s.us_actions_blocks)
       else
         bind "switch" (transl env arg) (fun arg ->
           Cifthenelse(
           Cop(Cand, [arg; Cconst_int (1, dbg)], dbg),
           dbg,
-          transl_switch dbg (Vval kind) env
+          transl_switch dbg (kind_of_layout kind) env
             (untag_int arg dbg) s.us_index_consts s.us_actions_consts,
           dbg,
-          transl_switch dbg (Vval kind) env
+          transl_switch dbg (kind_of_layout kind) env
             (get_tag arg dbg) s.us_index_blocks s.us_actions_blocks,
-          dbg, Vval kind))
+          dbg, kind_of_layout kind))
   | Ustringswitch(arg,sw,d, kind) ->
       let dbg = Debuginfo.none in
       bind "switch" (transl env arg)
         (fun arg ->
-          strmatch_compile dbg (Vval kind) arg (Option.map (transl env) d)
+          strmatch_compile dbg (kind_of_layout kind) arg (Option.map (transl env) d)
             (List.map (fun (s,act) -> s,transl env act) sw))
   | Ustaticfail (nfail, args) ->
       let cargs = List.map (transl env) args in
       notify_catch nfail env cargs;
       Cexit (nfail, cargs)
   | Ucatch(nfail, [], body, handler, kind) ->
       let dbg = Debuginfo.none in
-      make_catch (Vval kind) nfail (transl env body) (transl env handler) dbg
+      make_catch (kind_of_layout kind) nfail (transl env body) (transl env handler) dbg
   | Ucatch(nfail, ids, body, handler, kind) ->
       let dbg = Debuginfo.none in
-      transl_catch (Vval kind) env nfail ids body handler dbg
+      transl_catch (kind_of_layout kind) env nfail ids body handler dbg
   | Utrywith(body, exn, handler, kind) ->
       let dbg = Debuginfo.none in
-      Ctrywith(transl env body, exn, transl env handler, dbg, Vval kind)
+      Ctrywith(transl env body, exn, transl env handler, dbg, kind_of_layout kind)
   | Uifthenelse(cond, ifso, ifnot, kind) ->
       let ifso_dbg = Debuginfo.none in
       let ifnot_dbg = Debuginfo.none in
@@ -643,7 +643,7 @@ let rec transl env e =
         | Cconst_int (3, _), Cconst_int (1, _) -> Then_true_else_false
         | _, _ -> Unknown
       in
-      transl_if env (Vval kind) approx dbg cond
+      transl_if env (kind_of_layout kind) approx dbg cond
         ifso_dbg ifso ifnot_dbg ifnot
   | Usequence(exp1, exp2) ->
       Csequence(remove_unit(transl env exp1), transl env exp2)
@@ -717,7 +717,7 @@ and transl_catch (kind : Cmm.value_kind) env nfail ids body handler dbg =
      each argument.  *)
   let report args =
     List.iter2
-      (fun (_id, kind, u) c ->
+      (fun (_id, Pvalue kind, u) c ->
          let strict =
            match kind with
            | Pfloatval | Pboxedintval _ -> false
@@ -1167,7 +1167,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 (kind : Lambda.value_kind) id exp transl_body =
+and transl_let env str (Pvalue kind : Lambda.layout) id exp transl_body =
   let dbg = Debuginfo.none in
   let cexp = transl env exp in
   let unboxing =

lambda/lambda.ml

@@ -227,6 +227,9 @@ and value_kind =
     }
   | Parrayval of array_kind
 
+and layout =
+  | Pvalue of value_kind
+
 and block_shape =
   value_kind list option
 
@@ -286,6 +289,12 @@ let rec equal_value_kind x y =
   | (Pgenval | Pfloatval | Pboxedintval _ | Pintval | Pvariant _
       | Parrayval _), _ -> false
 
+let equal_layout (Pvalue x) (Pvalue y) = equal_value_kind x y
+
+let must_be_value layout =
+  match layout with
+  | Pvalue v -> v
+  (* | _ -> Misc.fatal_error "Layout is not a value" *)
 
 type structured_constant =
     Const_base of constant
@@ -416,17 +425,17 @@ type lambda =
   | Lconst of structured_constant
   | Lapply of lambda_apply
   | Lfunction of lfunction
-  | Llet of let_kind * value_kind * Ident.t * lambda * lambda
-  | Lmutlet of value_kind * Ident.t * lambda * lambda
+  | Llet of let_kind * layout * Ident.t * lambda * lambda
+  | Lmutlet of layout * Ident.t * lambda * lambda
   | Lletrec of (Ident.t * lambda) list * lambda
   | Lprim of primitive * lambda list * scoped_location
-  | Lswitch of lambda * lambda_switch * scoped_location * value_kind
+  | Lswitch of lambda * lambda_switch * scoped_location * layout
   | Lstringswitch of
-      lambda * (string * lambda) list * lambda option * scoped_location * value_kind
+      lambda * (string * lambda) list * lambda option * scoped_location * layout
   | Lstaticraise of int * lambda list
-  | Lstaticcatch of lambda * (int * (Ident.t * value_kind) list) * lambda * value_kind
-  | Ltrywith of lambda * Ident.t * lambda * value_kind
-  | Lifthenelse of lambda * lambda * lambda * value_kind
+  | Lstaticcatch of lambda * (int * (Ident.t * layout) list) * lambda * layout
+  | Ltrywith of lambda * Ident.t * lambda * layout
+  | Lifthenelse of lambda * lambda * lambda * layout
   | Lsequence of lambda * lambda
   | Lwhile of lambda_while
   | Lfor of lambda_for
@@ -440,8 +449,8 @@ type lambda =
 
 and lfunction =
   { kind: function_kind;
-    params: (Ident.t * value_kind) list;
-    return: value_kind;
+    params: (Ident.t * layout) list;
+    return: layout;
     body: lambda;
     attr: function_attribute; (* specified with [@inline] attribute *)
     loc: scoped_location;
@@ -538,6 +547,27 @@ let lfunction ~kind ~params ~return ~body ~attr ~loc ~mode ~region =
 
 let lambda_unit = Lconst const_unit
 
+let layout_unit = Pvalue Pintval
+let layout_int = Pvalue Pintval
+let layout_array kind = Pvalue (Parrayval kind)
+let layout_block = Pvalue Pgenval
+let layout_list =
+  Pvalue (Pvariant { consts = [0] ; non_consts = [0, [Pgenval; Pgenval]] })
+let layout_field = Pvalue Pgenval
+let layout_function = Pvalue Pgenval
+let layout_object = Pvalue Pgenval
+let layout_class = Pvalue Pgenval
+let layout_module = Pvalue Pgenval
+let layout_module_field = Pvalue Pgenval
+let layout_functor = Pvalue Pgenval
+let layout_float = Pvalue Pfloatval
+let layout_string = Pvalue Pgenval
+let layout_boxedint bi = Pvalue (Pboxedintval bi)
+let layout_lazy = Pvalue Pgenval
+let layout_lazy_contents = Pvalue Pgenval
+
+let layout_top = Pvalue Pgenval
+
 let default_function_attribute = {
   inline = Default_inline;
   specialise = Default_specialise;
@@ -649,21 +679,21 @@ let make_key e =
 
 (***************)
 
-let name_lambda strict arg fn =
+let name_lambda strict arg layout fn =
   match arg with
     Lvar id -> fn id
   | _ ->
       let id = Ident.create_local "let" in
-      Llet(strict, Pgenval, id, arg, fn id)
+      Llet(strict, layout, id, arg, fn id)
 
 let name_lambda_list args fn =
   let rec name_list names = function
     [] -> fn (List.rev names)
-  | (Lvar _ as arg) :: rem ->
+  | (Lvar _ as arg, _) :: rem ->
       name_list (arg :: names) rem
-  | arg :: rem ->
+  | (arg, layout) :: rem ->
       let id = Ident.create_local "let" in
-      Llet(Strict, Pgenval, id, arg, name_list (Lvar id :: names) rem) in
+      Llet(Strict, layout, id, arg, name_list (Lvar id :: names) rem) in
   name_list [] args
 
 
@@ -1056,40 +1086,40 @@ let shallow_map ~tail ~non_tail:f = function
   | Lfunction { kind; params; return; body; attr; loc; mode; region } ->
       Lfunction { kind; params; return; body = f body; attr; loc;
                   mode; region }
-  | Llet (str, k, v, e1, e2) ->
-      Llet (str, k, v, f e1, tail e2)
-  | Lmutlet (k, v, e1, e2) ->
-      Lmutlet (k, v, f e1, tail e2)
+  | Llet (str, layout, v, e1, e2) ->
+      Llet (str, layout, v, f e1, tail e2)
+  | Lmutlet (layout, v, e1, e2) ->
+      Lmutlet (layout, v, f e1, tail e2)
   | Lletrec (idel, e2) ->
       Lletrec (List.map (fun (v, e) -> (v, f e)) idel, tail e2)
   | Lprim (Psequand as p, [l1; l2], loc)
   | Lprim (Psequor as p, [l1; l2], loc) ->
       Lprim(p, [f l1; tail l2], loc)
   | Lprim (p, el, loc) ->
       Lprim (p, List.map f el, loc)
-  | Lswitch (e, sw, loc,kind) ->
+  | Lswitch (e, sw, loc, layout) ->
       Lswitch (f e,
                { sw_numconsts = sw.sw_numconsts;
                  sw_consts = List.map (fun (n, e) -> (n, tail e)) sw.sw_consts;
                  sw_numblocks = sw.sw_numblocks;
                  sw_blocks = List.map (fun (n, e) -> (n, tail e)) sw.sw_blocks;
                  sw_failaction = Option.map tail sw.sw_failaction;
                },
-               loc,kind)
-  | Lstringswitch (e, sw, default, loc,kind) ->
+               loc, layout)
+  | Lstringswitch (e, sw, default, loc, layout) ->
       Lstringswitch (
         f e,
         List.map (fun (s, e) -> (s, tail e)) sw,
         Option.map tail default,
-        loc, kind)
+        loc, layout)
   | Lstaticraise (i, args) ->
       Lstaticraise (i, List.map f args)
-  | Lstaticcatch (body, id, handler, kind) ->
-      Lstaticcatch (tail body, id, tail handler, kind)
-  | Ltrywith (e1, v, e2, kind) ->
-      Ltrywith (f e1, v, tail e2, kind)
-  | Lifthenelse (e1, e2, e3, kind) ->
-      Lifthenelse (f e1, tail e2, tail e3, kind)
+  | Lstaticcatch (body, id, handler, layout) ->
+      Lstaticcatch (tail body, id, tail handler, layout)
+  | Ltrywith (e1, v, e2, layout) ->
+      Ltrywith (f e1, v, tail e2, layout)
+  | Lifthenelse (e1, e2, e3, layout) ->
+      Lifthenelse (f e1, tail e2, tail e3, layout)
   | Lsequence (e1, e2) ->
       Lsequence (f e1, tail e2)
   | Lwhile lw ->
@@ -1116,13 +1146,10 @@ let map f =
 
 (* To let-bind expressions to variables *)
 
-let bind_with_value_kind str (var, kind) exp body =
+let bind_with_layout str (var, layout) exp body =
   match exp with
     Lvar var' when Ident.same var var' -> body
-  | _ -> Llet(str, kind, var, exp, body)
-
-let bind str var exp body =
-  bind_with_value_kind str (var, Pgenval) exp body
+  | _ -> Llet(str, layout, var, exp, body)
 
 let negate_integer_comparison = function
   | Ceq -> Cne
@@ -1289,3 +1316,16 @@ let primitive_may_allocate : primitive -> alloc_mode option = function
   | Pprobe_is_enabled _ -> None
   | Pobj_dup -> Some alloc_heap
   | Pobj_magic -> None
+
+let constant_layout = function
+  | Const_int _ | Const_char _ -> Pvalue Pintval
+  | Const_string _ -> Pvalue Pgenval
+  | Const_int32 _ -> Pvalue (Pboxedintval Pint32)
+  | Const_int64 _ -> Pvalue (Pboxedintval Pint64)
+  | Const_nativeint _ -> Pvalue (Pboxedintval Pnativeint)
+  | Const_float _ -> Pvalue Pfloatval
+
+let structured_constant_layout = function
+  | Const_base const -> constant_layout const
+  | Const_block _ | Const_immstring _ -> Pvalue Pgenval
+  | Const_float_array _ | Const_float_block _ -> Pvalue (Parrayval Pfloatarray)