From 6280bd4d0eda772031eb62df94eaeadd82e3e30c Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Wed, 28 Apr 2021 12:48:08 +0100 Subject: [PATCH 1/2] Remove dune compute Signed-off-by: Jeremie Dimino --- CHANGES.md | 3 + bin/compute.ml | 82 -------------- bin/compute.mli | 1 - bin/internal.ml | 11 +- bin/main.ml | 1 - doc/dune.inc | 9 -- doc/test/run.t | 2 +- src/dune_engine/build_system.ml | 24 ++--- src/dune_engine/fs_memo.ml | 3 +- src/dune_engine/source_tree.ml | 7 +- src/dune_engine/vcs.ml | 22 +--- src/dune_rules/context.ml | 12 +-- src/dune_rules/dir_contents.ml | 2 +- src/dune_rules/dir_status.ml | 3 +- src/dune_rules/fdo.ml | 16 +-- src/dune_rules/install_rules.ml | 11 +- src/dune_rules/odoc.ml | 10 +- src/dune_rules/packages.ml | 3 +- src/dune_rules/workspace.ml | 3 +- src/memo/memo.ml | 137 ++++-------------------- src/memo/memo.mli | 33 +----- test/expect-tests/memo/memoize_tests.ml | 44 ++------ 22 files changed, 84 insertions(+), 355 deletions(-) delete mode 100644 bin/compute.ml delete mode 100644 bin/compute.mli diff --git a/CHANGES.md b/CHANGES.md index ff68ca2ec03..3b9d81cf1cc 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -131,6 +131,9 @@ Unreleased way to rerun all actions failed due to errors without restarting the build, e.g. via a Dune RPC call. (#4522, Andrey Mokhov) +- Remove `dune compute`. It was broken and unused (#...., + @jeremiedimino) + 2.9.0 (unreleased) ------------------ diff --git a/bin/compute.ml b/bin/compute.ml deleted file mode 100644 index e0a42df8b89..00000000000 --- a/bin/compute.ml +++ /dev/null @@ -1,82 +0,0 @@ -open Stdune -open Import - -let doc = "Compute internal function." - -let man = - [ `S "DESCRIPTION" - ; `P - {|Run a registered memoize function with the given input and - print the output. |} - ; `P {|This should only be used for debugging dune.|} - ; `Blocks Common.help_secs - ] - -let info = Term.info "compute" ~doc ~man - -let term = - Term.ret - @@ let+ common = Common.term - and+ fn = - Arg.( - required - & pos 0 (some string) None - & info [] ~docv:"FUNCTION" ~doc:"Compute $(docv) for a given input.") - and+ inp = - Arg.( - value - & pos 1 (some string) None - & info [] ~docv:"INPUT" - ~doc:"Use $(docv) as the input to the function.") - in - let config = Common.init common in - let action = - Scheduler.go ~common ~config (fun () -> - let open Fiber.O in - let* _setup = Import.Main.setup () in - match (fn, inp) with - | "latest-lang-version", None -> - Fiber.return - (`Result - (Dyn.String - (Dune_lang.Syntax.greatest_supported_version - Dune_engine.Stanza.syntax - |> Dune_lang.Syntax.Version.to_string))) - | "list", None -> Fiber.return `List - | "list", Some _ -> - Fiber.return (`Error "'list' doesn't take an argument") - | "help", Some fn -> Fiber.return (`Show_doc fn) - | fn, Some inp -> - let sexp = - Dune_lang.Parser.parse_string ~fname:"" - ~mode:Dune_lang.Parser.Mode.Single inp - in - let+ res = Memo.Build.run (Memo.call fn sexp) in - `Result res - | fn, None -> - Fiber.return (`Error (sprintf "argument missing for '%s'" fn))) - in - match action with - | `Error msg -> `Error (true, msg) - | `Result res -> - Ansi_color.print (Dyn.pp res); - print_newline (); - `Ok () - | `List -> - let fns = Memo.registered_functions () in - let longest = - String.longest_map fns ~f:(fun info -> info.Memo.Info.name) - in - List.iter fns ~f:(fun { Memo.Info.name; doc } -> - Printf.printf "%-*s" longest name; - Option.iter doc ~f:(Printf.printf ": %s"); - Printf.printf "\n"); - flush stdout; - `Ok () - | `Show_doc name -> - let info = Memo.function_info ~name in - Printf.printf "%s\n%s\n" name (String.make (String.length name) '='); - Option.iter info.doc ~f:(Printf.printf "%s\n"); - `Ok () - -let command = (term, info) diff --git a/bin/compute.mli b/bin/compute.mli deleted file mode 100644 index 6d988967f3a..00000000000 --- a/bin/compute.mli +++ /dev/null @@ -1 +0,0 @@ -val command : unit Cmdliner.Term.t * Cmdliner.Term.info diff --git a/bin/internal.ml b/bin/internal.ml index 75c3f5b3272..a3b6fded5f1 100644 --- a/bin/internal.ml +++ b/bin/internal.ml @@ -1,4 +1,13 @@ open Import +let latest_lang_version = + ( (let+ () = Term.const () in + print_endline + (Dune_lang.Syntax.greatest_supported_version Dune_engine.Stanza.syntax + |> Dune_lang.Syntax.Version.to_string)) + , Term.info "latest-lang-version" ) + let group = - (Term.Group.Group [ in_group Internal_dump.command ], Term.info "internal") + ( Term.Group.Group + [ in_group Internal_dump.command; in_group latest_lang_version ] + , Term.info "internal" ) diff --git a/bin/main.ml b/bin/main.ml index 3c74170cd7f..a2e48196f5f 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -20,7 +20,6 @@ let all : _ Term.Group.t list = ; Printenv.command ; Help.command ; Format_dune_file.command - ; Compute.command ; Upgrade.command ; Cache.command ; Describe.command diff --git a/doc/dune.inc b/doc/dune.inc index 79bcaa4c338..6f508fd3c55 100644 --- a/doc/dune.inc +++ b/doc/dune.inc @@ -26,15 +26,6 @@ (package dune) (files dune-clean.1)) -(rule - (with-stdout-to dune-compute.1 - (run dune compute --help=groff))) - -(install - (section man) - (package dune) - (files dune-compute.1)) - (rule (with-stdout-to dune-describe.1 (run dune describe --help=groff))) diff --git a/doc/test/run.t b/doc/test/run.t index 32554d0e474..d883d6be638 100644 --- a/doc/test/run.t +++ b/doc/test/run.t @@ -6,7 +6,7 @@ When changing Dune version, you need to update the docs too to make this test pa Occasionally we do want to mention an older Dune version in documentation. This is fine, but you then need to update the list of such exceptions below. - $ DUNE_LANG=$(dune compute latest-lang-version | sed 's/"//g') + $ DUNE_LANG=$(dune internal latest-lang-version) $ grep '(lang dune' ../*.rst | grep -v "$DUNE_LANG" ../formatting.rst:If using ``(lang dune 2.0)``, there is nothing to setup in dune, formatting will ../formatting.rst:.. note:: This section applies only to projects with ``(lang dune 1.x)``. diff --git a/src/dune_engine/build_system.ml b/src/dune_engine/build_system.ml index e40e8009e82..a61fdd26278 100644 --- a/src/dune_engine/build_system.ml +++ b/src/dune_engine/build_system.ml @@ -12,10 +12,9 @@ module Fs : sig val assert_exists : loc:Loc.t -> Path.t -> unit Memo.Build.t end = struct let mkdir_p_def = - Memo.create "mkdir_p" ~doc:"mkdir_p" + Memo.create "mkdir_p" ~input:(module Path.Build) ~output:(Simple (module Unit)) - ~visibility:Hidden (fun p -> Path.mkdir_p (Path.build p); Memo.Build.return ()) @@ -23,10 +22,9 @@ end = struct let mkdir_p = Memo.exec mkdir_p_def let assert_exists_def = - Memo.create "assert_path_exists" ~doc:"Path.exists" + Memo.create "assert_path_exists" ~input:(module Path) ~output:(Simple (module Bool)) - ~visibility:Hidden (fun p -> Memo.Build.return (Path.exists p)) let assert_exists ~loc path = @@ -1139,9 +1137,7 @@ end = struct let load_dir = let load_dir_impl dir = load_dir_impl (t ()) ~dir in let memo = - Memo.create_hidden "load-dir" ~doc:"load dir" - ~input:(module Path) - load_dir_impl + Memo.create_hidden "load-dir" ~input:(module Path) load_dir_impl in fun ~dir -> Memo.exec memo dir end @@ -2064,36 +2060,34 @@ end = struct |> Path.Set.of_list let eval_memo = - Memo.create "eval-pred" ~doc:"Evaluate a predicate in a directory" + Memo.create "eval-pred" ~input:(module File_selector) ~output:(Allow_cutoff (module Path.Set)) - ~visibility:Hidden eval_impl + eval_impl let eval = Memo.exec eval_memo let build = Memo.exec - (Memo.create "build-pred" ~doc:"build a predicate" + (Memo.create "build-pred" ~input:(module File_selector) ~output:(Allow_cutoff (module Dep.Fact.Files)) - ~visibility:Hidden build_impl) + build_impl) end let build_file_memo = Memo.create "build-file" ~output:(Allow_cutoff (module Digest)) - ~doc:"Build a file." ~input:(module Path) - ~visibility:Hidden build_file_impl + build_file_impl let build_file = Memo.exec build_file_memo let build_alias_memo = Memo.create "build-alias" ~output:(Allow_cutoff (module Dep.Fact.Files)) - ~doc:"Build an alias." ~input:(module Alias) - ~visibility:Hidden build_alias_impl + build_alias_impl let build_alias = Memo.exec build_alias_memo diff --git a/src/dune_engine/fs_memo.ml b/src/dune_engine/fs_memo.ml index e65e5aa95c6..66817c2c876 100644 --- a/src/dune_engine/fs_memo.ml +++ b/src/dune_engine/fs_memo.ml @@ -5,10 +5,9 @@ open Memo.Build.O (* Files and directories have non-overlapping sets of paths, so we can track them using the same memoization table. *) let memo = - Memo.create "fs_memo" ~doc:"tracking files and directories on the file system" + Memo.create "fs_memo" ~input:(module Path) ~output:(Simple (module Unit)) - ~visibility:Hidden (fun _path -> Memo.Build.return ()) (* Declare a dependency on a path. Instead of calling [depend] directly, you diff --git a/src/dune_engine/source_tree.ml b/src/dune_engine/source_tree.ml index 036a620bcf2..b8cef6137f1 100644 --- a/src/dune_engine/source_tree.ml +++ b/src/dune_engine/source_tree.ml @@ -614,10 +614,10 @@ end = struct option (Output.to_dyn Dir0.to_dyn) end in let memo = - Memo.create "find-dir-raw" ~doc:"get file tree" + Memo.create "find-dir-raw" ~input:(module Path.Source) ~output:(Simple (module Output)) - ~visibility:Memo.Visibility.Hidden find_dir_raw_impl + find_dir_raw_impl in Memo.cell memo @@ -657,10 +657,9 @@ let execution_parameters_of_dir = in let memo = Memo.create "execution-parameters-of-dir" - ~doc:"Return the execution parameters of a given directory" ~input:(module Path.Source) ~output:(Allow_cutoff (module Execution_parameters)) - ~visibility:Hidden f + f in Memo.exec memo diff --git a/src/dune_engine/vcs.ml b/src/dune_engine/vcs.ml index 9020397dec9..7f87f3cedff 100644 --- a/src/dune_engine/vcs.ml +++ b/src/dune_engine/vcs.ml @@ -21,8 +21,6 @@ module Kind = struct , [] ) let equal = ( = ) - - let decode = Dune_lang.Decoder.enum [ ("git", Git); ("hg", Hg) ] end module T = struct @@ -40,13 +38,6 @@ module T = struct (* No need to hash the kind as there is only only kind per directory *) let hash t = Path.hash t.root - - let decode = - let open Dune_lang.Decoder in - fields - (let+ root = field "root" Dpath.decode - and+ kind = field "kind" Kind.decode in - { root; kind }) end include T @@ -118,12 +109,8 @@ let hg_describe t = in s ^ dirty_suffix -let make_fun name ~output ~doc ~git ~hg = - let memo = - Memo.create name ~doc - ~input:(module T) - ~output ~visibility:(Public decode) (select git hg) - in +let make_fun name ~output ~git ~hg = + let memo = Memo.create name ~input:(module T) ~output (select git hg) in Staged.stage (Memo.exec memo) module Option_output (S : sig @@ -140,7 +127,6 @@ end let describe = Staged.unstage @@ make_fun "vcs-describe" - ~doc:"Obtain a nice description of the tip from the vcs" ~output:(Simple (module Option_output (String))) ~git:(fun t -> run_git t [ "describe"; "--always"; "--dirty" ]) ~hg:(fun x -> @@ -150,7 +136,7 @@ let describe = let commit_id = Staged.unstage - @@ make_fun "vcs-commit-id" ~doc:"The hash of the head commit" + @@ make_fun "vcs-commit-id" ~output:(Simple (module Option_output (String))) ~git:(fun t -> run_git t [ "rev-parse"; "HEAD" ]) ~hg:(fun t -> @@ -180,7 +166,7 @@ let files = List.map l ~f:Path.in_source in Staged.unstage - @@ make_fun "vcs-files" ~doc:"Return the files committed in the repo" + @@ make_fun "vcs-files" ~output: (Simple (module struct diff --git a/src/dune_rules/context.ml b/src/dune_rules/context.ml index ef2d545d18d..8e5912d8561 100644 --- a/src/dune_rules/context.ml +++ b/src/dune_rules/context.ml @@ -335,7 +335,6 @@ let create ~(kind : Kind.t) ~path ~env ~env_nodes ~name ~merlin ~targets (sprintf "which-memo-for-%s" (Context_name.to_string name)) ~input:(module Program.Name) ~output:(Allow_cutoff (module Program.Which_path)) - ~visibility:Hidden (fun p -> Memo.Build.return (Program.which ~path p)) in let which = Memo.exec which_memo in @@ -791,10 +790,10 @@ end = struct ~dynamically_linked_foreign_archives ~instrument_with let memo = - Memo.create "instantiate-context" ~doc:"instantiate contexts" + Memo.create "instantiate-context" ~input:(module Context_name) ~output:(Simple (module T_list)) - ~visibility:Memo.Visibility.Hidden instantiate_impl + instantiate_impl let instantiate name = Memo.exec memo name end @@ -817,19 +816,18 @@ module DB = struct all in let memo = - Memo.create "build-contexts" ~doc:"all build contexts" + Memo.create "build-contexts" ~input:(module Unit) ~output:(Simple (module T_list)) - ~visibility:Memo.Visibility.Hidden impl + impl in Memo.exec memo let get = let memo = - Memo.create "context-db-get" ~doc:"get context from db" + Memo.create "context-db-get" ~input:(module Context_name) ~output:(Simple (module T)) - ~visibility:Hidden (fun name -> let+ contexts = all () in List.find_exn contexts ~f:(fun c -> Context_name.equal name c.name)) diff --git a/src/dune_rules/dir_contents.ml b/src/dune_rules/dir_contents.ml index 051ec300c85..a93f59ac9e7 100644 --- a/src/dune_rules/dir_contents.ml +++ b/src/dune_rules/dir_contents.ml @@ -354,7 +354,7 @@ end = struct Memo.create "dir-contents-get0" ~input:(module Key) ~output:(Simple (module Output)) - ~doc:"dir contents" ~visibility:Hidden get0_impl + get0_impl let get sctx ~dir = Memo.exec memo0 (sctx, dir) >>= function diff --git a/src/dune_rules/dir_status.ml b/src/dune_rules/dir_status.ml index 65573accb12..8d31df6845f 100644 --- a/src/dune_rules/dir_status.ml +++ b/src/dune_rules/dir_status.ml @@ -139,9 +139,8 @@ module DB = struct ; fn = Memo.create "get-dir-status" ~input:(module Path.Build) - ~visibility:Hidden ~output:(Simple (module T)) - ~doc:"Get a directory status." Fn.get + Fn.get } end diff --git a/src/dune_rules/fdo.ml b/src/dune_rules/fdo.ml index 785f4b3433e..82369f42c04 100644 --- a/src/dune_rules/fdo.ml +++ b/src/dune_rules/fdo.ml @@ -45,12 +45,7 @@ let get_flags var = Env.get ctx.env var |> Option.value ~default:"" |> String.extract_blank_separated_words |> Memo.Build.return in - let memo = - Memo.create_hidden var - ~doc:(sprintf "parse %s environment variable in context" var) - ~input:(module Context) - f - in + let memo = Memo.create_hidden var ~input:(module Context) f in Memo.exec memo let ocamlfdo_flags = get_flags "OCAMLFDO_FLAGS" @@ -118,14 +113,7 @@ let get_profile = else None in - let memo = - Memo.create_hidden Mode.var - ~doc: - (sprintf "use profile based on %s environment variable in context" - Mode.var) - ~input:(module Context) - f - in + let memo = Memo.create_hidden Mode.var ~input:(module Context) f in Memo.exec memo let opt_rule cctx m = diff --git a/src/dune_rules/install_rules.ml b/src/dune_rules/install_rules.ml index 5b286eeefd6..78d712339f7 100644 --- a/src/dune_rules/install_rules.ml +++ b/src/dune_rules/install_rules.ml @@ -381,8 +381,7 @@ end = struct let to_dyn _ = Dyn.Opaque end)) - "stanzas-to-entries" ~doc:"install entries for all packages" - ~visibility:Hidden stanzas_to_entries + "stanzas-to-entries" stanzas_to_entries in Memo.exec memo end @@ -703,7 +702,6 @@ end = struct end in Memo.With_implicit_output.create "meta_and_dune_package_rules" ~input:(module Project_and_super_context) - ~visibility:Hidden ~output:(module Unit) ~implicit_output:Rules.implicit_output meta_and_dune_package_rules_impl @@ -765,9 +763,8 @@ let packages = ~f:Package.Id.Set.add in let memo = - Memo.create "package-map" ~doc:"Return a map assining package to files" + Memo.create "package-map" ~input:(module Super_context.As_memo_key) - ~visibility:Hidden ~output: (Allow_cutoff (module struct @@ -933,8 +930,7 @@ let memo = Memo.create ~input:(module Sctx_and_package) ~output:(Simple (module Rules_scheme)) - "install-rules-and-pkg-entries" ~doc:"install rules and package entries" - ~visibility:Hidden + "install-rules-and-pkg-entries" (fun (sctx, pkg) -> Memo.Build.return (let ctx = Super_context.context sctx in @@ -961,7 +957,6 @@ let scheme_per_ctx_memo = Memo.create ~input:(module Super_context.As_memo_key) ~output:(Memo.Output.simple ()) "install-rule-scheme" - ~doc:"install rules scheme" ~visibility:Hidden (fun sctx -> let packages = Package.Name.Map.values (Super_context.packages sctx) in let* schemes = Memo.Build.sequential_map packages ~f:(scheme sctx) in diff --git a/src/dune_rules/odoc.ml b/src/dune_rules/odoc.ml index 45b12a988a4..14d9be6bda2 100644 --- a/src/dune_rules/odoc.ml +++ b/src/dune_rules/odoc.ml @@ -515,10 +515,10 @@ let setup_lib_html_rules_def = (Path.Set.of_list (List.rev_append static_html html_files)) in Memo.With_implicit_output.create "setup-library-html-rules" - ~doc:"setup html rules for library" ~implicit_output:Rules.implicit_output + ~implicit_output:Rules.implicit_output ~input:(module Input) ~output:(module Unit) - ~visibility:Hidden f + f let setup_lib_html_rules sctx lib ~requires = Memo.With_implicit_output.exec setup_lib_html_rules_def (sctx, lib, requires) @@ -549,9 +549,8 @@ let setup_pkg_html_rules_def = end in Memo.With_implicit_output.create "setup-package-html-rules" ~output:(module Unit) - ~implicit_output:Rules.implicit_output ~doc:"setup odoc package html rules" + ~implicit_output:Rules.implicit_output ~input:(module Input) - ~visibility:Hidden (fun (sctx, pkg, (libs : Lib.Local.t list)) -> let requires = let libs = (libs :> Lib.t list) in @@ -659,9 +658,8 @@ let setup_package_odoc_rules_def = end in Memo.With_implicit_output.create "setup-package-odoc-rules" ~output:(module Unit) - ~implicit_output:Rules.implicit_output ~doc:"setup odoc package rules" + ~implicit_output:Rules.implicit_output ~input:(module Input) - ~visibility:Hidden (fun (sctx, pkg) -> let* mlds = Packages.mlds sctx pkg in let mlds = check_mlds_no_dupes ~pkg ~mlds in diff --git a/src/dune_rules/packages.ml b/src/dune_rules/packages.ml index 417d55b41eb..41ba691bcd1 100644 --- a/src/dune_rules/packages.ml +++ b/src/dune_rules/packages.ml @@ -11,10 +11,9 @@ let mlds_by_package_def = let to_dyn _ = Dyn.Opaque end in Memo.With_implicit_output.create "mlds by package" - ~implicit_output:Rules.implicit_output ~doc:"mlds by package" + ~implicit_output:Rules.implicit_output ~input:(module Super_context.As_memo_key) ~output:(module Output) - ~visibility:Hidden (fun sctx -> let stanzas = Super_context.stanzas sctx in Memo.Build.parallel_map stanzas ~f:(fun (w : _ Dir_with_dune.t) -> diff --git a/src/dune_rules/workspace.ml b/src/dune_rules/workspace.ml index ddfbb5cee69..39de9049392 100644 --- a/src/dune_rules/workspace.ml +++ b/src/dune_rules/workspace.ml @@ -653,8 +653,7 @@ let workspace = Lazy.force step1.t in let memo = - Memo.create "workspace" ~doc:"Return the workspace configuration" - ~visibility:Hidden + Memo.create "workspace" ~input:(module Unit) ~output:(Allow_cutoff (module T)) f diff --git a/src/memo/memo.ml b/src/memo/memo.ml index 3ee78627a4f..930611e75ad 100644 --- a/src/memo/memo.ml +++ b/src/memo/memo.ml @@ -117,12 +117,6 @@ module Output = struct | Some equal -> allow_cutoff ?to_dyn ~equal () end -module Visibility = struct - type 'i t = - | Hidden - | Public of 'i Dune_lang.Decoder.t -end - module Exn_comparable = Comparable.Make (struct type t = Exn_with_backtrace.t @@ -134,78 +128,32 @@ end) module Exn_set = Exn_comparable.Set -module Info = struct - type t = - { name : string - ; doc : string option - } -end - module Spec = struct type ('i, 'o) t = - { info : Info.t option + { name : string option ; input : (module Store_intf.Input with type t = 'i) ; output : (module Output_simple with type t = 'o) ; allow_cutoff : 'o Allow_cutoff.t - ; decode : 'i Dune_lang.Decoder.t ; witness : 'i Type_eq.Id.t ; f : 'i -> 'o Fiber.t } - type packed = T : (_, _) t -> packed [@@unboxed] - - (* This mutable table is safe under the assumption that [register] is called - only at the top level, which is currently true. This means that all - memoization tables created not at the top level are hidden. *) - let by_name : packed String.Table.t = String.Table.create 256 - - let find name = String.Table.find by_name name - - let register t = - match t.info with - | None -> Code_error.raise "[Spec.register] got a function with no info" [] - | Some info -> ( - match find info.name with - | Some _ -> - Code_error.raise - "[Spec.register] called twice on a function with the same name" - [ ("name", Dyn.String info.name) ] - | None -> String.Table.set by_name info.name (T t)) - - let create (type o) ~info ~input ~visibility ~(output : o Output.t) ~f = - let info = - match info with + let create (type o) ~name ~input ~(output : o Output.t) ~f = + let name = + match name with | None when !track_locations_of_lazy_values -> Option.map (Caller_id.get ~skip:[ __FILE__ ]) ~f:(fun loc -> - let name = - sprintf "lazy value created at %s" (Loc.to_file_colon_line loc) - in - { Info.name; doc = None }) - | _ -> info + sprintf "lazy value created at %s" (Loc.to_file_colon_line loc)) + | _ -> name in let (output : (module Output_simple with type t = o)), allow_cutoff = match output with | Simple (module Output) -> ((module Output), Allow_cutoff.No) | Allow_cutoff (module Output) -> ((module Output), Yes Output.equal) in - let decode = - match visibility with - | Visibility.Public decode -> decode - | Hidden -> - let open Dune_lang.Decoder in - let+ loc = loc in - User_error.raise ~loc [ Pp.text "" ] - in - { info - ; input - ; output - ; allow_cutoff - ; decode - ; witness = Type_eq.Id.create () - ; f - } + { name; input; output; allow_cutoff; witness = Type_eq.Id.create (); f } end module Id = Id.Make () @@ -239,7 +187,7 @@ module Stack_frame_without_state = struct type t = Dep_node_without_state.packed - let name (T t) = Option.map t.spec.info ~f:(fun x -> x.name) + let name (T t) = t.spec.name let input (T t) = ser_input t @@ -791,32 +739,26 @@ module Stack_frame = struct | None -> None end -let create_with_cache (type i o) name ~cache ?doc ~input ~visibility ~output - (f : i -> o Fiber.t) = - let spec = - Spec.create ~info:(Some { name; doc }) ~input ~output ~visibility ~f - in - (match visibility with - | Public _ -> Spec.register spec - | Hidden -> ()); +let create_with_cache (type i o) name ~cache ~input ~output (f : i -> o Fiber.t) + = + let spec = Spec.create ~name:(Some name) ~input ~output ~f in Caches.register ~clear:(fun () -> Store.clear cache); { cache; spec } let create_with_store (type i) name - ~store:(module S : Store_intf.S with type key = i) ?doc ~input ~visibility - ~output f = + ~store:(module S : Store_intf.S with type key = i) ~input ~output f = let cache = Store.make (module S) in - create_with_cache name ~cache ?doc ~input ~output ~visibility f + create_with_cache name ~cache ~input ~output f -let create (type i) name ?doc ~input:(module Input : Input with type t = i) - ~visibility ~output f = +let create (type i) name ~input:(module Input : Input with type t = i) ~output f + = (* This mutable table is safe: the implementation tracks all dependencies. *) let cache = Store.of_table (Table.create (module Input) 16) in let input = (module Input : Store_intf.Input with type t = i) in - create_with_cache name ~cache ?doc ~input ~visibility ~output f + create_with_cache name ~cache ~input ~output f -let create_hidden name ?doc ~input impl = - create ~output:(Output.simple ()) ~visibility:Hidden name ?doc ~input impl +let create_hidden name ~input impl = + create ~output:(Output.simple ()) name ~input impl let make_dep_node ~spec ~input : _ Dep_node.t = let dep_node_without_state : _ Dep_node_without_state.t = @@ -1090,34 +1032,7 @@ let get_deps (type i o) (t : (i, o) t) inp = | Some cv -> Some (List.map cv.deps ~f:(fun (Last_dep.T (dep, _value)) -> - ( Option.map dep.without_state.spec.info ~f:(fun x -> x.name) - , ser_input dep.without_state )))) - -let get_func name = - match Spec.find name with - | None -> User_error.raise [ Pp.textf "function %s doesn't exist!" name ] - | Some spec -> spec - -let call name input = - let (Spec.T spec) = get_func name in - let (module Output : Output_simple with type t = _) = spec.output in - let input = Dune_lang.Decoder.parse spec.decode Univ_map.empty input in - let+ output = spec.f input in - Output.to_dyn output - -let function_info_of_spec (Spec.T spec) = - match spec.info with - | Some info -> info - | None -> Code_error.raise "[function_info_of_spec] got an unnamed spec" [] - -let registered_functions () = - String.Table.to_seq_values Spec.by_name - |> Seq.fold_left - ~f:(fun xs x -> List.cons (function_info_of_spec x) xs) - ~init:[] - |> List.sort ~compare:(fun x y -> String.compare x.Info.name y.Info.name) - -let function_info ~name = get_func name |> function_info_of_spec + (dep.without_state.spec.name, ser_input dep.without_state)))) let get_call_stack = Call_stack.get_call_stack_without_state @@ -1149,10 +1064,7 @@ module Current_run = struct let f () = Run.current () |> Build.return let memo = - create "current-run" - ~input:(module Unit) - ~output:(Simple (module Run)) - ~visibility:Hidden f + create "current-run" ~input:(module Unit) ~output:(Simple (module Run)) f let exec () = exec memo () @@ -1164,7 +1076,7 @@ let current_run () = Current_run.exec () module With_implicit_output = struct type ('i, 'o) t = 'i -> 'o Fiber.t - let create (type o) name ?doc ~input ~visibility + let create (type o) name ~input ~output:(module O : Output_simple with type t = o) ~implicit_output impl = let output = Output.simple @@ -1173,7 +1085,7 @@ module With_implicit_output = struct () in let memo = - create name ?doc ~input ~visibility ~output (fun i -> + create name ~input ~output (fun i -> Implicit_output.collect implicit_output (fun () -> impl i)) in fun input -> @@ -1205,10 +1117,7 @@ module Store = Store_intf let lazy_cell ?cutoff ?to_dyn f = let output = Output.create ?cutoff ?to_dyn () in - let visibility = Visibility.Hidden in - let spec = - Spec.create ~info:None ~input:(module Unit) ~output ~visibility ~f - in + let spec = Spec.create ~name:None ~input:(module Unit) ~output ~f in make_dep_node ~spec ~input:() let lazy_ ?cutoff ?to_dyn f = diff --git a/src/memo/memo.mli b/src/memo/memo.mli index b43ad616932..fafd853286a 100644 --- a/src/memo/memo.mli +++ b/src/memo/memo.mli @@ -185,12 +185,6 @@ module type Input = sig include Table.Key with type t := t end -module Visibility : sig - type 'i t = - | Hidden - | Public of 'i Dune_lang.Decoder.t -end - module Store : sig module type Input = sig type t @@ -216,15 +210,13 @@ end val create_with_store : string -> store:(module Store.S with type key = 'i) - -> ?doc:string -> input:(module Store.Input with type t = 'i) - -> visibility:'i Visibility.t -> output:'o Output.t -> ('i -> 'o Fiber.t) -> ('i, 'o) t -(** [create name ~doc ~input ~visibility ~output f] creates a memoized version - of [f : 'i -> 'o Build.t]. The result of [f] for a given input is cached, so +(** [create name ~input ~output f] creates a memoized version of + [f : 'i -> 'o Build.t]. The result of [f] for a given input is cached, so that the second time [exec t x] is called, the previous result is re-used if possible. @@ -239,16 +231,13 @@ val create_with_store : if it's user-facing then how to parse the values written by the user. *) val create : string - -> ?doc:string -> input:(module Input with type t = 'i) - -> visibility:'i Visibility.t -> output:'o Output.t -> ('i -> 'o Build.t) -> ('i, 'o) t val create_hidden : string - -> ?doc:string -> input:(module Input with type t = 'i) -> ('i -> 'o Build.t) -> ('i, 'o) t @@ -272,9 +261,6 @@ val pp_stack : unit -> _ Pp.t Fiber.t (** Get the memoized call stack during the execution of a memoized function. *) val get_call_stack : unit -> Stack_frame.t list Build.t -(** Call a memoized function by name *) -val call : string -> Dune_lang.Ast.t -> Dyn.t Build.t - module Run : sig (** A single build run. *) type t @@ -283,19 +269,6 @@ end (** Introduces a dependency on the current build run. *) val current_run : unit -> Run.t Build.t -module Info : sig - type t = - { name : string - ; doc : string option - } -end - -(** Return the list of registered functions *) -val registered_functions : unit -> Info.t list - -(** Lookup function's info *) -val function_info : name:string -> Info.t - module Lazy : sig type 'a t @@ -351,9 +324,7 @@ module With_implicit_output : sig val create : string - -> ?doc:string -> input:(module Input with type t = 'i) - -> visibility:'i Visibility.t -> output:(module Output_simple with type t = 'o) -> implicit_output:'io Implicit_output.t -> ('i -> 'o Build.t) diff --git a/test/expect-tests/memo/memoize_tests.ml b/test/expect-tests/memo/memoize_tests.ml index d6a03a31864..12f7d861688 100644 --- a/test/expect-tests/memo/memoize_tests.ml +++ b/test/expect-tests/memo/memoize_tests.ml @@ -16,15 +16,9 @@ let () = init () let printf = Printf.printf -let string_fn_create name = - Memo.create name - ~input:(module String) - ~visibility:(Public Dune_lang.Decoder.string) +let string_fn_create name = Memo.create name ~input:(module String) -let int_fn_create name = - Memo.create name - ~input:(module Int) - ~visibility:(Public Dune_lang.Decoder.int) +let int_fn_create name = Memo.create name ~input:(module Int) (* to run a computation *) let run m = Scheduler.run (Memo.Build.run m) @@ -200,8 +194,7 @@ let%expect_test _ = |}] let make_f name f ~input ~output = - Memo.create name ~input ~visibility:Hidden ~output:(Allow_cutoff output) - ~doc:"" f + Memo.create name ~input ~output:(Allow_cutoff output) f let id = let f = @@ -312,10 +305,9 @@ let%expect_test _ = (* Tests for depending on the current run *) let depends_on_run = - Memo.create "foobar" ~doc:"foo123" + Memo.create "foobar" ~input:(module Unit) ~output:(Allow_cutoff (module Unit)) - ~visibility:Hidden (fun () -> let+ (_ : Memo.Run.t) = Memo.current_run () in print_endline "running foobar") @@ -338,9 +330,8 @@ let%expect_test _ = let memo = Memo.create "for-cell" ~input:(module String) - ~visibility:(Public Dune_lang.Decoder.string) ~output:(Allow_cutoff (module String)) - ~doc:"" f + f in let cell = Memo.cell memo "foobar" in print_endline (run (Cell.read cell)); @@ -381,9 +372,8 @@ let%expect_test "fib linked list" = let memo = Memo.create "fib" ~input:(module Int) - ~visibility:Hidden ~output:(Simple (module Element)) - compute_element ~doc:"" + compute_element in Fdecl.set memo_fdecl memo; let fourth = run (Memo.exec memo 4) in @@ -418,9 +408,8 @@ let%expect_test "previously_evaluated_cell" = let memo = Memo.create "boxed" ~input:(module String) - ~visibility:(Public Dune_lang.Decoder.string) ~output:(Allow_cutoff (module String)) - ~doc:"" f + f in let evaluate_and_print name = let cell = Memo.cell memo name in @@ -675,7 +664,7 @@ let create ~with_cutoff name f = | true -> Memo.Output.Allow_cutoff (module Int) | false -> Simple (module Int) in - Memo.create name ~input:(module Unit) ~visibility:Hidden ~output ~doc:"" f + Memo.create name ~input:(module Unit) ~output f let%expect_test "diamond with non-uniform cutoff structure" = let base = create ~with_cutoff:true "base" (count_runs "base") in @@ -714,9 +703,8 @@ let%expect_test "diamond with non-uniform cutoff structure" = let summit = Memo.create "summit" ~input:(module Int) - ~visibility:Hidden ~output:(Simple (module Int)) - ~doc:"" summit + summit in evaluate_and_print summit 0; [%expect @@ -828,7 +816,7 @@ let%expect_test "dynamic cycles with non-uniform cutoff structure" = in Memo.create "incrementing_chain_plus_input" ~input:(module Int) - ~visibility:Hidden ~output ~doc:"" plus_input + ~output plus_input in let summit_fdecl = Fdecl.create (fun _ -> Dyn.Opaque) in let cycle_creator_no_cutoff = @@ -1053,9 +1041,7 @@ let%expect_test "deadlocks when creating a cycle twice" = let summit = Memo.create "summit" ~input:(module Int) - ~visibility:Hidden ~output:(Simple (module Int)) - ~doc:"" (fun offset -> printf "Started evaluating summit\n"; let+ middle = Memo.exec middle () in @@ -1094,9 +1080,7 @@ let%expect_test "Nested nodes with cutoff are recomputed optimally" = let summit = Memo.create "summit" ~input:(module Int) - ~visibility:Hidden ~output:(Simple (module Int)) - ~doc:"" (fun offset -> printf "Started evaluating summit\n"; let middle = @@ -1178,9 +1162,7 @@ let%expect_test "Test that there are no phantom dependencies" = let summit = Memo.create "summit" ~input:(module Int) - ~visibility:Hidden ~output:(Simple (module Int)) - ~doc:"" (fun offset -> printf "Started evaluating summit\n"; let middle = @@ -1243,9 +1225,7 @@ let%expect_test "Abandoned node with no cutoff is recomputed" = let middle = Memo.create "middle" ~input:(module Unit) - ~visibility:Hidden ~output:(Simple (module Int)) - ~doc:"" (fun () -> printf "Started evaluating middle\n"; let base = base () in @@ -1257,9 +1237,7 @@ let%expect_test "Abandoned node with no cutoff is recomputed" = let summit = Memo.create "summit" ~input:(module Int) - ~visibility:Hidden ~output:(Simple (module Int)) - ~doc:"" (fun input -> printf "Started evaluating summit\n"; let* middle = Memo.exec middle () in @@ -1457,9 +1435,7 @@ let%expect_test "errors work with early cutoff" = let exception Input_too_large of Memo.Run.t in Memo.create "divide 100 by input" ~input:(module Int) - ~visibility:Hidden ~output:(Allow_cutoff (module Int)) - ~doc:"" (fun x -> let+ run = Memo.current_run () in printf "[divide] Started evaluating %d\n" x; From 0aae4d898ab262d6ad5d46f7433d67bfeb67d299 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9mie=20Dimino?= Date: Wed, 28 Apr 2021 14:06:08 +0100 Subject: [PATCH 2/2] Update CHANGES.md --- CHANGES.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGES.md b/CHANGES.md index 3b9d81cf1cc..03902ff22a7 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -131,7 +131,7 @@ Unreleased way to rerun all actions failed due to errors without restarting the build, e.g. via a Dune RPC call. (#4522, Andrey Mokhov) -- Remove `dune compute`. It was broken and unused (#...., +- Remove `dune compute`. It was broken and unused (#4540, @jeremiedimino) 2.9.0 (unreleased)