diff --git a/CHANGES.md b/CHANGES.md index b0f95db38b7c..d550ed1e0148 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -32,6 +32,9 @@ - Do not install vendored packages (#3704, @diml) +- Avoid linear walk to detect children, this should greatly improve performance + when a target has a large number of dependencies (#2959, @ejgallego, review by: ) + 2.1.3 (16/01/2020) ------------------ diff --git a/src/dag/dag.ml b/src/dag/dag.ml index f9b7f3cf4a9d..9c6c4f061171 100644 --- a/src/dag/dag.ml +++ b/src/dag/dag.ml @@ -12,13 +12,15 @@ module Make (Value : Value) : S with type value := Value.t = struct type graph = t + module NodeMap = Map.Make(Int) + type node_info = { id : int ; (* only used for printing *) mutable mark : mark ; mutable level : int - ; mutable deps : node list - ; mutable rev_deps : node list + ; mutable deps : node NodeMap.t + ; mutable rev_deps : node NodeMap.t ; mutable parent : node option } @@ -30,8 +32,8 @@ module Make (Value : Value) : S with type value := Value.t = struct type vertex = node module VertexSet = struct - type t = vertex list - let interruptible_fold = List.interruptible_fold + type t = vertex NodeMap.t + let interruptible_fold = NodeMap.interruptible_fold end let new_mark g = @@ -51,9 +53,9 @@ module Make (Value : Value) : S with type value := Value.t = struct let get_incoming _ v = v.info.rev_deps - let clear_incoming _ v = v.info.rev_deps <- [] + let clear_incoming _ v = v.info.rev_deps <- NodeMap.empty - let add_incoming _ v w = v.info.rev_deps <- w :: v.info.rev_deps + let add_incoming _ v w = v.info.rev_deps <- NodeMap.add_exn v.info.rev_deps w.info.id w let get_outgoing _ v = v.info.deps @@ -65,9 +67,9 @@ module Make (Value : Value) : S with type value := Value.t = struct let set_parent _ v p = v.info.parent <- Some p let raw_add_edge _ v w = - v.info.deps <- w :: v.info.deps; + v.info.deps <- NodeMap.add_exn v.info.deps w.info.id w; if v.info.level = w.info.level then - w.info.rev_deps <- v :: w.info.rev_deps + w.info.rev_deps <- NodeMap.add_exn w.info.rev_deps v.info.id v let raw_add_vertex _ _ = () end @@ -82,7 +84,7 @@ module Make (Value : Value) : S with type value := Value.t = struct let create_node_info g = let id = g.fresh_id in g.fresh_id <- g.fresh_id + 1; - { id; mark = -1; level = 1; deps = []; rev_deps = []; parent = None } + { id; mark = -1; level = 1; deps = NodeMap.empty; rev_deps = NodeMap.empty; parent = None } let add g v w = match IC.add_edge_or_detect_cycle g v w with @@ -105,10 +107,9 @@ module Make (Value : Value) : S with type value := Value.t = struct pp_value n.data ( pp_depth (depth + 1) pp_value |> Fmt.list ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@, ") ) - n.info.deps + (NodeMap.values n.info.deps) let pp_node pp_value fmt n = pp_depth 0 pp_value fmt n - let is_child v w = - v.info.deps |> List.exists ~f:(fun c -> c.info.id = w.info.id) + let is_child v w = NodeMap.mem v.info.deps w.info.id end diff --git a/src/dag/dag_intf.ml b/src/dag/dag_intf.ml index fceea8484024..f22f0bde883c 100644 --- a/src/dag/dag_intf.ml +++ b/src/dag/dag_intf.ml @@ -16,6 +16,8 @@ module type S = sig (** Type of values attached to nodes. *) type value + module NodeMap : Map.S with type key := int + type node = { data : value ; info : node_info @@ -36,7 +38,7 @@ module type S = sig (** [children v] returns all nodes [w] for which an arc going from [v] to [w] exists. *) - val children : node -> node list + val children : node -> node NodeMap.t (** Pretty print a node. *) val pp_node : value Fmt.t -> node Fmt.t diff --git a/src/memo/memo.ml b/src/memo/memo.ml index ab6c2e0bbedd..51bc38b7443a 100644 --- a/src/memo/memo.ml +++ b/src/memo/memo.ml @@ -463,6 +463,7 @@ let add_rev_dep (type i o f) ~called_from_peek (dep_node : (i, o, f) Dep_node.t) order in which they were added. See the comment for [deps : Last_dep.t list]. *) let get_deps_from_graph_exn (dep_node : _ Dep_node.t) = Dag.children dep_node.dag_node + |> Dag.NodeMap.values |> List.map ~f:(fun { Dag.data = Dep_node.T node; _ } -> match node.state with | Init -> assert false diff --git a/test/expect-tests/dag/dag_tests.ml b/test/expect-tests/dag/dag_tests.ml index 2325553e7fdd..64e1149944c2 100644 --- a/test/expect-tests/dag/dag_tests.ml +++ b/test/expect-tests/dag/dag_tests.ml @@ -53,13 +53,13 @@ let%expect_test _ = List.map ~f:Pp.text cycle |> Pp.concat ~sep:Pp.space |> print; [%expect {| -(1: k=1) (root) [(3: k=1) (child 1 2) [(4: k=1) (child 2 1) [(5: k=2) (child 3 1) [ - ]]]; - (2: k=1) (child 1 1) []] -(1: k=1) (root) [(3: k=1) (child 1 2) [(4: k=1) (child 2 1) [(5: k=2) (child 3 1) [ - (6: k=2) (child 4 1) [ - ]]]]; - (2: k=1) (child 1 1) []] +(1: k=1) (root) [(2: k=1) (child 1 1) []; + (3: k=1) (child 1 2) [(4: k=1) (child 2 1) [(5: k=2) (child 3 1) [ + ]]]] +(1: k=1) (root) [(2: k=1) (child 1 1) []; + (3: k=1) (child 1 2) [(4: k=1) (child 2 1) [(5: k=2) (child 3 1) [ + (6: k=2) (child 4 1) [ + ]]]]] child 4 1 child 3 1 child 2 1 child 1 2 root child 4 1 |}] diff --git a/test/expect-tests/memo/memoize_tests.ml b/test/expect-tests/memo/memoize_tests.ml index 6479b6e027f4..f6dfeab9d725 100644 --- a/test/expect-tests/memo/memoize_tests.ml +++ b/test/expect-tests/memo/memoize_tests.ml @@ -78,7 +78,7 @@ let%expect_test _ = |> option (list (pair string (fun x -> x))) |> print_dyn; [%expect {| -Some [ ("another", "aa"); ("some", "a") ] +Some [ ("some", "a"); ("another", "aa") ] |}] let%expect_test _ = @@ -307,7 +307,7 @@ let%expect_test _ = [%expect {| (Some [ ("lazy_memo", "foo") ], -Some [ ("id", "lazy: foo"); ("lazy_memo", "foo") ]) +Some [ ("lazy_memo", "foo"); ("id", "lazy: foo") ]) |}] module Memo_lazy = Test_lazy (Memo.Lazy) @@ -322,8 +322,8 @@ let%expect_test _ = Memo_lazy.deps () |> print_dyn; [%expect {| -(Some [ ("lazy-0", ()); ("lazy_memo", "foo") ], -Some [ ("lazy-0", ()); ("lazy_memo", "foo") ]) +(Some [ ("lazy_memo", "foo"); ("lazy-0", ()) ], +Some [ ("lazy_memo", "foo"); ("lazy-0", ()) ]) |}] (* Tests for depending on the current run *)