fix #1701

Changes.md

@@ -11,6 +11,7 @@ Fixes:
 - #1654, `bsb -init` fails if package or current dir has space (parent dir can have spaces)
 - #1678, bs.get{null;undefined} in object type
 - #1692, fix invalid js syntax output
+- #1701, fix tailcall handling interaction with exception handler
 Features:
 - #1648, exposed `bsc` in the npm environment
 - #1647, speical handling `bsb -init .` to reuse current directory

jscomp/core/js_output.ml

@@ -62,17 +62,17 @@ let handle_name_tail
  (should_return : Lam_compile_defs.return_type)
  lam (exp : J.expression) : t =
  begin match name, should_return with 
- | EffectCall, False -> 
+ | EffectCall, ReturnFalse -> 
  if Lam_analysis.no_side_effects lam 
  then dummy
  else {block = []; value = Some exp ; finished = False}
- | EffectCall, True _ ->
+ | EffectCall, ReturnTrue _ ->
  make [S.return exp] ~finished:True
- | Declare (kind, n), False -> 
+ | Declare (kind, n), ReturnFalse -> 
  make [ S.define ~kind n exp]
- | Assign n ,False -> 
+ | Assign n ,ReturnFalse -> 
  make [S.assign n exp ]
- | (Declare _ | Assign _ ), True _ -> 
+ | (Declare _ | Assign _ ), ReturnTrue _ -> 
  make [S.unknown_lambda lam] ~finished:True
  | NeedValue, _ -> {block = []; value = Some exp; finished = False }
  end
@@ -82,12 +82,12 @@ let handle_block_return
  (should_return : Lam_compile_defs.return_type)
  (lam : Lam.t) (block : J.block) exp : t = 
  match st, should_return with 
- | Declare (kind,n), False -> 
+ | Declare (kind,n), ReturnFalse -> 
  make (block @ [ S.define ~kind n exp])
- | Assign n, False -> make (block @ [S.assign n exp])
- | (Declare _ | Assign _), True _ -> make [S.unknown_lambda lam] ~finished:True
- | EffectCall, False -> make block ~value:exp
- | EffectCall, True _ -> make (block @ [S.return exp]) ~finished:True
+ | Assign n, ReturnFalse -> make (block @ [S.assign n exp])
+ | (Declare _ | Assign _), ReturnTrue _ -> make [S.unknown_lambda lam] ~finished:True
+ | EffectCall, ReturnFalse -> make block ~value:exp
+ | EffectCall, ReturnTrue _ -> make (block @ [S.return exp]) ~finished:True
  | NeedValue, _ -> make block ~value:exp
 
 let statement_of_opt_expr (x : J.expression option) : J.statement =

jscomp/core/lam_compile_defs.ml

@@ -55,8 +55,14 @@ type return_label = {
 }
 
 type return_type = 
