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

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