Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/cm/main/cm-boot.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 380 - (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 : blume 380 structure P = OS.Path
30 :     structure F = OS.FileSys
31 : blume 375
32 :     val os = SMLofNJ.SysInfo.getOSKind ()
33 :    
34 :     structure SSV =
35 :     SpecificSymValFn (structure MachDepVC = HostMachDepVC
36 :     val os = os)
37 :    
38 :     val emptydyn = E.dynamicPart E.emptyEnv
39 :     val system_values = ref emptydyn
40 :    
41 :     (* Instantiate the persistent state functor; this includes
42 :     * the binfile cache and the dynamic value cache *)
43 :     structure FullPersstate =
44 :     FullPersstateFn (structure MachDepVC = HostMachDepVC
45 :     val system_values = system_values)
46 :    
47 :     (* Building "Exec" will automatically also build "Recomp" and
48 :     * "RecompTraversal"... *)
49 :     local
50 :     structure E = ExecFn (structure PS = FullPersstate)
51 :     in
52 :     structure Recomp = E.Recomp
53 :     structure RT = E.RecompTraversal
54 :     structure Exec = E.Exec
55 :     end
56 :    
57 :     structure ET = CompileGenericFn (structure CT = Exec)
58 :    
59 :     structure AutoLoad = AutoLoadFn
60 :     (structure RT = RT
61 :     structure ET = ET)
62 :    
63 :     (* The StabilizeFn functor needs a way of converting bnodes to
64 :     * dependency-analysis environments. This can be achieved quite
65 :     * conveniently by a "recompile" traversal for bnodes. *)
66 :     fun bn2statenv gp i = #1 (#stat (valOf (RT.bnode' gp i)))
67 :     handle Option => raise Fail "bn2statenv"
68 :    
69 :     (* exec_group is basically the same as ET.group with
70 : blume 379 * one additional actions to be taken:
71 :     * Before executing the code, we announce the priviliges
72 : blume 375 * that are being invoked. (For the time being, we assume
73 :     * that everybody has every conceivable privilege, but at the
74 : blume 379 * very least we announce which ones are being made use of.) *)
75 : blume 375 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 : blume 380 case F.readDir ds of
228 : blume 375 "" => l
229 :     | x => loop (x :: l)
230 :     in
231 :     loop []
232 :     end
233 :     val fileList = SafeIO.perform
234 : blume 380 { openIt = fn () => F.openDir bootdir,
235 :     closeIt = F.closeDir,
236 : blume 375 work = listDir,
237 :     cleanup = fn () => () }
238 : blume 380 fun isDir x = F.isDir x handle _ => false
239 : blume 375 fun subDir x = let
240 : blume 380 val d = P.concat (bootdir, x)
241 : blume 375 in
242 :     if isDir d then SOME (x, d) else NONE
243 :     end
244 :     val pairList = List.mapPartial subDir fileList
245 :     in
246 :     app (fn (x, d) => PathConfig.set (pcmode, x, d)) pairList
247 :     end
248 :     val initgspec =
249 :     SrcPath.standard pcmode { context = SrcPath.cwdContext (),
250 :     spec = BtNames.initgspec }
251 :     val ginfo = { param = { primconf = Primitive.primEnvConf,
252 :     fnpolicy = fnpolicy,
253 :     pcmode = pcmode,
254 :     symenv = SSV.env,
255 :     keep_going = false,
256 :     pervasive = E.emptyEnv,
257 :     corenv = BE.staticPart BE.emptyEnv,
258 :     pervcorepids = PidSet.empty },
259 :     groupreg = GroupReg.new (),
260 :     errcons = EM.defaultConsumer () }
261 :     in
262 :     case BuildInitDG.build ginfo initgspec of
263 :     NONE => raise Fail "CMBoot: BuiltInitDG.build"
264 :     | SOME { rts, core, pervasive, primitives, ... } => let
265 :     (* It is absolutely crucial that we don't finish the
266 :     * recomp traversal until we are done with all
267 :     * nodes of the InitDG. This is because we have
268 :     * been cheating, and if we ever have to try and
269 :     * fetch assembly.sig or core.sml in a separate
270 :     * traversal, it will fail. *)
271 :     val rtts = RT.start ()
272 :     fun get n = let
273 :     val { stat = (s, sp), sym = (sy, syp), ctxt, bfc } =
274 :     valOf (RT.sbnode rtts ginfo n)
275 :     (* Since we cannot start another recomp traversal,
276 :     * we must also avoid exec traversals (because they
277 :     * would internally trigger recomp traversals).
278 :     * But at boot time any relevant value should be
279 :     * available as a sysval, so there is no problem. *)
280 :     val d =
281 :     case Option.map (FullPersstate.sysval o
282 :     BF.exportPidOf) bfc of
283 :     SOME (SOME d) => d
284 :     | _ => emptydyn
285 :     val env = E.mkenv { static = s, symbolic = sy,
286 :     dynamic = d }
287 :     val pidInfo = { statpid = sp, sympid = syp,
288 :     ctxt = ctxt }
289 :     in
290 :     (env, pidInfo)
291 :     end
292 :     fun getPspec (name, n) = let
293 :     val (env, pidInfo) = get n
294 :     in
295 :     { name = name, env = env, pidInfo = pidInfo }
296 :     end
297 :    
298 :     val (core, corePidInfo) = get core
299 :     val corenv = CoerceEnv.es2bs (E.staticPart core)
300 :     val (rts, _) = get rts
301 :     val (pervasive0, pervPidInfo) = get pervasive
302 :     val pspecs = map getPspec primitives
303 :     val core_symdyn =
304 :     E.mkenv { static = E.staticPart E.emptyEnv,
305 :     dynamic = E.dynamicPart core,
306 :     symbolic = E.symbolicPart core }
307 :     val pervasive = E.layerEnv (pervasive0, core_symdyn)
308 :     val pervcorepids =
309 :     PidSet.addList (PidSet.empty,
310 :     [#statpid corePidInfo,
311 :     #statpid pervPidInfo,
312 :     #sympid pervPidInfo])
313 :     in
314 :     (* Nobody is going to try and share this state --
315 :     * or, rather, this state is shared via access
316 :     * to "primitives". Therefore, we don't call
317 :     * RT.finish and ET.finish and reset the state. *)
318 :     FullPersstate.reset ();
319 :     #set ER.core corenv;
320 :     #set ER.pervasive pervasive;
321 :     #set ER.topLevel BE.emptyEnv;
322 :     theValues :=
323 :     SOME { primconf = Primitive.configuration pspecs,
324 :     pervasive = pervasive,
325 :     corenv = corenv,
326 :     pervcorepids = pervcorepids };
327 :     case er of
328 :     BARE =>
329 :     (make "basis.cm";
330 :     make "host-compiler.cm";
331 :     system_values := emptydyn)
332 :     | AUTOLOAD =>
333 :     (HostMachDepVC.Interact.installCompManager
334 :     (SOME al_manager');
335 :     autoload "basis.cm";
336 :     autoload "host-cm.cm";
337 :     CmHook.init
338 :     { stabilize = stabilize,
339 :     recomp = recomp,
340 :     make = make,
341 :     autoload = autoload,
342 :     reset = reset,
343 :     verbose =
344 :     EnvConfig.getSet StdConfig.verbose,
345 :     debug =
346 :     EnvConfig.getSet StdConfig.debug,
347 :     keep_going =
348 :     EnvConfig.getSet StdConfig.keep_going,
349 :     parse_caching =
350 :     EnvConfig.getSet StdConfig.parse_caching,
351 :     setAnchor = setAnchor,
352 :     cancelAnchor = cancelAnchor,
353 :     resetPathConfig = resetPathConfig,
354 :     synchronize = SrcPath.sync,
355 :     showPending = showPending })
356 :    
357 :     end
358 :     end
359 :     end
360 :     in
361 :     fun init (bootdir, de, er) =
362 :     (system_values := de;
363 :     initTheValues (bootdir, er);
364 :     Cleanup.install initPaths)
365 :     end
366 :     end

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