diff --git a/Makefile.in b/Makefile.in index 22a299a95a4..0602f080006 100644 --- a/Makefile.in +++ b/Makefile.in @@ -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 diff --git a/backend/amd64/emit.mlp b/backend/amd64/emit.mlp index bf82f101b82..8a54a1b1788 100644 --- a/backend/amd64/emit.mlp +++ b/backend/amd64/emit.mlp @@ -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 *) @@ -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; diff --git a/backend/asmgen.ml b/backend/asmgen.ml index b3661465c1a..6eb32260be3 100644 --- a/backend/asmgen.ml +++ b/backend/asmgen.ml @@ -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 diff --git a/backend/cfg/cfg.ml b/backend/cfg/cfg.ml index 8b5cab53d75..9337e0574c2 100644 --- a/backend/cfg/cfg.ml +++ b/backend/cfg/cfg.ml @@ -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 = @@ -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 @@ -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 <- - 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 @@ -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 diff --git a/backend/cfg/cfg.mli b/backend/cfg/cfg.mli index d8e1d2b807a..17d2bfffb02 100644 --- a/backend/cfg/cfg.mli +++ b/backend/cfg/cfg.mli @@ -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 @@ -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 diff --git a/backend/cfg/cfg_to_linear.ml b/backend/cfg/cfg_to_linear.ml index bef1e1162e7..33edb5e0674 100644 --- a/backend/cfg/cfg_to_linear.ml +++ b/backend/cfg/cfg_to_linear.ml @@ -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 diff --git a/backend/cfg/eliminate_dead_blocks.ml b/backend/cfg/eliminate_dead_blocks.ml index dad987e90ba..22dfb0dc29f 100644 --- a/backend/cfg/eliminate_dead_blocks.ml +++ b/backend/cfg/eliminate_dead_blocks.ml @@ -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) else (* check that no blocks are left that are marked as dead *) C.iter_blocks cfg ~f:(fun label block -> diff --git a/backend/cfg/eliminate_fallthrough_blocks.ml b/backend/cfg/eliminate_fallthrough_blocks.ml index 13cc845464f..98fe373c076 100644 --- a/backend/cfg/eliminate_fallthrough_blocks.ml +++ b/backend/cfg/eliminate_fallthrough_blocks.ml @@ -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) let run cfg_with_layout = let cfg = CL.cfg cfg_with_layout in diff --git a/backend/cfg/ocamlcfg.mli b/backend/cfg/ocamlcfg.mli index 2acbaffa24a..7fdd80ec793 100644 --- a/backend/cfg/ocamlcfg.mli +++ b/backend/cfg/ocamlcfg.mli @@ -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 diff --git a/backend/linear.ml b/backend/linear.ml index 7adeab538c5..7bebfef7f35 100644 --- a/backend/linear.ml +++ b/backend/linear.ml @@ -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; diff --git a/backend/linear.mli b/backend/linear.mli index d0eb912af0d..813ff5c1d42 100644 --- a/backend/linear.mli +++ b/backend/linear.mli @@ -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; diff --git a/backend/linearize.ml b/backend/linearize.ml index 709c4fbe662..09e68b7f793 100644 --- a/backend/linearize.ml +++ b/backend/linearize.ml @@ -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;