diff --git a/src/build_system.ml b/src/build_system.ml index 0e9ed2b5..1dfe9ce1 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -367,25 +367,25 @@ type hook = type t = { (* File specification by targets *) - files : (Path.t, File_spec.packed) Hashtbl.t + files : File_spec.packed Path.Table.t ; contexts : Context.t String.Map.t ; (* Table from target to digest of [(deps (filename + contents), targets (filename only), action)] *) - trace : (Path.t, Digest.t) Hashtbl.t + trace : Digest.t Path.Table.t ; file_tree : File_tree.t ; mutable local_mkdirs : Path.Set.t - ; mutable dirs : (Path.t, Dir_status.t) Hashtbl.t + ; mutable dirs : Dir_status.t Path.Table.t ; mutable gen_rules : (dir:Path.t -> string list -> extra_sub_directories_to_keep) String.Map.t ; mutable load_dir_stack : Path.t list ; (* Set of directories under _build that have at least one rule and all their ancestors. *) mutable build_dirs_to_keep : Path.Set.t - ; files_of : (Path.t, Files_of.t) Hashtbl.t + ; files_of : Files_of.t Path.Table.t ; mutable prefix : (unit, unit) Build.t option ; hook : hook -> unit ; (* Package files are part of *) - packages : (Path.t, Package.Name.t) Hashtbl.t + packages : Package.Name.t Path.Table.t } let string_of_paths set = @@ -400,7 +400,7 @@ let set_rule_generators t generators = t.gen_rules <- generators let get_dir_status t ~dir = - Hashtbl.find_or_add t.dirs dir ~f:(fun _ -> + Path.Table.find_or_add t.dirs dir ~f:(fun _ -> if Path.is_in_source_tree dir then Dir_status.Loaded (File_tree.files_of t.file_tree dir) else if dir = Path.build_dir then @@ -441,7 +441,7 @@ module Target = Build_interpret.Target module Pre_rule = Build_interpret.Rule let get_file : type a. t -> Path.t -> a File_kind.t -> a File_spec.t = fun t fn kind -> - match Hashtbl.find t.files fn with + match Path.Table.find t.files fn with | None -> die "no rule found for %s" (Path.to_string fn) | Some (File_spec.T file) -> let Eq = File_kind.eq_exn kind file.kind in @@ -528,9 +528,9 @@ end (* [copy_source] is [true] for rules copying files from the source directory *) let add_spec t fn spec ~copy_source = - match Hashtbl.find t.files fn with + match Path.Table.find t.files fn with | None -> - Hashtbl.add t.files fn spec + Path.Table.add t.files fn spec | Some (File_spec.T { rule; _ }) -> match copy_source, rule.mode with | true, (Standard | Not_a_rule_stanza) -> @@ -551,7 +551,7 @@ let add_spec t fn spec ~copy_source = "To keep the current behavior and get rid of this warning, add a field \ (fallback) to the rule." | _ -> assert false); - Hashtbl.add t.files fn spec + Path.Table.add t.files fn spec | _ -> let (File_spec.T { rule = rule2; _ }) = spec in let string_of_loc = function @@ -630,7 +630,7 @@ let rec with_locks mutexes ~f = let remove_old_artifacts t ~dir ~subdirs_to_keep = if not (Path.is_in_build_dir dir) || - Hashtbl.mem t.files (Path.relative dir Config.jbuilder_keep_fname) then + Path.Table.mem t.files (Path.relative dir Config.jbuilder_keep_fname) then () else match Path.readdir_unsorted dir with @@ -650,9 +650,9 @@ let remove_old_artifacts t ~dir ~subdirs_to_keep = Path.rm_rf path end | exception _ -> - if not (Hashtbl.mem t.files path) then Path.unlink path + if not (Path.Table.mem t.files path) then Path.unlink path | _ -> - if not (Hashtbl.mem t.files path) then Path.unlink path) + if not (Path.Table.mem t.files path) then Path.unlink path) let no_rule_found = let fail fn = @@ -730,12 +730,12 @@ let rec compile_rule t ?(copy_source=false) pre_rule = in let deps_or_rule_changed = List.fold_left targets_as_list ~init:false ~f:(fun acc fn -> - match Hashtbl.find t.trace fn with + match Path.Table.find t.trace fn with | None -> - Hashtbl.add t.trace fn hash; + Path.Table.add t.trace fn hash; true | Some prev_hash -> - Hashtbl.replace t.trace ~key:fn ~data:hash; + Path.Table.replace t.trace ~key:fn ~data:hash; acc || prev_hash <> hash) in let targets_missing = @@ -859,7 +859,7 @@ and load_dir_and_get_targets t ~dir = try load_dir_step2_exn t ~dir ~collector ~lazy_generators with exn -> - (match Hashtbl.find t.dirs dir with + (match Path.Table.find t.dirs dir with | Some (Loaded _) -> () | _ -> (match t.load_dir_stack with @@ -867,7 +867,7 @@ and load_dir_and_get_targets t ~dir = | x :: l -> t.load_dir_stack <- l; assert (x = dir))); - Hashtbl.replace t.dirs ~key:dir ~data:Failed_to_load; + Path.Table.replace t.dirs ~key:dir ~data:Failed_to_load; reraise exn and load_dir_step2_exn t ~dir ~collector ~lazy_generators = @@ -921,7 +921,7 @@ and load_dir_step2_exn t ~dir ~collector ~lazy_generators = :: rules, Path.Set.add alias_stamp_files path)) in - Hashtbl.replace t.dirs ~key:alias_dir ~data:(Loaded alias_stamp_files); + Path.Table.replace t.dirs ~key:alias_dir ~data:(Loaded alias_stamp_files); (* Compute the set of targets and the set of source files that must not be copied *) let user_rule_targets, source_files_to_ignore = @@ -1035,7 +1035,7 @@ The following targets are not: in (* Set the directory status to loaded *) - Hashtbl.replace t.dirs ~key:dir ~data:(Loaded targets); + Path.Table.replace t.dirs ~key:dir ~data:(Loaded targets); (match t.load_dir_stack with | [] -> assert false | x :: l -> @@ -1054,13 +1054,13 @@ The following targets are not: targets and wait_for_file t fn = - match Hashtbl.find t.files fn with + match Path.Table.find t.files fn with | Some file -> wait_for_file_found fn file | None -> let dir = Path.parent_exn fn in if Path.is_strict_descendant_of_build_dir dir then begin load_dir t ~dir; - match Hashtbl.find t.files fn with + match Path.Table.find t.files fn with | Some file -> wait_for_file_found fn file | None -> no_rule_found t fn end else if Path.exists fn then @@ -1097,7 +1097,7 @@ and wait_for_deps t deps = let stamp_file_for_files_of t ~dir ~ext = let files_of_dir = - Hashtbl.find_or_add t.files_of dir ~f:(fun dir -> + Path.Table.find_or_add t.files_of dir ~f:(fun dir -> let files_by_ext = targets_of t ~dir |> Path.Set.to_list @@ -1130,7 +1130,7 @@ let stamp_file_for_files_of t ~dir ~ext = stamp_file module Trace = struct - type t = (Path.t, Digest.t) Hashtbl.t + type t = Digest.t Path.Table.t let file = Path.relative Path.build_dir ".db" @@ -1146,7 +1146,7 @@ module Trace = struct let load () = match P.load file with | Some t -> t - | None -> Hashtbl.create 1024 + | None -> Path.Table.create 1024 end let all_targets t = @@ -1155,7 +1155,7 @@ let all_targets t = ~f:(fun dir () -> load_dir t ~dir:(Path.append ctx.Context.build_dir (File_tree.Dir.path dir)))); - Hashtbl.foldi t.files ~init:[] ~f:(fun key _ acc -> key :: acc) + Path.Table.foldi t.files ~init:[] ~f:(fun key _ acc -> key :: acc) let finalize t = (* Promotion must be handled before dumping the digest cache, as it @@ -1173,17 +1173,17 @@ let create ~contexts ~file_tree ~hook = in let t = { contexts - ; files = Hashtbl.create 1024 - ; packages = Hashtbl.create 1024 + ; files = Path.Table.create 1024 + ; packages = Path.Table.create 1024 ; trace = Trace.load () ; local_mkdirs = Path.Set.empty - ; dirs = Hashtbl.create 1024 + ; dirs = Path.Table.create 1024 ; load_dir_stack = [] ; file_tree ; gen_rules = String.Map.map contexts ~f:(fun _ ~dir:_ -> die "gen_rules called too early") ; build_dirs_to_keep = Path.Set.empty - ; files_of = Hashtbl.create 1024 + ; files_of = Path.Table.create 1024 ; prefix = None ; hook } @@ -1239,7 +1239,7 @@ let rules_for_files t paths = Path.Set.fold paths ~init:[] ~f:(fun path acc -> if Path.is_in_build_dir path then load_dir t ~dir:(Path.parent_exn path); - match Hashtbl.find t.files path with + match Path.Table.find t.files path with | None -> acc | Some (File_spec.T { rule; _ }) -> rule :: acc) |> Ir_set.of_list @@ -1331,7 +1331,7 @@ let build_rules_internal ?(recursive=false) t ~request = let dir = Path.parent_exn fn in if Path.is_in_build_dir dir then load_dir t ~dir; - match Hashtbl.find t.files fn with + match Path.Table.find t.files fn with | Some file -> file_found fn file | None -> @@ -1404,12 +1404,12 @@ let build_rules ?recursive t ~request = build_rules_internal ?recursive t ~request) let set_package t file package = - Hashtbl.add t.packages file package + Path.Table.add t.packages file package let package_deps t pkg files = let rules_seen = ref Rule.Id.Set.empty in let rec loop fn acc = - match Hashtbl.find_all t.packages fn with + match Path.Table.find_all t.packages fn with | [] -> loop_deps fn acc | pkgs -> if List.mem pkg ~set:pkgs then @@ -1422,7 +1422,7 @@ let package_deps t pkg files = else Package.Name.Set.add acc p and loop_deps fn acc = - match Hashtbl.find t.files fn with + match Path.Table.find t.files fn with | None -> acc | Some (File_spec.T { rule = ir; _ }) -> if Rule.Id.Set.mem !rules_seen ir.id then diff --git a/src/stdune/hashable.ml b/src/stdune/hashable.ml new file mode 100644 index 00000000..48565d44 --- /dev/null +++ b/src/stdune/hashable.ml @@ -0,0 +1,5 @@ +module type S = sig + type t + val equal : t -> t -> bool + val hash : t -> int +end diff --git a/src/stdune/hashtbl.ml b/src/stdune/hashtbl.ml index c33652b3..51c16c1c 100644 --- a/src/stdune/hashtbl.ml +++ b/src/stdune/hashtbl.ml @@ -1,3 +1,5 @@ +module type S = Hashtbl_intf.S + include struct [@@@warning "-32"] @@ -7,19 +9,61 @@ include struct | exception Not_found -> None end -include MoreLabels.Hashtbl +module Make(H : Hashable.S) = struct + include MoreLabels.Hashtbl.Make(H) + + include struct + [@@@warning "-32"] + + let find_opt t key = + match find t key with + | x -> Some x + | exception Not_found -> None + end + + include struct + let find = find_opt + let add t key data = add t ~key ~data + + let find_or_add t key ~f = + match find t key with + | Some x -> x + | None -> + let x = f key in + add t key x; + x + + let foldi t ~init ~f = + fold t ~init ~f:(fun ~key ~data acc -> f key data acc) + let fold t ~init ~f = foldi t ~init ~f:(fun _ x -> f x) + end +end + +open MoreLabels.Hashtbl + +type nonrec ('a, 'b) t = ('a, 'b) t + +let hash = hash +let create = create +let add = add +let replace = replace +let length = length +let remove = remove +let mem = mem let find = find_opt +let add t key data = add t ~key ~data + let find_or_add t key ~f = match find t key with | Some x -> x | None -> let x = f key in - add t ~key ~data:x; + add t key x; x -let add t key data = add t ~key ~data - let foldi t ~init ~f = fold t ~init ~f:(fun ~key ~data acc -> f key data acc) let fold t ~init ~f = foldi t ~init ~f:(fun _ x -> f x) + +let iter t ~f = iter ~f t diff --git a/src/stdune/hashtbl.mli b/src/stdune/hashtbl.mli index bf5947e9..7630949c 100644 --- a/src/stdune/hashtbl.mli +++ b/src/stdune/hashtbl.mli @@ -1,4 +1,20 @@ -include module type of struct include MoreLabels.Hashtbl end +module type S = Hashtbl_intf.S + +module Make(Key : Hashable.S) : S with type key = Key.t + +type ('a, 'b) t = ('a, 'b) MoreLabels.Hashtbl.t + +val hash : 'a -> int + +val create : ?random:bool -> int -> ('a, 'b) t + +val remove : ('a, _) t -> 'a -> unit + +val length : (_, _) t -> int + +val iter : ('a, 'b) t -> f:(key:'a -> data:'b -> unit) -> unit + +val replace : ('a, 'b) t -> key:'a -> data:'b -> unit val add : ('a, 'b) t -> 'a -> 'b -> unit @@ -7,3 +23,5 @@ val find_or_add : ('a, 'b) t -> 'a -> f:('a -> 'b) -> 'b val fold : ('a, 'b) t -> init:'c -> f:( 'b -> 'c -> 'c) -> 'c val foldi : ('a, 'b) t -> init:'c -> f:('a -> 'b -> 'c -> 'c) -> 'c + +val mem : ('a, _) t -> 'a -> bool diff --git a/src/stdune/hashtbl_intf.ml b/src/stdune/hashtbl_intf.ml new file mode 100644 index 00000000..3d30d0e1 --- /dev/null +++ b/src/stdune/hashtbl_intf.ml @@ -0,0 +1,11 @@ +module type S = sig + include MoreLabels.Hashtbl.S + + val add : 'a t -> key -> 'a -> unit + + val find : 'a t -> key -> 'a option + val find_or_add : 'a t -> key -> f:(key -> 'a) -> 'a + + val fold : 'a t -> init:'b -> f:('a -> 'b -> 'b) -> 'b + val foldi : 'a t -> init:'b -> f:(key -> 'a -> 'b -> 'b) -> 'b +end diff --git a/src/stdune/path.ml b/src/stdune/path.ml index 70124ffa..c806c749 100644 --- a/src/stdune/path.ml +++ b/src/stdune/path.ml @@ -489,6 +489,8 @@ module T : sig | In_build_dir of Local.t val compare : t -> t -> Ordering.t + val equal : t -> t -> bool + val hash : t -> int val in_build_dir : Local.t -> t val in_source_tree : Local.t -> t @@ -509,6 +511,9 @@ end = struct | _ , In_source_tree _ -> Gt | In_build_dir x , In_build_dir y -> Local.compare x y + let equal (x : t) (y : t) = x = y + let hash = Hashtbl.hash + let in_build_dir s = In_build_dir s let in_source_tree s = In_source_tree s let external_ e = External e @@ -904,3 +909,5 @@ module Set = struct end let in_source s = in_source_tree (Local.of_string s) + +module Table = Hashtbl.Make(T) diff --git a/src/stdune/path.mli b/src/stdune/path.mli index 0820b2fc..c7a691fe 100644 --- a/src/stdune/path.mli +++ b/src/stdune/path.mli @@ -37,6 +37,7 @@ module Set : sig end module Map : Map.S with type key = t +module Table : Hashtbl.S with type key = t val of_string : ?error_loc:Usexp.Loc.t -> string -> t val to_string : t -> string