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 569 - (view) (download)

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

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