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

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