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

Parent Directory | Revision Log

---

Revision 363 - (view) (download)

1 :	blume	360	functor LinkCM (structure HostMachDepVC : MACHDEP_VC) = struct
2 :
3 :	blume	362	datatype envrequest = AUTOLOAD | BARE
4 :
5 :	blume	360	local
6 :			structure YaccTool = YaccTool
7 :			structure LexTool = LexTool
8 :			structure BurgTool = BurgTool
9 :
10 :			structure E = GenericVC.Environment
11 :			structure SE = GenericVC.StaticEnv
12 :			structure ER = GenericVC.EnvRef
13 :			structure BE = GenericVC.BareEnvironment
14 :			structure CMSE = GenericVC.CMStaticEnv
15 :			structure S = GenericVC.Symbol
16 :			structure CoerceEnv = GenericVC.CoerceEnv
17 :			structure EM = GenericVC.ErrorMsg
18 :
19 :			val os = SMLofNJ.SysInfo.getOSKind ()
20 :
21 :			structure SSV =
22 :			SpecificSymValFn (structure MachDepVC = HostMachDepVC
23 :			val os = os)
24 :
25 :	blume	362	val emptydyn = E.dynamicPart E.emptyEnv
26 :			val system_values = ref emptydyn
27 :	blume	360
28 :			(* Instantiate the persistent state functor; this includes
29 :			* the binfile cache and the dynamic value cache *)
30 :			structure FullPersstate =
31 :			FullPersstateFn (structure MachDepVC = HostMachDepVC
32 :	blume	362	val system_values = system_values)
33 :	blume	360
34 :			(* Create two arguments appropriate for being passed to
35 :			* CompileGenericFn. One instantiation of that functor
36 :			* is responsible for "recompile" traversals, the other one
37 :			* does "link" traversals. Notice how the two share the same
38 :			* underlying state. *)
39 :			structure Recomp = RecompFn (structure PS = FullPersstate)
40 :			structure Exec = ExecFn (structure PS = FullPersstate)
41 :
42 :			(* make the two traversals *)
43 :			structure RT = CompileGenericFn (structure CT = Recomp)
44 :			structure ET = CompileGenericFn (structure CT = Exec)
45 :
46 :			(* The StabilizeFn functor needs a way of converting bnodes to
47 :			* dependency-analysis environments. This can be achieved quite
48 :			* conveniently by a "recompile" traversal for bnodes. *)
49 :			fun bn2statenv gp i = #1 (#stat (valOf (RT.bnode gp i)))
50 :			handle Option => raise Fail "bn2statenv"
51 :
52 :			(* exec_group is basically the same as ET.group with
53 :			* two additional actions to be taken:
54 :			* 1. Before executing the code, we announce the priviliges
55 :			* that are being invoked. (For the time being, we assume
56 :			* that everybody has every conceivable privilege, but at the
57 :			* very least we announce which ones are being made use of.)
58 :			* 2. After we are done we must make the values of "shared"
59 :			* compilation units permanent. *)
60 :			fun exec_group gp (g as GroupGraph.GROUP { required = rq, ... }) =
61 :			(if StringSet.isEmpty rq then ()
62 :			else Say.say ("$Execute: required privileges are:\n" ::
63 :			map (fn s => (" " ^ s ^ "\n")) (StringSet.listItems rq));
64 :			ET.group gp g
65 :			before FullPersstate.rememberShared ())
66 :
67 :			fun recomp_runner gp g = isSome (RT.group gp g)
68 :
69 :			(* This function combines the actions of "recompile" and "exec".
70 :			* When successful, it combines the results (thus forming a full
71 :			* environment) and adds it to the toplevel environment. *)
72 :			fun make_runner gp g =
73 :			case RT.group gp g of
74 :			NONE => false
75 :			| SOME { stat, sym} =>
76 :			(case exec_group gp g of
77 :			NONE => false
78 :			| SOME dyn => let
79 :			val delta = E.mkenv { static = stat, symbolic = sym,
80 :			dynamic = dyn }
81 :			val base = #get ER.topLevel ()
82 :			val new = BE.concatEnv (CoerceEnv.e2b delta, base)
83 :			in
84 :			#set ER.topLevel new;
85 :			Say.vsay ["[New bindings added.]\n"];
86 :			true
87 :			end)
88 :
89 :			fun al_loadit gp m =
90 :			case RT.impexpmap gp m of
91 :			NONE => NONE
92 :			| SOME { stat, sym } => let
93 :			fun exec () =
94 :			ET.impexpmap gp m
95 :			before FullPersstate.rememberShared ()
96 :			in
97 :			case exec () of
98 :			NONE => NONE
99 :			| SOME dyn => let
100 :			val e = E.mkenv { static = stat, symbolic = sym,
101 :			dynamic =dyn }
102 :			val be = GenericVC.CoerceEnv.e2b e
103 :			in
104 :			SOME be
105 :			end
106 :			end
107 :
108 :			val al_greg = GroupReg.new ()
109 :
110 :			(* Instantiate the stabilization mechanism. *)
111 :			structure Stabilize =
112 :			StabilizeFn (val bn2statenv = bn2statenv
113 :			val getPid = FullPersstate.pid_fetch_sml
114 :	blume	363	val recomp = recomp_runner
115 :			val transfer_state = FullPersstate.transfer_state)
116 :	blume	360
117 :			(* Access to the stabilization mechanism is integrated into the
118 :			* parser. I'm not sure if this is the cleanest way, but it works
119 :			* well enough. *)
120 :	blume	362	structure Parse = ParseFn (structure Stabilize = Stabilize
121 :			val pending = AutoLoad.getPending)
122 :	blume	360
123 :			local
124 :			type kernelValues =
125 :			{ primconf : Primitive.configuration,
126 :			pervasive : E.environment,
127 :			corenv : BE.staticEnv,
128 :			pervcorepids : PidSet.set }
129 :
130 :			val fnpolicy = FilenamePolicy.colocate
131 :			{ os = os, arch = HostMachDepVC.architecture }
132 :
133 :	blume	361	val pcmode = PathConfig.new ()
134 :	blume	360
135 :			val theValues = ref (NONE: kernelValues option)
136 :
137 :			in
138 :	blume	361	fun initPaths () = let
139 :			val p =
140 :			case OS.Process.getEnv "HOME" of
141 :			NONE => []
142 :			| SOME h => [OS.Path.concat (h, ".smlnj-pathconfig")]
143 :			val p = EnvConfig.getSet StdConfig.pathcfgspec NONE :: p
144 :			fun processOne f = PathConfig.processSpecFile (pcmode, f)
145 :			handle _ => ()
146 :			in
147 :			app processOne p
148 :			end
149 :
150 :	blume	360	fun param () = let
151 :			val v = valOf (!theValues)
152 :			handle Option =>
153 :			raise Fail "CMBoot: theParam not initialized"
154 :			in
155 :			{ primconf = #primconf v,
156 :			fnpolicy = fnpolicy,
157 :	blume	361	pcmode = pcmode,
158 :	blume	360	symenv = SSV.env,
159 :			keep_going = EnvConfig.getSet StdConfig.keep_going NONE,
160 :			pervasive = #pervasive v,
161 :			corenv = #corenv v,
162 :			pervcorepids = #pervcorepids v }
163 :			end
164 :
165 :			fun autoload s = let
166 :			val c = SrcPath.cwdContext ()
167 :			val p = SrcPath.standard pcmode { context = c, spec = s }
168 :			in
169 :			case Parse.parse (SOME al_greg) (param ()) NONE p of
170 :			NONE => false
171 :			| SOME (g, _) =>
172 :			(AutoLoad.register (GenericVC.EnvRef.topLevel, g);
173 :			true)
174 :			end
175 :
176 :			fun al_ginfo () = { param = param (),
177 :			groupreg = al_greg,
178 :			errcons = EM.defaultConsumer () }
179 :
180 :			val al_manager =
181 :			AutoLoad.mkManager (fn m => al_loadit (al_ginfo ()) m)
182 :
183 :			fun al_manager' (ast, _, ter) = al_manager (ast, ter)
184 :
185 :	blume	362	fun run sflag f s = let
186 :			val c = SrcPath.cwdContext ()
187 :			val p = SrcPath.standard pcmode { context = c, spec = s }
188 :			in
189 :			case Parse.parse NONE (param ()) sflag p of
190 :			NONE => false
191 :			| SOME (g, gp) => f gp g
192 :			end
193 :
194 :			fun stabilize_runner gp g = true
195 :
196 :			fun stabilize recursively = run (SOME recursively) stabilize_runner
197 :			val recomp = run NONE recomp_runner
198 :			val make = run NONE make_runner
199 :
200 :			fun reset () =
201 :			(FullPersstate.reset ();
202 :			RT.resetAll ();
203 :			ET.resetAll ();
204 :			Recomp.reset ();
205 :			Exec.reset ();
206 :			AutoLoad.reset ();
207 :			SmlInfo.forgetAllBut SrcPathSet.empty)
208 :
209 :			fun initTheValues (bootdir, er) = let
210 :	blume	361	val _ = let
211 :			fun listDir ds = let
212 :			fun loop l =
213 :			case OS.FileSys.readDir ds of
214 :			"" => l
215 :			| x => loop (x :: l)
216 :			in
217 :			loop []
218 :			end
219 :			val fileList = SafeIO.perform
220 :			{ openIt = fn () => OS.FileSys.openDir bootdir,
221 :			closeIt = OS.FileSys.closeDir,
222 :			work = listDir,
223 :			cleanup = fn () => () }
224 :			fun isDir x =
225 :			OS.FileSys.isDir x handle _ => false
226 :			fun subDir x = let
227 :			val d = OS.Path.concat (bootdir, x)
228 :			in
229 :			if isDir d then SOME (x, d) else NONE
230 :			end
231 :			val pairList = List.mapPartial subDir fileList
232 :			in
233 :			app (fn (x, d) => PathConfig.set (pcmode, x, d)) pairList
234 :			end
235 :	blume	360	val initgspec =
236 :			SrcPath.standard pcmode { context = SrcPath.cwdContext (),
237 :			spec = BtNames.initgspec }
238 :			val ginfo = { param = { primconf = Primitive.primEnvConf,
239 :			fnpolicy = fnpolicy,
240 :			pcmode = pcmode,
241 :			symenv = SSV.env,
242 :			keep_going = false,
243 :			pervasive = E.emptyEnv,
244 :			corenv = BE.staticPart BE.emptyEnv,
245 :			pervcorepids = PidSet.empty },
246 :			groupreg = GroupReg.new (),
247 :			errcons = EM.defaultConsumer () }
248 :			in
249 :			case BuildInitDG.build ginfo initgspec of
250 :			NONE => raise Fail "CMBoot: BuiltInitDG.build"
251 :			| SOME { rts, core, pervasive, primitives, ... } => let
252 :			fun get n = let
253 :			val { stat = (s, sp), sym = (sy, syp), ctxt } =
254 :			valOf (RT.sbnode ginfo n)
255 :			val d = Exec.env2result (valOf (ET.sbnode ginfo n))
256 :			val env = E.mkenv { static = s, symbolic = sy,
257 :			dynamic = d }
258 :			val pidInfo = { statpid = sp, sympid = syp,
259 :			ctxt = ctxt }
260 :			in
261 :			(env, pidInfo)
262 :			end
263 :			fun getPspec (name, n) = let
264 :			val (env, pidInfo) = get n
265 :			in
266 :			{ name = name, env = env, pidInfo = pidInfo }
267 :			end
268 :
269 :			val (core, corePidInfo) = get core
270 :			val corenv = CoerceEnv.es2bs (E.staticPart core)
271 :			val (rts, _) = get rts
272 :			val (pervasive0, pervPidInfo) = get pervasive
273 :			val pspecs = map getPspec primitives
274 :			val core_symdyn =
275 :			E.mkenv { static = E.staticPart E.emptyEnv,
276 :			dynamic = E.dynamicPart core,
277 :			symbolic = E.symbolicPart core }
278 :			val pervasive = E.layerEnv (pervasive0, core_symdyn)
279 :			val pervcorepids =
280 :			PidSet.addList (PidSet.empty,
281 :			[#statpid corePidInfo,
282 :			#statpid pervPidInfo,
283 :			#sympid pervPidInfo])
284 :			in
285 :			#set ER.core corenv;
286 :			#set ER.pervasive pervasive;
287 :			#set ER.topLevel BE.emptyEnv;
288 :			theValues :=
289 :			SOME { primconf = Primitive.configuration pspecs,
290 :			pervasive = pervasive,
291 :			corenv = corenv,
292 :			pervcorepids = pervcorepids };
293 :	blume	362	case er of
294 :			BARE =>
295 :			(make "basis.cm";
296 :			make "host-compiler.cm";
297 :			system_values := emptydyn)
298 :			| AUTOLOAD =>
299 :			(HostMachDepVC.Interact.installCompManager
300 :			(SOME al_manager');
301 :			autoload "basis.cm";
302 :			AutoLoadHook.autoloadHook := autoload)
303 :	blume	360	end
304 :			end
305 :			end
306 :			in
307 :			structure CM = struct
308 :	blume	362	val stabilize = stabilize
309 :			val recomp = recomp
310 :			val make = make
311 :	blume	360	val autoload = autoload
312 :	blume	362	val reset = reset
313 :	blume	360	end
314 :
315 :	blume	362	fun init (bootdir, de, er) =
316 :			(system_values := de;
317 :			initTheValues (bootdir, er);
318 :	blume	361	Cleanup.install initPaths)
319 :	blume	360	end
320 :			end

---

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