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 1712 - (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 : mblume 1656 fun mk_standalone sflag { setup, project, wrapper, target } = let
392 : blume 692 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 : mblume 1656 val spopt = Option.map mkStdSrcPath setup
401 : blume 692 val pp = mkStdSrcPath project
402 :     val wp = mkStdSrcPath wrapper
403 :     val ts = TStamp.fmodTime target
404 : blume 537 val gr = GroupReg.new ()
405 : mblume 1656 fun do_cmfile p =
406 :     case Parse.parse (parse_arg (gr, NONE, p)) of
407 : blume 692 NONE => NONE
408 :     | SOME (g, gp) =>
409 :     if recomp_runner gp g then SOME (mkBootList g)
410 :     else NONE
411 : mblume 1656 val setup_list =
412 :     case spopt of
413 :     SOME sp => getOpt (do_cmfile sp, [])
414 :     | NONE => []
415 :     fun in_setup (i, _) =
416 :     List.exists (MkBootList.same_info i o #1) setup_list
417 :     fun do_wrapper () =
418 :     case do_cmfile wp of
419 :     NONE => NONE
420 :     | SOME l =>
421 :     SOME (map #2 (setup_list @
422 :     List.filter (not o in_setup) l))
423 : blume 537 in
424 : blume 692 (case Parse.parse (parse_arg (gr, sflag, pp)) of
425 : blume 537 NONE => NONE
426 :     | SOME (g, gp) =>
427 :     if isSome sflag orelse recomp_runner gp g then
428 : blume 692 case (ts, !(#youngest gp)) of
429 :     (TStamp.TSTAMP tgt_t, TStamp.TSTAMP src_t) =>
430 :     if Time.< (tgt_t, src_t) then do_wrapper ()
431 :     else SOME []
432 :     | _ => do_wrapper ()
433 : blume 537 else NONE)
434 :     before dropPickles ()
435 :     end
436 :    
437 : blume 518 fun slave () = let
438 : blume 537 val gr = GroupReg.new ()
439 : blume 1058 fun parse p = Parse.parse (slave_parse_arg (gr, NONE, p))
440 : blume 518 in
441 : mblume 1640 #set (SSV.symval "CM_SLAVE_MODE") (SOME 1);
442 : blume 666 Slave.slave { penv = penv,
443 : blume 518 parse = parse,
444 : blume 480 my_archos = my_archos,
445 :     sbtrav = Compile.newSbnodeTraversal,
446 :     make = make }
447 : blume 518 end
448 : blume 456
449 : blume 716 (* This function works on behalf of the ml-build script.
450 :     * Having it here avoids certain startup-costs and also
451 :     * keeps ML code together. (It used to be part of the
452 :     * script, but that proved difficult to maintain.) *)
453 :     fun mlbuild buildargs =
454 : mblume 1656 let fun doit (setup, root, cmfile, heap, listfile, linkargsfile) =
455 :     case mk_standalone NONE { setup = setup,
456 :     project = root,
457 :     wrapper = cmfile,
458 :     target = heap } of
459 :     NONE => (Say.say ["Compilation failed.\n"];
460 :     OS.Process.failure)
461 :     | SOME [] =>
462 :     (Say.say ["Heap was already up-to-date.\n"];
463 :     OS.Process.success)
464 :     | SOME l => let
465 :     fun wrf (f, l) =
466 :     let val s = TextIO.openOut f
467 :     fun wr str =
468 :     TextIO.output (s, str ^ "\n")
469 :     in
470 :     app wr l;
471 :     TextIO.closeOut s
472 :     end
473 : mblume 1342
474 : mblume 1656 val s = TextIO.openOut listfile
475 :     fun wr str = TextIO.output (s, str ^ "\n")
476 :     val n = length l
477 :     fun maxsz (s, n) = Int.max (size s, n)
478 :     val m = foldl maxsz 0 l
479 :     in
480 :     wrf (listfile,
481 :     concat ["%", Int.toString n, " ",
482 :     Int.toString m]
483 :     :: l);
484 :     wrf (linkargsfile,
485 :     [concat [" @SMLboot=", listfile]]);
486 :     OS.Process.success
487 :     end handle _ => OS.Process.failure
488 :     in
489 :     OS.Process.exit
490 :     (case buildargs of
491 :     [root, cmfile, heap, listfile, linkargsfile] =>
492 :     doit (NONE, root, cmfile, heap, listfile,
493 :     linkargsfile)
494 :     | [setup,
495 :     root, cmfile, heap, listfile, linkargsfile] =>
496 :     doit (SOME setup, root, cmfile, heap, listfile,
497 :     linkargsfile)
498 :     | _ => (Say.say ["bad arguments to @CMbuild\n"];
499 :     OS.Process.failure))
500 :     end
501 : blume 716
502 : blume 1058 fun al_ginfo () = { param = param false,
503 : blume 518 groupreg = al_greg,
504 : blume 692 errcons = EM.defaultConsumer (),
505 :     youngest = ref TStamp.ancient }
506 : blume 518
507 : mblume 1393 val al_managers =
508 :     AutoLoad.mkManagers { get_ginfo = al_ginfo,
509 :     dropPickles = dropPickles }
510 :    
511 : blume 375 fun reset () =
512 : blume 399 (Compile.reset ();
513 :     Link.reset ();
514 : blume 375 AutoLoad.reset ();
515 :     Parse.reset ();
516 : blume 588 SmlInfo.reset ();
517 : blume 1137 StabModmap.reset ())
518 : blume 375
519 : blume 905 fun initTheValues (bootdir, de, er, autoload_postprocess, icm) = let
520 :     (* icm: "install compilation manager" *)
521 : blume 375 val _ = let
522 :     fun listDir ds = let
523 :     fun loop l =
524 : blume 380 case F.readDir ds of
525 : mblume 1350 NONE => l
526 :     | SOME x => loop (x :: l)
527 : blume 375 in
528 :     loop []
529 :     end
530 :     val fileList = SafeIO.perform
531 : blume 380 { openIt = fn () => F.openDir bootdir,
532 :     closeIt = F.closeDir,
533 : blume 375 work = listDir,
534 : blume 459 cleanup = fn _ => () }
535 : blume 380 fun isDir x = F.isDir x handle _ => false
536 : blume 375 fun subDir x = let
537 : blume 380 val d = P.concat (bootdir, x)
538 : blume 375 in
539 :     if isDir d then SOME (x, d) else NONE
540 :     end
541 :     val pairList = List.mapPartial subDir fileList
542 : blume 666 fun sa (x, d) = SrcPath.set_anchor (penv, x, SOME d)
543 : blume 375 in
544 : blume 666 app sa pairList
545 : blume 375 end
546 : blume 569
547 :     val pidmapfile = P.concat (bootdir, BtNames.pidmap)
548 : mblume 1342
549 : blume 569 fun readpidmap s = let
550 :     fun loop m = let
551 :     fun enter (d, pids) = let
552 : blume 737 fun enter1 (spec, pm) = let
553 : blume 879 val fromHex = PersStamps.fromHex
554 : blume 737 in
555 :     case String.tokens (fn c => c = #":") spec of
556 :     [pos, hexp] =>
557 :     (case (fromHex hexp, Int.fromString pos) of
558 :     (SOME p, SOME i) =>
559 : blume 902 (case DE.look de p of
560 :     NONE => pm
561 :     | SOME obj =>
562 :     IM.insert (pm, i,
563 :     DE.singleton (p, obj)))
564 : blume 737 | _ => pm)
565 :     | _ => pm
566 :     end
567 : blume 569 in
568 : blume 666 SrcPathMap.insert (m, SrcPath.decode penv d,
569 : blume 737 foldl enter1 IM.empty pids)
570 : blume 569 end
571 :     in
572 :     case TextIO.inputLine s of
573 : mblume 1368 NONE => m
574 :     | SOME line =>
575 :     (case String.tokens Char.isSpace line of
576 :     d :: pids => loop (enter (d, pids))
577 :     | _ => loop m)
578 : blume 569 end
579 : blume 737 val m = loop SrcPathMap.empty
580 : blume 569 in
581 : blume 737 system_values := m
582 : blume 569 end
583 :    
584 :     val _ =
585 :     SafeIO.perform { openIt = fn () => TextIO.openIn pidmapfile,
586 :     closeIt = TextIO.closeIn,
587 :     work = readpidmap,
588 :     cleanup = fn _ => () }
589 :    
590 : blume 525 val initgspec = mkStdSrcPath BtNames.initgspec
591 : blume 537 val ginfo = { param = { fnpolicy = fnpolicy,
592 : blume 666 penv = penv,
593 : blume 433 symval = SSV.symval,
594 : blume 873 archos = my_archos,
595 : blume 1058 keep_going = false,
596 :     slave_mode = false },
597 : blume 375 groupreg = GroupReg.new (),
598 : blume 692 errcons = EM.defaultConsumer (),
599 :     youngest = ref TStamp.ancient }
600 : blume 537 fun loadInitGroup () =
601 : blume 666 Stabilize.loadStable
602 :     { getGroup = fn _ =>
603 :     raise Fail "CMBoot: initial getGroup",
604 :     anyerrors = ref false }
605 :     (ginfo, initgspec, NONE, [])
606 : blume 375 in
607 : blume 537 case loadInitGroup () of
608 :     NONE => raise Fail "CMBoot: unable to load init group"
609 :     | SOME init_group => let
610 :     val _ = Compile.reset ()
611 :     val _ = Link.reset ()
612 : blume 375
613 : blume 537 val { exports = ctm, ... } =
614 :     Compile.newTraversal (fn _ => fn _ => (),
615 :     fn _ => (),
616 :     init_group)
617 :     val { exports = ltm, ... } = Link.newTraversal
618 :     (init_group, fn _ => raise Fail "init: get bfc?")
619 :    
620 :     fun getSymTrav (tr_m, sy) =
621 :     case SymbolMap.find (tr_m, sy) of
622 :     NONE => raise Fail "init: bogus init group (1)"
623 :     | SOME tr => tr
624 :    
625 : blume 592 val perv_ct = getSymTrav (ctm, PervAccess.pervStrSym)
626 :     val perv_lt = getSymTrav (ltm, PervAccess.pervStrSym)
627 : blume 537
628 :     fun doTrav t =
629 :     case t ginfo of
630 :     SOME r => r
631 :     | NONE => raise Fail "init: bogus init group (2)"
632 :    
633 :     val { stat = pervstat, sym = pervsym } = doTrav perv_ct
634 :     val pervdyn = doTrav perv_lt
635 :    
636 :     val pervasive = E.mkenv { static = pervstat,
637 :     symbolic = pervsym,
638 :     dynamic = pervdyn }
639 :    
640 : blume 495 fun bare_autoload x =
641 :     (Say.say
642 :     ["!* ", x,
643 :     ": \"autoload\" not available, using \"make\"\n"];
644 :     make x)
645 :     val bare_preload =
646 :     Preload.preload { make = make,
647 :     autoload = bare_autoload }
648 :     val standard_preload =
649 :     Preload.preload { make = make, autoload = autoload }
650 : blume 375 in
651 : blume 592 #set ER.pervasive pervasive;
652 : blume 905 #set (ER.loc ()) E.emptyEnv;(* redundant? *)
653 : blume 592 theValues := SOME { init_group = init_group };
654 : blume 375 case er of
655 :     BARE =>
656 : blume 495 (bare_preload BtNames.bare_preloads;
657 : blume 569 system_values := SrcPathMap.empty;
658 : blume 495 NONE)
659 : blume 375 | AUTOLOAD =>
660 : mblume 1393 (icm al_managers;
661 : blume 905 standard_preload BtNames.standard_preloads;
662 : blume 507 (* unconditionally drop all library pickles *)
663 :     Parse.dropPickles ();
664 : blume 495 SOME (autoload_postprocess ()))
665 : blume 375 end
666 :     end
667 :     end
668 :     in
669 : mblume 1712 fun init (bootdir, de, er, useStream, useFile, errorwrap, icm) = let
670 : blume 495 fun procCmdLine () = let
671 : mblume 1712 val autoload = errorwrap (ignore o autoload)
672 :     val make = errorwrap (ignore o make)
673 : blume 905 fun p (f, mk, ("sml" | "sig" | "fun")) = useFile f
674 : blume 692 | p (f, mk, "cm") = mk f
675 :     | p (f, mk, e) = Say.say ["!* unable to process `", f,
676 : blume 495 "' (unknown extension `", e, "')\n"]
677 : blume 1201 fun inc n = n + 1
678 : blume 1126
679 : blume 1201 fun show_controls (getarg, getval, padval) level = let
680 :     fun walk indent (ControlRegistry.RTree rt) = let
681 :     open FormatComb
682 :     val { help, ctls, subregs, path } = rt
683 :    
684 : mblume 1629 fun one ci = let
685 : blume 1201 val arg = concat (foldr (fn (s, r) => s :: "." :: r)
686 : mblume 1629 [getarg ci] path)
687 :     val value = getval ci
688 : blume 1201 val sz = size value
689 :     val lw = !Control_Print.linewidth
690 :     val padsz = lw - 6 - size arg - indent
691 :     in
692 :     if padsz < sz then
693 :     let val padsz' = Int.max (lw, sz + 8 + indent)
694 :     in
695 :     format' Say.say (sp (indent + 6) o
696 :     text arg o nl o
697 :     padval padsz' (text value) o
698 :     nl)
699 :     end
700 :     else format' Say.say (sp (indent + 6) o
701 :     text arg o
702 :     padval padsz (text value) o
703 :     nl)
704 :     end
705 : blume 1126 in
706 : blume 1201 case (ctls, subregs) of
707 :     ([], []) => ()
708 :     | _ => (format' Say.say
709 :     (sp indent o text help o text ":" o nl);
710 :     app one ctls;
711 :     app (walk (indent + 1)) subregs)
712 : blume 1126 end
713 :     in
714 : blume 1201 walk 2 (ControlRegistry.controls
715 :     (BasicControl.topregistry, Option.map inc level))
716 : blume 1126 end
717 :    
718 :     fun help level =
719 :     (Say.say
720 :     ["sml [rtsargs] [options] [files]\n\
721 :     \\n\
722 :     \ rtsargs:\n\
723 :     \ @SMLload=<h> (start specified heap image)\n\
724 :     \ @SMLalloc=<s> (specify size of allocation area)\n\
725 :     \ @SMLcmdname=<n> (set command name)\n\
726 :     \ @SMLquiet (load heap image silently)\n\
727 :     \ @SMLverbose (show heap image load progress)\n\
728 :     \ @SMLobjects (show list of executable objects)\n\
729 :     \ @SMLdebug=<f> (write debugging info to file)\n\
730 :     \\n\
731 :     \ files:\n\
732 :     \ <file>.cm (CM.make or CM.autoload)\n\
733 :     \ -m (switch to CM.make)\n\
734 :     \ -a (switch to CM.autoload; default)\n\
735 :     \ <file>.sig (use)\n\
736 :     \ <file>.sml (use)\n\
737 :     \ <file>.fun (use)\n\
738 :     \\n\
739 :     \ options:\n\
740 :     \ -D<name>=<v> (set CM variable to given value)\n\
741 :     \ -D<name> (set CM variable to 1)\n\
742 :     \ -Uname (unset CM variable)\n\
743 :     \ -C<control>=<v> (set named control)\n\
744 :     \ -H (produce complete help listing)\n\
745 :     \ -h (produce minimal help listing)\n\
746 :     \ -h<level> (help with obscurity limit)\n\
747 :     \ -S (list all current settings)\n\
748 : mblume 1629 \ -s<level> (limited list of settings)\n\
749 :     \ -E (list all environment variables)\n\
750 :     \ -e<level> (limited list of environment variables)\n\n"];
751 :     show_controls (Controls.name o #ctl,
752 :     fn ci =>
753 :     concat ["(", #help (Controls.info (#ctl ci)),
754 :     ")"],
755 : blume 1201 FormatComb.pad FormatComb.left)
756 : blume 1126 level)
757 :    
758 : mblume 1629 fun showcur level =
759 :     show_controls (fn ci => (Controls.name (#ctl ci) ^ "="),
760 :     fn ci => Controls.get (#ctl ci),
761 : blume 1201 fn _ => fn ff => ff)
762 : blume 1126 level
763 :    
764 : mblume 1629 fun show_envvars level =
765 :     show_controls (fn ci => (Controls.name (#ctl ci) ^ ":"),
766 :     fn ci => Option.getOpt (#envName (#info ci),
767 :     "(none)"),
768 :     FormatComb.pad FormatComb.left)
769 :     level
770 :    
771 : blume 692 fun badopt opt f () =
772 : blume 1126 Say.say ["!* bad ", opt, " option: `", f, "'\n",
773 :     "!* try `-h' or `-h<level>' for help\n"]
774 : mblume 1595
775 :     fun quit () = OS.Process.exit OS.Process.success
776 :    
777 :     fun quit_if true = quit ()
778 :     | quit_if false = ()
779 :    
780 :     fun carg (opt as ("-C" | "-D"), f, _, _) =
781 : blume 1126 let val bad = badopt opt f
782 :     val spec = Substring.extract (f, 2, NONE)
783 :     val is_config = opt = "-C"
784 :     val (name, value) =
785 :     Substring.splitl (fn c => c <> #"=") spec
786 :     val name = Substring.string name
787 :     val value = Substring.string
788 :     (if Substring.size value > 0 then
789 :     Substring.slice (value, 1, NONE)
790 :     else value)
791 : blume 692 in
792 : blume 1126 if name = "" then bad ()
793 :     else if is_config then
794 : blume 1201 let val names = String.fields (fn c => c = #".") name
795 :     val look = ControlRegistry.control
796 :     BasicControl.topregistry
797 : blume 1126 in
798 : blume 1201 case look names of
799 :     NONE => Say.say ["!* no such control: ",
800 :     name, "\n"]
801 :     | SOME sctl =>
802 :     (Controls.set (sctl, value)
803 :     handle Controls.ValueSyntax vse =>
804 :     Say.say ["!* unable to parse value `",
805 :     #value vse, "' for ",
806 :     #ctlName vse, " : ",
807 :     #tyName vse, "\n"])
808 :     end
809 : blume 1126 else if value = "" then #set (SSV.symval name) (SOME 1)
810 :     else (case Int.fromString value of
811 :     SOME i => #set (SSV.symval name) (SOME i)
812 :     | NONE => bad ())
813 : blume 692 end
814 : mblume 1595 | carg ("-U", f, _, _) =
815 :     (case String.extract (f, 2, NONE) of
816 :     "" => badopt "-U" f ()
817 :     | var => #set (SSV.symval var) NONE)
818 :     | carg ("-h", f, _, last) =
819 :     (case String.extract (f, 2, NONE) of
820 :     "" => help (SOME 0)
821 :     | level => help (Int.fromString level);
822 :     quit_if last)
823 :     | carg ("-s", f, _, last) =
824 :     (case String.extract (f, 2, NONE) of
825 :     "" => showcur (SOME 0)
826 :     | level => showcur (Int.fromString level);
827 :     quit_if last)
828 : mblume 1629 | carg ("-e", f, _, last) =
829 :     (case String.extract (f, 2, NONE) of
830 :     "" => show_envvars (SOME 0)
831 :     | level => show_envvars (Int.fromString level);
832 :     quit_if last)
833 : mblume 1595 | carg (_, f, mk, _) =
834 :     p (f, mk, String.map Char.toLower
835 :     (getOpt (OS.Path.ext f, "<none>")))
836 : blume 716
837 :     fun args ("-a" :: rest, _) = args (rest, autoload)
838 :     | args ("-m" :: rest, _) = args (rest, make)
839 : mblume 1595 | args ("-H" :: rest, mk) = (help NONE; args_q (rest, mk))
840 :     | args ("-S" :: rest, mk) = (showcur NONE; args_q (rest, mk))
841 : mblume 1629 | args ("-E" :: rest, mk) = (show_envvars NONE; args_q (rest, mk))
842 : mblume 1595 | args ("-q" :: _, _) = quit ()
843 : blume 716 | args ("@CMbuild" :: rest, _) = mlbuild rest
844 :     | args (f :: rest, mk) =
845 : mblume 1595 (carg (String.substring (f, 0, 2)
846 :     handle General.Subscript => "",
847 :     f, mk, List.null rest);
848 : blume 716 args (rest, mk))
849 :     | args ([], _) = ()
850 : mblume 1595
851 :     and args_q ([], _) = quit ()
852 :     | args_q (rest, f) = args (rest, f)
853 : blume 495 in
854 :     case SMLofNJ.getArgs () of
855 :     ["@CMslave"] => (#set StdConfig.verbose false; slave ())
856 : blume 716 | l => args (l, autoload)
857 : blume 495 end
858 : blume 448 in
859 : blume 905 useStreamHook := useStream;
860 : blume 569 initTheValues (bootdir, de, er,
861 :     fn () => (Cleanup.install initPaths;
862 : blume 905 procCmdLine),
863 :     icm)
864 : blume 448 end
865 : blume 479
866 : blume 734 structure CM = struct
867 : blume 479 type 'a controller = { get : unit -> 'a, set : 'a -> unit }
868 :    
869 :     structure Anchor = struct
870 : blume 569 fun anchor a = { get = getAnchor a, set = setAnchor a }
871 : blume 479 val reset = resetPathConfig
872 :     end
873 :    
874 :     structure Control = struct
875 :     val keep_going = StdConfig.keep_going
876 :     val verbose = StdConfig.verbose
877 :     val parse_caching = StdConfig.parse_caching
878 :     val warn_obsolete = StdConfig.warn_obsolete
879 :     val debug = StdConfig.debug
880 : blume 505 val conserve_memory = StdConfig.conserve_memory
881 : blume 838 val generate_index = StdConfig.generate_index
882 : blume 479 end
883 :    
884 :     structure Library = struct
885 : blume 666 type lib = SrcPath.file
886 : blume 479 val known = Parse.listLibs
887 :     val descr = SrcPath.descr
888 :     val osstring = SrcPath.osstring
889 :     val dismiss = Parse.dismissLib
890 : blume 632 fun unshare lib = (Link.unshare lib; dismiss lib)
891 : blume 479 end
892 :    
893 :     structure State = struct
894 :     val synchronize = SrcPath.sync
895 :     val reset = reset
896 :     val pending = getPending
897 : blume 1068 val showBindings = showBindings
898 : blume 479 end
899 :    
900 :     structure Server = struct
901 : blume 735 type server = Servers.server_handle
902 : blume 666 fun start x = Servers.start x
903 :     before SrcPath.scheduleNotification ()
904 : blume 479 val stop = Servers.stop
905 :     val kill = Servers.kill
906 :     val name = Servers.name
907 :     end
908 :    
909 :     val autoload = autoload
910 :     val make = make
911 :     val recomp = recomp
912 :     val stabilize = stabilize
913 :    
914 : blume 642 val sources = sources
915 : blume 632
916 : blume 479 val symval = SSV.symval
917 : blume 578 val load_plugin = cwd_load_plugin
918 : blume 537 val mk_standalone = mk_standalone
919 : blume 975
920 :     structure Graph = struct
921 :     val graph = to_portable
922 :     end
923 : mblume 1385
924 :     val cm_dir_arc = FilenamePolicy.cm_dir_arc
925 : blume 479 end
926 : blume 525
927 : blume 756 structure Tools = ToolsFn (val load_plugin' = load_plugin'
928 : blume 666 val penv = penv)
929 : blume 578
930 :     val load_plugin = load_plugin
931 : blume 375 end
932 :     end

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