From 277f153fda89e78fc7394f85811bc19a4d06df1b Mon Sep 17 00:00:00 2001 From: Hongbo Zhang Date: Thu, 15 Mar 2018 22:32:16 +0800 Subject: [PATCH 1/8] more verbose labels --- jscomp/all.depend | 4 +- jscomp/core/bs_conditional_initial.ml | 2 +- jscomp/core/j.ml | 4 +- jscomp/core/js_dump.ml | 4 +- jscomp/core/js_fold.ml | 2 +- jscomp/core/js_map.ml | 4 +- jscomp/core/js_of_lam_variant.ml | 12 +- jscomp/core/js_output.ml | 3 +- jscomp/core/js_stmt_make.ml | 7 +- jscomp/core/lam_compile.ml | 6 +- jscomp/others/.depend | 2 + jscomp/test/.depend | 1 + jscomp/test/Makefile | 1 + jscomp/test/gpr_2413_test.js | 32 +++ jscomp/test/gpr_2413_test.ml | 15 ++ lib/whole_compiler.d | 1 + lib/whole_compiler.ml | 288 ++++++++++++++++++-------- 17 files changed, 280 insertions(+), 108 deletions(-) create mode 100644 jscomp/test/gpr_2413_test.js create mode 100644 jscomp/test/gpr_2413_test.ml diff --git a/jscomp/all.depend b/jscomp/all.depend index a572f314a93..7faa6d99241 100644 --- a/jscomp/all.depend +++ b/jscomp/all.depend @@ -761,9 +761,11 @@ super_errors/super_main.cmx : super_errors/super_typetexp.cmx \ super_errors/super_env.cmx super_errors/super_reason_react.cmi : super_errors/super_misc.cmi : +outcome_printer/reason_syntax_util.cmx : outcome_printer/outcome_printer_ns.cmx : ext/ext_namespace.cmx \ outcome_printer/outcome_printer_ns.cmi -outcome_printer/tweaked_reason_oprint.cmx : +outcome_printer/tweaked_reason_oprint.cmx : \ + outcome_printer/reason_syntax_util.cmx outcome_printer/reason_outcome_printer_main.cmx : \ outcome_printer/tweaked_reason_oprint.cmx outcome_printer/outcome_printer_ns.cmi : diff --git a/jscomp/core/bs_conditional_initial.ml b/jscomp/core/bs_conditional_initial.ml index 46a981cd2e0..184a97c7718 100644 --- a/jscomp/core/bs_conditional_initial.ml +++ b/jscomp/core/bs_conditional_initial.ml @@ -25,7 +25,7 @@ let setup_env () = #if BS_DEBUG then - Js_config.set_debug_file "gpr_2352_test.ml"; + Js_config.set_debug_file "gpr_2413_test.ml"; #end Lexer.replace_directive_bool "BS" true; Lexer.replace_directive_string "BS_VERSION" Bs_version.version diff --git a/jscomp/core/j.ml b/jscomp/core/j.ml index 2b55ca0f195..4c4cba0322a 100644 --- a/jscomp/core/j.ml +++ b/jscomp/core/j.ml @@ -379,8 +379,8 @@ and variable_declaration = { } and 'a case_clause = { - case : 'a ; - body : block * bool ; (* true means break *) + switch_case : 'a ; + switch_body : block * bool ; (* true means break *) } (* TODO: For efficency: block should not be a list, it should be able to diff --git a/jscomp/core/js_dump.ml b/jscomp/core/js_dump.ml index e794e072eea..c9c9fb7c414 100644 --- a/jscomp/core/js_dump.ml +++ b/jscomp/core/js_dump.ml @@ -359,7 +359,7 @@ and pp_function method_ and output_one : 'a . _ -> P.t -> (P.t -> 'a -> unit) -> 'a J.case_clause -> _ = fun cxt f pp_cond - ({case = e; body = (sl,break)} : _ J.case_clause) -> + ({switch_case = e; switch_body = (sl,should_break)} : _ J.case_clause) -> let cxt = P.group f 1 @@ fun _ -> P.group f 1 @@ (fun _ -> @@ -378,7 +378,7 @@ and output_one : 'a . P.newline f ; statement_list false cxt f sl in - (if break then + (if should_break then begin P.newline f ; P.string f L.break; diff --git a/jscomp/core/js_fold.ml b/jscomp/core/js_fold.ml index e7c7100282e..1d787de19ad 100644 --- a/jscomp/core/js_fold.ml +++ b/jscomp/core/js_fold.ml @@ -461,7 +461,7 @@ class virtual fold = {[ goto : label option ; ]} *) 'a. ('self_type -> 'a -> 'self_type) -> 'a case_clause -> 'self_type = - fun _f_a { case = _x; body = _x_i1 } -> + fun _f_a { switch_case = _x; switch_body = _x_i1 } -> let o = _f_a o _x in let o = (fun (_x, _x_i1) -> let o = o#block _x in let o = o#bool _x_i1 in o) diff --git a/jscomp/core/js_map.ml b/jscomp/core/js_map.ml index e5e5bb0e23c..224282c6b39 100644 --- a/jscomp/core/js_map.ml +++ b/jscomp/core/js_map.ml @@ -512,13 +512,13 @@ class virtual map = *) 'a 'a_out. ('self_type -> 'a -> 'a_out) -> 'a case_clause -> 'a_out case_clause = - fun _f_a { case = _x; body = _x_i1 } -> + fun _f_a { switch_case = _x; switch_body = _x_i1 } -> let _x = _f_a o _x in let _x_i1 = (fun (_x, _x_i1) -> let _x = o#block _x in let _x_i1 = o#bool _x_i1 in (_x, _x_i1)) _x_i1 - in { case = _x; body = _x_i1; } + in { switch_case = _x; switch_body = _x_i1; } method block : block -> block = (* true means break *) (* TODO: For efficency: block should not be a list, it should be able to be concatenated in both ways diff --git a/jscomp/core/js_of_lam_variant.ml b/jscomp/core/js_of_lam_variant.ml index 3df366529a9..b9ba392d251 100644 --- a/jscomp/core/js_of_lam_variant.ml +++ b/jscomp/core/js_of_lam_variant.ml @@ -40,8 +40,8 @@ let eval (arg : J.expression) (dispatches : (int * string) list ) : E.t = E.of_block [(S.int_switch arg (Ext_list.map (fun (i,r) -> - {J.case = i ; - body = [S.return_stmt (E.str r)], + {J.switch_case = i ; + switch_body = [S.return_stmt (E.str r)], false (* FIXME: if true, still print break*) }) dispatches))] @@ -58,8 +58,8 @@ let eval_as_event (arg : J.expression) (dispatches : (int * string) list ) = (E.of_block [(S.int_switch (E.index arg 0l) (Ext_list.map (fun (i,r) -> - {J.case = i ; - body = [S.return_stmt (E.str r)], + {J.switch_case = i ; + switch_body = [S.return_stmt (E.str r)], false (* FIXME: if true, still print break*) }) dispatches))] , (* TODO: improve, one dispatch later, @@ -86,8 +86,8 @@ let eval_as_int (arg : J.expression) (dispatches : (int * int) list ) : E.t = E.of_block [(S.int_switch arg (Ext_list.map (fun (i,r) -> - {J.case = i ; - body = [S.return_stmt (E.int (Int32.of_int r))], + {J.switch_case = i ; + switch_body = [S.return_stmt (E.int (Int32.of_int r))], false (* FIXME: if true, still print break*) }) dispatches))] diff --git a/jscomp/core/js_output.ml b/jscomp/core/js_output.ml index 2351d8885e0..f8cd8d54eb3 100644 --- a/jscomp/core/js_output.ml +++ b/jscomp/core/js_output.ml @@ -122,7 +122,8 @@ let to_break_block (x : t) : J.block * bool = TODO: check if it has side efects *) | { value = None; finished } -> - block, (match finished with | True -> false | (False | Dummy) -> true ) + block, + (match finished with | True -> false | (False | Dummy) -> true ) | {value = Some _ as opt; _} -> block_with_opt_expr block opt, true diff --git a/jscomp/core/js_stmt_make.ml b/jscomp/core/js_stmt_make.ml index 1898d4b31e6..3a9fb3037c3 100644 --- a/jscomp/core/js_stmt_make.ml +++ b/jscomp/core/js_stmt_make.ml @@ -100,7 +100,8 @@ let int_switch ?comment ?declaration ?default (e : J.expression) clauses : t let continuation = begin match Ext_list.find_opt (fun (x : _ J.case_clause) -> - if x.case = (Int32.to_int i) then Some (fst x.body) else None ) clauses + if x.switch_case = (Int32.to_int i) then + Some (fst x.switch_body) else None ) clauses with | Some case -> case | None -> @@ -137,8 +138,8 @@ let string_switch ?comment ?declaration ?default (e : J.expression) clauses : let continuation = begin match Ext_list.find_opt (fun (x : string J.case_clause) -> - if x.case = s then - Some (fst x.body) + if x.switch_case = s then + Some (fst x.switch_body) else None ) clauses with diff --git a/jscomp/core/lam_compile.ml b/jscomp/core/lam_compile.ml index 905e3ab89ce..59a7d47bb41 100644 --- a/jscomp/core/lam_compile.ml +++ b/jscomp/core/lam_compile.ml @@ -480,10 +480,10 @@ and compile_general_cases : |> Ext_list.map_last (fun last (x,lam) -> if last - then {J.case = x; - body = + then {J.switch_case = x; + switch_body = Js_output.to_break_block (compile_lambda cxt lam) } - else { case = x; body = [],false })) + else { switch_case = x; switch_body = [],false })) (* TODO: we should also group default *) (* The last clause does not need [break] common break through, *) diff --git a/jscomp/others/.depend b/jscomp/others/.depend index 8d50c497ac5..3e26012c5c0 100644 --- a/jscomp/others/.depend +++ b/jscomp/others/.depend @@ -57,6 +57,7 @@ belt_MapString.cmj : belt_internalMapString.cmj belt_internalAVLtree.cmj \ belt_Array.cmj belt_MapString.cmi belt_MapInt.cmj : belt_internalMapInt.cmj belt_internalAVLtree.cmj \ belt_Array.cmj belt_MapInt.cmi +belt_Option.cmj : belt_Option.cmi belt_Set.cmj : belt_SetString.cmj belt_SetInt.cmj belt_SetDict.cmj \ belt_Id.cmj belt_Array.cmj belt_Set.cmi belt_MutableSet.cmj : belt_internalAVLset.cmj belt_SortArray.cmj \ @@ -127,6 +128,7 @@ belt_Map.cmi : belt_MapString.cmi belt_MapInt.cmi belt_MapDict.cmi \ belt_Id.cmi belt_MapString.cmi : belt_MapInt.cmi : +belt_Option.cmi : belt_Set.cmi : belt_SetString.cmi belt_SetInt.cmi belt_SetDict.cmi \ belt_Id.cmi belt_MutableSet.cmi : belt_MutableSetString.cmi belt_MutableSetInt.cmi \ diff --git a/jscomp/test/.depend b/jscomp/test/.depend index 4bf9a463c41..9460348c152 100644 --- a/jscomp/test/.depend +++ b/jscomp/test/.depend @@ -302,6 +302,7 @@ gpr_1946_test.cmj : ../stdlib/obj.cmj ../runtime/js.cmj gpr_2250_test.cmj : mt.cmj gpr_2316_test.cmj : mt.cmj ../runtime/js.cmj gpr_2352_test.cmj : +gpr_2413_test.cmj : gpr_2474.cmj : gpr_2487.cmj : ../others/belt.cmj gpr_2503_test.cmj : mt.cmj ../runtime/js.cmj diff --git a/jscomp/test/Makefile b/jscomp/test/Makefile index 86f3b852edd..7eca9ebd507 100644 --- a/jscomp/test/Makefile +++ b/jscomp/test/Makefile @@ -245,6 +245,7 @@ OTHERS := test_literals a test_ari test_export2 test_internalOO test_obj_simple_ pipe_syntax\ gpr_2352_test\ gpr_2633_test\ + gpr_2413_test\ # bs_uncurry_test # needs Lam to get rid of Uncurry arity first # simple_derive_test diff --git a/jscomp/test/gpr_2413_test.js b/jscomp/test/gpr_2413_test.js new file mode 100644 index 00000000000..72172f485c5 --- /dev/null +++ b/jscomp/test/gpr_2413_test.js @@ -0,0 +1,32 @@ +'use strict'; + +var Caml_int32 = require("../../lib/js/caml_int32.js"); + +function f(param) { + var exit = 0; + switch (param.tag | 0) { + case 0 : + var match = param[0]; + if (match.tag) { + var a = match[0]; + return a - a | 0; + } else { + var a$1 = match[0]; + return a$1 + a$1 | 0; + } + break; + case 1 : + case 2 : + exit = 1; + break; + + } + if (exit === 1) { + var a$2 = param[0][0]; + return Caml_int32.imul(a$2, a$2); + } + +} + +exports.f = f; +/* No side effect */ diff --git a/jscomp/test/gpr_2413_test.ml b/jscomp/test/gpr_2413_test.ml new file mode 100644 index 00000000000..20ea5c2e178 --- /dev/null +++ b/jscomp/test/gpr_2413_test.ml @@ -0,0 +1,15 @@ +type inner = + | P of int + | S of int + + type outer = + | A of inner + | B of inner + | C of inner + + let f = function + (* These cause unreachable code *) + | A P a -> a + a + | A S a -> a - a + (* These don't, because there's commonality between them *) + | B P a | B S a | C P a | C S a -> a * a \ No newline at end of file diff --git a/lib/whole_compiler.d b/lib/whole_compiler.d index 7186d0bade4..b319a576754 100644 --- a/lib/whole_compiler.d +++ b/lib/whole_compiler.d @@ -492,6 +492,7 @@ ../lib/whole_compiler.ml : ./syntax/ast_tuple_pattern_flatten.mli ../lib/whole_compiler.ml : ./core/js_pass_flatten_and_mark_dead.ml ../lib/whole_compiler.ml : ./outcome_printer/outcome_printer_ns.ml +../lib/whole_compiler.ml : ./outcome_printer/reason_syntax_util.ml ../lib/whole_compiler.ml : ./core/js_pass_flatten_and_mark_dead.mli ../lib/whole_compiler.ml : ./outcome_printer/outcome_printer_ns.mli ../lib/whole_compiler.ml : ./outcome_printer/tweaked_reason_oprint.ml diff --git a/lib/whole_compiler.ml b/lib/whole_compiler.ml index d008eb21650..c472629f273 100644 --- a/lib/whole_compiler.ml +++ b/lib/whole_compiler.ml @@ -63570,8 +63570,8 @@ and variable_declaration = { } and 'a case_clause = { - case : 'a ; - body : block * bool ; (* true means break *) + switch_case : 'a ; + switch_body : block * bool ; (* true means break *) } (* TODO: For efficency: block should not be a list, it should be able to @@ -69944,7 +69944,7 @@ class virtual fold = {[ goto : label option ; ]} *) 'a. ('self_type -> 'a -> 'self_type) -> 'a case_clause -> 'self_type = - fun _f_a { case = _x; body = _x_i1 } -> + fun _f_a { switch_case = _x; switch_body = _x_i1 } -> let o = _f_a o _x in let o = (fun (_x, _x_i1) -> let o = o#block _x in let o = o#bool _x_i1 in o) @@ -73495,7 +73495,8 @@ let int_switch ?comment ?declaration ?default (e : J.expression) clauses : t let continuation = begin match Ext_list.find_opt (fun (x : _ J.case_clause) -> - if x.case = (Int32.to_int i) then Some (fst x.body) else None ) clauses + if x.switch_case = (Int32.to_int i) then + Some (fst x.switch_body) else None ) clauses with | Some case -> case | None -> @@ -73532,8 +73533,8 @@ let string_switch ?comment ?declaration ?default (e : J.expression) clauses : let continuation = begin match Ext_list.find_opt (fun (x : string J.case_clause) -> - if x.case = s then - Some (fst x.body) + if x.switch_case = s then + Some (fst x.switch_body) else None ) clauses with @@ -84563,7 +84564,7 @@ and pp_function method_ and output_one : 'a . _ -> P.t -> (P.t -> 'a -> unit) -> 'a J.case_clause -> _ = fun cxt f pp_cond - ({case = e; body = (sl,break)} : _ J.case_clause) -> + ({switch_case = e; switch_body = (sl,should_break)} : _ J.case_clause) -> let cxt = P.group f 1 @@ fun _ -> P.group f 1 @@ (fun _ -> @@ -84582,7 +84583,7 @@ and output_one : 'a . P.newline f ; statement_list false cxt f sl in - (if break then + (if should_break then begin P.newline f ; P.string f L.break; @@ -88097,7 +88098,8 @@ let to_break_block (x : t) : J.block * bool = TODO: check if it has side efects *) | { value = None; finished } -> - block, (match finished with | True -> false | (False | Dummy) -> true ) + block, + (match finished with | True -> false | (False | Dummy) -> true ) | {value = Some _ as opt; _} -> block_with_opt_expr block opt, true @@ -88740,13 +88742,13 @@ class virtual map = *) 'a 'a_out. ('self_type -> 'a -> 'a_out) -> 'a case_clause -> 'a_out case_clause = - fun _f_a { case = _x; body = _x_i1 } -> + fun _f_a { switch_case = _x; switch_body = _x_i1 } -> let _x = _f_a o _x in let _x_i1 = (fun (_x, _x_i1) -> let _x = o#block _x in let _x_i1 = o#bool _x_i1 in (_x, _x_i1)) _x_i1 - in { case = _x; body = _x_i1; } + in { switch_case = _x; switch_body = _x_i1; } method block : block -> block = (* true means break *) (* TODO: For efficency: block should not be a list, it should be able to be concatenated in both ways @@ -93651,8 +93653,8 @@ let eval (arg : J.expression) (dispatches : (int * string) list ) : E.t = E.of_block [(S.int_switch arg (Ext_list.map (fun (i,r) -> - {J.case = i ; - body = [S.return_stmt (E.str r)], + {J.switch_case = i ; + switch_body = [S.return_stmt (E.str r)], false (* FIXME: if true, still print break*) }) dispatches))] @@ -93669,8 +93671,8 @@ let eval_as_event (arg : J.expression) (dispatches : (int * string) list ) = (E.of_block [(S.int_switch (E.index arg 0l) (Ext_list.map (fun (i,r) -> - {J.case = i ; - body = [S.return_stmt (E.str r)], + {J.switch_case = i ; + switch_body = [S.return_stmt (E.str r)], false (* FIXME: if true, still print break*) }) dispatches))] , (* TODO: improve, one dispatch later, @@ -93684,7 +93686,7 @@ let eval_as_event (arg : J.expression) (dispatches : (int * string) list ) = Solution: calcuate the arg once in the beginning 2. avoid block for branches < 3 or always? - a === 444? "a" : + a === 444? "a" : a==222? "b" *) (* we need destruct [undefined] when input is optional *) @@ -93697,8 +93699,8 @@ let eval_as_int (arg : J.expression) (dispatches : (int * int) list ) : E.t = E.of_block [(S.int_switch arg (Ext_list.map (fun (i,r) -> - {J.case = i ; - body = [S.return_stmt (E.int (Int32.of_int r))], + {J.switch_case = i ; + switch_body = [S.return_stmt (E.int (Int32.of_int r))], false (* FIXME: if true, still print break*) }) dispatches))] @@ -97849,10 +97851,10 @@ and compile_general_cases : |> Ext_list.map_last (fun last (x,lam) -> if last - then {J.case = x; - body = + then {J.switch_case = x; + switch_body = Js_output.to_break_block (compile_lambda cxt lam) } - else { case = x; body = [],false })) + else { switch_case = x; switch_body = [],false })) (* TODO: we should also group default *) (* The last clause does not need [break] common break through, *) @@ -116698,6 +116700,161 @@ let out_ident ppf s = +end +module Reason_syntax_util += struct +#1 "reason_syntax_util.ml" +(* Hello! Welcome to the Reason syntax util logic. + + This file's shared between the Reason repo and the BuckleScript repo. In + Reason, it's in src/reason-parser. In BuckleScript, it's in + jscomp/outcome_printer. We periodically copy this file from Reason (the source + of truth) to BuckleScript, then uncomment the #if #else #end cppo macros you + see in the file. That's because BuckleScript's on OCaml 4.02 while Reason's on + 4.04; so the #if macros surround the pieces of code that are different between + the two compilers. + + When you modify this file, please make sure you're not dragging in too many + things. You don't necessarily have to test the file on both Reason and + BuckleScript; ping @chenglou and a few others and we'll keep them synced up by + patching the right parts, through the power of types(tm) +*) + + + +open Asttypes +open Ast_mapper +open Parsetree +open Longident + +(** Check to see if the string `s` is made up of `keyword` and zero or more + trailing `_` characters. *) +let potentially_conflicts_with ~keyword s = + let s_length = String.length s in + let keyword_length = String.length keyword in + (* It can't be a match if s is shorter than keyword *) + s_length >= keyword_length && ( + try + (* Ensure s starts with keyword... *) + for i = 0 to keyword_length - 1 do + if keyword.[i] <> s.[i] then raise Exit; + done; + (* ...and contains nothing else except trailing _ characters *) + for i = keyword_length to s_length - 1 do + if s.[i] <> '_' then raise Exit; + done; + (* If we've made it this far there's a potential conflict *) + true + with + | Exit -> false + ) + +(** Add/remove an appropriate suffix when mangling potential keywords *) +let string_add_suffix x = x ^ "_" +let string_drop_suffix x = String.sub x 0 (String.length x - 1) + +(** What do these *_swap functions do? Here's an example: Reason code uses `!` + for logical not, while ocaml uses `not`. So, for converting between reason + and ocaml syntax, ocaml `not` converts to `!`, reason `!` converts to + `not`. + + In more complicated cases where a reserved keyword exists in one syntax but + not the other, these functions translate any potentially conflicting + identifier into the same identifier with a suffix attached, or remove the + suffix when converting back. Two examples: + + reason to ocaml: + + pub: invalid in reason to begin with + pub_: pub + pub__: pub_ + + ocaml to reason: + + pub: pub_ + pub_: pub__ + pub__: pub___ + + ===== + + reason to ocaml: + + match: match_ + match_: match__ + match__: match___ + + ocaml to reason: + + match: invalid in ocaml to begin with + match_: match + match__: match_ +*) + +let reason_to_ml_swap = function + | "!" -> "not" + | "^" -> "!" + | "++" -> "^" + | "===" -> "==" + | "==" -> "=" + (* ===\/ and !==\/ are not representable in OCaml but + * representable in Reason + *) + | "\\!==" -> "!==" + | "\\===" -> "===" + | "!=" -> "<>" + | "!==" -> "!=" + | x when ( + potentially_conflicts_with ~keyword:"match" x + || potentially_conflicts_with ~keyword:"method" x + || potentially_conflicts_with ~keyword:"private" x) -> string_add_suffix x + | x when ( + potentially_conflicts_with ~keyword:"switch_" x + || potentially_conflicts_with ~keyword:"pub_" x + || potentially_conflicts_with ~keyword:"pri_" x) -> string_drop_suffix x + | everything_else -> everything_else + +let ml_to_reason_swap = function + | "not" -> "!" + | "!" -> "^" + | "^" -> "++" + | "==" -> "===" + | "=" -> "==" + (* ===\/ and !==\/ are not representable in OCaml but + * representable in Reason + *) + | "!==" -> "\\!==" + | "===" -> "\\===" + | "<>" -> "!=" + | "!=" -> "!==" + | x when ( + potentially_conflicts_with ~keyword:"match_" x + || potentially_conflicts_with ~keyword:"method_" x + || potentially_conflicts_with ~keyword:"private_" x) -> string_drop_suffix x + | x when ( + potentially_conflicts_with ~keyword:"switch" x + || potentially_conflicts_with ~keyword:"pub" x + || potentially_conflicts_with ~keyword:"pri" x) -> string_add_suffix x + | everything_else -> everything_else + +let escape_string str = + let buf = Buffer.create (String.length str) in + String.iter (fun c -> + match c with + | '\t' -> Buffer.add_string buf "\\t" + | '\r' -> Buffer.add_string buf "\\r" + | '\n' -> Buffer.add_string buf "\\n" + | '\\' -> Buffer.add_string buf "\\\\" + | '"' -> Buffer.add_string buf "\\\"" + | c when c < ' ' -> Buffer.add_string buf (Char.escaped c) + | c -> Buffer.add_char buf c + ) str; + Buffer.contents buf + +(* the stuff below contains side-effects and are not used by BuckleScript's + vendored version of reason_syntax_util.ml. So we can neglect it *) + + + end module Tweaked_reason_oprint = struct @@ -116728,12 +116885,12 @@ module Tweaked_reason_oprint (* This file's shared between the Reason repo and the BuckleScript repo. In - Reason, it's in src/reason_oprint.ml. In BuckleScript, it's in - jscomp/outcome_printer/tweaked_reason_oprint.ml. We periodically copy - this file from Reason (the source of truth) to BuckleScript, then uncomment - the #if #else #end cppo macros you see in the file. That's because - BuckleScript's on OCaml 4.02 while Reason's on 4.04; so the #if macros - surround the pieces of code that are different between the two compilers. + Reason, it's in src/reason-parser/. In BuckleScript, it's in + jscomp/outcome_printer/. We periodically copy this file from Reason (the + source of truth) to BuckleScript, then uncomment the #if #else #end cppo + macros you see in the file. That's because BuckleScript's on OCaml 4.02 while + Reason's on 4.04; so the #if macros surround the pieces of code that are + different between the two compilers. When you modify this file, please make sure you're not dragging in too many things. You don't necessarily have to test the file on both Reason and @@ -116770,62 +116927,9 @@ let parenthesized_ident name = false | _ -> true) - - -(* please keep this section in sync with Reason repo's Syntax_util file's - helpers of the same names *) - -let string_add_suffix x = x ^ "_" -let string_drop_suffix x = String.sub x 0 (String.length x - 1) -(** Check to see if the string `s` is made up of `keyword` and zero or more - trailing `_` characters. *) -let potentially_conflicts_with ~keyword s = - let s_length = String.length s in - let keyword_length = String.length keyword in - (* It can't be a match if s is shorter than keyword *) - s_length >= keyword_length && ( - try - (* Ensure s starts with keyword... *) - for i = 0 to keyword_length - 1 do - if keyword.[i] <> s.[i] then raise Exit; - done; - (* ...and contains nothing else except trailing _ characters *) - for i = keyword_length to s_length - 1 do - if s.[i] <> '_' then raise Exit; - done; - (* If we've made it this far there's a potential conflict *) - true - with - | Exit -> false - ) -let ml_to_reason_swap = function - | "not" -> "!" - | "!" -> "^" - | "^" -> "++" - | "==" -> "===" - | "=" -> "==" - (* ===\/ and !==\/ are not representable in OCaml but - * representable in Reason - *) - | "!==" -> "\\!==" - | "===" -> "\\===" - | "<>" -> "!=" - | "!=" -> "!==" - | x when ( - potentially_conflicts_with ~keyword:"match_" x - || potentially_conflicts_with ~keyword:"method_" x - || potentially_conflicts_with ~keyword:"private_" x) -> string_drop_suffix x - | x when ( - potentially_conflicts_with ~keyword:"switch" x - || potentially_conflicts_with ~keyword:"pub" x - || potentially_conflicts_with ~keyword:"pri" x) -> string_add_suffix x - | everything_else -> everything_else - - - let value_ident ppf name = if parenthesized_ident name then - fprintf ppf "( %s )" (ml_to_reason_swap name) + fprintf ppf "( %s )" (Reason_syntax_util.ml_to_reason_swap name) else pp_print_string ppf name @@ -116897,7 +117001,7 @@ let print_out_value ppf tree = | Oval_float f -> pp_print_string ppf (float_repres f) | Oval_char c -> fprintf ppf "%C" c | Oval_string s -> - begin try fprintf ppf "%S" s with + begin try fprintf ppf "\"%s\"" (Reason_syntax_util.escape_string s) with Invalid_argument "String.create" -> fprintf ppf "" end | Oval_list tl -> @@ -117217,10 +117321,9 @@ and print_typargs ppf = print_out_wrap_type ppf ty1; pp_print_string ppf ")" | tyl -> - pp_print_space ppf (); pp_print_string ppf "("; pp_open_box ppf 1; - print_typlist print_out_wrap_type ", " ppf tyl; + print_typlist print_out_wrap_type "," ppf tyl; pp_close_box ppf (); pp_print_string ppf ")" @@ -117820,6 +117923,8 @@ let message (warning : Warnings.t) = "This file's name is potentially invalid. The build systems conventionally turn a file name into a module name by upper-casing the first letter. " ^ modname ^ " isn't a valid module name.\n" ^ "Note: some build systems might e.g. turn kebab-case into CamelCase module, which is why this isn't a hard error." | Statement_type -> "This expression returns a value, but you're not doing anything with it. If this is on purpose, put `|> ignore` at the end." + | Useless_record_with -> + "All the fields are already explicitly listed in this record. You can remove the `...` spread." | _ -> Warnings.message warning ;; @@ -118471,8 +118576,19 @@ let report_error env ppf = function type_expr typ; fprintf ppf "@ @[It only accepts %i %s; here, it's called with more.@]@]" acceptsCount (if acceptsCount == 1 then "argument" else "arguments") - | Tconstr ((Path.Pdot (((Pdot (Path.Pident {name="Js"}, "Internal", _))| (Pident {name="Js_internal"})), ("fn" | "meth"), _)), _, _) - -> fprintf ppf "This is an uncurried bucklescript function. It must be applied with [@bs]." + | Tconstr ( + (Path.Pdot (((Pdot (Path.Pident {name="Js"}, "Internal", _)) | (Pident {name="Js_internal"})), ("fn" | "meth"), _)), + _, + _ + ) + -> + fprintf + ppf + "@[This is an uncurried BuckleScript function. @{It must be applied with a dot@}.@,@,\ + Like this: @{foo(. a, b)@}@,\ + Not like this: @{foo(a, b)@}@,@,\ + This guarantees that your function is fully applied. More info here:@,\ + https://bucklescript.github.io/docs/en/function.html#solution-guaranteed-uncurrying@]" | _ -> fprintf ppf "@[@[<2>This expression has type@ %a@]@ %s@]" type_expr typ From f674f518f909338c15f081d1fc72cf6740d7c278 Mon Sep 17 00:00:00 2001 From: Hongbo Zhang Date: Thu, 15 Mar 2018 23:04:13 +0800 Subject: [PATCH 2/8] tweaks --- jscomp/core/js_dump.ml | 47 +- jscomp/core/lam_compile.ml | 1269 +++++++++++++++++----------------- lib/whole_compiler.ml | 1316 ++++++++++++++++++------------------ 3 files changed, 1340 insertions(+), 1292 deletions(-) diff --git a/jscomp/core/js_dump.ml b/jscomp/core/js_dump.ml index c9c9fb7c414..cfac82e4cc9 100644 --- a/jscomp/core/js_dump.ml +++ b/jscomp/core/js_dump.ml @@ -361,30 +361,29 @@ and output_one : 'a . = fun cxt f pp_cond ({switch_case = e; switch_body = (sl,should_break)} : _ J.case_clause) -> let cxt = - P.group f 1 @@ fun _ -> - P.group f 1 @@ (fun _ -> - P.string f L.case; - P.space f ; - pp_cond f e; (* could be integer or string*) - P.space f ; - P.string f L.colon ); - - P.space f; - P.group f 1 @@ fun _ -> - let cxt = - match sl with - | [] -> cxt - | _ -> - P.newline f ; - statement_list false cxt f sl - in - (if should_break then - begin - P.newline f ; - P.string f L.break; - semi f; - end) ; - cxt + P.group f 1 (fun _ -> + P.group f 1 (fun _ -> + P.string f L.case; + P.space f ; + pp_cond f e; (* could be integer or string *) + P.space f ; + P.string f L.colon ); + P.space f; + P.group f 1 (fun _ -> + let cxt = + match sl with + | [] -> cxt + | _ -> + P.newline f ; + statement_list false cxt f sl + in + (if should_break then + begin + P.newline f ; + P.string f L.break; + semi f; + end) ; + cxt)) in P.newline f; cxt diff --git a/jscomp/core/lam_compile.ml b/jscomp/core/lam_compile.ml index 59a7d47bb41..670e89a8189 100644 --- a/jscomp/core/lam_compile.ml +++ b/jscomp/core/lam_compile.ml @@ -1,5 +1,5 @@ (* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -17,44 +17,44 @@ * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -module E = Js_exp_make +module E = Js_exp_make -module S = Js_stmt_make +module S = Js_stmt_make let method_cache_id = ref 1 (*TODO: move to js runtime for re-entrant *) (* assume outer is [Lstaticcatch] *) let rec flat_catches acc (x : Lam.t) - : (int * Lam.t * Ident.t list ) list * Lam.t = - match x with - | Lstaticcatch(l, (code, bindings), handler) - when + : (int * Lam.t * Ident.t list ) list * Lam.t = + match x with + | Lstaticcatch(l, (code, bindings), handler) + when acc = [] || - (not @@ Lam_exit_code.has_exit_code + (not @@ Lam_exit_code.has_exit_code (fun exit -> List.exists (fun (c,_,_) -> c = exit) acc) handler) -> (* #1698 should not crush exit code here without checking *) flat_catches ((code,handler,bindings)::acc) l | _ -> acc, x -let flatten_caches x : (int * Lam.t * Ident.t list ) list * Lam.t = - flat_catches [] x +let flatten_caches x : (int * Lam.t * Ident.t list ) list * Lam.t = + flat_catches [] x (* TODO: - for expression generation, + for expression generation, name, should_return is not needed, only jmp_table and env needed *) -type default_case = +type default_case = | Default of Lam.t | Complete | NonComplete @@ -65,76 +65,76 @@ type default_case = (* E.index m (pos + 1) *) (** shift by one *) (** This can not happen since this id should be already consulted by type checker *) (** We drop the ability of cross-compiling - the compiler has to be the same running -*) -(* since it's only for alias, there is no arguments, + the compiler has to be the same running +*) +(* since it's only for alias, there is no arguments, we should not inline function definition here, even though - it is very small - TODO: add comment here, we should try to add comment for - cross module inlining + it is very small + TODO: add comment here, we should try to add comment for + cross module inlining - if we do too agressive inlining here: + if we do too agressive inlining here: - if we inline {!List.length} which will call {!A_list.length}, - then we if we try inline {!A_list.length}, this means if {!A_list} + if we inline {!List.length} which will call {!A_list.length}, + then we if we try inline {!A_list.length}, this means if {!A_list} is rebuilt, this module should also be rebuilt, - But if the build system is content-based, suppose {!A_list} - is changed, cmj files in {!List} is unchnaged, however, + But if the build system is content-based, suppose {!A_list} + is changed, cmj files in {!List} is unchnaged, however, {!List.length} call {!A_list.length} which is changed, since - [ocamldep] only detect that we depend on {!List}, it will not - get re-built, then we are screwed. + [ocamldep] only detect that we depend on {!List}, it will not + get re-built, then we are screwed. This is okay for stamp based build system. Another solution is that we add dependencies in the compiler - -: we should not do functor application inlining in a - non-toplevel, it will explode code very quickly -*) -let rec + -: we should not do functor application inlining in a + non-toplevel, it will explode code very quickly +*) +let rec compile_external_field (* Like [List.empty]*) - (cxt : Lam_compile_context.t) + (cxt : Lam_compile_context.t) (lam : Lam.t) (id : Ident.t) (pos : int) (env : Env.t) - : Js_output.t = - let f = Js_output.output_of_expression cxt.st cxt.should_return lam in - match Lam_compile_env.cached_find_ml_id_pos id pos env with + : Js_output.t = + let f = Js_output.output_of_expression cxt.st cxt.should_return lam in + match Lam_compile_env.cached_find_ml_id_pos id pos env with | {id; name; closed_lambda } -> - match id, name, closed_lambda with + match id, name, closed_lambda with | {name = "Sys"; _}, "os_type" , _ - -> f (E.str Sys.os_type) - | _, _, Some lam + -> f (E.str Sys.os_type) + | _, _, Some lam when Lam_util.not_function lam - -> + -> compile_lambda cxt lam - | _ -> + | _ -> f (E.ml_var_dot id name) (* TODO: how nested module call would behave, - In the future, we should keep in track of if + In the future, we should keep in track of if it is fully applied from [Lapply] Seems that the module dependency is tricky.. should we depend on [Pervasives] or not? - we can not do this correctly for the return value, + we can not do this correctly for the return value, however we can inline the definition in Pervasives TODO: [Pervasives.print_endline] [Pervasives.prerr_endline] - @param id external module id - @param number the index of the external function + @param id external module id + @param number the index of the external function @param env typing environment - @param args arguments + @param args arguments *) -(** This can not happen since this id should be already consulted by type checker - Worst case +(** This can not happen since this id should be already consulted by type checker + Worst case {[ - E.index m pos + E.index m pos ]} *) (* when module is passed as an argument - unpack to an array @@ -142,51 +142,51 @@ let rec however it can not be global -- global can only module *) -and compile_external_field_apply - (cxt : Lam_compile_context.t) +and compile_external_field_apply + (cxt : Lam_compile_context.t) (lam : Lam.t) (* original lambda*) (args_lambda : Lam.t list) (id : Ident.t) (pos : int) - (env : Env.t) : Js_output.t = + (env : Env.t) : Js_output.t = match - Lam_compile_env.cached_find_ml_id_pos + Lam_compile_env.cached_find_ml_id_pos id pos env - with - | {id; name;arity; closed_lambda ; _} -> - let args_code, args = - Ext_list.fold_right + with + | {id; name;arity; closed_lambda ; _} -> + let args_code, args = + Ext_list.fold_right (fun (x : Lam.t) (args_code, args) -> match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} x with - | {block = a; value = Some b} -> + | {block = a; value = Some b} -> (Ext_list.append a args_code), (b :: args ) | _ -> assert false ) args_lambda ([], []) in - match closed_lambda with - | Some (Lfunction{ params; body; _}) - when Ext_list.same_length params args_lambda -> + match closed_lambda with + | Some (Lfunction{ params; body; _}) + when Ext_list.same_length params args_lambda -> (* TODO: serialize it when exporting to save compile time *) - let (_, param_map) = + let (_, param_map) = Lam_closure.is_closed_with_map Ident_set.empty params body in - compile_lambda cxt + compile_lambda cxt (Lam_beta_reduce.propogate_beta_reduce_with_map cxt.meta param_map params body args_lambda) | _ -> let rec aux (acc : J.expression) (arity : Lam_arity.t) args (len : int) = match arity, len with - | _, 0 -> + | _, 0 -> acc (** All arguments consumed so far *) | Determin (a, (x,_) :: rest, b), len -> - let x = - if x = 0 - then 1 + let x = + if x = 0 + then 1 else x in (* Relax when x = 0 *) - if len >= x + if len >= x then let first_part, continue = Ext_list.split_at x args in aux @@ -194,10 +194,10 @@ and compile_external_field_apply (Determin (a, rest, b)) continue (len - x) else (* GPR #1423 *) - if List.for_all Js_analyzer.is_okay_to_duplicate args then + if List.for_all Js_analyzer.is_okay_to_duplicate args then let params = Ext_list.init (x - len) (fun _ -> Ext_ident.create "param") in - E.ocaml_fun params + E.ocaml_fun params [S.return_stmt (E.call ~info:{arity=Full; call_info=Call_ml} acc (Ext_list.append args @@ Ext_list.map E.var params))] else E.call ~info:Js_call_info.dummy acc args @@ -215,105 +215,105 @@ and compile_external_field_apply cxt.should_return lam args_code - ( + ( aux - (E.ml_var_dot id name) + (E.ml_var_dot id name) (match arity with Single x -> x | Submodule _ -> NA) args (List.length args )) -and compile_let +and compile_let (let_kind : Lam_compile_context.let_kind) (cxt : Lam_compile_context.t) (id : J.ident) (arg : Lam.t) : Js_output.t = compile_lambda - {cxt with st = Declare (let_kind, id); should_return = ReturnFalse } arg -(** - The second return values are values which need to be wrapped using - [caml_update_dummy] + {cxt with st = Declare (let_kind, id); should_return = ReturnFalse } arg +(** + The second return values are values which need to be wrapped using + [caml_update_dummy] Invariant: jmp_table can not across function boundary, - here we share env + here we share env *) and compile_recursive_let ~all_bindings (cxt : Lam_compile_context.t) (id : Ident.t) - (arg : Lam.t) : Js_output.t * Ident.t list = - match arg with - | Lfunction { function_kind; params; body; _} -> + (arg : Lam.t) : Js_output.t * Ident.t list = + match arg with + | Lfunction { function_kind; params; body; _} -> let continue_label = Lam_util.generate_label ~name:id.name () in - (* TODO: Think about recursive value + (* TODO: Think about recursive value {[ - let rec v = ref (fun _ ... + let rec v = ref (fun _ ... ) ]} - [Alias] may not be exact + [Alias] may not be exact *) - let ret : Lam_compile_context.return_label = - { id; - label = continue_label; + let ret : Lam_compile_context.return_label = + { id; + label = continue_label; params; immutable_mask = Array.make (List.length params) true; new_params = Ident_map.empty; triggered = false } in - let output = + let output = compile_lambda - { cxt with - st = EffectCall; + { cxt with + st = EffectCall; should_return = ReturnTrue (Some ret ); jmp_table = Lam_compile_context.empty_handler_map} body in - let result = - if ret.triggered then + let result = + if ret.triggered then let body_block = Js_output.output_as_block output in E.ocaml_fun - (* TODO: save computation of length several times - Here we always create [ocaml_fun], - it will be renamed into [method] + (* TODO: save computation of length several times + Here we always create [ocaml_fun], + it will be renamed into [method] when it is detected by a primitive *) ~immutable_mask:ret.immutable_mask - (Ext_list.map (fun x -> + (Ext_list.map (fun x -> Ident_map.find_default x ret.new_params x ) params) [ S.while_ (* ~label:continue_label *) - E.caml_true + E.caml_true ( Ident_map.fold (fun old new_param acc -> - S.define_variable ~kind:Alias old (E.var new_param) :: acc) + S.define_variable ~kind:Alias old (E.var new_param) :: acc) ret.new_params body_block ) ] else (* TODO: save computation of length several times *) E.ocaml_fun params (Js_output.output_as_block output ) - in + in Js_output.output_of_expression (Declare (Alias, id)) - ReturnFalse arg result, [] + ReturnFalse arg result, [] | Lprim {primitive = Pmakeblock (0, _, _) ; args = ls} - when List.for_all (fun (x : Lam.t) -> - match x with - | Lvar pid -> - Ident.same pid id || + when List.for_all (fun (x : Lam.t) -> + match x with + | Lvar pid -> + Ident.same pid id || (not @@ List.exists (fun (other,_) -> Ident.same other pid ) all_bindings) - | _ -> false) ls + | _ -> false) ls -> (* capture cases like for {!Queue} {[let rec cell = { content = x; next = cell} ]} #1716: be careful not to optimize such cases: - {[ let rec a = { b} and b = { a} ]} they are indeed captured - and need to be declared first + {[ let rec a = { b} and b = { a} ]} they are indeed captured + and need to be declared first *) Js_output.make ( - S.define_variable ~kind:Variable id (E.array Mutable []) :: - (List.mapi (fun i (x : Lam.t) -> - match x with + S.define_variable ~kind:Variable id (E.array Mutable []) :: + (List.mapi (fun i (x : Lam.t) -> + match x with | Lvar lid - -> S.exp + -> S.exp (Js_arr.set_array (E.var id) (E.int (Int32.of_int i)) (E.var lid)) | _ -> assert false ) ls) @@ -323,140 +323,152 @@ and compile_recursive_let ~all_bindings (* FIXME: also should fill tag *) (* Lconst should not appear here if we do [scc] optimization, since it's faked recursive value, - however it would affect scope issues, we have to declare it first + however it would affect scope issues, we have to declare it first *) (* Ext_log.err "@[recursive value %s/%d@]@." id.name id.stamp; *) begin match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse } arg with - | { block = b; value = Some v} -> - (* TODO: check recursive value .. + | { block = b; value = Some v} -> + (* TODO: check recursive value .. could be improved for simple cases *) - Js_output.make + Js_output.make (Ext_list.append - b + b [S.exp - (E.runtime_call Js_runtime_modules.obj_runtime "caml_update_dummy" + (E.runtime_call Js_runtime_modules.obj_runtime "caml_update_dummy" [ E.var id; v])]), [id] (* S.define ~kind:Variable id (E.arr Mutable []):: *) - | _ -> assert false + | _ -> assert false end | Lvar _ -> compile_lambda {cxt with st = Declare (Alias ,id); should_return = ReturnFalse } arg, [] - | _ -> + | _ -> (* pathological case: fail to capture taill call? - {[ let rec a = + {[ let rec a = if g > 30 then .. fun () -> a () ]} Neither below is not allowed in ocaml: {[ - let rec v = - if sum 0 10 > 20 then - 1::v + let rec v = + if sum 0 10 > 20 then + 1::v else 2:: v ]} {[ - let rec v = - if sum 0 10 > 20 then + let rec v = + if sum 0 10 > 20 then fun _ -> print_endline "hi"; v () - else + else fun _-> print_endline "hey"; v () ]} *) compile_lambda {cxt with st = Declare (Alias ,id); should_return = ReturnFalse } arg, [] -and compile_recursive_lets_aux cxt id_args : Js_output.t = +and compile_recursive_lets_aux cxt id_args : Js_output.t = (* #1716 *) let output_code, ids = Ext_list.fold_right - (fun (ident,arg) (acc, ids) -> + (fun (ident,arg) (acc, ids) -> let code, declare_ids = compile_recursive_let ~all_bindings:id_args cxt ident arg in (Js_output.append_output code acc, Ext_list.append declare_ids ids ) ) id_args (Js_output.dummy, []) in - match ids with + match ids with | [] -> output_code - | _ -> - Js_output.append_output - (Js_output.make - (Ext_list.map - (fun id -> S.define_variable ~kind:Variable id (E.dummy_obj ())) + | _ -> + Js_output.append_output + (Js_output.make + (Ext_list.map + (fun id -> S.define_variable ~kind:Variable id (E.dummy_obj ())) ids ) ) output_code -and compile_recursive_lets cxt id_args : Js_output.t = +and compile_recursive_lets cxt id_args : Js_output.t = - match id_args with + match id_args with | [ ] -> Js_output.dummy - | _ -> - let id_args_group = Lam.scc_bindings id_args in - begin match id_args_group with - | [ ] -> assert false + | _ -> + let id_args_group = Lam.scc_bindings id_args in + begin match id_args_group with + | [ ] -> assert false | first::rest -> - let acc = compile_recursive_lets_aux cxt first in + let acc = compile_recursive_lets_aux cxt first in List.fold_left (fun acc x -> Js_output.append_output - acc (compile_recursive_lets_aux cxt x )) acc rest - end -and compile_general_cases : - 'a . + acc (compile_recursive_lets_aux cxt x )) acc rest + end +and compile_general_cases + : + 'a . ('a -> J.expression) -> - (J.expression -> J.expression -> J.expression) -> - Lam_compile_context.t -> + (J.expression -> J.expression -> J.expression) -> + Lam_compile_context.t -> (?default:J.block -> - ?declaration:Lam.let_kind * Ident.t -> - _ -> 'a J.case_clause list -> J.statement) -> - _ -> - ('a * Lam.t) list -> default_case -> J.block - = fun f eq cxt switch v table default -> + ?declaration:Lam.let_kind * Ident.t -> + _ -> 'a J.case_clause list -> J.statement) -> + _ -> + ('a * Lam.t) list -> default_case -> J.block + = fun + (make_exp : _ -> J.expression) + (eq_exp : J.expression -> J.expression -> J.expression) + (cxt : Lam_compile_context.t) + (switch : + ?default:J.block -> + ?declaration:Lam.let_kind * Ident.t -> + _ -> _ J.case_clause list -> J.statement + ) + (switch_exp : J.expression) + (table : (_ * Lam.t) list) + (default : default_case) -> let wrap (cxt : Lam_compile_context.t) k = let cxt, define = - match cxt.st with + match cxt.st with | Declare (kind, did) - -> + -> {cxt with st = Assign did}, Some (kind,did) | _ -> cxt, None in - k cxt define + k cxt define in - match table, default with - | [], Default lam -> + match table, default with + | [], Default lam -> Js_output.output_as_block (compile_lambda cxt lam) | [], (Complete | NonComplete) -> [] - | [(id,lam)],Complete -> - (* To take advantage of such optimizations, - when we generate code using switch, + | [(id,lam)],Complete -> + (* To take advantage of such optimizations, + when we generate code using switch, we should always have a default, - otherwise the compiler engine would think that + otherwise the compiler engine would think that it's also complete *) - Js_output.output_as_block @@ compile_lambda cxt lam - | [(id,lam)], NonComplete + Js_output.output_as_block (compile_lambda cxt lam) + | [(id,lam)], NonComplete -> wrap cxt @@ fun cxt define -> - [S.if_ ?declaration:define (eq v (f id) ) + [S.if_ ?declaration:define (eq_exp switch_exp (make_exp id) ) (Js_output.output_as_block @@ compile_lambda cxt lam )] | ([(id,lam)], Default x) | ([(id,lam); (_,x)], Complete) -> - wrap cxt @@ fun cxt define -> + wrap cxt @@ fun cxt define -> let else_block = Js_output.output_as_block (compile_lambda cxt x) in let then_block = Js_output.output_as_block (compile_lambda cxt lam) in - [ S.if_ ?declaration:define (eq v (f id) ) + [ S.if_ ?declaration:define (eq_exp switch_exp (make_exp id) ) then_block ~else_:else_block ] - | _ , _ -> + | _ , _ -> (* TODO: this is not relevant to switch case - however, in a subset of switch-case if we can analysis - its branch are the same, we can propogate which + however, in a subset of switch-case if we can analysis + its branch are the same, we can propogate which might encourage better inlining strategey --- TODO: grouping can be delayed untile JS IR @@ -469,17 +481,17 @@ and compile_general_cases : | NonComplete -> None | Default lam -> Some (Js_output.output_as_block (compile_lambda cxt lam)) in - let body = - table + let body = + table |> Ext_list.stable_group (fun (_,lam) (_,lam1) -> Lam_analysis.eq_lambda lam lam1) - |> Ext_list.flat_map - (fun group -> - group - |> Ext_list.map_last - (fun last (x,lam) -> - if last + |> Ext_list.flat_map + (fun group -> + group + |> Ext_list.map_last + (fun last (x,lam) -> + if last then {J.switch_case = x; switch_body = Js_output.to_break_block (compile_lambda cxt lam) } @@ -489,72 +501,85 @@ and compile_general_cases : common break through, *) in - [switch ?default ?declaration v body] + [switch ?default ?declaration switch_exp body] -and compile_cases cxt = - compile_general_cases (fun x -> E.small_int x) E.int_equal cxt +and compile_cases cxt switch_exp table default = + compile_general_cases + E.small_int + E.int_equal + cxt (fun ?default ?declaration e clauses -> S.int_switch ?default ?declaration e clauses) - -and compile_string_cases cxt = - compile_general_cases E.str E.string_equal cxt + switch_exp + table + default + +and compile_string_cases cxt switch_exp table default = + compile_general_cases + E.str + E.string_equal + cxt (fun ?default ?declaration e clauses -> S.string_switch ?default ?declaration e clauses) -(* TODO: optional arguments are not good + switch_exp + table + default + +(* TODO: optional arguments are not good for high order currying *) and compile_lambda ({st ; should_return; jmp_table; meta = {env ; _} } as cxt : Lam_compile_context.t) (lam : Lam.t) : Js_output.t = begin - match lam with + match lam with | Lfunction{ function_kind; params; body} -> - Js_output.output_of_expression st should_return lam + Js_output.output_of_expression st should_return lam (E.ocaml_fun params (* Invariant: jmp_table can not across function boundary, here we share env *) - (Js_output.output_as_block + (Js_output.output_as_block ( compile_lambda - { cxt with st = EffectCall; + { cxt with st = EffectCall; should_return = ReturnTrue None; (* Refine*) jmp_table = Lam_compile_context.empty_handler_map} body))) | Lapply{ fn = Lapply{ fn = an; args = fn_args; status = App_na ; }; - args; + args; status = App_na; loc } - -> - (* After inlining we can generate such code, - see {!Ari_regress_test} - *) - compile_lambda cxt + -> + (* After inlining we can generate such code, + see {!Ari_regress_test} + *) + compile_lambda cxt (Lam.apply an (Ext_list.append fn_args args) loc App_na ) (* External function calll *) - | Lapply{ fn = - Lprim{primitive = Pfield (n,_); + | Lapply{ fn = + Lprim{primitive = Pfield (n,_); args = [ Lglobal_module id];_}; args = args_lambda; status = App_na | App_ml_full} -> - (* Note we skip [App_js_full] since [get_exp_with_args] dont carry + (* Note we skip [App_js_full] since [get_exp_with_args] dont carry this information, we should fix [get_exp_with_args] *) compile_external_field_apply cxt lam args_lambda id n env - | Lapply{ fn; args = args_lambda; status} -> - (* TODO: --- + | Lapply{ fn; args = args_lambda; status} -> + (* TODO: --- 1. check arity, can be simplified for pure expression 2. no need create names *) - begin - let [@warning "-8" (* non-exhaustive pattern*)] (args_code, fn_code:: args) = - Ext_list.fold_right (fun (x : Lam.t) (args_code, fn_code )-> - match compile_lambda + begin + let [@warning "-8" (* non-exhaustive pattern*)] (args_code, fn_code:: args) = + Ext_list.fold_right (fun (x : Lam.t) (args_code, fn_code )-> + match compile_lambda {cxt with st = NeedValue ; should_return = ReturnFalse} x with - | {block = a; value = Some b} -> Ext_list.append a args_code , b:: fn_code + | {block = a; value = Some b} -> Ext_list.append a args_code , b:: fn_code | _ -> assert false ) (fn::args_lambda) ([],[]) in @@ -567,37 +592,37 @@ and (* Ext_log.err "@[ %s : %a tailcall @]@." cxt.meta.filename Ident.print id; *) ret.triggered <- true; - (* Here we mark [finished] true, since the continuation + (* Here we mark [finished] true, since the continuation does not make sense any more (due to that we have [continue]) - TODO: [finished] is not a meaningful name, we should use [truncate] + TODO: [finished] is not a meaningful name, we should use [truncate] to mean the following statement should be truncated *) - (* - actually, there is no easy way to determin - if the argument depends on an expresion, since + (* + actually, there is no easy way to determin + if the argument depends on an expresion, since it can be a function, then it may depend on anything http://caml.inria.fr/pub/ml-archives/caml-list/2005/02/5727b4ecaaef6a7a350c9d98f5f68432.en.html http://caml.inria.fr/pub/ml-archives/caml-list/2005/02/fe9bc4e23e6dc8c932c8ab34240ff195.en.html *) - (* TODO: use [fold]*) + (* TODO: use [fold]*) let block = args_code @ ( - let (_,assigned_params,new_params) = + let (_,assigned_params,new_params) = List.fold_left2 (fun (i,assigns,new_params) param (arg : J.expression) -> match arg with | {expression_desc = Var (Id x); _} when Ident.same x param -> (i + 1, assigns, new_params) | _ -> - let new_param, m = - match Ident_map.find_opt param ret.new_params with - | None -> + let new_param, m = + match Ident_map.find_opt param ret.new_params with + | None -> ret.immutable_mask.(i)<- false; let v = Ext_ident.create ("_"^param.Ident.name) in - v, (Ident_map.add param v new_params) + v, (Ident_map.add param v new_params) | Some v -> v, new_params in (i+1, (new_param, arg) :: assigns, m) - ) (0, [], Ident_map.empty) params args in + ) (0, [], Ident_map.empty) params args in let () = ret.new_params <- Ident_map.disjoint_merge new_params ret.new_params in assigned_params |> Ext_list.map (fun (param, arg) -> S.assign param arg)) @ @@ -606,19 +631,19 @@ and in begin (* Ext_log.dwarn __LOC__ "size : %d" (List.length block); *) - Js_output.make ~finished:True block + Js_output.make ~finished:True block end - | _ -> + | _ -> - Js_output.output_of_block_and_expression st should_return lam args_code - (E.call ~info:(match fn, status with - | _, App_ml_full -> + Js_output.output_of_block_and_expression st should_return lam args_code + (E.call ~info:(match fn, status with + | _, App_ml_full -> {arity = Full ; call_info = Call_ml} - | _, App_js_full -> + | _, App_js_full -> {arity = Full ; call_info = Call_na} - | _, App_na -> + | _, App_na -> {arity = NA; call_info = Call_ml } - ) fn_code args) + ) fn_code args) end; end @@ -626,71 +651,71 @@ and | Llet (let_kind,id,arg, body) -> (* Order matters.. see comment below in [Lletrec] *) let args_code = - compile_let let_kind cxt id arg in - Js_output.append_output - args_code + compile_let let_kind cxt id arg in + Js_output.append_output + args_code (compile_lambda cxt body) - | Lletrec (id_args, body) -> - (* There is a bug in our current design, + | Lletrec (id_args, body) -> + (* There is a bug in our current design, it requires compile args first (register that some objects are jsidentifiers) and compile body wiht such effect. So here we should compile [id_args] first, then [body] later. Note it has some side effect over cache number as well, mostly the value of [Caml_primitive["caml_get_public_method"](x,hash_tab, number)] - To fix this, + To fix this, 1. scan the lambda layer first, register js identifier before proceeding 2. delay the method call into javascript ast *) - let v = compile_recursive_lets cxt id_args in + let v = compile_recursive_lets cxt id_args in Js_output.append_output v (compile_lambda cxt body) | Lvar id -> Js_output.output_of_expression st should_return lam (E.var id ) - | Lconst c -> + | Lconst c -> Js_output.output_of_expression st should_return lam (Lam_compile_const.translate c) - | Lprim {primitive = Pfield (n,_); - args = [ Lglobal_module id ]; _} + | Lprim {primitive = Pfield (n,_); + args = [ Lglobal_module id ]; _} -> (* should be before Lglobal_global *) compile_external_field cxt lam id n env - | Lprim {primitive = Praise ; args = [ e ]; _} -> + | Lprim {primitive = Praise ; args = [ e ]; _} -> begin match compile_lambda { - cxt with should_return = ReturnFalse; st = NeedValue} e with - | {block = b; value = Some v} -> - Js_output.make + cxt with should_return = ReturnFalse; st = NeedValue} e with + | {block = b; value = Some v} -> + Js_output.make (Ext_list.append b [S.throw_stmt v]) ~value:E.undefined ~finished:True - (* FIXME -- breaks invariant when NeedValue, reason is that js [throw] is statement + (* FIXME -- breaks invariant when NeedValue, reason is that js [throw] is statement while ocaml it's an expression, we should remove such things in lambda optimizations *) - | {value = None; _} -> assert false + | {value = None; _} -> assert false end | Lprim{primitive = Psequand ; args = [l;r] ; _} -> - begin match cxt with - | {should_return = ReturnTrue _ } + begin match cxt with + | {should_return = ReturnTrue _ } (* Invariant: if [should_return], then [st] will not be [NeedValue] *) -> compile_lambda cxt (Lam.sequand l r ) - | {should_return = ReturnFalse } -> + | {should_return = ReturnFalse } -> let new_cxt = {cxt with st = NeedValue} in match - compile_lambda new_cxt l with - | { value = None } -> assert false + compile_lambda new_cxt l with + | { value = None } -> assert false | {block = l_block; value = Some l_expr} -> match compile_lambda new_cxt r with - | { value = None } -> assert false - | {block = []; value = Some r_expr} - -> - Js_output.output_of_block_and_expression - st + | { value = None } -> assert false + | {block = []; value = Some r_expr} + -> + Js_output.output_of_block_and_expression + st should_return lam l_block (E.and_ l_expr r_expr) - | { block = r_block; value = Some r_expr} -> - begin match cxt.st with + | { block = r_block; value = Some r_expr} -> + begin match cxt.st with | Assign v -> (* Refernece Js_output.output_of_block_and_expression *) Js_output.make @@ -702,26 +727,26 @@ and ) | Declare (_kind,v) -> (* Refernece Js_output.output_of_block_and_expression *) - Js_output.make + Js_output.make ( - l_block @ - [ S.define_variable ~kind:Variable v E.caml_false ; - S.if_ l_expr + l_block @ + [ S.define_variable ~kind:Variable v E.caml_false ; + S.if_ l_expr (r_block @ [S.assign v r_expr])]) | EffectCall | NeedValue -> - let v = Ext_ident.create_tmp () in + let v = Ext_ident.create_tmp () in Js_output.make - (S.define_variable ~kind:Variable v E.caml_false :: + (S.define_variable ~kind:Variable v E.caml_false :: l_block @ - [S.if_ l_expr + [S.if_ l_expr (r_block @ [ S.assign v r_expr ] ) ] ) - ~value:(E.var v) + ~value:(E.var v) end end | Lprim {primitive = Psequor; args = [l;r]} @@ -732,31 +757,31 @@ and -> compile_lambda cxt @@ Lam.sequor l r | {should_return = ReturnFalse } -> - let new_cxt = {cxt with st = NeedValue} in + let new_cxt = {cxt with st = NeedValue} in match compile_lambda new_cxt l with | {value = None } -> assert false - | {block = l_block; value = Some l_expr} -> + | {block = l_block; value = Some l_expr} -> match compile_lambda new_cxt r with | {value = None} -> assert false - | {block = []; value = Some r_expr} -> + | {block = []; value = Some r_expr} -> let exp = E.or_ l_expr r_expr in - Js_output.output_of_block_and_expression + Js_output.output_of_block_and_expression st should_return lam l_block exp | {block = r_block; value = Some r_expr} -> - begin match cxt.st with - | Assign v -> + begin match cxt.st with + | Assign v -> (* Reference Js_output.output_of_block_and_expression *) - Js_output.make - (l_block @ + Js_output.make + (l_block @ [ S.if_ (E.not l_expr) (r_block @ [ S.assign v r_expr ]) ~else_:[S.assign v E.caml_true] ]) | Declare(_kind,v) -> - Js_output.make + Js_output.make ( - l_block @ + l_block @ [ S.define_variable ~kind:Variable v E.caml_true; S.if_ (E.not l_expr) (r_block @ [S.assign v r_expr]) @@ -764,9 +789,9 @@ and ) | EffectCall | NeedValue -> - let v = Ext_ident.create_tmp () in + let v = Ext_ident.create_tmp () in Js_output.make - ( l_block @ + ( l_block @ [S.define_variable ~kind:Variable v E.caml_true; S.if_ (E.not l_expr) (r_block @ [ @@ -778,43 +803,43 @@ and end end | Lprim {primitive = Pdebugger ; _} - -> - (* [%bs.debugger] guarantees that the expression does not matter + -> + (* [%bs.debugger] guarantees that the expression does not matter TODO: make it even safer *) - Js_output.output_of_block_and_expression st should_return lam + Js_output.output_of_block_and_expression st should_return lam S.debugger_block E.unit - (* TODO: - check the arity of fn before wrapping it - we need mark something that such eta-conversion can not be simplified in some cases + (* TODO: + check the arity of fn before wrapping it + we need mark something that such eta-conversion can not be simplified in some cases *) - | Lprim {primitive = Pjs_unsafe_downgrade (name,loc); + | Lprim {primitive = Pjs_unsafe_downgrade (name,loc); args = [obj]} - when not (Ext_string.ends_with name Literals.setter_suffix) - -> + when not (Ext_string.ends_with name Literals.setter_suffix) + -> (** either a getter {[ x #. height ]} or {[ x ## method_call ]} *) let property = Lam_methname.translate ~loc name in - begin + begin match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} obj - with - | {block; value = Some b } -> - let blocks, ret = + with + | {block; value = Some b } -> + let blocks, ret = if block = [] then [], E.dot b property - else - (match Js_ast_util.named_expression b with + else + (match Js_ast_util.named_expression b with | None -> block, E.dot b property - | Some (x, b) -> + | Some (x, b) -> (Ext_list.append block [x]), E.dot (E.var b) property ) - in - Js_output.output_of_block_and_expression st should_return lam - blocks ret - | _ -> assert false + in + Js_output.output_of_block_and_expression st should_return lam + blocks ret + | _ -> assert false end | Lprim {primitive = Pjs_fn_run arity; args = args_lambda} -> @@ -825,147 +850,147 @@ and 3. we need a location for Pccall in the call site *) - begin match args_lambda with + begin match args_lambda with | [Lprim{ - primitive = + primitive = Pjs_unsafe_downgrade(method_name,loc); args = [obj]} as fn; arg] - -> + -> begin - let need_value_no_return_cxt = {cxt with st = NeedValue; should_return = ReturnFalse} in - let obj_output = compile_lambda need_value_no_return_cxt obj in - let arg_output = compile_lambda need_value_no_return_cxt arg in - let cont obj_block arg_block obj_code = - Js_output.output_of_block_and_expression st should_return lam + let need_value_no_return_cxt = {cxt with st = NeedValue; should_return = ReturnFalse} in + let obj_output = compile_lambda need_value_no_return_cxt obj in + let arg_output = compile_lambda need_value_no_return_cxt arg in + let cont obj_block arg_block obj_code = + Js_output.output_of_block_and_expression st should_return lam ( match obj_code with | None -> Ext_list.append obj_block arg_block | Some obj_code -> Ext_list.append obj_block (obj_code :: arg_block) ) - in - match obj_output, arg_output with - | {block = obj_block; value = Some obj }, + in + match obj_output, arg_output with + | {block = obj_block; value = Some obj }, {block = arg_block; value = Some value} -> - if Ext_string.ends_with method_name Literals.setter_suffix then + if Ext_string.ends_with method_name Literals.setter_suffix then let property = Lam_methname.translate ~loc - (String.sub method_name 0 - (String.length method_name - Literals.setter_suffix_len)) in + (String.sub method_name 0 + (String.length method_name - Literals.setter_suffix_len)) in match Js_ast_util.named_expression obj with | None -> - cont obj_block arg_block None + cont obj_block arg_block None (E.seq (E.assign (E.dot obj property) value) E.unit) | Some (obj_code, obj) -> - cont obj_block arg_block (Some obj_code) + cont obj_block arg_block (Some obj_code) (E.seq (E.assign (E.dot (E.var obj) property) value) E.unit) - else + else compile_lambda cxt - (Lam.apply fn [arg] + (Lam.apply fn [arg] Location.none (* TODO *) App_js_full) - | _ -> - assert false + | _ -> + assert false end - | fn :: rest -> - compile_lambda cxt - (Lam.apply fn rest + | fn :: rest -> + compile_lambda cxt + (Lam.apply fn rest Location.none (*TODO*) App_js_full) - | _ -> assert false + | _ -> assert false end | Lprim {primitive = Pjs_fn_runmethod arity ; args } - -> - begin match args with + -> + begin match args with | (Lprim{primitive = Pjs_unsafe_downgrade (name,loc); - args = [ _ ]} as fn) + args = [ _ ]} as fn) :: _obj - :: rest -> + :: rest -> (* assert (Ident.same id2 id) ; *) - (* we ignore the computation of [_obj], - since our ast writer + (* we ignore the computation of [_obj], + since our ast writer {[ obj#.f (x,y) ]} --> - {[ runmethod2 f obj#.f x y]} + {[ runmethod2 f obj#.f x y]} *) compile_lambda cxt (Lam.apply fn rest loc App_js_full) - | _ -> assert false + | _ -> assert false end - | Lprim {primitive = Pjs_fn_method arity; args = args_lambda} -> - begin match args_lambda with - | [Lfunction{arity = len; function_kind; params; body} ] - when len = arity -> - Js_output.output_of_block_and_expression + | Lprim {primitive = Pjs_fn_method arity; args = args_lambda} -> + begin match args_lambda with + | [Lfunction{arity = len; function_kind; params; body} ] + when len = arity -> + Js_output.output_of_block_and_expression st - should_return - lam + should_return + lam [] (E.method_ params (* Invariant: jmp_table can not across function boundary, here we share env *) - (Js_output.output_as_block + (Js_output.output_as_block ( compile_lambda - { cxt with st = EffectCall; - should_return = ReturnTrue None; - jmp_table = Lam_compile_context.empty_handler_map} + { cxt with st = EffectCall; + should_return = ReturnTrue None; + jmp_table = Lam_compile_context.empty_handler_map} body))) - | _ -> assert false + | _ -> assert false end - | Lprim {primitive = Pjs_fn_make arity; args = [fn]; loc } -> + | Lprim {primitive = Pjs_fn_make arity; args = [fn]; loc } -> compile_lambda cxt (Lam_eta_conversion.unsafe_adjust_to_arity loc ~to_:arity ?from:None fn) - | Lprim {primitive = Pjs_fn_make arity; - args = [] | _::_::_ } -> - assert false - | Lglobal_module i -> - (* introduced by + | Lprim {primitive = Pjs_fn_make arity; + args = [] | _::_::_ } -> + assert false + | Lglobal_module i -> + (* introduced by 1. {[ include Array --> let include = Array ]} 2. inline functor application *) - let exp = Lam_compile_global.expand_global_module i env in - Js_output.output_of_block_and_expression st should_return lam [] exp + let exp = Lam_compile_global.expand_global_module i env in + Js_output.output_of_block_and_expression st should_return lam [] exp | Lprim{ primitive = Pjs_object_create labels ; args ; loc} - -> + -> let args_block, args_expr = Ext_list.split_map (fun (x : Lam.t) -> - match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} x - with + match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} x + with | {block = a; value = Some b} -> a,b | _ -> assert false ) args in let args_code = List.concat args_block in - let block, exp = + let block, exp = Lam_compile_external_obj.assemble_args_obj labels args_expr in - Js_output.output_of_block_and_expression st should_return lam - (Ext_list.append args_code block) exp + Js_output.output_of_block_and_expression st should_return lam + (Ext_list.append args_code block) exp - | Lprim{primitive = prim; args = args_lambda; loc} -> + | Lprim{primitive = prim; args = args_lambda; loc} -> let args_block, args_expr = Ext_list.split_map (fun (x : Lam.t) -> - match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} x - with + match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} x + with | {block = a; value = Some b} -> a,b - | _ -> assert false ) args_lambda + | _ -> assert false ) args_lambda in let args_code : J.block = List.concat args_block in let exp = (* TODO: all can be done in [compile_primitive] *) Lam_compile_primitive.translate loc cxt prim args_expr in - Js_output.output_of_block_and_expression st should_return lam args_code exp + Js_output.output_of_block_and_expression st should_return lam args_code exp | Lsequence (l1,l2) -> - let output_l1 = + let output_l1 = compile_lambda {cxt with st = EffectCall; should_return = ReturnFalse} l1 in - let output_l2 = + let output_l2 = compile_lambda cxt l2 in Js_output.append_output output_l1 output_l2 @@ -973,7 +998,7 @@ and | Lifthenelse(p,t_br,f_br) -> (* - This should be optimized in lambda layer + This should be optimized in lambda layer (let (match/1038 = (apply g/1027 x/1028)) (catch (stringswitch match/1038 @@ -983,31 +1008,31 @@ and with (1) 2)) *) - begin - match compile_lambda {cxt with st = NeedValue ; should_return = ReturnFalse } p with + begin + match compile_lambda {cxt with st = NeedValue ; should_return = ReturnFalse } p with | {block = b; value = Some e} -> - begin match st with - | NeedValue -> + begin match st with + | NeedValue -> begin match - compile_lambda cxt t_br, - compile_lambda cxt f_br with - | {block = []; value = Some out1}, + compile_lambda cxt t_br, + compile_lambda cxt f_br with + | {block = []; value = Some out1}, {block = []; value = Some out2} -> (* speical optimization *) Js_output.make b ~value:(E.econd e out1 out2) - | _, _ -> - (* we can not reuse -- here we need they have the same name, + | _, _ -> + (* we can not reuse -- here we need they have the same name, TODO: could be optimized by inspecting assigment statement *) let id = Ext_ident.create_tmp () in (match compile_lambda {cxt with st = Assign id} t_br, compile_lambda {cxt with st = Assign id} f_br with - | out1 , out2 -> - Js_output.make - (Ext_list.append + | out1 , out2 -> + Js_output.make + (Ext_list.append (S.declare_variable ~kind:Variable id :: b) [ - S.if_ e - (Js_output.output_as_block out1) + S.if_ e + (Js_output.output_as_block out1) ~else_:(Js_output.output_as_block out2 ) ]) ~value:(E.var id) @@ -1015,173 +1040,173 @@ and end | Declare (kind,id) -> begin match - compile_lambda {cxt with st = NeedValue} t_br, - compile_lambda {cxt with st = NeedValue} f_br with + compile_lambda {cxt with st = NeedValue} t_br, + compile_lambda {cxt with st = NeedValue} f_br with | {block = []; value = Some out1}, - {block = []; value = Some out2} -> + {block = []; value = Some out2} -> (* Invariant: should_return is false*) - Js_output.make @@ + Js_output.make @@ Ext_list.append b [ S.define_variable ~kind id (E.econd e out1 out2) ] - | _, _ -> - Js_output.make + | _, _ -> + Js_output.make ( Ext_list.append b [ - S.if_ ~declaration:(kind,id) e - (Js_output.output_as_block @@ + S.if_ ~declaration:(kind,id) e + (Js_output.output_as_block @@ compile_lambda {cxt with st = Assign id} t_br) - ~else_:(Js_output.output_as_block @@ + ~else_:(Js_output.output_as_block @@ (compile_lambda {cxt with st = Assign id} f_br)) ]) end - | Assign id -> - (* -#if BS_DEBUG then - let () = Ext_log.dwarn __LOC__ "\n@[[TIME:]Lifthenelse: %f@]@." (Sys.time () *. 1000.) in -#end -*) + | Assign id -> + (* +#if BS_DEBUG then + let () = Ext_log.dwarn __LOC__ "\n@[[TIME:]Lifthenelse: %f@]@." (Sys.time () *. 1000.) in +#end +*) (* match - compile_lambda {cxt with st = NeedValue} t_br, - compile_lambda {cxt with st = NeedValue} f_br with - | {block = []; value = Some out1}, - {block = []; value = Some out2} -> + compile_lambda {cxt with st = NeedValue} t_br, + compile_lambda {cxt with st = NeedValue} f_br with + | {block = []; value = Some out1}, + {block = []; value = Some out2} -> (* Invariant: should_return is false *) Js_output.make [S.assign id (E.econd e out1 out2)] | _, _ -> *) - let then_output = - Js_output.output_as_block @@ + let then_output = + Js_output.output_as_block @@ (compile_lambda cxt t_br) in - let else_output = - Js_output.output_as_block @@ + let else_output = + Js_output.output_as_block @@ (compile_lambda cxt f_br) in Js_output.make (Ext_list.append b [ - S.if_ e + S.if_ e then_output ~else_:else_output ]) | EffectCall -> begin match should_return, - compile_lambda {cxt with st = NeedValue} t_br, - compile_lambda {cxt with st = NeedValue} f_br with + compile_lambda {cxt with st = NeedValue} t_br, + compile_lambda {cxt with st = NeedValue} f_br with (* see PR#83 *) - | ReturnFalse , {block = []; value = Some out1}, + | ReturnFalse , {block = []; value = Some out1}, {block = []; value = Some out2} -> begin match Js_exp_make.remove_pure_sub_exp out1 , Js_exp_make.remove_pure_sub_exp out2 with - | None, None -> Js_output.make (Ext_list.append b [ S.exp e]) + | None, None -> Js_output.make (Ext_list.append b [ S.exp e]) (* FIX #1762 *) - | Some out1, Some out2 -> + | Some out1, Some out2 -> Js_output.make b ~value:(E.econd e out1 out2) - | Some out1, None -> + | Some out1, None -> Js_output.make (Ext_list.append b [S.if_ e [S.exp out1]]) - | None, Some out2 -> + | None, Some out2 -> Js_output.make @@ (Ext_list.append b [S.if_ (E.not e) [S.exp out2] ]) end - | ReturnFalse , {block = []; value = Some out1}, _ -> - (* assert branch + | ReturnFalse , {block = []; value = Some out1}, _ -> + (* assert branch TODO: here we re-compile two branches since its context is different -- could be improved *) - if Js_analyzer.no_side_effect_expression out1 then + if Js_analyzer.no_side_effect_expression out1 then Js_output.make (Ext_list.append b [ S.if_ (E.not e) (Js_output.output_as_block @@ (compile_lambda cxt f_br))]) - else - Js_output.make - (Ext_list.append b [S.if_ e - (Js_output.output_as_block + else + Js_output.make + (Ext_list.append b [S.if_ e + (Js_output.output_as_block @@ compile_lambda cxt t_br) - ~else_:(Js_output.output_as_block @@ + ~else_:(Js_output.output_as_block @@ (compile_lambda cxt f_br))] ) - | ReturnFalse , _, {block = []; value = Some out2} -> - let else_ = - if Js_analyzer.no_side_effect_expression out2 then - None - else + | ReturnFalse , _, {block = []; value = Some out2} -> + let else_ = + if Js_analyzer.no_side_effect_expression out2 then + None + else Some ( Js_output.output_as_block @@ - compile_lambda cxt f_br) in - Js_output.make - (Ext_list.append b [S.if_ e + compile_lambda cxt f_br) in + Js_output.make + (Ext_list.append b [S.if_ e (Js_output.output_as_block @@ compile_lambda cxt t_br) ?else_]) - | ReturnTrue _, {block = []; value = Some out1}, + | ReturnTrue _, {block = []; value = Some out1}, {block = []; value = Some out2} -> - (* -#if BS_DEBUG then - let () = Ext_log.dwarn __LOC__ "\n@[[TIME:]Lifthenelse: %f@]@." (Sys.time () *. 1000.) in -#end + (* +#if BS_DEBUG then + let () = Ext_log.dwarn __LOC__ "\n@[[TIME:]Lifthenelse: %f@]@." (Sys.time () *. 1000.) in +#end *) - Js_output.make - (Ext_list.append b [S.return_stmt (E.econd e out1 out2)]) ~finished:True + Js_output.make + (Ext_list.append b [S.return_stmt (E.econd e out1 out2)]) ~finished:True | _, _, _ -> - (* -#if BS_DEBUG then - let () = Ext_log.dwarn __LOC__ "\n@[[TIME:]Lifthenelse: %f@]@." (Sys.time () *. 1000.) in -#end + (* +#if BS_DEBUG then + let () = Ext_log.dwarn __LOC__ "\n@[[TIME:]Lifthenelse: %f@]@." (Sys.time () *. 1000.) in +#end *) - let then_output = - Js_output.output_as_block @@ + let then_output = + Js_output.output_as_block @@ (compile_lambda cxt t_br) in - let else_output = - Js_output.output_as_block @@ + let else_output = + Js_output.output_as_block @@ (compile_lambda cxt f_br) in Js_output.make (Ext_list.append b [ - S.if_ e + S.if_ e then_output ~else_:else_output ]) end end - | {value = None } -> assert false + | {value = None } -> assert false end - | Lstringswitch(l, cases, default) -> + | Lstringswitch(l, cases, default) -> - (* TODO might better optimization according to the number of cases + (* TODO might better optimization according to the number of cases Be careful: we should avoid multiple evaluation of l, The [gen] can be elimiated when number of [cases] is less than 3 *) begin - match compile_lambda {cxt with should_return = ReturnFalse ; st = NeedValue} l + match compile_lambda {cxt with should_return = ReturnFalse ; st = NeedValue} l with - | {block ; value = Some e} -> - (* when should_return is true -- it's passed down + | {block ; value = Some e} -> + (* when should_return is true -- it's passed down otherwise it's ok *) - let default = - match default with - | Some x -> Default x + let default = + match default with + | Some x -> Default x | None -> Complete in begin - match st with + match st with (* TODO: can be avoided when cases are less than 3 *) - | NeedValue -> - let v = Ext_ident.create_tmp () in + | NeedValue -> + let v = Ext_ident.create_tmp () in Js_output.make (Ext_list.append block @@ - compile_string_cases + compile_string_cases {cxt with st = Declare (Variable, v)} e cases default) ~value:(E.var v) - | _ -> - Js_output.make + | _ -> + Js_output.make (Ext_list.append block @@ compile_string_cases cxt e cases default) end - | _ -> assert false + | _ -> assert false end | Lswitch(lam, - {sw_numconsts; + {sw_numconsts; sw_consts; sw_numblocks; sw_blocks; - sw_failaction = default }) - -> + sw_failaction = default }) + -> (* TODO: if default is None, we can do some optimizations Use switch vs if/then/else @@ -1189,64 +1214,64 @@ and also if last statement is throw -- should we drop remaining statement? *) - let sw_num_default = - match default with - | None -> Complete - | Some x -> - if Ext_list.length_ge sw_consts sw_numconsts + let sw_num_default = + match default with + | None -> Complete + | Some x -> + if Ext_list.length_ge sw_consts sw_numconsts then Complete - else Default x in - let sw_blocks_default = - match default with - | None -> Complete - | Some x -> + else Default x in + let sw_blocks_default = + match default with + | None -> Complete + | Some x -> if Ext_list.length_ge sw_blocks sw_numblocks then Complete - else Default x in + else Default x in let compile_whole ({st; _} as cxt : Lam_compile_context.t ) = - match sw_numconsts, sw_numblocks, + match sw_numconsts, sw_numblocks, compile_lambda {cxt with should_return = ReturnFalse; st = NeedValue} - lam with + lam with | 0 , _ , {block; value = Some e} -> compile_cases cxt (E.tag e ) sw_blocks sw_blocks_default - | _, 0, {block; value = Some e} -> + | _, 0, {block; value = Some e} -> compile_cases cxt e sw_consts sw_num_default | _, _, { block; value = Some e} -> (* [e] will be used twice *) - let dispatch e = + let dispatch e = [ - S.if_ + S.if_ (E.is_type_number e ) (compile_cases cxt e sw_consts sw_num_default ) (* default still needed, could simplified*) ~else_: - (compile_cases cxt (E.tag e ) sw_blocks + (compile_cases cxt (E.tag e ) sw_blocks sw_blocks_default) - ] in + ] in begin - match e.expression_desc with - | J.Var _ -> dispatch e - | _ -> - let v = Ext_ident.create_tmp () in + 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) end - | _, _, {value = None; _} -> assert false + | _, _, {value = None; _} -> assert false in begin match st with (* Needs declare first *) - | NeedValue -> - (* Necessary since switch is a statement, we need they return - the same value for different branches -- can be optmized + | NeedValue -> + (* Necessary since switch is a statement, we need they return + the same value for different branches -- can be optmized when branches are minimial (less than 2) *) let v = Ext_ident.create_tmp () in - Js_output.make - (S.declare_variable ~kind:Variable v :: + Js_output.make + (S.declare_variable ~kind:Variable v :: compile_whole {cxt with st = Assign v}) ~value:(E.var v) - | Declare (kind,id) -> + | Declare (kind,id) -> Js_output.make (S.declare_variable ~kind id :: compile_whole {cxt with st = Assign id} ) | EffectCall | Assign _ -> Js_output.make (compile_whole cxt) @@ -1255,18 +1280,18 @@ and | Lstaticraise(i, largs) -> (* TODO handlding *largs*) (* [i] is the jump table, [largs] is the arguments passed to [Lstaticcatch]*) begin - match Lam_compile_context.find_exn i cxt with - | {exit_id; args ; order_id} -> + match Lam_compile_context.find_exn i cxt with + | {exit_id; args ; order_id} -> let args_code = (Js_output.concat @@ Ext_list.map2 ( fun (x : Lam.t) (arg : Ident.t) -> match x with - | Lvar id -> + | Lvar id -> Js_output.make [S.assign arg (E.var id)] | _ -> (* TODO: should be Assign -- Assign is an optimization *) - compile_lambda {cxt with st = Assign arg ; should_return = ReturnFalse} x - ) largs (args : Ident.t list)) + compile_lambda {cxt with st = Assign arg ; should_return = ReturnFalse} x + ) largs (args : Ident.t list)) in Js_output.append_output args_code (* Declared in [Lstaticraise ]*) (Js_output.make [S.assign exit_id (E.small_int order_id)] @@ -1275,35 +1300,35 @@ and Js_output.make [S.unknown_lambda ~comment:"error" lam] (* staticraise is always enclosed by catch *) end - (* Invariant: code can not be reused + (* Invariant: code can not be reused (catch l with (32) (handler)) 32 should not be used in another catch - Assumption: + Assumption: This is true in current ocaml compiler currently exit only appears in should_return position relative to staticcatch if not we should use ``javascript break`` or ``continue`` *) - | Lstaticcatch _ -> + | Lstaticcatch _ -> let code_table, body = flatten_caches lam in let bindings = Ext_list.flat_map (fun (_,_,bindings) -> bindings) code_table in (* compile_list name l false (\*\) *) - (* if exit_code_id == code - handler -- ids are not useful, since + (* if exit_code_id == code + handler -- ids are not useful, since when compiling `largs` we will do the binding there - - when exit_code is undefined internally, + - when exit_code is undefined internally, it should PRESERVE ``tail`` property - - if it uses `staticraise` only once + - if it uses `staticraise` only once or handler is minimal, we can inline - always inline also seems to be ok, but it might bloat the code - another common scenario is that we have nested catch (catch (catch (catch ..)) *) (* - checkout example {!Digest.file}, you can not inline handler there, + checkout example {!Digest.file}, you can not inline handler there, we can spot such patten and use finally there? {[ let file filename = @@ -1317,100 +1342,100 @@ and (* TODO: handle NeedValue *) let exit_id = Ext_ident.create_tmp ~name:"exit" () in let exit_expr = E.var exit_id in - let jmp_table, handlers = + let jmp_table, handlers = Lam_compile_context.add_jmps exit_id code_table jmp_table in (* Declaration First, body and handler have the same value *) (* There is a bug in google closure compiler: - https://github.com/google/closure-compiler/issues/1234#issuecomment-151976340 + https://github.com/google/closure-compiler/issues/1234#issuecomment-151976340 TODO: wait for a bug fix *) - let declares = + let declares = S.define_variable ~kind:Variable exit_id - E.zero_int_literal :: + E.zero_int_literal :: (* we should always make it zero here, since [zero] is reserved in our mapping*) Ext_list.map (fun x -> S.declare_variable ~kind:Variable x ) bindings in - begin match st with + begin match st with (* could be optimized when cases are less than 3 *) - | NeedValue -> - let v = Ext_ident.create_tmp () in - let lbody = compile_lambda {cxt with + | NeedValue -> + let v = Ext_ident.create_tmp () in + let lbody = compile_lambda {cxt with jmp_table = jmp_table; st = Assign v } body in - Js_output.append_output + Js_output.append_output (Js_output.make (S.declare_variable ~kind:Variable v :: declares) ) (Js_output.append_output lbody (Js_output.make ( - compile_cases + compile_cases {cxt with st = Assign v; - jmp_table = jmp_table} + jmp_table = jmp_table} exit_expr handlers NonComplete) ~value:(E.var v ))) | Declare (kind, id) (* declare first this we will do branching*) -> - let declares = - S.declare_variable ~kind id :: declares in + let declares = + S.declare_variable ~kind id :: declares in let lbody = compile_lambda {cxt with jmp_table = jmp_table; st = Assign id } body in Js_output.append_output (Js_output.make declares) - (Js_output.append_output lbody - (Js_output.make (compile_cases - {cxt with jmp_table = jmp_table; st = Assign id} - exit_expr + (Js_output.append_output lbody + (Js_output.make (compile_cases + {cxt with jmp_table = jmp_table; st = Assign id} + exit_expr handlers NonComplete - (* place holder -- tell the compiler that + (* place holder -- tell the compiler that we don't know if it's complete *) ))) - | EffectCall | Assign _ -> + | EffectCall | Assign _ -> let lbody = compile_lambda {cxt with jmp_table = jmp_table } body in Js_output.append_output (Js_output.make declares) - (Js_output.append_output lbody + (Js_output.append_output lbody (Js_output.make (compile_cases {cxt with jmp_table = jmp_table} exit_expr handlers NonComplete))) end - | Lwhile(p,body) -> + | Lwhile(p,body) -> (* Note that ``J.While(expression * statement )`` idealy if ocaml expression does not need fresh variables, we can generate - while expression, here we generate for statement, leave optimization later. + while expression, here we generate for statement, leave optimization later. (Sine OCaml expression can be really complex..) *) - (match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse } p - with - | {block; value = Some e} -> + (match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse } p + with + | {block; value = Some e} -> (* st = NeedValue -- this should be optimized and never happen *) - let e = + let e = match block with - | [] -> e + | [] -> e | _ -> E.of_block block ~e in - let block = + let block = [ S.while_ e - (Js_output.output_as_block @@ - compile_lambda + (Js_output.output_as_block @@ + compile_lambda {cxt with st = EffectCall; should_return = ReturnFalse} body) ] in begin - match st, should_return with + match st, should_return with | Declare (_kind, x), _ -> (* FIXME _kind not used *) Js_output.make (Ext_list.append block [S.declare_unit x ]) | Assign x, _ -> Js_output.make (Ext_list.append block [S.assign_unit x ]) - | EffectCall, ReturnTrue _ -> + | EffectCall, ReturnTrue _ -> Js_output.make (Ext_list.append block S.return_unit) ~finished:True | EffectCall, _ -> Js_output.make block | NeedValue, _ -> Js_output.make block ~value:E.unit end | _ -> assert false ) - | Lfor (id,start,finish,direction,body) -> + | Lfor (id,start,finish,direction,body) -> (* all non-tail *) - (* TODO: check semantics should start, finish be executed each time in both + (* TODO: check semantics should start, finish be executed each time in both ocaml and js?, also check evaluation order.. in ocaml id is not in the scope of finish, so it should be safe here @@ -1424,10 +1449,10 @@ and let block = begin match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} start, - compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} finish with - | {block = b1; value = Some e1}, {block = b2; value = Some e2} -> + compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} finish with + | {block = b1; value = Some e1}, {block = b2; value = Some e2} -> - (* order b1 -- (e1 -- b2 -- e2) + (* order b1 -- (e1 -- b2 -- e2) in most cases we can shift it into such scenarios b1, b2, [e1, e2] - b2 is Empty @@ -1437,32 +1462,32 @@ and *) - begin + begin match b1,b2 with - | _,[] -> - Ext_list.append b1 [S.for_ (Some e1) e2 id direction - (Js_output.output_as_block @@ + | _,[] -> + Ext_list.append b1 [S.for_ (Some e1) e2 id direction + (Js_output.output_as_block @@ compile_lambda {cxt with should_return = ReturnFalse ; st = EffectCall} body) ] - | _, _ when Js_analyzer.no_side_effect_expression e1 - (* + | _, _ when Js_analyzer.no_side_effect_expression e1 + (* e1 > b2 > e2 - re-order + re-order b2 > e1 > e2 *) - -> - Ext_list.append b1 - (Ext_list.append b2 [S.for_ (Some e1) e2 id direction - (Js_output.output_as_block @@ + -> + Ext_list.append b1 + (Ext_list.append b2 [S.for_ (Some e1) e2 id direction + (Js_output.output_as_block @@ compile_lambda {cxt with should_return = ReturnFalse ; st = EffectCall} body) ]) | _ , _ - -> + -> Ext_list.append b1 (S.define_variable ~kind:Variable id e1 :: (Ext_list.append b2 [ - S.for_ None e2 id direction - (Js_output.output_as_block @@ + S.for_ None e2 id direction + (Js_output.output_as_block @@ compile_lambda {cxt with should_return = ReturnFalse ; st = EffectCall} - body) + body) ])) end @@ -1470,78 +1495,78 @@ and | _ -> assert false end in begin - match st, should_return with + match st, should_return with | EffectCall, ReturnFalse -> Js_output.make block - | EffectCall, ReturnTrue _ -> + | EffectCall, ReturnTrue _ -> Js_output.make (Ext_list.append block S.return_unit ) ~finished:True (* unit -> 0, order does not matter *) | (Declare _ | Assign _), ReturnTrue _ -> Js_output.make [S.unknown_lambda lam] - | Declare (_kind, x), ReturnFalse -> + | Declare (_kind, x), ReturnFalse -> (* FIXME _kind unused *) Js_output.make (Ext_list.append block [S.declare_unit x ]) - | Assign x, ReturnFalse -> + | Assign x, ReturnFalse -> Js_output.make (Ext_list.append block [S.assign_unit x ]) - | NeedValue, _ - -> + | NeedValue, _ + -> Js_output.make block ~value:E.unit (* TODO: fixme, here it's ok*) end - | Lassign(id,lambda) -> - let block = + | Lassign(id,lambda) -> + let block = match lambda with | Lprim {primitive = Poffsetint v; args = [Lvar id']} when Ident.same id id' -> - [ S.exp (E.assign (E.var id) + [ S.exp (E.assign (E.var id) (E.int32_add (E.var id) (E.small_int v))) ] | _ -> - begin - match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} lambda with - | {block = b; value = Some v} -> + begin + match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} lambda with + | {block = b; value = Some v} -> (Ext_list.append b [S.assign id v ]) - | _ -> assert false + | _ -> assert false end in begin - match st, should_return with + match st, should_return with | EffectCall, ReturnFalse -> Js_output.make block - | EffectCall, ReturnTrue _ -> + | EffectCall, ReturnTrue _ -> Js_output.make (Ext_list.append block S.return_unit ) ~finished:True - | (Declare _ | Assign _ ) , ReturnTrue _ -> + | (Declare _ | Assign _ ) , ReturnTrue _ -> Js_output.make [S.unknown_lambda lam] (* bound by a name, while in a tail position, this can not happen *) | Declare (_kind, x) , ReturnFalse -> (* FIXME: unused *) Js_output.make (Ext_list.append block [ S.declare_unit x ]) | Assign x, ReturnFalse -> Js_output.make (Ext_list.append block [S.assign_unit x ]) - | NeedValue, _ -> + | NeedValue, _ -> Js_output.make block ~value:E.unit end | (Ltrywith( (Lprim {primitive = Pccall {prim_name = "caml_sys_getenv"; _}; args = [Lconst _]} as body), - id, + id, Lifthenelse (Lprim{primitive = Pintcomp(Ceq); - args = [Lvar id2 ; + args = [Lvar id2 ; Lprim{primitive = Pglobal_exception {name = "Not_found"}; _}]}, cont, _reraise ) ) | Ltrywith( (Lprim {primitive = Pccall {prim_name = "caml_sys_getenv"; _}; args = [Lconst _]} as body), - id, + id, Lifthenelse(Lprim{primitive = Pintcomp(Ceq); - args = [ + args = [ Lprim { primitive = Pglobal_exception {name = "Not_found"; _}; _}; Lvar id2 ]}, cont, _reraise ) - )) when Ident.same id id2 - -> + )) when Ident.same id id2 + -> compile_lambda cxt (Lam.try_ body id cont) | Ltrywith(lam,id, catch) -> (* generate documentation *) - (* - tail --> should be renamed to `shouldReturn` - in most cases ``shouldReturn`` == ``tail``, however, here is not, + (* + tail --> should be renamed to `shouldReturn` + in most cases ``shouldReturn`` == ``tail``, however, here is not, should return, but it is not a tail call in js (* could be optimized using javascript style exceptions *) {[ @@ -1552,39 +1577,39 @@ and } ]} *) - let aux st = + let aux st = (* should_return is passed down *) (* #1701 *) - [ S.try_ - (Js_output.output_as_block (compile_lambda - (match should_return with + [ S.try_ + (Js_output.output_as_block (compile_lambda + (match should_return with | ReturnTrue (Some _ ) -> {cxt with st = st; should_return = ReturnTrue None} | ReturnTrue None | ReturnFalse -> {cxt with st = st}) lam)) - ~with_:(id, - Js_output.output_as_block @@ + ~with_:(id, + Js_output.output_as_block @@ compile_lambda {cxt with st = st} catch ) - ] in + ] in begin - match st with - | NeedValue -> + match st with + | NeedValue -> let v = Ext_ident.create_tmp () in Js_output.make (S.declare_variable ~kind:Variable v :: aux (Assign v)) ~value:(E.var v ) - | Declare (kind, id) -> + | Declare (kind, id) -> Js_output.make (S.declare_variable ~kind id :: aux (Assign id)) | Assign _ | EffectCall -> Js_output.make (aux st) end - | Lsend(meth_kind,met, obj, args,loc) -> - (* Note that in [Texp_apply] for [%sendcache] the cache might not be used + | Lsend(meth_kind,met, obj, args,loc) -> + (* Note that in [Texp_apply] for [%sendcache] the cache might not be used see {!CamlinternalOO.send_meth} and {!Translcore.transl_exp0} the branch [Texp_apply] when [public_send ], args are simply dropped - reference - [js_of_ocaml] + reference + [js_of_ocaml] 1. GETPUBMET 2. GETDYNMET 3. GETMETHOD @@ -1608,7 +1633,7 @@ and Obj.obj (set_id obj) end ]} - it's a block with tag [248], the first field is [table.methods] which is an array + it's a block with tag [248], the first field is [table.methods] which is an array {[ type table = { mutable size: int; @@ -1625,79 +1650,79 @@ and *) - begin match - (met :: obj :: args) - |> Ext_list.split_map (fun (x : Lam.t) -> - match x with + begin match + (met :: obj :: args) + |> Ext_list.split_map (fun (x : Lam.t) -> + match x with | Lprim {primitive = Pccall {prim_name ; _}; args = []} (* nullary external call*) - -> + -> [], E.var (Ext_ident.create_js prim_name) - | _ -> + | _ -> begin match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} x with - | {block = a; value = Some b} -> a, b + | {block = a; value = Some b} -> a, b | _ -> assert false end - ) with + ) with | _, ([] | [_]) -> assert false - | (args_code, label::nobj::args) - -> - let cont3 nobj k = - match Js_ast_util.named_expression nobj with - | None -> + | (args_code, label::nobj::args) + -> + let cont3 nobj k = + match Js_ast_util.named_expression nobj with + | None -> let cont = - Js_output.output_of_block_and_expression + Js_output.output_of_block_and_expression st should_return lam (List.concat args_code) in cont (k nobj) - | Some (obj_code, v) -> - let cont2 obj_code v = - Js_output.output_of_block_and_expression - st should_return lam - ( List.concat args_code @ [obj_code]) v in - let cobj = E.var v in - cont2 obj_code (k cobj) + | Some (obj_code, v) -> + let cont2 obj_code v = + Js_output.output_of_block_and_expression + st should_return lam + ( List.concat args_code @ [obj_code]) v in + let cobj = E.var v in + cont2 obj_code (k cobj) in begin - match meth_kind with - | Self -> + match meth_kind with + | Self -> (* TODO: horrible hack -- fixed later *) - cont3 nobj (fun aobj -> E.call ~info:Js_call_info.dummy - (Js_of_lam_array.ref_array + cont3 nobj (fun aobj -> E.call ~info:Js_call_info.dummy + (Js_of_lam_array.ref_array (Js_of_lam_record.field Fld_na aobj 0l) label ) (aobj :: args)) - (* [E.small_int 1] is because we use array, - when we change the runtime represenation, it needs to be adapted + (* [E.small_int 1] is because we use array, + when we change the runtime represenation, it needs to be adapted *) | Cached | Public None (* TODO: check -- 1. js object propagate 2. js object create *) - -> + -> let get = E.runtime_ref Js_runtime_modules.oo "caml_get_public_method" in let cache = !method_cache_id in let () = incr method_cache_id in - cont3 nobj (fun obj' -> - E.call ~info:Js_call_info.dummy - (E.call ~info:Js_call_info.dummy get + cont3 nobj (fun obj' -> + E.call ~info:Js_call_info.dummy + (E.call ~info:Js_call_info.dummy get [obj'; label; E.small_int cache]) (obj'::args) ) (* avoid duplicated compuattion *) - | Public (Some name) -> + | Public (Some name) -> let cache = !method_cache_id in incr method_cache_id ; - cont3 nobj - (fun aobj -> E.public_method_call name aobj label + cont3 nobj + (fun aobj -> E.public_method_call name aobj label (Int32.of_int cache) args ) end end (* [J.Empty,J.N] *) (* TODO debugging, sourcemap, ignore lambda_event currently *) - (* + (* seems to be an optimization trick for [translclass] | Lifused(v, l) -> if count_var v > 0 then simplif l else lambda_unit diff --git a/lib/whole_compiler.ml b/lib/whole_compiler.ml index c472629f273..5ca91eb5d3a 100644 --- a/lib/whole_compiler.ml +++ b/lib/whole_compiler.ml @@ -84566,30 +84566,29 @@ and output_one : 'a . = fun cxt f pp_cond ({switch_case = e; switch_body = (sl,should_break)} : _ J.case_clause) -> let cxt = - P.group f 1 @@ fun _ -> - P.group f 1 @@ (fun _ -> - P.string f L.case; - P.space f ; - pp_cond f e; (* could be integer or string*) - P.space f ; - P.string f L.colon ); - - P.space f; - P.group f 1 @@ fun _ -> - let cxt = - match sl with - | [] -> cxt - | _ -> - P.newline f ; - statement_list false cxt f sl - in - (if should_break then - begin - P.newline f ; - P.string f L.break; - semi f; - end) ; - cxt + P.group f 1 (fun _ -> + P.group f 1 (fun _ -> + P.string f L.case; + P.space f ; + pp_cond f e; (* could be integer or string *) + P.space f ; + P.string f L.colon ); + P.space f; + P.group f 1 (fun _ -> + let cxt = + match sl with + | [] -> cxt + | _ -> + P.newline f ; + statement_list false cxt f sl + in + (if should_break then + begin + P.newline f ; + P.string f L.break; + semi f; + end) ; + cxt)) in P.newline f; cxt @@ -97370,7 +97369,7 @@ val compile_lambda : end = struct #1 "lam_compile.ml" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -97388,44 +97387,44 @@ end = struct * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -module E = Js_exp_make +module E = Js_exp_make -module S = Js_stmt_make +module S = Js_stmt_make let method_cache_id = ref 1 (*TODO: move to js runtime for re-entrant *) (* assume outer is [Lstaticcatch] *) let rec flat_catches acc (x : Lam.t) - : (int * Lam.t * Ident.t list ) list * Lam.t = - match x with - | Lstaticcatch(l, (code, bindings), handler) - when + : (int * Lam.t * Ident.t list ) list * Lam.t = + match x with + | Lstaticcatch(l, (code, bindings), handler) + when acc = [] || - (not @@ Lam_exit_code.has_exit_code + (not @@ Lam_exit_code.has_exit_code (fun exit -> List.exists (fun (c,_,_) -> c = exit) acc) handler) -> (* #1698 should not crush exit code here without checking *) flat_catches ((code,handler,bindings)::acc) l | _ -> acc, x -let flatten_caches x : (int * Lam.t * Ident.t list ) list * Lam.t = - flat_catches [] x +let flatten_caches x : (int * Lam.t * Ident.t list ) list * Lam.t = + flat_catches [] x (* TODO: - for expression generation, + for expression generation, name, should_return is not needed, only jmp_table and env needed *) -type default_case = +type default_case = | Default of Lam.t | Complete | NonComplete @@ -97436,76 +97435,76 @@ type default_case = (* E.index m (pos + 1) *) (** shift by one *) (** This can not happen since this id should be already consulted by type checker *) (** We drop the ability of cross-compiling - the compiler has to be the same running -*) -(* since it's only for alias, there is no arguments, + the compiler has to be the same running +*) +(* since it's only for alias, there is no arguments, we should not inline function definition here, even though - it is very small - TODO: add comment here, we should try to add comment for - cross module inlining + it is very small + TODO: add comment here, we should try to add comment for + cross module inlining - if we do too agressive inlining here: + if we do too agressive inlining here: - if we inline {!List.length} which will call {!A_list.length}, - then we if we try inline {!A_list.length}, this means if {!A_list} + if we inline {!List.length} which will call {!A_list.length}, + then we if we try inline {!A_list.length}, this means if {!A_list} is rebuilt, this module should also be rebuilt, - But if the build system is content-based, suppose {!A_list} - is changed, cmj files in {!List} is unchnaged, however, + But if the build system is content-based, suppose {!A_list} + is changed, cmj files in {!List} is unchnaged, however, {!List.length} call {!A_list.length} which is changed, since - [ocamldep] only detect that we depend on {!List}, it will not - get re-built, then we are screwed. + [ocamldep] only detect that we depend on {!List}, it will not + get re-built, then we are screwed. This is okay for stamp based build system. Another solution is that we add dependencies in the compiler - -: we should not do functor application inlining in a - non-toplevel, it will explode code very quickly -*) -let rec + -: we should not do functor application inlining in a + non-toplevel, it will explode code very quickly +*) +let rec compile_external_field (* Like [List.empty]*) - (cxt : Lam_compile_context.t) + (cxt : Lam_compile_context.t) (lam : Lam.t) (id : Ident.t) (pos : int) (env : Env.t) - : Js_output.t = - let f = Js_output.output_of_expression cxt.st cxt.should_return lam in - match Lam_compile_env.cached_find_ml_id_pos id pos env with + : Js_output.t = + let f = Js_output.output_of_expression cxt.st cxt.should_return lam in + match Lam_compile_env.cached_find_ml_id_pos id pos env with | {id; name; closed_lambda } -> - match id, name, closed_lambda with + match id, name, closed_lambda with | {name = "Sys"; _}, "os_type" , _ - -> f (E.str Sys.os_type) - | _, _, Some lam + -> f (E.str Sys.os_type) + | _, _, Some lam when Lam_util.not_function lam - -> + -> compile_lambda cxt lam - | _ -> + | _ -> f (E.ml_var_dot id name) (* TODO: how nested module call would behave, - In the future, we should keep in track of if + In the future, we should keep in track of if it is fully applied from [Lapply] Seems that the module dependency is tricky.. should we depend on [Pervasives] or not? - we can not do this correctly for the return value, + we can not do this correctly for the return value, however we can inline the definition in Pervasives TODO: [Pervasives.print_endline] [Pervasives.prerr_endline] - @param id external module id - @param number the index of the external function + @param id external module id + @param number the index of the external function @param env typing environment - @param args arguments + @param args arguments *) -(** This can not happen since this id should be already consulted by type checker - Worst case +(** This can not happen since this id should be already consulted by type checker + Worst case {[ - E.index m pos + E.index m pos ]} *) (* when module is passed as an argument - unpack to an array @@ -97513,51 +97512,51 @@ let rec however it can not be global -- global can only module *) -and compile_external_field_apply - (cxt : Lam_compile_context.t) +and compile_external_field_apply + (cxt : Lam_compile_context.t) (lam : Lam.t) (* original lambda*) (args_lambda : Lam.t list) (id : Ident.t) (pos : int) - (env : Env.t) : Js_output.t = + (env : Env.t) : Js_output.t = match - Lam_compile_env.cached_find_ml_id_pos + Lam_compile_env.cached_find_ml_id_pos id pos env - with - | {id; name;arity; closed_lambda ; _} -> - let args_code, args = - Ext_list.fold_right + with + | {id; name;arity; closed_lambda ; _} -> + let args_code, args = + Ext_list.fold_right (fun (x : Lam.t) (args_code, args) -> match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} x with - | {block = a; value = Some b} -> + | {block = a; value = Some b} -> (Ext_list.append a args_code), (b :: args ) | _ -> assert false ) args_lambda ([], []) in - match closed_lambda with - | Some (Lfunction{ params; body; _}) - when Ext_list.same_length params args_lambda -> + match closed_lambda with + | Some (Lfunction{ params; body; _}) + when Ext_list.same_length params args_lambda -> (* TODO: serialize it when exporting to save compile time *) - let (_, param_map) = + let (_, param_map) = Lam_closure.is_closed_with_map Ident_set.empty params body in - compile_lambda cxt + compile_lambda cxt (Lam_beta_reduce.propogate_beta_reduce_with_map cxt.meta param_map params body args_lambda) | _ -> let rec aux (acc : J.expression) (arity : Lam_arity.t) args (len : int) = match arity, len with - | _, 0 -> + | _, 0 -> acc (** All arguments consumed so far *) | Determin (a, (x,_) :: rest, b), len -> - let x = - if x = 0 - then 1 + let x = + if x = 0 + then 1 else x in (* Relax when x = 0 *) - if len >= x + if len >= x then let first_part, continue = Ext_list.split_at x args in aux @@ -97565,10 +97564,10 @@ and compile_external_field_apply (Determin (a, rest, b)) continue (len - x) else (* GPR #1423 *) - if List.for_all Js_analyzer.is_okay_to_duplicate args then + if List.for_all Js_analyzer.is_okay_to_duplicate args then let params = Ext_list.init (x - len) (fun _ -> Ext_ident.create "param") in - E.ocaml_fun params + E.ocaml_fun params [S.return_stmt (E.call ~info:{arity=Full; call_info=Call_ml} acc (Ext_list.append args @@ Ext_list.map E.var params))] else E.call ~info:Js_call_info.dummy acc args @@ -97586,105 +97585,105 @@ and compile_external_field_apply cxt.should_return lam args_code - ( + ( aux - (E.ml_var_dot id name) + (E.ml_var_dot id name) (match arity with Single x -> x | Submodule _ -> NA) args (List.length args )) -and compile_let +and compile_let (let_kind : Lam_compile_context.let_kind) (cxt : Lam_compile_context.t) (id : J.ident) (arg : Lam.t) : Js_output.t = compile_lambda - {cxt with st = Declare (let_kind, id); should_return = ReturnFalse } arg -(** - The second return values are values which need to be wrapped using - [caml_update_dummy] + {cxt with st = Declare (let_kind, id); should_return = ReturnFalse } arg +(** + The second return values are values which need to be wrapped using + [caml_update_dummy] Invariant: jmp_table can not across function boundary, - here we share env + here we share env *) and compile_recursive_let ~all_bindings (cxt : Lam_compile_context.t) (id : Ident.t) - (arg : Lam.t) : Js_output.t * Ident.t list = - match arg with - | Lfunction { function_kind; params; body; _} -> + (arg : Lam.t) : Js_output.t * Ident.t list = + match arg with + | Lfunction { function_kind; params; body; _} -> let continue_label = Lam_util.generate_label ~name:id.name () in - (* TODO: Think about recursive value + (* TODO: Think about recursive value {[ - let rec v = ref (fun _ ... + let rec v = ref (fun _ ... ) ]} - [Alias] may not be exact + [Alias] may not be exact *) - let ret : Lam_compile_context.return_label = - { id; - label = continue_label; + let ret : Lam_compile_context.return_label = + { id; + label = continue_label; params; immutable_mask = Array.make (List.length params) true; new_params = Ident_map.empty; triggered = false } in - let output = + let output = compile_lambda - { cxt with - st = EffectCall; + { cxt with + st = EffectCall; should_return = ReturnTrue (Some ret ); jmp_table = Lam_compile_context.empty_handler_map} body in - let result = - if ret.triggered then + let result = + if ret.triggered then let body_block = Js_output.output_as_block output in E.ocaml_fun - (* TODO: save computation of length several times - Here we always create [ocaml_fun], - it will be renamed into [method] + (* TODO: save computation of length several times + Here we always create [ocaml_fun], + it will be renamed into [method] when it is detected by a primitive *) ~immutable_mask:ret.immutable_mask - (Ext_list.map (fun x -> + (Ext_list.map (fun x -> Ident_map.find_default x ret.new_params x ) params) [ S.while_ (* ~label:continue_label *) - E.caml_true + E.caml_true ( Ident_map.fold (fun old new_param acc -> - S.define_variable ~kind:Alias old (E.var new_param) :: acc) + S.define_variable ~kind:Alias old (E.var new_param) :: acc) ret.new_params body_block ) ] else (* TODO: save computation of length several times *) E.ocaml_fun params (Js_output.output_as_block output ) - in + in Js_output.output_of_expression (Declare (Alias, id)) - ReturnFalse arg result, [] + ReturnFalse arg result, [] | Lprim {primitive = Pmakeblock (0, _, _) ; args = ls} - when List.for_all (fun (x : Lam.t) -> - match x with - | Lvar pid -> - Ident.same pid id || + when List.for_all (fun (x : Lam.t) -> + match x with + | Lvar pid -> + Ident.same pid id || (not @@ List.exists (fun (other,_) -> Ident.same other pid ) all_bindings) - | _ -> false) ls + | _ -> false) ls -> (* capture cases like for {!Queue} {[let rec cell = { content = x; next = cell} ]} #1716: be careful not to optimize such cases: - {[ let rec a = { b} and b = { a} ]} they are indeed captured - and need to be declared first + {[ let rec a = { b} and b = { a} ]} they are indeed captured + and need to be declared first *) Js_output.make ( - S.define_variable ~kind:Variable id (E.array Mutable []) :: - (List.mapi (fun i (x : Lam.t) -> - match x with + S.define_variable ~kind:Variable id (E.array Mutable []) :: + (List.mapi (fun i (x : Lam.t) -> + match x with | Lvar lid - -> S.exp + -> S.exp (Js_arr.set_array (E.var id) (E.int (Int32.of_int i)) (E.var lid)) | _ -> assert false ) ls) @@ -97694,140 +97693,152 @@ and compile_recursive_let ~all_bindings (* FIXME: also should fill tag *) (* Lconst should not appear here if we do [scc] optimization, since it's faked recursive value, - however it would affect scope issues, we have to declare it first + however it would affect scope issues, we have to declare it first *) (* Ext_log.err "@[recursive value %s/%d@]@." id.name id.stamp; *) begin match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse } arg with - | { block = b; value = Some v} -> - (* TODO: check recursive value .. + | { block = b; value = Some v} -> + (* TODO: check recursive value .. could be improved for simple cases *) - Js_output.make + Js_output.make (Ext_list.append - b + b [S.exp - (E.runtime_call Js_runtime_modules.obj_runtime "caml_update_dummy" + (E.runtime_call Js_runtime_modules.obj_runtime "caml_update_dummy" [ E.var id; v])]), [id] (* S.define ~kind:Variable id (E.arr Mutable []):: *) - | _ -> assert false + | _ -> assert false end | Lvar _ -> compile_lambda {cxt with st = Declare (Alias ,id); should_return = ReturnFalse } arg, [] - | _ -> + | _ -> (* pathological case: fail to capture taill call? - {[ let rec a = + {[ let rec a = if g > 30 then .. fun () -> a () ]} Neither below is not allowed in ocaml: {[ - let rec v = - if sum 0 10 > 20 then - 1::v + let rec v = + if sum 0 10 > 20 then + 1::v else 2:: v ]} {[ - let rec v = - if sum 0 10 > 20 then + let rec v = + if sum 0 10 > 20 then fun _ -> print_endline "hi"; v () - else + else fun _-> print_endline "hey"; v () ]} *) compile_lambda {cxt with st = Declare (Alias ,id); should_return = ReturnFalse } arg, [] -and compile_recursive_lets_aux cxt id_args : Js_output.t = +and compile_recursive_lets_aux cxt id_args : Js_output.t = (* #1716 *) let output_code, ids = Ext_list.fold_right - (fun (ident,arg) (acc, ids) -> + (fun (ident,arg) (acc, ids) -> let code, declare_ids = compile_recursive_let ~all_bindings:id_args cxt ident arg in (Js_output.append_output code acc, Ext_list.append declare_ids ids ) ) id_args (Js_output.dummy, []) in - match ids with + match ids with | [] -> output_code - | _ -> - Js_output.append_output - (Js_output.make - (Ext_list.map - (fun id -> S.define_variable ~kind:Variable id (E.dummy_obj ())) + | _ -> + Js_output.append_output + (Js_output.make + (Ext_list.map + (fun id -> S.define_variable ~kind:Variable id (E.dummy_obj ())) ids ) ) output_code -and compile_recursive_lets cxt id_args : Js_output.t = +and compile_recursive_lets cxt id_args : Js_output.t = - match id_args with + match id_args with | [ ] -> Js_output.dummy - | _ -> - let id_args_group = Lam.scc_bindings id_args in - begin match id_args_group with - | [ ] -> assert false + | _ -> + let id_args_group = Lam.scc_bindings id_args in + begin match id_args_group with + | [ ] -> assert false | first::rest -> - let acc = compile_recursive_lets_aux cxt first in + let acc = compile_recursive_lets_aux cxt first in List.fold_left (fun acc x -> Js_output.append_output - acc (compile_recursive_lets_aux cxt x )) acc rest - end -and compile_general_cases : - 'a . + acc (compile_recursive_lets_aux cxt x )) acc rest + end +and compile_general_cases + : + 'a . ('a -> J.expression) -> - (J.expression -> J.expression -> J.expression) -> - Lam_compile_context.t -> + (J.expression -> J.expression -> J.expression) -> + Lam_compile_context.t -> (?default:J.block -> - ?declaration:Lam.let_kind * Ident.t -> - _ -> 'a J.case_clause list -> J.statement) -> - _ -> - ('a * Lam.t) list -> default_case -> J.block - = fun f eq cxt switch v table default -> + ?declaration:Lam.let_kind * Ident.t -> + _ -> 'a J.case_clause list -> J.statement) -> + _ -> + ('a * Lam.t) list -> default_case -> J.block + = fun + (make_exp : _ -> J.expression) + (eq_exp : J.expression -> J.expression -> J.expression) + (cxt : Lam_compile_context.t) + (switch : + ?default:J.block -> + ?declaration:Lam.let_kind * Ident.t -> + _ -> _ J.case_clause list -> J.statement + ) + (switch_exp : J.expression) + (table : (_ * Lam.t) list) + (default : default_case) -> let wrap (cxt : Lam_compile_context.t) k = let cxt, define = - match cxt.st with + match cxt.st with | Declare (kind, did) - -> + -> {cxt with st = Assign did}, Some (kind,did) | _ -> cxt, None in - k cxt define + k cxt define in - match table, default with - | [], Default lam -> + match table, default with + | [], Default lam -> Js_output.output_as_block (compile_lambda cxt lam) | [], (Complete | NonComplete) -> [] - | [(id,lam)],Complete -> - (* To take advantage of such optimizations, - when we generate code using switch, + | [(id,lam)],Complete -> + (* To take advantage of such optimizations, + when we generate code using switch, we should always have a default, - otherwise the compiler engine would think that + otherwise the compiler engine would think that it's also complete *) - Js_output.output_as_block @@ compile_lambda cxt lam - | [(id,lam)], NonComplete + Js_output.output_as_block (compile_lambda cxt lam) + | [(id,lam)], NonComplete -> wrap cxt @@ fun cxt define -> - [S.if_ ?declaration:define (eq v (f id) ) + [S.if_ ?declaration:define (eq_exp switch_exp (make_exp id) ) (Js_output.output_as_block @@ compile_lambda cxt lam )] | ([(id,lam)], Default x) | ([(id,lam); (_,x)], Complete) -> - wrap cxt @@ fun cxt define -> + wrap cxt @@ fun cxt define -> let else_block = Js_output.output_as_block (compile_lambda cxt x) in let then_block = Js_output.output_as_block (compile_lambda cxt lam) in - [ S.if_ ?declaration:define (eq v (f id) ) + [ S.if_ ?declaration:define (eq_exp switch_exp (make_exp id) ) then_block ~else_:else_block ] - | _ , _ -> + | _ , _ -> (* TODO: this is not relevant to switch case - however, in a subset of switch-case if we can analysis - its branch are the same, we can propogate which + however, in a subset of switch-case if we can analysis + its branch are the same, we can propogate which might encourage better inlining strategey --- TODO: grouping can be delayed untile JS IR @@ -97840,17 +97851,17 @@ and compile_general_cases : | NonComplete -> None | Default lam -> Some (Js_output.output_as_block (compile_lambda cxt lam)) in - let body = - table + let body = + table |> Ext_list.stable_group (fun (_,lam) (_,lam1) -> Lam_analysis.eq_lambda lam lam1) - |> Ext_list.flat_map - (fun group -> - group - |> Ext_list.map_last - (fun last (x,lam) -> - if last + |> Ext_list.flat_map + (fun group -> + group + |> Ext_list.map_last + (fun last (x,lam) -> + if last then {J.switch_case = x; switch_body = Js_output.to_break_block (compile_lambda cxt lam) } @@ -97860,72 +97871,85 @@ and compile_general_cases : common break through, *) in - [switch ?default ?declaration v body] + [switch ?default ?declaration switch_exp body] -and compile_cases cxt = - compile_general_cases (fun x -> E.small_int x) E.int_equal cxt +and compile_cases cxt switch_exp table default = + compile_general_cases + E.small_int + E.int_equal + cxt (fun ?default ?declaration e clauses -> S.int_switch ?default ?declaration e clauses) - -and compile_string_cases cxt = - compile_general_cases E.str E.string_equal cxt + switch_exp + table + default + +and compile_string_cases cxt switch_exp table default = + compile_general_cases + E.str + E.string_equal + cxt (fun ?default ?declaration e clauses -> S.string_switch ?default ?declaration e clauses) -(* TODO: optional arguments are not good + switch_exp + table + default + +(* TODO: optional arguments are not good for high order currying *) and compile_lambda ({st ; should_return; jmp_table; meta = {env ; _} } as cxt : Lam_compile_context.t) (lam : Lam.t) : Js_output.t = begin - match lam with + match lam with | Lfunction{ function_kind; params; body} -> - Js_output.output_of_expression st should_return lam + Js_output.output_of_expression st should_return lam (E.ocaml_fun params (* Invariant: jmp_table can not across function boundary, here we share env *) - (Js_output.output_as_block + (Js_output.output_as_block ( compile_lambda - { cxt with st = EffectCall; + { cxt with st = EffectCall; should_return = ReturnTrue None; (* Refine*) jmp_table = Lam_compile_context.empty_handler_map} body))) | Lapply{ fn = Lapply{ fn = an; args = fn_args; status = App_na ; }; - args; + args; status = App_na; loc } - -> - (* After inlining we can generate such code, - see {!Ari_regress_test} - *) - compile_lambda cxt + -> + (* After inlining we can generate such code, + see {!Ari_regress_test} + *) + compile_lambda cxt (Lam.apply an (Ext_list.append fn_args args) loc App_na ) (* External function calll *) - | Lapply{ fn = - Lprim{primitive = Pfield (n,_); + | Lapply{ fn = + Lprim{primitive = Pfield (n,_); args = [ Lglobal_module id];_}; args = args_lambda; status = App_na | App_ml_full} -> - (* Note we skip [App_js_full] since [get_exp_with_args] dont carry + (* Note we skip [App_js_full] since [get_exp_with_args] dont carry this information, we should fix [get_exp_with_args] *) compile_external_field_apply cxt lam args_lambda id n env - | Lapply{ fn; args = args_lambda; status} -> - (* TODO: --- + | Lapply{ fn; args = args_lambda; status} -> + (* TODO: --- 1. check arity, can be simplified for pure expression 2. no need create names *) - begin - let [@warning "-8" (* non-exhaustive pattern*)] (args_code, fn_code:: args) = - Ext_list.fold_right (fun (x : Lam.t) (args_code, fn_code )-> - match compile_lambda + begin + let [@warning "-8" (* non-exhaustive pattern*)] (args_code, fn_code:: args) = + Ext_list.fold_right (fun (x : Lam.t) (args_code, fn_code )-> + match compile_lambda {cxt with st = NeedValue ; should_return = ReturnFalse} x with - | {block = a; value = Some b} -> Ext_list.append a args_code , b:: fn_code + | {block = a; value = Some b} -> Ext_list.append a args_code , b:: fn_code | _ -> assert false ) (fn::args_lambda) ([],[]) in @@ -97938,37 +97962,37 @@ and (* Ext_log.err "@[ %s : %a tailcall @]@." cxt.meta.filename Ident.print id; *) ret.triggered <- true; - (* Here we mark [finished] true, since the continuation + (* Here we mark [finished] true, since the continuation does not make sense any more (due to that we have [continue]) - TODO: [finished] is not a meaningful name, we should use [truncate] + TODO: [finished] is not a meaningful name, we should use [truncate] to mean the following statement should be truncated *) - (* - actually, there is no easy way to determin - if the argument depends on an expresion, since + (* + actually, there is no easy way to determin + if the argument depends on an expresion, since it can be a function, then it may depend on anything http://caml.inria.fr/pub/ml-archives/caml-list/2005/02/5727b4ecaaef6a7a350c9d98f5f68432.en.html http://caml.inria.fr/pub/ml-archives/caml-list/2005/02/fe9bc4e23e6dc8c932c8ab34240ff195.en.html *) - (* TODO: use [fold]*) + (* TODO: use [fold]*) let block = args_code @ ( - let (_,assigned_params,new_params) = + let (_,assigned_params,new_params) = List.fold_left2 (fun (i,assigns,new_params) param (arg : J.expression) -> match arg with | {expression_desc = Var (Id x); _} when Ident.same x param -> (i + 1, assigns, new_params) | _ -> - let new_param, m = - match Ident_map.find_opt param ret.new_params with - | None -> + let new_param, m = + match Ident_map.find_opt param ret.new_params with + | None -> ret.immutable_mask.(i)<- false; let v = Ext_ident.create ("_"^param.Ident.name) in - v, (Ident_map.add param v new_params) + v, (Ident_map.add param v new_params) | Some v -> v, new_params in (i+1, (new_param, arg) :: assigns, m) - ) (0, [], Ident_map.empty) params args in + ) (0, [], Ident_map.empty) params args in let () = ret.new_params <- Ident_map.disjoint_merge new_params ret.new_params in assigned_params |> Ext_list.map (fun (param, arg) -> S.assign param arg)) @ @@ -97977,19 +98001,19 @@ and in begin (* Ext_log.dwarn __LOC__ "size : %d" (List.length block); *) - Js_output.make ~finished:True block + Js_output.make ~finished:True block end - | _ -> + | _ -> - Js_output.output_of_block_and_expression st should_return lam args_code - (E.call ~info:(match fn, status with - | _, App_ml_full -> + Js_output.output_of_block_and_expression st should_return lam args_code + (E.call ~info:(match fn, status with + | _, App_ml_full -> {arity = Full ; call_info = Call_ml} - | _, App_js_full -> + | _, App_js_full -> {arity = Full ; call_info = Call_na} - | _, App_na -> + | _, App_na -> {arity = NA; call_info = Call_ml } - ) fn_code args) + ) fn_code args) end; end @@ -97997,71 +98021,71 @@ and | Llet (let_kind,id,arg, body) -> (* Order matters.. see comment below in [Lletrec] *) let args_code = - compile_let let_kind cxt id arg in - Js_output.append_output - args_code + compile_let let_kind cxt id arg in + Js_output.append_output + args_code (compile_lambda cxt body) - | Lletrec (id_args, body) -> - (* There is a bug in our current design, + | Lletrec (id_args, body) -> + (* There is a bug in our current design, it requires compile args first (register that some objects are jsidentifiers) and compile body wiht such effect. So here we should compile [id_args] first, then [body] later. Note it has some side effect over cache number as well, mostly the value of [Caml_primitive["caml_get_public_method"](x,hash_tab, number)] - To fix this, + To fix this, 1. scan the lambda layer first, register js identifier before proceeding 2. delay the method call into javascript ast *) - let v = compile_recursive_lets cxt id_args in + let v = compile_recursive_lets cxt id_args in Js_output.append_output v (compile_lambda cxt body) | Lvar id -> Js_output.output_of_expression st should_return lam (E.var id ) - | Lconst c -> + | Lconst c -> Js_output.output_of_expression st should_return lam (Lam_compile_const.translate c) - | Lprim {primitive = Pfield (n,_); - args = [ Lglobal_module id ]; _} + | Lprim {primitive = Pfield (n,_); + args = [ Lglobal_module id ]; _} -> (* should be before Lglobal_global *) compile_external_field cxt lam id n env - | Lprim {primitive = Praise ; args = [ e ]; _} -> + | Lprim {primitive = Praise ; args = [ e ]; _} -> begin match compile_lambda { - cxt with should_return = ReturnFalse; st = NeedValue} e with - | {block = b; value = Some v} -> - Js_output.make + cxt with should_return = ReturnFalse; st = NeedValue} e with + | {block = b; value = Some v} -> + Js_output.make (Ext_list.append b [S.throw_stmt v]) ~value:E.undefined ~finished:True - (* FIXME -- breaks invariant when NeedValue, reason is that js [throw] is statement + (* FIXME -- breaks invariant when NeedValue, reason is that js [throw] is statement while ocaml it's an expression, we should remove such things in lambda optimizations *) - | {value = None; _} -> assert false + | {value = None; _} -> assert false end | Lprim{primitive = Psequand ; args = [l;r] ; _} -> - begin match cxt with - | {should_return = ReturnTrue _ } + begin match cxt with + | {should_return = ReturnTrue _ } (* Invariant: if [should_return], then [st] will not be [NeedValue] *) -> compile_lambda cxt (Lam.sequand l r ) - | {should_return = ReturnFalse } -> + | {should_return = ReturnFalse } -> let new_cxt = {cxt with st = NeedValue} in match - compile_lambda new_cxt l with - | { value = None } -> assert false + compile_lambda new_cxt l with + | { value = None } -> assert false | {block = l_block; value = Some l_expr} -> match compile_lambda new_cxt r with - | { value = None } -> assert false - | {block = []; value = Some r_expr} - -> - Js_output.output_of_block_and_expression - st + | { value = None } -> assert false + | {block = []; value = Some r_expr} + -> + Js_output.output_of_block_and_expression + st should_return lam l_block (E.and_ l_expr r_expr) - | { block = r_block; value = Some r_expr} -> - begin match cxt.st with + | { block = r_block; value = Some r_expr} -> + begin match cxt.st with | Assign v -> (* Refernece Js_output.output_of_block_and_expression *) Js_output.make @@ -98073,26 +98097,26 @@ and ) | Declare (_kind,v) -> (* Refernece Js_output.output_of_block_and_expression *) - Js_output.make + Js_output.make ( - l_block @ - [ S.define_variable ~kind:Variable v E.caml_false ; - S.if_ l_expr + l_block @ + [ S.define_variable ~kind:Variable v E.caml_false ; + S.if_ l_expr (r_block @ [S.assign v r_expr])]) | EffectCall | NeedValue -> - let v = Ext_ident.create_tmp () in + let v = Ext_ident.create_tmp () in Js_output.make - (S.define_variable ~kind:Variable v E.caml_false :: + (S.define_variable ~kind:Variable v E.caml_false :: l_block @ - [S.if_ l_expr + [S.if_ l_expr (r_block @ [ S.assign v r_expr ] ) ] ) - ~value:(E.var v) + ~value:(E.var v) end end | Lprim {primitive = Psequor; args = [l;r]} @@ -98103,31 +98127,31 @@ and -> compile_lambda cxt @@ Lam.sequor l r | {should_return = ReturnFalse } -> - let new_cxt = {cxt with st = NeedValue} in + let new_cxt = {cxt with st = NeedValue} in match compile_lambda new_cxt l with | {value = None } -> assert false - | {block = l_block; value = Some l_expr} -> + | {block = l_block; value = Some l_expr} -> match compile_lambda new_cxt r with | {value = None} -> assert false - | {block = []; value = Some r_expr} -> + | {block = []; value = Some r_expr} -> let exp = E.or_ l_expr r_expr in - Js_output.output_of_block_and_expression + Js_output.output_of_block_and_expression st should_return lam l_block exp | {block = r_block; value = Some r_expr} -> - begin match cxt.st with - | Assign v -> + begin match cxt.st with + | Assign v -> (* Reference Js_output.output_of_block_and_expression *) - Js_output.make - (l_block @ + Js_output.make + (l_block @ [ S.if_ (E.not l_expr) (r_block @ [ S.assign v r_expr ]) ~else_:[S.assign v E.caml_true] ]) | Declare(_kind,v) -> - Js_output.make + Js_output.make ( - l_block @ + l_block @ [ S.define_variable ~kind:Variable v E.caml_true; S.if_ (E.not l_expr) (r_block @ [S.assign v r_expr]) @@ -98135,9 +98159,9 @@ and ) | EffectCall | NeedValue -> - let v = Ext_ident.create_tmp () in + let v = Ext_ident.create_tmp () in Js_output.make - ( l_block @ + ( l_block @ [S.define_variable ~kind:Variable v E.caml_true; S.if_ (E.not l_expr) (r_block @ [ @@ -98149,43 +98173,43 @@ and end end | Lprim {primitive = Pdebugger ; _} - -> - (* [%bs.debugger] guarantees that the expression does not matter + -> + (* [%bs.debugger] guarantees that the expression does not matter TODO: make it even safer *) - Js_output.output_of_block_and_expression st should_return lam + Js_output.output_of_block_and_expression st should_return lam S.debugger_block E.unit - (* TODO: - check the arity of fn before wrapping it - we need mark something that such eta-conversion can not be simplified in some cases + (* TODO: + check the arity of fn before wrapping it + we need mark something that such eta-conversion can not be simplified in some cases *) - | Lprim {primitive = Pjs_unsafe_downgrade (name,loc); + | Lprim {primitive = Pjs_unsafe_downgrade (name,loc); args = [obj]} - when not (Ext_string.ends_with name Literals.setter_suffix) - -> + when not (Ext_string.ends_with name Literals.setter_suffix) + -> (** either a getter {[ x #. height ]} or {[ x ## method_call ]} *) let property = Lam_methname.translate ~loc name in - begin + begin match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} obj - with - | {block; value = Some b } -> - let blocks, ret = + with + | {block; value = Some b } -> + let blocks, ret = if block = [] then [], E.dot b property - else - (match Js_ast_util.named_expression b with + else + (match Js_ast_util.named_expression b with | None -> block, E.dot b property - | Some (x, b) -> + | Some (x, b) -> (Ext_list.append block [x]), E.dot (E.var b) property ) - in - Js_output.output_of_block_and_expression st should_return lam - blocks ret - | _ -> assert false + in + Js_output.output_of_block_and_expression st should_return lam + blocks ret + | _ -> assert false end | Lprim {primitive = Pjs_fn_run arity; args = args_lambda} -> @@ -98196,147 +98220,147 @@ and 3. we need a location for Pccall in the call site *) - begin match args_lambda with + begin match args_lambda with | [Lprim{ - primitive = + primitive = Pjs_unsafe_downgrade(method_name,loc); args = [obj]} as fn; arg] - -> + -> begin - let need_value_no_return_cxt = {cxt with st = NeedValue; should_return = ReturnFalse} in - let obj_output = compile_lambda need_value_no_return_cxt obj in - let arg_output = compile_lambda need_value_no_return_cxt arg in - let cont obj_block arg_block obj_code = - Js_output.output_of_block_and_expression st should_return lam + let need_value_no_return_cxt = {cxt with st = NeedValue; should_return = ReturnFalse} in + let obj_output = compile_lambda need_value_no_return_cxt obj in + let arg_output = compile_lambda need_value_no_return_cxt arg in + let cont obj_block arg_block obj_code = + Js_output.output_of_block_and_expression st should_return lam ( match obj_code with | None -> Ext_list.append obj_block arg_block | Some obj_code -> Ext_list.append obj_block (obj_code :: arg_block) ) - in - match obj_output, arg_output with - | {block = obj_block; value = Some obj }, + in + match obj_output, arg_output with + | {block = obj_block; value = Some obj }, {block = arg_block; value = Some value} -> - if Ext_string.ends_with method_name Literals.setter_suffix then + if Ext_string.ends_with method_name Literals.setter_suffix then let property = Lam_methname.translate ~loc - (String.sub method_name 0 - (String.length method_name - Literals.setter_suffix_len)) in + (String.sub method_name 0 + (String.length method_name - Literals.setter_suffix_len)) in match Js_ast_util.named_expression obj with | None -> - cont obj_block arg_block None + cont obj_block arg_block None (E.seq (E.assign (E.dot obj property) value) E.unit) | Some (obj_code, obj) -> - cont obj_block arg_block (Some obj_code) + cont obj_block arg_block (Some obj_code) (E.seq (E.assign (E.dot (E.var obj) property) value) E.unit) - else + else compile_lambda cxt - (Lam.apply fn [arg] + (Lam.apply fn [arg] Location.none (* TODO *) App_js_full) - | _ -> - assert false + | _ -> + assert false end - | fn :: rest -> - compile_lambda cxt - (Lam.apply fn rest + | fn :: rest -> + compile_lambda cxt + (Lam.apply fn rest Location.none (*TODO*) App_js_full) - | _ -> assert false + | _ -> assert false end | Lprim {primitive = Pjs_fn_runmethod arity ; args } - -> - begin match args with + -> + begin match args with | (Lprim{primitive = Pjs_unsafe_downgrade (name,loc); - args = [ _ ]} as fn) + args = [ _ ]} as fn) :: _obj - :: rest -> + :: rest -> (* assert (Ident.same id2 id) ; *) - (* we ignore the computation of [_obj], - since our ast writer + (* we ignore the computation of [_obj], + since our ast writer {[ obj#.f (x,y) ]} --> - {[ runmethod2 f obj#.f x y]} + {[ runmethod2 f obj#.f x y]} *) compile_lambda cxt (Lam.apply fn rest loc App_js_full) - | _ -> assert false + | _ -> assert false end - | Lprim {primitive = Pjs_fn_method arity; args = args_lambda} -> - begin match args_lambda with - | [Lfunction{arity = len; function_kind; params; body} ] - when len = arity -> - Js_output.output_of_block_and_expression + | Lprim {primitive = Pjs_fn_method arity; args = args_lambda} -> + begin match args_lambda with + | [Lfunction{arity = len; function_kind; params; body} ] + when len = arity -> + Js_output.output_of_block_and_expression st - should_return - lam + should_return + lam [] (E.method_ params (* Invariant: jmp_table can not across function boundary, here we share env *) - (Js_output.output_as_block + (Js_output.output_as_block ( compile_lambda - { cxt with st = EffectCall; - should_return = ReturnTrue None; - jmp_table = Lam_compile_context.empty_handler_map} + { cxt with st = EffectCall; + should_return = ReturnTrue None; + jmp_table = Lam_compile_context.empty_handler_map} body))) - | _ -> assert false + | _ -> assert false end - | Lprim {primitive = Pjs_fn_make arity; args = [fn]; loc } -> + | Lprim {primitive = Pjs_fn_make arity; args = [fn]; loc } -> compile_lambda cxt (Lam_eta_conversion.unsafe_adjust_to_arity loc ~to_:arity ?from:None fn) - | Lprim {primitive = Pjs_fn_make arity; - args = [] | _::_::_ } -> - assert false - | Lglobal_module i -> - (* introduced by + | Lprim {primitive = Pjs_fn_make arity; + args = [] | _::_::_ } -> + assert false + | Lglobal_module i -> + (* introduced by 1. {[ include Array --> let include = Array ]} 2. inline functor application *) - let exp = Lam_compile_global.expand_global_module i env in - Js_output.output_of_block_and_expression st should_return lam [] exp + let exp = Lam_compile_global.expand_global_module i env in + Js_output.output_of_block_and_expression st should_return lam [] exp | Lprim{ primitive = Pjs_object_create labels ; args ; loc} - -> + -> let args_block, args_expr = Ext_list.split_map (fun (x : Lam.t) -> - match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} x - with + match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} x + with | {block = a; value = Some b} -> a,b | _ -> assert false ) args in let args_code = List.concat args_block in - let block, exp = + let block, exp = Lam_compile_external_obj.assemble_args_obj labels args_expr in - Js_output.output_of_block_and_expression st should_return lam - (Ext_list.append args_code block) exp + Js_output.output_of_block_and_expression st should_return lam + (Ext_list.append args_code block) exp - | Lprim{primitive = prim; args = args_lambda; loc} -> + | Lprim{primitive = prim; args = args_lambda; loc} -> let args_block, args_expr = Ext_list.split_map (fun (x : Lam.t) -> - match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} x - with + match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} x + with | {block = a; value = Some b} -> a,b - | _ -> assert false ) args_lambda + | _ -> assert false ) args_lambda in let args_code : J.block = List.concat args_block in let exp = (* TODO: all can be done in [compile_primitive] *) Lam_compile_primitive.translate loc cxt prim args_expr in - Js_output.output_of_block_and_expression st should_return lam args_code exp + Js_output.output_of_block_and_expression st should_return lam args_code exp | Lsequence (l1,l2) -> - let output_l1 = + let output_l1 = compile_lambda {cxt with st = EffectCall; should_return = ReturnFalse} l1 in - let output_l2 = + let output_l2 = compile_lambda cxt l2 in Js_output.append_output output_l1 output_l2 @@ -98344,7 +98368,7 @@ and | Lifthenelse(p,t_br,f_br) -> (* - This should be optimized in lambda layer + This should be optimized in lambda layer (let (match/1038 = (apply g/1027 x/1028)) (catch (stringswitch match/1038 @@ -98354,31 +98378,31 @@ and with (1) 2)) *) - begin - match compile_lambda {cxt with st = NeedValue ; should_return = ReturnFalse } p with + begin + match compile_lambda {cxt with st = NeedValue ; should_return = ReturnFalse } p with | {block = b; value = Some e} -> - begin match st with - | NeedValue -> + begin match st with + | NeedValue -> begin match - compile_lambda cxt t_br, - compile_lambda cxt f_br with - | {block = []; value = Some out1}, + compile_lambda cxt t_br, + compile_lambda cxt f_br with + | {block = []; value = Some out1}, {block = []; value = Some out2} -> (* speical optimization *) Js_output.make b ~value:(E.econd e out1 out2) - | _, _ -> - (* we can not reuse -- here we need they have the same name, + | _, _ -> + (* we can not reuse -- here we need they have the same name, TODO: could be optimized by inspecting assigment statement *) let id = Ext_ident.create_tmp () in (match compile_lambda {cxt with st = Assign id} t_br, compile_lambda {cxt with st = Assign id} f_br with - | out1 , out2 -> - Js_output.make - (Ext_list.append + | out1 , out2 -> + Js_output.make + (Ext_list.append (S.declare_variable ~kind:Variable id :: b) [ - S.if_ e - (Js_output.output_as_block out1) + S.if_ e + (Js_output.output_as_block out1) ~else_:(Js_output.output_as_block out2 ) ]) ~value:(E.var id) @@ -98386,173 +98410,173 @@ and end | Declare (kind,id) -> begin match - compile_lambda {cxt with st = NeedValue} t_br, - compile_lambda {cxt with st = NeedValue} f_br with + compile_lambda {cxt with st = NeedValue} t_br, + compile_lambda {cxt with st = NeedValue} f_br with | {block = []; value = Some out1}, - {block = []; value = Some out2} -> + {block = []; value = Some out2} -> (* Invariant: should_return is false*) - Js_output.make @@ + Js_output.make @@ Ext_list.append b [ S.define_variable ~kind id (E.econd e out1 out2) ] - | _, _ -> - Js_output.make + | _, _ -> + Js_output.make ( Ext_list.append b [ - S.if_ ~declaration:(kind,id) e - (Js_output.output_as_block @@ + S.if_ ~declaration:(kind,id) e + (Js_output.output_as_block @@ compile_lambda {cxt with st = Assign id} t_br) - ~else_:(Js_output.output_as_block @@ + ~else_:(Js_output.output_as_block @@ (compile_lambda {cxt with st = Assign id} f_br)) ]) end - | Assign id -> - (* -#if BS_DEBUG then - let () = Ext_log.dwarn __LOC__ "\n@[[TIME:]Lifthenelse: %f@]@." (Sys.time () *. 1000.) in -#end -*) + | Assign id -> + (* +#if BS_DEBUG then + let () = Ext_log.dwarn __LOC__ "\n@[[TIME:]Lifthenelse: %f@]@." (Sys.time () *. 1000.) in +#end +*) (* match - compile_lambda {cxt with st = NeedValue} t_br, - compile_lambda {cxt with st = NeedValue} f_br with - | {block = []; value = Some out1}, - {block = []; value = Some out2} -> + compile_lambda {cxt with st = NeedValue} t_br, + compile_lambda {cxt with st = NeedValue} f_br with + | {block = []; value = Some out1}, + {block = []; value = Some out2} -> (* Invariant: should_return is false *) Js_output.make [S.assign id (E.econd e out1 out2)] | _, _ -> *) - let then_output = - Js_output.output_as_block @@ + let then_output = + Js_output.output_as_block @@ (compile_lambda cxt t_br) in - let else_output = - Js_output.output_as_block @@ + let else_output = + Js_output.output_as_block @@ (compile_lambda cxt f_br) in Js_output.make (Ext_list.append b [ - S.if_ e + S.if_ e then_output ~else_:else_output ]) | EffectCall -> begin match should_return, - compile_lambda {cxt with st = NeedValue} t_br, - compile_lambda {cxt with st = NeedValue} f_br with + compile_lambda {cxt with st = NeedValue} t_br, + compile_lambda {cxt with st = NeedValue} f_br with (* see PR#83 *) - | ReturnFalse , {block = []; value = Some out1}, + | ReturnFalse , {block = []; value = Some out1}, {block = []; value = Some out2} -> begin match Js_exp_make.remove_pure_sub_exp out1 , Js_exp_make.remove_pure_sub_exp out2 with - | None, None -> Js_output.make (Ext_list.append b [ S.exp e]) + | None, None -> Js_output.make (Ext_list.append b [ S.exp e]) (* FIX #1762 *) - | Some out1, Some out2 -> + | Some out1, Some out2 -> Js_output.make b ~value:(E.econd e out1 out2) - | Some out1, None -> + | Some out1, None -> Js_output.make (Ext_list.append b [S.if_ e [S.exp out1]]) - | None, Some out2 -> + | None, Some out2 -> Js_output.make @@ (Ext_list.append b [S.if_ (E.not e) [S.exp out2] ]) end - | ReturnFalse , {block = []; value = Some out1}, _ -> - (* assert branch + | ReturnFalse , {block = []; value = Some out1}, _ -> + (* assert branch TODO: here we re-compile two branches since its context is different -- could be improved *) - if Js_analyzer.no_side_effect_expression out1 then + if Js_analyzer.no_side_effect_expression out1 then Js_output.make (Ext_list.append b [ S.if_ (E.not e) (Js_output.output_as_block @@ (compile_lambda cxt f_br))]) - else - Js_output.make - (Ext_list.append b [S.if_ e - (Js_output.output_as_block + else + Js_output.make + (Ext_list.append b [S.if_ e + (Js_output.output_as_block @@ compile_lambda cxt t_br) - ~else_:(Js_output.output_as_block @@ + ~else_:(Js_output.output_as_block @@ (compile_lambda cxt f_br))] ) - | ReturnFalse , _, {block = []; value = Some out2} -> - let else_ = - if Js_analyzer.no_side_effect_expression out2 then - None - else + | ReturnFalse , _, {block = []; value = Some out2} -> + let else_ = + if Js_analyzer.no_side_effect_expression out2 then + None + else Some ( Js_output.output_as_block @@ - compile_lambda cxt f_br) in - Js_output.make - (Ext_list.append b [S.if_ e + compile_lambda cxt f_br) in + Js_output.make + (Ext_list.append b [S.if_ e (Js_output.output_as_block @@ compile_lambda cxt t_br) ?else_]) - | ReturnTrue _, {block = []; value = Some out1}, + | ReturnTrue _, {block = []; value = Some out1}, {block = []; value = Some out2} -> - (* -#if BS_DEBUG then - let () = Ext_log.dwarn __LOC__ "\n@[[TIME:]Lifthenelse: %f@]@." (Sys.time () *. 1000.) in -#end + (* +#if BS_DEBUG then + let () = Ext_log.dwarn __LOC__ "\n@[[TIME:]Lifthenelse: %f@]@." (Sys.time () *. 1000.) in +#end *) - Js_output.make - (Ext_list.append b [S.return_stmt (E.econd e out1 out2)]) ~finished:True + Js_output.make + (Ext_list.append b [S.return_stmt (E.econd e out1 out2)]) ~finished:True | _, _, _ -> - (* -#if BS_DEBUG then - let () = Ext_log.dwarn __LOC__ "\n@[[TIME:]Lifthenelse: %f@]@." (Sys.time () *. 1000.) in -#end + (* +#if BS_DEBUG then + let () = Ext_log.dwarn __LOC__ "\n@[[TIME:]Lifthenelse: %f@]@." (Sys.time () *. 1000.) in +#end *) - let then_output = - Js_output.output_as_block @@ + let then_output = + Js_output.output_as_block @@ (compile_lambda cxt t_br) in - let else_output = - Js_output.output_as_block @@ + let else_output = + Js_output.output_as_block @@ (compile_lambda cxt f_br) in Js_output.make (Ext_list.append b [ - S.if_ e + S.if_ e then_output ~else_:else_output ]) end end - | {value = None } -> assert false + | {value = None } -> assert false end - | Lstringswitch(l, cases, default) -> + | Lstringswitch(l, cases, default) -> - (* TODO might better optimization according to the number of cases + (* TODO might better optimization according to the number of cases Be careful: we should avoid multiple evaluation of l, The [gen] can be elimiated when number of [cases] is less than 3 *) begin - match compile_lambda {cxt with should_return = ReturnFalse ; st = NeedValue} l + match compile_lambda {cxt with should_return = ReturnFalse ; st = NeedValue} l with - | {block ; value = Some e} -> - (* when should_return is true -- it's passed down + | {block ; value = Some e} -> + (* when should_return is true -- it's passed down otherwise it's ok *) - let default = - match default with - | Some x -> Default x + let default = + match default with + | Some x -> Default x | None -> Complete in begin - match st with + match st with (* TODO: can be avoided when cases are less than 3 *) - | NeedValue -> - let v = Ext_ident.create_tmp () in + | NeedValue -> + let v = Ext_ident.create_tmp () in Js_output.make (Ext_list.append block @@ - compile_string_cases + compile_string_cases {cxt with st = Declare (Variable, v)} e cases default) ~value:(E.var v) - | _ -> - Js_output.make + | _ -> + Js_output.make (Ext_list.append block @@ compile_string_cases cxt e cases default) end - | _ -> assert false + | _ -> assert false end | Lswitch(lam, - {sw_numconsts; + {sw_numconsts; sw_consts; sw_numblocks; sw_blocks; - sw_failaction = default }) - -> + sw_failaction = default }) + -> (* TODO: if default is None, we can do some optimizations Use switch vs if/then/else @@ -98560,64 +98584,64 @@ and also if last statement is throw -- should we drop remaining statement? *) - let sw_num_default = - match default with - | None -> Complete - | Some x -> - if Ext_list.length_ge sw_consts sw_numconsts + let sw_num_default = + match default with + | None -> Complete + | Some x -> + if Ext_list.length_ge sw_consts sw_numconsts then Complete - else Default x in - let sw_blocks_default = - match default with - | None -> Complete - | Some x -> + else Default x in + let sw_blocks_default = + match default with + | None -> Complete + | Some x -> if Ext_list.length_ge sw_blocks sw_numblocks then Complete - else Default x in + else Default x in let compile_whole ({st; _} as cxt : Lam_compile_context.t ) = - match sw_numconsts, sw_numblocks, + match sw_numconsts, sw_numblocks, compile_lambda {cxt with should_return = ReturnFalse; st = NeedValue} - lam with + lam with | 0 , _ , {block; value = Some e} -> compile_cases cxt (E.tag e ) sw_blocks sw_blocks_default - | _, 0, {block; value = Some e} -> + | _, 0, {block; value = Some e} -> compile_cases cxt e sw_consts sw_num_default | _, _, { block; value = Some e} -> (* [e] will be used twice *) - let dispatch e = + let dispatch e = [ - S.if_ + S.if_ (E.is_type_number e ) (compile_cases cxt e sw_consts sw_num_default ) (* default still needed, could simplified*) ~else_: - (compile_cases cxt (E.tag e ) sw_blocks + (compile_cases cxt (E.tag e ) sw_blocks sw_blocks_default) - ] in + ] in begin - match e.expression_desc with - | J.Var _ -> dispatch e - | _ -> - let v = Ext_ident.create_tmp () in + 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) end - | _, _, {value = None; _} -> assert false + | _, _, {value = None; _} -> assert false in begin match st with (* Needs declare first *) - | NeedValue -> - (* Necessary since switch is a statement, we need they return - the same value for different branches -- can be optmized + | NeedValue -> + (* Necessary since switch is a statement, we need they return + the same value for different branches -- can be optmized when branches are minimial (less than 2) *) let v = Ext_ident.create_tmp () in - Js_output.make - (S.declare_variable ~kind:Variable v :: + Js_output.make + (S.declare_variable ~kind:Variable v :: compile_whole {cxt with st = Assign v}) ~value:(E.var v) - | Declare (kind,id) -> + | Declare (kind,id) -> Js_output.make (S.declare_variable ~kind id :: compile_whole {cxt with st = Assign id} ) | EffectCall | Assign _ -> Js_output.make (compile_whole cxt) @@ -98626,18 +98650,18 @@ and | Lstaticraise(i, largs) -> (* TODO handlding *largs*) (* [i] is the jump table, [largs] is the arguments passed to [Lstaticcatch]*) begin - match Lam_compile_context.find_exn i cxt with - | {exit_id; args ; order_id} -> + match Lam_compile_context.find_exn i cxt with + | {exit_id; args ; order_id} -> let args_code = (Js_output.concat @@ Ext_list.map2 ( fun (x : Lam.t) (arg : Ident.t) -> match x with - | Lvar id -> + | Lvar id -> Js_output.make [S.assign arg (E.var id)] | _ -> (* TODO: should be Assign -- Assign is an optimization *) - compile_lambda {cxt with st = Assign arg ; should_return = ReturnFalse} x - ) largs (args : Ident.t list)) + compile_lambda {cxt with st = Assign arg ; should_return = ReturnFalse} x + ) largs (args : Ident.t list)) in Js_output.append_output args_code (* Declared in [Lstaticraise ]*) (Js_output.make [S.assign exit_id (E.small_int order_id)] @@ -98646,35 +98670,35 @@ and Js_output.make [S.unknown_lambda ~comment:"error" lam] (* staticraise is always enclosed by catch *) end - (* Invariant: code can not be reused + (* Invariant: code can not be reused (catch l with (32) (handler)) 32 should not be used in another catch - Assumption: + Assumption: This is true in current ocaml compiler currently exit only appears in should_return position relative to staticcatch if not we should use ``javascript break`` or ``continue`` *) - | Lstaticcatch _ -> + | Lstaticcatch _ -> let code_table, body = flatten_caches lam in let bindings = Ext_list.flat_map (fun (_,_,bindings) -> bindings) code_table in (* compile_list name l false (\*\) *) - (* if exit_code_id == code - handler -- ids are not useful, since + (* if exit_code_id == code + handler -- ids are not useful, since when compiling `largs` we will do the binding there - - when exit_code is undefined internally, + - when exit_code is undefined internally, it should PRESERVE ``tail`` property - - if it uses `staticraise` only once + - if it uses `staticraise` only once or handler is minimal, we can inline - always inline also seems to be ok, but it might bloat the code - another common scenario is that we have nested catch (catch (catch (catch ..)) *) (* - checkout example {!Digest.file}, you can not inline handler there, + checkout example {!Digest.file}, you can not inline handler there, we can spot such patten and use finally there? {[ let file filename = @@ -98688,100 +98712,100 @@ and (* TODO: handle NeedValue *) let exit_id = Ext_ident.create_tmp ~name:"exit" () in let exit_expr = E.var exit_id in - let jmp_table, handlers = + let jmp_table, handlers = Lam_compile_context.add_jmps exit_id code_table jmp_table in (* Declaration First, body and handler have the same value *) (* There is a bug in google closure compiler: - https://github.com/google/closure-compiler/issues/1234#issuecomment-151976340 + https://github.com/google/closure-compiler/issues/1234#issuecomment-151976340 TODO: wait for a bug fix *) - let declares = + let declares = S.define_variable ~kind:Variable exit_id - E.zero_int_literal :: + E.zero_int_literal :: (* we should always make it zero here, since [zero] is reserved in our mapping*) Ext_list.map (fun x -> S.declare_variable ~kind:Variable x ) bindings in - begin match st with + begin match st with (* could be optimized when cases are less than 3 *) - | NeedValue -> - let v = Ext_ident.create_tmp () in - let lbody = compile_lambda {cxt with + | NeedValue -> + let v = Ext_ident.create_tmp () in + let lbody = compile_lambda {cxt with jmp_table = jmp_table; st = Assign v } body in - Js_output.append_output + Js_output.append_output (Js_output.make (S.declare_variable ~kind:Variable v :: declares) ) (Js_output.append_output lbody (Js_output.make ( - compile_cases + compile_cases {cxt with st = Assign v; - jmp_table = jmp_table} + jmp_table = jmp_table} exit_expr handlers NonComplete) ~value:(E.var v ))) | Declare (kind, id) (* declare first this we will do branching*) -> - let declares = - S.declare_variable ~kind id :: declares in + let declares = + S.declare_variable ~kind id :: declares in let lbody = compile_lambda {cxt with jmp_table = jmp_table; st = Assign id } body in Js_output.append_output (Js_output.make declares) - (Js_output.append_output lbody - (Js_output.make (compile_cases - {cxt with jmp_table = jmp_table; st = Assign id} - exit_expr + (Js_output.append_output lbody + (Js_output.make (compile_cases + {cxt with jmp_table = jmp_table; st = Assign id} + exit_expr handlers NonComplete - (* place holder -- tell the compiler that + (* place holder -- tell the compiler that we don't know if it's complete *) ))) - | EffectCall | Assign _ -> + | EffectCall | Assign _ -> let lbody = compile_lambda {cxt with jmp_table = jmp_table } body in Js_output.append_output (Js_output.make declares) - (Js_output.append_output lbody + (Js_output.append_output lbody (Js_output.make (compile_cases {cxt with jmp_table = jmp_table} exit_expr handlers NonComplete))) end - | Lwhile(p,body) -> + | Lwhile(p,body) -> (* Note that ``J.While(expression * statement )`` idealy if ocaml expression does not need fresh variables, we can generate - while expression, here we generate for statement, leave optimization later. + while expression, here we generate for statement, leave optimization later. (Sine OCaml expression can be really complex..) *) - (match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse } p - with - | {block; value = Some e} -> + (match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse } p + with + | {block; value = Some e} -> (* st = NeedValue -- this should be optimized and never happen *) - let e = + let e = match block with - | [] -> e + | [] -> e | _ -> E.of_block block ~e in - let block = + let block = [ S.while_ e - (Js_output.output_as_block @@ - compile_lambda + (Js_output.output_as_block @@ + compile_lambda {cxt with st = EffectCall; should_return = ReturnFalse} body) ] in begin - match st, should_return with + match st, should_return with | Declare (_kind, x), _ -> (* FIXME _kind not used *) Js_output.make (Ext_list.append block [S.declare_unit x ]) | Assign x, _ -> Js_output.make (Ext_list.append block [S.assign_unit x ]) - | EffectCall, ReturnTrue _ -> + | EffectCall, ReturnTrue _ -> Js_output.make (Ext_list.append block S.return_unit) ~finished:True | EffectCall, _ -> Js_output.make block | NeedValue, _ -> Js_output.make block ~value:E.unit end | _ -> assert false ) - | Lfor (id,start,finish,direction,body) -> + | Lfor (id,start,finish,direction,body) -> (* all non-tail *) - (* TODO: check semantics should start, finish be executed each time in both + (* TODO: check semantics should start, finish be executed each time in both ocaml and js?, also check evaluation order.. in ocaml id is not in the scope of finish, so it should be safe here @@ -98795,10 +98819,10 @@ and let block = begin match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} start, - compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} finish with - | {block = b1; value = Some e1}, {block = b2; value = Some e2} -> + compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} finish with + | {block = b1; value = Some e1}, {block = b2; value = Some e2} -> - (* order b1 -- (e1 -- b2 -- e2) + (* order b1 -- (e1 -- b2 -- e2) in most cases we can shift it into such scenarios b1, b2, [e1, e2] - b2 is Empty @@ -98808,32 +98832,32 @@ and *) - begin + begin match b1,b2 with - | _,[] -> - Ext_list.append b1 [S.for_ (Some e1) e2 id direction - (Js_output.output_as_block @@ + | _,[] -> + Ext_list.append b1 [S.for_ (Some e1) e2 id direction + (Js_output.output_as_block @@ compile_lambda {cxt with should_return = ReturnFalse ; st = EffectCall} body) ] - | _, _ when Js_analyzer.no_side_effect_expression e1 - (* + | _, _ when Js_analyzer.no_side_effect_expression e1 + (* e1 > b2 > e2 - re-order + re-order b2 > e1 > e2 *) - -> - Ext_list.append b1 - (Ext_list.append b2 [S.for_ (Some e1) e2 id direction - (Js_output.output_as_block @@ + -> + Ext_list.append b1 + (Ext_list.append b2 [S.for_ (Some e1) e2 id direction + (Js_output.output_as_block @@ compile_lambda {cxt with should_return = ReturnFalse ; st = EffectCall} body) ]) | _ , _ - -> + -> Ext_list.append b1 (S.define_variable ~kind:Variable id e1 :: (Ext_list.append b2 [ - S.for_ None e2 id direction - (Js_output.output_as_block @@ + S.for_ None e2 id direction + (Js_output.output_as_block @@ compile_lambda {cxt with should_return = ReturnFalse ; st = EffectCall} - body) + body) ])) end @@ -98841,78 +98865,78 @@ and | _ -> assert false end in begin - match st, should_return with + match st, should_return with | EffectCall, ReturnFalse -> Js_output.make block - | EffectCall, ReturnTrue _ -> + | EffectCall, ReturnTrue _ -> Js_output.make (Ext_list.append block S.return_unit ) ~finished:True (* unit -> 0, order does not matter *) | (Declare _ | Assign _), ReturnTrue _ -> Js_output.make [S.unknown_lambda lam] - | Declare (_kind, x), ReturnFalse -> + | Declare (_kind, x), ReturnFalse -> (* FIXME _kind unused *) Js_output.make (Ext_list.append block [S.declare_unit x ]) - | Assign x, ReturnFalse -> + | Assign x, ReturnFalse -> Js_output.make (Ext_list.append block [S.assign_unit x ]) - | NeedValue, _ - -> + | NeedValue, _ + -> Js_output.make block ~value:E.unit (* TODO: fixme, here it's ok*) end - | Lassign(id,lambda) -> - let block = + | Lassign(id,lambda) -> + let block = match lambda with | Lprim {primitive = Poffsetint v; args = [Lvar id']} when Ident.same id id' -> - [ S.exp (E.assign (E.var id) + [ S.exp (E.assign (E.var id) (E.int32_add (E.var id) (E.small_int v))) ] | _ -> - begin - match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} lambda with - | {block = b; value = Some v} -> + begin + match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} lambda with + | {block = b; value = Some v} -> (Ext_list.append b [S.assign id v ]) - | _ -> assert false + | _ -> assert false end in begin - match st, should_return with + match st, should_return with | EffectCall, ReturnFalse -> Js_output.make block - | EffectCall, ReturnTrue _ -> + | EffectCall, ReturnTrue _ -> Js_output.make (Ext_list.append block S.return_unit ) ~finished:True - | (Declare _ | Assign _ ) , ReturnTrue _ -> + | (Declare _ | Assign _ ) , ReturnTrue _ -> Js_output.make [S.unknown_lambda lam] (* bound by a name, while in a tail position, this can not happen *) | Declare (_kind, x) , ReturnFalse -> (* FIXME: unused *) Js_output.make (Ext_list.append block [ S.declare_unit x ]) | Assign x, ReturnFalse -> Js_output.make (Ext_list.append block [S.assign_unit x ]) - | NeedValue, _ -> + | NeedValue, _ -> Js_output.make block ~value:E.unit end | (Ltrywith( (Lprim {primitive = Pccall {prim_name = "caml_sys_getenv"; _}; args = [Lconst _]} as body), - id, + id, Lifthenelse (Lprim{primitive = Pintcomp(Ceq); - args = [Lvar id2 ; + args = [Lvar id2 ; Lprim{primitive = Pglobal_exception {name = "Not_found"}; _}]}, cont, _reraise ) ) | Ltrywith( (Lprim {primitive = Pccall {prim_name = "caml_sys_getenv"; _}; args = [Lconst _]} as body), - id, + id, Lifthenelse(Lprim{primitive = Pintcomp(Ceq); - args = [ + args = [ Lprim { primitive = Pglobal_exception {name = "Not_found"; _}; _}; Lvar id2 ]}, cont, _reraise ) - )) when Ident.same id id2 - -> + )) when Ident.same id id2 + -> compile_lambda cxt (Lam.try_ body id cont) | Ltrywith(lam,id, catch) -> (* generate documentation *) - (* - tail --> should be renamed to `shouldReturn` - in most cases ``shouldReturn`` == ``tail``, however, here is not, + (* + tail --> should be renamed to `shouldReturn` + in most cases ``shouldReturn`` == ``tail``, however, here is not, should return, but it is not a tail call in js (* could be optimized using javascript style exceptions *) {[ @@ -98923,39 +98947,39 @@ and } ]} *) - let aux st = + let aux st = (* should_return is passed down *) (* #1701 *) - [ S.try_ - (Js_output.output_as_block (compile_lambda - (match should_return with + [ S.try_ + (Js_output.output_as_block (compile_lambda + (match should_return with | ReturnTrue (Some _ ) -> {cxt with st = st; should_return = ReturnTrue None} | ReturnTrue None | ReturnFalse -> {cxt with st = st}) lam)) - ~with_:(id, - Js_output.output_as_block @@ + ~with_:(id, + Js_output.output_as_block @@ compile_lambda {cxt with st = st} catch ) - ] in + ] in begin - match st with - | NeedValue -> + match st with + | NeedValue -> let v = Ext_ident.create_tmp () in Js_output.make (S.declare_variable ~kind:Variable v :: aux (Assign v)) ~value:(E.var v ) - | Declare (kind, id) -> + | Declare (kind, id) -> Js_output.make (S.declare_variable ~kind id :: aux (Assign id)) | Assign _ | EffectCall -> Js_output.make (aux st) end - | Lsend(meth_kind,met, obj, args,loc) -> - (* Note that in [Texp_apply] for [%sendcache] the cache might not be used + | Lsend(meth_kind,met, obj, args,loc) -> + (* Note that in [Texp_apply] for [%sendcache] the cache might not be used see {!CamlinternalOO.send_meth} and {!Translcore.transl_exp0} the branch [Texp_apply] when [public_send ], args are simply dropped - reference - [js_of_ocaml] + reference + [js_of_ocaml] 1. GETPUBMET 2. GETDYNMET 3. GETMETHOD @@ -98979,7 +99003,7 @@ and Obj.obj (set_id obj) end ]} - it's a block with tag [248], the first field is [table.methods] which is an array + it's a block with tag [248], the first field is [table.methods] which is an array {[ type table = { mutable size: int; @@ -98996,79 +99020,79 @@ and *) - begin match - (met :: obj :: args) - |> Ext_list.split_map (fun (x : Lam.t) -> - match x with + begin match + (met :: obj :: args) + |> Ext_list.split_map (fun (x : Lam.t) -> + match x with | Lprim {primitive = Pccall {prim_name ; _}; args = []} (* nullary external call*) - -> + -> [], E.var (Ext_ident.create_js prim_name) - | _ -> + | _ -> begin match compile_lambda {cxt with st = NeedValue; should_return = ReturnFalse} x with - | {block = a; value = Some b} -> a, b + | {block = a; value = Some b} -> a, b | _ -> assert false end - ) with + ) with | _, ([] | [_]) -> assert false - | (args_code, label::nobj::args) - -> - let cont3 nobj k = - match Js_ast_util.named_expression nobj with - | None -> + | (args_code, label::nobj::args) + -> + let cont3 nobj k = + match Js_ast_util.named_expression nobj with + | None -> let cont = - Js_output.output_of_block_and_expression + Js_output.output_of_block_and_expression st should_return lam (List.concat args_code) in cont (k nobj) - | Some (obj_code, v) -> - let cont2 obj_code v = - Js_output.output_of_block_and_expression - st should_return lam - ( List.concat args_code @ [obj_code]) v in - let cobj = E.var v in - cont2 obj_code (k cobj) + | Some (obj_code, v) -> + let cont2 obj_code v = + Js_output.output_of_block_and_expression + st should_return lam + ( List.concat args_code @ [obj_code]) v in + let cobj = E.var v in + cont2 obj_code (k cobj) in begin - match meth_kind with - | Self -> + match meth_kind with + | Self -> (* TODO: horrible hack -- fixed later *) - cont3 nobj (fun aobj -> E.call ~info:Js_call_info.dummy - (Js_of_lam_array.ref_array + cont3 nobj (fun aobj -> E.call ~info:Js_call_info.dummy + (Js_of_lam_array.ref_array (Js_of_lam_record.field Fld_na aobj 0l) label ) (aobj :: args)) - (* [E.small_int 1] is because we use array, - when we change the runtime represenation, it needs to be adapted + (* [E.small_int 1] is because we use array, + when we change the runtime represenation, it needs to be adapted *) | Cached | Public None (* TODO: check -- 1. js object propagate 2. js object create *) - -> + -> let get = E.runtime_ref Js_runtime_modules.oo "caml_get_public_method" in let cache = !method_cache_id in let () = incr method_cache_id in - cont3 nobj (fun obj' -> - E.call ~info:Js_call_info.dummy - (E.call ~info:Js_call_info.dummy get + cont3 nobj (fun obj' -> + E.call ~info:Js_call_info.dummy + (E.call ~info:Js_call_info.dummy get [obj'; label; E.small_int cache]) (obj'::args) ) (* avoid duplicated compuattion *) - | Public (Some name) -> + | Public (Some name) -> let cache = !method_cache_id in incr method_cache_id ; - cont3 nobj - (fun aobj -> E.public_method_call name aobj label + cont3 nobj + (fun aobj -> E.public_method_call name aobj label (Int32.of_int cache) args ) end end (* [J.Empty,J.N] *) (* TODO debugging, sourcemap, ignore lambda_event currently *) - (* + (* seems to be an optimization trick for [translclass] | Lifused(v, l) -> if count_var v > 0 then simplif l else lambda_unit From 1c17a4653b03b386997bdcccff9f20107dfffeaa Mon Sep 17 00:00:00 2001 From: Hongbo Zhang Date: Sat, 17 Mar 2018 14:50:17 +0800 Subject: [PATCH 3/8] tweaks --- jscomp/core/js_output.ml | 146 +++++++++---------- jscomp/core/js_output.mli | 38 ++--- jscomp/core/lam_compile.ml | 107 +++++++------- lib/whole_compiler.ml | 291 +++++++++++++++++++------------------ 4 files changed, 298 insertions(+), 284 deletions(-) diff --git a/jscomp/core/js_output.ml b/jscomp/core/js_output.ml index f8cd8d54eb3..0f7f71e6aa5 100644 --- a/jscomp/core/js_output.ml +++ b/jscomp/core/js_output.ml @@ -1,5 +1,5 @@ (* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -17,124 +17,124 @@ * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -module E = Js_exp_make -module S = Js_stmt_make +module E = Js_exp_make +module S = Js_stmt_make -type finished = - | True - | False +type finished = + | True + | False | Dummy (* Have no idea, so that when [++] is applied, always use the other *) -type t = { +type t = { block : J.block ; value : J.expression option; - finished : finished ; + output_finished : finished ; } type continuation = Lam_compile_context.continuation -let make ?value ?(finished=False) block = - { block ; value ; finished } +let make ?value ?(output_finished=False) block = + { block ; value ; output_finished } -let dummy = - {value = None; block = []; finished = Dummy } +let dummy = + {value = None; block = []; output_finished = Dummy } -let output_of_expression +let output_of_expression (continuation : continuation) (should_return : Lam_compile_context.return_type) (lam : Lam.t) (exp : J.expression) : t = - begin match continuation, should_return with - | EffectCall, ReturnFalse -> - if Lam_analysis.no_side_effects lam + begin match continuation, should_return with + | EffectCall, ReturnFalse -> + if Lam_analysis.no_side_effects lam then dummy - else {block = []; value = Some exp ; finished = False} - | Declare (kind, n), ReturnFalse -> + else {block = []; value = Some exp ; output_finished = False} + | Declare (kind, n), ReturnFalse -> make [ S.define_variable ~kind n exp] - | Assign n ,ReturnFalse -> + | Assign n ,ReturnFalse -> make [S.assign n exp ] | EffectCall, ReturnTrue _ -> - make [S.return_stmt exp] ~finished:True - | (Declare _ | Assign _ ), ReturnTrue _ -> - make [S.unknown_lambda lam] ~finished:True - | NeedValue, _ -> - {block = []; value = Some exp; finished = False } + make [S.return_stmt exp] ~output_finished:True + | (Declare _ | Assign _ ), ReturnTrue _ -> + make [S.unknown_lambda lam] ~output_finished:True + | NeedValue, _ -> + {block = []; value = Some exp; output_finished = False } end -let output_of_block_and_expression - (continuation : continuation) +let output_of_block_and_expression + (continuation : continuation) (should_return : Lam_compile_context.return_type) - (lam : Lam.t) (block : J.block) exp : t = - match continuation, should_return with + (lam : Lam.t) (block : J.block) exp : t = + match continuation, should_return with | EffectCall, ReturnFalse -> make block ~value:exp - | Declare (kind,n), ReturnFalse -> + | Declare (kind,n), ReturnFalse -> make (block @ [ S.define_variable ~kind n exp]) - | Assign n, ReturnFalse -> make (block @ [S.assign n exp]) - | EffectCall, ReturnTrue _ -> make (block @ [S.return_stmt exp]) ~finished:True + | Assign n, ReturnFalse -> make (block @ [S.assign n exp]) + | EffectCall, ReturnTrue _ -> make (block @ [S.return_stmt exp]) ~output_finished:True | (Declare _ | Assign _), ReturnTrue _ -> - make [S.unknown_lambda lam] ~finished:True - | NeedValue, (ReturnTrue _ | ReturnFalse) -> + make [S.unknown_lambda lam] ~output_finished:True + | NeedValue, (ReturnTrue _ | ReturnFalse) -> make block ~value:exp -let block_with_opt_expr block (x : J.expression option) : J.block = - match x with +let block_with_opt_expr block (x : J.expression option) : J.block = + match x with | None -> block | Some x when Js_analyzer.no_side_effect_expression x -> block | Some x -> block @ [S.exp x ] -let opt_expr_with_block (x : J.expression option) block : J.block = - match x with +let opt_expr_with_block (x : J.expression option) block : J.block = + match x with | None -> block | Some x when Js_analyzer.no_side_effect_expression x -> block | Some x -> (S.exp x) :: block - -let rec unnest_block (block : J.block) : J.block = - match block with - | [{statement_desc = Block block}] -> unnest_block block - | _ -> block -let output_as_block ( x : t) : J.block = - match x with - | {block; value = opt; finished} -> +let rec unnest_block (block : J.block) : J.block = + match block with + | [{statement_desc = Block block}] -> unnest_block block + | _ -> block + +let output_as_block ( x : t) : J.block = + match x with + | {block; value = opt; output_finished} -> let block = unnest_block block in - if finished = True then block - else + if output_finished = True then block + else block_with_opt_expr block opt - -let to_break_block (x : t) : J.block * bool = - let block = unnest_block x.block in - match x with - | {finished = True; _ } -> + +let to_break_block (x : t) : J.block * bool = + let block = unnest_block x.block in + match x with + | {output_finished = True; _ } -> block, false (* value does not matter when [finished] is true TODO: check if it has side efects *) - | { value = None; finished } -> - block, - (match finished with | True -> false | (False | Dummy) -> true ) + | { value = None; output_finished } -> + block, + (match output_finished with | True -> false | (False | Dummy) -> true ) - | {value = Some _ as opt; _} -> + | {value = Some _ as opt; _} -> block_with_opt_expr block opt, true (** TODO: make everything expression make inlining hard, and code not readable? - 1. readability dpends on how we print the expression + 1. readability dpends on how we print the expression 2. inlining needs generate symbols, which are statements, type mismatch we need capture [Exp e] - can we call them all [statement]? statement has no value + can we call them all [statement]? statement has no value *) (* | {block = [{statement_desc = Exp e }]; value = None ; _}, _ *) (* -> *) @@ -142,35 +142,35 @@ let to_break_block (x : t) : J.block * bool = (* | _ , {block = [{statement_desc = Exp e }]; value = None ; _} *) (* -> *) (* append x { y with block = []; value = Some e} *) - -let rec append_output (x : t ) (y : t ) : t = + +let rec append_output (x : t ) (y : t ) : t = match x , y with (* ATTTENTION: should not optimize [opt_e2], it has to conform to [NeedValue]*) - | {finished = True; _ }, _ -> x - | _, {block = []; value= None; finished = Dummy } -> x + | { output_finished = True; _ }, _ -> x + | _, {block = []; value= None; output_finished = Dummy } -> x (* finished = true --> value = E.undefined otherwise would throw*) - | {block = []; value= None; _ }, y -> y - | {block = []; value= Some _; _}, {block = []; value= None; _ } -> x - | {block = []; value = Some e1; _}, ({block = []; value = Some e2; finished } as z) -> - if Js_analyzer.no_side_effect_expression e1 + | {block = []; value= None; _ }, y -> y + | {block = []; value= Some _; _}, {block = []; value= None; _ } -> x + | {block = []; value = Some e1; _}, ({block = []; value = Some e2; output_finished } as z) -> + if Js_analyzer.no_side_effect_expression e1 then z (* It would optimize cases like [module aliases] - Bigarray, List + Bigarray, List *) else - {block = []; value = Some (E.seq e1 e2); finished} + {block = []; value = Some (E.seq e1 e2); output_finished} (* {block = [S.exp e1]; value = Some e2(\* (E.seq e1 e2) *\); finished} *) - | {block = block1; value = opt_e1; _}, {block = block2; value = opt_e2; finished} -> + | {block = block1; value = opt_e1; _}, {block = block2; value = opt_e2; output_finished} -> let block1 = unnest_block block1 in make (block1 @ (opt_expr_with_block opt_e1 @@ unnest_block block2)) - ?value:opt_e2 ~finished + ?value:opt_e2 ~output_finished:output_finished (* Fold right is more efficient *) -let concat (xs : t list) : t = +let concat (xs : t list) : t = Ext_list.fold_right (fun x acc -> append_output x acc) xs dummy -let to_string x = +let to_string x = Js_dump.string_of_block (output_as_block x) diff --git a/jscomp/core/js_output.mli b/jscomp/core/js_output.mli index 8fde83b8d0f..6b8e797373b 100644 --- a/jscomp/core/js_output.mli +++ b/jscomp/core/js_output.mli @@ -1,5 +1,5 @@ (* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -17,7 +17,7 @@ * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) @@ -31,30 +31,30 @@ (** The intemediate output when compiling lambda into JS IR *) -(* Hongbo Should we rename this module js_of_lambda since it looks like it's +(* Hongbo Should we rename this module js_of_lambda since it looks like it's containing that step *) -type finished = - | True - | False +type finished = + | True + | False | Dummy (* Have no idea, so that when [++] is applied, always use the other *) -type t = { +type t = { block : J.block ; value : J.expression option; - finished : finished + output_finished : finished } -(** When [finished] is true the block is already terminated, +(** When [finished] is true the block is already terminated, value does not make sense [finished] default to false, which is conservative *) val make : ?value: J.expression -> - ?finished:finished -> + ?output_finished:finished -> J.block -> t @@ -64,27 +64,27 @@ val output_as_block : val to_break_block : t -> - J.block * bool - (* the second argument is + J.block * bool + (* the second argument is [true] means [break] needed When we know the output is gonna finished true - we can reduce + we can reduce {[ - return xx ; + return xx ; break ]} - into + into {[ - return ; + return ; ]} *) -val append_output: t -> t -> t +val append_output: t -> t -> t -val dummy : t +val dummy : t val output_of_expression : @@ -94,7 +94,7 @@ val output_of_expression : J.expression -> (* compiled expression *) t -val output_of_block_and_expression : +val output_of_block_and_expression : Lam_compile_context.continuation -> Lam_compile_context.return_type -> Lam.t -> diff --git a/jscomp/core/lam_compile.ml b/jscomp/core/lam_compile.ml index 670e89a8189..41f201f5a68 100644 --- a/jscomp/core/lam_compile.ml +++ b/jscomp/core/lam_compile.ml @@ -428,19 +428,16 @@ and compile_general_cases (switch_exp : J.expression) (table : (_ * Lam.t) list) (default : default_case) -> - let wrap (cxt : Lam_compile_context.t) k = - let cxt, define = + let morph_declare_to_assign (cxt : Lam_compile_context.t) k = match cxt.st with | Declare (kind, did) -> - {cxt with st = Assign did}, Some (kind,did) - | _ -> cxt, None - in - k cxt define + k {cxt with st = Assign did} (Some (kind,did)) + | _ -> k cxt None in match table, default with | [], Default lam -> - Js_output.output_as_block (compile_lambda cxt lam) + Js_output.output_as_block (compile_lambda cxt lam) | [], (Complete | NonComplete) -> [] | [(id,lam)],Complete -> (* To take advantage of such optimizations, @@ -452,19 +449,20 @@ and compile_general_cases Js_output.output_as_block (compile_lambda cxt lam) | [(id,lam)], NonComplete -> - wrap cxt @@ fun cxt define -> - [S.if_ ?declaration:define (eq_exp switch_exp (make_exp id) ) - (Js_output.output_as_block @@ compile_lambda cxt lam )] + morph_declare_to_assign cxt (fun cxt define -> + [S.if_ ?declaration:define (eq_exp switch_exp (make_exp id) ) + (Js_output.output_as_block (compile_lambda cxt lam) ) + ]) | ([(id,lam)], Default x) | ([(id,lam); (_,x)], Complete) -> - wrap cxt @@ fun cxt define -> - let else_block = Js_output.output_as_block (compile_lambda cxt x) in - let then_block = Js_output.output_as_block (compile_lambda cxt lam) in - [ S.if_ ?declaration:define (eq_exp switch_exp (make_exp id) ) - then_block - ~else_:else_block - ] + morph_declare_to_assign cxt (fun cxt define -> + let else_block = Js_output.output_as_block (compile_lambda cxt x) in + let then_block = Js_output.output_as_block (compile_lambda cxt lam) in + [ S.if_ ?declaration:define (eq_exp switch_exp (make_exp id) ) + then_block + ~else_:else_block + ]) | _ , _ -> (* TODO: this is not relevant to switch case however, in a subset of switch-case if we can analysis @@ -474,34 +472,38 @@ and compile_general_cases TODO: grouping can be delayed untile JS IR *) (*TOOD: disabled temporarily since it's not perfect yet *) - wrap cxt @@ fun cxt declaration -> - let default = - match default with - | Complete -> None - | NonComplete -> None - | Default lam -> Some (Js_output.output_as_block (compile_lambda cxt lam)) - in - let body = - table - |> Ext_list.stable_group - (fun (_,lam) (_,lam1) - -> Lam_analysis.eq_lambda lam lam1) - |> Ext_list.flat_map - (fun group -> - group - |> Ext_list.map_last - (fun last (x,lam) -> - if last - then {J.switch_case = x; - switch_body = - Js_output.to_break_block (compile_lambda cxt lam) } - else { switch_case = x; switch_body = [],false })) - (* TODO: we should also group default *) - (* The last clause does not need [break] - common break through, *) + morph_declare_to_assign cxt ( fun cxt declaration -> + let default = + match default with + | Complete -> None + | NonComplete -> None + | Default lam -> Some (Js_output.output_as_block (compile_lambda cxt lam)) + in + let body = + table + |> Ext_list.stable_group + (fun (_,lam) (_,lam1) + -> Lam_analysis.eq_lambda lam lam1) + |> Ext_list.flat_map + (fun group -> + Ext_list.map_last + (fun last (switch_case,lam) -> + if last + then {J.switch_case ; + switch_body = + Js_output.to_break_block (compile_lambda cxt lam) } + else + { switch_case; switch_body = [],false } + ) + group + ) + (* TODO: we should also group default *) + (* The last clause does not need [break] + common break through, *) - in - [switch ?default ?declaration switch_exp body] + in + [switch ?default ?declaration switch_exp body] + ) and compile_cases cxt switch_exp table default = compile_general_cases @@ -631,7 +633,7 @@ and in begin (* Ext_log.dwarn __LOC__ "size : %d" (List.length block); *) - Js_output.make ~finished:True block + Js_output.make ~output_finished:True block end | _ -> @@ -687,7 +689,7 @@ and | {block = b; value = Some v} -> Js_output.make (Ext_list.append b [S.throw_stmt v]) - ~value:E.undefined ~finished:True + ~value:E.undefined ~output_finished:True (* FIXME -- breaks invariant when NeedValue, reason is that js [throw] is statement while ocaml it's an expression, we should remove such things in lambda optimizations *) @@ -1147,7 +1149,8 @@ and #end *) Js_output.make - (Ext_list.append b [S.return_stmt (E.econd e out1 out2)]) ~finished:True + (Ext_list.append b [S.return_stmt (E.econd e out1 out2)]) + ~output_finished:True | _, _, _ -> (* #if BS_DEBUG then @@ -1428,7 +1431,8 @@ and | Assign x, _ -> Js_output.make (Ext_list.append block [S.assign_unit x ]) | EffectCall, ReturnTrue _ -> - Js_output.make (Ext_list.append block S.return_unit) ~finished:True + Js_output.make (Ext_list.append block S.return_unit) + ~output_finished:True | EffectCall, _ -> Js_output.make block | NeedValue, _ -> Js_output.make block ~value:E.unit end | _ -> assert false ) @@ -1498,7 +1502,8 @@ and match st, should_return with | EffectCall, ReturnFalse -> Js_output.make block | EffectCall, ReturnTrue _ -> - Js_output.make (Ext_list.append block S.return_unit ) ~finished:True + Js_output.make (Ext_list.append block S.return_unit ) + ~output_finished:True (* unit -> 0, order does not matter *) | (Declare _ | Assign _), ReturnTrue _ -> Js_output.make [S.unknown_lambda lam] | Declare (_kind, x), ReturnFalse -> @@ -1531,7 +1536,9 @@ and match st, should_return with | EffectCall, ReturnFalse -> Js_output.make block | EffectCall, ReturnTrue _ -> - Js_output.make (Ext_list.append block S.return_unit ) ~finished:True + Js_output.make + (Ext_list.append block S.return_unit ) + ~output_finished:True | (Declare _ | Assign _ ) , ReturnTrue _ -> Js_output.make [S.unknown_lambda lam] (* bound by a name, while in a tail position, this can not happen *) diff --git a/lib/whole_compiler.ml b/lib/whole_compiler.ml index 5ca91eb5d3a..f89b1ed7aa2 100644 --- a/lib/whole_compiler.ml +++ b/lib/whole_compiler.ml @@ -87860,7 +87860,7 @@ end module Js_output : sig #1 "js_output.mli" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -87878,7 +87878,7 @@ module Js_output : sig * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) @@ -87892,30 +87892,30 @@ module Js_output : sig (** The intemediate output when compiling lambda into JS IR *) -(* Hongbo Should we rename this module js_of_lambda since it looks like it's +(* Hongbo Should we rename this module js_of_lambda since it looks like it's containing that step *) -type finished = - | True - | False +type finished = + | True + | False | Dummy (* Have no idea, so that when [++] is applied, always use the other *) -type t = { +type t = { block : J.block ; value : J.expression option; - finished : finished + output_finished : finished } -(** When [finished] is true the block is already terminated, +(** When [finished] is true the block is already terminated, value does not make sense [finished] default to false, which is conservative *) val make : ?value: J.expression -> - ?finished:finished -> + ?output_finished:finished -> J.block -> t @@ -87925,27 +87925,27 @@ val output_as_block : val to_break_block : t -> - J.block * bool - (* the second argument is + J.block * bool + (* the second argument is [true] means [break] needed When we know the output is gonna finished true - we can reduce + we can reduce {[ - return xx ; + return xx ; break ]} - into + into {[ - return ; + return ; ]} *) -val append_output: t -> t -> t +val append_output: t -> t -> t -val dummy : t +val dummy : t val output_of_expression : @@ -87955,7 +87955,7 @@ val output_of_expression : J.expression -> (* compiled expression *) t -val output_of_block_and_expression : +val output_of_block_and_expression : Lam_compile_context.continuation -> Lam_compile_context.return_type -> Lam.t -> @@ -87974,7 +87974,7 @@ val to_string : end = struct #1 "js_output.ml" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -87992,124 +87992,124 @@ end = struct * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -module E = Js_exp_make -module S = Js_stmt_make +module E = Js_exp_make +module S = Js_stmt_make -type finished = - | True - | False +type finished = + | True + | False | Dummy (* Have no idea, so that when [++] is applied, always use the other *) -type t = { +type t = { block : J.block ; value : J.expression option; - finished : finished ; + output_finished : finished ; } type continuation = Lam_compile_context.continuation -let make ?value ?(finished=False) block = - { block ; value ; finished } +let make ?value ?(output_finished=False) block = + { block ; value ; output_finished } -let dummy = - {value = None; block = []; finished = Dummy } +let dummy = + {value = None; block = []; output_finished = Dummy } -let output_of_expression +let output_of_expression (continuation : continuation) (should_return : Lam_compile_context.return_type) (lam : Lam.t) (exp : J.expression) : t = - begin match continuation, should_return with - | EffectCall, ReturnFalse -> - if Lam_analysis.no_side_effects lam + begin match continuation, should_return with + | EffectCall, ReturnFalse -> + if Lam_analysis.no_side_effects lam then dummy - else {block = []; value = Some exp ; finished = False} - | Declare (kind, n), ReturnFalse -> + else {block = []; value = Some exp ; output_finished = False} + | Declare (kind, n), ReturnFalse -> make [ S.define_variable ~kind n exp] - | Assign n ,ReturnFalse -> + | Assign n ,ReturnFalse -> make [S.assign n exp ] | EffectCall, ReturnTrue _ -> - make [S.return_stmt exp] ~finished:True - | (Declare _ | Assign _ ), ReturnTrue _ -> - make [S.unknown_lambda lam] ~finished:True - | NeedValue, _ -> - {block = []; value = Some exp; finished = False } + make [S.return_stmt exp] ~output_finished:True + | (Declare _ | Assign _ ), ReturnTrue _ -> + make [S.unknown_lambda lam] ~output_finished:True + | NeedValue, _ -> + {block = []; value = Some exp; output_finished = False } end -let output_of_block_and_expression - (continuation : continuation) +let output_of_block_and_expression + (continuation : continuation) (should_return : Lam_compile_context.return_type) - (lam : Lam.t) (block : J.block) exp : t = - match continuation, should_return with + (lam : Lam.t) (block : J.block) exp : t = + match continuation, should_return with | EffectCall, ReturnFalse -> make block ~value:exp - | Declare (kind,n), ReturnFalse -> + | Declare (kind,n), ReturnFalse -> make (block @ [ S.define_variable ~kind n exp]) - | Assign n, ReturnFalse -> make (block @ [S.assign n exp]) - | EffectCall, ReturnTrue _ -> make (block @ [S.return_stmt exp]) ~finished:True + | Assign n, ReturnFalse -> make (block @ [S.assign n exp]) + | EffectCall, ReturnTrue _ -> make (block @ [S.return_stmt exp]) ~output_finished:True | (Declare _ | Assign _), ReturnTrue _ -> - make [S.unknown_lambda lam] ~finished:True - | NeedValue, (ReturnTrue _ | ReturnFalse) -> + make [S.unknown_lambda lam] ~output_finished:True + | NeedValue, (ReturnTrue _ | ReturnFalse) -> make block ~value:exp -let block_with_opt_expr block (x : J.expression option) : J.block = - match x with +let block_with_opt_expr block (x : J.expression option) : J.block = + match x with | None -> block | Some x when Js_analyzer.no_side_effect_expression x -> block | Some x -> block @ [S.exp x ] -let opt_expr_with_block (x : J.expression option) block : J.block = - match x with +let opt_expr_with_block (x : J.expression option) block : J.block = + match x with | None -> block | Some x when Js_analyzer.no_side_effect_expression x -> block | Some x -> (S.exp x) :: block - -let rec unnest_block (block : J.block) : J.block = - match block with - | [{statement_desc = Block block}] -> unnest_block block - | _ -> block -let output_as_block ( x : t) : J.block = - match x with - | {block; value = opt; finished} -> +let rec unnest_block (block : J.block) : J.block = + match block with + | [{statement_desc = Block block}] -> unnest_block block + | _ -> block + +let output_as_block ( x : t) : J.block = + match x with + | {block; value = opt; output_finished} -> let block = unnest_block block in - if finished = True then block - else + if output_finished = True then block + else block_with_opt_expr block opt - -let to_break_block (x : t) : J.block * bool = - let block = unnest_block x.block in - match x with - | {finished = True; _ } -> + +let to_break_block (x : t) : J.block * bool = + let block = unnest_block x.block in + match x with + | {output_finished = True; _ } -> block, false (* value does not matter when [finished] is true TODO: check if it has side efects *) - | { value = None; finished } -> - block, - (match finished with | True -> false | (False | Dummy) -> true ) + | { value = None; output_finished } -> + block, + (match output_finished with | True -> false | (False | Dummy) -> true ) - | {value = Some _ as opt; _} -> + | {value = Some _ as opt; _} -> block_with_opt_expr block opt, true (** TODO: make everything expression make inlining hard, and code not readable? - 1. readability dpends on how we print the expression + 1. readability dpends on how we print the expression 2. inlining needs generate symbols, which are statements, type mismatch we need capture [Exp e] - can we call them all [statement]? statement has no value + can we call them all [statement]? statement has no value *) (* | {block = [{statement_desc = Exp e }]; value = None ; _}, _ *) (* -> *) @@ -88117,37 +88117,37 @@ let to_break_block (x : t) : J.block * bool = (* | _ , {block = [{statement_desc = Exp e }]; value = None ; _} *) (* -> *) (* append x { y with block = []; value = Some e} *) - -let rec append_output (x : t ) (y : t ) : t = + +let rec append_output (x : t ) (y : t ) : t = match x , y with (* ATTTENTION: should not optimize [opt_e2], it has to conform to [NeedValue]*) - | {finished = True; _ }, _ -> x - | _, {block = []; value= None; finished = Dummy } -> x + | { output_finished = True; _ }, _ -> x + | _, {block = []; value= None; output_finished = Dummy } -> x (* finished = true --> value = E.undefined otherwise would throw*) - | {block = []; value= None; _ }, y -> y - | {block = []; value= Some _; _}, {block = []; value= None; _ } -> x - | {block = []; value = Some e1; _}, ({block = []; value = Some e2; finished } as z) -> - if Js_analyzer.no_side_effect_expression e1 + | {block = []; value= None; _ }, y -> y + | {block = []; value= Some _; _}, {block = []; value= None; _ } -> x + | {block = []; value = Some e1; _}, ({block = []; value = Some e2; output_finished } as z) -> + if Js_analyzer.no_side_effect_expression e1 then z (* It would optimize cases like [module aliases] - Bigarray, List + Bigarray, List *) else - {block = []; value = Some (E.seq e1 e2); finished} + {block = []; value = Some (E.seq e1 e2); output_finished} (* {block = [S.exp e1]; value = Some e2(\* (E.seq e1 e2) *\); finished} *) - | {block = block1; value = opt_e1; _}, {block = block2; value = opt_e2; finished} -> + | {block = block1; value = opt_e1; _}, {block = block2; value = opt_e2; output_finished} -> let block1 = unnest_block block1 in make (block1 @ (opt_expr_with_block opt_e1 @@ unnest_block block2)) - ?value:opt_e2 ~finished + ?value:opt_e2 ~output_finished:output_finished (* Fold right is more efficient *) -let concat (xs : t list) : t = +let concat (xs : t list) : t = Ext_list.fold_right (fun x acc -> append_output x acc) xs dummy -let to_string x = +let to_string x = Js_dump.string_of_block (output_as_block x) end @@ -97798,19 +97798,16 @@ and compile_general_cases (switch_exp : J.expression) (table : (_ * Lam.t) list) (default : default_case) -> - let wrap (cxt : Lam_compile_context.t) k = - let cxt, define = + let morph_declare_to_assign (cxt : Lam_compile_context.t) k = match cxt.st with | Declare (kind, did) -> - {cxt with st = Assign did}, Some (kind,did) - | _ -> cxt, None - in - k cxt define + k {cxt with st = Assign did} (Some (kind,did)) + | _ -> k cxt None in match table, default with | [], Default lam -> - Js_output.output_as_block (compile_lambda cxt lam) + Js_output.output_as_block (compile_lambda cxt lam) | [], (Complete | NonComplete) -> [] | [(id,lam)],Complete -> (* To take advantage of such optimizations, @@ -97822,19 +97819,20 @@ and compile_general_cases Js_output.output_as_block (compile_lambda cxt lam) | [(id,lam)], NonComplete -> - wrap cxt @@ fun cxt define -> - [S.if_ ?declaration:define (eq_exp switch_exp (make_exp id) ) - (Js_output.output_as_block @@ compile_lambda cxt lam )] + morph_declare_to_assign cxt (fun cxt define -> + [S.if_ ?declaration:define (eq_exp switch_exp (make_exp id) ) + (Js_output.output_as_block (compile_lambda cxt lam) ) + ]) | ([(id,lam)], Default x) | ([(id,lam); (_,x)], Complete) -> - wrap cxt @@ fun cxt define -> - let else_block = Js_output.output_as_block (compile_lambda cxt x) in - let then_block = Js_output.output_as_block (compile_lambda cxt lam) in - [ S.if_ ?declaration:define (eq_exp switch_exp (make_exp id) ) - then_block - ~else_:else_block - ] + morph_declare_to_assign cxt (fun cxt define -> + let else_block = Js_output.output_as_block (compile_lambda cxt x) in + let then_block = Js_output.output_as_block (compile_lambda cxt lam) in + [ S.if_ ?declaration:define (eq_exp switch_exp (make_exp id) ) + then_block + ~else_:else_block + ]) | _ , _ -> (* TODO: this is not relevant to switch case however, in a subset of switch-case if we can analysis @@ -97844,34 +97842,38 @@ and compile_general_cases TODO: grouping can be delayed untile JS IR *) (*TOOD: disabled temporarily since it's not perfect yet *) - wrap cxt @@ fun cxt declaration -> - let default = - match default with - | Complete -> None - | NonComplete -> None - | Default lam -> Some (Js_output.output_as_block (compile_lambda cxt lam)) - in - let body = - table - |> Ext_list.stable_group - (fun (_,lam) (_,lam1) - -> Lam_analysis.eq_lambda lam lam1) - |> Ext_list.flat_map - (fun group -> - group - |> Ext_list.map_last - (fun last (x,lam) -> - if last - then {J.switch_case = x; - switch_body = - Js_output.to_break_block (compile_lambda cxt lam) } - else { switch_case = x; switch_body = [],false })) - (* TODO: we should also group default *) - (* The last clause does not need [break] - common break through, *) + morph_declare_to_assign cxt ( fun cxt declaration -> + let default = + match default with + | Complete -> None + | NonComplete -> None + | Default lam -> Some (Js_output.output_as_block (compile_lambda cxt lam)) + in + let body = + table + |> Ext_list.stable_group + (fun (_,lam) (_,lam1) + -> Lam_analysis.eq_lambda lam lam1) + |> Ext_list.flat_map + (fun group -> + Ext_list.map_last + (fun last (switch_case,lam) -> + if last + then {J.switch_case ; + switch_body = + Js_output.to_break_block (compile_lambda cxt lam) } + else + { switch_case; switch_body = [],false } + ) + group + ) + (* TODO: we should also group default *) + (* The last clause does not need [break] + common break through, *) - in - [switch ?default ?declaration switch_exp body] + in + [switch ?default ?declaration switch_exp body] + ) and compile_cases cxt switch_exp table default = compile_general_cases @@ -98001,7 +98003,7 @@ and in begin (* Ext_log.dwarn __LOC__ "size : %d" (List.length block); *) - Js_output.make ~finished:True block + Js_output.make ~output_finished:True block end | _ -> @@ -98057,7 +98059,7 @@ and | {block = b; value = Some v} -> Js_output.make (Ext_list.append b [S.throw_stmt v]) - ~value:E.undefined ~finished:True + ~value:E.undefined ~output_finished:True (* FIXME -- breaks invariant when NeedValue, reason is that js [throw] is statement while ocaml it's an expression, we should remove such things in lambda optimizations *) @@ -98517,7 +98519,8 @@ and #end *) Js_output.make - (Ext_list.append b [S.return_stmt (E.econd e out1 out2)]) ~finished:True + (Ext_list.append b [S.return_stmt (E.econd e out1 out2)]) + ~output_finished:True | _, _, _ -> (* #if BS_DEBUG then @@ -98798,7 +98801,8 @@ and | Assign x, _ -> Js_output.make (Ext_list.append block [S.assign_unit x ]) | EffectCall, ReturnTrue _ -> - Js_output.make (Ext_list.append block S.return_unit) ~finished:True + Js_output.make (Ext_list.append block S.return_unit) + ~output_finished:True | EffectCall, _ -> Js_output.make block | NeedValue, _ -> Js_output.make block ~value:E.unit end | _ -> assert false ) @@ -98868,7 +98872,8 @@ and match st, should_return with | EffectCall, ReturnFalse -> Js_output.make block | EffectCall, ReturnTrue _ -> - Js_output.make (Ext_list.append block S.return_unit ) ~finished:True + Js_output.make (Ext_list.append block S.return_unit ) + ~output_finished:True (* unit -> 0, order does not matter *) | (Declare _ | Assign _), ReturnTrue _ -> Js_output.make [S.unknown_lambda lam] | Declare (_kind, x), ReturnFalse -> @@ -98901,7 +98906,9 @@ and match st, should_return with | EffectCall, ReturnFalse -> Js_output.make block | EffectCall, ReturnTrue _ -> - Js_output.make (Ext_list.append block S.return_unit ) ~finished:True + Js_output.make + (Ext_list.append block S.return_unit ) + ~output_finished:True | (Declare _ | Assign _ ) , ReturnTrue _ -> Js_output.make [S.unknown_lambda lam] (* bound by a name, while in a tail position, this can not happen *) From 8a5f506d0fadd6f82ac758e480e793b637edd2df Mon Sep 17 00:00:00 2001 From: Hongbo Zhang Date: Sun, 18 Mar 2018 09:35:13 +0800 Subject: [PATCH 4/8] fix a potential bug: missed block --- jscomp/core/lam_compile.ml | 46 ++++++++++++++++++++---------------- jscomp/test/gpr_2413_test.js | 11 +++++++++ jscomp/test/gpr_2413_test.ml | 16 ++++++++++--- lib/whole_compiler.ml | 46 ++++++++++++++++++++---------------- 4 files changed, 74 insertions(+), 45 deletions(-) diff --git a/jscomp/core/lam_compile.ml b/jscomp/core/lam_compile.ml index 41f201f5a68..1fc1032653b 100644 --- a/jscomp/core/lam_compile.ml +++ b/jscomp/core/lam_compile.ml @@ -1231,17 +1231,22 @@ and if Ext_list.length_ge sw_blocks sw_numblocks then Complete else Default x in - let compile_whole ({st; _} as cxt : Lam_compile_context.t ) = - match sw_numconsts, sw_numblocks, - compile_lambda {cxt with should_return = ReturnFalse; st = NeedValue} - lam with - | 0 , _ , {block; value = Some e} -> - compile_cases cxt (E.tag e ) sw_blocks sw_blocks_default - | _, 0, {block; value = Some e} -> - compile_cases cxt e sw_consts sw_num_default - | _, _, { block; value = Some e} -> (* [e] will be used twice *) - let dispatch e = - [ + let compile_whole (cxt : Lam_compile_context.t ) = + match + compile_lambda + {cxt with should_return = ReturnFalse; st = NeedValue} + lam + with + | {value = None; _} -> assert false + | { block; value = Some e } -> + block @ + (if sw_numconsts = 0 then + compile_cases cxt (E.tag e) sw_blocks sw_blocks_default + else if sw_numblocks = 0 then + compile_cases cxt e sw_consts sw_num_default + else + (* [e] will be used twice *) + let dispatch e = S.if_ (E.is_type_number e ) (compile_cases cxt e sw_consts sw_num_default @@ -1250,16 +1255,15 @@ and ~else_: (compile_cases cxt (E.tag e ) sw_blocks sw_blocks_default) - ] in - begin - 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) - end - | _, _, {value = None; _} -> assert false + in + begin + 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)] + end ) in begin match st with (* Needs declare first *) diff --git a/jscomp/test/gpr_2413_test.js b/jscomp/test/gpr_2413_test.js index 72172f485c5..628bf731720 100644 --- a/jscomp/test/gpr_2413_test.js +++ b/jscomp/test/gpr_2413_test.js @@ -28,5 +28,16 @@ function f(param) { } +function ff(c) { + c[0] = c[0] + 1 | 0; + var match = (1 + c[0] | 0) + 1 | 0; + if (match > 3 || match < 0) { + return 0; + } else { + return match + 1 | 0; + } +} + exports.f = f; +exports.ff = ff; /* No side effect */ diff --git a/jscomp/test/gpr_2413_test.ml b/jscomp/test/gpr_2413_test.ml index 20ea5c2e178..abbe06c07a4 100644 --- a/jscomp/test/gpr_2413_test.ml +++ b/jscomp/test/gpr_2413_test.ml @@ -1,15 +1,25 @@ type inner = | P of int | S of int - + type outer = | A of inner | B of inner | C of inner - + let f = function (* These cause unreachable code *) | A P a -> a + a | A S a -> a - a (* These don't, because there's commonality between them *) - | B P a | B S a | C P a | C S a -> a * a \ No newline at end of file + | B P a | B S a | C P a | C S a -> a * a + + + let ff c = + match let a = 1 in let b = 1 in + incr c; a + !c + b with + | 0 -> 1 + | 1 -> 2 + | 2 -> 3 + | 3 -> 4 + | _ -> 0 diff --git a/lib/whole_compiler.ml b/lib/whole_compiler.ml index f89b1ed7aa2..5c392ed886b 100644 --- a/lib/whole_compiler.ml +++ b/lib/whole_compiler.ml @@ -98601,17 +98601,22 @@ and if Ext_list.length_ge sw_blocks sw_numblocks then Complete else Default x in - let compile_whole ({st; _} as cxt : Lam_compile_context.t ) = - match sw_numconsts, sw_numblocks, - compile_lambda {cxt with should_return = ReturnFalse; st = NeedValue} - lam with - | 0 , _ , {block; value = Some e} -> - compile_cases cxt (E.tag e ) sw_blocks sw_blocks_default - | _, 0, {block; value = Some e} -> - compile_cases cxt e sw_consts sw_num_default - | _, _, { block; value = Some e} -> (* [e] will be used twice *) - let dispatch e = - [ + let compile_whole (cxt : Lam_compile_context.t ) = + match + compile_lambda + {cxt with should_return = ReturnFalse; st = NeedValue} + lam + with + | {value = None; _} -> assert false + | { block; value = Some e } -> + block @ + (if sw_numconsts = 0 then + compile_cases cxt (E.tag e) sw_blocks sw_blocks_default + else if sw_numblocks = 0 then + compile_cases cxt e sw_consts sw_num_default + else + (* [e] will be used twice *) + let dispatch e = S.if_ (E.is_type_number e ) (compile_cases cxt e sw_consts sw_num_default @@ -98620,16 +98625,15 @@ and ~else_: (compile_cases cxt (E.tag e ) sw_blocks sw_blocks_default) - ] in - begin - 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) - end - | _, _, {value = None; _} -> assert false + in + begin + 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)] + end ) in begin match st with (* Needs declare first *) From f37168110699b69db47e7a586d2aff572e2a23fc Mon Sep 17 00:00:00 2001 From: Hongbo Zhang Date: Sun, 18 Mar 2018 10:00:42 +0800 Subject: [PATCH 5/8] tweaks and clean --- jscomp/core/lam_compile.ml | 61 ++++++++++++++++++++++---------------- lib/whole_compiler.ml | 55 +++++++++++++++++++--------------- 2 files changed, 67 insertions(+), 49 deletions(-) diff --git a/jscomp/core/lam_compile.ml b/jscomp/core/lam_compile.ml index 1fc1032653b..7f455e71bf2 100644 --- a/jscomp/core/lam_compile.ml +++ b/jscomp/core/lam_compile.ml @@ -488,10 +488,21 @@ and compile_general_cases (fun group -> Ext_list.map_last (fun last (switch_case,lam) -> + (* let switch_block, should_break = + Js_output.to_break_block (compile_lambda cxt lam) in + let should_break = + match cxt.should_return with + | ReturnFalse -> should_break + | ReturnTrue _ -> false + in *) + if last - then {J.switch_case ; - switch_body = - Js_output.to_break_block (compile_lambda cxt lam) } + then + (* merge and shared *) + let switch_body = Js_output.to_break_block (compile_lambda cxt lam) in + {J.switch_case ; + switch_body + } else { switch_case; switch_body = [],false } ) @@ -1242,28 +1253,28 @@ and block @ (if sw_numconsts = 0 then compile_cases cxt (E.tag e) sw_blocks sw_blocks_default - else if sw_numblocks = 0 then - compile_cases cxt e sw_consts sw_num_default - else - (* [e] will be used twice *) - let dispatch e = - S.if_ - (E.is_type_number e ) - (compile_cases cxt e sw_consts sw_num_default - ) - (* default still needed, could simplified*) - ~else_: - (compile_cases cxt (E.tag e ) sw_blocks - sw_blocks_default) - in - begin - 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)] - end ) + else if sw_numblocks = 0 then + compile_cases cxt e sw_consts sw_num_default + else + (* [e] will be used twice *) + let dispatch e = + S.if_ + (E.is_type_number e ) + (compile_cases cxt e sw_consts sw_num_default + ) + (* default still needed, could simplified*) + ~else_: + (compile_cases cxt (E.tag e ) sw_blocks + sw_blocks_default) + in + begin + 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)] + end ) in begin match st with (* Needs declare first *) diff --git a/lib/whole_compiler.ml b/lib/whole_compiler.ml index 5c392ed886b..7c6c304405b 100644 --- a/lib/whole_compiler.ml +++ b/lib/whole_compiler.ml @@ -97858,10 +97858,17 @@ and compile_general_cases (fun group -> Ext_list.map_last (fun last (switch_case,lam) -> + let switch_block, should_break = + Js_output.to_break_block (compile_lambda cxt lam) in + let should_break = + match cxt.should_return with + | ReturnFalse -> should_break + | ReturnTrue _ -> false + in if last then {J.switch_case ; - switch_body = - Js_output.to_break_block (compile_lambda cxt lam) } + switch_body = switch_block, should_break + } else { switch_case; switch_body = [],false } ) @@ -98612,28 +98619,28 @@ and block @ (if sw_numconsts = 0 then compile_cases cxt (E.tag e) sw_blocks sw_blocks_default - else if sw_numblocks = 0 then - compile_cases cxt e sw_consts sw_num_default - else - (* [e] will be used twice *) - let dispatch e = - S.if_ - (E.is_type_number e ) - (compile_cases cxt e sw_consts sw_num_default - ) - (* default still needed, could simplified*) - ~else_: - (compile_cases cxt (E.tag e ) sw_blocks - sw_blocks_default) - in - begin - 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)] - end ) + else if sw_numblocks = 0 then + compile_cases cxt e sw_consts sw_num_default + else + (* [e] will be used twice *) + let dispatch e = + S.if_ + (E.is_type_number e ) + (compile_cases cxt e sw_consts sw_num_default + ) + (* default still needed, could simplified*) + ~else_: + (compile_cases cxt (E.tag e ) sw_blocks + sw_blocks_default) + in + begin + 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)] + end ) in begin match st with (* Needs declare first *) From ced601fd99b5c8dd8ae1fa7a1d91b671b5d192f0 Mon Sep 17 00:00:00 2001 From: Hongbo Zhang Date: Sun, 18 Mar 2018 10:13:23 +0800 Subject: [PATCH 6/8] reomove Sys.getenv ad-hoc processing --- jscomp/core/lam_compile.ml | 21 ---------------- jscomp/test/caml_sys_poly_fill_test.js | 7 +++++- lib/js/filename.js | 12 ++++++++-- lib/whole_compiler.ml | 33 +++++++------------------- 4 files changed, 24 insertions(+), 49 deletions(-) diff --git a/jscomp/core/lam_compile.ml b/jscomp/core/lam_compile.ml index 7f455e71bf2..96622f679af 100644 --- a/jscomp/core/lam_compile.ml +++ b/jscomp/core/lam_compile.ml @@ -1564,27 +1564,6 @@ and | NeedValue, _ -> Js_output.make block ~value:E.unit end - | (Ltrywith( - (Lprim {primitive = Pccall {prim_name = "caml_sys_getenv"; _}; - args = [Lconst _]} as body), - id, - Lifthenelse - (Lprim{primitive = Pintcomp(Ceq); - args = [Lvar id2 ; - Lprim{primitive = Pglobal_exception {name = "Not_found"}; _}]}, - cont, _reraise ) - ) - | Ltrywith( - (Lprim {primitive = Pccall {prim_name = "caml_sys_getenv"; _}; - args = [Lconst _]} as body), - id, - Lifthenelse(Lprim{primitive = Pintcomp(Ceq); - args = [ - Lprim { primitive = Pglobal_exception {name = "Not_found"; _}; _}; Lvar id2 ]}, - cont, _reraise ) - )) when Ident.same id id2 - -> - compile_lambda cxt (Lam.try_ body id cont) | Ltrywith(lam,id, catch) -> (* generate documentation *) (* tail --> should be renamed to `shouldReturn` diff --git a/jscomp/test/caml_sys_poly_fill_test.js b/jscomp/test/caml_sys_poly_fill_test.js index a5f14e2e4d6..8344e71efab 100644 --- a/jscomp/test/caml_sys_poly_fill_test.js +++ b/jscomp/test/caml_sys_poly_fill_test.js @@ -4,6 +4,7 @@ var Mt = require("./mt.js"); var Block = require("../../lib/js/block.js"); var Caml_sys = require("../../lib/js/caml_sys.js"); var Node_process = require("../../lib/js/node_process.js"); +var Caml_builtin_exceptions = require("../../lib/js/caml_builtin_exceptions.js"); var suites = [/* [] */0]; @@ -46,7 +47,11 @@ try { tmp = Caml_sys.caml_sys_getenv("caml_sys_poly_fill_test.ml"); } catch (exn){ - tmp = "Z"; + if (exn === Caml_builtin_exceptions.not_found) { + tmp = "Z"; + } else { + throw exn; + } } eq("File \"caml_sys_poly_fill_test.ml\", line 23, characters 5-12", "Z", tmp); diff --git a/lib/js/filename.js b/lib/js/filename.js index b2a13346722..6ac8af034fa 100644 --- a/lib/js/filename.js +++ b/lib/js/filename.js @@ -131,7 +131,11 @@ try { temp_dir_name = Caml_sys.caml_sys_getenv("TMPDIR"); } catch (exn){ - temp_dir_name = "/tmp"; + if (exn === Caml_builtin_exceptions.not_found) { + temp_dir_name = "/tmp"; + } else { + throw exn; + } } function quote(param) { @@ -165,7 +169,11 @@ try { temp_dir_name$1 = Caml_sys.caml_sys_getenv("TEMP"); } catch (exn$1){ - temp_dir_name$1 = "."; + if (exn$1 === Caml_builtin_exceptions.not_found) { + temp_dir_name$1 = "."; + } else { + throw exn$1; + } } var temp_dir_name$2 = temp_dir_name; diff --git a/lib/whole_compiler.ml b/lib/whole_compiler.ml index 7c6c304405b..ec2638bde54 100644 --- a/lib/whole_compiler.ml +++ b/lib/whole_compiler.ml @@ -97858,16 +97858,20 @@ and compile_general_cases (fun group -> Ext_list.map_last (fun last (switch_case,lam) -> - let switch_block, should_break = + (* let switch_block, should_break = Js_output.to_break_block (compile_lambda cxt lam) in let should_break = match cxt.should_return with | ReturnFalse -> should_break | ReturnTrue _ -> false - in + in *) + if last - then {J.switch_case ; - switch_body = switch_block, should_break + then + (* merge and shared *) + let switch_body = Js_output.to_break_block (compile_lambda cxt lam) in + {J.switch_case ; + switch_body } else { switch_case; switch_body = [],false } @@ -98930,27 +98934,6 @@ and | NeedValue, _ -> Js_output.make block ~value:E.unit end - | (Ltrywith( - (Lprim {primitive = Pccall {prim_name = "caml_sys_getenv"; _}; - args = [Lconst _]} as body), - id, - Lifthenelse - (Lprim{primitive = Pintcomp(Ceq); - args = [Lvar id2 ; - Lprim{primitive = Pglobal_exception {name = "Not_found"}; _}]}, - cont, _reraise ) - ) - | Ltrywith( - (Lprim {primitive = Pccall {prim_name = "caml_sys_getenv"; _}; - args = [Lconst _]} as body), - id, - Lifthenelse(Lprim{primitive = Pintcomp(Ceq); - args = [ - Lprim { primitive = Pglobal_exception {name = "Not_found"; _}; _}; Lvar id2 ]}, - cont, _reraise ) - )) when Ident.same id id2 - -> - compile_lambda cxt (Lam.try_ body id cont) | Ltrywith(lam,id, catch) -> (* generate documentation *) (* tail --> should be renamed to `shouldReturn` From cbeaced215851e21c5a1ef5302695a9585c289c3 Mon Sep 17 00:00:00 2001 From: Hongbo Zhang Date: Sun, 18 Mar 2018 10:39:36 +0800 Subject: [PATCH 7/8] clean up --- jscomp/core/js_output.mli | 2 ++ jscomp/core/lam_compile.ml | 39 ++++++++++++++------------------- lib/whole_compiler.ml | 45 +++++++++++++++----------------------- 3 files changed, 36 insertions(+), 50 deletions(-) diff --git a/jscomp/core/js_output.mli b/jscomp/core/js_output.mli index 6b8e797373b..238a7540025 100644 --- a/jscomp/core/js_output.mli +++ b/jscomp/core/js_output.mli @@ -94,6 +94,8 @@ val output_of_expression : J.expression -> (* compiled expression *) t +(** - needed for instrument [return] statement properly +*) val output_of_block_and_expression : Lam_compile_context.continuation -> Lam_compile_context.return_type -> diff --git a/jscomp/core/lam_compile.ml b/jscomp/core/lam_compile.ml index 96622f679af..08bd665de74 100644 --- a/jscomp/core/lam_compile.ml +++ b/jscomp/core/lam_compile.ml @@ -1300,22 +1300,22 @@ and begin match Lam_compile_context.find_exn i cxt with | {exit_id; args ; order_id} -> - let args_code = - (Js_output.concat @@ Ext_list.map2 ( - fun (x : Lam.t) (arg : Ident.t) -> - match x with - | Lvar id -> + Ext_list.fold_right2 + (fun (x : Lam.t) (arg: Ident.t) acc -> + let new_output = + match x with + | Lvar id -> Js_output.make [S.assign arg (E.var id)] - | _ -> (* TODO: should be Assign -- Assign is an optimization *) - compile_lambda {cxt with st = Assign arg ; should_return = ReturnFalse} x - ) largs (args : Ident.t list)) - in - Js_output.append_output args_code (* Declared in [Lstaticraise ]*) - (Js_output.make [S.assign exit_id (E.small_int order_id)] - ~value:E.undefined) + | _ -> (* TODO: should be Assign -- Assign is an optimization *) + compile_lambda {cxt with st = Assign arg ; should_return = ReturnFalse} x + in Js_output.append_output new_output acc + ) + largs args + (Js_output.make [S.assign exit_id (E.small_int order_id)] + ~value:E.undefined) | exception Not_found -> - Js_output.make [S.unknown_lambda ~comment:"error" lam] + assert false (* staticraise is always enclosed by catch *) end (* Invariant: code can not be reused @@ -1328,11 +1328,6 @@ and if not we should use ``javascript break`` or ``continue`` *) | Lstaticcatch _ -> - let code_table, body = flatten_caches lam in - - - let bindings = Ext_list.flat_map (fun (_,_,bindings) -> bindings) code_table in - (* compile_list name l false (\*\) *) (* if exit_code_id == code handler -- ids are not useful, since @@ -1358,16 +1353,14 @@ and ]} *) (* TODO: handle NeedValue *) - let exit_id = Ext_ident.create_tmp ~name:"exit" () in + let code_table, body = flatten_caches lam in + let bindings = Ext_list.flat_map (fun (_,_,bindings) -> bindings) code_table in + let exit_id = Ext_ident.create_tmp ~name:"exit" () in let exit_expr = E.var exit_id in let jmp_table, handlers = Lam_compile_context.add_jmps exit_id code_table jmp_table in (* Declaration First, body and handler have the same value *) - (* There is a bug in google closure compiler: - https://github.com/google/closure-compiler/issues/1234#issuecomment-151976340 - TODO: wait for a bug fix - *) let declares = S.define_variable ~kind:Variable exit_id E.zero_int_literal :: diff --git a/lib/whole_compiler.ml b/lib/whole_compiler.ml index ec2638bde54..90b7cc72248 100644 --- a/lib/whole_compiler.ml +++ b/lib/whole_compiler.ml @@ -87955,6 +87955,8 @@ val output_of_expression : J.expression -> (* compiled expression *) t +(** - needed for instrument [return] statement properly +*) val output_of_block_and_expression : Lam_compile_context.continuation -> Lam_compile_context.return_type -> @@ -87963,10 +87965,6 @@ val output_of_block_and_expression : J.expression -> t -val concat : - t list -> - t - val to_string : t -> string @@ -98670,22 +98668,22 @@ and begin match Lam_compile_context.find_exn i cxt with | {exit_id; args ; order_id} -> - let args_code = - (Js_output.concat @@ Ext_list.map2 ( - fun (x : Lam.t) (arg : Ident.t) -> - match x with - | Lvar id -> + Ext_list.fold_right2 + (fun (x : Lam.t) (arg: Ident.t) acc -> + let new_output = + match x with + | Lvar id -> Js_output.make [S.assign arg (E.var id)] - | _ -> (* TODO: should be Assign -- Assign is an optimization *) - compile_lambda {cxt with st = Assign arg ; should_return = ReturnFalse} x - ) largs (args : Ident.t list)) - in - Js_output.append_output args_code (* Declared in [Lstaticraise ]*) - (Js_output.make [S.assign exit_id (E.small_int order_id)] - ~value:E.undefined) + | _ -> (* TODO: should be Assign -- Assign is an optimization *) + compile_lambda {cxt with st = Assign arg ; should_return = ReturnFalse} x + in Js_output.append_output new_output acc + ) + largs args + (Js_output.make [S.assign exit_id (E.small_int order_id)] + ~value:E.undefined) | exception Not_found -> - Js_output.make [S.unknown_lambda ~comment:"error" lam] + assert false (* staticraise is always enclosed by catch *) end (* Invariant: code can not be reused @@ -98698,11 +98696,6 @@ and if not we should use ``javascript break`` or ``continue`` *) | Lstaticcatch _ -> - let code_table, body = flatten_caches lam in - - - let bindings = Ext_list.flat_map (fun (_,_,bindings) -> bindings) code_table in - (* compile_list name l false (\*\) *) (* if exit_code_id == code handler -- ids are not useful, since @@ -98728,16 +98721,14 @@ and ]} *) (* TODO: handle NeedValue *) - let exit_id = Ext_ident.create_tmp ~name:"exit" () in + let code_table, body = flatten_caches lam in + let bindings = Ext_list.flat_map (fun (_,_,bindings) -> bindings) code_table in + let exit_id = Ext_ident.create_tmp ~name:"exit" () in let exit_expr = E.var exit_id in let jmp_table, handlers = Lam_compile_context.add_jmps exit_id code_table jmp_table in (* Declaration First, body and handler have the same value *) - (* There is a bug in google closure compiler: - https://github.com/google/closure-compiler/issues/1234#issuecomment-151976340 - TODO: wait for a bug fix - *) let declares = S.define_variable ~kind:Variable exit_id E.zero_int_literal :: From 5ea4b0a89df6d88bcb1ca5f40f7e0290df39ac50 Mon Sep 17 00:00:00 2001 From: Hongbo Zhang Date: Sun, 18 Mar 2018 10:45:23 +0800 Subject: [PATCH 8/8] finally fix #2413 --- jscomp/core/lam_compile.ml | 22 ++-- jscomp/test/flow_parser_reg_test.js | 17 +-- jscomp/test/gpr_1698_test.js | 3 - jscomp/test/gpr_2413_test.js | 1 - jscomp/test/js_json_test.js | 5 - jscomp/test/mario_game.js | 5 - jscomp/test/ocaml_parsetree_test.js | 17 --- jscomp/test/ocaml_proto_test.js | 20 --- jscomp/test/ocaml_re_test.js | 25 ---- jscomp/test/ocaml_typedtree_test.js | 193 ++-------------------------- jscomp/test/qcc.js | 2 - jscomp/test/stream_parser_test.js | 2 - jscomp/test/ticker.js | 5 - lib/js/arg.js | 8 -- lib/js/camlinternalFormat.js | 39 ------ lib/js/format.js | 6 - lib/js/genlex.js | 1 - lib/js/scanf.js | 4 - lib/js/stream.js | 5 - lib/whole_compiler.ml | 26 ++-- 20 files changed, 41 insertions(+), 365 deletions(-) diff --git a/jscomp/core/lam_compile.ml b/jscomp/core/lam_compile.ml index 08bd665de74..6313599f535 100644 --- a/jscomp/core/lam_compile.ml +++ b/jscomp/core/lam_compile.ml @@ -488,21 +488,23 @@ and compile_general_cases (fun group -> Ext_list.map_last (fun last (switch_case,lam) -> - (* let switch_block, should_break = - Js_output.to_break_block (compile_lambda cxt lam) in - let should_break = - match cxt.should_return with - | ReturnFalse -> should_break - | ReturnTrue _ -> false - in *) + if last then (* merge and shared *) - let switch_body = Js_output.to_break_block (compile_lambda cxt lam) in + let switch_block, should_break = + Js_output.to_break_block (compile_lambda cxt lam) in + let should_break = + match cxt.should_return with + | ReturnFalse -> should_break + | ReturnTrue _ -> + Lam_exit_code.has_exit_code (fun _ -> true ) lam + in + (* let switch_body = Js_output.to_break_block (compile_lambda cxt lam) in *) {J.switch_case ; - switch_body - } + switch_body = switch_block, should_break + } else { switch_case; switch_body = [],false } ) diff --git a/jscomp/test/flow_parser_reg_test.js b/jscomp/test/flow_parser_reg_test.js index 5af109c0d48..c7673d1c896 100644 --- a/jscomp/test/flow_parser_reg_test.js +++ b/jscomp/test/flow_parser_reg_test.js @@ -1837,7 +1837,6 @@ function token(env, lexbuf) { var env$6 = save_comment(match$1[0], start$1, match$1[1], buf$1, /* true */1); return token(env$6, lexbuf$1); } - break; case 5 : if (env$1[/* lex_in_comment_syntax */2]) { var env$7 = in_comment_syntax(/* false */0, env$1); @@ -1849,7 +1848,6 @@ function token(env, lexbuf) { /* T_MULT */97 ]; } - break; case 6 : var start$2 = loc_of_lexbuf(env$1, lexbuf$1); var buf$2 = Buffer.create(127); @@ -1866,7 +1864,6 @@ function token(env, lexbuf) { /* T_ERROR */104 ]; } - break; case 8 : var quote = Caml_bytes.get(lexbuf$1[/* lex_buffer */1], lexbuf$1[/* lex_start_pos */4]); var start$3 = loc_of_lexbuf(env$1, lexbuf$1); @@ -1957,7 +1954,6 @@ function token(env, lexbuf) { throw exn; } } - break; case 23 : return /* tuple */[ env$1, @@ -3792,7 +3788,6 @@ function type_token(env, lexbuf) { var env$5 = save_comment(match$1[0], start$1, match$1[1], buf$1, /* true */1); return type_token(env$5, lexbuf$1); } - break; case 4 : if (env$1[/* lex_in_comment_syntax */2]) { var env$6 = in_comment_syntax(/* false */0, env$1); @@ -3804,7 +3799,6 @@ function type_token(env, lexbuf) { /* T_MULT */97 ]; } - break; case 5 : var start$2 = loc_of_lexbuf(env$1, lexbuf$1); var buf$2 = Buffer.create(127); @@ -3914,7 +3908,6 @@ function type_token(env, lexbuf) { throw exn$1; } } - break; case 15 : var neg$8 = Lexing.sub_lexeme(lexbuf$1, lexbuf$1[/* lex_start_pos */4], Caml_array.caml_array_get(lexbuf$1[/* lex_mem */9], 0)); var num$8 = Lexing.sub_lexeme(lexbuf$1, Caml_array.caml_array_get(lexbuf$1[/* lex_mem */9], 0), Caml_array.caml_array_get(lexbuf$1[/* lex_mem */9], 1)); @@ -3958,7 +3951,6 @@ function type_token(env, lexbuf) { throw exn$2; } } - break; case 22 : return /* tuple */[ env$1, @@ -6593,7 +6585,8 @@ function properties(allow_static, env, _param) { callProperties ]; continue ; - case 2 : + break; + case 2 : return /* tuple */[ List.rev(acc), List.rev(indexers), @@ -7575,7 +7568,6 @@ function call(env, _left) { continue ; } - break; case 5 : token$4(env, /* T_LBRACKET */5); var expr = Curry._1(Parse[/* expression */6], env); @@ -8036,7 +8028,6 @@ function primary$1(env) { ]]) ]; } - break; case 2 : var raw$4 = Curry._2(Parser_env_048[/* value */1], /* None */0, env); token$4(env, token$5); @@ -10625,6 +10616,7 @@ function declare_export_declaration($staropt$star, env) { /* source : None */0 ]]) ]; + break; case 1 : case 2 : case 3 : @@ -10768,6 +10760,7 @@ function declare_export_declaration($staropt$star, env) { /* source : None */0 ]]) ]; + break; } } @@ -12334,6 +12327,7 @@ function module_item(env) { /* exportKind : ExportValue */1 ]]) ]; + break; case 2 : case 3 : case 4 : @@ -14087,7 +14081,6 @@ function parse(content, _) { ] ]); } - break; case 6 : var binary = match[0]; var match$4 = binary[/* operator */0]; diff --git a/jscomp/test/gpr_1698_test.js b/jscomp/test/gpr_1698_test.js index 4aa1b45fbfd..cca4b692f5c 100644 --- a/jscomp/test/gpr_1698_test.js +++ b/jscomp/test/gpr_1698_test.js @@ -13,7 +13,6 @@ function is_number(_expr) { } else { return /* true */1; } - break; case 1 : _expr = expr[0]; continue ; @@ -167,7 +166,6 @@ function compare(context, state, _a, _b) { default: return -1; } - break; case 2 : var denom = compare(context, state, da, db); var match = +(denom === 0); @@ -179,7 +177,6 @@ function compare(context, state, _a, _b) { } else { return denom; } - break; } }; diff --git a/jscomp/test/gpr_2413_test.js b/jscomp/test/gpr_2413_test.js index 628bf731720..66bead56208 100644 --- a/jscomp/test/gpr_2413_test.js +++ b/jscomp/test/gpr_2413_test.js @@ -14,7 +14,6 @@ function f(param) { var a$1 = match[0]; return a$1 + a$1 | 0; } - break; case 1 : case 2 : exit = 1; diff --git a/jscomp/test/js_json_test.js b/jscomp/test/js_json_test.js index 6479e78dec8..fba1b6d4ea9 100644 --- a/jscomp/test/js_json_test.js +++ b/jscomp/test/js_json_test.js @@ -289,7 +289,6 @@ function eq_at_i(loc, json, i, kind, expected) { } else { return eq(loc, ty$1[0], expected); } - break; case 1 : if (typeof ty$1 === "number") { return add_test(loc, (function () { @@ -302,7 +301,6 @@ function eq_at_i(loc, json, i, kind, expected) { return /* Ok */Block.__(4, [/* false */0]); })); } - break; case 2 : if (typeof ty$1 === "number") { return add_test(loc, (function () { @@ -315,7 +313,6 @@ function eq_at_i(loc, json, i, kind, expected) { return /* Ok */Block.__(4, [/* false */0]); })); } - break; case 3 : if (typeof ty$1 === "number") { return add_test(loc, (function () { @@ -328,7 +325,6 @@ function eq_at_i(loc, json, i, kind, expected) { return /* Ok */Block.__(4, [/* false */0]); })); } - break; case 4 : if (typeof ty$1 === "number") { switch (ty$1) { @@ -347,7 +343,6 @@ function eq_at_i(loc, json, i, kind, expected) { return /* Ok */Block.__(4, [/* false */0]); })); } - break; case 5 : if (typeof ty$1 === "number") { if (ty$1 >= 2) { diff --git a/jscomp/test/mario_game.js b/jscomp/test/mario_game.js index c12cb08367c..b49d80173dd 100644 --- a/jscomp/test/mario_game.js +++ b/jscomp/test/mario_game.js @@ -968,7 +968,6 @@ function update_player(player, keys, context) { player$1[/* dir */6] = /* Left */0; return /* () */0; } - break; case 1 : if (player$1[/* crouch */10]) { return 0; @@ -979,7 +978,6 @@ function update_player(player, keys, context) { player$1[/* dir */6] = /* Right */1; return /* () */0; } - break; case 2 : if (!player$1[/* jumping */4] && player$1[/* grounded */5]) { player$1[/* jumping */4] = /* true */1; @@ -1401,7 +1399,6 @@ function kill(collid, ctx) { } else { return /* [] */0; } - break; } } @@ -1886,7 +1883,6 @@ function process_collision(dir, c1, c2, state) { /* None */0 ]; } - break; } break; @@ -2021,7 +2017,6 @@ function process_collision(dir, c1, c2, state) { /* None */0 ]; } - break; } } diff --git a/jscomp/test/ocaml_parsetree_test.js b/jscomp/test/ocaml_parsetree_test.js index 83c59b699bf..e7203736ff0 100644 --- a/jscomp/test/ocaml_parsetree_test.js +++ b/jscomp/test/ocaml_parsetree_test.js @@ -792,7 +792,6 @@ function message(param) { } else { return "this pattern-matching is fragile.\nIt will remain exhaustive when constructors are added to type " + (s + "."); } - break; case 2 : var match = param[0]; if (match) { @@ -822,7 +821,6 @@ function message(param) { ] ]; } - break; case 3 : var s$1 = param[0]; if (s$1 === "") { @@ -830,7 +828,6 @@ function message(param) { } else { return "this pattern-matching is not exhaustive.\nHere is an example of a value that is not matched:\n" + s$1; } - break; case 4 : return "the following labels are not bound in this record pattern:\n" + (param[0] + "\nEither bind these labels explicitly or add '; _' to the pattern."); case 5 : @@ -862,7 +859,6 @@ function message(param) { ] ]; } - break; case 6 : return "the following private methods were made public implicitly:\n " + ($$String.concat(" ", param[0]) + "."); case 7 : @@ -9879,7 +9875,6 @@ function directive_parse(token_with_comments, lexbuf) { curr(lexbuf) ]; } - break; case 91 : return /* true */1; default: @@ -10845,7 +10840,6 @@ function token(lexbuf) { throw exn; } } - break; case 11 : warn_latin1(lexbuf$1); return /* LIDENT */Block.__(11, [Lexing.lexeme(lexbuf$1)]); @@ -10870,7 +10864,6 @@ function token(lexbuf) { throw exn$1; } } - break; case 15 : return /* FLOAT */Block.__(1, [remove_underscores(Lexing.lexeme(lexbuf$1))]); case 16 : @@ -10889,7 +10882,6 @@ function token(lexbuf) { throw exn$2; } } - break; case 17 : try { return /* INT64 */Block.__(9, [cvt_int64_literal(Lexing.lexeme(lexbuf$1))]); @@ -10906,7 +10898,6 @@ function token(lexbuf) { throw exn$3; } } - break; case 18 : try { return /* NATIVEINT */Block.__(12, [cvt_nativeint_literal(Lexing.lexeme(lexbuf$1))]); @@ -10923,7 +10914,6 @@ function token(lexbuf) { throw exn$4; } } - break; case 19 : reset_string_buffer(/* () */0); is_in_string[0] = /* true */1; @@ -11151,7 +11141,6 @@ function token(lexbuf) { } else { return /* EOF */25; } - break; case 91 : throw [ $$Error$2, @@ -11198,7 +11187,6 @@ function __ocaml_lex_quoted_string_rec(delim, lexbuf, ___ocaml_lex_state) { continue ; } - break; case 3 : store_string_char(Lexing.lexeme_char(lexbuf, 0)); ___ocaml_lex_state = 183; @@ -11252,7 +11240,6 @@ function string(lexbuf) { store_string_char(Lexing.lexeme_char(lexbuf$1, 1)); return string(lexbuf$1); } - break; case 6 : if (comment_start_loc[0] === /* [] */0) { prerr_warning(curr(lexbuf$1), /* Eol_in_string */14); @@ -11319,7 +11306,6 @@ function __ocaml_lex_comment_rec(lexbuf, ___ocaml_lex_state) { ] ]; } - break; case 2 : string_start_loc[0] = curr(lexbuf); store_string_char(/* "\"" */34); @@ -11447,7 +11433,6 @@ function __ocaml_lex_comment_rec(lexbuf, ___ocaml_lex_state) { ] ]; } - break; case 11 : update_loc(lexbuf, /* None */0, 1, /* false */0, 0); store_string(Lexing.lexeme(lexbuf)); @@ -11561,7 +11546,6 @@ function token$1(lexbuf) { if_then_else[0] = /* Dir_out */2; return Curry._1(cont, lexbuf$1); } - break; case 37 : if (if_then_else$1 >= 2) { if (directive_parse(token_with_comments, lexbuf$1)) { @@ -11627,7 +11611,6 @@ function token$1(lexbuf) { curr(lexbuf$1) ]; } - break; default: return Curry._1(look_ahead, match); } diff --git a/jscomp/test/ocaml_proto_test.js b/jscomp/test/ocaml_proto_test.js index 174d8099fc5..e38edb83906 100644 --- a/jscomp/test/ocaml_proto_test.js +++ b/jscomp/test/ocaml_proto_test.js @@ -1605,7 +1605,6 @@ function lexer(lexbuf) { } else { return /* EOF */25; } - break; case 12 : var match$1 = __ocaml_lex_multi_line_comment_rec(/* [] */0, lexbuf$1, 47); if (match$1) { @@ -1615,7 +1614,6 @@ function lexer(lexbuf) { } else { return /* EOF */25; } - break; case 13 : var match$2 = __ocaml_lex_string_rec(/* [] */0, lexbuf$1, 55); if (match$2) { @@ -1988,7 +1986,6 @@ function runtime_function(param) { ]; } - break; case 1 : switch (param[2]) { case 1 : @@ -2007,7 +2004,6 @@ function runtime_function(param) { ]; } - break; case 2 : var match$2 = param[2]; if (match$2 !== 5) { @@ -2022,7 +2018,6 @@ function runtime_function(param) { } else { return "Pbrt.Encoder.bytes"; } - break; } } else if (match$1[0] !== 0) { @@ -2086,7 +2081,6 @@ function runtime_function(param) { ]; } - break; case 1 : switch (param[2]) { case 1 : @@ -2105,7 +2099,6 @@ function runtime_function(param) { ]; } - break; case 2 : var match$4 = param[2]; if (match$4 !== 5) { @@ -2120,7 +2113,6 @@ function runtime_function(param) { } else { return "Pbrt.Decoder.bytes"; } - break; } } else if (match$3[0] !== 0) { @@ -4110,14 +4102,12 @@ function compile_default_p2(all_types, field) { } else { return invalid_default_value(/* Some */[field_name$1], "invalid default type (bool expected)", /* () */0); } - break; case 13 : if (constant.tag) { return invalid_default_value(/* Some */[field_name$1], "invalid default type (string expected)", /* () */0); } else { return /* Some */[constant]; } - break; case 14 : return invalid_default_value(/* Some */[field_name$1], "default value not supported for bytes", /* () */0); @@ -4156,14 +4146,12 @@ function compile_default_p2(all_types, field) { default: return invalid_default_value(/* Some */[field_name$1], "invalid default type (float/int expected)", /* () */0); } - break; case 2 : if (constant.tag === 2) { return /* Some */[constant]; } else { return invalid_default_value(/* Some */[field_name$1], "invalid default type (int expected)", /* () */0); } - break; case 3 : if (constant.tag === 2) { if (constant[0] >= 0) { @@ -4174,7 +4162,6 @@ function compile_default_p2(all_types, field) { } else { return invalid_default_value(/* Some */[field_name$1], "invalid default type (int expected)", /* () */0); } - break; } } else { @@ -5660,7 +5647,6 @@ function default_value_of_field_type(field_name, field_type, field_default) { } else { return "\"\""; } - break; case 1 : if (field_default$1) { var match$1 = field_default$1[0]; @@ -5672,7 +5658,6 @@ function default_value_of_field_type(field_name, field_type, field_default) { } else { return "0."; } - break; case 2 : if (field_default$1) { var match$2 = field_default$1[0]; @@ -5684,7 +5669,6 @@ function default_value_of_field_type(field_name, field_type, field_default) { } else { return "0"; } - break; case 3 : if (field_default$1) { var match$3 = field_default$1[0]; @@ -5707,7 +5691,6 @@ function default_value_of_field_type(field_name, field_type, field_default) { } else { return "0l"; } - break; case 4 : if (field_default$1) { var match$4 = field_default$1[0]; @@ -5730,7 +5713,6 @@ function default_value_of_field_type(field_name, field_type, field_default) { } else { return "0L"; } - break; case 5 : if (field_default$1) { var match$5 = field_default$1[0]; @@ -5754,7 +5736,6 @@ function default_value_of_field_type(field_name, field_type, field_default) { } else { return "Bytes.create 64"; } - break; case 6 : if (field_default$1) { var match$6 = field_default$1[0]; @@ -5771,7 +5752,6 @@ function default_value_of_field_type(field_name, field_type, field_default) { } else { return "false"; } - break; } } diff --git a/jscomp/test/ocaml_re_test.js b/jscomp/test/ocaml_re_test.js index 8f83eca319f..942004318ac 100644 --- a/jscomp/test/ocaml_re_test.js +++ b/jscomp/test/ocaml_re_test.js @@ -790,7 +790,6 @@ function equal(_l1, _l2) { } else { return /* false */0; } - break; case 1 : case 2 : return /* false */0; @@ -799,7 +798,6 @@ function equal(_l1, _l2) { } else { return /* false */0; } - break; case 1 : if (l2) { var match$2 = l2[0]; @@ -813,7 +811,6 @@ function equal(_l1, _l2) { } else { return /* false */0; } - break; case 0 : case 2 : return /* false */0; @@ -822,7 +819,6 @@ function equal(_l1, _l2) { } else { return /* false */0; } - break; case 2 : if (l2) { var match$3 = l2[0]; @@ -839,13 +835,11 @@ function equal(_l1, _l2) { } else { return /* false */0; } - break; } } else { return /* false */0; } - break; } } else if (l2) { @@ -1130,7 +1124,6 @@ function remove_duplicates(prev, _l, y) { ]; } } - break; case 2 : return /* tuple */[ /* :: */[ @@ -1781,7 +1774,6 @@ function is_charset(_param) { } else { return /* false */0; } - break; default: return /* false */0; } @@ -2004,21 +1996,18 @@ function equal$2(_x1, _x2) { } else { return Caml_obj.caml_equal(x1[0], x2[0]); } - break; case 1 : if (typeof x2 === "number" || x2.tag !== 1) { return /* false */0; } else { return eq_list(x1[0], x2[0]); } - break; case 2 : if (typeof x2 === "number" || x2.tag !== 2) { return /* false */0; } else { return eq_list(x1[0], x2[0]); } - break; case 3 : if (typeof x2 === "number" || !(x2.tag === 3 && x1[1] === x2[1] && Caml_obj.caml_equal(x1[2], x2[2]))) { return /* false */0; @@ -2028,7 +2017,6 @@ function equal$2(_x1, _x2) { continue ; } - break; case 4 : if (typeof x2 === "number" || !(x2.tag === 4 && x1[0] === x2[0])) { return /* false */0; @@ -2038,7 +2026,6 @@ function equal$2(_x1, _x2) { continue ; } - break; case 5 : if (typeof x2 === "number" || !(x2.tag === 5 && x1[0] === x2[0])) { return /* false */0; @@ -2048,10 +2035,8 @@ function equal$2(_x1, _x2) { continue ; } - break; case 6 : return /* false */0; - break; case 7 : if (typeof x2 === "number" || x2.tag !== 7) { return /* false */0; @@ -2061,7 +2046,6 @@ function equal$2(_x1, _x2) { continue ; } - break; case 8 : if (typeof x2 === "number" || x2.tag !== 8) { return /* false */0; @@ -2071,7 +2055,6 @@ function equal$2(_x1, _x2) { continue ; } - break; case 9 : if (typeof x2 === "number" || x2.tag !== 9) { return /* false */0; @@ -2081,7 +2064,6 @@ function equal$2(_x1, _x2) { continue ; } - break; case 10 : if (typeof x2 === "number" || x2.tag !== 10) { return /* false */0; @@ -2091,21 +2073,18 @@ function equal$2(_x1, _x2) { continue ; } - break; case 11 : if (typeof x2 === "number" || x2.tag !== 11) { return /* false */0; } else { return eq_list(x1[0], x2[0]); } - break; case 12 : if (typeof x2 === "number" || x2.tag !== 12) { return /* false */0; } else { return eq_list(x1[0], x2[0]); } - break; case 13 : if (typeof x2 === "number" || !(x2.tag === 13 && equal$2(x1[0], x2[0]))) { return /* false */0; @@ -2115,7 +2094,6 @@ function equal$2(_x1, _x2) { continue ; } - break; case 14 : if (typeof x2 === "number" || !(x2.tag === 14 && x1[0] === x2[0])) { return /* false */0; @@ -2125,7 +2103,6 @@ function equal$2(_x1, _x2) { continue ; } - break; } } @@ -2429,7 +2406,6 @@ function translate(ids, kind, _ign_group, ign_case, _greedy, pos, cache, c, _par match$3[1] ]; } - break; case 7 : _param = param[0]; _ign_group = /* true */1; @@ -2659,7 +2635,6 @@ function anchored(_param) { } else { return /* false */0; } - break; case 6 : case 7 : case 8 : diff --git a/jscomp/test/ocaml_typedtree_test.js b/jscomp/test/ocaml_typedtree_test.js index 9028585257e..f131278f224 100644 --- a/jscomp/test/ocaml_typedtree_test.js +++ b/jscomp/test/ocaml_typedtree_test.js @@ -1038,7 +1038,6 @@ function message(param) { } else { return "this pattern-matching is fragile.\nIt will remain exhaustive when constructors are added to type " + (s + "."); } - break; case 2 : var match = param[0]; if (match) { @@ -1068,7 +1067,6 @@ function message(param) { ] ]; } - break; case 3 : var s$1 = param[0]; if (s$1 === "") { @@ -1076,7 +1074,6 @@ function message(param) { } else { return "this pattern-matching is not exhaustive.\nHere is an example of a value that is not matched:\n" + s$1; } - break; case 4 : return "the following labels are not bound in this record pattern:\n" + (param[0] + "\nEither bind these labels explicitly or add '; _' to the pattern."); case 5 : @@ -1108,7 +1105,6 @@ function message(param) { ] ]; } - break; case 6 : return "the following private methods were made public implicitly:\n " + ($$String.concat(" ", param[0]) + "."); case 7 : @@ -2418,7 +2414,6 @@ function same(_p1, _p2) { return /* false */0; } - break; case 1 : switch (p2.tag | 0) { case 1 : @@ -2430,13 +2425,11 @@ function same(_p1, _p2) { } else { return /* false */0; } - break; case 0 : case 2 : return /* false */0; } - break; case 2 : switch (p2.tag | 0) { case 0 : @@ -2451,10 +2444,8 @@ function same(_p1, _p2) { } else { return /* false */0; } - break; } - break; } }; @@ -2477,7 +2468,6 @@ function isfree(id, _param) { continue ; } - break; } }; @@ -3393,7 +3383,6 @@ function equal_tag(t1, t2) { return /* false */0; } - break; case 1 : switch (t2.tag | 0) { case 1 : @@ -3403,7 +3392,6 @@ function equal_tag(t1, t2) { return /* false */0; } - break; case 2 : switch (t2.tag | 0) { case 0 : @@ -3417,7 +3405,6 @@ function equal_tag(t1, t2) { } } - break; } } @@ -4099,7 +4086,6 @@ function repr(_t) { } else { return t; } - break; case 6 : _t = match[0]; continue ; @@ -4387,7 +4373,6 @@ function has_constr_row(t) { } else { return /* true */1; } - break; default: return /* false */0; } @@ -4834,7 +4819,6 @@ function copy_type_desc(_$staropt$star, f, _ty) { [/* None */0] ]); } - break; case 5 : return /* Tfield */Block.__(5, [ ty[0], @@ -5592,7 +5576,6 @@ function free_vars(ty) { continue ; } - break; default: return iter_type_expr(loop, ty$1); } @@ -8748,7 +8731,6 @@ function module_path(s, p) { throw exn; } } - break; case 1 : return /* Pdot */Block.__(1, [ module_path(s, p[0]), @@ -8782,7 +8764,6 @@ function modtype_path(s, p) { throw exn; } } - break; case 1 : return /* Pdot */Block.__(1, [ module_path(s, p[0]), @@ -8808,7 +8789,6 @@ function type_path(s, p) { throw exn; } } - break; case 1 : return /* Pdot */Block.__(1, [ module_path(s, p[0]), @@ -9050,6 +9030,7 @@ function typexp(s, ty) { } ty$prime[/* desc */0] = tmp; return ty$prime; + break; case 2 : if (s[/* for_saving */3] || ty$1[/* id */2] < 0) { var ty$prime$1 = s[/* for_saving */3] ? newpersty(norm(desc)) : newty2(ty$1[/* level */1], desc); @@ -9059,7 +9040,6 @@ function typexp(s, ty) { } else { return ty$1; } - break; } } @@ -9319,7 +9299,6 @@ function modtype(s, mty) { throw exn; } } - break; case 1 : return /* Mty_ident */Block.__(0, [/* Pdot */Block.__(1, [ module_path(s, p[0]), @@ -9330,7 +9309,6 @@ function modtype(s, mty) { return fatal_error("Subst.modtype"); } - break; case 1 : return /* Mty_signature */Block.__(1, [signature$2(s, mty[0])]); case 2 : @@ -9474,7 +9452,6 @@ function force(f, x) { x[0] = /* Raise */Block.__(1, [e]); throw e; } - break; } } @@ -9989,7 +9966,6 @@ function find_module_descr(path, env) { throw exn; } } - break; case 1 : var match = force(components_of_module_maker$prime[0], find_module_descr(path[0], env)); if (match.tag) { @@ -9997,7 +9973,6 @@ function find_module_descr(path, env) { } else { return find$2(path[1], match[0][/* comp_components */6])[0]; } - break; case 2 : var p1 = path[0]; var match$1 = force(components_of_module_maker$prime[0], find_module_descr(p1, env)); @@ -10006,7 +9981,6 @@ function find_module_descr(path, env) { } else { throw Caml_builtin_exceptions.not_found; } - break; } } @@ -10022,7 +9996,6 @@ function find$3(proj1, proj2, path, env) { } else { return find$2(path[1], Curry._1(proj2, match[0]))[0]; } - break; case 2 : throw Caml_builtin_exceptions.not_found; @@ -10080,7 +10053,6 @@ function find_module(alias, path, env) { throw exn; } } - break; case 1 : var match = force(components_of_module_maker$prime[0], find_module_descr(path[0], env)); if (match.tag) { @@ -10089,7 +10061,6 @@ function find_module(alias, path, env) { var match$1 = find$2(path[1], match[0][/* comp_modules */4]); return md(force(subst_modtype_maker, match$1[0])); } - break; case 2 : var p2 = path[1]; var desc1 = find_module_descr(path[0], env); @@ -10120,7 +10091,6 @@ function find_module(alias, path, env) { } else { throw Caml_builtin_exceptions.not_found; } - break; } } @@ -10336,7 +10306,6 @@ function is_functor_arg(_path, env) { throw exn; } } - break; case 1 : _path = path[0]; continue ; @@ -10374,7 +10343,6 @@ function lookup_module_descr(lid, env) { throw exn; } } - break; case 1 : var s$1 = lid[1]; var match = lookup_module_descr(lid[0], env); @@ -10392,7 +10360,6 @@ function lookup_module_descr(lid, env) { match$2[0] ]; } - break; case 2 : var match$3 = lookup_module_descr(lid[0], env); var p1 = match$3[0]; @@ -10412,7 +10379,6 @@ function lookup_module_descr(lid, env) { } else { throw Caml_builtin_exceptions.not_found; } - break; } } @@ -10468,7 +10434,6 @@ function lookup_module(load, lid, env) { throw exn; } } - break; case 1 : var s$1 = lid[1]; var match$1 = lookup_module_descr(lid[0], env); @@ -10483,7 +10448,6 @@ function lookup_module(load, lid, env) { match$3[1] ]); } - break; case 2 : var match$4 = lookup_module_descr(lid[0], env); var p2 = lookup_module(/* true */1, lid[1], env); @@ -10500,7 +10464,6 @@ function lookup_module(load, lid, env) { } else { throw Caml_builtin_exceptions.not_found; } - break; } } @@ -10526,7 +10489,6 @@ function lookup(proj1, proj2, lid, env) { match$2[0] ]; } - break; case 2 : throw Caml_builtin_exceptions.not_found; @@ -10582,7 +10544,6 @@ function lookup_all_simple(proj1, proj2, shadow, lid, env) { ]; }), comps); } - break; case 2 : throw Caml_builtin_exceptions.not_found; @@ -10605,7 +10566,6 @@ function cstr_shadow(cstr1, cstr2) { return /* true */1; } - break; } } @@ -10924,7 +10884,6 @@ function mark_constructor(usage, env, name, desc) { throw exn; } } - break; } if (exit === 1) { @@ -11369,7 +11328,6 @@ function scrape_alias(env, path, mty) { throw exn; } } - break; case 1 : case 2 : exit = 1; @@ -11386,7 +11344,6 @@ function scrape_alias(env, path, mty) { throw exn$1; } } - break; } if (exit === 1) { @@ -11931,7 +11888,6 @@ function components_of_module_maker(param) { } else { return /* () */0; } - break; case 1 : var decl$1 = item[1]; var id = item[0]; @@ -19914,7 +19870,6 @@ function directive_parse(token_with_comments, lexbuf) { curr(lexbuf) ]; } - break; case 91 : return /* true */1; default: @@ -20900,7 +20855,6 @@ function token(lexbuf) { throw exn; } } - break; case 11 : warn_latin1(lexbuf$1); return /* LIDENT */Block.__(11, [Lexing.lexeme(lexbuf$1)]); @@ -20925,7 +20879,6 @@ function token(lexbuf) { throw exn$1; } } - break; case 15 : return /* FLOAT */Block.__(1, [remove_underscores(Lexing.lexeme(lexbuf$1))]); case 16 : @@ -20944,7 +20897,6 @@ function token(lexbuf) { throw exn$2; } } - break; case 17 : try { return /* INT64 */Block.__(9, [cvt_int64_literal(Lexing.lexeme(lexbuf$1))]); @@ -20961,7 +20913,6 @@ function token(lexbuf) { throw exn$3; } } - break; case 18 : try { return /* NATIVEINT */Block.__(12, [cvt_nativeint_literal(Lexing.lexeme(lexbuf$1))]); @@ -20978,7 +20929,6 @@ function token(lexbuf) { throw exn$4; } } - break; case 19 : reset_string_buffer(/* () */0); is_in_string[0] = /* true */1; @@ -21206,7 +21156,6 @@ function token(lexbuf) { } else { return /* EOF */25; } - break; case 91 : throw [ $$Error$4, @@ -21253,7 +21202,6 @@ function __ocaml_lex_quoted_string_rec(delim, lexbuf, ___ocaml_lex_state) { continue ; } - break; case 3 : store_string_char(Lexing.lexeme_char(lexbuf, 0)); ___ocaml_lex_state = 183; @@ -21303,7 +21251,6 @@ function string(lexbuf) { store_string_char(Lexing.lexeme_char(lexbuf$1, 1)); return string(lexbuf$1); } - break; case 6 : if (comment_start_loc[0] === /* [] */0) { prerr_warning(curr(lexbuf$1), /* Eol_in_string */14); @@ -21374,7 +21321,6 @@ function __ocaml_lex_comment_rec(lexbuf, ___ocaml_lex_state) { ] ]; } - break; case 2 : string_start_loc[0] = curr(lexbuf); store_string_char(/* "\"" */34); @@ -21502,7 +21448,6 @@ function __ocaml_lex_comment_rec(lexbuf, ___ocaml_lex_state) { ] ]; } - break; case 11 : update_loc(lexbuf, /* None */0, 1, /* false */0, 0); store_string(Lexing.lexeme(lexbuf)); @@ -21616,7 +21561,6 @@ function token$1(lexbuf) { if_then_else[0] = /* Dir_out */2; return Curry._1(cont, lexbuf$1); } - break; case 37 : if (if_then_else$1 >= 2) { if (directive_parse(token_with_comments, lexbuf$1)) { @@ -21682,7 +21626,6 @@ function token$1(lexbuf) { curr(lexbuf$1) ]; } - break; default: return Curry._1(look_ahead, match); } @@ -22165,7 +22108,6 @@ function alpha_pat(env, p) { throw exn$1; } } - break; default: exit = 1; } @@ -24699,7 +24641,6 @@ function closed_schema_rec(_ty) { } else { return iter_type_expr(closed_schema_rec, ty$1); } - break; case 5 : if (field_kind_repr(match[1]) === /* Fpresent */0) { closed_schema_rec(match[2]); @@ -24716,7 +24657,6 @@ function closed_schema_rec(_ty) { continue ; } - break; default: return iter_type_expr(closed_schema_rec, ty$1); } @@ -24822,7 +24762,6 @@ function free_vars_rec(_real, _ty) { continue ; } - break; default: exit = 1; } @@ -27155,7 +27094,6 @@ function occur_univar(env, ty) { } else { return /* () */0; } - break; case 9 : if (mem$3(ty$1, bound)) { return 0; @@ -27171,7 +27109,6 @@ function occur_univar(env, ty) { ] ]; } - break; case 10 : var bound$1 = List.fold_right(add$3, List.map(repr, match[1]), bound); _ty = match[0]; @@ -27264,14 +27201,12 @@ function univars_escape(env, univar_pairs, vl, ty) { } else { return /* () */0; } - break; case 9 : if (mem$3(t$1, family)) { throw Occur; } else { return 0; } - break; case 10 : if (List.exists((function (t) { return mem$3(repr(t), family); @@ -27282,7 +27217,6 @@ function univars_escape(env, univar_pairs, vl, ty) { continue ; } - break; default: return iter_type_expr(occur, t$1); } @@ -27750,7 +27684,6 @@ function mcomp(type_pairs, env, _t1, _t2) { /* [] */0 ]; } - break; case 3 : exit$3 = 3; break; @@ -30374,7 +30307,6 @@ function filter_arrow(env, t, l) { /* [] */0 ]; } - break; default: throw [ Unify, @@ -30420,7 +30352,6 @@ function filter_method_field(env, name, priv, _ty) { continue ; } - break; default: throw [ Unify, @@ -30608,7 +30539,6 @@ function moregen(inst_nongen, type_pairs, env, t1, t2) { /* [] */0 ]; } - break; case 1 : if (typeof match$3 === "number") { throw [ @@ -30633,7 +30563,6 @@ function moregen(inst_nongen, type_pairs, env, t1, t2) { /* [] */0 ]; } - break; case 2 : if (typeof match$3 === "number") { throw [ @@ -30648,7 +30577,6 @@ function moregen(inst_nongen, type_pairs, env, t1, t2) { /* [] */0 ]; } - break; case 3 : if (typeof match$3 === "number") { throw [ @@ -30670,7 +30598,6 @@ function moregen(inst_nongen, type_pairs, env, t1, t2) { /* [] */0 ]; } - break; case 4 : if (typeof match$3 === "number") { throw [ @@ -30685,7 +30612,6 @@ function moregen(inst_nongen, type_pairs, env, t1, t2) { /* [] */0 ]; } - break; case 5 : if (typeof match$3 === "number") { throw [ @@ -30700,7 +30626,6 @@ function moregen(inst_nongen, type_pairs, env, t1, t2) { /* [] */0 ]; } - break; case 6 : case 7 : throw [ @@ -30973,7 +30898,6 @@ function moregen(inst_nongen, type_pairs, env, t1, t2) { /* [] */0 ]; } - break; case 9 : if (typeof match$3 === "number") { throw [ @@ -30988,7 +30912,6 @@ function moregen(inst_nongen, type_pairs, env, t1, t2) { /* [] */0 ]; } - break; case 10 : var tl1 = match$2[1]; var t1$2 = match$2[0]; @@ -31058,7 +30981,6 @@ function moregen(inst_nongen, type_pairs, env, t1, t2) { /* [] */0 ]; } - break; } } @@ -31273,7 +31195,6 @@ function rigidify_rec(vars, _ty) { continue ; } - break; default: return iter_type_expr((function (param) { return rigidify_rec(vars, param); @@ -31516,7 +31437,6 @@ function eqtype(rename, type_pairs, subst, env, t1, t2) { /* [] */0 ]; } - break; case 1 : if (typeof match$3 === "number") { throw [ @@ -31541,7 +31461,6 @@ function eqtype(rename, type_pairs, subst, env, t1, t2) { /* [] */0 ]; } - break; case 2 : if (typeof match$3 === "number") { throw [ @@ -31556,7 +31475,6 @@ function eqtype(rename, type_pairs, subst, env, t1, t2) { /* [] */0 ]; } - break; case 3 : if (typeof match$3 === "number") { throw [ @@ -31578,7 +31496,6 @@ function eqtype(rename, type_pairs, subst, env, t1, t2) { /* [] */0 ]; } - break; case 4 : if (typeof match$3 === "number") { throw [ @@ -31593,7 +31510,6 @@ function eqtype(rename, type_pairs, subst, env, t1, t2) { /* [] */0 ]; } - break; case 5 : if (typeof match$3 === "number") { throw [ @@ -31608,7 +31524,6 @@ function eqtype(rename, type_pairs, subst, env, t1, t2) { /* [] */0 ]; } - break; case 6 : case 7 : throw [ @@ -31808,7 +31723,6 @@ function eqtype(rename, type_pairs, subst, env, t1, t2) { /* [] */0 ]; } - break; case 9 : if (typeof match$3 === "number") { throw [ @@ -31823,7 +31737,6 @@ function eqtype(rename, type_pairs, subst, env, t1, t2) { /* [] */0 ]; } - break; case 10 : var tl1 = match$2[1]; var t1$2 = match$2[0]; @@ -31893,7 +31806,6 @@ function eqtype(rename, type_pairs, subst, env, t1, t2) { /* [] */0 ]; } - break; } } @@ -32190,7 +32102,6 @@ function moregen_clty(trace, type_pairs, env, cty1, cty2) { /* [] */0 ]; } - break; } break; @@ -32900,7 +32811,6 @@ function build_subtype(env, visited, loops, posi, level, t) { /* Unchanged */0 ]; } - break; case 1 : if (memq_warn(t$1, visited)) { return /* tuple */[ @@ -32932,7 +32842,6 @@ function build_subtype(env, visited, loops, posi, level, t) { ]; } } - break; case 2 : if (memq_warn(t$1, visited)) { return /* tuple */[ @@ -32963,7 +32872,6 @@ function build_subtype(env, visited, loops, posi, level, t) { ]; } } - break; case 3 : var tl = match[1]; var p = match[0]; @@ -33150,7 +33058,6 @@ function build_subtype(env, visited, loops, posi, level, t) { } } } - break; case 4 : var t1 = match[0]; if (memq_warn(t$1, visited) || opened_object(t1)) { @@ -33182,7 +33089,6 @@ function build_subtype(env, visited, loops, posi, level, t) { ]; } } - break; case 5 : var match$12 = build_subtype(env, visited, loops, posi, level, match[2]); var match$13 = build_subtype(env, visited, loops, posi, level, match[3]); @@ -33310,7 +33216,6 @@ function build_subtype(env, visited, loops, posi, level, t) { /* Changed */2 ]; } - break; case 10 : var match$14 = build_subtype(env, visited, loops, posi, level, match[0]); var c$7 = match$14[1]; @@ -33751,7 +33656,6 @@ function subtype_rec(env, _trace, _t1, _t2, _cstrs) { } else { throw Pervasives.Exit; } - break; default: throw Pervasives.Exit; } @@ -33873,7 +33777,6 @@ function subtype_rec(env, _trace, _t1, _t2, _cstrs) { throw exn$1; } } - break; default: exit = 1; } @@ -33954,7 +33857,6 @@ function subtype_rec(env, _trace, _t1, _t2, _cstrs) { continue ; } - break; default: exit = 1; } @@ -34036,7 +33938,6 @@ function subtype_rec(env, _trace, _t1, _t2, _cstrs) { throw exn$4; } } - break; default: exit = 1; } @@ -34837,7 +34738,6 @@ function nondep_class_type(env, id, _param) { nondep_class_type(env, id, cty) ]); } - break; case 1 : return /* Cty_signature */Block.__(1, [nondep_class_signature(env, id, param[0])]); case 2 : @@ -39198,7 +39098,6 @@ function compare$2(_p1, _p2) { return Caml_obj.caml_compare(p1, p2); } - break; case 2 : switch (p2.tag | 0) { case 0 : @@ -39214,10 +39113,8 @@ function compare$2(_p1, _p2) { continue ; } - break; } - break; } }; @@ -39939,7 +39836,6 @@ function mark_loops_rec(_visited, _ty) { }(visited$1)), match$3[0]); } } - break; case 5 : var ty2 = match[3]; if (field_kind_repr(match[1]) === /* Fpresent */0) { @@ -39954,7 +39850,6 @@ function mark_loops_rec(_visited, _ty) { continue ; } - break; case 6 : return fatal_error("Printtyp.mark_loops_rec (2)"); case 7 : @@ -39995,7 +39890,6 @@ function mark_loops_rec(_visited, _ty) { }(visited$1)), row); } } - break; case 0 : case 9 : return add_named_var(ty$1); @@ -40296,7 +40190,6 @@ function tree_of_typexp(sch, ty) { } else { return tree_of_typexp(sch, ty$2); } - break; case 11 : var n = List.map((function (li) { return $$String.concat(".", flat(/* [] */0, li)); @@ -40828,7 +40721,6 @@ function prepare_class_type(params, _param) { } else { return List.iter(mark_loops, tyl); } - break; case 1 : var sign = param[0]; var sty$1 = repr(sign[/* csig_self */0]); @@ -40876,7 +40768,6 @@ function tree_of_class_type(sch, params, _param) { }), param[1]) ]); } - break; case 1 : var sign = param[0]; var sty$1 = repr(sign[/* csig_self */0]); @@ -40985,6 +40876,7 @@ function tree_of_class_type(sch, params, _param) { tr, tree_of_class_type(sch, params, param[2]) ]); + break; } }; @@ -41128,7 +41020,6 @@ function filter_rem_sig(item, rem) { rem ]; } - break; case 6 : if (rem) { var match$2 = rem[1]; @@ -41155,7 +41046,6 @@ function filter_rem_sig(item, rem) { rem ]; } - break; default: return /* tuple */[ /* [] */0, @@ -42662,7 +42552,6 @@ function path_same_name(_p1, _p2) { return /* () */0; } - break; case 1 : switch (p2.tag | 0) { case 1 : @@ -42674,13 +42563,11 @@ function path_same_name(_p1, _p2) { } else { return /* () */0; } - break; case 0 : case 2 : return /* () */0; } - break; case 2 : switch (p2.tag | 0) { case 0 : @@ -42693,7 +42580,6 @@ function path_same_name(_p1, _p2) { continue ; } - break; } }; @@ -43349,7 +43235,6 @@ function is_absrow(env, ty) { return /* false */0; } } - break; case 1 : case 2 : return /* false */0; @@ -44286,6 +44171,7 @@ function strengthen_sig(env, sg, p) { ]), strengthen_sig(env, sg[1], p) ]; + break; case 3 : var md = sigelt[1]; var id$1 = sigelt[0]; @@ -44357,7 +44243,6 @@ function nondep_supertype(env, mid, mty) { } else { return mty; } - break; case 1 : return /* Mty_signature */Block.__(1, [nondep_sig(env, va, mty[0])]); case 2 : @@ -44394,7 +44279,6 @@ function nondep_supertype(env, mid, mty) { } else { return mty; } - break; } }; @@ -44483,7 +44367,6 @@ function nondep_supertype(env, mid, mty) { throw exn; } } - break; case 5 : return /* :: */[ /* Sig_class */Block.__(5, [ @@ -44680,7 +44563,6 @@ function contains_type(env, _param) { throw exn; } } - break; case 1 : return List.iter((function (param) { var env$1 = env; @@ -44698,7 +44580,6 @@ function contains_type(env, _param) { } else { throw Pervasives.Exit; } - break; case 3 : return contains_type(env$1, param$1[1][/* md_type */0]); case 4 : @@ -45369,7 +45250,6 @@ function rollback_path(subst, _p) { continue ; } - break; case 0 : case 2 : return p; @@ -45477,7 +45357,6 @@ function remove_aliases(env, excl, _mty) { continue ; } - break; } }; @@ -45847,7 +45726,6 @@ function is_runtime_component(param) { } else { return /* false */0; } - break; case 1 : case 4 : case 6 : @@ -45971,7 +45849,6 @@ function try_modtypes(env, cxt, subst, _mty1, mty2) { } else { throw Dont_match$1; } - break; case 1 : case 3 : throw Dont_match$1; @@ -45999,7 +45876,6 @@ function try_modtypes(env, cxt, subst, _mty1, mty2) { ]); } } - break; case 1 : case 3 : throw Dont_match$1; @@ -46069,7 +45945,6 @@ function try_modtypes(env, cxt, subst, _mty1, mty2) { modtypes(env, cxt, subst, mty1$1, mty2) ]); } - break; } if (exit === 1) { @@ -47676,14 +47551,12 @@ function const_compare(x, y) { } else { return Caml_obj.caml_compare(x, y); } - break; case 3 : if (y.tag === 3) { return Caml_primitive.caml_float_compare(Caml_format.caml_float_of_string(x[0]), Caml_format.caml_float_of_string(y[0])); } else { return Caml_obj.caml_compare(x, y); } - break; default: return Caml_obj.caml_compare(x, y); } @@ -47881,7 +47754,6 @@ function compat(_p, _q) { } else { return /* false */0; } - break; case 8 : exit = 2; break; @@ -48002,7 +47874,6 @@ function compat(_p, _q) { } } } - break; case 2 : if (compat(p, match$1[0])) { return /* true */1; @@ -48011,7 +47882,6 @@ function compat(_p, _q) { continue ; } - break; case 3 : throw [ Caml_builtin_exceptions.assert_failure, @@ -49872,7 +49742,6 @@ function full_match(ignore_generalized, closing, env) { } else { return /* false */0; } - break; case 4 : var c = match[1]; if (c[/* cstr_consts */6] < 0) { @@ -49883,7 +49752,6 @@ function full_match(ignore_generalized, closing, env) { } else { return +(List.length(env) === (c[/* cstr_consts */6] + c[/* cstr_nonconsts */7] | 0)); } - break; case 5 : var fields = List.map((function (param) { var match = param[0][/* pat_desc */0]; @@ -50432,7 +50300,6 @@ function build_other(ext, env) { }), 0, Nativeint.succ, p, env); } - break; case 4 : var c = match[1]; var exit = 0; @@ -50644,7 +50511,6 @@ function has_instance(_p) { } else { return /* true */1; } - break; case 6 : return has_instances(List.map((function (param) { return param[2]; @@ -50660,7 +50526,6 @@ function has_instance(_p) { continue ; } - break; case 1 : case 9 : _p = match[0]; @@ -50733,7 +50598,6 @@ function satisfiable(_pss, _qs) { continue ; } - break; default: exit = 2; } @@ -50767,7 +50631,6 @@ function satisfiable(_pss, _qs) { continue ; } - break; case 2 : var q0$1 = discr_pat(q, pss); _qs = Pervasives.$at(simple_match_args(q0$1, q), qs[1]); @@ -51467,7 +51330,6 @@ function every_satisfiables(_pss, _qs) { continue ; } - break; default: exit = 1; } @@ -51494,7 +51356,6 @@ function every_satisfiables(_pss, _qs) { continue ; } - break; } } else { @@ -51728,7 +51589,6 @@ function le_pat(_p, _q) { } else { return /* false */0; } - break; default: exit = 1; } @@ -52265,7 +52125,6 @@ function conv(typed) { /* [] */0 ]; } - break; case 6 : var subpatterns = match[0]; var pats = select(List.map((function (param) { @@ -52442,7 +52301,6 @@ function collect_paths_from_pat(_r, _p) { } else { return r; } - break; case 6 : return List.fold_left((function (r, param) { return collect_paths_from_pat(r, param[2]); @@ -52540,7 +52398,6 @@ function string_of_payload(param) { } else { return /* None */0; } - break; case 1 : case 2 : return /* None */0; @@ -52906,13 +52763,11 @@ function find_component(lookup, make_error, env, loc, lid) { } else { return Curry._2(lookup, lid, env); } - break; case 1 : case 2 : return Curry._2(lookup, lid, env); } - break; case 0 : case 2 : return Curry._2(lookup, lid, env); @@ -53450,7 +53305,6 @@ function transl_type(env, policy, styp) { } else { throw Caml_builtin_exceptions.not_found; } - break; default: throw Caml_builtin_exceptions.not_found; } @@ -55993,7 +55847,6 @@ function build_as_type(env, _p) { }), List.combine(pl, tyl$1), match$1[0]); return match$1[1]; } - break; case 5 : var ty = may_map((function (param) { return build_as_type(env, param); @@ -56057,7 +55910,6 @@ function build_as_type(env, _p) { $$Array.iter(do_label, lbl[/* lbl_all */5]); return ty$1; } - break; case 8 : var row = match[2]; var p2 = match[1]; @@ -56079,7 +55931,6 @@ function build_as_type(env, _p) { unify_pat(env, (newrecord[/* pat_type */3] = ty2, newrecord), ty1); return ty1; } - break; default: return p[/* pat_type */3]; } @@ -56402,7 +56253,6 @@ function lookup_from_type(env, tpath, lid) { throw exn; } } - break; case 1 : case 2 : throw Caml_builtin_exceptions.not_found; @@ -56963,7 +56813,6 @@ function lookup_from_type$1(env, tpath, lid) { throw exn; } } - break; case 1 : case 2 : throw Caml_builtin_exceptions.not_found; @@ -57306,7 +57155,6 @@ function type_pat(constrs, labels, no_existentials, mode, env, sp, expected_ty) /* Invalid_interval */5 ]; } - break; case 4 : var spl = match[0]; if (List.length(spl) < 2) { @@ -57487,6 +57335,7 @@ function type_pat(constrs, labels, no_existentials, mode, env, sp, expected_ty) /* pat_env */env[0], /* pat_attributes */sp[/* ppat_attributes */2] ]); + break; case 6 : var sarg$1 = match[1]; var l = match[0]; @@ -58163,7 +58012,6 @@ function final_subexpression(_sexp) { } else { return sexp; } - break; case 7 : _sexp = match[0]; continue ; @@ -58192,7 +58040,6 @@ function is_nonexpansive(_exp) { } else { return /* false */0; } - break; case 0 : case 1 : case 3 : @@ -58259,7 +58106,6 @@ function is_nonexpansive(_exp) { } else { return /* false */0; } - break; case 11 : case 25 : _exp = match[0]; @@ -58277,7 +58123,6 @@ function is_nonexpansive(_exp) { var match$1 = match[3]; count[0] = count[0] + 1 | 0; return match$1.tag ? is_nonexpansive(match$1[1]) : /* true */1; - break; case 4 : return is_nonexpansive(match[0]); default: @@ -58329,7 +58174,6 @@ function is_nonexpansive_mod(_mexp) { } else { return /* false */0; } - break; case 6 : return is_nonexpansive_mod(match[0][/* mb_expr */2]); case 7 : @@ -58412,7 +58256,6 @@ function approx_type(env, _sty) { throw exn; } } - break; case 8 : _sty = match[1]; continue ; @@ -58446,7 +58289,6 @@ function type_approx(env, _sexp) { } else { return newvar(/* None */0, /* () */0); } - break; case 4 : var e = match[3]; var p = match[0]; @@ -58471,7 +58313,6 @@ function type_approx(env, _sexp) { ]); return newty2(current_level[0], desc$2); } - break; case 6 : var match$2 = match[1]; if (match$2) { @@ -58481,7 +58322,6 @@ function type_approx(env, _sexp) { } else { return newvar(/* None */0, /* () */0); } - break; case 7 : _sexp = match[0]; continue ; @@ -59119,7 +58959,6 @@ function type_expect_(in_function, env, sexp, ty_expected) { /* exp_attributes */sexp[/* pexp_attributes */2] ]); } - break; case 2 : var rec_flag = match[0]; var exit = 0; @@ -59259,7 +59098,6 @@ function type_expect_(in_function, env, sexp, ty_expected) { /* [] */0 ]); } - break; case 5 : var sargs = match[1]; if (sargs === /* [] */0) { @@ -59679,7 +59517,6 @@ function type_expect_(in_function, env, sexp, ty_expected) { throw exn$1; } } - break; case 11 : var opt_sexp = match[1]; var lid_sexp_list = match[0]; @@ -59985,7 +59822,6 @@ function type_expect_(in_function, env, sexp, ty_expected) { /* exp_attributes */sexp[/* pexp_attributes */2] ]); } - break; case 16 : var exp1 = type_statement(env, match[0]); var exp2 = type_expect(/* None */0, env, match[1], ty_expected); @@ -60272,6 +60108,7 @@ function type_expect_(in_function, env, sexp, ty_expected) { /* exp_env */env, /* exp_attributes */arg$5[/* exp_attributes */5] ]); + break; case 21 : var met = match[1]; var e = match[0]; @@ -60524,7 +60361,6 @@ function type_expect_(in_function, env, sexp, ty_expected) { /* Virtual_class */Block.__(18, [cl[/* txt */0]]) ]; } - break; case 23 : var lab = match[0]; try { @@ -60683,7 +60519,6 @@ function type_expect_(in_function, env, sexp, ty_expected) { ] ]; } - break; case 25 : var name$2 = match[0]; var ty$7 = newvar(/* None */0, /* () */0); @@ -62092,7 +61927,6 @@ function type_argument(env, sarg, ty_expected$prime, ty_expected) { } else { return /* false */0; } - break; case 16 : _sexp = match[1]; continue ; @@ -65819,7 +65653,6 @@ function compute_variance(env, visited, vari, ty) { } } } - break; case 5 : compute_variance_rec(vari$1, match[2]); _ty = match[3]; @@ -68250,7 +68083,6 @@ function report_error$5(ppf, param) { return l[/* ld_id */0][/* name */1] + ": "; })); } - break; case 10 : return Curry._3(Format.fprintf(ppf, /* Format */[ /* Formatting_gen */Block.__(18, [ @@ -68971,7 +68803,6 @@ function closed_class$1(cty) { } else { return /* false */0; } - break; } }; @@ -69237,6 +69068,7 @@ function inheritance(self_type, env, ovf, concr_meths, warn_vals, loc, parent) { concr_meths$1, warn_vals$1 ]; + break; case 0 : case 2 : throw [ @@ -70036,7 +69868,6 @@ function class_structure(cl_num, $$final, val_env, met_env, loc, param) { local_vals ]; } - break; case 2 : var match$11 = match[0]; var match$12 = match$11[2]; @@ -70214,7 +70045,6 @@ function class_structure(cl_num, $$final, val_env, met_env, loc, param) { local_vals ]; } - break; case 3 : var match$18 = match[0]; var match$19 = type_constraint(val_env, match$18[0], match$18[1], loc); @@ -70688,7 +70518,6 @@ function class_expr(cl_num, val_env, met_env, _scl) { /* cl_attributes */scl[/* pcl_attributes */2] ]); } - break; case 3 : var sargs = match[1]; if (sargs === /* [] */0) { @@ -70726,7 +70555,6 @@ function class_expr(cl_num, val_env, met_env, _scl) { continue ; } - break; } }; @@ -71896,7 +71724,6 @@ function unify_parents_struct(env, ty, st) { ]; } } - break; case 1 : return unify_parents_struct(env$1, ty$1, match$1[0]); case 2 : @@ -72975,7 +72802,6 @@ register_error_of_exn((function (param) { "@[The %s `%s'@ has no previous definition@]" ]), param[0], name); } - break; case 24 : return Curry._2(Format.fprintf(ppf$1, /* Format */[ /* Formatting_gen */Block.__(18, [ @@ -74838,7 +74664,6 @@ function simplify_signature(sg) { add$14(name$1, ext_names) ]; } - break; default: var match$1 = aux(param[1]); return /* tuple */[ @@ -74879,7 +74704,6 @@ function path_of_module(_mexp) { } else { throw Not_a_path; } - break; case 4 : _mexp = match[0]; continue ; @@ -75094,7 +74918,6 @@ function package_constraints(env, loc, mty, constrs) { return item; } } - break; case 3 : var md = item[1]; var id$1 = item[0]; @@ -75313,6 +75136,7 @@ function type_module$1($staropt$star, sttn, funct_body, anchor, env, smod) { } return rm(tmp); + break; case 1 : var match$1 = type_structure(/* None */0, funct_body, anchor, env, match[0], smod[/* pmod_loc */1]); var sg = match$1[1]; @@ -75456,7 +75280,6 @@ function type_module$1($staropt$star, sttn, funct_body, anchor, env, smod) { /* Cannot_apply */Block.__(0, [funct[/* mod_type */2]]) ]; } - break; case 4 : var arg$1 = type_module$1(/* Some */[alias], /* true */1, funct_body, anchor, env, match[0]); var mty$4 = transl_modtype$1(env, match[1]); @@ -75539,6 +75362,7 @@ function type_module$1($staropt$star, sttn, funct_body, anchor, env, smod) { /* mod_env */env, /* mod_attributes */smod[/* pmod_attributes */2] ]); + break; case 6 : throw [ Error_forward$3, @@ -76309,7 +76133,6 @@ function type_implementation_more(sourcefile, outputprefix, modulename, initial_ /* Non_generalizable_module */Block.__(9, [md[/* mod_type */2]]) ]; } - break; default: return /* () */0; } diff --git a/jscomp/test/qcc.js b/jscomp/test/qcc.js index 65694f8244b..c63acacbd8c 100644 --- a/jscomp/test/qcc.js +++ b/jscomp/test/qcc.js @@ -949,7 +949,6 @@ function unary(stk) { return 0; } } - break; case 1 : return load(0, match[0]); case 2 : @@ -1445,7 +1444,6 @@ function top(_param) { "[var] or ) expected" ]; } - break; case 1 : case 2 : throw [ diff --git a/jscomp/test/stream_parser_test.js b/jscomp/test/stream_parser_test.js index 7e8c0973da1..634882ca352 100644 --- a/jscomp/test/stream_parser_test.js +++ b/jscomp/test/stream_parser_test.js @@ -55,7 +55,6 @@ function parse(token) { "unexpected token" ]; } - break; case 2 : return e[0]; default: @@ -182,7 +181,6 @@ function l_parse(token) { "Unexpected token" ]; } - break; case 2 : return t[0]; default: diff --git a/jscomp/test/ticker.js b/jscomp/test/ticker.js index f3b41eca675..5061e94253e 100644 --- a/jscomp/test/ticker.js +++ b/jscomp/test/ticker.js @@ -941,7 +941,6 @@ function process_input_line(ticker_map, all_tickers, line) { "Invalid input line" ]; } - break; case "R" : var match$2 = tokens[1]; if (match$2) { @@ -980,7 +979,6 @@ function process_input_line(ticker_map, all_tickers, line) { "Invalid input line" ]; } - break; case "-" : var match$6 = match$3[1]; if (match$6) { @@ -1012,7 +1010,6 @@ function process_input_line(ticker_map, all_tickers, line) { "Invalid input line" ]; } - break; case "S" : if (match$3[1]) { throw [ @@ -1033,7 +1030,6 @@ function process_input_line(ticker_map, all_tickers, line) { ticker_map ]; } - break; default: throw [ Caml_builtin_exceptions.failure, @@ -1052,7 +1048,6 @@ function process_input_line(ticker_map, all_tickers, line) { "Invalid input line" ]; } - break; default: throw [ Caml_builtin_exceptions.failure, diff --git a/lib/js/arg.js b/lib/js/arg.js index da9aa5c5460..e20f3d3a7ab 100644 --- a/lib/js/arg.js +++ b/lib/js/arg.js @@ -355,7 +355,6 @@ function parse_argv_dynamic($staropt$star, argv, speclist, anonfun, errmsg) { /* Missing */Block.__(2, [s]) ]; } - break; case 2 : param[0][0] = /* true */1; return /* () */0; @@ -373,7 +372,6 @@ function parse_argv_dynamic($staropt$star, argv, speclist, anonfun, errmsg) { /* Missing */Block.__(2, [s]) ]; } - break; case 5 : if ((current$1[0] + 1 | 0) < l) { param[0][0] = Caml_array.caml_array_get(argv, current$1[0] + 1 | 0); @@ -385,7 +383,6 @@ function parse_argv_dynamic($staropt$star, argv, speclist, anonfun, errmsg) { /* Missing */Block.__(2, [s]) ]; } - break; case 6 : if ((current$1[0] + 1 | 0) < l) { var arg$1 = Caml_array.caml_array_get(argv, current$1[0] + 1 | 0); @@ -419,7 +416,6 @@ function parse_argv_dynamic($staropt$star, argv, speclist, anonfun, errmsg) { /* Missing */Block.__(2, [s]) ]; } - break; case 7 : if ((current$1[0] + 1 | 0) < l) { var arg$2 = Caml_array.caml_array_get(argv, current$1[0] + 1 | 0); @@ -453,7 +449,6 @@ function parse_argv_dynamic($staropt$star, argv, speclist, anonfun, errmsg) { /* Missing */Block.__(2, [s]) ]; } - break; case 8 : if ((current$1[0] + 1 | 0) < l) { var arg$3 = Caml_array.caml_array_get(argv, current$1[0] + 1 | 0); @@ -487,7 +482,6 @@ function parse_argv_dynamic($staropt$star, argv, speclist, anonfun, errmsg) { /* Missing */Block.__(2, [s]) ]; } - break; case 9 : if ((current$1[0] + 1 | 0) < l) { var arg$4 = Caml_array.caml_array_get(argv, current$1[0] + 1 | 0); @@ -521,7 +515,6 @@ function parse_argv_dynamic($staropt$star, argv, speclist, anonfun, errmsg) { /* Missing */Block.__(2, [s]) ]; } - break; case 10 : return List.iter(treat_action, param[0]); case 11 : @@ -548,7 +541,6 @@ function parse_argv_dynamic($staropt$star, argv, speclist, anonfun, errmsg) { /* Missing */Block.__(2, [s]) ]; } - break; case 12 : var f = param[0]; while(current$1[0] < (l - 1 | 0)) { diff --git a/lib/js/camlinternalFormat.js b/lib/js/camlinternalFormat.js index 18547cfb2c9..09b218ad7b9 100644 --- a/lib/js/camlinternalFormat.js +++ b/lib/js/camlinternalFormat.js @@ -1587,7 +1587,6 @@ function trans(ty1, ty2) { ] ]; } - break; case 11 : if (typeof ty2 === "number") { throw [ @@ -2017,7 +2016,6 @@ function type_format_gen(fmt, fmtty) { match[1] ]; } - break; case 1 : if (typeof fmtty === "number") { throw Type_mismatch; @@ -2030,7 +2028,6 @@ function type_format_gen(fmt, fmtty) { match$1[1] ]; } - break; case 2 : var match$2 = type_padding(fmt[0], fmtty); var match$3 = match$2[1]; @@ -2048,7 +2045,6 @@ function type_format_gen(fmt, fmtty) { } else { throw Type_mismatch; } - break; case 3 : var match$5 = type_padding(fmt[0], fmtty); var match$6 = match$5[1]; @@ -2066,7 +2062,6 @@ function type_format_gen(fmt, fmtty) { } else { throw Type_mismatch; } - break; case 4 : var match$8 = type_padprec(fmt[1], fmt[2], fmtty); var match$9 = match$8[2]; @@ -2086,7 +2081,6 @@ function type_format_gen(fmt, fmtty) { } else { throw Type_mismatch; } - break; case 5 : var match$11 = type_padprec(fmt[1], fmt[2], fmtty); var match$12 = match$11[2]; @@ -2106,7 +2100,6 @@ function type_format_gen(fmt, fmtty) { } else { throw Type_mismatch; } - break; case 6 : var match$14 = type_padprec(fmt[1], fmt[2], fmtty); var match$15 = match$14[2]; @@ -2126,7 +2119,6 @@ function type_format_gen(fmt, fmtty) { } else { throw Type_mismatch; } - break; case 7 : var match$17 = type_padprec(fmt[1], fmt[2], fmtty); var match$18 = match$17[2]; @@ -2146,7 +2138,6 @@ function type_format_gen(fmt, fmtty) { } else { throw Type_mismatch; } - break; case 8 : var match$20 = type_padprec(fmt[1], fmt[2], fmtty); var match$21 = match$20[2]; @@ -2166,7 +2157,6 @@ function type_format_gen(fmt, fmtty) { } else { throw Type_mismatch; } - break; case 9 : if (typeof fmtty === "number") { throw Type_mismatch; @@ -2179,7 +2169,6 @@ function type_format_gen(fmt, fmtty) { } else { throw Type_mismatch; } - break; case 10 : var match$24 = type_format_gen(fmt[0], fmtty); return /* Fmt_fmtty_EBB */[ @@ -2224,7 +2213,6 @@ function type_format_gen(fmt, fmtty) { } else { throw Type_mismatch; } - break; case 14 : if (typeof fmtty === "number") { throw Type_mismatch; @@ -2245,7 +2233,6 @@ function type_format_gen(fmt, fmtty) { } else { throw Type_mismatch; } - break; case 15 : if (typeof fmtty === "number") { throw Type_mismatch; @@ -2258,7 +2245,6 @@ function type_format_gen(fmt, fmtty) { } else { throw Type_mismatch; } - break; case 16 : if (typeof fmtty === "number") { throw Type_mismatch; @@ -2271,7 +2257,6 @@ function type_format_gen(fmt, fmtty) { } else { throw Type_mismatch; } - break; case 17 : var match$31 = type_format_gen(fmt[1], fmtty); return /* Fmt_fmtty_EBB */[ @@ -2326,7 +2311,6 @@ function type_format_gen(fmt, fmtty) { } else { throw Type_mismatch; } - break; case 20 : if (typeof fmtty === "number") { throw Type_mismatch; @@ -2343,7 +2327,6 @@ function type_format_gen(fmt, fmtty) { } else { throw Type_mismatch; } - break; case 21 : if (typeof fmtty === "number") { throw Type_mismatch; @@ -2359,7 +2342,6 @@ function type_format_gen(fmt, fmtty) { } else { throw Type_mismatch; } - break; case 23 : var ign = fmt[0]; var fmt$1 = fmt[1]; @@ -2435,7 +2417,6 @@ function type_ignored_format_substitution(sub_fmtty, fmt, fmtty) { match[1] ]; } - break; case 1 : if (typeof fmtty === "number") { throw Type_mismatch; @@ -2448,7 +2429,6 @@ function type_ignored_format_substitution(sub_fmtty, fmt, fmtty) { } else { throw Type_mismatch; } - break; case 2 : if (typeof fmtty === "number") { throw Type_mismatch; @@ -2461,7 +2441,6 @@ function type_ignored_format_substitution(sub_fmtty, fmt, fmtty) { } else { throw Type_mismatch; } - break; case 3 : if (typeof fmtty === "number") { throw Type_mismatch; @@ -2474,7 +2453,6 @@ function type_ignored_format_substitution(sub_fmtty, fmt, fmtty) { } else { throw Type_mismatch; } - break; case 4 : if (typeof fmtty === "number") { throw Type_mismatch; @@ -2487,7 +2465,6 @@ function type_ignored_format_substitution(sub_fmtty, fmt, fmtty) { } else { throw Type_mismatch; } - break; case 5 : if (typeof fmtty === "number") { throw Type_mismatch; @@ -2500,7 +2477,6 @@ function type_ignored_format_substitution(sub_fmtty, fmt, fmtty) { } else { throw Type_mismatch; } - break; case 6 : if (typeof fmtty === "number") { throw Type_mismatch; @@ -2513,7 +2489,6 @@ function type_ignored_format_substitution(sub_fmtty, fmt, fmtty) { } else { throw Type_mismatch; } - break; case 7 : if (typeof fmtty === "number") { throw Type_mismatch; @@ -2526,7 +2501,6 @@ function type_ignored_format_substitution(sub_fmtty, fmt, fmtty) { } else { throw Type_mismatch; } - break; case 8 : if (typeof fmtty === "number") { throw Type_mismatch; @@ -2546,7 +2520,6 @@ function type_ignored_format_substitution(sub_fmtty, fmt, fmtty) { } else { throw Type_mismatch; } - break; case 9 : if (typeof fmtty === "number") { throw Type_mismatch; @@ -2575,7 +2548,6 @@ function type_ignored_format_substitution(sub_fmtty, fmt, fmtty) { } else { throw Type_mismatch; } - break; case 10 : if (typeof fmtty === "number") { throw Type_mismatch; @@ -2588,7 +2560,6 @@ function type_ignored_format_substitution(sub_fmtty, fmt, fmtty) { } else { throw Type_mismatch; } - break; case 11 : if (typeof fmtty === "number") { throw Type_mismatch; @@ -2601,7 +2572,6 @@ function type_ignored_format_substitution(sub_fmtty, fmt, fmtty) { } else { throw Type_mismatch; } - break; case 12 : throw Type_mismatch; case 13 : @@ -2616,7 +2586,6 @@ function type_ignored_format_substitution(sub_fmtty, fmt, fmtty) { } else { throw Type_mismatch; } - break; case 14 : if (typeof fmtty === "number") { throw Type_mismatch; @@ -2629,7 +2598,6 @@ function type_ignored_format_substitution(sub_fmtty, fmt, fmtty) { } else { throw Type_mismatch; } - break; } } @@ -2747,7 +2715,6 @@ function fix_int_precision(prec, str) { } else { return str; } - break; case 2 : if (prec$1 > len) { var res$2 = Bytes.make(prec$1, /* "0" */48); @@ -2756,7 +2723,6 @@ function fix_int_precision(prec, str) { } else { return str; } - break; } } @@ -3306,7 +3272,6 @@ function make_printf(_k, o, _acc, _fmt) { continue ; } - break; case 19 : throw [ Caml_builtin_exceptions.assert_failure, @@ -3652,7 +3617,6 @@ function output_acc(o, _acc) { continue ; } - break; case 2 : case 4 : exit = 1; @@ -3715,7 +3679,6 @@ function bufput_acc(b, _acc) { continue ; } - break; case 2 : case 4 : exit = 1; @@ -3778,7 +3741,6 @@ function strput_acc(b, _acc) { continue ; } - break; case 2 : case 4 : exit = 1; @@ -4615,7 +4577,6 @@ function fmt_ebb_of_string(legacy_behavior, str) { match$4[0] ])]; } - break; case 12 : var beg_ind$4 = str_ind + 1 | 0; var match$5 = parse_literal(beg_ind$4, beg_ind$4, end_ind); diff --git a/lib/js/format.js b/lib/js/format.js index 0233ec9062b..23609fad6d8 100644 --- a/lib/js/format.js +++ b/lib/js/format.js @@ -139,7 +139,6 @@ function format_pp_token(state, size, param) { } else { return /* () */0; } - break; case 1 : var match$1 = state[/* pp_format_stack */1]; if (match$1) { @@ -184,7 +183,6 @@ function format_pp_token(state, size, param) { } else { return /* () */0; } - break; } } else { @@ -225,7 +223,6 @@ function format_pp_token(state, size, param) { } else { return /* () */0; } - break; case 2 : var insertion_point = state[/* pp_margin */5] - state[/* pp_space_left */8] | 0; var match$8 = state[/* pp_tbox_stack */2]; @@ -273,7 +270,6 @@ function format_pp_token(state, size, param) { } else { return /* () */0; } - break; case 3 : var ty = param[1]; var insertion_point$1 = state[/* pp_margin */5] - state[/* pp_space_left */8] | 0; @@ -1347,7 +1343,6 @@ function output_acc(ppf, acc) { } else { return pp_open_tag(ppf, compute_tag(output_acc, match[0])); } - break; case 2 : var p$3 = acc[0]; var exit$1 = 0; @@ -1483,7 +1478,6 @@ function strput_acc(ppf, acc) { } else { return pp_open_tag(ppf, compute_tag(strput_acc, match[0])); } - break; case 2 : var p$3 = acc[0]; var exit$1 = 0; diff --git a/lib/js/genlex.js b/lib/js/genlex.js index 795361676aa..282af5e13f4 100644 --- a/lib/js/genlex.js +++ b/lib/js/genlex.js @@ -131,7 +131,6 @@ function make_lexer(keywords) { "" ]; } - break; case 40 : Stream.junk(strm__); var strm__$1 = strm__; diff --git a/lib/js/scanf.js b/lib/js/scanf.js index 4851b3efa50..7eaa2888243 100644 --- a/lib/js/scanf.js +++ b/lib/js/scanf.js @@ -1482,7 +1482,6 @@ function make_scanf(ib, _fmt, readers) { }; return pad_prec_scanf(ib, CamlinternalFormatBasics.concat_fmt(match$1[0][0], rest[1]), readers, pad, /* No_precision */0, scan$2, token); } - break; default: exit = 1; } @@ -1571,7 +1570,6 @@ function make_scanf(ib, _fmt, readers) { "end of input not found" ]; } - break; case 11 : var f = function (param) { return check_char(ib, param); @@ -1668,7 +1666,6 @@ function make_scanf(ib, _fmt, readers) { continue ; } - break; case 19 : var x = Curry._1(readers[0], ib); return /* Cons */[ @@ -1735,7 +1732,6 @@ function make_scanf(ib, _fmt, readers) { ] ]; } - break; case 24 : throw [ Caml_builtin_exceptions.invalid_argument, diff --git a/lib/js/stream.js b/lib/js/stream.js index 3e7118f3fc3..42108b2b936 100644 --- a/lib/js/stream.js +++ b/lib/js/stream.js @@ -54,7 +54,6 @@ function get_data(count, _d) { ]) ]); } - break; case 2 : var f = d[0]; var tag = f.tag | 0; @@ -88,7 +87,6 @@ function get_data(count, _d) { return /* Sempty */0; } } - break; case 4 : var b = d[0]; if (b[/* ind */3] >= b[/* len */2]) { @@ -104,7 +102,6 @@ function get_data(count, _d) { d ]); } - break; } } @@ -137,7 +134,6 @@ function peek(s) { s[1] = d; return /* Some */[d[0]]; } - break; case 2 : var f = match[0]; var tag = f.tag | 0; @@ -155,7 +151,6 @@ function peek(s) { g[/* curr */0] = /* Some */[x]; return x; } - break; case 4 : var b = match[0]; if (b[/* ind */3] >= b[/* len */2]) { diff --git a/lib/whole_compiler.ml b/lib/whole_compiler.ml index 90b7cc72248..100aa9bfdb7 100644 --- a/lib/whole_compiler.ml +++ b/lib/whole_compiler.ml @@ -87965,6 +87965,10 @@ val output_of_block_and_expression : J.expression -> t +val concat : + t list -> + t + val to_string : t -> string @@ -97856,21 +97860,23 @@ and compile_general_cases (fun group -> Ext_list.map_last (fun last (switch_case,lam) -> - (* let switch_block, should_break = - Js_output.to_break_block (compile_lambda cxt lam) in - let should_break = - match cxt.should_return with - | ReturnFalse -> should_break - | ReturnTrue _ -> false - in *) + if last then (* merge and shared *) - let switch_body = Js_output.to_break_block (compile_lambda cxt lam) in + let switch_block, should_break = + Js_output.to_break_block (compile_lambda cxt lam) in + let should_break = + match cxt.should_return with + | ReturnFalse -> should_break + | ReturnTrue _ -> + Lam_exit_code.has_exit_code (fun _ -> true ) lam + in + (* let switch_body = Js_output.to_break_block (compile_lambda cxt lam) in *) {J.switch_case ; - switch_body - } + switch_body = switch_block, should_break + } else { switch_case; switch_body = [],false } )