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 578 - (view) (download)

1 : blume 375 (*
2 :     * This is the module that actually puts together the contents of the
3 : blume 537 * structure CM that people find in full-cm.cm. 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 : blume 569 structure DE = DynamicEnv
18 : blume 375 structure SE = GenericVC.StaticEnv
19 :     structure ER = GenericVC.EnvRef
20 :     structure BE = GenericVC.BareEnvironment
21 :     structure CMSE = GenericVC.CMStaticEnv
22 :     structure S = GenericVC.Symbol
23 :     structure CoerceEnv = GenericVC.CoerceEnv
24 :     structure EM = GenericVC.ErrorMsg
25 :     structure BF = HostMachDepVC.Binfile
26 : blume 380 structure P = OS.Path
27 :     structure F = OS.FileSys
28 : blume 451 structure DG = DependencyGraph
29 : blume 375
30 :     val os = SMLofNJ.SysInfo.getOSKind ()
31 : blume 464 val my_archos =
32 :     concat [HostMachDepVC.architecture, "-", FilenamePolicy.kind2name os]
33 : blume 375
34 :     structure SSV =
35 :     SpecificSymValFn (structure MachDepVC = HostMachDepVC
36 :     val os = os)
37 :    
38 :     val emptydyn = E.dynamicPart E.emptyEnv
39 : blume 569 val system_values = ref (SrcPathMap.empty: E.dynenv SrcPathMap.map)
40 : blume 375
41 : blume 400 structure Compile =
42 : blume 448 CompileFn (structure MachDepVC = HostMachDepVC
43 : blume 464 val compile_there = Servers.compile o SrcPath.descr)
44 : blume 400
45 : blume 537 structure BFC =
46 :     BfcFn (structure MachDepVC = HostMachDepVC)
47 :    
48 : blume 399 structure Link =
49 :     LinkFn (structure MachDepVC = HostMachDepVC
50 : blume 537 structure BFC = BFC
51 : blume 399 val system_values = system_values)
52 : blume 375
53 :     structure AutoLoad = AutoLoadFn
54 : blume 399 (structure C = Compile
55 : blume 403 structure L = Link
56 :     structure BFC = BFC)
57 : blume 375
58 : blume 537 val mkBootList = #l o MkBootList.group (fn p => p)
59 :    
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 518 fun make_runner add_bindings 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 537 (* Before executing the code, we announce the privileges
87 : blume 399 * 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 : blume 518 | SOME dyn =>
98 :     (if add_bindings then
99 :     let val delta = E.mkenv { static = stat,
100 :     symbolic = sym,
101 :     dynamic = dyn }
102 :     val base = #get ER.topLevel ()
103 :     val new =
104 :     BE.concatEnv (CoerceEnv.e2b delta,
105 :     base)
106 :     in
107 :     #set ER.topLevel new;
108 :     Say.vsay ["[New bindings added.]\n"]
109 :     end
110 :     else ();
111 :     true))
112 : blume 399 end
113 : blume 375
114 :     val al_greg = GroupReg.new ()
115 :    
116 :     (* Instantiate the stabilization mechanism. *)
117 :     structure Stabilize =
118 : blume 403 StabilizeFn (structure MachDepVC = HostMachDepVC
119 :     fun recomp gp g = let
120 :     val { store, get } = BFC.new ()
121 : blume 456 val _ = init_servers g
122 : blume 403 val { group, ... } =
123 :     Compile.newTraversal (Link.evict, store, g)
124 :     in
125 : blume 450 case Servers.withServers (fn () => group gp) of
126 : blume 403 NONE => NONE
127 :     | SOME _ => SOME get
128 :     end
129 :     val getII = Compile.getII)
130 : blume 375
131 :     (* Access to the stabilization mechanism is integrated into the
132 :     * parser. I'm not sure if this is the cleanest way, but it works
133 :     * well enough. *)
134 :     structure Parse = ParseFn (structure Stabilize = Stabilize
135 : blume 537 fun evictStale () =
136 :     (Compile.evictStale ();
137 :     Link.evictStale ())
138 : blume 375 val pending = AutoLoad.getPending)
139 :    
140 :     local
141 :     type kernelValues =
142 : blume 537 { corenv : BE.environment,
143 :     init_group : GroupGraph.group }
144 : blume 375
145 :     val fnpolicy = FilenamePolicy.colocate
146 :     { os = os, arch = HostMachDepVC.architecture }
147 :    
148 :     val pcmode = PathConfig.new ()
149 :    
150 :     val theValues = ref (NONE: kernelValues option)
151 :    
152 :     in
153 : blume 377 (* 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 569 fun setAnchor a NONE = PathConfig.cancel (pcmode, a)
157 :     | setAnchor a (SOME s) = (PathConfig.set (pcmode, a, s);
158 :     SrcPath.sync ())
159 : blume 377 (* same goes for reset because it just cancels all anchors... *)
160 : blume 375 fun resetPathConfig () = PathConfig.reset pcmode
161 : blume 569 (* get the current binding for an anchor *)
162 :     fun getAnchor a () =
163 :     Option.map (fn f => f ()) (PathConfig.configAnchor pcmode a)
164 : blume 375
165 : blume 525 fun mkStdSrcPath s =
166 :     SrcPath.standard pcmode { context = SrcPath.cwdContext (),
167 :     spec = s }
168 :    
169 : blume 479 fun getPending () = let
170 : blume 375 fun one (s, _) = let
171 :     val nss = Symbol.nameSpaceToString (Symbol.nameSpace s)
172 :     val n = Symbol.name s
173 :     in
174 : blume 479 concat [" ", nss, " ", n, "\n"]
175 : blume 375 end
176 :     in
177 : blume 479 map one (SymbolMap.listItemsi (AutoLoad.getPending ()))
178 : blume 375 end
179 :    
180 :     fun initPaths () = let
181 : blume 433 val lpcth = #get StdConfig.local_pathconfig ()
182 : blume 375 val p = case lpcth () of
183 :     NONE => []
184 :     | SOME f => [f]
185 : blume 433 val p = #get StdConfig.pathcfgspec () :: p
186 : blume 375 fun processOne f = PathConfig.processSpecFile (pcmode, f)
187 :     handle _ => ()
188 :     in
189 :     app processOne p
190 :     end
191 :    
192 : blume 537 fun getTheValues () = valOf (!theValues)
193 :     handle Option => raise Fail "CMBoot: theParam not initialized"
194 :    
195 : blume 375 fun param () = let
196 : blume 537 val v = getTheValues ()
197 : blume 375 in
198 : blume 537 { fnpolicy = fnpolicy,
199 : blume 375 pcmode = pcmode,
200 : blume 433 symval = SSV.symval,
201 :     keep_going = #get StdConfig.keep_going (),
202 : blume 537 corenv = #corenv v }
203 : blume 375 end
204 :    
205 : blume 537 val init_group = #init_group o getTheValues
206 :    
207 : blume 507 fun dropPickles () =
208 :     if #get StdConfig.conserve_memory () then
209 :     Parse.dropPickles ()
210 :     else ()
211 :    
212 : blume 537 fun parse_arg (gr, sflag, p) =
213 :     { load_plugin = load_plugin, gr = gr, param = param (),
214 : blume 569 stabflag = sflag, group = p,
215 :     init_group = init_group (), paranoid = false }
216 : blume 537
217 :     and autoload s = let
218 : blume 525 val p = mkStdSrcPath s
219 : blume 375 in
220 : blume 537 (case Parse.parse (parse_arg (al_greg, NONE, p)) of
221 : blume 505 NONE => false
222 :     | SOME (g, _) =>
223 : blume 537 (AutoLoad.register (GenericVC.EnvRef.topLevel, g);
224 :     true))
225 : blume 507 before dropPickles ()
226 : blume 375 end
227 :    
228 : blume 578 and run mkSrcPath sflag f s = let
229 :     val p = mkSrcPath s
230 : blume 537 val gr = GroupReg.new ()
231 : blume 375 in
232 : blume 537 (case Parse.parse (parse_arg (gr, sflag, p)) of
233 : blume 505 NONE => false
234 :     | SOME (g, gp) => f gp g)
235 : blume 507 before dropPickles ()
236 : blume 375 end
237 :    
238 : blume 578 and load_plugin context x = let
239 : blume 518 val _ = Say.vsay ["[attempting to load plugin ", x, "]\n"]
240 : blume 578 fun mkSrcPath s =
241 :     SrcPath.standard pcmode { context = context, spec = s }
242 : blume 518 val success =
243 : blume 578 run mkSrcPath NONE (make_runner false) x handle _ => false
244 : blume 518 in
245 :     if success then
246 :     Say.vsay ["[plugin ", x, " loaded successfully]\n"]
247 :     else
248 :     Say.vsay ["[unable to load plugin ", x, "]\n"];
249 :     success
250 :     end
251 :    
252 : blume 578 fun cwd_load_plugin x = load_plugin (SrcPath.cwdContext ()) x
253 :    
254 : blume 449 fun stabilize_runner gp g = true
255 :    
256 : blume 578 fun stabilize recursively =
257 :     run mkStdSrcPath (SOME recursively) stabilize_runner
258 :     val recomp = run mkStdSrcPath NONE recomp_runner
259 :     val make = run mkStdSrcPath NONE (make_runner true)
260 : blume 449
261 : blume 537 (* I would have liked to express this using "run", but "run"
262 :     * thinks it has to return a bool... *)
263 :     fun mk_standalone sflag s = let
264 :     val p = mkStdSrcPath s
265 :     val gr = GroupReg.new ()
266 :     in
267 :     (case Parse.parse (parse_arg (gr, sflag, p)) of
268 :     NONE => NONE
269 :     | SOME (g, gp) =>
270 :     if isSome sflag orelse recomp_runner gp g then
271 :     SOME (mkBootList g)
272 :     else NONE)
273 :     before dropPickles ()
274 :     end
275 :    
276 : blume 518 fun slave () = let
277 : blume 537 val gr = GroupReg.new ()
278 :     fun parse p = Parse.parse (parse_arg (gr, NONE, p))
279 : blume 518 in
280 : blume 480 Slave.slave { pcmode = pcmode,
281 : blume 518 parse = parse,
282 : blume 480 my_archos = my_archos,
283 :     sbtrav = Compile.newSbnodeTraversal,
284 :     make = make }
285 : blume 518 end
286 : blume 456
287 : blume 518 fun al_ginfo () = { param = param (),
288 :     groupreg = al_greg,
289 :     errcons = EM.defaultConsumer () }
290 :    
291 :     val al_manager =
292 :     AutoLoad.mkManager { get_ginfo = al_ginfo,
293 :     dropPickles = dropPickles }
294 :    
295 :     fun al_manager' (ast, _, ter) = al_manager (ast, ter)
296 :    
297 : blume 375 fun reset () =
298 : blume 399 (Compile.reset ();
299 :     Link.reset ();
300 : blume 375 AutoLoad.reset ();
301 :     Parse.reset ();
302 : blume 487 SmlInfo.reset ())
303 : blume 375
304 : blume 569 fun initTheValues (bootdir, de, er, autoload_postprocess) = let
305 : blume 375 val _ = let
306 :     fun listDir ds = let
307 :     fun loop l =
308 : blume 380 case F.readDir ds of
309 : blume 375 "" => l
310 :     | x => loop (x :: l)
311 :     in
312 :     loop []
313 :     end
314 :     val fileList = SafeIO.perform
315 : blume 380 { openIt = fn () => F.openDir bootdir,
316 :     closeIt = F.closeDir,
317 : blume 375 work = listDir,
318 : blume 459 cleanup = fn _ => () }
319 : blume 380 fun isDir x = F.isDir x handle _ => false
320 : blume 375 fun subDir x = let
321 : blume 380 val d = P.concat (bootdir, x)
322 : blume 375 in
323 :     if isDir d then SOME (x, d) else NONE
324 :     end
325 :     val pairList = List.mapPartial subDir fileList
326 :     in
327 :     app (fn (x, d) => PathConfig.set (pcmode, x, d)) pairList
328 :     end
329 : blume 569
330 :     val pidmapfile = P.concat (bootdir, BtNames.pidmap)
331 :     fun readpidmap s = let
332 :     fun loop m = let
333 :     fun enter (d, pids) = let
334 :     fun enter1 (hexp, e) =
335 :     case GenericVC.PersStamps.fromHex hexp of
336 :     SOME p => (DE.bind (p, DE.look de p, e)
337 :     handle DE.Unbound => e)
338 :     | NONE => e
339 :     in
340 :     SrcPathMap.insert (m, SrcPath.fromDescr pcmode d,
341 :     foldl enter1 emptydyn pids)
342 :     end
343 :     in
344 :     case TextIO.inputLine s of
345 :     "" => m
346 :     | line => (case String.tokens Char.isSpace line of
347 :     d :: pids => loop (enter (d, pids))
348 :     | _ => loop m)
349 :     end
350 :     in
351 :     system_values := loop SrcPathMap.empty
352 :     end
353 :    
354 :     val _ =
355 :     SafeIO.perform { openIt = fn () => TextIO.openIn pidmapfile,
356 :     closeIt = TextIO.closeIn,
357 :     work = readpidmap,
358 :     cleanup = fn _ => () }
359 :    
360 : blume 525 val initgspec = mkStdSrcPath BtNames.initgspec
361 : blume 537 val ginfo = { param = { fnpolicy = fnpolicy,
362 : blume 375 pcmode = pcmode,
363 : blume 433 symval = SSV.symval,
364 : blume 375 keep_going = false,
365 : blume 537 corenv = BE.emptyEnv },
366 : blume 375 groupreg = GroupReg.new (),
367 :     errcons = EM.defaultConsumer () }
368 : blume 537 fun loadInitGroup () =
369 :     Stabilize.loadStable ginfo
370 :     { getGroup = fn _ => raise Fail "CMBoot: initial getGroup",
371 :     anyerrors = ref false }
372 :     initgspec
373 : blume 375 in
374 : blume 537 case loadInitGroup () of
375 :     NONE => raise Fail "CMBoot: unable to load init group"
376 :     | SOME init_group => let
377 :     val _ = Compile.reset ()
378 :     val _ = Link.reset ()
379 : blume 375
380 : blume 537 val { exports = ctm, ... } =
381 :     Compile.newTraversal (fn _ => fn _ => (),
382 :     fn _ => (),
383 :     init_group)
384 :     val { exports = ltm, ... } = Link.newTraversal
385 :     (init_group, fn _ => raise Fail "init: get bfc?")
386 :    
387 :     fun getSymTrav (tr_m, sy) =
388 :     case SymbolMap.find (tr_m, sy) of
389 :     NONE => raise Fail "init: bogus init group (1)"
390 :     | SOME tr => tr
391 :    
392 :     val core_ct = getSymTrav (ctm, PervCoreAccess.coreStrSym)
393 :     val core_lt = getSymTrav (ltm, PervCoreAccess.coreStrSym)
394 :     val perv_ct = getSymTrav (ctm, PervCoreAccess.pervStrSym)
395 :     val perv_lt = getSymTrav (ltm, PervCoreAccess.pervStrSym)
396 :    
397 :     fun doTrav t =
398 :     case t ginfo of
399 :     SOME r => r
400 :     | NONE => raise Fail "init: bogus init group (2)"
401 :    
402 :     val { stat = corestat, sym = coresym } = doTrav core_ct
403 :     val coredyn = doTrav core_lt
404 :     val { stat = pervstat, sym = pervsym } = doTrav perv_ct
405 :     val pervdyn = doTrav perv_lt
406 :    
407 :     val corenv =
408 :     BE.mkenv { static = CoerceEnv.es2bs corestat,
409 :     symbolic = coresym,
410 :     dynamic = coredyn }
411 : blume 375 val core_symdyn =
412 :     E.mkenv { static = E.staticPart E.emptyEnv,
413 : blume 537 dynamic = coredyn, symbolic = coresym }
414 :    
415 :     val pervasive = E.mkenv { static = pervstat,
416 :     symbolic = pervsym,
417 :     dynamic = pervdyn }
418 :    
419 : blume 495 fun bare_autoload x =
420 :     (Say.say
421 :     ["!* ", x,
422 :     ": \"autoload\" not available, using \"make\"\n"];
423 :     make x)
424 :     val bare_preload =
425 :     Preload.preload { make = make,
426 :     autoload = bare_autoload }
427 :     val standard_preload =
428 :     Preload.preload { make = make, autoload = autoload }
429 : blume 375 in
430 : blume 537 #set ER.core (BE.staticPart corenv);
431 :     #set ER.pervasive (E.layerEnv (pervasive, core_symdyn));
432 : blume 375 #set ER.topLevel BE.emptyEnv;
433 : blume 537 theValues := SOME { corenv = corenv,
434 :     init_group = init_group };
435 : blume 375 case er of
436 :     BARE =>
437 : blume 495 (bare_preload BtNames.bare_preloads;
438 : blume 569 system_values := SrcPathMap.empty;
439 : blume 495 NONE)
440 : blume 375 | AUTOLOAD =>
441 :     (HostMachDepVC.Interact.installCompManager
442 :     (SOME al_manager');
443 : blume 495 standard_preload BtNames.standard_preloads;
444 : blume 375 CmHook.init
445 :     { stabilize = stabilize,
446 :     recomp = recomp,
447 :     make = make,
448 : blume 495 autoload = autoload };
449 : blume 507 (* unconditionally drop all library pickles *)
450 :     Parse.dropPickles ();
451 : blume 495 SOME (autoload_postprocess ()))
452 : blume 375 end
453 :     end
454 :     end
455 :     in
456 : blume 495 fun init (bootdir, de, er) = let
457 :     fun procCmdLine () = let
458 :     val autoload = ignore o autoload
459 :     val make = ignore o make
460 :     fun p (f, ("sml" | "sig"), mk) = HostMachDepVC.Interact.useFile f
461 :     | p (f, "cm", mk) = mk f
462 :     | p (f, e, mk) = Say.say ["!* unable to process `", f,
463 :     "' (unknown extension `", e, "')\n"]
464 :     fun arg ("-a", _) = autoload
465 :     | arg ("-m", _) = make
466 :     | arg (f, mk) =
467 :     (p (f,
468 :     String.map Char.toLower (getOpt (OS.Path.ext f, "<none>")),
469 :     mk);
470 :     mk)
471 :     in
472 :     case SMLofNJ.getArgs () of
473 :     ["@CMslave"] => (#set StdConfig.verbose false; slave ())
474 :     | l => ignore (foldl arg autoload l)
475 :     end
476 : blume 448 in
477 : blume 569 initTheValues (bootdir, de, er,
478 :     fn () => (Cleanup.install initPaths;
479 :     procCmdLine))
480 : blume 448 end
481 : blume 479
482 :     structure CM :> CM = struct
483 :     type 'a controller = { get : unit -> 'a, set : 'a -> unit }
484 :    
485 :     structure Anchor = struct
486 : blume 569 fun anchor a = { get = getAnchor a, set = setAnchor a }
487 : blume 479 val reset = resetPathConfig
488 :     end
489 :    
490 :     structure Control = struct
491 :     val keep_going = StdConfig.keep_going
492 :     val verbose = StdConfig.verbose
493 :     val parse_caching = StdConfig.parse_caching
494 :     val warn_obsolete = StdConfig.warn_obsolete
495 :     val debug = StdConfig.debug
496 : blume 505 val conserve_memory = StdConfig.conserve_memory
497 : blume 479 end
498 :    
499 :     structure Library = struct
500 :     type lib = SrcPath.t
501 :     val known = Parse.listLibs
502 :     val descr = SrcPath.descr
503 :     val osstring = SrcPath.osstring
504 :     val dismiss = Parse.dismissLib
505 :     end
506 :    
507 :     structure State = struct
508 :     val synchronize = SrcPath.sync
509 :     val reset = reset
510 :     val pending = getPending
511 :     end
512 :    
513 :     structure Server = struct
514 :     type server = Servers.server
515 :     fun start x = Servers.start x before SrcPath.invalidateCwd ()
516 :     val stop = Servers.stop
517 :     val kill = Servers.kill
518 :     val name = Servers.name
519 :     end
520 :    
521 :     val autoload = autoload
522 :     val make = make
523 :     val recomp = recomp
524 :     val stabilize = stabilize
525 :    
526 :     val symval = SSV.symval
527 : blume 578 val load_plugin = cwd_load_plugin
528 : blume 537 val mk_standalone = mk_standalone
529 : blume 479 end
530 : blume 525
531 : blume 578 structure Tools = ToolsFn (val load_plugin = cwd_load_plugin
532 : blume 525 val mkStdSrcPath = mkStdSrcPath)
533 : blume 578
534 :     val load_plugin = load_plugin
535 : blume 375 end
536 :     end

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