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/bootstrap/btcompile.sml
ViewVC logotype

Annotation of /sml/trunk/src/cm/bootstrap/btcompile.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 759 - (view) (download)

1 : blume 327 (*
2 :     * The bootstrap compiler.
3 :     * (Formerly known as "batch" compiler.)
4 :     *
5 :     * (C) 1999 Lucent Technologies, Bell Laboratories
6 :     *
7 :     * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
8 :     *)
9 : blume 569 local
10 :     structure EM = GenericVC.ErrorMsg
11 :     structure E = GenericVC.Environment
12 : blume 587 structure SE = GenericVC.StaticEnv
13 : blume 569 structure PS = GenericVC.PersStamps
14 :     structure GG = GroupGraph
15 :     structure DG = DependencyGraph
16 :     in
17 : blume 578 functor BootstrapCompileFn
18 :     (structure MachDepVC : MACHDEP_VC
19 : blume 677 val useStream : TextIO.instream -> unit
20 : blume 578 val os : SMLofNJ.SysInfo.os_kind
21 : blume 734 val load_plugin : SrcPath.dir -> string -> bool) =
22 :     struct
23 : blume 336 structure SSV = SpecificSymValFn (structure MachDepVC = MachDepVC
24 :     val os = os)
25 : blume 364 structure P = OS.Path
26 :     structure F = OS.FileSys
27 : blume 403 structure BF = MachDepVC.Binfile
28 : blume 327
29 : blume 452 val arch = MachDepVC.architecture
30 :     val osname = FilenamePolicy.kind2name os
31 : blume 642
32 : blume 452 val archos = concat [arch, "-", osname]
33 :    
34 : blume 569 fun init_servers (GG.GROUP { grouppath, ... }) =
35 : blume 464 Servers.cmb { archos = archos,
36 : blume 666 root = SrcPath.encode grouppath }
37 : blume 587 | init_servers GG.ERRORGROUP = ()
38 : blume 456
39 : blume 588 structure StabModmap = StabModmapFn ()
40 :    
41 : blume 448 structure Compile = CompileFn (structure MachDepVC = MachDepVC
42 : blume 588 structure StabModmap = StabModmap
43 : blume 677 val useStream = useStream
44 : blume 464 val compile_there =
45 : blume 666 Servers.compile o SrcPath.encode)
46 : blume 360
47 : blume 403 structure BFC = BfcFn (structure MachDepVC = MachDepVC)
48 :    
49 : blume 327 (* instantiate Stabilize... *)
50 : blume 329 structure Stabilize =
51 : blume 537 StabilizeFn (structure MachDepVC = MachDepVC
52 : blume 588 structure StabModmap = StabModmap
53 : blume 399 fun recomp gp g = let
54 : blume 403 val { store, get } = BFC.new ()
55 : blume 456 val _ = init_servers g
56 : blume 399 val { group, ... } =
57 : blume 403 Compile.newTraversal (fn _ => fn _ => (),
58 :     store, g)
59 : blume 399 in
60 : blume 450 case Servers.withServers (fn () => group gp) of
61 : blume 403 NONE => NONE
62 :     | SOME _ => SOME get
63 :     end
64 :     val getII = Compile.getII)
65 : blume 398
66 : blume 569 structure VerifyStable = VerStabFn (structure Stabilize = Stabilize)
67 :    
68 : blume 327 (* ... and Parse *)
69 : blume 362 structure Parse = ParseFn (structure Stabilize = Stabilize
70 : blume 588 structure StabModmap = StabModmap
71 : blume 537 val evictStale = Compile.evictStale
72 : blume 372 fun pending () = SymbolMap.empty)
73 : blume 327
74 : blume 537 fun mkBootList g = let
75 :     fun listName p =
76 :     case P.fromString p of
77 :     { vol = "", isAbs = false, arcs = _ :: arc1 :: arcn } => let
78 :     fun win32name () =
79 :     concat (arc1 ::
80 :     foldr (fn (a, r) => "\\" :: a :: r) [] arcn)
81 :     in
82 :     case os of
83 :     SMLofNJ.SysInfo.WIN32 => win32name ()
84 :     | _ => P.toString { isAbs = false, vol = "",
85 :     arcs = arc1 :: arcn }
86 :     end
87 :     | _ => raise Fail ("BootstrapCompile:listName: bad name: " ^ p)
88 : blume 364 in
89 : blume 537 MkBootList.group listName g
90 : blume 364 end
91 : blume 327
92 : blume 588 local
93 :     fun internal_reset () =
94 :     (Compile.reset ();
95 :     Parse.reset ();
96 :     StabModmap.reset ())
97 :     in
98 :     fun reset () =
99 :     (Say.vsay ["[CMB reset]\n"];
100 :     internal_reset ())
101 :     val checkDirbase = let
102 :     val prev = ref NONE
103 :     fun ck db =
104 :     (case !prev of
105 :     NONE => prev := SOME db
106 :     | SOME db' =>
107 :     if db = db' then ()
108 :     else (Say.vsay ["[new dirbase is `", db,
109 :     "'; CMB reset]\n"];
110 :     internal_reset ();
111 :     prev := SOME db))
112 :     in
113 :     ck
114 :     end
115 :     end
116 :    
117 : blume 569 fun mk_compile { deliver, root, dirbase = dbopt, paranoid } = let
118 : blume 358
119 : blume 360 val dirbase = getOpt (dbopt, BtNames.dirbaseDefault)
120 : blume 588 val _ = checkDirbase dirbase
121 : blume 666 val penvspec = BtNames.penvspec
122 : blume 360 val initgspec = BtNames.initgspec
123 :     val maingspec = BtNames.maingspec
124 :    
125 : blume 537 val bindir = concat [dirbase, BtNames.bin_infix, archos]
126 :     val bootdir = concat [dirbase, BtNames.boot_infix, archos]
127 : blume 357
128 : blume 433 val keep_going = #get StdConfig.keep_going ()
129 : blume 329
130 : blume 666 val ctxt = SrcPath.cwd ()
131 : blume 329
132 : blume 537 val listfile = P.joinDirFile { dir = bootdir, file = BtNames.bootlist }
133 :     val pidmapfile = P.joinDirFile { dir = bootdir, file = BtNames.pidmap }
134 : blume 329
135 : blume 666 val penv = SrcPath.newEnv ()
136 : blume 735 val _ = SafeIO.perform { openIt = fn () => TextIO.openIn penvspec,
137 :     closeIt = TextIO.closeIn,
138 :     work = SrcPath.processSpecFile
139 :     { env = penv, specfile = penvspec,
140 :     say = Say.say },
141 :     cleanup = fn _ => () }
142 : blume 676 val _ = SrcPath.sync ()
143 : blume 329
144 : blume 666 fun stdpath s =
145 :     SrcPath.file (SrcPath.standard
146 :     { err = fn s => raise Fail s, env = penv }
147 :     { context = ctxt, spec = s })
148 : blume 352
149 :     val initgspec = stdpath initgspec
150 : blume 456 val maingspec =
151 :     case root of
152 :     NONE => stdpath maingspec
153 : blume 666 | SOME r => SrcPath.decode penv r
154 : blume 352
155 : blume 364 val fnpolicy =
156 : blume 357 FilenamePolicy.separate { bindir = bindir, bootdir = bootdir }
157 :     { arch = arch, os = os }
158 :    
159 : blume 592 val param =
160 : blume 537 { fnpolicy = fnpolicy,
161 : blume 666 penv = penv,
162 : blume 433 symval = SSV.symval,
163 : blume 592 keep_going = keep_going }
164 : blume 349
165 : blume 327 val emptydyn = E.dynamicPart E.emptyEnv
166 :    
167 :     (* first, build an initial GeneralParam.info, so we can
168 :     * deal with the pervasive env and friends... *)
169 :    
170 :     val groupreg = GroupReg.new ()
171 :     val errcons = EM.defaultConsumer ()
172 : blume 692 val ginfo = { param = param, groupreg = groupreg,
173 :     errcons = errcons,
174 :     youngest = ref TStamp.ancient }
175 : blume 327
176 : blume 449 fun mk_main_compile arg = let
177 : blume 450
178 : blume 592 val { pervasive = perv_n, others, src } = arg
179 : blume 327
180 : blume 569 fun recompInitGroup () = let
181 :     val ovldR = GenericVC.Control.overloadKW
182 :     val savedOvld = !ovldR
183 :     val _ = ovldR := true
184 :     val sbnode = Compile.newSbnodeTraversal ()
185 : blume 329
186 : blume 569 val perv_fsbnode = (NONE, perv_n)
187 : blume 327
188 : blume 569 fun rt n = valOf (sbnode ginfo n)
189 :     val pervasive = rt perv_n
190 : blume 537
191 : blume 569 fun rt2ie (n, ii: IInfo.info) = let
192 : blume 587 val s = #statenv ii ()
193 :     val (dae, mkDomain) = Statenv2DAEnv.cvt s
194 : blume 652 val domain = mkDomain ()
195 : blume 569 in
196 : blume 652 { ie = (fn () => (NONE, n), dae, domain), domain = domain }
197 : blume 569 end
198 : blume 537
199 : blume 569 fun add_exports (n, exports) = let
200 : blume 652 val { ie, domain } = rt2ie (n, rt n)
201 : blume 569 fun ins_ie (sy, m) = SymbolMap.insert (m, sy, ie)
202 :     in
203 : blume 652 SymbolSet.foldl ins_ie exports domain
204 : blume 569 end
205 :    
206 :     val special_exports = let
207 :     fun mkie (n, rtn) = #ie (rt2ie (n, rtn))
208 :     in
209 : blume 592 SymbolMap.insert (SymbolMap.empty,
210 :     PervAccess.pervStrSym,
211 :     mkie (perv_n, pervasive))
212 : blume 569 end
213 : blume 537 in
214 : blume 592 GG.GROUP { exports = foldl add_exports special_exports others,
215 : blume 632 kind = GG.LIB {
216 :     kind = GG.DEVELOPED { wrapped = StringSet.empty,
217 : blume 592 subgroups = [] },
218 : blume 632 version = NONE },
219 : blume 592 required = StringSet.singleton "primitive",
220 :     grouppath = initgspec,
221 : blume 642 (* hack: sources never used for this group *)
222 :     sources = SrcPathMap.empty,
223 : blume 592 sublibs = [] }
224 : blume 569 before (ovldR := savedOvld)
225 : blume 537 end
226 : blume 327
227 : blume 569 (* just go and load the stable init group or signal failure *)
228 :     fun loadInitGroup () = let
229 :     val lsarg =
230 :     { getGroup = fn _ => raise Fail "CMB: initial getGroup",
231 :     anyerrors = ref false }
232 : blume 537 in
233 : blume 666 case Stabilize.loadStable lsarg (ginfo, initgspec, NONE, []) of
234 : blume 569 NONE => NONE
235 : blume 592 | SOME (g as GG.GROUP { exports, ... }) => SOME g
236 : blume 587 | SOME GG.ERRORGROUP => NONE
237 : blume 537 end
238 : blume 569
239 :     (* Don't try to load the stable init group. Instead, recompile
240 :     * directly. *)
241 :     fun dontLoadInitGroup () = let
242 : blume 592 val g0 = recompInitGroup ()
243 : blume 759 val stabarg = { group = g0, anyerrors = ref false,
244 :     rebindings = [] }
245 : blume 569 in
246 :     if deliver then
247 : blume 592 case Stabilize.stabilize ginfo stabarg of
248 :     SOME g => g
249 : blume 569 | NONE => raise Fail "CMB: cannot stabilize init group"
250 : blume 592 else g0
251 : blume 569 end
252 : blume 327
253 : blume 569 (* Try loading the init group from the stable file if possible;
254 :     * recompile if loading fails *)
255 :     fun tryLoadInitGroup () =
256 :     case loadInitGroup () of
257 :     SOME g => g
258 :     | NONE => dontLoadInitGroup ()
259 :    
260 :     (* Ok, now, based on "paranoid" and stable verification,
261 :     * call the appropriate function(s) to get the init group. *)
262 : blume 592 val init_group =
263 : blume 569 if paranoid then let
264 : blume 592 val export_nodes = perv_n :: others
265 : blume 569 val ver_arg = (initgspec, export_nodes, [],
266 : blume 632 SrcPathSet.empty, NONE)
267 : blume 569 val em = StableMap.empty
268 : blume 537 in
269 : blume 592 if VerifyStable.verify' ginfo em ver_arg then
270 : blume 569 tryLoadInitGroup ()
271 :     else dontLoadInitGroup ()
272 : blume 537 end
273 : blume 569 else tryLoadInitGroup ()
274 : blume 356
275 : blume 569
276 :     val stab = if deliver then SOME true else NONE
277 :    
278 : blume 537 val gr = GroupReg.new ()
279 :     val _ = GroupReg.register gr (initgspec, src)
280 :    
281 :     val parse_arg =
282 :     { load_plugin = load_plugin,
283 :     gr = gr,
284 :     param = param,
285 :     stabflag = stab,
286 :     group = maingspec,
287 :     init_group = init_group,
288 : blume 569 paranoid = paranoid }
289 : blume 327 in
290 : blume 456 Servers.dirbase dirbase;
291 : blume 632 Servers.cmb_new { archos = archos };
292 : blume 537 case Parse.parse parse_arg of
293 : blume 449 NONE => NONE
294 : blume 399 | SOME (g, gp) => let
295 : blume 449 fun thunk () = let
296 : blume 456 val _ = init_servers g
297 : blume 449 fun store _ = ()
298 :     val { group = recomp, ... } =
299 :     Compile.newTraversal (fn _ => fn _ => (), store, g)
300 : blume 450 val res =
301 :     Servers.withServers (fn () => recomp gp)
302 : blume 449 in
303 : blume 450 if isSome res then let
304 : blume 537 val { l = bootitems, ss } = mkBootList g
305 :     val stablelibs = Reachable.stableLibsOf g
306 :     fun inSet bi = StableSet.member (ss, bi)
307 :     val frontiers =
308 :     SrcPathMap.map (Reachable.frontier inSet)
309 :     stablelibs
310 :     fun writeBootList s = let
311 :     fun wr str = TextIO.output (s, str ^ "\n")
312 : blume 569 val numitems = length bootitems
313 :     fun biggerlen (s, n) = Int.max (size s, n)
314 :     val maxlen = foldl biggerlen 0 bootitems
315 : blume 364 in
316 : blume 569 wr (concat ["%", Int.toString numitems,
317 :     " ", Int.toString maxlen]);
318 : blume 537 app wr bootitems
319 : blume 364 end
320 : blume 537 fun writePid s i = let
321 :     val sn = BinInfo.stablename i
322 :     val os = BinInfo.offset i
323 :     val descr = BinInfo.describe i
324 :     val bfc = BFC.getStable
325 :     { stable = sn, offset = os, descr = descr }
326 :     in
327 :     case BF.exportPidOf bfc of
328 :     NONE => ()
329 :     | SOME pid =>
330 : blume 737 app (fn str => TextIO.output (s, str))
331 :     [" ", Int.toString os,
332 :     ":", PS.toHex pid]
333 : blume 537 end
334 :     fun writePidLine s (p, set) =
335 :     if StableSet.isEmpty set then ()
336 : blume 666 else (TextIO.output (s, SrcPath.encode p);
337 : blume 537 StableSet.app (writePid s) set;
338 :     TextIO.output (s, "\n"))
339 :     fun writePidMap s =
340 :     SrcPathMap.appi (writePidLine s) frontiers
341 : blume 349 in
342 : blume 449 if deliver then
343 :     (SafeIO.perform
344 :     { openIt = fn () =>
345 : blume 537 AutoDir.openTextOut listfile,
346 : blume 449 closeIt = TextIO.closeOut,
347 : blume 537 work = writeBootList,
348 : blume 459 cleanup = fn _ =>
349 : blume 537 OS.FileSys.remove listfile
350 : blume 449 handle _ => () };
351 :     SafeIO.perform
352 :     { openIt = fn () =>
353 : blume 537 AutoDir.openTextOut pidmapfile,
354 : blume 449 closeIt = TextIO.closeOut,
355 : blume 537 work = writePidMap,
356 : blume 459 cleanup = fn _ =>
357 : blume 537 OS.FileSys.remove pidmapfile
358 : blume 449 handle _ => () };
359 : blume 537 Say.say
360 :     ["New boot directory has been built.\n"])
361 : blume 449 else ();
362 :     true
363 : blume 349 end
364 : blume 449 else false
365 : blume 349 end
366 : blume 449 in
367 : blume 666 SOME ((g, gp, penv), thunk)
368 : blume 399 end
369 : blume 449 end handle Option => (Compile.reset (); NONE)
370 : blume 330 (* to catch valOf failures in "rt" *)
371 : blume 327 in
372 : blume 592 case BuildInitDG.build ginfo initgspec of
373 : blume 449 SOME x => mk_main_compile x
374 :     | NONE => NONE
375 : blume 327 end
376 : blume 362
377 : blume 569 fun compile dbopt =
378 : blume 632 (StabModmap.reset ();
379 :     case mk_compile { deliver = true, root = NONE,
380 :     dirbase = dbopt, paranoid = true } of
381 :     NONE => false
382 :     | SOME (_, thunk) => thunk ())
383 : blume 449
384 :     local
385 : blume 632 fun slave NONE = (StabModmap.reset (); NONE)
386 :     | slave (SOME (dirbase, root)) =
387 : blume 569 case mk_compile { deliver = false, root = SOME root,
388 :     dirbase = SOME dirbase, paranoid = false } of
389 : blume 449 NONE => NONE
390 : blume 666 | SOME ((g, gp, penv), _) => let
391 : blume 449 val trav = Compile.newSbnodeTraversal () gp
392 :     fun trav' sbn = isSome (trav sbn)
393 :     in
394 : blume 666 SOME (g, trav', penv)
395 : blume 449 end
396 :     in
397 : blume 452 val _ = CMBSlaveHook.init archos slave
398 : blume 449 end
399 :    
400 : blume 569 val make' = compile
401 : blume 377 fun make () = make' NONE
402 : blume 434 val symval = SSV.symval
403 : blume 327 end
404 : blume 569 end (* local *)

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