Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/trunk/src/compiler/Semant/pickle/pickmod-new.sml
ViewVC logotype

Diff of /sml/trunk/src/compiler/Semant/pickle/pickmod-new.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 476, Wed Nov 10 22:59:58 1999 UTC revision 569, Tue Mar 7 04:01:07 2000 UTC
# Line 5  Line 5 
5   *)   *)
6  signature PICKMOD = sig  signature PICKMOD = sig
7    
8      datatype ckey =                     (* context key *)      (* "context keys": PrimKey indicates some kind of "primitive" context
9          PrimKey of string       * (e.g., the primitive environment), and NodeKey specifies a module
10        | NodeKey of int * Symbol.symbol       * of a library.  The library is given by the string list (CM's "pickle"
11         * representation of the abstract path) and the module is given by
12         * a representative export symbol.
13         * But these are details that we don't concern us here.  We just have
14         * to write this info to a pickle. *)
15        datatype ckey =
16            PrimKey
17          | NodeKey of string list * Symbol.symbol
18    
19      type 'a context =      type 'a context =
20          { lookSTR: ModuleId.modId -> 'a,          { lookSTR: ModuleId.modId -> 'a,
# Line 26  Line 33 
33               exportLvars: Access.lvar list,               exportLvars: Access.lvar list,
34               exportPid: PersStamps.persstamp option}               exportPid: PersStamps.persstamp option}
35    
36        (* Re-pickling is done for the purpose of getting the hash value
37         * of a "reduced" (filtered) version of another environment that
38         * has been pickled before.  During re-pickling, the LOCAL->GLOBAL
39         * translation for stamps and the LVAR->EXTERN translation for
40         * accesses is undone so that the resulting hash value is the
41         * same that one would have gotten if the current environment
42         * was pickled using "pickleEnv". The context for repickling is
43         * specified using a set of module IDs instead of an entire
44         * context environment.  The set will have to be obtained from the
45         * unpickling process of the original pickle. *)
46        val repickleEnvHash :
47            { context: ModuleId.Set.set,
48              env: StaticEnv.staticEnv,
49              orig_hash: PersStamps.persstamp } -> PersStamps.persstamp
50    
51      val pickleFLINT:      val pickleFLINT:
52          CompBasic.flint option          CompBasic.flint option
53          -> { hash: PersStamps.persstamp,          -> { hash: PersStamps.persstamp,
# Line 36  Line 58 
58      type map      type map
59      val emptyMap : map      val emptyMap : map
60    
61        type env'n'ctxt = { env: StaticEnv.staticEnv, ctxt: ModuleId.Set.set }
62    
63      val envPickler :      val envPickler :
64          ckey option context -> (map, StaticEnv.staticEnv) PickleUtil.pickler          ckey option context -> (map, env'n'ctxt) PickleUtil.pickler
65    
66      val symenvPickler : (map, SymbolicEnv.symenv) PickleUtil.pickler      val symenvPickler : (map, SymbolicEnv.symenv) PickleUtil.pickler
67    
# Line 50  Line 74 
74  end  end
75    
76  local  local
     (* make those into red-black-maps once rb-maps work correcty. *)  
77      functor MapFn = RedBlackMapFn      functor MapFn = RedBlackMapFn
78      structure IntMap = IntRedBlackMap      structure IntMap = IntRedBlackMap
79  in  in
# Line 147  Line 170 
170           DTF, TYCON, T, II, VAR, SD, SG, FSG,  SP, EN,           DTF, TYCON, T, II, VAR, SD, SG, FSG,  SP, EN,
171           STR, F, STE, TCE, STRE, FE, EE, ED, EEV, FX,           STR, F, STE, TCE, STRE, FE, EE, ED, EEV, FX,
172           B, DCON, DICT, FPRIM, FUNDEC, TFUNDEC, DATACON, DTMEM, NRD,           B, DCON, DICT, FPRIM, FUNDEC, TFUNDEC, DATACON, DTMEM, NRD,
173           OVERLD, FCTC, SEN, FEN) =           OVERLD, FCTC, SEN, FEN, SPATH, IPATH) =
174          (1, 2, 3, 4, 5, 6, 7, 8, 9, 10,          (1, 2, 3, 4, 5, 6, 7, 8, 9, 10,
175           11, 12, 13, 14, 15, 16, 17, 18, 19, 20,           11, 12, 13, 14, 15, 16, 17, 18, 19, 20,
176           21, 22, 23, 24, 25, 26, 27, 28, 29, 30,           21, 22, 23, 24, 25, 26, 27, 28, 29, 30,
177           31, 32, 33, 34, 35, 36, 37, 38, 39, 40,           31, 32, 33, 34, 35, 36, 37, 38, 39, 40,
178           41, 42, 43, 44, 45, 46, 47, 48, 49,           41, 42, 43, 44, 45, 46, 47, 48, 49,
179           50, 51, 52, 53)           50, 51, 52, 53, 54, 55)
180    
181      (* this is a bit awful...      (* this is a bit awful...
182       * (we really ought to have syntax for "functional update") *)       * (we really ought to have syntax for "functional update") *)
# Line 207  Line 230 
230                               mi = MIMap.insert (mi, x, v) } }                               mi = MIMap.insert (mi, x, v) } }
231    
232      infix 3 $      infix 3 $
     infixr 4 &  
     val op & = PU.&  
     val % = PU.%  
