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

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

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