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

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