Start incremental compilation
This commit is contained in:
parent
87fa4c080a
commit
a188fcacf4
|
@ -45,6 +45,7 @@ module Mini_shexp = struct
|
|||
| Copy_and_add_line_directive of 'path * 'path
|
||||
| System of 'a
|
||||
| Bash of 'a
|
||||
| Write_file of 'path * 'a
|
||||
|
||||
let rec t a p sexp =
|
||||
sum
|
||||
|
@ -85,6 +86,7 @@ module Mini_shexp = struct
|
|||
List [Atom "copy-and-add-line-directive"; g x; g y]
|
||||
| System x -> List [Atom "system"; f x]
|
||||
| Bash x -> List [Atom "bash"; f x]
|
||||
| Write_file (x, y) -> List [Atom "write-file"; g x; f y]
|
||||
|
||||
let rec fold t ~init:acc ~f =
|
||||
match t with
|
||||
|
@ -101,6 +103,7 @@ module Mini_shexp = struct
|
|||
| Copy_and_add_line_directive (x, y) -> f (f acc x) y
|
||||
| System x -> f acc x
|
||||
| Bash x -> f acc x
|
||||
| Write_file (x, y) -> f (f acc x) y
|
||||
end
|
||||
open Ast
|
||||
|
||||
|
@ -148,6 +151,7 @@ module Mini_shexp = struct
|
|||
Copy_and_add_line_directive (expand_path ~dir ~f x, expand_path ~dir ~f y)
|
||||
| System x -> System (expand_str ~dir ~f x)
|
||||
| Bash x -> Bash (expand_str ~dir ~f x)
|
||||
| Write_file (x, y) -> Write_file (expand_path ~dir ~f x, expand_str ~dir ~f y)
|
||||
end
|
||||
|
||||
open Future
|
||||
|
@ -246,6 +250,13 @@ module Mini_shexp = struct
|
|||
run ~dir ~env ~env_extra ~stdout_to ~tail
|
||||
(Path.absolute "/bin/bash")
|
||||
["-e"; "-u"; "-o"; "pipefail"; "-c"; cmd]
|
||||
| Write_file (fn, s) ->
|
||||
let fn = Path.to_string fn in
|
||||
if Sys.file_exists fn && read_file fn = s then
|
||||
()
|
||||
else
|
||||
write_file fn s;
|
||||
return ()
|
||||
|
||||
and exec_list l ~dir ~env ~env_extra ~stdout_to ~tail =
|
||||
match l with
|
||||
|
@ -301,3 +312,10 @@ let exec { action; dir; context } =
|
|||
in
|
||||
Mini_shexp.exec action ~dir ~env ~env_extra:String_map.empty
|
||||
~stdout_to:None ~tail:true
|
||||
|
||||
type for_hash = string option * Path.t * Mini_shexp.t
|
||||
|
||||
let for_hash { context; dir; action } =
|
||||
(Option.map context ~f:(fun c -> c.name),
|
||||
dir,
|
||||
action)
|
||||
|
|
|
@ -22,6 +22,7 @@ module Mini_shexp : sig
|
|||
| Copy_and_add_line_directive of 'path * 'path
|
||||
| System of 'a
|
||||
| Bash of 'a
|
||||
| Write_file of 'path * 'a
|
||||
val t : 'a Sexp.Of_sexp.t -> 'b Sexp.Of_sexp.t -> ('a, 'b) t Sexp.Of_sexp.t
|
||||
val sexp_of_t : 'a Sexp.To_sexp.t -> 'b Sexp.To_sexp.t -> ('a, 'b) t Sexp.To_sexp.t
|
||||
end
|
||||
|
@ -49,3 +50,6 @@ type t =
|
|||
val t : Context.t String_map.t -> t Sexp.Of_sexp.t
|
||||
val sexp_of_t : t Sexp.To_sexp.t
|
||||
val exec : t -> unit Future.t
|
||||
|
||||
type for_hash
|
||||
val for_hash : t -> for_hash
|
||||
|
|
|
@ -163,7 +163,7 @@ let action ?(dir=Path.root) ?context ~targets action =
|
|||
{ Action. context; dir; action }
|
||||
|
||||
let echo fn s =
|
||||
action ~targets:[fn] (With_stdout_to (fn, Echo s))
|
||||
action ~targets:[fn] (Write_file (fn, s))
|
||||
|
||||
let echo_dyn fn =
|
||||
Targets [fn]
|
||||
|
@ -171,7 +171,7 @@ let echo_dyn fn =
|
|||
{ Action.
|
||||
context = None
|
||||
; dir = Path.root
|
||||
; action = With_stdout_to (fn, Echo s)
|
||||
; action = Write_file (fn, s)
|
||||
}
|
||||
|
||||
let copy ~src ~dst =
|
||||
|
|
|
@ -20,10 +20,10 @@ end
|
|||
|
||||
module Rule = struct
|
||||
type t =
|
||||
{ deps : Pset.t
|
||||
; targets : Pset.t
|
||||
; build : (unit, Action.t) Build.t
|
||||
; mutable exec : Exec_status.t
|
||||
{ deps : Pset.t
|
||||
; targets : Pset.t
|
||||
; build : (unit, Action.t) Build.t
|
||||
; mutable exec : Exec_status.t
|
||||
}
|
||||
end
|
||||
|
||||
|
@ -56,10 +56,32 @@ end
|
|||
|
||||
type t =
|
||||
{ (* File specification by targets *)
|
||||
files : (Path.t, File_spec.packed) Hashtbl.t
|
||||
; contexts : Context.t list
|
||||
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
|
||||
; timestamps : (Path.t, float) Hashtbl.t
|
||||
}
|
||||
|
||||
let timestamp t fn ~default =
|
||||
match Hashtbl.find t.timestamps fn with
|
||||
| Some ts -> ts
|
||||
| None ->
|
||||
match Unix.lstat (Path.to_string fn) with
|
||||
| exception _ -> default
|
||||
| stat ->
|
||||
let ts = stat.st_mtime in
|
||||
Hashtbl.add t.timestamps ~key:fn ~data:ts;
|
||||
ts
|
||||
|
||||
let min_timestamp t fns =
|
||||
List.fold_left fns ~init:max_float
|
||||
~f:(fun acc fn -> min acc (timestamp t fn ~default:0.))
|
||||
|
||||
let max_timestamp t fns =
|
||||
List.fold_left fns ~init:0.
|
||||
~f:(fun acc fn -> max acc (timestamp t fn ~default:max_float))
|
||||
|
||||
let find_file_exn t file =
|
||||
Hashtbl.find_exn t.files file ~string_of_key:(fun fn -> sprintf "%S" (Path.to_string fn))
|
||||
~table_desc:(fun _ -> "<target to rule>")
|
||||
|
@ -146,20 +168,14 @@ let get_file : type a. t -> Path.t -> a File_kind.t -> a File_spec.t = fun t fn
|
|||
let Eq = File_kind.eq_exn kind file.kind in
|
||||
file
|
||||
|
||||
let save_vfile (type a) (module K : Vfile_kind.S with type t = a) fn x =
|
||||
K.save fn x
|
||||
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 nop =
|
||||
{ Action.
|
||||
context = None
|
||||
; dir = Path.root
|
||||
; action = Progn []
|
||||
}
|
||||
|
||||
let exec bs t x ~targeting =
|
||||
let exec bs t x ~static_deps ~targeting =
|
||||
let all_deps = ref static_deps in
|
||||
let rec exec
|
||||
: type a b. (a, b) t -> a -> b Future.t = fun t x ->
|
||||
let return = Future.return in
|
||||
|
@ -170,8 +186,12 @@ module Build_exec = struct
|
|||
let file = get_file bs fn (Sexp_file kind) in
|
||||
assert (file.data = None);
|
||||
file.data <- Some x;
|
||||
save_vfile kind fn x;
|
||||
Future.return nop
|
||||
Future.return
|
||||
{ Action.
|
||||
context = None
|
||||
; dir = Path.root
|
||||
; action = Write_file (fn, vfile_to_string kind fn x)
|
||||
}
|
||||
| Compose (a, b) ->
|
||||
exec a x >>= exec b
|
||||
| First t ->
|
||||
|
@ -194,12 +214,14 @@ module Build_exec = struct
|
|||
return (Option.value_exn file.data)
|
||||
| Dyn_paths t ->
|
||||
exec t x >>= fun fns ->
|
||||
all_deps := Pset.union !all_deps (Pset.of_list fns);
|
||||
all_unit (List.rev_map fns ~f:(wait_for_file bs ~targeting)) >>= fun () ->
|
||||
return x
|
||||
| Record_lib_deps _ -> return x
|
||||
| Fail { fail } -> fail ()
|
||||
in
|
||||
exec (Build.repr t) x
|
||||
exec (Build.repr t) x >>| fun action ->
|
||||
(action, !all_deps)
|
||||
end
|
||||
|
||||
let add_spec t fn spec ~allow_override =
|
||||
|
@ -252,12 +274,31 @@ let compile_rule t ~all_targets_by_dir ?(allow_override=false) pre_rule =
|
|||
all_unit
|
||||
(Pset.fold deps ~init:[] ~f:(fun fn acc -> wait_for_file t fn ~targeting :: acc))
|
||||
>>= fun () ->
|
||||
Build_exec.exec t build () ~targeting
|
||||
>>= fun action ->
|
||||
Build_exec.exec t build () ~targeting ~static_deps:deps
|
||||
>>= fun (action, all_deps) ->
|
||||
if !Clflags.debug_actions then
|
||||
Format.eprintf "@{<debug>Action@}: %s@."
|
||||
(Sexp.to_string (Action.sexp_of_t action));
|
||||
Action.exec action
|
||||
let all_deps = Pset.elements all_deps in
|
||||
let targets = Pset.elements targets in
|
||||
let hash =
|
||||
let trace = (all_deps, targets, Action.for_hash action) in
|
||||
Digest.string (Marshal.to_string trace [])
|
||||
in
|
||||
let rule_changed =
|
||||
List.fold_left targets ~init:false ~f:(fun acc fn ->
|
||||
match Hashtbl.find t.trace fn with
|
||||
| None ->
|
||||
Hashtbl.add t.trace ~key:fn ~data:hash;
|
||||
true
|
||||
| Some prev_hash ->
|
||||
Hashtbl.replace t.trace ~key:fn ~data:hash;
|
||||
acc || prev_hash <> hash)
|
||||
in
|
||||
if rule_changed || min_timestamp t targets < max_timestamp t all_deps then
|
||||
Action.exec action
|
||||
else
|
||||
return ()
|
||||
) in
|
||||
let rule =
|
||||
{ Rule.
|
||||
|
@ -290,6 +331,36 @@ let setup_copy_rules t ~all_non_target_source_files ~all_targets_by_dir =
|
|||
~all_targets_by_dir
|
||||
~allow_override:true))
|
||||
|
||||
module Trace = struct
|
||||
type t = (Path.t, Digest.t) Hashtbl.t
|
||||
|
||||
let file = "_build/.db"
|
||||
|
||||
let dump (trace : t) =
|
||||
let sexp =
|
||||
Sexp.List (
|
||||
Hashtbl.fold trace ~init:Pmap.empty ~f:(fun ~key ~data acc ->
|
||||
Pmap.add acc ~key ~data)
|
||||
|> Path.Map.bindings
|
||||
|> List.map ~f:(fun (path, hash) ->
|
||||
Sexp.List [ Atom (Path.to_string path); Atom (Digest.to_hex hash) ]))
|
||||
in
|
||||
write_file file (Sexp.to_string sexp)
|
||||
|
||||
let load () =
|
||||
let trace = Hashtbl.create 1024 in
|
||||
if Sys.file_exists file then begin
|
||||
let sexp = Sexp_load.single file in
|
||||
let bindings =
|
||||
let open Sexp.Of_sexp in
|
||||
list (pair Path.t (fun s -> Digest.from_hex (string s))) sexp
|
||||
in
|
||||
List.iter bindings ~f:(fun (path, hash) ->
|
||||
Hashtbl.add trace ~key:path ~data:hash);
|
||||
end;
|
||||
trace
|
||||
end
|
||||
|
||||
let create ~contexts ~file_tree ~rules =
|
||||
let all_source_files =
|
||||
File_tree.fold file_tree ~init:Pset.empty ~f:(fun dir acc ->
|
||||
|
@ -321,11 +392,17 @@ let create ~contexts ~file_tree ~rules =
|
|||
|> Pmap.of_alist_multi
|
||||
|> Pmap.map ~f:Pset.of_list
|
||||
) in
|
||||
let t = { files = Hashtbl.create 1024; contexts } in
|
||||
let t =
|
||||
{ contexts
|
||||
; files = Hashtbl.create 1024
|
||||
; trace = Trace.load ()
|
||||
; timestamps = Hashtbl.create 1024
|
||||
} in
|
||||
List.iter rules ~f:(compile_rule t ~all_targets_by_dir ~allow_override:false);
|
||||
setup_copy_rules t ~all_targets_by_dir
|
||||
~all_non_target_source_files:
|
||||
(Pset.diff all_source_files all_other_targets);
|
||||
at_exit (fun () -> Trace.dump t.trace);
|
||||
t
|
||||
|
||||
let remove_old_artifacts t =
|
||||
|
|
|
@ -80,6 +80,8 @@ module To_sexp = struct
|
|||
| Some x -> List [f x]
|
||||
let string_set set = list string (String_set.elements set)
|
||||
let string_map f map = list (pair string f) (String_map.bindings map)
|
||||
let record l =
|
||||
List (List.map l ~f:(fun (n, v) -> List [Atom n; v]))
|
||||
end
|
||||
|
||||
module Of_sexp = struct
|
||||
|
|
|
@ -36,7 +36,12 @@ module type Combinators = sig
|
|||
val string_map : 'a t -> 'a String_map.t t
|
||||
end
|
||||
|
||||
module To_sexp : Combinators with type 'a t = 'a -> t
|
||||
module To_sexp : sig
|
||||
type sexp = t
|
||||
include Combinators with type 'a t = 'a -> t
|
||||
|
||||
val record : (string * sexp) list -> sexp
|
||||
end with type sexp := t
|
||||
|
||||
module Of_sexp : sig
|
||||
type ast = Ast.t =
|
||||
|
|
|
@ -32,7 +32,7 @@ module type S = sig
|
|||
val id : t Id.t
|
||||
|
||||
val load : Path.t -> t
|
||||
val save : Path.t -> t -> unit
|
||||
val to_string : Path.t -> t -> string
|
||||
end
|
||||
|
||||
type 'a t = (module S with type t = 'a)
|
||||
|
@ -52,11 +52,7 @@ struct
|
|||
|
||||
let id = Id.create ()
|
||||
|
||||
let save path x =
|
||||
let s = To_sexp.t path x |> Sexp.to_string in
|
||||
let oc = open_out (Path.to_string path) in
|
||||
output_string oc s;
|
||||
close_out oc
|
||||
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))
|
||||
|
|
|
@ -12,7 +12,7 @@ module type S = sig
|
|||
val id : t Id.t
|
||||
|
||||
val load : Path.t -> t
|
||||
val save : Path.t -> t -> unit
|
||||
val to_string : Path.t -> t -> string
|
||||
end
|
||||
|
||||
type 'a t = (module S with type t = 'a)
|
||||
|
|
Loading…
Reference in New Issue