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

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