Test primitive untagged cases before class checks

changes/untagged-default-arm.fix.md

@@ -0,0 +1 @@
+- Fix untagged variant switches with a default arm matching class instances in the object case and literals in a payload case of their kind.

changes/untagged-typeof-first.polish.md

@@ -0,0 +1 @@
+- Test the primitive cases of an untagged variant before its class checks, so that strings and numbers skip `instanceof` and a class missing at run time no longer throws for them.

compiler/core/lam_compile.ml

@@ -780,10 +780,34 @@ let compile output_prefix =
               | NonComplete, NonComplete -> true
               | _ -> false
             in
+            (* A literal handled by the default would otherwise pass the
+               check of a payload arm of its kind *)
+            let a_literal_reaches_an_arm () =
+              let arm_types =
+                Ext_list.filter_map sw_blocks (fun (key, _) ->
+                    match tag_of_switch_key key with
+                    | Some {tag_type = Some (Payload_shape block_type)} ->
+                      Some block_type
+                    | Some _ | None -> None)
+              in
+              Ext_list.exists literal_cases
+                (fun (literal : Variant_runtime.literal_tag) ->
+                  Ext_list.exists arm_types
+                    (fun (block_type : Variant_runtime.block_type) ->
+                      match (literal, block_type) with
+                      | String _, StringType
+                      | (Int _ | Float _), (IntType | FloatType)
+                      | BigInt _, BigintType
+                      | Bool _, BooleanType
+                      | _, UnknownType ->
+                        true
+                      | _, _ -> false))
+            in
             if
               untagged
               && List.length sw_consts = 0
               && eq_default sw_num_default sw_blocks_default
+              && not (a_literal_reaches_an_arm ())
             then
               let has_null_case = List.mem Variant_runtime.Null literal_cases in
               compile_cases ~untagged ~cxt
@@ -853,6 +877,22 @@ let compile output_prefix =
       | _ -> false
     in
     let clause_is_not_typeof (tag, _) = tag_is_not_typeof tag in
+    let tag_is_primitive = function
+      | Variant_runtime.Payload_shape
+          ( IntType | FloatType | StringType | BigintType | BooleanType
+          | SymbolType ) ->
+        true
+      | _ -> false
+    in
+    (* Only class checks can throw (when the class is missing), so arrays,
+       recognized by [Array.isArray], keep the shorter form *)
+    let has_class_case =
+      List.exists
+        (function
+          | Variant_runtime.InstanceType (Class _) -> true
+          | _ -> false)
+        block_cases
+    in
     let switch ?default ?declaration e clauses =
       let not_typeof_clauses, typeof_clauses =
         List.partition clause_is_not_typeof clauses
@@ -864,26 +904,52 @@ let compile output_prefix =
             | _ -> false)
           typeof_clauses
       in
-      let clauses_have_array_case =
-        List.exists
-          (function
-            | Variant_runtime.Payload_shape (InstanceType Array), _ -> true
-            | _ -> false)
-          not_typeof_clauses
-      in
-      let type_has_array_case =
+      let has_function_typeof =
         List.exists
           (function
-            | Variant_runtime.InstanceType Array -> true
+            | Variant_runtime.Payload_shape FunctionType, _ -> true
             | _ -> false)
-          block_cases
+          typeof_clauses
       in
       (* When there's an ObjectType typeof case, null and arrays can
-         incorrectly match it (typeof null === typeof [] === "object").
-         Guard against them when they should fall through to default. *)
+         incorrectly match it (typeof null === typeof [] === "object"), and so
+         can class instances, which can be functions too. Guard against the
+         instance cases without an arm of their own, which belong to the
+         default. *)
       let needs_null_guard = has_object_typeof && has_null_case in
