flambda-backend: Merge ocaml-jst

Author: lpw25

.depend

@@ -121,15 +121,12 @@ utils/profile.cmi :
 utils/strongly_connected_components.cmo : \
     utils/numbers.cmi \
     utils/misc.cmi \
-    utils/identifiable.cmi \
     utils/strongly_connected_components.cmi
 utils/strongly_connected_components.cmx : \
     utils/numbers.cmx \
     utils/misc.cmx \
-    utils/identifiable.cmx \
     utils/strongly_connected_components.cmi
-utils/strongly_connected_components.cmi : \
-    utils/identifiable.cmi
+utils/strongly_connected_components.cmi :
 utils/target_system.cmo : \
     utils/misc.cmi \
     utils/config.cmi \
@@ -343,15 +340,13 @@ parsing/lexer.cmo : \
     utils/misc.cmi \
     parsing/location.cmi \
     parsing/docstrings.cmi \
-    utils/clflags.cmi \
     parsing/lexer.cmi
 parsing/lexer.cmx : \
     utils/warnings.cmx \
     parsing/parser.cmx \
     utils/misc.cmx \
     parsing/location.cmx \
     parsing/docstrings.cmx \
-    utils/clflags.cmx \
     parsing/lexer.cmi
 parsing/lexer.cmi : \
     parsing/parser.cmi \
@@ -480,13 +475,15 @@ typing/annot.cmi : \
 typing/btype.cmo : \
     typing/types.cmi \
     typing/path.cmi \
+    utils/misc.cmi \
     utils/local_store.cmi \
     typing/ident.cmi \
     parsing/asttypes.cmi \
     typing/btype.cmi
 typing/btype.cmx : \
     typing/types.cmx \
     typing/path.cmx \
+    utils/misc.cmx \
     utils/local_store.cmx \
     typing/ident.cmx \
     parsing/asttypes.cmi \
@@ -815,11 +812,13 @@ typing/mtype.cmi : \
 typing/oprint.cmo : \
     parsing/pprintast.cmi \
     typing/outcometree.cmi \
+    utils/clflags.cmi \
     parsing/asttypes.cmi \
     typing/oprint.cmi
 typing/oprint.cmx : \
     parsing/pprintast.cmx \
     typing/outcometree.cmi \
+    utils/clflags.cmx \
     parsing/asttypes.cmi \
     typing/oprint.cmi
 typing/oprint.cmi : \
@@ -2106,14 +2105,12 @@ asmcomp/CSEgen.cmi : \
     asmcomp/mach.cmi \
     parsing/asttypes.cmi
 asmcomp/afl_instrument.cmo : \
-    lambda/lambda.cmi \
     asmcomp/cmm.cmi \
     utils/clflags.cmi \
     middle_end/backend_var.cmi \
     parsing/asttypes.cmi \
     asmcomp/afl_instrument.cmi
 asmcomp/afl_instrument.cmx : \
-    lambda/lambda.cmx \
     asmcomp/cmm.cmx \
     utils/clflags.cmx \
     middle_end/backend_var.cmx \
@@ -2921,6 +2918,7 @@ asmcomp/selectgen.cmo : \
     asmcomp/mach.cmi \
     lambda/lambda.cmi \
     lambda/debuginfo.cmi \
+    utils/config.cmi \
     asmcomp/cmm.cmi \
     middle_end/backend_var.cmi \
     parsing/asttypes.cmi \
@@ -2934,6 +2932,7 @@ asmcomp/selectgen.cmx : \
     asmcomp/mach.cmx \
     lambda/lambda.cmx \
     lambda/debuginfo.cmx \
+    utils/config.cmx \
     asmcomp/cmm.cmx \
     middle_end/backend_var.cmx \
     parsing/asttypes.cmi \
@@ -3343,6 +3342,7 @@ lambda/lambda.cmo : \
     typing/ident.cmi \
     typing/env.cmi \
     lambda/debuginfo.cmi \
+    utils/config.cmi \
     utils/clflags.cmi \
     parsing/asttypes.cmi \
     lambda/lambda.cmi
@@ -3355,6 +3355,7 @@ lambda/lambda.cmx : \
     typing/ident.cmx \
     typing/env.cmx \
     lambda/debuginfo.cmx \
