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

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