Fix tailcalls within regions (#48)

Author: lpw25

asmcomp/afl_instrument.ml

@@ -89,6 +89,7 @@ and instrument = function
      Ccatch (isrec, cases, instrument body)
   | Cexit (ex, args) -> Cexit (ex, List.map instrument args)
   | Cregion e -> Cregion (instrument e)
+  | Ctail e -> Ctail (instrument e)
 
   (* these are base cases and have no logging *)
   | Cconst_int _ | Cconst_natint _ | Cconst_float _

asmcomp/cmm.ml

@@ -149,7 +149,7 @@ type memory_chunk =
   | Double_u
 
 and operation =
-    Capply of machtype
+    Capply of machtype * Lambda.apply_position
   | Cextcall of string * machtype * exttype list * bool
   | Cload of memory_chunk * Asttypes.mutable_flag
   | Calloc of Lambda.alloc_mode
@@ -194,6 +194,7 @@ type expression =
   | Ctrywith of expression * Backend_var.With_provenance.t * expression
       * Debuginfo.t
   | Cregion of expression
+  | Ctail of expression
 
 type codegen_option =
   | Reduce_code_size
@@ -256,6 +257,9 @@ let iter_shallow_tail f = function
   | Cregion e ->
       f e;
       true
+  | Ctail e ->
+      f e;
+      true
   | Cexit _ | Cop (Craise _, _, _) ->
       true
   | Cconst_int _
@@ -294,6 +298,8 @@ let rec map_tail f = function
       Ctrywith(map_tail f e1, id, map_tail f e2, dbg)
   | Cregion e ->
       Cregion(map_tail f e)
+  | Ctail e ->
+      Ctail(map_tail f e)
   | Cexit _ | Cop (Craise _, _, _) as cmm ->
       cmm
   | Cconst_int _
@@ -334,6 +340,8 @@ let iter_shallow f = function
       f e1; f e2
   | Cregion e ->
       f e
+  | Ctail e ->
+      f e
   | Cconst_int _
   | Cconst_natint _
   | Cconst_float _
@@ -369,6 +377,8 @@ let map_shallow f = function
       Ctrywith (f e1, id, f e2, dbg)
   | Cregion e ->
       Cregion (f e)
+  | Ctail e ->
+      Ctail (f e)
   | Cconst_int _
   | Cconst_natint _
   | Cconst_float _

asmcomp/cmm.mli

@@ -139,7 +139,7 @@ type memory_chunk =
   | Double_u                           (* word-aligned 64-bit float *)
 
 and operation =
-    Capply of machtype
+    Capply of machtype * Lambda.apply_position
   | Cextcall of string * machtype * exttype list * bool
       (** The [machtype] is the machine type of the result.
           The [exttype list] describes the unboxing types of the arguments.
@@ -194,6 +194,7 @@ and expression =
   | Ctrywith of expression * Backend_var.With_provenance.t * expression
       * Debuginfo.t
   | Cregion of expression
+  | Ctail of expression
 
 type codegen_option =
   | Reduce_code_size

asmcomp/cmm_helpers.ml

@@ -636,8 +636,8 @@ let rec remove_unit = function
       Ctrywith(remove_unit body, exn, remove_unit handler, dbg)
   | Clet(id, c1, c2) ->
       Clet(id, c1, remove_unit c2)
-  | Cop(Capply _mty, args, dbg) ->
-      Cop(Capply typ_void, args, dbg)
+  | Cop(Capply(_mty, pos), args, dbg) ->
+      Cop(Capply(typ_void, pos), args, dbg)
   | Cop(Cextcall(proc, _ty_res, ty_args, alloc), args, dbg) ->
       Cop(Cextcall(proc, typ_void, ty_args, alloc), args, dbg)
   | Cexit (_,_) as c -> c
@@ -807,11 +807,11 @@ let lookup_label obj lab dbg =
     let table = Cop (Cload (Word_val, Mutable), [obj], dbg) in
     addr_array_ref table lab dbg)
 
-let call_cached_method obj tag cache pos args dbg =
+let call_cached_method obj tag cache pos args apos dbg =
   let arity = List.length args in
   let cache = array_indexing log2_size_addr cache pos dbg in
   Compilenv.need_send_fun arity;
-  Cop(Capply typ_val,
+  Cop(Capply(typ_val, apos),
       Cconst_symbol("caml_send" ^ Int.to_string arity, dbg) ::
         obj :: tag :: cache :: args,
       dbg)
@@ -1713,35 +1713,35 @@ let ptr_offset ptr offset dbg =
   then ptr
   else Cop(Caddv, [ptr; Cconst_int(offset * size_addr, dbg)], dbg)
 
-let direct_apply lbl args dbg =
-  Cop(Capply typ_val, Cconst_symbol (lbl, dbg) :: args, dbg)
+let direct_apply lbl args pos dbg =
+  Cop(Capply(typ_val, pos), Cconst_symbol (lbl, dbg) :: args, dbg)
 
-let generic_apply mut clos args dbg =
+let generic_apply mut clos args pos dbg =
   match args with
   | [arg] ->
       bind "fun" clos (fun clos ->
-        Cop(Capply typ_val, [get_field_gen mut clos 0 dbg; arg; clos],
+        Cop(Capply(typ_val, pos), [get_field_gen mut clos 0 dbg; arg; clos],
           dbg))
   | _ ->
       let arity = List.length args in
       let cargs =
         Cconst_symbol(apply_function_sym arity, dbg) :: args @ [clos]
       in
-      Cop(Capply typ_val, cargs, dbg)
+      Cop(Capply(typ_val, pos), cargs, dbg)
 
-let send kind met obj args dbg =
+let send kind met obj args apos dbg =
   let call_met obj args clos =
     (* met is never a simple expression, so it never gets turned into an
        Immutable load *)
-    generic_apply Asttypes.Mutable clos (obj :: args) dbg
+    generic_apply Asttypes.Mutable clos (obj :: args) apos dbg
   in
   bind "obj" obj (fun obj ->
       match (kind : Lambda.meth_kind), args with
         Self, _ ->
           bind "met" (lookup_label obj met dbg)
             (call_met obj args)
       | Cached, cache :: pos :: args ->
-          call_cached_method obj met cache pos args dbg
+          call_cached_method obj met cache pos args apos dbg
       | _ ->
           bind "met" (lookup_tag obj met dbg)
             (call_met obj args))
@@ -1811,9 +1811,9 @@ let region e =
   (* [Cregion e] is equivalent to [e] if [e] contains no local allocs *)
   let rec check_local_allocs = function
     | Cregion _ ->
-       (* Assume any already-existing Cregion contains a local alloc.
-          This prevents O(n^2) behaviour with many nested regions *)
-       raise Exit
+       (* Local allocations within a nested region do not affect this region.
+          Note this prevents O(n^2) behaviour with many nested regions. *)
+       ()
     | Cop (Calloc Alloc_local, _, _)
     | Cop ((Cextcall _ | Capply _), _, _) ->
        raise Exit
@@ -1847,15 +1847,15 @@ let apply_function_body arity =
   let clos = V.create_local "clos" in
   let rec app_fun clos n =
     if n = arity-1 then
-      Cop(Capply typ_val,
+      Cop(Capply(typ_val, Apply_nontail),
           [get_field_gen Asttypes.Mutable (Cvar clos) 0 (dbg ());
            Cvar arg.(n);
            Cvar clos],
           dbg ())
     else begin
       let newclos = V.create_local "clos" in
       Clet(VP.create newclos,
-           Cop(Capply typ_val,
+           Cop(Capply(typ_val, Apply_nontail),
                [get_field_gen Asttypes.Mutable (Cvar clos) 0 (dbg ());
                 Cvar arg.(n); Cvar clos], dbg ()),
            app_fun newclos (n+1))
@@ -1870,7 +1870,7 @@ let apply_function_body arity =
                         Cconst_int(pos_arity_in_closinfo, dbg())], dbg());
                    Cconst_int(arity, dbg())], dbg()),
    dbg (),
-   Cop(Capply typ_val,
+   Cop(Capply(typ_val, Apply_nontail),
        get_field_gen Asttypes.Mutable (Cvar clos) 2 (dbg ())
        :: List.map (fun s -> Cvar s) all_args,
        dbg ()),
@@ -1961,7 +1961,7 @@ let tuplify_function arity =
    {fun_name;
     fun_args = [VP.create arg, typ_val; VP.create clos, typ_val];
     fun_body =
-      Cop(Capply typ_val,
+      Cop(Capply(typ_val, Apply_nontail),
           get_field_gen Asttypes.Mutable (Cvar clos) 2 (dbg ())
           :: access_components 0 @ [Cvar clos],
           (dbg ()));
@@ -2004,7 +2004,7 @@ let final_curry_function ~nlocal ~arity =
   let last_clos = V.create_local "clos" in
   let rec curry_fun args clos n =
     if n = 0 then
-      Cop(Capply typ_val,
+      Cop(Capply(typ_val, Apply_nontail),
           get_field_gen Asttypes.Mutable (Cvar clos) 2 (dbg ()) ::
             args @ [Cvar last_arg; Cvar clos],
           dbg ())
@@ -2088,7 +2088,7 @@ let rec intermediate_curry_functions ~nlocal ~arity num =
           let direct_args = iter (num+2) in
           let rec iter i args clos =
             if i = 0 then
-              Cop(Capply typ_val,
+              Cop(Capply(typ_val, Apply_nontail),
                   (get_field_gen Asttypes.Mutable (Cvar clos) 2 (dbg ()))
                   :: args @ [Cvar clos],
                   dbg ())
@@ -2645,7 +2645,7 @@ let entry_point namelist =
     List.fold_right
       (fun name next ->
         let entry_sym = Compilenv.make_symbol ~unitname:name (Some "entry") in
-        Csequence(Cop(Capply typ_void,
+        Csequence(Cop(Capply(typ_void, Apply_nontail),
                          [cconst_symbol entry_sym], dbg ()),
                   Csequence(incr_global_inited (), next)))
       namelist (cconst_int 1) in

asmcomp/cmm_helpers.mli

@@ -281,7 +281,7 @@ val lookup_label : expression -> expression -> Debuginfo.t -> expression
     - args : the additional arguments to the method call *)
 val call_cached_method :
   expression -> expression -> expression -> expression -> expression list ->
-  Debuginfo.t -> expression
+  Lambda.apply_position -> Debuginfo.t -> expression
 
 (** Allocations *)
 
@@ -542,16 +542,18 @@ val strmatch_compile :
 val ptr_offset : expression -> int -> Debuginfo.t -> expression
 
 (** Direct application of a function via a symbol *)
-val direct_apply : string -> expression list -> Debuginfo.t -> expression
+val direct_apply :
+  string -> expression list -> Lambda.apply_position
+  -> Debuginfo.t -> expression
 
 (** Generic application of a function to one or several arguments.
     The mutable_flag argument annotates the loading of the code pointer
     from the closure. The Cmmgen code uses a mutable load by
     default, with a special case when the load is from (the first function of)
     the currently defined closure. *)
 val generic_apply :
-  Asttypes.mutable_flag ->
-  expression -> expression list -> Debuginfo.t -> expression
+  Asttypes.mutable_flag -> expression -> expression list
+  -> Lambda.apply_position -> Debuginfo.t -> expression
 
 (** Method call : [send kind met obj args dbg]
     - [met] is a method identifier, which can be a hashed variant or an index
@@ -561,8 +563,8 @@ val generic_apply :
     of any way for the frontend to generate any arguments other than the
     cache and cache position) *)
 val send :
-  Lambda.meth_kind -> expression -> expression -> expression list ->
-  Debuginfo.t -> expression
+  Lambda.meth_kind -> expression -> expression -> expression list
+  -> Lambda.apply_position -> Debuginfo.t -> expression
 
 (** Construct [Cregion e], eliding some useless regions *)
 val region : expression -> expression

asmcomp/cmmgen.ml

@@ -422,18 +422,18 @@ let rec transl env e =
       let ptr = transl env arg in
       let dbg = Debuginfo.none in
       ptr_offset ptr offset dbg
-  | Udirect_apply(lbl, args, dbg) ->
+  | Udirect_apply(lbl, args, pos, dbg) ->
       let args = List.map (transl env) args in
-      direct_apply lbl args dbg
-  | Ugeneric_apply(clos, args, dbg) ->
+      direct_apply lbl args pos dbg
+  | Ugeneric_apply(clos, args, pos, dbg) ->
       let clos = transl env clos in
       let args = List.map (transl env) args in
-      generic_apply (mut_from_env env clos) clos args dbg
-  | Usend(kind, met, obj, args, dbg) ->
+      generic_apply (mut_from_env env clos) clos args pos dbg
+  | Usend(kind, met, obj, args, pos, dbg) ->
       let met = transl env met in
       let obj = transl env obj in
       let args = List.map (transl env) args in
-      send kind met obj args dbg
+      send kind met obj args pos dbg
   | Ulet(str, kind, id, exp, body) ->
       transl_let env str kind id exp body
   | Uphantom_let (var, defining_expr, body) ->
@@ -687,6 +687,8 @@ let rec transl env e =
       Cop(Cload (Word_int, Mutable), [Cconst_int (0, dbg)], dbg)
   | Uregion e ->
       region (transl env e)
+  | Utail e ->
+      Ctail (transl env e)
 
 and transl_catch env nfail ids body handler dbg =
   let ids = List.map (fun (id, kind) -> (id, kind, ref No_result)) ids in

asmcomp/printcmm.ml

@@ -115,7 +115,7 @@ let location d =
   else Debuginfo.to_string d
 
 let operation d = function
-  | Capply _ty -> "app" ^ location d
+  | Capply(_ty, _) -> "app" ^ location d
   | Cextcall(lbl, _ty_res, _ty_args, _alloc) ->
       Printf.sprintf "extcall \"%s\"%s" lbl (location d)
   | Cload (c, Asttypes.Immutable) -> Printf.sprintf "load %s" (chunk c)
@@ -220,7 +220,7 @@ let rec expr ppf = function
       fprintf ppf "@[<2>(%s" (operation dbg op);
       List.iter (fun e -> fprintf ppf "@ %a" expr e) el;
       begin match op with
-      | Capply mty -> fprintf ppf "@ %a" machtype mty
+      | Capply(mty, _) -> fprintf ppf "@ %a" machtype mty
       | Cextcall(_, ty_res, ty_args, _) ->
           fprintf ppf "@ %a" extcall_signature (ty_res, ty_args)
       | _ -> ()
@@ -269,6 +269,8 @@ let rec expr ppf = function
              sequence e1 VP.print id sequence e2
   | Cregion e ->
       fprintf ppf "@[<2>(region@ %a)@]" sequence e
+  | Ctail e ->
+      fprintf ppf "@[<2>(tail@ %a)@]" sequence e
 
 and sequence ppf = function
   | Csequence(e1, e2) -> fprintf ppf "%a@ %a" sequence e1 sequence e2