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

1 : blume 375 (*
2 :     * This is the module that actually puts together the contents of the
3 : blume 801 * structure CM people find in $smlnj/cm/full.cm.
4 : blume 375 *
5 : blume 756 * Copyright (c) 1999, 2000 by Lucent Bell Laboratories
6 : blume 375 *
7 :     * author: Matthias Blume (blume@cs.princeton.edu)
8 :     *)
9 :     functor LinkCM (structure HostMachDepVC : MACHDEP_VC) = struct
10 :    
11 :     datatype envrequest = AUTOLOAD | BARE
12 :    
13 :     local
14 :     structure E = GenericVC.Environment
15 : blume 569 structure DE = DynamicEnv
16 : blume 375 structure SE = GenericVC.StaticEnv
17 :     structure ER = GenericVC.EnvRef
18 :     structure S = GenericVC.Symbol
19 :     structure EM = GenericVC.ErrorMsg
20 :     structure BF = HostMachDepVC.Binfile
21 : blume 380 structure P = OS.Path
22 :     structure F = OS.FileSys
23 : blume 451 structure DG = DependencyGraph
24 : blume 587 structure GG = GroupGraph
25 : blume 737 structure IM = IntMap
26 : blume 375
27 :     val os = SMLofNJ.SysInfo.getOSKind ()
28 : blume 464 val my_archos =
29 :     concat [HostMachDepVC.architecture, "-", FilenamePolicy.kind2name os]
30 : blume 375
31 :     structure SSV =
32 :     SpecificSymValFn (structure MachDepVC = HostMachDepVC
33 :     val os = os)
34 :    
35 :     val emptydyn = E.dynamicPart E.emptyEnv
36 : blume 737 val system_values =
37 :     ref (SrcPathMap.empty: E.dynenv IntMap.map 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 677 val useStream = HostMachDepVC.Interact.useStream
45 : blume 801 val compile_there = Servers.compile o SrcPath.encode)
46 : blume 400
47 : blume 537 structure BFC =
48 :     BfcFn (structure MachDepVC = HostMachDepVC)
49 :    
50 : blume 399 structure Link =
51 :     LinkFn (structure MachDepVC = HostMachDepVC
52 : blume 537 structure BFC = BFC
53 : blume 399 val system_values = system_values)
54 : blume 375
55 :     structure AutoLoad = AutoLoadFn
56 : blume 399 (structure C = Compile
57 : blume 403 structure L = Link
58 :     structure BFC = BFC)
59 : blume 375
60 : blume 537 val mkBootList = #l o MkBootList.group (fn p => p)
61 :    
62 : blume 587 fun init_servers (GG.GROUP { grouppath, ... }) =
63 : blume 801 Servers.cm { archos = my_archos, project = SrcPath.encode grouppath }
64 : blume 587 | init_servers GG.ERRORGROUP = ()
65 : blume 456
66 : blume 399 fun recomp_runner gp g = let
67 : blume 456 val _ = init_servers g
68 : blume 403 fun store _ = ()
69 :     val { group, ... } = Compile.newTraversal (Link.evict, store, g)
70 : blume 399 in
71 : blume 450 isSome (Servers.withServers (fn () => group gp))
72 :     before Link.cleanup gp
73 : blume 399 end
74 : blume 375
75 :     (* This function combines the actions of "recompile" and "exec".
76 :     * When successful, it combines the results (thus forming a full
77 :     * environment) and adds it to the toplevel environment. *)
78 : blume 587 fun make_runner _ _ GG.ERRORGROUP = false
79 :     | make_runner add_bindings gp (g as GG.GROUP grec) = let
80 :     val { required = rq, ... } = grec
81 :     val { store, get } = BFC.new ()
82 :     val _ = init_servers g
83 :     val { group = c_group, ... } =
84 :     Compile.newTraversal (Link.evict, store, g)
85 : blume 771 val { group = l_group, ... } =
86 :     Link.newTraversal (g, #content o get)
87 : blume 587 in
88 :     case Servers.withServers (fn () => c_group gp) of
89 :     NONE => false
90 :     | SOME { stat, sym} =>
91 : blume 537 (* Before executing the code, we announce the privileges
92 : blume 399 * that are being invoked. (For the time being, we assume
93 :     * that everybody has every conceivable privilege, but at
94 :     * the very least we announce which ones are being made
95 :     * use of.) *)
96 : blume 400 (Link.cleanup gp;
97 : blume 399 if StringSet.isEmpty rq then ()
98 :     else Say.say ("$Execute: required privileges are:\n" ::
99 :     map (fn s => (" " ^ s ^ "\n")) (StringSet.listItems rq));
100 :     case l_group gp of
101 : blume 375 NONE => false
102 : blume 518 | SOME dyn =>
103 :     (if add_bindings then
104 :     let val delta = E.mkenv { static = stat,
105 :     symbolic = sym,
106 :     dynamic = dyn }
107 :     val base = #get ER.topLevel ()
108 : blume 587 val new = E.concatEnv (delta, base)
109 : blume 518 in
110 :     #set ER.topLevel new;
111 :     Say.vsay ["[New bindings added.]\n"]
112 :     end
113 :     else ();
114 :     true))
115 : blume 587 end
116 : blume 375
117 :     val al_greg = GroupReg.new ()
118 :    
119 :     (* Instantiate the stabilization mechanism. *)
120 :     structure Stabilize =
121 : blume 403 StabilizeFn (structure MachDepVC = HostMachDepVC
122 : blume 588 structure StabModmap = StabModmap
123 : blume 403 fun recomp gp g = let
124 :     val { store, get } = BFC.new ()
125 :     val { group, ... } =
126 :     Compile.newTraversal (Link.evict, store, g)
127 :     in
128 : blume 801 case group gp of
129 : blume 403 NONE => NONE
130 :     | SOME _ => SOME get
131 :     end
132 :     val getII = Compile.getII)
133 : blume 375
134 :     (* Access to the stabilization mechanism is integrated into the
135 :     * parser. I'm not sure if this is the cleanest way, but it works
136 :     * well enough. *)
137 :     structure Parse = ParseFn (structure Stabilize = Stabilize
138 : blume 588 structure StabModmap = StabModmap
139 : blume 537 fun evictStale () =
140 :     (Compile.evictStale ();
141 :     Link.evictStale ())
142 : blume 375 val pending = AutoLoad.getPending)
143 :    
144 :     local
145 : blume 592 type kernelValues = { init_group : GG.group }
146 : blume 375
147 :     val fnpolicy = FilenamePolicy.colocate
148 :     { os = os, arch = HostMachDepVC.architecture }
149 :    
150 :     val theValues = ref (NONE: kernelValues option)
151 :    
152 :     in
153 : blume 666 val penv = SrcPath.newEnv ()
154 : blume 645
155 : blume 377 (* cancelling anchors cannot affect the order of existing paths
156 :     * (it may invalidate some paths; but all other ones stay as
157 :     * they are) *)
158 : blume 666 fun setAnchor a v = SrcPath.set_anchor (penv, a, v)
159 : blume 377 (* same goes for reset because it just cancels all anchors... *)
160 : blume 666 fun resetPathConfig () = SrcPath.reset_anchors penv
161 : blume 569 (* get the current binding for an anchor *)
162 : blume 666 fun getAnchor a () = SrcPath.get_anchor (penv, a)
163 : blume 375
164 : blume 525 fun mkStdSrcPath s =
165 : blume 666 SrcPath.file
166 :     (SrcPath.standard { err = fn s => raise Fail s, env = penv }
167 :     { context = SrcPath.cwd (), spec = s })
168 : blume 525
169 : blume 479 fun getPending () = let
170 : blume 375 fun one (s, _) = let
171 :     val nss = Symbol.nameSpaceToString (Symbol.nameSpace s)
172 :     val n = Symbol.name s
173 :     in
174 : blume 479 concat [" ", nss, " ", n, "\n"]
175 : blume 375 end
176 :     in
177 : blume 479 map one (SymbolMap.listItemsi (AutoLoad.getPending ()))
178 : blume 375 end
179 :    
180 :     fun initPaths () = let
181 : blume 433 val lpcth = #get StdConfig.local_pathconfig ()
182 : blume 375 val p = case lpcth () of
183 :     NONE => []
184 :     | SOME f => [f]
185 : blume 433 val p = #get StdConfig.pathcfgspec () :: p
186 : blume 735 fun processOne f = let
187 :     val work = SrcPath.processSpecFile
188 :     { env = penv, specfile = f, say = Say.say }
189 :     in
190 :     SafeIO.perform { openIt = fn () => TextIO.openIn f,
191 :     closeIt = TextIO.closeIn,
192 :     work = work,
193 :     cleanup = fn _ => () }
194 :     end handle _ => ()
195 : blume 375 in
196 : blume 676 app processOne p;
197 :     SrcPath.sync ()
198 : blume 375 end
199 :    
200 : blume 537 fun getTheValues () = valOf (!theValues)
201 :     handle Option => raise Fail "CMBoot: theParam not initialized"
202 :    
203 : blume 375 fun param () = let
204 : blume 537 val v = getTheValues ()
205 : blume 375 in
206 : blume 537 { fnpolicy = fnpolicy,
207 : blume 666 penv = penv,
208 : blume 433 symval = SSV.symval,
209 : blume 592 keep_going = #get StdConfig.keep_going () }
210 : blume 375 end
211 :    
212 : blume 537 val init_group = #init_group o getTheValues
213 :    
214 : blume 507 fun dropPickles () =
215 :     if #get StdConfig.conserve_memory () then
216 :     Parse.dropPickles ()
217 :     else ()
218 :    
219 : blume 537 fun parse_arg (gr, sflag, p) =
220 :     { load_plugin = load_plugin, gr = gr, param = param (),
221 : blume 569 stabflag = sflag, group = p,
222 :     init_group = init_group (), paranoid = false }
223 : blume 537
224 :     and autoload s = let
225 : blume 525 val p = mkStdSrcPath s
226 : blume 375 in
227 : blume 537 (case Parse.parse (parse_arg (al_greg, NONE, p)) of
228 : blume 505 NONE => false
229 :     | SOME (g, _) =>
230 : blume 537 (AutoLoad.register (GenericVC.EnvRef.topLevel, g);
231 :     true))
232 : blume 507 before dropPickles ()
233 : blume 375 end
234 :    
235 : blume 578 and run mkSrcPath sflag f s = let
236 :     val p = mkSrcPath s
237 : blume 537 val gr = GroupReg.new ()
238 : blume 375 in
239 : blume 537 (case Parse.parse (parse_arg (gr, sflag, p)) of
240 : blume 505 NONE => false
241 :     | SOME (g, gp) => f gp g)
242 : blume 507 before dropPickles ()
243 : blume 375 end
244 :    
245 : blume 735 and load_plugin' p = let
246 :     val d = SrcPath.descr p
247 :     val _ = Say.vsay ["[attempting to load plugin ", d, "]\n"]
248 :     val gr = GroupReg.new ()
249 : blume 518 val success =
250 : blume 735 ((case Parse.parse (parse_arg (gr, NONE, p)) of
251 :     NONE => false
252 :     | SOME (g, gp) => make_runner false gp g)
253 :     before dropPickles ())
254 :     handle _ => false
255 : blume 518 in
256 :     if success then
257 : blume 735 Say.vsay ["[plugin ", d, " loaded successfully]\n"]
258 : blume 518 else
259 : blume 735 Say.vsay ["[unable to load plugin ", d, "]\n"];
260 : blume 518 success
261 :     end
262 :    
263 : blume 735 and load_plugin context s = let
264 :     fun badname s = Say.say ["[bad plugin name: ", s, "]\n"]
265 :     val pp = SrcPath.standard { env = penv, err = badname }
266 :     { context = context, spec = s }
267 :     in
268 :     load_plugin' (SrcPath.file pp)
269 :     end
270 :    
271 : blume 666 fun cwd_load_plugin x = load_plugin (SrcPath.cwd ()) x
272 : blume 578
273 : blume 801 fun stabilize recursively root = let
274 :     fun stabilize_recomp_runner gp g = let
275 :     val _ = init_servers g
276 :     val { allgroups, ... } =
277 :     Compile.newTraversal (Link.evict, fn _ => (), g)
278 :     in
279 :     Servers.withServers (fn () => allgroups gp)
280 :     end
281 :     fun stabilize_dummy_runner gp g = true
282 :     fun phase1 () = run mkStdSrcPath NONE
283 :     stabilize_recomp_runner root
284 :     fun phase2 () = (Compile.reset ();(* a bit too draconian? *)
285 :     run mkStdSrcPath (SOME recursively)
286 :     stabilize_dummy_runner root)
287 :     in
288 :     (* Don't bother with the 2-phase thing if there are
289 : blume 854 * no compile servers attached. (We still need
290 :     * the "withServers" call to clean up our queues in case
291 :     * of an interrupt or error.) *)
292 :     if Servers.noServers () then Servers.withServers phase2
293 : blume 801 else
294 :     (* We do this in two phases:
295 :     * 1. recompile everything without stabilization but
296 :     * potentially using compile servers
297 :     * 2. do a local stabilization run (which should have
298 :     * no need to compile anything); don't use servers
299 :     *)
300 :     phase1 () andalso phase2 ()
301 :     end
302 : blume 449
303 : blume 578 val recomp = run mkStdSrcPath NONE recomp_runner
304 :     val make = run mkStdSrcPath NONE (make_runner true)
305 : blume 449
306 : blume 642 fun sources archos group = let
307 :     val policy =
308 :     case archos of
309 :     NONE => fnpolicy
310 :     | SOME ao => FilenamePolicy.colocate_generic ao
311 : blume 666 fun sourcesOf ((p, gth, _), (v, a)) =
312 : blume 642 if SrcPathSet.member (v, p) then (v, a)
313 :     else
314 :     let val v = SrcPathSet.add (v, p)
315 : blume 652 in case gth () of
316 : blume 642 GG.ERRORGROUP => (v, a)
317 :     | GG.GROUP { kind, sources, ... } => let
318 :     fun add (p, x, a) =
319 :     StringMap.insert
320 :     (a, SrcPath.osstring p, x)
321 :     val a = SrcPathMap.foldli add a sources
322 :     fun sg subgroups =
323 :     foldl sourcesOf (v, a) subgroups
324 :     in
325 :     case kind of
326 :     GG.LIB { kind, version } =>
327 :     (case kind of
328 :     GG.STABLE _ => let
329 :     val file = SrcPath.osstring p
330 :     val (a, x) =
331 :     StringMap.remove (a, file)
332 :     val sfile =
333 :     FilenamePolicy.mkStableName
334 :     policy (p, version)
335 :     in
336 :     (v,
337 :     StringMap.insert (a, sfile, x))
338 :     end
339 :     | GG.DEVELOPED d => sg (#subgroups d))
340 :     | GG.NOLIB n => sg (#subgroups n)
341 :     end
342 :     end
343 : blume 632 val p = mkStdSrcPath group
344 :     val gr = GroupReg.new ()
345 :     in
346 :     (case Parse.parse (parse_arg (gr, NONE, p)) of
347 : blume 642 SOME (g, _) => let
348 :     val (_, sm) =
349 : blume 666 sourcesOf ((p, fn () => g, []),
350 : blume 642 (SrcPathSet.empty,
351 :     StringMap.singleton
352 :     (SrcPath.osstring p,
353 :     { class = "cm",
354 :     derived = false })))
355 :     fun add (s, { class, derived }, l) =
356 :     { file = s, class = class, derived = derived } :: l
357 : blume 632 in
358 : blume 642 SOME (StringMap.foldli add [] sm)
359 :     end
360 :     | _ => NONE)
361 : blume 632 before dropPickles ()
362 :     end
363 :    
364 : blume 692 fun mk_standalone sflag { project, wrapper, target } = let
365 :     val hsfx = SMLofNJ.SysInfo.getHeapSuffix ()
366 :     fun extendTarget () =
367 :     OS.Path.joinBaseExt { base = target, ext = SOME hsfx }
368 :     val target =
369 :     case OS.Path.splitBaseExt target of
370 :     { base, ext = NONE } => extendTarget ()
371 :     | { base, ext = SOME e } =>
372 :     if e = hsfx then target else extendTarget ()
373 :     val pp = mkStdSrcPath project
374 :     val wp = mkStdSrcPath wrapper
375 :     val ts = TStamp.fmodTime target
376 : blume 537 val gr = GroupReg.new ()
377 : blume 692 fun do_wrapper () =
378 :     case Parse.parse (parse_arg (gr, NONE, wp)) of
379 :     NONE => NONE
380 :     | SOME (g, gp) =>
381 :     if recomp_runner gp g then SOME (mkBootList g)
382 :     else NONE
383 : blume 537 in
384 : blume 692 (case Parse.parse (parse_arg (gr, sflag, pp)) of
385 : blume 537 NONE => NONE
386 :     | SOME (g, gp) =>
387 :     if isSome sflag orelse recomp_runner gp g then
388 : blume 692 case (ts, !(#youngest gp)) of
389 :     (TStamp.TSTAMP tgt_t, TStamp.TSTAMP src_t) =>
390 :     if Time.< (tgt_t, src_t) then do_wrapper ()
391 :     else SOME []
392 :     | _ => do_wrapper ()
393 : blume 537 else NONE)
394 :     before dropPickles ()
395 :     end
396 :    
397 : blume 518 fun slave () = let
398 : blume 537 val gr = GroupReg.new ()
399 :     fun parse p = Parse.parse (parse_arg (gr, NONE, p))
400 : blume 518 in
401 : blume 666 Slave.slave { penv = penv,
402 : blume 518 parse = parse,
403 : blume 480 my_archos = my_archos,
404 :     sbtrav = Compile.newSbnodeTraversal,
405 :     make = make }
406 : blume 518 end
407 : blume 456
408 : blume 716 (* This function works on behalf of the ml-build script.
409 :     * Having it here avoids certain startup-costs and also
410 :     * keeps ML code together. (It used to be part of the
411 :     * script, but that proved difficult to maintain.) *)
412 :     fun mlbuild buildargs =
413 :     OS.Process.exit
414 :     (case buildargs of
415 :     [root, cmfile, heap, listfile, link] =>
416 :     (case mk_standalone NONE { project = root,
417 :     wrapper = cmfile,
418 :     target = heap } of
419 :     NONE => (Say.say ["Compilation failed.\n"];
420 :     OS.Process.failure)
421 :     | SOME [] => (Say.say ["Heap was already up-to-date.\n"];
422 :     OS.Process.success)
423 :     | SOME l => let
424 :     val s = TextIO.openOut listfile
425 :     fun wr str = TextIO.output (s, str ^ "\n")
426 :     val n = length l
427 :     fun maxsz (s, n) = Int.max (size s, n)
428 :     val m = foldl maxsz 0 l
429 :     in
430 :     wr (concat ["%", Int.toString n, " ",
431 :     Int.toString m]);
432 :     app wr l;
433 :     TextIO.closeOut s;
434 :     OS.Process.system (concat [link,
435 :     " @SMLboot=", listfile])
436 :     end
437 :     handle _ => OS.Process.failure)
438 :     | _ => (Say.say ["bad arguments to @CMbuild\n"];
439 :     OS.Process.failure))
440 :    
441 : blume 518 fun al_ginfo () = { param = param (),
442 :     groupreg = al_greg,
443 : blume 692 errcons = EM.defaultConsumer (),
444 :     youngest = ref TStamp.ancient }
445 : blume 518
446 :     val al_manager =
447 :     AutoLoad.mkManager { get_ginfo = al_ginfo,
448 :     dropPickles = dropPickles }
449 :    
450 :     fun al_manager' (ast, _, ter) = al_manager (ast, ter)
451 :    
452 : blume 375 fun reset () =
453 : blume 399 (Compile.reset ();
454 :     Link.reset ();
455 : blume 375 AutoLoad.reset ();
456 :     Parse.reset ();
457 : blume 588 SmlInfo.reset ();
458 :     StabModmap.reset ())
459 : blume 375
460 : blume 569 fun initTheValues (bootdir, de, er, autoload_postprocess) = let
461 : blume 375 val _ = let
462 :     fun listDir ds = let
463 :     fun loop l =
464 : blume 380 case F.readDir ds of
465 : blume 375 "" => l
466 :     | x => loop (x :: l)
467 :     in
468 :     loop []
469 :     end
470 :     val fileList = SafeIO.perform
471 : blume 380 { openIt = fn () => F.openDir bootdir,
472 :     closeIt = F.closeDir,
473 : blume 375 work = listDir,
474 : blume 459 cleanup = fn _ => () }
475 : blume 380 fun isDir x = F.isDir x handle _ => false
476 : blume 375 fun subDir x = let
477 : blume 380 val d = P.concat (bootdir, x)
478 : blume 375 in
479 :     if isDir d then SOME (x, d) else NONE
480 :     end
481 :     val pairList = List.mapPartial subDir fileList
482 : blume 666 fun sa (x, d) = SrcPath.set_anchor (penv, x, SOME d)
483 : blume 375 in
484 : blume 666 app sa pairList
485 : blume 375 end
486 : blume 569
487 :     val pidmapfile = P.concat (bootdir, BtNames.pidmap)
488 :     fun readpidmap s = let
489 :     fun loop m = let
490 :     fun enter (d, pids) = let
491 : blume 737 fun enter1 (spec, pm) = let
492 :     val fromHex = GenericVC.PersStamps.fromHex
493 :     in
494 :     case String.tokens (fn c => c = #":") spec of
495 :     [pos, hexp] =>
496 :     (case (fromHex hexp, Int.fromString pos) of
497 :     (SOME p, SOME i) =>
498 :     (IM.insert (pm, i,
499 :     DE.bind (p, DE.look de p,
500 :     emptydyn))
501 :     handle DE.Unbound => pm)
502 :     | _ => pm)
503 :     | _ => pm
504 :     end
505 : blume 569 in
506 : blume 666 SrcPathMap.insert (m, SrcPath.decode penv d,
507 : blume 737 foldl enter1 IM.empty pids)
508 : blume 569 end
509 :     in
510 :     case TextIO.inputLine s of
511 :     "" => m
512 :     | line => (case String.tokens Char.isSpace line of
513 :     d :: pids => loop (enter (d, pids))
514 :     | _ => loop m)
515 :     end
516 : blume 737 val m = loop SrcPathMap.empty
517 : blume 569 in
518 : blume 737 system_values := m
519 : blume 569 end
520 :    
521 :     val _ =
522 :     SafeIO.perform { openIt = fn () => TextIO.openIn pidmapfile,
523 :     closeIt = TextIO.closeIn,
524 :     work = readpidmap,
525 :     cleanup = fn _ => () }
526 :    
527 : blume 525 val initgspec = mkStdSrcPath BtNames.initgspec
528 : blume 537 val ginfo = { param = { fnpolicy = fnpolicy,
529 : blume 666 penv = penv,
530 : blume 433 symval = SSV.symval,
531 : blume 592 keep_going = false },
532 : blume 375 groupreg = GroupReg.new (),
533 : blume 692 errcons = EM.defaultConsumer (),
534 :     youngest = ref TStamp.ancient }
535 : blume 537 fun loadInitGroup () =
536 : blume 666 Stabilize.loadStable
537 :     { getGroup = fn _ =>
538 :     raise Fail "CMBoot: initial getGroup",
539 :     anyerrors = ref false }
540 :     (ginfo, initgspec, NONE, [])
541 : blume 375 in
542 : blume 537 case loadInitGroup () of
543 :     NONE => raise Fail "CMBoot: unable to load init group"
544 :     | SOME init_group => let
545 :     val _ = Compile.reset ()
546 :     val _ = Link.reset ()
547 : blume 375
548 : blume 537 val { exports = ctm, ... } =
549 :     Compile.newTraversal (fn _ => fn _ => (),
550 :     fn _ => (),
551 :     init_group)
552 :     val { exports = ltm, ... } = Link.newTraversal
553 :     (init_group, fn _ => raise Fail "init: get bfc?")
554 :    
555 :     fun getSymTrav (tr_m, sy) =
556 :     case SymbolMap.find (tr_m, sy) of
557 :     NONE => raise Fail "init: bogus init group (1)"
558 :     | SOME tr => tr
559 :    
560 : blume 592 val perv_ct = getSymTrav (ctm, PervAccess.pervStrSym)
561 :     val perv_lt = getSymTrav (ltm, PervAccess.pervStrSym)
562 : blume 537
563 :     fun doTrav t =
564 :     case t ginfo of
565 :     SOME r => r
566 :     | NONE => raise Fail "init: bogus init group (2)"
567 :    
568 :     val { stat = pervstat, sym = pervsym } = doTrav perv_ct
569 :     val pervdyn = doTrav perv_lt
570 :    
571 :     val pervasive = E.mkenv { static = pervstat,
572 :     symbolic = pervsym,
573 :     dynamic = pervdyn }
574 :    
575 : blume 495 fun bare_autoload x =
576 :     (Say.say
577 :     ["!* ", x,
578 :     ": \"autoload\" not available, using \"make\"\n"];
579 :     make x)
580 :     val bare_preload =
581 :     Preload.preload { make = make,
582 :     autoload = bare_autoload }
583 :     val standard_preload =
584 :     Preload.preload { make = make, autoload = autoload }
585 : blume 375 in
586 : blume 592 #set ER.pervasive pervasive;
587 : blume 587 #set ER.topLevel E.emptyEnv;
588 : blume 592 theValues := SOME { init_group = init_group };
589 : blume 375 case er of
590 :     BARE =>
591 : blume 495 (bare_preload BtNames.bare_preloads;
592 : blume 569 system_values := SrcPathMap.empty;
593 : blume 495 NONE)
594 : blume 375 | AUTOLOAD =>
595 :     (HostMachDepVC.Interact.installCompManager
596 :     (SOME al_manager');
597 : blume 495 standard_preload BtNames.standard_preloads;
598 : blume 507 (* unconditionally drop all library pickles *)
599 :     Parse.dropPickles ();
600 : blume 495 SOME (autoload_postprocess ()))
601 : blume 375 end
602 :     end
603 :     end
604 :     in
605 : blume 495 fun init (bootdir, de, er) = let
606 :     fun procCmdLine () = let
607 :     val autoload = ignore o autoload
608 :     val make = ignore o make
609 : blume 692 fun p (f, mk, ("sml" | "sig" | "fun")) =
610 :     HostMachDepVC.Interact.useFile f
611 :     | p (f, mk, "cm") = mk f
612 :     | p (f, mk, e) = Say.say ["!* unable to process `", f,
613 : blume 495 "' (unknown extension `", e, "')\n"]
614 : blume 692 fun badopt opt f () =
615 :     Say.say ["!* bad ", opt, " option: `", f, "'\n"]
616 :     fun carg ("-D", f, _) =
617 :     let val bad = badopt "-D" f
618 :     in
619 :     case String.fields (fn c => c = #"=")
620 :     (String.extract (f, 2, NONE)) of
621 :     "" :: _ => bad ()
622 :     | [var, num] =>
623 :     (case Int.fromString num of
624 :     SOME i => #set (SSV.symval var) (SOME i)
625 :     | NONE => bad ())
626 :     | [var] => #set (SSV.symval var) (SOME 1)
627 :     | _ => bad ()
628 :     end
629 :     | carg ("-U", f, _) =
630 :     (case String.extract (f, 2, NONE) of
631 :     "" => badopt "-U" f ()
632 :     | var => #set (SSV.symval var) NONE)
633 :     | carg (_, f, mk) = p (f, mk,
634 :     String.map Char.toLower
635 :     (getOpt (OS.Path.ext f, "<none>")))
636 : blume 716
637 :     fun args ("-a" :: rest, _) = args (rest, autoload)
638 :     | args ("-m" :: rest, _) = args (rest, make)
639 :     | args ("@CMbuild" :: rest, _) = mlbuild rest
640 :     | args (f :: rest, mk) =
641 :     (carg (String.substring (f, 0, 2), f, mk)
642 :     handle General.Subscript => ();
643 :     args (rest, mk))
644 :     | args ([], _) = ()
645 : blume 495 in
646 :     case SMLofNJ.getArgs () of
647 :     ["@CMslave"] => (#set StdConfig.verbose false; slave ())
648 : blume 716 | l => args (l, autoload)
649 : blume 495 end
650 : blume 448 in
651 : blume 569 initTheValues (bootdir, de, er,
652 :     fn () => (Cleanup.install initPaths;
653 :     procCmdLine))
654 : blume 448 end
655 : blume 479
656 : blume 734 structure CM = struct
657 : blume 479 type 'a controller = { get : unit -> 'a, set : 'a -> unit }
658 :    
659 :     structure Anchor = struct
660 : blume 569 fun anchor a = { get = getAnchor a, set = setAnchor a }
661 : blume 479 val reset = resetPathConfig
662 :     end
663 :    
664 :     structure Control = struct
665 :     val keep_going = StdConfig.keep_going
666 :     val verbose = StdConfig.verbose
667 :     val parse_caching = StdConfig.parse_caching
668 :     val warn_obsolete = StdConfig.warn_obsolete
669 :     val debug = StdConfig.debug
670 : blume 505 val conserve_memory = StdConfig.conserve_memory
671 : blume 838 val generate_index = StdConfig.generate_index
672 : blume 479 end
673 :    
674 :     structure Library = struct
675 : blume 666 type lib = SrcPath.file
676 : blume 479 val known = Parse.listLibs
677 :     val descr = SrcPath.descr
678 :     val osstring = SrcPath.osstring
679 :     val dismiss = Parse.dismissLib
680 : blume 632 fun unshare lib = (Link.unshare lib; dismiss lib)
681 : blume 479 end
682 :    
683 :     structure State = struct
684 :     val synchronize = SrcPath.sync
685 :     val reset = reset
686 :     val pending = getPending
687 :     end
688 :    
689 :     structure Server = struct
690 : blume 735 type server = Servers.server_handle
691 : blume 666 fun start x = Servers.start x
692 :     before SrcPath.scheduleNotification ()
693 : blume 479 val stop = Servers.stop
694 :     val kill = Servers.kill
695 :     val name = Servers.name
696 :     end
697 :    
698 :     val autoload = autoload
699 :     val make = make
700 :     val recomp = recomp
701 :     val stabilize = stabilize
702 :    
703 : blume 642 val sources = sources
704 : blume 632
705 : blume 479 val symval = SSV.symval
706 : blume 578 val load_plugin = cwd_load_plugin
707 : blume 537 val mk_standalone = mk_standalone
708 : blume 479 end
709 : blume 525
710 : blume 756 structure Tools = ToolsFn (val load_plugin' = load_plugin'
711 : blume 666 val penv = penv)
712 : blume 578
713 :     val load_plugin = load_plugin
714 : blume 375 end
715 :     end

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