Decide the untagged dispatch's literal cases by routing them

changes/untagged-dispatch-fewer-checks.polish.md

@@ -0,0 +1 @@
+- Leave out checks of an untagged variant switch whose outcome runs the same code, and test a literal without an arm with `===` only when the payload dispatch would run a class check on it.

compiler/ml/UntaggedVariants.md

@@ -334,12 +334,17 @@ constructor:
 The literals are compared with `===`: by one `switch (x)` over the literal
 arms, whose default holds the payload dispatch, or, when at most two
 literals get a `case`, by an `if` per arm body. A literal without an arm of its own goes
-to the default arm. It gets a `case` leading there when it could pass a
-check of the payload dispatch (a string literal beside a `string` arm, any
-literal beside an unknown-kind arm) or when the variant has class cases;
-otherwise it reaches the default through the payload dispatch, which then
-checks its last arm. A `null` literal that only the object check would
-accept adds `x !== null` to that check instead (rule 9).
+to the default arm. It reaches the default through the payload dispatch,
+which then checks its last arm, when the payload dispatch takes it there
+without a class check; otherwise, as for a string literal beside a `string`
+arm, any literal beside an unknown-kind arm, or a literal whose kind meets a
+class check, it gets a `case` leading there. A `null` literal that only the
+object check would accept adds `x !== null` to that check instead (rule 9).
+
+The dispatch tests nothing whose outcome runs the same body: arms of
+different kinds with one body, also arms with the default's body, are left
+to one unchecked branch, and a literal with the body of a payload dispatch
+that runs one body unchecked gets no `case`.
 
 A payload pattern whose every value is a literal case's can therefore never
 match, and is reported: warning 11 for an arm, such as `S("a")` beside

compiler/ml/untagged_dispatch.ml

@@ -208,10 +208,148 @@ let payload_part ~same ~block_cases ~null_guard ~fallback ~has_default arms =
           | Body tree -> tree
           | Falls_through _ -> Skip
         in
-        Switch_typeof (List.rev rest, default)
+        (* The cases falling through to that arm go to the default too *)
+        let rec without_fall_through = function
+          | (_, Falls_through _) :: rest -> without_fall_through rest
+          | rest -> rest
+        in
+        Switch_typeof (List.rev (without_fall_through rest), default)
       | _ -> Switch_typeof (primitive_clauses, Fallback))
     | _ :: _ -> Switch_typeof (primitive_clauses, chain entries))
 