- | False 
- | True of return_label option 
+ | ReturnFalse 
+ | ReturnTrue of return_label option 
+ (* Note [return] does indicate it is a tail position in most cases
+ however, in an exception handler, return may not be in tail position
+ to fix #1701 we play a trick that (ReturnTrue None) 
+ would never trigger tailcall, however, it preserves [return] 
+ semantics
+ *)
  (* have a mutable field to notifiy it's actually triggered *)
  (* anonoymous function does not have identifier *)
 

jscomp/core/lam_compile_defs.mli

@@ -67,8 +67,8 @@ type return_label = {
 }
 
 type return_type = 
- | False 
- | True of return_label option (* anonoymous function does not have identifier *)
+ | ReturnFalse 
+ | ReturnTrue of return_label option (* anonoymous function does not have identifier *)
 
 (* delegate to the callee to generate expression 
  Invariant: [output] should return a trailing expression

jscomp/core/lam_compile_group.ml

@@ -151,22 +151,22 @@ let compile_group ({filename = file_name; env;} as meta : Lam_stats.meta)
  (* can not apply again, it's wrong USE it with care*)
  (* ([Js_stmt_make.comment (Gen_of_env.query_type id env )], None) ++ *)
  Lam_compile.compile_let kind { st = Declare (kind, id);
- should_return = False;
+ should_return = ReturnFalse;
  jmp_table = Lam_compile_defs.empty_handler_map;
  meta
  } id lam
 
  | Recursive id_lams, _ -> 
  Lam_compile.compile_recursive_lets 
  { st = EffectCall ;
- should_return = False; 
+ should_return = ReturnFalse; 
  jmp_table = Lam_compile_defs.empty_handler_map;
  meta
  } 
  id_lams
  | Nop lam, _ -> (* TODO: Side effect callls, log and see statistics *)
  Lam_compile.compile_lambda {st = EffectCall;
- should_return = False;
+ should_return = ReturnFalse;
  jmp_table = Lam_compile_defs.empty_handler_map;
  meta
  } lam

jscomp/core/lam_compile_primitive.ml

@@ -36,9 +36,9 @@ module E = Js_exp_make
 *)
 let decorate_side_effect ({st; should_return;_} : Lam_compile_defs.cxt) e : E.t = 
  match st, should_return with 
- | _, True _ 
+ | _, ReturnTrue _ 
  | (Assign _ | Declare _ | NeedValue), _ -> E.seq e E.unit
- | EffectCall, False -> e 
+ | EffectCall, ReturnFalse -> e 
 (* NeedValue should return a meaningful expression*)
 
 let translate loc

jscomp/test/.depend

@@ -227,6 +227,7 @@ gpr_1600_test.cmj : ../runtime/js.cmj ../stdlib/array.cmj
 gpr_1658_test.cmj : mt.cmj ../runtime/js.cmj
 gpr_1667_test.cmj : mt.cmj
 gpr_1692_test.cmj :
+gpr_1701_test.cmj : ../stdlib/list.cmj
 gpr_405_test.cmj : ../stdlib/hashtbl.cmj gpr_405_test.cmi
 gpr_441.cmj :
 gpr_459_test.cmj : mt.cmj

jscomp/test/Makefile

@@ -160,7 +160,8 @@ OTHERS := literals a test_ari test_export2 test_internalOO test_obj_simple_ffi t
 js_option_test\
 gpr_1658_test\
 gpr_1667_test\
-gpr_1692_test
+gpr_1692_test\
+gpr_1701_test
 
 # bs_uncurry_test
 # needs Lam to get rid of Uncurry arity first

jscomp/test/gpr_1701_test.js

@@ -0,0 +1,111 @@
+'use strict';
+
+var List = require("../../lib/js/list.js");
+var Pervasives = require("../../lib/js/pervasives.js");
+var Caml_exceptions = require("../../lib/js/caml_exceptions.js");
+var Caml_builtin_exceptions = require("../../lib/js/caml_builtin_exceptions.js");
+
+var Foo = Caml_exceptions.create("Gpr_1701_test.Foo");
+
+function test(n) {
+ if (n) {
+ try {
+ return test(n - 1 | 0);
+ }
+ catch (exn){
+ if (exn === Foo) {
+ return /* () */0;
+ } else {
+ throw exn;
+ }
+ }
+ } else {
+ throw Foo;
+ }
+}
+
+test(100);
+
+function read_lines(inc) {
+ var _acc = /* [] */0;
+ while(true) {
+ var acc = _acc;
+ var match;
+ try {
+ match = /* Some */[Pervasives.input_line(inc)];
+ }
+ catch (exn){
+ if (exn === Caml_builtin_exceptions.end_of_file) {
+ match = /* None */0;
+ } else {
+ throw exn;
+ }
+ }
+ if (match) {
+ _acc = /* :: */[
+ match[0],
+ acc
+ ];
+ continue ;
+
+ } else {
+ return List.rev(acc);
+ }
+ };
+}
+
+function read_lines2(inc) {
+ var _acc = /* [] */0;
+ while(true) {
+ var acc = _acc;
+ var exit = 0;
+ var l;
+ try {
+ l = Pervasives.input_line(inc);
+ exit = 1;
+ }
+ catch (exn){
+ if (exn === Caml_builtin_exceptions.end_of_file) {
+ return List.rev(acc);
+ } else {
+ throw exn;
+ }
+ }
+ if (exit === 1) {
+ _acc = /* :: */[
+ l,
+ acc
+ ];
+ continue ;
+
+ }
+
+ };
+}
+
+function read_lines3(inc) {
+ var loop = function (acc) {
+ try {
+ var l = Pervasives.input_line(inc);
+ return loop(/* :: */[
+ l,
+ acc
+ ]);
+ }
+ catch (exn){
+ if (exn === Caml_builtin_exceptions.end_of_file) {
+ return List.rev(acc);
+ } else {
+ throw exn;
+ }
+ }
+ };
+ return loop(/* [] */0);
+}
+
+exports.Foo = Foo;
+exports.test = test;
+exports.read_lines = read_lines;
+exports.read_lines2 = read_lines2;
+exports.read_lines3 = read_lines3;
+/* Not a pure module */

jscomp/test/gpr_1701_test.ml

@@ -0,0 +1,42 @@
+
+
+exception Foo 
+
+let rec test n =
+ if n = 0 then raise Foo
+ else 
+ try 
+ test (n - 1)
+ with Foo ->()
+
+
+let () = test 100 
+
+
+
+let read_lines inc =
+ let rec loop acc =
+ match (try Some (input_line inc)
+ with End_of_file -> None)
+ with
+ | Some l -> loop (l :: acc)
+ | None -> List.rev acc
+ in
+ loop [] 
+
+let read_lines2 inc =
+ let rec loop acc =
+ match input_line inc with
+ | l -> loop (l :: acc)
+ | exception End_of_file -> List.rev acc
+ in
+ loop [] 
+
+let read_lines3 inc =
+ let rec loop acc =
+ try
+ let l = input_line inc in
+ loop (l :: acc)
+ with End_of_file -> List.rev acc
+ in
+ loop [] 

jscomp/test/ocaml_parsetree_test.js

@@ -11852,20 +11852,10 @@ function skip_phrase(lexbuf) {
  while(true) {
  try {
  var match = token$1(lexbuf);
- if (typeof match === "number") {
- if (match !== 25) {
- if (match !== 83) {
- continue ;
-
- } else {
- return /* () */0;
- }
- } else {
- return /* () */0;
- }
+ if (typeof match === "number" && !(match !== 25 && match !== 83)) {
+ return /* () */0;
  } else {
- continue ;
-
+ return skip_phrase(lexbuf);
  }
  }
  catch (raw_exn){

jscomp/test/ocaml_proto_test.js

@@ -192,21 +192,14 @@ function file_option(file_options, name) {
 }
 
 function rev_split_by_char(c, s) {
- var _i = 0;
- var _l = /* [] */0;
- while(true) {
- var l = _l;
- var i = _i;
+ var loop = function (i, l) {
  try {
  var i$prime = $$String.index_from(s, i, c);
  var s$prime = $$String.sub(s, i, i$prime - i | 0);
- _l = s$prime === "" ? l : /* :: */[
- s$prime,
- l
- ];
- _i = i$prime + 1 | 0;
- continue ;
-
+ return loop(i$prime + 1 | 0, s$prime === "" ? l : /* :: */[
+ s$prime,
+ l
+ ]);
  }
  catch (exn){
  if (exn === Caml_builtin_exceptions.not_found) {
@@ -219,6 +212,7 @@ function rev_split_by_char(c, s) {
  }
  }
  };
+ return loop(0, /* [] */0);
 }
 
 function pop_last(param) {