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