-      let needs_array_guard =
-        has_object_typeof && type_has_array_case && not clauses_have_array_case
+      let unmatched_instances =
+        Ext_list.filter_map block_cases (function
+          | Variant_runtime.InstanceType instance
+            when not
+                   (List.exists
+                      (function
+                        | Variant_runtime.Payload_shape (InstanceType i), _ ->
+                          i = instance
+                        | _ -> false)
+                      not_typeof_clauses) -> (
+            match instance with
+            | Array -> if has_object_typeof then Some instance else None
+            | Class _ ->
+              if has_object_typeof || has_function_typeof then Some instance
+              else None)
+          | _ -> None)
+      in
+      (* A class instance is never a primitive, so the primitive kinds can be
+         tested first: their values then skip the instance checks and guards,
+         which throw when a class is missing at run time *)
+      let primitive_clauses, typeof_clauses =
+        if
+          (not has_class_case)
+          || not_typeof_clauses = []
+             && not
+                  (List.exists
+                     (function
+                       | Variant_runtime.Instance.Class _ -> true
+                       | Array -> false)
+                     unmatched_instances)
+        then ([], typeof_clauses)
+        else
+          List.partition (fun (tag, _) -> tag_is_primitive tag) typeof_clauses
       in
       let instances =
         Ext_list.filter_map block_cases (function
@@ -903,26 +969,60 @@ let compile output_prefix =
             ~else_:[build_if_chain rest]
         | _ -> (
           let typeof_switch () =
-            S.string_switch ?default ?declaration (E.typeof e) typeof_clauses
+            match (primitive_clauses, typeof_clauses) with
+            | _ :: _, [] -> S.block (Option.value default ~default:[])
+            | _ :: _, _ :: _ ->
+              S.string_switch ?default (E.typeof e) typeof_clauses
+            | [], _ ->
+              S.string_switch ?default ?declaration (E.typeof e) typeof_clauses
+          in
+          let guards =
+            (if needs_null_guard then [E.is_null e] else [])
+            @ List.map
+                (fun instance ->
+                  E.emit_check
+                    (Ast_untagged_variants.Dynamic_checks.is_instance instance
+                       (Expr e)))
+                unmatched_instances
           in
           let guard =
-            match (needs_null_guard, needs_array_guard) with
-            | true, true -> Some (E.or_ (E.is_null e) (E.is_array e))
-            | true, false -> Some (E.is_null e)
-            | false, true -> Some (E.is_array e)
-            | false, false -> None
+            match guards with
+            | [] -> None
+            | first :: rest -> Some (List.fold_left E.or_ first rest)
           in
           match (guard, default) with
           | Some guard, Some default_body ->
             S.if_ guard default_body ~else_:[typeof_switch ()]
           | Some guard, None -> S.if_ (E.not guard) [typeof_switch ()]
           | None, _ -> typeof_switch ())
       in
-      build_if_chain not_typeof_clauses
+      match primitive_clauses with
+      | [] -> build_if_chain not_typeof_clauses
+      | _ ->
+        S.string_switch ?declaration (E.typeof e) primitive_clauses
+          ~default:[build_if_chain not_typeof_clauses]
     in
     let merge_cases tag1 tag2 =
-      (* only merge typeof cases, as instanceof cases are pulled out into if-then-else *)
-      not (tag_is_not_typeof tag1 || tag_is_not_typeof tag2)
+      (* only merge typeof cases, as instanceof cases are pulled out into
+         if-then-else. With instance cases, the primitive kinds are tested in
+         a switch of their own, so they share bodies only among themselves *)
+      (not (tag_is_not_typeof tag1 || tag_is_not_typeof tag2))
+      && ((not has_class_case) || tag_is_primitive tag1 = tag_is_primitive tag2)
+    in
+    (* Two arms are compiled to one check of the first. When it is a class
+       check and the other arm's check is not, check the other arm instead,
+       so that primitives never reach [instanceof] *)
+    let cases =
+      match (cases, default) with
+      | ( [
+            ((Variant_runtime.Payload_shape (InstanceType (Class _)), _) as
+             class_case);
+            ((tag, _) as other_case);
+          ],
+          Complete )
+        when not (tag_is_not_typeof tag) ->
+        [other_case; class_case]
+      | _ -> cases
     in
     cases
     |> compile_general_cases ~make_exp:E.tag_type ~eq_exp:mk_eq ~cxt ~switch

compiler/ml/UntaggedVariants.md

@@ -275,7 +275,11 @@ constructor:
 The "is a literal case" test is the smaller of two equivalent expressions: the
 disjunction of `x === literal` over the literal cases, or the conjunction of
 the negated payload checks (with a payload check replaced by the literal
-disjunction where a literal overlaps it).
+disjunction where a literal overlaps it). A variant with class cases always
+uses the first, so that literals never reach a class check. A `switch` whose
+arms name no literal case still tests the literals first when one of them
+would pass the check of a payload arm, such as `@as("lit")` beside a
+`string` arm, so that it reaches the default arm.
 
 - Implementation: `lam_compile.ml:compile_switch`,
   `ast_untagged_variants.ml:Dynamic_checks.is_a_literal_case`.
