l4/pkg/ocaml/ocaml/contrib/ocamlbuild/rule.ml

   1 (***********************************************************************)
   2 (*                             ocamlbuild                              *)
   3 (*                                                                     *)
   4 (*  Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
   5 (*                                                                     *)
   6 (*  Copyright 2007 Institut National de Recherche en Informatique et   *)
   7 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   8 (*  under the terms of the Q Public License version 1.0.               *)
   9 (*                                                                     *)
  10 (***********************************************************************)
  11
  12
  13 (* Original author: Nicolas Pouillard *)
  14 open My_std
  15 open Format
  16 open Log
  17 open Outcome
  18 module Resources = Resource.Resources
  19
  20 exception Exit_rule_error of string
  21 exception Failed
  22
  23 type env = Pathname.t -> Pathname.t
  24 type builder = Pathname.t list list -> (Pathname.t, exn) Outcome.t list
  25 type action = env -> builder -> Command.t
  26
  27 type digest_command = { digest : string; command : Command.t }
  28
  29 type 'a gen_rule =
  30   { name  : string;
  31     tags  : Tags.t;
  32     deps  : Pathname.t list; (* These pathnames must be normalized *)
  33     prods : 'a list; (* Note that prods also contains stamp *)
  34     stamp : 'a option;
  35     code  : env -> builder -> digest_command }
  36
  37 type rule = Pathname.t gen_rule
  38 type rule_scheme = Resource.resource_pattern gen_rule
  39
  40 let name_of_rule r = r.name
  41 let deps_of_rule r = r.deps
  42 let prods_of_rule r = r.prods
  43 let stamp_of_rule r = r.stamp
  44
  45 type 'a rule_printer = (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a gen_rule -> unit
  46
  47 let compare _ _ = assert false
  48
  49 let print_rule_name f r = pp_print_string f r.name
  50
  51 let print_resource_list = List.print Resource.print
  52
  53 let print_rule_contents ppelt f r =
  54   fprintf f "@[<v2>{@ @[<2>name  =@ %S@];@ @[<2>tags  =@ %a@];@ @[<2>deps  =@ %a@];@ @[<2>prods = %a@];@ @[<2>code  = <fun>@]@]@ }"
  55     r.name Tags.print r.tags print_resource_list r.deps (List.print ppelt) r.prods
  56
  57 let pretty_print ppelt f r =
  58   fprintf f "@[<hv2>rule@ %S@ ~deps:%a@ ~prods:%a@ <fun>@]"
  59     r.name print_resource_list r.deps (List.print ppelt) r.prods
  60
  61 let print = print_rule_name
  62
  63 let subst env rule =
  64   let subst_resources = List.map (Resource.subst env) in
  65   let subst_resource_patterns = List.map (Resource.subst_pattern env) in
  66   let finder next_finder p = next_finder (Resource.subst_any env p) in
  67   let stamp = match rule.stamp with None -> None | Some x -> Some (Resource.subst_pattern env x) in
  68   let prods = subst_resource_patterns rule.prods in
  69   { (rule) with name = sbprintf "%s (%a)" rule.name Resource.print_env env;
  70                 prods = prods;
  71                 deps = subst_resources rule.deps; (* The substition should preserve normalization of pathnames *)
  72                 stamp = stamp;
  73                 code = (fun env -> rule.code (finder env)) }
  74
  75 exception Can_produce of rule
  76
  77 let can_produce target rule =
  78   try
  79     List.iter begin fun resource ->
  80       match Resource.matchit resource target with
  81       | Some env -> raise (Can_produce (subst env rule))
  82       | None -> ()
  83     end rule.prods; None
  84   with Can_produce r -> Some r
  85
  86 (* let tags_matches tags r = if Tags.does_match tags r.tags then Some r else None *)
  87
  88 let digest_prods r =
  89   List.fold_right begin fun p acc ->
  90     let f = Pathname.to_string (Resource.in_build_dir p) in
  91     if sys_file_exists f then (f, Digest.file f) :: acc else acc
  92   end r.prods []
  93
  94 let digest_deps r dyndeps =
  95   let buf = Buffer.create 1024 in
  96   let add_resource r = Buffer.add_string buf (Digest.to_hex (Resource.digest r)) in
  97   Buffer.add_string buf "deps:";
  98   List.iter add_resource r.deps;
  99   Buffer.add_string buf "dyndeps:";
 100   Resources.iter add_resource dyndeps;
 101   Digest.to_hex (Digest.string (Buffer.contents buf))
 102
 103 let digest_rule r dyndeps action =
 104   let buf = Buffer.create 1024 in
 105   Buffer.add_string buf action.digest;
 106   let add_resource r = Buffer.add_string buf (Resource.digest r) in
 107   Buffer.add_string buf "prods:";
 108   List.iter add_resource r.prods;
 109   Buffer.add_string buf "deps:";
 110   List.iter add_resource r.deps;
 111   Buffer.add_string buf "dyndeps:";
 112   Resources.iter add_resource dyndeps;
 113   Digest.string (Buffer.contents buf)
 114
 115 let cached_digest r =
 116   try Some (Digest_cache.get ("Rule: " ^ r.name))
 117   with Not_found -> None
 118
 119 let store_digest r digest = Digest_cache.put ("Rule: " ^ r.name) digest
 120
 121 let print_digest f x = pp_print_string f (Digest.to_hex x)
 122
 123 let exists2 find p rs =
 124   try Some (find p rs) with Not_found -> None
 125
 126 let build_deps_of_tags builder tags =
 127   match Command.deps_of_tags tags with
 128   | [] -> []
 129   | deps -> List.map Outcome.good (builder (List.map (fun x -> [x]) deps))
 130
 131 let build_deps_of_tags_on_cmd builder =
 132   Command.iter_tags begin fun tags ->
 133     match Command.deps_of_tags tags with
 134     | [] -> ()
 135     | deps -> List.iter ignore_good (builder (List.map (fun x -> [x]) deps))
 136   end
 137
 138 let call builder r =
 139   let dyndeps = ref Resources.empty in
 140   let builder rs =
 141     let results = builder rs in
 142     List.map begin fun res ->
 143       match res with
 144       | Good res' ->
 145           let () = dprintf 10 "new dyndep for %S(%a): %S" r.name print_resource_list r.prods res' in
 146           dyndeps := Resources.add res' !dyndeps;
 147           List.iter (fun x -> Resource.Cache.add_dependency x res') r.prods;
 148           res
 149       | Bad _ -> res
 150     end results in
 151   let () = dprintf 5 "start rule %a" print r in
 152   let action = r.code (fun x -> x) builder in
 153   build_deps_of_tags_on_cmd builder action.command;
 154   let dyndeps = !dyndeps in
 155   let () = dprintf 10 "dyndeps: %a" Resources.print dyndeps in
 156   let (reason, cached) =
 157     match exists2 List.find (fun r -> not (Resource.exists_in_build_dir r)) r.prods with
 158     | Some r -> (`cache_miss_missing_prod r, false)
 159     | _ ->
 160       begin match exists2 List.find Resource.Cache.resource_has_changed r.deps with
 161       | Some r -> (`cache_miss_changed_dep r, false)
 162       | _ ->
 163         begin match exists2 Resources.find Resource.Cache.resource_has_changed dyndeps with
 164         | Some r -> (`cache_miss_changed_dyn_dep r, false)
 165         | _ ->
 166             begin match cached_digest r with
 167             | None -> (`cache_miss_no_digest, false)
 168             | Some d ->
 169                 let rule_digest = digest_rule r dyndeps action in
 170                 if d = rule_digest then (`cache_hit, true)
 171                 else (`cache_miss_digest_changed(d, rule_digest), false)
 172             end
 173         end
 174       end
 175   in
 176   let explain_reason l =
 177     raw_dprintf (l+1) "mid rule %a: " print r;
 178     match reason with
 179     | `cache_miss_missing_prod r ->
 180           dprintf l "cache miss: a product is not in build dir (%a)" Resource.print r
 181     | `cache_miss_changed_dep r ->
 182           dprintf l "cache miss: a dependency has changed (%a)" Resource.print r
 183     | `cache_miss_changed_dyn_dep r ->
 184           dprintf l "cache miss: a dynamic dependency has changed (%a)" Resource.print r
 185     | `cache_miss_no_digest ->
 186           dprintf l "cache miss: no digest found for %S (the command, a dependency, or a product)"
 187             r.name
 188     | `cache_hit -> dprintf (l+1) "cache hit"
 189     | `cache_miss_digest_changed(old_d, new_d) ->
 190           dprintf l "cache miss: the digest has changed for %S (the command, a dependency, or a product: %a <> %a)"
 191             r.name print_digest old_d print_digest new_d
 192   in
 193   let prod_digests = digest_prods r in
 194   (if not cached then List.iter Resource.clean r.prods);
 195   (if !Options.nothing_should_be_rebuilt && not cached then
 196     (explain_reason (-1);
 197      let msg = sbprintf "Need to rebuild %a through the rule `%a'" print_resource_list r.prods print r in
 198      raise (Exit_rule_error msg)));
 199   explain_reason 3;
 200   let thunk () =
 201     try
 202       if cached then Command.execute ~pretend:true action.command
 203       else
 204         begin match r.stamp with
 205         | Some stamp ->
 206             reset_filesys_cache ();
 207             let digest_deps = digest_deps r dyndeps in
 208             with_output_file stamp (fun oc -> output_string oc digest_deps)
 209         | None -> ()
 210         end;
 211       List.iter (fun r -> Resource.Cache.resource_built r) r.prods;
 212       (if not cached then
 213         let new_rule_digest = digest_rule r dyndeps action in
 214         let new_prod_digests = digest_prods r in
 215         let () = store_digest r new_rule_digest in
 216         List.iter begin fun p ->
 217           let f = Pathname.to_string (Resource.in_build_dir p) in
 218           (try let digest = List.assoc f prod_digests in
 219                let new_digest = List.assoc f new_prod_digests in
 220                if digest <> new_digest then raise Not_found
 221           with Not_found -> Resource.Cache.resource_changed p)
 222         end r.prods);
 223       dprintf 5 "end rule %a" print r
 224     with exn -> (List.iter Resource.clean r.prods; raise exn)
 225   in
 226   if cached
 227   then thunk ()
 228   else List.iter (fun x -> Resource.Cache.suspend_resource x action.command thunk r.prods) r.prods
 229
 230 let (get_rules, add_rule, clear_rules) =
 231   let rules = ref [] in
 232   (fun () -> !rules),
 233   begin fun pos r ->
 234     try
 235       let _ = List.find (fun x -> x.name = r.name) !rules in
 236       raise (Exit_rule_error (sbprintf "Rule.add_rule: already exists: (%a)" print r))
 237     with Not_found ->
 238       match pos with
 239       | `bottom -> rules := !rules @ [r]
 240       | `top -> rules := r :: !rules
 241       | `after s ->
 242           rules :=
 243             List.fold_right begin fun x acc ->
 244               if x.name = s then x :: r :: acc else x :: acc
 245             end !rules []
 246       | `before s ->
 247           rules :=
 248             List.fold_right begin fun x acc ->
 249               if x.name = s then r :: x :: acc else x :: acc
 250             end !rules []
 251   end,
 252   (fun () -> rules := [])
 253
 254 let rule name ?(tags=[]) ?(prods=[]) ?(deps=[]) ?prod ?dep ?stamp ?(insert = `bottom) code =
 255   let res_add import xs xopt =
 256     let init =
 257       match xopt with
 258       | None -> []
 259       | Some r -> [import r]
 260     in
 261     List.fold_right begin fun x acc ->
 262       let r = import x in
 263       if List.mem r acc then
 264         failwith (sprintf "in rule %s, multiple occurences of the resource %s" name x)
 265       else r :: acc
 266     end xs init
 267   in
 268   if prods = [] && prod = None && stamp = None then raise (Exit_rule_error "Can't make a rule that produce nothing");
 269   let stamp, prods =
 270     match stamp with
 271     | None -> None, prods
 272     | Some stamp ->
 273         Some (Resource.import_pattern stamp), stamp :: prods
 274   in
 275   let prods = res_add Resource.import_pattern prods prod in
 276   let code env build =
 277     let cmd = code env build in
 278     { digest  = Command.digest cmd
 279     ; command = cmd }
 280   in
 281   add_rule insert
 282   { name  = name;
 283     tags  = List.fold_right Tags.add tags Tags.empty;
 284     deps  = res_add Resource.import (* should normalize *) deps dep;
 285     stamp = stamp;
 286     prods = prods;
 287     code  = code }
 288
 289 module Common_commands = struct
 290   open Command
 291   let mv src dest = Cmd (S [A"mv"; P src; Px dest])
 292   let cp src dest = Cmd (S [A"cp"; P src; Px dest])
 293   let cp_p src dest = Cmd (S [A"cp"; A"-p"; P src; Px dest])
 294   let ln_f pointed pointer = Cmd (S [A"ln"; A"-f"; P pointed; Px pointer])
 295   let ln_s pointed pointer = Cmd (S[A"ln"; A"-s"; P pointed; Px pointer])
 296   let rm_f x = Cmd (S [A"rm"; A"-f"; Px x])
 297   let chmod opts file = Cmd (S[A"chmod"; opts; Px file])
 298   let cmp a b = Cmd (S[A"cmp"; P a; Px b])
 299 end
 300 open Common_commands
 301
 302 let copy_rule name ?insert src dest =
 303   rule name ?insert ~prod:dest ~dep:src
 304     begin fun env _ ->
 305       let src = env src and dest = env dest in
 306       Shell.mkdir_p (Pathname.dirname dest);
 307       cp_p src dest
 308     end
 309