src/deps.ml

   1 (* Goalfile dependency DAG
   2  * Copyright (C) 2020 Richard W.M. Jones
   3  * Copyright (C) 2020 Red Hat Inc.
   4  *
   5  * This program is free software; you can redistribute it and/or modify
   6  * it under the terms of the GNU General Public License as published by
   7  * the Free Software Foundation; either version 2 of the License, or
   8  * (at your option) any later version.
   9  *
  10  * This program is distributed in the hope that it will be useful,
  11  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13  * GNU General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU General Public License along
  16  * with this program; if not, write to the Free Software Foundation, Inc.,
  17  * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  18  *)
  19
  20 open Printf
  21
  22 open Utils
  23
  24 type node =
  25   | Goal of Ast.env * Ast.loc * string * Ast.expr list *
  26               Ast.goal * Ast.expr list * string
  27   | Exists of Ast.env * Ast.loc * Ast.pattern * string
  28
  29 let string_of_node = function
  30   | Goal (_, _, _, _, _, _, debug_goal) -> debug_goal
  31   | Exists (_, _, _, debug_pred) -> debug_pred
  32
  33 let loc_of_node = function
  34   | Goal (_, loc, _, _, _, _, _)
  35   | Exists (_, loc, _, _) -> loc
  36
  37 let compare_nodes n1 n2 =
  38   match n1, n2 with
  39   | Goal _, Exists _ -> -1
  40   | Exists _, Goal _ -> 1
  41   | Exists (_, _, p1, _), Exists (_, _, p2, _) -> compare p1 p2
  42   | Goal (_, _, n1, a1, _, _, _), Goal (_, _, n2, a2, _, _, _) ->
  43      compare (n1, a1) (n2, a2)
  44
  45 module G = Map.Make (
  46   struct
  47     type t = node
  48     let compare = compare_nodes
  49   end
  50 )
  51
  52 exception Cycle_found
  53
  54 type dag = {
  55   (* List of nodes. *)
  56   nodes : node list;
  57
  58   (* Edges are stored as an adjacency list, which is a map from
  59    * a parent node to a list of child nodes.  Note that as the
  60    * graph does not need to be connected, there may be nodes
  61    * in the list above which don't appear in this map.
  62    *)
  63   edges : node list G.t;
  64 }
  65
  66 type t = dag * node list
  67 (* The final type is a DAG and a topologically sorted list of nodes. *)
  68
  69 (* Creates a new DAG. *)
  70 let rec new_dag () = { nodes = []; edges = G.empty }
  71
  72 (* This will create a new node, unless the node already exists.
  73  * If the optional parent parameter is given then it also creates
  74  * an edge from parent to the new (or existing) node.
  75  *)
  76 and add_node { nodes; edges } ?parent data =
  77   let node, nodes =
  78     try List.find (fun n -> compare_nodes n data = 0) nodes, nodes
  79     with Not_found -> data, data :: nodes in
  80   let edges =
  81     match parent with
  82     | None -> edges
  83     | Some parent ->
  84        let children = try G.find parent edges with Not_found -> [] in
  85        if List.mem node children then edges
  86        else (
  87          (* We are going to add an edge from parent -> node.  To
  88           * ensure we don't make a cycle, check there is no path
  89           * already from node -> parent.
  90           *)
  91          (match exists_path node parent edges with
  92           | None -> ()
  93           | Some nodes ->
  94              let loc = loc_of_node data in
  95              failwithf "%a: dependency cycle: %s -> %s"
  96                Ast.string_loc loc
  97                (String.concat " -> " (List.map string_of_node nodes))
  98                (string_of_node data)
  99          );
 100          G.add parent (node :: children) edges
 101        ) in
 102   node, { nodes; edges }
 103
 104 (* Is there a path from n1 to n2 in edges?
 105  * Returns [None] if no path, or [Some nodes] if there is a path.
 106  *)
 107 and exists_path n1 n2 edges =
 108   if compare_nodes n1 n2 = 0 then Some [n2]
 109   else (
 110     let children = try G.find n1 edges with Not_found -> [] in
 111     let path =
 112       List.find_map (
 113         fun n -> exists_path n n2 edges
 114       ) children in
 115     match path with
 116     | None -> None
 117     | Some nodes -> Some (n1 :: nodes)
 118   )
 119
 120 (* This is Khan's algorithm. *)
 121 and topological_sort dag =
 122   let incoming_map = incoming_map dag in
 123
 124   (* Set of all nodes with no incoming edge. *)
 125   let q = List.filter (fun node -> not (G.mem node incoming_map)) dag.nodes in
 126
 127   let rec loop dag acc im = function
 128     | [] -> dag, acc
 129     | node :: q ->
 130        let acc = node :: acc in
 131        let children = try G.find node dag.edges with Not_found -> [] in
 132        let dag, q, im =
 133          List.fold_left (
 134            fun (dag, q, im) child ->
 135              (* There's an arrow from node to child. *)
 136              let dag =
 137                { nodes =
 138                    List.filter (fun n -> compare_nodes n node <> 0) dag.nodes;
 139                  edges = remove_edge dag.edges node child } in
 140              let im = remove_edge im child node in
 141              let q = if not (G.mem child im) then child :: q else q in
 142              (dag, q, im)
 143          ) (dag, q, im) children in
 144        loop dag acc im q
 145   in
 146   let dag, acc = loop dag [] incoming_map q in
 147
 148   if not (G.is_empty dag.edges) then raise Cycle_found;
 149
 150   (* This builds the topological list in reverse order, but that's
 151    * fine because that is the running order.
 152    *)
 153   acc
 154
 155 (* The dag structure has an adjacency list, which is a list of outgoing
 156  * edges from each node.  But for a topological sort what we actually
 157  * need is another list of incoming edges, so construct that first.
 158  *
 159  * Note this never returns a mapping node -> [].
 160  *)
 161 and incoming_map { edges } =
 162   let im = ref G.empty in
 163   G.iter (
 164     fun parent children ->
 165       List.iter (
 166         fun c ->
 167           (* There is an arrow from parent -> c. *)
 168           let xs = try G.find c !im with Not_found -> [] in
 169           im := G.add c (parent :: xs) !im
 170       ) children
 171   ) edges;
 172   !im
 173
 174 (* Remove edge from parent to child returning a new edges map.
 175  * Preserves the invariant that there is never a mapping node -> [].
 176  *)
 177 and remove_edge edges parent child =
 178   try
 179     let children = G.find parent edges in
 180     let children =
 181       List.filter (fun n -> compare_nodes n child <> 0) children in
 182     if children = [] then
 183       G.remove parent edges
 184     else
 185       G.add parent children edges
 186   with
 187     Not_found -> edges
 188
 189 and debug_dag { nodes; edges } =
 190   eprintf "nodes:\n";
 191   List.iter (fun node -> eprintf "  %s\n" (string_of_node node)) nodes;
 192   eprintf "edges:\n";
 193   G.iter (
 194     fun parent children ->
 195       eprintf "  %s ->" (string_of_node parent);
 196       List.iter (fun c -> eprintf " %s" (string_of_node c)) children;
 197       eprintf "\n"
 198   ) edges
 199
 200 let rec create env roots =
 201   let dag = new_dag () in
 202   let dag = add_targets dag env roots in
 203   if Cmdline.debug_flag () then debug_dag dag;
 204   (* Make actually breaks cycles, but I'm not convinced that this
 205    * is a good idea, so this function will fail if any cycle is
 206    * found.  We may wish to revisit this decision in future.
 207    *)
 208   let sorted =
 209     try topological_sort dag
 210     with Cycle_found -> failwithf "dependency graph contains cycles" in
 211   if Cmdline.debug_flag () then
 212     eprintf "dependency order:\n  %s\n"
 213       (String.concat " <- " (List.map string_of_node sorted));
 214   dag, sorted
 215
 216 and add_targets dag ?parent env roots =
 217   List.fold_left (fun dag root -> add_target dag ?parent env root) dag roots
 218
 219 and add_target dag ?parent env = function
 220   | Ast.EGoalDefn _ | Ast.EFuncDefn _ | Ast.EPredDefn _ -> assert false
 221
 222   (* Call a goal or function. *)
 223   | Ast.ECall (loc, name, args) ->
 224      let expr = Ast.getvar env loc name in
 225      (match expr with
 226       | Ast.EGoalDefn (_, goal) ->
 227          add_goal dag ?parent env loc name args goal []
 228       | Ast.EFuncDefn (_, func) ->
 229          let expr = Eval.call_function env loc name args func in
 230          add_target dag ?parent env expr
 231       | _ ->
 232          failwithf "%a: tried to call ‘%s’ which is not a goal or a function"
 233            Ast.string_loc loc name
 234      )
 235
 236   (* Call a predicate. *)
 237   | Ast.EPredCtor (loc, name, args) ->
 238      (* All parameters of predicates must be simple constant expressions
 239       * (strings, in future booleans, numbers, etc).
 240       *)
 241      let args = List.map (Eval.to_constant env) args in
 242      add_pred dag ?parent env loc name args
 243
 244   (* If this is a goal then it's the same as calling goal().  If not
 245    * then look up the variable and substitute it.
 246    *)
 247   | Ast.EVar (loc, name) ->
 248      let expr = Ast.getvar env loc name in
 249      (match expr with
 250       | Ast.EGoalDefn (loc, ([], _, _, _)) ->
 251          add_target dag ?parent env (Ast.ECall (loc, name, []))
 252       | EGoalDefn _ ->
 253          failwithf "%a: cannot call %s() since this goal has parameters"
 254            Ast.string_loc loc name
 255       | _ ->
 256          add_target dag ?parent env expr
 257      )
 258
 259   (* Lists are inlined when found as a target. *)
 260   | Ast.EList (loc, exprs) ->
 261      add_targets dag ?parent env exprs
 262
 263   (* A string (with or without substitutions) implies is-file(filename). *)
 264   | Ast.ESubsts (loc, str) ->
 265      let str = Eval.substitute env loc str in
 266      add_pred dag ?parent env loc "is-file" [Ast.CString str]
 267
 268   | Ast.EConstant (loc, c) ->
 269      add_pred dag ?parent env loc "is-file" [c]
 270
 271 (* Add a goal by name. *)
 272 and add_goal dag ?parent env loc name args
 273              ((params, patterns, deps, code) as goal)
 274              extra_deps =
 275   (* This is used to print the goal in debug and error messages only. *)
 276   let debug_goal =
 277     sprintf "%s (%s)" name
 278       (String.concat ", " (List.map (Ast.string_expr ()) args)) in
 279   Cmdline.debug "%a: adding goal %s" Ast.string_loc loc debug_goal;
 280
 281   (* This is the point where we evaluate the goal arguments.  We must
 282    * do this before creating the new environment, because variables
 283    * appearing in goal arguments don't refer to goal parameters.
 284    *)
 285   let args = List.map (Eval.evaluate_goal_arg env) args in
 286
 287   (* Create a new environment which maps the parameter names to
 288    * the args.
 289    *)
 290   let env =
 291     let params =
 292       try List.combine params args
 293       with Invalid_argument _ ->
 294         failwithf "%a: calling goal %s with wrong number of arguments, expecting %d args but got %d args"
 295           Ast.string_loc loc debug_goal
 296           (List.length params) (List.length args) in
 297     List.fold_left (fun env (k, v) -> Ast.Env.add k v env) env params in
 298
 299   (* Create the node. *)
 300   let node, dag =
 301     add_node dag ?parent (Goal (env, loc, name, args, goal,
 302                                 extra_deps, debug_goal)) in
 303
 304   (* Add all dependencies. *)
 305   add_targets dag ~parent:node env (deps @ extra_deps)
 306
 307 (* Find the goal which matches the given predicate and add it.
 308  * cargs is a list of parameters (all constants).
 309  *)
 310 and add_pred dag ?parent env loc pred cargs =
 311   (* This is used to print the predicate in debug and error messages only. *)
 312   let debug_pred =
 313     Ast.string_expr ()
 314       (Ast.EPredCtor (loc, pred,
 315                         List.map (fun c -> Ast.EConstant (loc, c)) cargs)) in
 316   Cmdline.debug "%a: adding predicate %s" Ast.string_loc loc debug_pred;
 317
 318   (* Find all goals in the environment.  Returns a list of (name, goal). *)
 319   let goals =
 320     let env = Ast.Env.bindings env in
 321     filter_map
 322       (function
 323        | name, Ast.EGoalDefn (loc, goal) -> Some (name, goal)
 324        | _ -> None) env in
 325
 326   (* Find all patterns.  Returns a list of (pattern, name, goal). *)
 327   let patterns : (Ast.pattern * Ast.id * Ast.goal) list =
 328     List.flatten
 329       (List.map (fun (name, ((_, patterns, _, _) as goal)) ->
 330            List.map (fun pattern -> (pattern, name, goal)) patterns) goals) in
 331
 332   (* Find any patterns (ie. predicates) which match the one we
 333    * are searching for.  This returns a binding for the goal args,
 334    * so we end up with a list of (pattern, name, goal, args).
 335    *)
 336   let patterns : (Ast.pattern * Ast.id * Ast.goal * Ast.expr list) list =
 337     filter_map (
 338       fun (pattern, name, ((params, _, _, _) as goal)) ->
 339         match matching_pattern env loc pred cargs pattern params with
 340         | None -> None
 341         | Some args -> Some (pattern, name, goal, args)
 342     ) patterns in
 343
 344   match patterns with
 345   | [] ->
 346      (* There's no matching goal, but we don't need one if
 347       * the predicate doesn't need to be rebuilt.  So create a
 348       * special Exists node which will be used to run the predicate
 349       * to see if the target needs to be rebuilt, and only fail
 350       * if it does need a rebuild.
 351       *)
 352      let targs = List.map (function Ast.CString s -> [Ast.SString s]) cargs in
 353      let p = Ast.PPred (loc, pred, targs) in
 354      let _, dag = add_node dag ?parent (Exists (env, loc, p, debug_pred)) in
 355      dag
 356
 357   | [_, name, goal, args] ->
 358      (* Single goal matches. *)
 359      add_goal dag ?parent env loc name args goal []
 360
 361   | goals ->
 362      (* Two or more goals match.  Only one must have a CODE section,
 363       * and we combine the dependencies into a "supergoal".
 364       *)
 365      let with_code, without_code =
 366        List.partition (
 367          fun (_, _, (_, _, _, code), _) -> code <> None
 368        ) goals in
 369
 370      let (_, name, goal, args), extra_deps =
 371        match with_code with
 372        | [g] ->
 373           let extra_deps =
 374             List.flatten (
 375               List.map (fun (_, _, (_, _, deps, _), _) -> deps) without_code
 376             ) in
 377           (g, extra_deps)
 378
 379        | [] ->
 380           (* This is OK, it means we'll rebuild all dependencies
 381            * but there is no code to run.  Pick the first goal
 382            * without code and the dependencies from the other goals.
 383            *)
 384           let g = List.hd without_code in
 385           let extra_deps =
 386             List.flatten (
 387               List.map (fun (_, _, (_, _, deps, _), _) -> deps)
 388                 (List.tl without_code)
 389             ) in
 390           (g, extra_deps)
 391
 392        | _ :: _ ->
 393           failwithf "%a: multiple goals found which match predicate %s, but more than one of these goals have {code} sections which is not allowed"
 394             Ast.string_loc loc debug_pred in
 395
 396      add_goal dag ?parent env loc name args goal extra_deps
 397
 398 (* Test if pattern matches is-predicate(cargs).  If it does
 399  * then we return Some args where args is the arguments that must
 400  * be passed to the matching goal.  The params parameter is
 401  * the names of the parameters of that goal.
 402  *)
 403 and matching_pattern env loc pred cargs pattern params =
 404   match pattern with
 405   | Ast.PPred (loc, tpred, targs)
 406        when pred <> tpred ||
 407             List.length cargs <> List.length targs ->
 408      None (* Can't possibly match if predicate name or #args is different. *)
 409   | Ast.PPred (loc, tpred, targs) ->
 410      (* Do the args match with a possible params binding? *)
 411      try Some (matching_params env loc params targs cargs)
 412      with Not_found -> None
 413
 414 (* Return a possible binding.  For example the goal is:
 415  *   goal compile (name) = "%name.o": "%name.c" {}
 416  * which means that params = ["name"] and targs = ["%name.o"].
 417  *
 418  * If we are called with cargs = ["file1.o"], we would
 419  * return ["file1"].
 420  *
 421  * On non-matching this raises Not_found.
 422  *)
 423 and matching_params env loc params targs cargs =
 424   (* This is going to record the resulting binding. *)
 425   let res = ref Ast.Env.empty in
 426   List.iter2 (matching_param env loc params res) targs cargs;
 427
 428   (* Rearrange the result into goal parameter order.  Also this
 429    * checks that every parameter got a binding.
 430    *)
 431   let res = !res in
 432   List.map (
 433     (* Allow the Not_found exception to escape if no binding for this param. *)
 434     fun param -> Ast.Env.find param res
 435   ) params
 436
 437 (* If targ = "%name.o" and carg = "file.o" then this would set
 438  * name => "file" in !res.  If they don't match, raises Not_found.
 439  *)
 440 and matching_param env loc params res targ carg =
 441   match carg with
 442   | Ast.CString carg ->
 443      (* Substitute any non parameters in targ from the environment. *)
 444      let targ =
 445        List.map (
 446          function
 447          | Ast.SString _ as s -> s
 448          | Ast.SVar name ->
 449             if not (List.mem name params) then (
 450               try
 451                 let expr = Ast.getvar env loc name in
 452                 match Eval.to_constant env expr with
 453                 | Ast.CString s -> Ast.SString s
 454               with Failure _ -> raise Not_found
 455             )
 456             else
 457               Ast.SVar name
 458        ) targ in
 459
 460      (* Do the actual pattern matching.  Any remaining SVar elements
 461       * must refer to goal parameters.
 462       *)
 463      let carg = ref carg in
 464      let rec loop = function
 465        | [] ->
 466           (* End of targ, we must have matched all of carg. *)
 467           if !carg <> "" then raise Not_found
 468        | Ast.SString s :: rest ->
 469           (* Does this match the first part of !carg? *)
 470           let clen = String.length !carg in
 471           let slen = String.length s in
 472           if slen > clen || s <> String.sub !carg 0 slen then
 473             raise Not_found;
 474           (* Yes, so continue after the matching prefix. *)
 475           carg := String.sub !carg slen (clen-slen);
 476           loop rest
 477        | Ast.SVar name :: Ast.SString s :: rest ->
 478           (* This is a goal parameter.  Find s later in !carg. *)
 479           let i = string_find !carg s in
 480           if i = -1 then raise Not_found;
 481           (* Set the binding in !res. *)
 482           let r = Ast.EConstant (Ast.noloc,
 483                                  Ast.CString (String.sub !carg 0 i)) in
 484           res := Ast.Env.add name r !res;
 485           (* Continue after the match. *)
 486           let skip = i + String.length s in
 487           carg := String.sub !carg skip (String.length !carg - skip);
 488           loop rest
 489        | Ast.SVar name :: [] ->
 490           (* Matches the whole remainder of the string. *)
 491           let r = Ast.EConstant (Ast.noloc, Ast.CString !carg) in
 492           res := Ast.Env.add name r !res
 493        | Ast.SVar x :: Ast.SVar y :: _ ->
 494           (* TODO! We cannot match a target like "%x%y". *)
 495           assert false
 496      in
 497      loop targ
 498
 499 type goal_runner =
 500   Ast.env -> Ast.loc -> string -> Ast.expr list -> Ast.goal ->
 501   Ast.expr list -> string -> unit
 502
 503 type exists_runner = Ast.env -> Ast.loc -> Ast.pattern -> string -> unit
 504
 505 type state = {
 506   dag : dag;
 507   goal_runner : goal_runner;
 508   exists_runner : exists_runner;
 509
 510   (* Topologically sorted in build order.  When nodes start running
 511    * we take them off this list.
 512    *)
 513   mutable sorted_nodes : node list;
 514
 515   (* List of nodes which completed successfully.  Actually for fast
 516    * access we store a map node -> true.
 517    *)
 518   mutable complete : bool G.t;
 519
 520   (* List of nodes which failed. *)
 521   mutable failed : bool G.t;
 522 }
 523
 524 let new_state (dag, sorted_nodes) goal_runner exists_runner =
 525   { dag; goal_runner; exists_runner; sorted_nodes;
 526     complete = G.empty; failed = G.empty }
 527
 528 (* Called by [Jobs] when a node completes successfully.  We mark
 529  * it as done.
 530  *)
 531 let retire_job state node =
 532   state.complete <- G.add node true state.complete
 533
 534 (* Called by [Jobs] when a node fails.  We mark the node as
 535  * failed and ensure that anything that depends on it will
 536  * also be marked as failed (and never returned by next_job).
 537  *)
 538 let fail_job state node =
 539   state.failed <- G.add node true state.failed
 540
 541 let rec next_job state =
 542   (* Find the earliest node in the list which has all its
 543    * dependencies done.
 544    *)
 545   let rec loop acc = function
 546     | [] ->
 547        if state.sorted_nodes = [] then Jobs.Complete else Jobs.Not_ready
 548     | node :: nodes when node_is_ready_to_run state node ->
 549        (* Drop the node from the list of jobs and run it. *)
 550        state.sorted_nodes <- List.rev acc @ nodes;
 551        (match node with
 552         | Goal (env, loc, name, args, goal, extra_deps, debug_goal) ->
 553            Jobs.Job (node, fun () ->
 554                            state.goal_runner env loc name args goal
 555                              extra_deps debug_goal)
 556         | Exists (env, loc, p, debug_pred) ->
 557            Jobs.Job (node, fun () ->
 558                            state.exists_runner env loc p debug_pred)
 559        )
 560     | node :: nodes when node_failed state node ->
 561        (* Mark it as failed also, and drop it from the list of jobs. *)
 562        fail_job state node;
 563        state.sorted_nodes <- List.rev acc @ nodes;
 564        loop acc nodes
 565     | node :: nodes ->
 566        (* All dependencies of this node are neither complete nor failed,
 567         * continue down the list.
 568         *)
 569        loop (node :: acc) nodes
 570   in
 571   loop [] state.sorted_nodes
 572
 573 (* All dependencies of this node are complete. *)
 574 and node_is_ready_to_run { dag; complete } node =
 575   let parents = try G.find node dag.edges with Not_found -> [] in
 576   List.for_all (fun p -> G.mem p complete) parents
 577
 578 (* This node or any dependency of this node failed. *)
 579 and node_failed { dag; failed } node =
 580   G.mem node failed || (
 581     let parents = try G.find node dag.edges with Not_found -> [] in
 582     List.exists (fun p -> G.mem p failed) parents
 583   )
 584
 585 let string_of_job  = string_of_node