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 1629 - (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 : blume 879 functor LinkCM (structure HostBackend : BACKEND) = struct
10 : blume 375
11 :     datatype envrequest = AUTOLOAD | BARE
12 :    
13 :     local
14 : blume 879 structure E = Environment
15 : blume 569 structure DE = DynamicEnv
16 : blume 879 structure SE = StaticEnv
17 :     structure ER = EnvRef
18 :     structure S = Symbol
19 :     structure EM = ErrorMsg
20 : blume 380 structure P = OS.Path
21 :     structure F = OS.FileSys
22 : blume 451 structure DG = DependencyGraph
23 : blume 587 structure GG = GroupGraph
24 : blume 737 structure IM = IntMap
25 : blume 375
26 :     val os = SMLofNJ.SysInfo.getOSKind ()
27 : blume 464 val my_archos =
28 : blume 879 concat [HostBackend.architecture, "-", FilenamePolicy.kind2name os]
29 : blume 375
30 :     structure SSV =
31 : blume 879 SpecificSymValFn (val arch = HostBackend.architecture
32 : blume 375 val os = os)
33 :    
34 : blume 737 val system_values =
35 :     ref (SrcPathMap.empty: E.dynenv IntMap.map SrcPathMap.map)
36 : blume 375
37 : blume 588 structure StabModmap = StabModmapFn ()
38 :    
39 : blume 905 val useStreamHook =
40 :     ref (fn _ => raise Fail "useStreamHook not initialized")
41 :     : (TextIO.instream -> unit) ref
42 :    
43 : blume 400 structure Compile =
44 : blume 879 CompileFn (structure Backend = HostBackend
45 : blume 588 structure StabModmap = StabModmap
46 : blume 905 fun useStream s = !useStreamHook s
47 : blume 801 val compile_there = Servers.compile o SrcPath.encode)
48 : blume 400
49 : blume 537 structure BFC =
50 : blume 879 BfcFn (val arch = HostBackend.architecture)
51 : blume 537
52 : blume 399 structure Link =
53 : blume 1186 LinkFn (structure BFC = BFC
54 : blume 399 val system_values = system_values)
55 : blume 375
56 :     structure AutoLoad = AutoLoadFn
57 : blume 399 (structure C = Compile
58 : blume 403 structure L = Link
59 :     structure BFC = BFC)
60 : blume 375
61 : blume 537 val mkBootList = #l o MkBootList.group (fn p => p)
62 :    
63 : blume 587 fun init_servers (GG.GROUP { grouppath, ... }) =
64 : blume 801 Servers.cm { archos = my_archos, project = SrcPath.encode grouppath }
65 : blume 587 | init_servers GG.ERRORGROUP = ()
66 : blume 456
67 : blume 399 fun recomp_runner gp g = let
68 : blume 456 val _ = init_servers g
69 : blume 403 fun store _ = ()
70 :     val { group, ... } = Compile.newTraversal (Link.evict, store, g)
71 : blume 399 in
72 : blume 450 isSome (Servers.withServers (fn () => group gp))
73 :     before Link.cleanup gp
74 : blume 399 end
75 : blume 375
76 :     (* This function combines the actions of "recompile" and "exec".
77 :     * When successful, it combines the results (thus forming a full
78 :     * environment) and adds it to the toplevel environment. *)
79 : blume 587 fun make_runner _ _ GG.ERRORGROUP = false
80 :     | make_runner add_bindings gp (g as GG.GROUP grec) = let
81 :     val { required = rq, ... } = grec
82 :     val { store, get } = BFC.new ()
83 :     val _ = init_servers g
84 :     val { group = c_group, ... } =
85 :     Compile.newTraversal (Link.evict, store, g)
86 : blume 771 val { group = l_group, ... } =
87 : blume 879 Link.newTraversal (g, #contents o get)
88 : blume 587 in
89 :     case Servers.withServers (fn () => c_group gp) of
90 :     NONE => false
91 :     | SOME { stat, sym} =>
92 : blume 537 (* Before executing the code, we announce the privileges
93 : blume 399 * that are being invoked. (For the time being, we assume
94 :     * that everybody has every conceivable privilege, but at
95 :     * the very least we announce which ones are being made
96 :     * use of.) *)
97 : blume 400 (Link.cleanup gp;
98 : blume 399 if StringSet.isEmpty rq then ()
99 :     else Say.say ("$Execute: required privileges are:\n" ::
100 :     map (fn s => (" " ^ s ^ "\n")) (StringSet.listItems rq));
101 :     case l_group gp of
102 : blume 375 NONE => false
103 : blume 518 | SOME dyn =>
104 :     (if add_bindings then
105 :     let val delta = E.mkenv { static = stat,
106 :     symbolic = sym,
107 :     dynamic = dyn }
108 : blume 905 val loc = ER.loc ()
109 :     val base = #get loc ()
110 : blume 587 val new = E.concatEnv (delta, base)
111 : blume 518 in
112 : blume 905 #set loc new;
113 : blume 518 Say.vsay ["[New bindings added.]\n"]
114 :     end
115 :     else ();
116 :     true))
117 : blume 587 end
118 : blume 375
119 :     val al_greg = GroupReg.new ()
120 :    
121 :     (* Instantiate the stabilization mechanism. *)
122 :     structure Stabilize =
123 : blume 879 StabilizeFn (val arch = HostBackend.architecture
124 : blume 588 structure StabModmap = StabModmap
125 : blume 403 fun recomp gp g = let
126 :     val { store, get } = BFC.new ()
127 :     val { group, ... } =
128 :     Compile.newTraversal (Link.evict, store, g)
129 :     in
130 : blume 801 case group gp of
131 : blume 403 NONE => NONE
132 :     | SOME _ => SOME get
133 :     end
134 :     val getII = Compile.getII)
135 : blume 375
136 :     (* Access to the stabilization mechanism is integrated into the
137 :     * parser. I'm not sure if this is the cleanest way, but it works
138 :     * well enough. *)
139 :     structure Parse = ParseFn (structure Stabilize = Stabilize
140 : blume 588 structure StabModmap = StabModmap
141 : blume 537 fun evictStale () =
142 :     (Compile.evictStale ();
143 :     Link.evictStale ())
144 : blume 375 val pending = AutoLoad.getPending)
145 :    
146 :     local
147 : blume 592 type kernelValues = { init_group : GG.group }
148 : blume 375
149 :     val fnpolicy = FilenamePolicy.colocate
150 : blume 879 { os = os, arch = HostBackend.architecture }
151 : blume 375
152 :     val theValues = ref (NONE: kernelValues option)
153 :    
154 :     in
155 : blume 666 val penv = SrcPath.newEnv ()
156 : blume 645
157 : blume 377 (* cancelling anchors cannot affect the order of existing paths
158 :     * (it may invalidate some paths; but all other ones stay as
159 :     * they are) *)
160 : blume 666 fun setAnchor a v = SrcPath.set_anchor (penv, a, v)
161 : blume 377 (* same goes for reset because it just cancels all anchors... *)
162 : blume 666 fun resetPathConfig () = SrcPath.reset_anchors penv
163 : blume 569 (* get the current binding for an anchor *)
164 : blume 666 fun getAnchor a () = SrcPath.get_anchor (penv, a)
165 : blume 375
166 : blume 525 fun mkStdSrcPath s =
167 : blume 666 SrcPath.file
168 :     (SrcPath.standard { err = fn s => raise Fail s, env = penv }
169 :     { context = SrcPath.cwd (), spec = s })
170 : blume 525
171 : blume 1068 fun getPending () =
172 :     map (Symbol.describe o #1)
173 :     (SymbolMap.listItemsi (AutoLoad.getPending ()))
174 :    
175 :     fun showBindings () = let
176 :     val loaded = map Symbol.describe (EnvRef.listBoundSymbols ())
177 :     val pending = getPending ()
178 :     fun pr s = Say.say [s, "\n"]
179 : blume 375 in
180 : blume 1068 Say.say ["\n*** Symbols bound at toplevel:\n"];
181 :     app pr loaded;
182 :     Say.say ["\n*** Symbols registered for autoloading:\n"];
183 :     app pr pending
184 : blume 375 end
185 :    
186 :     fun initPaths () = let
187 : blume 433 val lpcth = #get StdConfig.local_pathconfig ()
188 : blume 375 val p = case lpcth () of
189 :     NONE => []
190 :     | SOME f => [f]
191 : blume 1261 val p = #get StdConfig.pathcfgspec () () :: p
192 : blume 735 fun processOne f = let
193 :     val work = SrcPath.processSpecFile
194 :     { env = penv, specfile = f, say = Say.say }
195 :     in
196 :     SafeIO.perform { openIt = fn () => TextIO.openIn f,
197 :     closeIt = TextIO.closeIn,
198 :     work = work,
199 :     cleanup = fn _ => () }
200 :     end handle _ => ()
201 : blume 375 in
202 : blume 676 app processOne p;
203 :     SrcPath.sync ()
204 : blume 375 end
205 :    
206 : blume 537 fun getTheValues () = valOf (!theValues)
207 : mblume 1393 handle Option => raise Fail "CMBoot: theValues not initialized"
208 : blume 537
209 : blume 1058 fun param slave_mode =
210 : blume 537 { fnpolicy = fnpolicy,
211 : blume 666 penv = penv,
212 : blume 433 symval = SSV.symval,
213 : blume 873 archos = my_archos,
214 : blume 1058 keep_going = #get StdConfig.keep_going (),
215 :     slave_mode = slave_mode }
216 : blume 375
217 : blume 537 val init_group = #init_group o getTheValues
218 :    
219 : blume 507 fun dropPickles () =
220 :     if #get StdConfig.conserve_memory () then
221 :     Parse.dropPickles ()
222 :     else ()
223 :    
224 : blume 1058 fun parse_arg0 slave_mode (gr, sflag, p) =
225 :     { load_plugin = load_plugin, gr = gr, param = param slave_mode,
226 : blume 569 stabflag = sflag, group = p,
227 :     init_group = init_group (), paranoid = false }
228 : blume 537
229 : blume 1058 and parse_arg x = parse_arg0 false x
230 :    
231 :     and slave_parse_arg x = parse_arg0 true x
232 :    
233 : blume 537 and autoload s = let
234 : blume 525 val p = mkStdSrcPath s
235 : blume 375 in
236 : blume 537 (case Parse.parse (parse_arg (al_greg, NONE, p)) of
237 : blume 505 NONE => false
238 :     | SOME (g, _) =>
239 : blume 905 (AutoLoad.register (EnvRef.loc (), g);
240 : blume 537 true))
241 : blume 507 before dropPickles ()
242 : blume 375 end
243 :    
244 : blume 578 and run mkSrcPath sflag f s = let
245 :     val p = mkSrcPath s
246 : blume 537 val gr = GroupReg.new ()
247 : blume 375 in
248 : blume 537 (case Parse.parse (parse_arg (gr, sflag, p)) of
249 : blume 505 NONE => false
250 :     | SOME (g, gp) => f gp g)
251 : blume 507 before dropPickles ()
252 : blume 375 end
253 :    
254 : blume 735 and load_plugin' p = let
255 :     val d = SrcPath.descr p
256 :     val _ = Say.vsay ["[attempting to load plugin ", d, "]\n"]
257 :     val gr = GroupReg.new ()
258 : blume 518 val success =
259 : blume 735 ((case Parse.parse (parse_arg (gr, NONE, p)) of
260 :     NONE => false
261 :     | SOME (g, gp) => make_runner false gp g)
262 :     before dropPickles ())
263 :     handle _ => false
264 : blume 518 in
265 :     if success then
266 : blume 735 Say.vsay ["[plugin ", d, " loaded successfully]\n"]
267 : blume 518 else
268 : blume 735 Say.vsay ["[unable to load plugin ", d, "]\n"];
269 : blume 518 success
270 :     end
271 :    
272 : blume 735 and load_plugin context s = let
273 :     fun badname s = Say.say ["[bad plugin name: ", s, "]\n"]
274 :     val pp = SrcPath.standard { env = penv, err = badname }
275 :     { context = context, spec = s }
276 :     in
277 :     load_plugin' (SrcPath.file pp)
278 :     end
279 :    
280 : blume 666 fun cwd_load_plugin x = load_plugin (SrcPath.cwd ()) x
281 : blume 578
282 : blume 801 fun stabilize recursively root = let
283 :     fun stabilize_recomp_runner gp g = let
284 :     val _ = init_servers g
285 :     val { allgroups, ... } =
286 :     Compile.newTraversal (Link.evict, fn _ => (), g)
287 :     in
288 :     Servers.withServers (fn () => allgroups gp)
289 :     end
290 :     fun stabilize_dummy_runner gp g = true
291 :     fun phase1 () = run mkStdSrcPath NONE
292 :     stabilize_recomp_runner root
293 :     fun phase2 () = (Compile.reset ();(* a bit too draconian? *)
294 :     run mkStdSrcPath (SOME recursively)
295 :     stabilize_dummy_runner root)
296 :     in
297 :     (* Don't bother with the 2-phase thing if there are
298 : blume 854 * no compile servers attached. (We still need
299 :     * the "withServers" call to clean up our queues in case
300 :     * of an interrupt or error.) *)
301 :     if Servers.noServers () then Servers.withServers phase2
302 : blume 801 else
303 :     (* We do this in two phases:
304 :     * 1. recompile everything without stabilization but
305 :     * potentially using compile servers
306 :     * 2. do a local stabilization run (which should have
307 :     * no need to compile anything); don't use servers
308 :     *)
309 :     phase1 () andalso phase2 ()
310 :     end
311 : blume 449
312 : blume 578 val recomp = run mkStdSrcPath NONE recomp_runner
313 :     val make = run mkStdSrcPath NONE (make_runner true)
314 : blume 449
315 : blume 977 fun to_portable s = let
316 :     val gp = mkStdSrcPath s
317 :     fun nativesrc s = let
318 :     val p = SrcPath.standard
319 :     { err = fn s => raise Fail s, env = penv }
320 :     { context = SrcPath.dir gp, spec = s }
321 :     in
322 :     SrcPath.osstring' (SrcPath.file p)
323 :     end
324 :     fun mkres (g, pl) = { graph = g, imports = pl,
325 :     nativesrc = nativesrc }
326 :     in
327 : blume 975 Option.map
328 : blume 977 (mkres o ToPortable.export)
329 : blume 975 (Parse.parse (parse_arg
330 :     (GroupReg.new (), NONE, mkStdSrcPath s)))
331 : blume 977 end
332 : blume 975
333 : blume 642 fun sources archos group = let
334 :     val policy =
335 :     case archos of
336 :     NONE => fnpolicy
337 :     | SOME ao => FilenamePolicy.colocate_generic ao
338 : blume 666 fun sourcesOf ((p, gth, _), (v, a)) =
339 : blume 642 if SrcPathSet.member (v, p) then (v, a)
340 :     else
341 :     let val v = SrcPathSet.add (v, p)
342 : blume 652 in case gth () of
343 : blume 642 GG.ERRORGROUP => (v, a)
344 :     | GG.GROUP { kind, sources, ... } => let
345 :     fun add (p, x, a) =
346 :     StringMap.insert
347 :     (a, SrcPath.osstring p, x)
348 :     val a = SrcPathMap.foldli add a sources
349 :     fun sg subgroups =
350 :     foldl sourcesOf (v, a) subgroups
351 :     in
352 :     case kind of
353 :     GG.LIB { kind, version } =>
354 :     (case kind of
355 :     GG.STABLE _ => let
356 :     val file = SrcPath.osstring p
357 :     val (a, x) =
358 :     StringMap.remove (a, file)
359 :     val sfile =
360 :     FilenamePolicy.mkStableName
361 :     policy (p, version)
362 :     in
363 :     (v,
364 :     StringMap.insert (a, sfile, x))
365 :     end
366 :     | GG.DEVELOPED d => sg (#subgroups d))
367 :     | GG.NOLIB n => sg (#subgroups n)
368 :     end
369 :     end
370 : blume 632 val p = mkStdSrcPath group
371 :     val gr = GroupReg.new ()
372 :     in
373 :     (case Parse.parse (parse_arg (gr, NONE, p)) of
374 : blume 642 SOME (g, _) => let
375 :     val (_, sm) =
376 : blume 666 sourcesOf ((p, fn () => g, []),
377 : blume 642 (SrcPathSet.empty,
378 :     StringMap.singleton
379 :     (SrcPath.osstring p,
380 :     { class = "cm",
381 :     derived = false })))
382 :     fun add (s, { class, derived }, l) =
383 :     { file = s, class = class, derived = derived } :: l
384 : blume 632 in
385 : blume 642 SOME (StringMap.foldli add [] sm)
386 :     end
387 :     | _ => NONE)
388 : blume 632 before dropPickles ()
389 :     end
390 :    
391 : blume 692 fun mk_standalone sflag { project, wrapper, target } = let
392 :     val hsfx = SMLofNJ.SysInfo.getHeapSuffix ()
393 :     fun extendTarget () =
394 :     OS.Path.joinBaseExt { base = target, ext = SOME hsfx }
395 :     val target =
396 :     case OS.Path.splitBaseExt target of
397 :     { base, ext = NONE } => extendTarget ()
398 :     | { base, ext = SOME e } =>
399 :     if e = hsfx then target else extendTarget ()
400 :     val pp = mkStdSrcPath project
401 :     val wp = mkStdSrcPath wrapper
402 :     val ts = TStamp.fmodTime target
403 : blume 537 val gr = GroupReg.new ()
404 : blume 692 fun do_wrapper () =
405 :     case Parse.parse (parse_arg (gr, NONE, wp)) of
406 :     NONE => NONE
407 :     | SOME (g, gp) =>
408 :     if recomp_runner gp g then SOME (mkBootList g)
409 :     else NONE
410 : blume 537 in
411 : blume 692 (case Parse.parse (parse_arg (gr, sflag, pp)) of
412 : blume 537 NONE => NONE
413 :     | SOME (g, gp) =>
414 :     if isSome sflag orelse recomp_runner gp g then
415 : blume 692 case (ts, !(#youngest gp)) of
416 :     (TStamp.TSTAMP tgt_t, TStamp.TSTAMP src_t) =>
417 :     if Time.< (tgt_t, src_t) then do_wrapper ()
418 :     else SOME []
419 :     | _ => do_wrapper ()
420 : blume 537 else NONE)
421 :     before dropPickles ()
422 :     end
423 :    
424 : blume 518 fun slave () = let
425 : blume 537 val gr = GroupReg.new ()
426 : blume 1058 fun parse p = Parse.parse (slave_parse_arg (gr, NONE, p))
427 : blume 518 in
428 : blume 666 Slave.slave { penv = penv,
429 : blume 518 parse = parse,
430 : blume 480 my_archos = my_archos,
431 :     sbtrav = Compile.newSbnodeTraversal,
432 :     make = make }
433 : blume 518 end
434 : blume 456
435 : blume 716 (* This function works on behalf of the ml-build script.
436 :     * Having it here avoids certain startup-costs and also
437 :     * keeps ML code together. (It used to be part of the
438 :     * script, but that proved difficult to maintain.) *)
439 :     fun mlbuild buildargs =
440 :     OS.Process.exit
441 :     (case buildargs of
442 : mblume 1342 [root, cmfile, heap, listfile, linkargsfile] =>
443 : blume 716 (case mk_standalone NONE { project = root,
444 :     wrapper = cmfile,
445 :     target = heap } of
446 :     NONE => (Say.say ["Compilation failed.\n"];
447 :     OS.Process.failure)
448 :     | SOME [] => (Say.say ["Heap was already up-to-date.\n"];
449 :     OS.Process.success)
450 :     | SOME l => let
451 : mblume 1342 fun wrf (f, l) = let
452 :     val s = TextIO.openOut f
453 :     fun wr str = TextIO.output (s, str ^ "\n")
454 :     in
455 :     app (fn str => TextIO.output (s, str ^ "\n")) l;
456 :     TextIO.closeOut s
457 :     end
458 :    
459 :    
460 : blume 716 val s = TextIO.openOut listfile
461 :     fun wr str = TextIO.output (s, str ^ "\n")
462 :     val n = length l
463 :     fun maxsz (s, n) = Int.max (size s, n)
464 :     val m = foldl maxsz 0 l
465 :     in
466 : mblume 1342 wrf (listfile, concat ["%", Int.toString n, " ",
467 :     Int.toString m]
468 :     :: l);
469 :     wrf (linkargsfile,
470 :     [concat [" @SMLboot=", listfile]]);
471 :     OS.Process.success
472 : blume 716 end
473 :     handle _ => OS.Process.failure)
474 :     | _ => (Say.say ["bad arguments to @CMbuild\n"];
475 :     OS.Process.failure))
476 :    
477 : blume 1058 fun al_ginfo () = { param = param false,
478 : blume 518 groupreg = al_greg,
479 : blume 692 errcons = EM.defaultConsumer (),
480 :     youngest = ref TStamp.ancient }
481 : blume 518
482 : mblume 1393 val al_managers =
483 :     AutoLoad.mkManagers { get_ginfo = al_ginfo,
484 :     dropPickles = dropPickles }
485 :    
486 : blume 375 fun reset () =
487 : blume 399 (Compile.reset ();
488 :     Link.reset ();
489 : blume 375 AutoLoad.reset ();
490 :     Parse.reset ();
491 : blume 588 SmlInfo.reset ();
492 : blume 1137 StabModmap.reset ())
493 : blume 375
494 : blume 905 fun initTheValues (bootdir, de, er, autoload_postprocess, icm) = let
495 :     (* icm: "install compilation manager" *)
496 : blume 375 val _ = let
497 :     fun listDir ds = let
498 :     fun loop l =
499 : blume 380 case F.readDir ds of
500 : mblume 1350 NONE => l
501 :     | SOME x => loop (x :: l)
502 : blume 375 in
503 :     loop []
504 :     end
505 :     val fileList = SafeIO.perform
506 : blume 380 { openIt = fn () => F.openDir bootdir,
507 :     closeIt = F.closeDir,
508 : blume 375 work = listDir,
509 : blume 459 cleanup = fn _ => () }
510 : blume 380 fun isDir x = F.isDir x handle _ => false
511 : blume 375 fun subDir x = let
512 : blume 380 val d = P.concat (bootdir, x)
513 : blume 375 in
514 :     if isDir d then SOME (x, d) else NONE
515 :     end
516 :     val pairList = List.mapPartial subDir fileList
517 : blume 666 fun sa (x, d) = SrcPath.set_anchor (penv, x, SOME d)
518 : blume 375 in
519 : blume 666 app sa pairList
520 : blume 375 end
521 : blume 569
522 :     val pidmapfile = P.concat (bootdir, BtNames.pidmap)
523 : mblume 1342
524 : blume 569 fun readpidmap s = let
525 :     fun loop m = let
526 :     fun enter (d, pids) = let
527 : blume 737 fun enter1 (spec, pm) = let
528 : blume 879 val fromHex = PersStamps.fromHex
529 : blume 737 in
530 :     case String.tokens (fn c => c = #":") spec of
531 :     [pos, hexp] =>
532 :     (case (fromHex hexp, Int.fromString pos) of
533 :     (SOME p, SOME i) =>
534 : blume 902 (case DE.look de p of
535 :     NONE => pm
536 :     | SOME obj =>
537 :     IM.insert (pm, i,
538 :     DE.singleton (p, obj)))
539 : blume 737 | _ => pm)
540 :     | _ => pm
541 :     end
542 : blume 569 in
543 : blume 666 SrcPathMap.insert (m, SrcPath.decode penv d,
544 : blume 737 foldl enter1 IM.empty pids)
545 : blume 569 end
546 :     in
547 :     case TextIO.inputLine s of
548 : mblume 1368 NONE => m
549 :     | SOME line =>
550 :     (case String.tokens Char.isSpace line of
551 :     d :: pids => loop (enter (d, pids))
552 :     | _ => loop m)
553 : blume 569 end
554 : blume 737 val m = loop SrcPathMap.empty
555 : blume 569 in
556 : blume 737 system_values := m
557 : blume 569 end
558 :    
559 :     val _ =
560 :     SafeIO.perform { openIt = fn () => TextIO.openIn pidmapfile,
561 :     closeIt = TextIO.closeIn,
562 :     work = readpidmap,
563 :     cleanup = fn _ => () }
564 :    
565 : blume 525 val initgspec = mkStdSrcPath BtNames.initgspec
566 : blume 537 val ginfo = { param = { fnpolicy = fnpolicy,
567 : blume 666 penv = penv,
568 : blume 433 symval = SSV.symval,
569 : blume 873 archos = my_archos,
570 : blume 1058 keep_going = false,
571 :     slave_mode = false },
572 : blume 375 groupreg = GroupReg.new (),
573 : blume 692 errcons = EM.defaultConsumer (),
574 :     youngest = ref TStamp.ancient }
575 : blume 537 fun loadInitGroup () =
576 : blume 666 Stabilize.loadStable
577 :     { getGroup = fn _ =>
578 :     raise Fail "CMBoot: initial getGroup",
579 :     anyerrors = ref false }
580 :     (ginfo, initgspec, NONE, [])
581 : blume 375 in
582 : blume 537 case loadInitGroup () of
583 :     NONE => raise Fail "CMBoot: unable to load init group"
584 :     | SOME init_group => let
585 :     val _ = Compile.reset ()
586 :     val _ = Link.reset ()
587 : blume 375
588 : blume 537 val { exports = ctm, ... } =
589 :     Compile.newTraversal (fn _ => fn _ => (),
590 :     fn _ => (),
591 :     init_group)
592 :     val { exports = ltm, ... } = Link.newTraversal
593 :     (init_group, fn _ => raise Fail "init: get bfc?")
594 :    
595 :     fun getSymTrav (tr_m, sy) =
596 :     case SymbolMap.find (tr_m, sy) of
597 :     NONE => raise Fail "init: bogus init group (1)"
598 :     | SOME tr => tr
599 :    
600 : blume 592 val perv_ct = getSymTrav (ctm, PervAccess.pervStrSym)
601 :     val perv_lt = getSymTrav (ltm, PervAccess.pervStrSym)
602 : blume 537
603 :     fun doTrav t =
604 :     case t ginfo of
605 :     SOME r => r
606 :     | NONE => raise Fail "init: bogus init group (2)"
607 :    
608 :     val { stat = pervstat, sym = pervsym } = doTrav perv_ct
609 :     val pervdyn = doTrav perv_lt
610 :    
611 :     val pervasive = E.mkenv { static = pervstat,
612 :     symbolic = pervsym,
613 :     dynamic = pervdyn }
614 :    
615 : blume 495 fun bare_autoload x =
616 :     (Say.say
617 :     ["!* ", x,
618 :     ": \"autoload\" not available, using \"make\"\n"];
619 :     make x)
620 :     val bare_preload =
621 :     Preload.preload { make = make,
622 :     autoload = bare_autoload }
623 :     val standard_preload =
624 :     Preload.preload { make = make, autoload = autoload }
625 : blume 375 in
626 : blume 592 #set ER.pervasive pervasive;
627 : blume 905 #set (ER.loc ()) E.emptyEnv;(* redundant? *)
628 : blume 592 theValues := SOME { init_group = init_group };
629 : blume 375 case er of
630 :     BARE =>
631 : blume 495 (bare_preload BtNames.bare_preloads;
632 : blume 569 system_values := SrcPathMap.empty;
633 : blume 495 NONE)
634 : blume 375 | AUTOLOAD =>
635 : mblume 1393 (icm al_managers;
636 : blume 905 standard_preload BtNames.standard_preloads;
637 : blume 507 (* unconditionally drop all library pickles *)
638 :     Parse.dropPickles ();
639 : blume 495 SOME (autoload_postprocess ()))
640 : blume 375 end
641 :     end
642 :     end
643 :     in
644 : blume 905 fun init (bootdir, de, er, useStream, useFile, icm) = let
645 : blume 495 fun procCmdLine () = let
646 :     val autoload = ignore o autoload
647 :     val make = ignore o make
648 : blume 905 fun p (f, mk, ("sml" | "sig" | "fun")) = useFile f
649 : blume 692 | p (f, mk, "cm") = mk f
650 :     | p (f, mk, e) = Say.say ["!* unable to process `", f,
651 : blume 495 "' (unknown extension `", e, "')\n"]
652 : blume 1201 fun inc n = n + 1
653 : blume 1126
654 : blume 1201 fun show_controls (getarg, getval, padval) level = let
655 :     fun walk indent (ControlRegistry.RTree rt) = let
656 :     open FormatComb
657 :     val { help, ctls, subregs, path } = rt
658 :    
659 : mblume 1629 fun one ci = let
660 : blume 1201 val arg = concat (foldr (fn (s, r) => s :: "." :: r)
661 : mblume 1629 [getarg ci] path)
662 :     val value = getval ci
663 : blume 1201 val sz = size value
664 :     val lw = !Control_Print.linewidth
665 :     val padsz = lw - 6 - size arg - indent
666 :     in
667 :     if padsz < sz then
668 :     let val padsz' = Int.max (lw, sz + 8 + indent)
669 :     in
670 :     format' Say.say (sp (indent + 6) o
671 :     text arg o nl o
672 :     padval padsz' (text value) o
673 :     nl)
674 :     end
675 :     else format' Say.say (sp (indent + 6) o
676 :     text arg o
677 :     padval padsz (text value) o
678 :     nl)
679 :     end
680 : blume 1126 in
681 : blume 1201 case (ctls, subregs) of
682 :     ([], []) => ()
683 :     | _ => (format' Say.say
684 :     (sp indent o text help o text ":" o nl);
685 :     app one ctls;
686 :     app (walk (indent + 1)) subregs)
687 : blume 1126 end
688 :     in
689 : blume 1201 walk 2 (ControlRegistry.controls
690 :     (BasicControl.topregistry, Option.map inc level))
691 : blume 1126 end
692 :    
693 :     fun help level =
694 :     (Say.say
695 :     ["sml [rtsargs] [options] [files]\n\
696 :     \\n\
697 :     \ rtsargs:\n\
698 :     \ @SMLload=<h> (start specified heap image)\n\
699 :     \ @SMLalloc=<s> (specify size of allocation area)\n\
700 :     \ @SMLcmdname=<n> (set command name)\n\
701 :     \ @SMLquiet (load heap image silently)\n\
702 :     \ @SMLverbose (show heap image load progress)\n\
703 :     \ @SMLobjects (show list of executable objects)\n\
704 :     \ @SMLdebug=<f> (write debugging info to file)\n\
705 :     \\n\
706 :     \ files:\n\
707 :     \ <file>.cm (CM.make or CM.autoload)\n\
708 :     \ -m (switch to CM.make)\n\
709 :     \ -a (switch to CM.autoload; default)\n\
710 :     \ <file>.sig (use)\n\
711 :     \ <file>.sml (use)\n\
712 :     \ <file>.fun (use)\n\
713 :     \\n\
714 :     \ options:\n\
715 :     \ -D<name>=<v> (set CM variable to given value)\n\
716 :     \ -D<name> (set CM variable to 1)\n\
717 :     \ -Uname (unset CM variable)\n\
718 :     \ -C<control>=<v> (set named control)\n\
719 :     \ -H (produce complete help listing)\n\
720 :     \ -h (produce minimal help listing)\n\
721 :     \ -h<level> (help with obscurity limit)\n\
722 :     \ -S (list all current settings)\n\
723 : mblume 1629 \ -s<level> (limited list of settings)\n\
724 :     \ -E (list all environment variables)\n\
725 :     \ -e<level> (limited list of environment variables)\n\n"];
726 :     show_controls (Controls.name o #ctl,
727 :     fn ci =>
728 :     concat ["(", #help (Controls.info (#ctl ci)),
729 :     ")"],
730 : blume 1201 FormatComb.pad FormatComb.left)
731 : blume 1126 level)
732 :    
733 : mblume 1629 fun showcur level =
734 :     show_controls (fn ci => (Controls.name (#ctl ci) ^ "="),
735 :     fn ci => Controls.get (#ctl ci),
736 : blume 1201 fn _ => fn ff => ff)
737 : blume 1126 level
738 :    
739 : mblume 1629 fun show_envvars level =
740 :     show_controls (fn ci => (Controls.name (#ctl ci) ^ ":"),
741 :     fn ci => Option.getOpt (#envName (#info ci),
742 :     "(none)"),
743 :     FormatComb.pad FormatComb.left)
744 :     level
745 :    
746 : blume 692 fun badopt opt f () =
747 : blume 1126 Say.say ["!* bad ", opt, " option: `", f, "'\n",
748 :     "!* try `-h' or `-h<level>' for help\n"]
749 : mblume 1595
750 :     fun quit () = OS.Process.exit OS.Process.success
751 :    
752 :     fun quit_if true = quit ()
753 :     | quit_if false = ()
754 :    
755 :     fun carg (opt as ("-C" | "-D"), f, _, _) =
756 : blume 1126 let val bad = badopt opt f
757 :     val spec = Substring.extract (f, 2, NONE)
758 :     val is_config = opt = "-C"
759 :     val (name, value) =
760 :     Substring.splitl (fn c => c <> #"=") spec
761 :     val name = Substring.string name
762 :     val value = Substring.string
763 :     (if Substring.size value > 0 then
764 :     Substring.slice (value, 1, NONE)
765 :     else value)
766 : blume 692 in
767 : blume 1126 if name = "" then bad ()
768 :     else if is_config then
769 : blume 1201 let val names = String.fields (fn c => c = #".") name
770 :     val look = ControlRegistry.control
771 :     BasicControl.topregistry
772 : blume 1126 in
773 : blume 1201 case look names of
774 :     NONE => Say.say ["!* no such control: ",
775 :     name, "\n"]
776 :     | SOME sctl =>
777 :     (Controls.set (sctl, value)
778 :     handle Controls.ValueSyntax vse =>
779 :     Say.say ["!* unable to parse value `",
780 :     #value vse, "' for ",
781 :     #ctlName vse, " : ",
782 :     #tyName vse, "\n"])
783 :     end
784 : blume 1126 else if value = "" then #set (SSV.symval name) (SOME 1)
785 :     else (case Int.fromString value of
786 :     SOME i => #set (SSV.symval name) (SOME i)
787 :     | NONE => bad ())
788 : blume 692 end
789 : mblume 1595 | carg ("-U", f, _, _) =
790 :     (case String.extract (f, 2, NONE) of
791 :     "" => badopt "-U" f ()
792 :     | var => #set (SSV.symval var) NONE)
793 :     | carg ("-h", f, _, last) =
794 :     (case String.extract (f, 2, NONE) of
795 :     "" => help (SOME 0)
796 :     | level => help (Int.fromString level);
797 :     quit_if last)
798 :     | carg ("-s", f, _, last) =
799 :     (case String.extract (f, 2, NONE) of
800 :     "" => showcur (SOME 0)
801 :     | level => showcur (Int.fromString level);
802 :     quit_if last)
803 : mblume 1629 | carg ("-e", f, _, last) =
804 :     (case String.extract (f, 2, NONE) of
805 :     "" => show_envvars (SOME 0)
806 :     | level => show_envvars (Int.fromString level);
807 :     quit_if last)
808 : mblume 1595 | carg (_, f, mk, _) =
809 :     p (f, mk, String.map Char.toLower
810 :     (getOpt (OS.Path.ext f, "<none>")))
811 : blume 716
812 :     fun args ("-a" :: rest, _) = args (rest, autoload)
813 :     | args ("-m" :: rest, _) = args (rest, make)
814 : mblume 1595 | args ("-H" :: rest, mk) = (help NONE; args_q (rest, mk))
815 :     | args ("-S" :: rest, mk) = (showcur NONE; args_q (rest, mk))
816 : mblume 1629 | args ("-E" :: rest, mk) = (show_envvars NONE; args_q (rest, mk))
817 : mblume 1595 | args ("-q" :: _, _) = quit ()
818 : blume 716 | args ("@CMbuild" :: rest, _) = mlbuild rest
819 :     | args (f :: rest, mk) =
820 : mblume 1595 (carg (String.substring (f, 0, 2)
821 :     handle General.Subscript => "",
822 :     f, mk, List.null rest);
823 : blume 716 args (rest, mk))
824 :     | args ([], _) = ()
825 : mblume 1595
826 :     and args_q ([], _) = quit ()
827 :     | args_q (rest, f) = args (rest, f)
828 : blume 495 in
829 :     case SMLofNJ.getArgs () of
830 :     ["@CMslave"] => (#set StdConfig.verbose false; slave ())
831 : blume 716 | l => args (l, autoload)
832 : blume 495 end
833 : blume 448 in
834 : blume 905 useStreamHook := useStream;
835 : blume 569 initTheValues (bootdir, de, er,
836 :     fn () => (Cleanup.install initPaths;
837 : blume 905 procCmdLine),
838 :     icm)
839 : blume 448 end
840 : blume 479
841 : blume 734 structure CM = struct
842 : blume 479 type 'a controller = { get : unit -> 'a, set : 'a -> unit }
843 :    
844 :     structure Anchor = struct
845 : blume 569 fun anchor a = { get = getAnchor a, set = setAnchor a }
846 : blume 479 val reset = resetPathConfig
847 :     end
848 :    
849 :     structure Control = struct
850 :     val keep_going = StdConfig.keep_going
851 :     val verbose = StdConfig.verbose
852 :     val parse_caching = StdConfig.parse_caching
853 :     val warn_obsolete = StdConfig.warn_obsolete
854 :     val debug = StdConfig.debug
855 : blume 505 val conserve_memory = StdConfig.conserve_memory
856 : blume 838 val generate_index = StdConfig.generate_index
857 : blume 479 end
858 :    
859 :     structure Library = struct
860 : blume 666 type lib = SrcPath.file
861 : blume 479 val known = Parse.listLibs
862 :     val descr = SrcPath.descr
863 :     val osstring = SrcPath.osstring
864 :     val dismiss = Parse.dismissLib
865 : blume 632 fun unshare lib = (Link.unshare lib; dismiss lib)
866 : blume 479 end
867 :    
868 :     structure State = struct
869 :     val synchronize = SrcPath.sync
870 :     val reset = reset
871 :     val pending = getPending
872 : blume 1068 val showBindings = showBindings
873 : blume 479 end
874 :    
875 :     structure Server = struct
876 : blume 735 type server = Servers.server_handle
877 : blume 666 fun start x = Servers.start x
878 :     before SrcPath.scheduleNotification ()
879 : blume 479 val stop = Servers.stop
880 :     val kill = Servers.kill
881 :     val name = Servers.name
882 :     end
883 :    
884 :     val autoload = autoload
885 :     val make = make
886 :     val recomp = recomp
887 :     val stabilize = stabilize
888 :    
889 : blume 642 val sources = sources
890 : blume 632
891 : blume 479 val symval = SSV.symval
892 : blume 578 val load_plugin = cwd_load_plugin
893 : blume 537 val mk_standalone = mk_standalone
894 : blume 975
895 :     structure Graph = struct
896 :     val graph = to_portable
897 :     end
898 : mblume 1385
899 :     val cm_dir_arc = FilenamePolicy.cm_dir_arc
900 : blume 479 end
901 : blume 525
902 : blume 756 structure Tools = ToolsFn (val load_plugin' = load_plugin'
903 : blume 666 val penv = penv)
904 : blume 578
905 :     val load_plugin = load_plugin
906 : blume 375 end
907 :     end

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