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 340 - (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 310
17 :     type statenvgetter = GP.info -> DG.bnode -> E.staticEnv
18 : blume 314 type recomp = GP.info -> GG.group -> bool
19 : blume 309 in
20 : blume 304
21 : blume 309 signature STABILIZE = sig
22 :    
23 :     val loadStable :
24 : blume 310 GP.info * (AbsPath.t -> GG.group option) * bool ref ->
25 :     AbsPath.t -> GG.group option
26 : blume 309
27 :     val stabilize :
28 : blume 311 GP.info -> { group: GG.group, anyerrors: bool ref } ->
29 : blume 310 GG.group option
30 : blume 309 end
31 :    
32 : blume 311 functor StabilizeFn (val bn2statenv : statenvgetter
33 :     val recomp: recomp) :> STABILIZE = struct
34 : blume 309
35 : blume 307 datatype pitem =
36 :     PSS of SymbolSet.set
37 :     | PS of Symbol.symbol
38 :     | PSN of DG.snode
39 : blume 304
40 : blume 307 datatype uitem =
41 :     USS of SymbolSet.set
42 :     | US of Symbol.symbol
43 :     | UBN of DG.bnode
44 : blume 304
45 : blume 307 fun compare (PS s, PS s') = SymbolOrdKey.compare (s, s')
46 :     | compare (PS _, _) = GREATER
47 :     | compare (_, PS _) = LESS
48 :     | compare (PSS s, PSS s') = SymbolSet.compare (s, s')
49 :     | compare (PSS _, _) = GREATER
50 :     | compare (_, PSS _) = LESS
51 :     | compare (PSN (DG.SNODE n), PSN (DG.SNODE n')) =
52 :     SmlInfo.compare (#smlinfo n, #smlinfo n')
53 :    
54 : blume 304 structure Map =
55 :     BinaryMapFn (struct
56 : blume 307 type ord_key = pitem
57 : blume 304 val compare = compare
58 :     end)
59 :    
60 : blume 308 fun genStableInfoMap (exports, group) = let
61 :     (* find all the exported bnodes that are in the same group: *)
62 :     fun add (((_, DG.SB_BNODE (n as DG.BNODE b)), _), m) = let
63 :     val i = #bininfo b
64 :     in
65 :     if AbsPath.compare (BinInfo.group i, group) = EQUAL then
66 :     IntBinaryMap.insert (m, BinInfo.offset i, n)
67 :     else m
68 :     end
69 :     | add (_, m) = m
70 :     in
71 :     SymbolMap.foldl add IntBinaryMap.empty exports
72 :     end
73 :    
74 : blume 310 fun deleteFile n = OS.FileSys.remove n
75 :     handle e as Interrupt.Interrupt => raise e
76 :     | _ => ()
77 :    
78 : blume 311 fun stabilize gp { group = g as GG.GROUP grec, anyerrors } = let
79 : blume 304
80 : blume 323 val primconf = #primconf (#param gp)
81 :     val policy = #fnpolicy (#param gp)
82 :    
83 : blume 340 val grouppath = #grouppath grec
84 :     val groupdir = AbsPath.dir grouppath
85 :    
86 : blume 311 fun doit granted = let
87 : blume 312
88 : blume 314 val _ =
89 :     if StringSet.isEmpty granted then ()
90 :     else
91 :     Say.say ("$Stabilize: wrapping the following privileges:\n"
92 : blume 312 :: map (fn s => (" " ^ s ^ "\n"))
93 :     (StringSet.listItems granted))
94 :    
95 : blume 311 val bname = AbsPath.name o SmlInfo.binpath
96 :     val bsz = OS.FileSys.fileSize o bname
97 :     fun cpb s i = let
98 :     val ins = BinIO.openIn (bname i)
99 :     fun cp () =
100 :     if BinIO.endOfStream ins then ()
101 :     else (BinIO.output (s, BinIO.input ins); cp ())
102 :     in
103 :     cp () handle e => (BinIO.closeIn ins; raise e);
104 : blume 310 BinIO.closeIn ins
105 : blume 311 end
106 : blume 310
107 : blume 311 val grpSrcInfo = (#errcons gp, anyerrors)
108 : blume 308
109 : blume 311 val exports = #exports grec
110 :     val islib = #islib grec
111 :     val required = StringSet.difference (#required grec, granted)
112 : blume 340 val sublibs = #sublibs grec
113 : blume 304
114 : blume 311 (* The format of a stable archive is the following:
115 :     * - It starts with the size s of the pickled dependency
116 :     * graph. This size itself is written as four-byte string.
117 :     * - The pickled dependency graph. This graph contains
118 :     * integer offsets of the binfiles for the individual ML
119 :     * members. These offsets need to be adjusted by adding
120 :     * s + 4. The pickled dependency graph also contains integer
121 :     * offsets relative to other stable groups. These offsets
122 :     * need no further adjustment.
123 :     * - Individual binfile contents (concatenated).
124 :     *)
125 : blume 304
126 : blume 340 (* Here we build a mapping that maps each BNODE to a number
127 :     * representing the sub-library that it came from and a
128 :     * representative symbol that can be used to find the BNODE
129 :     * within the exports of that library *)
130 :     fun oneB i (sy, ((_, DG.SB_BNODE (DG.BNODE n)), _), m) =
131 :     StableMap.insert (m, #bininfo n, (i, sy))
132 :     | oneB i (_, _, m) = m
133 :     fun oneSL ((_, g as GG.GROUP { exports, ... }), (m, i)) =
134 :     (SymbolMap.foldli (oneB i) m exports, i + 1)
135 :     val inverseMap = #1 (foldl oneSL (StableMap.empty, 0) sublibs)
136 : blume 330
137 : blume 311 val members = ref []
138 :     val (registerOffset, getOffset) = let
139 :     val dict = ref SmlInfoMap.empty
140 :     val cur = ref 0
141 :     fun reg (i, sz) = let
142 :     val os = !cur
143 : blume 306 in
144 : blume 311 cur := os + sz;
145 :     dict := SmlInfoMap.insert (!dict, i, os);
146 :     members := i :: (!members);
147 :     os
148 : blume 306 end
149 : blume 311 fun get i = valOf (SmlInfoMap.find (!dict, i))
150 :     in
151 :     (reg, get)
152 :     end
153 : blume 304
154 : blume 311 fun w_list w_item [] k m =
155 :     "0" :: k m
156 :     | w_list w_item [a] k m =
157 :     "1" :: w_item a k m
158 :     | w_list w_item [a, b] k m =
159 :     "2" :: w_item a (w_item b k) m
160 :     | w_list w_item [a, b, c] k m =
161 :     "3" :: w_item a (w_item b (w_item c k)) m
162 :     | w_list w_item [a, b, c, d] k m =
163 :     "4" :: w_item a (w_item b (w_item c (w_item d k))) m
164 :     | w_list w_item (a :: b :: c :: d :: e :: r) k m =
165 :     "5" :: w_item a (w_item b (w_item c (w_item d (w_item e
166 :     (w_list w_item r k))))) m
167 : blume 304
168 : blume 311 fun w_option w_item NONE k m = "n" :: k m
169 :     | w_option w_item (SOME i) k m = "s" :: w_item i k m
170 : blume 304
171 : blume 311 fun int_encode i = let
172 :     (* this is the same mechanism that's also used in
173 :     * TopLevel/batch/binfile.sml (maybe we should share it) *)
174 :     val n = Word32.fromInt i
175 :     val // = LargeWord.div
176 :     val %% = LargeWord.mod
177 :     val !! = LargeWord.orb
178 :     infix // %% !!
179 :     val toW8 = Word8.fromLargeWord
180 :     fun r (0w0, l) = Word8Vector.fromList l
181 :     | r (n, l) =
182 :     r (n // 0w128, toW8 ((n %% 0w128) !! 0w128) :: l)
183 :     in
184 :     Byte.bytesToString (r (n // 0w128, [toW8 (n %% 0w128)]))
185 :     end
186 : blume 304
187 : blume 311 fun w_int i k m = int_encode i :: k m
188 : blume 304
189 : blume 311 fun w_share w C v k (i, m) =
190 :     case Map.find (m, C v) of
191 :     SOME i' => "o" :: w_int i' k (i, m)
192 :     | NONE => "n" :: w v k (i + 1, Map.insert (m, C v, i))
193 : blume 304
194 : blume 311 fun w_symbol_raw s k m = let
195 :     val ns = case Symbol.nameSpace s of
196 :     Symbol.SIGspace => "'"
197 :     | Symbol.FCTspace => "("
198 :     | Symbol.FSIGspace => ")"
199 :     | Symbol.STRspace => ""
200 :     | _ => GenericVC.ErrorMsg.impossible "stabilize:w_symbol"
201 :     in
202 :     ns :: Symbol.name s :: "." :: k m
203 :     end
204 : blume 304
205 : blume 311 val w_symbol = w_share w_symbol_raw PS
206 : blume 304
207 : blume 311 val w_ss = w_share (w_list w_symbol o SymbolSet.listItems) PSS
208 : blume 306
209 : blume 311 val w_filter = w_option w_ss
210 : blume 306
211 : blume 311 fun w_string s k m = let
212 :     fun esc #"\\" = "\\\\"
213 :     | esc #"\"" = "\\\""
214 :     | esc c = String.str c
215 :     in
216 :     String.translate esc s :: "\"" :: k m
217 :     end
218 : blume 306
219 : blume 311 fun w_sharing NONE k m = "n" :: k m
220 :     | w_sharing (SOME true) k m = "t" :: k m
221 :     | w_sharing (SOME false) k m = "f" :: k m
222 : blume 306
223 : blume 311 fun w_si i k = let
224 : blume 340 (* FIXME: this is not a technical flaw, but perhaps one
225 :     * that deserves fixing anyway: If we only look at spec,
226 :     * then we are losing information about sub-grouping
227 :     * within libraries. However, the spec in BinInfo.info
228 :     * is only used for diagnostics and has no impact on the
229 :     * operation of CM itself. *)
230 : blume 311 val spec = AbsPath.spec (SmlInfo.sourcepath i)
231 :     val locs = SmlInfo.errorLocation gp i
232 :     val offset = registerOffset (i, bsz i)
233 :     in
234 :     w_string spec
235 :     (w_string locs
236 :     (w_int offset
237 :     (w_sharing (SmlInfo.share i) k)))
238 :     end
239 : blume 306
240 : blume 323 fun w_primitive p k m =
241 :     String.str (Primitive.toIdent primconf p) :: k m
242 : blume 306
243 : blume 340 fun warn_relabs p abs = let
244 :     val relabs = if abs then "absolute" else "relative"
245 : blume 330 fun ppb pps =
246 :     (PP.add_newline pps;
247 : blume 340 PP.add_string pps (AbsPath.name p);
248 : blume 330 PP.add_newline pps;
249 :     PP.add_string pps
250 :     "(This means that in order to be able to use the result of stabilization";
251 :     PP.add_newline pps;
252 : blume 340 PP.add_string pps "the library must be in the same ";
253 : blume 330 PP.add_string pps relabs;
254 :     PP.add_string pps " location as it is now.)";
255 :     PP.add_newline pps)
256 :     in
257 :     EM.errorNoFile (#errcons gp, anyerrors) SM.nullRegion
258 :     EM.WARN
259 : blume 340 (concat [AbsPath.name grouppath,
260 :     ": library referred to by ", relabs,
261 :     " pathname:"])
262 : blume 330 ppb
263 :     end
264 : blume 306
265 : blume 330 fun w_abspath p k m =
266 : blume 340 w_list w_string (AbsPath.pickle (warn_relabs p) (p, groupdir))
267 :     k m
268 : blume 306
269 : blume 311 fun w_bn (DG.PNODE p) k m = "p" :: w_primitive p k m
270 : blume 340 | w_bn (DG.BNODE { bininfo = i, ... }) k m = let
271 :     val (n, sy) = valOf (StableMap.find (inverseMap, i))
272 :     in
273 :     "b" :: w_int n (w_symbol sy k) m
274 :     end
275 : blume 306
276 : blume 311 fun w_sn_raw (DG.SNODE n) k =
277 :     w_si (#smlinfo n)
278 :     (w_list w_sn (#localimports n)
279 :     (w_list w_fsbn (#globalimports n) k))
280 : blume 306
281 : blume 311 and w_sn n = w_share w_sn_raw PSN n
282 : blume 307
283 : blume 311 and w_sbn (DG.SB_BNODE n) k m = "b" :: w_bn n k m
284 :     | w_sbn (DG.SB_SNODE n) k m = "s" :: w_sn n k m
285 : blume 306
286 : blume 311 and w_fsbn (f, n) k = w_filter f (w_sbn n k)
287 : blume 306
288 : blume 311 fun w_impexp (s, (n, _)) k = w_symbol s (w_fsbn n k)
289 : blume 306
290 : blume 311 fun w_exports e = w_list w_impexp (SymbolMap.listItemsi e)
291 : blume 306
292 : blume 311 fun w_bool true k m = "t" :: k m
293 :     | w_bool false k m = "f" :: k m
294 : blume 306
295 : blume 311 fun w_privileges p = w_list w_string (StringSet.listItems p)
296 : blume 306
297 : blume 311 fun pickle_group () = let
298 : blume 330 fun w_sg (p, _) = w_abspath p
299 : blume 311 fun k0 m = []
300 :     val m0 = (0, Map.empty)
301 :     in
302 : blume 340 (* Pickle the sublibs first because we need to already
303 : blume 330 * have them back when we unpickle BNODEs. *)
304 : blume 340 concat (w_list w_sg sublibs
305 : blume 330 (w_exports exports
306 :     (w_bool islib
307 :     (w_privileges required k0))) m0)
308 : blume 311 end
309 : blume 308
310 : blume 311 val pickle = pickle_group ()
311 :     val sz = size pickle
312 :     val offset_adjustment = sz + 4
313 : blume 308
314 : blume 329 fun mkStableGroup spath = let
315 : blume 311 val m = ref SmlInfoMap.empty
316 :     fun sn (DG.SNODE (n as { smlinfo, ... })) =
317 :     case SmlInfoMap.find (!m, smlinfo) of
318 :     SOME n => n
319 :     | NONE => let
320 :     val li = map sn (#localimports n)
321 :     val gi = map fsbn (#globalimports n)
322 :     val sourcepath = SmlInfo.sourcepath smlinfo
323 : blume 340 (* FIXME: see the comment near the other
324 :     * occurence of AbsPath.spec... *)
325 : blume 311 val spec = AbsPath.spec sourcepath
326 :     val offset =
327 :     getOffset smlinfo + offset_adjustment
328 :     val share = SmlInfo.share smlinfo
329 :     val locs = SmlInfo.errorLocation gp smlinfo
330 :     val error = EM.errorNoSource grpSrcInfo locs
331 :     val i = BinInfo.new { group = grouppath,
332 : blume 329 stablepath = spath,
333 : blume 311 spec = spec,
334 :     offset = offset,
335 :     share = share,
336 :     error = error }
337 :     val n = DG.BNODE { bininfo = i,
338 :     localimports = li,
339 :     globalimports = gi }
340 :     in
341 :     m := SmlInfoMap.insert (!m, smlinfo, n);
342 :     n
343 :     end
344 : blume 308
345 : blume 311 and sbn (DG.SB_SNODE n) = sn n
346 :     | sbn (DG.SB_BNODE n) = n
347 : blume 308
348 : blume 311 and fsbn (f, n) = (f, sbn n)
349 : blume 308
350 : blume 311 fun impexp ((f, n), e) = ((f, DG.SB_BNODE (sbn n)), e)
351 : blume 308
352 : blume 311 val exports = SymbolMap.map impexp (#exports grec)
353 :     val simap = genStableInfoMap (exports, grouppath)
354 :     in
355 :     GG.GROUP { exports = exports,
356 :     islib = islib,
357 :     required = required,
358 :     grouppath = grouppath,
359 : blume 340 sublibs = sublibs,
360 : blume 311 stableinfo = GG.STABLE simap }
361 :     end
362 : blume 308
363 : blume 311 fun writeInt32 (s, i) = let
364 :     val a = Word8Array.array (4, 0w0)
365 :     val _ = Pack32Big.update (a, 0, LargeWord.fromInt i)
366 :     in
367 :     BinIO.output (s, Word8Array.extract (a, 0, NONE))
368 :     end
369 :     val memberlist = rev (!members)
370 :    
371 :     val gpath = #grouppath grec
372 :     val spath = FilenamePolicy.mkStablePath policy gpath
373 :     fun delete () = deleteFile (AbsPath.name spath)
374 :     val outs = AbsPath.openBinOut spath
375 :     fun try () =
376 :     (Say.vsay ["[stabilizing ", AbsPath.name gpath, "]\n"];
377 :     writeInt32 (outs, sz);
378 :     BinIO.output (outs, Byte.stringToBytes pickle);
379 :     app (cpb outs) memberlist;
380 :     BinIO.closeOut outs;
381 : blume 329 SOME (mkStableGroup spath))
382 : blume 311 in
383 :     Interrupt.guarded try
384 :     handle e as Interrupt.Interrupt => (BinIO.closeOut outs;
385 :     delete ();
386 :     raise e)
387 :     | exn => (BinIO.closeOut outs; NONE)
388 :     end
389 :     in
390 :     case #stableinfo grec of
391 :     GG.STABLE _ => SOME g
392 :     | GG.NONSTABLE granted =>
393 : blume 314 if not (recomp gp g) then
394 : blume 311 (anyerrors := true; NONE)
395 :     else let
396 : blume 330 fun notStable (_, GG.GROUP { stableinfo, ... }) =
397 : blume 311 case stableinfo of
398 :     GG.STABLE _ => false
399 :     | GG.NONSTABLE _ => true
400 : blume 308 in
401 : blume 340 case List.filter notStable (#sublibs grec) of
402 : blume 311 [] => doit granted
403 :     | l => let
404 :     val grammar = case l of [_] => " is" | _ => "s are"
405 :     fun ppb pps = let
406 :     fun loop [] = ()
407 : blume 330 | loop ((p, GG.GROUP { grouppath, ... })
408 :     :: t) =
409 : blume 311 (PP.add_string pps
410 :     (AbsPath.name grouppath);
411 : blume 330 PP.add_string pps " (";
412 :     PP.add_string pps (AbsPath.name p);
413 :     PP.add_string pps ")";
414 : blume 311 PP.add_newline pps;
415 :     loop t)
416 :     in
417 :     PP.add_newline pps;
418 :     PP.add_string pps
419 :     (concat ["because the following sub-group",
420 :     grammar, " not stable:"]);
421 :     PP.add_newline pps;
422 :     loop l
423 :     end
424 :     val errcons = #errcons gp
425 :     val gname = AbsPath.name (#grouppath grec)
426 :     in
427 :     EM.errorNoFile (errcons, anyerrors) SM.nullRegion
428 :     EM.COMPLAIN
429 :     (gname ^ " cannot be stabilized")
430 :     ppb;
431 :     NONE
432 :     end
433 : blume 308 end
434 : blume 311 end
435 : blume 310
436 :     fun loadStable (gp, getGroup, anyerrors) group = let
437 : blume 306
438 : blume 340 val groupdir = AbsPath.dir group
439 : blume 310 fun bn2env n = Statenv2DAEnv.cvtMemo (fn () => bn2statenv gp n)
440 : blume 308
441 : blume 311 val errcons = #errcons gp
442 :     val grpSrcInfo = (errcons, anyerrors)
443 :     val gname = AbsPath.name group
444 :     fun error l = EM.errorNoFile (errcons, anyerrors) SM.nullRegion
445 :     EM.COMPLAIN (concat (gname :: ": " :: l)) EM.nullErrorBody
446 : blume 309
447 : blume 306 exception Format
448 :    
449 : blume 318 val pcmode = #pcmode (#param gp)
450 : blume 310 val policy = #fnpolicy (#param gp)
451 : blume 323 val primconf = #primconf (#param gp)
452 : blume 310 val spath = FilenamePolicy.mkStablePath policy group
453 : blume 311 val _ = Say.vsay ["[checking stable ", gname, "]\n"]
454 : blume 310 val s = AbsPath.openBinIn spath
455 :    
456 :     fun getGroup' p =
457 :     case getGroup p of
458 :     SOME g => g
459 : blume 311 | NONE =>
460 :     (error ["unable to find ", AbsPath.name p];
461 :     raise Format)
462 : blume 310
463 : blume 306 (* for getting sharing right... *)
464 :     val m = ref IntBinaryMap.empty
465 :     val next = ref 0
466 :    
467 :     fun bytesIn n = let
468 :     val bv = BinIO.inputN (s, n)
469 : blume 304 in
470 : blume 306 if n = Word8Vector.length bv then bv
471 :     else raise Format
472 : blume 304 end
473 :    
474 : blume 306 val sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))
475 :     val pickle = bytesIn sz
476 :     val offset_adjustment = sz + 4
477 : blume 304
478 : blume 306 val rd = let
479 :     val pos = ref 0
480 :     fun rd () = let
481 :     val p = !pos
482 :     in
483 :     pos := p + 1;
484 :     Byte.byteToChar (Word8Vector.sub (pickle, p))
485 :     handle _ => raise Format
486 :     end
487 : blume 304 in
488 : blume 306 rd
489 : blume 304 end
490 :    
491 : blume 306 fun r_list r () =
492 :     case rd () of
493 :     #"0" => []
494 :     | #"1" => [r ()]
495 :     | #"2" => [r (), r ()]
496 :     | #"3" => [r (), r (), r ()]
497 :     | #"4" => [r (), r (), r (), r ()]
498 :     | #"5" => r () :: r () :: r () :: r () :: r () :: r_list r ()
499 :     | _ => raise Format
500 : blume 304
501 : blume 306 fun r_bool () =
502 :     case rd () of
503 :     #"t" => true
504 :     | #"f" => false
505 :     | _ => raise Format
506 : blume 304
507 : blume 306 fun r_option r_item () =
508 :     case rd () of
509 :     #"n" => NONE
510 :     | #"s" => SOME (r_item ())
511 :     | _ => raise Format
512 : blume 304
513 : blume 306 fun r_int () = let
514 :     fun loop n = let
515 :     val w8 = Byte.charToByte (rd ())
516 :     val n' = n * 0w128 + Word8.toLargeWord (Word8.andb (w8, 0w127))
517 :     in
518 :     if Word8.andb (w8, 0w128) = 0w0 then n' else loop n'
519 :     end
520 :     in
521 :     LargeWord.toIntX (loop 0w0)
522 :     end
523 : blume 304
524 : blume 306 fun r_share r_raw C unC () =
525 :     case rd () of
526 :     #"o" => (case IntBinaryMap.find (!m, r_int ()) of
527 :     SOME x => unC x
528 :     | NONE => raise Format)
529 :     | #"n" => let
530 :     val i = !next
531 :     val _ = next := i + 1
532 :     val v = r_raw ()
533 :     in
534 :     m := IntBinaryMap.insert (!m, i, C v);
535 :     v
536 :     end
537 :     | _ => raise Format
538 : blume 304
539 : blume 306 fun r_string () = let
540 :     fun loop l =
541 :     case rd () of
542 :     #"\"" => String.implode (rev l)
543 :     | #"\\" => loop (rd () :: l)
544 :     | c => loop (c :: l)
545 :     in
546 :     loop []
547 :     end
548 : blume 304
549 : blume 330 fun r_abspath () =
550 : blume 340 case AbsPath.unpickle pcmode (r_list r_string (), groupdir) of
551 : blume 330 SOME p => p
552 :     | NONE => raise Format
553 : blume 304
554 : blume 306 val r_symbol = let
555 :     fun r_symbol_raw () = let
556 :     val (ns, first) =
557 :     case rd () of
558 :     #"`" => (Symbol.sigSymbol, rd ())
559 :     | #"(" => (Symbol.fctSymbol, rd ())
560 :     | #")" => (Symbol.fsigSymbol, rd ())
561 :     | c => (Symbol.strSymbol, c)
562 :     fun loop (#".", l) = String.implode (rev l)
563 :     | loop (c, l) = loop (rd (), c :: l)
564 :     in
565 :     ns (loop (first, []))
566 :     end
567 : blume 307 fun unUS (US x) = x
568 :     | unUS _ = raise Format
569 : blume 306 in
570 : blume 307 r_share r_symbol_raw US unUS
571 : blume 306 end
572 : blume 304
573 : blume 306 val r_ss = let
574 :     fun r_ss_raw () =
575 :     SymbolSet.addList (SymbolSet.empty, r_list r_symbol ())
576 : blume 307 fun unUSS (USS s) = s
577 :     | unUSS _ = raise Format
578 : blume 306 in
579 : blume 307 r_share r_ss_raw USS unUSS
580 : blume 306 end
581 : blume 304
582 : blume 306 val r_filter = r_option r_ss
583 : blume 305
584 : blume 306 fun r_primitive () =
585 : blume 323 case Primitive.fromIdent primconf (rd ()) of
586 : blume 306 NONE => raise Format
587 :     | SOME p => p
588 : blume 305
589 : blume 306 fun r_sharing () =
590 :     case rd () of
591 :     #"n" => NONE
592 :     | #"t" => SOME true
593 :     | #"f" => SOME false
594 :     | _ => raise Format
595 : blume 305
596 : blume 307 fun r_si () = let
597 :     val spec = r_string ()
598 :     val locs = r_string ()
599 :     val offset = r_int () + offset_adjustment
600 :     val share = r_sharing ()
601 :     val error = EM.errorNoSource grpSrcInfo locs
602 : blume 306 in
603 : blume 307 BinInfo.new { group = group,
604 : blume 329 stablepath = spath,
605 : blume 307 error = error,
606 :     spec = spec,
607 :     offset = offset,
608 :     share = share }
609 : blume 306 end
610 : blume 305
611 : blume 330 fun r_sg () = let
612 :     val p = r_abspath ()
613 :     in
614 :     (p, getGroup' p)
615 :     end
616 : blume 306
617 : blume 330 fun unpickle_group () = let
618 : blume 306
619 : blume 340 val sublibs = r_list r_sg ()
620 : blume 307
621 : blume 330 fun r_bn () =
622 :     case rd () of
623 :     #"p" => DG.PNODE (r_primitive ())
624 :     | #"b" => let
625 : blume 340 val n = r_int ()
626 : blume 330 val sy = r_symbol ()
627 : blume 340 val (_, GG.GROUP { exports = slexp, ... }) =
628 :     List.nth (sublibs, n) handle _ => raise Format
629 : blume 330 in
630 : blume 340 case SymbolMap.find (slexp, sy) of
631 : blume 330 SOME ((_, DG.SB_BNODE (n as DG.BNODE _)), _) => n
632 :     | _ => raise Format
633 :     end
634 :     | _ => raise Format
635 : blume 306
636 : blume 330 (* this is the place where what used to be an
637 :     * SNODE changes to a BNODE! *)
638 :     fun r_sn_raw () =
639 :     DG.BNODE { bininfo = r_si (),
640 :     localimports = r_list r_sn (),
641 :     globalimports = r_list r_fsbn () }
642 : blume 306
643 : blume 330 and r_sn () =
644 :     r_share r_sn_raw UBN (fn (UBN n) => n | _ => raise Format) ()
645 : blume 306
646 : blume 330 (* this one changes from farsbnode to plain farbnode *)
647 :     and r_sbn () =
648 :     case rd () of
649 :     #"b" => r_bn ()
650 :     | #"s" => r_sn ()
651 :     | _ => raise Format
652 : blume 306
653 : blume 330 and r_fsbn () = (r_filter (), r_sbn ())
654 : blume 306
655 : blume 330 fun r_impexp () = let
656 :     val sy = r_symbol ()
657 :     val (f, n) = r_fsbn () (* really reads farbnodes! *)
658 :     val e = bn2env n
659 :     (* put a filter in front to avoid having the FCTENV being
660 :     * queried needlessly (this avoids spurious module loadings) *)
661 :     val e' = DAEnv.FILTER (SymbolSet.singleton sy, e)
662 :     in
663 :     (sy, ((f, DG.SB_BNODE n), e')) (* coerce to farsbnodes *)
664 :     end
665 :    
666 :     fun r_exports () =
667 :     foldl SymbolMap.insert' SymbolMap.empty (r_list r_impexp ())
668 :    
669 :     fun r_privileges () =
670 :     StringSet.addList (StringSet.empty, r_list r_string ())
671 :    
672 : blume 306 val exports = r_exports ()
673 :     val islib = r_bool ()
674 :     val required = r_privileges ()
675 : blume 308 val simap = genStableInfoMap (exports, group)
676 : blume 306 in
677 :     GG.GROUP { exports = exports,
678 :     islib = islib,
679 :     required = required,
680 : blume 308 grouppath = group,
681 : blume 340 sublibs = sublibs,
682 : blume 307 stableinfo = GG.STABLE simap }
683 : blume 310 before BinIO.closeIn s
684 : blume 306 end
685 : blume 304 in
686 : blume 310 SOME (unpickle_group ())
687 :     handle Format => (BinIO.closeIn s; NONE)
688 :     | exn => (BinIO.closeIn s; raise exn)
689 :     end handle IO.Io _ => NONE
690 : blume 304 end
691 : blume 309
692 :     end (* local *)

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