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

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