@@ -673,8 +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);
676+ (* Printf.eprintf "XXX switch_arg: %s\n\n"
677+ (Lam_print.lambda_to_string switch_arg); *)
678678 let ({
679679 sw_consts_full;
680680 sw_consts;
@@ -715,28 +715,28 @@ let compile output_prefix =
715715 block
716716 @
717717 if sw_consts_full && sw_consts = [] then
718- let _ = Printf. eprintf " QQQ sw_consts_full\n\n " in
718+ (* let _ = Printf.eprintf "QQQ sw_consts_full\n\n" in *)
719719 compile_cases ~block_cases ~untagged ~cxt
720720 ~switch_exp: (if untagged then e else E. tag ~name: tag_name e)
721721 ~default: sw_blocks_default ~get_tag: get_block_tag sw_blocks
722722 else if sw_blocks_full && sw_blocks = [] then
723- let _ = Printf. eprintf " QQQ sw_blocks_full\n\n " in
723+ (* let _ = Printf.eprintf "QQQ sw_blocks_full\n\n" in *)
724724 compile_cases ~cxt ~switch_exp: e ~block_cases ~default: sw_num_default
725725 ~get_tag: get_const_tag sw_consts
726726 else
727- let _ = Printf. eprintf " QQQ else\n\n " in
727+ (* let _ = Printf.eprintf "QQQ else\n\n" in *)
728728 (* [e] will be used twice *)
729729 let dispatch e =
730730 let is_a_literal_case =
731- if untagged then (
731+ if untagged then
732732 let literal_case =
733733 E. is_a_literal_case
734734 ~literal_cases: (get_literal_cases sw_names)
735735 ~block_cases e
736736 in
737- Printf. eprintf " LLL literal_case: %s\n\n "
738- (Js_dump. string_of_expression literal_case);
739- literal_case)
737+ (* Printf.eprintf "LLL literal_case: %s\n\n"
738+ (Js_dump.string_of_expression literal_case); *)
739+ literal_case
740740 else
741741 E. is_int_tag
742742 ~has_null_undefined_other: (has_null_undefined_other sw_names)
@@ -748,14 +748,21 @@ let compile output_prefix =
748748 let qblocks =
749749 use_compile_literal_cases sw_blocks ~get_tag: get_block_tag
750750 in
751+ let eq_default d1 d2 =
752+ match (d1, d2) with
753+ | Default lam1 , Default lam2 -> Lam. eq_approx lam1 lam2
754+ | Complete , Complete -> true
755+ | NonComplete , NonComplete -> true
756+ | _ -> false
757+ in
751758 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+ | Some consts_cases, Some blocks_cases
760+ when untagged
761+ && List. length blocks_cases > = 1
762+ && List. length consts_cases = 0
763+ && eq_default sw_num_default sw_blocks_default ->
764+ compile_cases ~untagged ~cxt ~switch_exp: e ~block_cases
765+ ~default: sw_blocks_default ~get_tag: get_block_tag sw_blocks
759766 | _ ->
760767 [
761768 S. if_ is_a_literal_case
@@ -785,17 +792,17 @@ let compile output_prefix =
785792 *)
786793 let v = Ext_ident. create_tmp () in
787794 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);
795+ (* Printf.eprintf "XXX res 1: %s\n\n" (Js_dump.string_of_block res); *)
789796 Js_output. make
790797 (S. declare_variable ~kind: Variable v :: res)
791798 ~value: (E. var v)
792799 | Declare (kind , id ) ->
793800 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);
801+ (* Printf.eprintf "XXX res 2: %s\n\n" (Js_dump.string_of_block res); *)
795802 Js_output. make (S. declare_variable ~kind id :: res) ~value: (E. var id)
796803 | EffectCall _ | Assign _ ->
797804 let res = compile_whole lambda_cxt in
798- Printf. eprintf " XXX res 3: %s\n\n " (Js_dump. string_of_block res);
805+ (* Printf.eprintf "XXX res 3: %s\n\n" (Js_dump.string_of_block res); *)
799806 Js_output. make res
800807 and compile_string_cases ~cxt ~switch_exp ~default cases : initialization =
801808 cases
0 commit comments