@@ -673,6 +673,8 @@ let compile output_prefix =
673
673
also if last statement is throw -- should we drop remaining
674
674
statement?
675
675
*)
676
+ Printf. eprintf " XXX switch_arg: %s\n\n "
677
+ (Lam_print. lambda_to_string switch_arg);
676
678
let ({
677
679
sw_consts_full;
678
680
sw_consts;
@@ -713,40 +715,66 @@ let compile output_prefix =
713
715
block
714
716
@
715
717
if sw_consts_full && sw_consts = [] then
718
+ let _ = Printf. eprintf " QQQ sw_consts_full\n\n " in
716
719
compile_cases ~block_cases ~untagged ~cxt
717
720
~switch_exp: (if untagged then e else E. tag ~name: tag_name e)
718
721
~default: sw_blocks_default ~get_tag: get_block_tag sw_blocks
719
722
else if sw_blocks_full && sw_blocks = [] then
723
+ let _ = Printf. eprintf " QQQ sw_blocks_full\n\n " in
720
724
compile_cases ~cxt ~switch_exp: e ~block_cases ~default: sw_num_default
721
725
~get_tag: get_const_tag sw_consts
722
726
else
727
+ let _ = Printf. eprintf " QQQ else\n\n " in
723
728
(* [e] will be used twice *)
724
729
let dispatch e =
725
730
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)
730
740
else
731
741
E. is_int_tag
732
742
~has_null_undefined_other: (has_null_undefined_other sw_names)
733
743
e
734
744
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
+ ]
743
771
in
744
772
match e.expression_desc with
745
- | J. Var _ -> [ dispatch e]
773
+ | J. Var _ -> dispatch e
746
774
| _ ->
747
775
let v = Ext_ident. create_tmp () in
748
776
(* 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))
750
778
in
751
779
match lambda_cxt.continuation with
752
780
(* Needs declare first *)
@@ -756,15 +784,19 @@ let compile output_prefix =
756
784
when branches are minimial (less than 2)
757
785
*)
758
786
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);
759
789
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)
762
791
~value: (E. var v)
763
792
| 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
768
800
and compile_string_cases ~cxt ~switch_exp ~default cases : initialization =
769
801
cases
770
802
|> compile_general_cases ~make_exp: E. tag_type
0 commit comments