Annotation of /sml/trunk/src/cm/main/cm-boot.sml

Parent Directory | Revision Log

---

Revision 1595 - (view) (download)

1 :	blume	375	(*
2 :			* This is the module that actually puts together the contents of the
3 :	blume	801	* structure CM people find in $smlnj/cm/full.cm.
4 :	blume	375	*
5 :	blume	756	* Copyright (c) 1999, 2000 by Lucent Bell Laboratories
6 :	blume	375	*
7 :			* author: Matthias Blume (blume@cs.princeton.edu)
8 :			*)
9 :	blume	879	functor LinkCM (structure HostBackend : BACKEND) = struct
10 :	blume	375
11 :			datatype envrequest = AUTOLOAD | BARE
12 :
13 :			local
14 :	blume	879	structure E = Environment
15 :	blume	569	structure DE = DynamicEnv
16 :	blume	879	structure SE = StaticEnv
17 :			structure ER = EnvRef
18 :			structure S = Symbol
19 :			structure EM = ErrorMsg
20 :	blume	380	structure P = OS.Path
21 :			structure F = OS.FileSys
22 :	blume	451	structure DG = DependencyGraph
23 :	blume	587	structure GG = GroupGraph
24 :	blume	737	structure IM = IntMap
25 :	blume	375
26 :			val os = SMLofNJ.SysInfo.getOSKind ()
27 :	blume	464	val my_archos =
28 :	blume	879	concat [HostBackend.architecture, "-", FilenamePolicy.kind2name os]
29 :	blume	375
30 :			structure SSV =
31 :	blume	879	SpecificSymValFn (val arch = HostBackend.architecture
32 :	blume	375	val os = os)
33 :
34 :	blume	737	val system_values =
35 :			ref (SrcPathMap.empty: E.dynenv IntMap.map SrcPathMap.map)
36 :	blume	375
37 :	blume	588	structure StabModmap = StabModmapFn ()
38 :
39 :	blume	905	val useStreamHook =
40 :			ref (fn _ => raise Fail "useStreamHook not initialized")
41 :			: (TextIO.instream -> unit) ref
42 :
43 :	blume	400	structure Compile =
44 :	blume	879	CompileFn (structure Backend = HostBackend
45 :	blume	588	structure StabModmap = StabModmap
46 :	blume	905	fun useStream s = !useStreamHook s
47 :	blume	801	val compile_there = Servers.compile o SrcPath.encode)
48 :	blume	400
49 :	blume	537	structure BFC =
50 :	blume	879	BfcFn (val arch = HostBackend.architecture)
51 :	blume	537
52 :	blume	399	structure Link =
53 :	blume	1186	LinkFn (structure BFC = BFC
54 :	blume	399	val system_values = system_values)
55 :	blume	375
56 :			structure AutoLoad = AutoLoadFn
57 :	blume	399	(structure C = Compile
58 :	blume	403	structure L = Link
59 :			structure BFC = BFC)
60 :	blume	375
61 :	blume	537	val mkBootList = #l o MkBootList.group (fn p => p)
62 :
63 :	blume	587	fun init_servers (GG.GROUP { grouppath, ... }) =
64 :	blume	801	Servers.cm { archos = my_archos, project = SrcPath.encode grouppath }
65 :	blume	587	| init_servers GG.ERRORGROUP = ()
66 :	blume	456
67 :	blume	399	fun recomp_runner gp g = let
68 :	blume	456	val _ = init_servers g
69 :	blume	403	fun store _ = ()
70 :			val { group, ... } = Compile.newTraversal (Link.evict, store, g)
71 :	blume	399	in
72 :	blume	450	isSome (Servers.withServers (fn () => group gp))
73 :			before Link.cleanup gp
74 :	blume	399	end
75 :	blume	375
76 :			(* This function combines the actions of "recompile" and "exec".
77 :			* When successful, it combines the results (thus forming a full
78 :			* environment) and adds it to the toplevel environment. *)
79 :	blume	587	fun make_runner _ _ GG.ERRORGROUP = false
80 :			| make_runner add_bindings gp (g as GG.GROUP grec) = let
81 :			val { required = rq, ... } = grec
82 :			val { store, get } = BFC.new ()
83 :			val _ = init_servers g
84 :			val { group = c_group, ... } =
85 :			Compile.newTraversal (Link.evict, store, g)
86 :	blume	771	val { group = l_group, ... } =
87 :	blume	879	Link.newTraversal (g, #contents o get)
88 :	blume	587	in
89 :			case Servers.withServers (fn () => c_group gp) of
90 :			NONE => false
91 :			| SOME { stat, sym} =>
92 :	blume	537	(* Before executing the code, we announce the privileges
93 :	blume	399	* that are being invoked. (For the time being, we assume
94 :			* that everybody has every conceivable privilege, but at
95 :			* the very least we announce which ones are being made
96 :			* use of.) *)
97 :	blume	400	(Link.cleanup gp;
98 :	blume	399	if StringSet.isEmpty rq then ()
99 :			else Say.say ("$Execute: required privileges are:\n" ::
100 :			map (fn s => (" " ^ s ^ "\n")) (StringSet.listItems rq));
101 :			case l_group gp of
102 :	blume	375	NONE => false
103 :	blume	518	| SOME dyn =>
104 :			(if add_bindings then
105 :			let val delta = E.mkenv { static = stat,
106 :			symbolic = sym,
107 :			dynamic = dyn }
108 :	blume	905	val loc = ER.loc ()
109 :			val base = #get loc ()
110 :	blume	587	val new = E.concatEnv (delta, base)
111 :	blume	518	in
112 :	blume	905	#set loc new;
113 :	blume	518	Say.vsay ["[New bindings added.]\n"]
114 :			end
115 :			else ();
116 :			true))
117 :	blume	587	end
118 :	blume	375
119 :			val al_greg = GroupReg.new ()
120 :
121 :			(* Instantiate the stabilization mechanism. *)
122 :			structure Stabilize =
123 :	blume	879	StabilizeFn (val arch = HostBackend.architecture
124 :	blume	588	structure StabModmap = StabModmap
125 :	blume	403	fun recomp gp g = let
126 :			val { store, get } = BFC.new ()
127 :			val { group, ... } =
128 :			Compile.newTraversal (Link.evict, store, g)
129 :			in
130 :	blume	801	case group gp of
131 :	blume	403	NONE => NONE
132 :			| SOME _ => SOME get
133 :			end
134 :			val getII = Compile.getII)
135 :	blume	375
136 :			(* Access to the stabilization mechanism is integrated into the
137 :			* parser. I'm not sure if this is the cleanest way, but it works
138 :			* well enough. *)
139 :			structure Parse = ParseFn (structure Stabilize = Stabilize
140 :	blume	588	structure StabModmap = StabModmap
141 :	blume	537	fun evictStale () =
142 :			(Compile.evictStale ();
143 :			Link.evictStale ())
144 :	blume	375	val pending = AutoLoad.getPending)
145 :
146 :			local
147 :	blume	592	type kernelValues = { init_group : GG.group }
148 :	blume	375
149 :			val fnpolicy = FilenamePolicy.colocate
150 :	blume	879	{ os = os, arch = HostBackend.architecture }
151 :	blume	375
152 :			val theValues = ref (NONE: kernelValues option)
153 :
154 :			in
155 :	blume	666	val penv = SrcPath.newEnv ()
156 :	blume	645
157 :	blume	377	(* cancelling anchors cannot affect the order of existing paths
158 :			* (it may invalidate some paths; but all other ones stay as
159 :			* they are) *)
160 :	blume	666	fun setAnchor a v = SrcPath.set_anchor (penv, a, v)
161 :	blume	377	(* same goes for reset because it just cancels all anchors... *)
162 :	blume	666	fun resetPathConfig () = SrcPath.reset_anchors penv
163 :	blume	569	(* get the current binding for an anchor *)
164 :	blume	666	fun getAnchor a () = SrcPath.get_anchor (penv, a)
165 :	blume	375
166 :	blume	525	fun mkStdSrcPath s =
167 :	blume	666	SrcPath.file
168 :			(SrcPath.standard { err = fn s => raise Fail s, env = penv }
169 :			{ context = SrcPath.cwd (), spec = s })
170 :	blume	525
171 :	blume	1068	fun getPending () =
172 :			map (Symbol.describe o #1)
173 :			(SymbolMap.listItemsi (AutoLoad.getPending ()))
174 :
175 :			fun showBindings () = let
176 :			val loaded = map Symbol.describe (EnvRef.listBoundSymbols ())
177 :			val pending = getPending ()
178 :			fun pr s = Say.say [s, "\n"]
179 :	blume	375	in
180 :	blume	1068	Say.say ["\n*** Symbols bound at toplevel:\n"];
181 :			app pr loaded;
182 :			Say.say ["\n*** Symbols registered for autoloading:\n"];
183 :			app pr pending
184 :	blume	375	end
185 :
186 :			fun initPaths () = let
187 :	blume	433	val lpcth = #get StdConfig.local_pathconfig ()
188 :	blume	375	val p = case lpcth () of
189 :			NONE => []
190 :			| SOME f => [f]
191 :	blume	1261	val p = #get StdConfig.pathcfgspec () () :: p
192 :	blume	735	fun processOne f = let
193 :			val work = SrcPath.processSpecFile
194 :			{ env = penv, specfile = f, say = Say.say }
195 :			in
196 :			SafeIO.perform { openIt = fn () => TextIO.openIn f,
197 :			closeIt = TextIO.closeIn,
198 :			work = work,
199 :			cleanup = fn _ => () }
200 :			end handle _ => ()
201 :	blume	375	in
202 :	blume	676	app processOne p;
203 :			SrcPath.sync ()
204 :	blume	375	end
205 :
206 :	blume	537	fun getTheValues () = valOf (!theValues)
207 :	mblume	1393	handle Option => raise Fail "CMBoot: theValues not initialized"
208 :	blume	537
209 :	blume	1058	fun param slave_mode =
210 :	blume	537	{ fnpolicy = fnpolicy,
211 :	blume	666	penv = penv,
212 :	blume	433	symval = SSV.symval,
213 :	blume	873	archos = my_archos,
214 :	blume	1058	keep_going = #get StdConfig.keep_going (),
215 :			slave_mode = slave_mode }
216 :	blume	375
217 :	blume	537	val init_group = #init_group o getTheValues
218 :
219 :	blume	507	fun dropPickles () =
220 :			if #get StdConfig.conserve_memory () then
221 :			Parse.dropPickles ()
222 :			else ()
223 :
224 :	blume	1058	fun parse_arg0 slave_mode (gr, sflag, p) =
225 :			{ load_plugin = load_plugin, gr = gr, param = param slave_mode,
226 :	blume	569	stabflag = sflag, group = p,
227 :			init_group = init_group (), paranoid = false }
228 :	blume	537
229 :	blume	1058	and parse_arg x = parse_arg0 false x
230 :
231 :			and slave_parse_arg x = parse_arg0 true x
232 :
233 :	blume	537	and autoload s = let
234 :	blume	525	val p = mkStdSrcPath s
235 :	blume	375	in
236 :	blume	537	(case Parse.parse (parse_arg (al_greg, NONE, p)) of
237 :	blume	505	NONE => false
238 :			| SOME (g, _) =>
239 :	blume	905	(AutoLoad.register (EnvRef.loc (), g);
240 :	blume	537	true))
241 :	blume	507	before dropPickles ()
242 :	blume	375	end
243 :
244 :	blume	578	and run mkSrcPath sflag f s = let
245 :			val p = mkSrcPath s
246 :	blume	537	val gr = GroupReg.new ()
247 :	blume	375	in
248 :	blume	537	(case Parse.parse (parse_arg (gr, sflag, p)) of
249 :	blume	505	NONE => false
250 :			| SOME (g, gp) => f gp g)
251 :	blume	507	before dropPickles ()
252 :	blume	375	end
253 :
254 :	blume	735	and load_plugin' p = let
255 :			val d = SrcPath.descr p
256 :			val _ = Say.vsay ["[attempting to load plugin ", d, "]\n"]
257 :			val gr = GroupReg.new ()
258 :	blume	518	val success =
259 :	blume	735	((case Parse.parse (parse_arg (gr, NONE, p)) of
260 :			NONE => false
261 :			| SOME (g, gp) => make_runner false gp g)
262 :			before dropPickles ())
263 :			handle _ => false
264 :	blume	518	in
265 :			if success then
266 :	blume	735	Say.vsay ["[plugin ", d, " loaded successfully]\n"]
267 :	blume	518	else
268 :	blume	735	Say.vsay ["[unable to load plugin ", d, "]\n"];
269 :	blume	518	success
270 :			end
271 :
272 :	blume	735	and load_plugin context s = let
273 :			fun badname s = Say.say ["[bad plugin name: ", s, "]\n"]
274 :			val pp = SrcPath.standard { env = penv, err = badname }
275 :			{ context = context, spec = s }
276 :			in
277 :			load_plugin' (SrcPath.file pp)
278 :			end
279 :
280 :	blume	666	fun cwd_load_plugin x = load_plugin (SrcPath.cwd ()) x
281 :	blume	578
282 :	blume	801	fun stabilize recursively root = let
283 :			fun stabilize_recomp_runner gp g = let
284 :			val _ = init_servers g
285 :			val { allgroups, ... } =
286 :			Compile.newTraversal (Link.evict, fn _ => (), g)
287 :			in
288 :			Servers.withServers (fn () => allgroups gp)
289 :			end
290 :			fun stabilize_dummy_runner gp g = true
291 :			fun phase1 () = run mkStdSrcPath NONE
292 :			stabilize_recomp_runner root
293 :			fun phase2 () = (Compile.reset ();(* a bit too draconian? *)
294 :			run mkStdSrcPath (SOME recursively)
295 :			stabilize_dummy_runner root)
296 :			in
297 :			(* Don't bother with the 2-phase thing if there are
298 :	blume	854	* no compile servers attached. (We still need
299 :			* the "withServers" call to clean up our queues in case
300 :			* of an interrupt or error.) *)
301 :			if Servers.noServers () then Servers.withServers phase2
302 :	blume	801	else
303 :			(* We do this in two phases:
304 :			* 1. recompile everything without stabilization but
305 :			* potentially using compile servers
306 :			* 2. do a local stabilization run (which should have
307 :			* no need to compile anything); don't use servers
308 :			*)
309 :			phase1 () andalso phase2 ()
310 :			end
311 :	blume	449
312 :	blume	578	val recomp = run mkStdSrcPath NONE recomp_runner
313 :			val make = run mkStdSrcPath NONE (make_runner true)
314 :	blume	449
315 :	blume	977	fun to_portable s = let
316 :			val gp = mkStdSrcPath s
317 :			fun nativesrc s = let
318 :			val p = SrcPath.standard
319 :			{ err = fn s => raise Fail s, env = penv }
320 :			{ context = SrcPath.dir gp, spec = s }
321 :			in
322 :			SrcPath.osstring' (SrcPath.file p)
323 :			end
324 :			fun mkres (g, pl) = { graph = g, imports = pl,
325 :			nativesrc = nativesrc }
326 :			in
327 :	blume	975	Option.map
328 :	blume	977	(mkres o ToPortable.export)
329 :	blume	975	(Parse.parse (parse_arg
330 :			(GroupReg.new (), NONE, mkStdSrcPath s)))
331 :	blume	977	end
332 :	blume	975
333 :	blume	642	fun sources archos group = let
334 :			val policy =
335 :			case archos of
336 :			NONE => fnpolicy
337 :			| SOME ao => FilenamePolicy.colocate_generic ao
338 :	blume	666	fun sourcesOf ((p, gth, _), (v, a)) =
339 :	blume	642	if SrcPathSet.member (v, p) then (v, a)
340 :			else
341 :			let val v = SrcPathSet.add (v, p)
342 :	blume	652	in case gth () of
343 :	blume	642	GG.ERRORGROUP => (v, a)
344 :			| GG.GROUP { kind, sources, ... } => let
345 :			fun add (p, x, a) =
346 :			StringMap.insert
347 :			(a, SrcPath.osstring p, x)
348 :			val a = SrcPathMap.foldli add a sources
349 :			fun sg subgroups =
350 :			foldl sourcesOf (v, a) subgroups
351 :			in
352 :			case kind of
353 :			GG.LIB { kind, version } =>
354 :			(case kind of
355 :			GG.STABLE _ => let
356 :			val file = SrcPath.osstring p
357 :			val (a, x) =
358 :			StringMap.remove (a, file)
359 :			val sfile =
360 :			FilenamePolicy.mkStableName
361 :			policy (p, version)
362 :			in
363 :			(v,
364 :			StringMap.insert (a, sfile, x))
365 :			end
366 :			| GG.DEVELOPED d => sg (#subgroups d))
367 :			| GG.NOLIB n => sg (#subgroups n)
368 :			end
369 :			end
370 :	blume	632	val p = mkStdSrcPath group
371 :			val gr = GroupReg.new ()
372 :			in
373 :			(case Parse.parse (parse_arg (gr, NONE, p)) of
374 :	blume	642	SOME (g, _) => let
375 :			val (_, sm) =
376 :	blume	666	sourcesOf ((p, fn () => g, []),
377 :	blume	642	(SrcPathSet.empty,
378 :			StringMap.singleton
379 :			(SrcPath.osstring p,
380 :			{ class = "cm",
381 :			derived = false })))
382 :			fun add (s, { class, derived }, l) =
383 :			{ file = s, class = class, derived = derived } :: l
384 :	blume	632	in
385 :	blume	642	SOME (StringMap.foldli add [] sm)
386 :			end
387 :			| _ => NONE)
388 :	blume	632	before dropPickles ()
389 :			end
390 :
391 :	blume	692	fun mk_standalone sflag { project, wrapper, target } = let
392 :			val hsfx = SMLofNJ.SysInfo.getHeapSuffix ()
393 :			fun extendTarget () =
394 :			OS.Path.joinBaseExt { base = target, ext = SOME hsfx }
395 :			val target =
396 :			case OS.Path.splitBaseExt target of
397 :			{ base, ext = NONE } => extendTarget ()
398 :			| { base, ext = SOME e } =>
399 :			if e = hsfx then target else extendTarget ()
400 :			val pp = mkStdSrcPath project
401 :			val wp = mkStdSrcPath wrapper
402 :			val ts = TStamp.fmodTime target
403 :	blume	537	val gr = GroupReg.new ()
404 :	blume	692	fun do_wrapper () =
405 :			case Parse.parse (parse_arg (gr, NONE, wp)) of
406 :			NONE => NONE
407 :			| SOME (g, gp) =>
408 :			if recomp_runner gp g then SOME (mkBootList g)
409 :			else NONE
410 :	blume	537	in
411 :	blume	692	(case Parse.parse (parse_arg (gr, sflag, pp)) of
412 :	blume	537	NONE => NONE
413 :			| SOME (g, gp) =>
414 :			if isSome sflag orelse recomp_runner gp g then
415 :	blume	692	case (ts, !(#youngest gp)) of
416 :			(TStamp.TSTAMP tgt_t, TStamp.TSTAMP src_t) =>
417 :			if Time.< (tgt_t, src_t) then do_wrapper ()
418 :			else SOME []
419 :			| _ => do_wrapper ()
420 :	blume	537	else NONE)
421 :			before dropPickles ()
422 :			end
423 :
424 :	blume	518	fun slave () = let
425 :	blume	537	val gr = GroupReg.new ()
426 :	blume	1058	fun parse p = Parse.parse (slave_parse_arg (gr, NONE, p))
427 :	blume	518	in
428 :	blume	666	Slave.slave { penv = penv,
429 :	blume	518	parse = parse,
430 :	blume	480	my_archos = my_archos,
431 :			sbtrav = Compile.newSbnodeTraversal,
432 :			make = make }
433 :	blume	518	end
434 :	blume	456
435 :	blume	716	(* This function works on behalf of the ml-build script.
436 :			* Having it here avoids certain startup-costs and also
437 :			* keeps ML code together. (It used to be part of the
438 :			* script, but that proved difficult to maintain.) *)
439 :			fun mlbuild buildargs =
440 :			OS.Process.exit
441 :			(case buildargs of
442 :	mblume	1342	[root, cmfile, heap, listfile, linkargsfile] =>
443 :	blume	716	(case mk_standalone NONE { project = root,
444 :			wrapper = cmfile,
445 :			target = heap } of
446 :			NONE => (Say.say ["Compilation failed.\n"];
447 :			OS.Process.failure)
448 :			| SOME [] => (Say.say ["Heap was already up-to-date.\n"];
449 :			OS.Process.success)
450 :			| SOME l => let
451 :	mblume	1342	fun wrf (f, l) = let
452 :			val s = TextIO.openOut f
453 :			fun wr str = TextIO.output (s, str ^ "\n")
454 :			in
455 :			app (fn str => TextIO.output (s, str ^ "\n")) l;
456 :			TextIO.closeOut s
457 :			end
458 :
459 :
460 :	blume	716	val s = TextIO.openOut listfile
461 :			fun wr str = TextIO.output (s, str ^ "\n")
462 :			val n = length l
463 :			fun maxsz (s, n) = Int.max (size s, n)
464 :			val m = foldl maxsz 0 l
465 :			in
466 :	mblume	1342	wrf (listfile, concat ["%", Int.toString n, " ",
467 :			Int.toString m]
468 :			:: l);
469 :			wrf (linkargsfile,
470 :			[concat [" @SMLboot=", listfile]]);
471 :			OS.Process.success
472 :	blume	716	end
473 :			handle _ => OS.Process.failure)
474 :			| _ => (Say.say ["bad arguments to @CMbuild\n"];
475 :			OS.Process.failure))
476 :
477 :	blume	1058	fun al_ginfo () = { param = param false,
478 :	blume	518	groupreg = al_greg,
479 :	blume	692	errcons = EM.defaultConsumer (),
480 :			youngest = ref TStamp.ancient }
481 :	blume	518
482 :	mblume	1393	val al_managers =
483 :			AutoLoad.mkManagers { get_ginfo = al_ginfo,
484 :			dropPickles = dropPickles }
485 :
486 :	blume	375	fun reset () =
487 :	blume	399	(Compile.reset ();
488 :			Link.reset ();
489 :	blume	375	AutoLoad.reset ();
490 :			Parse.reset ();
491 :	blume	588	SmlInfo.reset ();
492 :	blume	1137	StabModmap.reset ())
493 :	blume	375
494 :	blume	905	fun initTheValues (bootdir, de, er, autoload_postprocess, icm) = let
495 :			(* icm: "install compilation manager" *)
496 :	blume	375	val _ = let
497 :			fun listDir ds = let
498 :			fun loop l =
499 :	blume	380	case F.readDir ds of
500 :	mblume	1350	NONE => l
501 :			| SOME x => loop (x :: l)
502 :	blume	375	in
503 :			loop []
504 :			end
505 :			val fileList = SafeIO.perform
506 :	blume	380	{ openIt = fn () => F.openDir bootdir,
507 :			closeIt = F.closeDir,
508 :	blume	375	work = listDir,
509 :	blume	459	cleanup = fn _ => () }
510 :	blume	380	fun isDir x = F.isDir x handle _ => false
511 :	blume	375	fun subDir x = let
512 :	blume	380	val d = P.concat (bootdir, x)
513 :	blume	375	in
514 :			if isDir d then SOME (x, d) else NONE
515 :			end
516 :			val pairList = List.mapPartial subDir fileList
517 :	blume	666	fun sa (x, d) = SrcPath.set_anchor (penv, x, SOME d)
518 :	blume	375	in
519 :	blume	666	app sa pairList
520 :	blume	375	end
521 :	blume	569
522 :			val pidmapfile = P.concat (bootdir, BtNames.pidmap)
523 :	mblume	1342
524 :	blume	569	fun readpidmap s = let
525 :			fun loop m = let
526 :			fun enter (d, pids) = let
527 :	blume	737	fun enter1 (spec, pm) = let
528 :	blume	879	val fromHex = PersStamps.fromHex
529 :	blume	737	in
530 :			case String.tokens (fn c => c = #":") spec of
531 :			[pos, hexp] =>
532 :			(case (fromHex hexp, Int.fromString pos) of
533 :			(SOME p, SOME i) =>
534 :	blume	902	(case DE.look de p of
535 :			NONE => pm
536 :			| SOME obj =>
537 :			IM.insert (pm, i,
538 :			DE.singleton (p, obj)))
539 :	blume	737	| _ => pm)
540 :			| _ => pm
541 :			end
542 :	blume	569	in
543 :	blume	666	SrcPathMap.insert (m, SrcPath.decode penv d,
544 :	blume	737	foldl enter1 IM.empty pids)
545 :	blume	569	end
546 :			in
547 :			case TextIO.inputLine s of
548 :	mblume	1368	NONE => m
549 :			| SOME line =>
550 :			(case String.tokens Char.isSpace line of
551 :			d :: pids => loop (enter (d, pids))
552 :			| _ => loop m)
553 :	blume	569	end
554 :	blume	737	val m = loop SrcPathMap.empty
555 :	blume	569	in
556 :	blume	737	system_values := m
557 :	blume	569	end
558 :
559 :			val _ =
560 :			SafeIO.perform { openIt = fn () => TextIO.openIn pidmapfile,
561 :			closeIt = TextIO.closeIn,
562 :			work = readpidmap,
563 :			cleanup = fn _ => () }
564 :
565 :	blume	525	val initgspec = mkStdSrcPath BtNames.initgspec
566 :	blume	537	val ginfo = { param = { fnpolicy = fnpolicy,
567 :	blume	666	penv = penv,
568 :	blume	433	symval = SSV.symval,
569 :	blume	873	archos = my_archos,
570 :	blume	1058	keep_going = false,
571 :			slave_mode = false },
572 :	blume	375	groupreg = GroupReg.new (),
573 :	blume	692	errcons = EM.defaultConsumer (),
574 :			youngest = ref TStamp.ancient }
575 :	blume	537	fun loadInitGroup () =
576 :	blume	666	Stabilize.loadStable
577 :			{ getGroup = fn _ =>
578 :			raise Fail "CMBoot: initial getGroup",
579 :			anyerrors = ref false }
580 :			(ginfo, initgspec, NONE, [])
581 :	blume	375	in
582 :	blume	537	case loadInitGroup () of
583 :			NONE => raise Fail "CMBoot: unable to load init group"
584 :			| SOME init_group => let
585 :			val _ = Compile.reset ()
586 :			val _ = Link.reset ()
587 :	blume	375
588 :	blume	537	val { exports = ctm, ... } =
589 :			Compile.newTraversal (fn _ => fn _ => (),
590 :			fn _ => (),
591 :			init_group)
592 :			val { exports = ltm, ... } = Link.newTraversal
593 :			(init_group, fn _ => raise Fail "init: get bfc?")
594 :
595 :			fun getSymTrav (tr_m, sy) =
596 :			case SymbolMap.find (tr_m, sy) of
597 :			NONE => raise Fail "init: bogus init group (1)"
598 :			| SOME tr => tr
599 :
600 :	blume	592	val perv_ct = getSymTrav (ctm, PervAccess.pervStrSym)
601 :			val perv_lt = getSymTrav (ltm, PervAccess.pervStrSym)
602 :	blume	537
603 :			fun doTrav t =
604 :			case t ginfo of
605 :			SOME r => r
606 :			| NONE => raise Fail "init: bogus init group (2)"
607 :
608 :			val { stat = pervstat, sym = pervsym } = doTrav perv_ct
609 :			val pervdyn = doTrav perv_lt
610 :
611 :			val pervasive = E.mkenv { static = pervstat,
612 :			symbolic = pervsym,
613 :			dynamic = pervdyn }
614 :
615 :	blume	495	fun bare_autoload x =
616 :			(Say.say
617 :			["!* ", x,
618 :			": \"autoload\" not available, using \"make\"\n"];
619 :			make x)
620 :			val bare_preload =
621 :			Preload.preload { make = make,
622 :			autoload = bare_autoload }
623 :			val standard_preload =
624 :			Preload.preload { make = make, autoload = autoload }
625 :	blume	375	in
626 :	blume	592	#set ER.pervasive pervasive;
627 :	blume	905	#set (ER.loc ()) E.emptyEnv;(* redundant? *)
628 :	blume	592	theValues := SOME { init_group = init_group };
629 :	blume	375	case er of
630 :			BARE =>
631 :	blume	495	(bare_preload BtNames.bare_preloads;
632 :	blume	569	system_values := SrcPathMap.empty;
633 :	blume	495	NONE)
634 :	blume	375	| AUTOLOAD =>
635 :	mblume	1393	(icm al_managers;
636 :	blume	905	standard_preload BtNames.standard_preloads;
637 :	blume	507	(* unconditionally drop all library pickles *)
638 :			Parse.dropPickles ();
639 :	blume	495	SOME (autoload_postprocess ()))
640 :	blume	375	end
641 :			end
642 :			end
643 :			in
644 :	blume	905	fun init (bootdir, de, er, useStream, useFile, icm) = let
645 :	blume	495	fun procCmdLine () = let
646 :			val autoload = ignore o autoload
647 :			val make = ignore o make
648 :	blume	905	fun p (f, mk, ("sml" | "sig" | "fun")) = useFile f
649 :	blume	692	| p (f, mk, "cm") = mk f
650 :			| p (f, mk, e) = Say.say ["!* unable to process `", f,
651 :	blume	495	"' (unknown extension `", e, "')\n"]
652 :	blume	1201	fun inc n = n + 1
653 :	blume	1126
654 :	blume	1201	fun show_controls (getarg, getval, padval) level = let
655 :			fun walk indent (ControlRegistry.RTree rt) = let
656 :			open FormatComb
657 :			val { help, ctls, subregs, path } = rt
658 :
659 :			fun one c = let
660 :			val arg = concat (foldr (fn (s, r) => s :: "." :: r)
661 :			[getarg c] path)
662 :			val value = getval c
663 :			val sz = size value
664 :			val lw = !Control_Print.linewidth
665 :			val padsz = lw - 6 - size arg - indent
666 :			in
667 :			if padsz < sz then
668 :			let val padsz' = Int.max (lw, sz + 8 + indent)
669 :			in
670 :			format' Say.say (sp (indent + 6) o
671 :			text arg o nl o
672 :			padval padsz' (text value) o
673 :			nl)
674 :			end
675 :			else format' Say.say (sp (indent + 6) o
676 :			text arg o
677 :			padval padsz (text value) o
678 :			nl)
679 :			end
680 :	blume	1126	in
681 :	blume	1201	case (ctls, subregs) of
682 :			([], []) => ()
683 :			| _ => (format' Say.say
684 :			(sp indent o text help o text ":" o nl);
685 :			app one ctls;
686 :			app (walk (indent + 1)) subregs)
687 :	blume	1126	end
688 :			in
689 :	blume	1201	walk 2 (ControlRegistry.controls
690 :			(BasicControl.topregistry, Option.map inc level))
691 :	blume	1126	end
692 :
693 :			fun help level =
694 :			(Say.say
695 :			["sml [rtsargs] [options] [files]\n\
696 :			\\n\
697 :			\ rtsargs:\n\
698 :			\ @SMLload=<h> (start specified heap image)\n\
699 :			\ @SMLalloc=<s> (specify size of allocation area)\n\
700 :			\ @SMLcmdname=<n> (set command name)\n\
701 :			\ @SMLquiet (load heap image silently)\n\
702 :			\ @SMLverbose (show heap image load progress)\n\
703 :			\ @SMLobjects (show list of executable objects)\n\
704 :			\ @SMLdebug=<f> (write debugging info to file)\n\
705 :			\\n\
706 :			\ files:\n\
707 :			\ <file>.cm (CM.make or CM.autoload)\n\
708 :			\ -m (switch to CM.make)\n\
709 :			\ -a (switch to CM.autoload; default)\n\
710 :			\ <file>.sig (use)\n\
711 :			\ <file>.sml (use)\n\
712 :			\ <file>.fun (use)\n\
713 :			\\n\
714 :			\ options:\n\
715 :			\ -D<name>=<v> (set CM variable to given value)\n\
716 :			\ -D<name> (set CM variable to 1)\n\
717 :			\ -Uname (unset CM variable)\n\
718 :			\ -C<control>=<v> (set named control)\n\
719 :			\ -H (produce complete help listing)\n\
720 :			\ -h (produce minimal help listing)\n\
721 :			\ -h<level> (help with obscurity limit)\n\
722 :			\ -S (list all current settings)\n\
723 :	blume	1201	\ -s<level> (limited list of settings)\n\n"];
724 :			show_controls (Controls.name,
725 :			fn c => concat ["(", #help (Controls.info c),
726 :			")"],
727 :			FormatComb.pad FormatComb.left)
728 :	blume	1126	level)
729 :
730 :			fun showcur level = let
731 :			fun nopad (_, s) = s
732 :			in
733 :	blume	1201	show_controls (fn c => (Controls.name c ^ "="),
734 :			fn c => Controls.get c,
735 :			fn _ => fn ff => ff)
736 :	blume	1126	level
737 :			end
738 :
739 :	blume	692	fun badopt opt f () =
740 :	blume	1126	Say.say ["!* bad ", opt, " option: `", f, "'\n",
741 :			"!* try `-h' or `-h<level>' for help\n"]
742 :	mblume	1595
743 :			fun quit () = OS.Process.exit OS.Process.success
744 :
745 :			fun quit_if true = quit ()
746 :			| quit_if false = ()
747 :
748 :			fun carg (opt as ("-C" | "-D"), f, _, _) =
749 :	blume	1126	let val bad = badopt opt f
750 :			val spec = Substring.extract (f, 2, NONE)
751 :			val is_config = opt = "-C"
752 :			val (name, value) =
753 :			Substring.splitl (fn c => c <> #"=") spec
754 :			val name = Substring.string name
755 :			val value = Substring.string
756 :			(if Substring.size value > 0 then
757 :			Substring.slice (value, 1, NONE)
758 :			else value)
759 :	blume	692	in
760 :	blume	1126	if name = "" then bad ()
761 :			else if is_config then
762 :	blume	1201	let val names = String.fields (fn c => c = #".") name
763 :			val look = ControlRegistry.control
764 :			BasicControl.topregistry
765 :	blume	1126	in
766 :	blume	1201	case look names of
767 :			NONE => Say.say ["!* no such control: ",
768 :			name, "\n"]
769 :			| SOME sctl =>
770 :			(Controls.set (sctl, value)
771 :			handle Controls.ValueSyntax vse =>
772 :			Say.say ["!* unable to parse value `",
773 :			#value vse, "' for ",
774 :			#ctlName vse, " : ",
775 :			#tyName vse, "\n"])
776 :			end
777 :	blume	1126	else if value = "" then #set (SSV.symval name) (SOME 1)
778 :			else (case Int.fromString value of
779 :			SOME i => #set (SSV.symval name) (SOME i)
780 :			| NONE => bad ())
781 :	blume	692	end
782 :	mblume	1595	| carg ("-U", f, _, _) =
783 :			(case String.extract (f, 2, NONE) of
784 :			"" => badopt "-U" f ()
785 :			| var => #set (SSV.symval var) NONE)
786 :			| carg ("-h", f, _, last) =
787 :			(case String.extract (f, 2, NONE) of
788 :			"" => help (SOME 0)
789 :			| level => help (Int.fromString level);
790 :			quit_if last)
791 :			| carg ("-s", f, _, last) =
792 :			(case String.extract (f, 2, NONE) of
793 :			"" => showcur (SOME 0)
794 :			| level => showcur (Int.fromString level);
795 :			quit_if last)
796 :			| carg (_, f, mk, _) =
797 :			p (f, mk, String.map Char.toLower
798 :			(getOpt (OS.Path.ext f, "<none>")))
799 :	blume	716
800 :			fun args ("-a" :: rest, _) = args (rest, autoload)
801 :			| args ("-m" :: rest, _) = args (rest, make)
802 :	mblume	1595	| args ("-H" :: rest, mk) = (help NONE; args_q (rest, mk))
803 :			| args ("-S" :: rest, mk) = (showcur NONE; args_q (rest, mk))
804 :			| args ("-q" :: _, _) = quit ()
805 :	blume	716	| args ("@CMbuild" :: rest, _) = mlbuild rest
806 :			| args (f :: rest, mk) =
807 :	mblume	1595	(carg (String.substring (f, 0, 2)
808 :			handle General.Subscript => "",
809 :			f, mk, List.null rest);
810 :	blume	716	args (rest, mk))
811 :			| args ([], _) = ()
812 :	mblume	1595
813 :			and args_q ([], _) = quit ()
814 :			| args_q (rest, f) = args (rest, f)
815 :	blume	495	in
816 :			case SMLofNJ.getArgs () of
817 :			["@CMslave"] => (#set StdConfig.verbose false; slave ())
818 :	blume	716	| l => args (l, autoload)
819 :	blume	495	end
820 :	blume	448	in
821 :	blume	905	useStreamHook := useStream;
822 :	blume	569	initTheValues (bootdir, de, er,
823 :			fn () => (Cleanup.install initPaths;
824 :	blume	905	procCmdLine),
825 :			icm)
826 :	blume	448	end
827 :	blume	479
828 :	blume	734	structure CM = struct
829 :	blume	479	type 'a controller = { get : unit -> 'a, set : 'a -> unit }
830 :
831 :			structure Anchor = struct
832 :	blume	569	fun anchor a = { get = getAnchor a, set = setAnchor a }
833 :	blume	479	val reset = resetPathConfig
834 :			end
835 :
836 :			structure Control = struct
837 :			val keep_going = StdConfig.keep_going
838 :			val verbose = StdConfig.verbose
839 :			val parse_caching = StdConfig.parse_caching
840 :			val warn_obsolete = StdConfig.warn_obsolete
841 :			val debug = StdConfig.debug
842 :	blume	505	val conserve_memory = StdConfig.conserve_memory
843 :	blume	838	val generate_index = StdConfig.generate_index
844 :	blume	479	end
845 :
846 :			structure Library = struct
847 :	blume	666	type lib = SrcPath.file
848 :	blume	479	val known = Parse.listLibs
849 :			val descr = SrcPath.descr
850 :			val osstring = SrcPath.osstring
851 :			val dismiss = Parse.dismissLib
852 :	blume	632	fun unshare lib = (Link.unshare lib; dismiss lib)
853 :	blume	479	end
854 :
855 :			structure State = struct
856 :			val synchronize = SrcPath.sync
857 :			val reset = reset
858 :			val pending = getPending
859 :	blume	1068	val showBindings = showBindings
860 :	blume	479	end
861 :
862 :			structure Server = struct
863 :	blume	735	type server = Servers.server_handle
864 :	blume	666	fun start x = Servers.start x
865 :			before SrcPath.scheduleNotification ()
866 :	blume	479	val stop = Servers.stop
867 :			val kill = Servers.kill
868 :			val name = Servers.name
869 :			end
870 :
871 :			val autoload = autoload
872 :			val make = make
873 :			val recomp = recomp
874 :			val stabilize = stabilize
875 :
876 :	blume	642	val sources = sources
877 :	blume	632
878 :	blume	479	val symval = SSV.symval
879 :	blume	578	val load_plugin = cwd_load_plugin
880 :	blume	537	val mk_standalone = mk_standalone
881 :	blume	975
882 :			structure Graph = struct
883 :			val graph = to_portable
884 :			end
885 :	mblume	1385
886 :			val cm_dir_arc = FilenamePolicy.cm_dir_arc
887 :	blume	479	end
888 :	blume	525
889 :	blume	756	structure Tools = ToolsFn (val load_plugin' = load_plugin'
890 :	blume	666	val penv = penv)
891 :	blume	578
892 :			val load_plugin = load_plugin
893 :	blume	375	end
894 :			end

---

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