+type value = Literal of literal_tag | Object | Array
+
+type 'a outcome = Arm of 'a | Default | Nothing
+
+(* What [typeof] returns for a value, as a kind *)
+let kind_of = function
+  | Literal (String _) -> Some StringType
+  | Literal (Int _ | Float _) -> Some NumberType
+  | Literal (BigInt _) -> Some BigintType
+  | Literal (Bool _) -> Some BooleanType
+  | Literal Null | Object | Array -> Some ObjectType
+  | Literal Undefined -> None
+
+let select ?(on_test = ignore) tree value =
+  (* JavaScript semantics, including the short circuits of [&&] and [||] *)
+  let rec holds test =
+    on_test test;
+    match (test, value) with
+    | Equals literal, Literal v -> same_literal_value v literal
+    | Equals _, (Object | Array) -> false
+    | Typeof kind, _ -> kind_of value = Some kind
+    | Instance Array, _ -> value = Array
+    | Instance (Class _), _ -> false
+    | Not_null, _ -> value <> Literal Null
+    | Not test, _ -> not (holds test)
+    | And (test1, test2), _ -> holds test1 && holds test2
+    | Or (test1, test2), _ -> holds test1 || holds test2
+  in
+  let rec run = function
+    | Run body -> Arm body
+    | Fallback -> Default
+    | Skip -> Nothing
+    | If (test, then_, else_) -> if holds test then run then_ else run else_
+    | Block tree -> run tree
+    | Switch_value (clauses, default) -> (
+      match value with
+      | Literal v ->
+        from_clauses
+          (fun literal -> same_literal_value v literal)
+          clauses default
+      | Object | Array -> run default)
+    | Switch_typeof (clauses, default) -> (
+      match kind_of value with
+      | Some kind -> from_clauses (fun k -> k = kind) clauses default
+      | None -> run default)
+  (* A matching case runs its body, or falls through to the next one *)
+  and from_clauses : 'k. ('k -> bool) -> ('k * _ clause) list -> _ =
+   fun matches clauses default ->
+    let rec fall = function
+      | (_, Body tree) :: _ -> run tree
+      | (_, Falls_through _) :: rest -> fall rest
+      | [] -> run default
+    in
+    let rec find = function
+      | [] -> run default
+      | (key, _) :: _ as clauses when matches key -> fall clauses
+      | _ :: rest -> find rest
+    in
+    find clauses
+  in
+  run tree
+
+(* Two trees that run the same bodies after the same tests *)
+let rec same_tree ~same tree1 tree2 =
+  match (tree1, tree2) with
+  | Run body1, Run body2 -> same body1 body2
+  | Fallback, Fallback | Skip, Skip -> true
+  | If (test1, then1, else1), If (test2, then2, else2) ->
+    test1 = test2 && same_tree ~same then1 then2 && same_tree ~same else1 else2
+  | Block tree1, Block tree2 -> same_tree ~same tree1 tree2
+  | Switch_value (clauses1, default1), Switch_value (clauses2, default2) ->
+    same_clauses ~same clauses1 clauses2 && same_tree ~same default1 default2
+  | Switch_typeof (clauses1, default1), Switch_typeof (clauses2, default2) ->
+    same_clauses ~same clauses1 clauses2 && same_tree ~same default1 default2
+  | ( ( Run _ | Fallback | Skip | If _ | Block _ | Switch_value _
+      | Switch_typeof _ ),
+      _ ) ->
+    false
+
+and same_clauses : 'k. same:_ -> ('k * _) list -> ('k * _) list -> bool =
+ fun ~same clauses1 clauses2 ->
+  List.length clauses1 = List.length clauses2
+  && List.for_all2
+       (fun (key1, clause1) (key2, clause2) ->
+         key1 = key2
+         &&
+         match (clause1, clause2) with
+         | Falls_through _, Falls_through _ -> true
+         | Body tree1, Body tree2 -> same_tree ~same tree1 tree2
+         | (Falls_through _ | Body _), _ -> false)
+       clauses1 clauses2
+
+(* A test whose branches run the same is not run, and a case of a switch that
+   runs what its default runs is left to the default, with the cases falling
+   through to it *)
+let rec simplify ~same tree =
+  match tree with
+  | Run _ | Fallback | Skip -> tree
+  | If (test, then_, else_) ->
+    let then_ = simplify ~same then_ and else_ = simplify ~same else_ in
+    if same_tree ~same then_ else_ then then_ else If (test, then_, else_)
+  | Block tree -> Block (simplify ~same tree)
+  | Switch_value (clauses, default) -> (
+    let default = simplify ~same default in
+    match simplify_clauses ~same ~default clauses with
+    | [] -> default
+    | clauses -> Switch_value (clauses, default))
+  | Switch_typeof (clauses, default) -> (
+    let default = simplify ~same default in
+    match simplify_clauses ~same ~default clauses with
+    | [] -> default
+    | clauses -> Switch_typeof (clauses, default))
+
+and simplify_clauses : 'k. same:_ -> default:_ -> ('k * _) list -> ('k * _) list
+    =
+ fun ~same ~default clauses ->
+  (* The cases falling through to a body, then the body *)
+  let rec groups pending = function
+    | [] -> if pending = [] then [] else [List.rev pending]
+    | ((_, Falls_through _) as clause) :: rest ->
+      groups (clause :: pending) rest
+    | ((_, Body _) as clause) :: rest ->
+      List.rev (clause :: pending) :: groups [] rest
+  in
+  groups [] clauses
+  |> List.concat_map (fun group ->
+      match List.rev group with
+      | (key, Body tree) :: members ->
+        let tree = simplify ~same tree in
+        if same_tree ~same tree default then []
+        else List.rev ((key, Body tree) :: members)
+      | _ -> group)
+
 let plan ~same
     ({
        facts = {block_types = block_cases; literal_tags = literal_cases};
@@ -225,34 +363,38 @@ let plan ~same
   let literal_default = if literals_complete then None else fallback in
   let payload_has_default = (not payloads_complete) && fallback <> None in
   if literals_complete && literal_arms = [] then
-    payload_part ~same ~block_cases ~null_guard:false ~fallback
-      ~has_default:payload_has_default payload_arms
+    simplify ~same
+      (payload_part ~same ~block_cases ~null_guard:false ~fallback
+         ~has_default:payload_has_default payload_arms)
   else
     (* The literals first, compared with [===] by one switch whose default is
        the payload dispatch. A literal without an arm goes to the match's
        default, never to a payload arm *)
     let named = List.map fst literal_arms in
-    (* A literal reaches the same default through the payload dispatch when no
-       payload arm accepts its kind and no class check runs on it *)
-    let payload_kinds = List.map fst payload_arms in
-    let reaches_a_payload_arm literal =
-      List.exists (literal_passes literal) payload_kinds
-    in
-    let has_class_case =
-      List.exists
-        (function
-          | InstanceType (Class _) -> true
-          | _ -> false)
-        block_cases
-    in
     let unnamed =
       List.filter (fun literal -> not (List.mem literal named)) literal_cases
     in
-    (* [null] passes only the object check, which then tests [x !== null] *)
-    let skips_the_switch literal =
-      (not has_class_case)
-      && ((not (reaches_a_payload_arm literal))
-         || (literal = Null && not (List.mem UnknownType payload_kinds)))
+    (* A literal without an arm skips the switch when the payload dispatch
+       takes it to the default without a class check, which could throw when
+       the class does not exist. [null] passes the object check only without
+       [x !== null], which is added when [null] skips. *)
+    let skips_the_switch =
+      match literal_default with
+      | None -> fun _ -> false
+      | Some _ -> (
+        let payload =
+          payload_part ~same ~block_cases ~null_guard:(List.mem Null unnamed)
+            ~fallback ~has_default:true payload_arms
+        in
+        fun literal ->
+          let class_check = ref false in
+          let on_test = function
+            | Instance (Class _) -> class_check := true
+            | _ -> ()
+          in
+          match select ~on_test payload (Literal literal) with
+          | Default -> not !class_check
+          | Arm _ | Nothing -> false)
     in
     (* Values no payload arm takes are the literals without an arm: a complete
        payload dispatch checks its last arm, and these literals skip the
@@ -276,20 +418,19 @@ let plan ~same
       | None -> []
     in
     let literal_arms = literal_arms @ unnamed in
-    (* A complete payload dispatch with one body runs it unchecked, so a
-       literal arm with the same body can go there too *)
+    let payload =
+      simplify ~same
+        (payload_part ~same ~block_cases ~null_guard ~fallback
+           ~has_default:payload_has_default payload_arms)
+    in
+    (* A payload dispatch that runs one body unchecked takes the literals with
+       that body too *)
     let literal_arms =
-      match payload_arms with
-      | (_, body) :: rest
-        when (not payload_has_default)
-             && List.for_all (fun (_, other) -> same body other) rest ->
+      match payload with
+      | Run body ->
         List.filter (fun (_, other) -> not (same body other)) literal_arms
       | _ -> literal_arms
     in
-    let payload =
-      payload_part ~same ~block_cases ~null_guard ~fallback
-        ~has_default:payload_has_default payload_arms
-    in
     if List.length literal_arms <= 2 then
       (* An [if] per body, testing its literals with [===] *)
       let rec group = function
@@ -313,67 +454,6 @@ let plan ~same
           If (test, Run body, rest))
         (group literal_arms) payload
     else
-      Switch_value
-        (clauses ~same literal_arms ~shares:(fun _ _ -> true), payload)
-
-type value = Literal of literal_tag | Object | Array
-
-type 'a outcome = Arm of 'a | Default | Nothing
-
-(* What [typeof] returns for a value, as a kind *)
-let kind_of = function
-  | Literal (String _) -> Some StringType
-  | Literal (Int _ | Float _) -> Some NumberType
-  | Literal (BigInt _) -> Some BigintType
-  | Literal (Bool _) -> Some BooleanType
-  | Literal Null | Object | Array -> Some ObjectType
-  | Literal Undefined -> None
-
-let select ?(on_test = ignore) tree value =
-  (* JavaScript semantics, including the short circuits of [&&] and [||] *)
-  let rec holds test =
-    on_test test;
-    match (test, value) with
-    | Equals literal, Literal v -> same_literal_value v literal
-    | Equals _, (Object | Array) -> false
-    | Typeof kind, _ -> kind_of value = Some kind
-    | Instance Array, _ -> value = Array
-    | Instance (Class _), _ -> false
-    | Not_null, _ -> value <> Literal Null
-    | Not test, _ -> not (holds test)
-    | And (test1, test2), _ -> holds test1 && holds test2
-    | Or (test1, test2), _ -> holds test1 || holds test2
-  in
-  let rec run = function
-    | Run body -> Arm body
-    | Fallback -> Default
-    | Skip -> Nothing
-    | If (test, then_, else_) -> if holds test then run then_ else run else_
-    | Block tree -> run tree
-    | Switch_value (clauses, default) -> (
-      match value with
-      | Literal v ->
-        from_clauses
-          (fun literal -> same_literal_value v literal)
-          clauses default
-      | Object | Array -> run default)
-    | Switch_typeof (clauses, default) -> (
-      match kind_of value with
-      | Some kind -> from_clauses (fun k -> k = kind) clauses default
-      | None -> run default)
-  (* A matching case runs its body, or falls through to the next one *)
-  and from_clauses : 'k. ('k -> bool) -> ('k * _ clause) list -> _ =
-   fun matches clauses default ->
-    let rec fall = function
-      | (_, Body tree) :: _ -> run tree
-      | (_, Falls_through _) :: rest -> fall rest
-      | [] -> run default
-    in
-    let rec find = function
-      | [] -> run default
-      | (key, _) :: _ as clauses when matches key -> fall clauses
-      | _ :: rest -> find rest
-    in
-    find clauses
-  in
-  run tree
+      simplify ~same
+        (Switch_value
+           (clauses ~same literal_arms ~shares:(fun _ _ -> true), payload))

compiler/ml/variant_runtime.ml

@@ -91,20 +91,6 @@ let literal_value_key = function
 
 let same_literal_value a b = literal_value_key a = literal_value_key b
 
-let literal_passes (literal : literal_tag) (block_type : block_type) =
-  match (block_type, literal) with
-  | UnknownType, _
-  | StringType, String _
-  | NumberType, (Int _ | Float _)
-  | BigintType, BigInt _
-  | BooleanType, Bool _
-  | ObjectType, Null ->
-    true
-  | ( ( StringType | NumberType | BigintType | BooleanType | ObjectType
-      | InstanceType _ | SymbolType | FunctionType ),
-      _ ) ->
-    false
-
 (** Information used to recognize a constructor during matching. A literal
     identifies a constant or an object's tag; a payload shape identifies a
     value represented directly by its payload. *)

compiler/ml/variant_runtime.mli

@@ -61,11 +61,6 @@ val literal_value_key : literal_tag -> string
 
 val same_literal_value : literal_tag -> literal_tag -> bool
 
-val literal_passes : literal_tag -> block_type -> bool
-(** Whether a literal passes the check of a payload case of this kind, as
-    [typeof] sees it: ["a"] a string case, [null] an object case, anything an
-    unknown case, which is not checked *)
-
 (** Information used to recognize a constructor during matching. A literal
     identifies a constant or an object's tag; a payload shape identifies a
     value represented directly by its payload. *)

tests/ounit_tests/ounit_untagged_dispatch_tests.ml

@@ -192,7 +192,19 @@ let suites =
              in
              List.iter
                (fun value ->
-                 let outcome = D.select tree value in
+                 let class_checks = ref 0 in
+                 let on_test : D.test -> unit = function
+                   | Instance (Class _) -> incr class_checks
+                   | _ -> ()
+                 in
+                 let outcome = D.select ~on_test tree value in
+                 (* A literal or a primitive never reaches a class check *)
+                 (match value with
+                 | Literal _ when !class_checks > 0 ->
+                   OUnit.assert_failure
+                     ("a class check on " ^ value_to_string value ^ " in "
+                    ^ tree_to_string tree)
+                 | Literal _ | Object | Array -> ());
                  match
                    oracle ~literals ~kinds ~literal_arms ~payload_arms value
                  with