From 446dce1d802322f661151cd95998596f56ba2686 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sun, 25 Oct 2026 20:37:13 +0000 Subject: [PATCH 1/2] Decide the untagged dispatch's literal cases by routing them Why: A literal without an arm got a case whenever the variant had a class case, even where no class check runs on it, and arms of different kinds with one body kept the checks telling them apart. The literal arm left to a complete payload dispatch with one body assumed that dispatch runs no check, which held only because matching shares such bodies. A literal without an arm skips the literal switch when the payload dispatch, evaluated on it with `select`, takes it to the default without a class check. The plan is simplified: a test whose branches run the same, and a case that runs what its default runs, are left out, and a literal with the body of a payload dispatch that runs one body unchecked gets no case. The property test also checks that no literal or primitive reaches a class check. `Variant_runtime.literal_passes` is gone. Generated code changed (a literal without an arm beside a class case): Example: @unboxed type t = | @as("a") A | S(string) | N(float) | D(Date.t) | O({x: int}) let f = (x: t) => switch x { | D(_) => 1 | O(_) => 2 | _ => 3 } Before (JS): if (x === "a") { return 3; } switch (typeof x) { case "string" : case "number" : return 3; default: ... } After (JS): switch (typeof x) { case "string" : case "number" : return 3; default: ... } Generated code changed (arms of different kinds with one body): Example: @unboxed type t = | @as(null) NoPoint | Point({x: int}) | Name(string) switch x { | NoPoint => Console.log("null") | Point(_) => Console.log("payload") | Name(_) => Console.log("payload") } Before (JS): if (x === null) { console.log("null"); return; } if (typeof x === "string") { console.log("payload"); return; } console.log("payload"); After (JS): if (x === null) { console.log("null"); return; } console.log("payload"); Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Signed-off-by: Christoph Knittel --- .../untagged-dispatch-fewer-checks.polish.md | 1 + compiler/ml/UntaggedVariants.md | 17 +- compiler/ml/untagged_dispatch.ml | 263 +++++++++++------- compiler/ml/variant_runtime.ml | 14 - compiler/ml/variant_runtime.mli | 5 - .../ounit_untagged_dispatch_tests.ml | 14 +- tests/tests/src/UntaggedVariants.mjs | 12 - .../tests/src/untagged_variants_heuristic.mjs | 26 ++ .../tests/src/untagged_variants_heuristic.res | 24 ++ 9 files changed, 244 insertions(+), 132 deletions(-) create mode 100644 changes/untagged-dispatch-fewer-checks.polish.md diff --git a/changes/untagged-dispatch-fewer-checks.polish.md b/changes/untagged-dispatch-fewer-checks.polish.md new file mode 100644 index 00000000000..53f341f11e0 --- /dev/null +++ b/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. diff --git a/compiler/ml/UntaggedVariants.md b/compiler/ml/UntaggedVariants.md index bdd3ae4d9c3..e7d52d54b9f 100644 --- a/compiler/ml/UntaggedVariants.md +++ b/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 diff --git a/compiler/ml/untagged_dispatch.ml b/compiler/ml/untagged_dispatch.ml index be9dd4072a0..a6d7099b8db 100644 --- a/compiler/ml/untagged_dispatch.ml +++ b/compiler/ml/untagged_dispatch.ml @@ -212,6 +212,139 @@ let payload_part ~same ~block_cases ~null_guard ~fallback ~has_default arms = | _ -> 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 +358,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 +413,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 +449,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)) diff --git a/compiler/ml/variant_runtime.ml b/compiler/ml/variant_runtime.ml index 2c04022f550..d386d7d4b16 100644 --- a/compiler/ml/variant_runtime.ml +++ b/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. *) diff --git a/compiler/ml/variant_runtime.mli b/compiler/ml/variant_runtime.mli index 1d57cd6fa0e..a08b211c28a 100644 --- a/compiler/ml/variant_runtime.mli +++ b/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. *) diff --git a/tests/ounit_tests/ounit_untagged_dispatch_tests.ml b/tests/ounit_tests/ounit_untagged_dispatch_tests.ml index c545012ac87..e4ad95346b3 100644 --- a/tests/ounit_tests/ounit_untagged_dispatch_tests.ml +++ b/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 diff --git a/tests/tests/src/UntaggedVariants.mjs b/tests/tests/src/UntaggedVariants.mjs index 3004d9e4b1d..ce9beed95a1 100644 --- a/tests/tests/src/UntaggedVariants.mjs +++ b/tests/tests/src/UntaggedVariants.mjs @@ -629,18 +629,6 @@ function preserveDiscriminatorGroups(x) { if (typeof x === "boolean") { return; } - if (Array.isArray(x)) { - while (keepGoing()) { - sideEffect(); - }; - return; - } - if (x instanceof Date) { - while (keepGoing()) { - sideEffect(); - }; - return; - } while (keepGoing()) { sideEffect(); }; diff --git a/tests/tests/src/untagged_variants_heuristic.mjs b/tests/tests/src/untagged_variants_heuristic.mjs index 66eb239c111..60ca0141a71 100644 --- a/tests/tests/src/untagged_variants_heuristic.mjs +++ b/tests/tests/src/untagged_variants_heuristic.mjs @@ -15,8 +15,34 @@ function ff(x) { console.log("abc"); } +function dateOrObject(x) { + switch (typeof x) { + case "string" : + case "number" : + return 3; + default: + if (x instanceof Date) { + return 1; + } else if (typeof x === "object") { + return 2; + } else { + return 3; + } + } +} + +function logPointOrName(x) { + if (x === null) { + console.log("null"); + return; + } + console.log("payload"); +} + export { f, ff, + dateOrObject, + logPointOrName, } /* No side effect */ diff --git a/tests/tests/src/untagged_variants_heuristic.res b/tests/tests/src/untagged_variants_heuristic.res index 2f068b207ae..e34f865767d 100644 --- a/tests/tests/src/untagged_variants_heuristic.res +++ b/tests/tests/src/untagged_variants_heuristic.res @@ -20,3 +20,27 @@ let ff = (x: t) => | Int(_) => Console.log("abc") | _ => () } + +// The literal without an arm reaches the default through the case of its +// kind, before any class check, so it needs no case of its own +@unboxed +type withDate = + | @as("a") WithA | WithText(string) | WithCount(float) | WithDate(Date.t) | WithObject({x: int}) + +let dateOrObject = (x: withDate) => + switch x { + | WithDate(_) => 1 + | WithObject(_) => 2 + | _ => 3 + } + +// Arms of different kinds with one body are one unchecked branch +@unboxed +type pointOrName = | @as(null) NoPoint | Point({x: int}) | Name(string) + +let logPointOrName = (x: pointOrName) => + switch x { + | NoPoint => Console.log("null") + | Point(_) => Console.log("payload") + | Name(_) => Console.log("payload") + } From 708529147d9ccee656fd2374b30d91f7e2f28fad Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Mon, 26 Oct 2026 06:11:33 +0000 Subject: [PATCH 2/2] Leave the cases falling through to the default of a complete typeof switch Why: In a complete dispatch on primitive kinds only, the last arm becomes the default, but the cases of other kinds sharing its body stayed in the switch, falling through into `default:`. That also kept the dispatch from being one unchecked body, so a literal with that body kept its case. The cases falling through to the last arm are left out with it. Generated code changed (kinds sharing the last arm's body): Example: @unboxed type t = Num(int) | Text(string) | Flag(bool) let f = (x: t) => switch x { | Num(_) => 1 | Text(_) => 2 | Flag(_) => 2 } Before (JS): switch (typeof x) { case "number" : return 1; case "string" : default: return 2; } After (JS): if (typeof x === "number") { return 1; } else { return 2; } Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01CMkrYaktctdKc4M41WF36t Signed-off-by: Christoph Knittel --- compiler/ml/untagged_dispatch.ml | 7 +++++- .../tests/src/untagged_variants_heuristic.mjs | 18 +++++++++++++++ .../tests/src/untagged_variants_heuristic.res | 22 +++++++++++++++++++ 3 files changed, 46 insertions(+), 1 deletion(-) diff --git a/compiler/ml/untagged_dispatch.ml b/compiler/ml/untagged_dispatch.ml index a6d7099b8db..54a1c62b0fd 100644 --- a/compiler/ml/untagged_dispatch.ml +++ b/compiler/ml/untagged_dispatch.ml @@ -208,7 +208,12 @@ 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)) diff --git a/tests/tests/src/untagged_variants_heuristic.mjs b/tests/tests/src/untagged_variants_heuristic.mjs index 60ca0141a71..13e3d5f08e2 100644 --- a/tests/tests/src/untagged_variants_heuristic.mjs +++ b/tests/tests/src/untagged_variants_heuristic.mjs @@ -39,10 +39,28 @@ function logPointOrName(x) { console.log("payload"); } +function numberOrText(x) { + if (typeof x === "number") { + return 1; + } else { + return 2; + } +} + +function letterOrNumber(x) { + if (x === "a") { + return 1; + } else { + return 2; + } +} + export { f, ff, dateOrObject, logPointOrName, + numberOrText, + letterOrNumber, } /* No side effect */ diff --git a/tests/tests/src/untagged_variants_heuristic.res b/tests/tests/src/untagged_variants_heuristic.res index e34f865767d..474b6b2311b 100644 --- a/tests/tests/src/untagged_variants_heuristic.res +++ b/tests/tests/src/untagged_variants_heuristic.res @@ -44,3 +44,25 @@ let logPointOrName = (x: pointOrName) => | Point(_) => Console.log("payload") | Name(_) => Console.log("payload") } + +// The last arm of a complete match is the default, with the arms of other +// kinds that share its body +@unboxed +type numberOrText = Num(int) | Text(string) | Flag(bool) + +let numberOrText = (x: numberOrText) => + switch x { + | Num(_) => 1 + | Text(_) => 2 + | Flag(_) => 2 + } + +@unboxed +type letterOrNumber = | @as("a") Letter | LetterNum(int) | LetterText(string) + +let letterOrNumber = (x: letterOrNumber) => + switch x { + | Letter => 1 + | LetterNum(_) => 2 + | LetterText(_) => 2 + }