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

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