diff --git a/backend/.ocamlformat-enable b/backend/.ocamlformat-enable index cdd5dc7c6c8..a0281894acd 100644 --- a/backend/.ocamlformat-enable +++ b/backend/.ocamlformat-enable @@ -19,5 +19,7 @@ regalloc/**/*.mli amd64/simd*.ml amd64/stack_check.ml arm64/simd*.ml +amd64/stack_check.ml +arm64/stack_check.ml generic_fns.ml generic_fns.mli diff --git a/backend/amd64/emit.mlp b/backend/amd64/emit.mlp index 92d56620710..70f7b2da200 100644 --- a/backend/amd64/emit.mlp +++ b/backend/amd64/emit.mlp @@ -487,7 +487,7 @@ let emit_stack_realloc () = cfi_adjust_cfa_offset 8; (* measured in words *) emit_call (Cmm.global_symbol "caml_call_realloc_stack"); - I.pop r10; (* ignored *) + I.add (int 8) rsp; cfi_adjust_cfa_offset (-8); I.jmp (label sc_return) end diff --git a/backend/arm64/stack_check.ml b/backend/arm64/stack_check.ml index ae0a797b34e..cb3364900ee 100644 --- a/backend/arm64/stack_check.ml +++ b/backend/arm64/stack_check.ml @@ -18,15 +18,14 @@ let stack_threshold_size = 0 -let frame_size - : stack_offset:int -> frame_required:bool -> num_stack_slots:int array -> int - = fun ~stack_offset:_ ~frame_required:_ ~num_stack_slots:_ -> +let frame_size : + stack_offset:int -> frame_required:bool -> num_stack_slots:int array -> int + = + fun ~stack_offset:_ ~frame_required:_ ~num_stack_slots:_ -> Misc.fatal_error "stack checks are not supported on arm64" -let linear - : Linear.fundecl -> Linear.fundecl - = fun fundecl -> +let linear : Linear.fundecl -> Linear.fundecl = + fun fundecl -> match Config.runtime5 with | false -> fundecl - | true -> - Misc.fatal_error "stack checks are not supported on arm64" + | true -> Misc.fatal_error "stack checks are not supported on arm64" diff --git a/backend/asmgen.ml b/backend/asmgen.ml index ece633bf38e..ad9fda73103 100644 --- a/backend/asmgen.ml +++ b/backend/asmgen.ml @@ -335,6 +335,10 @@ let compile_fundecl ~ppf_dump ~funcnames fd_cmm = we would have to recompute it here. Recomputing it here breaks the CI because the liveness_analysis algorithm does not work properly after register allocation. *) ++ Profile.record ~accumulate:true "peephole_optimize_cfg" Peephole_optimize.peephole_optimize_cfg + ++ (fun (cfg_with_layout : Cfg_with_layout.t) -> + match !Flambda_backend_flags.cfg_stack_checks with + | false -> cfg_with_layout + | true -> Cfg_stack_checks.cfg cfg_with_layout) ++ Profile.record ~accumulate:true "save_cfg" save_cfg ++ Profile.record ~accumulate:true "cfg_reorder_blocks" (reorder_blocks_random ppf_dump) @@ -376,6 +380,10 @@ let compile_fundecl ~ppf_dump ~funcnames fd_cmm = ~simplify_terminators:true) ++ Compiler_hooks.execute_and_pipe Compiler_hooks.Cfg ++ pass_dump_cfg_if ppf_dump Flambda_backend_flags.dump_cfg "After cfgize" + ++ (fun (cfg_with_layout : Cfg_with_layout.t) -> + match !Flambda_backend_flags.cfg_stack_checks with + | false -> cfg_with_layout + | true -> Cfg_stack_checks.cfg cfg_with_layout) ++ Profile.record ~accumulate:true "save_cfg" save_cfg ++ Profile.record ~accumulate:true "cfg_reorder_blocks" (reorder_blocks_random ppf_dump) @@ -385,7 +393,10 @@ let compile_fundecl ~ppf_dump ~funcnames fd_cmm = ++ Profile.record ~accumulate:true "scheduling" Scheduling.fundecl ++ pass_dump_linear_if ppf_dump dump_scheduling "After instruction scheduling" ++ Profile.record ~accumulate:true "save_linear" save_linear - ++ Stack_check.linear + ++ (fun (fd : Linear.fundecl) -> + match !Flambda_backend_flags.cfg_stack_checks with + | false -> Stack_check.linear fd + | true -> fd) ++ Profile.record ~accumulate:true "emit_fundecl" emit_fundecl let compile_data dl = diff --git a/backend/cfg/cfg.ml b/backend/cfg/cfg.ml index 8c960a283c1..3df6db282d0 100644 --- a/backend/cfg/cfg.ml +++ b/backend/cfg/cfg.ml @@ -191,10 +191,18 @@ let get_block_exn t label = let can_raise_interproc block = block.can_raise && Option.is_none block.exn -let first_instruction_id (block : basic_block) : int = +type 'a instr_mapper = { f : 'b. 'b instruction -> 'a } [@@unboxed] + +let map_first_instruction (block : basic_block) (t : 'a instr_mapper) = match DLL.hd block.body with - | None -> block.terminator.id - | Some first_instr -> first_instr.id + | None -> t.f block.terminator + | Some first_instr -> t.f first_instr + +let first_instruction_id (block : basic_block) : int = + map_first_instruction block { f = (fun instr -> instr.id) } + +let first_instruction_stack_offset (block : basic_block) : int = + map_first_instruction block { f = (fun instr -> instr.stack_offset) } let fun_name t = t.fun_name @@ -556,3 +564,21 @@ let string_of_irc_work_list = function | Frozen -> "frozen" | Work_list -> "work_list" | Active -> "active" + +let make_instruction ~desc ?(arg = [||]) ?(res = [||]) ?(dbg = Debuginfo.none) + ?(fdo = Fdo_info.none) ?(live = Reg.Set.empty) ~stack_offset ~id + ?(irc_work_list = Unknown_list) ?(ls_order = 0) ?(available_before = None) + ?(available_across = None) () = + { desc; + arg; + res; + dbg; + fdo; + live; + stack_offset; + id; + irc_work_list; + ls_order; + available_before; + available_across + } diff --git a/backend/cfg/cfg.mli b/backend/cfg/cfg.mli index 9a54e4835c8..93d53eb2a6a 100644 --- a/backend/cfg/cfg.mli +++ b/backend/cfg/cfg.mli @@ -123,6 +123,8 @@ val can_raise_interproc : basic_block -> bool val first_instruction_id : basic_block -> int +val first_instruction_stack_offset : basic_block -> int + val mem_block : t -> Label.t -> bool val add_block_exn : t -> basic_block -> unit @@ -185,3 +187,19 @@ val string_of_irc_work_list : irc_work_list -> string val dump_basic : Format.formatter -> basic -> unit val dump_terminator : ?sep:string -> Format.formatter -> terminator -> unit + +val make_instruction : + desc:'a -> + ?arg:Reg.t array -> + ?res:Reg.t array -> + ?dbg:Debuginfo.t -> + ?fdo:Fdo_info.t -> + ?live:Reg.Set.t -> + stack_offset:int -> + id:int -> + ?irc_work_list:irc_work_list -> + ?ls_order:int -> + ?available_before:Reg_availability_set.t option -> + ?available_across:Reg_availability_set.t option -> + unit -> + 'a instruction diff --git a/backend/cfg/cfg_dominators.ml b/backend/cfg/cfg_dominators.ml index 164ac21aa54..53da711cc26 100644 --- a/backend/cfg/cfg_dominators.ml +++ b/backend/cfg/cfg_dominators.ml @@ -21,7 +21,8 @@ type dominator_tree = } type t = - { doms : doms; + { entry_label : Label.t; + doms : doms; dominance_frontiers : dominance_frontiers; dominator_forest : dominator_tree list } @@ -418,7 +419,7 @@ let build : Cfg.t -> t = let doms = compute_doms cfg in let dominance_frontiers = compute_dominance_frontiers cfg doms in let dominator_forest = compute_dominator_forest cfg doms in - { doms; dominance_frontiers; dominator_forest } + { entry_label = cfg.entry_label; doms; dominance_frontiers; dominator_forest } let is_dominating t left right = is_dominating t.doms left right @@ -434,6 +435,18 @@ let find_dominance_frontier t label = let dominator_forest t = t.dominator_forest +let dominator_tree_for_entry_point t = + match + List.find_opt t.dominator_forest ~f:(fun tree -> + Label.equal tree.label t.entry_label) + with + | None -> + fatal + "Cfg_dominators.dominator_tree_for_entry_point: no tree for entry point \ + (label %d)" + t.entry_label + | Some tree -> tree + let iter_breadth_dominator_forest t ~f = List.iter t.dominator_forest ~f:(fun dominator_tree -> iter_breadth_dominator_tree dominator_tree ~f) diff --git a/backend/cfg/cfg_dominators.mli b/backend/cfg/cfg_dominators.mli index f14106d88a3..980d64bc69d 100644 --- a/backend/cfg/cfg_dominators.mli +++ b/backend/cfg/cfg_dominators.mli @@ -1,6 +1,6 @@ [@@@ocaml.warning "+a-4-30-40-41-42"] -(* Dominator-related utility functions. *) +(** Dominator-related utility functions. *) type dominator_tree = private { label : Label.t; @@ -9,29 +9,35 @@ type dominator_tree = private type t -val build : Cfg.t -> t -(* Computes all dominator-related information, in particular immediate +(** Computes all dominator-related information, in particular immediate dominators, dominance frontiers, and dominator forest for the passed CFG. *) +val build : Cfg.t -> t -val is_dominating : t -> Label.t -> Label.t -> bool -(* [is_dominating doms x y] is [true] iff [x] is dominating [y] according to +(** [is_dominating doms x y] is [true] iff [x] is dominating [y] according to [doms]. That is, all paths from the entry node to [y] go through [x]. All edges, regular and exceptional are treated the same way. *) +val is_dominating : t -> Label.t -> Label.t -> bool -val is_strictly_dominating : t -> Label.t -> Label.t -> bool -(* [is_strictly_dominating doms x y] is [true] iff [x] is strictly dominating +(** [is_strictly_dominating doms x y] is [true] iff [x] is strictly dominating [y] according to [doms]. That is, [is_dominating doms x y = true] and [x] is not equal [y]. All edges, regular and exceptional are treated the same way.*) +val is_strictly_dominating : t -> Label.t -> Label.t -> bool -val find_dominance_frontier : t -> Label.t -> Label.Set.t -(* [find_dominance_frontier doms label] returns the dominance frontier for +(** [find_dominance_frontier doms label] returns the dominance frontier for [label] according to [doms]. The definition we use is the following: "the dominance frontier of a node n is the set of all nodes m such that n dominates a predecessor of m, but does not strictly dominate m itself". *) +val find_dominance_frontier : t -> Label.t -> Label.Set.t +(** Returns all dominator trees. Typically one of these will correspond to the + entry point of the program and the remainder to dead code. *) val dominator_forest : t -> dominator_tree list -val iter_breadth_dominator_forest : t -> f:(Label.t -> unit) -> unit -(* [iter_breadth_dominator_forest doms ~f] iterates over the dominator forest +(** Returns the unique dominator tree rooted at the entry point of the program + (thus ignoring any isolated trees that correspond to dead code). *) +val dominator_tree_for_entry_point : t -> dominator_tree + +(** [iter_breadth_dominator_forest doms ~f] iterates over the dominator forest from [doms] in a breadth-first manner (iterating over a whole tree of the forest before moving to the next tree), applying [f] to visited nodes. *) +val iter_breadth_dominator_forest : t -> f:(Label.t -> unit) -> unit diff --git a/backend/cfg/cfg_stack_checks.ml b/backend/cfg/cfg_stack_checks.ml new file mode 100644 index 00000000000..a24d9bb7a08 --- /dev/null +++ b/backend/cfg/cfg_stack_checks.ml @@ -0,0 +1,228 @@ +(****************************************************************************** + * flambda-backend * + * Xavier Clerc and Mark Shinwell, Jane Street * + * -------------------------------------------------------------------------- * + * MIT License * + * * + * Copyright (c) 2024 Jane Street Group LLC * + * opensource-contacts@janestreet.com * + * * + * Permission is hereby granted, free of charge, to any person obtaining a * + * copy of this software and associated documentation files (the "Software"), * + * to deal in the Software without restriction, including without limitation * + * the rights to use, copy, modify, merge, publish, distribute, sublicense, * + * and/or sell copies of the Software, and to permit persons to whom the * + * Software is furnished to do so, subject to the following conditions: * + * * + * The above copyright notice and this permission notice shall be included * + * in all copies or substantial portions of the Software. * + * * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL * + * THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * + * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * + * DEALINGS IN THE SOFTWARE. * + ******************************************************************************) + +[@@@ocaml.warning "+4"] + +open! Int_replace_polymorphic_compare +module DLL = Flambda_backend_utils.Doubly_linked_list + +let is_nontail_call : Cfg.terminator -> bool = + fun term_desc -> + (* CR-soon xclerc for xclerc: reconsider whether this predicate is generic and + well-defined enough to be moved to `Cfg` once the transitive checks are + implemented. *) + match term_desc with + | Call_no_return _ | Call _ -> true + | Never | Always _ | Parity_test _ | Truth_test _ | Float_test _ | Int_test _ + | Switch _ | Return | Raise _ | Tailcall_self _ | Tailcall_func _ | Prim _ -> + false + | Specific_can_raise _ -> + (* Specific operations cannot raise, and hence cannot call OCaml functions; + for the purpose of this check it is thus fine to return `false` even + though a specific operation may call some C code. *) + false + +(* Returns the stack check info, and the max of seen instruction ids. *) +let block_preproc_stack_check_result : + Cfg.basic_block -> + frame_size:int -> + Emitaux.preproc_stack_check_result * int = + fun block ~frame_size -> + let contains_nontail_calls = + (* XCR mshinwell: move to a method in Cfg somewhere? + + xclerc: I have extracted the match to a dedicated function, but I don't + think the predicate is generic enough to be moved to `Cfg`. *) + is_nontail_call block.terminator.desc + in + let max_frame_size, max_instr_id = + DLL.fold_left block.body + ~init:(block.terminator.stack_offset, block.terminator.id) + ~f:(fun (max_stack_frame, max_instr_id) (instr : _ Cfg.instruction) -> + ( Int.max max_stack_frame instr.stack_offset, + Int.max max_instr_id instr.id )) + in + let max_frame_size = max_frame_size + frame_size in + { max_frame_size; contains_nontail_calls }, max_instr_id + +type cfg_info = + { max_frame_size : int; + blocks_needing_stack_checks : Label.Set.t; + max_instr_id : int + } + +let build_cfg_info : Cfg.t -> cfg_info = + fun cfg -> + let frame_required = + Proc.frame_required ~fun_contains_calls:cfg.fun_contains_calls + ~fun_num_stack_slots:cfg.fun_num_stack_slots + in + let frame_size = + Stack_check.frame_size ~stack_offset:0 ~frame_required + ~num_stack_slots:cfg.fun_num_stack_slots + in + let init = + { max_frame_size = 0; + blocks_needing_stack_checks = Label.Set.empty; + max_instr_id = 0 + } + in + Cfg.fold_blocks cfg ~init + ~f:(fun + label + block + { max_frame_size; blocks_needing_stack_checks; max_instr_id } + -> + let preproc_stack_check_result, max_instr_id_block = + block_preproc_stack_check_result block ~frame_size + in + let block_needs_stack_checks = + preproc_stack_check_result.contains_nontail_calls + || preproc_stack_check_result.max_frame_size + >= Stack_check.stack_threshold_size + in + let max_frame_size = + Int.max max_frame_size preproc_stack_check_result.max_frame_size + in + let blocks_needing_stack_checks = + if block_needs_stack_checks + then Label.Set.add label blocks_needing_stack_checks + else blocks_needing_stack_checks + in + let max_instr_id = Int.max max_instr_id max_instr_id_block in + { max_frame_size; blocks_needing_stack_checks; max_instr_id }) + +(* Populates `num_checks` with the number of blocks needing a stack check in the + subtree whose root is the associated label, and returns that value. *) +let rec num_checks_tree : + Cfg_dominators.dominator_tree -> + blocks_needing_stack_checks:Label.Set.t -> + num_checks:int Label.Tbl.t -> + int = + fun tree ~blocks_needing_stack_checks ~num_checks -> + let num_for_root : int = + if Label.Set.mem tree.label blocks_needing_stack_checks then 1 else 0 + in + let num_for_children : int = + List.fold_left + (fun acc child -> + acc + num_checks_tree child ~blocks_needing_stack_checks ~num_checks) + 0 tree.children + in + let res = num_for_root + num_for_children in + Label.Tbl.replace num_checks tree.label res; + res + +(* Determines which block should have the stack check. `num_checks` contains for + each label the number of blocks needing the check in the subtree; `to_cover` + is the number of blocks needing the check at the entry point. We recursively + choose the child whose `num_checks` is equal to `to_cover`, if it exists. *) +let rec find_stack_check_block : + Cfg_dominators.dominator_tree -> + to_cover:int -> + num_checks:int Label.Tbl.t -> + loop_infos:Cfg_loop_infos.t Lazy.t -> + Label.t = + fun tree ~to_cover ~num_checks ~loop_infos -> + assert (to_cover = Label.Tbl.find num_checks tree.label); + (* Either: + * to_cover = num_checks_child0 + ... + num_checks_childN + * or (in the case where the current root block needs a stack check): + * to_cover = 1 + num_checks_child0 + ... + num_checks_childN + * This allows us to work out whether to put a stack check before the + * current root block, or before exactly one of the children. + *) + let candidates = + List.filter + (fun (child : Cfg_dominators.dominator_tree) -> + to_cover = Label.Tbl.find num_checks child.label) + tree.children + in + match candidates with + | [] -> tree.label + | [candidate] -> + (* Never push a stack check into a loop. *) + let candidate_is_in_a_loop = + Label.Map.find candidate.label (Lazy.force loop_infos).loop_depths > 0 + in + if candidate_is_in_a_loop + then tree.label + else find_stack_check_block candidate ~to_cover ~num_checks ~loop_infos + | _ :: _ :: _ -> + Misc.fatal_errorf + "More than one child has num_checks = %d (= to_cover), maybe a bug in \ + num_checks_tree" + to_cover + +let insert_stack_checks (cfg : Cfg.t) ~max_frame_size + ~blocks_needing_stack_checks ~max_instr_id = + (* CR-soon xclerc for xclerc: use the dominators and loop infos from + Cfg_with_infos (at least on some paths). *) + let doms = Cfg_dominators.build cfg in + let loop_infos = lazy (Cfg_loop_infos.build cfg doms) in + (* note: the other entries in the forest are dead code *) + let tree = Cfg_dominators.dominator_tree_for_entry_point doms in + let num_checks = Label.Tbl.create (Label.Tbl.length cfg.blocks) in + let num_checks_root = + num_checks_tree tree ~blocks_needing_stack_checks ~num_checks + in + match num_checks_root with + | 0 -> () + | to_cover -> + let label = find_stack_check_block tree ~to_cover ~num_checks ~loop_infos in + let block = Cfg.get_block_exn cfg label in + let stack_offset = Cfg.first_instruction_stack_offset block in + let check : Cfg.basic Cfg.instruction = + (* CR xclerc for xclerc: double check `available_before` and + `available_across`. + + mshinwell: having these as None should be fine, so long as this is run + before the forthcoming Cfg_available_regs (which it probably should + be)? + + xclerc: (keeping the comment, and the explicit values below until all + of that is implemented.) *) + Cfg.make_instruction () + ~desc:(Cfg.Stack_check { max_frame_size_bytes = max_frame_size }) + ~stack_offset ~id:(succ max_instr_id) ~available_before:None + ~available_across:None + in + DLL.add_begin block.body check + +(* CR-someday xclerc for xclerc: we may want to duplicate the check in some + cases, rather than simply pushing it down. *) +let cfg (cfg_with_layout : Cfg_with_layout.t) = + let cfg = Cfg_with_layout.cfg cfg_with_layout in + let { max_frame_size; blocks_needing_stack_checks; max_instr_id } = + build_cfg_info cfg + in + if not (Label.Set.is_empty blocks_needing_stack_checks) + then + insert_stack_checks cfg ~max_frame_size ~blocks_needing_stack_checks + ~max_instr_id; + cfg_with_layout diff --git a/backend/cfg/cfg_stack_checks.mli b/backend/cfg/cfg_stack_checks.mli new file mode 100644 index 00000000000..674173b3bb5 --- /dev/null +++ b/backend/cfg/cfg_stack_checks.mli @@ -0,0 +1,29 @@ +(****************************************************************************** + * flambda-backend * + * Xavier Clerc and Mark Shinwell, Jane Street * + * -------------------------------------------------------------------------- * + * MIT License * + * * + * Copyright (c) 2024 Jane Street Group LLC * + * opensource-contacts@janestreet.com * + * * + * Permission is hereby granted, free of charge, to any person obtaining a * + * copy of this software and associated documentation files (the "Software"), * + * to deal in the Software without restriction, including without limitation * + * the rights to use, copy, modify, merge, publish, distribute, sublicense, * + * and/or sell copies of the Software, and to permit persons to whom the * + * Software is furnished to do so, subject to the following conditions: * + * * + * The above copyright notice and this permission notice shall be included * + * in all copies or substantial portions of the Software. * + * * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL * + * THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * + * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER * + * DEALINGS IN THE SOFTWARE. * + ******************************************************************************) + +val cfg : Cfg_with_layout.t -> Cfg_with_layout.t diff --git a/driver/flambda_backend_args.ml b/driver/flambda_backend_args.ml index 30160ed08da..8140d5f4f79 100644 --- a/driver/flambda_backend_args.ml +++ b/driver/flambda_backend_args.ml @@ -63,6 +63,12 @@ let mk_cfg_cse_optimize f = let mk_no_cfg_cse_optimize f = "-no-cfg-cse-optimize", Arg.Unit f, " Do not apply CSE optimizations to CFG" +let mk_cfg_stack_checks f = + "-cfg-stack-checks", Arg.Unit f, " Insert the stack checks on the CFG representation" + +let mk_no_cfg_stack_checks f = + "-no-cfg-stack-checks", Arg.Unit f, " Insert the stack checks on the linear representation" + let mk_reorder_blocks_random f = "-reorder-blocks-random", Arg.Int f, @@ -637,6 +643,9 @@ module type Flambda_backend_options = sig val cfg_cse_optimize : unit -> unit val no_cfg_cse_optimize : unit -> unit + val cfg_stack_checks : unit -> unit + val no_cfg_stack_checks : unit -> unit + val reorder_blocks_random : int -> unit val basic_block_sections : unit -> unit @@ -752,6 +761,9 @@ struct mk_cfg_cse_optimize F.cfg_cse_optimize; mk_no_cfg_cse_optimize F.no_cfg_cse_optimize; + mk_cfg_stack_checks F.cfg_stack_checks; + mk_no_cfg_stack_checks F.no_cfg_stack_checks; + mk_reorder_blocks_random F.reorder_blocks_random; mk_basic_block_sections F.basic_block_sections; @@ -896,6 +908,9 @@ module Flambda_backend_options_impl = struct let cfg_cse_optimize = set' Flambda_backend_flags.cfg_cse_optimize let no_cfg_cse_optimize = clear' Flambda_backend_flags.cfg_cse_optimize + let cfg_stack_checks = set' Flambda_backend_flags.cfg_stack_checks + let no_cfg_stack_checks = clear' Flambda_backend_flags.cfg_stack_checks + let reorder_blocks_random seed = Flambda_backend_flags.reorder_blocks_random := Some seed let basic_block_sections () = @@ -1189,6 +1204,7 @@ module Extra_params = struct | "regalloc-validate" -> set' Flambda_backend_flags.regalloc_validate | "cfg-peephole-optimize" -> set' Flambda_backend_flags.cfg_peephole_optimize | "cfg-cse-optimize" -> set' Flambda_backend_flags.cfg_cse_optimize + | "cfg-stack-checks" -> set' Flambda_backend_flags.cfg_stack_checks | "dump-inlining-paths" -> set' Flambda_backend_flags.dump_inlining_paths | "davail" -> set' Flambda_backend_flags.davail | "dranges" -> set' Flambda_backend_flags.dranges diff --git a/driver/flambda_backend_args.mli b/driver/flambda_backend_args.mli index d1af133a252..84d74ac6cb1 100644 --- a/driver/flambda_backend_args.mli +++ b/driver/flambda_backend_args.mli @@ -40,6 +40,9 @@ module type Flambda_backend_options = sig val cfg_cse_optimize : unit -> unit val no_cfg_cse_optimize : unit -> unit + val cfg_stack_checks : unit -> unit + val no_cfg_stack_checks : unit -> unit + val reorder_blocks_random : int -> unit val basic_block_sections : unit -> unit diff --git a/driver/flambda_backend_flags.ml b/driver/flambda_backend_flags.ml index a4c487337db..92c4bafd35a 100644 --- a/driver/flambda_backend_flags.ml +++ b/driver/flambda_backend_flags.ml @@ -25,6 +25,8 @@ let cfg_peephole_optimize = ref true (* -[no-]cfg-peephole-optimize *) let cfg_cse_optimize = ref false (* -[no-]cfg-cse-optimize *) +let cfg_stack_checks = ref false (* -[no-]cfg-stack-check *) + let reorder_blocks_random = ref None (* -reorder-blocks-random seed *) let basic_block_sections = ref false (* -basic-block-sections *) diff --git a/driver/flambda_backend_flags.mli b/driver/flambda_backend_flags.mli index 4598247c30d..6877de6d320 100644 --- a/driver/flambda_backend_flags.mli +++ b/driver/flambda_backend_flags.mli @@ -26,6 +26,8 @@ val cfg_peephole_optimize: bool ref val cfg_cse_optimize: bool ref +val cfg_stack_checks : bool ref + val reorder_blocks_random : int option ref val basic_block_sections : bool ref diff --git a/dune b/dune index 51c625d6f5f..ca04cd65a5a 100755 --- a/dune +++ b/dune @@ -159,6 +159,7 @@ cfg_loop_infos cfg_to_linear_desc cfg_cse + cfg_stack_checks eliminate_dead_code disconnect_block eliminate_dead_blocks