@@ -288,14 +292,28 @@ disjunction where a literal overlaps it).
 The payload arms compile in one of two forms.
 
 - **Two arms, or one arm and a default**: one `if` on the check of the arm
-  declared first, with the other branch unchecked (rule 10). The object check is
+  declared first, with the other branch unchecked (rule 10). Of a class arm
+  and an arm of another kind, the other one is checked, so that primitives
+  never reach a class check. The object check is
   `typeof x === "object"`, followed by `x !== null` when the variant has an
   `@as(null)` case, and by `!(x instanceof C)` (`!Array.isArray(x)` for
   arrays) for every instance case of the variant. The function check is
   followed by `!(x instanceof C)` for every class case.
 - **Three or more arms**: an `if` chain of the instance checks, in the
   declaration order of the cases, then one `switch (typeof x)` over the other
-  arms.
+  arms. When a variant has class cases (not only arrays), the arms of
+  primitive kinds (string, number, bigint, boolean, symbol) come first, in an
+  outer `switch (typeof x)` whose default holds the rest; a class instance is
+  never a primitive, so this changes no outcome:
+
+  ```js
+  switch (typeof x) {
+    case "string": ...
+    default:
+      if (x instanceof Date) { ... }
+      else switch (typeof x) { case "object": ... }
+  }
+  ```
 
 In both forms a value of an instance case never lands in the object or
 function case. A class check is followed by `!(x instanceof D)` for every
@@ -309,7 +327,12 @@ if (v instanceof Animal && !(v instanceof Dog)) { ... }
 A value upcast to the superclass and wrapped in its case lands in the
 subclass case, as a payload equal to a literal lands in the literal's case
 (rule 7). Classes not declared to be related are tested in declaration order.
-`instanceof` consults `Symbol.hasInstance`, which is trusted.
+`instanceof` consults `Symbol.hasInstance`, which is trusted for objects and
+functions. A literal, and a primitive whose kind has an arm of the `switch`,
+land in their case before any class check runs, even if a class's
+`Symbol.hasInstance` would accept them: the values of a class type are
+instances, never primitives. With one class arm and a default, every value
+reaches the class check.
 An `int` case is recognized by `typeof x === "number"` and so receives every
 number, integral or not.
 
@@ -321,17 +344,18 @@ number, integral or not.
   declaration order, `objectFirst` both forms); `tests/tests/src/UntaggedVariants.res`
   (`AllInstanceofTypes`, `MergeCases`);
   `tests/tests/src/untagged_runtime_annotations_test.res` (subclasses, the
-  function case).
+  function case), `untagged_default_arm_test.res` (`Symbol.hasInstance`).
 - Shaped by #6103, #6383, #6792, #7144, #7149.
 
 ### 9. `null` and arrays are not objects
 
