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/stable/stabilize.sml
ViewVC logotype

Annotation of /sml/trunk/src/cm/stable/stabilize.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1137 - (view) (download)

1 : blume 309 (*
2 : blume 588 * Reading, generating, and writing stable libraries.
3 : blume 309 *
4 :     * (C) 1999 Lucent Technologies, Bell Laboratories
5 :     *
6 :     * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
7 :     *)
8 :     local
9 : blume 304 structure DG = DependencyGraph
10 : blume 306 structure GG = GroupGraph
11 : blume 879 structure EM = ErrorMsg
12 : blume 311 structure PP = PrettyPrint
13 : blume 879 structure SM = SourceMap
14 : blume 309 structure GP = GeneralParams
15 : blume 879 structure Pid = PersStamps
16 : blume 398 structure P = PickMod
17 :     structure UP = UnpickMod
18 : blume 879 structure MI = ModuleId
19 : blume 309 in
20 : blume 304
21 : blume 309 signature STABILIZE = sig
22 :    
23 : blume 632 val libStampIsValid : GP.info
24 : blume 666 -> (SrcPath.file * DG.sbnode list * GG.subgrouplist) * Version.t option
25 : blume 632 -> bool
26 : blume 569
27 : blume 666 type groupgetter =
28 :     GP.info * SrcPath.file * Version.t option * SrcPath.rebindings ->
29 :     GG.group option
30 : blume 632
31 : blume 309 val loadStable :
32 : blume 666 { getGroup: groupgetter, anyerrors: bool ref } -> groupgetter
33 : blume 309
34 : blume 759 val stabilize : GP.info -> { group: GG.group, anyerrors: bool ref,
35 :     rebindings: SrcPath.rebindings } ->
36 :     GG.group option
37 : blume 309 end
38 :    
39 : blume 879 functor StabilizeFn (val arch : string
40 : blume 588 structure StabModmap : STAB_MODMAP
41 : blume 403 val recomp : GP.info -> GG.group ->
42 : blume 771 (SmlInfo.info ->
43 : blume 879 { contents: Binfile.bfContents,
44 :     stats: Binfile.stats }) option
45 : blume 403 val getII : SmlInfo.info -> IInfo.info) :> STABILIZE =
46 :     struct
47 : blume 666 type groupgetter =
48 :     GP.info * SrcPath.file * Version.t option * SrcPath.rebindings ->
49 :     GG.group option
50 : blume 632
51 : blume 879 structure BF = Binfile
52 : blume 403
53 : blume 447 structure SSMap = MapFn
54 : blume 385 (struct
55 :     type ord_key = SymbolSet.set
56 :     val compare = SymbolSet.compare
57 :     end)
58 :    
59 : blume 398 structure PU = PickleUtil
60 :     structure UU = UnpickleUtil
61 : blume 384
62 : blume 569 val libstamp_nbytes = 16
63 :    
64 : blume 653 type map = { ss: PU.id SSMap.map, sn: PU.id SmlInfoMap.map, pm: P.map }
65 : blume 393
66 : blume 653 val emptyMap : map =
67 :     { ss = SSMap.empty, sn = SmlInfoMap.empty, pm = P.emptyMap }
68 : blume 393
69 : blume 398 val lifter =
70 :     { extract = fn (m: map) => #pm m,
71 :     patchback = fn (m: map, pm) => { ss = #ss m, sn = #sn m, pm = pm } }
72 :    
73 : blume 393 infix 3 $
74 :    
75 :     (* type info *)
76 : blume 513 val (BN, SN, SBN, SS, SI, FSBN, IMPEXP, SHM, G, AP,
77 : blume 666 PRIM, EXPORTS, PRIV, VERSION, SG, RB) =
78 : blume 513 (1001, 1002, 1003, 1004, 1005, 1006, 1007, 1008, 1009, 1010,
79 : blume 666 1011, 1012, 1013, 1014, 1015, 1016)
80 : blume 393
81 : blume 398 val SSs =
82 :     { find = fn (m: map, k) => SSMap.find (#ss m, k),
83 :     insert = fn ({ ss, sn, pm }, k, v) =>
84 :     { sn = sn, ss = SSMap.insert (ss, k, v), pm = pm } }
85 : blume 653 val SNs =
86 :     { find = fn (m: map, DG.SNODE k) => SmlInfoMap.find (#sn m,#smlinfo k),
87 :     insert = fn ({ ss, sn, pm }, DG.SNODE k, v) =>
88 :     { ss = ss,
89 :     sn = SmlInfoMap.insert (sn, #smlinfo k, v),
90 :     pm = pm } }
91 : blume 385
92 : blume 505 fun fetch_pickle s = let
93 :     fun bytesIn n = let
94 :     val bv = BinIO.inputN (s, n)
95 :     in
96 :     if n = Word8Vector.length bv then bv
97 :     else raise UU.Format
98 :     end
99 :    
100 : blume 569 val libstamp = bytesIn libstamp_nbytes (* ignored *)
101 : blume 505 val dg_sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))
102 :     val dg_pickle = Byte.bytesToString (bytesIn dg_sz)
103 :     in
104 :     { size = dg_sz, pickle = dg_pickle }
105 :     end
106 :    
107 :     fun mkPickleFetcher mksname () =
108 :     SafeIO.perform { openIt = BinIO.openIn o mksname,
109 :     closeIt = BinIO.closeIn,
110 :     work = #pickle o fetch_pickle,
111 :     cleanup = fn _ => () }
112 :    
113 : blume 569 fun mkInverseMap sublibs = let
114 : blume 632 (* Here we build a mapping that maps each BNODE to the
115 :     * position of its exporting sub-library and a representative
116 :     * symbol that can be used to find the BNODE within the
117 :     * exports of that library. *)
118 : blume 652 fun oneB i (sy, (nth, _, _), m) =
119 :     case nth () of
120 : blume 737 (_, DG.SB_BNODE (DG.BNODE n, _, _)) =>
121 : blume 733 (* we blindly override existing info for the same bnode;
122 :     * this means that the last guy wins... *)
123 : blume 652 StableMap.insert (m, #bininfo n, (i, sy))
124 :     | _ => m
125 : blume 733 (* ... but we want the first guy to win, so we do foldr
126 :     * and count from the top. *)
127 : blume 652 fun oneSL (g as GG.GROUP { exports, ... }, (m, i)) =
128 : blume 733 (SymbolMap.foldli (oneB i) m exports, i - 1)
129 :     | oneSL (_, (m, i)) = (m, i - 1)
130 : blume 666 fun oneSL' ((_, gth, _), a) = oneSL (gth (), a)
131 : blume 733 val (im, _) =
132 :     foldr oneSL' (StableMap.empty, length sublibs - 1) sublibs
133 : blume 569 fun look i =
134 :     case StableMap.find (im, i) of
135 :     SOME p => p
136 :     | NONE => EM.impossible "stabilize: bad inverse map"
137 :     in
138 :     look
139 :     end
140 :    
141 :     (* A stamp for a library is created by "pickling" the dependency graph
142 :     * of the library in a cursory fashion, thereby recording the ii pids
143 :     * of external references. The so-created pickle string is never used
144 :     * for unpickling. Instead, it is hashed and recorded as part of
145 :     * the regular library file. In paranoia mode CM checks if the recorded
146 :     * hash is identical to the one that _would_ be created if one were
147 :     * to re-build the library now. *)
148 :     fun libStampOf (grouppath, export_nodes, sublibs) = let
149 : blume 805 fun sbn_cmp (DG.SB_BNODE (DG.BNODE n, _, _),
150 :     DG.SB_BNODE (DG.BNODE n', _, _)) =
151 :     BinInfo.compare (#bininfo n, #bininfo n')
152 :     | sbn_cmp (DG.SB_BNODE _, DG.SB_SNODE _) = GREATER
153 :     | sbn_cmp (DG.SB_SNODE _, DG.SB_BNODE _) = LESS
154 :     | sbn_cmp (DG.SB_SNODE (DG.SNODE n), DG.SB_SNODE (DG.SNODE n')) =
155 :     SmlInfo.compare (#smlinfo n, #smlinfo n')
156 :    
157 :     (* To deal with the init group (where export nodes come in
158 :     * in an ad-hoc order not derived from the export map),
159 :     * we first sort the list of export nodes, thereby getting rid
160 :     * of duplicates. This should normally canonicalize the list.
161 :     * However, the resulting order is unfortunately not persistent.
162 :     * Most of the time this should not matter, though. *)
163 :     val export_nodes = ListMergeSort.uniqueSort sbn_cmp export_nodes
164 :    
165 : blume 569 val inverseMap = mkInverseMap sublibs
166 :    
167 :     val pid = PickleSymPid.w_pid
168 :     val share = PU.ah_share
169 :     val symbol = PickleSymPid.w_symbol
170 :     val string = PU.w_string
171 :     val list = PU.w_list
172 : blume 632 val int = PU.w_int
173 : blume 569
174 :     fun abspath p = let
175 :     val op $ = PU.$ AP
176 : blume 666 val l = SrcPath.pickle { warn = fn _ => () }
177 :     { file = SrcPath.pre p, relativeTo = grouppath }
178 : blume 569 in
179 :     "p" $ [list string l]
180 :     end
181 :    
182 :     fun sn n = let
183 :     val op $ = PU.$ SN
184 :     fun raw_sn (DG.SNODE n) =
185 :     "a" $ [list sn (#localimports n), list fsbn (#globalimports n)]
186 :     in
187 :     share SNs raw_sn n
188 :     end
189 :    
190 :     and sbn x = let
191 :     val op $ = PU.$ SBN
192 :     in
193 :     case x of
194 : blume 737 DG.SB_BNODE (DG.BNODE { bininfo = i, ... }, ii, _) => let
195 : blume 632 val (i, sy) = inverseMap i
196 : blume 569 val { statpid, sympid, ... } = ii
197 :     in
198 : blume 632 "2" $ [int i, pid statpid, pid sympid]
199 : blume 569 end
200 :     | DG.SB_SNODE n => "3" $ [sn n]
201 :     end
202 :    
203 :     and fsbn (_, n) = let val op $ = PU.$ FSBN in "f" $ [sbn n] end
204 :    
205 :     fun group () = let
206 :     val op $ = PU.$ G
207 :     in "g" $ [list sbn export_nodes]
208 :     end
209 :     in
210 :     P.pickle2hash (Byte.stringToBytes (PU.pickle emptyMap (group ())))
211 :     end
212 :    
213 :     (* Comparison of old and new library stamps. *)
214 : blume 632 fun libStampIsValid (gp: GP.info) (a as (grouppath, _, _), version) = let
215 : blume 569 val newStamp = Byte.bytesToString (Pid.toBytes (libStampOf a))
216 :     val policy = #fnpolicy (#param gp)
217 : blume 632 val sname = FilenamePolicy.mkStableName policy (grouppath, version)
218 : blume 569 fun work s = let
219 :     val oldStamp =
220 :     Byte.bytesToString (BinIO.inputN (s, libstamp_nbytes))
221 :     in
222 :     oldStamp = newStamp
223 :     end
224 :     in
225 :     SafeIO.perform { openIt = fn () => BinIO.openIn sname,
226 :     closeIt = BinIO.closeIn,
227 :     work = work,
228 :     cleanup = fn _ => () }
229 :     handle _ => false
230 :     end
231 :    
232 : blume 666 fun loadStable { getGroup, anyerrors } (gp, group, version, rebinds) = let
233 : blume 537
234 : blume 666 val gp = GeneralParams.bind gp rebinds
235 :    
236 : blume 537 val errcons = #errcons (gp: GeneralParams.info)
237 :     val grpSrcInfo = (errcons, anyerrors)
238 :     val gdescr = SrcPath.descr group
239 :     fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion
240 :     EM.COMPLAIN (concat ("(stable) " :: gdescr :: ": " :: l))
241 :     EM.nullErrorBody
242 :    
243 :     exception Format = UU.Format
244 :    
245 : blume 666 val penv = #penv (#param gp)
246 : blume 537 val policy = #fnpolicy (#param gp)
247 :    
248 : blume 632 fun mksname () = FilenamePolicy.mkStableName policy (group, version)
249 : blume 537
250 :     fun work s = let
251 :    
252 : blume 666 fun getGroup' (gp, p, vo, rb) =
253 :     case getGroup (gp, p, vo, rb) of
254 : blume 537 SOME g => g
255 :     | NONE => (error ["unable to find ", SrcPath.descr p];
256 :     raise Format)
257 :    
258 :     val { size = dg_sz, pickle = dg_pickle } = fetch_pickle s
259 : blume 569 val offset_adjustment = dg_sz + 4 + libstamp_nbytes
260 : blume 537 val { getter, dropper } =
261 :     UU.stringGetter' (SOME dg_pickle, mkPickleFetcher mksname)
262 :     val session = UU.mkSession getter
263 :    
264 :     val sgListM = UU.mkMap ()
265 :     val ssM = UU.mkMap ()
266 :     val ssoM = UU.mkMap ()
267 :     val boolOptionM = UU.mkMap ()
268 :     val siM = UU.mkMap ()
269 :     val snM = UU.mkMap ()
270 :     val snListM = UU.mkMap ()
271 :     val sbnM = UU.mkMap ()
272 :     val fsbnM = UU.mkMap ()
273 :     val fsbnListM = UU.mkMap ()
274 :     val impexpM = UU.mkMap ()
275 :     val impexpListM = UU.mkMap ()
276 :     val groupM = UU.mkMap ()
277 :     val apM = UU.mkMap ()
278 :     val exportsM = UU.mkMap ()
279 :     val privilegesM = UU.mkMap ()
280 :     val poM = UU.mkMap ()
281 : blume 569 val stringListM = UU.mkMap ()
282 : blume 632 val versionM = UU.mkMap ()
283 :     val versionOptM = UU.mkMap ()
284 :     val sgM = UU.mkMap ()
285 : blume 666 val rbM = UU.mkMap ()
286 :     val rblM = UU.mkMap ()
287 : blume 537
288 :     fun list m r = UU.r_list session m r
289 :     val string = UU.r_string session
290 :    
291 :     fun option m r = UU.r_option session m r
292 :     val int = UU.r_int session
293 :     val bool = UU.r_bool session
294 :     fun share m r = UU.share session m r
295 :     fun nonshare r = UU.nonshare session r
296 :     val bool = UU.r_bool session
297 :     val pid = UnpickleSymPid.r_pid (session, string)
298 :    
299 : blume 587 val stringlist = list stringListM string
300 :    
301 : blume 666 fun list2path c sl =
302 :     c (SrcPath.unpickle penv { pickled = sl, relativeTo = group })
303 : blume 569 handle SrcPath.Format => raise Format
304 :    
305 : blume 537 fun abspath () = let
306 : blume 666 fun ap #"p" = list2path SrcPath.file (stringlist ())
307 : blume 537 | ap _ = raise Format
308 :     in
309 :     share apM ap
310 :     end
311 :    
312 : blume 632 fun version () = let
313 :     fun v #"v" =
314 :     (case Version.fromString (string ()) of
315 :     SOME v => v
316 :     | NONE => raise Format)
317 :     | v _ = raise Format
318 :     in
319 :     share versionM v
320 :     end
321 :    
322 : blume 666 fun rb () = let
323 :     fun r #"b" =
324 :     { anchor = string (),
325 :     value = list2path (fn x => x) (stringlist ()) }
326 :     | r _ = raise Format
327 :     in
328 :     share rbM r
329 :     end
330 :    
331 : blume 537 fun sg () = let
332 : blume 666 fun doit getRbl =
333 : blume 632 let val p = abspath ()
334 :     val vo = option versionOptM version ()
335 : blume 666 val rbl = getRbl ()
336 :     fun gth () = getGroup' (gp, p, vo, rbl)
337 : blume 632 in
338 : blume 666 (p, Memoize.memoize gth, rbl)
339 : blume 632 end
340 : blume 666 fun xsg #"s" = doit (fn () => []) (* backward-compatible *)
341 :     | xsg #"S" = doit (list rblM rb)
342 : blume 632 | xsg _ = raise Format
343 : blume 537 in
344 : blume 632 share sgM xsg
345 : blume 537 end
346 :    
347 :     fun gr #"g" =
348 : blume 632 let val version = option versionOptM version ()
349 :     val sublibs = list sgListM sg ()
350 : blume 537
351 : blume 632 fun getSublib i =
352 : blume 652 (case #2 (List.nth (sublibs, i)) () of
353 : blume 632 GG.GROUP x => x
354 :     | GG.ERRORGROUP =>
355 :     EM.impossible "loadStable: ERRORGROUP")
356 :     handle General.Subscript => raise Format
357 :    
358 : blume 587 fun context NONE = raise Format
359 : blume 632 | context (SOME (pos, sy)) = let
360 :     val { exports, ... } = getSublib pos
361 : blume 587 in
362 : blume 632 case SymbolMap.find (exports, sy) of
363 : blume 652 SOME (nth, _, _) =>
364 :     (case nth () of
365 : blume 737 (_, DG.SB_BNODE (_, x, _)) =>
366 : blume 652 StabModmap.addEnv (#statenv x ())
367 :     | _ => raise Format)
368 :     | NONE => raise Format
369 : blume 587 end
370 : blume 537
371 : blume 587 val { symenv, statenv, symbol, symbollist } =
372 :     UP.mkUnpicklers
373 :     { session = session,
374 :     stringlist = stringlist }
375 :     context
376 :    
377 : blume 537 val lazy_symenv = UU.r_lazy session symenv
378 : blume 587 val lazy_statenv = UU.r_lazy session statenv
379 : blume 537
380 :     fun symbolset () = let
381 :     fun s #"s" =
382 :     SymbolSet.addList (SymbolSet.empty, symbollist ())
383 :     | s _ = raise Format
384 :     in
385 :     share ssM s
386 :     end
387 :    
388 :     val filter = option ssoM symbolset
389 :    
390 :     fun shm () = let
391 :     fun s #"a" = Sharing.SHARE true
392 :     | s #"b" = Sharing.SHARE false
393 :     | s #"c" = Sharing.DONTSHARE
394 :     | s _ = raise Format
395 :     in
396 :     nonshare s
397 :     end
398 :    
399 :     val pidoption = option poM pid
400 :    
401 :     fun si () = let
402 :     fun s #"s" =
403 :     let val spec = string ()
404 :     val locs = string ()
405 :     val offset = int () + offset_adjustment
406 :     val rts_pid = pidoption ()
407 :     val sh_mode = shm ()
408 :     val error = EM.errorNoSource grpSrcInfo locs
409 :     in
410 :     BinInfo.new { group = group,
411 :     mkStablename = mksname,
412 :     error = error,
413 :     spec = spec,
414 :     offset = offset,
415 :     rts_pid = rts_pid,
416 :     sh_mode = sh_mode }
417 :     end
418 :     | s _ = raise Format
419 :     in
420 :     share siM s
421 :     end
422 :    
423 :     (* this is the place where what used to be an
424 :     * SNODE changes to a BNODE! *)
425 :     fun sn () = let
426 :     fun sn' #"a" =
427 :     DG.BNODE { bininfo = si (),
428 :     localimports = snlist (),
429 :     globalimports = fsbnlist () }
430 :     | sn' _ = raise Format
431 :     in
432 :     share snM sn'
433 :     end
434 :    
435 :     and snlist () = list snListM sn ()
436 :    
437 :     (* this one changes from farsbnode to plain farbnode *)
438 :     and sbn () = let
439 :     fun sbn' #"2" = let
440 : blume 632 val pos = int ()
441 : blume 537 val sy = symbol ()
442 : blume 632 val { exports = slexp, ... } = getSublib pos
443 : blume 537 in
444 :     case SymbolMap.find (slexp, sy) of
445 : blume 652 SOME (nth, _, _) =>
446 :     (case nth () of
447 : blume 737 (_, DG.SB_BNODE (n, _, _)) =>
448 :     (n, SOME pos)
449 : blume 652 | _ => raise Format)
450 :     | NONE => raise Format
451 : blume 537 end
452 : blume 737 | sbn' #"3" = (sn (), NONE)
453 : blume 537 | sbn' _ = raise Format
454 :     in
455 :     share sbnM sbn'
456 :     end
457 :    
458 :     and fsbn () = let
459 : blume 737 fun f #"f" =
460 :     let val f = filter ()
461 :     val (n, pos) = sbn ()
462 :     in
463 :     (f, n, pos)
464 :     end
465 : blume 537 | f _ = raise Format
466 :     in
467 :     share fsbnM f
468 :     end
469 :    
470 : blume 715 and fsbnlist () = list fsbnListM lazy_fsbn ()
471 : blume 537
472 : blume 715 and lazy_fsbn () = UU.r_lazy session fsbn ()
473 : blume 652
474 : blume 537 fun impexp () = let
475 :     fun ie #"i" =
476 :     let val sy = symbol ()
477 :     (* really reads farbnodes! *)
478 : blume 652 val nth = lazy_fsbn ()
479 : blume 587 val ge = lazy_statenv ()
480 : blume 652 val sye = lazy_symenv ()
481 :     val statpid = pid ()
482 :     val sympid = pid ()
483 : blume 1137 val guid = string ()
484 : blume 652 val allsyms = symbolset ()
485 :     fun ieth () = let
486 : blume 737 val (f, n, pos) = nth ()
487 : blume 652 val ii = { statenv = ge,
488 :     symenv = sye,
489 :     statpid = statpid,
490 : blume 1058 sympid = sympid,
491 : blume 1137 guid = guid }
492 : blume 652 in
493 : blume 737 (f, DG.SB_BNODE (n, ii, pos))
494 : blume 652 end
495 : blume 587 val e = Statenv2DAEnv.cvtMemo ge
496 : blume 652 (* put a filter in front to avoid having
497 :     * the FCTENV being queried needlessly
498 :     * (avoids spurious module loadings) *)
499 :     val e' = DAEnv.FILTER
500 :     (SymbolSet.singleton sy, e)
501 : blume 537 in
502 : blume 652 (sy, (Memoize.memoize ieth, e', allsyms))
503 : blume 537 end
504 : blume 773 | ie #"j" = let
505 :     val sy = symbol ()
506 :     val nth = lazy_fsbn ()
507 :     val allsyms = symbolset ()
508 :     (* This seems (is?) a bit clumsy... *)
509 :     fun xth () = let
510 :     val (f, n, pos) = nth ()
511 :     val (sbnth, e, _) =
512 :     valOf (SymbolMap.find
513 :     (#exports
514 :     (getSublib
515 :     (valOf pos)), sy))
516 :     handle _ => raise Format
517 :     in
518 :     (f, n, pos, sbnth, e)
519 :     end
520 :     val xth = Memoize.memoize xth
521 :     fun eth () = #5 (xth ())
522 :     val e' = DAEnv.FILTER
523 :     (SymbolSet.singleton sy,
524 :     DAEnv.SUSPEND eth)
525 :     fun ieth () = let
526 :     val (f, n, pos, sbnth, _) = xth ()
527 :     val ii =
528 :     case #2 (sbnth ()) of
529 :     DG.SB_BNODE (_, ii, _) => ii
530 :     | _ => raise Format
531 :     in
532 :     (f, DG.SB_BNODE (n, ii, pos))
533 :     end
534 :     in
535 :     (sy, (Memoize.memoize ieth, e', allsyms))
536 :     end
537 : blume 537 | ie _ = raise Format
538 :     in
539 :     share impexpM ie
540 :     end
541 :    
542 :     val impexplist = list impexpListM impexp
543 :    
544 :     fun r_exports () = let
545 :     fun e #"e" =
546 :     foldl SymbolMap.insert'
547 :     SymbolMap.empty (impexplist ())
548 :     | e _ = raise Format
549 :     in
550 :     share exportsM e
551 :     end
552 :    
553 :     fun privileges () = let
554 :     fun p #"p" =
555 :     StringSet.addList (StringSet.empty, stringlist ())
556 :     | p _ = raise Format
557 :     in
558 :     share privilegesM p
559 :     end
560 :    
561 :     val exports = r_exports ()
562 :     val required = privileges ()
563 :     in
564 :     GG.GROUP { exports = exports,
565 : blume 632 kind = GG.LIB { version = version,
566 :     kind = GG.STABLE dropper },
567 : blume 537 required = required,
568 :     grouppath = group,
569 : blume 642 sources = SrcPathMap.empty,
570 : blume 537 sublibs = sublibs }
571 :     end
572 :     | gr _ = raise Format
573 :     in
574 :     share groupM gr
575 :     end
576 :     in
577 :     SOME (SafeIO.perform { openIt = BinIO.openIn o mksname,
578 :     closeIt = BinIO.closeIn,
579 :     work = work,
580 :     cleanup = fn _ => () })
581 :     handle Format => (error ["file is corrupted (old version?)"];
582 :     NONE)
583 :     | IO.Io _ => NONE
584 :     end
585 :    
586 : blume 587 fun stabilize _ { group = GG.ERRORGROUP, ... } = NONE
587 : blume 759 | stabilize gp { group = g as GG.GROUP grec, anyerrors, rebindings } =
588 :     let val policy = #fnpolicy (#param gp)
589 : blume 304
590 : blume 759 fun doit (wrapped, getBFC, vers) = let
591 : blume 323
592 : blume 759 val grouppath = #grouppath grec
593 :     val sublibs = #sublibs grec
594 :     val exports = #exports grec
595 : blume 312
596 : blume 759 fun force f = f ()
597 : blume 569
598 : blume 759 val libstamp =
599 :     libStampOf (grouppath,
600 :     map (#2 o force o #1)
601 :     (SymbolMap.listItems exports),
602 :     sublibs)
603 : blume 652
604 : blume 771 fun writeBFC s (i, { code, data, env, inlinfo }) = let
605 : blume 879 val { contents, stats } = getBFC i
606 : blume 771 val { code = c, data = d, env = e, inlinfo = ii } = stats
607 : blume 902 val v = #version_id CompilerVersion.version
608 : blume 771 in
609 : blume 902 ignore (BF.write { arch = arch, version = v,
610 :     nopickle = true,
611 : blume 879 stream = s, contents = contents });
612 : blume 771 { code = code + c, data = data + d,
613 :     env = env + e, inlinfo = inlinfo + ii }
614 :     end
615 : blume 569
616 : blume 771 fun sizeBFC i =
617 : blume 879 BF.size { contents = #contents (getBFC i),
618 :     nopickle = true }
619 :     fun pidBFC i = BF.staticPidOf (#contents (getBFC i))
620 : blume 771
621 : blume 759 val _ =
622 :     Say.vsay ["[stabilizing ", SrcPath.descr grouppath, "]\n"]
623 : blume 403
624 : blume 759 val _ =
625 :     if StringSet.isEmpty wrapped then ()
626 :     else
627 :     Say.say
628 :     ("$Stabilize: wrapping the following privileges:\n"
629 : blume 312 :: map (fn s => (" " ^ s ^ "\n"))
630 : blume 348 (StringSet.listItems wrapped))
631 : blume 312
632 : blume 759 val grpSrcInfo = (#errcons gp, anyerrors)
633 : blume 308
634 : blume 759 val required = StringSet.difference (#required grec, wrapped)
635 : blume 304
636 : blume 759 (* The format of a stable archive is the following:
637 :     * - It starts with the size s of the pickled dependency
638 :     * graph. This size itself is written as four-byte string.
639 :     * - The size t of the pickled environment for the entire
640 :     * library (using the pickleEnvN interface of the pickler)
641 :     * in the same format as s.
642 :     * - The pickled dependency graph. This graph contains
643 :     * integer offsets of the binfiles for the individual ML
644 :     * members. These offsets need to be adjusted by adding
645 :     * s + t + 8. The pickled dependency graph also contains
646 :     * integer offsets relative to other stable groups. These
647 :     * offsets need no further adjustment.
648 :     * - Individual binfile contents (concatenated) but without
649 :     * their static environments. *)
650 : blume 304
651 : blume 759 val inverseMap = mkInverseMap sublibs
652 : blume 330
653 : blume 759 val members = ref []
654 :     val (registerOffset, getOffset) = let
655 :     val dict = ref SmlInfoMap.empty
656 :     val cur = ref 0
657 :     fun get0 i = SmlInfoMap.find (!dict, i)
658 :     fun reg (i, sz) =
659 :     case get0 i of
660 :     (* This test is necessary because of a tiny chance
661 :     * that a portion of a pickle needs to be re-done
662 :     * by the pickler because it underestimated its
663 :     * size during lazy pickling. Ideally, the pickler
664 :     * should run without side-effects, but in the
665 :     * present case all we need is idempotence. *)
666 :     SOME os => os
667 :     | NONE => let
668 :     val os = !cur
669 :     in
670 :     cur := os + sz;
671 :     dict := SmlInfoMap.insert (!dict, i, os);
672 :     members := i :: (!members);
673 :     os
674 :     end
675 :     val get = valOf o get0
676 :     in
677 :     (reg, get)
678 :     end
679 :    
680 :     fun prepath2list what p = let
681 :     fun warn_relabs (abs, descr) = let
682 :     val relabs = if abs then "absolute" else "relative"
683 : blume 760 val gdesc = SrcPath.descr grouppath
684 : blume 759 fun ppb pps = let
685 :     fun space () = PP.add_break pps (1, 0)
686 :     fun string s = PP.add_string pps s
687 :     fun ss s = (string s; space ())
688 :     fun nl () = PP.add_newline pps
689 : blume 653 in
690 : blume 759 nl ();
691 : blume 760 PP.begin_block pps PP.INCONSISTENT 0;
692 :     app ss ["The", "path", "specifying"];
693 :     app ss [what, descr, "is"];
694 :     string relabs; string "."; nl ();
695 : blume 759 app ss ["(This", "means", "that", "in", "order",
696 :     "to", "be", "able", "to", "use", "the",
697 : blume 760 "stabilized", "library"];
698 :     string gdesc; ss ",";
699 :     app ss ["it", "will", "be", "necessary", "to",
700 :     "keep", "all", "imported", "libraries",
701 :     "with", "names", "derived", "from", "or",
702 :     "equal", "to"];
703 :     ss descr;
704 :     app ss ["in", "the", "same"];
705 : blume 759 ss relabs;
706 :     app ss ["location", "as", "they", "are"];
707 :     string "now.)";
708 : blume 760 PP.end_block pps
709 : blume 653 end
710 : blume 759 in
711 : blume 760 EM.errorNoFile
712 :     (#errcons gp, anyerrors) SM.nullRegion EM.WARN
713 :     (gdesc ^ ": uses non-anchored path") ppb
714 : blume 759 end
715 : blume 569 in
716 : blume 759 SrcPath.pickle { warn = warn_relabs }
717 :     { file = p, relativeTo = grouppath }
718 : blume 569 end
719 :    
720 : blume 759 (* Collect all BNODEs that we see and build
721 :     * a context suitable for P.envPickler. *)
722 :     val libctxt = let
723 :     fun lst f [] k s = k s
724 :     | lst f (h :: t) k s = f h (lst f t k) s
725 : blume 398
726 : blume 759 fun sbn n k (s as (bnodes, snodes)) =
727 :     case n of
728 :     DG.SB_BNODE (DG.BNODE { bininfo = i, ... },
729 :     ii, _) =>
730 :     let val (pos, sy) = inverseMap i
731 :     val bnodes' =
732 :     StableMap.insert (bnodes, i,
733 :     ((pos, sy), #statenv ii))
734 :     in
735 :     k (bnodes', snodes)
736 :     end
737 :     | DG.SB_SNODE n => sn n k s
738 : blume 398
739 : blume 759 and sn (DG.SNODE n) k (bnodes, snodes) = let
740 :     val i = #smlinfo n
741 :     val li = #localimports n
742 :     val gi = #globalimports n
743 : blume 398 in
744 : blume 759 if SmlInfoSet.member (snodes, i) then
745 :     k (bnodes, snodes)
746 :     else let
747 :     val snodes' = SmlInfoSet.add (snodes, i)
748 :     in
749 :     lst sn li (lst fsbn gi k) (bnodes, snodes')
750 :     end
751 : blume 398 end
752 :    
753 : blume 759 and fsbn (_, n) k s = sbn n k s
754 : blume 398
755 : blume 759 fun impexp (nth, _, _) k s = fsbn (nth ()) k s
756 : blume 398
757 : blume 759 val bnodes =
758 :     lst impexp (SymbolMap.listItems exports)
759 :     #1
760 :     (StableMap.empty, SmlInfoSet.empty)
761 : blume 398
762 : blume 759 val bnodel = ListMergeSort.sort
763 :     (fn (x, y) => (#1 (#1 x) > #1 (#1 y)))
764 :     (StableMap.listItems bnodes)
765 : blume 398
766 : blume 759 fun libArg ([], _) = []
767 :     | libArg ((lsm, ge) :: t, m) = let
768 :     val m' = GenModIdMap.mkMap' (ge (), m)
769 :     in
770 :     (SOME lsm, m') :: libArg (t, m')
771 :     end
772 :     in
773 :     libArg (bnodel, MI.emptyTmap)
774 :     end
775 : blume 398
776 : blume 759 val env_orig = P.envPickler (fn _ => ()) (P.LIBRARY libctxt)
777 :     val env = PU.lift_pickler lifter env_orig
778 :     val symenv_orig = P.symenvPickler
779 :     val symenv = PU.lift_pickler lifter symenv_orig
780 :     val lazy_env = PU.w_lazy env
781 :     val lazy_symenv = PU.w_lazy symenv
782 : blume 398
783 : blume 759 val bool = PU.w_bool
784 :     val int = PU.w_int
785 :     val symbol = PickleSymPid.w_symbol
786 :     val pid = PickleSymPid.w_pid
787 :     val share = PU.ah_share
788 :     val option = PU.w_option
789 :     val list = PU.w_list
790 :     val string = PU.w_string
791 :     val bool = PU.w_bool
792 :     val int = PU.w_int
793 : blume 304
794 : blume 759 fun symbolset ss = let
795 :     val op $ = PU.$ SS
796 :     fun raw_ss ss =
797 :     "s" $ [list symbol (SymbolSet.listItems ss)]
798 :     in
799 :     share SSs raw_ss ss
800 :     end
801 : blume 304
802 : blume 759 val filter = option symbolset
803 : blume 304
804 : blume 759 val op $ = PU.$ SHM
805 :     fun shm (Sharing.SHARE true) = "a" $ []
806 :     | shm (Sharing.SHARE false) = "b" $ []
807 :     | shm Sharing.DONTSHARE = "c" $ []
808 : blume 304
809 : blume 759 fun si i = let
810 :     (* FIXME: this is not a technical flaw, but perhaps one
811 :     * that deserves fixing anyway: If we only look at spec,
812 :     * then we are losing information about sub-grouping
813 :     * within libraries. However, the spec in BinInfo.info
814 :     * is only used for diagnostics and has no impact on the
815 :     * operation of CM itself. *)
816 :     val spec = SrcPath.osstring_relative (SmlInfo.sourcepath i)
817 :     val locs = SmlInfo.errorLocation gp i
818 :     val offset = registerOffset (i, sizeBFC i)
819 :     val { is_rts, ... } = SmlInfo.attribs i
820 :     val sh_mode = SmlInfo.sh_mode i
821 :     val op $ = PU.$ SI
822 :     val rts_pid = if is_rts then SOME (pidBFC i) else NONE
823 :     in
824 :     "s" $ [string spec, string locs, int offset,
825 :     option pid rts_pid, shm sh_mode]
826 :     end
827 : blume 306
828 : blume 759 fun abspath p = let
829 :     val op $ = PU.$ AP
830 :     in
831 :     "p" $ [list string (prepath2list "library"
832 :     (SrcPath.pre p))]
833 :     end
834 : blume 306
835 : blume 759 fun sn n = let
836 :     val op $ = PU.$ SN
837 :     fun raw_sn (DG.SNODE n) =
838 :     "a" $ [si (#smlinfo n), list sn (#localimports n),
839 :     list lazy_fsbn' (#globalimports n)]
840 :     in
841 :     share SNs raw_sn n
842 :     end
843 : blume 306
844 : blume 759 (* Here we ignore the interface info because we will not
845 :     * need it anymore when we unpickle. *)
846 :     and sbn x = let
847 :     val op $ = PU.$ SBN
848 :     in
849 :     case x of
850 :     DG.SB_BNODE (DG.BNODE { bininfo = i, ... }, _, _) =>
851 :     let val (pos, sy) = inverseMap i
852 :     in
853 :     "2" $ [int pos, symbol sy]
854 :     end
855 :     | DG.SB_SNODE n => "3" $ [sn n]
856 :     end
857 : blume 385
858 : blume 759 and fsbn (f, n) = let
859 :     val op $ = PU.$ FSBN
860 :     in
861 :     "f" $ [filter f, sbn n]
862 :     end
863 : blume 370
864 : blume 759 and lazy_fsbn arg = PU.w_lazy fsbn arg
865 : blume 652
866 : blume 759 and lazy_fsbn' arg = lazy_fsbn (fn () => arg)
867 : blume 715
868 : blume 759 (* Here is the place where we need to write interface info. *)
869 :     fun impexp (s, (nth, _, allsyms)) = let
870 :     val op $ = PU.$ IMPEXP
871 :     in
872 : blume 773 case nth () of
873 :     (_, DG.SB_SNODE (DG.SNODE { smlinfo, ... })) =>
874 :     (* this is the case of an actual internal node *)
875 : blume 1137 let val { statenv, symenv, statpid, sympid, guid } =
876 : blume 773 getII smlinfo
877 :     in
878 :     "i" $ [symbol s,
879 :     lazy_fsbn nth,
880 :     lazy_env statenv,
881 :     lazy_symenv symenv,
882 :     pid statpid,
883 :     pid sympid,
884 : blume 1137 string guid,
885 : blume 773 symbolset allsyms]
886 :     end
887 :     | (f, DG.SB_BNODE (DG.BNODE n, _, _)) =>
888 :     (* This is the case of a simple re-export;
889 :     * we avoid pickling any environments here because
890 :     * they can be re-fetched from the sublib directly
891 :     * when unpickling. *)
892 :     "j" $ [symbol s, lazy_fsbn nth, symbolset allsyms]
893 : blume 759 end
894 : blume 307
895 : blume 759 fun w_exports e = let
896 :     val op $ = PU.$ EXPORTS
897 :     in
898 :     "e" $ [list impexp (SymbolMap.listItemsi e)]
899 :     end
900 : blume 306
901 : blume 759 fun privileges p = let
902 :     val op $ = PU.$ PRIV
903 :     in
904 :     "p" $ [list string (StringSet.listItems p)]
905 :     end
906 : blume 306
907 : blume 759 fun version v = let
908 :     val op $ = PU.$ VERSION
909 :     in
910 :     "v" $ [string (Version.toString v)]
911 :     end
912 : blume 632
913 : blume 759 fun rb { anchor, value } = let
914 :     val op $ = PU.$ RB
915 :     in
916 :     "b" $ [string anchor,
917 :     list string (prepath2list "anchor binding" value)]
918 :     end
919 : blume 666
920 : blume 759 fun sg (p, gth, rbl) = let
921 :     val op $ = PU.$ SG
922 :     val vo = case gth () of
923 :     GG.GROUP { kind = GG.LIB x, ... } => #version x
924 :     | _ => NONE
925 :     in
926 :     "S" $ [abspath p, option version vo, list rb rbl]
927 :     end
928 : blume 632
929 : blume 759 fun group () = let
930 :     val op $ = PU.$ G
931 :     in
932 :     (* Pickle the sublibs first because we need to already
933 :     * have them back when we unpickle BNODEs. *)
934 :     "g" $ [option version vers,
935 :     list sg sublibs,
936 :     w_exports exports,
937 :     privileges required]
938 :     end
939 : blume 308
940 : blume 759 val dg_pickle =
941 :     Byte.stringToBytes (PU.pickle emptyMap (group ()))
942 : blume 403
943 : blume 759 val dg_sz = Word8Vector.length dg_pickle
944 : blume 308
945 : blume 759 val offset_adjustment = dg_sz + 4 + libstamp_nbytes
946 : blume 398
947 : blume 759 (* We could generate the graph for a stable group here directly
948 :     * by transcribing the original graph. However, it is
949 :     * cumbersome and is likely to result in a larger memory
950 :     * footprint because we don't get the benefit of lazy
951 :     * unpickling of environments.
952 :     * It seems easier to simply rely on "loadStable" to re-fetch
953 :     * the stable graph. *)
954 :     fun refetchStableGroup () = let
955 :     fun getGroup (_, p, _, _) = let
956 :     fun theSublib (q, _, _) =
957 :     SrcPath.compare (p, q) = EQUAL
958 :     fun force f = f ()
959 :     in
960 :     Option.map (force o #2) (List.find theSublib sublibs)
961 :     end
962 : blume 537 in
963 : blume 759 loadStable { getGroup = getGroup, anyerrors = anyerrors }
964 :     (gp, grouppath, NONE, rebindings)
965 : blume 537 end
966 :    
967 : blume 759 fun writeInt32 (s, i) = let
968 :     val a = Word8Array.array (4, 0w0)
969 :     val _ = Pack32Big.update (a, 0, LargeWord.fromInt i)
970 :     in
971 :     BinIO.output (s, Word8Array.extract (a, 0, NONE))
972 :     end
973 :     val memberlist = rev (!members)
974 :    
975 :     (* don't use version information for making the stable path! *)
976 :     fun mksname () =
977 :     FilenamePolicy.mkStableName policy (grouppath, NONE)
978 :    
979 :     val libstamp_bytes = Pid.toBytes libstamp
980 :     val _ =
981 :     if Word8Vector.length libstamp_bytes <> libstamp_nbytes
982 :     then EM.impossible "stabilize: libstamp size wrong"
983 :     else ()
984 :     fun work outs =
985 :     (BinIO.output (outs, libstamp_bytes);
986 :     writeInt32 (outs, dg_sz);
987 :     BinIO.output (outs, dg_pickle);
988 : blume 771 let val { code, data, env, inlinfo } =
989 :     foldl (writeBFC outs)
990 :     { code = 0, data = 0, env = 0, inlinfo = 0 }
991 :     memberlist
992 :     in
993 :     Say.vsay ["[code: ", Int.toString code,
994 :     ", data: ", Int.toString data,
995 :     ", inlinable: ", Int.toString inlinfo,
996 :     ", env: ", Int.toString dg_sz,
997 :     " bytes]\n"]
998 :     end)
999 : blume 311 in
1000 : blume 759 (SafeIO.perform { openIt = AutoDir.openBinOut o mksname,
1001 :     closeIt = BinIO.closeOut,
1002 :     work = work,
1003 :     cleanup = fn _ =>
1004 :     (OS.FileSys.remove (mksname ())
1005 :     handle _ => ()) };
1006 :     refetchStableGroup ())
1007 :     handle exn =>
1008 :     (EM.errorNoFile (#errcons gp, anyerrors) SM.nullRegion
1009 :     EM.COMPLAIN
1010 :     (concat ["Exception raised while stabilizing ",
1011 :     SrcPath.descr grouppath])
1012 :     EM.nullErrorBody;
1013 :     NONE)
1014 : blume 311 end
1015 :     in
1016 : blume 759 case #kind grec of
1017 :     GG.LIB { kind = GG.STABLE _, ... } => SOME g
1018 :     | GG.NOLIB _ => EM.impossible "stabilize: no library"
1019 :     | GG.LIB { kind = GG.DEVELOPED { wrapped, ... }, version } =>
1020 :     (case recomp gp g of
1021 :     NONE => (anyerrors := true; NONE)
1022 :     | SOME bfc_acc => let
1023 :     fun notStable (_, gth, _) =
1024 :     case gth () of
1025 :     GG.GROUP { kind =
1026 :     GG.LIB { kind = GG.STABLE _,
1027 :     ... }, ... } =>
1028 :     false
1029 :     | _ => true
1030 :     in
1031 :     case List.filter notStable (#sublibs grec) of
1032 :     [] => doit (wrapped, bfc_acc, version)
1033 :     | l => let
1034 :     val grammar =
1035 :     case l of [_] => " is" | _ => "s are"
1036 :     fun ppb pps = let
1037 :     fun loop [] = ()
1038 :     | loop ((p, _, _) :: t) =
1039 :     (PP.add_string pps (SrcPath.descr p);
1040 :     PP.add_newline pps;
1041 :     loop t)
1042 :     in
1043 : blume 311 PP.add_newline pps;
1044 : blume 759 PP.add_string pps
1045 : blume 311 (concat ["because the following sub-group",
1046 :     grammar, " not stable:"]);
1047 : blume 759 PP.add_newline pps;
1048 :     loop l
1049 :     end
1050 :     val errcons = #errcons gp
1051 :     val gdescr = SrcPath.descr (#grouppath grec)
1052 :     in
1053 :     EM.errorNoFile (errcons, anyerrors)
1054 :     SM.nullRegion
1055 :     EM.COMPLAIN
1056 :     (gdescr ^ " cannot be stabilized")
1057 :     ppb;
1058 :     NONE
1059 :     end
1060 :     end)
1061 :     end
1062 : blume 537 end (* functor Stabilize *)
1063 : blume 310
1064 : blume 309 end (* local *)

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