1structure multibuild = 2struct 3 4open ProcessMultiplexor HM_DepGraph Holmake_tools 5type wp = HM_DepGraph.t workprovider 6 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 15infix ++ 16fun p1 ++ p2 = OS.Path.concat(p1, p2) 17val loggingdir = ".hollogs" 18 19 20fun graphbuild optinfo incinfo g = 21 let 22 val _ = OS.FileSys.mkDir loggingdir handle _ => () 23 val { build_command, mosml_build_command, warn, tgtfatal, diag, 24 keep_going, quiet, hmenv, jobs, info, time_limit, 25 relocbuild } = optinfo 26 val safetag = String.map (fn #"/" => #"-" | c => c) 27 val monitor = 28 MB_Monitor.new {info = info, 29 warn = warn, 30 genLogFile = (fn {tag} => loggingdir ++ safetag tag), 31 keep_going = keep_going, 32 time_limit = time_limit} 33 34 val env = 35 (if relocbuild then [Systeml.build_after_reloc_envvar^"=1"] else []) @ 36 Posix.ProcEnv.environ() 37 fun cline_to_command (s, args) = {executable = s, nm_args = args, env = env} 38 fun shell_command s = 39 {executable = "/bin/sh", nm_args = ["/bin/sh", "-c", s], env = env} 40 41 fun genjob g = 42 case find_runnable g of 43 NONE => NoMoreJobs g 44 | SOME (n,nI) => 45 let 46 val _ = diag ("Found runnable node "^node_toString n) 47 fun k b g = 48 if b orelse keep_going then 49 genjob (updnode(n, if b then Succeeded else Failed) g) 50 else GiveUpAndDie g 51 val depfs = map (toFile o #2) (#dependencies nI) 52 val _ = #status nI = Pending orelse 53 raise Fail "runnable not pending" 54 val target_s = #target nI 55 fun stdprocess() = 56 case #command nI of 57 NoCmd => genjob (updnode (n,Succeeded) g) 58 | cmd as SomeCmd c => 59 let 60 val hypargs as {noecho,ignore_error,command=c} = 61 process_hypat_options c 62 val hypargs = 63 {noecho=true,ignore_error=ignore_error,command=c} 64 fun error b = 65 if b then Succeeded 66 else if ignore_error then 67 (warn ("Ignoring error building " ^ target_s); 68 Succeeded) 69 else Failed 70 in 71 case mosml_build_command hmenv hypargs depfs of 72 SOME r => 73 k (error (OS.Process.isSuccess r) = Succeeded) g 74 | NONE => 75 let 76 val others = find_nodes_by_command g cmd 77 val _ = diag ("Found nodes " ^ 78 String.concatWith ", " 79 (map node_toString others) ^ 80 " with duplicate commands") 81 fun updall (g, st) = 82 List.foldl (fn (n, g) => updnode (n, st) g) 83 g 84 (n::others) 85 fun update (g, b) = updall (g, error b) 86 in 87 NewJob ({tag = target_s, command = shell_command c, 88 update = update}, 89 updall(g, Running)) 90 end 91 end 92 | BuiltInCmd bic => 93 let 94 val _ = diag ("Setting up for target >" ^ target_s ^ 95 "< with bic " ^ bic_toString bic) 96 fun bresk bres g = 97 case bres of 98 BR_OK => k true g 99 | BR_Failed => k false g 100 | BR_ClineK{cline, job_kont, other_nodes} => 101 let 102 fun b2res b = if b then OS.Process.success 103 else OS.Process.failure 104 fun updall s g = 105 List.foldl (fn (n,g) => updnode(n,s) g) g 106 (n::other_nodes) 107 fun update (g, b) = 108 if job_kont (fn s => ()) (b2res b) then 109 updall Succeeded g 110 else 111 updall Failed g 112 fun cline_str (c,l) = "["^c^"] " ^ 113 String.concatWith " " l 114 in 115 diag ("New graph job for "^target_s^ 116 " with c/line: " ^ cline_str cline); 117 diag ("Other nodes are: "^ 118 String.concatWith ", " 119 (map node_toString other_nodes)); 120 NewJob({tag = target_s, 121 command = cline_to_command cline, 122 update = update}, 123 updall Running g) 124 end 125 val bc = build_command g incinfo 126 val _ = diag ("Handling builtin command " ^ 127 bic_toString bic ^ " for "^target_s) 128 in 129 case bic of 130 BIC_Compile => 131 (case toFile target_s of 132 UI c => bresk (bc (Compile depfs) (SIG c)) g 133 | UO c => bresk (bc (Compile depfs) (SML c)) g 134 | ART (RawArticle s) => 135 bresk (bc (BuildArticle(s,depfs)) 136 (SML (Script s))) 137 g 138 | ART (ProcessedArticle s) => 139 bresk (bc (ProcessArticle s) 140 (ART (RawArticle s))) 141 g 142 | _ => raise Fail ("bg tgt = " ^ target_s)) 143 | BIC_BuildScript thyname => 144 bresk (bc (BuildScript(thyname, depfs)) 145 (SML (Script thyname))) 146 g 147 end 148 in 149 if not (#phony nI) andalso exists_readable (#target nI) andalso 150 #seqnum nI = 0 151 (* necessary to avoid dropping out of a multi-command execution 152 part way through *) 153 then 154 let 155 val _ = diag ("May not need to rebuild "^target_s) 156 in 157 case List.find 158 (fn (_, d) => forces_update_of(d,#target nI)) 159 (#dependencies nI) 160 of 161 NONE => (diag ("Can skip work on "^target_s); 162 genjob (updnode (n, Succeeded) g)) 163 | SOME (_,d) => 164 (diag ("Dependency "^d^" forces rebuild of "^ target_s); 165 stdprocess()) 166 end 167 else 168 stdprocess() 169 end 170 val worklist = 171 new_worklist {worklimit = jobs, 172 provider = { initial = g, genjob = genjob }} 173 in 174 do_work(worklist, monitor) 175 end 176 177end 178