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

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