+    utils/config.cmx \
     utils/clflags.cmx \
     parsing/asttypes.cmi \
     lambda/lambda.cmi
@@ -5145,6 +5146,7 @@ middle_end/flambda/lift_let_to_initialize_symbol.cmo : \
     middle_end/variable.cmi \
     middle_end/flambda/base_types/tag.cmi \
     middle_end/symbol.cmi \
+    lambda/lambda.cmi \
     middle_end/internal_variable_names.cmi \
     utils/int_replace_polymorphic_compare.cmi \
     middle_end/flambda/flambda_utils.cmi \
@@ -5155,6 +5157,7 @@ middle_end/flambda/lift_let_to_initialize_symbol.cmx : \
     middle_end/variable.cmx \
     middle_end/flambda/base_types/tag.cmx \
     middle_end/symbol.cmx \
+    lambda/lambda.cmx \
     middle_end/internal_variable_names.cmx \
     utils/int_replace_polymorphic_compare.cmx \
     middle_end/flambda/flambda_utils.cmx \
@@ -5251,6 +5254,7 @@ middle_end/flambda/remove_unused_arguments.cmo : \
     middle_end/variable.cmi \
     middle_end/flambda/projection.cmi \
     middle_end/flambda/parameter.cmi \
+    lambda/lambda.cmi \
     middle_end/flambda/invariant_params.cmi \
     utils/int_replace_polymorphic_compare.cmi \
     middle_end/flambda/flambda_utils.cmi \
@@ -5266,6 +5270,7 @@ middle_end/flambda/remove_unused_arguments.cmx : \
     middle_end/variable.cmx \
     middle_end/flambda/projection.cmx \
     middle_end/flambda/parameter.cmx \
+    lambda/lambda.cmx \
     middle_end/flambda/invariant_params.cmx \
     utils/int_replace_polymorphic_compare.cmx \
     middle_end/flambda/flambda_utils.cmx \

asmcomp/selectgen.ml

@@ -1104,7 +1104,8 @@ method emit_tail (env:environment) exp =
      end
   | Cphantom_let (_var, _defining_expr, body) ->
       self#emit_tail env body
-  | Cop((Capply(ty, pos)) as op, args, dbg) ->
+  | Cop((Capply(ty, ((Rc_close_at_apply | Rc_normal) as pos))) as op,
+        args, dbg) ->
       let tail = (pos = Lambda.Rc_close_at_apply) in
       let endregion = env.region_tail in
       begin match self#emit_parts_list env' args with

boot/ocamlc

@@ -512,6 +512,10 @@ let comp_primitive p args =
 
 let is_immed n = immed_min <= n && n <= immed_max
 
+let is_nontail = function
+  | Rc_nontail -> true
+  | Rc_normal | Rc_close_at_apply -> false
+
 module Storer =
   Switch.Store
     (struct type t = lambda type key = lambda
@@ -546,9 +550,9 @@ let rec comp_expr env exp sz cont =
       end
   | Lconst cst ->
       Kconst cst :: cont
-  | Lapply{ap_func = func; ap_args = args} ->
+  | Lapply{ap_func = func; ap_args = args; ap_region_close = rc} ->
       let nargs = List.length args in
-      if is_tailcall cont then begin
+      if is_tailcall cont && not (is_nontail rc) then begin
         comp_args env args sz
           (Kpush :: comp_expr env func (sz + nargs)
             (Kappterm(nargs, sz + nargs) :: discard_dead_code cont))
@@ -564,7 +568,7 @@ let rec comp_expr env exp sz cont =
                       (Kapply nargs :: cont1))
         end
       end
-  | Lsend(kind, met, obj, args, _, _, _) ->
+  | Lsend(kind, met, obj, args, rc, _, _) ->
       let args = if kind = Cached then List.tl args else args in
       let nargs = List.length args + 1 in
       let getmethod, args' =
@@ -573,7 +577,7 @@ let rec comp_expr env exp sz cont =
           Lconst(Const_base(Const_int n)) -> (Kgetpubmet n, obj::args)
         | _ -> (Kgetdynmet, met::obj::args)
       in
