Skip to content

Commit a39126a

Browse files
authored
Fix tailcalls within regions (#48)
1 parent fca94c4 commit a39126a

Some content is hidden

Large Commits have some content hidden by default. Use the searchbox below for content that may be hidden.

47 files changed

+696
-289
lines changed

asmcomp/afl_instrument.ml

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -89,6 +89,7 @@ and instrument = function
8989
Ccatch (isrec, cases, instrument body)
9090
| Cexit (ex, args) -> Cexit (ex, List.map instrument args)
9191
| Cregion e -> Cregion (instrument e)
92+
| Ctail e -> Ctail (instrument e)
9293

9394
(* these are base cases and have no logging *)
9495
| Cconst_int _ | Cconst_natint _ | Cconst_float _

asmcomp/cmm.ml

Lines changed: 11 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -149,7 +149,7 @@ type memory_chunk =
149149
| Double_u
150150

151151
and operation =
152-
Capply of machtype
152+
Capply of machtype * Lambda.apply_position
153153
| Cextcall of string * machtype * exttype list * bool
154154
| Cload of memory_chunk * Asttypes.mutable_flag
155155
| Calloc of Lambda.alloc_mode
@@ -194,6 +194,7 @@ type expression =
194194
| Ctrywith of expression * Backend_var.With_provenance.t * expression
195195
* Debuginfo.t
196196
| Cregion of expression
197+
| Ctail of expression
197198

198199
type codegen_option =
199200
| Reduce_code_size
@@ -256,6 +257,9 @@ let iter_shallow_tail f = function
256257
| Cregion e ->
257258
f e;
258259
true
260+
| Ctail e ->
261+
f e;
262+
true
259263
| Cexit _ | Cop (Craise _, _, _) ->
260264
true
261265
| Cconst_int _
@@ -294,6 +298,8 @@ let rec map_tail f = function
294298
Ctrywith(map_tail f e1, id, map_tail f e2, dbg)
295299
| Cregion e ->
296300
Cregion(map_tail f e)
301+
| Ctail e ->
302+
Ctail(map_tail f e)
297303
| Cexit _ | Cop (Craise _, _, _) as cmm ->
298304
cmm
299305
| Cconst_int _
@@ -334,6 +340,8 @@ let iter_shallow f = function
334340
f e1; f e2
335341
| Cregion e ->
336342
f e
343+
| Ctail e ->
344+
f e
337345
| Cconst_int _
338346
| Cconst_natint _
339347
| Cconst_float _
@@ -369,6 +377,8 @@ let map_shallow f = function
369377
Ctrywith (f e1, id, f e2, dbg)
370378
| Cregion e ->
371379
Cregion (f e)
380+
| Ctail e ->
381+
Ctail (f e)
372382
| Cconst_int _
373383
| Cconst_natint _
374384
| Cconst_float _

asmcomp/cmm.mli

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -139,7 +139,7 @@ type memory_chunk =
139139
| Double_u (* word-aligned 64-bit float *)
140140

141141
and operation =
142-
Capply of machtype
142+
Capply of machtype * Lambda.apply_position
143143
| Cextcall of string * machtype * exttype list * bool
144144
(** The [machtype] is the machine type of the result.
145145
The [exttype list] describes the unboxing types of the arguments.
@@ -194,6 +194,7 @@ and expression =
194194
| Ctrywith of expression * Backend_var.With_provenance.t * expression
195195
* Debuginfo.t
196196
| Cregion of expression
197+
| Ctail of expression
197198

198199
type codegen_option =
199200
| Reduce_code_size

asmcomp/cmm_helpers.ml

Lines changed: 22 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -636,8 +636,8 @@ let rec remove_unit = function
636636
Ctrywith(remove_unit body, exn, remove_unit handler, dbg)
637637
| Clet(id, c1, c2) ->
638638
Clet(id, c1, remove_unit c2)
639-
| Cop(Capply _mty, args, dbg) ->
640-
Cop(Capply typ_void, args, dbg)
639+
| Cop(Capply(_mty, pos), args, dbg) ->
640+
Cop(Capply(typ_void, pos), args, dbg)
641641
| Cop(Cextcall(proc, _ty_res, ty_args, alloc), args, dbg) ->
642642
Cop(Cextcall(proc, typ_void, ty_args, alloc), args, dbg)
643643
| Cexit (_,_) as c -> c
@@ -807,11 +807,11 @@ let lookup_label obj lab dbg =
807807
let table = Cop (Cload (Word_val, Mutable), [obj], dbg) in
808808
addr_array_ref table lab dbg)
809809

810-
let call_cached_method obj tag cache pos args dbg =
810+
let call_cached_method obj tag cache pos args apos dbg =
811811
let arity = List.length args in
812812
let cache = array_indexing log2_size_addr cache pos dbg in
813813
Compilenv.need_send_fun arity;
814-
Cop(Capply typ_val,
814+
Cop(Capply(typ_val, apos),
815815
Cconst_symbol("caml_send" ^ Int.to_string arity, dbg) ::
816816
obj :: tag :: cache :: args,
817817
dbg)
@@ -1713,35 +1713,35 @@ let ptr_offset ptr offset dbg =
17131713
then ptr
17141714
else Cop(Caddv, [ptr; Cconst_int(offset * size_addr, dbg)], dbg)
17151715

1716-
let direct_apply lbl args dbg =
1717-
Cop(Capply typ_val, Cconst_symbol (lbl, dbg) :: args, dbg)
1716+
let direct_apply lbl args pos dbg =
1717+
Cop(Capply(typ_val, pos), Cconst_symbol (lbl, dbg) :: args, dbg)
17181718

1719-
let generic_apply mut clos args dbg =
1719+
let generic_apply mut clos args pos dbg =
17201720
match args with
17211721
| [arg] ->
17221722
bind "fun" clos (fun clos ->
1723-
Cop(Capply typ_val, [get_field_gen mut clos 0 dbg; arg; clos],
1723+
Cop(Capply(typ_val, pos), [get_field_gen mut clos 0 dbg; arg; clos],
17241724
dbg))
17251725
| _ ->
17261726
let arity = List.length args in
17271727
let cargs =
17281728
Cconst_symbol(apply_function_sym arity, dbg) :: args @ [clos]
17291729
in
1730-
Cop(Capply typ_val, cargs, dbg)
1730+
Cop(Capply(typ_val, pos), cargs, dbg)
17311731

1732-
let send kind met obj args dbg =
1732+
let send kind met obj args apos dbg =
17331733
let call_met obj args clos =
17341734
(* met is never a simple expression, so it never gets turned into an
17351735
Immutable load *)
1736-
generic_apply Asttypes.Mutable clos (obj :: args) dbg
1736+
generic_apply Asttypes.Mutable clos (obj :: args) apos dbg
17371737
in
17381738
bind "obj" obj (fun obj ->
17391739
match (kind : Lambda.meth_kind), args with
17401740
Self, _ ->
17411741
bind "met" (lookup_label obj met dbg)
17421742
(call_met obj args)
17431743
| Cached, cache :: pos :: args ->
1744-
call_cached_method obj met cache pos args dbg
1744+
call_cached_method obj met cache pos args apos dbg
17451745
| _ ->
17461746
bind "met" (lookup_tag obj met dbg)
17471747
(call_met obj args))
@@ -1811,9 +1811,9 @@ let region e =
18111811
(* [Cregion e] is equivalent to [e] if [e] contains no local allocs *)
18121812
let rec check_local_allocs = function
18131813
| Cregion _ ->
1814-
(* Assume any already-existing Cregion contains a local alloc.
1815-
This prevents O(n^2) behaviour with many nested regions *)
1816-
raise Exit
1814+
(* Local allocations within a nested region do not affect this region.
1815+
Note this prevents O(n^2) behaviour with many nested regions. *)
1816+
()
18171817
| Cop (Calloc Alloc_local, _, _)
18181818
| Cop ((Cextcall _ | Capply _), _, _) ->
18191819
raise Exit
@@ -1847,15 +1847,15 @@ let apply_function_body arity =
18471847
let clos = V.create_local "clos" in
18481848
let rec app_fun clos n =
18491849
if n = arity-1 then
1850-
Cop(Capply typ_val,
1850+
Cop(Capply(typ_val, Apply_nontail),
18511851
[get_field_gen Asttypes.Mutable (Cvar clos) 0 (dbg ());
18521852
Cvar arg.(n);
18531853
Cvar clos],
18541854
dbg ())
18551855
else begin
18561856
let newclos = V.create_local "clos" in
18571857
Clet(VP.create newclos,
1858-
Cop(Capply typ_val,
1858+
Cop(Capply(typ_val, Apply_nontail),
18591859
[get_field_gen Asttypes.Mutable (Cvar clos) 0 (dbg ());
18601860
Cvar arg.(n); Cvar clos], dbg ()),
18611861
app_fun newclos (n+1))
@@ -1870,7 +1870,7 @@ let apply_function_body arity =
18701870
Cconst_int(pos_arity_in_closinfo, dbg())], dbg());
18711871
Cconst_int(arity, dbg())], dbg()),
18721872
dbg (),
1873-
Cop(Capply typ_val,
1873+
Cop(Capply(typ_val, Apply_nontail),
18741874
get_field_gen Asttypes.Mutable (Cvar clos) 2 (dbg ())
18751875
:: List.map (fun s -> Cvar s) all_args,
18761876
dbg ()),
@@ -1961,7 +1961,7 @@ let tuplify_function arity =
19611961
{fun_name;
19621962
fun_args = [VP.create arg, typ_val; VP.create clos, typ_val];
19631963
fun_body =
1964-
Cop(Capply typ_val,
1964+
Cop(Capply(typ_val, Apply_nontail),
19651965
get_field_gen Asttypes.Mutable (Cvar clos) 2 (dbg ())
19661966
:: access_components 0 @ [Cvar clos],
19671967
(dbg ()));
@@ -2004,7 +2004,7 @@ let final_curry_function ~nlocal ~arity =
20042004
let last_clos = V.create_local "clos" in
20052005
let rec curry_fun args clos n =
20062006
if n = 0 then
2007-
Cop(Capply typ_val,
2007+
Cop(Capply(typ_val, Apply_nontail),
20082008
get_field_gen Asttypes.Mutable (Cvar clos) 2 (dbg ()) ::
20092009
args @ [Cvar last_arg; Cvar clos],
20102010
dbg ())
@@ -2088,7 +2088,7 @@ let rec intermediate_curry_functions ~nlocal ~arity num =
20882088
let direct_args = iter (num+2) in
20892089
let rec iter i args clos =
20902090
if i = 0 then
2091-
Cop(Capply typ_val,
2091+
Cop(Capply(typ_val, Apply_nontail),
20922092
(get_field_gen Asttypes.Mutable (Cvar clos) 2 (dbg ()))
20932093
:: args @ [Cvar clos],
20942094
dbg ())
@@ -2645,7 +2645,7 @@ let entry_point namelist =
26452645
List.fold_right
26462646
(fun name next ->
26472647
let entry_sym = Compilenv.make_symbol ~unitname:name (Some "entry") in
2648-
Csequence(Cop(Capply typ_void,
2648+
Csequence(Cop(Capply(typ_void, Apply_nontail),
26492649
[cconst_symbol entry_sym], dbg ()),
26502650
Csequence(incr_global_inited (), next)))
26512651
namelist (cconst_int 1) in

asmcomp/cmm_helpers.mli

Lines changed: 8 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -281,7 +281,7 @@ val lookup_label : expression -> expression -> Debuginfo.t -> expression
281281
- args : the additional arguments to the method call *)
282282
val call_cached_method :
283283
expression -> expression -> expression -> expression -> expression list ->
284-
Debuginfo.t -> expression
284+
Lambda.apply_position -> Debuginfo.t -> expression
285285

286286
(** Allocations *)
287287

@@ -542,16 +542,18 @@ val strmatch_compile :
542542
val ptr_offset : expression -> int -> Debuginfo.t -> expression
543543

544544
(** Direct application of a function via a symbol *)
545-
val direct_apply : string -> expression list -> Debuginfo.t -> expression
545+
val direct_apply :
546+
string -> expression list -> Lambda.apply_position
547+
-> Debuginfo.t -> expression
546548

547549
(** Generic application of a function to one or several arguments.
548550
The mutable_flag argument annotates the loading of the code pointer
549551
from the closure. The Cmmgen code uses a mutable load by
550552
default, with a special case when the load is from (the first function of)
551553
the currently defined closure. *)
552554
val generic_apply :
553-
Asttypes.mutable_flag ->
554-
expression -> expression list -> Debuginfo.t -> expression
555+
Asttypes.mutable_flag -> expression -> expression list
556+
-> Lambda.apply_position -> Debuginfo.t -> expression
555557

556558
(** Method call : [send kind met obj args dbg]
557559
- [met] is a method identifier, which can be a hashed variant or an index
@@ -561,8 +563,8 @@ val generic_apply :
561563
of any way for the frontend to generate any arguments other than the
562564
cache and cache position) *)
563565
val send :
564-
Lambda.meth_kind -> expression -> expression -> expression list ->
565-
Debuginfo.t -> expression
566+
Lambda.meth_kind -> expression -> expression -> expression list
567+
-> Lambda.apply_position -> Debuginfo.t -> expression
566568

567569
(** Construct [Cregion e], eliding some useless regions *)
568570
val region : expression -> expression

asmcomp/cmmgen.ml

Lines changed: 8 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -422,18 +422,18 @@ let rec transl env e =
422422
let ptr = transl env arg in
423423
let dbg = Debuginfo.none in
424424
ptr_offset ptr offset dbg
425-
| Udirect_apply(lbl, args, dbg) ->
425+
| Udirect_apply(lbl, args, pos, dbg) ->
426426
let args = List.map (transl env) args in
427-
direct_apply lbl args dbg
428-
| Ugeneric_apply(clos, args, dbg) ->
427+
direct_apply lbl args pos dbg
428+
| Ugeneric_apply(clos, args, pos, dbg) ->
429429
let clos = transl env clos in
430430
let args = List.map (transl env) args in
431-
generic_apply (mut_from_env env clos) clos args dbg
432-
| Usend(kind, met, obj, args, dbg) ->
431+
generic_apply (mut_from_env env clos) clos args pos dbg
432+
| Usend(kind, met, obj, args, pos, dbg) ->
433433
let met = transl env met in
434434
let obj = transl env obj in
435435
let args = List.map (transl env) args in
436-
send kind met obj args dbg
436+
send kind met obj args pos dbg
437437
| Ulet(str, kind, id, exp, body) ->
438438
transl_let env str kind id exp body
439439
| Uphantom_let (var, defining_expr, body) ->
@@ -687,6 +687,8 @@ let rec transl env e =
687687
Cop(Cload (Word_int, Mutable), [Cconst_int (0, dbg)], dbg)
688688
| Uregion e ->
689689
region (transl env e)
690+
| Utail e ->
691+
Ctail (transl env e)
690692

691693
and transl_catch env nfail ids body handler dbg =
692694
let ids = List.map (fun (id, kind) -> (id, kind, ref No_result)) ids in

asmcomp/printcmm.ml

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -115,7 +115,7 @@ let location d =
115115
else Debuginfo.to_string d
116116

117117
let operation d = function
118-
| Capply _ty -> "app" ^ location d
118+
| Capply(_ty, _) -> "app" ^ location d
119119
| Cextcall(lbl, _ty_res, _ty_args, _alloc) ->
120120
Printf.sprintf "extcall \"%s\"%s" lbl (location d)
121121
| Cload (c, Asttypes.Immutable) -> Printf.sprintf "load %s" (chunk c)
@@ -220,7 +220,7 @@ let rec expr ppf = function
220220
fprintf ppf "@[<2>(%s" (operation dbg op);
221221
List.iter (fun e -> fprintf ppf "@ %a" expr e) el;
222222
begin match op with
223-
| Capply mty -> fprintf ppf "@ %a" machtype mty
223+
| Capply(mty, _) -> fprintf ppf "@ %a" machtype mty
224224
| Cextcall(_, ty_res, ty_args, _) ->
225225
fprintf ppf "@ %a" extcall_signature (ty_res, ty_args)
226226
| _ -> ()
@@ -269,6 +269,8 @@ let rec expr ppf = function
269269
sequence e1 VP.print id sequence e2
270270
| Cregion e ->
271271
fprintf ppf "@[<2>(region@ %a)@]" sequence e
272+
| Ctail e ->
273+
fprintf ppf "@[<2>(tail@ %a)@]" sequence e
272274

273275
and sequence ppf = function
274276
| Csequence(e1, e2) -> fprintf ppf "%a@ %a" sequence e1 sequence e2

0 commit comments

Comments
 (0)