diff --git a/backend/.ocamlformat-enable b/backend/.ocamlformat-enable index 9ba5a29f0ab..209f7c7f2d5 100644 --- a/backend/.ocamlformat-enable +++ b/backend/.ocamlformat-enable @@ -2,8 +2,8 @@ cmm_helpers.ml cmm_helpers.mli cmm_builtins.ml cmm_builtins.mli -checks.ml -checks.mli +zero_alloc_info.ml +zero_alloc_info.mli zero_alloc_checker.ml zero_alloc_checker.mli cfg/**/*.ml diff --git a/backend/asmpackager.ml b/backend/asmpackager.ml index 7ee5a19bcf2..7edf5329edf 100644 --- a/backend/asmpackager.ml +++ b/backend/asmpackager.ml @@ -180,8 +180,9 @@ let build_package_cmx members cmxfile = ui.ui_export_info units in - let ui_checks = Checks.create () in - List.iter (fun info -> Checks.merge info.ui_checks ~into:ui_checks) units; + let ui_zero_alloc_info = Zero_alloc_info.create () in + List.iter (fun info -> Zero_alloc_info.merge info.ui_zero_alloc_info + ~into:ui_zero_alloc_info) units; let modname = Compilation_unit.name ui.ui_unit in let pkg_infos = { ui_unit = ui.ui_unit; @@ -204,7 +205,7 @@ let build_package_cmx members cmxfile = ui_force_link = List.exists (fun info -> info.ui_force_link) units; ui_export_info; - ui_checks; + ui_zero_alloc_info; ui_external_symbols = union (List.map (fun info -> info.ui_external_symbols) units); } in Compilenv.write_unit_info pkg_infos cmxfile diff --git a/backend/checks.ml b/backend/checks.ml deleted file mode 100644 index 39599530dd8..00000000000 --- a/backend/checks.ml +++ /dev/null @@ -1,66 +0,0 @@ -module String = Misc.Stdlib.String - -(* CR gyorsh: Add [t] per analysis when at least one more analysis is - implemented *) -type t = - { mutable zero_alloc : int String.Map.t; - mutable enabled : bool - } - -let create () = { zero_alloc = String.Map.empty; enabled = false } - -let reset t = - t.zero_alloc <- String.Map.empty; - t.enabled <- false - -let merge src ~into:dst = - let join key b1 b2 = - Misc.fatal_errorf "Unexpected merge %s %d %d" key b1 b2 - in - dst.zero_alloc <- String.Map.union join dst.zero_alloc src.zero_alloc; - dst.enabled <- dst.enabled || src.enabled - -type value = int option - -let get_value (t : t) s : value = String.Map.find_opt s t.zero_alloc - -let get_value (t : t) s : value option = - match t.enabled with false -> None | true -> Some (get_value t s) - -let set_value (t : t) s (v : value) = - let f new_ old = - if not (Option.is_none old) - then Misc.fatal_errorf "Value of %s is already set" s; - new_ - in - t.zero_alloc <- String.Map.update s (f v) t.zero_alloc; - t.enabled <- true - -module Raw = struct - type entries = (string * int) list - - type r = { zero_alloc : entries } - - type t = r option - - let entries_to_map (e : entries) = - List.fold_left (fun acc (k, v) -> String.Map.add k v acc) String.Map.empty e - - let print t = - let print (name, v) = Printf.printf "\t\t%s = %#x\n" name v in - (* CR gyorsh: move encode/decode here somehow for noalloc *) - Printf.printf "Function summaries for static checks:\n"; - List.iter print t.zero_alloc - - let print = function None -> () | Some t -> print t -end - -let to_raw (t : t) : Raw.r = { zero_alloc = String.Map.bindings t.zero_alloc } - -let to_raw (t : t) : Raw.t = - match t.enabled with false -> None | true -> Some (to_raw t) - -let of_raw (t : Raw.t) : t = - match t with - | None -> create () - | Some t -> { zero_alloc = Raw.entries_to_map t.zero_alloc; enabled = true } diff --git a/backend/checks.mli b/backend/checks.mli deleted file mode 100644 index 53a8e0337b1..00000000000 --- a/backend/checks.mli +++ /dev/null @@ -1,28 +0,0 @@ -(** Symbols of function that pass certain checks for special properties. *) - -type value = int option - -type t - -val create : unit -> t - -val reset : t -> unit - -(** [merge_checks c ~into] modifies [into] by adding - information from [src]. *) -val merge : t -> into:t -> unit - -(** [get_value t] returns None if checks are not enabled *) -val get_value : t -> string -> value option - -val set_value : t -> string -> value -> unit - -module Raw : sig - type t - - val print : t -> unit -end - -val to_raw : t -> Raw.t - -val of_raw : Raw.t -> t diff --git a/backend/zero_alloc_checker.ml b/backend/zero_alloc_checker.ml index 346871b8f65..13225b02389 100644 --- a/backend/zero_alloc_checker.ml +++ b/backend/zero_alloc_checker.ml @@ -1850,10 +1850,10 @@ module Compilenv_utils : sig (** [set_value f v] records the value of the function named [f] in [Compilenv]. *) val set_value : string -> Value.t -> unit end = struct - (* Compact the mapping from function name to Value.t to reduce size of Checks - in cmx and memory consumption Compilenv. Different components have - different frequencies of Top/Bot. The most likely value is encoded as None - (i.e., not stored). *) + (* Compact the mapping from function name to Value.t to reduce size of + Zero_alloc_info in cmx and memory consumption Compilenv. Different + components have different frequencies of Top/Bot. The most likely value is + encoded as None (i.e., not stored). *) let encode (v : V.t) = V.match_with v ~top:(fun _ -> 0) @@ -1872,11 +1872,11 @@ end = struct | 2 -> V.bot | n -> Misc.fatal_errorf "Zero_alloc_checker cannot decode %d" n - let encode (v : Value.t) : Checks.value = + let encode (v : Value.t) : Zero_alloc_info.value option = let c = (encode v.div lsl 4) lor (encode v.exn lsl 2) lor encode v.nor in if c = 0 then None else Some c - let decode : Checks.value -> Value.t = function + let decode : Zero_alloc_info.value option -> Value.t = function | None -> Value.top decoded_witness | Some d -> if d = 0 then Misc.fatal_error "Zero_alloc_checker unexpected 0 encoding"; @@ -1886,14 +1886,14 @@ end = struct { nor; exn; div } let set_value s (v : Value.t) = - let checks = (Compilenv.current_unit_infos ()).ui_checks in - Checks.set_value checks s (encode v) + let info = (Compilenv.current_unit_infos ()).ui_zero_alloc_info in + match encode v with + | None -> () + | Some i -> Zero_alloc_info.set_value info s i let get_value_opt s = - let checks = Compilenv.cached_checks in - match Checks.get_value checks s with - | None -> None - | Some (c : Checks.value) -> Some (decode c) + let info = Compilenv.cached_zero_alloc_info in + Some (decode (Zero_alloc_info.get_value info s)) end (** The analysis involved some fixed point computations. @@ -2485,7 +2485,8 @@ let reset_unit_info () = let record_unit_info ppf_dump = Analysis.record_unit unit_info unresolved_deps ppf_dump; - Compilenv.cache_checks (Compilenv.current_unit_infos ()).ui_checks + Compilenv.cache_zero_alloc_info + (Compilenv.current_unit_infos ()).ui_zero_alloc_info type iter_witnesses = (string -> Witnesses.components -> unit) -> unit diff --git a/backend/zero_alloc_info.ml b/backend/zero_alloc_info.ml new file mode 100644 index 00000000000..9b0755c075d --- /dev/null +++ b/backend/zero_alloc_info.ml @@ -0,0 +1,52 @@ +module String = Misc.Stdlib.String + +type t = { mutable zero_alloc : int String.Map.t } + +let create () = { zero_alloc = String.Map.empty } + +let reset t = t.zero_alloc <- String.Map.empty + +let merge src ~into:dst = + let join key b1 b2 = + Misc.fatal_errorf "Unexpected merge %s %d %d" key b1 b2 + in + dst.zero_alloc <- String.Map.union join dst.zero_alloc src.zero_alloc + +type value = int + +let get_value (t : t) s = String.Map.find_opt s t.zero_alloc + +let set_value (t : t) s (v : value) = + let f new_ old = + if not (Option.is_none old) + then Misc.fatal_errorf "Value of %s is already set" s; + Some new_ + in + t.zero_alloc <- String.Map.update s (f v) t.zero_alloc + +module Raw = struct + type entries = (string * int) list + + type t = entries option + + let entries_to_map (e : entries) = + List.fold_left (fun acc (k, v) -> String.Map.add k v acc) String.Map.empty e + + let print t = + let print (name, v) = Printf.printf "\t\t%s = %#x\n" name v in + (* CR gyorsh: move encode/decode here somehow for noalloc *) + Printf.printf "Function summaries for static checks:\n"; + List.iter print t + + let print = function None -> () | Some t -> print t +end + +let to_raw (t : t) : Raw.t = + if String.Map.is_empty t.zero_alloc + then None + else Some (String.Map.bindings t.zero_alloc) + +let of_raw (t : Raw.t) : t = + match t with + | None -> create () + | Some t -> { zero_alloc = Raw.entries_to_map t } diff --git a/backend/zero_alloc_info.mli b/backend/zero_alloc_info.mli new file mode 100644 index 00000000000..c88b9ebbe3b --- /dev/null +++ b/backend/zero_alloc_info.mli @@ -0,0 +1,29 @@ +(** Function summaries computed by zero_alloc analysis + and encoded as integers for storing in .cmx files. *) + +type value = int + +type t + +val create : unit -> t + +val reset : t -> unit + +(** [merge_checks t ~into] modifies [into] by adding information from [t]. *) +val merge : t -> into:t -> unit + +(** [get_value t fun_name] returns None if [fun_name] is not associated + with any value. *) +val get_value : t -> string -> value option + +val set_value : t -> string -> value -> unit + +module Raw : sig + type t + + val print : t -> unit +end + +val to_raw : t -> Raw.t + +val of_raw : Raw.t -> t diff --git a/dune b/dune index 8fe96af0a53..fdd63dc4b20 100755 --- a/dune +++ b/dune @@ -86,7 +86,6 @@ branch_relaxation branch_relaxation_intf cfgize - checks cmm_helpers cmm_builtins cmm_invariants @@ -145,6 +144,7 @@ x86_masm x86_proc zero_alloc_checker + zero_alloc_info ;; asmcomp/cfg cfg cfg_intf diff --git a/file_formats/cmx_format.mli b/file_formats/cmx_format.mli index 67965ff76d9..9b385e19914 100644 --- a/file_formats/cmx_format.mli +++ b/file_formats/cmx_format.mli @@ -55,7 +55,7 @@ type unit_infos = (* Infos imported *) mutable ui_generic_fns: generic_fns; (* Generic functions needed *) mutable ui_export_info: Flambda2_cmx.Flambda_cmx_format.t option; - mutable ui_checks: Checks.t; + mutable ui_zero_alloc_info: Zero_alloc_info.t; mutable ui_force_link: bool; (* Always linked *) mutable ui_external_symbols: string list; (* Set of external symbols *) } @@ -67,7 +67,7 @@ type unit_infos_raw = uir_imports_cmx: Import_info.t array; uir_generic_fns: generic_fns; uir_export_info: Flambda2_cmx.Flambda_cmx_format.raw option; - uir_checks: Checks.Raw.t; + uir_zero_alloc_info: Zero_alloc_info.Raw.t; uir_force_link: bool; uir_section_toc: int array; (* Byte offsets of sections in .cmx relative to byte immediately after diff --git a/middle_end/compilenv.ml b/middle_end/compilenv.ml index 082ae865483..18bac2da84b 100644 --- a/middle_end/compilenv.ml +++ b/middle_end/compilenv.ml @@ -45,9 +45,9 @@ module String = Misc.Stdlib.String let exported_constants = Hashtbl.create 17 -let cached_checks = Checks.create () +let cached_zero_alloc_info = Zero_alloc_info.create () -let cache_checks c = Checks.merge c ~into:cached_checks +let cache_zero_alloc_info c = Zero_alloc_info.merge c ~into:cached_zero_alloc_info let current_unit = { ui_unit = CU.dummy; @@ -56,14 +56,14 @@ let current_unit = ui_imports_cmx = []; ui_generic_fns = { curry_fun = []; apply_fun = []; send_fun = [] }; ui_force_link = false; - ui_checks = Checks.create (); + ui_zero_alloc_info = Zero_alloc_info.create (); ui_export_info = None; ui_external_symbols = []; } let reset compilation_unit = CU.Name.Tbl.clear global_infos_table; - Checks.reset cached_checks; + Zero_alloc_info.reset cached_zero_alloc_info; CU.set_current (Some compilation_unit); current_unit.ui_unit <- compilation_unit; current_unit.ui_defines <- [compilation_unit]; @@ -72,7 +72,7 @@ let reset compilation_unit = current_unit.ui_generic_fns <- { curry_fun = []; apply_fun = []; send_fun = [] }; current_unit.ui_force_link <- !Clflags.link_everything; - Checks.reset current_unit.ui_checks; + Zero_alloc_info.reset current_unit.ui_zero_alloc_info; Hashtbl.clear exported_constants; current_unit.ui_export_info <- None; current_unit.ui_external_symbols <- [] @@ -111,7 +111,7 @@ let read_unit_info filename = ui_imports_cmx = uir.uir_imports_cmx |> Array.to_list; ui_generic_fns = uir.uir_generic_fns; ui_export_info = export_info; - ui_checks = Checks.of_raw uir.uir_checks; + ui_zero_alloc_info = Zero_alloc_info.of_raw uir.uir_zero_alloc_info; ui_force_link = uir.uir_force_link; ui_external_symbols = uir.uir_external_symbols |> Array.to_list; } @@ -157,7 +157,7 @@ let get_unit_info comp_unit = let (ui, crc) = read_unit_info filename in if not (CU.equal ui.ui_unit comp_unit) then raise(Error(Illegal_renaming(comp_unit, ui.ui_unit, filename))); - cache_checks ui.ui_checks; + cache_zero_alloc_info ui.ui_zero_alloc_info; (Some ui, Some crc) with Not_found -> let warn = Warnings.No_cmx_file (cmx_name |> CU.Name.to_string) in @@ -188,7 +188,7 @@ let get_global_export_info id = | Some ui -> ui.ui_export_info let cache_unit_info ui = - cache_checks ui.ui_checks; + cache_zero_alloc_info ui.ui_zero_alloc_info; CU.Name.Tbl.add global_infos_table (CU.name ui.ui_unit) (Some ui) (* Exporting cross-module information *) @@ -257,7 +257,7 @@ let write_unit_info info filename = uir_imports_cmx = Array.of_list info.ui_imports_cmx; uir_generic_fns = info.ui_generic_fns; uir_export_info = raw_export_info; - uir_checks = Checks.to_raw info.ui_checks; + uir_zero_alloc_info = Zero_alloc_info.to_raw info.ui_zero_alloc_info; uir_force_link = info.ui_force_link; uir_section_toc = toc; uir_sections_length = total_length; diff --git a/middle_end/compilenv.mli b/middle_end/compilenv.mli index fef913f7375..6e8c2492c97 100644 --- a/middle_end/compilenv.mli +++ b/middle_end/compilenv.mli @@ -50,12 +50,12 @@ val need_send_fun: (* Record the need of a currying (resp. application, message sending) function with the given arity *) -val cached_checks : Checks.t +val cached_zero_alloc_info : Zero_alloc_info.t (* Return cached information about functions (from other complication units) that satisfy certain properties. *) -val cache_checks : Checks.t -> unit - (* [cache_checks c] adds [c] to [cached_checks] *) +val cache_zero_alloc_info : Zero_alloc_info.t -> unit + (* [cache_zero_alloc_info c] adds [c] to [cached_zero_alloc_info] *) val new_const_symbol : unit -> string diff --git a/tools/flambda_backend_objinfo.ml b/tools/flambda_backend_objinfo.ml index f40d7cb3eb4..602a55fcbde 100644 --- a/tools/flambda_backend_objinfo.ml +++ b/tools/flambda_backend_objinfo.ml @@ -264,7 +264,7 @@ let print_cmx_infos (uir, sections, crc) = end; print_generic_fns uir.uir_generic_fns; printf "Force link: %s\n" (if uir.uir_force_link then "YES" else "no"); - Checks.Raw.print uir.uir_checks + Zero_alloc_info.Raw.print uir.uir_zero_alloc_info let print_cmxa_infos (lib : Cmx_format.library_infos) = printf "Extra C object files:";