Fix option unboxing logic in the presence of untagged variants (#6233)

* Fix option unboxing logic in the presence of untagged variants

Fixes #6222

* Refactor: naming and avoid double negations

Author: cristianoc

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
 

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

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

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

jscomp/ml/typeopt.ml

@@ -44,34 +44,52 @@ 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 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:
          int, char, float, bool, unit, exn, array, list, nativeint,
          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 ->
+            Ext_list.for_all cdecls (fun cd ->
+              if Ast_untagged_variants.has_undefined_literal cd.cd_attributes
+              then false
+              else if !untagged then
+                match cd.cd_args with
+                | Cstr_tuple [t] ->
+                  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}] ->
+                  Ast_untagged_variants.type_is_builtin_object t || type_cannot_contain_undefined t env
+                | Cstr_record ([] | _::_::_) -> true
+              else
+                true)
         end)
   | Ttuple _
   | Tvariant _

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

jscomp/test/UntaggedVariants.js

@@ -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<string>)
+  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<int>})
+  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<int>, y?: string})
+  let untaggedInlineMultinaryOption = (x: untaggedInlineMultinaryOption) => Some(x)
+}