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

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