diff --git a/src/action.ml b/src/action.ml index 14dc238a..f274750b 100644 --- a/src/action.ml +++ b/src/action.ml @@ -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) diff --git a/src/action.mli b/src/action.mli index 5f75c6e2..9184a422 100644 --- a/src/action.mli +++ b/src/action.mli @@ -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 diff --git a/src/build.ml b/src/build.ml index 27fdf6a2..024be6da 100644 --- a/src/build.ml +++ b/src/build.ml @@ -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 = diff --git a/src/build_system.ml b/src/build_system.ml index 3a944266..27c1c6d7 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -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 _ -> "") @@ -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 "@{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 = diff --git a/src/sexp.ml b/src/sexp.ml index ab65fdd1..644b4548 100644 --- a/src/sexp.ml +++ b/src/sexp.ml @@ -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 diff --git a/src/sexp.mli b/src/sexp.mli index 17c9f538..973e379d 100644 --- a/src/sexp.mli +++ b/src/sexp.mli @@ -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 = diff --git a/src/vfile_kind.ml b/src/vfile_kind.ml index 1e0b97bc..3a3092c3 100644 --- a/src/vfile_kind.ml +++ b/src/vfile_kind.ml @@ -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)) diff --git a/src/vfile_kind.mli b/src/vfile_kind.mli index 4ee25ccf..447b910d 100644 --- a/src/vfile_kind.mli +++ b/src/vfile_kind.mli @@ -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)