flambda-backend: Revert "Revert "Add a proper top and bottom layout" (#1169)" (#1191)

This reverts commit 5123d61.

Author: Ekdohibs

asmcomp/cmm_helpers.ml

@@ -2239,7 +2239,11 @@ 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]"
+  | Pvalue _ -> typ_val
 
 let final_curry_function nlocal arity result =
   let last_arg = V.create_local "arg" in
@@ -3140,5 +3144,9 @@ 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
+  | Pvalue kind -> Vval kind

asmcomp/cmmgen.ml

@@ -448,9 +448,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
@@ -731,14 +741,23 @@ 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
+         | 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
@@ -1181,7 +1200,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 +1252,20 @@ 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
+  | 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)

lambda/lambda.ml

@@ -255,7 +255,9 @@ and value_kind =
   | Parrayval of array_kind
 
 and layout =
+  | Ptop
   | Pvalue of value_kind
+  | Pbottom
 
 and block_shape =
   value_kind list option
@@ -316,14 +318,30 @@ 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 equal_layout x y =
+  match x, y with
+  | Pvalue x, Pvalue y -> equal_value_kind x y
+  | Ptop, Ptop -> true
+  | Pbottom, Pbottom -> true
+  | _, _ -> false
 
-let compatible_layout (Pvalue _) (Pvalue _) = true
+let compatible_layout x y =
+  match x, y with
+  | Pbottom, _
+  | _, Pbottom -> true
+  | Pvalue _, Pvalue _ -> true
+  | Ptop, Ptop -> true
+  | Ptop, _ | _, Ptop -> false
 
 let must_be_value layout =
   match layout with
   | Pvalue v -> v
-  (* | _ -> Misc.fatal_error "Layout is not a value" *)
+  | Pbottom ->
+      (* Here, we want to get the [value_kind] corresponding to
+         a [Pbottom] layout. Anything will do, we return [Pgenval]
+         as a default. *)
+      Pgenval
+  | _ -> Misc.fatal_error "Layout is not a value"
 
 type structured_constant =
     Const_base of constant
@@ -601,10 +619,9 @@ let layout_lazy_contents = Pvalue Pgenval
 let layout_any_value = Pvalue Pgenval
 let layout_letrec = layout_any_value
 
