Skip to content

Make tailrec label optional #48

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Closed
wants to merge 3 commits into from
Closed

Make tailrec label optional #48

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
9349b0b
Workaround for a GNU make 3.81 bug.
xclerc Jun 10, 2021
b46fca4
Turn the `fun_tailrec_entry_point_label` into a `Label.t option` value.
xclerc Jun 10, 2021
26ae9da
Propagate the change to the corresponding `Linear` type.
xclerc Jun 10, 2021
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
16 changes: 10 additions & 6 deletions Makefile.in
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -178,12 +178,16 @@ flags.sexp: ocaml-stage1-config.status
else \
/bin/echo -n "(:standard)" > ocamlopt_flags.sexp; \
fi
/bin/echo -n "( $$(grep "^OC_CFLAGS=" ocaml/Makefile.config \
| sed 's/^OC_CFLAGS=//') )" > oc_cflags.sexp
/bin/echo -n "( $$(grep "^OC_CPPFLAGS=" ocaml/Makefile.config \
| sed 's/^OC_CPPFLAGS=//') )" > oc_cppflags.sexp
/bin/echo -n "( $$(grep "^SHAREDLIB_CFLAGS=" ocaml/Makefile.config \
| sed 's/^SHAREDLIB_CFLAGS=//') )" > sharedlib_cflags.sexp
# note: it looks like the use of "$(...)" with a command spanning over
# two lines triggers a bug in GNU make 3.81, that will as a consequence
# change the file name. It also looks like the bug is not triggered by
# "`...`".
/bin/echo -n "( `grep \"^OC_CFLAGS=\" ocaml/Makefile.config \
| sed 's/^OC_CFLAGS=//'` )" > oc_cflags.sexp
/bin/echo -n "( `grep \"^OC_CPPFLAGS=\" ocaml/Makefile.config \
| sed 's/^OC_CPPFLAGS=//'` )" > oc_cppflags.sexp
/bin/echo -n "( `grep \"^SHAREDLIB_CFLAGS=\" ocaml/Makefile.config \
| sed 's/^SHAREDLIB_CFLAGS=//'` )" > sharedlib_cflags.sexp

# Most of the installation tree is correctly set up by dune, but we need to
# copy it to the final destination, and rearrange a few things to match
Expand Down
6 changes: 4 additions & 2 deletions backend/amd64/emit.mlp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -566,7 +566,7 @@ let emit_named_text_section func_name =
(* Name of current function *)
let function_name = ref ""
(* Entry point for tail recursive calls *)
let tailrec_entry_point = ref 0
let tailrec_entry_point = ref None

(* Emit tracing probes *)

Expand Down Expand Up @@ -722,7 +722,9 @@ let emit_instr fallthrough i =
| Lop(Itailcall_imm { func; label_after; }) ->
begin
if func = !function_name then
I.jmp (label !tailrec_entry_point)
match !tailrec_entry_point with
| None -> Misc.fatal_error "jump to missing tailrec entry point"
| Some tailrec_entry_point -> I.jmp (label tailrec_entry_point)
else begin
output_epilogue begin fun () ->
add_used_symbol func;
Expand Down
4 changes: 3 additions & 1 deletion backend/asmgen.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -138,7 +138,9 @@ let compile_fundecl ~ppf_dump fd_cmm =
if !use_ocamlcfg then begin
let cfg = Ocamlcfg.Cfg_with_layout.of_linear fd ~preserve_orig_labels:true in
let fun_body = Ocamlcfg.Cfg_with_layout.to_linear cfg in
{ fd with Linear.fun_body; }
let fun_tailrec_entry_point_label =
Ocamlcfg.Cfg.fun_tailrec_entry_point_label (Ocamlcfg.Cfg_with_layout.cfg cfg) in
{ fd with Linear.fun_body; fun_tailrec_entry_point_label }
end else
fd)
++ Profile.record ~accumulate:true "scheduling" Scheduling.fundecl
Expand Down
22 changes: 15 additions & 7 deletions backend/cfg/cfg.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -47,7 +47,7 @@ type t =
fun_name : string;
fun_dbg : Debuginfo.t;
entry_label : Label.t;
mutable fun_tailrec_entry_point_label : Label.t
mutable fun_tailrec_entry_point_label : Label.t option
}

let create ~fun_name ~fun_tailrec_entry_point_label ~fun_dbg =
Expand All @@ -62,7 +62,11 @@ let mem_block t label = Label.Tbl.mem t.blocks label

