diff --git a/ocaml/.depend b/ocaml/.depend index 5d5cfcc9eb6..0e52a7893f8 100644 --- a/ocaml/.depend +++ b/ocaml/.depend @@ -1116,34 +1116,62 @@ typing/includemod_errorprinter.cmx : \ typing/includemod_errorprinter.cmi : \ typing/includemod.cmi typing/jkind.cmo : \ + typing/types.cmi \ + typing/primitive.cmi \ typing/path.cmi \ parsing/parsetree.cmi \ typing/mode.cmi \ utils/misc.cmi \ parsing/location.cmi \ utils/language_extension.cmi \ + typing/jkind_types.cmi \ parsing/jane_syntax.cmi \ parsing/jane_asttypes.cmi \ typing/ident.cmi \ parsing/builtin_attributes.cmi \ typing/jkind.cmi typing/jkind.cmx : \ + typing/types.cmx \ + typing/primitive.cmx \ typing/path.cmx \ parsing/parsetree.cmi \ typing/mode.cmx \ utils/misc.cmx \ parsing/location.cmx \ utils/language_extension.cmx \ + typing/jkind_types.cmx \ parsing/jane_syntax.cmx \ parsing/jane_asttypes.cmx \ typing/ident.cmx \ parsing/builtin_attributes.cmx \ typing/jkind.cmi typing/jkind.cmi : \ + typing/types.cmi \ typing/path.cmi \ parsing/parsetree.cmi \ typing/mode.cmi \ parsing/location.cmi \ + typing/jkind_types.cmi \ + parsing/jane_asttypes.cmi \ + typing/ident.cmi +typing/jkind_types.cmo : \ + typing/path.cmi \ + typing/mode.cmi \ + parsing/location.cmi \ + parsing/jane_asttypes.cmi \ + typing/ident.cmi \ + typing/jkind_types.cmi +typing/jkind_types.cmx : \ + typing/path.cmx \ + typing/mode.cmx \ + parsing/location.cmx \ + parsing/jane_asttypes.cmx \ + typing/ident.cmx \ + typing/jkind_types.cmi +typing/jkind_types.cmi : \ + typing/path.cmi \ + typing/mode.cmi \ + parsing/location.cmi \ parsing/jane_asttypes.cmi \ typing/ident.cmi typing/mode.cmo : \ @@ -1210,7 +1238,7 @@ typing/oprint.cmx : \ typing/oprint.cmi : \ typing/outcometree.cmi typing/outcometree.cmi : \ - typing/jkind.cmi \ + typing/jkind_types.cmi \ parsing/asttypes.cmi typing/parmatch.cmo : \ utils/warnings.cmi \ @@ -1374,7 +1402,7 @@ typing/primitive.cmo : \ utils/misc.cmi \ parsing/location.cmi \ utils/language_extension.cmi \ - typing/jkind.cmi \ + typing/jkind_types.cmi \ parsing/attr_helper.cmi \ typing/primitive.cmi typing/primitive.cmx : \ @@ -1383,14 +1411,14 @@ typing/primitive.cmx : \ utils/misc.cmx \ parsing/location.cmx \ utils/language_extension.cmx \ - typing/jkind.cmx \ + typing/jkind_types.cmx \ parsing/attr_helper.cmx \ typing/primitive.cmi typing/primitive.cmi : \ parsing/parsetree.cmi \ typing/outcometree.cmi \ parsing/location.cmi \ - typing/jkind.cmi + typing/jkind_types.cmi typing/printpat.cmo : \ typing/types.cmi \ typing/typedtree.cmi \ @@ -2236,7 +2264,7 @@ typing/types.cmo : \ parsing/longident.cmi \ parsing/location.cmi \ utils/local_store.cmi \ - typing/jkind.cmi \ + typing/jkind_types.cmi \ typing/ident.cmi \ utils/config.cmi \ parsing/builtin_attributes.cmi \ @@ -2252,7 +2280,7 @@ typing/types.cmx : \ parsing/longident.cmx \ parsing/location.cmx \ utils/local_store.cmx \ - typing/jkind.cmx \ + typing/jkind_types.cmx \ typing/ident.cmx \ utils/config.cmx \ parsing/builtin_attributes.cmx \ @@ -2266,7 +2294,7 @@ typing/types.cmi : \ typing/mode.cmi \ parsing/longident.cmi \ parsing/location.cmi \ - typing/jkind.cmi \ + typing/jkind_types.cmi \ typing/ident.cmi \ parsing/builtin_attributes.cmi \ parsing/asttypes.cmi diff --git a/ocaml/compilerlibs/Makefile.compilerlibs b/ocaml/compilerlibs/Makefile.compilerlibs index 0ec8b7d3bac..908e6419acb 100644 --- a/ocaml/compilerlibs/Makefile.compilerlibs +++ b/ocaml/compilerlibs/Makefile.compilerlibs @@ -87,10 +87,11 @@ TYPING = \ typing/solver.cmo \ typing/path.cmo \ typing/mode.cmo \ - typing/jkind.cmo \ + typing/jkind_types.cmo \ typing/primitive.cmo \ typing/shape.cmo \ typing/types.cmo \ + typing/jkind.cmo \ typing/btype.cmo \ typing/oprint.cmo \ typing/subst.cmo \ diff --git a/ocaml/debugger4/.depend b/ocaml/debugger4/.depend index 4bba9203d7b..02cebf0b018 100644 --- a/ocaml/debugger4/.depend +++ b/ocaml/debugger4/.depend @@ -287,6 +287,7 @@ loadprinter.cmo : \ ../parsing/longident.cmi \ ../utils/load_path.cmi \ ../typing/jkind.cmi \ + ../typing/jkind_types.cmi \ ../typing/ident.cmi \ ../typing/env.cmi \ ../otherlibs/dynlink/dynlink.cmi \ @@ -304,6 +305,7 @@ loadprinter.cmx : \ ../parsing/longident.cmx \ ../utils/load_path.cmx \ ../typing/jkind.cmx \ + ../typing/jkind_types.cmx \ ../typing/ident.cmx \ ../typing/env.cmx \ ../otherlibs/dynlink/dynlink.cmx \ diff --git a/ocaml/dune b/ocaml/dune index decc3be7b9c..33468a4797f 100644 --- a/ocaml/dune +++ b/ocaml/dune @@ -88,7 +88,7 @@ ;; TYPING ident path jkind primitive shape shape_reduce types btype oprint subst predef datarepr - cmi_format persistent_env env errortrace mode + cmi_format persistent_env env errortrace mode jkind_types jkind_intf typedtree printtyped ctype printtyp includeclass mtype envaux includecore tast_iterator tast_mapper signature_group cmt_format cms_format untypeast includemod includemod_errorprinter @@ -286,6 +286,7 @@ (ident.mli as compiler-libs/ident.mli) (path.mli as compiler-libs/path.mli) (jkind.mli as compiler-libs/jkind.mli) + (jkind_types.mli as compiler-libs/jkind_types.mli) (primitive.mli as compiler-libs/primitive.mli) (types.mli as compiler-libs/types.mli) (btype.mli as compiler-libs/btype.mli) diff --git a/ocaml/jane/build-resolved-files-for-ci b/ocaml/jane/build-resolved-files-for-ci index 0d56827bc61..00b96d31175 100755 --- a/ocaml/jane/build-resolved-files-for-ci +++ b/ocaml/jane/build-resolved-files-for-ci @@ -88,6 +88,7 @@ typing_mls=( includecore includemod jkind + jkind_types mtype oprint parmatch diff --git a/ocaml/ocamldoc/.depend b/ocaml/ocamldoc/.depend index 7b19b1cdf10..20ed5424cba 100644 --- a/ocaml/ocamldoc/.depend +++ b/ocaml/ocamldoc/.depend @@ -761,6 +761,7 @@ odoc_sig.cmo : \ ../parsing/longident.cmi \ ../parsing/location.cmi \ ../typing/jkind.cmi \ + ../typing/jkind_types.cmi \ ../parsing/jane_syntax.cmi \ ../typing/ident.cmi \ ../typing/ctype.cmi \ @@ -788,6 +789,7 @@ odoc_sig.cmx : \ ../parsing/longident.cmx \ ../parsing/location.cmx \ ../typing/jkind.cmx \ + ../typing/jkind_types.cmx \ ../parsing/jane_syntax.cmx \ ../typing/ident.cmx \ ../typing/ctype.cmx \ diff --git a/ocaml/otherlibs/dynlink/Makefile b/ocaml/otherlibs/dynlink/Makefile index 0882c99c39c..e7accabd018 100644 --- a/ocaml/otherlibs/dynlink/Makefile +++ b/ocaml/otherlibs/dynlink/Makefile @@ -120,9 +120,10 @@ COMPILERLIBS_SOURCES=\ typing/mode.ml \ typing/path.ml \ typing/shape.ml \ - typing/jkind.ml \ + typing/jkind_types.ml \ typing/primitive.ml \ typing/types.ml \ + typing/jkind.ml \ typing/typedtree.ml \ typing/btype.ml \ typing/subst.ml \ diff --git a/ocaml/otherlibs/dynlink/dune b/ocaml/otherlibs/dynlink/dune index 4ccc64d61f9..a0380edadab 100644 --- a/ocaml/otherlibs/dynlink/dune +++ b/ocaml/otherlibs/dynlink/dune @@ -87,9 +87,11 @@ mode_intf mode typemode - jkind + jkind_intf + jkind_types primitive types + jkind value_rec_types btype lazy_backtrack @@ -185,6 +187,8 @@ (copy_files ../../typing/ident.ml) (copy_files ../../typing/path.ml) (copy_files ../../typing/jkind.ml) +(copy_files ../../typing/jkind_intf.ml) +(copy_files ../../typing/jkind_types.ml) (copy_files ../../typing/primitive.ml) (copy_files ../../typing/shape.ml) (copy_files ../../typing/solver.ml) @@ -253,6 +257,8 @@ (copy_files ../../typing/ident.mli) (copy_files ../../typing/path.mli) (copy_files ../../typing/jkind.mli) +(copy_files ../../typing/jkind_intf.mli) +(copy_files ../../typing/jkind_types.mli) (copy_files ../../typing/primitive.mli) (copy_files ../../typing/shape.mli) (copy_files ../../typing/solver.mli) @@ -370,8 +376,12 @@ .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Solver.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Mode.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Typemode.cmo - .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Jkind.cmo + .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Jkind_intf.cmo + .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Jkind_types.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Types.cmo + .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Attr_helper.cmo + .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Primitive.cmo + .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Jkind.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Btype.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Subst.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Bytesections.cmo @@ -381,8 +391,6 @@ .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Shape.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Datarepr.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Persistent_env.cmo - .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Attr_helper.cmo - .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Primitive.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Predef.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Env.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Lambda.cmo @@ -452,8 +460,12 @@ .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Solver.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Mode.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Typemode.cmx - .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Jkind.cmx + .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Jkind_intf.cmx + .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Jkind_types.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Types.cmx + .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Attr_helper.cmx + .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Primitive.cmx + .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Jkind.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Btype.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Subst.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Bytesections.cmx @@ -463,8 +475,6 @@ .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Shape.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Datarepr.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Persistent_env.cmx - .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Attr_helper.cmx - .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Primitive.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Predef.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Env.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Lambda.cmx diff --git a/ocaml/typing/.ocamlformat-enable b/ocaml/typing/.ocamlformat-enable index cc3aa7148dd..f677d8b9d6f 100644 --- a/ocaml/typing/.ocamlformat-enable +++ b/ocaml/typing/.ocamlformat-enable @@ -1,5 +1,8 @@ jkind.ml jkind.mli +jkind_types.ml +jkind_types.mli +jkind_intf.ml uniqueness_analysis.ml uniqueness_analysis.mli mode_intf.mli @@ -9,4 +12,4 @@ solver_intf.mli solver.ml solver.mli typemode.mli -typemode.ml \ No newline at end of file +typemode.ml diff --git a/ocaml/typing/jkind.ml b/ocaml/typing/jkind.ml index b2e46d1e4b4..547accec4b2 100644 --- a/ocaml/typing/jkind.ml +++ b/ocaml/typing/jkind.ml @@ -13,12 +13,13 @@ (**************************************************************************) open Mode +open Jkind_types [@@@warning "+9"] (* CR layouts v2.8: remove this *) module Legacy = struct - type const = + type const = Jkind_types.const = | Any | Value | Void @@ -90,301 +91,12 @@ end (* A *sort* is the information the middle/back ends need to be able to compile a manipulation (storing, passing, etc) of a runtime value. *) -module Sort = struct - (* CR layouts v2.8: Refactor to use a Const module *) - type const = - | Void - | Value - | Float64 - | Float32 - | Word - | Bits32 - | Bits64 - - type t = - | Var of var - | Const of const - - and var = t option ref - - (* To record changes to sorts, for use with `Types.{snapshot, backtrack}` *) - type change = var * t option - - let change_log : (change -> unit) ref = ref (fun _ -> ()) - - let log_change change = !change_log change - - let undo_change (v, t_op) = v := t_op - - let var_name : var -> string = - let next_id = ref 1 in - let named = ref [] in - fun v -> - match List.assq_opt v !named with - | Some name -> name - | None -> - let id = !next_id in - let name = "'_representable_layout_" ^ Int.to_string id in - next_id := id + 1; - named := (v, name) :: !named; - name - - let set : var -> t option -> unit = - fun v t_op -> - log_change (v, !v); - v := t_op - - let void = Const Void - - let value = Const Value - - let float64 = Const Float64 - - let float32 = Const Float32 - - let word = Const Word - - let bits32 = Const Bits32 - - let bits64 = Const Bits64 - - let some_value = Some value - - let of_const = function - | Void -> void - | Value -> value - | Float64 -> float64 - | Float32 -> float32 - | Word -> word - | Bits32 -> bits32 - | Bits64 -> bits64 - - let of_var v = Var v - - let new_var () = Var (ref None) - - (* Post-condition: If the result is a [Var v], then [!v] is [None]. *) - let rec get : t -> t = function - | Const _ as t -> t - | Var r as t -> ( - match !r with - | None -> t - | Some s -> - let result = get s in - if result != s then set r (Some result); - (* path compression *) - result) - - let memoized_value : t option = Some (Const Value) - - let memoized_void : t option = Some (Const Void) - - let memoized_float64 : t option = Some (Const Float64) - - let memoized_float32 : t option = Some (Const Float32) - - let memoized_word : t option = Some (Const Word) - - let memoized_bits32 : t option = Some (Const Bits32) - - let memoized_bits64 : t option = Some (Const Bits64) - - let[@inline] get_memoized = function - | Value -> memoized_value - | Void -> memoized_void - | Float64 -> memoized_float64 - | Float32 -> memoized_float32 - | Word -> memoized_word - | Bits32 -> memoized_bits32 - | Bits64 -> memoized_bits64 - - let rec get_default_value : t -> const = function - | Const c -> c - | Var r -> ( - match !r with - | None -> - set r memoized_value; - Value - | Some s -> - let result = get_default_value s in - set r (get_memoized result); - (* path compression *) - result) - - let default_to_value t = ignore (get_default_value t) - - (***********************) - (* equality *) - - type equate_result = - | Unequal - | Equal_mutated_first - | Equal_mutated_second - | Equal_no_mutation - - let swap_equate_result = function - | Equal_mutated_first -> Equal_mutated_second - | Equal_mutated_second -> Equal_mutated_first - | (Unequal | Equal_no_mutation) as r -> r - - let equal_const_const c1 c2 = - match c1, c2 with - | Void, Void - | Value, Value - | Float64, Float64 - | Float32, Float32 - | Word, Word - | Bits32, Bits32 - | Bits64, Bits64 -> - Equal_no_mutation - | (Void | Value | Float64 | Float32 | Word | Bits32 | Bits64), _ -> Unequal - - let rec equate_var_const v1 c2 = - match !v1 with - | Some s1 -> equate_sort_const s1 c2 - | None -> - set v1 (Some (of_const c2)); - Equal_mutated_first - - and equate_var v1 s2 = - match s2 with - | Const c2 -> equate_var_const v1 c2 - | Var v2 -> equate_var_var v1 v2 - - and equate_var_var v1 v2 = - if v1 == v2 - then Equal_no_mutation - else - match !v1, !v2 with - | Some s1, _ -> swap_equate_result (equate_var v2 s1) - | _, Some s2 -> equate_var v1 s2 - | None, None -> - set v1 (Some (of_var v2)); - Equal_mutated_first - - and equate_sort_const s1 c2 = - match s1 with - | Const c1 -> equal_const_const c1 c2 - | Var v1 -> equate_var_const v1 c2 - - let equate_tracking_mutation s1 s2 = - match s1 with - | Const c1 -> swap_equate_result (equate_sort_const s2 c1) - | Var v1 -> equate_var v1 s2 - - (* Don't expose whether or not mutation happened; we just need that for [Jkind] *) - let equate s1 s2 = - match equate_tracking_mutation s1 s2 with - | Unequal -> false - | Equal_mutated_first | Equal_mutated_second | Equal_no_mutation -> true - - let equal_const c1 c2 = - match c1, c2 with - | Void, Void - | Value, Value - | Float64, Float64 - | Float32, Float32 - | Word, Word - | Bits32, Bits32 - | Bits64, Bits64 -> - true - | (Void | Value | Float64 | Float32 | Word | Bits32 | Bits64), _ -> false - - let rec is_void_defaulting = function - | Const Void -> true - | Var v -> ( - match !v with - (* CR layouts v5: this should probably default to void now *) - | None -> - set v some_value; - false - | Some s -> is_void_defaulting s) - | Const (Value | Float64 | Float32 | Word | Bits32 | Bits64) -> false - - (*** pretty printing ***) - - let string_of_const = function - | Value -> "value" - | Void -> "void" - | Float64 -> "float64" - | Float32 -> "float32" - | Word -> "word" - | Bits32 -> "bits32" - | Bits64 -> "bits64" - - let to_string s = - match get s with Var v -> var_name v | Const c -> string_of_const c - - let format ppf t = Format.fprintf ppf "%s" (to_string t) - - let format_const ppf const = Format.fprintf ppf "%s" (string_of_const const) - - (*** debug printing **) - - module Debug_printers = struct - open Format - - let rec t ppf = function - | Var v -> fprintf ppf "Var %a" var v - | Const c -> - fprintf ppf - (match c with - | Void -> "Void" - | Value -> "Value" - | Float64 -> "Float64" - | Float32 -> "Float32" - | Word -> "Word" - | Bits32 -> "Bits32" - | Bits64 -> "Bits64") - - and opt_t ppf = function - | Some s -> fprintf ppf "Some %a" t s - | None -> fprintf ppf "None" - - and var ppf v = fprintf ppf "{ contents = %a }" opt_t !v - end - - let for_function = value - - let for_predef_value = value - - let for_block_element = value - - let for_probe_body = value - - let for_poly_variant = value - - let for_record = value - - let for_object = value - - let for_lazy_body = value - - let for_tuple_element = value - - let for_variant_arg = value - - let for_instance_var = value - - let for_class_arg = value - - let for_method = value - - let for_initializer = value - - let for_module = value - - let for_tuple = value - - let for_array_get_result = value - - let for_array_comprehension_element = value - - let for_list_element = value -end +module Sort = Jkind_types.Sort type sort = Sort.t +type type_expr = Types.type_expr + (* A *layout* of a type describes the way values of that type are stored at runtime, including details like width, register convention, calling convention, etc. A layout may be *representable* or *unrepresentable*. The @@ -392,11 +104,12 @@ type sort = Sort.t unrepresentable layout. The only unrepresentable layout is `any`, which is the top of the layout lattice. *) module Layout = struct + open Jkind_types.Layout + + type nonrec 'sort layout = (type_expr, 'sort) layout + module Const = struct - type t = - | Sort of Sort.const - | Any - | Non_null_value + type t = Sort.const layout let max = Any @@ -407,7 +120,7 @@ module Layout = struct | Non_null_value, Non_null_value -> true | (Any | Sort _ | Non_null_value), _ -> false - let sub c1 c2 : Misc.Le_result.t = + let sub (c1 : t) (c2 : t) : Misc.Le_result.t = match c1, c2 with | _ when equal c1 c2 -> Equal | _, Any -> Less @@ -417,11 +130,6 @@ module Layout = struct | (Any | Sort _ | Non_null_value), Sort _ -> Not_le end - type t = - | Sort of Sort.t - | Any - | Non_null_value - let max = Any let equate_or_equal ~allow_mutation t1 t2 = @@ -485,7 +193,7 @@ module Layout = struct end module Externality = struct - type t = + type t = Jkind_types.Externality.t = | External | External64 | Internal @@ -634,11 +342,7 @@ module Desc = struct end module Jkind_desc = struct - type t = - { layout : Layout.t; - modes_upper_bounds : Modes.t; - externality_upper_bound : Externality.t - } + open Jkind_types.Jkind_desc let max = { layout = Layout.max; @@ -806,157 +510,10 @@ module Jkind_desc = struct end end -(*** reasons for jkinds **) -type concrete_jkind_reason = - | Match - | Constructor_declaration of int - | Label_declaration of Ident.t - | Unannotated_type_parameter of Path.t - | Record_projection - | Record_assignment - | Let_binding - | Function_argument - | Function_result - | Structure_item_expression - | External_argument - | External_result - | Statement - | Wildcard - | Unification_var - | Optional_arg_default - | Layout_poly_in_external - | Array_element - -type value_creation_reason = - | Class_let_binding - | Tuple_element - | Probe - | Object - | Instance_variable - | Object_field - | Class_field - | Boxed_record - | Boxed_variant - | Extensible_variant - | Primitive of Ident.t - | Type_argument of - { parent_path : Path.t; - position : int; - arity : int - } - (* [position] is 1-indexed *) - | Tuple - | Row_variable - | Polymorphic_variant - | Arrow - | Tfield - | Tnil - | First_class_module - | Separability_check - | Univar - | Polymorphic_variant_field - | Default_type_jkind - | Existential_type_variable - | Array_comprehension_element - | Lazy_expression - | Class_type_argument - | Class_term_argument - | Structure_element - | Debug_printer_argument - | V1_safety_check - | Captured_in_object - | Recmod_fun_arg - | Unknown of string - -type immediate_creation_reason = - | Empty_record - | Enumeration - | Primitive of Ident.t - | Immediate_polymorphic_variant - -type immediate64_creation_reason = Separability_check - -type void_creation_reason = | - -type any_creation_reason = - | Missing_cmi of Path.t - | Initial_typedecl_env - | Dummy_jkind - | Type_expression_call - | Inside_of_Tarrow - | Wildcard - | Unification_var - | Array_type_argument - -type float64_creation_reason = Primitive of Ident.t - -type float32_creation_reason = Primitive of Ident.t - -type word_creation_reason = Primitive of Ident.t - -type bits32_creation_reason = Primitive of Ident.t - -type bits64_creation_reason = Primitive of Ident.t - -type annotation_context = - | Type_declaration of Path.t - | Type_parameter of Path.t * string option - | Newtype_declaration of string - | Constructor_type_parameter of Path.t * string - | Univar of string - | Type_variable of string - | Type_wildcard of Location.t - | With_error_message of string * annotation_context - -type creation_reason = - | Annotated of annotation_context * Location.t - | Missing_cmi of Path.t - | Value_creation of value_creation_reason - | Immediate_creation of immediate_creation_reason - | Immediate64_creation of immediate64_creation_reason - | Void_creation of void_creation_reason - | Any_creation of any_creation_reason - | Float64_creation of float64_creation_reason - | Float32_creation of float32_creation_reason - | Word_creation of word_creation_reason - | Bits32_creation of bits32_creation_reason - | Bits64_creation of bits64_creation_reason - | Concrete_creation of concrete_jkind_reason - | Imported - | Imported_type_argument of - { parent_path : Path.t; - position : int; - arity : int - } - (* [position] is 1-indexed *) - | Generalized of Ident.t option * Location.t - -type interact_reason = - | Gadt_equation of Path.t - | Tyvar_refinement_intersection - (* CR layouts: this needs to carry a type_expr, but that's loopy *) - | Subjkind - -(* A history of conditions placed on a jkind. +(* CR layouts v2.8: refactor not to be an [include], but a proper module *) +include Jkind_intf.History - INVARIANT: at most one sort variable appears in this history. - This is a natural consequence of producing this history by comparing - jkinds. -*) -type history = - | Interact of - { reason : interact_reason; - lhs_jkind : Jkind_desc.t; - lhs_history : history; - rhs_jkind : Jkind_desc.t; - rhs_history : history - } - | Creation of creation_reason - -type t = - { jkind : Jkind_desc.t; - history : history - } +type t = type_expr Jkind_types.t let fresh_jkind jkind ~why = { jkind; history = Creation why } @@ -1630,6 +1187,8 @@ let equate_or_equal ~allow_mutation { jkind = jkind1; history = _ } (* CR layouts v2.8: Switch this back to ~allow_mutation:false *) let equal = equate_or_equal ~allow_mutation:true +let () = Types.set_jkind_equal equal + let equate = equate_or_equal ~allow_mutation:true (* Not all jkind history reasons are created equal. Some are more helpful than others. diff --git a/ocaml/typing/jkind.mli b/ocaml/typing/jkind.mli index 057fa8ddb10..8f63d3f1ab5 100644 --- a/ocaml/typing/jkind.mli +++ b/ocaml/typing/jkind.mli @@ -42,7 +42,7 @@ https://github.com/goldfirere/flambda-backend/commit/d802597fbdaaa850e1ed9209a1305c5dcdf71e17 first, which was reisenberg's attempt to do so. *) module Externality : sig - type t = + type t = Jkind_types.Externality.t = | External (* not managed by the garbage collector *) | External64 (* not managed by the garbage collector on 64-bit systems *) | Internal (* managed by the garbage collector *) @@ -50,132 +50,7 @@ module Externality : sig val le : t -> t -> bool end -module Sort : sig - (** A sort classifies how a type is represented at runtime. Every concrete - jkind has a sort, and knowing the sort is sufficient for knowing the - calling convention of values of a given type. *) - type t - - (** These are the constant sorts -- fully determined and without variables *) - type const = - | Void (** No run time representation at all *) - | Value (** Standard ocaml value representation *) - | Float64 (** Unboxed 64-bit floats *) - | Float32 (** Unboxed 32-bit floats *) - | Word (** Unboxed native-size integers *) - | Bits32 (** Unboxed 32-bit integers *) - | Bits64 (** Unboxed 64-bit integers *) - - (** A sort variable that can be unified during type-checking. *) - type var - - (** Create a new sort variable that can be unified. *) - val new_var : unit -> t - - val of_const : const -> t - - val of_var : var -> t - - val void : t - - val value : t - - val float64 : t - - val float32 : t - - val word : t - - val bits32 : t - - val bits64 : t - - (** These names are generated lazily and only when this function is called, - and are not guaranteed to be efficient to create *) - val var_name : var -> string - - (** This checks for equality, and sets any variables to make two sorts - equal, if possible *) - val equate : t -> t -> bool - - val equal_const : const -> const -> bool - - val format : Format.formatter -> t -> unit - - val format_const : Format.formatter -> const -> unit - - (** Defaults any variables to value; leaves other sorts alone *) - val default_to_value : t -> unit - - (** Checks whether this sort is [void], defaulting to [value] if a sort - variable is unfilled. *) - val is_void_defaulting : t -> bool - - (** [get_default_value] extracts the sort as a `const`. If it's a variable, - it is set to [value] first. *) - val get_default_value : t -> const - - (** To record changes to sorts, for use with `Types.{snapshot, backtrack}` *) - type change - - val change_log : (change -> unit) ref - - val undo_change : change -> unit - - module Debug_printers : sig - val t : Format.formatter -> t -> unit - - val var : Format.formatter -> var -> unit - end - - (* CR layouts: These are sorts for the types of ocaml expressions that are - currently required to be values, but for which we expect to relax that - restriction in versions 2 and beyond. Naming them makes it easy to find - where in the translation to lambda they are assume to be value. *) - (* CR layouts: add similarly named jkinds and use those names everywhere (not - just the translation to lambda) rather than writing specific jkinds and - sorts in the code. *) - val for_class_arg : t - - val for_instance_var : t - - val for_lazy_body : t - - val for_tuple_element : t - - val for_variant_arg : t - - val for_record : t - - val for_block_element : t - - val for_array_get_result : t - - val for_array_comprehension_element : t - - val for_list_element : t - - (** These are sorts for the types of ocaml expressions that we expect will - always be "value". These names are used in the translation to lambda to - make the code clearer. *) - val for_function : t - - val for_probe_body : t - - val for_poly_variant : t - - val for_object : t - - val for_initializer : t - - val for_method : t - - val for_module : t - - val for_predef_value : t (* Predefined value types, e.g. int and string *) - - val for_tuple : t -end +module Sort : Jkind_intf.Sort with type const = Jkind_types.Sort.const type sort = Sort.t @@ -186,155 +61,22 @@ type sort = Sort.t layout of "classical" OCaml values used by the upstream compiler. *) module Layout : sig module Const : sig - type t = - | Sort of Sort.const - | Any - | Non_null_value + type t = (Types.type_expr, Sort.const) Jkind_types.Layout.layout end end (** A Jkind.t is a full description of the runtime representation of values of a given type. It includes sorts, but also the abstract top jkind [Any] and subjkinds of other sorts, such as [Immediate]. *) -type t +type t = Types.type_expr Jkind_types.t + +include module type of struct + include Jkind_intf.History +end (******************************) (* errors *) -type concrete_jkind_reason = - | Match - | Constructor_declaration of int - | Label_declaration of Ident.t - | Unannotated_type_parameter of Path.t - | Record_projection - | Record_assignment - | Let_binding - | Function_argument - | Function_result - | Structure_item_expression - | External_argument - | External_result - | Statement - | Wildcard - | Unification_var - | Optional_arg_default - | Layout_poly_in_external - | Array_element - -type annotation_context = - | Type_declaration of Path.t - | Type_parameter of Path.t * string option - | Newtype_declaration of string - | Constructor_type_parameter of Path.t * string - | Univar of string - | Type_variable of string - | Type_wildcard of Location.t - | With_error_message of string * annotation_context - -type value_creation_reason = - | Class_let_binding - | Tuple_element - | Probe - | Object - | Instance_variable - | Object_field - | Class_field - | Boxed_record - | Boxed_variant - | Extensible_variant - | Primitive of Ident.t - | Type_argument of - { parent_path : Path.t; - position : int; - arity : int - } - (* [position] is 1-indexed *) - | Tuple - | Row_variable - | Polymorphic_variant - | Arrow - | Tfield - | Tnil - | First_class_module - | Separability_check - | Univar - | Polymorphic_variant_field - | Default_type_jkind - | Existential_type_variable - | Array_comprehension_element - | Lazy_expression - | Class_type_argument - | Class_term_argument - | Structure_element - | Debug_printer_argument - | V1_safety_check - | Captured_in_object - | Recmod_fun_arg - | Unknown of string (* CR layouts: get rid of these *) - -type immediate_creation_reason = - | Empty_record - | Enumeration - | Primitive of Ident.t - | Immediate_polymorphic_variant - -type immediate64_creation_reason = Separability_check - -(* CR layouts v5: make new void_creation_reasons *) -type void_creation_reason = | - -type any_creation_reason = - | Missing_cmi of Path.t - | Initial_typedecl_env - | Dummy_jkind - (* This is used when the jkind is about to get overwritten; - key example: when creating a fresh tyvar that is immediately - unified to correct levels *) - | Type_expression_call - | Inside_of_Tarrow - | Wildcard - | Unification_var - | Array_type_argument - -type float64_creation_reason = Primitive of Ident.t - -type float32_creation_reason = Primitive of Ident.t - -type word_creation_reason = Primitive of Ident.t - -type bits32_creation_reason = Primitive of Ident.t - -type bits64_creation_reason = Primitive of Ident.t - -type creation_reason = - | Annotated of annotation_context * Location.t - | Missing_cmi of Path.t - | Value_creation of value_creation_reason - | Immediate_creation of immediate_creation_reason - | Immediate64_creation of immediate64_creation_reason - | Void_creation of void_creation_reason - | Any_creation of any_creation_reason - | Float64_creation of float64_creation_reason - | Float32_creation of float32_creation_reason - | Word_creation of word_creation_reason - | Bits32_creation of bits32_creation_reason - | Bits64_creation of bits64_creation_reason - | Concrete_creation of concrete_jkind_reason - | Imported - | Imported_type_argument of - { parent_path : Path.t; - position : int; - arity : int - } - (* [position] is 1-indexed *) - | Generalized of Ident.t option * Location.t - -type interact_reason = - | Gadt_equation of Path.t - | Tyvar_refinement_intersection - (* CR layouts: this needs to carry a type_expr, but that's loopy *) - | Subjkind - module Violation : sig type violation = | Not_a_subjkind of t * t @@ -378,7 +120,7 @@ end (** Constant jkinds are used both for user-written annotations and within the type checker when we know a jkind has no variables *) -type const = +type const = Jkind_types.const = | Any | Value | Void @@ -444,7 +186,7 @@ val of_new_sort : why:concrete_jkind_reason -> t val of_const : why:creation_reason -> const -> t (** The typed jkind together with its user-written annotation. *) -type annotation = const * Jane_asttypes.jkind_annotation +type annotation = Jkind_types.annotation val of_annotation : context:annotation_context -> Jane_asttypes.jkind_annotation -> t * annotation diff --git a/ocaml/typing/jkind_intf.ml b/ocaml/typing/jkind_intf.ml new file mode 100644 index 00000000000..97045622463 --- /dev/null +++ b/ocaml/typing/jkind_intf.ml @@ -0,0 +1,276 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Richard Eisenberg, Jane Street, New York *) +(* *) +(* Copyright 2024 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* This module contains definitions that we do not otherwise need to repeat + between the various Jkind modules. See comment in jkind_types.mli. *) +module type Sort = sig + (** A sort classifies how a type is represented at runtime. Every concrete + jkind has a sort, and knowing the sort is sufficient for knowing the + calling convention of values of a given type. *) + type t + + (** These are the constant sorts -- fully determined and without variables *) + type const = + | Void (** No run time representation at all *) + | Value (** Standard ocaml value representation *) + | Float64 (** Unboxed 64-bit floats *) + | Float32 (** Unboxed 32-bit floats *) + | Word (** Unboxed native-size integers *) + | Bits32 (** Unboxed 32-bit integers *) + | Bits64 (** Unboxed 64-bit integers *) + + (** A sort variable that can be unified during type-checking. *) + type var + + (** Create a new sort variable that can be unified. *) + val new_var : unit -> t + + val of_const : const -> t + + val of_var : var -> t + + val void : t + + val value : t + + val float64 : t + + val float32 : t + + val word : t + + val bits32 : t + + val bits64 : t + + (** These names are generated lazily and only when this function is called, + and are not guaranteed to be efficient to create *) + val var_name : var -> string + + (** This checks for equality, and sets any variables to make two sorts + equal, if possible *) + val equate : t -> t -> bool + + val equal_const : const -> const -> bool + + val format : Format.formatter -> t -> unit + + val format_const : Format.formatter -> const -> unit + + (** Defaults any variables to value; leaves other sorts alone *) + val default_to_value : t -> unit + + (** Checks whether this sort is [void], defaulting to [value] if a sort + variable is unfilled. *) + val is_void_defaulting : t -> bool + + (** [get_default_value] extracts the sort as a `const`. If it's a variable, + it is set to [value] first. *) + val get_default_value : t -> const + + (** To record changes to sorts, for use with `Types.{snapshot, backtrack}` *) + type change + + val undo_change : change -> unit + + module Debug_printers : sig + val t : Format.formatter -> t -> unit + + val var : Format.formatter -> var -> unit + end + + (* CR layouts: These are sorts for the types of ocaml expressions that are + currently required to be values, but for which we expect to relax that + restriction in versions 2 and beyond. Naming them makes it easy to find + where in the translation to lambda they are assume to be value. *) + (* CR layouts: add similarly named jkinds and use those names everywhere (not + just the translation to lambda) rather than writing specific jkinds and + sorts in the code. *) + val for_class_arg : t + + val for_instance_var : t + + val for_lazy_body : t + + val for_tuple_element : t + + val for_variant_arg : t + + val for_record : t + + val for_block_element : t + + val for_array_get_result : t + + val for_array_comprehension_element : t + + val for_list_element : t + + (** These are sorts for the types of ocaml expressions that we expect will + always be "value". These names are used in the translation to lambda to + make the code clearer. *) + val for_function : t + + val for_probe_body : t + + val for_poly_variant : t + + val for_object : t + + val for_initializer : t + + val for_method : t + + val for_module : t + + val for_predef_value : t (* Predefined value types, e.g. int and string *) + + val for_tuple : t +end + +module History = struct + type concrete_jkind_reason = + | Match + | Constructor_declaration of int + | Label_declaration of Ident.t + | Unannotated_type_parameter of Path.t + | Record_projection + | Record_assignment + | Let_binding + | Function_argument + | Function_result + | Structure_item_expression + | External_argument + | External_result + | Statement + | Wildcard + | Unification_var + | Optional_arg_default + | Layout_poly_in_external + | Array_element + + type annotation_context = + | Type_declaration of Path.t + | Type_parameter of Path.t * string option + | Newtype_declaration of string + | Constructor_type_parameter of Path.t * string + | Univar of string + | Type_variable of string + | Type_wildcard of Location.t + | With_error_message of string * annotation_context + + type value_creation_reason = + | Class_let_binding + | Tuple_element + | Probe + | Object + | Instance_variable + | Object_field + | Class_field + | Boxed_record + | Boxed_variant + | Extensible_variant + | Primitive of Ident.t + | Type_argument of + { parent_path : Path.t; + position : int; + arity : int + } + (* [position] is 1-indexed *) + | Tuple + | Row_variable + | Polymorphic_variant + | Arrow + | Tfield + | Tnil + | First_class_module + | Separability_check + | Univar + | Polymorphic_variant_field + | Default_type_jkind + | Existential_type_variable + | Array_comprehension_element + | Lazy_expression + | Class_type_argument + | Class_term_argument + | Structure_element + | Debug_printer_argument + | V1_safety_check + | Captured_in_object + | Recmod_fun_arg + | Unknown of string (* CR layouts: get rid of these *) + + type immediate_creation_reason = + | Empty_record + | Enumeration + | Primitive of Ident.t + | Immediate_polymorphic_variant + + type immediate64_creation_reason = Separability_check + + (* CR layouts v5: make new void_creation_reasons *) + type void_creation_reason = | + + type any_creation_reason = + | Missing_cmi of Path.t + | Initial_typedecl_env + | Dummy_jkind + (* This is used when the jkind is about to get overwritten; + key example: when creating a fresh tyvar that is immediately + unified to correct levels *) + | Type_expression_call + | Inside_of_Tarrow + | Wildcard + | Unification_var + | Array_type_argument + + type float64_creation_reason = Primitive of Ident.t + + type float32_creation_reason = Primitive of Ident.t + + type word_creation_reason = Primitive of Ident.t + + type bits32_creation_reason = Primitive of Ident.t + + type bits64_creation_reason = Primitive of Ident.t + + type creation_reason = + | Annotated of annotation_context * Location.t + | Missing_cmi of Path.t + | Value_creation of value_creation_reason + | Immediate_creation of immediate_creation_reason + | Immediate64_creation of immediate64_creation_reason + | Void_creation of void_creation_reason + | Any_creation of any_creation_reason + | Float64_creation of float64_creation_reason + | Float32_creation of float32_creation_reason + | Word_creation of word_creation_reason + | Bits32_creation of bits32_creation_reason + | Bits64_creation of bits64_creation_reason + | Concrete_creation of concrete_jkind_reason + | Imported + | Imported_type_argument of + { parent_path : Path.t; + position : int; + arity : int + } + (* [position] is 1-indexed *) + | Generalized of Ident.t option * Location.t + + type interact_reason = + | Gadt_equation of Path.t + | Tyvar_refinement_intersection + (* CR layouts: this needs to carry a type_expr, but that's loopy *) + | Subjkind +end diff --git a/ocaml/typing/jkind_types.ml b/ocaml/typing/jkind_types.ml new file mode 100644 index 00000000000..06c2a40bb29 --- /dev/null +++ b/ocaml/typing/jkind_types.ml @@ -0,0 +1,369 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Liam Stevenson, Jane Street, New York *) +(* *) +(* Copyright 2024 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module Sort = struct + type const = + | Void + | Value + | Float64 + | Float32 + | Word + | Bits32 + | Bits64 + + type t = + | Var of var + | Const of const + + and var = t option ref + + let equal_const c1 c2 = + match c1, c2 with + | Void, Void + | Value, Value + | Float64, Float64 + | Float32, Float32 + | Word, Word + | Bits32, Bits32 + | Bits64, Bits64 -> + true + | (Void | Value | Float64 | Float32 | Word | Bits32 | Bits64), _ -> false + + (* To record changes to sorts, for use with `Types.{snapshot, backtrack}` *) + type change = var * t option + + let change_log : (change -> unit) ref = ref (fun _ -> ()) + + let set_change_log cl = change_log := cl + + let log_change change = !change_log change + + let undo_change (v, t_op) = v := t_op + + let var_name : var -> string = + let next_id = ref 1 in + let named = ref [] in + fun v -> + match List.assq_opt v !named with + | Some name -> name + | None -> + let id = !next_id in + let name = "'_representable_layout_" ^ Int.to_string id in + next_id := id + 1; + named := (v, name) :: !named; + name + + let set : var -> t option -> unit = + fun v t_op -> + log_change (v, !v); + v := t_op + + let void = Const Void + + let value = Const Value + + let float64 = Const Float64 + + let float32 = Const Float32 + + let word = Const Word + + let bits32 = Const Bits32 + + let bits64 = Const Bits64 + + let some_value = Some value + + let of_const = function + | Void -> void + | Value -> value + | Float64 -> float64 + | Float32 -> float32 + | Word -> word + | Bits32 -> bits32 + | Bits64 -> bits64 + + let of_var v = Var v + + let new_var () = Var (ref None) + + (* Post-condition: If the result is a [Var v], then [!v] is [None]. *) + let rec get : t -> t = function + | Const _ as t -> t + | Var r as t -> ( + match !r with + | None -> t + | Some s -> + let result = get s in + if result != s then set r (Some result); + (* path compression *) + result) + + let memoized_value : t option = Some (Const Value) + + let memoized_void : t option = Some (Const Void) + + let memoized_float64 : t option = Some (Const Float64) + + let memoized_float32 : t option = Some (Const Float32) + + let memoized_word : t option = Some (Const Word) + + let memoized_bits32 : t option = Some (Const Bits32) + + let memoized_bits64 : t option = Some (Const Bits64) + + let[@inline] get_memoized = function + | Value -> memoized_value + | Void -> memoized_void + | Float64 -> memoized_float64 + | Float32 -> memoized_float32 + | Word -> memoized_word + | Bits32 -> memoized_bits32 + | Bits64 -> memoized_bits64 + + let rec get_default_value : t -> const = function + | Const c -> c + | Var r -> ( + match !r with + | None -> + set r memoized_value; + Value + | Some s -> + let result = get_default_value s in + set r (get_memoized result); + (* path compression *) + result) + + let default_to_value t = ignore (get_default_value t) + + (***********************) + (* equality *) + + type equate_result = + | Unequal + | Equal_mutated_first + | Equal_mutated_second + | Equal_no_mutation + + let swap_equate_result = function + | Equal_mutated_first -> Equal_mutated_second + | Equal_mutated_second -> Equal_mutated_first + | (Unequal | Equal_no_mutation) as r -> r + + let equal_const_const c1 c2 = + match c1, c2 with + | Void, Void + | Value, Value + | Float64, Float64 + | Float32, Float32 + | Word, Word + | Bits32, Bits32 + | Bits64, Bits64 -> + Equal_no_mutation + | (Void | Value | Float64 | Float32 | Word | Bits32 | Bits64), _ -> Unequal + + let rec equate_var_const v1 c2 = + match !v1 with + | Some s1 -> equate_sort_const s1 c2 + | None -> + set v1 (Some (of_const c2)); + Equal_mutated_first + + and equate_var v1 s2 = + match s2 with + | Const c2 -> equate_var_const v1 c2 + | Var v2 -> equate_var_var v1 v2 + + and equate_var_var v1 v2 = + if v1 == v2 + then Equal_no_mutation + else + match !v1, !v2 with + | Some s1, _ -> swap_equate_result (equate_var v2 s1) + | _, Some s2 -> equate_var v1 s2 + | None, None -> + set v1 (Some (of_var v2)); + Equal_mutated_first + + and equate_sort_const s1 c2 = + match s1 with + | Const c1 -> equal_const_const c1 c2 + | Var v1 -> equate_var_const v1 c2 + + let equate_tracking_mutation s1 s2 = + match s1 with + | Const c1 -> swap_equate_result (equate_sort_const s2 c1) + | Var v1 -> equate_var v1 s2 + + (* Don't expose whether or not mutation happened; we just need that for [Jkind] *) + let equate s1 s2 = + match equate_tracking_mutation s1 s2 with + | Unequal -> false + | Equal_mutated_first | Equal_mutated_second | Equal_no_mutation -> true + + let rec is_void_defaulting = function + | Const Void -> true + | Var v -> ( + match !v with + (* CR layouts v5: this should probably default to void now *) + | None -> + set v some_value; + false + | Some s -> is_void_defaulting s) + | Const (Value | Float64 | Float32 | Word | Bits32 | Bits64) -> false + + (*** pretty printing ***) + + let string_of_const = function + | Value -> "value" + | Void -> "void" + | Float64 -> "float64" + | Float32 -> "float32" + | Word -> "word" + | Bits32 -> "bits32" + | Bits64 -> "bits64" + + let to_string s = + match get s with Var v -> var_name v | Const c -> string_of_const c + + let format ppf t = Format.fprintf ppf "%s" (to_string t) + + let format_const ppf const = Format.fprintf ppf "%s" (string_of_const const) + + (*** debug printing **) + + module Debug_printers = struct + open Format + + let rec t ppf = function + | Var v -> fprintf ppf "Var %a" var v + | Const c -> + fprintf ppf + (match c with + | Void -> "Void" + | Value -> "Value" + | Float64 -> "Float64" + | Float32 -> "Float32" + | Word -> "Word" + | Bits32 -> "Bits32" + | Bits64 -> "Bits64") + + and opt_t ppf = function + | Some s -> fprintf ppf "Some %a" t s + | None -> fprintf ppf "None" + + and var ppf v = fprintf ppf "{ contents = %a }" opt_t !v + end + + let for_function = value + + let for_predef_value = value + + let for_block_element = value + + let for_probe_body = value + + let for_poly_variant = value + + let for_record = value + + let for_object = value + + let for_lazy_body = value + + let for_tuple_element = value + + let for_variant_arg = value + + let for_instance_var = value + + let for_class_arg = value + + let for_method = value + + let for_initializer = value + + let for_module = value + + let for_tuple = value + + let for_array_get_result = value + + let for_array_comprehension_element = value + + let for_list_element = value +end + +module Layout = struct + type ('type_expr, 'sort) layout = + | Sort of 'sort + | Any + | Non_null_value + + type 'type_expr t = ('type_expr, Sort.t) layout +end + +module Externality = struct + type t = + | External + | External64 + | Internal +end + +module Modes = Mode.Alloc.Const + +module Jkind_desc = struct + type 'type_expr t = + { layout : 'type_expr Layout.t; + modes_upper_bounds : Modes.t; + externality_upper_bound : Externality.t + } +end + +(* A history of conditions placed on a jkind. + + INVARIANT: at most one sort variable appears in this history. + This is a natural consequence of producing this history by comparing + jkinds. +*) +type 'type_expr history = + | Interact of + { reason : Jkind_intf.History.interact_reason; + lhs_jkind : 'type_expr Jkind_desc.t; + lhs_history : 'type_expr history; + rhs_jkind : 'type_expr Jkind_desc.t; + rhs_history : 'type_expr history + } + | Creation of Jkind_intf.History.creation_reason + +type 'type_expr t = + { jkind : 'type_expr Jkind_desc.t; + history : 'type_expr history + } + +type const = + | Any + | Value + | Void + | Immediate64 + | Immediate + | Float64 + | Float32 + | Word + | Bits32 + | Bits64 + | Non_null_value + +type annotation = const * Jane_asttypes.jkind_annotation diff --git a/ocaml/typing/jkind_types.mli b/ocaml/typing/jkind_types.mli new file mode 100644 index 00000000000..9259a43378e --- /dev/null +++ b/ocaml/typing/jkind_types.mli @@ -0,0 +1,133 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Liam Stevenson, Jane Street, New York *) +(* *) +(* Copyright 2024 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** You should use the types defined in [Jkind] (which redefines the + types in this file) rather than using this file directly, unless you + are in [Types] or [Primitive]. *) + +(* This module defines types used in the module Jkind. This is to avoid + a mutual dependencies between jkind.ml(i) and types.ml(i) and bewteen + jkind.ml(i) and primitive.ml(i). Polymorphic versions of types are defined + here, with type parameters that are meant to be filled by types defined in + types.ml(i). jkind.ml(i) redefines the types from this file types.ml + with the type variables instantiated. types.ml also redefines the types + from this file with the type variables instantiated, but only for internal + use. primitive.ml(i) uses the type [Jkind.const], and types.ml(i) depends on + prmitive.ml(i), so [Jkind.const] is defined here and primitive.ml(i) also + uses this module. + + Dependency chain without Jkind_types: + _____________________ + | | | + | | V + Primitive <-- Types <-- Jkind + + Dependency chain with Jkind_types: + ______________________________________ + | | | + V | | + Jkind_types <-- Primitive <-- Types <-- Jkind + + All definitions here are commented in jkind.ml or jkind.mli. *) + +module Sort : sig + (* We need to expose these details for use in [Jkind] *) + + (* Comments in [Jkind_intf.ml] *) + type const = + | Void + | Value + | Float64 + | Float32 + | Word + | Bits32 + | Bits64 + + type t = + | Var of var + | Const of const + + and var = t option ref + + include + Jkind_intf.Sort with type t := t and type var := var and type const := const + + val set_change_log : (change -> unit) -> unit + + type equate_result = + | Unequal + | Equal_mutated_first + | Equal_mutated_second + | Equal_no_mutation + + val equate_tracking_mutation : t -> t -> equate_result + + val get : t -> t +end + +module Layout : sig + type ('type_expr, 'sort) layout = + | Sort of 'sort + | Any + | Non_null_value + + type 'type_expr t = ('type_expr, Sort.t) layout +end + +module Externality : sig + type t = + | External + | External64 + | Internal +end + +module Modes = Mode.Alloc.Const + +module Jkind_desc : sig + type 'type_expr t = + { layout : 'type_expr Layout.t; + modes_upper_bounds : Modes.t; + externality_upper_bound : Externality.t + } +end + +type const = + | Any + | Value + | Void + | Immediate64 + | Immediate + | Float64 + | Float32 + | Word + | Bits32 + | Bits64 + | Non_null_value + +type 'type_expr history = + | Interact of + { reason : Jkind_intf.History.interact_reason; + lhs_jkind : 'type_expr Jkind_desc.t; + lhs_history : 'type_expr history; + rhs_jkind : 'type_expr Jkind_desc.t; + rhs_history : 'type_expr history + } + | Creation of Jkind_intf.History.creation_reason + +type 'type_expr t = + { jkind : 'type_expr Jkind_desc.t; + history : 'type_expr history + } + +type annotation = const * Jane_asttypes.jkind_annotation diff --git a/ocaml/typing/outcometree.mli b/ocaml/typing/outcometree.mli index 3c3ed5572d1..2d1d8e0dafd 100644 --- a/ocaml/typing/outcometree.mli +++ b/ocaml/typing/outcometree.mli @@ -58,7 +58,7 @@ type out_value = | Oval_variant of string * out_value option type out_jkind = - | Olay_const of Jkind.const + | Olay_const of Jkind_types.const | Olay_var of string type out_type_param = diff --git a/ocaml/typing/primitive.ml b/ocaml/typing/primitive.ml index 60298a62045..16dc89e58d7 100644 --- a/ocaml/typing/primitive.ml +++ b/ocaml/typing/primitive.ml @@ -28,7 +28,7 @@ type boxed_vector = Pvec128 of vec128_type type native_repr = | Repr_poly - | Same_as_ocaml_repr of Jkind.Sort.const + | Same_as_ocaml_repr of Jkind_types.Sort.const | Unboxed_float of boxed_float | Unboxed_vector of boxed_vector | Unboxed_integer of boxed_integer @@ -381,7 +381,7 @@ let equal_native_repr nr1 nr2 = | Untagged_int | Unboxed_vector _ | Same_as_ocaml_repr _) | (Unboxed_float _ | Unboxed_integer _ | Untagged_int | Unboxed_vector _ | Same_as_ocaml_repr _), Repr_poly -> false - | Same_as_ocaml_repr s1, Same_as_ocaml_repr s2 -> Jkind.Sort.equal_const s1 s2 + | Same_as_ocaml_repr s1, Same_as_ocaml_repr s2 -> Jkind_types.Sort.equal_const s1 s2 | Same_as_ocaml_repr _, (Unboxed_float _ | Unboxed_integer _ | Untagged_int | Unboxed_vector _) -> false diff --git a/ocaml/typing/primitive.mli b/ocaml/typing/primitive.mli index 13a06a68bc0..ad2d3e8b574 100644 --- a/ocaml/typing/primitive.mli +++ b/ocaml/typing/primitive.mli @@ -27,7 +27,7 @@ type boxed_vector = Pvec128 of vec128_type of a primitive *) type native_repr = | Repr_poly - | Same_as_ocaml_repr of Jkind.Sort.const + | Same_as_ocaml_repr of Jkind_types.Sort.const | Unboxed_float of boxed_float | Unboxed_vector of boxed_vector | Unboxed_integer of boxed_integer diff --git a/ocaml/typing/types.ml b/ocaml/typing/types.ml index d07eedb71cf..cf22e1f9892 100644 --- a/ocaml/typing/types.ml +++ b/ocaml/typing/types.ml @@ -17,8 +17,6 @@ open Asttypes -type jkind = Jkind.t - type mutability = | Immutable | Mutable of Mode.Alloc.Comonadic.Const.t @@ -38,7 +36,7 @@ type transient_expr = and type_expr = transient_expr and type_desc = - | Tvar of { name : string option; jkind : Jkind.t } + | Tvar of { name : string option; jkind : jkind } | Tarrow of arrow_desc * type_expr * type_expr * commutable | Ttuple of (string option * type_expr) list | Tconstr of Path.t * type_expr list * abbrev_memo ref @@ -48,7 +46,7 @@ and type_desc = | Tlink of type_expr | Tsubst of type_expr * type_expr option | Tvariant of row_desc - | Tunivar of { name : string option; jkind : Jkind.t } + | Tunivar of { name : string option; jkind : jkind } | Tpoly of type_expr * type_expr list | Tpackage of Path.t * (Longident.t * type_expr) list @@ -99,6 +97,16 @@ and _ commutable_gen = | Cunknown : [> `none] commutable_gen | Cvar : {mutable commu: any commutable_gen} -> [> `var] commutable_gen +and jkind = type_expr Jkind_types.t + +(* jkind depends on types defined in this file, but Jkind.equal is required + here. When jkind.ml is loaded, it calls set_jkind_equal to fill a ref to the + function. *) +(** Corresponds to [Jkind.equal] *) +let jkind_equal = ref (fun _ _ -> + failwith "jkind_equal should be set by jkind.ml") +let set_jkind_equal f = jkind_equal := f + module TransientTypeOps = struct type t = type_expr let compare t1 t2 = t1.id - t2.id @@ -245,8 +253,8 @@ type type_declaration = { type_params: type_expr list; type_arity: int; type_kind: type_decl_kind; - type_jkind: Jkind.t; - type_jkind_annotation: Jkind.annotation option; + type_jkind: jkind; + type_jkind_annotation: Jkind_types.annotation option; type_private: private_flag; type_manifest: type_expr option; type_variance: Variance.t list; @@ -269,7 +277,7 @@ and ('lbl, 'cstr) type_kind = and tag = Ordinary of {src_index: int; (* Unique name (per type) *) runtime_tag: int} (* The runtime tag *) - | Extension of Path.t * Jkind.t array + | Extension of Path.t * jkind array and abstract_reason = Abstract_def @@ -284,14 +292,14 @@ and mixed_product_shape = and record_representation = | Record_unboxed | Record_inlined of tag * variant_representation - | Record_boxed of Jkind.t array + | Record_boxed of jkind array | Record_float | Record_ufloat | Record_mixed of mixed_product_shape and variant_representation = | Variant_unboxed - | Variant_boxed of (constructor_representation * Jkind.t array) array + | Variant_boxed of (constructor_representation * jkind array) array | Variant_extensible and constructor_representation = @@ -304,7 +312,7 @@ and label_declaration = ld_mutable: mutability; ld_global: Mode.Global_flag.t; ld_type: type_expr; - ld_jkind : Jkind.t; + ld_jkind : jkind; ld_loc: Location.t; ld_attributes: Parsetree.attributes; ld_uid: Uid.t; @@ -328,7 +336,7 @@ type extension_constructor = { ext_type_path: Path.t; ext_type_params: type_expr list; ext_args: constructor_arguments; - ext_arg_jkinds: Jkind.t array; + ext_arg_jkinds: jkind array; ext_shape: constructor_representation; ext_constant: bool; ext_ret_type: type_expr option; @@ -546,7 +554,7 @@ type constructor_description = cstr_res: type_expr; (* Type of the result *) cstr_existentials: type_expr list; (* list of existentials *) cstr_args: (type_expr * Mode.Global_flag.t) list; (* Type of the arguments *) - cstr_arg_jkinds: Jkind.t array; (* Jkinds of the arguments *) + cstr_arg_jkinds: jkind array; (* Jkinds of the arguments *) cstr_arity: int; (* Number of arguments *) cstr_tag: tag; (* Tag for heap blocks *) cstr_repr: variant_representation; (* Repr of the outer variant *) @@ -613,7 +621,7 @@ let equal_variant_representation r1 r2 = r1 == r2 || match r1, r2 with | Variant_boxed cstrs_and_jkinds1, Variant_boxed cstrs_and_jkinds2 -> Misc.Stdlib.Array.equal (fun (cstr1, jkinds1) (cstr2, jkinds2) -> equal_constructor_representation cstr1 cstr2 - && Misc.Stdlib.Array.equal Jkind.equal jkinds1 jkinds2) + && Misc.Stdlib.Array.equal !jkind_equal jkinds1 jkinds2) cstrs_and_jkinds1 cstrs_and_jkinds2 | Variant_extensible, Variant_extensible -> @@ -627,7 +635,7 @@ let equal_record_representation r1 r2 = match r1, r2 with | Record_inlined (tag1, vr1), Record_inlined (tag2, vr2) -> equal_tag tag1 tag2 && equal_variant_representation vr1 vr2 | Record_boxed lays1, Record_boxed lays2 -> - Misc.Stdlib.Array.equal Jkind.equal lays1 lays2 + Misc.Stdlib.Array.equal !jkind_equal lays1 lays2 | Record_float, Record_float -> true | Record_ufloat, Record_ufloat -> @@ -677,7 +685,7 @@ type label_description = lbl_arg: type_expr; (* Type of the argument *) lbl_mut: mutability; (* Is this a mutable field? *) lbl_global: Mode.Global_flag.t; (* Is this a global field? *) - lbl_jkind : Jkind.t; (* Jkind of the argument *) + lbl_jkind : jkind; (* Jkind of the argument *) lbl_pos: int; (* Position in block *) lbl_num: int; (* Position in type *) lbl_all: label_description array; (* All the labels in this type *) @@ -751,7 +759,7 @@ type change = | Ccommu : [`var] commutable_gen -> change | Cuniv : type_expr option ref * type_expr option -> change | Cmodes : Mode.changes -> change - | Csort : Jkind.Sort.change -> change + | Csort : Jkind_types.Sort.change -> change type changes = Change of change * changes ref @@ -767,7 +775,7 @@ let log_change ch = let () = Mode.set_append_changes (fun changes -> log_change (Cmodes !changes)); - Jkind.Sort.change_log := (fun change -> log_change (Csort change)) + Jkind_types.Sort.set_change_log (fun change -> log_change (Csort change)) (* constructor and accessors for [field_kind] *) @@ -1017,7 +1025,7 @@ let undo_change = function | Ccommu (Cvar r) -> r.commu <- Cunknown | Cuniv (r, v) -> r := v | Cmodes c -> Mode.undo_changes c - | Csort change -> Jkind.Sort.undo_change change + | Csort change -> Jkind_types.Sort.undo_change change type snapshot = changes ref * int let last_snapshot = Local_store.s_ref 0 diff --git a/ocaml/typing/types.mli b/ocaml/typing/types.mli index eadff7a4c25..39ee505cbd4 100644 --- a/ocaml/typing/types.mli +++ b/ocaml/typing/types.mli @@ -24,10 +24,6 @@ (** Asttypes exposes basic definitions shared both by Parsetree and Types. *) open Asttypes -(** Jkinds classify types. *) -(* CR layouts v2.8: Say more here. *) -type jkind = Jkind.t - (** Describes a mutable field/element. *) type mutability = | Immutable @@ -76,7 +72,7 @@ type field_kind type commutable and type_desc = - | Tvar of { name : string option; jkind : Jkind.t } + | Tvar of { name : string option; jkind : jkind } (** [Tvar (Some "a")] ==> ['a] or ['_a] [Tvar None] ==> [_] *) @@ -140,7 +136,7 @@ and type_desc = | Tvariant of row_desc (** Representation of polymorphic variants, see [row_desc]. *) - | Tunivar of { name : string option; jkind : Jkind.t } + | Tunivar of { name : string option; jkind : jkind } (** Occurrence of a type variable introduced by a forall quantifier / [Tpoly]. *) @@ -221,6 +217,17 @@ and abbrev_memo = This is only allowed when the real type is known. *) +(** Jkinds classify types. *) +(* CR layouts v2.8: Say more here. *) +and jkind = type_expr Jkind_types.t + +(* jkind depends on types defined in this file, but Jkind.equal is required + here. When jkind.ml is loaded, it calls set_jkind_equal to fill a ref to the + function. *) +(** INTERNAL USE ONLY + jkind.ml should call this with the definition of Jkind.equal *) +val set_jkind_equal : (jkind -> jkind -> bool) -> unit + val is_commu_ok: commutable -> bool val commu_ok: commutable val commu_var: unit -> commutable @@ -495,7 +502,7 @@ type type_declaration = type_arity: int; type_kind: type_decl_kind; - type_jkind: Jkind.t; + type_jkind: jkind; (* for an abstract decl kind or for [@@unboxed] types: this is the stored jkind for the type; expansion might find a type with a more precise jkind. See PR#10017 for motivating examples where subsitution or @@ -507,7 +514,7 @@ type type_declaration = be computed from the decl kind. This happens in Ctype.add_jkind_equation. *) - type_jkind_annotation: Jkind.annotation option; + type_jkind_annotation: Jkind_types.annotation option; (* This is the jkind annotation written by the user. If the user did not write this declaration (because it's a synthesized declaration for an e.g. local abstract type or an inlined record), then this field @@ -548,7 +555,7 @@ and ('lbl, 'cstr) type_kind = case of normal projections from boxes. *) and tag = Ordinary of {src_index: int; (* Unique name (per type) *) runtime_tag: int} (* The runtime tag *) - | Extension of Path.t * Jkind.t array + | Extension of Path.t * jkind array and abstract_reason = Abstract_def @@ -570,7 +577,7 @@ and record_representation = | Record_inlined of tag * variant_representation (* For an inlined record, we record the representation of the variant that contains it and the tag of the relevant constructor of that variant. *) - | Record_boxed of Jkind.t array + | Record_boxed of jkind array | Record_float (* All fields are floats *) | Record_ufloat (* All fields are [float#]s. Same runtime representation as [Record_float], @@ -583,7 +590,7 @@ and record_representation = and variant_representation = | Variant_unboxed - | Variant_boxed of (constructor_representation * Jkind.t array) array + | Variant_boxed of (constructor_representation * jkind array) array (* The outer array has an element for each constructor. Each inner array has a jkind for each argument of the corresponding constructor. @@ -608,7 +615,7 @@ and label_declaration = ld_mutable: mutability; ld_global: Mode.Global_flag.t; ld_type: type_expr; - ld_jkind : Jkind.t; + ld_jkind : jkind; ld_loc: Location.t; ld_attributes: Parsetree.attributes; ld_uid: Uid.t; @@ -638,7 +645,7 @@ type extension_constructor = ext_type_path: Path.t; ext_type_params: type_expr list; ext_args: constructor_arguments; - ext_arg_jkinds: Jkind.t array; + ext_arg_jkinds: jkind array; ext_shape: constructor_representation; ext_constant: bool; ext_ret_type: type_expr option; @@ -802,7 +809,7 @@ type constructor_description = cstr_res: type_expr; (* Type of the result *) cstr_existentials: type_expr list; (* list of existentials *) cstr_args: (type_expr * Mode.Global_flag.t) list; (* Type of the arguments *) - cstr_arg_jkinds: Jkind.t array; (* Jkinds of the arguments *) + cstr_arg_jkinds: jkind array; (* Jkinds of the arguments *) cstr_arity: int; (* Number of arguments *) cstr_tag: tag; (* Tag for heap blocks *) cstr_repr: variant_representation; (* Repr of the outer variant *) @@ -843,7 +850,7 @@ type label_description = lbl_arg: type_expr; (* Type of the argument *) lbl_mut: mutability; (* Is this a mutable field? *) lbl_global: Mode.Global_flag.t; (* Is this a global field? *) - lbl_jkind : Jkind.t; (* Jkind of the argument *) + lbl_jkind : jkind; (* Jkind of the argument *) lbl_pos: int; (* Position in block *) lbl_num: int; (* Position in the type *) lbl_all: label_description array; (* All the labels in this type *) @@ -917,7 +924,7 @@ val set_type_desc: type_expr -> type_desc -> unit (* Set directly the desc field, without sharing *) val set_level: type_expr -> int -> unit val set_scope: type_expr -> int -> unit -val set_var_jkind: type_expr -> Jkind.t -> unit +val set_var_jkind: type_expr -> jkind -> unit (* May only be called on Tvars *) val set_name: (Path.t * type_expr list) option ref ->