-let layout_top = Pvalue Pgenval
-let layout_bottom =
-  (* CR pchambart: this should be an actual bottom *)
-  Pvalue Pgenval
+(* CR ncourant: use [Ptop] or remove this as soon as possible. *)
+let layout_top = layout_any_value
+let layout_bottom = Pbottom
 
 let default_function_attribute = {
   inline = Default_inline;

lambda/lambda.mli

@@ -212,7 +212,9 @@ and value_kind =
   | Parrayval of array_kind
 
 and layout =
+  | Ptop
   | Pvalue of value_kind
+  | Pbottom
 
 and block_shape =
   value_kind list option

lambda/printlambda.ml

@@ -95,7 +95,11 @@ and value_kind' ppf = function
   | Pvariant { consts; non_consts; } ->
     variant_kind value_kind' ppf ~consts ~non_consts
 
-let layout ppf (Pvalue k) = value_kind ppf k
+let layout ppf layout =
+  match layout with
+  | Pvalue k -> value_kind ppf k
+  | Ptop -> fprintf ppf "[top]"
+  | Pbottom -> fprintf ppf "[bottom]"
 
 let return_kind ppf (mode, kind) =
   let smode = alloc_mode mode in
@@ -109,6 +113,8 @@ let return_kind ppf (mode, kind) =
   | Pvalue (Pboxedintval bi) -> fprintf ppf ": %s%s@ " smode (boxed_integer_name bi)
   | Pvalue (Pvariant { consts; non_consts; }) ->
     variant_kind value_kind' ppf ~consts ~non_consts
+  | Ptop -> fprintf ppf ": top@ "
+  | Pbottom -> fprintf ppf ": bottom@ "
 
 let field_kind ppf = function
   | Pgenval -> pp_print_string ppf "*"

middle_end/clambda_primitives.ml

@@ -142,7 +142,9 @@ and value_kind = Lambda.value_kind =
   | Parrayval of array_kind
 
 and layout = Lambda.layout =
+  | Ptop
   | Pvalue of value_kind
+  | Pbottom
 
 and block_shape = Lambda.block_shape
 and boxed_integer = Primitive.boxed_integer =

middle_end/clambda_primitives.mli

@@ -145,7 +145,9 @@ and value_kind = Lambda.value_kind =
   | Parrayval of array_kind
 
 and layout = Lambda.layout =
+  | Ptop
   | Pvalue of value_kind
+  | Pbottom
 
 and block_shape = Lambda.block_shape
 and boxed_integer = Primitive.boxed_integer =

middle_end/closure/closure.ml

@@ -59,6 +59,8 @@ let rec add_to_closure_env env_param pos cenv = function
 
 let is_gc_ignorable kind =
   match kind with
+  | Ptop -> Misc.fatal_error "[Ptop] can't be stored in a closure."
+  | Pbottom -> Misc.fatal_error "[Pbottom] should not be stored in a closure."
   | Pvalue Pintval -> true
   | Pvalue (Pgenval | Pfloatval | Pboxedintval _ | Pvariant _ | Parrayval _) -> false
 

middle_end/flambda/closure_offsets.ml

@@ -70,7 +70,15 @@ let add_closure_offsets
   in
   let gc_invisible_free_vars, gc_visible_free_vars =
     Variable.Map.partition (fun _ (free_var : Flambda.specialised_to) ->
-        match free_var.kind with Pvalue Pintval -> true | Pvalue _ -> false)
+        match free_var.kind with
+        | Ptop ->
+          Misc.fatal_error "[Ptop] can't be stored in a closure."
+        | Pbottom ->
+          Misc.fatal_error
+            "[Pbottom] should have been eliminated as dead code \
+             and not stored in a closure."
+        | Pvalue Pintval -> true
+        | Pvalue _ -> false)
       free_vars
   in
   let free_variable_offsets, free_variable_pos =

middle_end/flambda/flambda_to_clambda.ml

@@ -696,6 +696,11 @@ and to_clambda_set_of_closures t env
   let not_scanned_fv, scanned_fv =
     Variable.Map.partition (fun _ (free_var : Flambda.specialised_to) ->
         match free_var.kind with
+        | Ptop -> Misc.fatal_error "[Ptop] can't be stored in a closure."
+        | Pbottom ->
+          Misc.fatal_error
+            "[Pbottom] should have been eliminated as dead code \
+             and not stored in a closure."
         | Pvalue Pintval -> true
         | Pvalue _ -> false)
       free_vars

middle_end/printclambda.ml

@@ -51,7 +51,11 @@ let rec value_kind0 ppf kind =
       non_consts
 
 let value_kind kind = Format.asprintf "%a" value_kind0 kind
-let layout (Lambda.Pvalue kind) = value_kind kind
+let layout (layout : Lambda.layout) =
+  match layout with
+  | Pvalue kind -> value_kind kind
+  | Ptop -> ":top"
+  | Pbottom -> ":bottom"
 
 let rec structured_constant ppf = function
   | Uconst_float x -> fprintf ppf "%F" x

typing/typeopt.ml

@@ -411,5 +411,10 @@ let value_kind_union (k1 : Lambda.value_kind) (k2 : Lambda.value_kind) =
   if Lambda.equal_value_kind k1 k2 then k1
   else Pgenval
 
-let layout_union (Pvalue layout1) (Pvalue layout2) =
-  Pvalue (value_kind_union layout1 layout2)
+let layout_union l1 l2 =
+  match l1, l2 with
+  | Pbottom, l
+  | l, Pbottom -> l
+  | Pvalue layout1, Pvalue layout2 ->
+      Pvalue (value_kind_union layout1 layout2)
+  | Ptop, _ | _, Ptop -> Ptop