let successor_labels_normal t ti =
match ti.desc with
| Tailcall (Self _) -> Label.Set.singleton t.fun_tailrec_entry_point_label
| Tailcall (Self _) ->
begin match t.fun_tailrec_entry_point_label with
| None -> Label.Set.empty
| Some label -> Label.Set.singleton label
end
| Switch labels -> Array.to_seq labels |> Label.Set.of_seq
| Return | Raise _ | Tailcall (Func _) -> Label.Set.empty
| Never -> Label.Set.empty
Expand Down Expand Up @@ -138,7 +142,7 @@ let replace_successor_labels t ~normal ~exn block ~f =
t.fun_tailrec_entry_point_label and the tailrec entry point
block has as its predecessors *all* the "tailcall self" blocks. *)
t.fun_tailrec_entry_point_label <-
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

In the case of Tailcall(Self), t.fun_tailrec_entry_point_label must not be None, so Option.map is fine, but may be worth checking.

f t.fun_tailrec_entry_point_label;
Option.map f t.fun_tailrec_entry_point_label;
block.terminator.desc
| Return | Raise _ | Tailcall (Func _) -> block.terminator.desc
in
Expand All @@ -165,10 +169,14 @@ let entry_label t = t.entry_label
let fun_tailrec_entry_point_label t = t.fun_tailrec_entry_point_label

let set_fun_tailrec_entry_point_label t label =
if not (mem_block t label) then
Misc.fatal_errorf
"Cfg.set_fun_tailrec_entry_point_label: \n\
label %d not found in the cfg" label;
begin match label with
| None -> ()
| Some label ->
if not (mem_block t label) then
Misc.fatal_errorf
"Cfg.set_fun_tailrec_entry_point_label: \n\
label %d not found in the cfg" label;
end;
t.fun_tailrec_entry_point_label <- label

let iter_blocks t ~f = Label.Tbl.iter f t.blocks
Expand Down
8 changes: 4 additions & 4 deletions backend/cfg/cfg.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -80,19 +80,19 @@ type t = private
fun_dbg : Debuginfo.t; (** Dwarf debug info for function entry. *)
entry_label : Label.t;
(** This label must be the first in all layouts of this cfg. *)
mutable fun_tailrec_entry_point_label : Label.t
mutable fun_tailrec_entry_point_label : Label.t option
(** When a [Prologue] is absent, this is the same as [entry_label].
Otherwise, the [Prologue] falls through to this label. *)
}

val create : fun_name:string -> fun_tailrec_entry_point_label:Label.t ->
val create : fun_name:string -> fun_tailrec_entry_point_label:Label.t option ->
fun_dbg:Debuginfo.t -> t

val fun_name : t -> string

val entry_label : t -> Label.t

val fun_tailrec_entry_point_label : t -> Label.t
val fun_tailrec_entry_point_label : t -> Label.t option

val predecessor_labels : basic_block -> Label.t list

Expand All @@ -117,7 +117,7 @@ val get_block : t -> Label.t -> basic_block option

val get_block_exn : t -> Label.t -> basic_block

val set_fun_tailrec_entry_point_label : t -> Label.t -> unit
val set_fun_tailrec_entry_point_label : t -> Label.t option -> unit

val iter_blocks : t -> f:(Label.t -> basic_block -> unit) -> unit

Expand Down
2 changes: 1 addition & 1 deletion backend/cfg/cfg_to_linear.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -384,7 +384,7 @@ let print_assembly (blocks : Cfg.basic_block list) =
(* create a fake cfg just for printing these blocks *)
let layout = List.map (fun (b : Cfg.basic_block) -> b.start) blocks in
let fun_name = "_fun_start_" in
let fun_tailrec_entry_point_label = 0 in
let fun_tailrec_entry_point_label = Some 0 in
let cfg = Cfg.create ~fun_name ~fun_tailrec_entry_point_label
~fun_dbg:Debuginfo.none in
List.iter
Expand Down
8 changes: 7 additions & 1 deletion backend/cfg/eliminate_dead_blocks.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -64,7 +64,13 @@ let rec eliminate_dead_blocks cfg_with_layout =
Printf.printf "\n" );
(* Termination: the number of remaining blocks is strictly smaller in
each recursive call. *)
eliminate_dead_blocks cfg_with_layout )
eliminate_dead_blocks cfg_with_layout;
begin match cfg.fun_tailrec_entry_point_label with
| None -> ()
| Some label ->
if List.exists (Label.equal label) found_dead then
Cfg.set_fun_tailrec_entry_point_label cfg None
end)
Comment on lines +68 to +73
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I think this check is not correct here: if there is another Tailcall Self that is not dead, we cannot set fun_tailrec_entry_point_label to None. Instead, we should check at the end of CFG construction and transformations whether any block has Tailcall Self and if not, then we can set fun_tailrec_entry_point_label to None.

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

