diff --git a/asmcomp/cmm_helpers.ml b/asmcomp/cmm_helpers.ml index 8c43fb09b15..13529811715 100644 --- a/asmcomp/cmm_helpers.ml +++ b/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 + diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 6f6fc010ea7..8c8b2eb0c68 100644 --- a/asmcomp/cmmgen.ml +++ b/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) diff --git a/lambda/lambda.ml b/lambda/lambda.ml index cfb85dcccd6..66eb5af5d96 100644 --- a/lambda/lambda.ml +++ b/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; diff --git a/lambda/lambda.mli b/lambda/lambda.mli index 2862f5af974..2e0ac83d3da 100644 --- a/lambda/lambda.mli +++ b/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 diff --git a/lambda/printlambda.ml b/lambda/printlambda.ml index 4c7eb218208..a5e759ab0dc 100644 --- a/lambda/printlambda.ml +++ b/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 "*" diff --git a/middle_end/clambda_primitives.ml b/middle_end/clambda_primitives.ml index 72dd70af2c3..b56314afa9c 100644 --- a/middle_end/clambda_primitives.ml +++ b/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 = diff --git a/middle_end/clambda_primitives.mli b/middle_end/clambda_primitives.mli index 65a52db1644..6bd588ae13d 100644 --- a/middle_end/clambda_primitives.mli +++ b/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 = diff --git a/middle_end/closure/closure.ml b/middle_end/closure/closure.ml index 9a3753c7c62..116c28fe0b8 100644 --- a/middle_end/closure/closure.ml +++ b/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 diff --git a/middle_end/flambda/closure_offsets.ml b/middle_end/flambda/closure_offsets.ml index 5891b508f6d..f88f1683cdf 100644 --- a/middle_end/flambda/closure_offsets.ml +++ b/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 = diff --git a/middle_end/flambda/flambda_to_clambda.ml b/middle_end/flambda/flambda_to_clambda.ml index 8781f1f29cb..34c1dae0eec 100644 --- a/middle_end/flambda/flambda_to_clambda.ml +++ b/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 diff --git a/middle_end/printclambda.ml b/middle_end/printclambda.ml index fdb5b67c358..b63d37b591e 100644 --- a/middle_end/printclambda.ml +++ b/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 diff --git a/typing/typeopt.ml b/typing/typeopt.ml index a6f946bcf37..e18dd5992a9 100644 --- a/typing/typeopt.ml +++ b/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)