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