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

Revert some changes: 

- Make targets explicit b7ad08df84.
- Get rid of Vfile      e73fd90b65.

Without vfile we need some new concepts to avoid parsing the requires
file multiple times and with vfile it's annoying to specify the
dependencies by hand.

Will leave that for future work. Just use memoize where it make sense,
for instance when we read the result from only the current directory
(for instance the ocamldep stuff).
This commit is contained in:
Jeremie Dimino 2017-05-15 14:46:23 +01:00
parent 5adfe2d668
commit 648b2b2990
18 changed files with 539 additions and 256 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/alias.ml
View File

@ -101,7 +101,7 @@ let rules store ~prefixes ~tree =
Hashtbl.fold store ~init:[] ~f:(fun ~key:_ ~data:{ Store. alias; deps } acc ->
let open Build.O in
let rule =
Build_interpret.Rule.make ~targets:[alias.file]
Build_interpret.Rule.make
(Build.path_set deps >>>
Build.create_file alias.file)
in

10
src/arg_spec.ml
View File

@ -10,6 +10,7 @@ type 'a t =
| Deps of Path.t list
| Dep_rel of Path.t * string
| Deps_rel of Path.t * string list
| Target of Path.t
| Path of Path.t
| Paths of Path.t list
| Dyn of ('a -> nothing t)
@ -26,6 +27,13 @@ let rec add_deps ts set =
| S ts -> add_deps ts set
| _ -> set)
let rec add_targets ts acc =
List.fold_left ts ~init:acc ~f:(fun acc t ->
match t with
| Target fn -> fn :: acc
| S ts -> add_targets ts acc
| _ -> acc)
let expand ~dir ts x =
let dyn_deps = ref Path.Set.empty in
let add_dep path = dyn_deps := Path.Set.add path !dyn_deps in
@ -49,6 +57,7 @@ let expand ~dir ts x =
| Paths fns ->
List.map fns ~f:(Path.reach ~from:dir)
| S ts -> List.concat_map ts ~f:loop_dyn
| Target _ -> die "Target not allowed under Dyn"
| Dyn _ -> assert false
in
let rec loop = function
@ -59,6 +68,7 @@ let expand ~dir ts x =
| (Dep fn | Path fn) -> [Path.reach fn ~from:dir]
| (Deps fns | Paths fns) -> List.map fns ~f:(Path.reach ~from:dir)
| S ts -> List.concat_map ts ~f:loop
| Target fn -> [Path.reach fn ~from:dir]
| Dyn f -> loop_dyn (f x)
in
let l = List.concat_map ts ~f:loop in

6
src/arg_spec.mli
View File

@ -8,10 +8,12 @@ type 'a t =
| Deps of Path.t list
| Dep_rel of Path.t * string
| Deps_rel of Path.t * string list
| Target of Path.t
| Path of Path.t
| Paths of Path.t list
| Dyn of ('a -> nothing t)
val add_deps : _ t list -> Path.Set.t -> Path.Set.t
val expand : dir:Path.t -> 'a t list -> 'a -> string list * Path.Set.t
val add_deps : _ t list -> Path.Set.t -> Path.Set.t
val add_targets : _ t list -> Path.t list -> Path.t list
val expand : dir:Path.t -> 'a t list -> 'a -> string list * Path.Set.t

94
src/build.ml
View File

@ -2,6 +2,10 @@ open Import
module Pset = Path.Set
module Vspec = struct
type 'a t = T : Path.t * 'a Vfile_kind.t -> 'a t
end
module Prog_spec = struct
type 'a t =
| Dep of Path.t
@ -21,6 +25,8 @@ let merge_lib_dep_kind a b =
module Repr = struct
type ('a, 'b) t =
| Arr : ('a -> 'b) -> ('a, 'b) t
| Targets : Path.t list -> ('a, 'a) t
| Store_vfile : 'a Vspec.t -> ('a, Action.t) t
| Compose : ('a, 'b) t * ('b, 'c) t -> ('a, 'c) t
| First : ('a, 'b) t -> ('a * 'c, 'b * 'c) t
| Second : ('a, 'b) t -> ('c * 'a, 'c * 'b) t
@ -32,6 +38,7 @@ module Repr = struct
| If_file_exists : Path.t * ('a, 'b) if_file_exists_state ref -> ('a, 'b) t
| Contents : Path.t -> ('a, string) t
| Lines_of : Path.t -> ('a, string list) t
| Vpath : 'a Vspec.t -> (unit, 'a) t
| Dyn_paths : ('a, Path.t list) t -> ('a, 'a) t
| Record_lib_deps : Path.t * lib_deps -> ('a, 'a) t
| Fail : fail -> (_, _) t
@ -118,6 +125,7 @@ let path p = Paths (Pset.singleton p)
let paths ps = Paths (Pset.of_list ps)
let path_set ps = Paths ps
let paths_glob ~dir re = Paths_glob (dir, re)
let vpath vp = Vpath vp
let dyn_paths t = Dyn_paths t
let contents p = Contents p
@ -136,24 +144,14 @@ let file_exists_opt p t =
~then_:(t >>^ fun x -> Some x)
~else_:(arr (fun _ -> None))
let fail x = Fail x
let fail ?targets x =
match targets with
| None -> Fail x
| Some l -> Targets l >>> Fail x
let memoize ~name t =
let memoize name t =
Memo { name; t; state = Unevaluated }
let read_sexp path of_sexp =
memoize ~name:(Path.to_string path)
(contents path
>>^ fun s ->
let lb = Lexing.from_string s in
lb.lex_curr_p <-
{ pos_fname = Path.to_string path
; pos_lnum = 1
; pos_bol = 0
; pos_cnum = 0
};
of_sexp (Sexp_lexer.single lb))
let files_recursively_in ~dir ~file_tree =
let prefix_with, dir =
match Path.extract_build_context_dir dir with
@ -162,6 +160,8 @@ let files_recursively_in ~dir ~file_tree =
in
path_set (File_tree.files_recursively_in file_tree dir ~prefix_with)
let store_vfile spec = Store_vfile spec
let get_prog (prog : _ Prog_spec.t) =
match prog with
| Dep p -> path p >>> arr (fun _ -> p)
@ -177,9 +177,17 @@ let prog_and_args ~dir prog args =
>>>
arr fst))
let run ~context ?(dir=context.Context.build_dir) ?stdout_to
let run ~context ?(dir=context.Context.build_dir) ?stdout_to ?(extra_targets=[])
prog args =
let extra_targets =
match stdout_to with
| None -> extra_targets
| Some fn -> fn :: extra_targets
in
let targets = Arg_spec.add_targets args extra_targets in
prog_and_args ~dir prog args
>>>
Targets targets
>>^ (fun (prog, args) ->
let action : Action.Mini_shexp.t = Run (prog, args) in
let action =
@ -193,48 +201,50 @@ let run ~context ?(dir=context.Context.build_dir) ?stdout_to
; action
})
let action ~context ?(dir=context.Context.build_dir) action =
return { Action. context = Some context; dir; action }
let action ~context ?(dir=context.Context.build_dir) ~targets action =
Targets targets
>>^ fun () ->
{ Action. context = Some context; dir; action }
let action_dyn ~context ?(dir=context.Context.build_dir) () =
arr (fun action ->
{ Action. context = Some context; dir; action })
let action_dyn ~context ?(dir=context.Context.build_dir) ~targets () =
Targets targets
>>^ fun action ->
{ Action. context = Some context; dir; action }
let action_context_independent ?(dir=Path.root) action =
return { Action. context = None; dir; action }
let action_context_independent ?(dir=Path.root) ~targets action =
Targets targets
>>^ fun () ->
{ Action. context = None; dir; action }
let update_file fn s =
action_context_independent (Update_file (fn, s))
action_context_independent ~targets:[fn] (Update_file (fn, s))
let update_file_dyn fn =
arr (fun s ->
{ Action.
context = None
; dir = Path.root
; action = Update_file (fn, s)
})
let write_sexp path to_sexp =
arr (fun x -> Sexp.to_string (to_sexp x))
>>>
update_file_dyn path
Targets [fn]
>>^ fun s ->
{ Action.
context = None
; dir = Path.root
; action = Update_file (fn, s)
}
let copy ~src ~dst =
path src >>>
action_context_independent (Copy (src, dst))
action_context_independent ~targets:[dst] (Copy (src, dst))
let symlink ~src ~dst =
path src >>>
action_context_independent (Symlink (src, dst))
action_context_independent ~targets:[dst] (Symlink (src, dst))
let create_file fn =
action_context_independent (Create_file fn)
action_context_independent ~targets:[fn] (Create_file fn)
let and_create_file fn =
arr (fun (action : Action.t) ->
{ action with
action = Progn [action.action; Create_file fn]
})
Targets [fn]
>>^ fun (action : Action.t) ->
{ action with
action = Progn [action.action; Create_file fn]
}
(*
{[

23
src/build.mli
View File

@ -8,6 +8,12 @@ val arr : ('a -> 'b) -> ('a, 'b) t
val return : 'a -> (unit, 'a) t
module Vspec : sig
type 'a t = T : Path.t * 'a Vfile_kind.t -> 'a t
end
val store_vfile : 'a Vspec.t -> ('a, Action.t) t
module O : sig
val ( >>> ) : ('a, 'b) t -> ('b, 'c) t -> ('a, 'c) t
val ( ^>> ) : ('a -> 'b) -> ('b, 'c) t -> ('a, 'c) t
@ -32,9 +38,7 @@ val paths : Path.t list -> ('a, 'a) t
val path_set : Path.Set.t -> ('a, 'a) t
val paths_glob : dir:Path.t -> Re.re -> ('a, 'a) t
val files_recursively_in : dir:Path.t -> file_tree:File_tree.t -> ('a, 'a) t
val read_sexp : Path.t -> 'a Sexp.Of_sexp.t -> (unit, 'a) t
val write_sexp : Path.t -> 'a Sexp.To_sexp.t -> ('a, Action.t) t
val vpath : 'a Vspec.t -> (unit, 'a) t
val dyn_paths : ('a, Path.t list) t -> ('a, 'a) t
@ -59,11 +63,11 @@ val file_exists_opt : Path.t -> ('a, 'b) t -> ('a, 'b option) t
(** Always fail when executed. We pass a function rather than an exception to get a proper
backtrace *)
val fail : fail -> (_, _) t
val fail : ?targets:Path.t list -> fail -> (_, _) t
(** [memoize ~name t] is an arrow that behaves like [t] except that its
(** [memoize name t] is an arrow that behaves like [t] except that its
result is computed only once. *)
val memoize : name:string -> (unit, 'a) t -> (unit, 'a) t
val memoize : string -> (unit, 'a) t -> (unit, 'a) t
module Prog_spec : sig
type 'a t =
@ -75,6 +79,7 @@ val run
: context:Context.t
-> ?dir:Path.t (* default: context.build_dir *)
-> ?stdout_to:Path.t
-> ?extra_targets:Path.t list
-> 'a Prog_spec.t
-> 'a Arg_spec.t list
-> ('a, Action.t) t
@ -82,17 +87,20 @@ val run
val action
: context:Context.t
-> ?dir:Path.t (* default: context.build_dir *)
-> targets:Path.t list
-> Action.Mini_shexp.t
-> (unit, Action.t) t
val action_dyn
: context:Context.t
-> ?dir:Path.t (* default: context.build_dir *)
-> targets:Path.t list
-> unit
-> (Action.Mini_shexp.t, Action.t) t
val action_context_independent
: ?dir:Path.t (* default: Path.root *)
-> targets:Path.t list
-> Action.Mini_shexp.t
-> (unit, Action.t) t
@ -129,6 +137,8 @@ val record_lib_deps_simple : dir:Path.t -> lib_deps -> ('a, 'a) t
module Repr : sig
type ('a, 'b) t =
| Arr : ('a -> 'b) -> ('a, 'b) t
| Targets : Path.t list -> ('a, 'a) t
| Store_vfile : 'a Vspec.t -> ('a, Action.t) t
| Compose : ('a, 'b) t * ('b, 'c) t -> ('a, 'c) t
| First : ('a, 'b) t -> ('a * 'c, 'b * 'c) t
| Second : ('a, 'b) t -> ('c * 'a, 'c * 'b) t
@ -139,6 +149,7 @@ module Repr : sig
| If_file_exists : Path.t * ('a, 'b) if_file_exists_state ref -> ('a, 'b) t
| Contents : Path.t -> ('a, string) t
| Lines_of : Path.t -> ('a, string list) t
| Vpath : 'a Vspec.t -> (unit, 'a) t
| Dyn_paths : ('a, Path.t list) t -> ('a, 'a) t
| Record_lib_deps : Path.t * lib_deps -> ('a, 'a) t
| Fail : fail -> (_, _) t

64
src/build_interpret.ml
View File

@ -3,11 +3,28 @@ open Build.Repr
module Pset = Path.Set
module Pmap = Path.Map
module Vspec = Build.Vspec
module Target = struct
type t =
| Normal of Path.t
| Vfile : _ Vspec.t -> t
let path = function
| Normal p -> p
| Vfile (Vspec.T (p, _)) -> p
let paths ts =
List.fold_left ts ~init:Pset.empty ~f:(fun acc t ->
Pset.add (path t) acc)
end
let rule_deps t ~all_targets_by_dir =
let rec loop : type a b. (a, b) t -> Pset.t -> Pset.t = fun t acc ->
match t with
| Arr _ -> acc
| Targets _ -> acc
| Store_vfile _ -> acc
| Compose (a, b) -> loop a (loop b acc)
| First t -> loop t acc
| Second t -> loop t acc
@ -33,6 +50,7 @@ let rule_deps t ~all_targets_by_dir =
end
end
| Dyn_paths t -> loop t acc
| Vpath (Vspec.T (p, _)) -> Pset.add p acc
| Contents p -> Pset.add p acc
| Lines_of p -> Pset.add p acc
| Record_lib_deps _ -> acc
@ -45,6 +63,7 @@ let static_action_deps t ~all_targets_by_dir =
let rec loop : type a b. (a, b) t -> Pset.t -> Pset.t = fun t acc ->
match t with
| Arr _ -> acc
| Targets _ -> acc
| Compose (a, b) -> loop a (loop b acc)
| First t -> loop t acc
| Second t -> loop t acc
@ -59,6 +78,7 @@ let static_action_deps t ~all_targets_by_dir =
Re.execp re (Path.basename path))
|> Pset.union acc
end
| Vpath _ -> acc
| If_file_exists (_, state) -> loop (get_if_file_exists_exn state) acc
| Dyn_paths t -> loop t acc
| Contents _ -> acc
@ -66,6 +86,7 @@ let static_action_deps t ~all_targets_by_dir =
| Record_lib_deps _ -> acc
| Fail _ -> acc
| Memo m -> loop m.t acc
| Store_vfile _ -> acc
in
loop (Build.repr t) Pset.empty
@ -74,12 +95,15 @@ let lib_deps =
= fun t acc ->
match t with
| Arr _ -> acc
| Targets _ -> acc
| Store_vfile _ -> acc
| Compose (a, b) -> loop a (loop b acc)
| First t -> loop t acc
| Second t -> loop t acc
| Split (a, b) -> loop a (loop b acc)
| Fanout (a, b) -> loop a (loop b acc)
| Paths _ -> acc
| Vpath _ -> acc
| Paths_glob _ -> acc
| Dyn_paths t -> loop t acc
| Contents _ -> acc
@ -98,16 +122,50 @@ let lib_deps =
in
fun t -> loop (Build.repr t) Pmap.empty
let targets =
let rec loop : type a b. (a, b) t -> Target.t list -> Target.t list = fun t acc ->
match t with
| Arr _ -> acc
| Targets targets ->
List.fold_left targets ~init:acc ~f:(fun acc fn -> Target.Normal fn :: acc)
| Store_vfile spec -> Vfile spec :: acc
| Compose (a, b) -> loop a (loop b acc)
| First t -> loop t acc
| Second t -> loop t acc
| Split (a, b) -> loop a (loop b acc)
| Fanout (a, b) -> loop a (loop b acc)
| Paths _ -> acc
| Vpath _ -> acc
| Paths_glob _ -> acc
| Dyn_paths t -> loop t acc
| Contents _ -> acc
| Lines_of _ -> acc
| Record_lib_deps _ -> acc
| Fail _ -> acc
| If_file_exists (_, state) -> begin
match !state with
| Decided _ -> code_errorf "Build_interpret.targets got decided if_file_exists"
| Undecided (a, b) ->
match loop a [], loop b [] with
| [], [] -> acc
| _ ->
code_errorf "Build_interpret.targets: cannot have targets \
under a [if_file_exists]"
end
| Memo m -> loop m.t acc
in
fun t -> loop (Build.repr t) []
module Rule = struct
type t =
{ build : (unit, Action.t) Build.t
; targets : Path.Set.t
; targets : Target.t list
; sandbox : bool
}
let make ?(sandbox=false) ~targets build =
let make ?(sandbox=false) build =
{ build
; targets = Path.Set.of_list targets
; targets = targets build
; sandbox
}
end

17
src/build_interpret.mli
View File

@ -1,13 +1,22 @@
open! Import
module Target : sig
type t =
| Normal of Path.t
| Vfile : _ Build.Vspec.t -> t
val path : t -> Path.t
val paths : t list -> Path.Set.t
end
module Rule : sig
type t =
{ build : (unit, Action.t) Build.t
; targets : Path.Set.t
; targets : Target.t list
; sandbox : bool
}
val make : ?sandbox:bool -> targets:Path.t list -> (unit, Action.t) Build.t -> t
val make : ?sandbox:bool -> (unit, Action.t) Build.t -> t
end
(* must be called first *)
@ -24,3 +33,7 @@ val static_action_deps
val lib_deps
: (_, _) Build.t
-> Build.lib_deps Path.Map.t
val targets
: (_, _) Build.t
-> Target.t list

99
src/build_system.ml
View File

@ -3,6 +3,7 @@ open Future
module Pset = Path.Set
module Pmap = Path.Map
module Vspec = Build.Vspec
module Exec_status = struct
module Starting = struct
@ -27,9 +28,36 @@ module Rule = struct
}
end
module File_kind = struct
type 'a t =
| Ignore_contents : unit t
| Sexp_file : 'a Vfile_kind.t -> 'a t
let eq : type a b. a t -> b t -> (a, b) eq option = fun a b ->
match a, b with
| Ignore_contents, Ignore_contents -> Some Eq
| Sexp_file a , Sexp_file b -> Vfile_kind.eq a b
| _ -> None
let eq_exn a b = Option.value_exn (eq a b)
end
module File_spec = struct
type 'a t =
{ rule : Rule.t (* Rule which produces it *)
; mutable kind : 'a File_kind.t
; mutable data : 'a option
}
type packed = T : _ t -> packed
let create rule kind =
T { rule; kind; data = None }
end
type t =
{ (* File specification by targets *)
files : (Path.t, Rule.t) Hashtbl.t
files : (Path.t, File_spec.packed) Hashtbl.t
; contexts : Context.t list
; (* Table from target to digest of [(deps, targets, action)] *)
trace : (Path.t, Digest.t) Hashtbl.t
@ -106,8 +134,8 @@ module Build_error = struct
let rec build_path acc targeting ~seen =
assert (not (Pset.mem targeting seen));
let seen = Pset.add targeting seen in
let rule = find_file_exn t targeting in
match rule.exec with
let (File_spec.T file) = find_file_exn t targeting in
match file.rule.exec with
| Not_started _ -> assert false
| Running { for_file; _ } | Starting { for_file } ->
if for_file = targeting then
@ -128,10 +156,10 @@ let wait_for_file t fn ~targeting =
return ()
else
die "file unavailable: %s" (Path.to_string fn)
| Some rule ->
match rule.exec with
| Some (File_spec.T file) ->
match file.rule.exec with
| Not_started f ->
rule.exec <- Starting { for_file = targeting };
file.rule.exec <- Starting { for_file = targeting };
let future =
with_exn_handler (fun () -> f ~targeting:fn)
~handler:(fun exn backtrace ->
@ -139,7 +167,7 @@ let wait_for_file t fn ~targeting =
| Build_error.E _ -> reraise exn
| exn -> Build_error.raise t exn ~targeting:fn ~backtrace)
in
rule.exec <- Running { for_file = targeting; future };
file.rule.exec <- Running { for_file = targeting; future };
future
| Running { future; _ } -> future
| Starting _ ->
@ -149,8 +177,8 @@ let wait_for_file t fn ~targeting =
if fn = targeting then
acc
else
let rule = find_file_exn t targeting in
match rule.exec with
let (File_spec.T file) = find_file_exn t targeting in
match file.rule.exec with
| Not_started _ | Running _ -> assert false
| Starting { for_file } ->
build_loop acc for_file
@ -160,15 +188,37 @@ let wait_for_file t fn ~targeting =
(String.concat ~sep:"\n--> "
(List.map loop ~f:Path.to_string))
module Target = Build_interpret.Target
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
| 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
file
let vfile_to_string (type a) (module K : Vfile_kind.S with type t = a) fn x =
K.to_string fn x
module Build_exec = struct
open Build.Repr
let exec t x =
let exec bs t x =
let dyn_deps = ref Pset.empty in
let rec exec
: type a b. (a, b) t -> a -> b = fun t x ->
match t with
| Arr f -> f x
| Targets _ -> x
| Store_vfile (Vspec.T (fn, kind)) ->
let file = get_file bs fn (Sexp_file kind) in
assert (file.data = None);
file.data <- Some x;
{ Action.
context = None
; dir = Path.root
; action = Update_file (fn, vfile_to_string kind fn x)
}
| Compose (a, b) ->
exec a x |> exec b
| First t ->
@ -190,6 +240,9 @@ module Build_exec = struct
| Paths_glob _ -> x
| Contents p -> read_file (Path.to_string p)
| Lines_of p -> lines_of_file (Path.to_string p)
| Vpath (Vspec.T (fn, kind)) ->
let file : b File_spec.t = get_file bs fn (Sexp_file kind) in
Option.value_exn file.data
| Dyn_paths t ->
let fns = exec t x in
dyn_deps := Pset.union !dyn_deps (Pset.of_list fns);
@ -213,13 +266,17 @@ module Build_exec = struct
(action, !dyn_deps)
end
let add_rule t fn rule ~allow_override =
let add_spec t fn spec ~allow_override =
if not allow_override && Hashtbl.mem t.files fn then
die "multiple rules generated for %s" (Path.to_string fn);
Hashtbl.add t.files ~key:fn ~data:rule
Hashtbl.add t.files ~key:fn ~data:spec
let create_file_rules t targets rule ~allow_override =
Pset.iter targets ~f:(fun fn -> add_rule t fn rule ~allow_override)
let create_file_specs t targets rule ~allow_override =
List.iter targets ~f:(function
| Target.Normal fn ->
add_spec t fn (File_spec.create rule Ignore_contents) ~allow_override
| Target.Vfile (Vspec.T (fn, kind)) ->
add_spec t fn (File_spec.create rule (Sexp_file kind)) ~allow_override)
module Pre_rule = Build_interpret.Rule
@ -276,7 +333,8 @@ let make_local_parent_dirs t paths ~map_path =
let sandbox_dir = Path.of_string "_build/.sandbox"
let compile_rule t ~all_targets_by_dir ?(allow_override=false) pre_rule =
let { Pre_rule. build; targets; sandbox } = pre_rule in
let { Pre_rule. build; targets = target_specs; sandbox } = pre_rule in
let targets = Target.paths target_specs in
let rule_deps = Build_interpret.rule_deps build ~all_targets_by_dir in
let static_deps = Build_interpret.static_action_deps build ~all_targets_by_dir in
@ -310,7 +368,7 @@ let compile_rule t ~all_targets_by_dir ?(allow_override=false) pre_rule =
(wait_for_deps t static_deps ~targeting)
(wait_for_deps t rule_deps ~targeting
>>= fun () ->
let action, dyn_deps = Build_exec.exec build () in
let action, dyn_deps = Build_exec.exec t build () in
wait_for_deps t ~targeting (Pset.diff dyn_deps static_deps)
>>| fun () ->
(action, dyn_deps))
@ -421,7 +479,7 @@ let compile_rule t ~all_targets_by_dir ?(allow_override=false) pre_rule =
; exec
}
in
create_file_rules t targets rule ~allow_override
create_file_specs t target_specs rule ~allow_override
let setup_copy_rules t ~all_non_target_source_files ~all_targets_by_dir =
List.iter t.contexts ~f:(fun (ctx : Context.t) ->
@ -440,7 +498,7 @@ let setup_copy_rules t ~all_non_target_source_files ~all_targets_by_dir =
This allows to keep generated files in tarballs. Maybe we
should allow it on a case-by-case basis though. *)
compile_rule t (Pre_rule.make build ~targets:[ctx_path])
compile_rule t (Pre_rule.make build)
~all_targets_by_dir
~allow_override:true))
@ -494,7 +552,8 @@ let create ~contexts ~file_tree ~rules =
in
let all_other_targets =
List.fold_left rules ~init:Pset.empty ~f:(fun acc { Pre_rule.targets; _ } ->
Pset.union acc targets)
List.fold_left targets ~init:acc ~f:(fun acc target ->
Pset.add (Target.path target) acc))
in
let all_targets_by_dir = lazy (
Pset.elements (Pset.union all_copy_targets all_other_targets)
@ -566,7 +625,7 @@ let rules_for_files t paths =
List.filter_map paths ~f:(fun path ->
match Hashtbl.find t.files path with
| None -> None
| Some rule -> Some (path, rule))
| Some (File_spec.T { rule; _ }) -> Some (path, rule))
module File_closure =
Top_closure.Make(Path)

