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 309 - (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 309 structure GP = GeneralParams
13 :     structure E = GenericVC.Environment
14 :     in
15 : blume 304
16 : blume 309 signature STABILIZE = sig
17 :    
18 :     val loadStable :
19 :     GP.info * (AbsPath.t -> GG.group) ->
20 :     { group: AbsPath.t, s: BinIO.instream, anyerrors: bool ref } ->
21 :     GG.group option
22 :    
23 :     val stabilize :
24 :     GP.info ->
25 :     { group: GG.group, s: BinIO.outstream, anyerrors: bool ref } ->
26 :     GG.group
27 :     end
28 :    
29 :     functor StablizeFn
30 :     (val bn2statenv : GP.info -> DG.bnode -> E.staticEnv
31 :     val binSizeOf : SmlInfo.info -> int
32 :     val copyBin : BinIO.outstream -> SmlInfo.info -> unit) :> STABILIZE =
33 :     struct
34 :    
35 :    
36 : blume 307 datatype pitem =
37 :     PSS of SymbolSet.set
38 :     | PS of Symbol.symbol
39 :     | PSN of DG.snode
40 :     | PAP of AbsPath.t
41 : blume 304
42 : blume 307 datatype uitem =
43 :     USS of SymbolSet.set
44 :     | US of Symbol.symbol
45 :     | UBN of DG.bnode
46 :     | UAP of AbsPath.t
47 : blume 304
48 : blume 307 fun compare (PS s, PS s') = SymbolOrdKey.compare (s, s')
49 :     | compare (PS _, _) = GREATER
50 :     | compare (_, PS _) = LESS
51 :     | compare (PSS s, PSS s') = SymbolSet.compare (s, s')
52 :     | compare (PSS _, _) = GREATER
53 :     | compare (_, PSS _) = LESS
54 :     | compare (PSN (DG.SNODE n), PSN (DG.SNODE n')) =
55 :     SmlInfo.compare (#smlinfo n, #smlinfo n')
56 :     | compare (PSN _, _) = GREATER
57 :     | compare (_, PSN _) = LESS
58 :     | compare (PAP p, PAP p') = AbsPath.compare (p, p')
59 :    
60 : blume 304 structure Map =
61 :     BinaryMapFn (struct
62 : blume 307 type ord_key = pitem
63 : blume 304 val compare = compare
64 :     end)
65 :    
66 : blume 308 fun genStableInfoMap (exports, group) = let
67 :     (* find all the exported bnodes that are in the same group: *)
68 :     fun add (((_, DG.SB_BNODE (n as DG.BNODE b)), _), m) = let
69 :     val i = #bininfo b
70 :     in
71 :     if AbsPath.compare (BinInfo.group i, group) = EQUAL then
72 :     IntBinaryMap.insert (m, BinInfo.offset i, n)
73 :     else m
74 :     end
75 :     | add (_, m) = m
76 :     in
77 :     SymbolMap.foldl add IntBinaryMap.empty exports
78 :     end
79 :    
80 : blume 309 fun stabilize gp { group = g as GG.GROUP grec, s = outs, anyerrors } =
81 : blume 306 case #stableinfo grec of
82 :     GG.STABLE _ => g
83 :     | GG.NONSTABLE granted => let
84 : blume 304
85 : blume 309 val grpSrcInfo = (#errcons gp, anyerrors)
86 : blume 308
87 : blume 306 val exports = #exports grec
88 : blume 308 val islib = #islib grec
89 :     val required = StringSet.difference (#required grec,
90 :     granted)
91 :     val grouppath = #grouppath grec
92 :     val subgroups = #subgroups grec
93 : blume 304
94 : blume 306 (* The format of a stable archive is the following:
95 :     * - It starts with the size s of the pickled dependency
96 :     * graph. This size itself is written as four-byte string.
97 :     * - The pickled dependency graph. This graph contains
98 :     * integer offsets of the binfiles for the individual ML
99 :     * members. These offsets need to be adjusted by adding
100 :     * s + 4. The pickled dependency graph also contains integer
101 :     * offsets relative to other stable groups. These offsets
102 :     * need no further adjustment.
103 :     * - Individual binfile contents (concatenated).
104 :     *)
105 : blume 304
106 : blume 307 val members = ref []
107 : blume 308 val (registerOffset, getOffset) = let
108 :     val dict = ref SmlInfoMap.empty
109 : blume 307 val cur = ref 0
110 :     fun reg (i, sz) = let
111 :     val os = !cur
112 :     in
113 :     cur := os + sz;
114 : blume 308 dict := SmlInfoMap.insert (!dict, i, os);
115 : blume 307 members := i :: (!members);
116 :     os
117 :     end
118 : blume 308 fun get i = valOf (SmlInfoMap.find (!dict, i))
119 : blume 306 in
120 : blume 308 (reg, get)
121 : blume 306 end
122 : blume 304
123 : blume 307 fun w_list w_item [] k m =
124 :     "0" :: k m
125 :     | w_list w_item [a] k m =
126 :     "1" :: w_item a k m
127 :     | w_list w_item [a, b] k m =
128 :     "2" :: w_item a (w_item b k) m
129 : blume 306 | w_list w_item [a, b, c] k m =
130 :     "3" :: w_item a (w_item b (w_item c k)) m
131 :     | w_list w_item [a, b, c, d] k m =
132 :     "4" :: w_item a (w_item b (w_item c (w_item d k))) m
133 :     | w_list w_item (a :: b :: c :: d :: e :: r) k m =
134 :     "5" :: w_item a (w_item b (w_item c (w_item d (w_item e
135 : blume 307 (w_list w_item r k))))) m
136 : blume 304
137 : blume 306 fun w_option w_item NONE k m = "n" :: k m
138 :     | w_option w_item (SOME i) k m = "s" :: w_item i k m
139 : blume 304
140 : blume 306 fun int_encode i = let
141 :     (* this is the same mechanism that's also used in
142 :     * TopLevel/batch/binfile.sml (maybe we should share it) *)
143 :     val n = Word32.fromInt i
144 :     val // = LargeWord.div
145 :     val %% = LargeWord.mod
146 :     val !! = LargeWord.orb
147 :     infix // %% !!
148 :     val toW8 = Word8.fromLargeWord
149 :     fun r (0w0, l) = Word8Vector.fromList l
150 :     | r (n, l) =
151 :     r (n // 0w128, toW8 ((n %% 0w128) !! 0w128) :: l)
152 :     in
153 :     Byte.bytesToString (r (n // 0w128, [toW8 (n %% 0w128)]))
154 :     end
155 : blume 304
156 : blume 306 fun w_int i k m = int_encode i :: k m
157 : blume 304
158 : blume 306 fun w_share w C v k (i, m) =
159 :     case Map.find (m, C v) of
160 :     SOME i' => "o" :: w_int i' k (i, m)
161 :     | NONE => "n" :: w v k (i + 1, Map.insert (m, C v, i))
162 : blume 304
163 : blume 306 fun w_symbol_raw s k m = let
164 :     val ns = case Symbol.nameSpace s of
165 :     Symbol.SIGspace => "'"
166 :     | Symbol.FCTspace => "("
167 :     | Symbol.FSIGspace => ")"
168 :     | Symbol.STRspace => ""
169 :     | _ => GenericVC.ErrorMsg.impossible "stabilize:w_symbol"
170 :     in
171 :     ns :: Symbol.name s :: "." :: k m
172 :     end
173 : blume 304
174 : blume 307 val w_symbol = w_share w_symbol_raw PS
175 : blume 304
176 : blume 307 val w_ss = w_share (w_list w_symbol o SymbolSet.listItems) PSS
177 : blume 306
178 :     val w_filter = w_option w_ss
179 :    
180 :     fun w_string s k m = let
181 :     fun esc #"\\" = "\\\\"
182 :     | esc #"\"" = "\\\""
183 :     | esc c = String.str c
184 : blume 304
185 : blume 306 in
186 :     String.translate esc s :: "\"" :: k m
187 :     end
188 :    
189 :     fun w_sharing NONE k m = "n" :: k m
190 :     | w_sharing (SOME true) k m = "t" :: k m
191 :     | w_sharing (SOME false) k m = "f" :: k m
192 :    
193 : blume 307 fun w_si i k = let
194 : blume 306 val spec = AbsPath.spec (SmlInfo.sourcepath i)
195 :     val locs = SmlInfo.errorLocation gp i
196 : blume 307 val offset = registerOffset (i, binSizeOf i)
197 : blume 306 in
198 :     w_string spec
199 :     (w_string locs
200 :     (w_int offset
201 :     (w_sharing (SmlInfo.share i) k)))
202 :     end
203 :    
204 :     fun w_primitive p k m = String.str (Primitive.toIdent p) :: k m
205 :    
206 :     fun w_abspath_raw p k m =
207 :     w_list w_string (AbsPath.pickle p) k m
208 :    
209 : blume 307 val w_abspath = w_share w_abspath_raw PAP
210 : blume 306
211 :     fun w_bn (DG.PNODE p) k m = "p" :: w_primitive p k m
212 :     | w_bn (DG.BNODE { bininfo = i, ... }) k m =
213 :     "b" :: w_abspath (BinInfo.group i)
214 :     (w_int (BinInfo.offset i) k) m
215 :    
216 : blume 307 fun w_sn_raw (DG.SNODE n) k =
217 : blume 306 w_si (#smlinfo n)
218 :     (w_list w_sn (#localimports n)
219 :     (w_list w_fsbn (#globalimports n) k))
220 :    
221 : blume 307 and w_sn n = w_share w_sn_raw PSN n
222 :    
223 : blume 306 and w_sbn (DG.SB_BNODE n) k m = "b" :: w_bn n k m
224 :     | w_sbn (DG.SB_SNODE n) k m = "s" :: w_sn n k m
225 :    
226 :     and w_fsbn (f, n) k = w_filter f (w_sbn n k)
227 :    
228 :     fun w_impexp (s, (n, _)) k = w_symbol s (w_fsbn n k)
229 :    
230 :     fun w_exports e = w_list w_impexp (SymbolMap.listItemsi e)
231 :    
232 :     fun w_bool true k m = "t" :: k m
233 :     | w_bool false k m = "f" :: k m
234 :    
235 :     fun w_privileges p = w_list w_string (StringSet.listItems p)
236 :    
237 : blume 308 fun pickle_group () = let
238 : blume 306 fun w_sg (GG.GROUP g) = w_abspath (#grouppath g)
239 :     fun k0 m = []
240 :     val m0 = (0, Map.empty)
241 :     in
242 :     concat
243 : blume 308 (w_exports exports
244 :     (w_bool islib
245 :     (w_privileges required
246 :     (w_list w_sg subgroups k0))) m0)
247 : blume 306 end
248 : blume 308
249 :     val pickle = pickle_group ()
250 : blume 306 val sz = size pickle
251 : blume 308 val offset_adjustment = sz + 4
252 :    
253 :     fun mkStableGroup () = let
254 :     val m = ref SmlInfoMap.empty
255 :     fun sn (DG.SNODE (n as { smlinfo, ... })) =
256 :     case SmlInfoMap.find (!m, smlinfo) of
257 :     SOME n => n
258 :     | NONE => let
259 :     val li = map sn (#localimports n)
260 :     val gi = map fsbn (#globalimports n)
261 :     val sourcepath = SmlInfo.sourcepath smlinfo
262 :     val spec = AbsPath.spec sourcepath
263 :     val offset =
264 :     getOffset smlinfo + offset_adjustment
265 :     val share = SmlInfo.share smlinfo
266 :     val locs = SmlInfo.errorLocation gp smlinfo
267 :     val error = EM.errorNoSource grpSrcInfo locs
268 :     val i = BinInfo.new { group = grouppath,
269 :     spec = spec,
270 :     offset = offset,
271 :     share = share,
272 :     error = error }
273 :     val n = DG.BNODE { bininfo = i,
274 :     localimports = li,
275 :     globalimports = gi }
276 :     in
277 :     m := SmlInfoMap.insert (!m, smlinfo, n);
278 :     n
279 :     end
280 :    
281 :     and sbn (DG.SB_SNODE n) = sn n
282 :     | sbn (DG.SB_BNODE n) = n
283 :    
284 :     and fsbn (f, n) = (f, sbn n)
285 :    
286 :     fun impexp ((f, n), e) = ((f, DG.SB_BNODE (sbn n)), e)
287 :    
288 :     val exports = SymbolMap.map impexp (#exports grec)
289 :     val simap = genStableInfoMap (exports, grouppath)
290 :     in
291 :     GG.GROUP { exports = exports,
292 :     islib = islib,
293 :     required = required,
294 :     grouppath = grouppath,
295 :     subgroups = subgroups,
296 :     stableinfo = GG.STABLE simap }
297 :     end
298 :    
299 :     fun writeInt32 (s, i) = let
300 :     val a = Word8Array.array (4, 0w0)
301 :     val _ = Pack32Big.update (a, 0, LargeWord.fromInt i)
302 :     in
303 :     BinIO.output (s, Word8Array.extract (a, 0, NONE))
304 :     end
305 : blume 306 in
306 : blume 308 writeInt32 (outs, sz);
307 :     BinIO.output (outs, Byte.stringToBytes pickle);
308 :     app (copyBin outs) (rev (!members));
309 :     mkStableGroup ()
310 : blume 306 end
311 :    
312 : blume 309 fun loadStable (gp, getGroup) { group, s, anyerrors } = let
313 : blume 306
314 : blume 309 val bn2env = #1 o Statenv2DAEnv.cvt o bn2statenv gp
315 : blume 308
316 : blume 309 val grpSrcInfo = (#errcons gp, anyerrors)
317 :    
318 : blume 306 exception Format
319 :    
320 :     (* for getting sharing right... *)
321 :     val m = ref IntBinaryMap.empty
322 :     val next = ref 0
323 :    
324 :     fun bytesIn n = let
325 :     val bv = BinIO.inputN (s, n)
326 : blume 304 in
327 : blume 306 if n = Word8Vector.length bv then bv
328 :     else raise Format
329 : blume 304 end
330 :    
331 : blume 306 val sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))
332 :     val pickle = bytesIn sz
333 :     val offset_adjustment = sz + 4
334 : blume 304
335 : blume 306 val rd = let
336 :     val pos = ref 0
337 :     fun rd () = let
338 :     val p = !pos
339 :     in
340 :     pos := p + 1;
341 :     Byte.byteToChar (Word8Vector.sub (pickle, p))
342 :     handle _ => raise Format
343 :     end
344 : blume 304 in
345 : blume 306 rd
346 : blume 304 end
347 :    
348 : blume 306 fun r_list r () =
349 :     case rd () of
350 :     #"0" => []
351 :     | #"1" => [r ()]
352 :     | #"2" => [r (), r ()]
353 :     | #"3" => [r (), r (), r ()]
354 :     | #"4" => [r (), r (), r (), r ()]
355 :     | #"5" => r () :: r () :: r () :: r () :: r () :: r_list r ()
356 :     | _ => raise Format
357 : blume 304
358 : blume 306 fun r_bool () =
359 :     case rd () of
360 :     #"t" => true
361 :     | #"f" => false
362 :     | _ => raise Format
363 : blume 304
364 : blume 306 fun r_option r_item () =
365 :     case rd () of
366 :     #"n" => NONE
367 :     | #"s" => SOME (r_item ())
368 :     | _ => raise Format
369 : blume 304
370 : blume 306 fun r_int () = let
371 :     fun loop n = let
372 :     val w8 = Byte.charToByte (rd ())
373 :     val n' = n * 0w128 + Word8.toLargeWord (Word8.andb (w8, 0w127))
374 :     in
375 :     if Word8.andb (w8, 0w128) = 0w0 then n' else loop n'
376 :     end
377 :     in
378 :     LargeWord.toIntX (loop 0w0)
379 :     end
380 : blume 304
381 : blume 306 fun r_share r_raw C unC () =
382 :     case rd () of
383 :     #"o" => (case IntBinaryMap.find (!m, r_int ()) of
384 :     SOME x => unC x
385 :     | NONE => raise Format)
386 :     | #"n" => let
387 :     val i = !next
388 :     val _ = next := i + 1
389 :     val v = r_raw ()
390 :     in
391 :     m := IntBinaryMap.insert (!m, i, C v);
392 :     v
393 :     end
394 :     | _ => raise Format
395 : blume 304
396 : blume 306 fun r_string () = let
397 :     fun loop l =
398 :     case rd () of
399 :     #"\"" => String.implode (rev l)
400 :     | #"\\" => loop (rd () :: l)
401 :     | c => loop (c :: l)
402 :     in
403 :     loop []
404 :     end
405 : blume 304
406 : blume 306 val r_abspath = let
407 :     fun r_abspath_raw () =
408 :     case AbsPath.unpickle (r_list r_string ()) of
409 :     SOME p => p
410 :     | NONE => raise Format
411 : blume 307 fun unUAP (UAP x) = x
412 :     | unUAP _ = raise Format
413 : blume 306 in
414 : blume 307 r_share r_abspath_raw UAP unUAP
415 : blume 306 end
416 : blume 304
417 : blume 306 val r_symbol = let
418 :     fun r_symbol_raw () = let
419 :     val (ns, first) =
420 :     case rd () of
421 :     #"`" => (Symbol.sigSymbol, rd ())
422 :     | #"(" => (Symbol.fctSymbol, rd ())
423 :     | #")" => (Symbol.fsigSymbol, rd ())
424 :     | c => (Symbol.strSymbol, c)
425 :     fun loop (#".", l) = String.implode (rev l)
426 :     | loop (c, l) = loop (rd (), c :: l)
427 :     in
428 :     ns (loop (first, []))
429 :     end
430 : blume 307 fun unUS (US x) = x
431 :     | unUS _ = raise Format
432 : blume 306 in
433 : blume 307 r_share r_symbol_raw US unUS
434 : blume 306 end
435 : blume 304
436 : blume 306 val r_ss = let
437 :     fun r_ss_raw () =
438 :     SymbolSet.addList (SymbolSet.empty, r_list r_symbol ())
439 : blume 307 fun unUSS (USS s) = s
440 :     | unUSS _ = raise Format
441 : blume 306 in
442 : blume 307 r_share r_ss_raw USS unUSS
443 : blume 306 end
444 : blume 304
445 : blume 306 val r_filter = r_option r_ss
446 : blume 305
447 : blume 306 fun r_primitive () =
448 :     case Primitive.fromIdent (rd ()) of
449 :     NONE => raise Format
450 :     | SOME p => p
451 : blume 305
452 : blume 306 fun r_sharing () =
453 :     case rd () of
454 :     #"n" => NONE
455 :     | #"t" => SOME true
456 :     | #"f" => SOME false
457 :     | _ => raise Format
458 : blume 305
459 : blume 307 fun r_si () = let
460 :     val spec = r_string ()
461 :     val locs = r_string ()
462 :     val offset = r_int () + offset_adjustment
463 :     val share = r_sharing ()
464 :     val error = EM.errorNoSource grpSrcInfo locs
465 : blume 306 in
466 : blume 307 BinInfo.new { group = group,
467 :     error = error,
468 :     spec = spec,
469 :     offset = offset,
470 :     share = share }
471 : blume 306 end
472 : blume 305
473 : blume 306 fun r_bn () =
474 :     case rd () of
475 :     #"p" => DG.PNODE (r_primitive ())
476 : blume 307 | #"b" => let
477 :     val p = r_abspath ()
478 :     val os = r_int ()
479 :     val GG.GROUP { stableinfo, ... } = getGroup p
480 :     in
481 :     case stableinfo of
482 :     GG.NONSTABLE _ => raise Format
483 :     | GG.STABLE im =>
484 :     (case IntBinaryMap.find (im, os) of
485 :     NONE => raise Format
486 :     | SOME n => n)
487 :     end
488 : blume 306 | _ => raise Format
489 :    
490 :     (* this is the place where what used to be an
491 :     * SNODE changes to a BNODE! *)
492 : blume 307 fun r_sn_raw () =
493 : blume 306 DG.BNODE { bininfo = r_si (),
494 :     localimports = r_list r_sn (),
495 :     globalimports = r_list r_fsbn () }
496 :    
497 : blume 307 and r_sn () =
498 :     r_share r_sn_raw UBN (fn (UBN n) => n | _ => raise Format) ()
499 :    
500 : blume 306 (* this one changes from farsbnode to plain farbnode *)
501 :     and r_sbn () =
502 :     case rd () of
503 :     #"b" => r_bn ()
504 :     | #"s" => r_sn ()
505 :     | _ => raise Format
506 :    
507 :     and r_fsbn () = (r_filter (), r_sbn ())
508 :    
509 :     fun r_impexp () = let
510 :     val sy = r_symbol ()
511 :     val (f, n) = r_fsbn () (* really reads farbnodes! *)
512 : blume 307 val e = bn2env n
513 : blume 305 in
514 : blume 306 (sy, ((f, DG.SB_BNODE n), e)) (* coerce to farsbnodes *)
515 : blume 305 end
516 : blume 306
517 :     fun r_exports () =
518 :     foldl SymbolMap.insert' SymbolMap.empty (r_list r_impexp ())
519 :    
520 :     fun r_privileges () =
521 :     StringSet.addList (StringSet.empty, r_list r_string ())
522 :    
523 :     fun unpickle_group () = let
524 :     val exports = r_exports ()
525 :     val islib = r_bool ()
526 :     val required = r_privileges ()
527 :     val subgroups = r_list (getGroup o r_abspath) ()
528 : blume 308 val simap = genStableInfoMap (exports, group)
529 : blume 306 in
530 :     GG.GROUP { exports = exports,
531 :     islib = islib,
532 :     required = required,
533 : blume 308 grouppath = group,
534 : blume 306 subgroups = subgroups,
535 : blume 307 stableinfo = GG.STABLE simap }
536 : blume 306 end
537 : blume 304 in
538 : blume 306 SOME (unpickle_group ()) handle Format => NONE
539 : blume 304 end
540 :     end
541 : blume 309
542 :     end (* local *)

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