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

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