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

1 : blume 375 (*
2 :     * This is the module that actually puts together the contents of the
3 : blume 587 * structure CM that people find in smlnj/cm/full.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 S = GenericVC.Symbol
21 :     structure EM = GenericVC.ErrorMsg
22 :     structure BF = HostMachDepVC.Binfile
23 : blume 380 structure P = OS.Path
24 :     structure F = OS.FileSys
25 : blume 451 structure DG = DependencyGraph
26 : blume 587 structure GG = GroupGraph
27 : blume 375
28 :     val os = SMLofNJ.SysInfo.getOSKind ()
29 : blume 464 val my_archos =
30 :     concat [HostMachDepVC.architecture, "-", FilenamePolicy.kind2name os]
31 : blume 375
32 :     structure SSV =
33 :     SpecificSymValFn (structure MachDepVC = HostMachDepVC
34 :     val os = os)
35 :    
36 :     val emptydyn = E.dynamicPart E.emptyEnv
37 : blume 569 val system_values = ref (SrcPathMap.empty: E.dynenv SrcPathMap.map)
38 : blume 375
39 : blume 588 structure StabModmap = StabModmapFn ()
40 :    
41 : blume 400 structure Compile =
42 : blume 448 CompileFn (structure MachDepVC = HostMachDepVC
43 : blume 588 structure StabModmap = StabModmap
44 : blume 464 val compile_there = Servers.compile o SrcPath.descr)
45 : blume 400
46 : blume 537 structure BFC =
47 :     BfcFn (structure MachDepVC = HostMachDepVC)
48 :    
49 : blume 399 structure Link =
50 :     LinkFn (structure MachDepVC = HostMachDepVC
51 : blume 537 structure BFC = BFC
52 : blume 399 val system_values = system_values)
53 : blume 375
54 :     structure AutoLoad = AutoLoadFn
55 : blume 399 (structure C = Compile
56 : blume 403 structure L = Link
57 :     structure BFC = BFC)
58 : blume 375
59 : blume 537 val mkBootList = #l o MkBootList.group (fn p => p)
60 :    
61 : blume 587 fun init_servers (GG.GROUP { grouppath, ... }) =
62 : blume 464 Servers.cm { archos = my_archos, project = SrcPath.descr grouppath }
63 : blume 587 | init_servers GG.ERRORGROUP = ()
64 : blume 456
65 : blume 399 fun recomp_runner gp g = let
66 : blume 456 val _ = init_servers g
67 : blume 403 fun store _ = ()
68 :     val { group, ... } = Compile.newTraversal (Link.evict, store, g)
69 : blume 399 in
70 : blume 450 isSome (Servers.withServers (fn () => group gp))
71 :     before Link.cleanup gp
72 : blume 399 end
73 : blume 375
74 :     (* This function combines the actions of "recompile" and "exec".
75 :     * When successful, it combines the results (thus forming a full
76 :     * environment) and adds it to the toplevel environment. *)
77 : blume 587 fun make_runner _ _ GG.ERRORGROUP = false
78 :     | make_runner add_bindings gp (g as GG.GROUP grec) = let
79 :     val { required = rq, ... } = grec
80 :     val { store, get } = BFC.new ()
81 :     val _ = init_servers g
82 :     val { group = c_group, ... } =
83 :     Compile.newTraversal (Link.evict, store, g)
84 :     val { group = l_group, ... } = Link.newTraversal (g, get)
85 :     in
86 :     case Servers.withServers (fn () => c_group gp) of
87 :     NONE => false
88 :     | SOME { stat, sym} =>
89 : blume 537 (* Before executing the code, we announce the privileges
90 : blume 399 * that are being invoked. (For the time being, we assume
91 :     * that everybody has every conceivable privilege, but at
92 :     * the very least we announce which ones are being made
93 :     * use of.) *)
94 : blume 400 (Link.cleanup gp;
95 : blume 399 if StringSet.isEmpty rq then ()
96 :     else Say.say ("$Execute: required privileges are:\n" ::
97 :     map (fn s => (" " ^ s ^ "\n")) (StringSet.listItems rq));
98 :     case l_group gp of
99 : blume 375 NONE => false
100 : blume 518 | SOME dyn =>
101 :     (if add_bindings then
102 :     let val delta = E.mkenv { static = stat,
103 :     symbolic = sym,
104 :     dynamic = dyn }
105 :     val base = #get ER.topLevel ()
106 : blume 587 val new = E.concatEnv (delta, base)
107 : blume 518 in
108 :     #set ER.topLevel new;
109 :     Say.vsay ["[New bindings added.]\n"]
110 :     end
111 :     else ();
112 :     true))
113 : blume 587 end
114 : blume 375
115 :     val al_greg = GroupReg.new ()
116 :    
117 :     (* Instantiate the stabilization mechanism. *)
118 :     structure Stabilize =
119 : blume 403 StabilizeFn (structure MachDepVC = HostMachDepVC
120 : blume 588 structure StabModmap = StabModmap
121 : blume 403 fun recomp gp g = let
122 :     val { store, get } = BFC.new ()
123 : blume 456 val _ = init_servers g
124 : blume 403 val { group, ... } =
125 :     Compile.newTraversal (Link.evict, store, g)
126 :     in
127 : blume 450 case Servers.withServers (fn () => group gp) of
128 : blume 403 NONE => NONE
129 :     | SOME _ => SOME get
130 :     end
131 :     val getII = Compile.getII)
132 : blume 375
133 :     (* Access to the stabilization mechanism is integrated into the
134 :     * parser. I'm not sure if this is the cleanest way, but it works
135 :     * well enough. *)
136 :     structure Parse = ParseFn (structure Stabilize = Stabilize
137 : blume 588 structure StabModmap = StabModmap
138 : blume 537 fun evictStale () =
139 :     (Compile.evictStale ();
140 :     Link.evictStale ())
141 : blume 375 val pending = AutoLoad.getPending)
142 :    
143 :     local
144 : blume 592 type kernelValues = { init_group : GG.group }
145 : blume 375
146 :     val fnpolicy = FilenamePolicy.colocate
147 :     { os = os, arch = HostMachDepVC.architecture }
148 :    
149 :     val pcmode = PathConfig.new ()
150 :    
151 :     val theValues = ref (NONE: kernelValues option)
152 :    
153 :     in
154 : blume 377 (* cancelling anchors cannot affect the order of existing paths
155 :     * (it may invalidate some paths; but all other ones stay as
156 :     * they are) *)
157 : blume 569 fun setAnchor a NONE = PathConfig.cancel (pcmode, a)
158 :     | setAnchor a (SOME s) = (PathConfig.set (pcmode, a, s);
159 :     SrcPath.sync ())
160 : blume 377 (* same goes for reset because it just cancels all anchors... *)
161 : blume 375 fun resetPathConfig () = PathConfig.reset pcmode
162 : blume 569 (* get the current binding for an anchor *)
163 :     fun getAnchor a () =
164 :     Option.map (fn f => f ()) (PathConfig.configAnchor pcmode a)
165 : blume 375
166 : blume 525 fun mkStdSrcPath s =
167 :     SrcPath.standard pcmode { context = SrcPath.cwdContext (),
168 :     spec = s }
169 :    
170 : blume 479 fun getPending () = let
171 : blume 375 fun one (s, _) = let
172 :     val nss = Symbol.nameSpaceToString (Symbol.nameSpace s)
173 :     val n = Symbol.name s
174 :     in
175 : blume 479 concat [" ", nss, " ", n, "\n"]
176 : blume 375 end
177 :     in
178 : blume 479 map one (SymbolMap.listItemsi (AutoLoad.getPending ()))
179 : blume 375 end
180 :    
181 :     fun initPaths () = let
182 : blume 433 val lpcth = #get StdConfig.local_pathconfig ()
183 : blume 375 val p = case lpcth () of
184 :     NONE => []
185 :     | SOME f => [f]
186 : blume 433 val p = #get StdConfig.pathcfgspec () :: p
187 : blume 375 fun processOne f = PathConfig.processSpecFile (pcmode, f)
188 :     handle _ => ()
189 :     in
190 :     app processOne p
191 :     end
192 :    
193 : blume 537 fun getTheValues () = valOf (!theValues)
194 :     handle Option => raise Fail "CMBoot: theParam not initialized"
195 :    
196 : blume 375 fun param () = let
197 : blume 537 val v = getTheValues ()
198 : blume 375 in
199 : blume 537 { fnpolicy = fnpolicy,
200 : blume 375 pcmode = pcmode,
201 : blume 433 symval = SSV.symval,
202 : blume 592 keep_going = #get StdConfig.keep_going () }
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 632 fun makedepend { group, targetname, outstream } = let
262 :     val oss = SrcPath.osstring
263 :     val fnrec = { bininfo = fn i => [BinInfo.stablename i],
264 :     smlinfo = fn i => [oss (SmlInfo.group i),
265 :     oss (SmlInfo.sourcepath i)],
266 :     Cons = fn (l, s) => foldl StringSet.add' s l,
267 :     Nil = StringSet.empty }
268 :     val p = mkStdSrcPath group
269 :     val gr = GroupReg.new ()
270 :     in
271 :     (case Parse.parse (parse_arg (gr, NONE, p)) of
272 :     NONE => false
273 :     | SOME (g, _) => let
274 :     val names = MkList.group fnrec g
275 :     fun oneTarget t =
276 :     TextIO.output (outstream, " \\\n\t" ^ t)
277 :     in
278 :     TextIO.output (outstream, targetname ^ ":");
279 :     StringSet.app oneTarget names;
280 :     TextIO.output (outstream, "\n");
281 :     true
282 :     end)
283 :     before dropPickles ()
284 :     end
285 :    
286 : blume 537 (* I would have liked to express this using "run", but "run"
287 :     * thinks it has to return a bool... *)
288 :     fun mk_standalone sflag s = let
289 :     val p = mkStdSrcPath s
290 :     val gr = GroupReg.new ()
291 :     in
292 :     (case Parse.parse (parse_arg (gr, sflag, p)) of
293 :     NONE => NONE
294 :     | SOME (g, gp) =>
295 :     if isSome sflag orelse recomp_runner gp g then
296 :     SOME (mkBootList g)
297 :     else NONE)
298 :     before dropPickles ()
299 :     end
300 :    
301 : blume 518 fun slave () = let
302 : blume 537 val gr = GroupReg.new ()
303 :     fun parse p = Parse.parse (parse_arg (gr, NONE, p))
304 : blume 518 in
305 : blume 480 Slave.slave { pcmode = pcmode,
306 : blume 518 parse = parse,
307 : blume 480 my_archos = my_archos,
308 :     sbtrav = Compile.newSbnodeTraversal,
309 :     make = make }
310 : blume 518 end
311 : blume 456
312 : blume 518 fun al_ginfo () = { param = param (),
313 :     groupreg = al_greg,
314 :     errcons = EM.defaultConsumer () }
315 :    
316 :     val al_manager =
317 :     AutoLoad.mkManager { get_ginfo = al_ginfo,
318 :     dropPickles = dropPickles }
319 :    
320 :     fun al_manager' (ast, _, ter) = al_manager (ast, ter)
321 :    
322 : blume 375 fun reset () =
323 : blume 399 (Compile.reset ();
324 :     Link.reset ();
325 : blume 375 AutoLoad.reset ();
326 :     Parse.reset ();
327 : blume 588 SmlInfo.reset ();
328 :     StabModmap.reset ())
329 : blume 375
330 : blume 569 fun initTheValues (bootdir, de, er, autoload_postprocess) = let
331 : blume 375 val _ = let
332 :     fun listDir ds = let
333 :     fun loop l =
334 : blume 380 case F.readDir ds of
335 : blume 375 "" => l
336 :     | x => loop (x :: l)
337 :     in
338 :     loop []
339 :     end
340 :     val fileList = SafeIO.perform
341 : blume 380 { openIt = fn () => F.openDir bootdir,
342 :     closeIt = F.closeDir,
343 : blume 375 work = listDir,
344 : blume 459 cleanup = fn _ => () }
345 : blume 380 fun isDir x = F.isDir x handle _ => false
346 : blume 375 fun subDir x = let
347 : blume 380 val d = P.concat (bootdir, x)
348 : blume 375 in
349 :     if isDir d then SOME (x, d) else NONE
350 :     end
351 :     val pairList = List.mapPartial subDir fileList
352 :     in
353 :     app (fn (x, d) => PathConfig.set (pcmode, x, d)) pairList
354 :     end
355 : blume 569
356 :     val pidmapfile = P.concat (bootdir, BtNames.pidmap)
357 :     fun readpidmap s = let
358 :     fun loop m = let
359 :     fun enter (d, pids) = let
360 :     fun enter1 (hexp, e) =
361 :     case GenericVC.PersStamps.fromHex hexp of
362 :     SOME p => (DE.bind (p, DE.look de p, e)
363 :     handle DE.Unbound => e)
364 :     | NONE => e
365 :     in
366 :     SrcPathMap.insert (m, SrcPath.fromDescr pcmode d,
367 :     foldl enter1 emptydyn pids)
368 :     end
369 :     in
370 :     case TextIO.inputLine s of
371 :     "" => m
372 :     | line => (case String.tokens Char.isSpace line of
373 :     d :: pids => loop (enter (d, pids))
374 :     | _ => loop m)
375 :     end
376 :     in
377 :     system_values := loop SrcPathMap.empty
378 :     end
379 :    
380 :     val _ =
381 :     SafeIO.perform { openIt = fn () => TextIO.openIn pidmapfile,
382 :     closeIt = TextIO.closeIn,
383 :     work = readpidmap,
384 :     cleanup = fn _ => () }
385 :    
386 : blume 525 val initgspec = mkStdSrcPath BtNames.initgspec
387 : blume 537 val ginfo = { param = { fnpolicy = fnpolicy,
388 : blume 375 pcmode = pcmode,
389 : blume 433 symval = SSV.symval,
390 : blume 592 keep_going = false },
391 : blume 375 groupreg = GroupReg.new (),
392 :     errcons = EM.defaultConsumer () }
393 : blume 537 fun loadInitGroup () =
394 :     Stabilize.loadStable ginfo
395 :     { getGroup = fn _ => raise Fail "CMBoot: initial getGroup",
396 :     anyerrors = ref false }
397 : blume 632 (initgspec, NONE)
398 : blume 375 in
399 : blume 537 case loadInitGroup () of
400 :     NONE => raise Fail "CMBoot: unable to load init group"
401 :     | SOME init_group => let
402 :     val _ = Compile.reset ()
403 :     val _ = Link.reset ()
404 : blume 375
405 : blume 537 val { exports = ctm, ... } =
406 :     Compile.newTraversal (fn _ => fn _ => (),
407 :     fn _ => (),
408 :     init_group)
409 :     val { exports = ltm, ... } = Link.newTraversal
410 :     (init_group, fn _ => raise Fail "init: get bfc?")
411 :    
412 :     fun getSymTrav (tr_m, sy) =
413 :     case SymbolMap.find (tr_m, sy) of
414 :     NONE => raise Fail "init: bogus init group (1)"
415 :     | SOME tr => tr
416 :    
417 : blume 592 val perv_ct = getSymTrav (ctm, PervAccess.pervStrSym)
418 :     val perv_lt = getSymTrav (ltm, PervAccess.pervStrSym)
419 : blume 537
420 :     fun doTrav t =
421 :     case t ginfo of
422 :     SOME r => r
423 :     | NONE => raise Fail "init: bogus init group (2)"
424 :    
425 :     val { stat = pervstat, sym = pervsym } = doTrav perv_ct
426 :     val pervdyn = doTrav perv_lt
427 :    
428 :     val pervasive = E.mkenv { static = pervstat,
429 :     symbolic = pervsym,
430 :     dynamic = pervdyn }
431 :    
432 : blume 495 fun bare_autoload x =
433 :     (Say.say
434 :     ["!* ", x,
435 :     ": \"autoload\" not available, using \"make\"\n"];
436 :     make x)
437 :     val bare_preload =
438 :     Preload.preload { make = make,
439 :     autoload = bare_autoload }
440 :     val standard_preload =
441 :     Preload.preload { make = make, autoload = autoload }
442 : blume 375 in
443 : blume 592 #set ER.pervasive pervasive;
444 : blume 587 #set ER.topLevel E.emptyEnv;
445 : blume 592 theValues := SOME { init_group = init_group };
446 : blume 375 case er of
447 :     BARE =>
448 : blume 495 (bare_preload BtNames.bare_preloads;
449 : blume 569 system_values := SrcPathMap.empty;
450 : blume 495 NONE)
451 : blume 375 | AUTOLOAD =>
452 :     (HostMachDepVC.Interact.installCompManager
453 :     (SOME al_manager');
454 : blume 495 standard_preload BtNames.standard_preloads;
455 : blume 375 CmHook.init
456 :     { stabilize = stabilize,
457 :     recomp = recomp,
458 :     make = make,
459 : blume 495 autoload = autoload };
460 : blume 507 (* unconditionally drop all library pickles *)
461 :     Parse.dropPickles ();
462 : blume 495 SOME (autoload_postprocess ()))
463 : blume 375 end
464 :     end
465 :     end
466 :     in
467 : blume 495 fun init (bootdir, de, er) = let
468 :     fun procCmdLine () = let
469 :     val autoload = ignore o autoload
470 :     val make = ignore o make
471 :     fun p (f, ("sml" | "sig"), mk) = HostMachDepVC.Interact.useFile f
472 :     | p (f, "cm", mk) = mk f
473 :     | p (f, e, mk) = Say.say ["!* unable to process `", f,
474 :     "' (unknown extension `", e, "')\n"]
475 :     fun arg ("-a", _) = autoload
476 :     | arg ("-m", _) = make
477 :     | arg (f, mk) =
478 :     (p (f,
479 :     String.map Char.toLower (getOpt (OS.Path.ext f, "<none>")),
480 :     mk);
481 :     mk)
482 :     in
483 :     case SMLofNJ.getArgs () of
484 :     ["@CMslave"] => (#set StdConfig.verbose false; slave ())
485 :     | l => ignore (foldl arg autoload l)
486 :     end
487 : blume 448 in
488 : blume 569 initTheValues (bootdir, de, er,
489 :     fn () => (Cleanup.install initPaths;
490 :     procCmdLine))
491 : blume 448 end
492 : blume 479
493 :     structure CM :> CM = struct
494 :     type 'a controller = { get : unit -> 'a, set : 'a -> unit }
495 :    
496 :     structure Anchor = struct
497 : blume 569 fun anchor a = { get = getAnchor a, set = setAnchor a }
498 : blume 479 val reset = resetPathConfig
499 :     end
500 :    
501 :     structure Control = struct
502 :     val keep_going = StdConfig.keep_going
503 :     val verbose = StdConfig.verbose
504 :     val parse_caching = StdConfig.parse_caching
505 :     val warn_obsolete = StdConfig.warn_obsolete
506 :     val debug = StdConfig.debug
507 : blume 505 val conserve_memory = StdConfig.conserve_memory
508 : blume 479 end
509 :    
510 :     structure Library = struct
511 :     type lib = SrcPath.t
512 :     val known = Parse.listLibs
513 :     val descr = SrcPath.descr
514 :     val osstring = SrcPath.osstring
515 :     val dismiss = Parse.dismissLib
516 : blume 632 fun unshare lib = (Link.unshare lib; dismiss lib)
517 : blume 479 end
518 :    
519 :     structure State = struct
520 :     val synchronize = SrcPath.sync
521 :     val reset = reset
522 :     val pending = getPending
523 :     end
524 :    
525 :     structure Server = struct
526 :     type server = Servers.server
527 :     fun start x = Servers.start x before SrcPath.invalidateCwd ()
528 :     val stop = Servers.stop
529 :     val kill = Servers.kill
530 :     val name = Servers.name
531 :     end
532 :    
533 :     val autoload = autoload
534 :     val make = make
535 :     val recomp = recomp
536 :     val stabilize = stabilize
537 :    
538 : blume 632 val makedepend = makedepend
539 :    
540 : blume 479 val symval = SSV.symval
541 : blume 578 val load_plugin = cwd_load_plugin
542 : blume 537 val mk_standalone = mk_standalone
543 : blume 479 end
544 : blume 525
545 : blume 578 structure Tools = ToolsFn (val load_plugin = cwd_load_plugin
546 : blume 525 val mkStdSrcPath = mkStdSrcPath)
547 : blume 578
548 :     val load_plugin = load_plugin
549 : blume 375 end
550 :     end

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