diff --git a/backend/cmm_helpers.ml b/backend/cmm_helpers.ml index dbe9297b8cb..9562e66635a 100644 --- a/backend/cmm_helpers.ml +++ b/backend/cmm_helpers.ml @@ -2654,7 +2654,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 @@ -3989,4 +3993,9 @@ let transl_attrib : Lambda.check_attribute -> Cmm.codegen_option list = function | Assert p -> [Assert (transl_property p)] | Assume p -> [Assume (transl_property p)] -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 diff --git a/backend/cmmgen.ml b/backend/cmmgen.ml index 77252d09724..e77e8bb1136 100644 --- a/backend/cmmgen.ml +++ b/backend/cmmgen.ml @@ -506,9 +506,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 @@ -787,10 +797,19 @@ 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 = is_strict kind in - u := join_unboxed_number_kind ~strict !u - (is_unboxed_number_cmm 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 = is_strict kind in + u := join_unboxed_number_kind ~strict !u + (is_unboxed_number_cmm c) ) ids args in @@ -1235,7 +1254,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 = @@ -1275,6 +1294,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 (Lbl nexit,[],[]) when nexit=ncatch -> handler diff --git a/middle_end/clambda_primitives.ml b/middle_end/clambda_primitives.ml index b56314afa9c..72dd70af2c3 100644 --- a/middle_end/clambda_primitives.ml +++ b/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 = diff --git a/middle_end/clambda_primitives.mli b/middle_end/clambda_primitives.mli index 6bd588ae13d..65a52db1644 100644 --- a/middle_end/clambda_primitives.mli +++ b/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 = diff --git a/middle_end/closure/closure.ml b/middle_end/closure/closure.ml index 6f94e641bb1..fe0f67461dc 100644 --- a/middle_end/closure/closure.ml +++ b/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 diff --git a/middle_end/flambda/closure_offsets.ml b/middle_end/flambda/closure_offsets.ml index f88f1683cdf..5891b508f6d 100644 --- a/middle_end/flambda/closure_offsets.ml +++ b/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 = diff --git a/middle_end/flambda/flambda_to_clambda.ml b/middle_end/flambda/flambda_to_clambda.ml index 0f8bfb0fbf8..5dfd46b44ac 100644 --- a/middle_end/flambda/flambda_to_clambda.ml +++ b/middle_end/flambda/flambda_to_clambda.ml @@ -698,6 +698,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 diff --git a/middle_end/flambda2/kinds/flambda_kind.ml b/middle_end/flambda2/kinds/flambda_kind.ml index 77e75cb07be..fe345f17415 100644 --- a/middle_end/flambda2/kinds/flambda_kind.ml +++ b/middle_end/flambda2/kinds/flambda_kind.ml @@ -516,7 +516,12 @@ module With_subkind = struct | Parrayval Paddrarray -> value_array | Parrayval Pgenarray -> generic_array - let from_lambda (Pvalue vk : Lambda.layout) = from_lambda_value_kind vk + let from_lambda (layout : Lambda.layout) = + match layout with + | Pvalue vk -> from_lambda_value_kind vk + | Ptop -> Misc.fatal_error "Can't convert layout [Ptop] to flambda kind" + | Pbottom -> + Misc.fatal_error "Can't convert layout [Pbottom] to flambda kind" include Container_types.Make (struct type nonrec t = t diff --git a/middle_end/printclambda.ml b/middle_end/printclambda.ml index 2c166ae1129..0f319f249d4 100644 --- a/middle_end/printclambda.ml +++ b/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 diff --git a/ocaml/asmcomp/cmm_helpers.ml b/ocaml/asmcomp/cmm_helpers.ml index 13529811715..8c43fb09b15 100644 --- a/ocaml/asmcomp/cmm_helpers.ml +++ b/ocaml/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 diff --git a/ocaml/asmcomp/cmmgen.ml b/ocaml/asmcomp/cmmgen.ml index 8c8b2eb0c68..6f6fc010ea7 100644 --- a/ocaml/asmcomp/cmmgen.ml +++ b/ocaml/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) diff --git a/ocaml/lambda/lambda.ml b/ocaml/lambda/lambda.ml index f0b57921a41..d22dfd21594 100644 --- a/ocaml/lambda/lambda.ml +++ b/ocaml/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; diff --git a/ocaml/lambda/lambda.mli b/ocaml/lambda/lambda.mli index 7758fcadad2..f7afdf8c3ff 100644 --- a/ocaml/lambda/lambda.mli +++ b/ocaml/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 diff --git a/ocaml/lambda/printlambda.ml b/ocaml/lambda/printlambda.ml index a5e759ab0dc..4c7eb218208 100644 --- a/ocaml/lambda/printlambda.ml +++ b/ocaml/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 "*" diff --git a/ocaml/middle_end/clambda_primitives.ml b/ocaml/middle_end/clambda_primitives.ml index b56314afa9c..72dd70af2c3 100644 --- a/ocaml/middle_end/clambda_primitives.ml +++ b/ocaml/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 = diff --git a/ocaml/middle_end/clambda_primitives.mli b/ocaml/middle_end/clambda_primitives.mli index 6bd588ae13d..65a52db1644 100644 --- a/ocaml/middle_end/clambda_primitives.mli +++ b/ocaml/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 = diff --git a/ocaml/middle_end/closure/closure.ml b/ocaml/middle_end/closure/closure.ml index ae36105e08c..6d4a30fd179 100644 --- a/ocaml/middle_end/closure/closure.ml +++ b/ocaml/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 diff --git a/ocaml/middle_end/flambda/closure_offsets.ml b/ocaml/middle_end/flambda/closure_offsets.ml index f88f1683cdf..5891b508f6d 100644 --- a/ocaml/middle_end/flambda/closure_offsets.ml +++ b/ocaml/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 = diff --git a/ocaml/middle_end/flambda/flambda_to_clambda.ml b/ocaml/middle_end/flambda/flambda_to_clambda.ml index 34c1dae0eec..8781f1f29cb 100644 --- a/ocaml/middle_end/flambda/flambda_to_clambda.ml +++ b/ocaml/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 diff --git a/ocaml/middle_end/printclambda.ml b/ocaml/middle_end/printclambda.ml index b63d37b591e..fdb5b67c358 100644 --- a/ocaml/middle_end/printclambda.ml +++ b/ocaml/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 diff --git a/ocaml/typing/typeopt.ml b/ocaml/typing/typeopt.ml index e18dd5992a9..a6f946bcf37 100644 --- a/ocaml/typing/typeopt.ml +++ b/ocaml/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