@@ -375,6 +375,13 @@ module Acc = struct
375
375
| Trackable_arguments of Env .value_approximation list
376
376
| Untrackable
377
377
378
+ type closure_info =
379
+ { return_continuation : Continuation .t ;
380
+ exn_continuation : Exn_continuation .t ;
381
+ my_closure : Variable .t ;
382
+ is_purely_tailrec : bool
383
+ }
384
+
378
385
type t =
379
386
{ declared_symbols : (Symbol .t * Static_const .t ) list ;
380
387
lifted_sets_of_closures :
@@ -389,7 +396,8 @@ module Acc = struct
389
396
seen_a_function : bool ;
390
397
symbol_for_global : Ident .t -> Symbol .t ;
391
398
slot_offsets : Slot_offsets .t ;
392
- regions_closed_early : Ident.Set .t
399
+ regions_closed_early : Ident.Set .t ;
400
+ closure_infos : closure_info list
393
401
}
394
402
395
403
let cost_metrics t = t.cost_metrics
@@ -414,7 +422,8 @@ module Acc = struct
414
422
seen_a_function = false ;
415
423
symbol_for_global;
416
424
slot_offsets;
417
- regions_closed_early = Ident.Set. empty
425
+ regions_closed_early = Ident.Set. empty;
426
+ closure_infos = []
418
427
}
419
428
420
429
let declared_symbols t = t.declared_symbols
@@ -451,15 +460,47 @@ module Acc = struct
451
460
let add_free_names free_names t =
452
461
{ t with free_names = Name_occurrences. union free_names t.free_names }
453
462
454
- let add_name_to_free_names ~name t =
463
+ let add_free_names_and_check_my_closure_use free_names t =
464
+ let t =
465
+ match t.closure_infos with
466
+ | [] -> t
467
+ | closure_info :: closure_infos ->
468
+ if closure_info.is_purely_tailrec
469
+ && Name_occurrences. mem_var free_names closure_info.my_closure
470
+ then
471
+ { t with
472
+ closure_infos =
473
+ { closure_info with is_purely_tailrec = false } :: closure_infos
474
+ }
475
+ else t
476
+ in
477
+ add_free_names free_names t
478
+
479
+ let add_name_to_free_names ~is_tail_call ~name t =
480
+ let closure_infos =
481
+ match is_tail_call, t.closure_infos with
482
+ | true , closure_infos -> closure_infos
483
+ | false , [] -> []
484
+ | false , closure_info :: closure_infos ->
485
+ if closure_info.is_purely_tailrec
486
+ && Name. equal (Name. var closure_info.my_closure) name
487
+ then { closure_info with is_purely_tailrec = false } :: closure_infos
488
+ else t.closure_infos
489
+ in
455
490
{ t with
491
+ closure_infos;
456
492
free_names = Name_occurrences. add_name t.free_names name Name_mode. normal
457
493
}
458
494
459
- let add_simple_to_free_names acc simple =
495
+ let add_simple_to_free_names_maybe_tail_call ~ is_tail_call acc simple =
460
496
Simple. pattern_match simple
461
497
~const: (fun _ -> acc)
462
- ~name: (fun name ~coercion :_ -> add_name_to_free_names ~name acc)
498
+ ~name: (fun name ~coercion ->
499
+ let acc = add_name_to_free_names ~is_tail_call ~name acc in
500
+ add_free_names (Coercion. free_names coercion) acc)
501
+
502
+ let add_simple_to_free_names acc simple =
503
+ add_simple_to_free_names_maybe_tail_call ~is_tail_call: false acc simple
463
504
464
505
let remove_code_id_or_symbol_from_free_names code_id_or_symbol t =
465
506
{ t with
@@ -538,6 +579,36 @@ module Acc = struct
538
579
set_of_closures
539
580
in
540
581
{ t with slot_offsets }
582
+
583
+ let top_closure_info t =
584
+ match t.closure_infos with
585
+ | [] -> None
586
+ | closure_info :: _ -> Some closure_info
587
+
588
+ let push_closure_info t ~return_continuation ~exn_continuation ~my_closure
589
+ ~is_purely_tailrec =
590
+ { t with
591
+ closure_infos =
592
+ { return_continuation; exn_continuation; my_closure; is_purely_tailrec }
593
+ :: t.closure_infos
594
+ }
595
+
596
+ let pop_closure_info t =
597
+ let closure_info, closure_infos =
598
+ match t.closure_infos with
599
+ | [] -> Misc. fatal_error " pop_closure_info called on empty stack"
600
+ | closure_info :: closure_infos -> closure_info, closure_infos
601
+ in
602
+ let closure_infos =
603
+ match closure_infos with
604
+ | [] -> []
605
+ | closure_info2 :: closure_infos2 ->
606
+ if closure_info2.is_purely_tailrec
607
+ && Name_occurrences. mem_var t.free_names closure_info2.my_closure
608
+ then { closure_info2 with is_purely_tailrec = false } :: closure_infos2
609
+ else closure_infos
610
+ in
611
+ closure_info, { t with closure_infos }
541
612
end
542
613
543
614
module Function_decls = struct
@@ -711,7 +782,40 @@ module Expr_with_acc = struct
711
782
(Code_size. apply apply |> Cost_metrics. from_size)
712
783
acc
713
784
in
714
- let acc = Acc. add_free_names (Apply_expr. free_names apply) acc in
785
+ let is_tail_call =
786
+ match Acc. top_closure_info acc with
787
+ | None -> false
788
+ | Some { return_continuation; exn_continuation; _ } -> (
789
+ (match Apply_expr. continuation apply with
790
+ | Never_returns -> true
791
+ | Return cont -> Continuation. equal cont return_continuation)
792
+ && Exn_continuation. equal
793
+ (Apply_expr. exn_continuation apply)
794
+ exn_continuation
795
+ (* If the return and exn continuation match, the call is in tail
796
+ position, but could still be an under- or over-application. By
797
+ checking that it is a direct call, we are sure it has the correct
798
+ arity. *)
799
+ &&
800
+ match Apply. call_kind apply with
801
+ | Function { function_call = Direct _ ; _ } -> true
802
+ | Function
803
+ { function_call = Indirect_unknown_arity | Indirect_known_arity _;
804
+ _
805
+ } ->
806
+ false
807
+ | Method _ -> false
808
+ | C_call _ -> false )
809
+ in
810
+ let acc =
811
+ Acc. add_simple_to_free_names_maybe_tail_call ~is_tail_call acc
812
+ (Apply. callee apply)
813
+ in
814
+ let acc =
815
+ Acc. add_free_names_and_check_my_closure_use
816
+ (Apply_expr. free_names_except_callee apply)
817
+ acc
818
+ in
715
819
let acc =
716
820
match Apply_expr. continuation apply with
717
821
| Never_returns -> acc
@@ -744,7 +848,11 @@ module Apply_cont_with_acc = struct
744
848
let create acc ?trap_action ?args_approx cont ~args ~dbg =
745
849
let apply_cont = Apply_cont. create ?trap_action cont ~args ~dbg in
746
850
let acc = Acc. add_continuation_application ~cont args_approx acc in
747
- let acc = Acc. add_free_names (Apply_cont. free_names apply_cont) acc in
851
+ let acc =
852
+ Acc. add_free_names_and_check_my_closure_use
853
+ (Apply_cont. free_names apply_cont)
854
+ acc
855
+ in
748
856
acc, apply_cont
749
857
750
858
let goto acc cont =
@@ -799,7 +907,18 @@ module Let_with_acc = struct
799
907
~code_id: (fun acc cid -> Acc. remove_code_id_from_free_names cid acc)
800
908
in
801
909
let let_expr = Let. create let_bound named ~body ~free_names_of_body in
802
- let acc = Acc. add_free_names (Named. free_names named) acc in
910
+ let is_project_value_slot =
911
+ match [@ ocaml.warning " -4" ] (named : Named.t ) with
912
+ | Prim (Unary (Project_value_slot _ , _ ), _ ) -> true
913
+ | _ -> false
914
+ in
915
+ let acc =
916
+ if is_project_value_slot
917
+ then Acc. add_free_names (Named. free_names named) acc
918
+ else
919
+ Acc. add_free_names_and_check_my_closure_use (Named. free_names named)
920
+ acc
921
+ in
803
922
acc, Expr. create_let let_expr
804
923
end
805
924
0 commit comments