233    
234      val int = PU.w_int      val int = PU.w_int
235      val int32 = PU.w_int32      val int32 = PU.w_int32
# Line 243  Line 263 
263    
264      fun numkind arg = let      fun numkind arg = let
265          val op $ = PU.$ NK          val op $ = PU.$ NK
266          fun nk (P.INT i) = "A" $ int i          fun nk (P.INT i) = "A" $ [int i]
267            | nk (P.UINT i) = "B" $ int i            | nk (P.UINT i) = "B" $ [int i]
268            | nk (P.FLOAT i) = "C" $ int i            | nk (P.FLOAT i) = "C" $ [int i]
269      in      in
270          nk arg          nk arg
271      end      end
272    
273      fun arithop oper = let      fun arithop oper = let
274            val op $ = PU.$ AO
275          fun arithopc P.+ = "\000"          fun arithopc P.+ = "\000"
276            | arithopc P.- = "\001"            | arithopc P.- = "\001"
277            | arithopc P.* = "\002"            | arithopc P.* = "\002"
# Line 265  Line 286 
286            | arithopc P.XORB = "\011"            | arithopc P.XORB = "\011"
287            | arithopc P.NOTB = "\012"            | arithopc P.NOTB = "\012"
288      in      in
289          % AO (arithopc oper)          arithopc oper $ []
290      end      end
291    
292      fun cmpop oper = let      fun cmpop oper = let
293            val op $ = PU.$ CO
294          fun cmpopc P.> = "\000"          fun cmpopc P.> = "\000"
295            | cmpopc P.>= = "\001"            | cmpopc P.>= = "\001"
296            | cmpopc P.< = "\002"            | cmpopc P.< = "\002"
# Line 280  Line 302 
302            | cmpopc P.EQL = "\008"            | cmpopc P.EQL = "\008"
303            | cmpopc P.NEQ = "\009"            | cmpopc P.NEQ = "\009"
304      in      in
305          % CO (cmpopc oper)          cmpopc oper $ []
306      end      end
307    
308      fun primop p = let      fun primop p = let
309          val op $ = PU.$ PO          val op $ = PU.$ PO
310          fun ?n = String.str (Char.chr n)          fun ?n = String.str (Char.chr n)
311          fun fromto tag (from, to) = ?tag $ int from & int to          fun fromto tag (from, to) = ?tag $ [int from, int to]
312          fun %?n = % PO (?n)          fun %?n = ?n $ []
313          in          in
314              case p of              case p of
315                  P.ARITH { oper, overflow, kind } =>                  P.ARITH { oper, overflow, kind } =>
316                      ?100 $ arithop oper & bool overflow & numkind kind                      ?100 $ [arithop oper, bool overflow, numkind kind]
317                | P.CMP { oper, kind } => ?101 $ cmpop oper & numkind kind                | P.CMP { oper, kind } => ?101 $ [cmpop oper, numkind kind]
318                | P.TEST x => fromto 102 x                | P.TEST x => fromto 102 x
319                | P.TESTU x => fromto 103 x                | P.TESTU x => fromto 103 x
320                | P.TRUNC x => fromto 104 x                | P.TRUNC x => fromto 104 x
321                | P.EXTEND x => fromto 105 x                | P.EXTEND x => fromto 105 x
322                | P.COPY x => fromto 106 x                | P.COPY x => fromto 106 x
323                | P.INLLSHIFT kind => ?107 $ numkind kind                | P.INLLSHIFT kind => ?107 $ [numkind kind]
324                | P.INLRSHIFT kind => ?108 $ numkind kind                | P.INLRSHIFT kind => ?108 $ [numkind kind]
325                | P.INLRSHIFTL kind => ?109 $ numkind kind                | P.INLRSHIFTL kind => ?109 $ [numkind kind]
326                | P.ROUND { floor, fromkind, tokind } =>                | P.ROUND { floor, fromkind, tokind } =>
327                      ?110 $ bool floor & numkind fromkind & numkind tokind                      ?110 $ [bool floor, numkind fromkind, numkind tokind]
328                | P.REAL { fromkind, tokind } =>                | P.REAL { fromkind, tokind } =>
329                      ?111 $ numkind fromkind & numkind tokind                      ?111 $ [numkind fromkind, numkind tokind]
330                | P.NUMSUBSCRIPT { kind, checked, immutable } =>                | P.NUMSUBSCRIPT { kind, checked, immutable } =>
331                      ?112 $ numkind kind & bool checked & bool immutable                      ?112 $ [numkind kind, bool checked, bool immutable]
332                | P.NUMUPDATE { kind, checked } =>                | P.NUMUPDATE { kind, checked } =>
333                      ?113 $ numkind kind & bool checked                      ?113 $ [numkind kind, bool checked]
334                | P.INL_MONOARRAY kind => ?114 $ numkind kind                | P.INL_MONOARRAY kind => ?114 $ [numkind kind]
335                | P.INL_MONOVECTOR kind => ?115 $ numkind kind                | P.INL_MONOVECTOR kind => ?115 $ [numkind kind]
336    
337                | P.MKETAG => %?0                | P.MKETAG => %?0
338                | P.WRAP => %?1                | P.WRAP => %?1
# Line 380  Line 402 
402    
403      fun consig arg = let      fun consig arg = let
404          val op $ = PU.$ CS          val op $ = PU.$ CS
405          fun cs (A.CSIG (i, j)) = "S" $ int i & int j          fun cs (A.CSIG (i, j)) = "S" $ [int i, int j]
406            | cs A.CNIL = % CS "N"            | cs A.CNIL = "N" $ []
407      in      in
408          cs arg          cs arg
409      end      end
410    
411      fun mkAccess lvar = let      fun mkAccess { lvar, isLocalPid } = let
412          val op $ = PU.$ A          val op $ = PU.$ A
413          fun access (A.LVAR i) = "A" $ lvar i          fun access (A.LVAR i) = "A" $ [lvar i]
414            | access (A.EXTERN p) = "B" $ pid p            | access (A.EXTERN p) = "B" $ [pid p]
415            | access (A.PATH (a, i)) = "C" $ access a & int i            | access (A.PATH (a as A.EXTERN p, i)) =
416            | access A.NO_ACCESS = % A "D"              (* isLocalPid always returns false for in the "normal pickler"
417                 * case.  It returns true in the "repickle" case for the
418                 * pid that was the hash of the original whole pickle.
419                 * Since alpha-conversion has already taken place if we find
420                 * an EXTERN pid, we don't call "lvar" but "int". *)
421                if isLocalPid p then "A" $ [int i]
422                else "C" $ [access a, int i]
423              | access (A.PATH (a, i)) = "C" $ [access a, int i]
424              | access A.NO_ACCESS = "D" $ []
425    
426          val op $ = PU.$ CR          val op $ = PU.$ CR
427          fun conrep A.UNTAGGED = % CR "A"          fun conrep A.UNTAGGED = "A" $ []
428            | conrep (A.TAGGED i) = "B" $ int i            | conrep (A.TAGGED i) = "B" $ [int i]
429            | conrep A.TRANSPARENT = %CR "C"            | conrep A.TRANSPARENT = "C" $ []
430            | conrep (A.CONSTANT i) = "D" $ int i            | conrep (A.CONSTANT i) = "D" $ [int i]
431            | conrep A.REF = %CR "E"            | conrep A.REF = "E" $ []
432            | conrep (A.EXN a) = "F" $ access a            | conrep (A.EXN a) = "F" $ [access a]
433            | conrep A.LISTCONS = %CR "G"            | conrep A.LISTCONS = "G" $ []
434            | conrep A.LISTNIL = %CR "H"            | conrep A.LISTNIL = "H" $ []
435            | conrep (A.SUSP NONE) = %CR "I"            | conrep (A.SUSP NONE) = "I" $ []
436            | conrep (A.SUSP (SOME (a, b))) = "J" $ access a & access b            | conrep (A.SUSP (SOME (a, b))) = "J" $ [access a, access b]
437      in      in
438          { access = access, conrep = conrep }          { access = access, conrep = conrep }
439      end      end
440    
441      (* lambda-type stuff; this is used in both picklers *)      (* lambda-type stuff; some of it is used in both picklers *)
442      fun ltyI x = let      fun tkind x = let
443          val op $ = PU.$ LT          val op $ = PU.$ TK
444            fun tk x =
445                case LK.tk_out x of
446                LK.TK_MONO => "A" $ []
447              | LK.TK_BOX => "B" $ []
448              | LK.TK_SEQ ks => "C" $ [list tkind ks]
449              | LK.TK_FUN (ks, kr) => "D" $ [list tkind ks, tkind kr]
450      in      in
451            share TKs tk x
452        end
453    
454        fun mkLty lvar = let
455            fun lty x = let
456                val op $ = PU.$ LT
457                fun ltyI x =
458          case LK.lt_out x of          case LK.lt_out x of
459              LK.LT_TYC tc => "A" $ tyc tc                      LK.LT_TYC tc => "A" $ [tyc tc]
460            | LK.LT_STR l => "B" $ list lty l                    | LK.LT_STR l => "B" $ [list lty l]
461            | LK.LT_FCT (ts1, ts2) => "C" $ list lty ts1 & list lty ts2                    | LK.LT_FCT (ts1, ts2) => "C" $ [list lty ts1, list lty ts2]
462            | LK.LT_POLY (ks, ts) => "D" $ list tkind ks & list lty ts                    | LK.LT_POLY (ks, ts) => "D" $ [list tkind ks, list lty ts]
463            | LK.LT_IND _ => bug "unexpected LT_IND in mkPickleLty"            | LK.LT_IND _ => bug "unexpected LT_IND in mkPickleLty"
464            | LK.LT_ENV _ => bug "unexpected LT_ENV in mkPickleLty"            | LK.LT_ENV _ => bug "unexpected LT_ENV in mkPickleLty"
465            | LK.LT_CONT _ => bug "unexpected LT_CONT in mkPickleLty"            | LK.LT_CONT _ => bug "unexpected LT_CONT in mkPickleLty"
466            in
467                share LTs ltyI x
468      end      end
469    
470      and lty x =          and tyc x = let
         if LK.ltp_norm x then share LTs ltyI x  
         else (* bug "unexpected complex lambda type in mkPickleLty" *) ltyI x  
   
     and tycI x = let  
471          val op $ = PU.$ TC          val op $ = PU.$ TC
472      in              fun tycI x =
473          case LK.tc_out x of          case LK.tc_out x of
474              LK.TC_VAR (db, i) => "A" $ int (DI.di_toint db) & int i                      LK.TC_VAR (db, i) => "A" $ [int (DI.di_toint db), int i]
475            | LK.TC_NVAR (n, dp, i) =>                    | LK.TC_NVAR n => "B" $ [lvar n]
476                  "B" $ int n & int (DI.dp_toint dp) & int i                    | LK.TC_PRIM t => "C" $ [int (PT.pt_toint t)]
477            | LK.TC_PRIM t => "C" $ int (PT.pt_toint t)                    | LK.TC_FN (ks, tc) => "D" $ [list tkind ks, tyc tc]
478            | LK.TC_FN (ks, tc) => "D" $ list tkind ks & tyc tc                    | LK.TC_APP (tc, l) => "E" $ [tyc tc, list tyc l]
479            | LK.TC_APP (tc, l) => "E" $ tyc tc & list tyc l                    | LK.TC_SEQ l => "F" $ [list tyc l]
480            | LK.TC_SEQ l => "F" $ list tyc l                    | LK.TC_PROJ (tc, i) => "G" $ [tyc tc, int i]
481            | LK.TC_PROJ (tc, i) => "G" $ tyc tc & int i                    | LK.TC_SUM l => "H" $ [list tyc l]
           | LK.TC_SUM l => "H" $ list tyc l  
482            | LK.TC_FIX ((n, tc, ts), i) =>            | LK.TC_FIX ((n, tc, ts), i) =>
483                  "I" $ int n & tyc tc & list tyc ts & int i                          "I" $ [int n, tyc tc, list tyc ts, int i]
484            | LK.TC_ABS tc => "J" $ tyc tc                    | LK.TC_ABS tc => "J" $ [tyc tc]
485            | LK.TC_BOX tc => "K" $ tyc tc                    | LK.TC_BOX tc => "K" $ [tyc tc]
486            | LK.TC_TUPLE (_, l) => "L" $ list tyc l                    | LK.TC_TUPLE (_, l) => "L" $ [list tyc l]
487            | LK.TC_ARROW (LK.FF_VAR (b1, b2), ts1, ts2) =>            | LK.TC_ARROW (LK.FF_VAR (b1, b2), ts1, ts2) =>
488                  "M" $ bool b1 & bool b2 & list tyc ts1 & list tyc ts2                          "M" $ [bool b1, bool b2, list tyc ts1, list tyc ts2]
489            | LK.TC_ARROW (LK.FF_FIXED, ts1, ts2) =>            | LK.TC_ARROW (LK.FF_FIXED, ts1, ts2) =>
490                  "N" $ list tyc ts1 & list tyc ts2                          "N" $ [list tyc ts1, list tyc ts2]
491            | LK.TC_PARROW _ => bug "unexpected TC_PARREW in mkPickleLty"            | LK.TC_PARROW _ => bug "unexpected TC_PARREW in mkPickleLty"
492            | LK.TC_TOKEN (tk, t) => "O" $ int (LK.token_int tk) & tyc t                    | LK.TC_TOKEN (tk, t) => "O" $ [int (LK.token_int tk), tyc t]
493            | LK.TC_IND _ => bug "unexpected TC_IND in mkPickleLty"            | LK.TC_IND _ => bug "unexpected TC_IND in mkPickleLty"
494            | LK.TC_ENV _ => bug "unexpected TC_ENV in mkPickleLty"            | LK.TC_ENV _ => bug "unexpected TC_ENV in mkPickleLty"
495            | LK.TC_CONT _ => bug "unexpected TC_CONT in mkPickleLty"            | LK.TC_CONT _ => bug "unexpected TC_CONT in mkPickleLty"
496            in
497                share TCs tycI x
498      end      end
   
     and tyc x =  
         if LK.tcp_norm x then share TCs tycI x  
         else (* bug "unexpected complex lambda tyc in mkPickleLty" *) tycI x  
   
     and tkind x = let  
         val op $ = PU.$ TK  
         fun tk x =  
             case LK.tk_out x of  
             LK.TK_MONO => %TK "A"  
           | LK.TK_BOX => %TK "B"  
           | LK.TK_SEQ ks => "C" $ list tkind ks  
           | LK.TK_FUN (ks, kr) => "D" $ list tkind ks & tkind kr  
499      in      in
500          share TKs tk x          { tyc = tyc, lty = lty }
501      end      end
502    
503      (* the FLINT pickler *)      (* the FLINT pickler *)
504      fun flint flint_exp = let      fun flint flint_exp = let
505          val alphaConvert = mkAlphaConvert ()          val alphaConvert = mkAlphaConvert ()
506          val lvar = int o alphaConvert          val lvar = int o alphaConvert
507          val { access, conrep } = mkAccess lvar          val { access, conrep } = mkAccess { lvar = lvar,
508                                                isLocalPid = fn _ => false }
509            val { lty, tyc } = mkLty lvar
510    
511          val op $ = PU.$ V          val op $ = PU.$ V
512          fun value (F.VAR v) = "a" $ lvar v          fun value (F.VAR v) = "a" $ [lvar v]
513            | value (F.INT i) = "b" $ int i            | value (F.INT i) = "b" $ [int i]
514            | value (F.INT32 i32) = "c" $ int32 i32            | value (F.INT32 i32) = "c" $ [int32 i32]
515            | value (F.WORD w) = "d" $ word w            | value (F.WORD w) = "d" $ [word w]
516            | value (F.WORD32 w32) = "e" $ word32 w32            | value (F.WORD32 w32) = "e" $ [word32 w32]
517            | value (F.REAL s) = "f" $ string s            | value (F.REAL s) = "f" $ [string s]
518            | value (F.STRING s) = "g" $ string s            | value (F.STRING s) = "g" $ [string s]
519    
520          fun con arg = let          fun con arg = let
521              val op $ = PU.$ C              val op $ = PU.$ C
522              fun c (F.DATAcon (dc, ts, v), e) =              fun c (F.DATAcon (dc, ts, v), e) =
523                  "1" $ dcon (dc, ts) & lvar v & lexp e                  "1" $ [dcon (dc, ts), lvar v, lexp e]
524                | c (F.INTcon i, e) = "2" $ int i & lexp e                | c (F.INTcon i, e) = "2" $ [int i, lexp e]
525                | c (F.INT32con i32, e) = "3" $ int32 i32 & lexp e                | c (F.INT32con i32, e) = "3" $ [int32 i32, lexp e]
526                | c (F.WORDcon w, e) = "4" $ word w & lexp e                | c (F.WORDcon w, e) = "4" $ [word w, lexp e]
527                | c (F.WORD32con w32, e) = "5" $ word32 w32 & lexp e                | c (F.WORD32con w32, e) = "5" $ [word32 w32, lexp e]
528                | c (F.REALcon s, e) = "6" $ string s & lexp e                | c (F.REALcon s, e) = "6" $ [string s, lexp e]
529                | c (F.STRINGcon s, e) = "7" $ string s & lexp e                | c (F.STRINGcon s, e) = "7" $ [string s, lexp e]
530                | c (F.VLENcon i, e) = "8" $ int i & lexp e                | c (F.VLENcon i, e) = "8" $ [int i, lexp e]
531          in          in
532              c arg              c arg
533          end          end
# Line 504  Line 535 
535          and dcon ((s, cr, t), ts) = let          and dcon ((s, cr, t), ts) = let
536              val op $ = PU.$ DCON              val op $ = PU.$ DCON
537          in          in
538              "x" $ symbol s & conrep cr & lty t & list tyc ts              "x" $ [symbol s, conrep cr, lty t, list tyc ts]
539          end          end
540    
541          and dict { default = v, table = tbls } = let          and dict { default = v, table = tbls } = let
542              val op $ = PU.$ DICT              val op $ = PU.$ DICT
543          in          in
544              "y" $ lvar v & list (pair (list tyc, lvar)) tbls              "y" $ [lvar v, list (pair (list tyc, lvar)) tbls]
545          end          end
546    
547          and fprim (dtopt, p, t, ts) = let          and fprim (dtopt, p, t, ts) = let
548              val op $ = PU.$ FPRIM              val op $ = PU.$ FPRIM
549          in          in
550              "z" $ option dict dtopt & primop p & lty t & list tyc ts              "z" $ [option dict dtopt, primop p, lty t, list tyc ts]
551          end          end
552    
553          and lexp arg = let          and lexp arg = let
554              val op $ = PU.$ E              val op $ = PU.$ E
555              fun l (F.RET vs) = "j" $ list value vs              fun l (F.RET vs) = "j" $ [list value vs]
556                | l (F.LET (vs, e1, e2)) =                | l (F.LET (vs, e1, e2)) =
557                  "k" $ list lvar vs & lexp e1 & lexp e2                  "k" $ [list lvar vs, lexp e1, lexp e2]
558                | l (F.FIX (fdecs, e)) = "l" $ list fundec fdecs & lexp e                | l (F.FIX (fdecs, e)) = "l" $ [list fundec fdecs, lexp e]
559                | l (F.APP (v, vs)) = "m" $ value v & list value vs                | l (F.APP (v, vs)) = "m" $ [value v, list value vs]
560                | l (F.TFN (tfdec, e)) = "n" $ tfundec tfdec & lexp e                | l (F.TFN (tfdec, e)) = "n" $ [tfundec tfdec, lexp e]
561                | l (F.TAPP (v, ts)) = "o" $ value v & list tyc ts                | l (F.TAPP (v, ts)) = "o" $ [value v, list tyc ts]
562                | l (F.SWITCH (v, crl, cel, eo)) =                | l (F.SWITCH (v, crl, cel, eo)) =
563                  "p" $ value v & consig crl & list con cel & option lexp eo                  "p" $ [value v, consig crl, list con cel, option lexp eo]
564                | l (F.CON (dc, ts, u, v, e)) =                | l (F.CON (dc, ts, u, v, e)) =
565                  "q" $ dcon (dc, ts) & value u & lvar v & lexp e                  "q" $ [dcon (dc, ts), value u, lvar v, lexp e]
566                | l (F.RECORD (rk, vl, v, e)) =                | l (F.RECORD (rk, vl, v, e)) =
567                  "r" $ rkind rk & list value vl & lvar v & lexp e                  "r" $ [rkind rk, list value vl, lvar v, lexp e]
568                | l (F.SELECT (u, i, v, e)) =                | l (F.SELECT (u, i, v, e)) =
569                  "s" $ value u & int i & lvar v & lexp e                  "s" $ [value u, int i, lvar v, lexp e]
570                | l (F.RAISE (u, ts)) = "t" $ value u & list lty ts                | l (F.RAISE (u, ts)) = "t" $ [value u, list lty ts]
571                | l (F.HANDLE (e, u)) = "u" $ lexp e & value u                | l (F.HANDLE (e, u)) = "u" $ [lexp e, value u]
572                | l (F.BRANCH (p, vs, e1, e2)) =                | l (F.BRANCH (p, vs, e1, e2)) =
573                  "v" $ fprim p & list value vs & lexp e1 & lexp e2                  "v" $ [fprim p, list value vs, lexp e1, lexp e2]
574                | l (F.PRIMOP (p, vs, v, e)) =                | l (F.PRIMOP (p, vs, v, e)) =
575                  "w" $ fprim p & list value vs & lvar v & lexp e                  "w" $ [fprim p, list value vs, lvar v, lexp e]
576          in          in
577              l arg              l arg
578          end          end
# Line 549  Line 580 
580          and fundec (fk, v, vts, e) = let          and fundec (fk, v, vts, e) = let
581              val op $ = PU.$ FUNDEC              val op $ = PU.$ FUNDEC
582          in          in
583              "a" $ fkind fk & lvar v & list (pair (lvar, lty)) vts & lexp e              "a" $ [fkind fk, lvar v, list (pair (lvar, lty)) vts, lexp e]
584          end          end
585    
586          and tfundec (v, tvks, e) = let          and tfundec (_, v, tvks, e) = let
587              val op $ = PU.$ TFUNDEC              val op $ = PU.$ TFUNDEC
588          in          in
589              "b" $ lvar v & list (pair (lvar, tkind)) tvks & lexp e              "b" $ [lvar v, list (pair (lvar, tkind)) tvks, lexp e]
590          end          end
591    
592          and fkind arg = let          and fkind arg = let
593              val op $ = PU.$ FK              val op $ = PU.$ FK
594              fun fk F.FK_FCT = %FK "2"              fun isAlways F.IH_ALWAYS = true
595                | fk (F.FK_FUN { isrec, fixed, known, inline }) =                | isAlways _ = false
596                fun strip (x, y) = x
597                fun fk { cconv = F.CC_FCT, ... } = "2" $ []
598                  | fk { isrec, cconv = F.CC_FUN fixed, known, inline } =
599                  case fixed of                  case fixed of
600                      LK.FF_VAR (b1, b2) =>                      LK.FF_VAR (b1, b2) =>
601                          "3" $ option (list lty) isrec &                          "3" $ [option (list lty) (Option.map strip isrec),
602                          bool b1 & bool b2 & bool known & bool inline                                 bool b1, bool b2, bool known,
603                                   bool (isAlways inline)]
604                    | LK.FF_FIXED =>                    | LK.FF_FIXED =>
605                          "4" $ option (list lty) isrec &                          "4" $ [option (list lty) (Option.map strip isrec),
606                          bool known & bool inline                                 bool known, bool (isAlways inline)]
607          in          in
608              fk arg              fk arg
609          end          end
610    
611          and rkind arg = let          and rkind arg = let
612              val op $ = PU.$ RK              val op $ = PU.$ RK
613              fun rk (F.RK_VECTOR tc) = "5" $ tyc tc              fun rk (F.RK_VECTOR tc) = "5" $ [tyc tc]
614                | rk F.RK_STRUCT = %RK "6"                | rk F.RK_STRUCT = "6" $ []
615                | rk (F.RK_TUPLE _) = %RK "7"                | rk (F.RK_TUPLE _) = "7" $ []
616          in          in
617              rk arg              rk arg
618          end          end
# Line 597  Line 632 
632          list (pair (pid, flint)) (SymbolicEnv.listItemsi sye)          list (pair (pid, flint)) (SymbolicEnv.listItemsi sye)
633    
634      datatype ckey =                     (* context key *)      datatype ckey =                     (* context key *)
635          PrimKey of string          PrimKey
636        | NodeKey of int * Symbol.symbol        | NodeKey of string list * Symbol.symbol
637    
638      type 'a context =      type 'a context =
639          { lookSTR: ModuleId.modId -> 'a,          { lookSTR: ModuleId.modId -> 'a,
# Line 611  Line 646 
646      datatype stubinfo =      datatype stubinfo =
647          NoStub          NoStub
648        | SimpleStub        | SimpleStub
649        | PrimStub of string        | PrimStub
650        | NodeStub of int * Symbol.symbol        | NodeStub of string list * Symbol.symbol
651    
652      (* the environment pickler *)      (* the environment pickler *)
653      fun mkEnvPickler (context0: stubinfo context) = let      fun mkEnvPickler (context0: stubinfo context, isLocalPid) = let
654    
655          val { lookTYC, lookSIG, lookFSIG, lookSTR, lookFCT, lookEENV } =          val { lookTYC, lookSIG, lookFSIG, lookSTR, lookFCT, lookEENV } =
656              context0              context0
# Line 626  Line 661 
661              val op $ = PU.$ ST              val op $ = PU.$ ST
662          in          in
663              case scope of              case scope of
664                  Stamps.LOCAL => "A" $ int (alphaConvert count)                  Stamps.LOCAL => "A" $ [int (alphaConvert count)]
665                | Stamps.GLOBAL p => "B" $ pid p & int count                | Stamps.GLOBAL p =>
666                | Stamps.SPECIAL s => "C" $ string s & int count                      if isLocalPid p then "A" $ [int count]
667                        else "B" $ [pid p, int count]
668                  | Stamps.SPECIAL s => "C" $ [string s, int count]
669          end          end
670    
671          val entVar = stamp          val entVar = stamp
672          val entPath = list entVar          val entPath = list entVar
673    
674          val op $ = PU.$ MI          val op $ = PU.$ MI
675          fun modId (MI.STRid { rlzn, sign }) = "1" $ stamp rlzn & stamp sign          fun modId (MI.STRid { rlzn, sign }) = "1" $ [stamp rlzn, stamp sign]
676            | modId (MI.SIGid s) = "2" $ stamp s            | modId (MI.SIGid s) = "2" $ [stamp s]
677            | modId (MI.FCTid { rlzn, sign }) = "3" $ stamp rlzn & modId sign            | modId (MI.FCTid { rlzn, sign }) = "3" $ [stamp rlzn, modId sign]
678            | modId (MI.FSIGid { paramsig, bodysig }) =            | modId (MI.FSIGid { paramsig, bodysig }) =
679              "4" $ stamp paramsig & stamp bodysig              "4" $ [stamp paramsig, stamp bodysig]
680            | modId (MI.TYCid a) = "5" $ stamp a            | modId (MI.TYCid a) = "5" $ [stamp a]
681            | modId (MI.EENVid s) = "6" $ stamp s            | modId (MI.EENVid s) = "6" $ [stamp s]
682    
683          val lvcount = ref 0          val lvcount = ref 0
684          val lvlist = ref []          val lvlist = ref []
# Line 654  Line 691 
691              j              j
692          end          end
693    
694          val { access, conrep } = mkAccess (int o anotherLvar)          val { access, conrep } = mkAccess { lvar = int o anotherLvar,
695                                                isLocalPid = isLocalPid }
696    
697          fun spath (SP.SPATH p) = list symbol p          val op $ = PU.$ SPATH
698          fun ipath (IP.IPATH p) = list symbol p          fun spath (SP.SPATH p) = "s" $ [list symbol p]
699            val op $ = PU.$ IPATH
700            fun ipath (IP.IPATH p) = "i" $ [list symbol p]
701    
702          val label = symbol          val label = symbol
703    
704          fun eqprop eqp = let          fun eqprop eqp = let
705                val op $ = PU.$ EQP
706              fun eqc T.YES = "\000"              fun eqc T.YES = "\000"
707                | eqc T.NO = "\001"                | eqc T.NO = "\001"
708                | eqc T.IND = "\002"                | eqc T.IND = "\002"
# Line 670  Line 711 
711                | eqc T.ABS = "\005"                | eqc T.ABS = "\005"
712                | eqc T.UNDEF = "\006"                | eqc T.UNDEF = "\006"
713          in          in
714              %EQP (eqc eqp)              eqc eqp $ []
715          end          end
716    
717          fun datacon (T.DATACON { name, const, typ, rep, sign, lazyp }) = let          fun datacon (T.DATACON { name, const, typ, rep, sign, lazyp }) = let
718              val op $ = PU.$ DATACON              val op $ = PU.$ DATACON
719          in          in
720              "c" $ symbol name & bool const & ty typ & conrep rep &              "c" $ [symbol name, bool const, ty typ, conrep rep,
721                    consig sign & bool lazyp                     consig sign, bool lazyp]
722          end          end
723    
724          and tyckind arg = let          and tyckind arg = let
725              val op $ = PU.$ TYCKIND              val op $ = PU.$ TYCKIND
726              fun tk (T.PRIMITIVE pt) = "a" $ int (PT.pt_toint pt)              fun tk (T.PRIMITIVE pt) = "a" $ [int (PT.pt_toint pt)]
727                | tk (T.DATATYPE { index, family, stamps, root,freetycs }) =                | tk (T.DATATYPE { index, family, stamps, root,freetycs }) =
728                  "b" $ int index & option entVar root &                  "b" $ [int index, option entVar root,
729                        dtypeInfo (stamps, family, freetycs)                         dtypeInfo (stamps, family, freetycs)]
730                | tk (T.ABSTRACT tyc) = "c" $ tycon tyc                | tk (T.ABSTRACT tyc) = "c" $ [tycon tyc]
731                | tk (T.FLEXTYC tps) = %TYCKIND "d" (* "f" $ tycpath tps *)                | tk (T.FLEXTYC tps) = "d" $ [] (* "f" $ tycpath tps *)
732                (*** I (Matthias) carried through this message from Zhong:                (*** I (Matthias) carried through this message from Zhong:
733                 tycpath should never be pickled; the only way it can be                 tycpath should never be pickled; the only way it can be
734                 pickled is when pickling the domains of a mutually                 pickled is when pickling the domains of a mutually
# Line 695  Line 736 
736                 datatypes are not assigned accurate domains ... (ZHONG)                 datatypes are not assigned accurate domains ... (ZHONG)
737                 the preceding code is just a temporary gross hack.                 the preceding code is just a temporary gross hack.
738                 ***)                 ***)
739                | tk T.FORMAL = %TYCKIND "d"                | tk T.FORMAL = "d" $ []
740                | tk T.TEMP = %TYCKIND "e"                | tk T.TEMP = "e" $ []
741          in          in
742              tk arg              tk arg
743          end          end
# Line 704  Line 745 
745          and dtypeInfo x = let          and dtypeInfo x = let
746              val op $ = PU.$ DTI              val op $ = PU.$ DTI
747              fun dti_raw (ss, family, freetycs) =              fun dti_raw (ss, family, freetycs) =
748                  "a" $ list stamp (Vector.foldr (op ::) [] ss) &                  "a" $ [list stamp (Vector.foldr (op ::) [] ss),
749                        dtFamily family & list tycon freetycs                         dtFamily family, list tycon freetycs]
750          in          in
751              share (DTs (Vector.sub (#1 x, 0))) dti_raw x              share (DTs (Vector.sub (#1 x, 0))) dti_raw x
752          end          end
# Line 713  Line 754 
754          and dtFamily x = let          and dtFamily x = let
755              val op $ = PU.$ DTF              val op $ = PU.$ DTF
756              fun dtf_raw { mkey, members, lambdatyc } =              fun dtf_raw { mkey, members, lambdatyc } =
757                  "b" $ stamp mkey &                  "b" $ [stamp mkey,
758                        list dtmember (Vector.foldr (op ::) [] members)                         list dtmember (Vector.foldr (op ::) [] members)]
759          in          in
760              share (MBs (#mkey x)) dtf_raw x              share (MBs (#mkey x)) dtf_raw x
761          end          end
# Line 722  Line 763 
763          and dtmember { tycname, dcons, arity, eq = ref e, lazyp, sign } = let          and dtmember { tycname, dcons, arity, eq = ref e, lazyp, sign } = let
764              val op $ = PU.$ DTMEM              val op $ = PU.$ DTMEM
765          in          in
766              "c" $ symbol tycname & list nameRepDomain dcons & int arity &              "c" $ [symbol tycname, list nameRepDomain dcons, int arity,
767                    eqprop e & bool lazyp & consig sign                     eqprop e, bool lazyp, consig sign]
768          end          end
769    
770          and nameRepDomain { name, rep, domain } = let          and nameRepDomain { name, rep, domain } = let
771              val op $ = PU.$ NRD              val op $ = PU.$ NRD
772          in          in
773              "d" $ symbol name & conrep rep & option ty domain              "d" $ [symbol name, conrep rep, option ty domain]
774          end          end
775    
776          and tycon arg = let          and tycon arg = let
# Line 738  Line 779 
779                  let val id = MI.TYCid (#stamp x)                  let val id = MI.TYCid (#stamp x)
780                      fun gt_raw { stamp = s, arity, eq = ref eq, kind, path } =                      fun gt_raw { stamp = s, arity, eq = ref eq, kind, path } =
781                          case lookTYC id of                          case lookTYC id of
782                              SimpleStub => "A" $ modId id                              SimpleStub => "A" $ [modId id]
783                            | NoStub => "B" $ stamp s & int arity & eqprop eq &                            | NoStub => "B" $ [stamp s, int arity, eqprop eq,
784                                              tyckind kind & ipath path                                               tyckind kind, ipath path]
785                            | PrimStub s => "I" $ string s & modId id                            | PrimStub => "I" $ [modId id]
786                            | NodeStub (i, s) =>                            | NodeStub (sl, s) =>
787                                              "J" $ int i & symbol s & modId id                              "J" $ [list string sl, symbol s, modId id]
788                  in                  in
789                      share (MIs (id, NONE)) gt_raw x                      share (MIs (id, NONE)) gt_raw x
790                  end                  end
# Line 752  Line 793 
793                          val { stamp = s, tyfun, strict, path } = x                          val { stamp = s, tyfun, strict, path } = x
794                          val T.TYFUN { arity, body } = tyfun                          val T.TYFUN { arity, body } = tyfun
795                      in                      in
796                          "C" $ stamp s & int arity & ty body &                          "C" $ [stamp s, int arity, ty body,
797                                list bool strict & ipath path                                 list bool strict, ipath path]
798                      end                      end
799                  in                  in
800                      share (MIs (MI.TYCid (#stamp x), NONE)) dt_raw x                      share (MIs (MI.TYCid (#stamp x), NONE)) dt_raw x
801                  end                  end
802                | tc (T.PATHtyc { arity, entPath = ep, path }) =                | tc (T.PATHtyc { arity, entPath = ep, path }) =
803                  "D" $ int arity & entPath ep & ipath path                  "D" $ [int arity, entPath ep, ipath path]
804                | tc (T.RECORDtyc l) = "E" $ list label l                | tc (T.RECORDtyc l) = "E" $ [list label l]
805                | tc (T.RECtyc i) = "F" $ int i                | tc (T.RECtyc i) = "F" $ [int i]
806                | tc (T.FREEtyc i) = "G" $ int i                | tc (T.FREEtyc i) = "G" $ [int i]
807                | tc T.ERRORtyc = %TC "H"                | tc T.ERRORtyc = "H" $ []
808          in          in
809              tc arg              tc arg
810          end          end
# Line 773  Line 814 
814              fun ty (T.VARty (ref (T.INSTANTIATED t))) = ty t              fun ty (T.VARty (ref (T.INSTANTIATED t))) = ty t
815                | ty (T.VARty (ref (T.OPEN _))) =                | ty (T.VARty (ref (T.OPEN _))) =
816                  bug "uninstantiated VARty in pickmod"                  bug "uninstantiated VARty in pickmod"
817                | ty (T.CONty (c, l)) = "a" $ tycon c & list ty l                | ty (T.CONty (c, l)) = "a" $ [tycon c, list ty l]
818                | ty (T.IBOUND i) = "b" $ int i                | ty (T.IBOUND i) = "b" $ [int i]
819                | ty T.WILDCARDty = %T "c"                | ty T.WILDCARDty = "c" $ []
820                | ty (T.POLYty { sign, tyfun = T.TYFUN { arity, body } }) =                | ty (T.POLYty { sign, tyfun = T.TYFUN { arity, body } }) =
821                  "d" $ list bool sign & int arity & ty body                  "d" $ [list bool sign, int arity, ty body]
822                | ty T.UNDEFty = %T "e"                | ty T.UNDEFty = "e" $ []
823                | ty _ = bug "unexpected type in pickmod-ty"                | ty _ = bug "unexpected type in pickmod-ty"
824          in          in
825              ty arg              ty arg
826          end          end
827    
828          val op $ = PU.$ II          val op $ = PU.$ II
829          fun inl_info (II.INL_PRIM (p, t)) = "A" $ primop p & option ty t          fun inl_info (II.INL_PRIM (p, t)) = "A" $ [primop p, option ty t]
830            | inl_info (II.INL_STR sl) = "B" $ list inl_info sl            | inl_info (II.INL_STR sl) = "B" $ [list inl_info sl]
831            | inl_info II.INL_NO = %II "C"            | inl_info II.INL_NO = "C" $ []
832            | inl_info _ = bug "unexpected inl_info in pickmod"            | inl_info _ = bug "unexpected inl_info in pickmod"
833    
834          val op $ = PU.$ VAR          val op $ = PU.$ VAR
835          fun var (V.VALvar { access = a, info, path, typ = ref t }) =          fun var (V.VALvar { access = a, info, path, typ = ref t }) =
836              "1" $ access a & inl_info info & spath path & ty t              "1" $ [access a, inl_info info, spath path, ty t]
837            | var (V.OVLDvar { name, options = ref p,            | var (V.OVLDvar { name, options = ref p,
838                               scheme = T.TYFUN { arity, body } }) =                               scheme = T.TYFUN { arity, body } }) =
839              "2" $ symbol name & list overld p & int arity & ty body              "2" $ [symbol name, list overld p, int arity, ty body]
840            | var V.ERRORvar = %VAR "3"            | var V.ERRORvar = "3" $ []
841    
842          and overld { indicator, variant } = let          and overld { indicator, variant } = let
843              val op $ = PU.$ OVERLD              val op $ = PU.$ OVERLD
844          in          in
845              "o" $ ty indicator & var variant              "o" $ [ty indicator, var variant]
846          end          end
847    
848          fun fsigId (M.FSIG { paramsig = M.SIG { stamp = ps, ... },          fun fsigId (M.FSIG { paramsig = M.SIG { stamp = ps, ... },
# Line 812  Line 853 
853    
854          fun strDef arg = let          fun strDef arg = let
855              val op $ = PU.$ SD              val op $ = PU.$ SD
856              fun sd (M.CONSTstrDef s) = "C" $ Structure s              fun sd (M.CONSTstrDef s) = "C" $ [Structure s]
857                | sd (M.VARstrDef (s, p)) = "V" $ Signature s & entPath p                | sd (M.VARstrDef (s, p)) = "V" $ [Signature s, entPath p]
858          in          in
859              sd arg              sd arg
860          end          end
# Line 824  Line 865 
865           *)           *)
866          and Signature arg = let          and Signature arg = let
867              val op $ = PU.$ SG              val op $ = PU.$ SG
868              fun sg  M.ERRORsig = %SG "A"              fun sg  M.ERRORsig = "A" $ []
869                | sg (M.SIG x) = let                | sg (M.SIG x) = let
870                      val id = MI.SIGid (#stamp x)                      val id = MI.SIGid (#stamp x)
871                      fun sig_raw x = let                      fun sig_raw x = let
# Line 834  Line 875 
875                          val b = NONE            (* currently turned off *)                          val b = NONE            (* currently turned off *)
876                      in                      in
877                          case lookSIG id of                          case lookSIG id of
878                              SimpleStub => "B" $ modId id                              SimpleStub => "B" $ [modId id]
879                            | NoStub =>                            | NoStub =>
880                                  "C" $ option symbol name & bool closed &                                  "C" $ [option symbol name, bool closed,
881                                        bool fctflag & stamp sta &                                         bool fctflag, stamp sta,
882                                        list symbol symbols &                                         list symbol symbols,
883                                        list (pair (symbol, spec)) elements &                                         list (pair (symbol, spec)) elements,
884                                        option (list (pair (entPath, tkind))) b &                                         option (list (pair (entPath, tkind))) b,
885                                        list (list spath) typsharing &                                         list (list spath) typsharing,
886                                        list (list spath) strsharing                                         list (list spath) strsharing]
887                            | PrimStub s => "D" $ string s & modId id                            | PrimStub => "D" $ [modId id]
888                            | NodeStub (i, s) =>                            | NodeStub (sl, s) =>
889                                        "E" $ int i & symbol s & modId id                              "E" $ [list string sl, symbol s, modId id]
890                      end                      end
891                  in                  in
892                      share (MIs (id, NONE)) sig_raw x                      share (MIs (id, NONE)) sig_raw x
# Line 856  Line 897 
897    
898          and fctSig arg = let          and fctSig arg = let
899              val op $ = PU.$ FSG              val op $ = PU.$ FSG
900              fun fsg M.ERRORfsig = %FSG "a"              fun fsg M.ERRORfsig = "a" $ []
901                | fsg (fs as M.FSIG x) = let                | fsg (fs as M.FSIG x) = let
902                      val id = fsigId fs                      val id = fsigId fs
903                      fun fsig_raw x = let                      fun fsig_raw x = let
904                          val { kind, paramsig, paramvar, paramsym, bodysig } = x                          val { kind, paramsig, paramvar, paramsym, bodysig } = x
905                      in                      in
906                          case lookFSIG id of                          case lookFSIG id of
907                              SimpleStub => "b" $ modId id                              SimpleStub => "b" $ [modId id]
908                            | NoStub =>                            | NoStub =>
909                                  "c" $ option symbol kind & Signature paramsig &                                  "c" $ [option symbol kind, Signature paramsig,
910                                        entVar paramvar &                                         entVar paramvar,
911                                        option symbol paramsym &                                         option symbol paramsym,
912                                        Signature bodysig                                         Signature bodysig]
913                            | PrimStub s => "d" $ string s & modId id                            | PrimStub => "d" $ [modId id]
914                            | NodeStub (i, s) =>                            | NodeStub (sl, s) => "e" $ [list string sl,
915                                        "e" $ int i & symbol s & modId id                                                         symbol s, modId id]
916                      end                      end
917                  in                  in
918                      share (MIs (id, NONE)) fsig_raw x                      share (MIs (id, NONE)) fsig_raw x
# Line 883  Line 924 
924          and spec arg = let          and spec arg = let
925              val op $ = PU.$ SP              val op $ = PU.$ SP
926              fun sp (M.TYCspec { spec = t, entVar = v, repl, scope }) =              fun sp (M.TYCspec { spec = t, entVar = v, repl, scope }) =
927                  "1" $ tycon t & entVar v & bool repl & int scope                  "1" $ [tycon t, entVar v, bool repl, int scope]
928                | sp (M.STRspec { sign, slot, def, entVar = v }) =                | sp (M.STRspec { sign, slot, def, entVar = v }) =
929                  "2" $ Signature sign & int slot &                  "2" $ [Signature sign, int slot,
930                        option (pair (strDef, int)) def & entVar v                         option (pair (strDef, int)) def, entVar v]
931                | sp (M.FCTspec { sign, slot, entVar = v }) =                | sp (M.FCTspec { sign, slot, entVar = v }) =
932                  "3" $ fctSig sign & int slot & entVar v                  "3" $ [fctSig sign, int slot, entVar v]
933                | sp (M.VALspec { spec = t, slot }) = "4" $ ty t & int slot                | sp (M.VALspec { spec = t, slot }) = "4" $ [ty t, int slot]
934                | sp (M.CONspec { spec = c, slot }) =                | sp (M.CONspec { spec = c, slot }) =
935                  "5" $ datacon c & option int slot                  "5" $ [datacon c, option int slot]
936          in          in
937              sp arg              sp arg
938          end          end
939    
940          and entity arg = let          and entity arg = let
941              val op $ = PU.$ EN              val op $ = PU.$ EN
942              fun en (M.TYCent t) = "A" $ tycEntity t              fun en (M.TYCent t) = "A" $ [tycEntity t]
943                | en (M.STRent t) = "B" $ strEntity t                | en (M.STRent t) = "B" $ [strEntity t]
944                | en (M.FCTent t) = "C" $ fctEntity t                | en (M.FCTent t) = "C" $ [fctEntity t]
945                | en M.ERRORent = %EN "D"                | en M.ERRORent = "D" $ []
946          in          in
947              en arg              en arg
948          end          end
# Line 909  Line 950 
950          and fctClosure (M.CLOSURE { param, body, env }) = let          and fctClosure (M.CLOSURE { param, body, env }) = let
951              val op $ = PU.$ FCTC              val op $ = PU.$ FCTC
952          in          in
953              "f" $ entVar param & strExp body & entityEnv env              "f" $ [entVar param, strExp body, entityEnv env]
954          end          end
955    
956          and Structure arg = let          and Structure arg = let
957              val op $ = PU.$ STR              val op $ = PU.$ STR
958              fun str (M.STRSIG { sign, entPath = p }) =              fun str (M.STRSIG { sign, entPath = p }) =
959                  "A" $ Signature sign & entPath p                  "A" $ [Signature sign, entPath p]
960                | str M.ERRORstr = %STR "B"                | str M.ERRORstr = "B" $ []
961                | str (M.STR (x as { sign = M.SIG sign, ... })) = let                | str (M.STR (x as { sign = M.SIG sign, ... })) = let
962                      val id = MI.STRid { rlzn = #stamp (#rlzn x),                      val id = MI.STRid { rlzn = #stamp (#rlzn x),
963                                          sign = #stamp sign }                                          sign = #stamp sign }
964                      fun s_raw { sign, rlzn, access = a, info } =                      fun s_raw { sign, rlzn, access = a, info } =
965                          case lookSTR id of                          case lookSTR id of
966                              SimpleStub => "C" $ modId id & access a                              SimpleStub => "C" $ [modId id, access a]
967                            | NoStub =>                            | NoStub =>
968                                  "D" $ Signature sign & strEntity rlzn &                                  "D" $ [Signature sign, strEntity rlzn,
969                                        access a & inl_info info                                         access a, inl_info info]
970                            | PrimStub s => "I" $ string s & modId id                            | PrimStub => "I" $ [modId id]
971                            | NodeStub (i, s) =>                            | NodeStub (sl, s) =>
972                                   "J" $ int i & symbol s & modId id & access a                              "J" $ [list string sl, symbol s, modId id,
973                                       access a]
974                  in                  in
975                      share (MIs (id, acc_pid (#access x))) s_raw x                      share (MIs (id, acc_pid (#access x))) s_raw x
976                  end                  end
# Line 939  Line 981 
981    
982          and Functor arg = let          and Functor arg = let
983              val op $ = PU.$ F              val op $ = PU.$ F
984              fun fct M.ERRORfct = %F "E"              fun fct M.ERRORfct = "E" $ []
985                | fct (M.FCT x) = let                | fct (M.FCT x) = let
986                      val id = MI.FCTid { rlzn = #stamp (#rlzn x),                      val id = MI.FCTid { rlzn = #stamp (#rlzn x),
987                                          sign = fsigId (#sign x) }                                          sign = fsigId (#sign x) }
988                      fun f_raw { sign, rlzn, access = a, info } =                      fun f_raw { sign, rlzn, access = a, info } =
989                          case lookFCT id of                          case lookFCT id of
990                              SimpleStub => "F" $ modId id & access a                              SimpleStub => "F" $ [modId id, access a]
991                            | NoStub =>                            | NoStub =>
992                                  "G" $ fctSig sign & fctEntity rlzn &                              "G" $ [fctSig sign, fctEntity rlzn,
993                                        access a & inl_info info                                     access a, inl_info info]
994                            | PrimStub s => "H" $ string s & modId id                            | PrimStub => "H" $ [modId id]
995                            | NodeStub (i, s) =>                            | NodeStub (sl, s) =>
996                                  "I" $ int i & symbol s & modId id & access a                              "I" $ [list string sl, symbol s, modId id,
997                                       access a]
998                  in                  in
999                      share (MIs (id, acc_pid (#access x))) f_raw x                      share (MIs (id, acc_pid (#access x))) f_raw x
1000                  end                  end
# Line 959  Line 1002 
1002              fct arg              fct arg
1003          end          end
1004    
1005          and stampExp (M.CONST s) = PU.$ STE ("a", stamp s)          and stampExp (M.CONST s) = PU.$ STE ("a", [stamp s])
1006            | stampExp (M.GETSTAMP s) = PU.$ STE ("b", strExp s)            | stampExp (M.GETSTAMP s) = PU.$ STE ("b", [strExp s])
1007            | stampExp M.NEW = %STE "c"            | stampExp M.NEW = "c" $ []
1008    
1009          and tycExp (M.CONSTtyc t) = PU.$ TCE ("d", tycon t)          and tycExp (M.CONSTtyc t) = PU.$ TCE ("d", [tycon t])
1010            | tycExp (M.FORMtyc t) = PU.$ TCE ("e", tycon t)            | tycExp (M.FORMtyc t) = PU.$ TCE ("e", [tycon t])
1011            | tycExp (M.VARtyc s) = PU.$ TCE ("f", entPath s)            | tycExp (M.VARtyc s) = PU.$ TCE ("f", [entPath s])
1012    
1013          and strExp arg = let          and strExp arg = let
1014              val op $ = PU.$ STRE              val op $ = PU.$ STRE
1015              fun stre (M.VARstr s) = "g" $ entPath s              fun stre (M.VARstr s) = "g" $ [entPath s]
1016                | stre (M.CONSTstr s) = "h" $ strEntity s                | stre (M.CONSTstr s) = "h" $ [strEntity s]
1017                | stre (M.STRUCTURE { stamp = s, entDec }) =                | stre (M.STRUCTURE { stamp = s, entDec }) =
1018                  "i" $ stampExp s & entityDec entDec                  "i" $ [stampExp s, entityDec entDec]
1019                | stre (M.APPLY (f, s)) = "j" $ fctExp f & strExp s                | stre (M.APPLY (f, s)) = "j" $ [fctExp f, strExp s]
1020                | stre (M.LETstr (e, s)) = "k" $ entityDec e & strExp s                | stre (M.LETstr (e, s)) = "k" $ [entityDec e, strExp s]
1021                | stre (M.ABSstr (s, e)) = "l" $ Signature s & strExp e                | stre (M.ABSstr (s, e)) = "l" $ [Signature s, strExp e]
1022                | stre (M.CONSTRAINstr { boundvar, raw, coercion }) =                | stre (M.CONSTRAINstr { boundvar, raw, coercion }) =
1023                  "m" $ entVar boundvar & strExp raw & strExp coercion                  "m" $ [entVar boundvar, strExp raw, strExp coercion]
1024                | stre (M.FORMstr fs) = "n" $ fctSig fs                | stre (M.FORMstr fs) = "n" $ [fctSig fs]
1025          in          in
1026              stre arg              stre arg
1027          end          end
1028    
1029          and fctExp arg = let          and fctExp arg = let
1030              val op $ = PU.$ FE              val op $ = PU.$ FE
1031              fun fe (M.VARfct s) = "o" $ entPath s              fun fe (M.VARfct s) = "o" $ [entPath s]
1032                | fe (M.CONSTfct e) = "p" $ fctEntity e                | fe (M.CONSTfct e) = "p" $ [fctEntity e]
1033                | fe (M.LAMBDA { param, body }) =                | fe (M.LAMBDA { param, body }) =
1034                  "q" $ entVar param & strExp body                  "q" $ [entVar param, strExp body]
1035                | fe (M.LAMBDA_TP { param, body, sign }) =                | fe (M.LAMBDA_TP { param, body, sign }) =
1036                  "r" $ entVar param & strExp body & fctSig sign                  "r" $ [entVar param, strExp body, fctSig sign]
1037                | fe (M.LETfct (e, f)) = "s" $ entityDec e & fctExp f                | fe (M.LETfct (e, f)) = "s" $ [entityDec e, fctExp f]
1038          in          in
1039              fe arg              fe arg
1040          end          end
1041    
1042          and entityExp arg = let          and entityExp arg = let
1043              val op $ = PU.$ EE              val op $ = PU.$ EE
1044              fun ee (M.TYCexp t) = "t" $ tycExp t              fun ee (M.TYCexp t) = "t" $ [tycExp t]
1045                | ee (M.STRexp s) = "u" $ strExp s                | ee (M.STRexp s) = "u" $ [strExp s]
1046                | ee (M.FCTexp f) = "v" $ fctExp f                | ee (M.FCTexp f) = "v" $ [fctExp f]
1047                | ee M.ERRORexp = %EE "w"                | ee M.ERRORexp = "w" $ []
1048                | ee M.DUMMYexp = %EE "x"                | ee M.DUMMYexp = "x" $ []
1049          in          in
1050              ee arg              ee arg
1051          end          end
1052    
1053          and entityDec arg = let          and entityDec arg = let
1054              val op $ = PU.$ ED              val op $ = PU.$ ED
1055              fun ed (M.TYCdec (s, x)) = "A" $ entVar s & tycExp x              fun ed (M.TYCdec (s, x)) = "A" $ [entVar s, tycExp x]
1056                | ed (M.STRdec (s, x, n)) = "B" $ entVar s & strExp x & symbol n                | ed (M.STRdec (s, x, n)) = "B" $ [entVar s, strExp x, symbol n]
1057                | ed (M.FCTdec (s, x)) = "C" $ entVar s & fctExp x                | ed (M.FCTdec (s, x)) = "C" $ [entVar s, fctExp x]
1058                | ed (M.SEQdec e) = "D" $ list entityDec e                | ed (M.SEQdec e) = "D" $ [list entityDec e]
1059                | ed (M.LOCALdec (a, b)) = "E" $ entityDec a & entityDec b                | ed (M.LOCALdec (a, b)) = "E" $ [entityDec a, entityDec b]
1060                | ed M.ERRORdec = %ED "F"                | ed M.ERRORdec = "F" $ []
1061                | ed M.EMPTYdec = %ED "G"                | ed M.EMPTYdec = "G" $ []
1062          in          in
1063              ed arg              ed arg
1064          end          end
# Line 1025  Line 1068 
1068                  val id = MI.EENVid s                  val id = MI.EENVid s
1069                  fun mee_raw (s, r) =                  fun mee_raw (s, r) =
1070                      case lookEENV id of                      case lookEENV id of
1071                          SimpleStub => "D" $ modId id                          SimpleStub => "D" $ [modId id]
1072                        | NoStub => "E" $ stamp s & entityEnv r                        | NoStub => "E" $ [stamp s, entityEnv r]
1073                        | PrimStub s => "F" $ string s & modId id                        | PrimStub => "F" $ [modId id]
1074                        | NodeStub (i, s) => "G" $ int i & symbol s & modId id                        | NodeStub (sl, s) =>
1075                            "G" $ [list string sl, symbol s, modId id]
1076              in              in
1077                  share (MIs (id, NONE)) mee_raw (s, r)                  share (MIs (id, NONE)) mee_raw (s, r)
1078              end              end
1079            | entityEnv (M.BINDeenv (d, r)) =            | entityEnv (M.BINDeenv (d, r)) =
1080              PU.$ EEV ("A", list (pair (entVar, entity)) (ED.listItemsi d) &              PU.$ EEV ("A", [list (pair (entVar, entity)) (ED.listItemsi d),
1081                             entityEnv r)                             entityEnv r])
1082            | entityEnv M.NILeenv = %EEV "B"            | entityEnv M.NILeenv = "B" $ []
1083            | entityEnv M.ERReenv = %EEV "C"            | entityEnv M.ERReenv = "C" $ []
1084    
1085          and strEntity { stamp = s, entities, lambdaty = _, rpath } = let          and strEntity { stamp = s, entities, lambdaty = _, rpath } = let
1086              val op $ = PU.$ SEN              val op $ = PU.$ SEN
1087          in          in
1088              "s" $ stamp s & entityEnv entities & ipath rpath              "s" $ [stamp s, entityEnv entities, ipath rpath]
1089          end          end
1090    
1091          and fctEntity fe = let          and fctEntity fe = let
1092              val op $ = PU.$ FEN              val op $ = PU.$ FEN
1093              val { stamp = s, closure, lambdaty = _, tycpath = _, rpath } = fe              val { stamp = s, closure, lambdaty = _, tycpath = _, rpath } = fe
1094          in          in
1095              "f" $ stamp s & fctClosure closure & ipath rpath              "f" $ [stamp s, fctClosure closure, ipath rpath]
1096          end          end
1097    
1098          and tycEntity x = tycon x          and tycEntity x = tycon x
1099    
1100          fun fixity Fixity.NONfix = %FX "N"          fun fixity Fixity.NONfix = "N" $ []
1101            | fixity (Fixity.INfix (i, j)) = PU.$ FX ("I", int i & int j)            | fixity (Fixity.INfix (i, j)) = PU.$ FX ("I", [int i, int j])
1102    
1103          val op $ = PU.$ B          val op $ = PU.$ B
1104          fun binding (B.VALbind x) = "1" $ var x          fun binding (B.VALbind x) = "1" $ [var x]
1105            | binding (B.CONbind x) = "2" $ datacon x            | binding (B.CONbind x) = "2" $ [datacon x]
1106            | binding (B.TYCbind x) = "3" $ tycon x            | binding (B.TYCbind x) = "3" $ [tycon x]
1107            | binding (B.SIGbind x) = "4" $ Signature x            | binding (B.SIGbind x) = "4" $ [Signature x]
1108            | binding (B.STRbind x) = "5" $ Structure x            | binding (B.STRbind x) = "5" $ [Structure x]
1109            | binding (B.FSGbind x) = "6" $ fctSig x            | binding (B.FSGbind x) = "6" $ [fctSig x]
1110            | binding (B.FCTbind x) = "7" $ Functor x            | binding (B.FCTbind x) = "7" $ [Functor x]
1111            | binding (B.FIXbind x) = "8" $ fixity x            | binding (B.FIXbind x) = "8" $ [fixity x]
1112    
1113          fun env e = let          fun env e = let
1114              val syms = ListMergeSort.uniqueSort symCmp (Env.symbols e)              val syms = ListMergeSort.uniqueSort symCmp (Env.symbols e)
# Line 1072  Line 1116 
1116          in          in
1117              list (pair (symbol, binding)) pairs              list (pair (symbol, binding)) pairs
1118          end          end
1119    
1120            fun env'n'ctxt { env = e, ctxt } =
1121                pair (env, list modId) (e, ModuleId.Set.listItems ctxt)
1122      in      in
1123          { pickler = env, exportLvarsGetter = fn () => rev (!lvlist) }          { pickler = env, pickler' = env'n'ctxt,
1124              exportLvarsGetter = fn () => rev (!lvlist) }
1125      end      end
1126    
1127      fun pickleEnv { context, env } = let      fun pickleEnv { context, env } = let
# Line 1089  Line 1137 
1137                    lookTYC = cvt CMStaticEnv.lookTYC,                    lookTYC = cvt CMStaticEnv.lookTYC,
1138                    lookEENV = cvt CMStaticEnv.lookEENV }                    lookEENV = cvt CMStaticEnv.lookEENV }
1139    
1140          val { pickler, exportLvarsGetter } = mkEnvPickler c          val { pickler, exportLvarsGetter, ... } =
1141                mkEnvPickler (c, fn _ => false)
1142          val pickle = Byte.stringToBytes (PU.pickle emptyMap (pickler env))          val pickle = Byte.stringToBytes (PU.pickle emptyMap (pickler env))
1143          val exportLvars = exportLvarsGetter ()          val exportLvars = exportLvarsGetter ()
1144    
# Line 1105  Line 1154 
1154            exportPid = exportPid }            exportPid = exportPid }
1155      end      end
1156    
1157        fun repickleEnvHash { context, env, orig_hash } = let
1158            fun lk i =
1159                if ModuleId.Set.member (context, i) then SimpleStub else NoStub
1160            val c = { lookSTR = lk, lookSIG = lk, lookFCT = lk,
1161                      lookFSIG = lk, lookTYC = lk, lookEENV = lk }
1162            fun isLocalPid p = PersStamps.compare (p, orig_hash) = EQUAL
1163            val { pickler, ... } = mkEnvPickler (c, isLocalPid)
1164            val pickle = Byte.stringToBytes (PU.pickle emptyMap (pickler env))
1165        in
1166            pickle2hash pickle
1167        end
1168    
1169        type env'n'ctxt = { env: StaticEnv.staticEnv, ctxt: ModuleId.Set.set }
1170    
1171      fun envPickler context = let      fun envPickler context = let
1172          val { lookSTR, lookSIG, lookFCT, lookFSIG, lookTYC, lookEENV } =          val { lookSTR, lookSIG, lookFCT, lookFSIG, lookTYC, lookEENV } =
1173              context              context
1174          fun cvt lk i =          fun cvt lk i =
1175              case lk i of              case lk i of
1176                  SOME (PrimKey s) => PrimStub s                  SOME PrimKey => PrimStub
1177                | SOME (NodeKey (i, s)) => NodeStub (i, s)                | SOME (NodeKey (sl, s)) => NodeStub (sl, s)
1178                | NONE => NoStub                | NONE => NoStub
1179          val c = { lookSTR = cvt lookSTR,          val c = { lookSTR = cvt lookSTR,
1180                    lookSIG = cvt lookSIG,                    lookSIG = cvt lookSIG,
# Line 1119  Line 1182 
1182                    lookFSIG = cvt lookFSIG,                    lookFSIG = cvt lookFSIG,
1183                    lookTYC = cvt lookTYC,                    lookTYC = cvt lookTYC,
1184                    lookEENV = cvt lookEENV }                    lookEENV = cvt lookEENV }
1185          val { pickler, ... } = mkEnvPickler c          val { pickler', ... } = mkEnvPickler (c, fn _ => false)
1186      in      in
1187          pickler          pickler'
1188      end      end
1189    
1190      (* the dummy environment pickler *)      (* the dummy environment pickler *)

Legend:
Removed from v.476  
changed lines
  Added in v.569

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