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

[WIP] Load rules lazily (#370) 

* Change jbuilder to load rules lazily

Rules are now loaded on a per directory basis as needed. This speed up
the start up time on large workspaces.

Does various refactoring as well.

* Simplify the handling of META files

We no longer generate a META.foo.from-jbuilder file. Nobody is using
this feature and it's making the new code more complicated.
This commit is contained in:
Jérémie Dimino 2018-01-19 08:50:06 +00:00 committed by GitHub
parent 1c8ca6718c
commit 9dd5ab74e4
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
38 changed files with 1891 additions and 1405 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
CHANGES.md
View File

@ -56,6 +56,15 @@ next
ppx_driver. This allows to use `[@@deriving_inline]` in .ml/.mli
files. This require `ppx_driver >= v0.10.2` to work properly (#415)
- Make jbuilder load rules lazily instead of generating them all
eagerly. This speeds up the initial startup time of jbuilder on big
workspaces (#370)
- Now longer generate a `META.pkg.from-jbuilder` file. Now the only
way to customise the generated `META` file is through
`META.pkg.template`. This feature was unused and was making the code
complicated (#370)
1.0+beta16 (05/11/2017)
-----------------------

105
bin/main.ml
View File

@ -24,6 +24,7 @@ type common =
; x : string option
; diff_command : string option
; auto_promote : bool
; force : bool
; (* Original arguments for the external-lib-deps hint *)
orig_args : string list
}
@ -43,6 +44,7 @@ let set_common c ~targets =
Clflags.workspace_root := Sys.getcwd ();
Clflags.diff_command := c.diff_command;
Clflags.auto_promote := c.auto_promote;
Clflags.force := c.force;
Clflags.external_lib_deps_hint :=
List.concat
[ ["jbuilder"; "external-lib-deps"; "--missing"]
@ -73,10 +75,9 @@ let restore_cwd_and_execve common prog argv env =
module Main = struct
include Jbuilder.Main
let setup ~log ?unlink_aliases ?filter_out_optional_stanzas_with_missing_deps common =
let setup ~log ?filter_out_optional_stanzas_with_missing_deps common =
setup
~log
?unlink_aliases
?workspace_file:common.workspace_file
?only_packages:common.only_packages
?filter_out_optional_stanzas_with_missing_deps
@ -86,17 +87,29 @@ end
type target =
| File of Path.t
| Alias_rec of Alias.t
| Alias_rec of Path.t
let request_of_targets (setup : Main.setup) targets =
let open Build.O in
let contexts = List.map setup.contexts ~f:(fun c -> c.Context.name) in
List.fold_left targets ~init:(Build.return ()) ~f:(fun acc target ->
acc >>>
match target with
| File path -> Build.path path
| Alias_rec alias ->
Alias.dep_rec ~loc:(Loc.in_file "<command-line>")
~file_tree:setup.file_tree alias)
| Alias_rec path ->
let dir = Path.parent path in
let name = Path.basename path in
let contexts, dir =
match Path.extract_build_context dir with
| None -> (contexts, dir)
| Some ("install", _) ->
die "Invalid alias: %s.\n\
There are no aliases in _build/install."
(Path.to_string_maybe_quoted path)
| Some (ctx, dir) -> ([ctx], dir)
in
Build_system.Alias.dep_rec_multi_contexts ~dir ~name
~file_tree:setup.file_tree ~contexts)
let do_build (setup : Main.setup) targets =
Build_system.do_build_exn setup.build_system
@ -162,6 +175,7 @@ let common =
workspace_file
diff_command
auto_promote
force
(root, only_packages, orig)
x
=
@ -190,6 +204,7 @@ let common =
; target_prefix = String.concat ~sep:"" (List.map to_cwd ~f:(sprintf "%s/"))
; diff_command
; auto_promote
; force
; only_packages =
Option.map only_packages
~f:(fun s -> String_set.of_list (String.split s ~on:','))
@ -287,6 +302,13 @@ let common =
~doc:"Automatically promote files. This is similar to running
$(b,jbuilder promote) after the build.")
in
let force =
Arg.(value
& flag
& info ["force"; "f"]
~doc:"Force actions associated to aliases to be re-executed even
if their dependencies haven't changed.")
in
let for_release = "for-release-of-packages" in
let frop =
Arg.(value
@ -349,6 +371,7 @@ let common =
$ workspace_file
$ diff_command
$ auto_promote
$ force
$ root_and_only_packages
$ x
)
@ -423,21 +446,43 @@ let target_hint (setup : Main.setup) path =
let candidates = String_set.of_list candidates |> String_set.elements in
hint (Path.to_string path) candidates
let check_path contexts =
let contexts = String_set.of_list (List.map contexts ~f:(fun c -> c.Context.name)) in
fun path ->
let internal path =
die "This path is internal to jbuilder: %s" (Path.to_string_maybe_quoted path)
in
if Path.is_in_build_dir path then
match Path.extract_build_context path with
| None -> internal path
| Some (name, _) ->
if name = "" || name.[0] = '.' then internal path;
if not (name = "install" || String_set.mem name contexts) then
die "%s refers to unknown build context: %s%s"
(Path.to_string_maybe_quoted path)
name
(hint name (String_set.elements contexts))
let resolve_targets ~log common (setup : Main.setup) user_targets =
match user_targets with
| [] -> []
| _ ->
let check_path = check_path setup.contexts in
let targets =
List.map user_targets ~f:(fun s ->
if String.is_prefix s ~prefix:"@" then
if String.is_prefix s ~prefix:"@" then begin
let s = String.sub s ~pos:1 ~len:(String.length s - 1) in
let path = Path.relative Path.root (prefix_target common s) in
check_path path;
if Path.is_root path then
die "@@ on the command line must be followed by a valid alias name"
else if not (Path.is_local path) then
die "@@ on the command line must be followed by a relative path"
else
Ok [Alias_rec (Alias.of_path path)]
else
Ok [Alias_rec path]
end else begin
let path = Path.relative Path.root (prefix_target common s) in
check_path path;
let can't_build path =
Error (path, target_hint setup path);
in
@ -450,23 +495,17 @@ let resolve_targets ~log common (setup : Main.setup) user_targets =
can't_build path
end else
match
let l =
List.filter_map setup.contexts ~f:(fun ctx ->
let path = Path.append ctx.Context.build_dir path in
if Build_system.is_target setup.build_system path then
Some (File path)
else
None)
in
if Build_system.is_target setup.build_system path ||
Path.exists path then
File path :: l
else
l
List.filter_map setup.contexts ~f:(fun ctx ->
let path = Path.append ctx.Context.build_dir path in
if Build_system.is_target setup.build_system path then
Some (File path)
else
None)
with
| [] -> can't_build path
| l -> Ok l
)
end
)
in
if !Clflags.verbose then begin
Log.info log "Actual targets:";
@ -477,8 +516,7 @@ let resolve_targets ~log common (setup : Main.setup) user_targets =
List.iter targets ~f:(function
| File path ->
Log.info log @@ "- " ^ (Path.to_string path)
| Alias_rec alias ->
let path = Alias.fully_qualified_name alias in
| Alias_rec path ->
Log.info log @@ "- recursive alias " ^
(Path.to_string_maybe_quoted path));
flush stdout;
@ -524,8 +562,7 @@ let runtest =
]
in
let name_ = Arg.info [] ~docv:"DIR" in
let go common force dirs =
let unlink_aliases = if force then Some ["runtest"] else None in
let go common dirs =
set_common common
~targets:(List.map dirs ~f:(function
| "" | "." -> "@runtest"
@ -533,16 +570,17 @@ let runtest =
| dir -> sprintf "@%s/runtest" dir));
let log = Log.create () in
Future.Scheduler.go ~log
(Main.setup ?unlink_aliases ~log common >>= fun setup ->
(Main.setup ~log common >>= fun setup ->
let check_path = check_path setup.contexts in
let targets =
List.map dirs ~f:(fun dir ->
let dir = Path.(relative root) (prefix_target common dir) in
Alias_rec (Alias.runtest ~dir))
check_path dir;
Alias_rec (Path.relative dir "runtest"))
in
do_build setup targets) in
( Term.(const go
$ common
$ Arg.(value & flag & info ["force"; "f"])
$ Arg.(value & pos_all string ["."] name_))
, Term.info "runtest" ~doc ~man)
@ -557,7 +595,8 @@ let clean =
let go common =
begin
set_common common ~targets:[];
Build_system.all_targets_ever_built () |> List.iter ~f:Path.unlink_no_err;
Build_system.files_in_source_tree_to_delete ()
|> List.iter ~f:Path.unlink_no_err;
Path.(rm_rf (append root (of_string "_build")))
end
in
@ -928,7 +967,7 @@ let exec =
| [] -> ()
| targets ->
Future.Scheduler.go ~log (do_build setup targets);
Build_system.dump_trace setup.build_system
Build_system.finalize setup.build_system
end;
match prog_where with
| `Search prog ->
@ -1061,7 +1100,7 @@ let utop =
do_build setup [File target] >>| fun () ->
(setup.build_system, context, Path.to_string target)
) |> Future.Scheduler.go ~log in
Build_system.dump_trace build_system;
Build_system.finalize build_system;
restore_cwd_and_execve common utop_path (Array.of_list (utop_path :: args))
(Context.env_for_exec context)
in

27
doc/advanced-topics.rst
View File

@ -16,26 +16,19 @@ of a project to Jbuilder, it is allowed to write/generate a specific
one.
In order to do that, write or setup a rule to generate a
``META.<package>`` file in the same directory as the ``<package>.opam``
file. If you do that, Jbuilder will still generate a ``META`` file but
it will be called ``META.<package>.from-jbuilder``. So for instance if
you want to extend the ``META`` file generated by Jbuilder you can
write:
``META.<package>.template`` file in the same directory as the
``<package>.opam`` file. Jbuilder will generate a ``META.<package>``
file from the ``META.<package>.template`` file by replacing lines of
the form ``# JBUILDER_GEN`` by the contents of the ``META`` it would
normally generate.
.. code:: scheme
For instance if you want to extend the ``META`` file generated by
Jbuilder you can write the folliwing ``META.foo.template`` file:
(rule
((targets (META.foo))
(deps (META.foo.from-jbuilder))
(action (with-stdout-to ${@}
(progn
(cat ${<})
(echo blah))))))
.. code::
Additionally, Jbuilder provides a simpler mechanism for this scheme:
just write or generate a ``META.<package>.template`` file containing a
line of the form ``# JBUILDER_GEN``. Jbuilder will automatically insert
its generated ``META`` contents in place of this line.
# JBUILDER_GEN
blah = "..."
.. _custom-driver:

30
doc/usage.rst
View File

@ -91,14 +91,13 @@ the command line.
Resolution
----------
Most targets that Jbuilder knows how to build lives in the ``_build`` directory,
except for a few:
All targets that Jbuilder knows how to build live in the ``_build``
directory. Although, some are sometimes copied to the source tree for
the need of external tools. These includes:
= ``.merlin`` files
- ``.merlin`` files
- ``<package>.install`` files; for the ``default`` context Jbuilder knows how
generate the install file both in ``_build/default`` and in the source tree
so that ``opam`` can find it
- ``<package>.install`` files
As a result, if you want to ask ``jbuilder`` to produce a particular ``.exe``
file you would have to type:
@ -107,14 +106,15 @@ file you would have to type:
$ jbuilder build _build/default/bin/prog.exe
However, for convenience when a target on the command line doesn't start with
``_build``, ``jbuilder`` will expand it to the corresponding target in all the
build contexts where it knows how to build it. It prints out the actual set of
targets when starting so that you know what is happening:
However, for convenience when a target on the command line doesn't
start with ``_build``, ``jbuilder`` will expand it to the
corresponding target in all the build contexts where it knows how to
build it. When using ``--verbose``, It prints out the actual set of
targets when starting:
.. code:: bash
$ jbuilder build bin/prog.exe
$ jbuilder build bin/prog.exe --verbose
...
Actual targets:
- _build/default/bin/prog.exe
@ -126,11 +126,11 @@ Aliases
Targets starting with a ``@`` are interpreted as aliases. For instance
``@src/runtest`` means the alias ``runtest`` in all descendant of
``src`` where it is defined. If you want to refer to a target starting
with a ``@``, simply write: ``./@foo``.
``src`` in all build contexts where it is defined. If you want to
refer to a target starting with a ``@``, simply write: ``./@foo``.
Note that an alias not pointing to the ``_build`` directory always
depends on all the corresponding aliases in build contexts.
To build and run the tests for a particular build context, use
``@_build/default/runtest`` instead.
So for instance:

2
src/action.ml
View File

@ -795,7 +795,7 @@ let rec exec t ~ectx ~dir ~env_extra ~stdout_to ~stderr_to =
exec_echo stdout_to s
| Diff { optional; file1; file2 } ->
if (optional && not (Path.exists file1 && Path.exists file2)) ||
Io.read_file (Path.to_string file1) = Io.read_file (Path.to_string file2) then
Io.compare_files (Path.to_string file1) (Path.to_string file2) = 0 then
return ()
else begin
let is_copied_from_source_tree file =

210
src/alias.ml
View File

@ -1,210 +0,0 @@
open! Import
(** Fully qualified name *)
module Fq_name : sig
type t
val pp : Format.formatter -> t -> unit
val make : Path.t -> t
val path : t -> Path.t
end = struct
type t = Path.t
let make t = t
let path t = t
let pp = Path.pp
end
type t =
{ name : Fq_name.t
; file : Path.t
}
let pp fmt t =
Format.fprintf fmt "@[<2>{ name@ =@ %a@ ;@ file@ =@ %a }@]"
Path.pp (Fq_name.path t.name) Path.pp t.file
let aliases_path = Path.(relative root) "_build/.aliases"
let suffix = "-" ^ String.make 32 '0'
let of_path path =
if not (Path.is_local path) then
die "Aliases are only supported for local paths!\n\
Tried to reference alias %S"
(Path.to_string path);
{ name = Fq_name.make path
; file = Path.extend_basename (Path.append aliases_path path) ~suffix
}
let name t = Path.basename (Fq_name.path t.name)
let dir t = Path.parent (Fq_name.path t.name)
let fully_qualified_name t = Fq_name.path t.name
let make name ~dir =
assert (not (String.contains name '/'));
of_path (Path.relative dir name)
let dep t = Build.path t.file
let is_standard = function
| "runtest" | "install" | "doc" | "lint" -> true
| _ -> false
let dep_rec ~loc ~file_tree t =
let path = Path.parent (Fq_name.path t.name) |> Path.drop_optional_build_context in
let name = Path.basename (Fq_name.path t.name) in
match File_tree.find_dir file_tree path with
| None -> Build.fail { fail = fun () ->
Loc.fail loc "Don't know about directory %s!" (Path.to_string_maybe_quoted path) }
| Some dir ->
let open Build.O in
File_tree.Dir.fold dir ~traverse_ignored_dirs:false ~init:(Build.return true)
~f:(fun dir acc ->
let path = File_tree.Dir.path dir in
let t = of_path (Path.relative path name) in
acc
>>>
Build.if_file_exists t.file
~then_:(Build.path t.file
>>^
fun _ -> false)
~else_:(Build.arr (fun x -> x)))
>>^ fun is_empty ->
if is_empty && not (is_standard name) then
Loc.fail loc "This alias is empty.\n\
Alias %S is not defined in %s or any of its descendants."
name (Path.to_string_maybe_quoted path)
let file t = t.file
let file_with_digest_suffix t ~digest =
let dir = Path.parent t.file in
let base = Path.basename t.file in
let len = String.length base in
Path.relative dir
(String.sub base ~pos:0 ~len:(len - 32) ^ Digest.to_hex digest)
let of_file fn =
match Path.extract_build_context fn with
| Some (".aliases", fn) -> begin
let dir = Path.parent fn in
let name = Path.basename fn in
match String.rsplit2 name ~on:'-' with
| None -> assert false
| Some (name, digest) ->
assert (String.length digest = 32);
Some (make name ~dir)
end
| _ -> None
let name_of_file fn =
match Path.extract_build_context fn with
| Some (".aliases", fn) -> begin
let name = Path.basename fn in
match String.rsplit2 name ~on:'-' with
| None -> assert false
| Some (name, digest) ->
assert (String.length digest = 32);
Some name
end
| _ -> None
let default = make "DEFAULT"
let runtest = make "runtest"
let install = make "install"
let doc = make "doc"
let lint = make "lint"
module Store = struct
type entry =
{ alias : t
; mutable deps : Path.Set.t
}
let pp_entry fmt entry =
let pp_deps fmt deps =
Format.pp_print_list Path.pp fmt (Path.Set.elements deps) in
Format.fprintf fmt "@[<2>{@ alias@ =@ %a@ ;@ deps@ = (%a)@ }@]"
pp entry.alias pp_deps entry.deps
type t = (Fq_name.t, entry) Hashtbl.t
let pp fmt (t : t) =
let bindings = Hashtbl.fold ~init:[] ~f:(fun ~key ~data acc ->
(key, data)::acc
) t in
let pp_bindings fmt b =
Format.pp_print_list (fun fmt (k, v) ->
Format.fprintf fmt "@[<2>(%a@ %a)@]" Fq_name.pp k pp_entry v
) fmt b in
Format.fprintf fmt "Store.t@ @[@<2>(%a)@]" pp_bindings bindings
let create () = Hashtbl.create 1024
let unlink (store : t) = function
| [] -> ()
| alias_basenames ->
store
|> Hashtbl.fold ~init:Path.Set.empty ~f:(fun ~key:_ ~data:entry acc ->
if List.mem (name entry.alias) ~set:alias_basenames then (
Path.Set.union acc (Path.Set.add entry.alias.file entry.deps)
) else (
acc
))
|> Path.Set.iter ~f:Path.unlink_no_err
end
let add_deps store t deps =
let deps = Path.Set.of_list deps in
match Hashtbl.find store t.name with
| None ->
Hashtbl.add store ~key:t.name
~data:{ Store.alias = t
; deps = deps
}
| Some e -> e.deps <- Path.Set.union deps e.deps
let rules store =
(* For each alias @_build/blah/../x, add a dependency: @../x --> @_build/blah/../x *)
Hashtbl.fold store ~init:[] ~f:(fun ~key:_ ~data:{ Store. alias; _ } acc ->
match Path.extract_build_context (Fq_name.path alias.name) with
| None -> acc
| Some (_, in_src) -> (of_path in_src, alias) :: acc)
|> List.iter ~f:(fun (in_src, in_build_dir) ->
add_deps store in_src [in_build_dir.file]);
Hashtbl.fold store ~init:[] ~f:(fun ~key:_ ~data:{ Store. alias; deps } acc ->
let open Build.O in
let rule =
Build_interpret.Rule.make
(Build.path_set deps >>>
Build.action ~targets:[alias.file]
(Redirect (Stdout,
alias.file,
Digest_files
(Path.Set.elements deps))))
in
rule :: acc)
let add_build store t ~stamp build =
let digest = Digest.string (Sexp.to_string stamp) in
let digest_path = file_with_digest_suffix t ~digest in
add_deps store t [digest_path];
Build.progn
[ build
; Build.create_file digest_path
]
let add_builds store t builds =
let digest_files, actions =
List.split
(List.map builds ~f:(fun (stamp, build) ->
let digest = Digest.string (Sexp.to_string stamp) in
let digest_path = file_with_digest_suffix t ~digest in
(digest_path,
Build.progn
[ build
; Build.create_file digest_path
])))
in
add_deps store t digest_files;
actions

95
src/alias.mli
View File

@ -1,95 +0,0 @@
(** Rule aliases. *)
open Import
type t
val pp : t Fmt.t
val make : string -> dir:Path.t -> t
val of_path : Path.t -> t
(** The following always holds:
{[
make (name t) ~dir:(dir t) = t
]}
*)
val name : t -> string
val dir : t -> Path.t
val fully_qualified_name : t -> Path.t
val default : dir:Path.t -> t
val runtest : dir:Path.t -> t
val install : dir:Path.t -> t
val doc : dir:Path.t -> t
val lint : dir:Path.t -> t
val dep : t -> ('a, 'a) Build.t
(** Implements [(alias_rec ...)] in dependency specification and
[@alias] on the command line. *)
val dep_rec : loc:Loc.t -> file_tree:File_tree.t -> t -> (unit, unit) Build.t
(** File that represent the alias in the filesystem. It is a file under
[_build/.aliases]. *)
val file : t -> Path.t
(** Same as [file t], except that it sets the digest suffix to [digest]. Files
representing aliases ends with a hex-encoded md5sum of some data. It is usually filled
with zeros except for files that represent the running of an action associated to an
alias, it which case it is the md5 checksum of the action and its dependencies. *)
val file_with_digest_suffix : t -> digest:Digest.t -> Path.t
(** The following holds for any path [p]:
{[
match of_file p with
| None -> true
| Some t -> p = file t
]}
*)
val of_file : Path.t -> t option
(** Same as [Option.map (of_file p) ~f:name] but more efficient. *)
val name_of_file : Path.t -> string option
module Store : sig
type t
val pp : t Fmt.t
val create : unit -> t
val unlink : t -> string list -> unit
end
(** [add_build store alias deps] arrange things so that all [deps] are built as part of
the build of alias [alias]. *)
val add_deps : Store.t -> t -> Path.t list -> unit
(** [add_build store alias ~stamp build] arrange things so that [build] is part of the
build of alias [alias]. [stamp] is any S-expression that is unique and persistent
S-expression.
Return a rule that must be added with [Super_context.add_rule].
*)
val add_build
: Store.t
-> t
-> stamp:Sexp.t
-> (unit, Action.t) Build.t
-> (unit, Action.t) Build.t
(** Same as calling [add_build] in a loop but slightly more efficient. *)
val add_builds
: Store.t
-> t
-> (Sexp.t * (unit, Action.t) Build.t) list
-> (unit, Action.t) Build.t list
val rules : Store.t -> Build_interpret.Rule.t list

67
src/build_interpret.ml
View File

@ -26,7 +26,7 @@ module Static_deps = struct
}
end
let static_deps t ~all_targets_by_dir =
let static_deps t ~all_targets =
let rec loop : type a b. (a, b) t -> Static_deps.t -> Static_deps.t = fun t acc ->
match t with
| Arr _ -> acc
@ -43,30 +43,32 @@ let static_deps t ~all_targets_by_dir =
| G_evaluated l ->
{ acc with action_deps = Pset.union acc.action_deps (Pset.of_list l) }
| G_unevaluated (loc, dir, re) ->
match Pmap.find dir (Lazy.force all_targets_by_dir) with
| None ->
Loc.warn loc "Directory %s doesn't exist."
(Path.to_string_maybe_quoted dir);
state := G_evaluated [];
acc
| Some targets ->
let result =
Pset.filter targets ~f:(fun path ->
Re.execp re (Path.basename path))
in
state := G_evaluated (Pset.elements result);
let action_deps = Pset.union result acc.action_deps in
{ acc with action_deps }
let targets = all_targets ~dir in
let result =
Pset.filter targets ~f:(fun path ->
Re.execp re (Path.basename path))
in
if Pset.is_empty result then begin
if not (Path.exists dir) then
Loc.warn loc "Directory %s doesn't exist."
(Path.to_string_maybe_quoted dir)
else if not (Path.is_directory dir) then
Loc.warn loc "%s is not a directory."
(Path.to_string_maybe_quoted dir)
else
(* diml: we should probably warn in this case as well *)
()
end;
state := G_evaluated (Pset.elements result);
let action_deps = Pset.union result acc.action_deps in
{ acc with action_deps }
end
| If_file_exists (p, state) -> begin
match !state with
| Decided (_, t) -> loop t acc
| Undecided (then_, else_) ->
let dir = Path.parent p in
let targets =
Option.value (Pmap.find dir (Lazy.force all_targets_by_dir))
~default:Pset.empty
in
let targets = all_targets ~dir in
if Pset.mem p targets then begin
state := Decided (true, then_);
loop then_ acc
@ -157,19 +159,38 @@ module Rule = struct
; build : (unit, Action.t) Build.t
; targets : Target.t list
; sandbox : bool
; fallback : Jbuild.Rule.Fallback.t
; mode : Jbuild.Rule.Mode.t
; locks : Path.t list
; loc : Loc.t option
; dir : Path.t
}
let make ?(sandbox=false) ?(fallback=Jbuild.Rule.Fallback.Not_possible)
let make ?(sandbox=false) ?(mode=Jbuild.Rule.Mode.Not_a_rule_stanza)
?context ?(locks=[]) ?loc build =
let targets = targets build in
let dir =
match targets with
| [] ->
invalid_arg "Build_interpret.Rule.make: rule has no targets"
| x :: l ->
let dir = Path.parent (Target.path x) in
List.iter l ~f:(fun target ->
let path = Target.path target in
if Path.parent path <> dir then
Sexp.code_error "rule has targets in different directories"
[ "dir", Path.sexp_of_t dir
; "targets", Sexp.To_sexp.list Path.sexp_of_t
(List.map (x :: l) ~f:Target.path)
]);
dir
in
{ context
; build
; targets = targets build
; targets
; sandbox
; fallback
; mode
; locks
; loc
; dir
}
end

8
src/build_interpret.mli
View File

@ -15,14 +15,16 @@ module Rule : sig
; build : (unit, Action.t) Build.t
; targets : Target.t list
; sandbox : bool
; fallback : Jbuild.Rule.Fallback.t
; mode : Jbuild.Rule.Mode.t
; locks : Path.t list
; loc : Loc.t option
; (** Directory where all the targets are produced *)
dir : Path.t
}
val make
: ?sandbox:bool
-> ?fallback:Jbuild.Rule.Fallback.t
-> ?mode:Jbuild.Rule.Mode.t
-> ?context:Context.t
-> ?locks:Path.t list
-> ?loc:Loc.t
@ -40,7 +42,7 @@ end
(* must be called first *)
val static_deps
: (_, _) Build.t
-> all_targets_by_dir:Path.Set.t Path.Map.t Lazy.t
-> all_targets:(dir:Path.t -> Path.Set.t)
-> Static_deps.t
val lib_deps

1083
src/build_system.ml
View File

File diff suppressed because it is too large Load Diff

145
src/build_system.mli
View File

@ -4,15 +4,137 @@ open! Import
type t
(** {1 Creation} *)
(** Create a new build system. [file_tree] represent the source
tree. *)
val create
: contexts:Context.t list
-> file_tree:File_tree.t
-> rules:Build_interpret.Rule.t list
-> t
val is_target : t -> Path.t -> bool
type extra_sub_directories_to_keep =
| All
| These of String_set.t
(** Set the rule generators callback. There must be one callback per
build context name.
Each callback is used to generate the rules for a given directory
in the corresponding build context. It receive the directory for
which to generate the rules and the splitted part of the path after
the build context. It must return an additional list of
sub-directories to keep. This is in addition to the ones that are
present in the source tree and the ones that already contain rules.
It is expected that [f] only generate rules whose targets are
descendant of [dir]. *)
val set_rule_generators : t -> (dir:Path.t -> string list -> extra_sub_directories_to_keep) String_map.t -> unit
(** {1 Primitive for rule generations} *)
(** Add a rule to the system. This function must be called from the [gen_rules]
callback. All the target of the rule must be in the same directory.
Assuming that [gen_rules ~dir:a] calls [add_rule r] where [r.dir] is [Some b], one of
the following assumption must hold:
- [a] and [b] are the same
- [gen_rules ~dir:b] calls [load_dir ~dir:a]
The call to [load_dir ~dir:a] from [gen_rules ~dir:b] declares a directory dependency
from [b] to [a]. There must be no cyclic directory dependencies.
*)
val add_rule : t -> Build_interpret.Rule.t -> unit
(** [eval_glob t ~dir re ~f] returns the list of files in [dir] that matches [re] to
[f]. The list of files includes the list of targets. *)
val eval_glob : t -> dir:Path.t -> Re.re -> string list
(** Returns the set of targets in the given directory. *)
val targets_of : t -> dir:Path.t -> Path.Set.t
(** Load the rules for this directory. *)
val load_dir : t -> dir:Path.t -> unit
(** [on_load_dir ~dir ~f] remembers to run [f] when loading the rules for [dir]. *)
val on_load_dir : t -> dir:Path.t -> f:(unit -> unit) -> unit
(** Stamp file that depends on all files of [dir] with extension [ext]. *)
val stamp_file_for_files_of : t -> dir:Path.t -> ext:string -> Path.t
(** {1 Aliases} *)
module Alias : sig
type build_system = t
type t
val pp : t Fmt.t
val make : string -> dir:Path.t -> t
val of_path : Path.t -> t
(** The following always holds:
{[
make (name t) ~dir:(dir t) = t
]}
*)
val name : t -> string
val dir : t -> Path.t
val fully_qualified_name : t -> Path.t
val default : dir:Path.t -> t
val runtest : dir:Path.t -> t
val install : dir:Path.t -> t
val doc : dir:Path.t -> t
val lint : dir:Path.t -> t
(** Return the underlying stamp file *)
val stamp_file : t -> Path.t
(** [dep t = Build.path (stamp_file t)] *)
val dep : t -> ('a, 'a) Build.t
(** Implements [(alias_rec ...)] in dependency specification *)
val dep_rec
: t
-> loc:Loc.t
-> file_tree:File_tree.t
-> (unit, unit) Build.t
(** Implements [@alias] on the command line *)
val dep_rec_multi_contexts
: dir:Path.t
-> name:string
-> file_tree:File_tree.t
-> contexts:string list
-> (unit, unit) Build.t
(** [add_deps store alias deps] arrange things so that all [deps]
are built as part of the build of alias [alias]. *)
val add_deps : build_system -> t -> Path.t list -> unit
(** [add_action store alias ~stamp action] arrange things so that
[action] is executed as part of the build of alias
[alias]. [stamp] is any S-expression that is unique and
persistent S-expression.
*)
val add_action
: build_system
-> t
-> ?locks:Path.t list
-> stamp:Sexp.t
-> (unit, Action.t) Build.t
-> unit
end with type build_system := t
(** {1 Building} *)
module Build_error : sig
(** Exception raised in case of build error *)
type t
val backtrace : t -> Printexc.raw_backtrace
@ -32,6 +154,10 @@ val do_build_exn
-> request:(unit, unit) Build.t
-> unit Future.t
(** {1 Other queries} *)
val is_target : t -> Path.t -> bool
(** Return all the library dependencies (as written by the user)
needed to build this request *)
val all_lib_deps
@ -49,6 +175,14 @@ val all_lib_deps_by_context
(** List of all buildable targets *)
val all_targets : t -> Path.t list
(** Return the list of files that were created in the source tree and
needs to be deleted *)
val files_in_source_tree_to_delete
: unit
-> Path.t list
(** {1 Build rules} *)
(** A fully built rule *)
module Rule : sig
module Id : sig
@ -75,8 +209,7 @@ val build_rules
-> request:(unit, unit) Build.t
-> Rule.t list Future.t
val all_targets_ever_built
: unit
-> Path.t list
(** {1 Misc} *)
val dump_trace : t -> unit
(** Dump various databases on disk *)
val finalize : t -> unit

1
src/clflags.ml
View File

@ -12,3 +12,4 @@ let capture_outputs = ref true
let debug_backtraces = ref false
let diff_command = ref None
let auto_promote = ref false
let force = ref false

3
src/clflags.mli
View File

@ -41,3 +41,6 @@ val diff_command : string option ref
(** Automatically promote files *)
val auto_promote : bool ref
(** Force re-running actions associated to aliases *)
val force : bool ref

19
src/file_tree.ml
View File

@ -13,6 +13,19 @@ module Dir = struct
let sub_dirs t = t.sub_dirs
let ignored t = t.ignored
let file_paths t =
Path.Set.of_string_set t.files ~f:(Path.relative t.path)
let sub_dir_names t =
String_map.fold t.sub_dirs ~init:String_set.empty
~f:(fun ~key:s ~data:_ acc ->
String_set.add s acc)
let sub_dir_paths t =
String_map.fold t.sub_dirs ~init:Path.Set.empty
~f:(fun ~key:s ~data:_ acc ->
Path.Set.add (Path.relative t.path s) acc)
let rec fold t ~traverse_ignored_dirs ~init:acc ~f =
if not traverse_ignored_dirs && t.ignored then
acc
@ -89,6 +102,12 @@ let fold t ~traverse_ignored_dirs ~init ~f =
let find_dir t path =
Path.Map.find path t.dirs
let files_of t path =
match find_dir t path with
| None -> Path.Set.empty
| Some dir ->
Path.Set.of_string_set (Dir.files dir) ~f:(Path.relative path)
let file_exists t path fn =
match Path.Map.find path t.dirs with
| None -> false

5
src/file_tree.mli
View File

@ -5,7 +5,10 @@ module Dir : sig
val path : t -> Path.t
val files : t -> String_set.t
val file_paths : t -> Path.Set.t
val sub_dirs : t -> t String_map.t
val sub_dir_paths : t -> Path.Set.t
val sub_dir_names : t -> String_set.t
(** Whether this directory is ignored by a [jbuild-ignore] file in
one of its ancestor directories. *)
@ -34,6 +37,8 @@ val root : t -> Dir.t
val find_dir : t -> Path.t -> Dir.t option
val files_of : t -> Path.t -> Path.Set.t
val exists : t -> Path.t -> bool
val file_exists : t -> Path.t -> string -> bool

31
src/future.ml
View File

@ -387,30 +387,15 @@ module Scheduler = struct
let rec split_paths targets_acc ctxs_acc = function
| [] -> List.rev targets_acc, String_set.(elements (of_list ctxs_acc))
| path :: rest ->
match Path.extract_build_context path with
| None ->
let add_ctx ctx acc = if ctx = "default" then acc else ctx :: acc in
match Utils.analyse_target path with
| Other path ->
split_paths (Path.to_string path :: targets_acc) ctxs_acc rest
| Some ("default", filename) ->
split_paths (Path.to_string filename :: targets_acc) ctxs_acc rest
| Some (".aliases", filename) ->
let ctxs_acc, filename =
match Path.extract_build_context filename with
| None -> ctxs_acc, Path.to_string filename
| Some (ctx, fn) ->
let strip_digest fn =
let fn = Path.to_string fn in
match String.rsplit2 fn ~on:'-' with
| None -> assert false
| Some (name, digest) ->
assert (String.length digest = 32);
name
in
let ctxs_acc =
if ctx = "default" then ctxs_acc else ctx :: ctxs_acc in
ctxs_acc, strip_digest fn in
split_paths (("alias " ^ filename) :: targets_acc) ctxs_acc rest
| Some (ctx, filename) ->
split_paths (Path.to_string filename :: targets_acc) (ctx :: ctxs_acc) rest in
| Regular (ctx, filename) ->
split_paths (Path.to_string filename :: targets_acc) (add_ctx ctx ctxs_acc) rest
| Alias (ctx, name) ->
split_paths (("alias " ^ Path.to_string name) :: targets_acc) (add_ctx ctx ctxs_acc) rest
in
let target_names, contexts = split_paths [] [] targets in
let target_names_grouped_by_prefix =
List.map target_names ~f:Filename.split_extension_after_dot

896
src/gen_rules.ml
View File

File diff suppressed because it is too large Load Diff

7
src/gen_rules.mli
View File

@ -1,12 +1,11 @@
open! Import
open Jbuild
(* Generate rules. Returns evaluated jbuilds per context names. *)
val gen
: contexts:Context.t list
-> build_system:Build_system.t
-> ?filter_out_optional_stanzas_with_missing_deps:bool (* default: true *)
-> ?only_packages:String_set.t
-> ?unlink_aliases:string list
-> Jbuild_load.conf
-> (Build_interpret.Rule.t list *
(* Evaluated jbuilds per context names *)
(Path.t * Scope.t * Stanzas.t) list String_map.t) Future.t
-> (Path.t * Scope.t * Stanzas.t) list String_map.t Future.t

24
src/import.ml
View File

@ -2,7 +2,29 @@ include Jbuilder_re
module Array = StdLabels.Array
module Bytes = StdLabels.Bytes
module Set = MoreLabels.Set
module Set = struct
module type OrderedType = MoreLabels.Set.OrderedType
module type S = sig
include MoreLabels.Set.S
val map : f:(elt -> elt) -> t -> t
end
module Make(Elt : OrderedType) : S with type elt = Elt.t = struct
module M = MoreLabels.Set.Make(Elt)
include struct
[@@@warning "-32"]
(* [map] is only available since 4.04 *)
let map ~f t =
M.elements t
|> List.map f
|> M.of_list
end
include M
end
end
external reraise : exn -> _ = "%reraise"

3
src/io.ml
View File

@ -66,3 +66,6 @@ let copy_file ~src ~dst =
~finally:close_out
~f:(fun oc ->
copy_channels ic oc))
(* TODO: diml: improve this *)
let compare_files fn1 fn2 = String.compare (read_file fn1) (read_file fn2)

2
src/io.mli
View File

@ -16,6 +16,8 @@ val lines_of_file : string -> string list
val read_file : string -> string
val write_file : string -> string -> unit
val compare_files : string -> string -> int
val copy_channels : in_channel -> out_channel -> unit
val copy_file : src:string -> dst:string -> unit

25
src/jbuild.ml
View File

@ -727,18 +727,21 @@ module Rule = struct
| Infer
end
module Fallback = struct
module Mode = struct
type t =
| Yes
| No
| Not_possible
| Standard
| Fallback
| Promote
| Promote_but_delete_on_clean
| Not_a_rule_stanza
end
type t =
{ targets : Targets.t
; deps : Dep_conf.t list
; action : Action.Unexpanded.t
; fallback : Fallback.t
; mode : Mode.t
; locks : String_with_vars.t list
; loc : Loc.t
}
@ -749,7 +752,7 @@ module Rule = struct
{ targets = Infer
; deps = []
; action = Action.Unexpanded.t sexp
; fallback = No
; mode = Standard
; locks = []
; loc = Loc.none
}
@ -763,7 +766,7 @@ module Rule = struct
return { targets = Static targets
; deps
; action
; fallback = if fallback then Yes else No
; mode = if fallback then Fallback else Standard
; locks
; loc = Loc.none
})
@ -785,7 +788,7 @@ module Rule = struct
; S.virt_var __POS__ "@"
; S.virt_var __POS__"<"
]))
; fallback = Not_possible
; mode = Not_a_rule_stanza
; locks = []
; loc
})
@ -801,7 +804,7 @@ module Rule = struct
(S.virt_var __POS__ "ROOT",
Run (S.virt_text __POS__ "ocamlyacc",
[S.virt_var __POS__ "<"]))
; fallback = Not_possible
; mode = Not_a_rule_stanza
; locks = []
; loc
})
@ -841,7 +844,7 @@ module Menhir = struct
(S.virt_var __POS__ "ROOT",
Run (S.virt_text __POS__ "menhir",
t.flags @ [S.virt_var __POS__ "<"]))
; fallback = Not_possible
; mode = Not_a_rule_stanza
; locks = []
; loc
})
@ -861,7 +864,7 @@ module Menhir = struct
; t.flags
; [ S.virt_var __POS__ "^" ]
]))
; fallback = Not_possible
; mode = Not_a_rule_stanza
; locks = []
; loc
}]

19
src/jbuild.mli
View File

@ -203,20 +203,25 @@ module Rule : sig
| Infer
end
module Fallback : sig
module Mode : sig
type t =
| Yes
| No
| Not_possible
(** It is not possible to add a [(fallback)] field to the rule. For instance for
[ocamllex], ... *)
| Standard
(** Only use this rule if the source files don't exist. *)
| Fallback
(** Silently promote the targets to the source tree. *)
| Promote
(** Same as [Promote] but [jbuilder clean] must delete the file *)
| Promote_but_delete_on_clean
(** Same as [Standard] however this is not a rule stanza, so it is not possible to
add a [(fallback)] field to the rule. *)
| Not_a_rule_stanza
end
type t =
{ targets : Targets.t
; deps : Dep_conf.t list
; action : Action.Unexpanded.t
; fallback : Fallback.t
; mode : Mode.t
; locks : String_with_vars.t list
; loc : Loc.t
}

48
src/js_of_ocaml_rules.ml
View File

@ -101,36 +101,34 @@ let build_cm sctx ~scope ~dir ~js_of_ocaml ~src =
js_of_ocaml_rule ~sctx ~dir ~flags:(fun flags -> As flags) ~spec ~target ]
else []
let setup_separate_compilation_rules sctx =
let setup_separate_compilation_rules sctx components =
if separate_compilation_enabled ()
then
let ctx = SC.context sctx in
let all_pkg =
List.map
(Findlib.all_packages ctx.findlib)
~f:(fun pkg ->
match components with
| [] | _ :: _ :: _ -> ()
| [pkg] ->
let ctx = SC.context sctx in
match Findlib.find ctx.findlib pkg ~required_by:[] with
| None -> ()
| Some pkg ->
let pkg =
(* Special case for the stdlib because it is not referenced in the META *)
let pkg =
if pkg.Findlib.name = "stdlib"
then Findlib.stdlib_with_archives ctx.findlib
else pkg
in
let archives = Mode.Dict.get pkg.Findlib.archives Mode.Byte in
pkg.Findlib.name, pkg.dir, archives)
in
List.concat_map all_pkg
~f:(fun (pkg_name,pkg_dir,archives) ->
List.map archives ~f:(fun fn ->
match pkg.Findlib.name with
| "stdlib" -> Findlib.stdlib_with_archives ctx.findlib
| _ -> pkg
in
let archives = Mode.Dict.get pkg.Findlib.archives Mode.Byte in
List.iter archives ~f:(fun fn ->
let name = Path.basename fn in
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 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
Build.return (standard ())
>>>
js_of_ocaml_rule ~sctx ~dir ~flags:(fun flags -> As flags) ~spec ~target
))
else []
SC.add_rule sctx
(Build.return (standard ())
>>>
js_of_ocaml_rule ~sctx ~dir ~flags:(fun flags -> As flags) ~spec ~target)
)
let build_exe sctx ~dir ~js_of_ocaml ~src =
let {Jbuild.Js_of_ocaml.javascript_files; _} = js_of_ocaml in

3
src/js_of_ocaml_rules.mli
View File

@ -19,6 +19,7 @@ val build_exe
val setup_separate_compilation_rules
: Super_context.t
-> (unit, Action.t) Build.t list
-> string list
-> unit
val standard : unit -> string list

17
src/main.ml
View File

@ -15,7 +15,7 @@ let package_install_file { packages; _ } pkg =
| Some p ->
Ok (Path.relative p.path (Utils.install_file ~package:p.name ~findlib_toolchain:None))
let setup ?(log=Log.no_log) ?unlink_aliases
let setup ?(log=Log.no_log)
?filter_out_optional_stanzas_with_missing_deps
?workspace ?(workspace_file="jbuild-workspace")
?(use_findlib=true)
@ -55,14 +55,15 @@ let setup ?(log=Log.no_log) ?unlink_aliases
let contexts = List.concat contexts in
List.iter contexts ~f:(fun (ctx : Context.t) ->
Log.infof log "@[<1>Jbuilder context:@,%a@]@." Sexp.pp (Context.sexp_of_t ctx));
let build_system =
Build_system.create ~contexts ~file_tree:conf.file_tree
in
Gen_rules.gen conf
~build_system
~contexts
?unlink_aliases
?only_packages
?filter_out_optional_stanzas_with_missing_deps
>>= fun (rules, stanzas) ->
let build_system = Build_system.create ~contexts
~file_tree:conf.file_tree ~rules in
>>= fun stanzas ->
return { build_system
; stanzas
; contexts
@ -211,7 +212,6 @@ let ignored_during_bootstrap =
(* Called by the script generated by ../build.ml *)
let bootstrap () =
Ansi_color.setup_err_formatter_colors ();
let pkg = "jbuilder" in
let main () =
let anon s = raise (Arg.Bad (Printf.sprintf "don't know what to do with %s\n" s)) in
let subst () =
@ -228,13 +228,14 @@ let bootstrap () =
Clflags.debug_dep_path := true;
let log = Log.create () in
Future.Scheduler.go ~log
(setup ~log ~workspace:{ merlin_context = Some "default"; contexts = [Default [Native]] }
(setup ~log ~workspace:{ merlin_context = Some "default"
; contexts = [Default [Native]] }
~use_findlib:false
~extra_ignored_subtrees:ignored_during_bootstrap
()
>>= fun { build_system = bs; _ } ->
Build_system.do_build_exn bs
~request:(Build.path (Path.(relative root) (pkg ^ ".install"))))
~request:(Build.path (Path.of_string "_build/default/jbuilder.install")))
in
try
main ()

1
src/main.mli
View File

@ -17,7 +17,6 @@ val package_install_file : setup -> string -> (Path.t, unit) result
it. *)
val setup
: ?log:Log.t
-> ?unlink_aliases:string list
-> ?filter_out_optional_stanzas_with_missing_deps:bool
-> ?workspace:Workspace.t
-> ?workspace_file:string

18
src/merlin.ml
View File

@ -12,10 +12,10 @@ type t =
; source_dirs: Path.Set.t
}
let ppx_flags sctx ~dir ~src_dir:_ { preprocess; libname; _ } =
let ppx_flags sctx ~dir:_ ~src_dir:_ { preprocess; libname; _ } =
match preprocess with
| Pps { pps; flags } ->
let exe = SC.PP.get_ppx_driver sctx pps ~dir ~dep_kind:Optional in
let exe = SC.PP.get_ppx_driver sctx pps in
let command =
List.map (Path.to_absolute_filename exe
:: "--as-ppx"
@ -28,14 +28,10 @@ let ppx_flags sctx ~dir ~src_dir:_ { preprocess; libname; _ } =
| _ -> []
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
SC.add_rule sctx
(Build.path path
>>>
Build.write_file (Path.relative dir ".merlin-exists") "");
SC.add_rule sctx (
match Path.drop_build_context dir with
| Some remaindir ->
let merlin_file = Path.relative dir ".merlin" in
SC.add_rule sctx ~mode:Promote_but_delete_on_clean (
requires &&& flags
>>^ (fun (libs, flags) ->
let ppx_flags = ppx_flags sctx ~dir ~src_dir:remaindir t in
@ -82,7 +78,7 @@ let dot_merlin sctx ~dir ({ requires; flags; _ } as t) =
|> List.map ~f:(Printf.sprintf "%s\n")
|> String.concat ~sep:"")
>>>
Build.write_file_dyn path
Build.write_file_dyn merlin_file
)
| _ ->
()

14
src/odoc.ml
View File

@ -155,7 +155,7 @@ let setup_library_rules sctx (lib : Library.t) ~dir ~modules ~requires
~f:(fun (m, _) -> m.Module.name = main_module_name)
else
modules_and_odoc_files
in*)
in*)
let html_files =
List.map modules_and_odoc_files ~f:(fun (m, odoc_file) ->
to_html sctx m odoc_file ~doc_dir ~odoc ~dir ~includes ~lib
@ -165,7 +165,7 @@ let setup_library_rules sctx (lib : Library.t) ~dir ~modules ~requires
lib_index sctx ~dir ~lib ~lib_unique_name ~lib_name ~doc_dir
~modules ~includes ~odoc
in
Alias.add_deps (SC.aliases sctx) (Alias.doc ~dir)
SC.add_alias_deps sctx (Build_system.Alias.doc ~dir)
(css_file ~doc_dir
:: toplevel_index ~doc_dir
:: lib_index_html
@ -227,3 +227,13 @@ let setup_toplevel_index_rule sctx =
let context = SC.context sctx in
let doc_dir = doc_dir ~context in
SC.add_rule sctx @@ Build.write_file (toplevel_index ~doc_dir) html
let gen_rules sctx ~dir rest =
match rest with
| [] ->
setup_css_rule sctx;
setup_toplevel_index_rule sctx
| lib :: _ ->
match Lib_db.find (SC.libs sctx) ~from:dir lib with
| None | Some (External _) -> ()
| Some (Internal (dir, _)) -> SC.load_dir sctx ~dir

4
src/odoc.mli
View File

@ -12,6 +12,4 @@ val setup_library_rules
-> dep_graph:Ocamldep.dep_graph
-> unit
val setup_css_rule : Super_context.t -> unit
val setup_toplevel_index_rule: Super_context.t -> unit
val gen_rules : Super_context.t -> dir:Path.t -> string list -> unit

44
src/path.ml
View File

@ -223,7 +223,9 @@ let compare = String.compare
module Set = struct
include String_set
let sexp_of_t t = Sexp.To_sexp.(list string) (String_set.elements t)
let of_string_set = map
end
module Map = String_map
module Kind = struct
@ -346,9 +348,16 @@ let parent t =
let build_prefix = "_build/"
let build_dir = "_build"
let is_in_build_dir t =
String.is_prefix t ~prefix:build_prefix
let is_in_source_tree t = is_local t && not (is_in_build_dir t)
let is_alias_stamp_file t =
String.is_prefix t ~prefix:"_build/.aliases/"
let extract_build_context t =
if String.is_prefix t ~prefix:build_prefix then
let i = String.length build_prefix in
@ -380,11 +389,39 @@ let extract_build_context_dir t =
let drop_build_context t =
Option.map (extract_build_context t) ~f:snd
let drop_build_context_exn t =
match extract_build_context t with
| None -> Sexp.code_error "Path.drop_build_context_exn" [ "t", sexp_of_t t ]
| Some (_, t) -> t
let drop_optional_build_context t =
match extract_build_context t with
| None -> t
| Some (_, t) -> t
let split_first_component t =
if is_local t && not (is_root t)then
match String.index t '/' with
| None -> Some (t, root)
| Some i ->
Some
(String.sub t ~pos:0 ~len:i,
String.sub t ~pos:(i + 1) ~len:(String.length t - i - 1))
else
None
let explode t =
if is_local t then
Some (String.split t ~on:'/')
else
None
let explode_exn t =
if is_local t then
String.split t ~on:'/'
else
Sexp.code_error "Path.explode_exn" ["path", Atom t]
let exists t = Sys.file_exists (to_string t)
let readdir t = Sys.readdir (to_string t) |> Array.to_list
let is_directory t =
@ -405,13 +442,10 @@ let insert_after_build_dir_exn =
]
in
fun a b ->
if not (is_local a && is_local b) then error a b;
if not (is_local a) || String.contains b '/' then error a b;
match String.lsplit2 a ~on:'/' with
| Some ("_build", rest) ->
if is_root b then
a
else
sprintf "_build/%s/%s" b rest
sprintf "_build/%s/%s" b rest
| _ ->
error a b

21
src/path.mli
View File

@ -42,9 +42,12 @@ val compare : t -> t -> int
module Set : sig
include Set.S with type elt = t
val sexp_of_t : t Sexp.To_sexp.t
val of_string_set : f:(string -> elt) -> String_set.t -> t
end
module Map : Map.S with type key = t
val kind : t -> Kind.t
val of_string : ?error_loc:Loc.t -> string -> t
@ -99,13 +102,29 @@ val extract_build_context_dir : t -> (t * t) option
(** Drop the "_build/blah" prefix *)
val drop_build_context : t -> t option
val drop_build_context_exn : t -> t
(** Drop the "_build/blah" prefix if present, return [t] otherwise *)
val drop_optional_build_context : t -> t
val explode : t -> string list option
val explode_exn : t -> string list
(** The build directory *)
val build_dir : t
(** [is_in_build_dir t = is_descendant t ~of:build_dir] *)
val is_in_build_dir : t -> bool
val insert_after_build_dir_exn : t -> t -> t
(** [is_in_build_dir t = is_local t && not (is_in_build_dir t)] *)
val is_in_source_tree : t -> bool
val is_alias_stamp_file : t -> bool
(** Split after the first component if [t] is local *)
val split_first_component : t -> (string * t) option
val insert_after_build_dir_exn : t -> string -> t
val exists : t -> bool
val readdir : t -> string list

199
src/super_context.ml
View File

@ -3,6 +3,7 @@ open Jbuild
module A = Action
module Pset = Path.Set
module Alias = Build_system.Alias
module Dir_with_jbuild = struct
type t =
@ -13,72 +14,36 @@ module Dir_with_jbuild = struct
}
end
module External_dir = struct
(* Files in the directory, grouped by extension *)
type t = Path.t list String_map.t
let create ~dir : t =
match Path.readdir dir with
| exception _ -> String_map.empty
| files ->
List.map files ~f:(fun fn -> Filename.extension fn, Path.relative dir fn)
|> String_map.of_alist_multi
(* CR-someday jdimino: when we can have dynamic targets:
{[
|> String_map.mapi ~f:(fun ext files ->
lazy (
let alias =
Alias.make ~dir:Path.root (sprintf "external-files-%s%s" hash ext)
in
Alias.add_deps aliases alias files;
alias
))
]}
*)
let files t ~ext = String_map.find_default ext t ~default:[]
end
type t =
{ context : Context.t
; libs : Lib_db.t
; stanzas : Dir_with_jbuild.t list
; packages : Package.t String_map.t
; aliases : Alias.Store.t
; file_tree : File_tree.t
; artifacts : Artifacts.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 : Action.Var_expansion.t String_map.t
; ppx_dir : Path.t
; ppx_drivers : (string, Path.t) Hashtbl.t
; external_dirs : (Path.t, External_dir.t) Hashtbl.t
; chdir : (Action.t, Action.t) Build.t
; host : t option
{ context : Context.t
; build_system : Build_system.t
; libs : Lib_db.t
; stanzas : Dir_with_jbuild.t list
; packages : Package.t String_map.t
; file_tree : File_tree.t
; artifacts : Artifacts.t
; stanzas_to_consider_for_install : (Path.t * Stanza.t) list
; libs_vfile : (module Vfile_kind.S with type t = Lib.t list)
; cxx_flags : string list
; vars : Action.Var_expansion.t String_map.t
; ppx_dir : Path.t
; chdir : (Action.t, Action.t) Build.t
; host : t option
}
let context t = t.context
let aliases t = t.aliases
let stanzas t = t.stanzas
let packages t = t.packages
let artifacts t = t.artifacts
let file_tree t = t.file_tree
let rules t = t.rules
let stanzas_to_consider_for_install t = t.stanzas_to_consider_for_install
let cxx_flags t = t.cxx_flags
let libs t = t.libs
let host_sctx t = Option.value t.host ~default:t
let expand_var_no_root t var = String_map.find var t.vars
let get_external_dir t ~dir =
Hashtbl.find_or_add t.external_dirs dir ~f:(fun dir ->
External_dir.create ~dir)
let expand_vars t ~scope ~dir s =
String_with_vars.expand s ~f:(fun _loc -> function
| "ROOT" -> Some (Path.reach ~from:dir t.context.build_dir)
@ -98,12 +63,12 @@ let resolve_program t ?hint bin =
let create
~(context:Context.t)
?host
~aliases
~scopes
~file_tree
~packages
~stanzas
~filter_out_optional_stanzas_with_missing_deps
~build_system
=
let stanzas =
List.map stanzas
@ -203,61 +168,55 @@ let create
in
{ context
; host
; build_system
; libs
; stanzas
; packages
; aliases
; file_tree
; 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
; ppx_drivers = Hashtbl.create 32
; ppx_dir = Path.relative context.build_dir ".ppx"
; external_dirs = Hashtbl.create 1024
; chdir = Build.arr (fun (action : Action.t) ->
match action with
| Chdir _ -> action
| _ -> Chdir (context.build_dir, action))
}
let add_rule t ?sandbox ?fallback ?locks ?loc build =
let add_rule t ?sandbox ?mode ?locks ?loc build =
let build = Build.O.(>>>) build t.chdir in
Build_system.add_rule t.build_system
(Build_interpret.Rule.make ?sandbox ?mode ?locks ?loc
~context:t.context build)
let add_rule_get_targets t ?sandbox ?mode ?locks ?loc build =
let build = Build.O.(>>>) build t.chdir in
let rule =
Build_interpret.Rule.make ?sandbox ?fallback ?locks ?loc
Build_interpret.Rule.make ?sandbox ?mode ?locks ?loc
~context:t.context build
in
t.rules <- rule :: t.rules;
t.known_targets_by_src_dir_so_far <-
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
let fn = Path.basename path in
let files =
match Path.Map.find dir acc with
| None -> String_set.singleton fn
| Some set -> String_set.add fn set
in
Path.Map.add acc ~key:dir ~data:files)
Build_system.add_rule t.build_system rule;
List.map rule.targets ~f:Build_interpret.Target.path
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
| None -> String_set.empty
| Some dir -> File_tree.Dir.files dir
in
match Path.Map.find src_path t.known_targets_by_src_dir_so_far with
| None -> sources
| Some set -> String_set.union sources set
let add_alias_deps t alias deps =
Alias.add_deps t.build_system alias deps
let add_alias_action t alias ?locks ~stamp action =
Alias.add_action t.build_system alias ?locks ~stamp action
let eval_glob t ~dir re = Build_system.eval_glob t.build_system ~dir re
let load_dir t ~dir = Build_system.load_dir t.build_system ~dir
let on_load_dir t ~dir ~f = Build_system.on_load_dir t.build_system ~dir ~f
let source_files t ~src_path =
match File_tree.find_dir t.file_tree src_path with
| None -> String_set.empty
| Some dir -> File_tree.Dir.files dir
let unique_library_name t lib =
Lib_db.unique_library_name t.libs lib
@ -363,14 +322,7 @@ module Libs = struct
in
let requires =
if t.context.merlin && has_dot_merlin then
(* We don't depend on the dot_merlin directly, otherwise everytime it changes we
would have to rebuild everything.
.merlin-exists depends on the .merlin and is an empty file. Depending on it
forces the generation of the .merlin but not recompilation when it
changes. Maybe one day we should add [Build.path_exists] to do the same in
general. *)
Build.path (Path.relative dir ".merlin-exists")
Build.path (Path.relative dir ".merlin")
>>>
real_requires
else
@ -394,24 +346,21 @@ module Libs = struct
Alias.make (sprintf "lib-%s%s-all" lib.name ext) ~dir
let setup_file_deps_alias t lib ~ext files =
Alias.add_deps t.aliases (lib_files_alias lib ~ext) files
add_alias_deps t (lib_files_alias lib ~ext) files
let setup_file_deps_group_alias t lib ~exts =
setup_file_deps_alias t lib
~ext:(String.concat exts ~sep:"-and-")
(List.map exts ~f:(fun ext -> Alias.file (lib_files_alias lib ~ext)))
(List.map exts ~f:(fun ext -> Alias.stamp_file (lib_files_alias lib ~ext)))
let file_deps t ~ext =
Build.dyn_paths (Build.arr (fun libs ->
List.fold_left libs ~init:[] ~f:(fun acc (lib : Lib.t) ->
match lib with
| External pkg -> begin
List.rev_append
(External_dir.files (get_external_dir t ~dir:pkg.dir) ~ext)
acc
end
| External pkg ->
Build_system.stamp_file_for_files_of t.build_system ~dir:pkg.dir ~ext :: acc
| Internal lib ->
Alias.file (lib_files_alias lib ~ext) :: acc)))
Alias.stamp_file (lib_files_alias lib ~ext) :: acc)))
let static_file_deps ~ext lib =
Alias.dep (lib_files_alias lib ~ext)
@ -852,12 +801,31 @@ module PP = struct
; Dyn (Lib.link_flags ~mode)
])
let get_ppx_driver sctx pps ~dir ~dep_kind =
let driver, names =
let gen_rules sctx components =
match components with
| [key] ->
let ppx_dir = Path.relative sctx.ppx_dir key in
let exe = Path.relative ppx_dir "ppx.exe" in
let names =
match key with
| "+none+" -> []
| _ -> String.split key ~on:'+'
in
let driver, names =
match List.rev names with
| [] -> (None, [])
| driver :: rest ->
(Some driver, List.sort rest ~cmp:String.compare @ [driver])
in
build_ppx_driver sctx names ~dir:ppx_dir ~dep_kind:Required ~target:exe ~driver
| _ -> ()
let get_ppx_driver sctx pps =
let names =
match List.rev_map pps ~f:Pp.to_string with
| [] -> (None, [])
| [] -> []
| driver :: rest ->
(Some driver, List.sort rest ~cmp:String.compare @ [driver])
List.sort rest ~cmp:String.compare @ [driver]
in
let key =
match names with
@ -865,14 +833,8 @@ module PP = struct
| _ -> String.concat names ~sep:"+"
in
let sctx = host_sctx sctx in
match Hashtbl.find sctx.ppx_drivers key with
| Some x -> x
| None ->
let ppx_dir = Path.relative sctx.ppx_dir key in
let exe = Path.relative ppx_dir "ppx.exe" in
build_ppx_driver sctx names ~dir ~dep_kind ~target:exe ~driver;
Hashtbl.add sctx.ppx_drivers ~key ~data:exe;
exe
let ppx_dir = Path.relative sctx.ppx_dir key in
Path.relative ppx_dir "ppx.exe"
let target_var = String_with_vars.virt_var __POS__ "@"
let root_var = String_with_vars.virt_var __POS__ "ROOT"
@ -933,12 +895,11 @@ module PP = struct
~dep_kind ~lint ~lib_name ~scope =
let alias = Alias.lint ~dir in
let add_alias fn build =
add_rule sctx
(Alias.add_build (aliases sctx) alias build
~stamp:(List [ Atom "lint"
; Sexp.To_sexp.(option string) lib_name
; Atom fn
]))
Alias.add_action sctx.build_system alias build
~stamp:(List [ Atom "lint"
; Sexp.To_sexp.(option string) lib_name
; Atom fn
])
in
match Preprocess_map.find source.name lint with
| No_preprocessing -> ()
@ -957,7 +918,7 @@ module PP = struct
~scope)
)
| Pps { pps; flags } ->
let ppx_exe = get_ppx_driver sctx pps ~dir ~dep_kind in
let ppx_exe = get_ppx_driver sctx pps in
Module.iter ast ~f:(fun kind src ->
let src_path = Path.relative dir src.name in
let args =
@ -1020,7 +981,7 @@ module PP = struct
lint_module ~ast ~source:m;
ast
| Pps { pps; flags } ->
let ppx_exe = get_ppx_driver sctx pps ~dir ~dep_kind in
let ppx_exe = get_ppx_driver sctx pps in
let ast = setup_reason_rules sctx ~dir m in
lint_module ~ast ~source:m;
let uses_ppx_driver = uses_ppx_driver ~pps in

43
src/super_context.mli
View File

@ -23,41 +23,65 @@ type t
val create
: context:Context.t
-> ?host:t
-> aliases:Alias.Store.t
-> scopes:Scope.t list
-> file_tree:File_tree.t
-> packages:Package.t String_map.t
-> stanzas:(Path.t * Scope.t * Stanzas.t) list
-> filter_out_optional_stanzas_with_missing_deps:bool
-> build_system:Build_system.t
-> t
val context : t -> Context.t
val aliases : t -> Alias.Store.t
val stanzas : t -> Dir_with_jbuild.t list
val packages : t -> Package.t String_map.t
val file_tree : t -> File_tree.t
val artifacts : t -> Artifacts.t
val stanzas_to_consider_for_install : t -> (Path.t * Stanza.t) list
val cxx_flags : t -> string list
val libs : t -> Lib_db.t
val expand_vars : t -> scope:Scope.t -> dir:Path.t -> String_with_vars.t -> string
val add_rule
: t
-> ?sandbox:bool
-> ?fallback:Jbuild.Rule.Fallback.t
-> ?mode:Jbuild.Rule.Mode.t
-> ?locks:Path.t list
-> ?loc:Loc.t
-> (unit, Action.t) Build.t
-> unit
val add_rule_get_targets
: t
-> ?sandbox:bool
-> ?mode:Jbuild.Rule.Mode.t
-> ?locks:Path.t list
-> ?loc:Loc.t
-> (unit, Action.t) Build.t
-> Path.t list
val add_rules
: t
-> ?sandbox:bool
-> (unit, Action.t) Build.t list
-> unit
val rules : t -> Build_interpret.Rule.t list
val add_alias_deps
: t
-> Build_system.Alias.t
-> Path.t list
-> unit
val add_alias_action
: t
-> Build_system.Alias.t
-> ?locks:Path.t list
-> stamp:Sexp.t
-> (unit, Action.t) Build.t
-> unit
val sources_and_targets_known_so_far : t -> src_path:Path.t -> String_set.t
(** See [Build_system for details] *)
val eval_glob : t -> dir:Path.t -> Re.re -> string list
val load_dir : t -> dir:Path.t -> unit
val on_load_dir : t -> dir:Path.t -> f:(unit -> unit) -> unit
val source_files : t -> src_path:Path.t -> String_set.t
(** [prog_spec t ?hint name] resolve a program. [name] is looked up in the
workspace, if it is not found in the tree is is looked up in the PATH. If it
@ -174,16 +198,13 @@ module PP : sig
-> Module.t String_map.t
(** Get a path to a cached ppx driver *)
val get_ppx_driver
: t
-> Pp.t list
-> dir:Path.t
-> dep_kind:Build.lib_dep_kind
-> Path.t
val get_ppx_driver : t -> Pp.t list -> Path.t
(** [cookie_library_name lib_name] is ["--cookie"; lib_name] if [lib_name] is not
[None] *)
val cookie_library_name : string option -> string list
val gen_rules : t -> string list -> unit
end
val expand_and_eval_set

49
src/utils.ml
View File

@ -73,19 +73,44 @@ let jbuild_name_in ~dir =
(Path.to_string_maybe_quoted (Path.relative dir "jbuild"))
ctx_name
let describe_target fn =
type target_kind =
| Regular of string * Path.t
| Alias of string * Path.t
| Other of Path.t
let analyse_target fn =
match Path.extract_build_context fn with
| Some (".aliases", fn) ->
let name =
let fn = Path.to_string fn in
match String.rsplit2 fn ~on:'-' with
| None -> assert false
| Some (name, digest) ->
assert (String.length digest = 32);
name
in
sprintf "alias %s" (maybe_quoted name)
| _ ->
| Some (".aliases", sub) -> begin
match Path.split_first_component sub with
| None -> Other fn
| Some (ctx, fn) ->
if Path.is_root fn then
Other fn
else
let basename =
match String.rsplit2 (Path.basename fn) ~on:'-' with
| None -> assert false
| Some (name, digest) ->
assert (String.length digest = 32);
name
in
Alias (ctx, Path.relative (Path.parent fn) basename)
end
| Some (ctx, sub) -> Regular (ctx, sub)
| None ->
Other fn
let describe_target fn =
let ctx_suffix = function
| "default" -> ""
| ctx -> sprintf " (context %s)" ctx
in
match analyse_target fn with
| Alias (ctx, p) ->
sprintf "alias %s%s" (Path.to_string_maybe_quoted p) (ctx_suffix ctx)
| Regular (ctx, fn) ->
sprintf "%s%s" (Path.to_string_maybe_quoted fn) (ctx_suffix ctx)
| Other fn ->
Path.to_string_maybe_quoted fn
let program_not_found ?context ?hint prog =

8
src/utils.mli
View File

@ -18,6 +18,14 @@ val jbuild_name_in : dir:Path.t -> string
(** Nice description of a target *)
val describe_target : Path.t -> string
type target_kind =
| Regular of string (* build context *) * Path.t
| Alias of string (* build context *) * Path.t
| Other of Path.t
(** Return the name of an alias from its stamp file *)
val analyse_target : Path.t -> target_kind
(** Raise an error about a program not found in the PATH or in the tree *)
val program_not_found
: ?context:string

8
test/blackbox-tests/test-cases/aliases/run.t
View File

@ -12,11 +12,11 @@
running in src/foo/baz
running in src
$ $JBUILDER build -j1 --root . @plop
File "<command-line>", line 1, characters 0-0:
Error: This alias is empty.
Alias "plop" is not defined in . or any of its descendants.
From the command line:
Error: Alias plop is empty.
It is not defined in . or any of its descendants.
[1]
$ $JBUILDER build -j1 --root . @truc/x
File "<command-line>", line 1, characters 0-0:
From the command line:
Error: Don't know about directory truc!
[1]

3
test/blackbox-tests/test-cases/meta-gen/jbuild
View File

@ -23,5 +23,4 @@
(alias
((name runtest)
(deps (META.foobar))
(action (echo "${read:META.foobar}"))))
(action (echo "${read:META.foobar}"))))