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 479 - (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 451 structure DG = DependencyGraph
32 : blume 375
33 :     val os = SMLofNJ.SysInfo.getOSKind ()
34 : blume 464 val my_archos =
35 :     concat [HostMachDepVC.architecture, "-", FilenamePolicy.kind2name os]
36 : blume 375
37 :     structure SSV =
38 :     SpecificSymValFn (structure MachDepVC = HostMachDepVC
39 :     val os = os)
40 :    
41 :     val emptydyn = E.dynamicPart E.emptyEnv
42 :     val system_values = ref emptydyn
43 :    
44 : blume 400 structure Compile =
45 : blume 448 CompileFn (structure MachDepVC = HostMachDepVC
46 : blume 464 val compile_there = Servers.compile o SrcPath.descr)
47 : blume 400
48 : blume 399 structure Link =
49 :     LinkFn (structure MachDepVC = HostMachDepVC
50 :     val system_values = system_values)
51 : blume 375
52 : blume 403 structure BFC =
53 :     BfcFn (structure MachDepVC = HostMachDepVC)
54 :    
55 : blume 375 structure AutoLoad = AutoLoadFn
56 : blume 399 (structure C = Compile
57 : blume 403 structure L = Link
58 :     structure BFC = BFC)
59 : blume 375
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 399 fun make_runner 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 399 (* Before executing the code, we announce the priviliges
87 :     * 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 :     | SOME dyn => let
98 :     val delta = E.mkenv { static = stat, symbolic = sym,
99 :     dynamic = dyn }
100 :     val base = #get ER.topLevel ()
101 :     val new = BE.concatEnv (CoerceEnv.e2b delta, base)
102 :     in
103 :     #set ER.topLevel new;
104 :     Say.vsay ["[New bindings added.]\n"];
105 :     true
106 :     end)
107 : blume 399 end
108 : blume 375
109 :     val al_greg = GroupReg.new ()
110 :    
111 :     (* Instantiate the stabilization mechanism. *)
112 :     structure Stabilize =
113 : blume 403 StabilizeFn (structure MachDepVC = HostMachDepVC
114 :     fun recomp gp g = let
115 :     val { store, get } = BFC.new ()
116 : blume 456 val _ = init_servers g
117 : blume 403 val { group, ... } =
118 :     Compile.newTraversal (Link.evict, store, g)
119 :     in
120 : blume 450 case Servers.withServers (fn () => group gp) of
121 : blume 403 NONE => NONE
122 :     | SOME _ => SOME get
123 :     end
124 :     fun destroy_state gp i =
125 : blume 451 (Compile.evict i;
126 :     Link.evict gp i)
127 : blume 403 val getII = Compile.getII)
128 : blume 375
129 :     (* Access to the stabilization mechanism is integrated into the
130 :     * parser. I'm not sure if this is the cleanest way, but it works
131 :     * well enough. *)
132 :     structure Parse = ParseFn (structure Stabilize = Stabilize
133 :     val pending = AutoLoad.getPending)
134 :    
135 :     local
136 :     type kernelValues =
137 :     { primconf : Primitive.configuration,
138 :     pervasive : E.environment,
139 :     corenv : BE.staticEnv,
140 :     pervcorepids : PidSet.set }
141 :    
142 :     val fnpolicy = FilenamePolicy.colocate
143 :     { os = os, arch = HostMachDepVC.architecture }
144 :    
145 :     val pcmode = PathConfig.new ()
146 :    
147 :     val theValues = ref (NONE: kernelValues option)
148 :    
149 :     in
150 : blume 479 fun setAnchor { anchor = a, path = s } =
151 : blume 377 (PathConfig.set (pcmode, a, s); SrcPath.sync ())
152 :     (* cancelling anchors cannot affect the order of existing paths
153 :     * (it may invalidate some paths; but all other ones stay as
154 :     * they are) *)
155 : blume 375 fun cancelAnchor a = PathConfig.cancel (pcmode, a)
156 : blume 377 (* same goes for reset because it just cancels all anchors... *)
157 : blume 375 fun resetPathConfig () = PathConfig.reset pcmode
158 :    
159 : blume 479 fun getPending () = let
160 : blume 375 fun one (s, _) = let
161 :     val nss = Symbol.nameSpaceToString (Symbol.nameSpace s)
162 :     val n = Symbol.name s
163 :     in
164 : blume 479 concat [" ", nss, " ", n, "\n"]
165 : blume 375 end
166 :     in
167 : blume 479 map one (SymbolMap.listItemsi (AutoLoad.getPending ()))
168 : blume 375 end
169 :    
170 :     fun initPaths () = let
171 : blume 433 val lpcth = #get StdConfig.local_pathconfig ()
172 : blume 375 val p = case lpcth () of
173 :     NONE => []
174 :     | SOME f => [f]
175 : blume 433 val p = #get StdConfig.pathcfgspec () :: p
176 : blume 375 fun processOne f = PathConfig.processSpecFile (pcmode, f)
177 :     handle _ => ()
178 :     in
179 :     app processOne p
180 :     end
181 :    
182 :     fun param () = let
183 :     val v = valOf (!theValues)
184 :     handle Option =>
185 :     raise Fail "CMBoot: theParam not initialized"
186 :     in
187 :     { primconf = #primconf v,
188 :     fnpolicy = fnpolicy,
189 :     pcmode = pcmode,
190 : blume 433 symval = SSV.symval,
191 :     keep_going = #get StdConfig.keep_going (),
192 : blume 375 pervasive = #pervasive v,
193 :     corenv = #corenv v,
194 :     pervcorepids = #pervcorepids v }
195 :     end
196 :    
197 :     fun autoload s = let
198 :     val c = SrcPath.cwdContext ()
199 :     val p = SrcPath.standard pcmode { context = c, spec = s }
200 :     in
201 :     case Parse.parse (SOME al_greg) (param ()) NONE p of
202 :     NONE => false
203 :     | SOME (g, _) =>
204 :     (AutoLoad.register (GenericVC.EnvRef.topLevel, g);
205 :     true)
206 :     end
207 :    
208 :     fun al_ginfo () = { param = param (),
209 :     groupreg = al_greg,
210 :     errcons = EM.defaultConsumer () }
211 :    
212 :     val al_manager = AutoLoad.mkManager al_ginfo
213 :    
214 :     fun al_manager' (ast, _, ter) = al_manager (ast, ter)
215 :    
216 :     fun run sflag f s = let
217 :     val c = SrcPath.cwdContext ()
218 :     val p = SrcPath.standard pcmode { context = c, spec = s }
219 :     in
220 :     case Parse.parse NONE (param ()) sflag p of
221 :     NONE => false
222 : blume 456 | SOME (g, gp) => f gp g
223 : blume 375 end
224 :    
225 : blume 449 fun stabilize_runner gp g = true
226 :    
227 :     fun stabilize recursively = run (SOME recursively) stabilize_runner
228 :     val recomp = run NONE recomp_runner
229 :     val make = run NONE make_runner
230 :    
231 : blume 448 fun slave () = let
232 : blume 456
233 :     val dbr = ref BtNames.dirbaseDefault
234 :    
235 : blume 448 fun shutdown () = OS.Process.exit OS.Process.success
236 :     fun say_ok () = Say.say ["SLAVE: ok\n"]
237 :     fun say_error () = Say.say ["SLAVE: error\n"]
238 : blume 453 fun say_pong () = Say.say ["SLAVE: pong\n"]
239 : blume 452
240 : blume 457 fun path (s, pcmode) = SrcPath.fromDescr pcmode s
241 : blume 464
242 :     fun chDir d =
243 : blume 465 OS.FileSys.chDir (SrcPath.osstring (path (d, pcmode)))
244 : blume 457
245 : blume 448 fun waitForStart () = let
246 :     val line = TextIO.inputLine TextIO.stdIn
247 :     in
248 :     if line = "" then shutdown ()
249 :     else case String.tokens Char.isSpace line of
250 : blume 464 ["cd", d] => (chDir d; say_ok (); waitForStart ())
251 :     | ["cm", archos, f] => do_cm (archos, f)
252 :     | ["cmb", archos, f] => do_cmb (archos, f)
253 : blume 453 | ["ping"] => (say_pong (); waitForStart ())
254 :     | ["finish"] => (say_ok (); waitForStart ())
255 : blume 456 | ["dirbase", db] =>
256 :     (say_ok (); dbr := db; waitForStart ())
257 : blume 448 | ["shutdown"] => shutdown ()
258 :     | _ => (say_error (); waitForStart ())
259 :     end handle _ => (say_error (); waitForStart ())
260 :    
261 : blume 464 and do_cmb (archos, f) = let
262 :     val slave = CMBSlave.slave make
263 : blume 449 in
264 : blume 456 case slave archos (!dbr, f) of
265 : blume 449 NONE => (say_error (); waitForStart ())
266 : blume 457 | SOME (g, trav, cmb_pcmode) => let
267 : blume 449 val _ = say_ok ()
268 :     val index = Reachable.snodeMap g
269 :     in
270 : blume 457 workLoop (index, trav, cmb_pcmode)
271 : blume 449 end
272 :     end handle _ => (say_error (); waitForStart ())
273 :    
274 : blume 464 and do_cm (archos, f) =
275 :     if archos <> my_archos then (say_error (); waitForStart ())
276 :     else let
277 :     val p = path (f, pcmode)
278 :     in
279 :     case Parse.parse NONE (param ()) NONE p of
280 :     NONE => (say_error (); waitForStart ())
281 :     | SOME (g, gp) => let
282 :     val _ = say_ok ()
283 :     val index = Reachable.snodeMap g
284 :     val trav = Compile.newSbnodeTraversal () gp
285 :     fun trav' sbn = isSome (trav sbn)
286 :     in
287 :     workLoop (index, trav', pcmode)
288 :     end
289 :     end handle _ => (say_error (); waitForStart ())
290 : blume 448
291 : blume 457 and workLoop (index, trav, pcmode) = let
292 : blume 448 fun loop () = let
293 :     val line = TextIO.inputLine TextIO.stdIn
294 :     in
295 :     if line = "" then shutdown ()
296 :     else case String.tokens Char.isSpace line of
297 : blume 464 ["cd", d] => (chDir d; say_ok (); loop ())
298 :     | ["compile", f] => let
299 : blume 457 val p = path (f, pcmode)
300 : blume 448 in
301 :     case SrcPathMap.find (index, p) of
302 :     NONE => (say_error (); loop ())
303 :     | SOME sn => let
304 : blume 451 val sbn = DG.SB_SNODE sn
305 : blume 448 in
306 : blume 449 if trav sbn then (say_ok (); loop ())
307 :     else (say_error (); loop ())
308 : blume 456 end
309 : blume 448 end
310 : blume 464 | ["cm", archos, f] => do_cm (archos, f)
311 :     | ["cmb", archos, f] => do_cmb (archos, f)
312 : blume 448 | ["finish"] => (say_ok (); waitForStart ())
313 : blume 456 | ["dirbase", db] =>
314 :     (say_ok (); dbr := db; waitForStart ())
315 : blume 453 | ["ping"] => (say_pong (); loop ())
316 : blume 448 | ["shutdown"] => shutdown ()
317 :     | _ => (say_error (); loop ())
318 :     end handle _ => (say_error (); loop ())
319 :     in
320 :     loop ()
321 :     end
322 :     in
323 : blume 453 ignore (Signals.setHandler (Signals.sigINT, Signals.IGNORE));
324 : blume 448 say_ok (); (* announce readiness *)
325 : blume 452 waitForStart () handle _ => ();
326 :     OS.Process.exit OS.Process.failure
327 : blume 448 end
328 :    
329 : blume 375 fun reset () =
330 : blume 399 (Compile.reset ();
331 :     Link.reset ();
332 : blume 375 AutoLoad.reset ();
333 :     Parse.reset ();
334 :     SmlInfo.forgetAllBut SrcPathSet.empty)
335 :    
336 :     fun initTheValues (bootdir, er) = let
337 :     val _ = let
338 :     fun listDir ds = let
339 :     fun loop l =
340 : blume 380 case F.readDir ds of
341 : blume 375 "" => l
342 :     | x => loop (x :: l)
343 :     in
344 :     loop []
345 :     end
346 :     val fileList = SafeIO.perform
347 : blume 380 { openIt = fn () => F.openDir bootdir,
348 :     closeIt = F.closeDir,
349 : blume 375 work = listDir,
350 : blume 459 cleanup = fn _ => () }
351 : blume 380 fun isDir x = F.isDir x handle _ => false
352 : blume 375 fun subDir x = let
353 : blume 380 val d = P.concat (bootdir, x)
354 : blume 375 in
355 :     if isDir d then SOME (x, d) else NONE
356 :     end
357 :     val pairList = List.mapPartial subDir fileList
358 :     in
359 :     app (fn (x, d) => PathConfig.set (pcmode, x, d)) pairList
360 :     end
361 :     val initgspec =
362 :     SrcPath.standard pcmode { context = SrcPath.cwdContext (),
363 :     spec = BtNames.initgspec }
364 :     val ginfo = { param = { primconf = Primitive.primEnvConf,
365 :     fnpolicy = fnpolicy,
366 :     pcmode = pcmode,
367 : blume 433 symval = SSV.symval,
368 : blume 375 keep_going = false,
369 :     pervasive = E.emptyEnv,
370 :     corenv = BE.staticPart BE.emptyEnv,
371 :     pervcorepids = PidSet.empty },
372 :     groupreg = GroupReg.new (),
373 :     errcons = EM.defaultConsumer () }
374 :     in
375 :     case BuildInitDG.build ginfo initgspec of
376 :     NONE => raise Fail "CMBoot: BuiltInitDG.build"
377 :     | SOME { rts, core, pervasive, primitives, ... } => let
378 :     (* It is absolutely crucial that we don't finish the
379 :     * recomp traversal until we are done with all
380 :     * nodes of the InitDG. This is because we have
381 :     * been cheating, and if we ever have to try and
382 :     * fetch assembly.sig or core.sml in a separate
383 :     * traversal, it will fail. *)
384 : blume 400 val sbnode = Compile.newSbnodeTraversal ()
385 : blume 375 fun get n = let
386 : blume 460 val { statpid, statenv, symenv, sympid } =
387 :     valOf (sbnode ginfo n)
388 : blume 399 (* We have not implemented the "sbnode" part
389 :     * in the Link module.
390 : blume 375 * But at boot time any relevant value should be
391 : blume 399 * available as a sysval, so there is no problem.
392 :     *
393 :     * WARNING! HACK!
394 :     * We are cheating somewhat by taking advantage
395 :     * of the fact that the staticPid is always
396 :     * the same as the exportPid if the latter exists.
397 :     *)
398 :     val d = case Link.sysval (SOME statpid) of
399 :     SOME d => d
400 :     | NONE => emptydyn
401 : blume 461 val { env = static, ctxt } = statenv ()
402 :     val env = E.mkenv { static = static,
403 : blume 399 symbolic = symenv (),
404 : blume 375 dynamic = d }
405 : blume 461 val pidInfo =
406 :     { statpid = statpid, sympid = sympid,
407 :     ctxt = ctxt }
408 : blume 375 in
409 :     (env, pidInfo)
410 :     end
411 :     fun getPspec (name, n) = let
412 :     val (env, pidInfo) = get n
413 :     in
414 :     { name = name, env = env, pidInfo = pidInfo }
415 :     end
416 :    
417 :     val (core, corePidInfo) = get core
418 :     val corenv = CoerceEnv.es2bs (E.staticPart core)
419 :     val (rts, _) = get rts
420 :     val (pervasive0, pervPidInfo) = get pervasive
421 :     val pspecs = map getPspec primitives
422 :     val core_symdyn =
423 :     E.mkenv { static = E.staticPart E.emptyEnv,
424 :     dynamic = E.dynamicPart core,
425 :     symbolic = E.symbolicPart core }
426 :     val pervasive = E.layerEnv (pervasive0, core_symdyn)
427 :     val pervcorepids =
428 :     PidSet.addList (PidSet.empty,
429 :     [#statpid corePidInfo,
430 :     #statpid pervPidInfo,
431 :     #sympid pervPidInfo])
432 :     in
433 : blume 399 Compile.reset ();
434 :     Link.reset ();
435 : blume 375 #set ER.core corenv;
436 :     #set ER.pervasive pervasive;
437 :     #set ER.topLevel BE.emptyEnv;
438 :     theValues :=
439 :     SOME { primconf = Primitive.configuration pspecs,
440 :     pervasive = pervasive,
441 :     corenv = corenv,
442 :     pervcorepids = pervcorepids };
443 :     case er of
444 :     BARE =>
445 :     (make "basis.cm";
446 :     make "host-compiler.cm";
447 :     system_values := emptydyn)
448 :     | AUTOLOAD =>
449 :     (HostMachDepVC.Interact.installCompManager
450 :     (SOME al_manager');
451 :     autoload "basis.cm";
452 : blume 479 autoload "minimal-cm.cm";
453 : blume 375 CmHook.init
454 :     { stabilize = stabilize,
455 :     recomp = recomp,
456 :     make = make,
457 : blume 479 autoload = autoload })
458 : blume 375
459 :     end
460 :     end
461 :     end
462 :     in
463 :     fun init (bootdir, de, er) =
464 :     (system_values := de;
465 :     initTheValues (bootdir, er);
466 :     Cleanup.install initPaths)
467 : blume 448
468 :     fun procCmdLine () = let
469 :     fun p (f, "sml") = HostMachDepVC.Interact.useFile f
470 :     | p (f, "sig") = HostMachDepVC.Interact.useFile f
471 :     | p (f, "cm") = ignore (make f)
472 :     | p (f, e) =
473 :     (print (concat ["!* unable to process `", f,
474 :     "' (unknown extension `", e, "')\n"]))
475 :     fun c f = (f, String.map Char.toLower
476 :     (getOpt (OS.Path.ext f, "<none>")))
477 :     in
478 :     case SMLofNJ.getArgs () of
479 : blume 451 ["@CMslave"] => (#set StdConfig.verbose false; slave ())
480 : blume 448 | l => app (p o c) l
481 :     end
482 : blume 479
483 :     structure CM :> CM = struct
484 :     type 'a controller = { get : unit -> 'a, set : 'a -> unit }
485 :    
486 :     structure Anchor = struct
487 :     val set = setAnchor
488 :     val cancel = cancelAnchor
489 :     val reset = resetPathConfig
490 :     end
491 :    
492 :     structure Control = struct
493 :     val keep_going = StdConfig.keep_going
494 :     val verbose = StdConfig.verbose
495 :     val parse_caching = StdConfig.parse_caching
496 :     val warn_obsolete = StdConfig.warn_obsolete
497 :     val debug = StdConfig.debug
498 :     end
499 :    
500 :     structure Library = struct
501 :     type lib = SrcPath.t
502 :     val known = Parse.listLibs
503 :     val descr = SrcPath.descr
504 :     val osstring = SrcPath.osstring
505 :     val dismiss = Parse.dismissLib
506 :     end
507 :    
508 :     structure State = struct
509 :     val synchronize = SrcPath.sync
510 :     val reset = reset
511 :     val pending = getPending
512 :     end
513 :    
514 :     structure Server = struct
515 :     type server = Servers.server
516 :     fun start x = Servers.start x before SrcPath.invalidateCwd ()
517 :     val stop = Servers.stop
518 :     val kill = Servers.kill
519 :     val name = Servers.name
520 :     end
521 :    
522 :     val autoload = autoload
523 :     val make = make
524 :     val recomp = recomp
525 :     val stabilize = stabilize
526 :    
527 :     val symval = SSV.symval
528 :     end
529 : blume 375 end
530 :     end

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