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/unpickmod-new.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1548 - (view) (download)

1 : monnier 427 (*
2 :     * The new unpickler (based on the new generic unpickling facility).
3 :     *
4 : blume 587 * The unpickler embeds a "modtree" into the unpickled environment.
5 :     * The modtree allows for very rapid construction of modmaps so that
6 :     * modmaps do not have to be stored permanently but can be built on-demand.
7 :     * (Permanently stored modmaps incur space problems: one has to be careful
8 :     * that they don't hang on to bindings that no longer exist, and because
9 :     * of sharing there can be significant overlap--and space overhead--in what
10 :     * each such map points to. Modtrees do not have these problems.)
11 :     *
12 : blume 588 * The embedding of modtrees into static environments follows the example
13 :     * of the control-flow in the original "cmstatenv.sml" module. This means
14 :     * that not all possible branches of the environment data structure are
15 :     * explored when building modmaps. I dearly hope that the original code
16 :     * was correct in its assumptions...
17 :     *
18 : blume 587 * March 2000, Matthias Blume
19 : monnier 427 *)
20 :     signature UNPICKMOD = sig
21 :    
22 : blume 632 type context = (int * Symbol.symbol) option -> ModuleId.tmap
23 : monnier 504
24 : blume 587 val unpickleEnv : context ->
25 :     PersStamps.persstamp * Word8Vector.vector ->
26 :     StaticEnv.staticEnv
27 : monnier 427
28 : blume 879 val unpickleFLINT : Word8Vector.vector -> FLINT.prog option
29 : monnier 427
30 : blume 587 (* The env unpickler resulting from "mkUnpicklers" cannot be used for
31 : monnier 427 * "original" environments that come out of the elaborator. For those,
32 :     * continue to use "unpickleEnv". "mkUnpicklers" is intended to be
33 : blume 587 * used by CM's stable library mechanism. *)
34 : monnier 427 val mkUnpicklers :
35 : blume 587 { session: UnpickleUtil.session,
36 :     stringlist: string list UnpickleUtil.reader } ->
37 :     context ->
38 : blume 902 { symenv: SymbolicEnv.env UnpickleUtil.reader,
39 : blume 587 statenv: StaticEnv.staticEnv UnpickleUtil.reader,
40 :     symbol: Symbol.symbol UnpickleUtil.reader,
41 :     symbollist: Symbol.symbol list UnpickleUtil.reader }
42 : monnier 427 end
43 :    
44 :     structure UnpickMod : UNPICKMOD = struct
45 :    
46 : blume 632 type context = (int * Symbol.symbol) option -> ModuleId.tmap
47 : blume 587
48 : monnier 427 structure A = Access
49 :     structure DI = DebIndex
50 :     structure LT = LtyDef
51 :     structure LK = LtyKernel
52 :     structure PT = PrimTyc
53 :     structure F = FLINT
54 :     structure T = Types
55 :     structure SP = SymPath
56 :     structure IP = InvPath
57 :     structure MI = ModuleId
58 :     structure II = InlInfo
59 :     structure V = VarCon
60 :     structure ED = EntPath.EvDict
61 :     structure PS = PersStamps
62 :     structure P = PrimOp
63 :     structure M = Modules
64 :     structure B = Bindings
65 :    
66 :     structure UU = UnpickleUtil
67 :     exception Format = UU.Format
68 :    
69 :     (* The order of the entries in the following tables
70 :     * must be coordinated with pickmod! *)
71 :     val primop_table =
72 :     #[P.MKETAG,
73 :     P.WRAP,
74 :     P.UNWRAP,
75 :     P.SUBSCRIPT,
76 :     P.SUBSCRIPTV,
77 :     P.INLSUBSCRIPT,
78 :     P.INLSUBSCRIPTV,
79 :     P.INLMKARRAY,
80 :    
81 :     P.PTREQL,
82 :     P.PTRNEQ,
83 :     P.POLYEQL,
84 :     P.POLYNEQ,
85 :     P.BOXED,
86 :     P.UNBOXED,
87 :     P.LENGTH,
88 :     P.OBJLENGTH,
89 :     P.CAST,
90 :     P.GETRUNVEC,
91 :     P.MARKEXN,
92 :     P.GETHDLR,
93 :     P.SETHDLR,
94 :     P.GETVAR,
95 :     P.SETVAR,
96 :     P.GETPSEUDO,
97 :     P.SETPSEUDO,
98 :     P.SETMARK,
99 :     P.DISPOSE,
100 :     P.MAKEREF,
101 :     P.CALLCC,
102 :     P.CAPTURE,
103 :     P.THROW,
104 :     P.DEREF,
105 :     P.ASSIGN,
106 :     P.UPDATE,
107 :     P.INLUPDATE,
108 :     P.BOXEDUPDATE,
109 :     P.UNBOXEDUPDATE,
110 :    
111 :     P.GETTAG,
112 :     P.MKSPECIAL,
113 :     P.SETSPECIAL,
114 :     P.GETSPECIAL,
115 :     P.USELVAR,
116 :     P.DEFLVAR,
117 :     P.INLNOT,
118 :     P.INLCOMPOSE,
119 :     P.INLBEFORE,
120 :     P.INL_ARRAY,
121 :     P.INL_VECTOR,
122 :     P.ISOLATE,
123 :     P.WCAST,
124 :     P.NEW_ARRAY0,
125 :     P.GET_SEQ_DATA,
126 :     P.SUBSCRIPT_REC,
127 :     P.SUBSCRIPT_RAW64,
128 : blume 772 P.UNBOXEDASSIGN,
129 : blume 1183 P.RAW_CCALL NONE,
130 : mblume 1347 P.INLIGNORE,
131 :     P.INLIDENTITY
132 : leunga 1174 ]
133 : monnier 427
134 :     val cmpop_table =
135 :     #[P.>, P.>=, P.<, P.<=, P.LEU, P.LTU, P.GEU, P.GTU, P.EQL, P.NEQ]
136 :    
137 :     val arithop_table =
138 :     #[P.+, P.-, P.*, P./, P.~, P.ABS, P.LSHIFT, P.RSHIFT, P.RSHIFTL,
139 : blume 1183 P.ANDB, P.ORB, P.XORB, P.NOTB, P.FSQRT, P.FSIN, P.FCOS, P.FTAN,
140 :     P.REM, P.DIV, P.MOD]
141 : monnier 427
142 :     val eqprop_table =
143 :     #[T.YES, T.NO, T.IND, T.OBJ, T.DATA, T.ABS, T.UNDEF]
144 :    
145 : blume 773 val ctype_table =
146 :     #[CTypes.C_void,
147 :     CTypes.C_float,
148 :     CTypes.C_double,
149 :     CTypes.C_long_double,
150 :     CTypes.C_unsigned CTypes.I_char,
151 :     CTypes.C_unsigned CTypes.I_short,
152 :     CTypes.C_unsigned CTypes.I_int,
153 :     CTypes.C_unsigned CTypes.I_long,
154 :     CTypes.C_unsigned CTypes.I_long_long,
155 :     CTypes.C_signed CTypes.I_char,
156 :     CTypes.C_signed CTypes.I_short,
157 :     CTypes.C_signed CTypes.I_int,
158 :     CTypes.C_signed CTypes.I_long,
159 :     CTypes.C_signed CTypes.I_long_long,
160 :     CTypes.C_PTR]
161 :    
162 : blume 587 fun & c (x, t) = (c x, t)
163 :    
164 :     fun branch l = let
165 :     fun loop ([], [x]) = x
166 :     | loop ([], l) = M.BRANCH l
167 :     | loop (M.BRANCH [] :: t, l) = loop (t, l)
168 :     | loop (M.BRANCH [x] :: t, l) = loop (t, x :: l) (* never occurs! *)
169 :     | loop (x :: t, l) = loop (t, x :: l)
170 :     in
171 :     loop (l, [])
172 :     end
173 :    
174 :     val notree = M.BRANCH []
175 :    
176 : monnier 427 fun mkSharedStuff (session, lvar) = let
177 :    
178 :     fun share m f = UU.share session m f
179 :     fun nonshare f = UU.nonshare session f
180 :    
181 :     val int = UU.r_int session
182 :     val bool = UU.r_bool session
183 :     fun list m r = UU.r_list session m r
184 : blume 774 fun option m r = UU.r_option session m r
185 : monnier 427 val string = UU.r_string session
186 :     val symbol = UnpickleSymPid.r_symbol (session, string)
187 :    
188 :     (* These maps will all acquire different types by being used in
189 :     * different contexts... *)
190 :     val accM = UU.mkMap ()
191 :     val crM = UU.mkMap ()
192 :     val csM = UU.mkMap ()
193 :     val nkM = UU.mkMap ()
194 :     val poM = UU.mkMap ()
195 :     val boolListM = UU.mkMap ()
196 : blume 774 val boolOptionM = UU.mkMap ()
197 : blume 515 val tkindM = UU.mkMap ()
198 :     val tkindListM = UU.mkMap ()
199 : blume 773 val ctypeM = UU.mkMap ()
200 :     val ctypeListM = UU.mkMap ()
201 : leunga 1174 val ccalltypeListM = UU.mkMap ()
202 :     val ccalltypeOptionM = UU.mkMap ()
203 : blume 773 val cciM = UU.mkMap ()
204 : mblume 1347 val ioM = UU.mkMap ()
205 : monnier 427
206 :     val boollist = list boolListM bool
207 : blume 774 val booloption = option boolOptionM bool
208 : mblume 1347 val intoption = option ioM int
209 : monnier 427
210 : blume 515 val pid = UnpickleSymPid.r_pid (session, string)
211 : monnier 427
212 :     fun access () = let
213 :     fun a #"A" = lvar (int ())
214 :     | a #"B" = A.EXTERN (pid ())
215 :     | a #"C" = A.PATH (access (), int ())
216 :     | a #"D" = A.NO_ACCESS
217 :     | a _ = raise Format
218 :     in
219 :     share accM a
220 :     end
221 :    
222 :     fun conrep () = let
223 :     fun cr #"A" = A.UNTAGGED
224 :     | cr #"B" = A.TAGGED (int ())
225 :     | cr #"C" = A.TRANSPARENT
226 :     | cr #"D" = A.CONSTANT (int ())
227 :     | cr #"E" = A.REF
228 :     | cr #"F" = A.EXN (access ())
229 :     | cr #"G" = A.LISTCONS
230 :     | cr #"H" = A.LISTNIL
231 :     | cr #"I" = A.SUSP NONE
232 :     | cr #"J" = A.SUSP (SOME (access (), access ()))
233 :     | cr _ = raise Format
234 :     in
235 :     share crM cr
236 :     end
237 :    
238 :     fun consig () = let
239 :     fun cs #"S" = A.CSIG (int (), int ())
240 :     | cs #"N" = A.CNIL
241 :     | cs _ = raise Format
242 :     in
243 :     share csM cs
244 :     end
245 :    
246 : blume 515 fun tkind () = let
247 : monnier 427 fun tk #"A" = LT.tkc_mono
248 :     | tk #"B" = LT.tkc_box
249 :     | tk #"C" = LT.tkc_seq (tkindlist ())
250 :     | tk #"D" = LT.tkc_fun (tkindlist (), tkind ())
251 :     | tk _ = raise Format
252 :     in
253 :     share tkindM tk
254 :     end
255 :    
256 :     and tkindlist () = list tkindListM tkind ()
257 :    
258 :     fun numkind () = let
259 :     fun nk #"A" = P.INT (int ())
260 :     | nk #"B" = P.UINT (int ())
261 :     | nk #"C" = P.FLOAT (int ())
262 :     | nk _ = raise Format
263 :     in
264 :     share nkM nk
265 :     end
266 :    
267 :     fun arithop () = let
268 :     fun ao c =
269 :     Vector.sub (arithop_table, Char.ord c)
270 :     handle General.Subscript => raise Format
271 :     in
272 :     nonshare ao
273 :     end
274 :    
275 :     fun cmpop () = let
276 :     fun co c =
277 :     Vector.sub (cmpop_table, Char.ord c)
278 :     handle General.Subscript => raise Format
279 :     in
280 :     nonshare co
281 :     end
282 :    
283 : blume 773 fun ctype () = let
284 :     fun ct #"\020" = CTypes.C_ARRAY (ctype (), int ())
285 :     | ct #"\021" = CTypes.C_STRUCT (ctypelist ())
286 : mblume 1548 | ct #"\022" = CTypes.C_UNION (ctypelist ())
287 : blume 773 | ct c =
288 :     Vector.sub (ctype_table, Char.ord c)
289 :     handle General.Subscript => raise Format
290 :     in
291 :     share ctypeM ct
292 :     end
293 :    
294 :     and ctypelist () = list ctypeListM ctype ()
295 :    
296 : leunga 1174 fun ccalltype() = let
297 : blume 1178 fun ct #"\000" = P.CCI32
298 :     | ct #"\001" = P.CCI64
299 :     | ct #"\002" = P.CCR64
300 :     | ct #"\003" = P.CCML
301 : leunga 1174 | ct _ = raise Format
302 :     in nonshare ct
303 :     end
304 :    
305 :     and ccalltypelist () = list ccalltypeListM ccalltype ()
306 :     and ccalltypeoption () = option ccalltypeOptionM ccalltype ()
307 :    
308 : blume 773 fun ccall_info () = let
309 :     fun cp #"C" =
310 :     { c_proto = { conv = string (),
311 :     retTy = ctype (),
312 :     paramTys = ctypelist () },
313 : leunga 1174 ml_args = ccalltypelist (),
314 :     ml_res_opt = ccalltypeoption (),
315 :     reentrant = bool () }
316 : blume 773 | cp _ = raise Format
317 :     in
318 :     share cciM cp
319 :     end
320 :    
321 : monnier 427 fun primop () = let
322 :     fun po #"\100" = P.ARITH { oper = arithop (), overflow = bool (),
323 :     kind = numkind () }
324 :     | po #"\101" = P.CMP { oper = cmpop (), kind = numkind () }
325 :     | po #"\102" = P.TEST (int (), int ())
326 :     | po #"\103" = P.TESTU (int (), int ())
327 :     | po #"\104" = P.TRUNC (int (), int ())
328 :     | po #"\105" = P.EXTEND (int (), int ())
329 :     | po #"\106" = P.COPY (int (), int ())
330 :     | po #"\107" = P.INLLSHIFT (numkind ())
331 :     | po #"\108" = P.INLRSHIFT (numkind ())
332 :     | po #"\109" = P.INLRSHIFTL (numkind ())
333 :     | po #"\110" = P.ROUND { floor = bool (), fromkind = numkind (),
334 :     tokind = numkind () }
335 :     | po #"\111" = P.REAL { fromkind = numkind (),
336 :     tokind = numkind ()}
337 :     | po #"\112" = P.NUMSUBSCRIPT { kind = numkind (),
338 :     checked = bool (),
339 :     immutable = bool () }
340 :     | po #"\113" = P.NUMUPDATE { kind = numkind (),
341 :     checked = bool () }
342 :     | po #"\114" = P.INL_MONOARRAY (numkind ())
343 :     | po #"\115" = P.INL_MONOVECTOR (numkind ())
344 : blume 772 | po #"\116" = P.RAW_LOAD (numkind ())
345 :     | po #"\117" = P.RAW_STORE (numkind ())
346 : blume 773 | po #"\118" = P.RAW_CCALL (SOME (ccall_info ()))
347 : blume 1178 | po #"\119" = P.RAW_RECORD { fblock = bool () }
348 : blume 1183 | po #"\120" = P.INLMIN (numkind ())
349 :     | po #"\121" = P.INLMAX (numkind ())
350 :     | po #"\122" = P.INLABS (numkind ())
351 : mblume 1347 | po #"\123" = P.TEST_INF (int ())
352 :     | po #"\124" = P.TRUNC_INF (int ())
353 :     | po #"\125" = P.EXTEND_INF (int ())
354 :     | po #"\126" = P.COPY_INF (int ())
355 : monnier 427 | po c =
356 :     Vector.sub (primop_table, Char.ord c)
357 :     handle General.Subscript => raise Format
358 :     in
359 :     share poM po
360 :     end
361 : leunga 1174
362 : monnier 427 in
363 :     { pid = pid, string = string, symbol = symbol,
364 :     access = access, conrep = conrep, consig = consig,
365 : mblume 1347 primop = primop, boollist = boollist, intoption = intoption,
366 : blume 515 tkind = tkind, tkindlist = tkindlist }
367 : monnier 427 end
368 :    
369 : blume 587 fun mkEnvUnpickler extraInfo sessionInfo context = let
370 :     val { globalPid, symbollist, sharedStuff, lib } = extraInfo
371 :     val { session, stringlist } = sessionInfo
372 : monnier 427
373 : blume 587 local
374 :     fun look lk (m, i) =
375 :     case lk (context m, i) of
376 :     SOME x => x
377 :     | NONE =>
378 :     (ErrorMsg.impossible "UnpickMod: stub lookup failed";
379 :     raise Format)
380 :     in
381 :     val lookTyc = look MI.lookTyc
382 :     val lookSig = look MI.lookSig
383 :     val lookStr = look MI.lookStr
384 :     val lookFct = look MI.lookFct
385 :     val lookEnv = look MI.lookEnv
386 :     end
387 : monnier 427
388 :     fun list m r = UU.r_list session m r
389 :     fun option m r = UU.r_option session m r
390 :     val bool = UU.r_bool session
391 : blume 515 fun pair m fp p = UU.r_pair session m fp p
392 : monnier 427 val int = UU.r_int session
393 :    
394 :     fun share m f = UU.share session m f
395 :     fun nonshare f = UU.nonshare session f
396 :    
397 :     (* The following maps all acquire different types by being used
398 :     * in different contexts: *)
399 :     val stampM = UU.mkMap ()
400 : blume 587 val strIdM = UU.mkMap ()
401 :     val fctIdM = UU.mkMap ()
402 : monnier 427 val stampOptionM = UU.mkMap ()
403 :     val stampListM = UU.mkMap ()
404 :     val symbolOptionM = UU.mkMap ()
405 :     val symbolListM = UU.mkMap ()
406 :     val spathListM = UU.mkMap ()
407 :     val spathListListM = UU.mkMap ()
408 :     val dataconM = UU.mkMap ()
409 :     val tkM = UU.mkMap ()
410 :     val dtiM = UU.mkMap ()
411 :     val dtfM = UU.mkMap ()
412 :     val dtmemberM = UU.mkMap ()
413 :     val dtmListM = UU.mkMap ()
414 :     val nrdM = UU.mkMap ()
415 :     val nrdListM = UU.mkMap ()
416 :     val tyconM = UU.mkMap ()
417 :     val tyconListM = UU.mkMap ()
418 :     val tyM = UU.mkMap ()
419 :     val tyOptionM = UU.mkMap ()
420 :     val tyListM = UU.mkMap ()
421 :     val iiM = UU.mkMap ()
422 :     val vM = UU.mkMap ()
423 :     val sdM = UU.mkMap ()
424 :     val sigM = UU.mkMap ()
425 :     val fsigM = UU.mkMap ()
426 :     val spM = UU.mkMap ()
427 :     val enM = UU.mkMap ()
428 :     val fctcM = UU.mkMap ()
429 :     val strM = UU.mkMap ()
430 :     val fctM = UU.mkMap ()
431 :     val steM = UU.mkMap ()
432 :     val tceM = UU.mkMap ()
433 :     val streM = UU.mkMap ()
434 :     val feM = UU.mkMap ()
435 :     val eeM = UU.mkMap ()
436 :     val edM = UU.mkMap ()
437 :     val eenvM = UU.mkMap ()
438 :     val senM = UU.mkMap ()
439 :     val fenM = UU.mkMap ()
440 :     val fxM = UU.mkMap ()
441 :     val bM = UU.mkMap ()
442 :     val elementsM = UU.mkMap ()
443 :     val bepsLM = UU.mkMap ()
444 :     val bepsOM = UU.mkMap ()
445 :     val spDefM = UU.mkMap ()
446 :     val iiListM = UU.mkMap ()
447 :     val overldM = UU.mkMap ()
448 :     val olListM = UU.mkMap ()
449 :     val edListM = UU.mkMap ()
450 :     val eenvBindM = UU.mkMap ()
451 :     val envM = UU.mkMap ()
452 : blume 515 val spathM = UU.mkMap ()
453 :     val ipathM = UU.mkMap ()
454 :     val symSpecPM = UU.mkMap ()
455 :     val epTkPM = UU.mkMap ()
456 :     val sdIntPM = UU.mkMap ()
457 :     val evEntPM = UU.mkMap ()
458 :     val symBindPM = UU.mkMap ()
459 : blume 587 val pidOptionM = UU.mkMap ()
460 :     val lmsOptM = UU.mkMap ()
461 :     val lmsPairM = UU.mkMap ()
462 : monnier 427
463 : mblume 1347 val { pid, string, symbol, access, conrep, consig, intoption,
464 : blume 515 primop, boollist, tkind, tkindlist } = sharedStuff
465 : monnier 427
466 : blume 632 fun libModSpec () = option lmsOptM (pair lmsPairM (int, symbol)) ()
467 : blume 587
468 : monnier 427 fun stamp () = let
469 : blume 587 fun st #"A" = Stamps.global { pid = globalPid (),
470 :     cnt = int () }
471 :     | st #"B" = Stamps.global { pid = pid (),
472 :     cnt = int () }
473 :     | st #"C" = Stamps.special (string ())
474 : monnier 427 | st _ = raise Format
475 :     in
476 :     share stampM st
477 : blume 587 end
478 :    
479 :     val tycId = stamp
480 :     val sigId = stamp
481 :     fun strId () = let
482 :     fun si #"D" = { sign = stamp (), rlzn = stamp () }
483 :     | si _ = raise Format
484 :     in
485 :     share strIdM si
486 : monnier 427 end
487 : blume 587 fun fctId () = let
488 :     fun fi #"E" = { paramsig = stamp (), bodysig = stamp (),
489 :     rlzn = stamp () }
490 :     | fi _ = raise Format
491 :     in
492 :     share fctIdM fi
493 :     end
494 :     val envId = stamp
495 : monnier 427
496 :     val stamplist = list stampListM stamp
497 :     val stampoption = option stampOptionM stamp
498 : blume 587 val pidoption = option pidOptionM pid
499 : monnier 427
500 :     val entVar = stamp
501 :     val entVarOption = stampoption
502 :     val entPath = stamplist
503 :    
504 :     val symbollist = list symbolListM symbol
505 :     val symboloption = option symbolOptionM symbol
506 :    
507 : blume 515 fun spath () = let
508 :     fun sp #"s" = SP.SPATH (symbollist ())
509 :     | sp _ = raise Format
510 :     in
511 :     share spathM sp
512 :     end
513 :    
514 :     fun ipath () = let
515 :     fun ip #"i" = IP.IPATH (symbollist ())
516 :     | ip _ = raise Format
517 :     in
518 :     share ipathM ip
519 :     end
520 :    
521 : monnier 427 val spathlist = list spathListM spath
522 :     val spathlistlist = list spathListListM spathlist
523 :    
524 :     val label = symbol
525 :     val labellist = symbollist
526 :    
527 :     fun eqprop () = let
528 :     fun eqp c =
529 :     Vector.sub (eqprop_table, Char.ord c)
530 :     handle General.Subscript => raise Format
531 :     in
532 :     nonshare eqp
533 :     end
534 :    
535 : blume 587 fun datacon' () = let
536 : monnier 427 fun d #"c" =
537 : blume 587 let val n = symbol ()
538 :     val c = bool ()
539 :     val (t, ttr) = ty' ()
540 :     val r = conrep ()
541 :     val s = consig ()
542 :     val l = bool ()
543 :     in
544 :     (T.DATACON { name = n, const = c, typ = t,
545 :     rep = r, sign = s, lazyp = l },
546 :     ttr)
547 :     end
548 : monnier 427 | d _ = raise Format
549 :     in
550 :     share dataconM d
551 :     end
552 :    
553 :     and tyckind () = let
554 : blume 902 fun tk #"a" = T.PRIMITIVE (int ())
555 : monnier 427 | tk #"b" = let
556 :     val index = int ()
557 :     val root = entVarOption ()
558 :     val (stamps, family, freetycs) = dtypeInfo ()
559 :     in
560 :     T.DATATYPE { index = index, root = root,
561 :     stamps = stamps, family = family,
562 :     freetycs = freetycs }
563 :     end
564 :     | tk #"c" = T.ABSTRACT (tycon ())
565 :     | tk #"d" = T.FORMAL
566 :     | tk #"e" = T.TEMP
567 :     | tk _ = raise Format
568 :     in
569 :     share tkM tk
570 :     end
571 :    
572 :     and dtypeInfo () = let
573 :     fun dti #"a" =
574 :     (Vector.fromList (stamplist ()), dtFamily (), tyconlist ())
575 :     | dti _ = raise Format
576 :     in
577 :     share dtiM dti
578 :     end
579 :    
580 :     and dtFamily () = let
581 :     fun dtf #"b" =
582 :     { mkey = stamp (),
583 :     members = Vector.fromList (dtmemberlist ()),
584 : blume 902 properties = PropList.newHolder () }
585 : monnier 427 | dtf _ = raise Format
586 :     in
587 :     share dtfM dtf
588 :     end
589 :    
590 :     and dtmember () = let
591 :     fun d #"c" = { tycname = symbol (), dcons = nrdlist (),
592 :     arity = int (), eq = ref (eqprop ()),
593 :     lazyp = bool (), sign = consig () }
594 :     | d _ = raise Format
595 :     in
596 :     share dtmemberM d
597 :     end
598 :    
599 :     and dtmemberlist () = list dtmListM dtmember ()
600 :    
601 :     and nameRepDomain () = let
602 :     fun n #"d" =
603 :     { name = symbol (), rep = conrep (), domain = tyoption () }
604 :     | n _ = raise Format
605 :     in
606 :     share nrdM n
607 :     end
608 :    
609 :     and nrdlist () = list nrdListM nameRepDomain ()
610 :    
611 :     and tycon () = let
612 : blume 587 fun tyc #"A" = T.GENtyc (lookTyc (libModSpec (), tycId ()))
613 :     | tyc #"B" = T.GENtyc { stamp = stamp (),
614 :     arity = int (),
615 :     eq = ref (eqprop ()),
616 :     kind = tyckind (),
617 :     path = ipath (),
618 :     stub = SOME { owner = if lib then pid ()
619 :     else globalPid (),
620 :     lib = lib } }
621 : monnier 427 | tyc #"C" = T.DEFtyc { stamp = stamp (),
622 :     tyfun = T.TYFUN { arity = int (),
623 :     body = ty () },
624 :     strict = boollist (),
625 :     path = ipath () }
626 :     | tyc #"D" = T.PATHtyc { arity = int (), entPath = entPath (),
627 :     path = ipath () }
628 :     | tyc #"E" = T.RECORDtyc (labellist ())
629 :     | tyc #"F" = T.RECtyc (int ())
630 :     | tyc #"G" = T.FREEtyc (int ())
631 :     | tyc #"H" = T.ERRORtyc
632 :     | tyc _ = raise Format
633 :     in
634 :     share tyconM tyc
635 :     end
636 :    
637 : blume 587 and tycon' () = let
638 :     val tyc = tycon ()
639 :     val tree =
640 :     case tyc of
641 :     T.GENtyc r => M.TYCNODE r
642 :     | _ => notree
643 :     in
644 :     (tyc, tree)
645 :     end
646 :    
647 : monnier 427 and tyconlist () = list tyconListM tycon ()
648 :    
649 : blume 587 and ty' () = let
650 :     fun t #"a" =
651 :     let val (tyc, tyctr) = tycon' ()
652 :     val (tyl, tyltr) = tylist' ()
653 :     in (T.CONty (tyc, tyl), branch [tyctr, tyltr])
654 :     end
655 :     | t #"b" = (T.IBOUND (int ()), notree)
656 :     | t #"c" = (T.WILDCARDty, notree)
657 :     | t #"d" =
658 :     let val s = boollist ()
659 :     val ar = int ()
660 :     val (b, btr) = ty' ()
661 :     in
662 :     (T.POLYty { sign = s, tyfun = T.TYFUN { arity = ar,
663 :     body = b } },
664 :     btr)
665 :     end
666 :     | t #"e" = (T.UNDEFty, notree)
667 : monnier 427 | t _ = raise Format
668 :     in
669 :     share tyM t
670 :     end
671 :    
672 : blume 587 and ty () = #1 (ty' ())
673 :    
674 : monnier 427 and tyoption () = option tyOptionM ty ()
675 :    
676 : blume 587 and tylist' () = let
677 :     val (l, trl) = ListPair.unzip (list tyListM ty' ())
678 :     in
679 :     (l, branch trl)
680 :     end
681 :    
682 : monnier 427 and inl_info () = let
683 : macqueen 1374 fun ii #"A" = II.INL_PRIM (primop (), ty ())
684 : monnier 427 | ii #"B" = II.INL_STR (iilist ())
685 :     | ii #"C" = II.INL_NO
686 :     | ii _ = raise Format
687 :     in
688 :     share iiM ii
689 :     end
690 :    
691 :     and iilist () = list iiListM inl_info ()
692 :    
693 : blume 587 and var' () = let
694 :     fun v #"1" =
695 :     let val a = access ()
696 :     val i = inl_info ()
697 :     val p = spath ()
698 :     val (t, tr) = ty' ()
699 :     in
700 :     (V.VALvar { access = a, info = i, path = p, typ = ref t },
701 :     tr)
702 :     end
703 :     | v #"2" =
704 :     let val n = symbol ()
705 :     val (ol, oltr) = overldlist' ()
706 :     val ar = int ()
707 :     val (b, btr) = ty' ()
708 :     in
709 :     (V.OVLDvar { name = n,
710 :     options = ref ol,
711 :     scheme = T.TYFUN { arity = ar, body = b } },
712 :     branch [oltr, btr])
713 :     end
714 :     | v #"3" = (V.ERRORvar, notree)
715 : monnier 427 | v _ = raise Format
716 :     in
717 :     share vM v
718 :     end
719 :    
720 : blume 587 and overld' () = let
721 :     fun ov #"o" =
722 :     let val (t, ttr) = ty' ()
723 :     val (v, vtr) = var' ()
724 :     in
725 :     ({ indicator = t, variant = v },
726 :     branch [ttr, vtr])
727 :     end
728 : monnier 427 | ov _ = raise Format
729 :     in
730 :     share overldM ov
731 :     end
732 :    
733 : blume 587 and overldlist' () = let
734 :     val (l, trl) = ListPair.unzip (list olListM overld' ())
735 :     in
736 :     (l, branch trl)
737 :     end
738 : monnier 427
739 :     fun strDef () = let
740 :     fun sd #"C" = M.CONSTstrDef (Structure ())
741 :     | sd #"V" = M.VARstrDef (Signature (), entPath ())
742 :     | sd _ = raise Format
743 :     in
744 :     share sdM sd
745 :     end
746 :    
747 : blume 587 and Signature' () = let
748 :     fun sg #"A" = (M.ERRORsig, notree)
749 :     | sg #"B" =
750 :     let val sr = lookSig (libModSpec (), sigId ())
751 :     in
752 :     (M.SIG sr, M.SIGNODE sr)
753 :     end
754 :     | sg #"C" =
755 :     let val s = stamp ()
756 :     val n = symboloption ()
757 :     val c = bool ()
758 :     val ff = bool ()
759 :     val sl = symbollist ()
760 :     val (el, eltrl) =
761 :     ListPair.unzip
762 :     (map (fn (sy, (sp, tr)) => ((sy, sp), tr))
763 :     (list elementsM
764 :     (pair symSpecPM (symbol, spec')) ()))
765 :     val beps = option bepsOM
766 :     (list bepsLM
767 :     (pair epTkPM (entPath, tkind))) ()
768 :     val ts = spathlistlist ()
769 :     val ss = spathlistlist ()
770 :     val r = { stamp = s,
771 :     name = n,
772 :     closed = c,
773 :     fctflag = ff,
774 :     symbols = sl,
775 :     elements = el,
776 : blume 902 properties = PropList.newHolder (),
777 :     (* boundeps = ref beps, *)
778 :     (* lambdaty = ref NONE, *)
779 : blume 587 typsharing = ts,
780 :     strsharing = ss,
781 :     stub = SOME { owner = if lib then pid ()
782 :     else globalPid (),
783 :     tree = branch eltrl,
784 :     lib = lib } }
785 :     in
786 : blume 902 ModulePropLists.setSigBoundeps (r, beps);
787 : blume 587 (M.SIG r, M.SIGNODE r)
788 :     end
789 : monnier 427 | sg _ = raise Format
790 :     in
791 :     share sigM sg
792 :     end
793 :    
794 : blume 587 and Signature () = #1 (Signature' ())
795 :    
796 :     and fctSig' () = let
797 :     fun fsg #"a" = (M.ERRORfsig, notree)
798 :     | fsg #"c" =
799 :     let val k = symboloption ()
800 :     val (ps, pstr) = Signature' ()
801 :     val pv = entVar ()
802 :     val psy = symboloption ()
803 :     val (bs, bstr) = Signature' ()
804 :     in
805 :     (M.FSIG { kind = k, paramsig = ps,
806 :     paramvar = pv, paramsym = psy,
807 :     bodysig = bs },
808 :     branch [pstr, bstr])
809 :     end
810 : monnier 427 | fsg _ = raise Format
811 :     in
812 :     share fsigM fsg
813 :     end
814 :    
815 : blume 587 and spec' () = let
816 :     fun sp #"1" =
817 :     let val (t, ttr) = tycon' ()
818 :     in
819 :     (M.TYCspec { spec = t, entVar = entVar (),
820 :     repl = bool (), scope = int () },
821 :     ttr)
822 :     end
823 :     | sp #"2" =
824 :     let val (s, str) = Signature' ()
825 :     in
826 :     (M.STRspec { sign = s, slot = int (),
827 :     def = option spDefM
828 :     (pair sdIntPM (strDef, int)) (),
829 :     entVar = entVar () },
830 :     str)
831 :     end
832 :     | sp #"3" =
833 :     let val (f, ftr) = fctSig' ()
834 :     in
835 :     (M.FCTspec { sign = f, slot = int (), entVar = entVar () },
836 :     ftr)
837 :     end
838 :     | sp #"4" =
839 :     let val (t, ttr) = ty' ()
840 :     in
841 :     (M.VALspec { spec = t, slot = int () }, ttr)
842 :     end
843 :     | sp #"5" =
844 :     let val (d, dtr) = datacon' ()
845 :     in
846 :     (M.CONspec { spec = d, slot = intoption () }, dtr)
847 :     end
848 : monnier 427 | sp _ = raise Format
849 :     in
850 :     share spM sp
851 :     end
852 :    
853 : blume 587 and entity' () = let
854 :     fun en #"A" = & M.TYCent (tycEntity' ())
855 :     | en #"B" = & M.STRent (strEntity' ())
856 :     | en #"C" = & M.FCTent (fctEntity' ())
857 :     | en #"D" = (M.ERRORent, notree)
858 : monnier 427 | en _ = raise Format
859 :     in
860 :     share enM en
861 :     end
862 :    
863 : blume 587 and fctClosure' () = let
864 :     fun f #"f" =
865 :     let val p = entVar ()
866 :     val (b, btr) = strExp' ()
867 :     val (e, etr) = entityEnv' ()
868 :     in
869 :     (M.CLOSURE { param = p, body = b, env = e },
870 :     branch [btr, etr])
871 :     end
872 : monnier 427 | f _ = raise Format
873 :     in
874 :     share fctcM f
875 :     end
876 :    
877 : blume 587 (* The construction of the STRNODE in the modtree deserves some
878 :     * comment: Even though it contains the whole strrec, it does
879 :     * _not_ take care of the Signature contained therein. The reason
880 :     * why STRNODE has the whole strrec and not just the strEntity that
881 :     * it really guards is that the identity of the strEntity is not
882 :     * fully recoverable without also having access to the Signature.
883 :     * The same situation occurs in the case of FCTNODE. *)
884 :     and Structure' () = let
885 :     fun str #"A" =
886 :     let val (s, str) = Signature' ()
887 :     in
888 :     (M.STRSIG { sign = s, entPath = entPath () }, str)
889 :     end
890 :     | str #"B" = (M.ERRORstr, notree)
891 :     | str #"C" =
892 :     let val (s, str) = Signature' ()
893 :     val r = { sign = s,
894 :     rlzn = lookStr (libModSpec (), strId ()),
895 :     access = access (),
896 :     info = inl_info () }
897 :     in
898 :     (M.STR r, branch [str, M.STRNODE r])
899 :     end
900 :     | str #"D" =
901 :     let val (s, str) = Signature' ()
902 :     val r = { sign = s,
903 :     rlzn = strEntity (),
904 :     access = access (),
905 :     info = inl_info () }
906 :     in
907 :     (M.STR r, branch [str, M.STRNODE r])
908 :     end
909 : monnier 427 | str _ = raise Format
910 :     in
911 :     share strM str
912 :     end
913 :    
914 : blume 587 and Structure () = #1 (Structure' ())
915 :    
916 :     (* See the comment about STRNODE, strrec, Signature, and strEntity
917 :     * in front of Structure'. The situation for FCTNODE, fctrec,
918 :     * fctSig, and fctEntity is analogous. *)
919 :     and Functor' () = let
920 :     fun fct #"E" = (M.ERRORfct, notree)
921 :     | fct #"F" =
922 :     let val (s, str) = fctSig' ()
923 :     val r = { sign = s,
924 :     rlzn = lookFct (libModSpec (), fctId ()),
925 :     access = access (),
926 :     info = inl_info () }
927 :     in
928 :     (M.FCT r, branch [str, M.FCTNODE r])
929 :     end
930 :     | fct #"G" =
931 :     let val (s, str) = fctSig' ()
932 :     val r = { sign = s,
933 :     rlzn = fctEntity (),
934 :     access = access (),
935 :     info = inl_info () }
936 :     in
937 :     (M.FCT r, branch [str, M.FCTNODE r])
938 :     end
939 : monnier 427 | fct _ = raise Format
940 :     in
941 :     share fctM fct
942 :     end
943 :    
944 :     and stampExp () = let
945 : blume 587 fun ste #"b" = M.GETSTAMP (strExp ())
946 : monnier 427 | ste #"c" = M.NEW
947 :     | ste _ = raise Format
948 :     in
949 :     share steM ste
950 :     end
951 :    
952 : blume 587 and tycExp' () = let
953 :     fun tce #"d" = & M.CONSTtyc (tycon' ())
954 :     | tce #"e" = (M.FORMtyc (tycon ()), notree) (* ? *)
955 :     | tce #"f" = (M.VARtyc (entPath ()), notree)
956 : monnier 427 | tce _ = raise Format
957 :     in
958 :     share tceM tce
959 :     end
960 :    
961 : blume 587 and tycExp () = #1 (tycExp' ())
962 :    
963 :     and strExp' () = let
964 :     fun stre #"g" = (M.VARstr (entPath ()), notree)
965 :     | stre #"h" = & M.CONSTstr (strEntity' ())
966 :     | stre #"i" =
967 :     let val s = stampExp ()
968 :     val (d, dtr) = entityDec' ()
969 :     in
970 :     (M.STRUCTURE { stamp = s, entDec = d }, dtr)
971 :     end
972 :     | stre #"j" =
973 :     let val (f, ftr) = fctExp' ()
974 :     val (s, str) = strExp' ()
975 :     in
976 :     (M.APPLY (f, s), branch [ftr, str])
977 :     end
978 :     | stre #"k" =
979 :     let val (d, dtr) = entityDec' ()
980 :     val (s, str) = strExp' ()
981 :     in
982 :     (M.LETstr (d, s), branch [dtr, str])
983 :     end
984 :     | stre #"l" =
985 :     let val (s, str) = Signature' ()
986 :     val (e, etr) = strExp' ()
987 :     in
988 :     (M.ABSstr (s, e), branch [str, etr])
989 :     end
990 :     | stre #"m" =
991 :     let val bv = entVar ()
992 :     val (r, rtr) = strExp' ()
993 :     val (c, ctr) = strExp' ()
994 :     in
995 :     (M.CONSTRAINstr { boundvar = bv, raw = r, coercion = c },
996 :     branch [rtr, ctr])
997 :     end
998 :     | stre #"n" = & M.FORMstr (fctSig' ())
999 : monnier 427 | stre _ = raise Format
1000 :     in
1001 :     share streM stre
1002 :     end
1003 :    
1004 : blume 587 and strExp () = #1 (strExp' ())
1005 :    
1006 :     and fctExp' () = let
1007 :     fun fe #"o" = (M.VARfct (entPath ()), notree)
1008 :     | fe #"p" = & M.CONSTfct (fctEntity' ())
1009 :     | fe #"q" =
1010 :     let val p = entVar ()
1011 :     val (b, btr) = strExp' ()
1012 :     in
1013 :     (M.LAMBDA { param = p, body = b }, btr)
1014 :     end
1015 :     | fe #"r" =
1016 :     let val p = entVar ()
1017 :     val (b, btr) = strExp' ()
1018 :     val (s, str) = fctSig' ()
1019 :     in
1020 :     (M.LAMBDA_TP { param = p, body = b, sign = s },
1021 :     branch [btr, str])
1022 :     end
1023 :     | fe #"s" =
1024 :     let val (d, dtr) = entityDec' ()
1025 :     val (f, ftr) = fctExp' ()
1026 :     in
1027 :     (M.LETfct (d, f), branch [dtr, ftr])
1028 :     end
1029 : monnier 427 | fe _ = raise Format
1030 :     in
1031 :     share feM fe
1032 :     end
1033 :    
1034 : blume 587 and fctExp () = #1 (fctExp' ())
1035 :    
1036 : monnier 427 and entityExp () = let
1037 :     fun ee #"t" = M.TYCexp (tycExp ())
1038 :     | ee #"u" = M.STRexp (strExp ())
1039 :     | ee #"v" = M.FCTexp (fctExp ())
1040 :     | ee #"w" = M.ERRORexp
1041 :     | ee #"x" = M.DUMMYexp
1042 :     | ee _ = raise Format
1043 :     in
1044 :     share eeM ee
1045 :     end
1046 :    
1047 : blume 587 and entityDec' () = let
1048 :     fun ed #"A" =
1049 :     let val v = entVar ()
1050 :     val (e, etr) = tycExp' ()
1051 :     in
1052 :     (M.TYCdec (v, e), etr)
1053 :     end
1054 :     | ed #"B" =
1055 :     let val v = entVar ()
1056 :     val (e, etr) = strExp' ()
1057 :     val s = symbol ()
1058 :     in
1059 :     (M.STRdec (v, e, s), etr)
1060 :     end
1061 :     | ed #"C" =
1062 :     let val v = entVar ()
1063 :     val (e, etr) = fctExp' ()
1064 :     in
1065 :     (M.FCTdec (v, e), etr)
1066 :     end
1067 :     | ed #"D" = & M.SEQdec (entityDecList' ())
1068 :     | ed #"E" =
1069 :     let val (d1, d1tr) = entityDec' ()
1070 :     val (d2, d2tr) = entityDec' ()
1071 :     in
1072 :     (M.LOCALdec (d1, d2), branch [d1tr, d2tr])
1073 :     end
1074 :     | ed #"F" = (M.ERRORdec, notree)
1075 :     | ed #"G" = (M.EMPTYdec, notree)
1076 : monnier 427 | ed _ = raise Format
1077 :     in
1078 :     share edM ed
1079 :     end
1080 :    
1081 : blume 587 and entityDecList' () = let
1082 :     val (l, trl) = ListPair.unzip (list edListM entityDec' ())
1083 :     in
1084 :     (l, branch trl)
1085 :     end
1086 : monnier 427
1087 : blume 587 and entityEnv' () = let
1088 : monnier 427 fun eenv #"A" =
1089 : blume 587 let val l = list eenvBindM (pair evEntPM (entVar, entity')) ()
1090 :     val l' = map (fn (v, (e, tr)) => ((v, e), tr)) l
1091 :     val (l'', trl) = ListPair.unzip l'
1092 : monnier 427 fun add ((v, e), z) = ED.insert (z, v, e)
1093 : blume 587 val ed = foldr add ED.empty l''
1094 :     val (e, etr) = entityEnv' ()
1095 : monnier 427 in
1096 : blume 587 (M.BINDeenv (ed, e), branch (etr :: trl))
1097 : monnier 427 end
1098 : blume 587 | eenv #"B" = (M.NILeenv, notree)
1099 :     | eenv #"C" = (M.ERReenv, notree)
1100 :     | eenv #"D" =
1101 :     let val r = lookEnv (libModSpec (), envId ())
1102 :     in
1103 :     (M.MARKeenv r, M.ENVNODE r)
1104 :     end
1105 :     | eenv #"E" =
1106 :     let val s = stamp ()
1107 :     val (e, etr) = entityEnv' ()
1108 :     val r = { stamp = s,
1109 :     env = e,
1110 :     stub = SOME { owner = if lib then pid ()
1111 :     else globalPid (),
1112 :     tree = etr,
1113 :     lib = lib } }
1114 :     in
1115 :     (M.MARKeenv r, M.ENVNODE r)
1116 :     end
1117 : monnier 427 | eenv _ = raise Format
1118 :     in
1119 :     share eenvM eenv
1120 :     end
1121 :    
1122 : blume 587 and strEntity' () = let
1123 : monnier 427 fun s #"s" =
1124 : blume 587 let val s = stamp ()
1125 :     val (e, etr) = entityEnv' ()
1126 :     in
1127 :     ({ stamp = s,
1128 :     entities = e,
1129 :     rpath = ipath (),
1130 : blume 902 properties = PropList.newHolder (),
1131 :     (* lambdaty = ref NONE, *)
1132 : blume 587 stub = SOME { owner = if lib then pid ()
1133 :     else globalPid (),
1134 :     tree = etr,
1135 :     lib = lib } },
1136 :     etr)
1137 :     end
1138 : monnier 427 | s _ = raise Format
1139 :     in
1140 :     share senM s
1141 :     end
1142 :    
1143 : blume 587 and strEntity () = #1 (strEntity' ())
1144 :    
1145 :     and fctEntity' () = let
1146 : monnier 427 fun f #"f" =
1147 : blume 587 let val s = stamp ()
1148 :     val (c, ctr) = fctClosure' ()
1149 :     in
1150 :     ({ stamp = s,
1151 :     closure = c,
1152 :     rpath = ipath (),
1153 : blume 902 properties = PropList.newHolder (),
1154 :     (* lambdaty = ref NONE, *)
1155 : blume 587 tycpath = NONE,
1156 :     stub = SOME { owner = if lib then pid ()
1157 :     else globalPid (),
1158 :     tree = ctr,
1159 :     lib = lib } },
1160 :     ctr)
1161 :     end
1162 : monnier 427 | f _ = raise Format
1163 :     in
1164 :     share fenM f
1165 :     end
1166 :    
1167 : blume 587 and fctEntity () = #1 (fctEntity' ())
1168 : monnier 427
1169 : blume 587 and tycEntity' () = tycon' ()
1170 :    
1171 : monnier 427 fun fixity () = let
1172 :     fun fx #"N" = Fixity.NONfix
1173 :     | fx #"I" = Fixity.INfix (int (), int ())
1174 :     | fx _ = raise Format
1175 :     in
1176 :     share fxM fx
1177 :     end
1178 :    
1179 : blume 587 fun binding' () = let
1180 :     fun b #"1" = & B.VALbind (var' ())
1181 :     | b #"2" = & B.CONbind (datacon' ())
1182 :     | b #"3" = & B.TYCbind (tycon' ())
1183 :     | b #"4" = & B.SIGbind (Signature' ())
1184 :     | b #"5" = & B.STRbind (Structure' ())
1185 :     | b #"6" = & B.FSGbind (fctSig' ())
1186 :     | b #"7" = & B.FCTbind (Functor' ())
1187 :     | b #"8" = (B.FIXbind (fixity ()), notree)
1188 : monnier 427 | b _ = raise Format
1189 :     in
1190 :     share bM b
1191 :     end
1192 :    
1193 :     fun env () = let
1194 : blume 587 val bindlist = list envM (pair symBindPM (symbol, binding')) ()
1195 :     fun bind ((s, (b, t)), e) = StaticEnv.bind0 (s, (b, SOME t), e)
1196 : monnier 427 in
1197 : blume 902 StaticEnv.consolidate (foldl bind StaticEnv.empty bindlist)
1198 : monnier 427 end
1199 :     in
1200 : blume 587 env
1201 : monnier 427 end
1202 :    
1203 : blume 587 fun unpickleEnv context (hash, pickle) = let
1204 : monnier 427 val session =
1205 :     UU.mkSession (UU.stringGetter (Byte.bytesToString pickle))
1206 :     fun import i = A.PATH (A.EXTERN hash, i)
1207 : blume 587 val slM = UU.mkMap ()
1208 :     val sloM = UU.mkMap ()
1209 :     val sylM = UU.mkMap ()
1210 :     val sharedStuff = mkSharedStuff (session, import)
1211 :     val stringlist = UU.r_list session slM (#string sharedStuff)
1212 :     val symbollist = UU.r_list session sylM (#symbol sharedStuff)
1213 :     val extraInfo = { globalPid = fn () => hash,
1214 :     symbollist = symbollist,
1215 :     sharedStuff = sharedStuff,
1216 :     lib = false }
1217 :     val sessionInfo = { session = session, stringlist = stringlist }
1218 :     val unpickle = mkEnvUnpickler extraInfo sessionInfo context
1219 : monnier 427 in
1220 : blume 587 unpickle ()
1221 : monnier 427 end
1222 :    
1223 :     fun mkFlintUnpickler (session, sharedStuff) = let
1224 :    
1225 :     fun share m r = UU.share session m r
1226 :    
1227 :     fun list m r = UU.r_list session m r
1228 :     fun option m r = UU.r_option session m r
1229 :    
1230 : blume 515 fun pair m fp p = UU.r_pair session m fp p
1231 : monnier 427 val int = UU.r_int session
1232 :     val int32 = UU.r_int32 session
1233 :     val word = UU.r_word session
1234 :     val word32 = UU.r_word32 session
1235 :     val bool = UU.r_bool session
1236 :    
1237 : blume 515 val { pid, string, symbol, access, conrep, consig,
1238 : mblume 1347 primop, boollist, tkind, tkindlist, intoption } = sharedStuff
1239 : monnier 427
1240 : blume 515 val ltyM = UU.mkMap ()
1241 :     val ltyListM = UU.mkMap ()
1242 :     val tycM = UU.mkMap ()
1243 :     val tycListM = UU.mkMap ()
1244 : monnier 427 val valueM = UU.mkMap ()
1245 :     val conM = UU.mkMap ()
1246 :     val dconM = UU.mkMap ()
1247 :     val dictM = UU.mkMap ()
1248 :     val fprimM = UU.mkMap ()
1249 :     val lexpM = UU.mkMap ()
1250 :     val fkindM = UU.mkMap ()
1251 :     val rkindM = UU.mkMap ()
1252 :     val ltyloM = UU.mkMap ()
1253 :     val dictTableM = UU.mkMap ()
1254 :     val dictOptionM = UU.mkMap ()
1255 :     val valueListM = UU.mkMap ()
1256 :     val lvarListM = UU.mkMap ()
1257 :     val fundecListM = UU.mkMap ()
1258 :     val conListM = UU.mkMap ()
1259 :     val lexpOptionM = UU.mkMap ()
1260 :     val fundecM = UU.mkMap ()
1261 :     val tfundecM = UU.mkMap ()
1262 : blume 515 val lvLtPM = UU.mkMap ()
1263 :     val lvLtPLM = UU.mkMap ()
1264 :     val lvTkPM = UU.mkMap ()
1265 :     val lvTkPLM = UU.mkMap ()
1266 :     val tycLvPM = UU.mkMap ()
1267 : monnier 427
1268 : blume 515 fun lty () = let
1269 :     fun lt #"A" = LT.ltc_tyc (tyc ())
1270 :     | lt #"B" = LT.ltc_str (ltylist ())
1271 :     | lt #"C" = LT.ltc_fct (ltylist (), ltylist ())
1272 :     | lt #"D" = LT.ltc_poly (tkindlist (), ltylist ())
1273 :     | lt _ = raise Format
1274 :     in
1275 :     share ltyM lt
1276 :     end
1277 :    
1278 :     and ltylist () = list ltyListM lty ()
1279 :    
1280 :     and tyc () = let
1281 :     fun tc #"A" = LT.tcc_var (DI.di_fromint (int ()), int ())
1282 :     | tc #"B" = LT.tcc_nvar (int ())
1283 :     | tc #"C" = LT.tcc_prim (PT.pt_fromint (int ()))
1284 :     | tc #"D" = LT.tcc_fn (tkindlist (), tyc ())
1285 :     | tc #"E" = LT.tcc_app (tyc (), tyclist ())
1286 :     | tc #"F" = LT.tcc_seq (tyclist ())
1287 :     | tc #"G" = LT.tcc_proj (tyc (), int ())
1288 :     | tc #"H" = LT.tcc_sum (tyclist ())
1289 :     | tc #"I" = LT.tcc_fix ((int (), tyc (), tyclist ()), int ())
1290 :     | tc #"J" = LT.tcc_abs (tyc ())
1291 :     | tc #"K" = LT.tcc_box (tyc ())
1292 :     | tc #"L" = LT.tcc_tuple (tyclist ())
1293 :     | tc #"M" = LT.tcc_arrow (LT.ffc_var (bool (), bool ()),
1294 :     tyclist (), tyclist ())
1295 :     | tc #"N" = LT.tcc_arrow (LT.ffc_fixed, tyclist (), tyclist ())
1296 :     | tc #"O" = LK.tc_inj (LK.TC_TOKEN (LK.token_key (int ()),
1297 :     tyc ()))
1298 :     | tc _ = raise Format
1299 :     in
1300 :     share tycM tc
1301 :     end
1302 :    
1303 :     and tyclist () = list tycListM tyc ()
1304 :    
1305 : monnier 427 val lvar = int
1306 :     val lvarlist = list lvarListM lvar
1307 :    
1308 :     fun value () = let
1309 :     fun v #"a" = F.VAR (lvar ())
1310 :     | v #"b" = F.INT (int ())
1311 :     | v #"c" = F.INT32 (int32 ())
1312 :     | v #"d" = F.WORD (word ())
1313 :     | v #"e" = F.WORD32 (word32 ())
1314 :     | v #"f" = F.REAL (string ())
1315 :     | v #"g" = F.STRING (string ())
1316 :     | v _ = raise Format
1317 :     in
1318 :     share valueM v
1319 :     end
1320 :    
1321 :     val valuelist = list valueListM value
1322 :    
1323 :     fun con () = let
1324 :     fun c #"1" =
1325 :     let
1326 :     val (dc, ts) = dcon ()
1327 :     in
1328 :     (F.DATAcon (dc, ts, lvar ()), lexp ())
1329 :     end
1330 :     | c #"2" = (F.INTcon (int ()), lexp ())
1331 :     | c #"3" = (F.INT32con (int32 ()), lexp ())
1332 :     | c #"4" = (F.WORDcon (word ()), lexp ())
1333 :     | c #"5" = (F.WORD32con (word32 ()), lexp ())
1334 :     | c #"6" = (F.REALcon (string ()), lexp ())
1335 :     | c #"7" = (F.STRINGcon (string ()), lexp ())
1336 :     | c #"8" = (F.VLENcon (int ()), lexp ())
1337 :     | c _ = raise Format
1338 :     in
1339 :     share conM c
1340 :     end
1341 :    
1342 :     and conlist () = list conListM con ()
1343 :    
1344 :     and dcon () = let
1345 :     fun d #"x" = ((symbol (), conrep (), lty ()), tyclist ())
1346 :     | d _ = raise Format
1347 :     in
1348 :     share dconM d
1349 :     end
1350 :    
1351 :     and dict () = let
1352 :     fun d #"y" =
1353 :     { default = lvar (),
1354 : blume 515 table = list dictTableM (pair tycLvPM (tyclist, lvar)) () }
1355 : monnier 427 | d _ = raise Format
1356 :     in
1357 :     share dictM d
1358 :     end
1359 :    
1360 :     and fprim () = let
1361 :     fun f #"z" = (option dictOptionM dict (),
1362 :     primop (), lty (), tyclist ())
1363 :     | f _ = raise Format
1364 :     in
1365 :     share fprimM f
1366 :     end
1367 :    
1368 :     and lexp () = let
1369 :     fun e #"j" = F.RET (valuelist ())
1370 :     | e #"k" = F.LET (lvarlist (), lexp (), lexp ())
1371 :     | e #"l" = F.FIX (fundeclist (), lexp ())
1372 :     | e #"m" = F.APP (value (), valuelist ())
1373 :     | e #"n" = F.TFN (tfundec (), lexp ())
1374 :     | e #"o" = F.TAPP (value (), tyclist ())
1375 :     | e #"p" = F.SWITCH (value (), consig (), conlist (),
1376 :     lexpoption ())
1377 :     | e #"q" = let
1378 :     val (dc, ts) = dcon ()
1379 :     in
1380 :     F.CON (dc, ts, value (), lvar (), lexp ())
1381 :     end
1382 :     | e #"r" = F.RECORD (rkind (), valuelist (), lvar (), lexp ())
1383 :     | e #"s" = F.SELECT (value (), int (), lvar (), lexp ())
1384 :     | e #"t" = F.RAISE (value (), ltylist ())
1385 :     | e #"u" = F.HANDLE (lexp (), value ())
1386 :     | e #"v" = F.BRANCH (fprim (), valuelist (), lexp (), lexp ())
1387 :     | e #"w" = F.PRIMOP (fprim (), valuelist (), lvar (), lexp ())
1388 :     | e _ = raise Format
1389 :     in
1390 :     share lexpM e
1391 :     end
1392 :    
1393 :     and lexpoption () = option lexpOptionM lexp ()
1394 :    
1395 :     and fundec () = let
1396 :     fun f #"a" =
1397 : blume 515 (fkind (), lvar (),
1398 :     list lvLtPLM (pair lvLtPM (lvar, lty)) (),
1399 :     lexp ())
1400 : monnier 427 | f _ = raise Format
1401 :     in
1402 :     share fundecM f
1403 :     end
1404 :    
1405 :     and fundeclist () = list fundecListM fundec ()
1406 :    
1407 :     and tfundec () = let
1408 : blume 515 fun t #"b" = ({ inline = F.IH_SAFE }, lvar (),
1409 :     list lvTkPLM (pair lvTkPM (lvar, tkind)) (),
1410 :     lexp ())
1411 : monnier 427 | t _ = raise Format
1412 :     in
1413 :     share tfundecM t
1414 :     end
1415 :    
1416 :     and fkind () = let
1417 : blume 515 fun aug_unknown x = (x, F.LK_UNKNOWN)
1418 :     fun inlflag true = F.IH_ALWAYS
1419 :     | inlflag false = F.IH_SAFE
1420 :     fun fk #"2" = { isrec = NONE, cconv = F.CC_FCT,
1421 :     known = false, inline = F.IH_SAFE }
1422 :     | fk #"3" = { isrec = Option.map aug_unknown (ltylistoption ()),
1423 :     cconv = F.CC_FUN (LT.ffc_var (bool (), bool ())),
1424 : monnier 489 known = bool (),
1425 : blume 515 inline = inlflag (bool ()) }
1426 :     | fk #"4" = { isrec = Option.map aug_unknown (ltylistoption ()),
1427 : monnier 489 cconv = F.CC_FUN LT.ffc_fixed,
1428 :     known = bool (),
1429 : blume 515 inline = inlflag (bool ()) }
1430 : monnier 427 | fk _ = raise Format
1431 :     in
1432 :     share fkindM fk
1433 :     end
1434 :    
1435 :     and ltylistoption () = option ltyloM ltylist ()
1436 :    
1437 :     and rkind () = let
1438 :     fun rk #"5" = F.RK_VECTOR (tyc ())
1439 :     | rk #"6" = F.RK_STRUCT
1440 :     | rk #"7" = FlintUtil.rk_tuple
1441 :     | rk _ = raise Format
1442 :     in
1443 :     share rkindM rk
1444 :     end
1445 :     in
1446 :     fundec
1447 :     end
1448 :    
1449 :     fun unpickleFLINT pickle = let
1450 :     val session =
1451 :     UU.mkSession (UU.stringGetter (Byte.bytesToString pickle))
1452 :     val sharedStuff = mkSharedStuff (session, A.LVAR)
1453 :     val flint = mkFlintUnpickler (session, sharedStuff)
1454 :     val foM = UU.mkMap ()
1455 :     in
1456 :     UU.r_option session foM flint ()
1457 :     end
1458 :    
1459 : blume 587 fun mkUnpicklers sessionInfo context = let
1460 :     val { session, stringlist } = sessionInfo
1461 :     val sharedStuff = mkSharedStuff (session, A.LVAR)
1462 :     val { symbol, pid, ... } = sharedStuff
1463 :     val sylM = UU.mkMap ()
1464 :     val symbollist = UU.r_list session sylM symbol
1465 :     val extraInfo = { globalPid = fn () => raise Format,
1466 :     symbollist = symbollist,
1467 :     sharedStuff = sharedStuff,
1468 :     lib = true }
1469 :     val statenv = mkEnvUnpickler extraInfo sessionInfo context
1470 : monnier 427 val flint = mkFlintUnpickler (session, sharedStuff)
1471 : blume 515 val pidFlintPM = UU.mkMap ()
1472 :     val symbind = UU.r_pair session pidFlintPM (pid, flint)
1473 : monnier 427 val sblM = UU.mkMap ()
1474 :     val sbl = UU.r_list session sblM symbind
1475 : blume 587 fun symenv () = SymbolicEnv.fromListi (sbl ())
1476 : monnier 427 in
1477 : blume 587 { symenv = symenv, statenv = statenv,
1478 : monnier 427 symbol = symbol, symbollist = symbollist }
1479 :     end
1480 :    
1481 :     val unpickleEnv =
1482 : blume 587 fn c => Stats.doPhase (Stats.makePhase "Compiler 087 unpickleEnv")
1483 :     (unpickleEnv c)
1484 : monnier 427 end

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