Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/branches/primop-branch-gkuan/cm/bootstrap/btcompile.sml
ViewVC logotype

Annotation of /sml/branches/primop-branch-gkuan/cm/bootstrap/btcompile.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2787 - (view) (download)

1 : blume 327 (*
2 :     * The bootstrap compiler.
3 :     * (Formerly known as "batch" compiler.)
4 :     *
5 :     * (C) 1999 Lucent Technologies, Bell Laboratories
6 :     *
7 :     * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
8 :     *)
9 : blume 569 local
10 : blume 879 structure EM = ErrorMsg
11 :     structure SE = StaticEnv
12 :     structure PS = PersStamps
13 : blume 569 structure GG = GroupGraph
14 :     structure DG = DependencyGraph
15 :     in
16 : blume 578 functor BootstrapCompileFn
17 : blume 879 (structure Backend : BACKEND
18 : blume 677 val useStream : TextIO.instream -> unit
19 : blume 578 val os : SMLofNJ.SysInfo.os_kind
20 : blume 734 val load_plugin : SrcPath.dir -> string -> bool) =
21 :     struct
22 : blume 879 structure SSV = SpecificSymValFn (val arch = Backend.architecture
23 : mblume 1886 val os = os
24 :     val abi_variant = Backend.abi_variant)
25 : blume 364 structure P = OS.Path
26 :     structure F = OS.FileSys
27 : blume 879 structure BF = Binfile
28 : blume 327
29 : blume 879 val arch = Backend.architecture
30 : blume 452 val osname = FilenamePolicy.kind2name os
31 : blume 642
32 : blume 452 val archos = concat [arch, "-", osname]
33 :    
34 : blume 588 structure StabModmap = StabModmapFn ()
35 :    
36 : blume 879 structure Compile = CompileFn (structure Backend = Backend
37 : blume 588 structure StabModmap = StabModmap
38 : blume 677 val useStream = useStream
39 : blume 464 val compile_there =
40 : blume 666 Servers.compile o SrcPath.encode)
41 : blume 360
42 : blume 879 structure BFC = BfcFn (val arch = Backend.architecture)
43 : blume 403
44 : blume 327 (* instantiate Stabilize... *)
45 : blume 329 structure Stabilize =
46 : blume 879 StabilizeFn (val arch = Backend.architecture
47 : blume 588 structure StabModmap = StabModmap
48 : blume 399 fun recomp gp g = let
49 : blume 403 val { store, get } = BFC.new ()
50 : blume 801 fun dummy _ _ = ()
51 : blume 399 val { group, ... } =
52 : blume 801 Compile.newTraversal (dummy, store, g)
53 : blume 399 in
54 : blume 801 case group gp of
55 : blume 403 NONE => NONE
56 :     | SOME _ => SOME get
57 :     end
58 :     val getII = Compile.getII)
59 : blume 398
60 : blume 569 structure VerifyStable = VerStabFn (structure Stabilize = Stabilize)
61 :    
62 : blume 327 (* ... and Parse *)
63 : blume 362 structure Parse = ParseFn (structure Stabilize = Stabilize
64 : blume 588 structure StabModmap = StabModmap
65 : blume 537 val evictStale = Compile.evictStale
66 : blume 372 fun pending () = SymbolMap.empty)
67 : blume 327
68 : blume 537 fun mkBootList g = let
69 :     fun listName p =
70 :     case P.fromString p of
71 :     { vol = "", isAbs = false, arcs = _ :: arc1 :: arcn } => let
72 :     fun win32name () =
73 :     concat (arc1 ::
74 :     foldr (fn (a, r) => "\\" :: a :: r) [] arcn)
75 :     in
76 :     case os of
77 :     SMLofNJ.SysInfo.WIN32 => win32name ()
78 :     | _ => P.toString { isAbs = false, vol = "",
79 :     arcs = arc1 :: arcn }
80 :     end
81 :     | _ => raise Fail ("BootstrapCompile:listName: bad name: " ^ p)
82 : blume 364 in
83 : blume 537 MkBootList.group listName g
84 : blume 364 end
85 : blume 327
86 : blume 805 fun internal_reset () =
87 :     (Compile.reset ();
88 :     Parse.reset ();
89 :     StabModmap.reset ())
90 :    
91 :     fun reset () =
92 :     (Say.vsay ["[CMB reset]\n"];
93 :     Servers.withServers (fn () => Servers.cmb_reset { archos = archos });
94 :     internal_reset ())
95 :    
96 :     val checkDirbase = let
97 :     val prev = ref NONE
98 :     fun ck db =
99 :     (case !prev of
100 :     NONE => prev := SOME db
101 :     | SOME db' =>
102 :     if db = db' then ()
103 :     else (Say.vsay ["[new dirbase is `", db,
104 :     "'; CMB reset]\n"];
105 :     internal_reset ();
106 :     prev := SOME db))
107 : blume 588 in
108 : blume 805 ck
109 : blume 588 end
110 :    
111 : blume 801 fun mk_compile { master, root, dirbase = dbopt } = let
112 : blume 358
113 : blume 360 val dirbase = getOpt (dbopt, BtNames.dirbaseDefault)
114 : blume 588 val _ = checkDirbase dirbase
115 : blume 666 val penvspec = BtNames.penvspec
116 : blume 360 val initgspec = BtNames.initgspec
117 :     val maingspec = BtNames.maingspec
118 :    
119 : blume 537 val bindir = concat [dirbase, BtNames.bin_infix, archos]
120 :     val bootdir = concat [dirbase, BtNames.boot_infix, archos]
121 : blume 357
122 : blume 433 val keep_going = #get StdConfig.keep_going ()
123 : blume 329
124 : blume 666 val ctxt = SrcPath.cwd ()
125 : blume 329
126 : blume 537 val listfile = P.joinDirFile { dir = bootdir, file = BtNames.bootlist }
127 :     val pidmapfile = P.joinDirFile { dir = bootdir, file = BtNames.pidmap }
128 : blume 329
129 : blume 666 val penv = SrcPath.newEnv ()
130 : blume 735 val _ = SafeIO.perform { openIt = fn () => TextIO.openIn penvspec,
131 :     closeIt = TextIO.closeIn,
132 :     work = SrcPath.processSpecFile
133 :     { env = penv, specfile = penvspec,
134 :     say = Say.say },
135 :     cleanup = fn _ => () }
136 : blume 676 val _ = SrcPath.sync ()
137 : blume 329
138 : blume 666 fun stdpath s =
139 :     SrcPath.file (SrcPath.standard
140 :     { err = fn s => raise Fail s, env = penv }
141 :     { context = ctxt, spec = s })
142 : blume 352
143 :     val initgspec = stdpath initgspec
144 : blume 456 val maingspec =
145 :     case root of
146 :     NONE => stdpath maingspec
147 : blume 666 | SOME r => SrcPath.decode penv r
148 : blume 352
149 : blume 364 val fnpolicy =
150 : blume 357 FilenamePolicy.separate { bindir = bindir, bootdir = bootdir }
151 :     { arch = arch, os = os }
152 :    
153 : blume 1058 fun param slave_mode =
154 : blume 537 { fnpolicy = fnpolicy,
155 : blume 666 penv = penv,
156 : blume 433 symval = SSV.symval,
157 : blume 873 archos = archos,
158 : blume 1058 keep_going = keep_going,
159 :     slave_mode = slave_mode }
160 : blume 349
161 : blume 905 val emptydyn = DynamicEnv.empty
162 : blume 327
163 :     (* first, build an initial GeneralParam.info, so we can
164 :     * deal with the pervasive env and friends... *)
165 :    
166 :     val groupreg = GroupReg.new ()
167 :     val errcons = EM.defaultConsumer ()
168 : blume 1058 val ginfo = { param = param false, groupreg = groupreg,
169 : blume 692 errcons = errcons,
170 :     youngest = ref TStamp.ancient }
171 : blume 327
172 : blume 449 fun mk_main_compile arg = let
173 : blume 450
174 : blume 592 val { pervasive = perv_n, others, src } = arg
175 : blume 327
176 : blume 569 fun recompInitGroup () = let
177 : blume 879 val ovldR = Control.overloadKW
178 : blume 569 val savedOvld = !ovldR
179 :     val _ = ovldR := true
180 :     val sbnode = Compile.newSbnodeTraversal ()
181 : blume 329
182 : blume 569 val perv_fsbnode = (NONE, perv_n)
183 : blume 327
184 : blume 771 fun rt n = valOf (sbnode n ginfo)
185 : blume 569 val pervasive = rt perv_n
186 : blume 537
187 : blume 569 fun rt2ie (n, ii: IInfo.info) = let
188 : blume 587 val s = #statenv ii ()
189 :     val (dae, mkDomain) = Statenv2DAEnv.cvt s
190 : blume 652 val domain = mkDomain ()
191 : blume 569 in
192 : blume 652 { ie = (fn () => (NONE, n), dae, domain), domain = domain }
193 : blume 569 end
194 : blume 537
195 : blume 569 fun add_exports (n, exports) = let
196 : blume 652 val { ie, domain } = rt2ie (n, rt n)
197 : blume 569 fun ins_ie (sy, m) = SymbolMap.insert (m, sy, ie)
198 :     in
199 : blume 652 SymbolSet.foldl ins_ie exports domain
200 : blume 569 end
201 :    
202 :     val special_exports = let
203 :     fun mkie (n, rtn) = #ie (rt2ie (n, rtn))
204 :     in
205 : blume 592 SymbolMap.insert (SymbolMap.empty,
206 :     PervAccess.pervStrSym,
207 :     mkie (perv_n, pervasive))
208 : blume 569 end
209 : blume 537 in
210 : blume 592 GG.GROUP { exports = foldl add_exports special_exports others,
211 : blume 632 kind = GG.LIB {
212 :     kind = GG.DEVELOPED { wrapped = StringSet.empty,
213 : blume 592 subgroups = [] },
214 : blume 632 version = NONE },
215 : blume 592 required = StringSet.singleton "primitive",
216 :     grouppath = initgspec,
217 : blume 642 (* hack: sources never used for this group *)
218 :     sources = SrcPathMap.empty,
219 : blume 592 sublibs = [] }
220 : blume 1137 before ovldR := savedOvld
221 : blume 537 end
222 : blume 327
223 : blume 569 (* just go and load the stable init group or signal failure *)
224 :     fun loadInitGroup () = let
225 :     val lsarg =
226 :     { getGroup = fn _ => raise Fail "CMB: initial getGroup",
227 :     anyerrors = ref false }
228 : blume 537 in
229 : blume 666 case Stabilize.loadStable lsarg (ginfo, initgspec, NONE, []) of
230 : blume 569 NONE => NONE
231 : blume 592 | SOME (g as GG.GROUP { exports, ... }) => SOME g
232 : blume 587 | SOME GG.ERRORGROUP => NONE
233 : blume 537 end
234 : blume 569
235 :     (* Don't try to load the stable init group. Instead, recompile
236 :     * directly. *)
237 :     fun dontLoadInitGroup () = let
238 : blume 771 (* Function recompileInitGroup will not use servers (hence no
239 :     * call to Servers.withServers), but since compile traversals
240 :     * invoke the scheduler anyway, we must still clear pending
241 :     * tasks when we hit an error or an interrupt. *)
242 :     val g0 = SafeIO.perform { openIt = fn () => (),
243 :     closeIt = fn () => (),
244 :     work = recompInitGroup,
245 :     cleanup = Servers.reset }
246 : blume 759 val stabarg = { group = g0, anyerrors = ref false,
247 :     rebindings = [] }
248 : blume 569 in
249 : blume 801 if master then
250 : blume 592 case Stabilize.stabilize ginfo stabarg of
251 : blume 805 SOME g => (Parse.reset (); g)
252 : blume 569 | NONE => raise Fail "CMB: cannot stabilize init group"
253 : blume 592 else g0
254 : blume 569 end
255 : blume 327
256 : blume 569 (* Try loading the init group from the stable file if possible;
257 :     * recompile if loading fails *)
258 :     fun tryLoadInitGroup () =
259 :     case loadInitGroup () of
260 :     SOME g => g
261 :     | NONE => dontLoadInitGroup ()
262 :    
263 :     (* Ok, now, based on "paranoid" and stable verification,
264 :     * call the appropriate function(s) to get the init group. *)
265 : blume 592 val init_group =
266 : blume 801 if master then let
267 : blume 592 val export_nodes = perv_n :: others
268 : blume 569 val ver_arg = (initgspec, export_nodes, [],
269 : blume 632 SrcPathSet.empty, NONE)
270 : blume 569 val em = StableMap.empty
271 : blume 537 in
272 : blume 592 if VerifyStable.verify' ginfo em ver_arg then
273 : blume 569 tryLoadInitGroup ()
274 :     else dontLoadInitGroup ()
275 : blume 537 end
276 : blume 801 else valOf (loadInitGroup ()) (* failure caught at the end *)
277 : blume 356
278 : blume 537 val gr = GroupReg.new ()
279 :     val _ = GroupReg.register gr (initgspec, src)
280 :    
281 : blume 1058 fun parse_arg0 slave_mode (s, p) =
282 : blume 537 { load_plugin = load_plugin,
283 :     gr = gr,
284 : blume 1058 param = param slave_mode,
285 : blume 801 stabflag = s,
286 : blume 537 group = maingspec,
287 :     init_group = init_group,
288 : blume 801 paranoid = p }
289 :    
290 : blume 1058 val parse_arg = parse_arg0 false
291 :     val slave_parse_arg = parse_arg0 true
292 :    
293 : blume 801 val lonely_master = master andalso Servers.noServers ()
294 :    
295 : blume 805 val initial_parse_result =
296 :     if master then
297 :     if lonely_master then
298 : blume 854 (* no slaves available; do everything alone
299 :     * (Still wrap "withServers" around it to make sure
300 :     * our queues get cleaned when an interrupt or error
301 :     * occurs.) *)
302 :     Servers.withServers
303 : blume 1058 (fn () => Parse.parse(parse_arg (SOME true, true)))
304 : blume 805 else
305 :     (* slaves available; we want master
306 :     * and slave initialization to overlap, so
307 :     * we do the master's parsing in its own
308 :     * thread *)
309 :     let fun worker () = let
310 :     val c =
311 :     Concur.fork
312 :     (fn () => Parse.parse
313 :     (parse_arg (NONE, true)))
314 :     in
315 :     Servers.cmb
316 :     { dirbase = dirbase,
317 :     archos = archos,
318 :     root = SrcPath.encode maingspec };
319 :     Concur.wait c
320 :     end
321 :     in
322 :     Servers.withServers worker
323 :     end
324 :     else
325 :     (* slave case *)
326 : blume 1058 Parse.parse (slave_parse_arg (NONE, false))
327 : blume 327 in
328 : blume 805 case initial_parse_result of
329 : blume 449 NONE => NONE
330 : blume 399 | SOME (g, gp) => let
331 : blume 801 fun finish (g, gp) = let
332 :     val { l = bootitems, ss } = mkBootList g
333 : mblume 1656 val bootitems = map #2 bootitems
334 : blume 801 val stablelibs = Reachable.stableLibsOf g
335 :     fun inSet bi = StableSet.member (ss, bi)
336 :     val frontiers =
337 :     SrcPathMap.map (Reachable.frontier inSet)
338 :     stablelibs
339 :     fun writeBootList s = let
340 :     fun wr str = TextIO.output (s, str ^ "\n")
341 :     val numitems = length bootitems
342 :     fun biggerlen (s, n) = Int.max (size s, n)
343 :     val maxlen = foldl biggerlen 0 bootitems
344 : blume 349 in
345 : blume 801 wr (concat ["%", Int.toString numitems,
346 :     " ", Int.toString maxlen]);
347 :     app wr bootitems
348 : blume 349 end
349 : blume 801 fun writePid s i = let
350 :     val sn = BinInfo.stablename i
351 :     val os = BinInfo.offset i
352 :     val descr = BinInfo.describe i
353 :     val bfc = BFC.getStable { stable = sn, offset = os,
354 :     descr = descr }
355 :     in
356 :     case BF.exportPidOf bfc of
357 :     NONE => ()
358 :     | SOME pid =>
359 :     app (fn str => TextIO.output (s, str))
360 :     [" ", Int.toString os, ":", PS.toHex pid]
361 :     end
362 :     fun writePidLine s (p, set) =
363 :     if StableSet.isEmpty set then ()
364 :     else (TextIO.output (s, SrcPath.encode p);
365 :     StableSet.app (writePid s) set;
366 :     TextIO.output (s, "\n"))
367 :     fun writePidMap s =
368 :     SrcPathMap.appi (writePidLine s) frontiers
369 :     in
370 :     SafeIO.perform
371 :     { openIt = fn () => AutoDir.openTextOut listfile,
372 :     closeIt = TextIO.closeOut,
373 :     work = writeBootList,
374 :     cleanup = fn _ => (OS.FileSys.remove listfile
375 :     handle _ => ()) };
376 :     SafeIO.perform
377 :     { openIt = fn () => AutoDir.openTextOut pidmapfile,
378 :     closeIt = TextIO.closeOut,
379 :     work = writePidMap,
380 :     cleanup = fn _ => (OS.FileSys.remove pidmapfile
381 :     handle _ => ()) };
382 :     Say.say ["New boot directory has been built.\n"];
383 :     true
384 :     end
385 :    
386 :     (* the following thunk represents phase 2 (stabilization)
387 :     * of the master's execution path; it is never
388 :     * executed in slave mode *)
389 :     fun stabilize () =
390 :     (* now we re-parse everything with stabilization
391 : blume 1058 * turned on (and servers turned off) *)
392 : blume 801 case Parse.parse (parse_arg (SOME true, false)) of
393 :     NONE => false
394 :     | SOME (g, gp) => finish (g, gp)
395 :    
396 :     (* Don't do another traversal if this is a lonely master *)
397 :     fun just_stabilize () = finish (g, gp)
398 :    
399 :     (* the following thunk is executed in "master" mode only;
400 :     * slaves just throw it away *)
401 :     fun compile_and_stabilize () = let
402 :    
403 :     (* make compilation traversal and execute it *)
404 :     val { allgroups, ... } =
405 :     Compile.newTraversal (fn _ => fn _ => (),
406 :     fn _ => (),
407 :     g)
408 :     in
409 :     if Servers.withServers (fn () => allgroups gp) then
410 :     (Compile.reset ();
411 :     stabilize ())
412 : blume 449 else false
413 : blume 349 end
414 : blume 449 in
415 : blume 801 SOME ((g, gp, penv),
416 :     if lonely_master then just_stabilize
417 :     else compile_and_stabilize)
418 : blume 399 end
419 : blume 449 end handle Option => (Compile.reset (); NONE)
420 : blume 801 (* to catch valOf failures in "rt" or slave's failure
421 :     * to load init group *)
422 : blume 327 in
423 : blume 592 case BuildInitDG.build ginfo initgspec of
424 : blume 449 SOME x => mk_main_compile x
425 :     | NONE => NONE
426 : blume 327 end
427 : blume 362
428 : blume 569 fun compile dbopt =
429 : blume 632 (StabModmap.reset ();
430 : blume 801 case mk_compile { master = true, root = NONE, dirbase = dbopt } of
431 : blume 632 NONE => false
432 : blume 805 | SOME (_, thunk) => thunk ())
433 : blume 449
434 :     local
435 : blume 805 fun slave NONE = (internal_reset (); NONE)
436 : blume 632 | slave (SOME (dirbase, root)) =
437 : blume 805 (StabModmap.reset ();
438 : mblume 1640 #set (SSV.symval "CMB_SLAVE_MODE") (SOME 1);
439 : dbm 2611 #set (SSV.symval "NO_PLUGINS") (SOME 1);
440 : blume 805 case mk_compile { master = false, root = SOME root,
441 :     dirbase = SOME dirbase } of
442 :     NONE => NONE
443 :     | SOME ((g, gp, penv), _) => let
444 :     val trav = Compile.newSbnodeTraversal ()
445 :     fun trav' sbn = isSome (trav sbn gp)
446 :     in
447 :     SOME (g, trav', penv)
448 :     end)
449 : blume 449 in
450 : blume 452 val _ = CMBSlaveHook.init archos slave
451 : blume 449 end
452 :    
453 : blume 569 val make' = compile
454 : blume 377 fun make () = make' NONE
455 : blume 434 val symval = SSV.symval
456 : blume 327 end
457 : blume 569 end (* local *)

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0