From 4fbe5bb3178d1d4b27eb4d658f8e60eb06b1501a Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 2 May 2023 07:25:52 +0200 Subject: [PATCH 1/2] Fix option unboxing logic in the presence of untagged variants Fixes https://github.com/rescript-lang/rescript-compiler/issues/6222 --- CHANGELOG.md | 1 + jscomp/ml/ast_untagged_variants.ml | 16 +++++++++-- jscomp/ml/typeopt.ml | 45 ++++++++++++++++++++++-------- jscomp/test/UntaggedVariants.js | 45 ++++++++++++++++++++++++++++++ jscomp/test/UntaggedVariants.res | 32 +++++++++++++++++++++ 5 files changed, 125 insertions(+), 14 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index d6042b0597..b874455bfe 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -19,6 +19,7 @@ #### :bug: Bug Fix - Remove unnecessary require and import statements when using dynamic imports. https://github.com/rescript-lang/rescript-compiler/pull/6232 +- Fix option unboxing logic in the presence of untagged variants. https://github.com/rescript-lang/rescript-compiler/pull/6233 #### :nail_care: Polish diff --git a/jscomp/ml/ast_untagged_variants.ml b/jscomp/ml/ast_untagged_variants.ml index 0708f558ee..ce5e01bf73 100644 --- a/jscomp/ml/ast_untagged_variants.ml +++ b/jscomp/ml/ast_untagged_variants.ml @@ -99,6 +99,12 @@ let () = None ) +let type_is_builtin_object (t:Types.type_expr) = match t.desc with + | Tconstr (path, _, _) -> + let name = Path.name path in + name = "Js.Dict.t" || name = "Js_dict.t" +| _ -> false + let get_block_type ~env (cstr: Types.constructor_declaration) : block_type option = match process_untagged cstr.cd_attributes, cstr.cd_args with | false, _ -> None @@ -112,9 +118,7 @@ let get_block_type ~env (cstr: Types.constructor_declaration) : block_type optio Some ArrayType | true, Cstr_tuple [{desc = Tconstr (path, _, _)}] when Path. same path Predef.path_string -> Some StringType - | true, Cstr_tuple [{desc = Tconstr (path, _, _)}] when - let name = Path.name path in - name = "Js.Dict.t" || name = "Js_dict.t" -> + | true, Cstr_tuple [{desc = Tconstr _} as t] when type_is_builtin_object t -> Some ObjectType | true, Cstr_tuple [ty] -> let default = Some UnknownType in @@ -242,6 +246,12 @@ let names_from_type_variant ?(isUntaggedDef=false) ~env (cstrs : Types.construct let check_well_formed ~env ~isUntaggedDef (cstrs: Types.constructor_declaration list) = ignore (names_from_type_variant ~env ~isUntaggedDef cstrs) +let has_undefined_literal attrs = + process_tag_type attrs = Some Undefined + +let block_is_object ~env attrs = + get_block_type ~env attrs = Some ObjectType + module DynamicChecks = struct type op = EqEqEq | NotEqEq | Or | And diff --git a/jscomp/ml/typeopt.ml b/jscomp/ml/typeopt.ml index 3a8ff7cf3a..9b645cde76 100644 --- a/jscomp/ml/typeopt.ml +++ b/jscomp/ml/typeopt.ml @@ -44,7 +44,7 @@ let scrape env ty = records the type at the definition type so for ['a option] it will always be [Tvar] *) -let cannot_inhabit_none_like_value (typ : Types.type_expr) (env : Env.t) = +let rec cannot_inhabit_none_like_value (typ : Types.type_expr) (env : Env.t) = match scrape env typ with | Tconstr(p, _,_) -> (* all built in types could not inhabit none-like values: @@ -52,26 +52,49 @@ let cannot_inhabit_none_like_value (typ : Types.type_expr) (env : Env.t) = int32, int64, lazy_t, bytes *) (match Predef.type_is_builtin_path_but_option p with - | For_sure_yes -> true + | For_sure_yes -> true | For_sure_no -> false - | NA -> - - begin match (Env.find_type p env).type_kind with + | NA -> + let untagged = ref false in + begin match + let decl = Env.find_type p env in + let () = + if Ast_untagged_variants.has_untagged decl.type_attributes + then untagged := true in + decl.type_kind with | exception _ -> false - | Types.Type_abstract | Types.Type_open -> false - | Types.Type_record _ -> true - | (Types.Type_variant + | Type_abstract | Type_open -> false + | Type_record _ -> true + | Type_variant ([{cd_id = {name="None"}; cd_args = Cstr_tuple [] }; {cd_id = {name = "Some"}; cd_args = Cstr_tuple [_]}] | [{cd_id = {name="Some"}; cd_args = Cstr_tuple [_] }; {cd_id = {name = "None"}; cd_args = Cstr_tuple []}] | [{cd_id= {name = "()"}; cd_args = Cstr_tuple []}] - )) - (* | Types.Type_variant *) + ) -> false (* conservative *) - | _ -> true + | Type_variant cdecls -> + let type_can_contain_undefined t = + not (Ast_untagged_variants.type_is_builtin_object t) && + not (cannot_inhabit_none_like_value t env) in + let can_contain_undefined = + Ext_list.exists cdecls (fun cd -> + if Ast_untagged_variants.has_undefined_literal cd.cd_attributes + then true + else if !untagged then + match cd.cd_args with + | Cstr_tuple [t] -> + type_can_contain_undefined t + | Cstr_tuple [] -> false + | Cstr_tuple (_::_::_) -> false (* Not actually possible for untagged *) + | Cstr_record [{ld_type=t}] -> + type_can_contain_undefined t + | Cstr_record ([] | _::_::_) -> false + else + false) in + not can_contain_undefined end) | Ttuple _ | Tvariant _ diff --git a/jscomp/test/UntaggedVariants.js b/jscomp/test/UntaggedVariants.js index 97f82d7694..f7b023abe7 100644 --- a/jscomp/test/UntaggedVariants.js +++ b/jscomp/test/UntaggedVariants.js @@ -2,6 +2,7 @@ 'use strict'; var Caml_array = require("../../lib/js/caml_array.js"); +var Caml_option = require("../../lib/js/caml_option.js"); function classify(x) { if (x === "A" && typeof x !== "number") { @@ -318,6 +319,49 @@ var ArrayAndObject = { classify: classify$8 }; +function testHasNull(x) { + return x; +} + +function testHasUndefined(x) { + return Caml_option.some(x); +} + +function untaggedWithOptionPayload(x) { + return Caml_option.some(x); +} + +function untaggedWithIntPayload(x) { + return x; +} + +function untaggedInlineNoOptions(x) { + return x; +} + +function untaggedInlineUnaryWihtExplicitOption(x) { + return Caml_option.some(x); +} + +function untaggedInlineUnaryWihtImplicitOption(x) { + return Caml_option.some(x); +} + +function untaggedInlineMultinaryOption(x) { + return x; +} + +var OptionUnboxingHeuristic = { + testHasNull: testHasNull, + testHasUndefined: testHasUndefined, + untaggedWithOptionPayload: untaggedWithOptionPayload, + untaggedWithIntPayload: untaggedWithIntPayload, + untaggedInlineNoOptions: untaggedInlineNoOptions, + untaggedInlineUnaryWihtExplicitOption: untaggedInlineUnaryWihtExplicitOption, + untaggedInlineUnaryWihtImplicitOption: untaggedInlineUnaryWihtImplicitOption, + untaggedInlineMultinaryOption: untaggedInlineMultinaryOption +}; + var i = 42; var i2 = 42.5; @@ -357,4 +401,5 @@ exports.OverlapNumber = OverlapNumber; exports.OverlapObject = OverlapObject; exports.RecordIsObject = RecordIsObject; exports.ArrayAndObject = ArrayAndObject; +exports.OptionUnboxingHeuristic = OptionUnboxingHeuristic; /* l2 Not a pure module */ diff --git a/jscomp/test/UntaggedVariants.res b/jscomp/test/UntaggedVariants.res index 6077501b70..0355ee671e 100644 --- a/jscomp/test/UntaggedVariants.res +++ b/jscomp/test/UntaggedVariants.res @@ -261,3 +261,35 @@ module ArrayAndObject = { | Array(a) => a[0] } } + +module OptionUnboxingHeuristic = { + type hasNull = | @as(null) Null | B(int) + let testHasNull = (x: hasNull) => Some(x) + + type hasUndefined = | @as(undefined) Undefined | B(int) + let testHasUndefined = (x: hasUndefined) => Some(x) + + @unboxed + type untaggedWithOptionPayload = A | B(option) + let untaggedWithOptionPayload = (x: untaggedWithOptionPayload) => Some(x) + + @unboxed + type untaggedWithIntPayload = A | B(int) + let untaggedWithIntPayload = (x: untaggedWithIntPayload) => Some(x) + + @unboxed + type untaggedInlineNoOption = A | B({x: int}) + let untaggedInlineNoOptions = (x: untaggedInlineNoOption) => Some(x) + + @unboxed + type untaggedInlineUnaryWihtExplicitOption = A | B({x: option}) + let untaggedInlineUnaryWihtExplicitOption = (x: untaggedInlineUnaryWihtExplicitOption) => Some(x) + + @unboxed + type untaggedInlineUnaryWihtImplicitOption = A | B({x?: int}) + let untaggedInlineUnaryWihtImplicitOption = (x: untaggedInlineUnaryWihtImplicitOption) => Some(x) + + @unboxed + type untaggedInlineMultinaryOption = A | B({x: option, y?: string}) + let untaggedInlineMultinaryOption = (x: untaggedInlineMultinaryOption) => Some(x) +} From 319a11ffe83ef9611ceaf55f741d898418daafc3 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 2 May 2023 07:47:26 +0200 Subject: [PATCH 2/2] Refactor: naming and avoid double negations --- jscomp/ml/matching.ml | 2 +- jscomp/ml/translcore.ml | 2 +- jscomp/ml/typeopt.ml | 23 +++++++++-------------- jscomp/ml/typeopt.mli | 2 +- 4 files changed, 12 insertions(+), 17 deletions(-) diff --git a/jscomp/ml/matching.ml b/jscomp/ml/matching.ml index c86dc1a378..575e118911 100644 --- a/jscomp/ml/matching.ml +++ b/jscomp/ml/matching.ml @@ -1345,7 +1345,7 @@ let make_constr_matching p def ctx = function [ { pat_type ; pat_env } ]) - when Typeopt.cannot_inhabit_none_like_value pat_type pat_env + when Typeopt.type_cannot_contain_undefined pat_type pat_env -> val_from_unnest_option_bs_primitive | _ -> val_from_option_bs_primitive in (Lprim (from_option, [arg], p.pat_loc), Alias) :: argl diff --git a/jscomp/ml/translcore.ml b/jscomp/ml/translcore.ml index 51479622cf..b4e4d1d92c 100644 --- a/jscomp/ml/translcore.ml +++ b/jscomp/ml/translcore.ml @@ -839,7 +839,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = if Datarepr.constructor_has_optional_shape cstr then match args with | [ arg ] - when Typeopt.cannot_inhabit_none_like_value arg.exp_type + when Typeopt.type_cannot_contain_undefined arg.exp_type arg.exp_env -> (* Format.fprintf Format.err_formatter "@[special boxingl@]@."; *) Blk_some_not_nested diff --git a/jscomp/ml/typeopt.ml b/jscomp/ml/typeopt.ml index 9b645cde76..4513f4fbf4 100644 --- a/jscomp/ml/typeopt.ml +++ b/jscomp/ml/typeopt.ml @@ -44,7 +44,7 @@ let scrape env ty = records the type at the definition type so for ['a option] it will always be [Tvar] *) -let rec cannot_inhabit_none_like_value (typ : Types.type_expr) (env : Env.t) = +let rec type_cannot_contain_undefined (typ : Types.type_expr) (env : Env.t) = match scrape env typ with | Tconstr(p, _,_) -> (* all built in types could not inhabit none-like values: @@ -76,25 +76,20 @@ let rec cannot_inhabit_none_like_value (typ : Types.type_expr) (env : Env.t) = ) -> false (* conservative *) | Type_variant cdecls -> - let type_can_contain_undefined t = - not (Ast_untagged_variants.type_is_builtin_object t) && - not (cannot_inhabit_none_like_value t env) in - let can_contain_undefined = - Ext_list.exists cdecls (fun cd -> + Ext_list.for_all cdecls (fun cd -> if Ast_untagged_variants.has_undefined_literal cd.cd_attributes - then true + then false else if !untagged then match cd.cd_args with | Cstr_tuple [t] -> - type_can_contain_undefined t - | Cstr_tuple [] -> false - | Cstr_tuple (_::_::_) -> false (* Not actually possible for untagged *) + Ast_untagged_variants.type_is_builtin_object t || type_cannot_contain_undefined t env + | Cstr_tuple [] -> true + | Cstr_tuple (_::_::_) -> true (* Not actually possible for untagged *) | Cstr_record [{ld_type=t}] -> - type_can_contain_undefined t - | Cstr_record ([] | _::_::_) -> false + Ast_untagged_variants.type_is_builtin_object t || type_cannot_contain_undefined t env + | Cstr_record ([] | _::_::_) -> true else - false) in - not can_contain_undefined + true) end) | Ttuple _ | Tvariant _ diff --git a/jscomp/ml/typeopt.mli b/jscomp/ml/typeopt.mli index ffb740c973..d0d5dffcc4 100644 --- a/jscomp/ml/typeopt.mli +++ b/jscomp/ml/typeopt.mli @@ -34,7 +34,7 @@ val classify_lazy_argument : Typedtree.expression -> | `Identifier of [`Forward_value | `Other] | `Other] -val cannot_inhabit_none_like_value: +val type_cannot_contain_undefined: Types.type_expr -> Env.t -> bool