Annotation of /sml/trunk/src/cm/bootstrap/btcompile.sml

Parent Directory | Revision Log

---

Revision 854 - (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 :			structure EM = GenericVC.ErrorMsg
11 :			structure E = GenericVC.Environment
12 :	blume	587	structure SE = GenericVC.StaticEnv
13 :	blume	569	structure PS = GenericVC.PersStamps
14 :			structure GG = GroupGraph
15 :			structure DG = DependencyGraph
16 :			in
17 :	blume	578	functor BootstrapCompileFn
18 :			(structure MachDepVC : MACHDEP_VC
19 :	blume	677	val useStream : TextIO.instream -> unit
20 :	blume	578	val os : SMLofNJ.SysInfo.os_kind
21 :	blume	734	val load_plugin : SrcPath.dir -> string -> bool) =
22 :			struct
23 :	blume	336	structure SSV = SpecificSymValFn (structure MachDepVC = MachDepVC
24 :			val os = os)
25 :	blume	364	structure P = OS.Path
26 :			structure F = OS.FileSys
27 :	blume	403	structure BF = MachDepVC.Binfile
28 :	blume	327
29 :	blume	452	val arch = MachDepVC.architecture
30 :			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	448	structure Compile = CompileFn (structure MachDepVC = MachDepVC
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	403	structure BFC = BfcFn (structure MachDepVC = MachDepVC)
43 :
44 :	blume	327	(* instantiate Stabilize... *)
45 :	blume	329	structure Stabilize =
46 :	blume	537	StabilizeFn (structure MachDepVC = MachDepVC
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	592	val param =
154 :	blume	537	{ fnpolicy = fnpolicy,
155 :	blume	666	penv = penv,
156 :	blume	433	symval = SSV.symval,
157 :	blume	592	keep_going = keep_going }
158 :	blume	349
159 :	blume	327	val emptydyn = E.dynamicPart E.emptyEnv
160 :
161 :			(* first, build an initial GeneralParam.info, so we can
162 :			* deal with the pervasive env and friends... *)
163 :
164 :			val groupreg = GroupReg.new ()
165 :			val errcons = EM.defaultConsumer ()
166 :	blume	692	val ginfo = { param = param, groupreg = groupreg,
167 :			errcons = errcons,
168 :			youngest = ref TStamp.ancient }
169 :	blume	327
170 :	blume	449	fun mk_main_compile arg = let
171 :	blume	450
172 :	blume	592	val { pervasive = perv_n, others, src } = arg
173 :	blume	327
174 :	blume	569	fun recompInitGroup () = let
175 :			val ovldR = GenericVC.Control.overloadKW
176 :			val savedOvld = !ovldR
177 :			val _ = ovldR := true
178 :			val sbnode = Compile.newSbnodeTraversal ()
179 :	blume	329
180 :	blume	569	val perv_fsbnode = (NONE, perv_n)
181 :	blume	327
182 :	blume	771	fun rt n = valOf (sbnode n ginfo)
183 :	blume	569	val pervasive = rt perv_n
184 :	blume	537
185 :	blume	569	fun rt2ie (n, ii: IInfo.info) = let
186 :	blume	587	val s = #statenv ii ()
187 :			val (dae, mkDomain) = Statenv2DAEnv.cvt s
188 :	blume	652	val domain = mkDomain ()
189 :	blume	569	in
190 :	blume	652	{ ie = (fn () => (NONE, n), dae, domain), domain = domain }
191 :	blume	569	end
192 :	blume	537
193 :	blume	569	fun add_exports (n, exports) = let
194 :	blume	652	val { ie, domain } = rt2ie (n, rt n)
195 :	blume	569	fun ins_ie (sy, m) = SymbolMap.insert (m, sy, ie)
196 :			in
197 :	blume	652	SymbolSet.foldl ins_ie exports domain
198 :	blume	569	end
199 :
200 :			val special_exports = let
201 :			fun mkie (n, rtn) = #ie (rt2ie (n, rtn))
202 :			in
203 :	blume	592	SymbolMap.insert (SymbolMap.empty,
204 :			PervAccess.pervStrSym,
205 :			mkie (perv_n, pervasive))
206 :	blume	569	end
207 :	blume	537	in
208 :	blume	592	GG.GROUP { exports = foldl add_exports special_exports others,
209 :	blume	632	kind = GG.LIB {
210 :			kind = GG.DEVELOPED { wrapped = StringSet.empty,
211 :	blume	592	subgroups = [] },
212 :	blume	632	version = NONE },
213 :	blume	592	required = StringSet.singleton "primitive",
214 :			grouppath = initgspec,
215 :	blume	642	(* hack: sources never used for this group *)
216 :			sources = SrcPathMap.empty,
217 :	blume	592	sublibs = [] }
218 :	blume	569	before (ovldR := savedOvld)
219 :	blume	537	end
220 :	blume	327
221 :	blume	569	(* just go and load the stable init group or signal failure *)
222 :			fun loadInitGroup () = let
223 :			val lsarg =
224 :			{ getGroup = fn _ => raise Fail "CMB: initial getGroup",
225 :			anyerrors = ref false }
226 :	blume	537	in
227 :	blume	666	case Stabilize.loadStable lsarg (ginfo, initgspec, NONE, []) of
228 :	blume	569	NONE => NONE
229 :	blume	592	| SOME (g as GG.GROUP { exports, ... }) => SOME g
230 :	blume	587	| SOME GG.ERRORGROUP => NONE
231 :	blume	537	end
232 :	blume	569
233 :			(* Don't try to load the stable init group. Instead, recompile
234 :			* directly. *)
235 :			fun dontLoadInitGroup () = let
236 :	blume	771	(* Function recompileInitGroup will not use servers (hence no
237 :			* call to Servers.withServers), but since compile traversals
238 :			* invoke the scheduler anyway, we must still clear pending
239 :			* tasks when we hit an error or an interrupt. *)
240 :			val g0 = SafeIO.perform { openIt = fn () => (),
241 :			closeIt = fn () => (),
242 :			work = recompInitGroup,
243 :			cleanup = Servers.reset }
244 :	blume	759	val stabarg = { group = g0, anyerrors = ref false,
245 :			rebindings = [] }
246 :	blume	569	in
247 :	blume	801	if master then
248 :	blume	592	case Stabilize.stabilize ginfo stabarg of
249 :	blume	805	SOME g => (Parse.reset (); g)
250 :	blume	569	| NONE => raise Fail "CMB: cannot stabilize init group"
251 :	blume	592	else g0
252 :	blume	569	end
253 :	blume	327
254 :	blume	569	(* Try loading the init group from the stable file if possible;
255 :			* recompile if loading fails *)
256 :			fun tryLoadInitGroup () =
257 :			case loadInitGroup () of
258 :			SOME g => g
259 :			| NONE => dontLoadInitGroup ()
260 :
261 :			(* Ok, now, based on "paranoid" and stable verification,
262 :			* call the appropriate function(s) to get the init group. *)
263 :	blume	592	val init_group =
264 :	blume	801	if master then let
265 :	blume	592	val export_nodes = perv_n :: others
266 :	blume	569	val ver_arg = (initgspec, export_nodes, [],
267 :	blume	632	SrcPathSet.empty, NONE)
268 :	blume	569	val em = StableMap.empty
269 :	blume	537	in
270 :	blume	592	if VerifyStable.verify' ginfo em ver_arg then
271 :	blume	569	tryLoadInitGroup ()
272 :			else dontLoadInitGroup ()
273 :	blume	537	end
274 :	blume	801	else valOf (loadInitGroup ()) (* failure caught at the end *)
275 :	blume	356
276 :	blume	537	val gr = GroupReg.new ()
277 :			val _ = GroupReg.register gr (initgspec, src)
278 :
279 :	blume	801	fun parse_arg (s, p) =
280 :	blume	537	{ load_plugin = load_plugin,
281 :			gr = gr,
282 :			param = param,
283 :	blume	801	stabflag = s,
284 :	blume	537	group = maingspec,
285 :			init_group = init_group,
286 :	blume	801	paranoid = p }
287 :
288 :			val lonely_master = master andalso Servers.noServers ()
289 :
290 :	blume	805	val initial_parse_result =
291 :			if master then
292 :			if lonely_master then
293 :	blume	854	(* no slaves available; do everything alone
294 :			* (Still wrap "withServers" around it to make sure
295 :			* our queues get cleaned when an interrupt or error
296 :			* occurs.) *)
297 :			Servers.withServers
298 :			(fn () => Parse.parse (parse_arg (SOME true, true)))
299 :	blume	805	else
300 :			(* slaves available; we want master
301 :			* and slave initialization to overlap, so
302 :			* we do the master's parsing in its own
303 :			* thread *)
304 :			let fun worker () = let
305 :			val c =
306 :			Concur.fork
307 :			(fn () => Parse.parse
308 :			(parse_arg (NONE, true)))
309 :			in
310 :			Servers.cmb
311 :			{ dirbase = dirbase,
312 :			archos = archos,
313 :			root = SrcPath.encode maingspec };
314 :			Concur.wait c
315 :			end
316 :			in
317 :			Servers.withServers worker
318 :			end
319 :			else
320 :			(* slave case *)
321 :			Parse.parse (parse_arg (NONE, false))
322 :	blume	327	in
323 :	blume	805	case initial_parse_result of
324 :	blume	449	NONE => NONE
325 :	blume	399	| SOME (g, gp) => let
326 :	blume	801	fun finish (g, gp) = let
327 :			val { l = bootitems, ss } = mkBootList g
328 :			val stablelibs = Reachable.stableLibsOf g
329 :			fun inSet bi = StableSet.member (ss, bi)
330 :			val frontiers =
331 :			SrcPathMap.map (Reachable.frontier inSet)
332 :			stablelibs
333 :			fun writeBootList s = let
334 :			fun wr str = TextIO.output (s, str ^ "\n")
335 :			val numitems = length bootitems
336 :			fun biggerlen (s, n) = Int.max (size s, n)
337 :			val maxlen = foldl biggerlen 0 bootitems
338 :	blume	349	in
339 :	blume	801	wr (concat ["%", Int.toString numitems,
340 :			" ", Int.toString maxlen]);
341 :			app wr bootitems
342 :	blume	349	end
343 :	blume	801	fun writePid s i = let
344 :			val sn = BinInfo.stablename i
345 :			val os = BinInfo.offset i
346 :			val descr = BinInfo.describe i
347 :			val bfc = BFC.getStable { stable = sn, offset = os,
348 :			descr = descr }
349 :			in
350 :			case BF.exportPidOf bfc of
351 :			NONE => ()
352 :			| SOME pid =>
353 :			app (fn str => TextIO.output (s, str))
354 :			[" ", Int.toString os, ":", PS.toHex pid]
355 :			end
356 :			fun writePidLine s (p, set) =
357 :			if StableSet.isEmpty set then ()
358 :			else (TextIO.output (s, SrcPath.encode p);
359 :			StableSet.app (writePid s) set;
360 :			TextIO.output (s, "\n"))
361 :			fun writePidMap s =
362 :			SrcPathMap.appi (writePidLine s) frontiers
363 :			in
364 :			SafeIO.perform
365 :			{ openIt = fn () => AutoDir.openTextOut listfile,
366 :			closeIt = TextIO.closeOut,
367 :			work = writeBootList,
368 :			cleanup = fn _ => (OS.FileSys.remove listfile
369 :			handle _ => ()) };
370 :			SafeIO.perform
371 :			{ openIt = fn () => AutoDir.openTextOut pidmapfile,
372 :			closeIt = TextIO.closeOut,
373 :			work = writePidMap,
374 :			cleanup = fn _ => (OS.FileSys.remove pidmapfile
375 :			handle _ => ()) };
376 :			Say.say ["New boot directory has been built.\n"];
377 :			true
378 :			end
379 :
380 :			(* the following thunk represents phase 2 (stabilization)
381 :			* of the master's execution path; it is never
382 :			* executed in slave mode *)
383 :			fun stabilize () =
384 :			(* now we re-parse everything with stabilization
385 :			* turnedon (and servers turned off *)
386 :			case Parse.parse (parse_arg (SOME true, false)) of
387 :			NONE => false
388 :			| SOME (g, gp) => finish (g, gp)
389 :
390 :			(* Don't do another traversal if this is a lonely master *)
391 :			fun just_stabilize () = finish (g, gp)
392 :
393 :			(* the following thunk is executed in "master" mode only;
394 :			* slaves just throw it away *)
395 :			fun compile_and_stabilize () = let
396 :
397 :			(* make compilation traversal and execute it *)
398 :			val { allgroups, ... } =
399 :			Compile.newTraversal (fn _ => fn _ => (),
400 :			fn _ => (),
401 :			g)
402 :			in
403 :			if Servers.withServers (fn () => allgroups gp) then
404 :			(Compile.reset ();
405 :			stabilize ())
406 :	blume	449	else false
407 :	blume	349	end
408 :	blume	449	in
409 :	blume	801	SOME ((g, gp, penv),
410 :			if lonely_master then just_stabilize
411 :			else compile_and_stabilize)
412 :	blume	399	end
413 :	blume	449	end handle Option => (Compile.reset (); NONE)
414 :	blume	801	(* to catch valOf failures in "rt" or slave's failure
415 :			* to load init group *)
416 :	blume	327	in
417 :	blume	592	case BuildInitDG.build ginfo initgspec of
418 :	blume	449	SOME x => mk_main_compile x
419 :			| NONE => NONE
420 :	blume	327	end
421 :	blume	362
422 :	blume	569	fun compile dbopt =
423 :	blume	632	(StabModmap.reset ();
424 :	blume	801	case mk_compile { master = true, root = NONE, dirbase = dbopt } of
425 :	blume	632	NONE => false
426 :	blume	805	| SOME (_, thunk) => thunk ())
427 :	blume	449
428 :			local
429 :	blume	805	fun slave NONE = (internal_reset (); NONE)
430 :	blume	632	| slave (SOME (dirbase, root)) =
431 :	blume	805	(StabModmap.reset ();
432 :			case mk_compile { master = false, root = SOME root,
433 :			dirbase = SOME dirbase } of
434 :			NONE => NONE
435 :			| SOME ((g, gp, penv), _) => let
436 :			val trav = Compile.newSbnodeTraversal ()
437 :			fun trav' sbn = isSome (trav sbn gp)
438 :			in
439 :			SOME (g, trav', penv)
440 :			end)
441 :	blume	449	in
442 :	blume	452	val _ = CMBSlaveHook.init archos slave
443 :	blume	449	end
444 :
445 :	blume	569	val make' = compile
446 :	blume	377	fun make () = make' NONE
447 :	blume	434	val symval = SSV.symval
448 :	blume	327	end
449 :	blume	569	end (* local *)

---

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