1structure HM_DepGraph :> HM_DepGraph =
2struct
3
4
5open Holmake_tools
6infix |>
7fun x |> f = f x
8
9structure Map = Binarymap
10
11datatype target_status =
12         Pending of {needed:bool}
13       | Succeeded
14       | Failed of {needed:bool}
15       | Running
16fun is_pending (Pending _) = true | is_pending _ = false
17fun is_failed (Failed _) = true | is_failed _ = false
18fun needed_string {needed} = "{needed="^Bool.toString needed^"}]"
19fun status_toString s =
20  case s of
21      Succeeded => "[Succeeded]"
22    | Failed n => "[Failed" ^ needed_string n ^ "]"
23    | Running => "[Running]"
24    | Pending n => "[Pending" ^ needed_string n ^ "]"
25
26exception NoSuchNode
27exception DuplicateTarget
28type node = int
29datatype builtincmd = BIC_BuildScript of string | BIC_Compile
30
31fun bic_toString BIC_Compile = "BIC_Compile"
32  | bic_toString (BIC_BuildScript s) = "BIC_Build " ^ s
33
34datatype command =
35         NoCmd
36       | SomeCmd of string
37       | BuiltInCmd of builtincmd * Holmake_tools.include_info
38type 'a nodeInfo = { target : dep, status : target_status, extra : 'a,
39                     command : command, phony : bool,
40                     seqnum : int, dir : Holmake_tools.hmdir.t,
41                     dependencies : (node * Holmake_tools.dep) list  }
42
43fun fupdStatus f (nI: 'a nodeInfo) : 'a nodeInfo =
44  let
45    val {target,command,status,dependencies,seqnum,phony,dir,extra} = nI
46  in
47    {target = target, status = f status, command = command, seqnum = seqnum,
48     dependencies = dependencies, phony = phony, dir = dir, extra = extra}
49  end
50
51fun setStatus s = fupdStatus (fn _ => s)
52
53fun addDeps0 dps {target,command,status,dependencies,seqnum,phony,dir,extra} =
54  {target = target, status = status, command = command, phony = phony,
55   dependencies = dps @ dependencies, seqnum = seqnum, dir = dir, extra = extra}
56
57
58val node_compare = Int.compare
59fun bic_compare (BIC_Compile, BIC_Compile) = EQUAL
60  | bic_compare (BIC_Compile, _) = LESS
61  | bic_compare (BIC_BuildScript _, BIC_Compile) = GREATER
62  | bic_compare (BIC_BuildScript s1, BIC_BuildScript s2) = String.compare(s1,s2)
63
64fun command_compare (NoCmd, NoCmd) = EQUAL
65  | command_compare (NoCmd, _) = LESS
66  | command_compare (_, NoCmd) = GREATER
67  | command_compare (SomeCmd s1, SomeCmd s2) = String.compare(s1,s2)
68  | command_compare (SomeCmd _, BuiltInCmd _) = LESS
69  | command_compare (BuiltInCmd _, SomeCmd _) = GREATER
70  | command_compare (BuiltInCmd (b1,_), BuiltInCmd (b2,_)) = bic_compare(b1,b2)
71
72type 'a t = { nodes : (node, 'a nodeInfo) Map.dict,
73              target_map : (dep,node) Map.dict,
74              command_map : (command,node list) Map.dict }
75
76
77fun empty() : 'a t = { nodes = Map.mkDict node_compare,
78                       target_map = Map.mkDict hm_target.compare,
79                       command_map = Map.mkDict command_compare }
80fun fupd_nodes f ({nodes, target_map, command_map}: 'a t) : 'a t =
81  {nodes = f nodes, target_map = target_map, command_map = command_map}
82
83fun find_nodes_by_command (g : 'a t) c =
84  case Map.peek (#command_map g, c) of
85      NONE => []
86    | SOME ns => ns
87
88fun size (g : 'a t) = Map.numItems (#nodes g)
89fun peeknode (g:'a t) n = Map.peek(#nodes g, n)
90val empty_nodeset = Binaryset.empty (pair_compare(node_compare, String.compare))
91
92fun addDeps (n,dps) g =
93  case peeknode g n of
94      NONE => raise NoSuchNode
95    | SOME nI =>
96      fupd_nodes (fn nm => Binarymap.insert(nm,n,addDeps0 dps nI)) g
97
98fun nodeStatus g n =
99  case peeknode g n of
100      NONE => raise NoSuchNode
101    | SOME nI => #status nI
102
103fun nodeset_eq (nl1, nl2) =
104  let
105    val ns1 = Binaryset.addList(empty_nodeset, nl1)
106    val ns2 = Binaryset.addList(empty_nodeset, nl2)
107  in
108    Binaryset.isSubset(ns1, ns2) andalso Binaryset.isSubset(ns2, ns1)
109  end
110
111fun extend_map_list m k v =
112  case Map.peek (m, k) of
113      NONE => Map.insert(m, k, [v])
114    | SOME vs => Map.insert(m, k, v::vs)
115
116fun add_node (nI : 'a nodeInfo) (g :'a t) =
117  let
118    fun newNode (copt : command) =
119      let
120        val n = size g
121      in
122        ({ nodes = Map.insert(#nodes g,n,nI),
123           target_map = Map.insert(#target_map g, #target nI, n),
124           command_map = extend_map_list (#command_map g) copt n },
125         n)
126      end
127    val {target=tgt,dir,...} = nI
128    val tmap = #target_map g
129    val _ =
130        case Map.peek (tmap, tgt) of
131            SOME n => if #seqnum (valOf (peeknode g n)) <> #seqnum nI then ()
132                      else raise DuplicateTarget
133          | NONE => ()
134  in
135    newNode (#command nI)
136  end
137
138fun updnode (n, st) (g : 'a t) : 'a t =
139  case peeknode g n of
140      NONE => raise NoSuchNode
141    | SOME nI => fupd_nodes (fn m => Map.insert(m, n, setStatus st nI)) g
142
143fun find_runnable (g : 'a t) =
144  let
145    val sz = size g
146    fun hasSucceeded (i,_) = #status (valOf (peeknode g i)) = Succeeded
147    (* relying on invariant that all nodes up to size are in map *)
148    fun search i =
149      case peeknode g i of
150          NONE => NONE
151        | SOME nI =>
152          if #status nI = Pending{needed=true} andalso
153             List.all hasSucceeded (#dependencies nI)
154          then SOME (i,nI)
155          else search (i + 1)
156  in
157    search 0
158  end
159
160fun target_node (g:'a t) t = Map.peek(#target_map g,t)
161fun listNodes (g:'a t) = Map.foldr (fn (k,v,acc) => (k,v)::acc) [] (#nodes g)
162
163val node_toString = Int.toString
164
165fun nodeInfo_toString (nI : 'a nodeInfo) =
166  let
167    open Holmake_tools
168    val {target,status,command,dependencies,seqnum,phony,dir,...} = nI
169  in
170    tgt_toString target ^ (if phony then "[PHONY]" else "") ^
171    "(" ^ Int.toString seqnum ^ ") " ^
172    "deps{" ^String.concatWith "," (map (Int.toString o #1) dependencies) ^ "}"^
173    status_toString status ^ " : " ^
174    (case command of
175         SomeCmd s => s
176       | BuiltInCmd (bic,{preincludes,includes}) => "<" ^ bic_toString bic ^ ">"
177       | NoCmd => "<no command>")
178  end
179
180fun mkneeded tgts g =
181    let
182      fun setneeded f n g = updnode(n,f{needed=true}) g
183      fun work visited wlist g =
184          case wlist of
185              [] => g
186            | [] :: rest => work visited rest g
187            | (n :: ns) :: rest =>
188              if Binaryset.member(visited, n) then work visited (ns::rest) g
189              else
190                case peeknode g n of
191                    NONE => raise NoSuchNode
192                  | SOME nI =>
193                    work (Binaryset.add(visited, n))
194                         (map #1 (#dependencies nI) :: ns :: rest)
195                         (case #status nI of
196                              Pending {needed=false} => setneeded Pending n g
197                            | Failed  {needed=false} => setneeded Failed  n g
198                            | _ => g)
199      val initial_tgts = List.mapPartial (target_node g) tgts
200    in
201      work (Binaryset.empty node_compare) [initial_tgts] g
202    end
203
204fun mk_dirneeded d g =
205    let
206      fun upd_nI nI =
207          if hmdir.compare(#dir nI, d) <> EQUAL then
208            case (hm_target.tgtexists_readable (#target nI), #status nI) of
209                (true, Pending _) => setStatus Succeeded nI
210              | (false, Pending {needed}) => setStatus(Failed{needed=needed})nI
211              | _ => nI
212          else nI
213    in
214      fupd_nodes (Map.map (fn (_,nI) => upd_nI nI)) g
215    end
216
217fun indentedlist f l =
218    let
219      fun recurse c A l =
220          case l of
221              [] => ""
222            | [x] => let val s = f x
223                     in
224                       if c + String.size s > 80 then
225                         String.concat (List.rev ("\n }\n" :: s :: "\n  " :: A))
226                       else String.concat (List.rev ("\n }\n" :: s :: A))
227                     end
228            | x::xs => let val s = f x
229                           val sz = String.size s
230                       in
231                         if c + sz > 78 then
232                           recurse (sz + 4) (", " :: s :: "\n  " :: A) xs
233                         else
234                           recurse (sz + c + 2) (", " :: s :: A) xs
235                       end
236    in
237      case l of
238          [] => "{}\n"
239        | _ => "{\n  " ^ recurse 2 [] l
240    end
241
242fun toString g =
243    let
244      open hm_target
245      val (successes, others) =
246          List.partition (fn (_,nI) => #status nI = Succeeded) (listNodes g)
247      fun prSuccess (n,{dir,target,...}) =
248          Int.toString n ^ ":" ^
249          tgt_toString target ^
250          (if hmdir.compare(dir,dirpart target) <> EQUAL then
251             "[ run in " ^ hmdir.pretty_dir dir ^ "]"
252           else "")
253      fun prNode(n,nI) = "[" ^ node_toString n ^ "], " ^ nodeInfo_toString nI
254    in
255      "{Already built " ^
256      indentedlist prSuccess successes ^ " Others:\n  " ^
257      String.concatWith ",\n  " (map prNode others) ^ "\n}"
258    end
259
260fun postmortem (outs : Holmake_tools.output_functions) (status,g) =
261  let
262    val pr = tgt_toString
263    val {diag,tgtfatal,...} = outs
264    val diagK = diag "postmortem" o (fn x => fn _ => x)
265    fun pending_or_failed ps fs ns =
266        case ns of
267            [] => (ps,fs)
268          | (x as (n,nI))::rest => if #status nI = Failed{needed=true} then
269                                     pending_or_failed ps (x::fs) rest
270                                   else if #status nI = Pending{needed=true}then
271                                     pending_or_failed (x::ps) fs rest
272                                   else pending_or_failed ps fs rest
273  in
274    case pending_or_failed [] [] (listNodes g) of
275        ([],[]) => OS.Process.success
276      | (ps, fs) =>
277        let
278          fun str (n,nI) = node_toString n ^ ": " ^ nodeInfo_toString nI
279          fun nocmd (_, nI) = #command nI = NoCmd
280          val fs' = List.filter nocmd fs
281          fun nI_target (_, nI) = #target nI
282        in
283          diagK ("Failed nodes: \n" ^ concatWithf str "\n" fs);
284          diagK ("True pending: \n" ^ concatWithf str "\n" ps);
285          if not (null fs') then
286            tgtfatal ("Don't know how to build necessary target(s): " ^
287                      concatWithf (tgt_toString o nI_target) ", " fs')
288          else ();
289          OS.Process.failure
290        end
291
292  end
293
294
295
296
297end
298