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