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

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