-      if is_tailcall cont then
+      if is_tailcall cont && not (is_nontail rc) then
         comp_args env args' sz
           (getmethod :: Kappterm(nargs, sz + nargs) :: discard_dead_code cont)
       else
@@ -978,6 +982,9 @@ let rec comp_expr env exp sz cont =
           let preserve_tailcall =
             match lam with
             | Lprim(prim, _, _) -> preserve_tailcall_for_prim prim
+            | Lapply {ap_region_close=rc; _}
+            | Lsend(_, _, _, _, rc, _, _) ->
+               not (is_nontail rc)
             | _ -> true
           in
           if preserve_tailcall && is_tailcall cont then

boot/ocamllex

@@ -301,7 +301,7 @@ loadprinter.cmx : \
     ../utils/load_path.cmx \
     ../typing/ident.cmx \
     ../typing/env.cmx \
-    ../otherlibs/dynlink/dynlink.cmi \
+    ../otherlibs/dynlink/dynlink.cmx \
     ../typing/ctype.cmx \
     loadprinter.cmi
 loadprinter.cmi : \

bytecomp/bytegen.ml

@@ -99,6 +99,7 @@ type initialization_or_assignment =
 
 type region_close =
   | Rc_normal
+  | Rc_nontail
   | Rc_close_at_apply
 
 type primitive =

debugger/.depend

@@ -65,8 +65,9 @@ type field_read_semantics =
 
 (* Tail calls can close their enclosing region early *)
 type region_close =
-  | Rc_normal
-  | Rc_close_at_apply
+  | Rc_normal         (* do not close region, may TCO if in tail position *)
+  | Rc_nontail        (* do not close region, must not TCO *)
+  | Rc_close_at_apply (* close region and tail call *)
 
 type primitive =
   | Pidentity

lambda/lambda.ml

@@ -581,6 +581,7 @@ let apply_kind name pos mode =
   let name =
     match pos with
     | Rc_normal -> name
+    | Rc_nontail -> name ^ "nontail"
     | Rc_close_at_apply -> name ^ "tail"
   in
   name ^ alloc_kind mode

lambda/lambda.mli

@@ -221,10 +221,11 @@ let simplify_exits lam =
     let ll = List.map simplif ll in
     match p, ll with
         (* Simplify %revapply, for n-ary functions with n > 1 *)
-      | Prevapply Rc_normal, [x; Lapply ap]
-      | Prevapply Rc_normal, [x; Levent (Lapply ap,_)] ->
+      | Prevapply ((Rc_normal | Rc_nontail) as pos), [x; Lapply ap]
+      | Prevapply ((Rc_normal | Rc_nontail) as pos),
+        [x; Levent (Lapply ap,_)] ->
           Lapply {ap with ap_args = ap.ap_args @ [x]; ap_loc = loc;
-                          ap_region_close = Rc_normal}
+                          ap_region_close = pos}
       | Prevapply pos, [x; f] ->
           Lapply {
             ap_loc=loc;
@@ -238,10 +239,11 @@ let simplify_exits lam =
             ap_probe=None;
           }
         (* Simplify %apply, for n-ary functions with n > 1 *)
-      | Pdirapply Rc_normal, [Lapply ap; x]
-      | Pdirapply Rc_normal, [Levent (Lapply ap,_); x] ->
+      | Pdirapply ((Rc_normal | Rc_nontail) as pos), [Lapply ap; x]
+      | Pdirapply ((Rc_normal | Rc_nontail) as pos),
+        [Levent (Lapply ap,_); x] ->
           Lapply {ap with ap_args = ap.ap_args @ [x];
-                          ap_loc = loc; ap_region_close=Rc_normal}
+                          ap_loc = loc; ap_region_close=pos}
       | Pdirapply pos, [f; x] ->
           Lapply {
             ap_loc=loc;
@@ -883,7 +885,7 @@ let simplify_local_functions lam =
     | Lapply {ap_func = Lvar id; ap_args; ap_region_close; _} ->
         let curr_scope =
           match ap_region_close with
-          | Rc_normal -> !current_scope
+          | Rc_normal | Rc_nontail -> !current_scope
           | Rc_close_at_apply -> !current_region_scope
         in
         begin match Hashtbl.find_opt slots id with