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/compiler/Semant/pickle/pickmod-new.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/Semant/pickle/pickmod-new.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1548 - (view) (download)

1 : monnier 427 (*
2 :     * The revised pickler using the new "generic" pickling facility.
3 :     *
4 : blume 587 * March 2000, Matthias Blume
5 : monnier 427 *)
6 :     signature PICKMOD = sig
7 :    
8 : blume 587 (* There are three possible reasons to run the pickler. Each form
9 :     * of context (see datatype context below) corresponds to one of them:
10 :     *
11 :     * 1. The initial pickle. This is done right after a new static
12 :     * environment has been constructed by the elaborator. The context
13 :     * is used to identify those identifiers (ModuleId.<xxx>Id) that
14 :     * correspond to stubs. Only the domain of the given map is relevant
15 :     * here, but since we (usually) need the full map right afterwards
16 :     * for unpickling, there is no gain in using a set.
17 :     *
18 :     * 2. Pickling a previously pickled-and-unpickled environment from
19 :     * which some parts may have been pruned. This is used to calculate
20 :     * a new hash value that is equal to the hash obtained from an initial
21 :     * pickle (1.) of the environment if it had been pruned earlier.
22 :     * (This is used by the compilation manager's cutoff recompilation
23 :     * system. Pickles obtained here are never unpickled.)
24 :     * No actual context is necessary because stubification info is
25 :     * fully embedded in the environment to be pickled. However, we
26 :     * must provide the original pid obtained from the first pickling
27 :     * because occurences of that pid have to be treated the same way
28 : blume 588 * their "not-yet-occurrences" had been treated in step 1.
29 : blume 587 *
30 :     * 3. A set of environments that have already gone through an initial
31 :     * pickling-and-unpickling is pickled as part of a stable library.
32 :     * The context is a sequence of maps together with information of
33 :     * how to get hold of the same map later during unpickling.
34 :     * (The full context of a stable library is a set of other stable
35 :     * libraries, but during unpickling we want to avoid unpickling
36 :     * all of these other libraries in full.) *)
37 :     datatype context =
38 :     INITIAL of ModuleId.tmap
39 :     | REHASH of PersStamps.persstamp
40 : blume 632 | LIBRARY of ((int * Symbol.symbol) option * ModuleId.tmap) list
41 : monnier 427
42 : blume 587 type map
43 :     val emptyMap : map
44 : monnier 427
45 : blume 587 val envPickler : (Access.lvar -> unit) ->
46 :     context ->
47 :     (map, StaticEnv.staticEnv) PickleUtil.pickler
48 : monnier 427
49 : blume 587 val pickleEnv : context ->
50 :     StaticEnv.staticEnv ->
51 :     { hash: PersStamps.persstamp,
52 :     pickle: Word8Vector.vector,
53 :     exportLvars: Access.lvar list,
54 : blume 1058 hasExports: bool }
55 : monnier 504
56 : blume 879 val pickleFLINT: FLINT.prog option -> { hash: PersStamps.persstamp,
57 :     pickle: Word8Vector.vector }
58 : monnier 427
59 : blume 902 val symenvPickler : (map, SymbolicEnv.env) PickleUtil.pickler
60 : monnier 427
61 :     val pickle2hash: Word8Vector.vector -> PersStamps.persstamp
62 :    
63 :     val dontPickle :
64 : blume 1058 { env: StaticEnv.staticEnv, count: int } ->
65 :     { newenv: StaticEnv.staticEnv, hash: PersStamps.persstamp,
66 :     exportLvars: Access.lvar list, hasExports: bool }
67 : monnier 427 end
68 :    
69 : monnier 475 local
70 :     functor MapFn = RedBlackMapFn
71 :     structure IntMap = IntRedBlackMap
72 :     in
73 :     structure PickMod :> PICKMOD = struct
74 : monnier 427
75 : blume 587 datatype context =
76 :     INITIAL of ModuleId.tmap
77 :     | REHASH of PersStamps.persstamp
78 : blume 632 | LIBRARY of ((int * Symbol.symbol) option * ModuleId.tmap) list
79 : blume 587
80 : monnier 427 (* to gather some statistics... *)
81 :     val addPickles = Stats.addStat (Stats.makeStat "Pickle Bytes")
82 :    
83 :     fun bug msg = ErrorMsg.impossible ("PickMod: " ^ msg)
84 :    
85 :     structure A = Access
86 :     structure DI = DebIndex
87 :     structure LK = LtyKernel
88 :     structure PT = PrimTyc
89 :     structure F = FLINT
90 :     structure T = Types
91 :     structure SP = SymPath
92 :     structure IP = InvPath
93 :     structure MI = ModuleId
94 :     structure II = InlInfo
95 :     structure V = VarCon
96 :     structure ED = EntPath.EvDict
97 :     structure PS = PersStamps
98 :     structure P = PrimOp
99 :     structure M = Modules
100 :     structure B = Bindings
101 :    
102 :     (** NOTE: the CRC functions really ought to work on Word8Vector.vectors **)
103 :     fun pickle2hash pickle =
104 :     PS.fromBytes
105 :     (Byte.stringToBytes
106 :     (CRC.toString
107 :     (CRC.fromString
108 :     (Byte.bytesToString pickle))))
109 :    
110 :     fun symCmp (a, b) =
111 :     if Symbol.symbolGt (a, b) then GREATER
112 :     else if Symbol.eq (a, b) then EQUAL else LESS
113 :    
114 : monnier 475 structure LTMap = MapFn
115 : monnier 427 (struct type ord_key = LK.lty val compare = LK.lt_cmp end)
116 : monnier 475 structure TCMap = MapFn
117 : monnier 427 (struct type ord_key = LK.tyc val compare = LK.tc_cmp end)
118 : monnier 475 structure TKMap = MapFn
119 : monnier 427 (struct type ord_key = LK.tkind val compare = LK.tk_cmp end)
120 : blume 587 structure DTMap = StampMap
121 :     structure MBMap = StampMap
122 : monnier 439
123 : monnier 427 structure PU = PickleUtil
124 :     structure PSymPid = PickleSymPid
125 :    
126 :     type map =
127 :     { lt: PU.id LTMap.map,
128 :     tc: PU.id TCMap.map,
129 :     tk: PU.id TKMap.map,
130 :     dt: PU.id DTMap.map,
131 :     mb: PU.id MBMap.map,
132 : blume 587 mi: PU.id MI.umap }
133 : monnier 427
134 :     val emptyMap = { lt = LTMap.empty, tc = TCMap.empty, tk = TKMap.empty,
135 : blume 587 dt = DTMap.empty, mb = MBMap.empty, mi = MI.emptyUmap }
136 : monnier 427
137 :     (* type info *)
138 :     val (NK, AO, CO, PO, CS, A, CR, LT, TC, TK,
139 :     V, C, E, FK, RK, ST, MI, EQP, TYCKIND, DTI,
140 :     DTF, TYCON, T, II, VAR, SD, SG, FSG, SP, EN,
141 :     STR, F, STE, TCE, STRE, FE, EE, ED, EEV, FX,
142 :     B, DCON, DICT, FPRIM, FUNDEC, TFUNDEC, DATACON, DTMEM, NRD,
143 : leunga 1174 OVERLD, FCTC, SEN, FEN, SPATH, IPATH, STRID, FCTID, CCI, CTYPE,
144 :     CCALL_TYPE) =
145 : monnier 427 (1, 2, 3, 4, 5, 6, 7, 8, 9, 10,
146 :     11, 12, 13, 14, 15, 16, 17, 18, 19, 20,
147 :     21, 22, 23, 24, 25, 26, 27, 28, 29, 30,
148 :     31, 32, 33, 34, 35, 36, 37, 38, 39, 40,
149 :     41, 42, 43, 44, 45, 46, 47, 48, 49,
150 : leunga 1174 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60)
151 : monnier 427
152 :     (* this is a bit awful...
153 :     * (we really ought to have syntax for "functional update") *)
154 :     val LTs = { find = fn (m: map, x) => LTMap.find (#lt m, x),
155 :     insert = fn ({ lt, tc, tk, dt, mb, mi }, x, v) =>
156 :     { lt = LTMap.insert (lt, x, v),
157 :     tc = tc,
158 :     tk = tk,
159 :     dt = dt,
160 :     mb = mb,
161 :     mi = mi } }
162 :     val TCs = { find = fn (m: map, x) => TCMap.find (#tc m, x),
163 :     insert = fn ({ lt, tc, tk, dt, mb, mi }, x, v) =>
164 :     { lt = lt,
165 :     tc = TCMap.insert (tc, x, v),
166 :     tk = tk,
167 :     dt = dt,
168 :     mb = mb,
169 :     mi = mi } }
170 :     val TKs = { find = fn (m: map, x) => TKMap.find (#tk m, x),
171 :     insert = fn ({ lt, tc, tk, dt, mb, mi }, x, v) =>
172 :     { lt = lt,
173 :     tc = tc,
174 :     tk = TKMap.insert (tk, x, v),
175 :     dt = dt,
176 :     mb = mb,
177 :     mi = mi } }
178 :     fun DTs x = { find = fn (m: map, _) => DTMap.find (#dt m, x),
179 :     insert = fn ({ lt, tc, tk, dt, mb, mi }, _, v) =>
180 :     { lt = lt,
181 :     tc = tc,
182 :     tk = tk,
183 :     dt = DTMap.insert (dt, x, v),
184 :     mb = mb,
185 :     mi = mi } }
186 :     fun MBs x = { find = fn (m: map, _) => MBMap.find (#mb m, x),
187 :     insert = fn ({ lt, tc, tk, dt, mb, mi }, _, v) =>
188 :     { lt = lt,
189 :     tc = tc,
190 :     tk = tk,
191 :     dt = dt,
192 :     mb = MBMap.insert (mb, x, v),
193 :     mi = mi } }
194 : blume 587 fun TYCs id = { find = fn (m: map, _) => MI.uLookTyc (#mi m, id),
195 :     insert = fn ({ lt, tc, tk, dt, mb, mi }, _, v) =>
196 :     { lt = lt,
197 :     tc = tc,
198 :     tk = tk,
199 :     dt = dt,
200 :     mb = mb,
201 :     mi = MI.uInsertTyc (mi, id, v) } }
202 :     val SIGs = { find = fn (m: map, r) => MI.uLookSig (#mi m, MI.sigId r),
203 :     insert = fn ({ lt, tc, tk, dt, mb, mi }, r, v) =>
204 :     { lt = lt,
205 :     tc = tc,
206 :     tk = tk,
207 :     dt = dt,
208 :     mb = mb,
209 :     mi = MI.uInsertSig (mi, MI.sigId r, v) } }
210 :     fun STRs i = { find = fn (m: map, _) => MI.uLookStr (#mi m, i),
211 :     insert = fn ({ lt, tc, tk, dt, mb, mi }, _, v) =>
212 :     { lt = lt,
213 :     tc = tc,
214 :     tk = tk,
215 :     dt = dt,
216 :     mb = mb,
217 :     mi = MI.uInsertStr (mi, i, v) } }
218 :     fun FCTs i = { find = fn (m: map, _) => MI.uLookFct (#mi m, i),
219 :     insert = fn ({ lt, tc, tk, dt, mb, mi }, _, v) =>
220 :     { lt = lt,
221 :     tc = tc,
222 :     tk = tk,
223 :     dt = dt,
224 :     mb = mb,
225 :     mi = MI.uInsertFct (mi, i, v) } }
226 :     val ENVs = { find = fn (m: map, r) => MI.uLookEnv (#mi m, MI.envId r),
227 :     insert = fn ({ lt, tc, tk, dt, mb, mi }, r, v) =>
228 :     { lt = lt,
229 :     tc = tc,
230 :     tk = tk,
231 :     dt = dt,
232 :     mb = mb,
233 :     mi = MI.uInsertEnv (mi, MI.envId r, v) } }
234 : monnier 427
235 :     infix 3 $
236 :    
237 :     val int = PU.w_int
238 :     val int32 = PU.w_int32
239 :     val word = PU.w_word
240 :     val word32 = PU.w_word32
241 :     val string = PU.w_string
242 :     val share = PU.ah_share
243 :     val list = PU.w_list
244 :     val pair = PU.w_pair
245 :     val bool = PU.w_bool
246 :     val option = PU.w_option
247 :     val symbol = PSymPid.w_symbol
248 :     val pid = PSymPid.w_pid
249 :    
250 :     fun mkAlphaConvert () = let
251 : monnier 475 val m = ref IntMap.empty
252 : monnier 427 val cnt = ref 0
253 :     fun cvt i =
254 : monnier 475 case IntMap.find (!m, i) of
255 : monnier 427 SOME i' => i'
256 :     | NONE => let
257 :     val i' = !cnt
258 :     in
259 :     cnt := i' + 1;
260 : monnier 475 m := IntMap.insert (!m, i, i');
261 : monnier 427 i'
262 :     end
263 :     in
264 :     cvt
265 :     end
266 :    
267 :     fun numkind arg = let
268 :     val op $ = PU.$ NK
269 : blume 515 fun nk (P.INT i) = "A" $ [int i]
270 :     | nk (P.UINT i) = "B" $ [int i]
271 :     | nk (P.FLOAT i) = "C" $ [int i]
272 : monnier 427 in
273 :     nk arg
274 :     end
275 :    
276 :     fun arithop oper = let
277 : blume 515 val op $ = PU.$ AO
278 : monnier 427 fun arithopc P.+ = "\000"
279 :     | arithopc P.- = "\001"
280 :     | arithopc P.* = "\002"
281 :     | arithopc P./ = "\003"
282 :     | arithopc P.~ = "\004"
283 :     | arithopc P.ABS = "\005"
284 :     | arithopc P.LSHIFT = "\006"
285 :     | arithopc P.RSHIFT = "\007"
286 :     | arithopc P.RSHIFTL = "\008"
287 :     | arithopc P.ANDB = "\009"
288 :     | arithopc P.ORB = "\010"
289 :     | arithopc P.XORB = "\011"
290 :     | arithopc P.NOTB = "\012"
291 : george 717 | arithopc P.FSQRT = "\013"
292 :     | arithopc P.FSIN = "\014"
293 :     | arithopc P.FCOS = "\015"
294 :     | arithopc P.FTAN = "\016"
295 : blume 1183 | arithopc P.REM = "\017"
296 :     | arithopc P.DIV = "\018"
297 :     | arithopc P.MOD = "\019"
298 : monnier 427 in
299 : blume 515 arithopc oper $ []
300 : monnier 427 end
301 :    
302 :     fun cmpop oper = let
303 : blume 515 val op $ = PU.$ CO
304 : monnier 427 fun cmpopc P.> = "\000"
305 :     | cmpopc P.>= = "\001"
306 :     | cmpopc P.< = "\002"
307 :     | cmpopc P.<= = "\003"
308 :     | cmpopc P.LEU = "\004"
309 :     | cmpopc P.LTU = "\005"
310 :     | cmpopc P.GEU = "\006"
311 :     | cmpopc P.GTU = "\007"
312 :     | cmpopc P.EQL = "\008"
313 :     | cmpopc P.NEQ = "\009"
314 :     in
315 : blume 515 cmpopc oper $ []
316 : monnier 427 end
317 : blume 773
318 :     fun ctype t = let
319 :     val op $ = PU.$ CTYPE
320 :     fun ?n = String.str (Char.chr n)
321 :     fun %?n = ?n $ []
322 :     in
323 :     case t of
324 :     CTypes.C_void => %?0
325 :     | CTypes.C_float => %?1
326 :     | CTypes.C_double => %?2
327 :     | CTypes.C_long_double => %?3
328 :     | CTypes.C_unsigned CTypes.I_char => %?4
329 :     | CTypes.C_unsigned CTypes.I_short => %?5
330 :     | CTypes.C_unsigned CTypes.I_int => %?6
331 :     | CTypes.C_unsigned CTypes.I_long => %?7
332 :     | CTypes.C_unsigned CTypes.I_long_long => %?8
333 :     | CTypes.C_signed CTypes.I_char => %?9
334 :     | CTypes.C_signed CTypes.I_short => %?10
335 :     | CTypes.C_signed CTypes.I_int => %?11
336 :     | CTypes.C_signed CTypes.I_long => %?12
337 :     | CTypes.C_signed CTypes.I_long_long => %?13
338 :     | CTypes.C_PTR => %?14
339 :     | CTypes.C_ARRAY (t, i) => ?20 $ [ctype t, int i]
340 :     | CTypes.C_STRUCT l => ?21 $ [list ctype l]
341 : mblume 1548 | CTypes.C_UNION l => ?22 $ [list ctype l]
342 : blume 773 end
343 :    
344 : leunga 1174 fun ccall_type t =
345 :     let val op $ = PU.$ CCALL_TYPE
346 :     in case t of
347 : blume 1178 P.CCI32 => "\000" $ []
348 :     | P.CCI64 => "\001" $ []
349 :     | P.CCR64 => "\002" $ []
350 :     | P.CCML => "\003" $ []
351 : leunga 1174 end
352 :    
353 : blume 773 fun ccall_info { c_proto = { conv, retTy, paramTys },
354 : leunga 1174 ml_args, ml_res_opt, reentrant } = let
355 :     val op $ = PU.$ CCI
356 : blume 773 in
357 :     "C" $ [string conv, ctype retTy, list ctype paramTys,
358 : leunga 1174 list ccall_type ml_args, option ccall_type ml_res_opt,
359 :     bool reentrant
360 :     ]
361 : blume 773 end
362 : monnier 427
363 :     fun primop p = let
364 :     val op $ = PU.$ PO
365 :     fun ?n = String.str (Char.chr n)
366 : blume 515 fun fromto tag (from, to) = ?tag $ [int from, int to]
367 :     fun %?n = ?n $ []
368 : monnier 427 in
369 :     case p of
370 :     P.ARITH { oper, overflow, kind } =>
371 : blume 515 ?100 $ [arithop oper, bool overflow, numkind kind]
372 :     | P.CMP { oper, kind } => ?101 $ [cmpop oper, numkind kind]
373 : monnier 427 | P.TEST x => fromto 102 x
374 :     | P.TESTU x => fromto 103 x
375 :     | P.TRUNC x => fromto 104 x
376 :     | P.EXTEND x => fromto 105 x
377 :     | P.COPY x => fromto 106 x
378 : blume 515 | P.INLLSHIFT kind => ?107 $ [numkind kind]
379 :     | P.INLRSHIFT kind => ?108 $ [numkind kind]
380 :     | P.INLRSHIFTL kind => ?109 $ [numkind kind]
381 : monnier 427 | P.ROUND { floor, fromkind, tokind } =>
382 : blume 515 ?110 $ [bool floor, numkind fromkind, numkind tokind]
383 : monnier 427 | P.REAL { fromkind, tokind } =>
384 : blume 515 ?111 $ [numkind fromkind, numkind tokind]
385 : monnier 427 | P.NUMSUBSCRIPT { kind, checked, immutable } =>
386 : blume 515 ?112 $ [numkind kind, bool checked, bool immutable]
387 : monnier 427 | P.NUMUPDATE { kind, checked } =>
388 : blume 515 ?113 $ [numkind kind, bool checked]
389 :     | P.INL_MONOARRAY kind => ?114 $ [numkind kind]
390 :     | P.INL_MONOVECTOR kind => ?115 $ [numkind kind]
391 : blume 772 | P.RAW_LOAD kind => ?116 $ [numkind kind]
392 :     | P.RAW_STORE kind => ?117 $ [numkind kind]
393 : blume 773 | P.RAW_CCALL (SOME i) => ?118 $ [ccall_info i]
394 : blume 1178 | P.RAW_RECORD { fblock } => ?119 $ [bool fblock]
395 : blume 1183
396 :     | P.INLMIN kind => ?120 $ [numkind kind]
397 :     | P.INLMAX kind => ?121 $ [numkind kind]
398 :     | P.INLABS kind => ?122 $ [numkind kind]
399 : monnier 427
400 : mblume 1347 | P.TEST_INF i => ?123 $ [int i]
401 :     | P.TRUNC_INF i => ?124 $ [int i]
402 :     | P.EXTEND_INF i => ?125 $ [int i]
403 :     | P.COPY_INF i => ?126 $ [int i]
404 :    
405 : monnier 427 | P.MKETAG => %?0
406 :     | P.WRAP => %?1
407 :     | P.UNWRAP => %?2
408 :     | P.SUBSCRIPT => %?3
409 :     | P.SUBSCRIPTV => %?4
410 :     | P.INLSUBSCRIPT => %?5
411 :     | P.INLSUBSCRIPTV => %?6
412 :     | P.INLMKARRAY => %?7
413 :    
414 :     | P.PTREQL => %?8
415 :     | P.PTRNEQ => %?9
416 :     | P.POLYEQL => %?10
417 :     | P.POLYNEQ => %?11
418 :     | P.BOXED => %?12
419 :     | P.UNBOXED => %?13
420 :     | P.LENGTH => %?14
421 :     | P.OBJLENGTH => %?15
422 :     | P.CAST => %?16
423 :     | P.GETRUNVEC => %?17
424 :     | P.MARKEXN => %?18
425 :     | P.GETHDLR => %?19
426 :     | P.SETHDLR => %?20
427 :     | P.GETVAR => %?21
428 :     | P.SETVAR => %?22
429 :     | P.GETPSEUDO => %?23
430 :     | P.SETPSEUDO => %?24
431 :     | P.SETMARK => %?25
432 :     | P.DISPOSE => %?26
433 :     | P.MAKEREF => %?27
434 :     | P.CALLCC => %?28
435 :     | P.CAPTURE => %?29
436 :     | P.THROW => %?30
437 :     | P.DEREF => %?31
438 :     | P.ASSIGN => %?32
439 :     (* NOTE: P.UNBOXEDASSIGN is defined below *)
440 :     | P.UPDATE => %?33
441 :     | P.INLUPDATE => %?34
442 :     | P.BOXEDUPDATE => %?35
443 :     | P.UNBOXEDUPDATE => %?36
444 :    
445 :     | P.GETTAG => %?37
446 :     | P.MKSPECIAL => %?38
447 :     | P.SETSPECIAL => %?39
448 :     | P.GETSPECIAL => %?40
449 :     | P.USELVAR => %?41
450 :     | P.DEFLVAR => %?42
451 : blume 1183 | P.INLNOT => %?43
452 :     | P.INLCOMPOSE => %?44
453 :     | P.INLBEFORE => %?45
454 :     | P.INL_ARRAY => %?46
455 :     | P.INL_VECTOR => %?47
456 :     | P.ISOLATE => %?48
457 :     | P.WCAST => %?49
458 :     | P.NEW_ARRAY0 => %?50
459 :     | P.GET_SEQ_DATA => %?51
460 :     | P.SUBSCRIPT_REC => %?52
461 :     | P.SUBSCRIPT_RAW64 => %?53
462 :     | P.UNBOXEDASSIGN => %?54
463 :     | P.RAW_CCALL NONE => %?55
464 :     | P.INLIGNORE => %?56
465 : mblume 1347 | P.INLIDENTITY => %?57
466 : monnier 427 end
467 :    
468 :     fun consig arg = let
469 :     val op $ = PU.$ CS
470 : blume 515 fun cs (A.CSIG (i, j)) = "S" $ [int i, int j]
471 :     | cs A.CNIL = "N" $ []
472 : monnier 427 in
473 :     cs arg
474 :     end
475 :    
476 : monnier 504 fun mkAccess { lvar, isLocalPid } = let
477 : monnier 427 val op $ = PU.$ A
478 : blume 515 fun access (A.LVAR i) = "A" $ [lvar i]
479 :     | access (A.EXTERN p) = "B" $ [pid p]
480 : monnier 504 | access (A.PATH (a as A.EXTERN p, i)) =
481 :     (* isLocalPid always returns false for in the "normal pickler"
482 :     * case. It returns true in the "repickle" case for the
483 :     * pid that was the hash of the original whole pickle.
484 :     * Since alpha-conversion has already taken place if we find
485 :     * an EXTERN pid, we don't call "lvar" but "int". *)
486 : blume 515 if isLocalPid p then "A" $ [int i]
487 :     else "C" $ [access a, int i]
488 :     | access (A.PATH (a, i)) = "C" $ [access a, int i]
489 :     | access A.NO_ACCESS = "D" $ []
490 : monnier 427
491 :     val op $ = PU.$ CR
492 : blume 515 fun conrep A.UNTAGGED = "A" $ []
493 :     | conrep (A.TAGGED i) = "B" $ [int i]
494 :     | conrep A.TRANSPARENT = "C" $ []
495 :     | conrep (A.CONSTANT i) = "D" $ [int i]
496 :     | conrep A.REF = "E" $ []
497 :     | conrep (A.EXN a) = "F" $ [access a]
498 :     | conrep A.LISTCONS = "G" $ []
499 :     | conrep A.LISTNIL = "H" $ []
500 :     | conrep (A.SUSP NONE) = "I" $ []
501 :     | conrep (A.SUSP (SOME (a, b))) = "J" $ [access a, access b]
502 : monnier 427 in
503 :     { access = access, conrep = conrep }
504 :     end
505 :    
506 : blume 515 (* lambda-type stuff; some of it is used in both picklers *)
507 :     fun tkind x = let
508 :     val op $ = PU.$ TK
509 :     fun tk x =
510 :     case LK.tk_out x of
511 :     LK.TK_MONO => "A" $ []
512 :     | LK.TK_BOX => "B" $ []
513 :     | LK.TK_SEQ ks => "C" $ [list tkind ks]
514 :     | LK.TK_FUN (ks, kr) => "D" $ [list tkind ks, tkind kr]
515 :     in
516 :     share TKs tk x
517 :     end
518 :    
519 :     fun mkLty lvar = let
520 :     fun lty x = let
521 : monnier 489 val op $ = PU.$ LT
522 : blume 515 fun ltyI x =
523 :     case LK.lt_out x of
524 :     LK.LT_TYC tc => "A" $ [tyc tc]
525 :     | LK.LT_STR l => "B" $ [list lty l]
526 :     | LK.LT_FCT (ts1, ts2) => "C" $ [list lty ts1, list lty ts2]
527 :     | LK.LT_POLY (ks, ts) => "D" $ [list tkind ks, list lty ts]
528 :     | LK.LT_IND _ => bug "unexpected LT_IND in mkPickleLty"
529 :     | LK.LT_ENV _ => bug "unexpected LT_ENV in mkPickleLty"
530 :     | LK.LT_CONT _ => bug "unexpected LT_CONT in mkPickleLty"
531 : monnier 489 in
532 : blume 515 share LTs ltyI x
533 : monnier 489 end
534 : monnier 427
535 : blume 515 and tyc x = let
536 : monnier 489 val op $ = PU.$ TC
537 : blume 515 fun tycI x =
538 :     case LK.tc_out x of
539 :     LK.TC_VAR (db, i) => "A" $ [int (DI.di_toint db), int i]
540 :     | LK.TC_NVAR n => "B" $ [lvar n]
541 :     | LK.TC_PRIM t => "C" $ [int (PT.pt_toint t)]
542 :     | LK.TC_FN (ks, tc) => "D" $ [list tkind ks, tyc tc]
543 :     | LK.TC_APP (tc, l) => "E" $ [tyc tc, list tyc l]
544 :     | LK.TC_SEQ l => "F" $ [list tyc l]
545 :     | LK.TC_PROJ (tc, i) => "G" $ [tyc tc, int i]
546 :     | LK.TC_SUM l => "H" $ [list tyc l]
547 :     | LK.TC_FIX ((n, tc, ts), i) =>
548 :     "I" $ [int n, tyc tc, list tyc ts, int i]
549 :     | LK.TC_ABS tc => "J" $ [tyc tc]
550 :     | LK.TC_BOX tc => "K" $ [tyc tc]
551 :     | LK.TC_TUPLE (_, l) => "L" $ [list tyc l]
552 :     | LK.TC_ARROW (LK.FF_VAR (b1, b2), ts1, ts2) =>
553 :     "M" $ [bool b1, bool b2, list tyc ts1, list tyc ts2]
554 :     | LK.TC_ARROW (LK.FF_FIXED, ts1, ts2) =>
555 :     "N" $ [list tyc ts1, list tyc ts2]
556 :     | LK.TC_PARROW _ => bug "unexpected TC_PARREW in mkPickleLty"
557 :     | LK.TC_TOKEN (tk, t) => "O" $ [int (LK.token_int tk), tyc t]
558 :     | LK.TC_IND _ => bug "unexpected TC_IND in mkPickleLty"
559 :     | LK.TC_ENV _ => bug "unexpected TC_ENV in mkPickleLty"
560 :     | LK.TC_CONT _ => bug "unexpected TC_CONT in mkPickleLty"
561 : monnier 489 in
562 : blume 515 share TCs tycI x
563 : monnier 489 end
564 :     in
565 : blume 515 { tyc = tyc, lty = lty }
566 : monnier 427 end
567 :    
568 :     (* the FLINT pickler *)
569 :     fun flint flint_exp = let
570 :     val alphaConvert = mkAlphaConvert ()
571 :     val lvar = int o alphaConvert
572 : monnier 504 val { access, conrep } = mkAccess { lvar = lvar,
573 :     isLocalPid = fn _ => false }
574 : blume 515 val { lty, tyc } = mkLty lvar
575 :    
576 : monnier 427 val op $ = PU.$ V
577 : blume 515 fun value (F.VAR v) = "a" $ [lvar v]
578 :     | value (F.INT i) = "b" $ [int i]
579 :     | value (F.INT32 i32) = "c" $ [int32 i32]
580 :     | value (F.WORD w) = "d" $ [word w]
581 :     | value (F.WORD32 w32) = "e" $ [word32 w32]
582 :     | value (F.REAL s) = "f" $ [string s]
583 :     | value (F.STRING s) = "g" $ [string s]
584 : monnier 427
585 :     fun con arg = let
586 :     val op $ = PU.$ C
587 :     fun c (F.DATAcon (dc, ts, v), e) =
588 : blume 515 "1" $ [dcon (dc, ts), lvar v, lexp e]
589 :     | c (F.INTcon i, e) = "2" $ [int i, lexp e]
590 :     | c (F.INT32con i32, e) = "3" $ [int32 i32, lexp e]
591 :     | c (F.WORDcon w, e) = "4" $ [word w, lexp e]
592 :     | c (F.WORD32con w32, e) = "5" $ [word32 w32, lexp e]
593 :     | c (F.REALcon s, e) = "6" $ [string s, lexp e]
594 :     | c (F.STRINGcon s, e) = "7" $ [string s, lexp e]
595 :     | c (F.VLENcon i, e) = "8" $ [int i, lexp e]
596 : monnier 427 in
597 :     c arg
598 :     end
599 :    
600 :     and dcon ((s, cr, t), ts) = let
601 :     val op $ = PU.$ DCON
602 :     in
603 : blume 515 "x" $ [symbol s, conrep cr, lty t, list tyc ts]
604 : monnier 427 end
605 :    
606 :     and dict { default = v, table = tbls } = let
607 :     val op $ = PU.$ DICT
608 :     in
609 : blume 515 "y" $ [lvar v, list (pair (list tyc, lvar)) tbls]
610 : monnier 427 end
611 :    
612 :     and fprim (dtopt, p, t, ts) = let
613 :     val op $ = PU.$ FPRIM
614 :     in
615 : blume 515 "z" $ [option dict dtopt, primop p, lty t, list tyc ts]
616 : monnier 427 end
617 :    
618 :     and lexp arg = let
619 :     val op $ = PU.$ E
620 : blume 515 fun l (F.RET vs) = "j" $ [list value vs]
621 : monnier 427 | l (F.LET (vs, e1, e2)) =
622 : blume 515 "k" $ [list lvar vs, lexp e1, lexp e2]
623 :     | l (F.FIX (fdecs, e)) = "l" $ [list fundec fdecs, lexp e]
624 :     | l (F.APP (v, vs)) = "m" $ [value v, list value vs]
625 :     | l (F.TFN (tfdec, e)) = "n" $ [tfundec tfdec, lexp e]
626 :     | l (F.TAPP (v, ts)) = "o" $ [value v, list tyc ts]
627 : monnier 427 | l (F.SWITCH (v, crl, cel, eo)) =
628 : blume 515 "p" $ [value v, consig crl, list con cel, option lexp eo]
629 : monnier 427 | l (F.CON (dc, ts, u, v, e)) =
630 : blume 515 "q" $ [dcon (dc, ts), value u, lvar v, lexp e]
631 : monnier 427 | l (F.RECORD (rk, vl, v, e)) =
632 : blume 515 "r" $ [rkind rk, list value vl, lvar v, lexp e]
633 : monnier 427 | l (F.SELECT (u, i, v, e)) =
634 : blume 515 "s" $ [value u, int i, lvar v, lexp e]
635 :     | l (F.RAISE (u, ts)) = "t" $ [value u, list lty ts]
636 :     | l (F.HANDLE (e, u)) = "u" $ [lexp e, value u]
637 : monnier 427 | l (F.BRANCH (p, vs, e1, e2)) =
638 : blume 515 "v" $ [fprim p, list value vs, lexp e1, lexp e2]
639 : monnier 427 | l (F.PRIMOP (p, vs, v, e)) =
640 : blume 515 "w" $ [fprim p, list value vs, lvar v, lexp e]
641 : monnier 427 in
642 :     l arg
643 :     end
644 :    
645 :     and fundec (fk, v, vts, e) = let
646 :     val op $ = PU.$ FUNDEC
647 :     in
648 : blume 515 "a" $ [fkind fk, lvar v, list (pair (lvar, lty)) vts, lexp e]
649 : monnier 427 end
650 :    
651 : blume 515 and tfundec (_, v, tvks, e) = let
652 : monnier 427 val op $ = PU.$ TFUNDEC
653 :     in
654 : blume 515 "b" $ [lvar v, list (pair (lvar, tkind)) tvks, lexp e]
655 : monnier 427 end
656 :    
657 :     and fkind arg = let
658 :     val op $ = PU.$ FK
659 : blume 515 fun isAlways F.IH_ALWAYS = true
660 :     | isAlways _ = false
661 :     fun strip (x, y) = x
662 :     fun fk { cconv = F.CC_FCT, ... } = "2" $ []
663 :     | fk { isrec, cconv = F.CC_FUN fixed, known, inline } =
664 : monnier 427 case fixed of
665 :     LK.FF_VAR (b1, b2) =>
666 : blume 515 "3" $ [option (list lty) (Option.map strip isrec),
667 :     bool b1, bool b2, bool known,
668 :     bool (isAlways inline)]
669 : monnier 427 | LK.FF_FIXED =>
670 : blume 515 "4" $ [option (list lty) (Option.map strip isrec),
671 :     bool known, bool (isAlways inline)]
672 : monnier 427 in
673 :     fk arg
674 :     end
675 :    
676 :     and rkind arg = let
677 :     val op $ = PU.$ RK
678 : blume 515 fun rk (F.RK_VECTOR tc) = "5" $ [tyc tc]
679 :     | rk F.RK_STRUCT = "6" $ []
680 :     | rk (F.RK_TUPLE _) = "7" $ []
681 : monnier 427 in
682 :     rk arg
683 :     end
684 :     in
685 :     fundec flint_exp
686 :     end
687 :    
688 :     fun pickleFLINT fo = let
689 :     val pickle =
690 :     Byte.stringToBytes (PU.pickle emptyMap (option flint fo))
691 :     val hash = pickle2hash pickle
692 :     in
693 :     { pickle = pickle, hash = hash }
694 :     end
695 :    
696 :     fun symenvPickler sye =
697 :     list (pair (pid, flint)) (SymbolicEnv.listItemsi sye)
698 :    
699 : blume 587 (* the environment pickler *)
700 :     fun envPickler registerLvar context = let
701 :     val { tycStub, sigStub, strStub, fctStub, envStub,
702 :     isLocalPid, isLib } =
703 :     case context of
704 :     INITIAL tmap => let
705 :     fun stub (xId, freshX, lookX) r = let
706 :     val id = xId r
707 :     in
708 :     if freshX id then NONE
709 :     else if isSome (lookX (tmap, id)) then SOME (NONE, id)
710 :     else NONE
711 :     end
712 :     in
713 :     { tycStub = stub (MI.tycId, MI.freshTyc, MI.lookTyc),
714 :     sigStub = stub (MI.sigId, MI.freshSig, MI.lookSig),
715 :     strStub = stub (MI.strId, MI.freshStr, MI.lookStr),
716 :     fctStub = stub (MI.fctId, MI.freshFct, MI.lookFct),
717 :     envStub = stub (MI.envId, MI.freshEnv, MI.lookEnv),
718 :     isLocalPid = fn _ => false,
719 :     isLib = false }
720 :     end
721 :     | REHASH myPid => let
722 :     fun isLocalPid p = PersStamps.compare (p, myPid) = EQUAL
723 :     fun stub (idX, stubX, owner) r =
724 :     case stubX r of
725 :     NONE => bug "REHASH:no stubinfo"
726 :     | SOME stb =>
727 :     if isLocalPid (owner stb) then SOME (NONE, idX r)
728 :     else NONE
729 :     in
730 :     { tycStub = stub (MI.tycId, #stub, #owner),
731 :     sigStub = stub (MI.sigId, #stub, #owner),
732 :     strStub = stub (MI.strId, #stub o #rlzn, #owner),
733 :     fctStub = stub (MI.fctId, #stub o #rlzn, #owner),
734 :     envStub = stub (MI.envId, #stub, #owner),
735 :     isLocalPid = isLocalPid,
736 :     isLib = false }
737 :     end
738 :     | LIBRARY l => let
739 :     fun stub (idX, stubX, lookX, lib) r = let
740 :     fun get id = let
741 :     fun loop [] =
742 :     bug "LIBRARY:import info missing"
743 :     | loop ((lms, m) :: t) =
744 :     if isSome (lookX (m, id)) then lms else loop t
745 :     in
746 :     loop l
747 :     end
748 :     in
749 :     case stubX r of
750 :     NONE => bug "LIBRARY:no stubinfo"
751 :     | SOME stb => let
752 :     val id = idX r
753 :     in
754 :     if lib stb then SOME (get id, id) else NONE
755 :     end
756 :     end
757 :     in
758 :     { tycStub = stub (MI.tycId, #stub, MI.lookTyc, #lib),
759 :     sigStub = stub (MI.sigId, #stub, MI.lookSig, #lib),
760 :     strStub = stub (MI.strId, #stub o #rlzn,
761 :     MI.lookStr, #lib),
762 :     fctStub = stub (MI.fctId, #stub o #rlzn,
763 :     MI.lookFct, #lib),
764 :     envStub = stub (MI.envId, #stub, MI.lookEnv, #lib),
765 :     isLocalPid = fn _ => false,
766 :     isLib = true }
767 :     end
768 : monnier 427
769 : blume 587 (* Owner pids of stubs are pickled only in the case of libraries,
770 :     * otherwise they are ignored completely. *)
771 :     fun libPid x =
772 :     if isLib then
773 :     case x of
774 :     (NONE, _) => []
775 :     | (SOME stb, ownerOf) => [pid (ownerOf stb)]
776 :     else []
777 : monnier 427
778 : blume 632 fun libModSpec lms = option (pair (int, symbol)) lms
779 : monnier 427
780 : blume 587 val stampConverter = Stamps.newConverter ()
781 : monnier 427
782 : blume 587 fun stamp s = let
783 : monnier 427 val op $ = PU.$ ST
784 :     in
785 : blume 587 Stamps.Case stampConverter s
786 :     { fresh = fn i => "A" $ [int i],
787 : blume 742 global = fn { pid = p, cnt } => "B" $ [pid p, int cnt],
788 : blume 587 special = fn s => "C" $ [string s] }
789 : monnier 427 end
790 :    
791 : blume 587 val tycId = stamp
792 :     val sigId = stamp
793 :     fun strId { sign, rlzn } = let
794 :     val op $ = PU.$ STRID
795 :     in
796 :     "D" $ [stamp sign, stamp rlzn]
797 :     end
798 :     fun fctId { paramsig, bodysig, rlzn } = let
799 :     val op $ = PU.$ FCTID
800 :     in
801 :     "E" $ [stamp paramsig, stamp bodysig, stamp rlzn]
802 :     end
803 :     val envId = stamp
804 :    
805 : monnier 427 val entVar = stamp
806 :     val entPath = list entVar
807 :    
808 : blume 587 val anotherLvar =
809 :     let val lvcount = ref 0
810 :     in (fn v => let val j = !lvcount
811 :     in registerLvar v; lvcount := j + 1; j end)
812 :     end
813 : monnier 427
814 : monnier 504 val { access, conrep } = mkAccess { lvar = int o anotherLvar,
815 :     isLocalPid = isLocalPid }
816 : monnier 427
817 : blume 515 val op $ = PU.$ SPATH
818 :     fun spath (SP.SPATH p) = "s" $ [list symbol p]
819 :     val op $ = PU.$ IPATH
820 :     fun ipath (IP.IPATH p) = "i" $ [list symbol p]
821 : monnier 427
822 : blume 773 (* for debugging *)
823 :     fun showipath (IP.IPATH p) =
824 :     concat (map (fn s => Symbol.symbolToString s ^ ".") (rev p))
825 :    
826 : monnier 427 val label = symbol
827 :    
828 :     fun eqprop eqp = let
829 : blume 515 val op $ = PU.$ EQP
830 : monnier 427 fun eqc T.YES = "\000"
831 :     | eqc T.NO = "\001"
832 :     | eqc T.IND = "\002"
833 :     | eqc T.OBJ = "\003"
834 :     | eqc T.DATA = "\004"
835 :     | eqc T.ABS = "\005"
836 :     | eqc T.UNDEF = "\006"
837 :     in
838 : blume 515 eqc eqp $ []
839 : monnier 427 end
840 :    
841 :     fun datacon (T.DATACON { name, const, typ, rep, sign, lazyp }) = let
842 :     val op $ = PU.$ DATACON
843 :     in
844 : blume 515 "c" $ [symbol name, bool const, ty typ, conrep rep,
845 :     consig sign, bool lazyp]
846 : monnier 427 end
847 :    
848 :     and tyckind arg = let
849 :     val op $ = PU.$ TYCKIND
850 : blume 902 fun tk (T.PRIMITIVE pt) = "a" $ [int pt]
851 : monnier 427 | tk (T.DATATYPE { index, family, stamps, root,freetycs }) =
852 : blume 515 "b" $ [int index, option entVar root,
853 :     dtypeInfo (stamps, family, freetycs)]
854 :     | tk (T.ABSTRACT tyc) = "c" $ [tycon tyc]
855 :     | tk (T.FLEXTYC tps) = "d" $ [] (* "f" $ tycpath tps *)
856 : monnier 427 (*** I (Matthias) carried through this message from Zhong:
857 :     tycpath should never be pickled; the only way it can be
858 :     pickled is when pickling the domains of a mutually
859 :     recursive datatypes; right now the mutually recursive
860 :     datatypes are not assigned accurate domains ... (ZHONG)
861 :     the preceding code is just a temporary gross hack.
862 :     ***)
863 : blume 515 | tk T.FORMAL = "d" $ []
864 :     | tk T.TEMP = "e" $ []
865 : monnier 427 in
866 :     tk arg
867 :     end
868 :    
869 :     and dtypeInfo x = let
870 :     val op $ = PU.$ DTI
871 :     fun dti_raw (ss, family, freetycs) =
872 : blume 515 "a" $ [list stamp (Vector.foldr (op ::) [] ss),
873 :     dtFamily family, list tycon freetycs]
874 : monnier 427 in
875 :     share (DTs (Vector.sub (#1 x, 0))) dti_raw x
876 :     end
877 :    
878 :     and dtFamily x = let
879 :     val op $ = PU.$ DTF
880 : blume 902 fun dtf_raw { mkey, members, properties } =
881 : blume 515 "b" $ [stamp mkey,
882 :     list dtmember (Vector.foldr (op ::) [] members)]
883 : monnier 427 in
884 :     share (MBs (#mkey x)) dtf_raw x
885 :     end
886 :    
887 :     and dtmember { tycname, dcons, arity, eq = ref e, lazyp, sign } = let
888 :     val op $ = PU.$ DTMEM
889 :     in
890 : blume 515 "c" $ [symbol tycname, list nameRepDomain dcons, int arity,
891 :     eqprop e, bool lazyp, consig sign]
892 : monnier 427 end
893 :    
894 :     and nameRepDomain { name, rep, domain } = let
895 :     val op $ = PU.$ NRD
896 :     in
897 : blume 515 "d" $ [symbol name, conrep rep, option ty domain]
898 : monnier 427 end
899 :    
900 :     and tycon arg = let
901 :     val op $ = PU.$ TYCON
902 : blume 587 fun tc (tyc as T.GENtyc g) =
903 :     let fun gt_raw (g as { stamp = s, arity, eq = ref eq, kind,
904 :     path, stub }) =
905 :     case tycStub g of
906 :     SOME (l, i) => "A" $ [libModSpec l, tycId i]
907 :     | NONE => "B" $ ([stamp s, int arity, eqprop eq,
908 :     tyckind kind, ipath path]
909 :     @ libPid (stub, #owner))
910 : monnier 427 in
911 : blume 587 share (TYCs (MI.tycId g)) gt_raw g
912 : monnier 427 end
913 : blume 587 | tc (tyc as T.DEFtyc dt) = let
914 :     fun dt_raw { stamp = s, tyfun, strict, path } = let
915 : monnier 427 val T.TYFUN { arity, body } = tyfun
916 :     in
917 : blume 515 "C" $ [stamp s, int arity, ty body,
918 :     list bool strict, ipath path]
919 : monnier 427 end
920 :     in
921 : blume 587 share (TYCs (MI.tycId' tyc)) dt_raw dt
922 : monnier 427 end
923 :     | tc (T.PATHtyc { arity, entPath = ep, path }) =
924 : blume 515 "D" $ [int arity, entPath ep, ipath path]
925 :     | tc (T.RECORDtyc l) = "E" $ [list label l]
926 :     | tc (T.RECtyc i) = "F" $ [int i]
927 :     | tc (T.FREEtyc i) = "G" $ [int i]
928 :     | tc T.ERRORtyc = "H" $ []
929 : monnier 427 in
930 :     tc arg
931 :     end
932 :    
933 :     and ty arg = let
934 :     val op $ = PU.$ T
935 :     fun ty (T.VARty (ref (T.INSTANTIATED t))) = ty t
936 :     | ty (T.VARty (ref (T.OPEN _))) =
937 :     bug "uninstantiated VARty in pickmod"
938 : blume 515 | ty (T.CONty (c, l)) = "a" $ [tycon c, list ty l]
939 :     | ty (T.IBOUND i) = "b" $ [int i]
940 :     | ty T.WILDCARDty = "c" $ []
941 : monnier 427 | ty (T.POLYty { sign, tyfun = T.TYFUN { arity, body } }) =
942 : blume 515 "d" $ [list bool sign, int arity, ty body]
943 :     | ty T.UNDEFty = "e" $ []
944 : monnier 427 | ty _ = bug "unexpected type in pickmod-ty"
945 :     in
946 :     ty arg
947 :     end
948 :    
949 :     val op $ = PU.$ II
950 : blume 902 fun inl_info i =
951 : macqueen 1374 II.match i { inl_prim = fn (p, t) => "A" $ [primop p, ty t],
952 : blume 902 inl_str = fn sl => "B" $ [list inl_info sl],
953 :     inl_no = fn () => "C" $ [] }
954 : monnier 427
955 :     val op $ = PU.$ VAR
956 :     fun var (V.VALvar { access = a, info, path, typ = ref t }) =
957 : blume 515 "1" $ [access a, inl_info info, spath path, ty t]
958 : monnier 427 | var (V.OVLDvar { name, options = ref p,
959 :     scheme = T.TYFUN { arity, body } }) =
960 : blume 515 "2" $ [symbol name, list overld p, int arity, ty body]
961 :     | var V.ERRORvar = "3" $ []
962 : monnier 427
963 :     and overld { indicator, variant } = let
964 :     val op $ = PU.$ OVERLD
965 :     in
966 : blume 515 "o" $ [ty indicator, var variant]
967 : monnier 427 end
968 :    
969 :     fun strDef arg = let
970 :     val op $ = PU.$ SD
971 : blume 515 fun sd (M.CONSTstrDef s) = "C" $ [Structure s]
972 :     | sd (M.VARstrDef (s, p)) = "V" $ [Signature s, entPath p]
973 : monnier 427 in
974 :     sd arg
975 :     end
976 :    
977 :     (*
978 :     * boundeps is not pickled right now, but it really should
979 :     * be pickled in the future.
980 :     *)
981 :     and Signature arg = let
982 :     val op $ = PU.$ SG
983 : blume 515 fun sg M.ERRORsig = "A" $ []
984 : blume 587 | sg (M.SIG s) =
985 :     (case sigStub s of
986 :     SOME (l, i) => "B" $ [libModSpec l, sigId i]
987 :     | NONE => let
988 :     fun sig_raw (s: M.sigrec) = let
989 :     val { stamp = sta, name, closed,
990 :     fctflag, symbols, elements,
991 : blume 902 properties,
992 :     (* boundeps = ref b, *)
993 :     (* lambdaty = _, *)
994 :     stub, typsharing, strsharing } = s
995 :     val b = ModulePropLists.sigBoundeps s
996 : blume 587 val b = NONE (* currently turned off *)
997 :     in
998 :     "C" $ ([stamp sta,
999 :     option symbol name, bool closed,
1000 :     bool fctflag,
1001 :     list symbol symbols,
1002 :     list (pair (symbol, spec)) elements,
1003 :     option (list (pair (entPath, tkind))) b,
1004 :     list (list spath) typsharing,
1005 :     list (list spath) strsharing]
1006 :     @ libPid (stub, #owner))
1007 :     end
1008 :     in
1009 :     share SIGs sig_raw s
1010 :     end)
1011 : monnier 427 in
1012 :     sg arg
1013 :     end
1014 :    
1015 :     and fctSig arg = let
1016 :     val op $ = PU.$ FSG
1017 : blume 515 fun fsg M.ERRORfsig = "a" $ []
1018 : blume 587 | fsg (M.FSIG { kind, paramsig, paramvar, paramsym, bodysig }) =
1019 :     "c" $ [option symbol kind, Signature paramsig,
1020 :     entVar paramvar,
1021 :     option symbol paramsym,
1022 :     Signature bodysig]
1023 : monnier 427 in
1024 :     fsg arg
1025 :     end
1026 :    
1027 :     and spec arg = let
1028 :     val op $ = PU.$ SP
1029 :     fun sp (M.TYCspec { spec = t, entVar = v, repl, scope }) =
1030 : blume 515 "1" $ [tycon t, entVar v, bool repl, int scope]
1031 : monnier 427 | sp (M.STRspec { sign, slot, def, entVar = v }) =
1032 : blume 515 "2" $ [Signature sign, int slot,
1033 :     option (pair (strDef, int)) def, entVar v]
1034 : monnier 427 | sp (M.FCTspec { sign, slot, entVar = v }) =
1035 : blume 515 "3" $ [fctSig sign, int slot, entVar v]
1036 :     | sp (M.VALspec { spec = t, slot }) = "4" $ [ty t, int slot]
1037 : monnier 427 | sp (M.CONspec { spec = c, slot }) =
1038 : blume 515 "5" $ [datacon c, option int slot]
1039 : monnier 427 in
1040 :     sp arg
1041 :     end
1042 :    
1043 :     and entity arg = let
1044 :     val op $ = PU.$ EN
1045 : blume 515 fun en (M.TYCent t) = "A" $ [tycEntity t]
1046 :     | en (M.STRent t) = "B" $ [strEntity t]
1047 :     | en (M.FCTent t) = "C" $ [fctEntity t]
1048 :     | en M.ERRORent = "D" $ []
1049 : monnier 427 in
1050 :     en arg
1051 :     end
1052 :    
1053 :     and fctClosure (M.CLOSURE { param, body, env }) = let
1054 :     val op $ = PU.$ FCTC
1055 :     in
1056 : blume 515 "f" $ [entVar param, strExp body, entityEnv env]
1057 : monnier 427 end
1058 :    
1059 :     and Structure arg = let
1060 :     val op $ = PU.$ STR
1061 :     fun str (M.STRSIG { sign, entPath = p }) =
1062 : blume 515 "A" $ [Signature sign, entPath p]
1063 :     | str M.ERRORstr = "B" $ []
1064 : blume 587 | str (M.STR (s as { sign, rlzn, access = a, info })) =
1065 :     (case strStub s of
1066 :     (* stub represents just the strerec suspension! *)
1067 :     SOME (l, i) => "C" $ [Signature sign,
1068 :     libModSpec l,
1069 :     strId i,
1070 :     access a,
1071 :     inl_info info]
1072 :     | NONE => "D" $ [Signature sign,
1073 :     shStrEntity (MI.strId s) rlzn,
1074 :     access a, inl_info info])
1075 : monnier 427 in
1076 :     str arg
1077 :     end
1078 :    
1079 :     and Functor arg = let
1080 :     val op $ = PU.$ F
1081 : blume 515 fun fct M.ERRORfct = "E" $ []
1082 : blume 587 | fct (M.FCT (f as { sign, rlzn, access = a, info })) =
1083 :     (case fctStub f of
1084 :     SOME (l, i) => "F" $ [fctSig sign,
1085 :     libModSpec l,
1086 :     fctId i,
1087 :     access a,
1088 :     inl_info info]
1089 :     | NONE => "G" $ [fctSig sign,
1090 :     shFctEntity (MI.fctId f) rlzn,
1091 :     access a, inl_info info])
1092 : monnier 427 in
1093 :     fct arg
1094 :     end
1095 :    
1096 : blume 587 and (* stampExp (M.CONST s) = PU.$ STE ("a", [stamp s])
1097 :     | *) stampExp (M.GETSTAMP s) = PU.$ STE ("b", [strExp s])
1098 : blume 515 | stampExp M.NEW = "c" $ []
1099 : monnier 427
1100 : blume 515 and tycExp (M.CONSTtyc t) = PU.$ TCE ("d", [tycon t])
1101 :     | tycExp (M.FORMtyc t) = PU.$ TCE ("e", [tycon t])
1102 :     | tycExp (M.VARtyc s) = PU.$ TCE ("f", [entPath s])
1103 : monnier 427
1104 :     and strExp arg = let
1105 :     val op $ = PU.$ STRE
1106 : blume 515 fun stre (M.VARstr s) = "g" $ [entPath s]
1107 :     | stre (M.CONSTstr s) = "h" $ [strEntity s]
1108 : monnier 427 | stre (M.STRUCTURE { stamp = s, entDec }) =
1109 : blume 515 "i" $ [stampExp s, entityDec entDec]
1110 :     | stre (M.APPLY (f, s)) = "j" $ [fctExp f, strExp s]
1111 :     | stre (M.LETstr (e, s)) = "k" $ [entityDec e, strExp s]
1112 :     | stre (M.ABSstr (s, e)) = "l" $ [Signature s, strExp e]
1113 : monnier 427 | stre (M.CONSTRAINstr { boundvar, raw, coercion }) =
1114 : blume 515 "m" $ [entVar boundvar, strExp raw, strExp coercion]
1115 :     | stre (M.FORMstr fs) = "n" $ [fctSig fs]
1116 : monnier 427 in
1117 :     stre arg
1118 :     end
1119 :    
1120 :     and fctExp arg = let
1121 :     val op $ = PU.$ FE
1122 : blume 515 fun fe (M.VARfct s) = "o" $ [entPath s]
1123 :     | fe (M.CONSTfct e) = "p" $ [fctEntity e]
1124 : monnier 427 | fe (M.LAMBDA { param, body }) =
1125 : blume 515 "q" $ [entVar param, strExp body]
1126 : monnier 427 | fe (M.LAMBDA_TP { param, body, sign }) =
1127 : blume 515 "r" $ [entVar param, strExp body, fctSig sign]
1128 :     | fe (M.LETfct (e, f)) = "s" $ [entityDec e, fctExp f]
1129 : monnier 427 in
1130 :     fe arg
1131 :     end
1132 :    
1133 :     and entityExp arg = let
1134 :     val op $ = PU.$ EE
1135 : blume 515 fun ee (M.TYCexp t) = "t" $ [tycExp t]
1136 :     | ee (M.STRexp s) = "u" $ [strExp s]
1137 :     | ee (M.FCTexp f) = "v" $ [fctExp f]
1138 :     | ee M.ERRORexp = "w" $ []
1139 :     | ee M.DUMMYexp = "x" $ []
1140 : monnier 427 in
1141 :     ee arg
1142 :     end
1143 :    
1144 :     and entityDec arg = let
1145 :     val op $ = PU.$ ED
1146 : blume 515 fun ed (M.TYCdec (s, x)) = "A" $ [entVar s, tycExp x]
1147 :     | ed (M.STRdec (s, x, n)) = "B" $ [entVar s, strExp x, symbol n]
1148 :     | ed (M.FCTdec (s, x)) = "C" $ [entVar s, fctExp x]
1149 :     | ed (M.SEQdec e) = "D" $ [list entityDec e]
1150 :     | ed (M.LOCALdec (a, b)) = "E" $ [entityDec a, entityDec b]
1151 :     | ed M.ERRORdec = "F" $ []
1152 :     | ed M.EMPTYdec = "G" $ []
1153 : monnier 427 in
1154 :     ed arg
1155 :     end
1156 :    
1157 : blume 587 and entityEnv (M.MARKeenv m) =
1158 :     (case envStub m of
1159 :     SOME (l, i) => "D" $ [libModSpec l, envId i]
1160 :     | NONE => let
1161 :     fun mee_raw { stamp = s, env, stub } =
1162 :     "E" $ ([stamp s, entityEnv env]
1163 :     @ libPid (stub: M.stubinfo option, #owner))
1164 :     in
1165 :     share ENVs mee_raw m
1166 :     end)
1167 : monnier 427 | entityEnv (M.BINDeenv (d, r)) =
1168 : blume 515 PU.$ EEV ("A", [list (pair (entVar, entity)) (ED.listItemsi d),
1169 :     entityEnv r])
1170 :     | entityEnv M.NILeenv = "B" $ []
1171 :     | entityEnv M.ERReenv = "C" $ []
1172 : monnier 427
1173 : blume 902 and strEntity { stamp = s, entities, properties, rpath, stub } =
1174 : blume 587 let val op $ = PU.$ SEN
1175 :     in
1176 :     "s" $ ([stamp s, entityEnv entities, ipath rpath]
1177 :     @ libPid (stub: M.stubinfo option, #owner))
1178 :     end
1179 : monnier 427
1180 : blume 587 and shStrEntity id = share (STRs id) strEntity
1181 : monnier 427
1182 : blume 902 and fctEntity { stamp = s,
1183 :     closure, properties, tycpath, rpath, stub } =
1184 : blume 587 let val op $ = PU.$ FEN
1185 :     in
1186 :     "f" $ ([stamp s, fctClosure closure, ipath rpath]
1187 :     @ libPid (stub: M.stubinfo option, #owner))
1188 :     end
1189 :    
1190 :     and shFctEntity id = share (FCTs id) fctEntity
1191 :    
1192 : monnier 427 and tycEntity x = tycon x
1193 :    
1194 : blume 515 fun fixity Fixity.NONfix = "N" $ []
1195 :     | fixity (Fixity.INfix (i, j)) = PU.$ FX ("I", [int i, int j])
1196 : monnier 427
1197 :     val op $ = PU.$ B
1198 : blume 515 fun binding (B.VALbind x) = "1" $ [var x]
1199 :     | binding (B.CONbind x) = "2" $ [datacon x]
1200 :     | binding (B.TYCbind x) = "3" $ [tycon x]
1201 :     | binding (B.SIGbind x) = "4" $ [Signature x]
1202 :     | binding (B.STRbind x) = "5" $ [Structure x]
1203 :     | binding (B.FSGbind x) = "6" $ [fctSig x]
1204 :     | binding (B.FCTbind x) = "7" $ [Functor x]
1205 :     | binding (B.FIXbind x) = "8" $ [fixity x]
1206 : monnier 427
1207 :     fun env e = let
1208 : blume 902 val syms = ListMergeSort.uniqueSort symCmp (StaticEnv.symbols e)
1209 : blume 587 val pairs = map (fn s => (s, StaticEnv.look (e, s))) syms
1210 : monnier 427 in
1211 :     list (pair (symbol, binding)) pairs
1212 :     end
1213 :     in
1214 : blume 587 env
1215 : monnier 427 end
1216 :    
1217 : blume 587 fun pickleEnv context e = let
1218 :     val lvlist = ref []
1219 :     fun registerLvar v = lvlist := v :: !lvlist
1220 :     val pickler = envPickler registerLvar context
1221 :     val pickle = Byte.stringToBytes (PU.pickle emptyMap (pickler e))
1222 :     val exportLvars = rev (!lvlist)
1223 : monnier 427 val hash = pickle2hash pickle
1224 : blume 1058 val hasExports = not (List.null exportLvars)
1225 : monnier 427 in
1226 :     addPickles (Word8Vector.length pickle);
1227 :     { hash = hash, pickle = pickle, exportLvars = exportLvars,
1228 : blume 1058 hasExports = hasExports }
1229 : monnier 427 end
1230 :    
1231 :     (* the dummy environment pickler *)
1232 : blume 1058 fun dontPickle { env = senv, count } = let
1233 : monnier 427 val hash = let
1234 :     val toByte = Word8.fromLargeWord o Word32.toLargeWord
1235 :     val >> = Word32.>>
1236 :     infix >>
1237 :     val w = Word32.fromInt count
1238 :     in
1239 :     PS.fromBytes
1240 :     (Word8Vector.fromList
1241 :     [0w0,0w0,0w0,toByte(w >> 0w24),0w0,0w0,0w0,toByte(w >> 0w16),
1242 :     0w0,0w0,0w0,toByte(w >> 0w8),0w0,0w0,0w0,toByte(w)])
1243 :     end
1244 :     (* next line is an alternative to using Env.consolidate *)
1245 : blume 902 val syms = ListMergeSort.uniqueSort symCmp (StaticEnv.symbols senv)
1246 : monnier 427 fun newAccess i = A.PATH (A.EXTERN hash, i)
1247 :     fun mapbinding (sym, (i, env, lvars)) =
1248 : blume 587 case StaticEnv.look (senv, sym) of
1249 : monnier 427 B.VALbind (V.VALvar {access=a, info=z, path=p, typ= ref t }) =>
1250 : blume 587 (case a of
1251 :     A.LVAR k =>
1252 :     (i+1,
1253 :     StaticEnv.bind (sym,
1254 :     B.VALbind (V.VALvar
1255 :     { access = newAccess i,
1256 :     info = z, path = p,
1257 :     typ = ref t}),
1258 :     env),
1259 :     k :: lvars)
1260 :     | _ => bug ("dontPickle 1: " ^ A.prAcc a))
1261 :     | B.STRbind (M.STR { sign = s, rlzn = r, access = a, info =z }) =>
1262 :     (case a of
1263 :     A.LVAR k =>
1264 :     (i+1,
1265 :     StaticEnv.bind (sym,
1266 :     B.STRbind (M.STR
1267 :     { access = newAccess i,
1268 :     sign = s, rlzn = r,
1269 :     info = z }),
1270 :     env),
1271 :     k :: lvars)
1272 :     | _ => bug ("dontPickle 2" ^ A.prAcc a))
1273 : monnier 427 | B.FCTbind (M.FCT { sign = s, rlzn = r, access = a, info=z }) =>
1274 : blume 587 (case a of
1275 :     A.LVAR k =>
1276 :     (i+1,
1277 :     StaticEnv.bind (sym,
1278 :     B.FCTbind (M.FCT
1279 : monnier 427 { access = newAccess i,
1280 :     sign = s, rlzn = r,
1281 : blume 587 info = z }),
1282 :     env),
1283 :     k :: lvars)
1284 :     | _ => bug ("dontPickle 3" ^ A.prAcc a))
1285 : monnier 427 | B.CONbind (T.DATACON { name = n, const = c, typ = t, sign = s,
1286 :     lazyp= false, rep as (A.EXN a) }) => let
1287 :     val newrep = A.EXN (newAccess i)
1288 :     in
1289 :     case a of
1290 :     A.LVAR k =>
1291 : blume 587 (i+1,
1292 :     StaticEnv.bind (sym,
1293 :     B.CONbind (T.DATACON
1294 :     { rep = newrep,
1295 :     name = n,
1296 :     lazyp = false,
1297 :     const = c, typ = t,
1298 :     sign = s }),
1299 :     env),
1300 :     k :: lvars)
1301 : monnier 427 | _ => bug ("dontPickle 4" ^ A.prAcc a)
1302 :     end
1303 : blume 587 | binding => (i, StaticEnv.bind (sym, binding, env), lvars)
1304 : monnier 427 val (_,newenv,lvars) = foldl mapbinding (0, StaticEnv.empty, nil) syms
1305 : blume 1058 val hasExports = not (List.null lvars)
1306 : monnier 427 in
1307 : blume 1058 { newenv = newenv, hash = hash,
1308 :     exportLvars = rev lvars, hasExports = hasExports }
1309 : monnier 427 end
1310 : monnier 475 end
1311 : monnier 427 end
1312 : monnier 475

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