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

Annotation of /sml/branches/SMLNJ/src/compiler/Semant/pickle/pickmod.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 69 - (view) (download)

1 : monnier 16 (* COPYRIGHT (c) 1996 Bell Laboratories *)
2 :     (* pickmod.sml *)
3 :    
4 :     signature PICKMOD =
5 :     sig
6 :     val pickleEnv :
7 :     SCStaticEnv.staticEnv * StaticEnv.staticEnv
8 :     -> {hash: PersStamps.persstamp,
9 :     pickle: Word8Vector.vector,
10 : monnier 45 exportLvars: Access.lvar list,
11 : monnier 16 exportPid: PersStamps.persstamp option}
12 : monnier 45 val pickleFLINT:
13 :     CompBasic.flint option ->
14 :     {hash: PersStamps.persstamp, pickle: Word8Vector.vector}
15 : monnier 16
16 :     val pickle2hash: Word8Vector.vector -> PersStamps.persstamp
17 :    
18 :     val dontPickle :
19 :     StaticEnv.staticEnv * int
20 :     -> StaticEnv.staticEnv * PersStamps.persstamp *
21 : monnier 45 Access.lvar list * PersStamps.persstamp option
22 : monnier 16
23 :     val debugging : bool ref
24 :     val debuggingSW : bool ref
25 :    
26 :     end (* signature PICKMOD *)
27 :    
28 :     structure PickMod : PICKMOD =
29 :     struct
30 :    
31 :     local structure A = Access
32 :     structure B = Bindings
33 :     structure DI = DebIndex
34 :     structure EP = EntPath
35 :     structure ED = EntPath.EvDict
36 :     structure II = InlInfo
37 :     structure IP = InvPath
38 : monnier 45 structure F = FLINT
39 : monnier 16 structure LK = LtyKernel (* structure LT = LtyDef *)
40 :     (** pickmod must look under the abstract lty representation *)
41 :     structure M = Modules
42 :     structure MI = ModuleId
43 :     structure P = PrimOp
44 :     structure PS = PersStamps
45 :     structure PT = PrimTyc
46 :     structure S = Symbol
47 :     structure SP = SymPath
48 :     structure T = Types
49 :     structure TU = TypesUtil
50 :     structure V = VarCon
51 :     structure LtyKey : ORD_KEY =
52 :     struct type ord_key = LK.lty * DI.depth
53 :     fun cmpKey((t,d),(t',d')) =
54 :     case LK.lt_cmp(t,t') of EQUAL => DI.cmp(d,d')
55 :     | x => x
56 :     end
57 :     structure LtyDict = BinaryDict(LtyKey)
58 :     in
59 :    
60 :     val say = Control.Print.say
61 :     val debugging = ref true
62 :     fun debugmsg (msg: string) =
63 :     if !debugging then (say msg; say "\n") else ()
64 :     fun bug msg = ErrorMsg.impossible ("PickMod: " ^ msg)
65 :    
66 :     fun isGlobalStamp(Stamps.STAMP{scope=Stamps.GLOBAL _,...}) = true
67 :     | isGlobalStamp _ = false
68 :    
69 :     val addPickles = Stats.addStat(Stats.makeStat "Pickle Bytes")
70 :    
71 :     (**************************************************************************
72 :     * UTILITY FUNCTIONS *
73 :     **************************************************************************)
74 :     datatype key
75 :     = MIkey of MI.modId
76 :     | LTkey of LK.lty
77 :     | TCkey of LK.tyc
78 :     | TKkey of LK.tkind
79 :     | DTkey of Stamps.stamp
80 :     | MBkey of Stamps.stamp
81 :     | EPkey of EP.entPath
82 :    
83 :     structure Key =
84 :     struct
85 :     type ord_key = key
86 :    
87 :     fun cmpKey(MIkey a', MIkey b') = MI.cmp(a',b')
88 :     | cmpKey(MIkey _, _) = GREATER
89 :     | cmpKey(_, MIkey _) = LESS
90 :     | cmpKey(LTkey a', LTkey b') = LK.lt_cmp(a',b')
91 :     | cmpKey(LTkey _, _) = GREATER
92 :     | cmpKey(_, LTkey _) = LESS
93 :     | cmpKey(TCkey a', TCkey b') = LK.tc_cmp(a',b')
94 :     | cmpKey(TCkey _, _) = GREATER
95 :     | cmpKey(_, TCkey _) = LESS
96 :     | cmpKey(TKkey a', TKkey b') = LK.tk_cmp(a',b')
97 :     | cmpKey(TKkey _, _) = GREATER
98 :     | cmpKey(_, TKkey _) = LESS
99 :     | cmpKey(DTkey a', DTkey b') = Stamps.cmp(a',b')
100 :     | cmpKey(DTkey _, _) = GREATER
101 :     | cmpKey(_, DTkey _) = LESS
102 :     | cmpKey(MBkey a', MBkey b') = Stamps.cmp(a',b')
103 :     | cmpKey(MBkey _, _) = GREATER
104 :     | cmpKey(_, MBkey _) = LESS
105 :     | cmpKey(EPkey a', EPkey b') = EP.cmpEntPath(a', b')
106 :     (*
107 :     | cmpKey(EPkey _, _) = GREATER
108 :     | cmpKey(_, EPkey _) = LESS
109 :     *)
110 :    
111 :    
112 :     end (* structure Key *)
113 :    
114 :     structure W = ShareWrite(Key)
115 :    
116 :     val debuggingSW = W.debugging
117 :     (*
118 :     val cnt = ref 0
119 :     fun getcnt () = if !cnt = 10 then (cnt := 0; true) else (cnt := (!cnt)+1; false)
120 :     fun dmsg x = (say x; if getcnt() then say "\n" else ())
121 :    
122 :     val $ = fn (s,z) => (dmsg (s^" "); W.$(s,z))
123 :     *)
124 :     val $ = W.$
125 :     infix $
126 :    
127 :     val nilEncode = "Na" $ []
128 :    
129 :     fun list alpha nil () = nilEncode
130 :     | list alpha [a] () = "1a" $ [alpha a]
131 :     | list alpha [a,b] () = "2a" $ [alpha a, alpha b]
132 :     | list alpha [a,b,c] () = "3a" $ [alpha a, alpha b, alpha c]
133 :     | list alpha [a,b,c,d] () = "4a" $ [alpha a, alpha b, alpha c, alpha d]
134 :     | list alpha [a,b,c,d,e] () =
135 :     "5a" $ [alpha a, alpha b, alpha c, alpha d, alpha e]
136 :     | list alpha (a::b::c::d::e::rest) () =
137 :     "Ma" $ [alpha a, alpha b, alpha c, alpha d, alpha e, list alpha rest]
138 :    
139 :     fun tuple2 (alpha,beta) (x,y) () = "Tb" $ [alpha x, beta y]
140 :    
141 :     fun option alpha (SOME x) () = "Sc" $ [alpha x]
142 :     | option alpha NONE () = "Nc" $ []
143 :    
144 :     fun bool true () = "Td" $ []
145 :     | bool false() = "Fd" $ []
146 :    
147 :     fun persstamp x = W.w8vector (PS.toBytes x)
148 :    
149 :     fun symbol s () =
150 :     let val code =
151 :     case S.nameSpace s
152 :     of S.VALspace => "Ap"
153 :     | S.TYCspace => "Bp"
154 :     | S.SIGspace => "Cp"
155 :     | S.STRspace => "Dp"
156 :     | S.FCTspace => "Ep"
157 :     | S.FIXspace => "Fp"
158 :     | S.LABspace => "Gp"
159 :     | S.TYVspace => "Hp"
160 :     | S.FSIGspace=> "Ip"
161 :     in code $ [W.string(S.name s)]
162 :     end
163 :    
164 :     val int = W.int
165 :     val word = W.string o Word.toString
166 :     val word32 = W.string o Word32.toString
167 :     val int32 = W.string o Int32.toString
168 :    
169 :     (* val apath = int list *)
170 :    
171 :     fun numkind (P.INT i) () = "Ig" $ [int i]
172 :     | numkind (P.UINT i) () = "Ug" $ [int i]
173 :     | numkind (P.FLOAT i) () = "Fg" $ [int i]
174 :    
175 :     fun arithop P.+ () = "ah" $ []
176 :     | arithop P.- () = "bh" $ []
177 :     | arithop P.* () = "ch" $ []
178 :     | arithop P./ () = "dh" $ []
179 :     | arithop P.~ () = "eh" $ []
180 :     | arithop P.ABS () = "fh" $ []
181 :     | arithop P.LSHIFT () = "gh" $ []
182 :     | arithop P.RSHIFT () = "hh" $ []
183 :     | arithop P.RSHIFTL () = "ih" $ []
184 :     | arithop P.ANDB () = "jh" $ []
185 :     | arithop P.ORB () = "kh" $ []
186 :     | arithop P.XORB () = "lh" $ []
187 :     | arithop P.NOTB () = "mh" $ []
188 :    
189 :     fun cmpop P.> () = "ai" $ []
190 :     | cmpop P.>= () = "bi" $ []
191 :     | cmpop P.< () = "ci" $ []
192 :     | cmpop P.<= () = "di" $ []
193 :     | cmpop P.LEU () = "ei" $ []
194 :     | cmpop P.LTU () = "fi" $ []
195 :     | cmpop P.GEU () = "gi" $ []
196 :     | cmpop P.GTU () = "hi" $ []
197 :     | cmpop P.EQL () = "ii" $ []
198 :     | cmpop P.NEQ () = "ji" $ []
199 :    
200 :     fun primop (P.ARITH{oper=p,overflow=v,kind=k}) () =
201 :     "Aj" $ [arithop p, bool v, numkind k]
202 :     | primop (P.CMP{oper=p,kind=k}) () =
203 :     "Cj" $ [cmpop p, numkind k]
204 :    
205 :     | primop (P.TEST(from,to)) () = "Gj" $ [int from, int to]
206 :     | primop (P.TESTU(from,to)) () = "Hj" $ [int from, int to]
207 :     | primop (P.TRUNC(from,to)) () = "Ij" $ [int from, int to]
208 :     | primop (P.EXTEND(from,to)) () = "Jj" $ [int from, int to]
209 :     | primop (P.COPY(from,to)) () = "Kj" $ [int from, int to]
210 :    
211 :     | primop (P.INLLSHIFT k) () = "<j" $ [numkind k]
212 :     | primop (P.INLRSHIFT k) () = ">j" $ [numkind k]
213 :     | primop (P.INLRSHIFTL k) () = "Lj" $ [numkind k]
214 :    
215 :     | primop (P.ROUND{floor=f,fromkind=k,tokind=t}) () =
216 :     "Rj" $ [bool f, numkind k, numkind t]
217 :     | primop (P.REAL{fromkind=k,tokind=t}) () =
218 :     "Fj" $ [numkind k, numkind t]
219 :     | primop (P.NUMSUBSCRIPT{kind=k,checked=c,immutable=i}) () =
220 :     "Sj" $ [numkind k, bool c, bool i]
221 :     | primop (P.NUMUPDATE{kind=k,checked=c}) () =
222 :     "Uj" $ [numkind k, bool c]
223 :     | primop (P.INL_MONOARRAY k) () = "Mj" $ [numkind k]
224 :     | primop (P.INL_MONOVECTOR k) () = "Vj" $ [numkind k]
225 :    
226 : monnier 45 | primop (P.MKETAG) () = "Xj" $ []
227 :     | primop (P.WRAP) () = "Yj" $ []
228 :     | primop (P.UNWRAP) () = "Zj" $ []
229 :    
230 : monnier 16 | primop P.SUBSCRIPT () = "ak" $ []
231 :     | primop P.SUBSCRIPTV () = "bk" $ []
232 :     | primop P.INLSUBSCRIPT () = "ck" $ []
233 :     | primop P.INLSUBSCRIPTV () = "dk" $ []
234 :     | primop P.INLMKARRAY () = "~k" $ []
235 :    
236 :     | primop P.PTREQL () = "ek" $ []
237 :     | primop P.PTRNEQ () = "fk" $ []
238 :     | primop P.POLYEQL () = "gk" $ []
239 :     | primop P.POLYNEQ () = "hk" $ []
240 :     | primop P.BOXED () = "ik" $ []
241 :     | primop P.UNBOXED () = "jk" $ []
242 :     | primop P.LENGTH () = "kk" $ []
243 :     | primop P.OBJLENGTH () = "lk" $ []
244 :     | primop P.CAST () = "mk" $ []
245 :     | primop P.GETRUNVEC () = "nk" $ []
246 :     | primop P.MARKEXN () = "[k" $ []
247 :     | primop P.GETHDLR () = "ok" $ []
248 :     | primop P.SETHDLR () = "pk" $ []
249 :     | primop P.GETVAR () = "qk" $ []
250 :     | primop P.SETVAR () = "rk" $ []
251 :     | primop P.GETPSEUDO () = "sk" $ []
252 :     | primop P.SETPSEUDO () = "tk" $ []
253 :     | primop P.SETMARK () = "uk" $ []
254 :     | primop P.DISPOSE () = "vk" $ []
255 :     | primop P.MAKEREF () = "wk" $ []
256 :     | primop P.CALLCC () = "xk" $ []
257 :     | primop P.CAPTURE () = "yk" $ []
258 :     | primop P.THROW () = "zk" $ []
259 :     | primop P.DEREF () = "1k" $ []
260 :     | primop P.ASSIGN () = "2k" $ []
261 :     | primop P.UPDATE () = "3k" $ []
262 :     | primop P.INLUPDATE () = "4k" $ []
263 :     | primop P.BOXEDUPDATE () = "5k" $ []
264 :     | primop P.UNBOXEDUPDATE () = "6k" $ []
265 :    
266 :     | primop P.GETTAG () = "7k" $ []
267 :     | primop P.MKSPECIAL () = "8k" $ []
268 :     | primop P.SETSPECIAL () = "9k" $ []
269 :     | primop P.GETSPECIAL () = "0k" $ []
270 :     | primop P.USELVAR () = "!k" $ []
271 :     | primop P.DEFLVAR () = "@k" $ []
272 :     | primop P.INLDIV () = "#k" $ []
273 :     | primop P.INLMOD () = "$k" $ []
274 :     | primop P.INLREM () = "%k" $ []
275 :     | primop P.INLMIN () = "^k" $ []
276 :     | primop P.INLMAX () = "&k" $ []
277 :     | primop P.INLABS () = "*k" $ []
278 :     | primop P.INLNOT () = "(k" $ []
279 :     | primop P.INLCOMPOSE () = ")k" $ []
280 :     | primop P.INLBEFORE () = ",k" $ []
281 :     | primop P.INL_ARRAY () = ".k" $ []
282 :     | primop P.INL_VECTOR () = "/k" $ []
283 :     | primop P.ISOLATE () = ":k" $ []
284 : monnier 69 | primop P.WCAST () = ";k" $ []
285 : monnier 16
286 : monnier 45
287 : monnier 16 fun consig (A.CSIG(i,j)) () = "S8" $ [W.int i, W.int j]
288 :     | consig (A.CNIL) () = "N8" $ []
289 :    
290 :     fun mkAccess var =
291 :     let fun access (A.LVAR i) () = "Ll" $ [var i]
292 :     | access (A.EXTERN p) () = "El" $ [persstamp p]
293 :     | access (A.PATH(a,i)) () = "Pl" $ [int i, access a]
294 :     | access (A.NO_ACCESS) () = "Nl" $ []
295 :    
296 :     fun conrep (A.UNTAGGED) () = "Um" $ []
297 :     | conrep (A.TAGGED i) () = "Tm" $ [int i]
298 :     | conrep (A.TRANSPARENT) () = "Bm" $ []
299 :     | conrep (A.CONSTANT i) () = "Cm" $ [int i]
300 :     | conrep (A.REF) () = "Rm" $ []
301 :     | conrep (A.EXN a) () = "Vm" $ [access a]
302 :     | conrep (A.LISTCONS) () = "Lm" $ []
303 :     | conrep (A.LISTNIL) () = "Nm" $ []
304 :     | conrep (A.SUSP NONE) () = "Sm" $ []
305 :     | conrep (A.SUSP (SOME (a,b))) () = "Xm" $ [access a, access b]
306 :    
307 :     in {access=access,conrep=conrep}
308 :     end
309 :    
310 :     fun alphaConverter () =
311 :     let exception AlphaCvt
312 :     val m: int Intmap.intmap = Intmap.new (32, AlphaCvt)
313 :     val alphacount = ref 0
314 :     fun alphaConvert i =
315 :     (Intmap.map m i
316 :     handle AlphaCvt => (let val j = !alphacount
317 :     in alphacount := j+1;
318 :     Intmap.add m (i,j);
319 :     j
320 :     end))
321 :     in alphaConvert
322 :     end
323 :    
324 :     fun mkStamp alphaConvert =
325 :     let fun stamp (Stamps.STAMP{scope=Stamps.LOCAL, count=i}) () =
326 :     "Le" $ [W.int(alphaConvert i)]
327 :     | stamp (Stamps.STAMP{scope=Stamps.GLOBAL pid, count=i}) () =
328 :     "Ge" $ [persstamp pid, W.int i]
329 :     | stamp (Stamps.STAMP{scope=Stamps.SPECIAL s, count=i}) () =
330 :     "Se" $ [W.string s, W.int i]
331 :     in stamp
332 :     end
333 :    
334 :     (** NOTE: the CRC functions really ought to work on Word8Vector.vectors **)
335 :     fun pickle2hash pickle =
336 :     PS.fromBytes(Byte.stringToBytes(CRC.toString(
337 :     CRC.fromString(Byte.bytesToString pickle))))
338 :    
339 :    
340 :     (**************************************************************************
341 :     * PICKLING A LAMBDA EXPRESSIONS *
342 :     **************************************************************************)
343 :    
344 :     fun mkPickleLty (stamp,tvar) =
345 :     let fun ltyI x () =
346 :     (case LK.lt_out x
347 :     of LK.LT_TYC tc => "An" $ [tyc tc]
348 :     | LK.LT_STR l => "Bn" $ [list lty l]
349 :     | LK.LT_PST l => "Cn" $ [list (tuple2 (int, lty)) l]
350 :     | LK.LT_FCT (ts1,ts2) => "Dn" $ [list lty ts1, list lty ts2]
351 :     | LK.LT_POLY(ks,ts) => "En" $ [list tkind ks, list lty ts]
352 :     | LK.LT_IND _ =>
353 :     bug "unexpected LT_IND in mkPickeLty"
354 :     | LK.LT_ENV (lt,ol,nl,te) =>
355 :     bug "unexpected LT_ENV in mkPickeLty"
356 :     | LK.LT_CONT _ =>
357 :     bug "unexpected LT_CONT in mkPickeLty")
358 :    
359 :     and lty x () =
360 :     if (LK.ltp_norm x) then
361 :     (W.identify (LTkey x) (fn () => ltyI x ()))
362 :     else ltyI x ()
363 :     (* bug "unexpected complex lambda type in mkPickleLty" *)
364 :    
365 :     and tycI x () =
366 :     (case LK.tc_out x
367 :     of LK.TC_VAR(db,i) => "A6" $ [int(DI.di_toint db), int i]
368 :     | LK.TC_NVAR(n, dp, i) =>
369 :     "B6" $ [int n, int(DI.dp_toint dp), int i]
370 :     | LK.TC_PRIM t => "C6" $ [int(PT.pt_toint t)]
371 :     | LK.TC_FN(ks,tc) => "D6" $ [list tkind ks, tyc tc]
372 :     | LK.TC_APP(tc,l) => "E6" $ [tyc tc, list tyc l]
373 :     | LK.TC_SEQ l => "F6" $ [list tyc l]
374 :     | LK.TC_PROJ(tc,i) => "G6" $ [tyc tc, int i]
375 :     | LK.TC_SUM l => "H6" $ [list tyc l]
376 :     | LK.TC_FIX((n,tc,ts),i) =>
377 :     "I6" $ [int n, tyc tc, list tyc ts, int i]
378 :     | LK.TC_ABS tc => "J6" $ [tyc tc]
379 :     | LK.TC_BOX tc => "K6" $ [tyc tc]
380 : monnier 45 | LK.TC_TUPLE (_,l) => "L6" $ [list tyc l]
381 :     | LK.TC_ARROW (LK.FF_VAR(b1,b2),ts1,ts2) =>
382 : monnier 16 "M6" $ [bool b1, bool b2, list tyc ts1, list tyc ts2]
383 : monnier 45 | LK.TC_ARROW (LK.FF_FIXED,ts1,ts2) =>
384 :     "N6" $ [list tyc ts1, list tyc ts2]
385 : monnier 16 | LK.TC_PARROW _ =>
386 :     bug "unexpected TC_PARROW in mkPickleLty"
387 : monnier 45 | LK.TC_TOKEN(k, t) =>
388 :     "O6" $ [int (LK.token_int k), tyc t]
389 : monnier 16 | LK.TC_IND _ =>
390 :     bug "unexpected TC_IND in mkPickleLty"
391 :     | LK.TC_ENV (tc, ol, nl, te) =>
392 :     bug "unexpected TC_ENV in mkPickleLty"
393 :     | LK.TC_CONT _ =>
394 :     bug "unexpected TC_CONT in mkPickleLty")
395 :    
396 :     and tyc x () =
397 :     if (LK.tcp_norm x) then
398 :     (W.identify (TCkey x) (fn () => tycI x ()))
399 :     else tycI x ()
400 :     (* bug "unexpected complex lambda tyc in mkPickleLty" *)
401 :    
402 :     and tkind x () =
403 :     W.identify (TKkey x)
404 :     (fn ()=>
405 :     case LK.tk_out x
406 :     of LK.TK_MONO => "A7" $ []
407 :     | LK.TK_BOX => "B7" $ []
408 :     | LK.TK_SEQ ks => "C7" $ [list tkind ks]
409 : monnier 45 | LK.TK_FUN(ks,k) => "D7" $ [list tkind ks, tkind k])
410 : monnier 16
411 :     in {lty=lty,tyc=tyc,tkind=tkind}
412 :     end
413 :    
414 : monnier 45 fun pickleFLINT fdecOp =
415 : monnier 16 let val alphaConvert = alphaConverter()
416 :     val stamp = mkStamp alphaConvert
417 :     val lvar = int o alphaConvert
418 :     val tvar = lvar
419 :     val {access,conrep} = mkAccess lvar
420 :     val {lty,tyc,tkind} = mkPickleLty(stamp,tvar)
421 :    
422 : monnier 45 fun con (F.DATAcon (dc, ts, v), e) () =
423 :     ".5" $ [dcon (dc, ts), lvar v, lexp e]
424 :     | con (F.INTcon i, e) () = ",5" $ [int i, lexp e]
425 :     | con (F.INT32con i32, e) () = "=5" $ [int32 i32, lexp e]
426 :     | con (F.WORDcon w, e) () = "?5" $ [word w, lexp e]
427 :     | con (F.WORD32con w32, e) () = ">5" $ [word32 w32, lexp e]
428 :     | con (F.REALcon s, e) () = "<5" $ [W.string s, lexp e]
429 :     | con (F.STRINGcon s, e) () = "'5" $ [W.string s, lexp e]
430 :     | con (F.VLENcon i, e) () = ";5" $ [int i, lexp e]
431 : monnier 16
432 : monnier 45 and dcon ((s, cr, t), ts) () =
433 :     "^5" $ [symbol s, conrep cr, lty t, list tyc ts]
434 :    
435 : monnier 16 and dict {default=v, table=tbls} () =
436 :     "%5" $ [lvar v, list (tuple2 (list tyc, lvar)) tbls]
437 :    
438 : monnier 45 and value (F.VAR v) () = "a5" $ [lvar v]
439 :     | value (F.INT i) () = "b5" $ [int i]
440 :     | value (F.INT32 i32) () = "c5" $ [int32 i32]
441 :     | value (F.WORD w) () = "d5" $ [word w]
442 :     | value (F.WORD32 w32) () = "e5" $ [word32 w32]
443 :     | value (F.REAL s) () = "f5" $ [W.string s]
444 :     | value (F.STRING s) () = "g5" $ [W.string s]
445 : monnier 16
446 : monnier 45 and fprim (NONE, p, t, ts) () =
447 :     "h5" $ [primop p, lty t, list tyc ts]
448 :     | fprim (SOME dt, p, t, ts) () =
449 :     "i5" $ [dict dt, primop p, lty t, list tyc ts]
450 : monnier 16
451 : monnier 45 and lexp (F.RET vs) () = "j5" $ [list value vs]
452 :     | lexp (F.LET(vs, e1, e2)) () =
453 :     "k5" $ [list lvar vs, lexp e1, lexp e2]
454 :     | lexp (F.FIX (fdecs, e)) () = "l5" $ [list fundec fdecs, lexp e]
455 :     | lexp (F.APP (v, vs)) () = "m5" $ [value v, list value vs]
456 :     | lexp (F.TFN(tfdec, e)) () =
457 :     "n5" $ [tfundec tfdec, lexp e]
458 :     | lexp (F.TAPP(v, ts)) () =
459 :     "o5" $ [value v, list tyc ts]
460 :     | lexp (F.SWITCH (v, crl, cel, eo)) () =
461 :     "p5" $ [value v, consig crl, list con cel, option lexp eo]
462 :     | lexp (F.CON (dc, ts, u, v, e)) () =
463 :     "q5" $ [dcon(dc, ts), value u, lvar v, lexp e]
464 :     | lexp (F.RECORD(rk, vl, v, e)) () =
465 :     "r5" $ [rkind rk, list value vl, lvar v, lexp e]
466 :     | lexp (F.SELECT (u, i, v, e)) () =
467 :     "s5" $ [value u, int i, lvar v, lexp e]
468 :     | lexp (F.RAISE (u, ts)) () = "t5" $ [value u, list lty ts]
469 :     | lexp (F.HANDLE (e, u)) () = "u5" $ [lexp e, value u]
470 :     | lexp (F.BRANCH (p, vs, e1, e2)) () =
471 :     "v5" $ [fprim p, list value vs, lexp e1, lexp e2]
472 :     | lexp (F.PRIMOP (p, vs, v, e)) () =
473 :     "w5" $ [fprim p, list value vs, lvar v, lexp e]
474 :    
475 :     and fundec (fk, v, vts, e) () =
476 :     "05" $ [fkind fk, lvar v, list (tuple2(lvar, lty)) vts, lexp e]
477 :    
478 :     and tfundec (v, tvks, e) () =
479 :     "15" $ [lvar v, list (tuple2(tvar, tkind)) tvks, lexp e]
480 :    
481 :     and fkind (F.FK_FCT) () = "25" $ []
482 :     | fkind (F.FK_FUN {isrec, fixed=LK.FF_VAR(b1, b2),
483 :     known, inline}) () =
484 :     "35" $ [option (list lty) isrec, bool b1, bool b2, bool known,
485 :     bool inline]
486 :     | fkind (F.FK_FUN {isrec, fixed=LK.FF_FIXED, known, inline}) () =
487 :     "45" $ [option (list lty) isrec, bool known, bool inline]
488 :    
489 :     and rkind (F.RK_VECTOR tc) () = "55" $ [tyc tc]
490 :     | rkind (F.RK_STRUCT) () = "65" $ []
491 :     | rkind (F.RK_TUPLE _) () = "75" $ []
492 :    
493 :     val prog = fundec
494 :     val pickle = W.pickle (option prog fdecOp)
495 : monnier 16 val hash = pickle2hash pickle
496 :     in {pickle = pickle, hash = hash}
497 :     end
498 :    
499 :    
500 :     (**************************************************************************
501 :     * PICKLING AN ENVIRONMENT *
502 :     **************************************************************************)
503 :    
504 :     fun pickleEnv(context0, e0: B.binding Env.env) =
505 :     let val alphaConvert = alphaConverter ()
506 :     val stamp = mkStamp alphaConvert
507 :     val entVar = stamp
508 :     val entPath = list entVar
509 :    
510 :     fun modId (MI.STRid{rlzn=a,sign=b}) () = "Bf" $ [stamp a, stamp b]
511 :     | modId (MI.SIGid s) () = "Cf" $ [stamp s]
512 :     | modId (MI.FCTid{rlzn=a,sign=b}) () = "Ef" $ [stamp a, modId b]
513 :     | modId (MI.FSIGid{paramsig=a,bodysig=b}) () = "Ff" $ [stamp a, stamp b]
514 :     | modId (MI.TYCid a) () = "Gf" $ [stamp a]
515 :     | modId (MI.EENVid s) () = "Vf" $ [stamp s]
516 :    
517 :     val lvcount = ref 0
518 : monnier 45 val lvlist = ref ([]: Access.lvar list)
519 : monnier 16
520 :     fun anotherLvar v =
521 :     let val j = !lvcount
522 :     in lvlist := v :: !lvlist;
523 :     lvcount := j+1;
524 :     j
525 :     end
526 :    
527 :     val {access,conrep} = mkAccess (int o anotherLvar)
528 :     val {lty,tkind,...} = mkPickleLty(stamp, int o alphaConvert)
529 :    
530 :     (* SP.path and IP.path are both treated as symbol lists *)
531 :     fun spath (SP.SPATH p) = list symbol p
532 :     fun ipath (IP.IPATH p) = list symbol p
533 :    
534 :     val label = symbol
535 :    
536 :     fun eqprop T.YES () = "Yq" $ []
537 :     | eqprop T.NO () = "Nq" $ []
538 :     | eqprop T.IND () = "Iq" $ []
539 :     | eqprop T.OBJ () = "Oq" $ []
540 :     | eqprop T.DATA() = "Dq" $ []
541 :     | eqprop T.ABS () = "Aq" $ []
542 :     | eqprop T.UNDEF()= "Uq" $ []
543 :    
544 :     fun datacon (T.DATACON{name=n,const=c,typ=t,rep=r,sign=s}) () =
545 :     "Dr" $ [symbol n, bool c, ty t, conrep r, consig s]
546 :    
547 :     and tyckind (T.PRIMITIVE pt) () = "Ps" $ [int (PT.pt_toint pt)]
548 :     | tyckind (T.DATATYPE{index=i, family, stamps=ss, root, freetycs}) () =
549 :     "Ds" $ [W.int i, option entVar root,
550 :     dtypeInfo (ss, family, freetycs)]
551 :    
552 :     | tyckind (T.ABSTRACT tyc) () = "As" $ [tycon tyc]
553 :     | tyckind (T.FLEXTYC tps) () =
554 :     (*** tycpath should never be pickled; the only way it can be
555 :     pickled is when pickling the domains of a mutually
556 :     recursive datatypes; right now the mutually recursive
557 :     datatypes are not assigned accurate domains ... (ZHONG)
558 :     the following code is just a temporary gross hack.
559 :     ***)
560 :     "Fs" $ [] (* "Ss" $ [tycpath tps] *)
561 :     | tyckind (T.FORMAL) () = "Fs" $ []
562 :     | tyckind (T.TEMP) () = "Ts" $ []
563 :    
564 :     and dtypeInfo (ss, family, freetycs) () =
565 :     W.identify (DTkey (Vector.sub(ss,0)))
566 :     (fn () => "Zs" $ [list stamp (Vector.foldr (op ::) nil ss),
567 :     dtFamily family, list tycon freetycs])
568 :    
569 :     and dtFamily {mkey=s, members=v, lambdatyc} () =
570 :     W.identify (MBkey s)
571 :     (fn () => "Us" $ [stamp s,
572 :     (list dtmember (Vector.foldr (op ::) nil v))])
573 :    
574 :     and tycpath _ () = bug "unexpected tycpath during the pickling"
575 :    
576 :     and dtmember {tycname=n,dcons=d,arity=i,eq=ref e,sign=sn} () =
577 :     "Tt" $ [symbol n, list nameRepDomain d, int i, eqprop e,
578 :     consig sn]
579 :    
580 :     and nameRepDomain {name=n,rep=r,domain=t} () =
581 :     "Nu" $ [symbol n, conrep r, option ty t]
582 :    
583 :     and tycon (T.GENtyc{stamp=s, arity=a, eq=ref e, kind=k, path=p}) () =
584 :     let val id = MI.TYCid s
585 :     in W.identify(MIkey id)
586 :     (fn()=> case SCStaticEnv.lookTYC context0 id
587 :     of SOME _ => "Xv" $ [modId id]
588 :     | NONE => "Gv" $ [stamp s, int a, eqprop e,
589 :     tyckind k, ipath p])
590 :     end
591 :    
592 :     | tycon (T.DEFtyc{stamp=x, tyfun=T.TYFUN{arity=r,body=b},
593 :     strict=s, path=p}) () =
594 :     W.identify(MIkey(MI.TYCid x))
595 :     (fn()=> "Dw" $ [stamp x, int r, ty b, list bool s, ipath p])
596 :    
597 :     | tycon (T.PATHtyc{arity=a, entPath=e, path=p}) () =
598 :     "Pw" $ [int a, ipath p, entPath e]
599 :     (*
600 :     W.identify(EPkey e)
601 :     (fn()=>"Pw" $ [int a, entPath e, ipath p])
602 :     *)
603 :    
604 :     | tycon (T.RECORDtyc l) () = "Rw" $ [list label l]
605 :     | tycon (T.RECtyc i) () = "Cw" $ [int i]
606 :     | tycon (T.FREEtyc i) () = "Hw" $ [int i]
607 :     | tycon T.ERRORtyc () = "Ew" $ []
608 :    
609 :     and ty (T.VARty(ref(T.INSTANTIATED t))) () = ty t ()
610 :     | ty (T.VARty(ref(T.OPEN _))) () = (* "Vx" $ [tyvar v] *)
611 :     bug "uninstatiated VARty in pickmod"
612 :     | ty (T.CONty (c,[])) () = "Nx" $ [tycon c]
613 :     | ty (T.CONty (c,l)) () = "Cx" $ [tycon c, list ty l]
614 :     | ty (T.IBOUND i) () = "Ix" $ [int i]
615 :     | ty T.WILDCARDty () = "Wx" $ []
616 :     | ty (T.POLYty{sign=s,tyfun=T.TYFUN{arity=r,body=b}}) () =
617 :     "Px" $ [list bool s, int r, ty b]
618 :     | ty T.UNDEFty () = "Ux" $ []
619 :     | ty _ () = bug "unexpected types in pickmod-ty"
620 :    
621 :     fun inl_info (II.INL_PRIM(p, t)) () = "Py" $ [primop p, option ty t]
622 :     | inl_info (II.INL_STR sl) () = "Sy" $ [list inl_info sl]
623 :     | inl_info (II.INL_NO) () = "Ny" $ []
624 :     | inl_info _ () = bug "unexpected inl_info in pickmod"
625 :    
626 :     fun var (V.VALvar{access=a, info=z, path=p, typ=ref t}) () =
627 :     "Vz" $ [access a, inl_info z, spath p, ty t]
628 :     | var (V.OVLDvar{name=n, options=ref p,
629 :     scheme=T.TYFUN{arity=r,body=b}}) () =
630 :     "Oz" $ [symbol n, list overld p, int r, ty b]
631 :     | var V.ERRORvar () = "Ez" $ []
632 :    
633 :     and overld {indicator=i,variant=v} () = "OA" $ [ty i, var v]
634 :    
635 :     fun fsigId(M.FSIG{kind,
636 :     paramsig=p as M.SIG{stamp=ps,...},
637 :     paramvar=q,
638 :     paramsym=s,
639 :     bodysig=b as M.SIG{stamp=bs,...}}) =
640 :     MI.FSIGid{paramsig=ps,bodysig=bs}
641 :     | fsigId _ = bug "unexpected functor signatures in fsigId"
642 :    
643 :    
644 :     fun strDef(M.CONSTstrDef s) () = "CE" $ [Structure s]
645 :     | strDef(M.VARstrDef(s,p)) () = "VE" $ [Signature s,entPath p]
646 :    
647 :     (*
648 :     * boundeps is not pickled right now, but it really should
649 :     * be pickled in the future.
650 :     *)
651 :     and Signature (M.SIG{name=k, closed=c, fctflag=f,
652 :     stamp=m, symbols=l, elements=e,
653 :     boundeps=ref b, lambdaty=_, typsharing=t,
654 :     strsharing=s}) () =
655 :     let val id = MI.SIGid m
656 :     in W.identify (MIkey id)
657 :     (fn () =>
658 :     case (SCStaticEnv.lookSIG context0 id)
659 :     of SOME _ => "XE" $ [modId id]
660 :     | NONE => "SE" $ [option symbol k, bool c, bool f,
661 :     stamp m, list symbol l,
662 :     list (tuple2 (symbol,spec)) e,
663 :    
664 :     (* this is currently turned off ...
665 :     * option (list (tuple2 (entPath, tkind))) b,
666 :     *)
667 :     option (list (tuple2 (entPath, tkind))) NONE,
668 :     list (list spath) t,
669 :     list (list spath) s])
670 :     end
671 :    
672 :     | Signature M.ERRORsig () = "EE" $ []
673 :    
674 :     and fctSig (fs as M.FSIG{kind=k, paramsig=p, paramvar=q,
675 :     paramsym=s, bodysig=b}) () =
676 :     let val id = fsigId fs
677 :     in W.identify (MIkey id)
678 :     (fn () =>
679 :     case SCStaticEnv.lookFSIG context0 id
680 :     of SOME _ => "XF" $ [modId id]
681 :     | NONE => "FF" $ [option symbol k, Signature p,
682 :     entVar q, option symbol s,
683 :     Signature b])
684 :     end
685 :     | fctSig M.ERRORfsig () = "EF" $ []
686 :    
687 :     and spec (M.TYCspec{spec=t, entVar=v, scope=s}) () =
688 :     "TG" $ [tycon t,entVar v,int s]
689 :     | spec (M.STRspec{sign=s, slot=d, def=e, entVar=v}) () =
690 :     "SG" $ [Signature s, int d, option (tuple2 (strDef, int)) e, entVar v]
691 :     | spec (M.FCTspec{sign=s, slot=d, entVar=v}) () =
692 :     "FG" $ [fctSig s, int d, entVar v]
693 :     | spec (M.VALspec{spec=t, slot=d}) () = "PH" $ [ty t, int d]
694 :     | spec (M.CONspec{spec=c, slot=i}) () = "QH" $ [datacon c, option int i]
695 :    
696 :     and entity (M.TYCent t) () = "LI" $ [tycEntity t]
697 :     | entity (M.STRent t) () = "SI" $ [strEntity t]
698 :     | entity (M.FCTent t) () = "FI" $ [fctEntity t]
699 :     | entity M.ERRORent () = "EI" $ []
700 :    
701 :     and fctClosure (M.CLOSURE{param=p,body=s,env=e}) () =
702 :     "FJ" $ [entVar p, strExp s, entityEnv e]
703 :    
704 :     and Structure (m as M.STR{sign=s as M.SIG{stamp=g,...},
705 :     rlzn=r as {stamp=st,...},
706 :     access=a, info=z}) () =
707 :     let val id = MI.STRid{rlzn=st,sign=g}
708 :     in W.identify (MIkey id)
709 :     (fn () =>
710 :     case SCStaticEnv.lookSTR context0 id
711 :     of NONE =>
712 :     ((* if isGlobalStamp st andalso isGlobalStamp g
713 :     then say (String.concat["#pickmod: missed global structure ",
714 :     MI.idToString id, "\n"])
715 :     else (); *)
716 :     "SK" $ [Signature s, strEntity r,
717 :     access a, inl_info z])
718 :     | SOME _ => "XK" $ [modId id, access a])
719 :     end
720 :     | Structure (M.STRSIG{sign=s,entPath=p}) () =
721 :     "GK" $ [Signature s, entPath p]
722 :     | Structure M.ERRORstr () = "EK" $ []
723 :     | Structure _ () = bug "unexpected structure in Structure"
724 :    
725 :     and Functor (M.FCT{sign=s, rlzn=r as {stamp=m,...},
726 :     access=a, info=z}) () =
727 :     let val sigid = fsigId s
728 :     val id = MI.FCTid{rlzn=m, sign=sigid}
729 :     in W.identify (MIkey id)
730 :     (fn () =>
731 :     case SCStaticEnv.lookFCT context0 id
732 :     of NONE =>
733 :     ((* if isGlobalStamp m andalso
734 :     (case sigid
735 :     of MI.FSIGid{paramsig,bodysig} =>
736 :     isGlobalStamp paramsig andalso
737 :     isGlobalStamp bodysig
738 :     | _ => (say "#pickmod: funny functor sig id\n";
739 :     false))
740 :     then say (String.concat["#pickmod: missed global functor ",
741 :     MI.idToString id, "\n"])
742 :     else (); *)
743 :     "FL" $ [fctSig s, fctEntity r,
744 :     access a, inl_info z])
745 :     | SOME _ => "XL" $ [modId id, access a])
746 :     end
747 :     | Functor M.ERRORfct () = "EL" $ []
748 :    
749 :     and stampExp (M.CONST s) () = "CM" $ [stamp s]
750 :     | stampExp (M.GETSTAMP s) () = "GM" $ [strExp s]
751 :     | stampExp M.NEW () = "NM" $ []
752 :    
753 :     and tycExp (M.CONSTtyc t) () = "CN" $ [tycon t]
754 :     | tycExp (M.FORMtyc t) () = "DN" $ [tycon t]
755 :     | tycExp (M.VARtyc s) () = "VN" $ [entPath s]
756 :    
757 :     and strExp (M.VARstr s) () = "VO" $ [entPath s]
758 :     | strExp (M.CONSTstr s) () = "CO" $ [strEntity s]
759 :     | strExp (M.STRUCTURE{stamp=s,entDec=e}) () =
760 :     "SO" $ [stampExp s, entityDec e]
761 :     | strExp (M.APPLY(f,s)) () = "AO" $ [fctExp f, strExp s]
762 :     | strExp (M.LETstr(e,s)) () = "LO" $ [entityDec e, strExp s]
763 :     | strExp (M.ABSstr(s,e)) () = "BO" $ [Signature s, strExp e]
764 :     | strExp (M.CONSTRAINstr{boundvar,raw,coercion}) () =
765 :     "RO" $ [entVar boundvar, strExp raw, strExp coercion]
766 :     | strExp (M.FORMstr fs) () = "FO" $ [fctSig fs]
767 :    
768 :     and fctExp (M.VARfct s) () = "VP" $ [entPath s]
769 :     | fctExp (M.CONSTfct e) () = "CP" $ [fctEntity e]
770 :     | fctExp (M.LAMBDA{param=p,body=b}) () = "LP" $ [entVar p, strExp b]
771 :     | fctExp (M.LAMBDA_TP{param=p, body=b, sign=fs}) () =
772 :     "PP" $ [entVar p, strExp b, fctSig fs]
773 :     | fctExp (M.LETfct(e,f)) () = "TP" $ [entityDec e, fctExp f]
774 :    
775 :     and entityExp (M.TYCexp t) () = "TQ" $ [tycExp t]
776 :     | entityExp (M.STRexp t) () = "SQ" $ [strExp t]
777 :     | entityExp (M.FCTexp t) () = "FQ" $ [fctExp t]
778 :     | entityExp (M.ERRORexp) () = "EQ" $ []
779 :     | entityExp (M.DUMMYexp) () = "DQ" $ []
780 :    
781 :     and entityDec (M.TYCdec(s,x)) () = "TR" $ [entVar s, tycExp x]
782 :     | entityDec (M.STRdec(s,x,n)) () = "SR" $ [entVar s, strExp x, symbol n]
783 :     | entityDec (M.FCTdec(s,x)) () = "FR" $ [entVar s, fctExp x]
784 :     | entityDec (M.SEQdec e) () = "QR" $ [list entityDec e]
785 :     | entityDec (M.LOCALdec(a,b)) () = "LR" $ [entityDec a, entityDec b]
786 :     | entityDec M.ERRORdec () = "ER" $ []
787 :     | entityDec M.EMPTYdec () = "MR" $ []
788 :    
789 :     and entityEnv (M.MARKeenv(s,r)) () =
790 :     let val id = MI.EENVid s
791 :     in W.identify(MIkey id)
792 :     (fn() => case SCStaticEnv.lookEENV context0 id
793 :     of SOME _ => "X4" $ [modId id]
794 :     | NONE => "M4" $ [stamp s, entityEnv r])
795 :     end
796 :     | entityEnv (M.BINDeenv(d, r)) () =
797 :     "B4" $ [list (tuple2(entVar, entity)) (ED.members d), entityEnv r]
798 :     | entityEnv M.NILeenv () = "N4" $ []
799 :     | entityEnv M.ERReenv () = "E4" $ []
800 :    
801 :     and strEntity {stamp=s, entities=e, lambdaty=_, rpath=r} () =
802 :     "SS" $ [stamp s, entityEnv e, ipath r]
803 :    
804 :     and fctEntity {stamp=s, closure=c, lambdaty=_,
805 :     tycpath=_, rpath=r} () =
806 :     "FT" $ [stamp s, fctClosure c, ipath r]
807 :     (* | fctEntity {stamp=s, closure=c, lambdaty=ref t,
808 :     tycpath=SOME _, rpath=r} () =
809 :     bug "unexpected fctEntity in pickmod"
810 :     *)
811 :    
812 :     and tycEntity x () = tycon x ()
813 :    
814 :     fun fixity Fixity.NONfix () = "NW" $ []
815 :     | fixity (Fixity.INfix(i,j)) () = "IW" $ [int i, int j]
816 :    
817 :     fun binding (B.VALbind x) () = "V2" $ [var x]
818 :     | binding (B.CONbind x) () = "C2" $ [datacon x]
819 :     | binding (B.TYCbind x) () = "T2" $ [tycon x]
820 :     | binding (B.SIGbind x) () = "G2" $ [Signature x]
821 :     | binding (B.STRbind x) () = "S2" $ [Structure x]
822 :     | binding (B.FSGbind x) () = "I2" $ [fctSig x]
823 :     | binding (B.FCTbind x) () = "F2" $ [Functor x]
824 :     | binding (B.FIXbind x) () = "X2" $ [fixity x]
825 :    
826 :     fun env alpha e () =
827 :     let fun uniq (a::b::rest) = if S.eq(a,b) then uniq(b::rest)
828 :     else a::uniq(b::rest)
829 :     | uniq l = l
830 :     val syms = uniq(Sort.sort S.symbolGt (Env.symbols e))
831 :     val pairs = map (fn s => (s, Env.look(e,s))) syms
832 :     in "E3" $ [list (tuple2(symbol,alpha)) pairs]
833 :     end
834 :    
835 :     val pickle = W.pickle (env binding e0)
836 :    
837 :     val hash = pickle2hash pickle
838 :    
839 :     val exportLvars = rev(!lvlist)
840 :     val exportPid = case exportLvars of [] => NONE
841 :     | _ => SOME hash
842 :    
843 :     in addPickles (Word8Vector.length pickle);
844 :     {hash = hash,
845 :     pickle = pickle,
846 :     exportLvars = exportLvars,
847 :     exportPid = exportPid}
848 :     end (* fun pickleEnv *)
849 :    
850 :     fun dontPickle (senv : StaticEnv.staticEnv, count) =
851 :     let val hash =
852 :     let val toByte = Word8.fromLargeWord o Word32.toLargeWord
853 :     val >> = Word32.>>
854 :     infix >>
855 :     val w = Word32.fromInt count
856 :     in
857 :     PersStamps.fromBytes(
858 :     Word8Vector.fromList
859 :     [0w0,0w0,0w0,toByte(w >> 0w24),0w0,0w0,0w0,toByte(w >> 0w16),
860 :     0w0,0w0,0w0,toByte(w >> 0w8),0w0,0w0,0w0,toByte(w)])
861 :     end
862 :     fun uniq (a::b::rest) = if S.eq(a,b) then uniq(b::rest)
863 :     else a::uniq(b::rest)
864 :     | uniq l = l
865 :     (* next two lines are alternative to using Env.consolidate *)
866 :     val syms = uniq(Sort.sort S.symbolGt (Env.symbols senv))
867 :     fun newAccess i = A.PATH (A.EXTERN hash, i)
868 :     fun mapbinding(sym,(i,env,lvars)) =
869 :     case Env.look(senv,sym)
870 :     of B.VALbind(V.VALvar{access=a, info=z, path=p, typ=ref t}) =>
871 :     (case a
872 :     of A.LVAR k =>
873 :     (i+1,
874 :     Env.bind(sym,B.VALbind(V.VALvar{access=newAccess i,
875 :     info=z, path=p,
876 :     typ=ref t}),
877 :     env),
878 :     k :: lvars)
879 :     | _ => (say(A.prAcc a ^ "\n"); bug "dontPickle 1"))
880 :     | B.STRbind(M.STR{sign=s, rlzn=r, access=a, info=z}) =>
881 :     (case a
882 :     of A.LVAR k =>
883 :     (i+1,
884 :     Env.bind(sym,B.STRbind(M.STR{access=newAccess i,
885 :     sign=s,rlzn=r,info=z}),
886 :     env),
887 :     k :: lvars)
888 :     | _ => (say(A.prAcc a ^ "\n"); bug "dontPickle 2"))
889 :     | B.FCTbind(M.FCT{sign=s, rlzn=r, access=a, info=z}) =>
890 :     (case a
891 :     of A.LVAR k =>
892 :     (i+1,
893 :     Env.bind(sym,B.FCTbind(M.FCT{access=newAccess i,
894 :     sign=s,rlzn=r,info=z}),
895 :     env),
896 :     k :: lvars)
897 :     | _ => (say(A.prAcc a ^ "\n"); bug "dontPickle 3"))
898 :     | B.CONbind(T.DATACON{name=n,const=c,typ=t,sign=s,
899 :     rep as (A.EXN a)}) =>
900 :     let val newrep = A.EXN (newAccess i)
901 :     in case a
902 :     of A.LVAR k =>
903 :     (i+1,
904 :     Env.bind(sym,B.CONbind
905 :     (T.DATACON{rep=newrep, name=n,
906 :     const=c, typ=t, sign=s}),
907 :     env),
908 :     k :: lvars)
909 :     | _ => (say(A.prAcc a ^ "\n"); bug "dontPickle 4")
910 :     end
911 :     | binding =>
912 :     (i, Env.bind(sym,binding,env), lvars)
913 :     val (_,newenv,lvars) = foldl mapbinding (0,StaticEnv.empty,nil) syms
914 :     val exportPid = case lvars
915 :     of [] => NONE
916 :     | _ => SOME hash
917 :     in (newenv,hash,rev(lvars),exportPid)
918 :     end
919 :    
920 :     end (* toplevel local *)
921 :     end (* structure PickMod *)
922 :    
923 :    

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