109
src/gen_rules.ml
View File

@ -63,11 +63,6 @@ module Gen(P : Params) = struct
| Native -> ["-cclib"; "-l" ^ stubs_name]
in
SC.add_rule sctx
~targets:
(target
:: match mode with
| Byte -> []
| Native -> [lib_archive lib ~dir ~ext:ctx.ext_lib])
(Build.fanout
(dep_graph >>>
Build.arr (fun dep_graph ->
@ -80,8 +75,12 @@ module Gen(P : Params) = struct
(SC.expand_and_eval_set ~dir lib.c_library_flags ~standard:[])
>>>
Build.run ~context:ctx (Dep compiler)
~extra_targets:(
match mode with
| Byte -> []
| Native -> [lib_archive lib ~dir ~ext:ctx.ext_lib])
[ Ocaml_flags.get flags mode
; A "-a"; A "-o"; Path target
; A "-a"; A "-o"; Target target
; As stubs_flags
; Dyn (fun (_, cclibs) ->
S (List.map cclibs ~f:(fun flag ->
@ -109,7 +108,7 @@ module Gen(P : Params) = struct
let build_c_file (lib : Library.t) ~dir ~requires ~h_files c_name =
let src = Path.relative dir (c_name ^ ".c") in
let dst = Path.relative dir (c_name ^ ctx.ext_obj) in
SC.add_rule sctx ~targets:[dst]
SC.add_rule sctx
(Build.paths h_files
>>>
Build.fanout
@ -129,7 +128,7 @@ module Gen(P : Params) = struct
S [ Lib.c_include_flags libs
; As (List.concat_map c_flags ~f:(fun f -> ["-ccopt"; f]))
])
; A "-o"; Path dst
; A "-o"; Target dst
; Dep src
]);
dst
@ -137,7 +136,7 @@ module Gen(P : Params) = struct
let build_cxx_file (lib : Library.t) ~dir ~requires ~h_files c_name =
let src = Path.relative dir (c_name ^ ".cpp") in
let dst = Path.relative dir (c_name ^ ctx.ext_obj) in
SC.add_rule sctx ~targets:[dst]
SC.add_rule sctx
(Build.paths h_files
>>>
Build.fanout
@ -158,7 +157,7 @@ module Gen(P : Params) = struct
S [ Lib.c_include_flags libs
; As cxx_flags
])
; A "-o"; Path dst
; A "-o"; Target dst
; A "-c"; Dep src
]);
dst
@ -232,8 +231,7 @@ module Gen(P : Params) = struct
let dep_graph = Ocamldep.rules sctx ~dir ~item:lib.name ~modules ~alias_module in
Option.iter alias_module ~f:(fun m ->
let target = Path.relative dir m.impl.name in
SC.add_rule sctx ~targets:[target]
SC.add_rule sctx
(Build.return
(String_map.values (String_map.remove m.name modules)
|> List.map ~f:(fun (m : Module.t) ->
@ -242,7 +240,7 @@ module Gen(P : Params) = struct
main_module_name m.name
m.name (Module.real_unit_name m))
|> String.concat ~sep:"\n")
>>> Build.update_file_dyn target));
>>> Build.update_file_dyn (Path.relative dir m.impl.name)));
let requires, real_requires =
SC.Libs.requires sctx ~dir ~dep_kind ~item:lib.name
@ -295,10 +293,11 @@ module Gen(P : Params) = struct
| Some _ -> ()
| None ->
let ocamlmklib ~sandbox ~custom ~targets =
SC.add_rule sctx ~sandbox ~targets
SC.add_rule sctx ~sandbox
(SC.expand_and_eval_set ~dir lib.c_library_flags ~standard:[]
>>>
Build.run ~context:ctx
~extra_targets:targets
(Dep ctx.ocamlmklib)
[ As (Utils.g ())
; if custom then A "-custom" else As []
@ -330,8 +329,9 @@ module Gen(P : Params) = struct
List.iter Mode.all ~f:(fun mode ->
build_lib lib ~flags ~dir ~mode ~modules ~dep_graph);
(* Build *.cma.js *)
(let src = lib_archive lib ~dir ~ext:(Mode.compiled_lib_ext Mode.Byte) in
Js_of_ocaml_rules.build_cm sctx ~dir ~src ~js_of_ocaml:lib.buildable.js_of_ocaml);
SC.add_rules sctx (
let src = lib_archive lib ~dir ~ext:(Mode.compiled_lib_ext Mode.Byte) in
Js_of_ocaml_rules.build_cm sctx ~dir ~js_of_ocaml:lib.buildable.js_of_ocaml ~src);
if ctx.natdynlink_supported then
Option.iter ctx.ocamlopt ~f:(fun ocamlopt ->
@ -343,7 +343,7 @@ module Gen(P : Params) = struct
[ Ocaml_flags.get flags Native
; A "-shared"; A "-linkall"
; A "-I"; Path dir
; A "-o"; Path dst
; A "-o"; Target dst
; Dep src
]
in
@ -355,7 +355,7 @@ module Gen(P : Params) = struct
else
build
in
SC.add_rule sctx build ~targets:[dst]
SC.add_rule sctx build
);
let flags =
@ -383,33 +383,32 @@ module Gen(P : Params) = struct
in
let dep_graph = Ml_kind.Dict.get dep_graph Impl in
let exe = Path.relative dir (name ^ exe_ext) in
let top_closed_cm_files =
dep_graph
>>^ fun dep_graph ->
Ocamldep.names_to_top_closed_cm_files
~dir
~dep_graph
~modules
~mode
[String.capitalize_ascii name]
in
SC.add_rule sctx ~targets:[exe]
(Build.fanout
let libs_and_cm =
Build.fanout
(requires
>>> Build.dyn_paths (Build.arr (Lib.archive_files ~mode ~ext_lib:ctx.ext_lib)))
top_closed_cm_files
>>>
(dep_graph
>>> Build.arr (fun dep_graph ->
Ocamldep.names_to_top_closed_cm_files
~dir
~dep_graph
~modules
~mode
[String.capitalize_ascii name]))
in
SC.add_rule sctx
(libs_and_cm >>>
Build.run ~context:ctx
(Dep compiler)
[ Ocaml_flags.get flags mode
; A "-o"; Path exe
; A "-o"; Target exe
; As link_flags
; Dyn (fun (libs, _) -> Lib.link_flags libs ~mode)
; Dyn (fun (_, cm_files) -> Deps cm_files)
]);
if mode = Mode.Byte then
Js_of_ocaml_rules.build_exe sctx ~dir ~js_of_ocaml ~src:exe
~requires ~top_closed_cm_files
let rules = Js_of_ocaml_rules.build_exe sctx ~dir ~js_of_ocaml ~src:exe in
SC.add_rules sctx (List.map rules ~f:(fun r -> libs_and_cm >>> r))
let executables_rules (exes : Executables.t) ~dir ~all_modules ~package_context =
let dep_kind = Build.Required in
@ -467,7 +466,7 @@ module Gen(P : Params) = struct
let user_rule (rule : Rule.t) ~dir ~package_context =
let targets = List.map rule.targets ~f:(Path.relative dir) in
SC.add_rule sctx ~targets
SC.add_rule sctx
(SC.Deps.interpret sctx ~dir rule.deps
>>>
SC.Action.run
@ -495,7 +494,7 @@ module Gen(P : Params) = struct
let digest_path = Alias.file_with_digest_suffix alias ~digest in
Alias.add_deps (SC.aliases sctx) alias [digest_path];
let deps = SC.Deps.interpret sctx ~dir alias_conf.deps in
SC.add_rule sctx ~targets:[digest_path]
SC.add_rule sctx
(match alias_conf.action with
| None ->
deps
@ -503,15 +502,14 @@ module Gen(P : Params) = struct
Build.create_file digest_path
| Some action ->
deps
>>>
SC.Action.run
sctx
action
~dir
~dep_kind:Required
~deps:(SC.Deps.only_plain_files sctx ~dir alias_conf.deps)
~targets:[]
~package_context
>>> SC.Action.run
sctx
action
~dir
~dep_kind:Required
~targets:[]
~deps:(SC.Deps.only_plain_files sctx ~dir alias_conf.deps)
~package_context
>>>
Build.and_create_file digest_path)
@ -561,9 +559,10 @@ module Gen(P : Params) = struct
| Reason -> "re")
intf.name impl_fname;
let dir = Path.append ctx.build_dir dir in
let src = Path.relative dir intf.name in
let dst = Path.relative dir impl_fname in
SC.add_rule sctx ~targets:[dst] (Build.copy ~src ~dst);
SC.add_rule sctx
(Build.copy
~src:(Path.relative dir intf.name)
~dst:(Path.relative dir impl_fname));
{ intf with name = impl_fname } in
String_map.merge impls intfs ~f:(fun name impl intf ->
let impl =
@ -621,7 +620,8 @@ module Gen(P : Params) = struct
|> Merlin.add_rules sctx ~dir:ctx_dir
let () = List.iter (SC.stanzas sctx) ~f:rules
let () = Js_of_ocaml_rules.setup_separate_compilation_rules sctx
let () =
SC.add_rules sctx (Js_of_ocaml_rules.setup_separate_compilation_rules sctx)
(* +-----------------------------------------------------------------+
| META |
@ -713,7 +713,7 @@ module Gen(P : Params) = struct
>>^ List.map ~f:Lib.best_name
| _ -> Build.arr (fun _ -> []))
in
SC.add_rule sctx ~targets:[meta_path]
SC.add_rule sctx
(Build.fanout meta template
>>^ (fun ((meta : Meta.t), template) ->
let buf = Buffer.create 1024 in
@ -830,7 +830,7 @@ module Gen(P : Params) = struct
let dst =
Path.append install_dir (Install.Entry.relative_installed_path entry ~package)
in
SC.add_rule ~targets:[dst] sctx (Build.symlink ~src:entry.src ~dst);
SC.add_rule sctx (Build.symlink ~src:entry.src ~dst);
{ entry with src = dst })
let install_file package_path package =
@ -872,7 +872,7 @@ module Gen(P : Params) = struct
Path.relative (Path.append ctx.build_dir package_path) (package ^ ".install")
in
let entries = local_install_rules entries ~package in
SC.add_rule sctx ~targets:[fn]
SC.add_rule sctx
(Build.path_set (Install.files entries)
>>^ (fun () ->
Install.gen_install_file entries)
@ -896,8 +896,7 @@ module Gen(P : Params) = struct
if is_default then begin
let src_install_alias = Alias.install ~dir:src_path in
let src_install_file = Path.relative src_path install_fn in
SC.add_rule sctx ~targets:[src_install_file]
(Build.copy ~src:ctx_install_file ~dst:src_install_file);
SC.add_rule sctx (Build.copy ~src:ctx_install_file ~dst:src_install_file);
Alias.add_deps (SC.aliases sctx) src_install_alias [src_install_file]
end)
end

99
src/js_of_ocaml_rules.ml
View File

@ -1,5 +1,4 @@
open Import
open Build.O
module SC = Super_context
@ -28,45 +27,42 @@ let runtime_file ~sctx ~dir fname =
"js_of_ocaml-compiler")
| Ok f -> Arg_spec.Dep f
let js_of_ocaml_rule ~sctx ~dir ~flags ~spec ~target ~dep =
let js_of_ocaml_rule ~sctx ~dir ~flags ~spec ~target =
let jsoo = SC.resolve_program sctx ~hint:install_jsoo_hint "js_of_ocaml" in
let runtime = runtime_file ~sctx ~dir "runtime.js" in
SC.add_rule sctx ~targets:[target]
(dep
>>>
Build.run ~context:(SC.context sctx) ~dir
jsoo
[ Arg_spec.As flags
; Arg_spec.A "-o"; Path target
; Arg_spec.A "--no-runtime"; runtime
; spec
])
Build.run ~context:(SC.context sctx) ~dir
jsoo
[ Arg_spec.As flags
; Arg_spec.A "-o"; Target target
; Arg_spec.A "--no-runtime"; runtime
; spec
]
let standalone_runtime_rule ~sctx ~dir ~flags ~javascript_files ~target ~requires =
let standalone_runtime_rule ~sctx ~dir ~flags ~javascript_files ~target =
let spec =
Arg_spec.S
[ Arg_spec.Dyn (fun libs -> Arg_spec.Deps (Lib.jsoo_runtime_files libs))
[ Arg_spec.Dyn (fun (libs,_) -> Arg_spec.Deps (Lib.jsoo_runtime_files libs))
; Arg_spec.Deps javascript_files
]
in
let flags = Ordered_set_lang.eval_with_standard flags ~standard:(standard ()) in
let flags = "--runtime-only" :: flags in
js_of_ocaml_rule ~sctx ~dir ~flags ~target ~spec ~dep:requires
js_of_ocaml_rule ~sctx ~dir ~flags ~target ~spec
let exe_rule ~sctx ~dir ~flags ~javascript_files ~src ~target ~requires =
let exe_rule ~sctx ~dir ~flags ~javascript_files ~src ~target =
let spec =
Arg_spec.S
[ Arg_spec.Dyn (fun libs -> Arg_spec.Deps (Lib.jsoo_runtime_files libs))
[ Arg_spec.Dyn (fun (libs,_) -> Arg_spec.Deps (Lib.jsoo_runtime_files libs))
; Arg_spec.Deps javascript_files
; Arg_spec.Dep src
]
in
let flags = Ordered_set_lang.eval_with_standard flags ~standard:(standard ()) in
js_of_ocaml_rule ~sctx ~dir ~flags ~spec ~target ~dep:requires
js_of_ocaml_rule ~sctx ~dir ~flags ~spec ~target
let link_rule ~sctx ~dir ~runtime ~target ~requires ~top_closed_cm_files =
let link_rule ~sctx ~dir ~runtime ~target =
let ctx = SC.context sctx in
let get_all (libs, cm) =
let get_all (libs,cm) =
(* Special case for the stdlib because it is not referenced in the META *)
let stdlib = Lib.External (Findlib.stdlib_with_archives ctx.findlib) in
let all_libs =
@ -84,31 +80,29 @@ let link_rule ~sctx ~dir ~runtime ~target ~requires ~top_closed_cm_files =
Arg_spec.Deps (List.concat [all_libs;all_other_modules])
in
let jsoo_link = SC.resolve_program sctx ~hint:install_jsoo_hint "jsoo_link" in
SC.add_rule sctx ~targets:[target]
(Build.fanout requires top_closed_cm_files
>>>
Build.run ~context:(SC.context sctx) ~dir
jsoo_link
[ Arg_spec.A "-o"; Path target
; Arg_spec.Dep runtime
; Arg_spec.As (sourcemap ())
; Arg_spec.Dyn get_all
])
Build.run ~context:(SC.context sctx) ~dir
jsoo_link
[ Arg_spec.A "-o"; Target target
; Arg_spec.Dep runtime
; Arg_spec.As (sourcemap ())
; Arg_spec.Dyn get_all
]
let build_cm sctx ~dir ~js_of_ocaml ~src =
if separate_compilation_enabled () then begin
let target = Path.extend_basename src ~suffix:".js" in
if separate_compilation_enabled ()
then let target = Path.extend_basename src ~suffix:".js" in
let spec = Arg_spec.Dep src in
let flags =
Ordered_set_lang.eval_with_standard
js_of_ocaml.Jbuild_types.Js_of_ocaml.flags
~standard:(standard ())
in
js_of_ocaml_rule ~sctx ~dir ~flags ~spec ~target ~dep:(Build.return ())
end
[ js_of_ocaml_rule ~sctx ~dir ~flags ~spec ~target ]
else []
let setup_separate_compilation_rules sctx =
if separate_compilation_enabled () then begin
if separate_compilation_enabled ()
then
let ctx = SC.context sctx in
let all_pkg =
List.map
@ -123,25 +117,28 @@ let setup_separate_compilation_rules sctx =
let archives = Mode.Dict.get pkg.Findlib.archives Mode.Byte in
pkg.Findlib.name, pkg.dir, archives)
in
List.iter all_pkg ~f:(fun (pkg_name, pkg_dir, archives) ->
List.iter archives ~f:(fun name ->
let src = Path.relative pkg_dir name in
let target = in_build_dir ~ctx [ pkg_name; sprintf "%s.js" name] in
let dir = in_build_dir ~ctx [ pkg_name ] in
let spec = Arg_spec.Dep src in
let flags = standard () in
js_of_ocaml_rule ~sctx ~dir ~flags ~spec ~target ~dep:(Build.return ())))
end
List.concat_map all_pkg
~f:(fun (pkg_name,pkg_dir,archives) ->
List.map archives ~f:(fun name ->
let src = Path.relative pkg_dir name in
let target = in_build_dir ~ctx [ pkg_name; sprintf "%s.js" name] in
let dir = in_build_dir ~ctx [ pkg_name ] in
let spec = Arg_spec.Dep src in
let flags = standard () in
js_of_ocaml_rule ~sctx ~dir ~flags ~spec ~target
))
else []
let build_exe sctx ~dir ~js_of_ocaml ~src ~requires ~top_closed_cm_files =
let build_exe sctx ~dir ~js_of_ocaml ~src =
let {Jbuild_types.Js_of_ocaml.javascript_files; flags} = js_of_ocaml in
let javascript_files = List.map javascript_files ~f:(Path.relative dir) in
let mk_target ext = Path.extend_basename src ~suffix:ext in
let target = mk_target ".js" in
let standalone_runtime = mk_target ".runtime.js" in
if separate_compilation_enabled () then begin
link_rule ~sctx ~dir ~runtime:standalone_runtime ~target ~requires ~top_closed_cm_files;
standalone_runtime_rule ~sctx ~dir ~flags ~javascript_files
~target:standalone_runtime ~requires
end else
exe_rule ~sctx ~dir ~flags ~javascript_files ~src ~target ~requires
if separate_compilation_enabled () then
[ link_rule ~sctx ~dir ~runtime:standalone_runtime ~target
; standalone_runtime_rule ~sctx ~dir ~flags ~javascript_files
~target:standalone_runtime
]
else
[ exe_rule ~sctx ~dir ~flags ~javascript_files ~src ~target ]

10
src/js_of_ocaml_rules.mli
View File

@ -7,17 +7,17 @@ val build_cm
-> dir:Path.t
-> js_of_ocaml:Js_of_ocaml.t
-> src:Path.t
-> unit
-> (unit, Action.t) Build.t list
val build_exe
: Super_context.t
-> dir:Path.t
-> js_of_ocaml:Js_of_ocaml.t
-> src:Path.t
-> requires:(unit, Lib.t list) Build.t
-> top_closed_cm_files:(unit, Path.t list) Build.t
-> unit
-> (Lib.t list * Path.t list, Action.t) Build.t list
val setup_separate_compilation_rules : Super_context.t -> unit
val setup_separate_compilation_rules
: Super_context.t
-> (unit, Action.t) Build.t list

7
src/merlin.ml
View File

@ -30,12 +30,11 @@ let dot_merlin sctx ~dir ({ requires; flags; _ } as t) =
match Path.extract_build_context dir with
| Some (_, remaindir) ->
let path = Path.relative remaindir ".merlin" in
let merlin_exists = Path.relative dir ".merlin-exists" in
SC.add_rule sctx ~targets:[merlin_exists]
SC.add_rule sctx
(Build.path path
>>>
Build.update_file merlin_exists "");
SC.add_rule sctx ~targets:[path] (
Build.update_file (Path.relative dir ".merlin-exists") "");
SC.add_rule sctx (
requires
>>^ (fun libs ->
let ppx_flags = ppx_flags sctx ~dir ~src_dir:remaindir t in

7
src/module_compilation.ml
View File

@ -71,12 +71,13 @@ let build_cm sctx ?sandbox ~dynlink ~flags ~cm_kind ~(dep_graph:Ocamldep.dep_gra
let fn = Option.value_exn (Module.cmt_file m ~dir ml_kind) in
(fn :: extra_targets, A "-bin-annot")
in
SC.add_rule sctx ?sandbox ~targets:(dst :: extra_targets)
SC.add_rule sctx ?sandbox
(Build.paths extra_deps >>>
other_cm_files >>>
requires >>>
Build.dyn_paths (Build.arr (lib_dependencies ~cm_kind)) >>>
Build.run ~context:ctx (Dep compiler)
~extra_targets
[ Ocaml_flags.get_for_cm flags ~cm_kind
; cmt_args
; Dyn Lib.include_flags
@ -87,7 +88,7 @@ let build_cm sctx ?sandbox ~dynlink ~flags ~cm_kind ~(dep_graph:Ocamldep.dep_gra
; (match alias_module with
| None -> S []
| Some (m : Module.t) -> As ["-open"; m.name])
; A "-o"; Path dst
; A "-o"; Target dst
; A "-c"; Ml_kind.flag ml_kind; Dep src
])))
@ -98,7 +99,7 @@ let build_module sctx ?sandbox ~dynlink ~js_of_ocaml ~flags m ~dir ~dep_graph ~m
~alias_module);
(* Build *.cmo.js *)
let src = Module.cm_file m ~dir Cm_kind.Cmo in
Js_of_ocaml_rules.build_cm sctx ~dir ~js_of_ocaml ~src
SC.add_rules sctx (Js_of_ocaml_rules.build_cm sctx ~dir ~js_of_ocaml ~src)
let build_modules sctx ~dynlink ~js_of_ocaml ~flags ~dir ~dep_graph ~modules ~requires ~alias_module =
String_map.iter

4
src/ocamldep.ml
View File

@ -59,10 +59,10 @@ let rules sctx ~ml_kind ~dir ~item ~modules ~alias_module =
Path.relative dir (sprintf "%s.depends%s.ocamldep-output" item suffix)
in
let ctx = SC.context sctx in
SC.add_rule sctx ~targets:[ocamldep_output]
SC.add_rule sctx
(Build.run ~context:ctx (Dep ctx.ocamldep) [A "-modules"; S files]
~stdout_to:ocamldep_output);
Build.memoize ~name:(Path.to_string ocamldep_output)
Build.memoize (Path.to_string ocamldep_output)
(Build.lines_of ocamldep_output
>>^ parse_deps ~dir ~modules ~alias_module)

132
src/super_context.ml
View File

@ -21,6 +21,7 @@ type t =
; mutable rules : Build_interpret.Rule.t list
; stanzas_to_consider_for_install : (Path.t * Stanza.t) list
; mutable known_targets_by_src_dir_so_far : String_set.t Path.Map.t
; libs_vfile : (module Vfile_kind.S with type t = Lib.t list)
; cxx_flags : string list
; vars : string String_map.t
; ppx_dir : Path.t
@ -97,6 +98,19 @@ let create
List.concat_map stanzas ~f:(fun { ctx_dir; stanzas; _ } ->
List.map stanzas ~f:(fun s -> (ctx_dir, s)))
in
let module Libs_vfile =
Vfile_kind.Make_full
(struct type t = Lib.t list end)
(struct
open Sexp.To_sexp
let t _dir l = list string (List.map l ~f:Lib.best_name)
end)
(struct
open Sexp.Of_sexp
let t dir sexp =
List.map (list string sexp) ~f:(Lib_db.find_exn libs ~from:dir)
end)
in
let artifacts =
Artifacts.create context (List.map stanzas ~f:(fun (d : Dir_with_jbuild.t) ->
(d.ctx_dir, d.stanzas)))
@ -146,6 +160,7 @@ let create
; rules = []
; stanzas_to_consider_for_install
; known_targets_by_src_dir_so_far = Path.Map.empty
; libs_vfile = (module Libs_vfile)
; artifacts
; cxx_flags
; vars
@ -153,13 +168,13 @@ let create
; ppx_dir = Path.of_string (sprintf "_build/.ppx/%s" context.name)
}
let add_rule t ?sandbox ~targets build =
let rule = Build_interpret.Rule.make ?sandbox ~targets build in
let add_rule t ?sandbox build =
let rule = Build_interpret.Rule.make ?sandbox build in
t.rules <- rule :: t.rules;
t.known_targets_by_src_dir_so_far <-
Path.Set.fold rule.targets ~init:t.known_targets_by_src_dir_so_far
~f:(fun path acc ->
match Path.extract_build_context path with
List.fold_left rule.targets ~init:t.known_targets_by_src_dir_so_far
~f:(fun acc target ->
match Path.extract_build_context (Build_interpret.Target.path target) with
| None -> acc
| Some (_, path) ->
let dir = Path.parent path in
@ -171,6 +186,9 @@ let add_rule t ?sandbox ~targets build =
in
Path.Map.add acc ~key:dir ~data:files)
let add_rules t ?sandbox builds =
List.iter builds ~f:(add_rule t ?sandbox)
let sources_and_targets_known_so_far t ~src_path =
let sources =
match File_tree.find_dir t.file_tree src_path with
@ -188,22 +206,19 @@ module Libs = struct
let find t ~from name = find t.libs ~from name
let requires_file ~dir ~item =
Path.relative dir (item ^ ".requires.sexp")
let load_deps t ~dir fn =
Build.read_sexp fn (fun sexp ->
Sexp.Of_sexp.(list string) sexp
|> List.map ~f:(fun name -> Lib_db.find_exn t.libs ~from:dir name))
let vrequires t ~dir ~item =
let fn = Path.relative dir (item ^ ".requires.sexp") in
Build.Vspec.T (fn, t.libs_vfile)
let load_requires t ~dir ~item =
load_deps t ~dir (requires_file ~dir ~item)
Build.vpath (vrequires t ~dir ~item)
let runtime_deps_file ~dir ~item =
Path.relative dir (item ^ ".runtime-deps.sexp")
let vruntime_deps t ~dir ~item =
let fn = Path.relative dir (item ^ ".runtime-deps.sexp") in
Build.Vspec.T (fn, t.libs_vfile)
let load_runtime_deps t ~dir ~item =
load_deps t ~dir (runtime_deps_file ~dir ~item)
Build.vpath (vruntime_deps t ~dir ~item)
let with_fail ~fail build =
match fail with
@ -252,21 +267,18 @@ module Libs = struct
List.iter (Lib_db.resolve_selects t.libs ~from:dir lib_deps) ~f:(fun { dst_fn; src_fn } ->
let src = Path.relative dir src_fn in
let dst = Path.relative dir dst_fn in
add_rule t ~targets:[dst]
add_rule t
(Build.path src
>>>
Build.action_context_independent
Build.action_context_independent ~targets:[dst]
(Copy_and_add_line_directive (src, dst))))
let write_deps fn =
Build.write_sexp fn (fun l -> Sexp.To_sexp.(list string) (List.map l ~f:Lib.best_name))
let real_requires t ~dir ~dep_kind ~item ~libraries ~preprocess ~virtual_deps =
let all_pps =
List.map (Preprocess_map.pps preprocess) ~f:Pp.to_string
in
let requires_file = requires_file ~dir ~item in
add_rule t ~targets:[requires_file]
let vrequires = vrequires t ~dir ~item in
add_rule t
(Build.record_lib_deps ~dir ~kind:dep_kind (List.map virtual_deps ~f:Lib_dep.direct)
>>>
Build.fanout
@ -277,8 +289,8 @@ module Libs = struct
Build.arr (fun (libs, rt_deps) ->
Lib.remove_dups_preserve_order (libs @ rt_deps))
>>>
write_deps requires_file);
load_deps t ~dir requires_file
Build.store_vfile vrequires);
Build.vpath vrequires
let requires t ~dir ~dep_kind ~item ~libraries ~preprocess ~virtual_deps =
let real_requires =
@ -302,8 +314,8 @@ module Libs = struct
(requires, real_requires)
let setup_runtime_deps t ~dir ~dep_kind ~item ~libraries ~ppx_runtime_libraries =
let runtime_deps_file = runtime_deps_file ~dir ~item in
add_rule t ~targets:[runtime_deps_file]
let vruntime_deps = vruntime_deps t ~dir ~item in
add_rule t
(Build.fanout
(closure t ~dir ~dep_kind (List.map ppx_runtime_libraries ~f:Lib_dep.direct))
(closed_ppx_runtime_deps_of t ~dir ~dep_kind libraries)
@ -311,7 +323,7 @@ module Libs = struct
Build.arr (fun (rt_deps, rt_deps_of_deps) ->
Lib.remove_dups_preserve_order (rt_deps @ rt_deps_of_deps))
>>>
write_deps runtime_deps_file)
Build.store_vfile vruntime_deps)
end
module Deps = struct
@ -355,17 +367,24 @@ end
module Pkg_version = struct
open Build.O
let spec_file sctx (p : Package.t) =
Path.relative (Path.append sctx.context.build_dir p.path)
(sprintf "%s.version.sexp" p.name)
module V = Vfile_kind.Make(struct type t = string option end)
(functor (C : Sexp.Combinators) -> struct
let t = C.option C.string
end)
let read sctx p = Build.read_sexp (spec_file sctx p) Sexp.Of_sexp.(option string)
let spec sctx (p : Package.t) =
let fn =
Path.relative (Path.append sctx.context.build_dir p.path)
(sprintf "%s.version.sexp" p.name)
in
Build.Vspec.T (fn, (module V))
let read sctx p = Build.vpath (spec sctx p)
let set sctx p get =
let fn = spec_file sctx p in
add_rule sctx ~targets:[fn]
(get >>> Build.write_sexp fn Sexp.To_sexp.(option string));
Build.read_sexp fn Sexp.Of_sexp.(option string)
let spec = spec sctx p in
add_rule sctx (get >>> Build.store_vfile spec);
Build.vpath spec
end
module Action = struct
@ -491,7 +510,7 @@ module Action = struct
U.expand sctx.context dir t
~f:(expand_var sctx ~artifacts ~targets ~deps))
>>>
Build.action_dyn () ~context:sctx.context ~dir
Build.action_dyn () ~context:sctx.context ~dir ~targets
in
match forms.failures with
| [] -> build
@ -580,13 +599,13 @@ module PP = struct
| Some _ ->
libs
in
add_rule sctx ~targets:[target]
add_rule sctx
(libs
>>>
Build.dyn_paths (Build.arr (Lib.archive_files ~mode ~ext_lib:ctx.ext_lib))
>>>
Build.run ~context:ctx (Dep compiler)
[ A "-o" ; Path target
[ A "-o" ; Target target
; Dyn (Lib.link_flags ~mode)
])
@ -624,37 +643,32 @@ module PP = struct
let setup_reason_rules sctx ~dir (m : Module.t) =
let ctx = sctx.context in
let refmt = resolve_program sctx "refmt" ~hint:"opam install reason" in
let refmt src target =
let rule src target =
let src_path = Path.relative dir src in
let target = Path.relative dir target in
add_rule sctx ~targets:[target]
(Build.run ~context:ctx refmt
[ A "--print"
; A "binary"
; Dep src_path ]
~stdout_to:target)
in
Build.run ~context:ctx refmt
[ A "--print"
; A "binary"
; Dep src_path ]
~stdout_to:(Path.relative dir target) in
let impl =
match m.impl.syntax with
| OCaml -> m.impl
| Reason ->
let ml = Module.File.to_ocaml m.impl in
refmt m.impl.name ml.name;
ml
in
add_rule sctx (rule m.impl.name ml.name);
ml in
let intf =
Option.map m.intf ~f:(fun f ->
match f.syntax with
| OCaml -> f
| Reason ->
let mli = Module.File.to_ocaml f in
refmt f.name mli.name;
mli)
in
add_rule sctx (rule f.name mli.name);
mli) in
{ m with impl ; intf }
(* Generate rules to build the .pp files and return a new module map
where all filenames point to the .pp files *)
(* Generate rules to build the .pp files and return a new module map where all filenames
point to the .pp files *)
let pped_modules sctx ~dir ~dep_kind ~modules ~preprocess ~preprocessor_deps ~lib_name
~package_context =
let preprocessor_deps = Deps.interpret sctx ~dir preprocessor_deps in
@ -664,7 +678,7 @@ module PP = struct
| No_preprocessing -> m
| Action action ->
pped_module m ~dir ~f:(fun _kind src dst ->
add_rule sctx ~targets:[dst]
add_rule sctx
(preprocessor_deps
>>>
Build.path src
@ -683,7 +697,7 @@ module PP = struct
| Pps { pps; flags } ->
let ppx_exe = get_ppx_driver sctx pps ~dir ~dep_kind in
pped_module m ~dir ~f:(fun kind src dst ->
add_rule sctx ~targets:[dst]
add_rule sctx
(preprocessor_deps
>>>
Build.run ~context:sctx.context
@ -691,7 +705,7 @@ module PP = struct
[ As flags
; A "--dump-ast"
; As (cookie_library_name lib_name)
; A "-o"; Path dst
; A "-o"; Target dst
; Ml_kind.ppx_driver_flag kind; Dep src
])
)

3
src/super_context.mli
View File

@ -42,7 +42,8 @@ val cxx_flags : t -> string list
val expand_var_no_root : t -> string -> string option
val expand_vars : t -> dir:Path.t -> String_with_vars.t -> string
val add_rule : t -> ?sandbox:bool -> targets:Path.t list -> (unit, Action.t) Build.t -> unit
val add_rule : t -> ?sandbox:bool -> (unit, Action.t) Build.t -> unit
val add_rules : t -> ?sandbox:bool -> (unit, Action.t) Build.t list -> unit
val rules : t -> Build_interpret.Rule.t list
val sources_and_targets_known_so_far : t -> src_path:Path.t -> String_set.t

78
src/vfile_kind.ml Normal file
View File

@ -0,0 +1,78 @@
open Import
module Id = struct
type 'a tag = ..
module type S = sig
type t
type 'a tag += X : t tag
end
type 'a t = (module S with type t = 'a)
let create (type a) () =
let module M = struct
type t = a
type 'a tag += X : t tag
end in
(module M : S with type t = a)
let eq (type a) (type b)
(module A : S with type t = a)
(module B : S with type t = b)
: (a, b) eq option =
match A.X with
| B.X -> Some Eq
| _ -> None
end
module type S = sig
type t
val id : t Id.t
val load : Path.t -> t
val to_string : Path.t -> t -> string
end
type 'a t = (module S with type t = 'a)
let eq (type a) (type b)
(module A : S with type t = a)
(module B : S with type t = b) =
Id.eq A.id B.id
module Make_full
(T : sig type t end)
(To_sexp : sig val t : Path.t -> T.t -> Sexp.t end)
(Of_sexp : sig val t : Path.t -> Sexp.Ast.t -> T.t end)
: S with type t = T.t =
struct
type t = T.t
let id = Id.create ()
let to_string path x = To_sexp.t path x |> Sexp.to_string
let load path =
Of_sexp.t path (Sexp_load.single (Path.to_string path))
end
module Make
(T : sig type t end)
(F : functor (C : Sexp.Combinators) -> sig val t : T.t C.t end)
: S with type t = T.t =
struct
module Of_sexp = struct
include F(Sexp.Of_sexp)
let t _ sexp = t sexp
end
module To_sexp = struct
include F(Sexp.To_sexp)
let t _ x = t x
end
include Make_full(T)(To_sexp)(Of_sexp)
end

31
src/vfile_kind.mli Normal file
View File

@ -0,0 +1,31 @@
open Import
module Id : sig
type 'a t
val eq : 'a t -> 'b t -> ('a, 'b) eq option
end
module type S = sig
type t
val id : t Id.t
val load : Path.t -> t
val to_string : Path.t -> t -> string
end
type 'a t = (module S with type t = 'a)
val eq : 'a t -> 'b t -> ('a, 'b) eq option
module Make
(T : sig type t end)
(F : functor (C : Sexp.Combinators) -> sig val t : T.t C.t end)
: S with type t = T.t
module Make_full
(T : sig type t end)
(To_sexp : sig val t : Path.t -> T.t -> Sexp.t end)
(Of_sexp : sig val t : Path.t -> Sexp.Ast.t -> T.t end)
: S with type t = T.t