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

Author: mshinwell

asmcomp/cmm_helpers.ml

@@ -2239,11 +2239,7 @@ let rec make_curry_apply result narity args_type args clos n =
           :: args)
           newclos (n - 1) )
 
-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 machtype_of_layout = function Lambda.Pvalue _ -> typ_val
 
 let final_curry_function nlocal arity result =
   let last_arg = V.create_local "arg" in
@@ -3144,9 +3140,5 @@ 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 (layout : Lambda.layout) =
-  match layout with
-  | Ptop | Pbottom ->
-    (* This is incorrect but only used for unboxing *)
-    Vval Pgenval
-  | Pvalue kind -> Vval kind
+let kind_of_layout (Lambda.Pvalue kind) = Vval kind
+

asmcomp/cmmgen.ml

@@ -448,19 +448,9 @@ 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
-      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
+      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
@@ -741,23 +731,14 @@ and transl_catch (kind : Cmm.value_kind) env nfail ids body handler dbg =
      each argument.  *)
   let report args =
     List.iter2
-      (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)
+      (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)
       )
       ids args
   in
@@ -1200,7 +1181,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_value 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 =
@@ -1252,20 +1233,6 @@ and transl_let_value env str (kind : Lambda.value_kind) 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,9 +255,7 @@ and value_kind =
   | Parrayval of array_kind
 
 and layout =
-  | Ptop
   | Pvalue of value_kind
-  | Pbottom
 
 and block_shape =
   value_kind list option
@@ -318,30 +316,14 @@ let rec equal_value_kind x y =
   | (Pgenval | Pfloatval | Pboxedintval _ | Pintval | Pvariant _
       | Parrayval _), _ -> false
 
-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 equal_layout (Pvalue x) (Pvalue y) = equal_value_kind x y
 
-let compatible_layout x y =
-  match x, y with
-  | Pbottom, _
-  | _, Pbottom -> true
-  | Pvalue _, Pvalue _ -> true
-  | Ptop, Ptop -> true
-  | Ptop, _ | _, Ptop -> false
+let compatible_layout (Pvalue _) (Pvalue _) = true
 
 let must_be_value layout =
   match layout with
   | Pvalue v -> v
-  | 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"
+  (* | _ -> Misc.fatal_error "Layout is not a value" *)
 
 type structured_constant =
     Const_base of constant
@@ -617,9 +599,10 @@ let layout_lazy_contents = Pvalue Pgenval
 let layout_any_value = Pvalue Pgenval
 let layout_letrec = layout_any_value
 
-(* CR ncourant: use [Ptop] or remove this as soon as possible. *)
-let layout_top = layout_any_value
-let layout_bottom = Pbottom
+let layout_top = Pvalue Pgenval
+let layout_bottom =
+  (* CR pchambart: this should be an actual bottom *)
+  Pvalue Pgenval
 
 let default_function_attribute = {
   inline = Default_inline;

lambda/lambda.mli

@@ -212,9 +212,7 @@ 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,11 +95,7 @@ and value_kind' ppf = function
   | Pvariant { consts; non_consts; } ->
     variant_kind value_kind' ppf ~consts ~non_consts
 
-let layout ppf layout =
-  match layout with
-  | Pvalue k -> value_kind ppf k
-  | Ptop -> fprintf ppf "[top]"
-  | Pbottom -> fprintf ppf "[bottom]"
+let layout ppf (Pvalue k) = value_kind ppf k
 
 let return_kind ppf (mode, kind) =
   let smode = alloc_mode mode in
@@ -113,8 +109,6 @@ 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,9 +142,7 @@ 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,9 +145,7 @@ 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,8 +59,6 @@ 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,15 +70,7 @@ 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
-        | 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)
+        match free_var.kind with Pvalue Pintval -> true | Pvalue _ -> false)
       free_vars
   in
   let free_variable_offsets, free_variable_pos =

middle_end/flambda/flambda_to_clambda.ml

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

typing/typeopt.ml

@@ -411,10 +411,5 @@ 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 l1 l2 =
-  match l1, l2 with
-  | Pbottom, l
-  | l, Pbottom -> l
-  | Pvalue layout1, Pvalue layout2 ->
-      Pvalue (value_kind_union layout1 layout2)
-  | Ptop, _ | _, Ptop -> Ptop
+let layout_union (Pvalue layout1) (Pvalue layout2) =
+  Pvalue (value_kind_union layout1 layout2)