diff --git a/changes/untagged-dispatch-plan.internal.md b/changes/untagged-dispatch-plan.internal.md new file mode 100644 index 0000000000..c39ed446e2 --- /dev/null +++ b/changes/untagged-dispatch-plan.internal.md @@ -0,0 +1 @@ +- Build the dispatch of a switch on an untagged variant as a plan before printing it. diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index d7685a8f96..e0df236832 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -153,10 +153,10 @@ let morph_declare_to_assign (cxt : Lam_compile_context.t) k = k {cxt with continuation = Assign did} (Some (kind, did)) | _ -> k cxt None -let group_apply ~merge_cases cases callback = +let group_apply cases callback = Ext_list.flat_map - (Ext_list.stable_group cases (fun (tag1, lam) (tag2, lam1) -> - merge_cases tag1 tag2 && Lambda.eq_approx lam lam1)) + (Ext_list.stable_group cases (fun (_, lam) (_, lam1) -> + Lambda.eq_approx lam lam1)) (fun group -> Ext_list.map_last group callback) (* TODO: for expression generation, @@ -164,13 +164,7 @@ let group_apply ~merge_cases cases callback = only jmp_table and env needed *) -type default_case = - | Default of Lambda.t - | Compiled of (Lam_compile_context.t -> J.block) - (** a default compiled by the caller, such as the payload dispatch of - an untagged variant after its literals *) - | Complete - | NonComplete +type default_case = Default of Lambda.t | Complete | NonComplete let default_action ~saturated failaction = match failaction with @@ -186,9 +180,9 @@ let tag_of_switch_key : _ -> Variant_runtime.tag_type option = function Some (Payload_shape block_type) let dispatch_info = function - | Lambda.Switch_direct -> (Js_dump_lit.tag, [], []) - | Switch_variant {Variant_runtime.tag_name; block_types; literal_tags} -> - (Option.value tag_name ~default:Js_dump_lit.tag, block_types, literal_tags) + | Lambda.Switch_direct -> (Js_dump_lit.tag, []) + | Switch_variant {Variant_runtime.tag_name; literal_tags} -> + (Option.value tag_name ~default:Js_dump_lit.tag, literal_tags) let no_effects_const = lazy true (* let has_effects_const = lazy false *) @@ -557,8 +551,6 @@ let compile output_prefix = J.statement) -> switch_exp:J.expression -> default:default_case -> - ?merge_cases:('a -> 'a -> bool) -> - ?always_switch:bool -> ('a * Lambda.t) list -> J.block = fun (type a) ~(make_exp : a -> J.expression) @@ -571,7 +563,6 @@ let compile output_prefix = _ -> (a * J.case_clause) list -> J.statement) ~(switch_exp : J.expression) ~(default : default_case) - ?(merge_cases = fun _ _ -> true) ?(always_switch = false) (cases : (a * Lambda.t) list) -> let output_block_with_source_loc cxt lam = compile_lambda cxt lam |> Js_output.output_as_block @@ -579,11 +570,10 @@ let compile output_prefix = in let output_default cxt = function | Default lam -> output_block_with_source_loc cxt lam - | Compiled compile -> compile cxt | Complete | NonComplete -> [] in match (cases, default) with - | [], (Default _ | Compiled _) -> output_default cxt default + | [], Default _ -> output_default cxt default | [], (Complete | NonComplete) -> [] | [(_, lam)], Complete -> (* To take advantage of such optimizations, @@ -593,14 +583,14 @@ let compile output_prefix = it's also complete *) output_block_with_source_loc cxt lam - | [(id, lam)], NonComplete when not always_switch -> + | [(id, lam)], NonComplete -> morph_declare_to_assign cxt (fun cxt define -> [ S.if_ ?declaration:define (eq_exp None switch_exp (Some id) (make_exp id)) (output_block_with_source_loc cxt lam); ]) - | [(id, lam)], (Default _ | Compiled _) when not always_switch -> + | [(id, lam)], Default _ -> morph_declare_to_assign cxt (fun cxt define -> let else_block = output_default cxt default in let then_block = output_block_with_source_loc cxt lam in @@ -609,7 +599,7 @@ let compile output_prefix = (eq_exp None switch_exp (Some id) (make_exp id)) then_block ~else_:else_block; ]) - | [(id, lam); (_, x)], Complete when not always_switch -> + | [(id, lam); (_, x)], Complete -> morph_declare_to_assign cxt (fun cxt define -> let else_block = output_block_with_source_loc cxt x in let then_block = output_block_with_source_loc cxt lam in @@ -654,7 +644,7 @@ let compile output_prefix = | statements -> Some statements in let body = - group_apply ~merge_cases cases (fun last (switch_case, lam) -> + group_apply cases (fun last (switch_case, lam) -> if last then (* merge and shared *) let switch_body, should_break = @@ -699,15 +689,11 @@ let compile output_prefix = Some ((tag_type, lam) :: string_table) | _, _ -> None) table (Some []) - and compile_cases ?(untagged = false) ?(null_guard = false) ~cxt - ~(switch_exp : E.t) ?(default = NonComplete) ?(block_cases = []) cases : + and compile_cases ~cxt ~(switch_exp : E.t) ?(default = NonComplete) cases : initialization = match use_compile_literal_cases cases with | Some string_cases -> - if untagged then - compile_untagged_cases ~cxt ~switch_exp ~block_cases ~null_guard - ~default string_cases - else compile_string_cases ~cxt ~switch_exp ~default string_cases + compile_string_cases ~cxt ~switch_exp ~default string_cases | None -> cases |> compile_general_cases @@ -751,188 +737,77 @@ let compile output_prefix = let sw_blocks_default = default_action ~saturated:sw_blocks_full sw_failaction in - let tag_name, block_cases, literal_cases = dispatch_info sw_dispatch in - let untagged = block_cases <> [] in + let tag_name, literal_cases = dispatch_info sw_dispatch in + let untagged_facts = + match sw_dispatch with + | Switch_variant ({block_types = _ :: _} as facts) -> Some facts + | Switch_variant {block_types = []} | Switch_direct -> None + in + let payload_only = sw_consts_full && sw_consts = [] in let compile_whole (cxt : Lam_compile_context.t) = match compile_lambda {cxt with continuation = NeedValue Not_tail} switch_arg with | {value = None; _} -> assert false | {block; value = Some e} -> ( - block - @ - if sw_consts_full && sw_consts = [] then - compile_cases ~block_cases ~untagged ~cxt - ~switch_exp:(if untagged then e else E.tag ~name:tag_name e) - ~default:sw_blocks_default sw_blocks - else if sw_blocks_full && sw_blocks = [] then - compile_cases ~cxt ~switch_exp:e ~block_cases ~default:sw_num_default - sw_consts - else - (* [e] will be used twice *) - let dispatch e = - if untagged then - (* 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 = - Ext_list.filter_map sw_consts (fun (key, _) -> - match tag_of_switch_key key with - | Some (Literal literal) -> Some literal - | Some (Payload_shape _) | None -> None) - 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_arms = - Ext_list.filter_map sw_blocks (fun (key, _) -> - match tag_of_switch_key key with - | Some (Payload_shape block_type) -> Some block_type - | Some (Literal _) | None -> - (* The blocks of an untagged variant are all untagged *) - None) - in - let reaches_a_payload_arm literal = - List.exists - (Variant_runtime.literal_passes literal) - payload_arms - in - let has_class_case = - List.exists - (function - | Variant_runtime.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 : Variant_runtime.literal_tag) = - (not has_class_case) - && ((not (reaches_a_payload_arm literal)) - || literal = Null - && not (List.mem Variant_runtime.UnknownType payload_arms) - ) - 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 switch *) - let blocks_default = - match (sw_num_default, sw_blocks_default) with - | Default lam, Complete - when List.exists skips_the_switch unnamed -> - Default lam - | _ -> sw_blocks_default - in - let null_guard = - match (sw_num_default, blocks_default) with - | Default _, Default _ -> - List.exists - (fun (literal : Variant_runtime.literal_tag) -> - literal = Null && skips_the_switch literal) - unnamed - | _ -> false - in - let unnamed = - match (sw_num_default, blocks_default) with - | Default lam, Default _ -> - Ext_list.filter_map unnamed (fun literal -> - if skips_the_switch literal then None - else Some (Variant_runtime.Literal literal, lam)) - | Default lam, (Compiled _ | Complete | NonComplete) -> - List.map - (fun literal -> (Variant_runtime.Literal literal, lam)) - unnamed - | (Compiled _ | Complete | NonComplete), _ -> [] - in - let literal_arms = - match use_compile_literal_cases sw_consts with - | Some arms -> arms @ unnamed - | None -> assert false - in - (* A complete payload dispatch with one body runs it unchecked, - so a literal arm with the same body can go there too *) - let literal_arms = - match (blocks_default, sw_blocks) with - | Complete, (_, body) :: rest - when List.for_all - (fun (_, other) -> Lambda.eq_approx body other) - rest -> - List.filter - (fun (_, lam) -> not (Lambda.eq_approx body lam)) - literal_arms - | _ -> literal_arms - in - let payload = - Compiled - (fun cxt -> - compile_cases ~untagged ~null_guard ~cxt ~switch_exp:e - ~block_cases ~default:blocks_default sw_blocks) - in - if List.length literal_arms <= 2 then - (* An [if] per body, testing its literals with [===] *) - let rec group = function - | [] -> [] - | (tag, lam) :: rest -> - let same, others = - List.partition - (fun (_, other) -> Lambda.eq_approx lam other) - rest - in - (tag :: List.map fst same, lam) :: group others - in - let rec chain ~cxt = function - | [] -> ( - match payload with - | Compiled compile -> compile cxt - | Default _ | Complete | NonComplete -> assert false) - | group :: rest -> - compile_general_cases - ~make_exp:(fun tags -> E.tag_type (List.hd tags)) - ~eq_exp:(fun _ x tags _ -> - match tags with - | Some (tag :: tags) -> - List.fold_left - (fun check tag -> - E.or_ check (E.string_equal x (E.tag_type tag))) - (E.string_equal x (E.tag_type tag)) - tags - | Some [] | None -> assert false) - ~cxt - ~switch:(fun ?default:_ ?declaration:_ _ _ -> - assert false) - ~switch_exp:e - ~default: - (match rest with - | [] -> payload - | _ :: _ -> Compiled (fun cxt -> chain ~cxt rest)) - [group] - in - chain ~cxt (group literal_arms) - else - compile_string_cases ~cxt ~switch_exp:e ~default:payload - literal_arms - else - [ - S.if_ - (E.is_int_tag ~literal_tags:literal_cases e) - (compile_cases ~cxt ~switch_exp:e ~block_cases - ~default:sw_num_default sw_consts) - ~else_: - (compile_cases ~cxt ~switch_exp:(E.tag ~name:tag_name e) - ~block_cases ~default:sw_blocks_default sw_blocks); - ] - in + (* [e] is used more than once *) + let with_variable dispatch = match e.expression_desc with | J.Var _ -> dispatch e | _ -> let v = Ext_ident.create_tmp () in - (* Necessary avoid duplicated computation*) - S.define_variable ~kind:Variable v e :: dispatch (E.var v)) + S.define_variable ~kind:Variable v e :: dispatch (E.var v) + in + block + @ + match untagged_facts with + | Some facts when payload_only || not (sw_blocks_full && sw_blocks = []) + -> + let plan = + Untagged_dispatch.plan ~same:Lambda.eq_approx + { + facts; + literal_arms = + List.map + (fun (key, lam) -> + match tag_of_switch_key key with + | Some (Literal literal) -> (literal, lam) + | Some (Payload_shape _) | None -> assert false) + sw_consts; + payload_arms = + List.map + (fun (key, lam) -> + match tag_of_switch_key key with + | Some (Payload_shape block_type) -> (block_type, lam) + | Some (Literal _) | None -> assert false) + sw_blocks; + literals_complete = sw_consts_full; + payloads_complete = sw_blocks_full; + fallback = sw_failaction; + } + in + let compile e = + compile_untagged_plan ~cxt ~switch_exp:e ~fallback:sw_failaction + plan + in + if payload_only then compile e else with_variable compile + | Some _ | None -> + if payload_only then + compile_cases ~cxt ~switch_exp:(E.tag ~name:tag_name e) + ~default:sw_blocks_default sw_blocks + else if sw_blocks_full && sw_blocks = [] then + compile_cases ~cxt ~switch_exp:e ~default:sw_num_default sw_consts + else + with_variable (fun e -> + [ + S.if_ + (E.is_int_tag ~literal_tags:literal_cases e) + (compile_cases ~cxt ~switch_exp:e ~default:sw_num_default + sw_consts) + ~else_: + (compile_cases ~cxt ~switch_exp:(E.tag ~name:tag_name e) + ~default:sw_blocks_default sw_blocks); + ])) in match lambda_cxt.continuation with (* Needs declare first *) @@ -959,220 +834,121 @@ let compile output_prefix = ~switch:(fun ?default ?declaration e clauses -> S.string_switch ?default ?declaration e clauses) ~switch_exp ~default - and compile_untagged_cases ~cxt ~switch_exp ~default ~block_cases ~null_guard - cases = - (* The payload cases of an untagged variant, after its literals: one - [switch (typeof x)] over the primitive kinds, whose default is an [if] - chain over the classes (subclasses first), arrays, functions and - objects. Primitives never reach a class check, and a class instance - never reaches the function or object arm before its own. In a complete - match the last arm is not checked. *) - let is_primitive_tag = function - | Variant_runtime.Payload_shape - (NumberType | StringType | BigintType | BooleanType | SymbolType) -> - true - | _ -> false + and compile_untagged_plan ~(cxt : Lam_compile_context.t) ~switch_exp ~fallback + (plan : Lambda.t Untagged_dispatch.tree) : J.block = + (* Prints the plan: each node is one statement. A body in a [switch] + statement is compiled in a [switch] context, a body of an [if] is + not *) + let e = switch_exp in + let rec test_exp : Untagged_dispatch.test -> J.expression = function + | Equals literal -> E.string_equal e (E.tag_type (Literal literal)) + | Typeof block_type -> ( + match Variant_runtime.typeof_name block_type with + | Some name -> E.string_equal (E.typeof e) (E.str name) + | None -> assert false) + | Instance instance -> E.is_instance_of instance e + | Not_null -> E.not (E.is_null e) + | Not test -> E.not (test_exp test) + | And (test1, test2) -> E.and_ (test_exp test1) (test_exp test2) + | Or (test1, test2) -> E.or_ (test_exp test1) (test_exp test2) in - let complete = - match default with - | Complete -> true - | Default _ | Compiled _ | NonComplete -> false + let output_block cxt lam = + compile_lambda cxt lam |> Js_output.output_as_block + |> with_block_source_loc lam in - let switch ?default:compiled_default ?declaration e clauses = - (* [None] in a complete match, where the last arm is not checked. A - value of an incomplete match that no arm takes runs no statement *) - let default = - if complete then None - else Some (Option.value compiled_default ~default:[]) - in - let primitive_clauses, other_clauses = - List.partition (fun (tag, _) -> is_primitive_tag tag) clauses - in - let arm block_type = - List.find_map - (fun (tag, {J.switch_body}) -> - if tag = Variant_runtime.Payload_shape block_type then - Some switch_body - else None) - other_clauses - in - (* A subclass is checked before its superclasses, otherwise the - declaration order decides *) - let rec subclasses_first = function - | [] -> [] - | instances -> - let first = - List.find - (fun i -> - not - (List.exists - (fun j -> Variant_runtime.Instance.is_subclass j ~of_:i) - instances)) - instances - in - first - :: subclasses_first (List.filter (fun i -> i <> first) instances) - in - let instances = - subclasses_first - (Ext_list.filter_map block_cases (function - | Variant_runtime.InstanceType i -> Some i - | _ -> None)) - in - let is_class = function - | Variant_runtime.Instance.Class _ -> true - | Array -> false - in - let check_instance i = E.is_instance_of i e in - let typeof_is name = E.string_equal (E.typeof e) (E.str name) in - (* [null], when it did not go to the default before *) - let is_object = - if null_guard then E.and_ (typeof_is "object") (E.not (E.is_null e)) - else typeof_is "object" - in - (* [Some body] for an arm, [None] for the default *) - let entries = - List.map - (fun i -> (Some (check_instance i), i, arm (InstanceType i))) - instances - |> List.filter_map (fun (check, i, body) -> - match (body, default) with - | Some body, _ -> Some (check, is_class i, Some body) - | None, Some _ -> Some (check, is_class i, None) - | None, None -> None) - in - let entries = - entries - @ (match arm FunctionType with - | Some body -> [(Some (typeof_is "function"), false, Some body)] - | None -> []) - @ (match arm ObjectType with - | Some body -> [(Some is_object, false, Some body)] - | None -> []) - @ - match arm UnknownType with - | Some body -> [(None, false, Some body)] - | None -> [] - in - (* Checks leading to the default are needed only before an arm *) - let rec drop_trailing_defaults = function - | [] -> [] - | entries -> ( - match List.rev entries with - | (_, _, None) :: rest -> drop_trailing_defaults (List.rev rest) - | _ -> entries) - in - let entries = drop_trailing_defaults entries in - (* [if (c1) default else if (c2) body else default] is - [if (c2 && !c1) body else default], and [c1] then runs only on - values passing [c2], never on primitives *) - let entries = - match (default, List.rev entries) with - | Some _, (Some check, is_class, Some body) :: rest -> - let rec absorb check = function - | (Some previous, _, None) :: rest -> - absorb (E.and_ check (E.not previous)) rest - | rest -> List.rev ((Some check, is_class, Some body) :: rest) - in - absorb check rest - | _ -> entries - in - (* Consecutive checks leading to the default share one [if] *) - let rec merge_defaults = function - | (Some c1, class1, None) :: (Some c2, class2, None) :: rest -> - merge_defaults ((Some (E.or_ c1 c2), class1 || class2, None) :: rest) - | entry :: rest -> entry :: merge_defaults rest - | [] -> [] - in - let entries = merge_defaults entries in - (* An arm may compile to no statement, so arms are counted here *) - let has_other_arms = entries <> [] in - (* The last arm of a complete match is not checked *) - let entries, final = - match (default, List.rev entries) with - | Some default, _ -> (entries, Some default) - | None, (_, _, body) :: rest -> (List.rev rest, body) - | None, [] -> (entries, None) - in - let has_class_check = - List.exists (fun (_, is_class, _) -> is_class) entries - in - let rec chain = function - | [] -> Option.value final ~default:[] - | (check, _, body) :: rest -> ( - let body = - Option.value body ~default:(Option.value default ~default:[]) - in - match check with - | Some check -> [S.if_ check body ~else_:(chain rest)] - | None -> body) - in - let other = chain entries in - (* The primitive kinds of the type without an arm go to the default - directly when the chain has class checks *) - let unmatched_primitives = - match default with - | Some default when has_class_check -> - let kinds = - Ext_list.filter_map block_cases (fun block_type -> - let tag = Variant_runtime.Payload_shape block_type in - if - is_primitive_tag tag - && not (List.exists (fun (t, _) -> t = tag) primitive_clauses) - then Some tag - else None) - in - Ext_list.mapi kinds (fun index tag -> - let last = index = List.length kinds - 1 in - ( tag, - { - J.switch_body = (if last then default else []); - should_break = - last - && not (S.block_last_is_return_throw_or_continue default); - comment = None; - source_loc = None; - } )) - | Some _ | None -> [] - in - let primitive_clauses = primitive_clauses @ unmatched_primitives in - (* One kind is an [if], more a [switch (typeof x)] *) - let typeof_switch ?default clauses = - match clauses with - | [ - ( Variant_runtime.Payload_shape block_type, - {J.switch_body; should_break} ); - ] - when switch_body <> [] || should_break -> ( - (* Not a clause falling through to the default *) - match Variant_runtime.typeof_name block_type with - | Some name -> - S.if_ ?declaration (typeof_is name) switch_body ?else_:default - | None -> assert false) - | _ -> S.string_switch ?declaration ?default (E.typeof e) clauses - in - match primitive_clauses with - | [] -> ( - match declaration with - | Some (kind, id) -> S.block (S.declare_variable ~kind id :: other) - | None -> S.block other) - | _ :: _ when not has_other_arms -> ( - (* No other arm: in a complete match the last primitive arm is not - checked *) - match List.rev primitive_clauses with - | (_, {J.switch_body}) :: rest when complete -> - typeof_switch ~default:switch_body (List.rev rest) - | _ -> typeof_switch ?default primitive_clauses) - | _ :: _ -> typeof_switch ~default:other primitive_clauses + (* The default action is compiled once and shared by every path to it *) + let fallback_blocks = ref [] in + let fallback_block (cxt : Lam_compile_context.t) = + let in_switch = cxt.switch_depth > 0 in + match List.assoc_opt in_switch !fallback_blocks with + | Some block -> block + | None -> + let block = + match fallback with + | Some lam -> output_block cxt lam + | None -> assert false + in + fallback_blocks := (in_switch, block) :: !fallback_blocks; + block in - let merge_cases tag1 tag2 = - (* Only primitive kinds share a switch, and so bodies *) - is_primitive_tag tag1 && is_primitive_tag tag2 + let rec emit ~cxt (tree : Lambda.t Untagged_dispatch.tree) : J.block = + match tree with + | Run lam -> output_block cxt lam + | Fallback -> fallback_block cxt + | Skip -> [] + | If (test, then_, else_) -> + (* Bodies are compiled in the order they are printed, which numbers + loop labels top to bottom *) + let then_ = emit ~cxt then_ in + let else_ = emit ~cxt else_ in + [S.if_ (test_exp test) then_ ~else_] + | Block tree -> [S.block (emit ~cxt tree)] + | Switch_value (clauses, default) -> + let cxt = Lam_compile_context.enter_switch cxt in + let default = + match emit ~cxt default with + | [] -> None + | statements -> Some statements + in + let clauses = + List.map + (fun (literal, clause) -> + (Variant_runtime.Literal literal, emit_clause ~cxt clause)) + clauses + in + [S.string_switch ?default e clauses] + | Switch_typeof ([(block_type, (Body _ as clause))], default) -> + (* One kind is an [if], so its bodies are not in a [switch] *) + let clause = emit_clause ~cxt clause in + let default = emit ~cxt default in + [S.if_ (test_exp (Typeof block_type)) clause.switch_body ~else_:default] + | Switch_typeof (clauses, default) -> + let cxt = Lam_compile_context.enter_switch cxt in + let default = emit ~cxt default in + let clauses = + List.map + (fun (block_type, clause) -> + (Variant_runtime.Payload_shape block_type, emit_clause ~cxt clause)) + clauses + in + [S.string_switch ~default (E.typeof e) clauses] + and emit_clause ~cxt (clause : Lambda.t Untagged_dispatch.clause) : + J.case_clause = + match clause with + | Falls_through lam -> + { + switch_body = []; + should_break = false; + comment = None; + source_loc = Option.bind lam source_map_loc_of_lam; + } + | Body (Run lam) -> + let switch_body, should_break = + Js_output.to_break_block (compile_lambda cxt lam) + in + let should_break = + if not (Lam_compile_context.continuation_is_return cxt.continuation) + then should_break + else should_break && Lam_exit_code.has_exit lam + in + { + switch_body = with_block_source_loc lam switch_body; + should_break; + comment = None; + source_loc = source_map_loc_of_lam lam; + } + | Body Fallback -> + let block = fallback_block cxt in + { + switch_body = block; + should_break = not (S.block_last_is_return_throw_or_continue block); + comment = None; + source_loc = None; + } + | Body (Skip | If _ | Block _ | Switch_value _ | Switch_typeof _) -> + assert false in - cases - |> compile_general_cases ~make_exp:E.tag_type - ~eq_exp:(fun _ _ _ _ -> assert false) - ~cxt ~switch ~switch_exp ~default ~merge_cases ~always_switch:true + emit ~cxt plan and compile_stringswitch l cases default (lambda_cxt : Lam_compile_context.t) = (* TODO might better optimization according to the number of cases diff --git a/compiler/ml/UntaggedVariants.md b/compiler/ml/UntaggedVariants.md index cd1a7093c8..c0b42aa149 100644 --- a/compiler/ml/UntaggedVariants.md +++ b/compiler/ml/UntaggedVariants.md @@ -356,7 +356,7 @@ needs a payload of type `bool`, also through an abbreviation: a `@typeOf("boolean")` type has no `true` and `false` patterns, so `Yes` alone does not cover it. -- Implementation: `lam_compile.ml:compile_switch`; +- Implementation: `untagged_dispatch.ml:plan` (the literal part); `parmatch.ml` (shadowed payload patterns, exhaustiveness). - Tests: `spec_test` rule 7; `tests/tests/src/untagged_variants_heuristic.res` (literals that skip the `switch`); `unboxed_variant_fold_test.res` @@ -412,12 +412,14 @@ every case (rule 10). An `int` case is recognized by `typeof x === "number"` and so receives every number, integral or not. -`break` and `continue` in an arm leave or continue the enclosing loop: every -arm placed in a generated `switch` is compiled in a `switch` context, where -they are labeled. +`break` and `continue` in an arm leave or continue the enclosing loop: an +arm placed in a generated `switch` statement is compiled in a `switch` +context, where they are labeled; an arm of an `if` is not +(`untagged_loop_control_test.res`, `scanIf`). -- Implementation: `lam_compile.ml:compile_untagged_cases`, - `compile_general_cases`. +- Implementation: `untagged_dispatch.ml:payload_part` builds the dispatch as + a plan, `lam_compile.ml:compile_untagged_plan` prints it; ounit tests in + `ounit_untagged_dispatch_tests.ml` pin plans as data. - Tests: `spec_test` rules 4, 5 and 8 (`instanceName` shows the chain in declaration order, `objectFirst` the unchecked last arm); `tests/tests/src/UntaggedVariants.res` (`AllInstanceofTypes`, @@ -444,8 +446,8 @@ as a record case does. | | all | `null` | `GNull` | | | `GObject(_)`, `_` | `[]`, `null` | `_` | -- Implementation: `lam_compile.ml:compile_switch` (`null_guard`), - `compile_untagged_cases`. +- Implementation: `untagged_dispatch.ml:plan` (`null_guard`), + `payload_part`. - 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. @@ -468,7 +470,7 @@ recognition is local to a realm. A class that does not exist where the and functions, and values outside every case. The literals and the primitives of the variant never reach it. -- Implementation: `lam_compile.ml:compile_untagged_cases` (a complete match +- Implementation: `untagged_dispatch.ml:payload_part` (a complete match emits no check for its last arm). - Tests: `spec_test` rule 10; `untagged_runtime_annotations_test.res` (a missing class). diff --git a/compiler/ml/untagged_dispatch.ml b/compiler/ml/untagged_dispatch.ml new file mode 100644 index 0000000000..d78c8f50bb --- /dev/null +++ b/compiler/ml/untagged_dispatch.ml @@ -0,0 +1,317 @@ +open Variant_runtime + +type test = + | Equals of literal_tag + | Typeof of block_type + | Instance of Instance.t + | Not_null + | Not of test + | And of test * test + | Or of test * test + +type 'a tree = + | Run of 'a + | Fallback + | Skip + | If of test * 'a tree * 'a tree + | Block of 'a tree + | Switch_value of (literal_tag * 'a clause) list * 'a tree + | Switch_typeof of (block_type * 'a clause) list * 'a tree + +and 'a clause = Falls_through of 'a option | Body of 'a tree + +type 'a input = { + facts: matching_facts; + literal_arms: (literal_tag * 'a) list; + payload_arms: (block_type * 'a) list; + literals_complete: bool; + payloads_complete: bool; + fallback: 'a option; +} + +(* The kinds [switch (typeof x)] tells apart; functions and objects are + checked after the classes *) +let is_primitive = function + | NumberType | StringType | BigintType | BooleanType | SymbolType -> true + | InstanceType _ | FunctionType | ObjectType | UnknownType -> false + +(* The cases of a switch: arms with one body share it, the earlier ones + falling through to the last *) +let clauses ~same ~shares arms = + Ext_list.flat_map + (Ext_list.stable_group arms (fun (key1, body1) (key2, body2) -> + shares key1 key2 && same body1 body2)) + (fun group -> + Ext_list.map_last group (fun last (key, body) -> + if last then (key, Body (Run body)) + else (key, Falls_through (Some body)))) + +(* A subclass is checked before its superclasses, otherwise the declaration + order decides *) +let rec subclasses_first = function + | [] -> [] + | instances -> + let first = + List.find + (fun i -> + not (List.exists (fun j -> Instance.is_subclass j ~of_:i) instances)) + instances + in + first :: subclasses_first (List.filter (fun i -> i <> first) instances) + +(* The payload cases, after the literals: one [switch (typeof x)] over the + primitive kinds, whose default is an [if] chain over the classes + (subclasses first), arrays, functions and objects. Primitives never reach a + class check, and a class instance never reaches the function or object arm + before its own. In a complete match ([has_default] false) the last arm is + not checked. *) +let payload_part ~same ~block_cases ~null_guard ~fallback ~has_default arms = + match (arms, has_default) with + | [], true -> Fallback + | [], false -> Skip + | [(_, body)], false -> Run body + | _ -> ( + (* An arm with the default's body is the default *) + let arms = + match fallback with + | Some fallback when has_default -> + List.filter (fun (_, body) -> not (same fallback body)) arms + | Some _ | None -> arms + in + let all_clauses = + clauses ~same arms ~shares:(fun kind1 kind2 -> + is_primitive kind1 && is_primitive kind2) + in + let primitive_clauses, other_clauses = + List.partition (fun (kind, _) -> is_primitive kind) all_clauses + in + let arm block_type = + List.find_map + (fun (kind, clause) -> + match clause with + | Body tree when kind = block_type -> Some tree + | Body _ | Falls_through _ -> None) + other_clauses + in + let instances = + subclasses_first + (Ext_list.filter_map block_cases (function + | InstanceType i -> Some i + | _ -> None)) + in + let is_class = function + | Instance.Class _ -> true + | Array -> false + in + (* [null], when it did not go to the default before *) + let is_object = + if null_guard then And (Typeof ObjectType, Not_null) + else Typeof ObjectType + in + (* [Some body] for an arm, [None] for the default *) + let entries = + List.filter_map + (fun i -> + match arm (InstanceType i) with + | Some body -> Some (Some (Instance i), is_class i, Some body) + | None when has_default -> Some (Some (Instance i), is_class i, None) + | None -> None) + instances + @ (match arm FunctionType with + | Some body -> [(Some (Typeof FunctionType), false, Some body)] + | None -> []) + @ (match arm ObjectType with + | Some body -> [(Some is_object, false, Some body)] + | None -> []) + @ + match arm UnknownType with + | Some body -> [(None, false, Some body)] + | None -> [] + in + (* Checks leading to the default are needed only before an arm *) + let rec drop_trailing_defaults = function + | [] -> [] + | entries -> ( + match List.rev entries with + | (_, _, None) :: rest -> drop_trailing_defaults (List.rev rest) + | _ -> entries) + in + let entries = drop_trailing_defaults entries in + (* [if (c1) default else if (c2) body else default] is + [if (c2 && !c1) body else default], and [c1] then runs only on values + passing [c2], never on primitives *) + let entries = + match List.rev entries with + | (Some check, is_class, Some body) :: rest when has_default -> + let rec absorb check = function + | (Some previous, _, None) :: rest -> + absorb (And (check, Not previous)) rest + | rest -> List.rev ((Some check, is_class, Some body) :: rest) + in + absorb check rest + | _ -> entries + in + (* Consecutive checks leading to the default share one [if] *) + let rec merge_defaults = function + | (Some c1, class1, None) :: (Some c2, class2, None) :: rest -> + merge_defaults ((Some (Or (c1, c2)), class1 || class2, None) :: rest) + | entry :: rest -> entry :: merge_defaults rest + | [] -> [] + in + let entries = merge_defaults entries in + (* An arm may compile to no statement, so arms are counted here *) + let has_other_arms = entries <> [] in + (* The last arm of a complete match is not checked *) + let entries, final = + match List.rev entries with + | _ when has_default -> (entries, Fallback) + | (_, _, body) :: rest -> (List.rev rest, Option.value body ~default:Skip) + | [] -> (entries, Skip) + in + let has_class_check = + List.exists (fun (_, is_class, _) -> is_class) entries + in + let rec chain = function + | [] -> final + | (check, _, body) :: rest -> ( + let body = Option.value body ~default:Fallback in + match check with + | Some check -> If (check, body, chain rest) + | None -> body) + in + (* The primitive kinds of the type without an arm go to the default + directly when the chain has class checks *) + let unmatched_primitives = + if has_default && has_class_check then + let kinds = + List.filter + (fun kind -> + is_primitive kind + && not (List.exists (fun (k, _) -> k = kind) primitive_clauses)) + block_cases + in + Ext_list.mapi kinds (fun index kind -> + if index = List.length kinds - 1 then (kind, Body Fallback) + else (kind, Falls_through None)) + else [] + in + let primitive_clauses = primitive_clauses @ unmatched_primitives in + match primitive_clauses with + | [] -> Block (chain entries) + | _ :: _ when not has_other_arms -> ( + (* No other arm: in a complete match the last primitive arm is not + checked *) + match List.rev primitive_clauses with + | (_, last) :: rest when not has_default -> + let default = + match last with + | Body tree -> tree + | Falls_through _ -> Skip + in + Switch_typeof (List.rev rest, default) + | _ -> Switch_typeof (primitive_clauses, Fallback)) + | _ :: _ -> Switch_typeof (primitive_clauses, chain entries)) + +let plan ~same + ({ + facts = {block_types = block_cases; literal_tags = literal_cases}; + literal_arms; + payload_arms; + literals_complete; + payloads_complete; + fallback; + } : + 'a input) = + 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 + 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))) + 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 + switch *) + let payload_has_default = + payload_has_default + || (literal_default <> None && List.exists skips_the_switch unnamed) + in + let null_guard = + literal_default <> None && payload_has_default + && List.exists + (fun literal -> literal = Null && skips_the_switch literal) + unnamed + in + let unnamed = + match literal_default with + | Some fallback -> + Ext_list.filter_map unnamed (fun literal -> + if payload_has_default && skips_the_switch literal then None + else Some (literal, fallback)) + | 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 literal_arms = + match payload_arms with + | (_, body) :: rest + when (not payload_has_default) + && List.for_all (fun (_, other) -> same body other) rest -> + 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 + | [] -> [] + | (literal, body) :: rest -> + let same_body, others = + List.partition (fun (_, other) -> same body other) rest + in + (literal :: List.map fst same_body, body) :: group others + in + List.fold_right + (fun (literals, body) rest -> + let test = + match literals with + | first :: others -> + List.fold_left + (fun test literal -> Or (test, Equals literal)) + (Equals first) others + | [] -> assert false + in + If (test, Run body, rest)) + (group literal_arms) payload + else + Switch_value + (clauses ~same literal_arms ~shares:(fun _ _ -> true), payload) diff --git a/compiler/ml/untagged_dispatch.mli b/compiler/ml/untagged_dispatch.mli new file mode 100644 index 0000000000..21cebd154a --- /dev/null +++ b/compiler/ml/untagged_dispatch.mli @@ -0,0 +1,55 @@ +(** The dispatch of a [switch] on an untagged variant, as data: which tests + the generated code runs on the scrutinee, in which statements, and which + body each path runs. [Lam_compile] prints a plan as JavaScript. The plan + is built once per [switch] from the variant's facts and the arms of the + match, so every decision about the dispatch is made here, with all of + them known. *) + +(** A test on the scrutinee [x] *) +type test = + | Equals of Variant_runtime.literal_tag (** [x === literal] *) + | Typeof of Variant_runtime.block_type + (** [typeof x === "k"], for a kind with a [typeof] name *) + | Instance of Variant_runtime.Instance.t + (** [Array.isArray(x)] or [x instanceof C] *) + | Not_null (** [x !== null] *) + | Not of test + | And of test * test + | Or of test * test + +(** How the generated code reaches the bodies ['a] *) +type 'a tree = + | Run of 'a (** an arm's body, unchecked *) + | Fallback + (** the match's default action, reached from the payload dispatch *) + | Skip (** no statement *) + | If of test * 'a tree * 'a tree + | Block of 'a tree (** a statement block around the tree *) + | Switch_value of (Variant_runtime.literal_tag * 'a clause) list * 'a tree + (** [switch (x)] over literals; the tree is the [default:] *) + | Switch_typeof of (Variant_runtime.block_type * 'a clause) list * 'a tree + (** [switch (typeof x)] over kinds with a [typeof] name; the tree is the + [default:]. A switch with one clause that is not empty is printed + as an [if]. *) + +(** A [case] of a switch *) +and 'a clause = + | Falls_through of 'a option + (** an empty case falling through to the next one; the body only gives + the source location *) + | Body of 'a tree (** a [Run] or [Fallback] *) + +type 'a input = { + facts: Variant_runtime.matching_facts; + literal_arms: (Variant_runtime.literal_tag * 'a) list; + (** the arms of the literal cases, in the order of the match *) + payload_arms: (Variant_runtime.block_type * 'a) list; + (** the arms of the payload cases, in the order of the match *) + literals_complete: bool; (** every literal case has an arm *) + payloads_complete: bool; (** every payload case has an arm *) + fallback: 'a option; + (** the default action of the match, for the cases without an arm *) +} + +val plan : same:('a -> 'a -> bool) -> 'a input -> 'a tree +(** [same] tells two bodies that are one body apart *) diff --git a/tests/ounit_tests/ounit_tests_main.ml b/tests/ounit_tests/ounit_tests_main.ml index dd17303b87..f02fbc7ed8 100644 --- a/tests/ounit_tests/ounit_tests_main.ml +++ b/tests/ounit_tests/ounit_tests_main.ml @@ -14,6 +14,7 @@ let suites = Ounit_util_tests.suites; Ounit_rec_check_tests.suites; Ounit_lambda_constant_tests.suites; + Ounit_untagged_dispatch_tests.suites; Ounit_lambda_traverse_tests.suites; Ounit_partial_application_tests.suites; Ounit_deep_flatten_tests.suites; diff --git a/tests/ounit_tests/ounit_untagged_dispatch_tests.ml b/tests/ounit_tests/ounit_untagged_dispatch_tests.ml new file mode 100644 index 0000000000..92a0919763 --- /dev/null +++ b/tests/ounit_tests/ounit_untagged_dispatch_tests.ml @@ -0,0 +1,126 @@ +open OUnit + +module D = Untagged_dispatch +module R = Variant_runtime + +let rec test_to_string : D.test -> string = function + | Equals literal -> "x === " ^ R.literal_value_key literal + | Typeof block_type -> + "typeof x === " ^ Option.value (R.typeof_name block_type) ~default:"?" + | Instance instance -> "x instanceof " ^ R.Instance.to_string instance + | Not_null -> "x !== null" + | Not test -> "!(" ^ test_to_string test ^ ")" + | And (test1, test2) -> + "(" ^ test_to_string test1 ^ " && " ^ test_to_string test2 ^ ")" + | Or (test1, test2) -> + "(" ^ test_to_string test1 ^ " || " ^ test_to_string test2 ^ ")" + +let rec tree_to_string : string D.tree -> string = function + | Run body -> body + | Fallback -> "fallback" + | Skip -> "skip" + | If (test, then_, else_) -> + "if (" ^ test_to_string test ^ ") " ^ tree_to_string then_ ^ " else " + ^ tree_to_string else_ + | Block tree -> "{" ^ tree_to_string tree ^ "}" + | Switch_value (clauses, default) -> + "switch (x) {" + ^ String.concat "" + (List.map + (fun (literal, clause) -> + R.literal_value_key literal ^ ": " ^ clause_to_string clause ^ "; ") + clauses) + ^ "default: " ^ tree_to_string default ^ "}" + | Switch_typeof (clauses, default) -> + "switch (typeof x) {" + ^ String.concat "" + (List.map + (fun (block_type, clause) -> + Option.value (R.typeof_name block_type) ~default:"?" + ^ ": " ^ clause_to_string clause ^ "; ") + clauses) + ^ "default: " ^ tree_to_string default ^ "}" + +and clause_to_string : string D.clause -> string = function + | Falls_through _ -> "falls through" + | Body tree -> tree_to_string tree + +let class_ ?(ancestors = []) name : R.block_type = + InstanceType (Class {name; ancestors}) + +(* The plan of a match with these arms on a variant with these literal and + payload cases; [fallback] is the match's default *) +let plan ~literals ~kinds ?(fallback : string option) literal_arms payload_arms + = + D.plan ~same:String.equal + { + facts = {tag_name = None; block_types = kinds; literal_tags = literals}; + literal_arms; + payload_arms; + literals_complete = List.length literal_arms = List.length literals; + payloads_complete = List.length payload_arms = List.length kinds; + fallback; + } + +let ( =~ ) expected tree = + OUnit.assert_equal ~printer:(fun s -> s) expected (tree_to_string tree) + +let suites = + __FILE__ + >::: [ + ( "a literal no payload arm takes skips the switch" >:: fun _ -> + "switch (typeof x) {number: int; default: fallback}" + =~ plan ~literals:[String "a"; String "b"] ~kinds:[NumberType] + ~fallback:"default" [] + [(NumberType, "int")] ); + ( "a literal a payload arm takes is tested first" >:: fun _ -> + "if (x === string:a) a else string" + =~ plan ~literals:[String "a"] ~kinds:[StringType] + [(String "a", "a")] + [(StringType, "string")] ); + ( "a skipping null adds a null check to the object arm" >:: fun _ -> + "switch (typeof x) {string: string; default: if ((typeof x === \ + object && x !== null)) object else fallback}" + =~ plan ~literals:[Null] ~kinds:[StringType; ObjectType] + ~fallback:"default" [] + [(StringType, "string"); (ObjectType, "object")] ); + ( "a subclass is checked before its superclass" >:: fun _ -> + "switch (typeof x) {string: string; default: if ((x instanceof \ + Animal && !(x instanceof Dog))) animal else fallback}" + =~ plan ~literals:[] + ~kinds: + [ + class_ "Animal"; + class_ "Dog" ~ancestors:["Animal"]; + StringType; + ] + ~fallback:"default" [] + [(class_ "Animal", "animal"); (StringType, "string")] ); + ( "the last arm of a complete match is not checked" >:: fun _ -> + "{if (x instanceof Date) date else regexp}" + =~ plan ~literals:[] + ~kinds:[class_ "Date"; class_ "RegExp"] + [] + [(class_ "Date", "date"); (class_ "RegExp", "regexp")] ); + ( "literals with one body share a case" >:: fun _ -> + "switch (x) {string:b: y; string:a: falls through; string:c: x; \ + default: string}" + =~ plan + ~literals:[String "a"; String "b"; String "c"] + ~kinds:[StringType] + [(String "a", "x"); (String "b", "y"); (String "c", "x")] + [(StringType, "string")] ); + ( "two literals with one body are one test" >:: fun _ -> + "if ((x === number:0x1p+0 || x === number:0x1p+1)) one else number" + =~ plan ~literals:[Int 1; Int 2] ~kinds:[NumberType] + [(Int 1, "one"); (Int 2, "one")] + [(NumberType, "number")] ); + ( "primitive kinds without an arm go to the default before class checks" + >:: fun _ -> + "switch (typeof x) {string: string; number: fallback; default: if \ + (x instanceof Date) date else fallback}" + =~ plan ~literals:[] + ~kinds:[StringType; NumberType; class_ "Date"] + ~fallback:"default" [] + [(StringType, "string"); (class_ "Date", "date")] ); + ] diff --git a/tests/tests/src/untagged_loop_control_test.mjs b/tests/tests/src/untagged_loop_control_test.mjs index 42ea62f619..df55a932be 100644 --- a/tests/tests/src/untagged_loop_control_test.mjs +++ b/tests/tests/src/untagged_loop_control_test.mjs @@ -95,8 +95,21 @@ function scanDefaultBreak(values) { return seen; } +function scanIf(values) { + let seen = []; + for (let i = 0, i_finish = values.length; i < i_finish; ++i) { + let text = values[i]; + if (typeof text === "string") { + seen.push(text); + } else { + break; + } + } + return seen; +} + Mocha.describe("Untagged_loop_control_test", () => { - Mocha.test("a literal arm", () => Test_utils.eq("File \"untagged_loop_control_test.res\", line 68, characters 7-14", scan([ + Mocha.test("a literal arm", () => Test_utils.eq("File \"untagged_loop_control_test.res\", line 83, characters 7-14", scan([ "a", "skip", "b", @@ -109,7 +122,7 @@ Mocha.describe("Untagged_loop_control_test", () => { "." ])); Mocha.test("a primitive arm", () => { - Test_utils.eq("File \"untagged_loop_control_test.res\", line 73, characters 6-13", scan([ + Test_utils.eq("File \"untagged_loop_control_test.res\", line 88, characters 6-13", scan([ "a", "continue", 1, @@ -121,7 +134,7 @@ Mocha.describe("Untagged_loop_control_test", () => { "count", "." ]); - Test_utils.eq("File \"untagged_loop_control_test.res\", line 77, characters 7-14", scan([ + Test_utils.eq("File \"untagged_loop_control_test.res\", line 92, characters 7-14", scan([ 1, -1, "c" @@ -130,7 +143,7 @@ Mocha.describe("Untagged_loop_control_test", () => { "." ]); }); - Mocha.test("a class and an object arm", () => Test_utils.eq("File \"untagged_loop_control_test.res\", line 81, characters 7-14", scan([ + Mocha.test("a class and an object arm", () => Test_utils.eq("File \"untagged_loop_control_test.res\", line 96, characters 7-14", scan([ new Date(), "a", { @@ -142,7 +155,7 @@ Mocha.describe("Untagged_loop_control_test", () => { "." ])); Mocha.test("a default arm", () => { - Test_utils.eq("File \"untagged_loop_control_test.res\", line 86, characters 6-13", scanDefault([ + Test_utils.eq("File \"untagged_loop_control_test.res\", line 101, characters 6-13", scanDefault([ 1, "a", "skip", @@ -158,29 +171,35 @@ Mocha.describe("Untagged_loop_control_test", () => { "date", "." ]); - Test_utils.eq("File \"untagged_loop_control_test.res\", line 90, characters 7-14", scanDefaultBreak([ + Test_utils.eq("File \"untagged_loop_control_test.res\", line 105, characters 7-14", scanDefaultBreak([ "a", 1, "c" ]), ["a"]); - Test_utils.eq("File \"untagged_loop_control_test.res\", line 91, characters 7-14", scanDefaultBreak([ + Test_utils.eq("File \"untagged_loop_control_test.res\", line 106, characters 7-14", scanDefaultBreak([ "a", { x: 1 }, "c" ]), ["a"]); - Test_utils.eq("File \"untagged_loop_control_test.res\", line 92, characters 7-14", scanDefaultBreak([ + Test_utils.eq("File \"untagged_loop_control_test.res\", line 107, characters 7-14", scanDefaultBreak([ new Date(), "skip", "c" ]), ["date"]); }); + Mocha.test("an arm of an if", () => Test_utils.eq("File \"untagged_loop_control_test.res\", line 111, characters 7-14", scanIf([ + "a", + 1, + "c" + ]), ["a"])); }); export { scan, scanDefault, scanDefaultBreak, + scanIf, } /* Not a pure module */ diff --git a/tests/tests/src/untagged_loop_control_test.res b/tests/tests/src/untagged_loop_control_test.res index ac373e2b28..a543523e9c 100644 --- a/tests/tests/src/untagged_loop_control_test.res +++ b/tests/tests/src/untagged_loop_control_test.res @@ -63,6 +63,21 @@ let scanDefaultBreak = (values: array) => { seen } +// A dispatch printed as an [if] leaves the loop with a plain [break] +@unboxed +type textOrCount = TextItem(string) | CountItem(float) + +let scanIf = (values: array) => { + let seen = [] + for i in 0 to Array.length(values) - 1 { + switch values->Array.getUnsafe(i) { + | TextItem(text) => seen->Array.push(text) + | CountItem(_) => break + } + } + seen +} + describe(__MODULE__, () => { test("a literal arm", () => { eq(__LOC__, scan([Text("a"), Skip, Text("b"), Stop, Text("c")]), ["a", ".", "b", "."]) @@ -91,4 +106,8 @@ describe(__MODULE__, () => { eq(__LOC__, scanDefaultBreak([Text("a"), Object({x: 1}), Text("c")]), ["a"]) eq(__LOC__, scanDefaultBreak([Date(Date.make()), Skip, Text("c")]), ["date"]) }) + + test("an arm of an if", () => { + eq(__LOC__, scanIf([TextItem("a"), CountItem(1.), TextItem("c")]), ["a"]) + }) })