-`typeof null` and `typeof []` are `"object"`. The object case never receives
-`null` when the variant has an `@as(null)` case, and never receives an array
-when the variant has an array or tuple case: the two-arm form adds the checks
-of rule 8, and the `switch (typeof x)` form is preceded by
-`x === null` / `Array.isArray(x)` guards that send those values to the default
-arm when their own arm is absent. A case declared with `@typeOf("object")`
+`typeof null` and `typeof []` are `"object"`, and a class instance is an
+object or a function. The object case never receives `null` when the variant
+has an `@as(null)` case, and neither the object nor the function case
+receives an instance of another case: the two-arm form adds the checks of
+rule 8, and the `switch (typeof x)` form is preceded by `x === null`,
+`Array.isArray(x)` and `x instanceof C` guards that send those values to the
+default arm when their own case has no arm. A case declared with `@typeOf("object")`
 (rule 5) is an object case: without an `@as(null)` case, it receives `null`,
 as a record case does.
 
@@ -342,9 +366,10 @@ as a record case does.
 | | `GObject(_)`, `_` | `[]`, `null` | `_` |
 
 - Implementation: `lam_compile.ml:compile_untagged_cases` (`needs_null_guard`,
-  `needs_array_guard`), `Dynamic_checks.add_runtime_type_check`.
-- Tests: `spec_test` rule 9; `UntaggedVariants.res` (`ObjectAndNull`, `Json`).
-- Shaped by #6219, #7303, #8253, #8255, #8279.
+  `unmatched_instances`), `Dynamic_checks.add_runtime_type_check`.
+- Tests: `spec_test` rule 9; `UntaggedVariants.res` (`ObjectAndNull`, `Json`);
+  `tests/tests/src/untagged_default_arm_test.res`.
+- Shaped by #6219, #7303, #8253, #8255, #8279, #8995.
 
 ### 10. Values outside every case
 
@@ -353,16 +378,17 @@ Recognition trusts the type. A value that belongs to no case is not rejected:
 - in the two-arm form it lands in the unchecked branch: with
   `I(int) | S(string)`, `true` lands in `S`; with
   `TDate(Date.t) | TRegExp(RegExp.t)`, `{x: 1}` lands in `TRegExp`; with
-  `PPromise(promise<int>) | PFloat(float)`, a thenable that is not a
-  `Promise` lands in `PFloat`;
+  `PPromise(promise<int>) | PFloat(float)`, the float case is checked (rule
+  8), so a thenable that is not a `Promise` lands in `PPromise`;
 - in the `switch (typeof x)` form it matches no arm, and the `switch`
   completes without running any arm.
 
 A value from another JavaScript realm fails every `instanceof` check and is
 recognized the same way (by the semantics of `instanceof`; not tested):
 recognition is local to a realm. A class that does not exist where the
-`switch` runs makes its check throw, for every value: the instance checks
-precede the `typeof` checks, so primitives reach them too.
+`switch` runs makes its check throw for every value that reaches it:
+objects and functions, primitives whose case has no arm of the `switch`, and,
+with one class arm and a default, every value.
 
 - Implementation: `lam_compile.ml:compile_general_cases` (a complete match
   emits no check for its last clause).
@@ -562,6 +588,5 @@ had to answer, and the answers of rule 5:
 9. **Globals.** A shadowed class is read through `globalThis`. A missing
    class throws when the check runs (rule 10).
 
-Still open: a class imported from a module cannot be named; the `typeof`
-checks could precede the instance checks, so that a missing class affects
-only objects; and the typed arrays share one type (#8955).
+Still open: a class imported from a module cannot be named, and the typed
+arrays share one type (#8955).

compiler/ml/ast_untagged_variants.ml

@@ -699,8 +699,18 @@ module Dynamic_checks = struct
     let without_literal_cases =
       is_a_literal_case ~literal_cases ~block_cases ~list_literal_cases:false e
     in
-    if size with_literal_cases <= size without_literal_cases then
-      with_literal_cases
+    (* Class checks would run on the literals, which are primitives: a class
+       missing at run time would throw, and a [Symbol.hasInstance] could
+       claim them *)
+    let has_class_case =
+      List.exists
+        (function
+          | InstanceType (Class _) -> true
+          | _ -> false)
+        block_cases
+    in
+    if has_class_case || size with_literal_cases <= size without_literal_cases
+    then with_literal_cases
     else without_literal_cases
 
   let is_int_tag ?(has_null_undefined_other = (false, false, false)) (e : _ t) :