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

Parent Directory | Revision Log

---

Revision 483 - (view) (download)

1 :	blume	375	(*
2 :			* This is the module that actually puts together the contents of the
3 :	blume	483	* structure CM that people find at the top-level. A "minimal" structure
4 :	blume	375	* CM is defined in CmHook, but it needs to be initialized at bootstrap
5 :	blume	483	* time -- and that is what's done here, too.
6 :	blume	375	*
7 :			* Copyright (c) 1999 by Lucent Bell Laboratories
8 :			*
9 :			* author: Matthias Blume (blume@cs.princeton.edu)
10 :			*)
11 :			functor LinkCM (structure HostMachDepVC : MACHDEP_VC) = struct
12 :
13 :			datatype envrequest = AUTOLOAD | BARE
14 :
15 :			local
16 :			structure YaccTool = YaccTool
17 :			structure LexTool = LexTool
18 :			structure BurgTool = BurgTool
19 :
20 :			structure E = GenericVC.Environment
21 :			structure SE = GenericVC.StaticEnv
22 :			structure ER = GenericVC.EnvRef
23 :			structure BE = GenericVC.BareEnvironment
24 :			structure CMSE = GenericVC.CMStaticEnv
25 :			structure S = GenericVC.Symbol
26 :			structure CoerceEnv = GenericVC.CoerceEnv
27 :			structure EM = GenericVC.ErrorMsg
28 :			structure BF = HostMachDepVC.Binfile
29 :	blume	380	structure P = OS.Path
30 :			structure F = OS.FileSys
31 :	blume	451	structure DG = DependencyGraph
32 :	blume	375
33 :			val os = SMLofNJ.SysInfo.getOSKind ()
34 :	blume	464	val my_archos =
35 :			concat [HostMachDepVC.architecture, "-", FilenamePolicy.kind2name os]
36 :	blume	375
37 :			structure SSV =
38 :			SpecificSymValFn (structure MachDepVC = HostMachDepVC
39 :			val os = os)
40 :
41 :			val emptydyn = E.dynamicPart E.emptyEnv
42 :			val system_values = ref emptydyn
43 :
44 :	blume	400	structure Compile =
45 :	blume	448	CompileFn (structure MachDepVC = HostMachDepVC
46 :	blume	464	val compile_there = Servers.compile o SrcPath.descr)
47 :	blume	400
48 :	blume	399	structure Link =
49 :			LinkFn (structure MachDepVC = HostMachDepVC
50 :			val system_values = system_values)
51 :	blume	375
52 :	blume	403	structure BFC =
53 :			BfcFn (structure MachDepVC = HostMachDepVC)
54 :
55 :	blume	375	structure AutoLoad = AutoLoadFn
56 :	blume	399	(structure C = Compile
57 :	blume	403	structure L = Link
58 :			structure BFC = BFC)
59 :	blume	375
60 :	blume	456	fun init_servers (GroupGraph.GROUP { grouppath, ... }) =
61 :	blume	464	Servers.cm { archos = my_archos, project = SrcPath.descr grouppath }
62 :	blume	456
63 :	blume	399	fun recomp_runner gp g = let
64 :	blume	456	val _ = init_servers g
65 :	blume	403	fun store _ = ()
66 :			val { group, ... } = Compile.newTraversal (Link.evict, store, g)
67 :	blume	399	in
68 :	blume	450	isSome (Servers.withServers (fn () => group gp))
69 :			before Link.cleanup gp
70 :	blume	399	end
71 :	blume	375
72 :			(* This function combines the actions of "recompile" and "exec".
73 :			* When successful, it combines the results (thus forming a full
74 :			* environment) and adds it to the toplevel environment. *)
75 :	blume	399	fun make_runner gp g = let
76 :	blume	403	val { store, get } = BFC.new ()
77 :	blume	456	val _ = init_servers g
78 :	blume	403	val { group = c_group, ... } =
79 :			Compile.newTraversal (Link.evict, store, g)
80 :			val { group = l_group, ... } = Link.newTraversal (g, get)
81 :	blume	399	val GroupGraph.GROUP { required = rq, ... } = g
82 :			in
83 :	blume	450	case Servers.withServers (fn () => c_group gp) of
84 :	blume	375	NONE => false
85 :			| SOME { stat, sym} =>
86 :	blume	399	(* Before executing the code, we announce the priviliges
87 :			* that are being invoked. (For the time being, we assume
88 :			* that everybody has every conceivable privilege, but at
89 :			* the very least we announce which ones are being made
90 :			* use of.) *)
91 :	blume	400	(Link.cleanup gp;
92 :	blume	399	if StringSet.isEmpty rq then ()
93 :			else Say.say ("$Execute: required privileges are:\n" ::
94 :			map (fn s => (" " ^ s ^ "\n")) (StringSet.listItems rq));
95 :			case l_group gp of
96 :	blume	375	NONE => false
97 :			| SOME dyn => let
98 :			val delta = E.mkenv { static = stat, symbolic = sym,
99 :			dynamic = dyn }
100 :			val base = #get ER.topLevel ()
101 :			val new = BE.concatEnv (CoerceEnv.e2b delta, base)
102 :			in
103 :			#set ER.topLevel new;
104 :			Say.vsay ["[New bindings added.]\n"];
105 :			true
106 :			end)
107 :	blume	399	end
108 :	blume	375
109 :			val al_greg = GroupReg.new ()
110 :
111 :			(* Instantiate the stabilization mechanism. *)
112 :			structure Stabilize =
113 :	blume	403	StabilizeFn (structure MachDepVC = HostMachDepVC
114 :			fun recomp gp g = let
115 :			val { store, get } = BFC.new ()
116 :	blume	456	val _ = init_servers g
117 :	blume	403	val { group, ... } =
118 :			Compile.newTraversal (Link.evict, store, g)
119 :			in
120 :	blume	450	case Servers.withServers (fn () => group gp) of
121 :	blume	403	NONE => NONE
122 :			| SOME _ => SOME get
123 :			end
124 :			fun destroy_state gp i =
125 :	blume	451	(Compile.evict i;
126 :			Link.evict gp i)
127 :	blume	403	val getII = Compile.getII)
128 :	blume	375
129 :			(* Access to the stabilization mechanism is integrated into the
130 :			* parser. I'm not sure if this is the cleanest way, but it works
131 :			* well enough. *)
132 :			structure Parse = ParseFn (structure Stabilize = Stabilize
133 :			val pending = AutoLoad.getPending)
134 :
135 :			local
136 :			type kernelValues =
137 :			{ primconf : Primitive.configuration,
138 :			pervasive : E.environment,
139 :			corenv : BE.staticEnv,
140 :			pervcorepids : PidSet.set }
141 :
142 :			val fnpolicy = FilenamePolicy.colocate
143 :			{ os = os, arch = HostMachDepVC.architecture }
144 :
145 :			val pcmode = PathConfig.new ()
146 :
147 :			val theValues = ref (NONE: kernelValues option)
148 :
149 :			in
150 :	blume	479	fun setAnchor { anchor = a, path = s } =
151 :	blume	377	(PathConfig.set (pcmode, a, s); SrcPath.sync ())
152 :			(* cancelling anchors cannot affect the order of existing paths
153 :			* (it may invalidate some paths; but all other ones stay as
154 :			* they are) *)
155 :	blume	375	fun cancelAnchor a = PathConfig.cancel (pcmode, a)
156 :	blume	377	(* same goes for reset because it just cancels all anchors... *)
157 :	blume	375	fun resetPathConfig () = PathConfig.reset pcmode
158 :
159 :	blume	479	fun getPending () = let
160 :	blume	375	fun one (s, _) = let
161 :			val nss = Symbol.nameSpaceToString (Symbol.nameSpace s)
162 :			val n = Symbol.name s
163 :			in
164 :	blume	479	concat [" ", nss, " ", n, "\n"]
165 :	blume	375	end
166 :			in
167 :	blume	479	map one (SymbolMap.listItemsi (AutoLoad.getPending ()))
168 :	blume	375	end
169 :
170 :			fun initPaths () = let
171 :	blume	433	val lpcth = #get StdConfig.local_pathconfig ()
172 :	blume	375	val p = case lpcth () of
173 :			NONE => []
174 :			| SOME f => [f]
175 :	blume	433	val p = #get StdConfig.pathcfgspec () :: p
176 :	blume	375	fun processOne f = PathConfig.processSpecFile (pcmode, f)
177 :			handle _ => ()
178 :			in
179 :			app processOne p
180 :			end
181 :
182 :			fun param () = let
183 :			val v = valOf (!theValues)
184 :			handle Option =>
185 :			raise Fail "CMBoot: theParam not initialized"
186 :			in
187 :			{ primconf = #primconf v,
188 :			fnpolicy = fnpolicy,
189 :			pcmode = pcmode,
190 :	blume	433	symval = SSV.symval,
191 :			keep_going = #get StdConfig.keep_going (),
192 :	blume	375	pervasive = #pervasive v,
193 :			corenv = #corenv v,
194 :			pervcorepids = #pervcorepids v }
195 :			end
196 :
197 :			fun autoload s = let
198 :			val c = SrcPath.cwdContext ()
199 :			val p = SrcPath.standard pcmode { context = c, spec = s }
200 :			in
201 :			case Parse.parse (SOME al_greg) (param ()) NONE p of
202 :			NONE => false
203 :			| SOME (g, _) =>
204 :			(AutoLoad.register (GenericVC.EnvRef.topLevel, g);
205 :			true)
206 :			end
207 :
208 :			fun al_ginfo () = { param = param (),
209 :			groupreg = al_greg,
210 :			errcons = EM.defaultConsumer () }
211 :
212 :			val al_manager = AutoLoad.mkManager al_ginfo
213 :
214 :			fun al_manager' (ast, _, ter) = al_manager (ast, ter)
215 :
216 :			fun run sflag f s = let
217 :			val c = SrcPath.cwdContext ()
218 :			val p = SrcPath.standard pcmode { context = c, spec = s }
219 :			in
220 :			case Parse.parse NONE (param ()) sflag p of
221 :			NONE => false
222 :	blume	456	| SOME (g, gp) => f gp g
223 :	blume	375	end
224 :
225 :	blume	449	fun stabilize_runner gp g = true
226 :
227 :			fun stabilize recursively = run (SOME recursively) stabilize_runner
228 :			val recomp = run NONE recomp_runner
229 :			val make = run NONE make_runner
230 :
231 :	blume	480	fun slave () =
232 :			Slave.slave { pcmode = pcmode,
233 :			parse = fn p => Parse.parse NONE (param ()) NONE p,
234 :			my_archos = my_archos,
235 :			sbtrav = Compile.newSbnodeTraversal,
236 :			make = make }
237 :	blume	456
238 :	blume	375	fun reset () =
239 :	blume	399	(Compile.reset ();
240 :			Link.reset ();
241 :	blume	375	AutoLoad.reset ();
242 :			Parse.reset ();
243 :			SmlInfo.forgetAllBut SrcPathSet.empty)
244 :
245 :			fun initTheValues (bootdir, er) = let
246 :			val _ = let
247 :			fun listDir ds = let
248 :			fun loop l =
249 :	blume	380	case F.readDir ds of
250 :	blume	375	"" => l
251 :			| x => loop (x :: l)
252 :			in
253 :			loop []
254 :			end
255 :			val fileList = SafeIO.perform
256 :	blume	380	{ openIt = fn () => F.openDir bootdir,
257 :			closeIt = F.closeDir,
258 :	blume	375	work = listDir,
259 :	blume	459	cleanup = fn _ => () }
260 :	blume	380	fun isDir x = F.isDir x handle _ => false
261 :	blume	375	fun subDir x = let
262 :	blume	380	val d = P.concat (bootdir, x)
263 :	blume	375	in
264 :			if isDir d then SOME (x, d) else NONE
265 :			end
266 :			val pairList = List.mapPartial subDir fileList
267 :			in
268 :			app (fn (x, d) => PathConfig.set (pcmode, x, d)) pairList
269 :			end
270 :			val initgspec =
271 :			SrcPath.standard pcmode { context = SrcPath.cwdContext (),
272 :			spec = BtNames.initgspec }
273 :			val ginfo = { param = { primconf = Primitive.primEnvConf,
274 :			fnpolicy = fnpolicy,
275 :			pcmode = pcmode,
276 :	blume	433	symval = SSV.symval,
277 :	blume	375	keep_going = false,
278 :			pervasive = E.emptyEnv,
279 :			corenv = BE.staticPart BE.emptyEnv,
280 :			pervcorepids = PidSet.empty },
281 :			groupreg = GroupReg.new (),
282 :			errcons = EM.defaultConsumer () }
283 :			in
284 :			case BuildInitDG.build ginfo initgspec of
285 :			NONE => raise Fail "CMBoot: BuiltInitDG.build"
286 :			| SOME { rts, core, pervasive, primitives, ... } => let
287 :			(* It is absolutely crucial that we don't finish the
288 :			* recomp traversal until we are done with all
289 :			* nodes of the InitDG. This is because we have
290 :			* been cheating, and if we ever have to try and
291 :			* fetch assembly.sig or core.sml in a separate
292 :			* traversal, it will fail. *)
293 :	blume	400	val sbnode = Compile.newSbnodeTraversal ()
294 :	blume	375	fun get n = let
295 :	blume	460	val { statpid, statenv, symenv, sympid } =
296 :			valOf (sbnode ginfo n)
297 :	blume	399	(* We have not implemented the "sbnode" part
298 :			* in the Link module.
299 :	blume	375	* But at boot time any relevant value should be
300 :	blume	399	* available as a sysval, so there is no problem.
301 :			*
302 :			* WARNING! HACK!
303 :			* We are cheating somewhat by taking advantage
304 :			* of the fact that the staticPid is always
305 :			* the same as the exportPid if the latter exists.
306 :			*)
307 :			val d = case Link.sysval (SOME statpid) of
308 :			SOME d => d
309 :			| NONE => emptydyn
310 :	blume	461	val { env = static, ctxt } = statenv ()
311 :			val env = E.mkenv { static = static,
312 :	blume	399	symbolic = symenv (),
313 :	blume	375	dynamic = d }
314 :	blume	461	val pidInfo =
315 :			{ statpid = statpid, sympid = sympid,
316 :			ctxt = ctxt }
317 :	blume	375	in
318 :			(env, pidInfo)
319 :			end
320 :			fun getPspec (name, n) = let
321 :			val (env, pidInfo) = get n
322 :			in
323 :			{ name = name, env = env, pidInfo = pidInfo }
324 :			end
325 :
326 :			val (core, corePidInfo) = get core
327 :			val corenv = CoerceEnv.es2bs (E.staticPart core)
328 :			val (rts, _) = get rts
329 :			val (pervasive0, pervPidInfo) = get pervasive
330 :			val pspecs = map getPspec primitives
331 :			val core_symdyn =
332 :			E.mkenv { static = E.staticPart E.emptyEnv,
333 :			dynamic = E.dynamicPart core,
334 :			symbolic = E.symbolicPart core }
335 :			val pervasive = E.layerEnv (pervasive0, core_symdyn)
336 :			val pervcorepids =
337 :			PidSet.addList (PidSet.empty,
338 :			[#statpid corePidInfo,
339 :			#statpid pervPidInfo,
340 :			#sympid pervPidInfo])
341 :			in
342 :	blume	399	Compile.reset ();
343 :			Link.reset ();
344 :	blume	375	#set ER.core corenv;
345 :			#set ER.pervasive pervasive;
346 :			#set ER.topLevel BE.emptyEnv;
347 :			theValues :=
348 :			SOME { primconf = Primitive.configuration pspecs,
349 :			pervasive = pervasive,
350 :			corenv = corenv,
351 :			pervcorepids = pervcorepids };
352 :			case er of
353 :			BARE =>
354 :			(make "basis.cm";
355 :			make "host-compiler.cm";
356 :			system_values := emptydyn)
357 :			| AUTOLOAD =>
358 :			(HostMachDepVC.Interact.installCompManager
359 :			(SOME al_manager');
360 :			autoload "basis.cm";
361 :	blume	479	autoload "minimal-cm.cm";
362 :	blume	375	CmHook.init
363 :			{ stabilize = stabilize,
364 :			recomp = recomp,
365 :			make = make,
366 :	blume	479	autoload = autoload })
367 :	blume	375
368 :			end
369 :			end
370 :			end
371 :			in
372 :			fun init (bootdir, de, er) =
373 :			(system_values := de;
374 :			initTheValues (bootdir, er);
375 :			Cleanup.install initPaths)
376 :	blume	448
377 :			fun procCmdLine () = let
378 :			fun p (f, "sml") = HostMachDepVC.Interact.useFile f
379 :			| p (f, "sig") = HostMachDepVC.Interact.useFile f
380 :			| p (f, "cm") = ignore (make f)
381 :			| p (f, e) =
382 :			(print (concat ["!* unable to process `", f,
383 :			"' (unknown extension `", e, "')\n"]))
384 :			fun c f = (f, String.map Char.toLower
385 :			(getOpt (OS.Path.ext f, "<none>")))
386 :			in
387 :			case SMLofNJ.getArgs () of
388 :	blume	451	["@CMslave"] => (#set StdConfig.verbose false; slave ())
389 :	blume	448	| l => app (p o c) l
390 :			end
391 :	blume	479
392 :			structure CM :> CM = struct
393 :			type 'a controller = { get : unit -> 'a, set : 'a -> unit }
394 :
395 :			structure Anchor = struct
396 :			val set = setAnchor
397 :			val cancel = cancelAnchor
398 :			val reset = resetPathConfig
399 :			end
400 :
401 :			structure Control = struct
402 :			val keep_going = StdConfig.keep_going
403 :			val verbose = StdConfig.verbose
404 :			val parse_caching = StdConfig.parse_caching
405 :			val warn_obsolete = StdConfig.warn_obsolete
406 :			val debug = StdConfig.debug
407 :			end
408 :
409 :			structure Library = struct
410 :			type lib = SrcPath.t
411 :			val known = Parse.listLibs
412 :			val descr = SrcPath.descr
413 :			val osstring = SrcPath.osstring
414 :			val dismiss = Parse.dismissLib
415 :			end
416 :
417 :			structure State = struct
418 :			val synchronize = SrcPath.sync
419 :			val reset = reset
420 :			val pending = getPending
421 :			end
422 :
423 :			structure Server = struct
424 :			type server = Servers.server
425 :			fun start x = Servers.start x before SrcPath.invalidateCwd ()
426 :			val stop = Servers.stop
427 :			val kill = Servers.kill
428 :			val name = Servers.name
429 :			end
430 :
431 :			val autoload = autoload
432 :			val make = make
433 :			val recomp = recomp
434 :			val stabilize = stabilize
435 :
436 :			val symval = SSV.symval
437 :			end
438 :	blume	375	end
439 :			end

---

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