1structure multibuild = 2struct 3 4open ProcessMultiplexor HM_DepGraph Holmake_tools 5 6type 'a mosml_build_command = 'a HM_GraphBuildJ1.mosml_build_command 7datatype buildresult = 8 BR_OK 9 | BR_ClineK of { cline : string * string list, 10 job_kont : (string -> unit) -> OS.Process.status -> 11 bool, 12 other_nodes : HM_DepGraph.node list } 13 | BR_Failed 14 15val RealFail = Failed{needed=true} 16 17infix ++ 18fun p1 ++ p2 = OS.Path.concat(p1, p2) 19val loggingdir = ".hollogs" 20 21 22 23fun graphbuild optinfo g = 24 let 25 val { build_command, 26 mosml_build_command : GraphExtra.t mosml_build_command, 27 warn, tgtfatal, diag, 28 keep_going, quiet, hmenv, jobs, info, time_limit, 29 relocbuild } = optinfo 30 val _ = diag "Starting graphbuild" 31 fun dropthySuffix s = 32 if List.exists 33 (fn sfx => String.isSuffix ("Theory." ^ sfx) s) 34 ["dat", "sml", "sig"] 35 then String.substring(s,0,String.size s - 4) 36 else s 37 fun safetag d t = 38 String.map (fn #"/" => #"-" | c => c) (dropthySuffix t) 39 fun genLF {tag, dir} = 40 let 41 val ldir = dir ++ loggingdir 42 val _ = OS.FileSys.mkDir ldir handle _ => () 43 in 44 ldir ++ safetag dir tag 45 end 46 47 val monitor = 48 MB_Monitor.new {info = info, warn = warn, genLogFile = genLF, 49 time_limit = time_limit} 50 51 val env = 52 (if relocbuild then [Systeml.build_after_reloc_envvar^"=1"] else []) @ 53 Posix.ProcEnv.environ() 54 fun cline_to_command (s, args) = {executable = s, nm_args = args, env = env} 55 fun shell_command s = 56 {executable = "/bin/sh", nm_args = ["/bin/sh", "-c", s], env = env} 57 58 fun genjob (g,ok) = 59 case (ok,find_runnable g) of 60 (false, _) => GiveUpAndDie (g, false) 61 | (true, NONE) => NoMoreJobs (g, ok) 62 | (true, SOME (n,nI : GraphExtra.t nodeInfo)) => 63 let 64 val _ = diag ("Found runnable node "^node_toString n) 65 val extra = #extra nI 66 fun eCompile ds = Compile(ds, extra) 67 fun eBuildScript (s,deps) = BuildScript(s,deps,extra) 68 fun eBuildArticle (s,deps) = BuildArticle(s,deps,extra) 69 fun eProcessArticle s = ProcessArticle(s,extra) 70 fun k b g = 71 if b orelse keep_going then 72 genjob (updnode(n, if b then Succeeded else RealFail) g, true) 73 else GiveUpAndDie (g, ok) 74 val deps = map #2 (#dependencies nI) 75 val dir = Holmake_tools.hmdir.toAbsPath (#dir nI) 76 val _ = is_pending (#status nI) orelse 77 raise Fail "runnable not pending" 78 val target_s = tgt_toString (#target nI) 79 val tag = if OS.Path.dir target_s = dir then OS.Path.file target_s 80 else target_s 81 fun stdprocess() = 82 case #command nI of 83 NoCmd => genjob (updnode (n,Succeeded) g, true) 84 | cmd as SomeCmd c => 85 let 86 val hypargs as {noecho,ignore_error,command=c} = 87 process_hypat_options c 88 val hypargs = 89 {noecho=true,ignore_error=ignore_error,command=c} 90 fun error b = 91 if b then Succeeded 92 else if ignore_error then 93 (warn ("Ignoring error executing: " ^ c); 94 Succeeded) 95 else RealFail 96 in 97 case pushdir dir 98 (mosml_build_command hmenv extra hypargs) deps 99 of 100 SOME r => 101 k (error (OS.Process.isSuccess r) = Succeeded) g 102 | NONE => 103 let 104 val others = find_nodes_by_command g cmd 105 val _ = diag ("Found nodes " ^ 106 String.concatWith ", " 107 (map node_toString others) ^ 108 " with duplicate commands") 109 fun updall (g, st) = 110 List.foldl (fn (n, g) => updnode (n, st) g) 111 g 112 (n::others) 113 fun update ((g,ok), b) = 114 let 115 val status = error b 116 val g' = updall (g, status) 117 val ok' = status = Succeeded orelse keep_going 118 in 119 (g',ok') 120 end 121 in 122 NewJob ({tag = tag, command = shell_command c, 123 update = update, dir = dir}, 124 (updall(g, Running), true)) 125 end 126 end 127 | BuiltInCmd (bic,incinfo) => 128 let 129 val _ = diag ("Setting up for target >" ^ target_s ^ 130 "< with bic " ^ bic_toString bic) 131 fun bresk bres g = 132 case bres of 133 BR_OK => k true g 134 | BR_Failed => k false g 135 | BR_ClineK{cline, job_kont, other_nodes} => 136 let 137 fun b2res b = if b then OS.Process.success 138 else OS.Process.failure 139 fun updall s g = 140 List.foldl (fn (n,g) => updnode(n,s) g) g 141 (n::other_nodes) 142 fun update ((g,ok), b) = 143 if job_kont (fn s => ()) (b2res b) then 144 (updall Succeeded g, true) 145 else 146 (updall RealFail g, keep_going) 147 fun cline_str (c,l) = "["^c^"] " ^ 148 String.concatWith " " l 149 in 150 diag ("New graph job for "^target_s^ 151 " with c/line: " ^ cline_str cline); 152 diag ("Other nodes are: "^ 153 String.concatWith ", " 154 (map node_toString other_nodes)); 155 NewJob({tag = tag, dir = dir, 156 command = cline_to_command cline, 157 update = update}, 158 (updall Running g, true)) 159 end 160 fun bc c f = pushdir dir (build_command g incinfo c) f 161 val _ = diag ("Handling builtin command " ^ 162 bic_toString bic ^ " for "^target_s) 163 in 164 case bic of 165 BIC_Compile => 166 (case toFile target_s of 167 UI c => bresk (bc (eCompile deps) (SIG c)) g 168 | UO c => bresk (bc (eCompile deps) (SML c)) g 169 | ART (RawArticle s) => 170 bresk (bc (eBuildArticle(s,deps)) 171 (SML (Script s))) 172 g 173 | ART (ProcessedArticle s) => 174 bresk (bc (eProcessArticle s) 175 (ART (RawArticle s))) 176 g 177 | _ => raise Fail ("bg tgt = " ^ target_s)) 178 | BIC_BuildScript thyname => 179 bresk (bc (eBuildScript(thyname, deps)) 180 (SML (Script thyname))) 181 g 182 end 183 in 184 if not (#phony nI) andalso 185 hm_target.tgtexists_readable (#target nI) andalso 186 #seqnum nI = 0 187 (* necessary to avoid dropping out of a multi-command execution 188 part way through *) 189 then 190 let 191 val _ = diag ("May not need to rebuild "^target_s) 192 in 193 case List.find 194 (fn (_, d) => depforces_update_of(d,#target nI)) 195 (#dependencies nI) 196 of 197 NONE => (diag ("Can skip work on "^target_s); 198 genjob (updnode (n, Succeeded) g, true)) 199 | SOME (_,d) => 200 (diag ("Dependency " ^ tgt_toString d ^ 201 " forces rebuild of "^ target_s); 202 stdprocess()) 203 end 204 else 205 stdprocess() 206 end 207 val worklist = 208 new_worklist {worklimit = jobs, 209 provider = { initial = (g,true), genjob = genjob }} 210 in 211 do_work(worklist, monitor) 212 end 213 214end 215