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

Parent Directory | Revision Log

---

Revision 377 - (view) (download)

1 :	blume	375	(*
2 :			* This is the module that actually puts together the contents of the
3 :			* structure CM that people find at the top-level. The "real" structure
4 :			* CM is defined in CmHook, but it needs to be initialized at bootstrap
5 :			* time -- and _that_ is what's done here.
6 :			*
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 :
30 :			val os = SMLofNJ.SysInfo.getOSKind ()
31 :
32 :			structure SSV =
33 :			SpecificSymValFn (structure MachDepVC = HostMachDepVC
34 :			val os = os)
35 :
36 :			val emptydyn = E.dynamicPart E.emptyEnv
37 :			val system_values = ref emptydyn
38 :
39 :			(* Instantiate the persistent state functor; this includes
40 :			* the binfile cache and the dynamic value cache *)
41 :			structure FullPersstate =
42 :			FullPersstateFn (structure MachDepVC = HostMachDepVC
43 :			val system_values = system_values)
44 :
45 :			(* Building "Exec" will automatically also build "Recomp" and
46 :			* "RecompTraversal"... *)
47 :			local
48 :			structure E = ExecFn (structure PS = FullPersstate)
49 :			in
50 :			structure Recomp = E.Recomp
51 :			structure RT = E.RecompTraversal
52 :			structure Exec = E.Exec
53 :			end
54 :
55 :			structure ET = CompileGenericFn (structure CT = Exec)
56 :
57 :			structure AutoLoad = AutoLoadFn
58 :			(structure RT = RT
59 :			structure ET = ET)
60 :
61 :			(* The StabilizeFn functor needs a way of converting bnodes to
62 :			* dependency-analysis environments. This can be achieved quite
63 :			* conveniently by a "recompile" traversal for bnodes. *)
64 :			fun bn2statenv gp i = #1 (#stat (valOf (RT.bnode' gp i)))
65 :			handle Option => raise Fail "bn2statenv"
66 :
67 :			(* exec_group is basically the same as ET.group with
68 :			* two additional actions to be taken:
69 :			* 1. Before executing the code, we announce the priviliges
70 :			* that are being invoked. (For the time being, we assume
71 :			* that everybody has every conceivable privilege, but at the
72 :			* very least we announce which ones are being made use of.)
73 :			* 2. After we are done we must make the values of "shared"
74 :			* compilation units permanent. *)
75 :			fun exec_group gp (g as GroupGraph.GROUP { required = rq, ... }) =
76 :			(if StringSet.isEmpty rq then ()
77 :			else Say.say ("$Execute: required privileges are:\n" ::
78 :			map (fn s => (" " ^ s ^ "\n")) (StringSet.listItems rq));
79 :			ET.group gp g)
80 :
81 :			fun recomp_runner gp g = isSome (RT.group gp g)
82 :
83 :			(* This function combines the actions of "recompile" and "exec".
84 :			* When successful, it combines the results (thus forming a full
85 :			* environment) and adds it to the toplevel environment. *)
86 :			fun make_runner gp g =
87 :			case RT.group gp g of
88 :			NONE => false
89 :			| SOME { stat, sym} =>
90 :			(case exec_group gp g of
91 :			NONE => false
92 :			| SOME dyn => let
93 :			val delta = E.mkenv { static = stat, symbolic = sym,
94 :			dynamic = dyn }
95 :			val base = #get ER.topLevel ()
96 :			val new = BE.concatEnv (CoerceEnv.e2b delta, base)
97 :			in
98 :			#set ER.topLevel new;
99 :			Say.vsay ["[New bindings added.]\n"];
100 :			true
101 :			end)
102 :
103 :			val al_greg = GroupReg.new ()
104 :
105 :			(* Instantiate the stabilization mechanism. *)
106 :			structure Stabilize =
107 :			StabilizeFn (val bn2statenv = bn2statenv
108 :			val recomp = recomp_runner
109 :			val transfer_state = FullPersstate.transfer_state)
110 :
111 :			(* Access to the stabilization mechanism is integrated into the
112 :			* parser. I'm not sure if this is the cleanest way, but it works
113 :			* well enough. *)
114 :			structure Parse = ParseFn (structure Stabilize = Stabilize
115 :			val pending = AutoLoad.getPending)
116 :
117 :			local
118 :			type kernelValues =
119 :			{ primconf : Primitive.configuration,
120 :			pervasive : E.environment,
121 :			corenv : BE.staticEnv,
122 :			pervcorepids : PidSet.set }
123 :
124 :			val fnpolicy = FilenamePolicy.colocate
125 :			{ os = os, arch = HostMachDepVC.architecture }
126 :
127 :			val pcmode = PathConfig.new ()
128 :
129 :			val theValues = ref (NONE: kernelValues option)
130 :
131 :			in
132 :	blume	377	fun setAnchor (a, s) =
133 :			(PathConfig.set (pcmode, a, s); SrcPath.sync ())
134 :			(* cancelling anchors cannot affect the order of existing paths
135 :			* (it may invalidate some paths; but all other ones stay as
136 :			* they are) *)
137 :	blume	375	fun cancelAnchor a = PathConfig.cancel (pcmode, a)
138 :	blume	377	(* same goes for reset because it just cancels all anchors... *)
139 :	blume	375	fun resetPathConfig () = PathConfig.reset pcmode
140 :
141 :			fun showPending () = let
142 :			fun one (s, _) = let
143 :			val nss = Symbol.nameSpaceToString (Symbol.nameSpace s)
144 :			val n = Symbol.name s
145 :			in
146 :			Say.say [" ", nss, " ", n, "\n"]
147 :			end
148 :			in
149 :			SymbolMap.appi one (AutoLoad.getPending ())
150 :			end
151 :
152 :			fun initPaths () = let
153 :			val lpcth = EnvConfig.getSet StdConfig.local_pathconfig NONE
154 :			val p = case lpcth () of
155 :			NONE => []
156 :			| SOME f => [f]
157 :			val p = EnvConfig.getSet StdConfig.pathcfgspec NONE :: p
158 :			fun processOne f = PathConfig.processSpecFile (pcmode, f)
159 :			handle _ => ()
160 :			in
161 :			app processOne p
162 :			end
163 :
164 :			fun param () = let
165 :			val v = valOf (!theValues)
166 :			handle Option =>
167 :			raise Fail "CMBoot: theParam not initialized"
168 :			in
169 :			{ primconf = #primconf v,
170 :			fnpolicy = fnpolicy,
171 :			pcmode = pcmode,
172 :			symenv = SSV.env,
173 :			keep_going = EnvConfig.getSet StdConfig.keep_going NONE,
174 :			pervasive = #pervasive v,
175 :			corenv = #corenv v,
176 :			pervcorepids = #pervcorepids v }
177 :			end
178 :
179 :			fun autoload s = let
180 :			val c = SrcPath.cwdContext ()
181 :			val p = SrcPath.standard pcmode { context = c, spec = s }
182 :			in
183 :			case Parse.parse (SOME al_greg) (param ()) NONE p of
184 :			NONE => false
185 :			| SOME (g, _) =>
186 :			(AutoLoad.register (GenericVC.EnvRef.topLevel, g);
187 :			true)
188 :			end
189 :
190 :			fun al_ginfo () = { param = param (),
191 :			groupreg = al_greg,
192 :			errcons = EM.defaultConsumer () }
193 :
194 :			val al_manager = AutoLoad.mkManager al_ginfo
195 :
196 :			fun al_manager' (ast, _, ter) = al_manager (ast, ter)
197 :
198 :			fun run sflag f s = let
199 :			val c = SrcPath.cwdContext ()
200 :			val p = SrcPath.standard pcmode { context = c, spec = s }
201 :			in
202 :			case Parse.parse NONE (param ()) sflag p of
203 :			NONE => false
204 :			| SOME (g, gp) => f gp g
205 :			end
206 :
207 :			fun stabilize_runner gp g = true
208 :
209 :			fun stabilize recursively = run (SOME recursively) stabilize_runner
210 :			val recomp = run NONE recomp_runner
211 :			val make = run NONE make_runner
212 :
213 :			fun reset () =
214 :			(FullPersstate.reset ();
215 :			RT.reset ();
216 :			ET.reset ();
217 :			Recomp.reset ();
218 :			Exec.reset ();
219 :			AutoLoad.reset ();
220 :			Parse.reset ();
221 :			SmlInfo.forgetAllBut SrcPathSet.empty)
222 :
223 :			fun initTheValues (bootdir, er) = let
224 :			val _ = let
225 :			fun listDir ds = let
226 :			fun loop l =
227 :			case OS.FileSys.readDir ds of
228 :			"" => l
229 :			| x => loop (x :: l)
230 :			in
231 :			loop []
232 :			end
233 :			val fileList = SafeIO.perform
234 :			{ openIt = fn () => OS.FileSys.openDir bootdir,
235 :			closeIt = OS.FileSys.closeDir,
236 :			work = listDir,
237 :			cleanup = fn () => () }
238 :			fun isDir x =
239 :			OS.FileSys.isDir x handle _ => false
240 :			fun subDir x = let
241 :			val d = OS.Path.concat (bootdir, x)
242 :			in
243 :			if isDir d then SOME (x, d) else NONE
244 :			end
245 :			val pairList = List.mapPartial subDir fileList
246 :			in
247 :			app (fn (x, d) => PathConfig.set (pcmode, x, d)) pairList
248 :			end
249 :			val initgspec =
250 :			SrcPath.standard pcmode { context = SrcPath.cwdContext (),
251 :			spec = BtNames.initgspec }
252 :			val ginfo = { param = { primconf = Primitive.primEnvConf,
253 :			fnpolicy = fnpolicy,
254 :			pcmode = pcmode,
255 :			symenv = SSV.env,
256 :			keep_going = false,
257 :			pervasive = E.emptyEnv,
258 :			corenv = BE.staticPart BE.emptyEnv,
259 :			pervcorepids = PidSet.empty },
260 :			groupreg = GroupReg.new (),
261 :			errcons = EM.defaultConsumer () }
262 :			in
263 :			case BuildInitDG.build ginfo initgspec of
264 :			NONE => raise Fail "CMBoot: BuiltInitDG.build"
265 :			| SOME { rts, core, pervasive, primitives, ... } => let
266 :			(* It is absolutely crucial that we don't finish the
267 :			* recomp traversal until we are done with all
268 :			* nodes of the InitDG. This is because we have
269 :			* been cheating, and if we ever have to try and
270 :			* fetch assembly.sig or core.sml in a separate
271 :			* traversal, it will fail. *)
272 :			val rtts = RT.start ()
273 :			fun get n = let
274 :			val { stat = (s, sp), sym = (sy, syp), ctxt, bfc } =
275 :			valOf (RT.sbnode rtts ginfo n)
276 :			(* Since we cannot start another recomp traversal,
277 :			* we must also avoid exec traversals (because they
278 :			* would internally trigger recomp traversals).
279 :			* But at boot time any relevant value should be
280 :			* available as a sysval, so there is no problem. *)
281 :			val d =
282 :			case Option.map (FullPersstate.sysval o
283 :			BF.exportPidOf) bfc of
284 :			SOME (SOME d) => d
285 :			| _ => emptydyn
286 :			val env = E.mkenv { static = s, symbolic = sy,
287 :			dynamic = d }
288 :			val pidInfo = { statpid = sp, sympid = syp,
289 :			ctxt = ctxt }
290 :			in
291 :			(env, pidInfo)
292 :			end
293 :			fun getPspec (name, n) = let
294 :			val (env, pidInfo) = get n
295 :			in
296 :			{ name = name, env = env, pidInfo = pidInfo }
297 :			end
298 :
299 :			val (core, corePidInfo) = get core
300 :			val corenv = CoerceEnv.es2bs (E.staticPart core)
301 :			val (rts, _) = get rts
302 :			val (pervasive0, pervPidInfo) = get pervasive
303 :			val pspecs = map getPspec primitives
304 :			val core_symdyn =
305 :			E.mkenv { static = E.staticPart E.emptyEnv,
306 :			dynamic = E.dynamicPart core,
307 :			symbolic = E.symbolicPart core }
308 :			val pervasive = E.layerEnv (pervasive0, core_symdyn)
309 :			val pervcorepids =
310 :			PidSet.addList (PidSet.empty,
311 :			[#statpid corePidInfo,
312 :			#statpid pervPidInfo,
313 :			#sympid pervPidInfo])
314 :			in
315 :			(* Nobody is going to try and share this state --
316 :			* or, rather, this state is shared via access
317 :			* to "primitives". Therefore, we don't call
318 :			* RT.finish and ET.finish and reset the state. *)
319 :			FullPersstate.reset ();
320 :			#set ER.core corenv;
321 :			#set ER.pervasive pervasive;
322 :			#set ER.topLevel BE.emptyEnv;
323 :			theValues :=
324 :			SOME { primconf = Primitive.configuration pspecs,
325 :			pervasive = pervasive,
326 :			corenv = corenv,
327 :			pervcorepids = pervcorepids };
328 :			case er of
329 :			BARE =>
330 :			(make "basis.cm";
331 :			make "host-compiler.cm";
332 :			system_values := emptydyn)
333 :			| AUTOLOAD =>
334 :			(HostMachDepVC.Interact.installCompManager
335 :			(SOME al_manager');
336 :			autoload "basis.cm";
337 :			autoload "host-cm.cm";
338 :			CmHook.init
339 :			{ stabilize = stabilize,
340 :			recomp = recomp,
341 :			make = make,
342 :			autoload = autoload,
343 :			reset = reset,
344 :			verbose =
345 :			EnvConfig.getSet StdConfig.verbose,
346 :			debug =
347 :			EnvConfig.getSet StdConfig.debug,
348 :			keep_going =
349 :			EnvConfig.getSet StdConfig.keep_going,
350 :			parse_caching =
351 :			EnvConfig.getSet StdConfig.parse_caching,
352 :			setAnchor = setAnchor,
353 :			cancelAnchor = cancelAnchor,
354 :			resetPathConfig = resetPathConfig,
355 :			synchronize = SrcPath.sync,
356 :			showPending = showPending })
357 :
358 :			end
359 :			end
360 :			end
361 :			in
362 :			fun init (bootdir, de, er) =
363 :			(system_values := de;
364 :			initTheValues (bootdir, er);
365 :			Cleanup.install initPaths)
366 :			end
367 :			end

---

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