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

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