matthieu
/
dune
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' into odoc-master-titles

This commit is contained in:
Jérémie Dimino 2018-05-24 17:37:28 +01:00 committed by GitHub
parent b2dd904847 1e3b90c1d6
commit 459d17fc13
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
32 changed files with 388 additions and 365 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
bin/main.ml
View File

@ -1044,12 +1044,13 @@ let install_uninstall ~what =
in in
Fiber.parallel_iter install_files_by_context Fiber.parallel_iter install_files_by_context
~f:(fun (context, install_files) -> ~f:(fun (context, install_files) ->
let install_files_set = Path.Set.of_list install_files in
get_prefix context ~from_command_line:prefix_from_command_line get_prefix context ~from_command_line:prefix_from_command_line
>>= fun prefix -> >>= fun prefix ->
get_libdir context ~libdir_from_command_line get_libdir context ~libdir_from_command_line
>>= fun libdir -> >>= fun libdir ->
Fiber.parallel_iter install_files ~f:(fun path -> Fiber.parallel_iter install_files ~f:(fun path ->
let purpose = Process.Build_job install_files in let purpose = Process.Build_job install_files_set in
Process.run ~purpose ~env:setup.env Strict opam_installer Process.run ~purpose ~env:setup.env Strict opam_installer
([ sprintf "-%c" what.[0] ([ sprintf "-%c" what.[0]
; Path.to_string path ; Path.to_string path

34
src/action.ml
View File

@ -30,7 +30,7 @@ struct
let rec t sexp = let rec t sexp =
let path = Path.t and string = String.t in let path = Path.t and string = String.t in
sum sum
[ cstr_rest "run" (Program.t @> nil) string (fun prog args -> Run (prog, args)) [ cstr "run" (Program.t @> rest string) (fun prog args -> Run (prog, args))
; cstr "chdir" (path @> t @> nil) (fun dn t -> Chdir (dn, t)) ; cstr "chdir" (path @> t @> nil) (fun dn t -> Chdir (dn, t))
; cstr "setenv" (string @> string @> t @> nil) (fun k v t -> Setenv (k, v, t)) ; cstr "setenv" (string @> string @> t @> nil) (fun k v t -> Setenv (k, v, t))
; cstr "with-stdout-to" (path @> t @> nil) (fun fn t -> Redirect (Stdout, fn, t)) ; cstr "with-stdout-to" (path @> t @> nil) (fun fn t -> Redirect (Stdout, fn, t))
@ -39,7 +39,7 @@ struct
; cstr "ignore-stdout" (t @> nil) (fun t -> Ignore (Stdout, t)) ; cstr "ignore-stdout" (t @> nil) (fun t -> Ignore (Stdout, t))
; cstr "ignore-stderr" (t @> nil) (fun t -> Ignore (Stderr, t)) ; cstr "ignore-stderr" (t @> nil) (fun t -> Ignore (Stderr, t))
; cstr "ignore-outputs" (t @> nil) (fun t -> Ignore (Outputs, t)) ; cstr "ignore-outputs" (t @> nil) (fun t -> Ignore (Outputs, t))
; cstr_rest "progn" nil t (fun l -> Progn l) ; cstr "progn" (rest t) (fun l -> Progn l)
; cstr "echo" (string @> nil) (fun x -> Echo x) ; cstr "echo" (string @> nil) (fun x -> Echo x)
; cstr "cat" (path @> nil) (fun x -> Cat x) ; cstr "cat" (path @> nil) (fun x -> Cat x)
; cstr "copy" (path @> path @> nil) (fun src dst -> Copy (src, dst)) ; cstr "copy" (path @> path @> nil) (fun src dst -> Copy (src, dst))
@ -49,7 +49,7 @@ struct
*) *)
; cstr "copy#" (path @> path @> nil) (fun src dst -> ; cstr "copy#" (path @> path @> nil) (fun src dst ->
Copy_and_add_line_directive (src, dst)) Copy_and_add_line_directive (src, dst))
; cstr_loc "copy-and-add-line-directive" (path @> path @> nil) (fun loc src dst -> ; cstr "copy-and-add-line-directive" (cstr_loc (path @> path @> nil)) (fun loc src dst ->
Loc.warn loc "copy-and-add-line-directive is deprecated, use copy# instead"; Loc.warn loc "copy-and-add-line-directive is deprecated, use copy# instead";
Copy_and_add_line_directive (src, dst)) Copy_and_add_line_directive (src, dst))
; cstr "copy#" (path @> path @> nil) (fun src dst -> ; cstr "copy#" (path @> path @> nil) (fun src dst ->
@ -929,7 +929,6 @@ let exec ~targets ~context t =
| None -> Env.initial | None -> Env.initial
| Some c -> c.env | Some c -> c.env
in in
let targets = Path.Set.to_list targets in
let purpose = Process.Build_job targets in let purpose = Process.Build_job targets in
let ectx = { purpose; context } in let ectx = { purpose; context } in
exec t ~ectx ~dir:Path.root ~env ~stdout_to:None ~stderr_to:None exec t ~ectx ~dir:Path.root ~env ~stdout_to:None ~stderr_to:None
@ -954,11 +953,10 @@ let sandbox t ~sandboxed ~deps ~targets =
] ]
module Infer = struct module Infer = struct
module S = Path.Set
module Outcome = struct module Outcome = struct
type t = type t =
{ deps : S.t { deps : Path.Set.t
; targets : S.t ; targets : Path.Set.t
} }
end end
open Outcome open Outcome
@ -1037,43 +1035,43 @@ module Infer = struct
{ deps = Pset.diff deps targets; targets } { deps = Pset.diff deps targets; targets }
end [@@inline always] end [@@inline always]
include Make(Ast)(S)(Outcome)(struct include Make(Ast)(Path.Set)(Outcome)(struct
let ( +@ ) acc fn = { acc with targets = S.add acc.targets fn } let ( +@ ) acc fn = { acc with targets = Path.Set.add acc.targets fn }
let ( +< ) acc fn = { acc with deps = S.add acc.deps fn } let ( +< ) acc fn = { acc with deps = Path.Set.add acc.deps fn }
let ( +<! ) acc prog = let ( +<! ) acc prog =
match prog with match prog with
| Ok p -> acc +< p | Ok p -> acc +< p
| Error _ -> acc | Error _ -> acc
end) end)
module Partial = Make(Unexpanded.Partial.Past)(S)(Outcome)(struct module Partial = Make(Unexpanded.Partial.Past)(Path.Set)(Outcome)(struct
let ( +@ ) acc fn = let ( +@ ) acc fn =
match fn with match fn with
| Left fn -> { acc with targets = S.add acc.targets fn } | Left fn -> { acc with targets = Path.Set.add acc.targets fn }
| Right _ -> acc | Right _ -> acc
let ( +< ) acc fn = let ( +< ) acc fn =
match fn with match fn with
| Left fn -> { acc with deps = S.add acc.deps fn } | Left fn -> { acc with deps = Path.Set.add acc.deps fn }
| Right _ -> acc | Right _ -> acc
let ( +<! ) acc fn = let ( +<! ) acc fn =
match (fn : Unexpanded.Partial.program) with match (fn : Unexpanded.Partial.program) with
| Left (This fn) -> { acc with deps = S.add acc.deps fn } | Left (This fn) -> { acc with deps = Path.Set.add acc.deps fn }
| Left (Search _) | Right _ -> acc | Left (Search _) | Right _ -> acc
end) end)
module Partial_with_all_targets = Make(Unexpanded.Partial.Past)(S)(Outcome)(struct module Partial_with_all_targets = Make(Unexpanded.Partial.Past)(Path.Set)(Outcome)(struct
let ( +@ ) acc fn = let ( +@ ) acc fn =
match fn with match fn with
| Left fn -> { acc with targets = S.add acc.targets fn } | Left fn -> { acc with targets = Path.Set.add acc.targets fn }
| Right sw -> | Right sw ->
Loc.fail (SW.loc sw) "Cannot determine this target statically." Loc.fail (SW.loc sw) "Cannot determine this target statically."
let ( +< ) acc fn = let ( +< ) acc fn =
match fn with match fn with
| Left fn -> { acc with deps = S.add acc.deps fn } | Left fn -> { acc with deps = Path.Set.add acc.deps fn }
| Right _ -> acc | Right _ -> acc
let ( +<! ) acc fn = let ( +<! ) acc fn =
match (fn : Unexpanded.Partial.program) with match (fn : Unexpanded.Partial.program) with
| Left (This fn) -> { acc with deps = S.add acc.deps fn } | Left (This fn) -> { acc with deps = Path.Set.add acc.deps fn }
| Left (Search _) | Right _ -> acc | Left (Search _) | Right _ -> acc
end) end)

8
src/arg_spec.ml
View File

@ -1,7 +1,5 @@
open Import open Import
module Pset = Path.Set
type 'a t = type 'a t =
| A of string | A of string
| As of string list | As of string list
@ -19,9 +17,9 @@ type 'a t =
let rec add_deps ts set = let rec add_deps ts set =
List.fold_left ts ~init:set ~f:(fun set t -> List.fold_left ts ~init:set ~f:(fun set t ->
match t with match t with
| Dep fn -> Pset.add set fn | Dep fn -> Path.Set.add set fn
| Deps fns | Deps fns
| Hidden_deps fns -> Pset.union set (Pset.of_list fns) | Hidden_deps fns -> Path.Set.union set (Path.Set.of_list fns)
| S ts | S ts
| Concat (_, ts) -> add_deps ts set | Concat (_, ts) -> add_deps ts set
| _ -> set) | _ -> set)
@ -56,7 +54,7 @@ let expand ~dir ts x =
| Target _ | Hidden_targets _ -> die "Target not allowed under Dyn" | Target _ | Hidden_targets _ -> die "Target not allowed under Dyn"
| Dyn _ -> assert false | Dyn _ -> assert false
| Hidden_deps l -> | Hidden_deps l ->
dyn_deps := Pset.union !dyn_deps (Pset.of_list l); dyn_deps := Path.Set.union !dyn_deps (Path.Set.of_list l);
[] []
in in
let rec loop = function let rec loop = function

12
src/build.ml
View File

@ -1,7 +1,5 @@
open Import open Import
module Pset = Path.Set
module Vspec = struct module Vspec = struct
type 'a t = T : Path.t * 'a Vfile_kind.t -> 'a t type 'a t = T : Path.t * 'a Vfile_kind.t -> 'a t
end end
@ -26,7 +24,7 @@ module Repr = struct
| Second : ('a, 'b) t -> ('c * 'a, 'c * 'b) t | Second : ('a, 'b) t -> ('c * 'a, 'c * 'b) t
| Split : ('a, 'b) t * ('c, 'd) t -> ('a * 'c, 'b * 'd) t | Split : ('a, 'b) t * ('c, 'd) t -> ('a * 'c, 'b * 'd) t
| Fanout : ('a, 'b) t * ('a, 'c) t -> ('a, 'b * 'c) t | Fanout : ('a, 'b) t * ('a, 'c) t -> ('a, 'b * 'c) t
| Paths : Pset.t -> ('a, 'a) t | Paths : Path.Set.t -> ('a, 'a) t
| Paths_for_rule : Path.Set.t -> ('a, 'a) t | Paths_for_rule : Path.Set.t -> ('a, 'a) t
| Paths_glob : glob_state ref -> ('a, Path.t list) t | Paths_glob : glob_state ref -> ('a, Path.t list) t
(* The reference gets decided in Build_interpret.deps *) (* The reference gets decided in Build_interpret.deps *)
@ -134,8 +132,8 @@ let rec all = function
>>> >>>
arr (fun (x, y) -> x :: y) arr (fun (x, y) -> x :: y)
let path p = Paths (Pset.singleton p) let path p = Paths (Path.Set.singleton p)
let paths ps = Paths (Pset.of_list ps) let paths ps = Paths (Path.Set.of_list ps)
let path_set ps = Paths ps let path_set ps = Paths ps
let paths_glob ~loc ~dir re = Paths_glob (ref (G_unevaluated (loc, dir, re))) let paths_glob ~loc ~dir re = Paths_glob (ref (G_unevaluated (loc, dir, re)))
let vpath vp = Vpath vp let vpath vp = Vpath vp
@ -206,12 +204,12 @@ let get_prog = function
>>> dyn_paths (arr (function Error _ -> [] | Ok x -> [x])) >>> dyn_paths (arr (function Error _ -> [] | Ok x -> [x]))
let prog_and_args ?(dir=Path.root) prog args = let prog_and_args ?(dir=Path.root) prog args =
Paths (Arg_spec.add_deps args Pset.empty) Paths (Arg_spec.add_deps args Path.Set.empty)
>>> >>>
(get_prog prog &&& (get_prog prog &&&
(arr (Arg_spec.expand ~dir args) (arr (Arg_spec.expand ~dir args)
>>> >>>
dyn_paths (arr (fun (_args, deps) -> Path.Set.to_list deps)) dyn_path_set (arr (fun (_args, deps) -> deps))
>>> >>>
arr fst)) arr fst))

30
src/build_interpret.ml
View File

@ -1,8 +1,6 @@
open Import open Import
open Build.Repr open Build.Repr
module Pset = Path.Set
module Pmap = Path.Map
module Vspec = Build.Vspec module Vspec = Build.Vspec
module Target = struct module Target = struct
@ -15,8 +13,8 @@ module Target = struct
| Vfile (Vspec.T (p, _)) -> p | Vfile (Vspec.T (p, _)) -> p
let paths ts = let paths ts =
List.fold_left ts ~init:Pset.empty ~f:(fun acc t -> List.fold_left ts ~init:Path.Set.empty ~f:(fun acc t ->
Pset.add acc (path t)) Path.Set.add acc (path t))
end end
module Static_deps = struct module Static_deps = struct
@ -62,20 +60,20 @@ let static_deps t ~all_targets ~file_tree =
| Second t -> loop t acc | Second t -> loop t acc
| Split (a, b) -> loop a (loop b acc) | Split (a, b) -> loop a (loop b acc)
| Fanout (a, b) -> loop a (loop b acc) | Fanout (a, b) -> loop a (loop b acc)
| Paths fns -> { acc with action_deps = Pset.union fns acc.action_deps } | Paths fns -> { acc with action_deps = Path.Set.union fns acc.action_deps }
| Paths_for_rule fns -> | Paths_for_rule fns ->
{ acc with rule_deps = Pset.union fns acc.rule_deps } { acc with rule_deps = Path.Set.union fns acc.rule_deps }
| Paths_glob state -> begin | Paths_glob state -> begin
match !state with match !state with
| G_evaluated l -> | G_evaluated l ->
{ acc with action_deps = Pset.union acc.action_deps (Pset.of_list l) } { acc with action_deps = Path.Set.union acc.action_deps (Path.Set.of_list l) }
| G_unevaluated (loc, dir, re) -> | G_unevaluated (loc, dir, re) ->
let targets = all_targets ~dir in let targets = all_targets ~dir in
let result = let result =
Pset.filter targets ~f:(fun path -> Path.Set.filter targets ~f:(fun path ->
Re.execp re (Path.basename path)) Re.execp re (Path.basename path))
in in
if Pset.is_empty result then begin if Path.Set.is_empty result then begin
match inspect_path file_tree dir with match inspect_path file_tree dir with
| None -> | None ->
Loc.warn loc "Directory %s doesn't exist." Loc.warn loc "Directory %s doesn't exist."
@ -89,8 +87,8 @@ let static_deps t ~all_targets ~file_tree =
(* diml: we should probably warn in this case as well *) (* diml: we should probably warn in this case as well *)
() ()
end; end;
state := G_evaluated (Pset.to_list result); state := G_evaluated (Path.Set.to_list result);
let action_deps = Pset.union result acc.action_deps in let action_deps = Path.Set.union result acc.action_deps in
{ acc with action_deps } { acc with action_deps }
end end
| If_file_exists (p, state) -> begin | If_file_exists (p, state) -> begin
@ -99,7 +97,7 @@ let static_deps t ~all_targets ~file_tree =
| Undecided (then_, else_) -> | Undecided (then_, else_) ->
let dir = Path.parent_exn p in let dir = Path.parent_exn p in
let targets = all_targets ~dir in let targets = all_targets ~dir in
if Pset.mem targets p then begin if Path.Set.mem targets p then begin
state := Decided (true, then_); state := Decided (true, then_);
loop then_ acc loop then_ acc
end else begin end else begin
@ -108,15 +106,15 @@ let static_deps t ~all_targets ~file_tree =
end end
end end
| Dyn_paths t -> loop t acc | Dyn_paths t -> loop t acc
| Vpath (Vspec.T (p, _)) -> { acc with rule_deps = Pset.add acc.rule_deps p } | Vpath (Vspec.T (p, _)) -> { acc with rule_deps = Path.Set.add acc.rule_deps p }
| Contents p -> { acc with rule_deps = Pset.add acc.rule_deps p } | Contents p -> { acc with rule_deps = Path.Set.add acc.rule_deps p }
| Lines_of p -> { acc with rule_deps = Pset.add acc.rule_deps p } | Lines_of p -> { acc with rule_deps = Path.Set.add acc.rule_deps p }
| Record_lib_deps _ -> acc | Record_lib_deps _ -> acc
| Fail _ -> acc | Fail _ -> acc
| Memo m -> loop m.t acc | Memo m -> loop m.t acc
| Catch (t, _) -> loop t acc | Catch (t, _) -> loop t acc
in in
loop (Build.repr t) { rule_deps = Pset.empty; action_deps = Pset.empty } loop (Build.repr t) { rule_deps = Path.Set.empty; action_deps = Path.Set.empty }
let lib_deps = let lib_deps =
let rec loop : type a b. (a, b) t -> Build.lib_deps -> Build.lib_deps let rec loop : type a b. (a, b) t -> Build.lib_deps -> Build.lib_deps

200
src/build_system.ml
View File

@ -1,8 +1,6 @@
open Import open Import
open Fiber.O open Fiber.O
module Pset = Path.Set
module Pmap = Path.Map
module Vspec = Build.Vspec module Vspec = Build.Vspec
(* Where we store stamp files for aliases *) (* Where we store stamp files for aliases *)
@ -26,11 +24,11 @@ module Promoted_to_delete = struct
[] []
let dump () = let dump () =
let db = Pset.union (Pset.of_list !db) (Pset.of_list (load ())) in let db = Path.Set.union (Path.Set.of_list !db) (Path.Set.of_list (load ())) in
if Path.build_dir_exists () then if Path.build_dir_exists () then
Io.write_file fn Io.write_file fn
(String.concat ~sep:"" (String.concat ~sep:""
(List.map (Pset.to_list db) ~f:(fun p -> (List.map (Path.Set.to_list db) ~f:(fun p ->
Sexp.to_string (Path.sexp_of_t p) ^ "\n"))) Sexp.to_string (Path.sexp_of_t p) ^ "\n")))
end end
@ -42,21 +40,21 @@ module Dependency_path = struct
{ (* Reason why this rule was visited *) { (* Reason why this rule was visited *)
requested_file : Path.t requested_file : Path.t
; (* All targets of the rule *) ; (* All targets of the rule *)
targets : Pset.t targets : Path.Set.t
} }
type t = type t =
{ dependency_path : rule_info list { dependency_path : rule_info list
; (* Union of all [targets] fields in [dependency_path]. Depending on any of these ; (* Union of all [targets] fields in [dependency_path]. Depending on any of these
means that there is a cycle. *) means that there is a cycle. *)
targets_seen : Pset.t targets_seen : Path.Set.t
} }
let var = Fiber.Var.create () let var = Fiber.Var.create ()
let empty = let empty =
{ dependency_path = [] { dependency_path = []
; targets_seen = Pset.empty ; targets_seen = Path.Set.empty
} }
let dependency_cycle last dep_path = let dependency_cycle last dep_path =
@ -64,7 +62,7 @@ module Dependency_path = struct
match dep_path with match dep_path with
| [] -> assert false | [] -> assert false
| { requested_file; targets } :: dep_path -> | { requested_file; targets } :: dep_path ->
if Pset.mem targets last then if Path.Set.mem targets last then
last :: acc last :: acc
else else
build_loop (requested_file :: acc) dep_path build_loop (requested_file :: acc) dep_path
@ -77,14 +75,14 @@ module Dependency_path = struct
let push requested_file ~targets ~f = let push requested_file ~targets ~f =
Fiber.Var.get var >>= fun x -> Fiber.Var.get var >>= fun x ->
let t = Option.value x ~default:empty in let t = Option.value x ~default:empty in
if Pset.mem t.targets_seen requested_file then if Path.Set.mem t.targets_seen requested_file then
dependency_cycle requested_file t.dependency_path; dependency_cycle requested_file t.dependency_path;
let dependency_path = let dependency_path =
{ requested_file; targets } :: t.dependency_path { requested_file; targets } :: t.dependency_path
in in
let t = let t =
{ dependency_path { dependency_path
; targets_seen = Pset.union targets t.targets_seen ; targets_seen = Path.Set.union targets t.targets_seen
} }
in in
let on_error exn = let on_error exn =
@ -94,10 +92,10 @@ module Dependency_path = struct
end end
module Exec_status = struct module Exec_status = struct
type rule_evaluation = (Action.t * Pset.t) Fiber.Future.t type rule_evaluation = (Action.t * Path.Set.t) Fiber.Future.t
type rule_execution = unit Fiber.Future.t type rule_execution = unit Fiber.Future.t
type eval_rule = unit -> (Action.t * Pset.t) Fiber.t type eval_rule = unit -> (Action.t * Path.Set.t) Fiber.t
type exec_rule = rule_evaluation -> unit Fiber.t type exec_rule = rule_evaluation -> unit Fiber.t
module Evaluating_rule = struct module Evaluating_rule = struct
@ -166,9 +164,9 @@ module Internal_rule = struct
type t = type t =
{ id : Id.t { id : Id.t
; rule_deps : Pset.t ; rule_deps : Path.Set.t
; static_deps : Pset.t ; static_deps : Path.Set.t
; targets : Pset.t ; targets : Path.Set.t
; context : Context.t option ; context : Context.t option
; build : (unit, Action.t) Build.t ; build : (unit, Action.t) Build.t
; mode : Jbuild.Rule.Mode.t ; mode : Jbuild.Rule.Mode.t
@ -333,8 +331,8 @@ module Dir_status = struct
type alias = type alias =
{ mutable deps : Pset.t { mutable deps : Path.Set.t
; mutable dyn_deps : (unit, Pset.t) Build.t ; mutable dyn_deps : (unit, Path.Set.t) Build.t
; mutable actions : alias_action list ; mutable actions : alias_action list
} }
@ -346,7 +344,7 @@ module Dir_status = struct
type t = type t =
| Collecting_rules of rules_collector | Collecting_rules of rules_collector
| Loaded of Pset.t (* set of targets in the directory *) | Loaded of Path.Set.t (* set of targets in the directory *)
| Forward of Path.t (* Load this directory first *) | Forward of Path.t (* Load this directory first *)
| Failed_to_load | Failed_to_load
end end
@ -391,7 +389,7 @@ type t =
} }
let string_of_paths set = let string_of_paths set =
Pset.to_list set Path.Set.to_list set
|> List.map ~f:(fun p -> sprintf "- %s" |> List.map ~f:(fun p -> sprintf "- %s"
(Path.to_string_maybe_quoted (Path.to_string_maybe_quoted
(Path.drop_optional_build_context p))) (Path.drop_optional_build_context p)))
@ -407,19 +405,19 @@ let get_dir_status t ~dir =
Dir_status.Loaded (File_tree.files_of t.file_tree dir) Dir_status.Loaded (File_tree.files_of t.file_tree dir)
else if dir = Path.build_dir then else if dir = Path.build_dir then
(* Not allowed to look here *) (* Not allowed to look here *)
Dir_status.Loaded Pset.empty Dir_status.Loaded Path.Set.empty
else if not (Path.is_local dir) then else if not (Path.is_local dir) then
Dir_status.Loaded Dir_status.Loaded
(match Path.readdir dir with (match Path.readdir dir with
| exception _ -> Path.Set.empty | exception _ -> Path.Set.empty
| files -> | files ->
Pset.of_list (List.map files ~f:(Path.relative dir))) Path.Set.of_list (List.map files ~f:(Path.relative dir)))
else begin else begin
let (ctx, sub_dir) = Option.value_exn (Path.extract_build_context dir) in let (ctx, sub_dir) = Option.value_exn (Path.extract_build_context dir) in
if ctx = ".aliases" then if ctx = ".aliases" then
Forward (Path.(append build_dir) sub_dir) Forward (Path.(append build_dir) sub_dir)
else if ctx <> "install" && not (String.Map.mem t.contexts ctx) then else if ctx <> "install" && not (String.Map.mem t.contexts ctx) then
Dir_status.Loaded Pset.empty Dir_status.Loaded Path.Set.empty
else else
Collecting_rules Collecting_rules
{ rules = [] { rules = []
@ -457,7 +455,7 @@ module Build_exec = struct
let exec bs t x = let exec bs t x =
let rec exec let rec exec
: type a b. Pset.t ref -> (a, b) t -> a -> b = fun dyn_deps t x -> : type a b. Path.Set.t ref -> (a, b) t -> a -> b = fun dyn_deps t x ->
match t with match t with
| Arr f -> f x | Arr f -> f x
| Targets _ -> x | Targets _ -> x
@ -492,7 +490,7 @@ module Build_exec = struct
Option.value_exn file.data Option.value_exn file.data
| Dyn_paths t -> | Dyn_paths t ->
let fns = exec dyn_deps t x in let fns = exec dyn_deps t x in
dyn_deps := Pset.union !dyn_deps fns; dyn_deps := Path.Set.union !dyn_deps fns;
x x
| Record_lib_deps _ -> x | Record_lib_deps _ -> x
| Fail { fail } -> fail () | Fail { fail } -> fail ()
@ -507,23 +505,23 @@ module Build_exec = struct
| Memo m -> | Memo m ->
match m.state with match m.state with
| Evaluated (x, deps) -> | Evaluated (x, deps) ->
dyn_deps := Pset.union !dyn_deps deps; dyn_deps := Path.Set.union !dyn_deps deps;
x x
| Evaluating -> | Evaluating ->
die "Dependency cycle evaluating memoized build arrow %s" m.name die "Dependency cycle evaluating memoized build arrow %s" m.name
| Unevaluated -> | Unevaluated ->
m.state <- Evaluating; m.state <- Evaluating;
let dyn_deps' = ref Pset.empty in let dyn_deps' = ref Path.Set.empty in
match exec dyn_deps' m.t x with match exec dyn_deps' m.t x with
| x -> | x ->
m.state <- Evaluated (x, !dyn_deps'); m.state <- Evaluated (x, !dyn_deps');
dyn_deps := Pset.union !dyn_deps !dyn_deps'; dyn_deps := Path.Set.union !dyn_deps !dyn_deps';
x x
| exception exn -> | exception exn ->
m.state <- Unevaluated; m.state <- Unevaluated;
reraise exn reraise exn
in in
let dyn_deps = ref Pset.empty in let dyn_deps = ref Path.Set.empty in
let result = exec dyn_deps (Build.repr t) x in let result = exec dyn_deps (Build.repr t) x in
(result, !dyn_deps) (result, !dyn_deps)
end end
@ -580,29 +578,29 @@ let create_file_specs t targets rule ~copy_source =
(* This contains the targets of the actions that are being executed. On exit, we need to (* This contains the targets of the actions that are being executed. On exit, we need to
delete them as they might contain garbage *) delete them as they might contain garbage *)
let pending_targets = ref Pset.empty let pending_targets = ref Path.Set.empty
let () = let () =
at_exit (fun () -> at_exit (fun () ->
let fns = !pending_targets in let fns = !pending_targets in
pending_targets := Pset.empty; pending_targets := Path.Set.empty;
Pset.iter fns ~f:Path.unlink_no_err) Path.Set.iter fns ~f:Path.unlink_no_err)
let clear_targets_digests_after_rule_execution targets = let clear_targets_digests_after_rule_execution targets =
let missing = let missing =
List.fold_left targets ~init:Pset.empty ~f:(fun acc fn -> List.fold_left targets ~init:Path.Set.empty ~f:(fun acc fn ->
match Unix.lstat (Path.to_string fn) with match Unix.lstat (Path.to_string fn) with
| exception _ -> Pset.add acc fn | exception _ -> Path.Set.add acc fn
| (_ : Unix.stats) -> | (_ : Unix.stats) ->
Utils.Cached_digest.remove fn; Utils.Cached_digest.remove fn;
acc) acc)
in in
if not (Pset.is_empty missing) then if not (Path.Set.is_empty missing) then
die "@{<error>Error@}: Rule failed to generate the following targets:\n%s" die "@{<error>Error@}: Rule failed to generate the following targets:\n%s"
(string_of_paths missing) (string_of_paths missing)
let make_local_dirs t paths = let make_local_dirs t paths =
Pset.iter paths ~f:(fun path -> Path.Set.iter paths ~f:(fun path ->
match Path.kind path with match Path.kind path with
| Local path -> | Local path ->
if not (Path.Local.Set.mem t.local_mkdirs path) then begin if not (Path.Local.Set.mem t.local_mkdirs path) then begin
@ -612,7 +610,7 @@ let make_local_dirs t paths =
| _ -> ()) | _ -> ())
let make_local_parent_dirs t paths ~map_path = let make_local_parent_dirs t paths ~map_path =
Pset.iter paths ~f:(fun path -> Path.Set.iter paths ~f:(fun path ->
match Path.kind (map_path path) with match Path.kind (map_path path) with
| Local path when not (Path.Local.is_root path) -> | Local path when not (Path.Local.is_root path) ->
let parent = Path.Local.parent path in let parent = Path.Local.parent path in
@ -650,7 +648,7 @@ let remove_old_artifacts t ~dir ~subdirs_to_keep =
| All -> () | All -> ()
| These set -> | These set ->
if String.Set.mem set fn || if String.Set.mem set fn ||
Pset.mem t.build_dirs_to_keep path then Path.Set.mem t.build_dirs_to_keep path then
() ()
else else
Path.rm_rf path Path.rm_rf path
@ -709,14 +707,14 @@ let rec compile_rule t ?(copy_source=false) pre_rule =
wait_for_deps t static_deps) wait_for_deps t static_deps)
(fun () -> (fun () ->
Fiber.Future.wait rule_evaluation >>= fun (action, dyn_deps) -> Fiber.Future.wait rule_evaluation >>= fun (action, dyn_deps) ->
wait_for_deps t (Pset.diff dyn_deps static_deps) wait_for_deps t (Path.Set.diff dyn_deps static_deps)
>>| fun () -> >>| fun () ->
(action, dyn_deps)) (action, dyn_deps))
>>= fun (action, dyn_deps) -> >>= fun (action, dyn_deps) ->
make_local_parent_dirs t targets ~map_path:(fun x -> x); make_local_parent_dirs t targets ~map_path:(fun x -> x);
let all_deps = Pset.union static_deps dyn_deps in let all_deps = Path.Set.union static_deps dyn_deps in
let all_deps_as_list = Pset.to_list all_deps in let all_deps_as_list = Path.Set.to_list all_deps in
let targets_as_list = Pset.to_list targets in let targets_as_list = Path.Set.to_list targets in
let hash = let hash =
let trace = let trace =
(List.map all_deps_as_list ~f:(fun fn -> (List.map all_deps_as_list ~f:(fun fn ->
@ -756,7 +754,7 @@ let rec compile_rule t ?(copy_source=false) pre_rule =
begin begin
if deps_or_rule_changed || targets_missing || force then begin if deps_or_rule_changed || targets_missing || force then begin
List.iter targets_as_list ~f:Path.unlink_no_err; List.iter targets_as_list ~f:Path.unlink_no_err;
pending_targets := Pset.union targets !pending_targets; pending_targets := Path.Set.union targets !pending_targets;
let action = let action =
match sandbox_dir with match sandbox_dir with
| Some sandbox_dir -> | Some sandbox_dir ->
@ -781,7 +779,7 @@ let rec compile_rule t ?(copy_source=false) pre_rule =
Action.exec ~context ~targets action) >>| fun () -> Action.exec ~context ~targets action) >>| fun () ->
Option.iter sandbox_dir ~f:Path.rm_rf; Option.iter sandbox_dir ~f:Path.rm_rf;
(* All went well, these targets are no longer pending *) (* All went well, these targets are no longer pending *)
pending_targets := Pset.diff !pending_targets targets; pending_targets := Path.Set.diff !pending_targets targets;
clear_targets_digests_after_rule_execution targets_as_list clear_targets_digests_after_rule_execution targets_as_list
end else end else
Fiber.return () Fiber.return ()
@ -790,7 +788,7 @@ let rec compile_rule t ?(copy_source=false) pre_rule =
match mode with match mode with
| Standard | Fallback | Not_a_rule_stanza | Ignore_source_files -> () | Standard | Fallback | Not_a_rule_stanza | Ignore_source_files -> ()
| Promote | Promote_but_delete_on_clean -> | Promote | Promote_but_delete_on_clean ->
Pset.iter targets ~f:(fun path -> Path.Set.iter targets ~f:(fun path ->
let in_source_tree = Option.value_exn (Path.drop_build_context path) in let in_source_tree = Option.value_exn (Path.drop_build_context path) in
if not (Path.exists in_source_tree) || if not (Path.exists in_source_tree) ||
(Utils.Cached_digest.file path <> (Utils.Cached_digest.file path <>
@ -819,7 +817,7 @@ let rec compile_rule t ?(copy_source=false) pre_rule =
create_file_specs t target_specs rule ~copy_source create_file_specs t target_specs rule ~copy_source
and setup_copy_rules t ~ctx_dir ~non_target_source_files = and setup_copy_rules t ~ctx_dir ~non_target_source_files =
Pset.iter non_target_source_files ~f:(fun path -> Path.Set.iter non_target_source_files ~f:(fun path ->
let ctx_path = Path.append ctx_dir path in let ctx_path = Path.append ctx_dir path in
let build = Build.copy ~src:path ~dst:ctx_path in let build = Build.copy ~src:path ~dst:ctx_path in
(* We temporarily allow overrides while setting up copy rules from (* We temporarily allow overrides while setting up copy rules from
@ -830,7 +828,7 @@ and setup_copy_rules t ~ctx_dir ~non_target_source_files =
should allow it on a case-by-case basis though. *) should allow it on a case-by-case basis though. *)
compile_rule t (Pre_rule.make build ~context:None) ~copy_source:true) compile_rule t (Pre_rule.make build ~context:None) ~copy_source:true)
and load_dir t ~dir = ignore (load_dir_and_get_targets t ~dir : Pset.t) and load_dir t ~dir = ignore (load_dir_and_get_targets t ~dir : Path.Set.t)
and targets_of t ~dir = load_dir_and_get_targets t ~dir and targets_of t ~dir = load_dir_and_get_targets t ~dir
and load_dir_and_get_targets t ~dir = and load_dir_and_get_targets t ~dir =
@ -894,7 +892,7 @@ and load_dir_step2_exn t ~dir ~collector ~lazy_generators =
let alias_dir = Path.append (Path.relative alias_dir context_name) sub_dir in let alias_dir = Path.append (Path.relative alias_dir context_name) sub_dir in
let alias_rules, alias_stamp_files = let alias_rules, alias_stamp_files =
let open Build.O in let open Build.O in
String.Map.foldi collector.aliases ~init:([], Pset.empty) String.Map.foldi collector.aliases ~init:([], Path.Set.empty)
~f:(fun name { Dir_status. deps; dyn_deps; actions } (rules, alias_stamp_files) -> ~f:(fun name { Dir_status. deps; dyn_deps; actions } (rules, alias_stamp_files) ->
let base_path = Path.relative alias_dir name in let base_path = Path.relative alias_dir name in
let rules, deps = let rules, deps =
@ -909,7 +907,7 @@ and load_dir_step2_exn t ~dir ~collector ~lazy_generators =
Pre_rule.make ~locks ~context:(Some context) Pre_rule.make ~locks ~context:(Some context)
(Build.progn [ action; Build.create_file path ]) (Build.progn [ action; Build.create_file path ])
in in
(rule :: rules, Pset.add deps path)) (rule :: rules, Path.Set.add deps path))
in in
let path = Path.extend_basename base_path ~suffix:Alias0.suffix in let path = Path.extend_basename base_path ~suffix:Alias0.suffix in
(Pre_rule.make (Pre_rule.make
@ -918,30 +916,30 @@ and load_dir_step2_exn t ~dir ~collector ~lazy_generators =
dyn_deps >>> dyn_deps >>>
Build.dyn_path_set (Build.arr (fun x -> x)) Build.dyn_path_set (Build.arr (fun x -> x))
>>^ (fun dyn_deps -> >>^ (fun dyn_deps ->
let deps = Pset.union deps dyn_deps in let deps = Path.Set.union deps dyn_deps in
Action.with_stdout_to path Action.with_stdout_to path
(Action.digest_files (Pset.to_list deps))) (Action.digest_files (Path.Set.to_list deps)))
>>> >>>
Build.action_dyn () ~targets:[path]) Build.action_dyn () ~targets:[path])
:: rules, :: rules,
Pset.add alias_stamp_files path)) Path.Set.add alias_stamp_files path))
in in
Hashtbl.replace t.dirs ~key:alias_dir ~data:(Loaded alias_stamp_files); Hashtbl.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 *) (* Compute the set of targets and the set of source files that must not be copied *)
let user_rule_targets, source_files_to_ignore = let user_rule_targets, source_files_to_ignore =
List.fold_left rules ~init:(Pset.empty, Pset.empty) List.fold_left rules ~init:(Path.Set.empty, Path.Set.empty)
~f:(fun (acc_targets, acc_ignored) { Pre_rule.targets; mode; _ } -> ~f:(fun (acc_targets, acc_ignored) { Pre_rule.targets; mode; _ } ->
let targets = Build_interpret.Target.paths targets in let targets = Build_interpret.Target.paths targets in
(Pset.union targets acc_targets, (Path.Set.union targets acc_targets,
match mode with match mode with
| Promote | Promote_but_delete_on_clean | Ignore_source_files -> | Promote | Promote_but_delete_on_clean | Ignore_source_files ->
Pset.union targets acc_ignored Path.Set.union targets acc_ignored
| _ -> | _ ->
acc_ignored)) acc_ignored))
in in
let source_files_to_ignore = let source_files_to_ignore =
Pset.map source_files_to_ignore ~f:(fun p -> Path.Set.map source_files_to_ignore ~f:(fun p ->
Option.value_exn (Path.drop_build_context p)) Option.value_exn (Path.drop_build_context p))
in in
@ -957,18 +955,18 @@ and load_dir_step2_exn t ~dir ~collector ~lazy_generators =
assert (String.Map.mem t.contexts ctx_name); assert (String.Map.mem t.contexts ctx_name);
let files, subdirs = let files, subdirs =
match File_tree.find_dir t.file_tree sub_dir with match File_tree.find_dir t.file_tree sub_dir with
| None -> (Pset.empty, String.Set.empty) | None -> (Path.Set.empty, String.Set.empty)
| Some dir -> | Some dir ->
(File_tree.Dir.file_paths dir, (File_tree.Dir.file_paths dir,
File_tree.Dir.sub_dir_names dir) File_tree.Dir.sub_dir_names dir)
in in
let files = Pset.diff files source_files_to_ignore in let files = Path.Set.diff files source_files_to_ignore in
if Pset.is_empty files then if Path.Set.is_empty files then
(user_rule_targets, None, subdirs) (user_rule_targets, None, subdirs)
else else
let ctx_path = Path.(relative build_dir) context_name in let ctx_path = Path.(relative build_dir) context_name in
(Pset.union user_rule_targets (Path.Set.union user_rule_targets
(Pset.map files ~f:(Path.append ctx_path)), (Path.Set.map files ~f:(Path.append ctx_path)),
Some (ctx_path, files), Some (ctx_path, files),
subdirs) subdirs)
in in
@ -992,9 +990,9 @@ and load_dir_step2_exn t ~dir ~collector ~lazy_generators =
| Not_a_rule_stanza | Ignore_source_files -> true | Not_a_rule_stanza | Ignore_source_files -> true
| Fallback -> | Fallback ->
let source_files_for_targtes = let source_files_for_targtes =
List.fold_left rule.targets ~init:Pset.empty List.fold_left rule.targets ~init:Path.Set.empty
~f:(fun acc target -> ~f:(fun acc target ->
Pset.add acc Path.Set.add acc
(Build_interpret.Target.path target (Build_interpret.Target.path target
|> Path.drop_build_context |> Path.drop_build_context
(* All targets are in [dir] and we know it (* All targets are in [dir] and we know it
@ -1003,19 +1001,19 @@ and load_dir_step2_exn t ~dir ~collector ~lazy_generators =
call can't fail. *) call can't fail. *)
|> Option.value_exn)) |> Option.value_exn))
in in
if Pset.is_subset source_files_for_targtes ~of_:to_copy then if Path.Set.is_subset source_files_for_targtes ~of_:to_copy then
(* All targets are present *) (* All targets are present *)
false false
else begin else begin
if Pset.is_empty (Pset.inter source_files_for_targtes to_copy) then if Path.Set.is_empty (Path.Set.inter source_files_for_targtes to_copy) then
(* No target is present *) (* No target is present *)
true true
else begin else begin
let absent_targets = let absent_targets =
Pset.diff source_files_for_targtes to_copy Path.Set.diff source_files_for_targtes to_copy
in in
let present_targets = let present_targets =
Pset.diff source_files_for_targtes absent_targets Path.Set.diff source_files_for_targtes absent_targets
in in
Loc.fail Loc.fail
(rule_loc (rule_loc
@ -1098,7 +1096,7 @@ and wait_for_file_found fn (File_spec.T file) =
Fiber.Future.wait rule_execution) Fiber.Future.wait rule_execution)
and wait_for_deps t deps = and wait_for_deps t deps =
Fiber.parallel_iter (Pset.to_list deps) ~f:(wait_for_file t) Fiber.parallel_iter (Path.Set.to_list deps) ~f:(wait_for_file t)
let stamp_file_for_files_of t ~dir ~ext = let stamp_file_for_files_of t ~dir ~ext =
let files_of_dir = let files_of_dir =
@ -1142,8 +1140,8 @@ module Trace = struct
let dump (trace : t) = let dump (trace : t) =
let sexp = let sexp =
Sexp.List ( Sexp.List (
Hashtbl.foldi trace ~init:Pmap.empty ~f:(fun key data acc -> Hashtbl.foldi trace ~init:Path.Map.empty ~f:(fun key data acc ->
Pmap.add acc key data) Path.Map.add acc key data)
|> Path.Map.to_list |> Path.Map.to_list
|> List.map ~f:(fun (path, hash) -> |> List.map ~f:(fun (path, hash) ->
Sexp.List [ Path.sexp_of_t path; Sexp.List [ Path.sexp_of_t path;
@ -1199,7 +1197,7 @@ let create ~contexts ~file_tree ~hook =
; file_tree ; file_tree
; gen_rules = String.Map.map contexts ~f:(fun _ ~dir:_ -> ; gen_rules = String.Map.map contexts ~f:(fun _ ~dir:_ ->
die "gen_rules called too early") die "gen_rules called too early")
; build_dirs_to_keep = Pset.empty ; build_dirs_to_keep = Path.Set.empty
; files_of = Hashtbl.create 1024 ; files_of = Hashtbl.create 1024
; prefix = None ; prefix = None
; hook ; hook
@ -1217,7 +1215,7 @@ let eval_request t ~request ~process_target =
in in
let process_targets ts = let process_targets ts =
Fiber.parallel_iter (Pset.to_list ts) ~f:process_target Fiber.parallel_iter (Path.Set.to_list ts) ~f:process_target
in in
Fiber.fork_and_join_unit Fiber.fork_and_join_unit
@ -1226,7 +1224,7 @@ let eval_request t ~request ~process_target =
wait_for_deps t rule_deps wait_for_deps t rule_deps
>>= fun () -> >>= fun () ->
let result, dyn_deps = Build_exec.exec t request () in let result, dyn_deps = Build_exec.exec t request () in
process_targets (Pset.diff dyn_deps static_deps) process_targets (Path.Set.diff dyn_deps static_deps)
>>| fun () -> >>| fun () ->
result) result)
@ -1241,7 +1239,7 @@ let update_universe t =
else else
0 0
in in
make_local_dirs t (Pset.singleton Path.build_dir); make_local_dirs t (Path.Set.singleton Path.build_dir);
Io.write_file universe_file (Sexp.to_string (Sexp.To_sexp.int n)) Io.write_file universe_file (Sexp.to_string (Sexp.To_sexp.int n))
let do_build t ~request = let do_build t ~request =
@ -1267,8 +1265,8 @@ let rules_for_targets t targets =
~key:(fun (r : Internal_rule.t) -> r.id) ~key:(fun (r : Internal_rule.t) -> r.id)
~deps:(fun (r : Internal_rule.t) -> ~deps:(fun (r : Internal_rule.t) ->
rules_for_files t rules_for_files t
(Pset.to_list (Path.Set.to_list
(Pset.union (Path.Set.union
r.static_deps r.static_deps
r.rule_deps))) r.rule_deps)))
with with
@ -1277,7 +1275,7 @@ let rules_for_targets t targets =
die "dependency cycle detected:\n %s" die "dependency cycle detected:\n %s"
(List.map cycle ~f:(fun rule -> (List.map cycle ~f:(fun rule ->
Path.to_string (Option.value_exn Path.to_string (Option.value_exn
(Pset.choose rule.Internal_rule.targets))) (Path.Set.choose rule.Internal_rule.targets)))
|> String.concat ~sep:"\n-> ") |> String.concat ~sep:"\n-> ")
let static_deps_of_request t request = let static_deps_of_request t request =
@ -1287,22 +1285,22 @@ let static_deps_of_request t request =
} = Build_interpret.static_deps request ~all_targets:(targets_of t) } = Build_interpret.static_deps request ~all_targets:(targets_of t)
~file_tree:t.file_tree ~file_tree:t.file_tree
in in
Pset.to_list (Pset.union rule_deps action_deps) Path.Set.to_list (Path.Set.union rule_deps action_deps)
let all_lib_deps t ~request = let all_lib_deps t ~request =
let targets = static_deps_of_request t request in let targets = static_deps_of_request t request in
List.fold_left (rules_for_targets t targets) ~init:Pmap.empty List.fold_left (rules_for_targets t targets) ~init:Path.Map.empty
~f:(fun acc (rule : Internal_rule.t) -> ~f:(fun acc (rule : Internal_rule.t) ->
let deps = Build_interpret.lib_deps rule.build in let deps = Build_interpret.lib_deps rule.build in
if String.Map.is_empty deps then if String.Map.is_empty deps then
acc acc
else else
let deps = let deps =
match Pmap.find acc rule.dir with match Path.Map.find acc rule.dir with
| None -> deps | None -> deps
| Some deps' -> Build.merge_lib_deps deps deps' | Some deps' -> Build.merge_lib_deps deps deps'
in in
Pmap.add acc rule.dir deps) Path.Map.add acc rule.dir deps)
let all_lib_deps_by_context t ~request = let all_lib_deps_by_context t ~request =
let targets = static_deps_of_request t request in let targets = static_deps_of_request t request in
@ -1339,7 +1337,7 @@ module Rule_set = Set.Make(Rule)
let rules_for_files rules paths = let rules_for_files rules paths =
List.fold_left paths ~init:Rule_set.empty ~f:(fun acc path -> List.fold_left paths ~init:Rule_set.empty ~f:(fun acc path ->
match Pmap.find rules path with match Path.Map.find rules path with
| None -> acc | None -> acc
| Some rule -> Rule_set.add acc rule) | Some rule -> Rule_set.add acc rule)
|> Rule_set.to_list |> Rule_set.to_list
@ -1379,7 +1377,7 @@ let build_rules_internal ?(recursive=false) t ~request =
>>| fun (action, dyn_deps) -> >>| fun (action, dyn_deps) ->
{ Rule. { Rule.
id = ir.id id = ir.id
; deps = Pset.union ir.static_deps dyn_deps ; deps = Path.Set.union ir.static_deps dyn_deps
; targets = ir.targets ; targets = ir.targets
; context = ir.context ; context = ir.context
; action = action ; action = action
@ -1390,33 +1388,33 @@ let build_rules_internal ?(recursive=false) t ~request =
Fiber.return () Fiber.return ()
else else
Fiber.Future.wait rule >>= fun rule -> Fiber.Future.wait rule >>= fun rule ->
Fiber.parallel_iter (Pset.to_list rule.deps) ~f:loop Fiber.parallel_iter (Path.Set.to_list rule.deps) ~f:loop
end end
in in
let targets = ref Pset.empty in let targets = ref Path.Set.empty in
eval_request t ~request ~process_target:(fun fn -> eval_request t ~request ~process_target:(fun fn ->
targets := Pset.add !targets fn; targets := Path.Set.add !targets fn;
loop fn) loop fn)
>>= fun () -> >>= fun () ->
Fiber.all (List.map !rules ~f:Fiber.Future.wait) Fiber.all (List.map !rules ~f:Fiber.Future.wait)
>>| fun rules -> >>| fun rules ->
let rules = let rules =
List.fold_left rules ~init:Pmap.empty ~f:(fun acc (r : Rule.t) -> List.fold_left rules ~init:Path.Map.empty ~f:(fun acc (r : Rule.t) ->
Pset.fold r.targets ~init:acc ~f:(fun fn acc -> Path.Set.fold r.targets ~init:acc ~f:(fun fn acc ->
Pmap.add acc fn r)) Path.Map.add acc fn r))
in in
match match
Rule.Id.Top_closure.top_closure Rule.Id.Top_closure.top_closure
(rules_for_files rules (Pset.to_list !targets)) (rules_for_files rules (Path.Set.to_list !targets))
~key:(fun (r : Rule.t) -> r.id) ~key:(fun (r : Rule.t) -> r.id)
~deps:(fun (r : Rule.t) -> ~deps:(fun (r : Rule.t) ->
rules_for_files rules (Pset.to_list r.deps)) rules_for_files rules (Path.Set.to_list r.deps))
with with
| Ok l -> l | Ok l -> l
| Error cycle -> | Error cycle ->
die "dependency cycle detected:\n %s" die "dependency cycle detected:\n %s"
(List.map cycle ~f:(fun rule -> (List.map cycle ~f:(fun rule ->
Path.to_string (Option.value_exn (Pset.choose rule.Rule.targets))) Path.to_string (Option.value_exn (Path.Set.choose rule.Rule.targets)))
|> String.concat ~sep:"\n-> ") |> String.concat ~sep:"\n-> ")
let build_rules ?recursive t ~request = let build_rules ?recursive t ~request =
@ -1454,22 +1452,22 @@ let package_deps t pkg files =
Option.value_exn (Fiber.Future.peek rule_evaluation) Option.value_exn (Fiber.Future.peek rule_evaluation)
| Not_started _ -> assert false | Not_started _ -> assert false
in in
Pset.fold (Pset.union ir.static_deps dyn_deps) ~init:acc ~f:loop Path.Set.fold (Path.Set.union ir.static_deps dyn_deps) ~init:acc ~f:loop
end end
in in
let open Build.O in let open Build.O in
Build.paths_for_rule files >>^ fun () -> Build.paths_for_rule files >>^ fun () ->
(* We know that at this point of execution, all the relevant ivars (* We know that at this point of execution, all the relevant ivars
have been filled *) have been filled *)
Pset.fold files ~init:Package.Name.Set.empty ~f:loop_deps Path.Set.fold files ~init:Package.Name.Set.empty ~f:loop_deps
(* +-----------------------------------------------------------------+ (* +-----------------------------------------------------------------+
| Adding rules to the system | | Adding rules to the system |
+-----------------------------------------------------------------+ *) +-----------------------------------------------------------------+ *)
let rec add_build_dir_to_keep t ~dir = let rec add_build_dir_to_keep t ~dir =
if not (Pset.mem t.build_dirs_to_keep dir) then begin if not (Path.Set.mem t.build_dirs_to_keep dir) then begin
t.build_dirs_to_keep <- Pset.add t.build_dirs_to_keep dir; t.build_dirs_to_keep <- Path.Set.add t.build_dirs_to_keep dir;
Option.iter (Path.parent dir) ~f:(fun dir -> Option.iter (Path.parent dir) ~f:(fun dir ->
if not (Path.is_root dir) then if not (Path.is_root dir) then
add_build_dir_to_keep t ~dir) add_build_dir_to_keep t ~dir)
@ -1537,7 +1535,7 @@ let on_load_dir t ~dir ~f =
p.lazy_generators <- f :: lazy_generators p.lazy_generators <- f :: lazy_generators
let eval_glob t ~dir re = let eval_glob t ~dir re =
let targets = targets_of t ~dir |> Pset.to_list |> List.map ~f:Path.basename in let targets = targets_of t ~dir |> Path.Set.to_list |> List.map ~f:Path.basename in
let files = let files =
match File_tree.find_dir t.file_tree dir with match File_tree.find_dir t.file_tree dir with
| None -> targets | None -> targets
@ -1556,8 +1554,8 @@ module Alias = struct
| None -> | None ->
let x = let x =
{ Dir_status. { Dir_status.
deps = Pset.empty deps = Path.Set.empty
; dyn_deps = Build.return Pset.empty ; dyn_deps = Build.return Path.Set.empty
; actions = [] ; actions = []
} }
in in
@ -1567,14 +1565,14 @@ module Alias = struct
let add_deps build_system t ?dyn_deps deps = let add_deps build_system t ?dyn_deps deps =
let def = get_alias_def build_system t in let def = get_alias_def build_system t in
def.deps <- Pset.union def.deps deps; def.deps <- Path.Set.union def.deps deps;
match dyn_deps with match dyn_deps with
| None -> () | None -> ()
| Some build -> | Some build ->
let open Build.O in let open Build.O in
def.dyn_deps <- def.dyn_deps <-
Build.fanout def.dyn_deps build >>^ fun (a, b) -> Build.fanout def.dyn_deps build >>^ fun (a, b) ->
Pset.union a b Path.Set.union a b
let add_action build_system t ~context ?(locks=[]) ~stamp action = let add_action build_system t ~context ?(locks=[]) ~stamp action =
let def = get_alias_def build_system t in let def = get_alias_def build_system t in
@ -1586,4 +1584,4 @@ module Alias = struct
end end
let is_target t file = let is_target t file =
Pset.mem (targets_of t ~dir:(Path.parent_exn file)) file Path.Set.mem (targets_of t ~dir:(Path.parent_exn file)) file

6
src/configurator/v1.ml
View File

@ -7,8 +7,6 @@ let ( ^/ ) = Filename.concat
exception Fatal_error of string exception Fatal_error of string
module Int_map = Stdune.Map.Make(Stdune.Int)
let die fmt = let die fmt =
Printf.ksprintf (fun s -> Printf.ksprintf (fun s ->
raise (Fatal_error s); raise (Fatal_error s);
@ -363,12 +361,12 @@ const char *s%i = "BEGIN-%i-false-END";
let extract_values obj_file vars = let extract_values obj_file vars =
let values = let values =
Io.with_lexbuf_from_file obj_file ~f:(Extract_obj.extract []) Io.with_lexbuf_from_file obj_file ~f:(Extract_obj.extract [])
|> Int_map.of_list_exn |> Int.Map.of_list_exn
in in
List.mapi vars ~f:(fun i (name, t) -> List.mapi vars ~f:(fun i (name, t) ->
let value = let value =
let raw_val = let raw_val =
match Int_map.find values i with match Int.Map.find values i with
| None -> die "Unable to get value for %s" name | None -> die "Unable to get value for %s" name
| Some v -> v in | Some v -> v in
match t with match t with

16
src/fiber/fiber.ml
View File

@ -45,8 +45,6 @@ module Binding = struct
type t = T : 'a Var0.t * 'a -> t type t = T : 'a Var0.t * 'a -> t
end end
module Int_map = Map.Make(Int)
module Execution_context : sig module Execution_context : sig
type t type t
@ -68,14 +66,14 @@ module Execution_context : sig
-> on_error:(exn -> unit) -> on_error:(exn -> unit)
-> t -> t
val vars : t -> Binding.t Int_map.t val vars : t -> Binding.t Int.Map.t
val set_vars : t -> Binding.t Int_map.t -> t val set_vars : t -> Binding.t Int.Map.t -> t
end = struct end = struct
type t = type t =
{ on_error : exn -> unit (* This callback must never raise *) { on_error : exn -> unit (* This callback must never raise *)
; fibers : int ref (* Number of fibers running in this execution ; fibers : int ref (* Number of fibers running in this execution
context *) context *)
; vars : Binding.t Int_map.t ; vars : Binding.t Int.Map.t
; on_release : unit -> unit ; on_release : unit -> unit
} }
@ -85,7 +83,7 @@ end = struct
let create_initial () = let create_initial () =
{ on_error = reraise { on_error = reraise
; fibers = ref 1 ; fibers = ref 1
; vars = Int_map.empty ; vars = Int.Map.empty
; on_release = ignore ; on_release = ignore
} }
@ -274,14 +272,14 @@ module Var = struct
include Var0 include Var0
let find ctx var = let find ctx var =
match Int_map.find (EC.vars ctx) (id var) with match Int.Map.find (EC.vars ctx) (id var) with
| None -> None | None -> None
| Some (Binding.T (var', v)) -> | Some (Binding.T (var', v)) ->
let eq = eq var' var in let eq = eq var' var in
Some (Eq.cast eq v) Some (Eq.cast eq v)
let find_exn ctx var = let find_exn ctx var =
match Int_map.find (EC.vars ctx) (id var) with match Int.Map.find (EC.vars ctx) (id var) with
| None -> failwith "Fiber.Var.find_exn" | None -> failwith "Fiber.Var.find_exn"
| Some (Binding.T (var', v)) -> | Some (Binding.T (var', v)) ->
let eq = eq var' var in let eq = eq var' var in
@ -293,7 +291,7 @@ module Var = struct
let set (type a) (var : a t) x fiber ctx k = let set (type a) (var : a t) x fiber ctx k =
let (module M) = var in let (module M) = var in
let data = Binding.T (var, x) in let data = Binding.T (var, x) in
let ctx = EC.set_vars ctx (Int_map.add (EC.vars ctx) M.id data) in let ctx = EC.set_vars ctx (Int.Map.add (EC.vars ctx) M.id data) in
fiber ctx k fiber ctx k
end end

59
src/import.ml
View File

@ -18,9 +18,6 @@ module String_map = struct
) fmt (to_list t) ) fmt (to_list t)
end end
module Int_set = Set.Make(Int)
module Int_map = Map.Make(Int)
module Sys = struct module Sys = struct
include Sys include Sys
@ -99,62 +96,6 @@ module No_io = struct
module Io = struct end module Io = struct end
end end
module Fmt = struct
(* CR-someday diml: we should define a GADT for this:
{[
type 'a t =
| Int : int t
| Box : ...
| Colored : ...
]}
This way we could separate the creation of messages from the
actual rendering.
*)
type 'a t = Format.formatter -> 'a -> unit
let kstrf f fmt =
let buf = Buffer.create 17 in
let f fmt = Format.pp_print_flush fmt () ; f (Buffer.contents buf) in
Format.kfprintf f (Format.formatter_of_buffer buf) fmt
let failwith fmt = kstrf failwith fmt
let list = Format.pp_print_list
let string s ppf = Format.pp_print_string ppf s
let nl = Format.pp_print_newline
let prefix f g ppf x = f ppf; g ppf x
let ocaml_list pp fmt = function
| [] -> Format.pp_print_string fmt "[]"
| l ->
Format.fprintf fmt "@[<hv>[ %a@ ]@]"
(list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@,; ")
pp) l
let quoted fmt = Format.fprintf fmt "%S"
let const
: 'a t -> 'a -> unit t
= fun pp a' fmt () -> pp fmt a'
let record fmt = function
| [] -> Format.pp_print_string fmt "{}"
| xs ->
let pp fmt (field, pp) =
Format.fprintf fmt "@[<hov 1>%s@ =@ %a@]"
field pp () in
let pp_sep fmt () = Format.fprintf fmt "@,; " in
Format.fprintf fmt "@[<hv>{ %a@ }@]"
(Format.pp_print_list ~pp_sep pp) xs
let tuple ppfa ppfb fmt (a, b) =
Format.fprintf fmt "@[<hv>(%a, %a)@]" ppfa a ppfb b
end
(* This is ugly *) (* This is ugly *)
let printer = ref (Printf.eprintf "%s%!") let printer = ref (Printf.eprintf "%s%!")
let print_to_console s = !printer s let print_to_console s = !printer s

12
src/jbuild.ml
View File

@ -1252,12 +1252,12 @@ module Stanzas = struct
[ cstr "library" (Library.v1 project @> nil) (fun x -> [Library x]) [ cstr "library" (Library.v1 project @> nil) (fun x -> [Library x])
; cstr "executable" (Executables.v1_single project @> nil) execs ; cstr "executable" (Executables.v1_single project @> nil) execs
; cstr "executables" (Executables.v1_multi project @> nil) execs ; cstr "executables" (Executables.v1_multi project @> nil) execs
; cstr_loc "rule" (Rule.v1 @> nil) (fun loc x -> [Rule { x with loc }]) ; cstr "rule" (cstr_loc (Rule.v1 @> nil)) (fun loc x -> [Rule { x with loc }])
; cstr_loc "ocamllex" (Rule.ocamllex_v1 @> nil) ; cstr "ocamllex" (cstr_loc (Rule.ocamllex_v1 @> nil))
(fun loc x -> rules (Rule.ocamllex_to_rule loc x)) (fun loc x -> rules (Rule.ocamllex_to_rule loc x))
; cstr_loc "ocamlyacc" (Rule.ocamlyacc_v1 @> nil) ; cstr "ocamlyacc" (cstr_loc (Rule.ocamlyacc_v1 @> nil))
(fun loc x -> rules (Rule.ocamlyacc_to_rule loc x)) (fun loc x -> rules (Rule.ocamlyacc_to_rule loc x))
; cstr_loc "menhir" (Menhir.v1 @> nil) ; cstr "menhir" (cstr_loc (Menhir.v1 @> nil))
(fun loc x -> [Menhir { x with loc }]) (fun loc x -> [Menhir { x with loc }])
; cstr "install" (Install_conf.v1 project @> nil) (fun x -> [Install x]) ; cstr "install" (Install_conf.v1 project @> nil) (fun x -> [Install x])
; cstr "alias" (Alias_conf.v1 project @> nil) (fun x -> [Alias x]) ; cstr "alias" (Alias_conf.v1 project @> nil) (fun x -> [Alias x])
@ -1265,11 +1265,11 @@ module Stanzas = struct
(fun glob -> [Copy_files {add_line_directive = false; glob}]) (fun glob -> [Copy_files {add_line_directive = false; glob}])
; cstr "copy_files#" (Copy_files.v1 @> nil) ; cstr "copy_files#" (Copy_files.v1 @> nil)
(fun glob -> [Copy_files {add_line_directive = true; glob}]) (fun glob -> [Copy_files {add_line_directive = true; glob}])
; cstr_rest_loc "env" nil Env.rule ; cstr "env" (cstr_loc (rest Env.rule))
(fun loc rules -> [Env { loc; rules }]) (fun loc rules -> [Env { loc; rules }])
(* Just for validation and error messages *) (* Just for validation and error messages *)
; cstr "jbuild_version" (Jbuild_version.t @> nil) (fun _ -> []) ; cstr "jbuild_version" (Jbuild_version.t @> nil) (fun _ -> [])
; cstr_loc "include" (relative_file @> nil) (fun loc fn -> ; cstr "include" (cstr_loc (relative_file @> nil)) (fun loc fn ->
let include_stack = (loc, file) :: include_stack in let include_stack = (loc, file) :: include_stack in
let dir = Path.parent_exn file in let dir = Path.parent_exn file in
let file = Path.relative dir fn in let file = Path.relative dir fn in

18
src/lib.ml
View File

@ -436,12 +436,12 @@ module L = struct
match l with match l with
| [] -> acc | [] -> acc
| x :: l -> | x :: l ->
if Int_set.mem seen x.unique_id then if Int.Set.mem seen x.unique_id then
loop acc l seen loop acc l seen
else else
loop (x :: acc) l (Int_set.add seen x.unique_id) loop (x :: acc) l (Int.Set.add seen x.unique_id)
in in
loop [] l Int_set.empty loop [] l Int.Set.empty
end end
(* +-----------------------------------------------------------------+ (* +-----------------------------------------------------------------+
@ -523,12 +523,12 @@ let gen_unique_id =
module Dep_stack = struct module Dep_stack = struct
type t = type t =
{ stack : Id.t list { stack : Id.t list
; seen : Int_set.t ; seen : Int.Set.t
} }
let empty = let empty =
{ stack = [] { stack = []
; seen = Int_set.empty ; seen = Int.Set.empty
} }
let to_required_by t ~stop_at = let to_required_by t ~stop_at =
@ -545,7 +545,7 @@ module Dep_stack = struct
loop [] t.stack loop [] t.stack
let dependency_cycle t (last : Id.t) = let dependency_cycle t (last : Id.t) =
assert (Int_set.mem t.seen last.unique_id); assert (Int.Set.mem t.seen last.unique_id);
let rec build_loop acc stack = let rec build_loop acc stack =
match stack with match stack with
| [] -> assert false | [] -> assert false
@ -564,15 +564,15 @@ module Dep_stack = struct
let init = { Id. unique_id; name; path } in let init = { Id. unique_id; name; path } in
(init, (init,
{ stack = init :: t.stack { stack = init :: t.stack
; seen = Int_set.add t.seen unique_id ; seen = Int.Set.add t.seen unique_id
}) })
let push t (x : Id.t) : (_, _) result = let push t (x : Id.t) : (_, _) result =
if Int_set.mem t.seen x.unique_id then if Int.Set.mem t.seen x.unique_id then
Error (dependency_cycle t x) Error (dependency_cycle t x)
else else
Ok { stack = x :: t.stack Ok { stack = x :: t.stack
; seen = Int_set.add t.seen x.unique_id ; seen = Int.Set.add t.seen x.unique_id
} }
end end

5
src/package.ml
View File

@ -1,7 +1,10 @@
open Stdune open Stdune
module Name = struct module Name = struct
include Interned.Make() include Interned.Make(struct
let initial_size = 16
let resize_policy = Interned.Conservative
end)
let of_string = make let of_string = make

3
src/process.ml
View File

@ -46,7 +46,7 @@ and opened_file_desc =
type purpose = type purpose =
| Internal_job | Internal_job
| Build_job of Path.t list | Build_job of Path.Set.t
module Temp = struct module Temp = struct
let tmp_files = ref Path.Set.empty let tmp_files = ref Path.Set.empty
@ -157,6 +157,7 @@ module Fancy = struct
split_paths (("alias " ^ Path.to_string name) :: targets_acc) split_paths (("alias " ^ Path.to_string name) :: targets_acc)
(add_ctx ctx ctxs_acc) rest (add_ctx ctx ctxs_acc) rest
in in
let targets = Path.Set.to_list targets in
let target_names, contexts = split_paths [] [] targets in let target_names, contexts = split_paths [] [] targets in
let target_names_grouped_by_prefix = let target_names_grouped_by_prefix =
List.map target_names ~f:Filename.split_extension_after_dot List.map target_names ~f:Filename.split_extension_after_dot

2
src/process.mli
View File

@ -34,7 +34,7 @@ and opened_file_desc =
(** Why a Fiber.t was run *) (** Why a Fiber.t was run *)
type purpose = type purpose =
| Internal_job | Internal_job
| Build_job of Path.t list | Build_job of Path.Set.t
(** [run ?dir ?stdout_to prog args] spawns a sub-process and wait for its termination *) (** [run ?dir ?stdout_to prog args] spawns a sub-process and wait for its termination *)
val run val run

54
src/stdune/fmt.ml Normal file
View File

@ -0,0 +1,54 @@
(* CR-someday diml: we should define a GADT for this:
{[
type 'a t =
| Int : int t
| Box : ...
| Colored : ...
]}
This way we could separate the creation of messages from the
actual rendering.
*)
type 'a t = Format.formatter -> 'a -> unit
let kstrf f fmt =
let buf = Buffer.create 17 in
let f fmt = Format.pp_print_flush fmt () ; f (Buffer.contents buf) in
Format.kfprintf f (Format.formatter_of_buffer buf) fmt
let failwith fmt = kstrf failwith fmt
let list = Format.pp_print_list
let string s ppf = Format.pp_print_string ppf s
let nl = Format.pp_print_newline
let prefix f g ppf x = f ppf; g ppf x
let ocaml_list pp fmt = function
| [] -> Format.pp_print_string fmt "[]"
| l ->
Format.fprintf fmt "@[<hv>[ %a@ ]@]"
(list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@,; ")
pp) l
let quoted fmt = Format.fprintf fmt "%S"
let const
: 'a t -> 'a -> unit t
= fun pp a' fmt () -> pp fmt a'
let record fmt = function
| [] -> Format.pp_print_string fmt "{}"
| xs ->
let pp fmt (field, pp) =
Format.fprintf fmt "@[<hov 1>%s@ =@ %a@]"
field pp () in
let pp_sep fmt () = Format.fprintf fmt "@,; " in
Format.fprintf fmt "@[<hv>{ %a@ }@]"
(Format.pp_print_list ~pp_sep pp) xs
let tuple ppfa ppfb fmt (a, b) =
Format.fprintf fmt "@[<hv>(%a, %a)@]" ppfa a ppfb b

24
src/stdune/fmt.mli Normal file
View File

@ -0,0 +1,24 @@
type 'a t = Format.formatter -> 'a -> unit
val list : ?pp_sep:unit t -> 'a t -> 'a list t
val failwith : ('a, Format.formatter, unit, 'b) format4 -> 'a
val string : string -> Format.formatter -> unit
val prefix
: (Format.formatter -> unit)
-> (Format.formatter -> 'b -> 'c)
-> (Format.formatter -> 'b -> 'c)
val ocaml_list : 'a t -> 'a list t
val quoted : string t
val const : 'a t -> 'a -> unit t
val record : (string * unit t) list t
val tuple : 'a t -> 'b t -> ('a * 'b) t
val nl : unit t

23
src/stdune/int.ml
View File

@ -1,8 +1,15 @@
type t = int module T = struct
let compare (a : int) b : Ordering.t = type t = int
if a < b then let compare (a : int) b : Ordering.t =
Lt if a < b then
else if a = b then Lt
Eq else if a = b then
else Eq
Gt else
Gt
end
include T
module Set = Set.Make(T)
module Map = Map.Make(T)

3
src/stdune/int.mli
View File

@ -1,2 +1,5 @@
type t = int type t = int
val compare : t -> t -> Ordering.t val compare : t -> t -> Ordering.t
module Set : Set.S with type elt = t
module Map : Map.S with type key = t

30
src/interned.ml → src/stdune/interned.ml
View File

@ -1,5 +1,3 @@
open Import
module type S = sig module type S = sig
type t type t
val compare : t -> t -> Ordering.t val compare : t -> t -> Ordering.t
@ -22,12 +20,26 @@ module type S = sig
end with type key := t end with type key := t
end end
module Make() = struct type resize_policy = Conservative | Greedy
include Int
let new_size ~next ~size = function
| Conservative ->
let increment_size = 512 in
(next land (lnot (increment_size - 1))) + (increment_size * 2)
| Greedy -> size * 2
module Make(R : sig
val resize_policy : resize_policy
val initial_size : int
end)
= struct
type t = int
let ids = Hashtbl.create 1024 let ids = Hashtbl.create 1024
let next = ref 0 let next = ref 0
let compare = Int.compare
module Table = struct module Table = struct
type 'a t = type 'a t =
{ default_value : 'a { default_value : 'a
@ -36,12 +48,12 @@ module Make() = struct
let create ~default_value = let create ~default_value =
{ default_value { default_value
; data = [||] ; data = Array.make R.initial_size default_value
} }
let resize t = let resize t =
let increment_size = 512 in let n =
let n = (!next land (lnot (increment_size - 1))) + (increment_size * 2) in new_size ~next:!next ~size:(Array.length t.data) R.resize_policy in
let old_data = t.data in let old_data = t.data in
let new_data = Array.make n t.default_value in let new_data = Array.make n t.default_value in
t.data <- new_data; t.data <- new_data;
@ -77,7 +89,7 @@ module Make() = struct
let pp fmt t = Format.fprintf fmt "%S" (to_string t) let pp fmt t = Format.fprintf fmt "%S" (to_string t)
module Set = struct module Set = struct
include Int_set include Int.Set
let make l = let make l =
List.fold_left l ~init:empty ~f:(fun acc s -> add acc (make s)) List.fold_left l ~init:empty ~f:(fun acc s -> add acc (make s))
@ -85,5 +97,5 @@ module Make() = struct
let pp fmt (t : t) = Fmt.ocaml_list pp fmt (to_list t) let pp fmt (t : t) = Fmt.ocaml_list pp fmt (to_list t)
end end
module Map = Int_map module Map = Int.Map
end end

9
src/interned.mli → src/stdune/interned.mli
View File

@ -1,7 +1,5 @@
(** Interned strings *) (** Interned strings *)
open! Import
module type S = sig module type S = sig
type t type t
val compare : t -> t -> Ordering.t val compare : t -> t -> Ordering.t
@ -36,4 +34,9 @@ module type S = sig
end with type key := t end with type key := t
end end
module Make() : S type resize_policy = Conservative | Greedy
module Make(R : sig
val initial_size : int
val resize_policy : resize_policy
end) : S

94
src/stdune/sexp.ml
View File

@ -336,35 +336,43 @@ module Of_sexp = struct
of_sexp_errorf ~hint:({ on = name ; candidates = state.known}) of_sexp_errorf ~hint:({ on = name ; candidates = state.known})
name_sexp "Unknown field %s" name name_sexp "Unknown field %s" name
type ('a, 'b) rest =
| No_rest : ('a, 'a) rest
| Many : 'a t -> ('a list -> 'b, 'b) rest
module Constructor_args_spec = struct module Constructor_args_spec = struct
type 'a conv = 'a t type 'a conv = 'a t
type ('a, 'b) t = type ('a, 'b) t =
| Nil : ('a, 'a) t | Nil : ('a, 'a) t
| Cons : 'a conv * ('b, 'c) t -> ('a -> 'b, 'c) t | Rest : 'a conv -> ('a list -> 'b, 'b) t
| Record : 'a record_parser -> ('a -> 'b, 'b) t
| Loc : ('a, 'b) t -> (Loc.t -> 'a, 'b) t
| Cons : 'a conv * ('b, 'c) t -> ('a -> 'b, 'c) t
let rec convert : type a b c. (a, b) t -> (b, c) rest -> Ast.t -> Ast.t list -> a -> c let rec convert : type a b. (a, b) t -> Ast.t -> Ast.t list -> a -> b
= fun t rest sexp sexps f -> = fun t sexp sexps f ->
match t, rest, sexps with match t, sexps with
| Nil, No_rest, [] -> f | Nil, [] -> f
| Nil, Many _ , [] -> f [] | Rest conv, l -> f (List.map l ~f:conv)
| Cons _, _, [] -> of_sexp_error sexp "not enough arguments" | Record rp, l -> begin
| Nil, No_rest, _ :: _ -> of_sexp_error sexp "too many arguments" match sexp with
| Nil, Many conv, l -> f (List.map l ~f:conv) | Atom (_, A s) | Quoted_string (_, s) ->
| Cons (conv, t), _, s :: sexps -> of_sexp_errorf sexp "'%s' expect arguments" s
convert t rest sexp sexps (f (conv s)) | List (loc, _) ->
f (record rp (List (loc, l)))
end
| Loc t, l -> convert t sexp l (f (Ast.loc sexp))
| Cons (conv, t), s :: l -> convert t sexp l (f (conv s))
| Cons _, [] -> of_sexp_error sexp "not enough arguments"
| Nil, _ :: _ -> of_sexp_error sexp "too many arguments"
end end
let nil = Constructor_args_spec.Nil let nil = Constructor_args_spec.Nil
let ( @> ) a b = Constructor_args_spec.Cons (a, b) let ( @> ) a b = Constructor_args_spec.Cons (a, b)
let rest f = Constructor_args_spec.Rest f
let cstr_loc x = Constructor_args_spec.Loc x
let rest_as_record rp = Constructor_args_spec.Record rp
let field_multi name ?default args_spec f state = let field_multi name ?default args_spec f state =
match find_single state name with match find_single state name with
| Some { values; entry; _ } -> | Some { values; entry; _ } ->
(Constructor_args_spec.convert args_spec No_rest entry values f, (Constructor_args_spec.convert args_spec entry values f,
consume name state) consume name state)
| None -> | None ->
match default with match default with
@ -377,7 +385,7 @@ module Of_sexp = struct
| None -> acc | None -> acc
| Some { values; entry; prev } -> | Some { values; entry; prev } ->
let x = let x =
Constructor_args_spec.convert args_spec No_rest entry values f Constructor_args_spec.convert args_spec entry values f
in in
loop (x :: acc) prev loop (x :: acc) prev
in in
@ -385,41 +393,19 @@ module Of_sexp = struct
(res, consume name state) (res, consume name state)
module Constructor_spec = struct module Constructor_spec = struct
type ('a, 'b, 'c) tuple = type ('a, 'b) unpacked =
{ name : string { name : string
; args : ('a, 'b) Constructor_args_spec.t ; args : ('a, 'b) Constructor_args_spec.t
; rest : ('b, 'c) rest ; make : 'a
; make : Loc.t -> 'a
} }
type 'a record = type 'a t = T : (_, 'a) unpacked -> 'a t [@@unboxed]
{ name : string
; parse : 'a record_parser
}
type 'a t = let name (T t) = t.name
| Tuple : (_, _, 'a) tuple -> 'a t
| Record : 'a record -> 'a t
let name = function
| Tuple x -> x.name
| Record x -> x.name
end end
module C = Constructor_spec module C = Constructor_spec
let cstr_loc name args make = let cstr name args make = C.T { name; args; make }
C.Tuple { name; args; make; rest = No_rest }
let cstr_rest_loc name args rest make =
C.Tuple { name; args; make; rest = Many rest }
let cstr_record name parse =
C.Record { name; parse }
let cstr name args make =
cstr_loc name args (fun _ -> make)
let cstr_rest name args rest make =
cstr_rest_loc name args rest (fun _ -> make)
let equal_cstr_name a b = Name.compare a b = Eq let equal_cstr_name a b = Name.compare a b = Eq
@ -432,27 +418,23 @@ module Of_sexp = struct
| None -> | None ->
of_sexp_errorf sexp of_sexp_errorf sexp
~hint:{ on = String.uncapitalize name ~hint:{ on = String.uncapitalize name
; candidates = List.map cstrs ~f:(fun c -> ; candidates = List.map cstrs ~f:C.name
String.uncapitalize (C.name c))
} }
"Unknown constructor %s" name "Unknown constructor %s" name
let sum cstrs sexp = let sum cstrs sexp =
match sexp with match sexp with
| Atom (loc, A s) -> begin | Atom (_, A s) ->
match find_cstr cstrs sexp s with let (C.T cstr) = find_cstr cstrs sexp s in
| C.Tuple t -> Constructor_args_spec.convert t.args t.rest sexp [] (t.make loc) Constructor_args_spec.convert cstr.args sexp [] cstr.make
| C.Record _ -> of_sexp_error sexp "'%s' expect arguments"
end
| Quoted_string _ -> of_sexp_error sexp "Atom expected" | Quoted_string _ -> of_sexp_error sexp "Atom expected"
| List (_, []) -> of_sexp_error sexp "non-empty list expected" | List (_, []) -> of_sexp_error sexp "non-empty list expected"
| List (loc, name_sexp :: args) -> | List (_, name_sexp :: args) ->
match name_sexp with match name_sexp with
| Quoted_string _ | List _ -> of_sexp_error name_sexp "Atom expected" | Quoted_string _ | List _ -> of_sexp_error name_sexp "Atom expected"
| Atom (_, A s) -> | Atom (_, A s) ->
match find_cstr cstrs sexp s with let (C.T cstr) = find_cstr cstrs sexp s in
| C.Tuple t -> Constructor_args_spec.convert t.args t.rest sexp args (t.make loc) Constructor_args_spec.convert cstr.args sexp args cstr.make
| C.Record r -> record r.parse (List (loc, args))
let enum cstrs sexp = let enum cstrs sexp =
match sexp with match sexp with

32
src/stdune/sexp.mli
View File

@ -130,6 +130,17 @@ module Of_sexp : sig
-> ('b, 'c) Constructor_args_spec.t -> ('b, 'c) Constructor_args_spec.t
-> ('a -> 'b, 'c) Constructor_args_spec.t -> ('a -> 'b, 'c) Constructor_args_spec.t
(** Parse all remaining arguments using the following parser *)
val rest : 'a t -> ('a list -> 'b, 'b) Constructor_args_spec.t
(** Parse all remaining arguments using the following record parser *)
val rest_as_record : 'a record_parser -> ('a -> 'b, 'b) Constructor_args_spec.t
(** Capture the location of the constructor *)
val cstr_loc
: ('a, 'b) Constructor_args_spec.t
-> (Loc.t -> 'a, 'b) Constructor_args_spec.t
(** Field that takes multiple values *) (** Field that takes multiple values *)
val field_multi val field_multi
: string : string
@ -146,29 +157,12 @@ module Of_sexp : sig
-> 'a -> 'a
-> 'b list record_parser -> 'b list record_parser
val cstr : string -> ('a, 'b) Constructor_args_spec.t -> 'a -> 'b Constructor_spec.t val cstr
val cstr_rest
: string
-> ('a, 'b list -> 'c) Constructor_args_spec.t
-> 'b t
-> 'a
-> 'c Constructor_spec.t
val cstr_record : string -> 'a record_parser -> 'a Constructor_spec.t
val cstr_loc
: string : string
-> ('a, 'b) Constructor_args_spec.t -> ('a, 'b) Constructor_args_spec.t
-> (Loc.t -> 'a) -> 'a
-> 'b Constructor_spec.t -> 'b Constructor_spec.t
val cstr_rest_loc
: string
-> ('a, 'b list -> 'c) Constructor_args_spec.t
-> 'b t
-> (Loc.t -> 'a)
-> 'c Constructor_spec.t
val sum val sum
: 'a Constructor_spec.t list : 'a Constructor_spec.t list
-> 'a t -> 'a t

2
src/stdune/stdune.ml
View File

@ -20,6 +20,8 @@ module String = String
module Char = Char module Char = Char
module Sexp = Sexp module Sexp = Sexp
module Path = Path module Path = Path
module Fmt = Fmt
module Interned = Interned
external reraise : exn -> _ = "%reraise" external reraise : exn -> _ = "%reraise"

7
src/sub_system_name.ml
View File

@ -1 +1,6 @@
include Interned.Make () open Stdune
include Interned.Make(struct
let initial_size = 16
let resize_policy = Interned.Conservative
end)

2
src/sub_system_name.mli
View File

@ -1 +1 @@
include Interned.S include Stdune.Interned.S

27
src/super_context.ml
View File

@ -2,7 +2,6 @@ open Import
open Jbuild open Jbuild
module A = Action module A = Action
module Pset = Path.Set
module Alias = Build_system.Alias module Alias = Build_system.Alias
module Dir_with_jbuild = struct module Dir_with_jbuild = struct
@ -492,7 +491,7 @@ module Deps = struct
let path = Path.relative ~error_loc:(String_with_vars.loc s) let path = Path.relative ~error_loc:(String_with_vars.loc s)
dir (expand_vars t ~scope ~dir s) in dir (expand_vars t ~scope ~dir s) in
Build.files_recursively_in ~dir:path ~file_tree:t.file_tree Build.files_recursively_in ~dir:path ~file_tree:t.file_tree
>>^ Pset.to_list >>^ Path.Set.to_list
| Package p -> | Package p ->
let pkg = Package.Name.of_string (expand_vars t ~scope ~dir p) in let pkg = Package.Name.of_string (expand_vars t ~scope ~dir p) in
Alias.dep (Alias.package_install ~context:t.context ~pkg) Alias.dep (Alias.package_install ~context:t.context ~pkg)
@ -564,7 +563,7 @@ module Action = struct
; (* All "name" for ${lib:name:...}/${lib-available:name} forms *) ; (* All "name" for ${lib:name:...}/${lib-available:name} forms *)
mutable lib_deps : Build.lib_deps mutable lib_deps : Build.lib_deps
; (* Static deps from ${...} variables. For instance ${exe:...} *) ; (* Static deps from ${...} variables. For instance ${exe:...} *)
mutable sdeps : Pset.t mutable sdeps : Path.Set.t
; (* Dynamic deps from ${...} variables. For instance ${read:...} *) ; (* Dynamic deps from ${...} variables. For instance ${read:...} *)
mutable ddeps : (unit, Action.Var_expansion.t) Build.t String.Map.t mutable ddeps : (unit, Action.Var_expansion.t) Build.t String.Map.t
} }
@ -604,7 +603,7 @@ module Action = struct
let acc = let acc =
{ failures = [] { failures = []
; lib_deps = String.Map.empty ; lib_deps = String.Map.empty
; sdeps = Pset.empty ; sdeps = Path.Set.empty
; ddeps = String.Map.empty ; ddeps = String.Map.empty
} }
in in
@ -722,7 +721,7 @@ module Action = struct
let exp = expand loc key var x in let exp = expand loc key var x in
(match exp with (match exp with
| Some (Paths (ps, _)) -> | Some (Paths (ps, _)) ->
acc.sdeps <- Pset.union (Pset.of_list ps) acc.sdeps acc.sdeps <- Path.Set.union (Path.Set.of_list ps) acc.sdeps
| _ -> ()); | _ -> ());
exp) exp)
in in
@ -768,7 +767,7 @@ module Action = struct
match targets_written_by_user with match targets_written_by_user with
| Infer -> Action.Infer.partial t ~all_targets:true | Infer -> Action.Infer.partial t ~all_targets:true
| Static targets_written_by_user -> | Static targets_written_by_user ->
let targets_written_by_user = Pset.of_list targets_written_by_user in let targets_written_by_user = Path.Set.of_list targets_written_by_user in
let { Action.Infer.Outcome. deps; targets } = let { Action.Infer.Outcome. deps; targets } =
Action.Infer.partial t ~all_targets:false Action.Infer.partial t ~all_targets:false
in in
@ -780,23 +779,23 @@ module Action = struct
so that it can report better errors. so that it can report better errors.
{[ {[
let missing = Pset.diff targets targets_written_by_user in let missing = Path.Set.diff targets targets_written_by_user in
if not (Pset.is_empty missing) then if not (Path.Set.is_empty missing) then
Loc.warn (Loc.in_file (Utils.jbuild_name_in ~dir)) Loc.warn (Loc.in_file (Utils.jbuild_name_in ~dir))
"Missing targets in user action:\n%s" "Missing targets in user action:\n%s"
(List.map (Pset.elements missing) ~f:(fun target -> (List.map (Path.Set.elements missing) ~f:(fun target ->
sprintf "- %s" (Utils.describe_target target)) sprintf "- %s" (Utils.describe_target target))
|> String.concat ~sep:"\n"); |> String.concat ~sep:"\n");
]} ]}
*) *)
{ deps; targets = Pset.union targets targets_written_by_user } { deps; targets = Path.Set.union targets targets_written_by_user }
| Alias -> | Alias ->
let { Action.Infer.Outcome. deps; targets = _ } = let { Action.Infer.Outcome. deps; targets = _ } =
Action.Infer.partial t ~all_targets:false Action.Infer.partial t ~all_targets:false
in in
{ deps; targets = Pset.empty } { deps; targets = Path.Set.empty }
in in
let targets = Pset.to_list targets in let targets = Path.Set.to_list targets in
List.iter targets ~f:(fun target -> List.iter targets ~f:(fun target ->
if Path.parent_exn target <> dir then if Path.parent_exn target <> dir then
Loc.fail loc Loc.fail loc
@ -830,11 +829,11 @@ module Action = struct
| Ok path -> path | Ok path -> path
| Error fail -> Action.Prog.Not_found.raise fail)) | Error fail -> Action.Prog.Not_found.raise fail))
>>> >>>
Build.dyn_paths (Build.arr (fun action -> Build.dyn_path_set (Build.arr (fun action ->
let { Action.Infer.Outcome.deps; targets = _ } = let { Action.Infer.Outcome.deps; targets = _ } =
Action.Infer.infer action Action.Infer.infer action
in in
Pset.to_list deps)) deps))
>>> >>>
Build.action_dyn () ~dir ~targets Build.action_dyn () ~dir ~targets
in in

10
src/syntax.ml
View File

@ -22,14 +22,14 @@ module Version = struct
end end
module Versioned_parser = struct module Versioned_parser = struct
type 'a t = (int * 'a) Int_map.t type 'a t = (int * 'a) Int.Map.t
let make l = let make l =
if List.is_empty l then if List.is_empty l then
Exn.code_error "Syntax.Versioned_parser.make got empty list" []; Exn.code_error "Syntax.Versioned_parser.make got empty list" [];
match match
List.map l ~f:(fun ((major, minor), p) -> (major, (minor, p))) List.map l ~f:(fun ((major, minor), p) -> (major, (minor, p)))
|> Int_map.of_list |> Int.Map.of_list
with with
| Ok x -> x | Ok x -> x
| Error _ -> | Error _ ->
@ -38,12 +38,12 @@ module Versioned_parser = struct
[ "versions", Sexp.To_sexp.list Version.sexp_of_t (List.map l ~f:fst) ] [ "versions", Sexp.To_sexp.list Version.sexp_of_t (List.map l ~f:fst) ]
let last t = let last t =
let major, (minor, p) = Option.value_exn (Int_map.max_binding t) in let major, (minor, p) = Option.value_exn (Int.Map.max_binding t) in
((major, minor), p) ((major, minor), p)
let find_exn t ~loc ~data_version:(major, minor) = let find_exn t ~loc ~data_version:(major, minor) =
match match
Option.bind (Int_map.find t major) ~f:(fun (minor', p) -> Option.bind (Int.Map.find t major) ~f:(fun (minor', p) ->
Option.some_if (minor' >= minor) p) Option.some_if (minor' >= minor) p)
with with
| None -> | None ->
@ -52,7 +52,7 @@ module Versioned_parser = struct
%s" %s"
(Version.to_string (major, minor)) (Version.to_string (major, minor))
(String.concat ~sep:"\n" (String.concat ~sep:"\n"
(Int_map.to_list t |> List.map ~f:(fun (major, (minor, _)) -> (Int.Map.to_list t |> List.map ~f:(fun (major, (minor, _)) ->
sprintf "- %u.0 to %u.%u" major major minor))) sprintf "- %u.0 to %u.%u" major major minor)))
| Some p -> p | Some p -> p
end end

2
src/top_closure.ml
View File

@ -46,5 +46,5 @@ module Make(Keys : Keys) = struct
| Error elts -> Error elts | Error elts -> Error elts
end end
module Int = Make(Int_set) module Int = Make(Int.Set)
module String = Make(String.Set) module String = Make(String.Set)

5
src/utils.ml
View File

@ -184,11 +184,10 @@ module Cached_digest = struct
let db_file = Path.relative Path.build_dir ".digest-db" let db_file = Path.relative Path.build_dir ".digest-db"
let dump () = let dump () =
let module Pmap = Path.Map in
let sexp = let sexp =
Sexp.List ( Sexp.List (
Hashtbl.foldi cache ~init:Pmap.empty ~f:(fun key data acc -> Hashtbl.foldi cache ~init:Path.Map.empty ~f:(fun key data acc ->
Pmap.add acc key data) Path.Map.add acc key data)
|> Path.Map.to_list |> Path.Map.to_list
|> List.map ~f:(fun (path, file) -> |> List.map ~f:(fun (path, file) ->
Sexp.List [ Quoted_string (Path.to_string path) Sexp.List [ Quoted_string (Path.to_string path)

7
src/variant.ml
View File

@ -1,4 +1,9 @@
include Interned.Make() open Stdune
include Interned.Make(struct
let initial_size = 256
let resize_policy = Interned.Conservative
end)
let ppx_driver = make "ppx_driver" let ppx_driver = make "ppx_driver"
let mt = make "mt" let mt = make "mt"

2
src/variant.mli
View File

@ -6,7 +6,7 @@
They are directly mapped to findlib predicates. They are directly mapped to findlib predicates.
*) *)
include Interned.S include Stdune.Interned.S
(** Well-known variants *) (** Well-known variants *)
val ppx_driver : t val ppx_driver : t

12
src/workspace.ml
View File

@ -63,10 +63,12 @@ module Context = struct
| List (_, List _ :: _) as sexp -> Opam (record (Opam.t ~profile) sexp) | List (_, List _ :: _) as sexp -> Opam (record (Opam.t ~profile) sexp)
| sexp -> | sexp ->
sum sum
[ cstr_record "default" [ cstr "default"
(Default.t ~profile >>= fun x -> return (Default x)) (rest_as_record (Default.t ~profile))
; cstr_record "opam" (fun x -> Default x)
(Opam.t ~profile >>= fun x -> return (Opam x)) ; cstr "opam"
(rest_as_record (Opam.t ~profile))
(fun x -> Opam x)
] ]
sexp sexp
@ -95,7 +97,7 @@ type item = Context of Sexp.Ast.t | Profile of Loc.t * string
let item_of_sexp = let item_of_sexp =
sum sum
[ cstr "context" (raw @> nil) (fun x -> Context x) [ cstr "context" (raw @> nil) (fun x -> Context x)
; cstr_loc "profile" (string @> nil) (fun loc x -> Profile (loc, x)) ; cstr "profile" (cstr_loc (string @> nil)) (fun loc x -> Profile (loc, x))
] ]
let t ?x ?profile:cmdline_profile sexps = let t ?x ?profile:cmdline_profile sexps =