Skip to content

Commit d7aaa37

Browse files
committed
Experiment for untagged pattern matching.
First step: remove the distinction between cases with and without payload in the toplevel algorithm. On this test: ```res @unboxed type rec t = | Boolean(bool) | @as(null) Null | String(string) | Number(float) | Object(Dict.t<t>) | Array(array<t>) type group = { id: string, name: string, } let decodeGroup = group => { switch group { | (dict{"id": String(id), "name": String(name)}) => (id, name) | _ => ("e", "f") } } ``` Before: ```js function decodeGroup(group) { let match = group.id; if (match === undefined) { return [ "e", "f" ]; } if (match === null) { return [ "e", "f" ]; } if (typeof match !== "string") { return [ "e", "f" ]; } let match$1 = group.name; if (match$1 !== undefined && !(match$1 === null || typeof match$1 !== "string")) { return [ match, match$1 ]; } else { return [ "e", "f" ]; } } ``` After: ``` function decodeGroup(group) { let match = group.id; if (match === undefined) { return [ "e", "f" ]; } if (typeof match !== "string") { return [ "e", "f" ]; } let match$1 = group.name; if (match$1 !== undefined && typeof match$1 === "string") { return [ match, match$1 ]; } else { return [ "e", "f" ]; } } ``` The 3 cases have become 2: check for optional fields and check for which case it is.
1 parent 1a3efbe commit d7aaa37

File tree

1 file changed

+52
-20
lines changed

1 file changed

+52
-20
lines changed

compiler/core/lam_compile.ml

Lines changed: 52 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -673,6 +673,8 @@ let compile output_prefix =
673673
also if last statement is throw -- should we drop remaining
674674
statement?
675675
*)
676+
Printf.eprintf "XXX switch_arg: %s\n\n"
677+
(Lam_print.lambda_to_string switch_arg);
676678
let ({
677679
sw_consts_full;
678680
sw_consts;
@@ -713,40 +715,66 @@ let compile output_prefix =
713715
block
714716
@
715717
if sw_consts_full && sw_consts = [] then
718+
let _ = Printf.eprintf "QQQ sw_consts_full\n\n" in
716719
compile_cases ~block_cases ~untagged ~cxt
717720
~switch_exp:(if untagged then e else E.tag ~name:tag_name e)
718721
~default:sw_blocks_default ~get_tag:get_block_tag sw_blocks
719722
else if sw_blocks_full && sw_blocks = [] then
723+
let _ = Printf.eprintf "QQQ sw_blocks_full\n\n" in
720724
compile_cases ~cxt ~switch_exp:e ~block_cases ~default:sw_num_default
721725
~get_tag:get_const_tag sw_consts
722726
else
727+
let _ = Printf.eprintf "QQQ else\n\n" in
723728
(* [e] will be used twice *)
724729
let dispatch e =
725730
let is_a_literal_case =
726-
if block_cases <> [] then
727-
E.is_a_literal_case
728-
~literal_cases:(get_literal_cases sw_names)
729-
~block_cases e
731+
if untagged then (
732+
let literal_case =
733+
E.is_a_literal_case
734+
~literal_cases:(get_literal_cases sw_names)
735+
~block_cases e
736+
in
737+
Printf.eprintf "LLL literal_case: %s\n\n"
738+
(Js_dump.string_of_expression literal_case);
739+
literal_case)
730740
else
731741
E.is_int_tag
732742
~has_null_undefined_other:(has_null_undefined_other sw_names)
733743
e
734744
in
735-
S.if_ is_a_literal_case
736-
(compile_cases ~cxt ~switch_exp:e ~block_cases
737-
~default:sw_num_default ~get_tag:get_const_tag sw_consts)
738-
~else_:
739-
(compile_cases ~untagged ~cxt
740-
~switch_exp:(if untagged then e else E.tag ~name:tag_name e)
741-
~block_cases ~default:sw_blocks_default
742-
~get_tag:get_block_tag sw_blocks)
745+
let qconsts =
746+
use_compile_literal_cases sw_consts ~get_tag:get_const_tag
747+
in
748+
let qblocks =
749+
use_compile_literal_cases sw_blocks ~get_tag:get_block_tag
750+
in
751+
match (qconsts, qblocks) with
752+
| Some consts_cases, Some blocks_cases when untagged ->
753+
let untagged_cases = consts_cases @ blocks_cases in
754+
let z =
755+
compile_untagged_cases ~cxt ~switch_exp:e ~block_cases
756+
~default:sw_num_default untagged_cases
757+
in
758+
z
759+
| _ ->
760+
[
761+
S.if_ is_a_literal_case
762+
(compile_cases ~cxt ~switch_exp:e ~block_cases
763+
~default:sw_num_default ~get_tag:get_const_tag sw_consts)
764+
~else_:
765+
(compile_cases ~untagged ~cxt
766+
~switch_exp:
767+
(if untagged then e else E.tag ~name:tag_name e)
768+
~block_cases ~default:sw_blocks_default
769+
~get_tag:get_block_tag sw_blocks);
770+
]
743771
in
744772
match e.expression_desc with
745-
| J.Var _ -> [dispatch e]
773+
| J.Var _ -> dispatch e
746774
| _ ->
747775
let v = Ext_ident.create_tmp () in
748776
(* Necessary avoid duplicated computation*)
749-
[S.define_variable ~kind:Variable v e; dispatch (E.var v)])
777+
[S.define_variable ~kind:Variable v e] @ dispatch (E.var v))
750778
in
751779
match lambda_cxt.continuation with
752780
(* Needs declare first *)
@@ -756,15 +784,19 @@ let compile output_prefix =
756784
when branches are minimial (less than 2)
757785
*)
758786
let v = Ext_ident.create_tmp () in
787+
let res = compile_whole {lambda_cxt with continuation = Assign v} in
788+
Printf.eprintf "XXX res 1: %s\n\n" (Js_dump.string_of_block res);
759789
Js_output.make
760-
(S.declare_variable ~kind:Variable v
761-
:: compile_whole {lambda_cxt with continuation = Assign v})
790+
(S.declare_variable ~kind:Variable v :: res)
762791
~value:(E.var v)
763792
| Declare (kind, id) ->
764-
Js_output.make
765-
(S.declare_variable ~kind id
766-
:: compile_whole {lambda_cxt with continuation = Assign id})
767-
| EffectCall _ | Assign _ -> Js_output.make (compile_whole lambda_cxt)
793+
let res = compile_whole {lambda_cxt with continuation = Assign id} in
794+
Printf.eprintf "XXX res 2: %s\n\n" (Js_dump.string_of_block res);
795+
Js_output.make (S.declare_variable ~kind id :: res) ~value:(E.var id)
796+
| EffectCall _ | Assign _ ->
797+
let res = compile_whole lambda_cxt in
798+
Printf.eprintf "XXX res 3: %s\n\n" (Js_dump.string_of_block res);
799+
Js_output.make res
768800
and compile_string_cases ~cxt ~switch_exp ~default cases : initialization =
769801
cases
770802
|> compile_general_cases ~make_exp:E.tag_type

0 commit comments

Comments
 (0)