sorry, this is actually fine and I was confused about who is dead! I still think it's better to do this check at the end.

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I still think it's better to do this check at the end.

I am slightly confused: it looks like the operation is the very
last of the function, and hence the whole transformation.

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This check will happen at the end of each recursive call.
What I meant is to have a separate pass that checks if the input Cfg has any Tailcall Self, and if it does not, sets tailrec label to None. This pass can be called at the end of Linear_to_cfg.run, and at the end of Eliminate_dead_blocks.run and at the end of Eliminate_fallthrough_blocks.run.
What you have here is more efficient, because it fixes up tailrec label only as needed, but I think we have this problem in the first place because the representation of tailrec label is problematic.

As suggested offline, this problem would completely go away if we change the representation of Tailcall Self to include the label, and also remove fun_tailrec_entry_point_label in Cfg. It is still worth changing Linear.fundecl.fun_tailrec_entry_point_label to an option. The pass Cfg_to_linear can compute the field and check its consistency (i.e., all Tailrec Self have the same destination label).

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I understand your point about the recursive calls.
However, it sounds simpler to have these calls accumulate
the set of dead blocks rather than have a whole new phase/
traversal at the end of run. run would get the set of
eliminated blocks from eliminate_dead_blocks and the
code currently at lines 68-73 would be at the end of run.

else
(* check that no blocks are left that are marked as dead *)
C.iter_blocks cfg ~f:(fun label block ->
Expand Down
8 changes: 7 additions & 1 deletion backend/cfg/eliminate_fallthrough_blocks.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -71,7 +71,13 @@ let rec disconnect_fallthrough_blocks cfg_with_layout =
if !C.verbose then
Printf.printf "%s: disconnected fallthrough blocks: %d\n" cfg.fun_name
len;
disconnect_fallthrough_blocks cfg_with_layout )
disconnect_fallthrough_blocks cfg_with_layout;
begin match cfg.fun_tailrec_entry_point_label with
| None -> ()
| Some label ->
if List.exists (Label.equal label) found then
Cfg.set_fun_tailrec_entry_point_label cfg None
end)
Comment on lines +78 to +80
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Same as above, I think this check should be done at the end of the entire transformation.

Unlike the above case, this seem correct for a subtle reason: if tailrec block was a fallthrough and got eliminated, then either (a) there are Tailcall Self, and then the label here will be the new fun_tailrec_entry_point_label which is the successor of the original one, so won't be in found or (b) there are no Tailcall Self, and the label is not used and can be safely set to None.


let run cfg_with_layout =
let cfg = CL.cfg cfg_with_layout in
Expand Down
2 changes: 1 addition & 1 deletion backend/cfg/ocamlcfg.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -65,7 +65,7 @@ module Cfg : sig

val entry_label : t -> Label.t

val fun_tailrec_entry_point_label : t -> Label.t
val fun_tailrec_entry_point_label : t -> Label.t option
end

module Cfg_with_layout : sig
Expand Down
2 changes: 1 addition & 1 deletion backend/linear.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -54,7 +54,7 @@ type fundecl =
fun_fast: bool;
fun_dbg : Debuginfo.t;
fun_spacetime_shape : Mach.spacetime_shape option;
fun_tailrec_entry_point_label : label;
fun_tailrec_entry_point_label : label option;
fun_contains_calls: bool;
fun_num_stack_slots: int array;
fun_frame_required: bool;
Expand Down
2 changes: 1 addition & 1 deletion backend/linear.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -55,7 +55,7 @@ type fundecl =
fun_fast: bool;
fun_dbg : Debuginfo.t;
fun_spacetime_shape : Mach.spacetime_shape option;
fun_tailrec_entry_point_label : label;
fun_tailrec_entry_point_label : label option;
fun_contains_calls: bool;
fun_num_stack_slots: int array;
fun_frame_required: bool;
Expand Down
2 changes: 1 addition & 1 deletion backend/linearize.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -334,7 +334,7 @@ let fundecl f =
fun_fast = not (List.mem Cmm.Reduce_code_size f.Mach.fun_codegen_options);
fun_dbg = f.Mach.fun_dbg;
fun_spacetime_shape = f.Mach.fun_spacetime_shape;
fun_tailrec_entry_point_label;
fun_tailrec_entry_point_label = Some fun_tailrec_entry_point_label;
fun_contains_calls = contains_calls;
fun_num_stack_slots = f.Mach.fun_num_stack_slots;
fun_frame_required = Proc.frame_required f;
Expand Down