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

1 : blume 304 structure Stablize = struct
2 :    
3 :     structure DG = DependencyGraph
4 :    
5 :     datatype item =
6 :     SS of SymbolSet.set
7 :     | S of Symbol.symbol
8 :     | SI of SmlInfo.info
9 :     | AP of AbsPath.t
10 :    
11 :     fun compare (S s, S s') = SymbolOrdKey.compare (s, s')
12 :     | compare (S _, _) = GREATER
13 :     | compare (_, S _) = LESS
14 :     | compare (SS s, SS s') = SymbolSet.compare (s, s')
15 :     | compare (SS _, _) = GREATER
16 :     | compare (_, SS _) = LESS
17 :     | compare (SI i, SI i') = SmlInfo.compare (i, i')
18 :     | compare (SI _, _) = GREATER
19 :     | compare (_, SI _) = LESS
20 :     | compare (AP p, AP p') = AbsPath.compare (p, p')
21 :    
22 :     structure Map =
23 :     BinaryMapFn (struct
24 :     type ord_key = item
25 :     val compare = compare
26 :     end)
27 :    
28 :     structure SmlInfoSet =
29 :     BinarySetFn (struct
30 :     type ord_key = SmlInfo.info
31 :     val compare = SmlInfo.compare
32 :     end)
33 :    
34 :     fun f (GroupGraph.GROUP { exports, ... }, binSizeOf, binCopy) = let
35 :     (* The format of a stable archive is the following:
36 :     * - It starts with the size s of the pickled dependency graph.
37 :     * This size itself is written as four-byte string.
38 :     * - The pickled dependency graph. This graph contains integer
39 :     * offsets of the binfiles for the individual ML members.
40 :     * These offsets need to be adjusted by adding s + 4.
41 :     * The pickled dependency graph also contains integer offsets
42 :     * relative to other stable groups. These offsets need no
43 :     * further adjustment.
44 :     * - Individual binfile contents (concatenated).
45 :     *)
46 :     val members = let
47 :     fun sn (DG.SNODE { smlinfo = i, localimports = l, ... }, s) =
48 :     if SmlInfoSet.member (s, i) then s
49 :     else foldl sn (SmlInfoSet.add (s, i)) l
50 :     fun impexp (((_, DG.SB_BNODE _), _), s) = s
51 :     | impexp (((_, DG.SB_SNODE n), _), s) = sn (n, s)
52 :     in
53 :     SmlInfoSet.listItems
54 :     (SymbolMap.foldl impexp SmlInfoSet.empty exports)
55 :     end
56 :    
57 :     val offsetDict = let
58 :     fun add (i, (d, n)) = let
59 :     val spec = AbsPath.spec (SmlInfo.sourcepath i)
60 :     in
61 :     (StringMap.insert (d, spec, n), n + binSizeOf i)
62 :     end
63 :     in
64 :     #1 (foldl add (StringMap.empty, 0) members)
65 :     end
66 :    
67 :     fun w_list w_item [] k m = ";" :: k m
68 :     | w_list w_item (h :: t) k m = w_item h (w_list w_item t k) m
69 :    
70 :     fun w_option w_item NONE k m = "n" :: k m
71 :     | w_option w_item (SOME i) k m = "s" :: w_item i k m
72 :    
73 :     fun int_encode i = let
74 :     (* this is the same mechanism that's also used in
75 :     * TopLevel/batch/binfile.sml -- maybe we should share it *)
76 :     val n = Word32.fromInt i
77 :     val // = LargeWord.div
78 :     val %% = LargeWord.mod
79 :     val !! = LargeWord.orb
80 :     infix // %% !!
81 :     val toW8 = Word8.fromLargeWord
82 :     fun r (0w0, l) = Word8Vector.fromList l
83 :     | r (n, l) = r (n // 0w128, toW8 ((n %% 0w128) !! 0w128) :: l)
84 :     in
85 :     Byte.bytesToString (r (n // 0w128, [toW8 (n %% 0w128)]))
86 :     end
87 :    
88 :     fun w_int i k m = int_encode i :: k m
89 :    
90 :     fun w_share w C v k (i, m) =
91 :     case Map.find (m, C v) of
92 :     SOME i' => "o" :: w_int i' k (i, m)
93 :     | NONE => "n" :: w_int i (w v k) (i + 1, Map.insert (m, C v, i))
94 :    
95 :     fun w_symbol_raw s k m = SkelIO.w_name (s, k m)
96 :    
97 :     val w_symbol = w_share w_symbol_raw S
98 :    
99 :     val w_ss = w_share (w_list w_symbol o SymbolSet.listItems) SS
100 :    
101 :     val w_filter = w_option w_ss
102 :    
103 :     fun w_string s k m = let
104 :     fun esc #"\\" = "\\\\"
105 :     | esc #"\"" = "\\\""
106 :     | esc c = String.str c
107 :    
108 :     in
109 :     String.translate esc s :: "\"" :: k m
110 :     end
111 :    
112 :     fun w_sharing NONE k m = "n" :: k m
113 :     | w_sharing (SOME true) k m = "t" :: k m
114 :     | w_sharing (SOME false) k m = "f" :: k m
115 :    
116 :     fun w_si_raw i k = let
117 :     val spec = AbsPath.pickleSpec (SmlInfo.sourcepath i)
118 :     val offset = valOf (StringMap.find (offsetDict, spec))
119 :     in
120 :     w_string spec (w_int offset (w_sharing (SmlInfo.share i) k))
121 :     end
122 :    
123 :     val w_si = w_share w_si_raw SI
124 :    
125 :     fun w_primitive p k m = String.str (Primitive.toIdent p) :: k m
126 :    
127 :     fun w_abspath_raw p k m = w_string (AbsPath.pickle p) k m
128 :    
129 :     val w_abspath = w_share w_abspath_raw AP
130 :    
131 :     fun w_bi i k = w_abspath (BinInfo.group i) (w_int (BinInfo.offset i) k)
132 :    
133 :     fun w_bn (DG.PNODE p) k m = "p" :: w_primitive p k m
134 :     | w_bn (DG.BNODE { bininfo, ... }) k m = "b" :: w_bi bininfo k m
135 :    
136 :     fun w_sn (DG.SNODE n) k =
137 :     w_si (#smlinfo n)
138 :     (w_list w_sn (#localimports n)
139 :     (w_list w_fsbn (#globalimports n) k))
140 :    
141 :     and w_sbn (DG.SB_BNODE n) = w_bn n
142 :     | w_sbn (DG.SB_SNODE n) = GenericVC.ErrorMsg.impossible
143 :     "stabilize: non-stabilized subgroup? (2)"
144 :    
145 :     and w_fsbn (f, n) k = w_filter f (w_sbn n k)
146 :    
147 :     fun w_impexp (n, _) k = w_fsbn n k
148 :     in
149 :     ()
150 :     end
151 :     end

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