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

1 : blume 304 structure Stablize = struct
2 :    
3 :     structure DG = DependencyGraph
4 : blume 306 structure GG = GroupGraph
5 :     structure EM = GenericVC.ErrorMsg
6 : blume 304
7 :     datatype item =
8 :     SS of SymbolSet.set
9 :     | S of Symbol.symbol
10 : blume 306 | SI of SmlInfo.info (* only used during pickling *)
11 : blume 304 | AP of AbsPath.t
12 : blume 306 | BI of BinInfo.info (* only used during unpickling *)
13 : blume 304
14 :     fun compare (S s, S s') = SymbolOrdKey.compare (s, s')
15 :     | compare (S _, _) = GREATER
16 :     | compare (_, S _) = LESS
17 :     | compare (SS s, SS s') = SymbolSet.compare (s, s')
18 :     | compare (SS _, _) = GREATER
19 :     | compare (_, SS _) = LESS
20 :     | compare (SI i, SI i') = SmlInfo.compare (i, i')
21 :     | compare (SI _, _) = GREATER
22 :     | compare (_, SI _) = LESS
23 :     | compare (AP p, AP p') = AbsPath.compare (p, p')
24 : blume 306 | compare (AP _, _) = GREATER
25 :     | compare (_, AP _) = LESS
26 :     | compare (BI i, BI i') = BinInfo.compare (i, i')
27 : blume 304
28 :     structure Map =
29 :     BinaryMapFn (struct
30 :     type ord_key = item
31 :     val compare = compare
32 :     end)
33 :    
34 : blume 306 fun stabilize (g as GG.GROUP grec, binSizeOf, binCopy, gp) =
35 :     case #stableinfo grec of
36 :     GG.STABLE _ => g
37 :     | GG.NONSTABLE granted => let
38 : blume 304
39 : blume 306 val exports = #exports grec
40 : blume 304
41 : blume 306 (* The format of a stable archive is the following:
42 :     * - It starts with the size s of the pickled dependency
43 :     * graph. This size itself is written as four-byte string.
44 :     * - The pickled dependency graph. This graph contains
45 :     * integer offsets of the binfiles for the individual ML
46 :     * members. These offsets need to be adjusted by adding
47 :     * s + 4. The pickled dependency graph also contains integer
48 :     * offsets relative to other stable groups. These offsets
49 :     * need no further adjustment.
50 :     * - Individual binfile contents (concatenated).
51 :     *)
52 :     val members = let
53 :     fun sn (DG.SNODE { smlinfo, localimports = l, ... }, s) =
54 :     if SmlInfoSet.member (s, smlinfo) then s
55 :     else foldl sn (SmlInfoSet.add (s, smlinfo)) l
56 :     fun impexp (((_, DG.SB_BNODE _), _), s) = s
57 :     | impexp (((_, DG.SB_SNODE n), _), s) = sn (n, s)
58 :     in
59 :     SmlInfoSet.listItems
60 :     (SymbolMap.foldl impexp SmlInfoSet.empty exports)
61 :     end
62 : blume 304
63 : blume 306 val offsetDict = let
64 :     fun add (i, (d, n)) =
65 :     (SmlInfoMap.insert (d, i, n), n + binSizeOf i)
66 :     in
67 :     #1 (foldl add (SmlInfoMap.empty, 0) members)
68 :     end
69 : blume 304
70 : blume 306 fun w_list w_item [] k m = "0" :: k m
71 :     | w_list w_item [a] k m = "1" :: w_item a k m
72 :     | w_list w_item [a, b] k m = "2" :: w_item a (w_item b k) m
73 :     | w_list w_item [a, b, c] k m =
74 :     "3" :: w_item a (w_item b (w_item c k)) m
75 :     | w_list w_item [a, b, c, d] k m =
76 :     "4" :: w_item a (w_item b (w_item c (w_item d k))) m
77 :     | w_list w_item (a :: b :: c :: d :: e :: r) k m =
78 :     "5" :: w_item a (w_item b (w_item c (w_item d (w_item e
79 :     (w_list w_item r k))))) m
80 : blume 304
81 : blume 306 fun w_option w_item NONE k m = "n" :: k m
82 :     | w_option w_item (SOME i) k m = "s" :: w_item i k m
83 : blume 304
84 : blume 306 fun int_encode i = let
85 :     (* this is the same mechanism that's also used in
86 :     * TopLevel/batch/binfile.sml (maybe we should share it) *)
87 :     val n = Word32.fromInt i
88 :     val // = LargeWord.div
89 :     val %% = LargeWord.mod
90 :     val !! = LargeWord.orb
91 :     infix // %% !!
92 :     val toW8 = Word8.fromLargeWord
93 :     fun r (0w0, l) = Word8Vector.fromList l
94 :     | r (n, l) =
95 :     r (n // 0w128, toW8 ((n %% 0w128) !! 0w128) :: l)
96 :     in
97 :     Byte.bytesToString (r (n // 0w128, [toW8 (n %% 0w128)]))
98 :     end
99 : blume 304
100 : blume 306 fun w_int i k m = int_encode i :: k m
101 : blume 304
102 : blume 306 fun w_share w C v k (i, m) =
103 :     case Map.find (m, C v) of
104 :     SOME i' => "o" :: w_int i' k (i, m)
105 :     | NONE => "n" :: w v k (i + 1, Map.insert (m, C v, i))
106 : blume 304
107 : blume 306 fun w_symbol_raw s k m = let
108 :     val ns = case Symbol.nameSpace s of
109 :     Symbol.SIGspace => "'"
110 :     | Symbol.FCTspace => "("
111 :     | Symbol.FSIGspace => ")"
112 :     | Symbol.STRspace => ""
113 :     | _ => GenericVC.ErrorMsg.impossible "stabilize:w_symbol"
114 :     in
115 :     ns :: Symbol.name s :: "." :: k m
116 :     end
117 : blume 304
118 : blume 306 val w_symbol = w_share w_symbol_raw S
119 : blume 304
120 : blume 306 val w_ss = w_share (w_list w_symbol o SymbolSet.listItems) SS
121 :    
122 :     val w_filter = w_option w_ss
123 :    
124 :     fun w_string s k m = let
125 :     fun esc #"\\" = "\\\\"
126 :     | esc #"\"" = "\\\""
127 :     | esc c = String.str c
128 : blume 304
129 : blume 306 in
130 :     String.translate esc s :: "\"" :: k m
131 :     end
132 :    
133 :     fun w_sharing NONE k m = "n" :: k m
134 :     | w_sharing (SOME true) k m = "t" :: k m
135 :     | w_sharing (SOME false) k m = "f" :: k m
136 :    
137 :     fun w_si_raw i k = let
138 :     val spec = AbsPath.spec (SmlInfo.sourcepath i)
139 :     val locs = SmlInfo.errorLocation gp i
140 :     val offset = valOf (SmlInfoMap.find (offsetDict, i))
141 :     in
142 :     w_string spec
143 :     (w_string locs
144 :     (w_int offset
145 :     (w_sharing (SmlInfo.share i) k)))
146 :     end
147 :    
148 :     val w_si = w_share w_si_raw SI
149 :    
150 :     fun w_primitive p k m = String.str (Primitive.toIdent p) :: k m
151 :    
152 :     fun w_abspath_raw p k m =
153 :     w_list w_string (AbsPath.pickle p) k m
154 :    
155 :     val w_abspath = w_share w_abspath_raw AP
156 :    
157 :     fun w_bn (DG.PNODE p) k m = "p" :: w_primitive p k m
158 :     | w_bn (DG.BNODE { bininfo = i, ... }) k m =
159 :     "b" :: w_abspath (BinInfo.group i)
160 :     (w_int (BinInfo.offset i) k) m
161 :    
162 :     fun w_sn (DG.SNODE n) k =
163 :     w_si (#smlinfo n)
164 :     (w_list w_sn (#localimports n)
165 :     (w_list w_fsbn (#globalimports n) k))
166 :    
167 :     and w_sbn (DG.SB_BNODE n) k m = "b" :: w_bn n k m
168 :     | w_sbn (DG.SB_SNODE n) k m = "s" :: w_sn n k m
169 :    
170 :     and w_fsbn (f, n) k = w_filter f (w_sbn n k)
171 :    
172 :     fun w_impexp (s, (n, _)) k = w_symbol s (w_fsbn n k)
173 :    
174 :     fun w_exports e = w_list w_impexp (SymbolMap.listItemsi e)
175 :    
176 :     fun w_bool true k m = "t" :: k m
177 :     | w_bool false k m = "f" :: k m
178 :    
179 :     fun w_privileges p = w_list w_string (StringSet.listItems p)
180 :    
181 :     fun pickle_group (GG.GROUP g, granted) = let
182 :     fun w_sg (GG.GROUP g) = w_abspath (#grouppath g)
183 :     val req' = StringSet.difference (#required g, granted)
184 :     fun k0 m = []
185 :     val m0 = (0, Map.empty)
186 :     in
187 :     concat
188 :     (w_exports (#exports g)
189 :     (w_bool (#islib g)
190 :     (w_privileges req'
191 :     (w_abspath (#grouppath g)
192 :     (w_list w_sg (#subgroups g) k0)))) m0)
193 :     end
194 :     val pickle = pickle_group (g, granted)
195 :     val sz = size pickle
196 :     in
197 :     Dummy.f ()
198 :     end
199 :    
200 :     fun g (getGroup, fsbn2env, knownStable, grpSrcInfo, group, s) = let
201 :    
202 :     exception Format
203 :    
204 :     (* for getting sharing right... *)
205 :     val m = ref IntBinaryMap.empty
206 :     val next = ref 0
207 :    
208 :     (* to build the stable info *)
209 :     val simap = ref IntBinaryMap.empty
210 :    
211 :     fun bytesIn n = let
212 :     val bv = BinIO.inputN (s, n)
213 : blume 304 in
214 : blume 306 if n = Word8Vector.length bv then bv
215 :     else raise Format
216 : blume 304 end
217 :    
218 : blume 306 val sz = LargeWord.toIntX (Pack32Big.subVec (bytesIn 4, 0))
219 :     val pickle = bytesIn sz
220 :     val offset_adjustment = sz + 4
221 : blume 304
222 : blume 306 val rd = let
223 :     val pos = ref 0
224 :     fun rd () = let
225 :     val p = !pos
226 :     in
227 :     pos := p + 1;
228 :     Byte.byteToChar (Word8Vector.sub (pickle, p))
229 :     handle _ => raise Format
230 :     end
231 : blume 304 in
232 : blume 306 rd
233 : blume 304 end
234 :    
235 : blume 306 fun r_list r () =
236 :     case rd () of
237 :     #"0" => []
238 :     | #"1" => [r ()]
239 :     | #"2" => [r (), r ()]
240 :     | #"3" => [r (), r (), r ()]
241 :     | #"4" => [r (), r (), r (), r ()]
242 :     | #"5" => r () :: r () :: r () :: r () :: r () :: r_list r ()
243 :     | _ => raise Format
244 : blume 304
245 : blume 306 fun r_bool () =
246 :     case rd () of
247 :     #"t" => true
248 :     | #"f" => false
249 :     | _ => raise Format
250 : blume 304
251 : blume 306 fun r_option r_item () =
252 :     case rd () of
253 :     #"n" => NONE
254 :     | #"s" => SOME (r_item ())
255 :     | _ => raise Format
256 : blume 304
257 : blume 306 fun r_int () = let
258 :     fun loop n = let
259 :     val w8 = Byte.charToByte (rd ())
260 :     val n' = n * 0w128 + Word8.toLargeWord (Word8.andb (w8, 0w127))
261 :     in
262 :     if Word8.andb (w8, 0w128) = 0w0 then n' else loop n'
263 :     end
264 :     in
265 :     LargeWord.toIntX (loop 0w0)
266 :     end
267 : blume 304
268 : blume 306 fun r_share r_raw C unC () =
269 :     case rd () of
270 :     #"o" => (case IntBinaryMap.find (!m, r_int ()) of
271 :     SOME x => unC x
272 :     | NONE => raise Format)
273 :     | #"n" => let
274 :     val i = !next
275 :     val _ = next := i + 1
276 :     val v = r_raw ()
277 :     in
278 :     m := IntBinaryMap.insert (!m, i, C v);
279 :     v
280 :     end
281 :     | _ => raise Format
282 : blume 304
283 : blume 306 fun r_string () = let
284 :     fun loop l =
285 :     case rd () of
286 :     #"\"" => String.implode (rev l)
287 :     | #"\\" => loop (rd () :: l)
288 :     | c => loop (c :: l)
289 :     in
290 :     loop []
291 :     end
292 : blume 304
293 : blume 306 val r_abspath = let
294 :     fun r_abspath_raw () =
295 :     case AbsPath.unpickle (r_list r_string ()) of
296 :     SOME p => p
297 :     | NONE => raise Format
298 :     fun unAP (AP x) = x
299 :     | unAP _ = raise Format
300 :     in
301 :     r_share r_abspath_raw AP unAP
302 :     end
303 : blume 304
304 : blume 306 val r_symbol = let
305 :     fun r_symbol_raw () = let
306 :     val (ns, first) =
307 :     case rd () of
308 :     #"`" => (Symbol.sigSymbol, rd ())
309 :     | #"(" => (Symbol.fctSymbol, rd ())
310 :     | #")" => (Symbol.fsigSymbol, rd ())
311 :     | c => (Symbol.strSymbol, c)
312 :     fun loop (#".", l) = String.implode (rev l)
313 :     | loop (c, l) = loop (rd (), c :: l)
314 :     in
315 :     ns (loop (first, []))
316 :     end
317 :     fun unS (S x) = x
318 :     | unS _ = raise Format
319 :     in
320 :     r_share r_symbol_raw S unS
321 :     end
322 : blume 304
323 : blume 306 val r_ss = let
324 :     fun r_ss_raw () =
325 :     SymbolSet.addList (SymbolSet.empty, r_list r_symbol ())
326 :     fun unSS (SS s) = s
327 :     | unSS _ = raise Format
328 :     in
329 :     r_share r_ss_raw SS unSS
330 :     end
331 : blume 304
332 : blume 306 val r_filter = r_option r_ss
333 : blume 305
334 : blume 306 fun r_primitive () =
335 :     case Primitive.fromIdent (rd ()) of
336 :     NONE => raise Format
337 :     | SOME p => p
338 : blume 305
339 : blume 306 fun r_sharing () =
340 :     case rd () of
341 :     #"n" => NONE
342 :     | #"t" => SOME true
343 :     | #"f" => SOME false
344 :     | _ => raise Format
345 : blume 305
346 : blume 306 val r_si = let
347 :     fun r_si_raw () = let
348 :     val spec = r_string ()
349 :     val locs = r_string ()
350 :     val offset = r_int () + offset_adjustment
351 :     val share = r_sharing ()
352 :     val error = EM.errorNoSource grpSrcInfo locs
353 :     val i = BinInfo.new { group = group,
354 :     error = error,
355 :     spec = spec,
356 :     offset = offset,
357 :     share = share }
358 :     in
359 :     simap := IntBinaryMap.insert (!simap, offset, i);
360 :     i
361 :     end
362 :     fun unBI (BI i) = i
363 :     | unBI _ = raise Format
364 :     in
365 :     r_share r_si_raw BI unBI
366 :     end
367 : blume 305
368 : blume 306 fun r_bn () =
369 :     case rd () of
370 :     #"p" => DG.PNODE (r_primitive ())
371 :     | #"b" =>
372 :     (case AbsPathMap.find (knownStable, r_abspath ()) of
373 :     NONE => raise Format
374 :     | SOME im =>
375 :     (case IntBinaryMap.find (im, r_int ()) of
376 :     NONE => raise Format
377 :     | SOME n => n))
378 :     | _ => raise Format
379 :    
380 :     (* this is the place where what used to be an
381 :     * SNODE changes to a BNODE! *)
382 :     fun r_sn () =
383 :     DG.BNODE { bininfo = r_si (),
384 :     localimports = r_list r_sn (),
385 :     globalimports = r_list r_fsbn () }
386 :    
387 :     (* this one changes from farsbnode to plain farbnode *)
388 :     and r_sbn () =
389 :     case rd () of
390 :     #"b" => r_bn ()
391 :     | #"s" => r_sn ()
392 :     | _ => raise Format
393 :    
394 :     and r_fsbn () = (r_filter (), r_sbn ())
395 :    
396 :     fun r_impexp () = let
397 :     val sy = r_symbol ()
398 :     val (f, n) = r_fsbn () (* really reads farbnodes! *)
399 :     val e = fsbn2env n
400 : blume 305 in
401 : blume 306 (sy, ((f, DG.SB_BNODE n), e)) (* coerce to farsbnodes *)
402 : blume 305 end
403 : blume 306
404 :     fun r_exports () =
405 :     foldl SymbolMap.insert' SymbolMap.empty (r_list r_impexp ())
406 :    
407 :     fun r_privileges () =
408 :     StringSet.addList (StringSet.empty, r_list r_string ())
409 :    
410 :     fun unpickle_group () = let
411 :     val exports = r_exports ()
412 :     val islib = r_bool ()
413 :     val required = r_privileges ()
414 :     val grouppath = r_abspath ()
415 :     val subgroups = r_list (getGroup o r_abspath) ()
416 :     fun add (((_, DG.SB_BNODE (DG.BNODE { bininfo, ... })), _), s) =
417 :     IntBinarySet.add (s, BinInfo.offset bininfo)
418 :     | add (_, s) = s
419 :     val ens = SymbolMap.foldl add IntBinarySet.empty exports
420 :     fun isExported (os, _) = IntBinarySet.member (ens, os)
421 :     val final_simap = IntBinaryMap.filteri isExported (!simap)
422 :     in
423 :     GG.GROUP { exports = exports,
424 :     islib = islib,
425 :     required = required,
426 :     grouppath = grouppath,
427 :     subgroups = subgroups,
428 :     stableinfo = GG.STABLE final_simap }
429 :     end
430 : blume 304 in
431 : blume 306 SOME (unpickle_group ()) handle Format => NONE
432 : blume 304 end
433 :     end

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