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 587, Thu Mar 30 09:01:52 2000 UTC
# Line 1  Line 1 
1  (*  (*
2   * The revised pickler using the new "generic" pickling facility.   * The revised pickler using the new "generic" pickling facility.
3   *   *
4   * July 1999, Matthias Blume   * March 2000, Matthias Blume
5   *)   *)
6  signature PICKMOD = sig  signature PICKMOD = sig
7    
8      datatype ckey =                     (* context key *)      (* There are three possible reasons to run the pickler.  Each form
9          PrimKey of string       * of context (see datatype context below) corresponds to one of them:
10        | NodeKey of int * Symbol.symbol       *
11         *  1. The initial pickle.  This is done right after a new static
12      type 'a context =       *     environment has been constructed by the elaborator.  The context
13          { lookSTR: ModuleId.modId -> 'a,       *     is used to identify those identifiers (ModuleId.<xxx>Id) that
14            lookSIG: ModuleId.modId -> 'a,       *     correspond to stubs.  Only the domain of the given map is relevant
15            lookFCT: ModuleId.modId -> 'a,       *     here, but since we (usually) need the full map right afterwards
16            lookFSIG: ModuleId.modId -> 'a,       *     for unpickling, there is no gain in using a set.
17            lookTYC: ModuleId.modId -> 'a,       *
18            lookEENV: ModuleId.modId -> 'a }       *  2. Pickling a previously pickled-and-unpickled environment from
19         *     which some parts may have been pruned.  This is used to calculate
20      (* All we really need here is a "bool context", but passing the whole       *     a new hash value that is equal to the hash obtained from an initial
21       * CMStaticEnv.staticEnv is more convenient (and backward-compatible). *)       *     pickle (1.) of the environment if it had been pruned earlier.
22      val pickleEnv :       *     (This is used by the compilation manager's cutoff recompilation
23          { context: CMStaticEnv.staticEnv, env: StaticEnv.staticEnv  }       *     system.  Pickles obtained here are never unpickled.)
24          -> { hash: PersStamps.persstamp,       *     No actual context is necessary because stubification info is
25         *     fully embedded in the environment to be pickled.  However, we
26         *     must provide the original pid obtained from the first pickling
27         *     because occurences of that pid have to be treated the same way
28         *     it was treated in step 1.
29         *
30         *  3. A set of environments that have already gone through an initial
31         *     pickling-and-unpickling is pickled as part of a stable library.
32         *     The context is a sequence of maps together with information of
33         *     how to get hold of the same map later during unpickling.
34         *     (The full context of a stable library is a set of other stable
35         *     libraries, but during unpickling we want to avoid unpickling
36         *     all of these other libraries in full.)  *)
37        datatype context =
38            INITIAL of ModuleId.tmap
39          | REHASH of PersStamps.persstamp
40          | LIBRARY of ((string list * Symbol.symbol) option * ModuleId.tmap) list
41    
42        type map
43        val emptyMap : map
44    
45        val envPickler : (Access.lvar -> unit) ->
46                         context ->
47                         (map, StaticEnv.staticEnv) PickleUtil.pickler
48    
49        val pickleEnv : context ->
50                        StaticEnv.staticEnv ->
51                        { hash: PersStamps.persstamp,
52               pickle: Word8Vector.vector,               pickle: Word8Vector.vector,
53               exportLvars: Access.lvar list,               exportLvars: Access.lvar list,
54               exportPid: PersStamps.persstamp option}               exportPid: PersStamps.persstamp option}
# Line 31  Line 58 
58          -> { hash: PersStamps.persstamp,          -> { hash: PersStamps.persstamp,
59               pickle: Word8Vector.vector }               pickle: Word8Vector.vector }
60    
     (* The following is low-level interface so this pickler can be part  
      * of another, bigger, pickler. *)  
     type map  
     val emptyMap : map  
   
     val envPickler :  
         ckey option context -> (map, StaticEnv.staticEnv) PickleUtil.pickler  
   
61      val symenvPickler : (map, SymbolicEnv.symenv) PickleUtil.pickler      val symenvPickler : (map, SymbolicEnv.symenv) PickleUtil.pickler
62    
63      val pickle2hash: Word8Vector.vector -> PersStamps.persstamp      val pickle2hash: Word8Vector.vector -> PersStamps.persstamp
# Line 50  Line 69 
69  end  end
70    
71  local  local
     (* make those into red-black-maps once rb-maps work correcty. *)  
72      functor MapFn = RedBlackMapFn      functor MapFn = RedBlackMapFn
73      structure IntMap = IntRedBlackMap      structure IntMap = IntRedBlackMap
74  in  in
75    structure PickMod :> PICKMOD = struct    structure PickMod :> PICKMOD = struct
76    
77        datatype context =
78            INITIAL of ModuleId.tmap
79          | REHASH of PersStamps.persstamp
80          | LIBRARY of ((string list * Symbol.symbol) option * ModuleId.tmap) list
81    
82      (* to gather some statistics... *)      (* to gather some statistics... *)
83      val addPickles = Stats.addStat (Stats.makeStat "Pickle Bytes")      val addPickles = Stats.addStat (Stats.makeStat "Pickle Bytes")
84    
# Line 96  Line 119 
119          (struct type ord_key = LK.tyc val compare = LK.tc_cmp end)          (struct type ord_key = LK.tyc val compare = LK.tc_cmp end)
120      structure TKMap = MapFn      structure TKMap = MapFn
121          (struct type ord_key = LK.tkind val compare = LK.tk_cmp end)          (struct type ord_key = LK.tkind val compare = LK.tk_cmp end)
     local  
         structure StampMap = MapFn  
             (struct type ord_key = Stamps.stamp val compare = Stamps.cmp end)  
     in  
122          structure DTMap = StampMap          structure DTMap = StampMap
123          structure MBMap = StampMap          structure MBMap = StampMap
     end  
   
   
     type pid = PS.persstamp  
     type mi = MI.modId * pid option  
   
     fun mi_cmp ((mi, po), (mi', po')) = let  
         fun po_cmp (NONE, NONE) = EQUAL  
           | po_cmp (NONE, SOME _) = LESS  
           | po_cmp (SOME _, NONE) = GREATER  
           | po_cmp (SOME p, SOME p') = PS.compare (p, p')  
     in  
         case MI.cmp (mi, mi') of  
             EQUAL => po_cmp (po, po')  
           | unequal => unequal  
     end  
   
     fun acc_pid (A.LVAR _) = NONE  
       | acc_pid (A.EXTERN p) = SOME p  
       | acc_pid (A.PATH (a, _)) = acc_pid a  
       | acc_pid A.NO_ACCESS = NONE  
   
     structure MIMap = MapFn  
         (struct type ord_key = mi val compare = mi_cmp end)  
124    
125      structure PU = PickleUtil      structure PU = PickleUtil
126      structure PSymPid = PickleSymPid      structure PSymPid = PickleSymPid
# Line 136  Line 131 
131            tk: PU.id TKMap.map,            tk: PU.id TKMap.map,
132            dt: PU.id DTMap.map,            dt: PU.id DTMap.map,
133            mb: PU.id MBMap.map,            mb: PU.id MBMap.map,
134            mi: PU.id MIMap.map }            mi: PU.id MI.umap }
135    
136      val emptyMap = { lt = LTMap.empty, tc = TCMap.empty, tk = TKMap.empty,      val emptyMap = { lt = LTMap.empty, tc = TCMap.empty, tk = TKMap.empty,
137                       dt = DTMap.empty, mb = MBMap.empty, mi = MIMap.empty }                       dt = DTMap.empty, mb = MBMap.empty, mi = MI.emptyUmap }
138    
139      (* type info *)      (* type info *)
140      val (NK, AO, CO, PO, CS, A, CR, LT, TC, TK,      val (NK, AO, CO, PO, CS, A, CR, LT, TC, TK,
# Line 147  Line 142 
142           DTF, TYCON, T, II, VAR, SD, SG, FSG,  SP, EN,           DTF, TYCON, T, II, VAR, SD, SG, FSG,  SP, EN,
143           STR, F, STE, TCE, STRE, FE, EE, ED, EEV, FX,           STR, F, STE, TCE, STRE, FE, EE, ED, EEV, FX,
144           B, DCON, DICT, FPRIM, FUNDEC, TFUNDEC, DATACON, DTMEM, NRD,           B, DCON, DICT, FPRIM, FUNDEC, TFUNDEC, DATACON, DTMEM, NRD,
145           OVERLD, FCTC, SEN, FEN) =           OVERLD, FCTC, SEN, FEN, SPATH, IPATH, STRID, FCTID) =
146          (1, 2, 3, 4, 5, 6, 7, 8, 9, 10,          (1, 2, 3, 4, 5, 6, 7, 8, 9, 10,
147           11, 12, 13, 14, 15, 16, 17, 18, 19, 20,           11, 12, 13, 14, 15, 16, 17, 18, 19, 20,
148           21, 22, 23, 24, 25, 26, 27, 28, 29, 30,           21, 22, 23, 24, 25, 26, 27, 28, 29, 30,
149           31, 32, 33, 34, 35, 36, 37, 38, 39, 40,           31, 32, 33, 34, 35, 36, 37, 38, 39, 40,
150           41, 42, 43, 44, 45, 46, 47, 48, 49,           41, 42, 43, 44, 45, 46, 47, 48, 49,
151           50, 51, 52, 53)           50, 51, 52, 53, 54, 55, 56, 57)
152    
153      (* this is a bit awful...      (* this is a bit awful...
154       * (we really ought to have syntax for "functional update") *)       * (we really ought to have syntax for "functional update") *)
# Line 197  Line 192 
192                               dt = dt,                               dt = dt,
193                               mb = MBMap.insert (mb, x, v),                               mb = MBMap.insert (mb, x, v),
194                               mi = mi } }                               mi = mi } }
195      fun MIs x = { find = fn (m: map, _) => MIMap.find (#mi m, x),      fun TYCs id = { find = fn (m: map, _) => MI.uLookTyc (#mi m, id),
196                    insert = fn ({ lt, tc, tk, dt, mb, mi }, _, v) =>                    insert = fn ({ lt, tc, tk, dt, mb, mi }, _, v) =>
197                             { lt = lt,                             { lt = lt,
198                               tc = tc,                               tc = tc,
199                               tk = tk,                               tk = tk,
200                               dt = dt,                               dt = dt,
201                               mb = mb,                               mb = mb,
202                               mi = MIMap.insert (mi, x, v) } }                                    mi = MI.uInsertTyc (mi, id, v) } }
203        val SIGs = { find = fn (m: map, r) => MI.uLookSig (#mi m, MI.sigId r),
204                     insert = fn ({ lt, tc, tk, dt, mb, mi }, r, v) =>
205                                 { lt = lt,
206                                   tc = tc,
207                                   tk = tk,
208                                   dt = dt,
209                                   mb = mb,
210                                   mi = MI.uInsertSig (mi, MI.sigId r, v) } }
211        fun STRs i = { find = fn (m: map, _) => MI.uLookStr (#mi m, i),
212                       insert = fn ({ lt, tc, tk, dt, mb, mi }, _, v) =>
213                                   { lt = lt,
214                                     tc = tc,
215                                     tk = tk,
216                                     dt = dt,
217                                     mb = mb,
218                                     mi = MI.uInsertStr (mi, i, v) } }
219        fun FCTs i = { find = fn (m: map, _) => MI.uLookFct (#mi m, i),
220                       insert = fn ({ lt, tc, tk, dt, mb, mi }, _, v) =>
221                                   { lt = lt,
222                                     tc = tc,
223                                     tk = tk,
224                                     dt = dt,
225                                     mb = mb,
226                                     mi = MI.uInsertFct (mi, i, v) } }
227        val ENVs = { find = fn (m: map, r) => MI.uLookEnv (#mi m, MI.envId r),
228                     insert = fn ({ lt, tc, tk, dt, mb, mi }, r, v) =>
229                                 { lt = lt,
230                                   tc = tc,
231                                   tk = tk,
232                                   dt = dt,
233                                   mb = mb,
234                                   mi = MI.uInsertEnv (mi, MI.envId r, v) } }
235    
236      infix 3 $      infix 3 $
     infixr 4 &  
     val op & = PU.&  
     val % = PU.%  
237    
238      val int = PU.w_int      val int = PU.w_int
239      val int32 = PU.w_int32      val int32 = PU.w_int32
# Line 243  Line 267 
267    
268      fun numkind arg = let      fun numkind arg = let
269          val op $ = PU.$ NK          val op $ = PU.$ NK
270          fun nk (P.INT i) = "A" $ int i          fun nk (P.INT i) = "A" $ [int i]
271            | nk (P.UINT i) = "B" $ int i            | nk (P.UINT i) = "B" $ [int i]
272            | nk (P.FLOAT i) = "C" $ int i            | nk (P.FLOAT i) = "C" $ [int i]
273      in      in
274          nk arg          nk arg
275      end      end
276    
277      fun arithop oper = let      fun arithop oper = let
278            val op $ = PU.$ AO
279          fun arithopc P.+ = "\000"          fun arithopc P.+ = "\000"
280            | arithopc P.- = "\001"            | arithopc P.- = "\001"
281            | arithopc P.* = "\002"            | arithopc P.* = "\002"
# Line 265  Line 290 
290            | arithopc P.XORB = "\011"            | arithopc P.XORB = "\011"
291            | arithopc P.NOTB = "\012"            | arithopc P.NOTB = "\012"
292      in      in
293          % AO (arithopc oper)          arithopc oper $ []
294      end      end
295    
296      fun cmpop oper = let      fun cmpop oper = let
297            val op $ = PU.$ CO
298          fun cmpopc P.> = "\000"          fun cmpopc P.> = "\000"
299            | cmpopc P.>= = "\001"            | cmpopc P.>= = "\001"
300            | cmpopc P.< = "\002"            | cmpopc P.< = "\002"
# Line 280  Line 306 
306            | cmpopc P.EQL = "\008"            | cmpopc P.EQL = "\008"
307            | cmpopc P.NEQ = "\009"            | cmpopc P.NEQ = "\009"
308      in      in
309          % CO (cmpopc oper)          cmpopc oper $ []
310      end      end
311    
312      fun primop p = let      fun primop p = let
313          val op $ = PU.$ PO          val op $ = PU.$ PO
314          fun ?n = String.str (Char.chr n)          fun ?n = String.str (Char.chr n)
315          fun fromto tag (from, to) = ?tag $ int from & int to          fun fromto tag (from, to) = ?tag $ [int from, int to]
316          fun %?n = % PO (?n)          fun %?n = ?n $ []
317          in          in
318              case p of              case p of
319                  P.ARITH { oper, overflow, kind } =>                  P.ARITH { oper, overflow, kind } =>
320                      ?100 $ arithop oper & bool overflow & numkind kind                      ?100 $ [arithop oper, bool overflow, numkind kind]
321                | P.CMP { oper, kind } => ?101 $ cmpop oper & numkind kind                | P.CMP { oper, kind } => ?101 $ [cmpop oper, numkind kind]
322                | P.TEST x => fromto 102 x                | P.TEST x => fromto 102 x
323                | P.TESTU x => fromto 103 x                | P.TESTU x => fromto 103 x
324                | P.TRUNC x => fromto 104 x                | P.TRUNC x => fromto 104 x
325                | P.EXTEND x => fromto 105 x                | P.EXTEND x => fromto 105 x
326                | P.COPY x => fromto 106 x                | P.COPY x => fromto 106 x
327                | P.INLLSHIFT kind => ?107 $ numkind kind                | P.INLLSHIFT kind => ?107 $ [numkind kind]
328                | P.INLRSHIFT kind => ?108 $ numkind kind                | P.INLRSHIFT kind => ?108 $ [numkind kind]
329                | P.INLRSHIFTL kind => ?109 $ numkind kind                | P.INLRSHIFTL kind => ?109 $ [numkind kind]
330                | P.ROUND { floor, fromkind, tokind } =>                | P.ROUND { floor, fromkind, tokind } =>
331                      ?110 $ bool floor & numkind fromkind & numkind tokind                      ?110 $ [bool floor, numkind fromkind, numkind tokind]
332                | P.REAL { fromkind, tokind } =>                | P.REAL { fromkind, tokind } =>
333                      ?111 $ numkind fromkind & numkind tokind                      ?111 $ [numkind fromkind, numkind tokind]
334                | P.NUMSUBSCRIPT { kind, checked, immutable } =>                | P.NUMSUBSCRIPT { kind, checked, immutable } =>
335                      ?112 $ numkind kind & bool checked & bool immutable                      ?112 $ [numkind kind, bool checked, bool immutable]
336                | P.NUMUPDATE { kind, checked } =>                | P.NUMUPDATE { kind, checked } =>
337                      ?113 $ numkind kind & bool checked                      ?113 $ [numkind kind, bool checked]
338                | P.INL_MONOARRAY kind => ?114 $ numkind kind                | P.INL_MONOARRAY kind => ?114 $ [numkind kind]
339                | P.INL_MONOVECTOR kind => ?115 $ numkind kind                | P.INL_MONOVECTOR kind => ?115 $ [numkind kind]
340    
341                | P.MKETAG => %?0                | P.MKETAG => %?0
342                | P.WRAP => %?1                | P.WRAP => %?1
# Line 380  Line 406 
406    
407      fun consig arg = let      fun consig arg = let
408          val op $ = PU.$ CS          val op $ = PU.$ CS
409          fun cs (A.CSIG (i, j)) = "S" $ int i & int j          fun cs (A.CSIG (i, j)) = "S" $ [int i, int j]
410            | cs A.CNIL = % CS "N"            | cs A.CNIL = "N" $ []
411      in      in
412          cs arg          cs arg
413      end      end
414    
415      fun mkAccess lvar = let      fun mkAccess { lvar, isLocalPid } = let
416          val op $ = PU.$ A          val op $ = PU.$ A
417          fun access (A.LVAR i) = "A" $ lvar i          fun access (A.LVAR i) = "A" $ [lvar i]
418            | access (A.EXTERN p) = "B" $ pid p            | access (A.EXTERN p) = "B" $ [pid p]
419            | access (A.PATH (a, i)) = "C" $ access a & int i            | access (A.PATH (a as A.EXTERN p, i)) =
420            | access A.NO_ACCESS = % A "D"              (* isLocalPid always returns false for in the "normal pickler"
421                 * case.  It returns true in the "repickle" case for the
422                 * pid that was the hash of the original whole pickle.
423                 * Since alpha-conversion has already taken place if we find
424                 * an EXTERN pid, we don't call "lvar" but "int". *)
425                if isLocalPid p then "A" $ [int i]
426                else "C" $ [access a, int i]
427              | access (A.PATH (a, i)) = "C" $ [access a, int i]
428              | access A.NO_ACCESS = "D" $ []
429    
430          val op $ = PU.$ CR          val op $ = PU.$ CR
431          fun conrep A.UNTAGGED = % CR "A"          fun conrep A.UNTAGGED = "A" $ []
432            | conrep (A.TAGGED i) = "B" $ int i            | conrep (A.TAGGED i) = "B" $ [int i]
433            | conrep A.TRANSPARENT = %CR "C"            | conrep A.TRANSPARENT = "C" $ []
434            | conrep (A.CONSTANT i) = "D" $ int i            | conrep (A.CONSTANT i) = "D" $ [int i]
435            | conrep A.REF = %CR "E"            | conrep A.REF = "E" $ []
436            | conrep (A.EXN a) = "F" $ access a            | conrep (A.EXN a) = "F" $ [access a]
437            | conrep A.LISTCONS = %CR "G"            | conrep A.LISTCONS = "G" $ []
438            | conrep A.LISTNIL = %CR "H"            | conrep A.LISTNIL = "H" $ []
439            | conrep (A.SUSP NONE) = %CR "I"            | conrep (A.SUSP NONE) = "I" $ []
440            | conrep (A.SUSP (SOME (a, b))) = "J" $ access a & access b            | conrep (A.SUSP (SOME (a, b))) = "J" $ [access a, access b]
441      in      in
442          { access = access, conrep = conrep }          { access = access, conrep = conrep }
443      end      end
444    
445      (* lambda-type stuff; this is used in both picklers *)      (* lambda-type stuff; some of it is used in both picklers *)
446      fun ltyI x = let      fun tkind x = let
447          val op $ = PU.$ LT          val op $ = PU.$ TK
448            fun tk x =
449                case LK.tk_out x of
450                LK.TK_MONO => "A" $ []
451              | LK.TK_BOX => "B" $ []
452              | LK.TK_SEQ ks => "C" $ [list tkind ks]
453              | LK.TK_FUN (ks, kr) => "D" $ [list tkind ks, tkind kr]
454      in      in
455            share TKs tk x
456        end
457    
458        fun mkLty lvar = let
459            fun lty x = let
460                val op $ = PU.$ LT
461                fun ltyI x =
462          case LK.lt_out x of          case LK.lt_out x of
463              LK.LT_TYC tc => "A" $ tyc tc                      LK.LT_TYC tc => "A" $ [tyc tc]
464            | LK.LT_STR l => "B" $ list lty l                    | LK.LT_STR l => "B" $ [list lty l]
465            | LK.LT_FCT (ts1, ts2) => "C" $ list lty ts1 & list lty ts2                    | LK.LT_FCT (ts1, ts2) => "C" $ [list lty ts1, list lty ts2]
466            | LK.LT_POLY (ks, ts) => "D" $ list tkind ks & list lty ts                    | LK.LT_POLY (ks, ts) => "D" $ [list tkind ks, list lty ts]
467            | LK.LT_IND _ => bug "unexpected LT_IND in mkPickleLty"            | LK.LT_IND _ => bug "unexpected LT_IND in mkPickleLty"
468            | LK.LT_ENV _ => bug "unexpected LT_ENV in mkPickleLty"            | LK.LT_ENV _ => bug "unexpected LT_ENV in mkPickleLty"
469            | LK.LT_CONT _ => bug "unexpected LT_CONT in mkPickleLty"            | LK.LT_CONT _ => bug "unexpected LT_CONT in mkPickleLty"
470            in
471                share LTs ltyI x
472      end      end
473    
474      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  
475          val op $ = PU.$ TC          val op $ = PU.$ TC
476      in              fun tycI x =
477          case LK.tc_out x of          case LK.tc_out x of
478              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]
479            | LK.TC_NVAR (n, dp, i) =>                    | LK.TC_NVAR n => "B" $ [lvar n]
480                  "B" $ int n & int (DI.dp_toint dp) & int i                    | LK.TC_PRIM t => "C" $ [int (PT.pt_toint t)]
481            | LK.TC_PRIM t => "C" $ int (PT.pt_toint t)                    | LK.TC_FN (ks, tc) => "D" $ [list tkind ks, tyc tc]
482            | LK.TC_FN (ks, tc) => "D" $ list tkind ks & tyc tc                    | LK.TC_APP (tc, l) => "E" $ [tyc tc, list tyc l]
483            | LK.TC_APP (tc, l) => "E" $ tyc tc & list tyc l                    | LK.TC_SEQ l => "F" $ [list tyc l]
484            | LK.TC_SEQ l => "F" $ list tyc l                    | LK.TC_PROJ (tc, i) => "G" $ [tyc tc, int i]
485            | 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  
486            | LK.TC_FIX ((n, tc, ts), i) =>            | LK.TC_FIX ((n, tc, ts), i) =>
487                  "I" $ int n & tyc tc & list tyc ts & int i                          "I" $ [int n, tyc tc, list tyc ts, int i]
488            | LK.TC_ABS tc => "J" $ tyc tc                    | LK.TC_ABS tc => "J" $ [tyc tc]
489            | LK.TC_BOX tc => "K" $ tyc tc                    | LK.TC_BOX tc => "K" $ [tyc tc]
490            | LK.TC_TUPLE (_, l) => "L" $ list tyc l                    | LK.TC_TUPLE (_, l) => "L" $ [list tyc l]
491            | LK.TC_ARROW (LK.FF_VAR (b1, b2), ts1, ts2) =>            | LK.TC_ARROW (LK.FF_VAR (b1, b2), ts1, ts2) =>
492                  "M" $ bool b1 & bool b2 & list tyc ts1 & list tyc ts2                          "M" $ [bool b1, bool b2, list tyc ts1, list tyc ts2]
493            | LK.TC_ARROW (LK.FF_FIXED, ts1, ts2) =>            | LK.TC_ARROW (LK.FF_FIXED, ts1, ts2) =>
494                  "N" $ list tyc ts1 & list tyc ts2                          "N" $ [list tyc ts1, list tyc ts2]
495            | LK.TC_PARROW _ => bug "unexpected TC_PARREW in mkPickleLty"            | LK.TC_PARROW _ => bug "unexpected TC_PARREW in mkPickleLty"
496            | 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]
497            | LK.TC_IND _ => bug "unexpected TC_IND in mkPickleLty"            | LK.TC_IND _ => bug "unexpected TC_IND in mkPickleLty"
498            | LK.TC_ENV _ => bug "unexpected TC_ENV in mkPickleLty"            | LK.TC_ENV _ => bug "unexpected TC_ENV in mkPickleLty"
499            | LK.TC_CONT _ => bug "unexpected TC_CONT in mkPickleLty"            | LK.TC_CONT _ => bug "unexpected TC_CONT in mkPickleLty"
500            in
501                share TCs tycI x
502      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  
503      in      in
504          share TKs tk x          { tyc = tyc, lty = lty }
505      end      end
506    
507      (* the FLINT pickler *)      (* the FLINT pickler *)
508      fun flint flint_exp = let      fun flint flint_exp = let
509          val alphaConvert = mkAlphaConvert ()          val alphaConvert = mkAlphaConvert ()
510          val lvar = int o alphaConvert          val lvar = int o alphaConvert
511          val { access, conrep } = mkAccess lvar          val { access, conrep } = mkAccess { lvar = lvar,
512                                                isLocalPid = fn _ => false }
513            val { lty, tyc } = mkLty lvar
514    
515          val op $ = PU.$ V          val op $ = PU.$ V
516          fun value (F.VAR v) = "a" $ lvar v          fun value (F.VAR v) = "a" $ [lvar v]
517            | value (F.INT i) = "b" $ int i            | value (F.INT i) = "b" $ [int i]
518            | value (F.INT32 i32) = "c" $ int32 i32            | value (F.INT32 i32) = "c" $ [int32 i32]
519            | value (F.WORD w) = "d" $ word w            | value (F.WORD w) = "d" $ [word w]
520            | value (F.WORD32 w32) = "e" $ word32 w32            | value (F.WORD32 w32) = "e" $ [word32 w32]
521            | value (F.REAL s) = "f" $ string s            | value (F.REAL s) = "f" $ [string s]
522            | value (F.STRING s) = "g" $ string s            | value (F.STRING s) = "g" $ [string s]
523    
524          fun con arg = let          fun con arg = let
525              val op $ = PU.$ C              val op $ = PU.$ C
526              fun c (F.DATAcon (dc, ts, v), e) =              fun c (F.DATAcon (dc, ts, v), e) =
527                  "1" $ dcon (dc, ts) & lvar v & lexp e                  "1" $ [dcon (dc, ts), lvar v, lexp e]
528                | c (F.INTcon i, e) = "2" $ int i & lexp e                | c (F.INTcon i, e) = "2" $ [int i, lexp e]
529                | c (F.INT32con i32, e) = "3" $ int32 i32 & lexp e                | c (F.INT32con i32, e) = "3" $ [int32 i32, lexp e]
530                | c (F.WORDcon w, e) = "4" $ word w & lexp e                | c (F.WORDcon w, e) = "4" $ [word w, lexp e]
531                | c (F.WORD32con w32, e) = "5" $ word32 w32 & lexp e                | c (F.WORD32con w32, e) = "5" $ [word32 w32, lexp e]
532                | c (F.REALcon s, e) = "6" $ string s & lexp e                | c (F.REALcon s, e) = "6" $ [string s, lexp e]
533                | c (F.STRINGcon s, e) = "7" $ string s & lexp e                | c (F.STRINGcon s, e) = "7" $ [string s, lexp e]
534                | c (F.VLENcon i, e) = "8" $ int i & lexp e                | c (F.VLENcon i, e) = "8" $ [int i, lexp e]
535          in          in
536              c arg              c arg
537          end          end
# Line 504  Line 539 
539          and dcon ((s, cr, t), ts) = let          and dcon ((s, cr, t), ts) = let
540              val op $ = PU.$ DCON              val op $ = PU.$ DCON
541          in          in
542              "x" $ symbol s & conrep cr & lty t & list tyc ts              "x" $ [symbol s, conrep cr, lty t, list tyc ts]
543          end          end
544    
545          and dict { default = v, table = tbls } = let          and dict { default = v, table = tbls } = let
546              val op $ = PU.$ DICT              val op $ = PU.$ DICT
547          in          in
548              "y" $ lvar v & list (pair (list tyc, lvar)) tbls              "y" $ [lvar v, list (pair (list tyc, lvar)) tbls]
549          end          end
550    
551          and fprim (dtopt, p, t, ts) = let          and fprim (dtopt, p, t, ts) = let
552              val op $ = PU.$ FPRIM              val op $ = PU.$ FPRIM
553          in          in
554              "z" $ option dict dtopt & primop p & lty t & list tyc ts              "z" $ [option dict dtopt, primop p, lty t, list tyc ts]
555          end          end
556    
557          and lexp arg = let          and lexp arg = let
558              val op $ = PU.$ E              val op $ = PU.$ E
559              fun l (F.RET vs) = "j" $ list value vs              fun l (F.RET vs) = "j" $ [list value vs]
560                | l (F.LET (vs, e1, e2)) =                | l (F.LET (vs, e1, e2)) =
561                  "k" $ list lvar vs & lexp e1 & lexp e2                  "k" $ [list lvar vs, lexp e1, lexp e2]
562                | l (F.FIX (fdecs, e)) = "l" $ list fundec fdecs & lexp e                | l (F.FIX (fdecs, e)) = "l" $ [list fundec fdecs, lexp e]
563                | l (F.APP (v, vs)) = "m" $ value v & list value vs                | l (F.APP (v, vs)) = "m" $ [value v, list value vs]
564                | l (F.TFN (tfdec, e)) = "n" $ tfundec tfdec & lexp e                | l (F.TFN (tfdec, e)) = "n" $ [tfundec tfdec, lexp e]
565                | l (F.TAPP (v, ts)) = "o" $ value v & list tyc ts                | l (F.TAPP (v, ts)) = "o" $ [value v, list tyc ts]
566                | l (F.SWITCH (v, crl, cel, eo)) =                | l (F.SWITCH (v, crl, cel, eo)) =
567                  "p" $ value v & consig crl & list con cel & option lexp eo                  "p" $ [value v, consig crl, list con cel, option lexp eo]
568                | l (F.CON (dc, ts, u, v, e)) =                | l (F.CON (dc, ts, u, v, e)) =
569                  "q" $ dcon (dc, ts) & value u & lvar v & lexp e                  "q" $ [dcon (dc, ts), value u, lvar v, lexp e]
570                | l (F.RECORD (rk, vl, v, e)) =                | l (F.RECORD (rk, vl, v, e)) =
571                  "r" $ rkind rk & list value vl & lvar v & lexp e                  "r" $ [rkind rk, list value vl, lvar v, lexp e]
572                | l (F.SELECT (u, i, v, e)) =                | l (F.SELECT (u, i, v, e)) =
573                  "s" $ value u & int i & lvar v & lexp e                  "s" $ [value u, int i, lvar v, lexp e]
574                | l (F.RAISE (u, ts)) = "t" $ value u & list lty ts                | l (F.RAISE (u, ts)) = "t" $ [value u, list lty ts]
575                | l (F.HANDLE (e, u)) = "u" $ lexp e & value u                | l (F.HANDLE (e, u)) = "u" $ [lexp e, value u]
576                | l (F.BRANCH (p, vs, e1, e2)) =                | l (F.BRANCH (p, vs, e1, e2)) =
577                  "v" $ fprim p & list value vs & lexp e1 & lexp e2                  "v" $ [fprim p, list value vs, lexp e1, lexp e2]
578                | l (F.PRIMOP (p, vs, v, e)) =                | l (F.PRIMOP (p, vs, v, e)) =
579                  "w" $ fprim p & list value vs & lvar v & lexp e                  "w" $ [fprim p, list value vs, lvar v, lexp e]
580          in          in
581              l arg              l arg
582          end          end
# Line 549  Line 584 
584          and fundec (fk, v, vts, e) = let          and fundec (fk, v, vts, e) = let
585              val op $ = PU.$ FUNDEC              val op $ = PU.$ FUNDEC
586          in          in
587              "a" $ fkind fk & lvar v & list (pair (lvar, lty)) vts & lexp e              "a" $ [fkind fk, lvar v, list (pair (lvar, lty)) vts, lexp e]
588          end          end
589    
590          and tfundec (v, tvks, e) = let          and tfundec (_, v, tvks, e) = let
591              val op $ = PU.$ TFUNDEC              val op $ = PU.$ TFUNDEC
592          in          in
593              "b" $ lvar v & list (pair (lvar, tkind)) tvks & lexp e              "b" $ [lvar v, list (pair (lvar, tkind)) tvks, lexp e]
594          end          end
595    
596          and fkind arg = let          and fkind arg = let
597              val op $ = PU.$ FK              val op $ = PU.$ FK
598              fun fk F.FK_FCT = %FK "2"              fun isAlways F.IH_ALWAYS = true
599                | fk (F.FK_FUN { isrec, fixed, known, inline }) =                | isAlways _ = false
600                fun strip (x, y) = x
601                fun fk { cconv = F.CC_FCT, ... } = "2" $ []
602                  | fk { isrec, cconv = F.CC_FUN fixed, known, inline } =
603                  case fixed of                  case fixed of
604                      LK.FF_VAR (b1, b2) =>                      LK.FF_VAR (b1, b2) =>
605                          "3" $ option (list lty) isrec &                          "3" $ [option (list lty) (Option.map strip isrec),
606                          bool b1 & bool b2 & bool known & bool inline                                 bool b1, bool b2, bool known,
607                                   bool (isAlways inline)]
608                    | LK.FF_FIXED =>                    | LK.FF_FIXED =>
609                          "4" $ option (list lty) isrec &                          "4" $ [option (list lty) (Option.map strip isrec),
610                          bool known & bool inline                                 bool known, bool (isAlways inline)]
611          in          in
612              fk arg              fk arg
613          end          end
614    
615          and rkind arg = let          and rkind arg = let
616              val op $ = PU.$ RK              val op $ = PU.$ RK
617              fun rk (F.RK_VECTOR tc) = "5" $ tyc tc              fun rk (F.RK_VECTOR tc) = "5" $ [tyc tc]
618                | rk F.RK_STRUCT = %RK "6"                | rk F.RK_STRUCT = "6" $ []
619                | rk (F.RK_TUPLE _) = %RK "7"                | rk (F.RK_TUPLE _) = "7" $ []
620          in          in
621              rk arg              rk arg
622          end          end
# Line 596  Line 635 
635      fun symenvPickler sye =      fun symenvPickler sye =
636          list (pair (pid, flint)) (SymbolicEnv.listItemsi sye)          list (pair (pid, flint)) (SymbolicEnv.listItemsi sye)
637    
     datatype ckey =                     (* context key *)  
         PrimKey of string  
       | NodeKey of int * Symbol.symbol  
   
     type 'a context =  
         { lookSTR: ModuleId.modId -> 'a,  
           lookSIG: ModuleId.modId -> 'a,  
           lookFCT: ModuleId.modId -> 'a,  
           lookFSIG: ModuleId.modId -> 'a,  
           lookTYC: ModuleId.modId -> 'a,  
           lookEENV: ModuleId.modId -> 'a }  
   
     datatype stubinfo =  
         NoStub  
       | SimpleStub  
       | PrimStub of string  
       | NodeStub of int * Symbol.symbol  
   
638      (* the environment pickler *)      (* the environment pickler *)
639      fun mkEnvPickler (context0: stubinfo context) = let      fun envPickler registerLvar context = let
640            val { tycStub, sigStub, strStub, fctStub, envStub,
641                  isLocalPid, isLib } =
642                case context of
643                    INITIAL tmap => let
644                        fun stub (xId, freshX, lookX) r = let
645                            val id = xId r
646                        in
647                            if freshX id then NONE
648                            else if isSome (lookX (tmap, id)) then SOME (NONE, id)
649                            else NONE
650                        end
651                    in
652                        { tycStub = stub (MI.tycId, MI.freshTyc, MI.lookTyc),
653                          sigStub = stub (MI.sigId, MI.freshSig, MI.lookSig),
654                          strStub = stub (MI.strId, MI.freshStr, MI.lookStr),
655                          fctStub = stub (MI.fctId, MI.freshFct, MI.lookFct),
656                          envStub = stub (MI.envId, MI.freshEnv, MI.lookEnv),
657                          isLocalPid = fn _ => false,
658                          isLib = false }
659                    end
660                  | REHASH myPid => let
661                        fun isLocalPid p = PersStamps.compare (p, myPid) = EQUAL
662                        fun stub (idX, stubX, owner) r =
663                            case stubX r of
664                                NONE => bug "REHASH:no stubinfo"
665                              | SOME stb =>
666                                if isLocalPid (owner stb) then SOME (NONE, idX r)
667                                else NONE
668                    in
669                        { tycStub = stub (MI.tycId, #stub, #owner),
670                          sigStub = stub (MI.sigId, #stub, #owner),
671                          strStub = stub (MI.strId, #stub o #rlzn, #owner),
672                          fctStub = stub (MI.fctId, #stub o #rlzn, #owner),
673                          envStub = stub (MI.envId, #stub, #owner),
674                          isLocalPid = isLocalPid,
675                          isLib = false }
676                    end
677                  | LIBRARY l => let
678                        fun stub (idX, stubX, lookX, lib) r = let
679                            fun get id = let
680                                fun loop [] =
681                                    bug "LIBRARY:import info missing"
682                                  | loop ((lms, m) :: t) =
683                                    if isSome (lookX (m, id)) then lms else loop t
684                            in
685                                loop l
686                            end
687                        in
688                            case stubX r of
689                                NONE => bug "LIBRARY:no stubinfo"
690                              | SOME stb => let
691                                    val id = idX r
692                                in
693                                    if lib stb then SOME (get id, id) else NONE
694                                end
695                        end
696                    in
697                        { tycStub = stub (MI.tycId, #stub, MI.lookTyc, #lib),
698                          sigStub = stub (MI.sigId, #stub, MI.lookSig, #lib),
699                          strStub = stub (MI.strId, #stub o #rlzn,
700                                          MI.lookStr, #lib),
701                          fctStub = stub (MI.fctId, #stub o #rlzn,
702                                          MI.lookFct, #lib),
703                          envStub = stub (MI.envId, #stub, MI.lookEnv, #lib),
704                          isLocalPid = fn _ => false,
705                          isLib = true }
706                    end
707    
708            (* Owner pids of stubs are pickled only in the case of libraries,
709             * otherwise they are ignored completely. *)
710            fun libPid x =
711                if isLib then
712                    case x of
713                        (NONE, _) => []
714                      | (SOME stb, ownerOf) => [pid (ownerOf stb)]
715                else []
716    
717          val { lookTYC, lookSIG, lookFSIG, lookSTR, lookFCT, lookEENV } =          fun libModSpec lms = option (pair (list string, symbol)) lms
             context0  
718    
719          val alphaConvert = mkAlphaConvert ()          val stampConverter = Stamps.newConverter ()
720    
721          fun stamp (Stamps.STAMP { scope, count }) = let          fun stamp s = let
722              val op $ = PU.$ ST              val op $ = PU.$ ST
723          in          in
724              case scope of              Stamps.Case stampConverter s
725                  Stamps.LOCAL => "A" $ int (alphaConvert count)                  { fresh = fn i => "A" $ [int i],
726                | Stamps.GLOBAL p => "B" $ pid p & int count                    global = fn { pid = p, cnt } =>"B" $ [pid p, int cnt],
727                | Stamps.SPECIAL s => "C" $ string s & int count                    special = fn s => "C" $ [string s] }
728            end
729    
730            val tycId = stamp
731            val sigId = stamp
732            fun strId { sign, rlzn } = let
733                val op $ = PU.$ STRID
734            in
735                "D" $ [stamp sign, stamp rlzn]
736          end          end
737            fun fctId { paramsig, bodysig, rlzn } = let
738                val op $ = PU.$ FCTID
739            in
740                "E" $ [stamp paramsig, stamp bodysig, stamp rlzn]
741            end
742            val envId = stamp
743    
744          val entVar = stamp          val entVar = stamp
745          val entPath = list entVar          val entPath = list entVar
746    
747          val op $ = PU.$ MI          val anotherLvar =
748          fun modId (MI.STRid { rlzn, sign }) = "1" $ stamp rlzn & stamp sign              let val lvcount = ref 0
749            | modId (MI.SIGid s) = "2" $ stamp s              in (fn v => let val j = !lvcount
750            | modId (MI.FCTid { rlzn, sign }) = "3" $ stamp rlzn & modId sign                          in registerLvar v; lvcount := j + 1; j end)
           | modId (MI.FSIGid { paramsig, bodysig }) =  
             "4" $ stamp paramsig & stamp bodysig  
           | modId (MI.TYCid a) = "5" $ stamp a  
           | modId (MI.EENVid s) = "6" $ stamp s  
   
         val lvcount = ref 0  
         val lvlist = ref []  
   
         fun anotherLvar v = let  
             val j = !lvcount  
         in  
             lvlist := v :: !lvlist;  
             lvcount := j + 1;  
             j  
751          end          end
752    
753          val { access, conrep } = mkAccess (int o anotherLvar)          val { access, conrep } = mkAccess { lvar = int o anotherLvar,
754                                                isLocalPid = isLocalPid }
755          fun spath (SP.SPATH p) = list symbol p  
756          fun ipath (IP.IPATH p) = list symbol p          val op $ = PU.$ SPATH
757            fun spath (SP.SPATH p) = "s" $ [list symbol p]
758            val op $ = PU.$ IPATH
759            fun ipath (IP.IPATH p) = "i" $ [list symbol p]
760    
761          val label = symbol          val label = symbol
762    
763          fun eqprop eqp = let          fun eqprop eqp = let
764                val op $ = PU.$ EQP
765              fun eqc T.YES = "\000"              fun eqc T.YES = "\000"
766                | eqc T.NO = "\001"                | eqc T.NO = "\001"
767                | eqc T.IND = "\002"                | eqc T.IND = "\002"
# Line 670  Line 770 
770                | eqc T.ABS = "\005"                | eqc T.ABS = "\005"
771                | eqc T.UNDEF = "\006"                | eqc T.UNDEF = "\006"
772          in          in
773              %EQP (eqc eqp)              eqc eqp $ []
774          end          end
775    
776          fun datacon (T.DATACON { name, const, typ, rep, sign, lazyp }) = let          fun datacon (T.DATACON { name, const, typ, rep, sign, lazyp }) = let
777              val op $ = PU.$ DATACON              val op $ = PU.$ DATACON
778          in          in
779              "c" $ symbol name & bool const & ty typ & conrep rep &              "c" $ [symbol name, bool const, ty typ, conrep rep,
780                    consig sign & bool lazyp                     consig sign, bool lazyp]
781          end          end
782    
783          and tyckind arg = let          and tyckind arg = let
784              val op $ = PU.$ TYCKIND              val op $ = PU.$ TYCKIND
785              fun tk (T.PRIMITIVE pt) = "a" $ int (PT.pt_toint pt)              fun tk (T.PRIMITIVE pt) = "a" $ [int (PT.pt_toint pt)]
786                | tk (T.DATATYPE { index, family, stamps, root,freetycs }) =                | tk (T.DATATYPE { index, family, stamps, root,freetycs }) =
787                  "b" $ int index & option entVar root &                  "b" $ [int index, option entVar root,
788                        dtypeInfo (stamps, family, freetycs)                         dtypeInfo (stamps, family, freetycs)]
789                | tk (T.ABSTRACT tyc) = "c" $ tycon tyc                | tk (T.ABSTRACT tyc) = "c" $ [tycon tyc]
790                | tk (T.FLEXTYC tps) = %TYCKIND "d" (* "f" $ tycpath tps *)                | tk (T.FLEXTYC tps) = "d" $ [] (* "f" $ tycpath tps *)
791                (*** I (Matthias) carried through this message from Zhong:                (*** I (Matthias) carried through this message from Zhong:
792                 tycpath should never be pickled; the only way it can be                 tycpath should never be pickled; the only way it can be
793                 pickled is when pickling the domains of a mutually                 pickled is when pickling the domains of a mutually
# Line 695  Line 795 
795                 datatypes are not assigned accurate domains ... (ZHONG)                 datatypes are not assigned accurate domains ... (ZHONG)
796                 the preceding code is just a temporary gross hack.                 the preceding code is just a temporary gross hack.
797                 ***)                 ***)
798                | tk T.FORMAL = %TYCKIND "d"                | tk T.FORMAL = "d" $ []
799                | tk T.TEMP = %TYCKIND "e"                | tk T.TEMP = "e" $ []
800          in          in
801              tk arg              tk arg
802          end          end
# Line 704  Line 804 
804          and dtypeInfo x = let          and dtypeInfo x = let
805              val op $ = PU.$ DTI              val op $ = PU.$ DTI
806              fun dti_raw (ss, family, freetycs) =              fun dti_raw (ss, family, freetycs) =
807                  "a" $ list stamp (Vector.foldr (op ::) [] ss) &                  "a" $ [list stamp (Vector.foldr (op ::) [] ss),
808                        dtFamily family & list tycon freetycs                         dtFamily family, list tycon freetycs]
809          in          in
810              share (DTs (Vector.sub (#1 x, 0))) dti_raw x              share (DTs (Vector.sub (#1 x, 0))) dti_raw x
811          end          end
# Line 713  Line 813 
813          and dtFamily x = let          and dtFamily x = let
814              val op $ = PU.$ DTF              val op $ = PU.$ DTF
815              fun dtf_raw { mkey, members, lambdatyc } =              fun dtf_raw { mkey, members, lambdatyc } =
816                  "b" $ stamp mkey &                  "b" $ [stamp mkey,
817                        list dtmember (Vector.foldr (op ::) [] members)                         list dtmember (Vector.foldr (op ::) [] members)]
818          in          in
819              share (MBs (#mkey x)) dtf_raw x              share (MBs (#mkey x)) dtf_raw x
820          end          end
# Line 722  Line 822 
822          and dtmember { tycname, dcons, arity, eq = ref e, lazyp, sign } = let          and dtmember { tycname, dcons, arity, eq = ref e, lazyp, sign } = let
823              val op $ = PU.$ DTMEM              val op $ = PU.$ DTMEM
824          in          in
825              "c" $ symbol tycname & list nameRepDomain dcons & int arity &              "c" $ [symbol tycname, list nameRepDomain dcons, int arity,
826                    eqprop e & bool lazyp & consig sign                     eqprop e, bool lazyp, consig sign]
827          end          end
828    
829          and nameRepDomain { name, rep, domain } = let          and nameRepDomain { name, rep, domain } = let
830              val op $ = PU.$ NRD              val op $ = PU.$ NRD
831          in          in
832              "d" $ symbol name & conrep rep & option ty domain              "d" $ [symbol name, conrep rep, option ty domain]
833          end          end
834    
835          and tycon arg = let          and tycon arg = let
836              val op $ = PU.$ TYCON              val op $ = PU.$ TYCON
837              fun tc (T.GENtyc x) =              fun tc (tyc as T.GENtyc g) =
838                  let val id = MI.TYCid (#stamp x)                  let fun gt_raw (g as { stamp = s, arity, eq = ref eq, kind,
839                      fun gt_raw { stamp = s, arity, eq = ref eq, kind, path } =                                         path, stub }) =
840                          case lookTYC id of                          case tycStub g of
841                              SimpleStub => "A" $ modId id                              SOME (l, i) => "A" $ [libModSpec l, tycId i]
842                            | NoStub => "B" $ stamp s & int arity & eqprop eq &                            | NONE => "B" $ ([stamp s, int arity, eqprop eq,
843                                              tyckind kind & ipath path                                              tyckind kind, ipath path]
844                            | PrimStub s => "I" $ string s & modId id                                             @ libPid (stub, #owner))
845                            | NodeStub (i, s) =>                  in
846                                              "J" $ int i & symbol s & modId id                      share (TYCs (MI.tycId g)) gt_raw g
847                  in                  end
848                      share (MIs (id, NONE)) gt_raw x                | tc (tyc as T.DEFtyc dt) = let
849                  end                      fun dt_raw { stamp = s, tyfun, strict, path } = let
               | tc (T.DEFtyc x) = let  
                     fun dt_raw x = let  
                         val { stamp = s, tyfun, strict, path } = x  
850                          val T.TYFUN { arity, body } = tyfun                          val T.TYFUN { arity, body } = tyfun
851                      in                      in
852                          "C" $ stamp s & int arity & ty body &                          "C" $ [stamp s, int arity, ty body,
853                                list bool strict & ipath path                                 list bool strict, ipath path]
854                      end                      end
855                  in                  in
856                      share (MIs (MI.TYCid (#stamp x), NONE)) dt_raw x                      share (TYCs (MI.tycId' tyc)) dt_raw dt
857                  end                  end
858                | tc (T.PATHtyc { arity, entPath = ep, path }) =                | tc (T.PATHtyc { arity, entPath = ep, path }) =
859                  "D" $ int arity & entPath ep & ipath path                  "D" $ [int arity, entPath ep, ipath path]
860                | tc (T.RECORDtyc l) = "E" $ list label l                | tc (T.RECORDtyc l) = "E" $ [list label l]
861                | tc (T.RECtyc i) = "F" $ int i                | tc (T.RECtyc i) = "F" $ [int i]
862                | tc (T.FREEtyc i) = "G" $ int i                | tc (T.FREEtyc i) = "G" $ [int i]
863                | tc T.ERRORtyc = %TC "H"                | tc T.ERRORtyc = "H" $ []
864          in          in
865              tc arg              tc arg
866          end          end
# Line 773  Line 870 
870              fun ty (T.VARty (ref (T.INSTANTIATED t))) = ty t              fun ty (T.VARty (ref (T.INSTANTIATED t))) = ty t
871                | ty (T.VARty (ref (T.OPEN _))) =                | ty (T.VARty (ref (T.OPEN _))) =
872                  bug "uninstantiated VARty in pickmod"                  bug "uninstantiated VARty in pickmod"
873                | ty (T.CONty (c, l)) = "a" $ tycon c & list ty l                | ty (T.CONty (c, l)) = "a" $ [tycon c, list ty l]
874                | ty (T.IBOUND i) = "b" $ int i                | ty (T.IBOUND i) = "b" $ [int i]
875                | ty T.WILDCARDty = %T "c"                | ty T.WILDCARDty = "c" $ []
876                | ty (T.POLYty { sign, tyfun = T.TYFUN { arity, body } }) =                | ty (T.POLYty { sign, tyfun = T.TYFUN { arity, body } }) =
877                  "d" $ list bool sign & int arity & ty body                  "d" $ [list bool sign, int arity, ty body]
878                | ty T.UNDEFty = %T "e"                | ty T.UNDEFty = "e" $ []
879                | ty _ = bug "unexpected type in pickmod-ty"                | ty _ = bug "unexpected type in pickmod-ty"
880          in          in
881              ty arg              ty arg
882          end          end
883    
884          val op $ = PU.$ II          val op $ = PU.$ II
885          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]
886            | inl_info (II.INL_STR sl) = "B" $ list inl_info sl            | inl_info (II.INL_STR sl) = "B" $ [list inl_info sl]
887            | inl_info II.INL_NO = %II "C"            | inl_info II.INL_NO = "C" $ []
888            | inl_info _ = bug "unexpected inl_info in pickmod"            | inl_info _ = bug "unexpected inl_info in pickmod"
889    
890          val op $ = PU.$ VAR          val op $ = PU.$ VAR
891          fun var (V.VALvar { access = a, info, path, typ = ref t }) =          fun var (V.VALvar { access = a, info, path, typ = ref t }) =
892              "1" $ access a & inl_info info & spath path & ty t              "1" $ [access a, inl_info info, spath path, ty t]
893            | var (V.OVLDvar { name, options = ref p,            | var (V.OVLDvar { name, options = ref p,
894                               scheme = T.TYFUN { arity, body } }) =                               scheme = T.TYFUN { arity, body } }) =
895              "2" $ symbol name & list overld p & int arity & ty body              "2" $ [symbol name, list overld p, int arity, ty body]
896            | var V.ERRORvar = %VAR "3"            | var V.ERRORvar = "3" $ []
897    
898          and overld { indicator, variant } = let          and overld { indicator, variant } = let
899              val op $ = PU.$ OVERLD              val op $ = PU.$ OVERLD
900          in          in
901              "o" $ ty indicator & var variant              "o" $ [ty indicator, var variant]
902          end          end
903    
         fun fsigId (M.FSIG { paramsig = M.SIG { stamp = ps, ... },  
                              bodysig = M.SIG { stamp = bs, ... },  
                              ... }) =  
             MI.FSIGid { paramsig = ps, bodysig = bs }  
           | fsigId _ = bug "unexpected functor signature in fsigId"  
   
904          fun strDef arg = let          fun strDef arg = let
905              val op $ = PU.$ SD              val op $ = PU.$ SD
906              fun sd (M.CONSTstrDef s) = "C" $ Structure s              fun sd (M.CONSTstrDef s) = "C" $ [Structure s]
907                | sd (M.VARstrDef (s, p)) = "V" $ Signature s & entPath p                | sd (M.VARstrDef (s, p)) = "V" $ [Signature s, entPath p]
908          in          in
909              sd arg              sd arg
910          end          end
# Line 824  Line 915 
915           *)           *)
916          and Signature arg = let          and Signature arg = let
917              val op $ = PU.$ SG              val op $ = PU.$ SG
918              fun sg  M.ERRORsig = %SG "A"              fun sg  M.ERRORsig = "A" $ []
919                | sg (M.SIG x) = let                | sg (M.SIG s) =
920                      val id = MI.SIGid (#stamp x)                  (case sigStub s of
921                      fun sig_raw x = let                       SOME (l, i) => "B" $ [libModSpec l, sigId i]
922                          val { name, closed, fctflag, stamp = sta, symbols,                     | NONE => let
923                                elements, boundeps = ref b, lambdaty = _,                           fun sig_raw (s: M.sigrec) = let
924                                typsharing, strsharing } = x                               val { stamp = sta, name, closed,
925                                       fctflag, symbols, elements,
926                                       boundeps = ref b,
927                                       lambdaty = _, stub,
928                                       typsharing, strsharing } = s
929                          val b = NONE            (* currently turned off *)                          val b = NONE            (* currently turned off *)
930                      in                      in
931                          case lookSIG id of                               "C" $ ([stamp sta,
932                              SimpleStub => "B" $ modId id                                       option symbol name, bool closed,
933                            | NoStub =>                                       bool fctflag,
934                                  "C" $ option symbol name & bool closed &                                       list symbol symbols,
935                                        bool fctflag & stamp sta &                                       list (pair (symbol, spec)) elements,
936                                        list symbol symbols &                                       option (list (pair (entPath, tkind))) b,
937                                        list (pair (symbol, spec)) elements &                                       list (list spath) typsharing,
938                                        option (list (pair (entPath, tkind))) b &                                       list (list spath) strsharing]
939                                        list (list spath) typsharing &                                      @ libPid (stub, #owner))
                                       list (list spath) strsharing  
                           | PrimStub s => "D" $ string s & modId id  
                           | NodeStub (i, s) =>  
                                       "E" $ int i & symbol s & modId id  
940                      end                      end
941                  in                  in
942                      share (MIs (id, NONE)) sig_raw x                           share SIGs sig_raw s
943                  end                       end)
944          in          in
945              sg arg              sg arg
946          end          end
947    
948          and fctSig arg = let          and fctSig arg = let
949              val op $ = PU.$ FSG              val op $ = PU.$ FSG
950              fun fsg M.ERRORfsig = %FSG "a"              fun fsg M.ERRORfsig = "a" $ []
951                | fsg (fs as M.FSIG x) = let                | fsg (M.FSIG { kind, paramsig, paramvar, paramsym, bodysig }) =
952                      val id = fsigId fs                  "c" $ [option symbol kind, Signature paramsig,
953                      fun fsig_raw x = let                         entVar paramvar,
954                          val { kind, paramsig, paramvar, paramsym, bodysig } = x                         option symbol paramsym,
955                      in                         Signature bodysig]
                         case lookFSIG id of  
                             SimpleStub => "b" $ modId id  
                           | NoStub =>  
                                 "c" $ option symbol kind & Signature paramsig &  
                                       entVar paramvar &  
                                       option symbol paramsym &  
                                       Signature bodysig  
                           | PrimStub s => "d" $ string s & modId id  
                           | NodeStub (i, s) =>  
                                       "e" $ int i & symbol s & modId id  
                     end  
                 in  
                     share (MIs (id, NONE)) fsig_raw x  
                 end  
956          in          in
957              fsg arg              fsg arg
958          end          end
# Line 883  Line 960 
960          and spec arg = let          and spec arg = let
961              val op $ = PU.$ SP              val op $ = PU.$ SP
962              fun sp (M.TYCspec { spec = t, entVar = v, repl, scope }) =              fun sp (M.TYCspec { spec = t, entVar = v, repl, scope }) =
963                  "1" $ tycon t & entVar v & bool repl & int scope                  "1" $ [tycon t, entVar v, bool repl, int scope]
964                | sp (M.STRspec { sign, slot, def, entVar = v }) =                | sp (M.STRspec { sign, slot, def, entVar = v }) =
965                  "2" $ Signature sign & int slot &                  "2" $ [Signature sign, int slot,
966                        option (pair (strDef, int)) def & entVar v                         option (pair (strDef, int)) def, entVar v]
967                | sp (M.FCTspec { sign, slot, entVar = v }) =                | sp (M.FCTspec { sign, slot, entVar = v }) =
968                  "3" $ fctSig sign & int slot & entVar v                  "3" $ [fctSig sign, int slot, entVar v]
969                | sp (M.VALspec { spec = t, slot }) = "4" $ ty t & int slot                | sp (M.VALspec { spec = t, slot }) = "4" $ [ty t, int slot]
970                | sp (M.CONspec { spec = c, slot }) =                | sp (M.CONspec { spec = c, slot }) =
971                  "5" $ datacon c & option int slot                  "5" $ [datacon c, option int slot]
972          in          in
973              sp arg              sp arg
974          end          end
975    
976          and entity arg = let          and entity arg = let
977              val op $ = PU.$ EN              val op $ = PU.$ EN
978              fun en (M.TYCent t) = "A" $ tycEntity t              fun en (M.TYCent t) = "A" $ [tycEntity t]
979                | en (M.STRent t) = "B" $ strEntity t                | en (M.STRent t) = "B" $ [strEntity t]
980                | en (M.FCTent t) = "C" $ fctEntity t                | en (M.FCTent t) = "C" $ [fctEntity t]
981                | en M.ERRORent = %EN "D"                | en M.ERRORent = "D" $ []
982          in          in
983              en arg              en arg
984          end          end
# Line 909  Line 986 
986          and fctClosure (M.CLOSURE { param, body, env }) = let          and fctClosure (M.CLOSURE { param, body, env }) = let
987              val op $ = PU.$ FCTC              val op $ = PU.$ FCTC
988          in          in
989              "f" $ entVar param & strExp body & entityEnv env              "f" $ [entVar param, strExp body, entityEnv env]
990          end          end
991    
992          and Structure arg = let          and Structure arg = let
993              val op $ = PU.$ STR              val op $ = PU.$ STR
994              fun str (M.STRSIG { sign, entPath = p }) =              fun str (M.STRSIG { sign, entPath = p }) =
995                  "A" $ Signature sign & entPath p                  "A" $ [Signature sign, entPath p]
996                | str M.ERRORstr = %STR "B"                | str M.ERRORstr = "B" $ []
997                | str (M.STR (x as { sign = M.SIG sign, ... })) = let                | str (M.STR (s as { sign, rlzn, access = a, info })) =
998                      val id = MI.STRid { rlzn = #stamp (#rlzn x),                  (case strStub s of
999                                          sign = #stamp sign }                       (* stub represents just the strerec suspension! *)
1000                      fun s_raw { sign, rlzn, access = a, info } =                       SOME (l, i) => "C" $ [Signature sign,
1001                          case lookSTR id of                                             libModSpec l,
1002                              SimpleStub => "C" $ modId id & access a                                             strId i,
1003                            | NoStub =>                                             access a,
1004                                  "D" $ Signature sign & strEntity rlzn &                                             inl_info info]
1005                                        access a & inl_info info                     | NONE => "D" $ [Signature sign,
1006                            | PrimStub s => "I" $ string s & modId id                                      shStrEntity (MI.strId s) rlzn,
1007                            | NodeStub (i, s) =>                                      access a, inl_info info])
                                  "J" $ int i & symbol s & modId id & access a  
                 in  
                     share (MIs (id, acc_pid (#access x))) s_raw x  
                 end  
               | str _ = bug "unexpected structure in pickmod"  
1008          in          in
1009              str arg              str arg
1010          end          end
1011    
1012          and Functor arg = let          and Functor arg = let
1013              val op $ = PU.$ F              val op $ = PU.$ F
1014              fun fct M.ERRORfct = %F "E"              fun fct M.ERRORfct = "E" $ []
1015                | fct (M.FCT x) = let                | fct (M.FCT (f as { sign, rlzn, access = a, info })) =
1016                      val id = MI.FCTid { rlzn = #stamp (#rlzn x),                  (case fctStub f of
1017                                          sign = fsigId (#sign x) }                       SOME (l, i) => "F" $ [fctSig sign,
1018                      fun f_raw { sign, rlzn, access = a, info } =                                             libModSpec l,
1019                          case lookFCT id of                                             fctId i,
1020                              SimpleStub => "F" $ modId id & access a                                             access a,
1021                            | NoStub =>                                             inl_info info]
1022                                  "G" $ fctSig sign & fctEntity rlzn &                     | NONE => "G" $ [fctSig sign,
1023                                        access a & inl_info info                                      shFctEntity (MI.fctId f) rlzn,
1024                            | PrimStub s => "H" $ string s & modId id                                      access a, inl_info info])
                           | NodeStub (i, s) =>  
                                 "I" $ int i & symbol s & modId id & access a  
                 in  
                     share (MIs (id, acc_pid (#access x))) f_raw x  
                 end  
1025          in          in
1026              fct arg              fct arg
1027          end          end
1028    
1029          and stampExp (M.CONST s) = PU.$ STE ("a", stamp s)          and (* stampExp (M.CONST s) = PU.$ STE ("a", [stamp s])
1030            | stampExp (M.GETSTAMP s) = PU.$ STE ("b", strExp s)            | *) stampExp (M.GETSTAMP s) = PU.$ STE ("b", [strExp s])
1031            | stampExp M.NEW = %STE "c"            | stampExp M.NEW = "c" $ []
1032    
1033          and tycExp (M.CONSTtyc t) = PU.$ TCE ("d", tycon t)          and tycExp (M.CONSTtyc t) = PU.$ TCE ("d", [tycon t])
1034            | tycExp (M.FORMtyc t) = PU.$ TCE ("e", tycon t)            | tycExp (M.FORMtyc t) = PU.$ TCE ("e", [tycon t])
1035            | tycExp (M.VARtyc s) = PU.$ TCE ("f", entPath s)            | tycExp (M.VARtyc s) = PU.$ TCE ("f", [entPath s])
1036    
1037          and strExp arg = let          and strExp arg = let
1038              val op $ = PU.$ STRE              val op $ = PU.$ STRE
1039              fun stre (M.VARstr s) = "g" $ entPath s              fun stre (M.VARstr s) = "g" $ [entPath s]
1040                | stre (M.CONSTstr s) = "h" $ strEntity s                | stre (M.CONSTstr s) = "h" $ [strEntity s]
1041                | stre (M.STRUCTURE { stamp = s, entDec }) =                | stre (M.STRUCTURE { stamp = s, entDec }) =
1042                  "i" $ stampExp s & entityDec entDec                  "i" $ [stampExp s, entityDec entDec]
1043                | stre (M.APPLY (f, s)) = "j" $ fctExp f & strExp s                | stre (M.APPLY (f, s)) = "j" $ [fctExp f, strExp s]
1044                | stre (M.LETstr (e, s)) = "k" $ entityDec e & strExp s                | stre (M.LETstr (e, s)) = "k" $ [entityDec e, strExp s]
1045                | stre (M.ABSstr (s, e)) = "l" $ Signature s & strExp e                | stre (M.ABSstr (s, e)) = "l" $ [Signature s, strExp e]
1046                | stre (M.CONSTRAINstr { boundvar, raw, coercion }) =                | stre (M.CONSTRAINstr { boundvar, raw, coercion }) =
1047                  "m" $ entVar boundvar & strExp raw & strExp coercion                  "m" $ [entVar boundvar, strExp raw, strExp coercion]
1048                | stre (M.FORMstr fs) = "n" $ fctSig fs                | stre (M.FORMstr fs) = "n" $ [fctSig fs]
1049          in          in
1050              stre arg              stre arg
1051          end          end
1052    
1053          and fctExp arg = let          and fctExp arg = let
1054              val op $ = PU.$ FE              val op $ = PU.$ FE
1055              fun fe (M.VARfct s) = "o" $ entPath s              fun fe (M.VARfct s) = "o" $ [entPath s]
1056                | fe (M.CONSTfct e) = "p" $ fctEntity e                | fe (M.CONSTfct e) = "p" $ [fctEntity e]
1057                | fe (M.LAMBDA { param, body }) =                | fe (M.LAMBDA { param, body }) =
1058                  "q" $ entVar param & strExp body                  "q" $ [entVar param, strExp body]
1059                | fe (M.LAMBDA_TP { param, body, sign }) =                | fe (M.LAMBDA_TP { param, body, sign }) =
1060                  "r" $ entVar param & strExp body & fctSig sign                  "r" $ [entVar param, strExp body, fctSig sign]
1061                | fe (M.LETfct (e, f)) = "s" $ entityDec e & fctExp f                | fe (M.LETfct (e, f)) = "s" $ [entityDec e, fctExp f]
1062          in          in
1063              fe arg              fe arg
1064          end          end
1065    
1066          and entityExp arg = let          and entityExp arg = let
1067              val op $ = PU.$ EE              val op $ = PU.$ EE
1068              fun ee (M.TYCexp t) = "t" $ tycExp t              fun ee (M.TYCexp t) = "t" $ [tycExp t]
1069                | ee (M.STRexp s) = "u" $ strExp s                | ee (M.STRexp s) = "u" $ [strExp s]
1070                | ee (M.FCTexp f) = "v" $ fctExp f                | ee (M.FCTexp f) = "v" $ [fctExp f]
1071                | ee M.ERRORexp = %EE "w"                | ee M.ERRORexp = "w" $ []
1072                | ee M.DUMMYexp = %EE "x"                | ee M.DUMMYexp = "x" $ []
1073          in          in
1074              ee arg              ee arg
1075          end          end
1076    
1077          and entityDec arg = let          and entityDec arg = let
1078              val op $ = PU.$ ED              val op $ = PU.$ ED
1079              fun ed (M.TYCdec (s, x)) = "A" $ entVar s & tycExp x              fun ed (M.TYCdec (s, x)) = "A" $ [entVar s, tycExp x]
1080                | 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]
1081                | ed (M.FCTdec (s, x)) = "C" $ entVar s & fctExp x                | ed (M.FCTdec (s, x)) = "C" $ [entVar s, fctExp x]
1082                | ed (M.SEQdec e) = "D" $ list entityDec e                | ed (M.SEQdec e) = "D" $ [list entityDec e]
1083                | ed (M.LOCALdec (a, b)) = "E" $ entityDec a & entityDec b                | ed (M.LOCALdec (a, b)) = "E" $ [entityDec a, entityDec b]
1084                | ed M.ERRORdec = %ED "F"                | ed M.ERRORdec = "F" $ []
1085                | ed M.EMPTYdec = %ED "G"                | ed M.EMPTYdec = "G" $ []
1086          in          in
1087              ed arg              ed arg
1088          end          end
1089    
1090          and entityEnv (M.MARKeenv (s, r)) =          and entityEnv (M.MARKeenv m) =
1091              let val op $ = PU.$ EEV              (case envStub m of
1092                  val id = MI.EENVid s                   SOME (l, i) => "D" $ [libModSpec l, envId i]
1093                  fun mee_raw (s, r) =                 | NONE => let
1094                      case lookEENV id of                       fun mee_raw { stamp = s, env, stub } =
1095                          SimpleStub => "D" $ modId id                           "E" $ ([stamp s, entityEnv env]
1096                        | NoStub => "E" $ stamp s & entityEnv r                                  @ libPid (stub: M.stubinfo option, #owner))
                       | PrimStub s => "F" $ string s & modId id  
                       | NodeStub (i, s) => "G" $ int i & symbol s & modId id  
1097              in              in
1098                  share (MIs (id, NONE)) mee_raw (s, r)                       share ENVs mee_raw m
1099              end                   end)
1100            | entityEnv (M.BINDeenv (d, r)) =            | entityEnv (M.BINDeenv (d, r)) =
1101              PU.$ EEV ("A", list (pair (entVar, entity)) (ED.listItemsi d) &              PU.$ EEV ("A", [list (pair (entVar, entity)) (ED.listItemsi d),
1102                             entityEnv r)                             entityEnv r])
1103            | entityEnv M.NILeenv = %EEV "B"            | entityEnv M.NILeenv = "B" $ []
1104            | entityEnv M.ERReenv = %EEV "C"            | entityEnv M.ERReenv = "C" $ []
1105    
1106          and strEntity { stamp = s, entities, lambdaty = _, rpath } = let          and strEntity { stamp = s, entities, lambdaty = _, rpath, stub } =
1107              val op $ = PU.$ SEN              let val op $ = PU.$ SEN
1108          in          in
1109              "s" $ stamp s & entityEnv entities & ipath rpath                  "s" $ ([stamp s, entityEnv entities, ipath rpath]
1110                           @ libPid (stub: M.stubinfo option, #owner))
1111          end          end
1112    
1113          and fctEntity fe = let          and shStrEntity id = share (STRs id) strEntity
1114              val op $ = PU.$ FEN  
1115              val { stamp = s, closure, lambdaty = _, tycpath = _, rpath } = fe          and fctEntity { stamp = s, closure, lambdaty, tycpath, rpath, stub } =
1116                let val op $ = PU.$ FEN
1117          in          in
1118              "f" $ stamp s & fctClosure closure & ipath rpath                  "f" $ ([stamp s, fctClosure closure, ipath rpath]
1119                           @ libPid (stub: M.stubinfo option, #owner))
1120          end          end
1121    
1122            and shFctEntity id = share (FCTs id) fctEntity
1123    
1124          and tycEntity x = tycon x          and tycEntity x = tycon x
1125    
1126          fun fixity Fixity.NONfix = %FX "N"          fun fixity Fixity.NONfix = "N" $ []
1127            | fixity (Fixity.INfix (i, j)) = PU.$ FX ("I", int i & int j)            | fixity (Fixity.INfix (i, j)) = PU.$ FX ("I", [int i, int j])
1128    
1129          val op $ = PU.$ B          val op $ = PU.$ B
1130          fun binding (B.VALbind x) = "1" $ var x          fun binding (B.VALbind x) = "1" $ [var x]
1131            | binding (B.CONbind x) = "2" $ datacon x            | binding (B.CONbind x) = "2" $ [datacon x]
1132            | binding (B.TYCbind x) = "3" $ tycon x            | binding (B.TYCbind x) = "3" $ [tycon x]
1133            | binding (B.SIGbind x) = "4" $ Signature x            | binding (B.SIGbind x) = "4" $ [Signature x]
1134            | binding (B.STRbind x) = "5" $ Structure x            | binding (B.STRbind x) = "5" $ [Structure x]
1135            | binding (B.FSGbind x) = "6" $ fctSig x            | binding (B.FSGbind x) = "6" $ [fctSig x]
1136            | binding (B.FCTbind x) = "7" $ Functor x            | binding (B.FCTbind x) = "7" $ [Functor x]
1137            | binding (B.FIXbind x) = "8" $ fixity x            | binding (B.FIXbind x) = "8" $ [fixity x]
1138    
1139          fun env e = let          fun env e = let
1140              val syms = ListMergeSort.uniqueSort symCmp (Env.symbols e)              val syms = ListMergeSort.uniqueSort symCmp (Env.symbols e)
1141              val pairs = map (fn s => (s, Env.look (e, s))) syms              val pairs = map (fn s => (s, StaticEnv.look (e, s))) syms
1142          in          in
1143              list (pair (symbol, binding)) pairs              list (pair (symbol, binding)) pairs
1144          end          end
1145      in      in
1146          { pickler = env, exportLvarsGetter = fn () => rev (!lvlist) }          env
1147      end      end
1148    
1149      fun pickleEnv { context, env } = let      fun pickleEnv context e = let
1150          fun cvt lk i =          val lvlist = ref []
1151              case lk context i of          fun registerLvar v = lvlist := v :: !lvlist
1152                  SOME _ => SimpleStub          val pickler = envPickler registerLvar context
1153                | NONE => NoStub          val pickle = Byte.stringToBytes (PU.pickle emptyMap (pickler e))
1154            val exportLvars = rev (!lvlist)
         val c = { lookSTR = cvt CMStaticEnv.lookSTR,  
                   lookSIG = cvt CMStaticEnv.lookSIG,  
                   lookFCT = cvt CMStaticEnv.lookFCT,  
                   lookFSIG = cvt CMStaticEnv.lookFSIG,  
                   lookTYC = cvt CMStaticEnv.lookTYC,  
                   lookEENV = cvt CMStaticEnv.lookEENV }  
   
         val { pickler, exportLvarsGetter } = mkEnvPickler c  
         val pickle = Byte.stringToBytes (PU.pickle emptyMap (pickler env))  
         val exportLvars = exportLvarsGetter ()  
   
1155          val hash = pickle2hash pickle          val hash = pickle2hash pickle
   
1156          val exportPid =          val exportPid =
1157              case exportLvars of              case exportLvars of
1158                  [] => NONE                  [] => NONE
# Line 1105  Line 1163 
1163            exportPid = exportPid }            exportPid = exportPid }
1164      end      end
1165    
     fun envPickler context = let  
         val { lookSTR, lookSIG, lookFCT, lookFSIG, lookTYC, lookEENV } =  
             context  
         fun cvt lk i =  
             case lk i of  
                 SOME (PrimKey s) => PrimStub s  
               | SOME (NodeKey (i, s)) => NodeStub (i, s)  
               | NONE => NoStub  
         val c = { lookSTR = cvt lookSTR,  
                   lookSIG = cvt lookSIG,  
                   lookFCT = cvt lookFCT,  
                   lookFSIG = cvt lookFSIG,  
                   lookTYC = cvt lookTYC,  
                   lookEENV = cvt lookEENV }  
         val { pickler, ... } = mkEnvPickler c  
     in  
         pickler  
     end  
   
1166      (* the dummy environment pickler *)      (* the dummy environment pickler *)
1167      fun dontPickle (senv : StaticEnv.staticEnv, count) = let      fun dontPickle (senv : StaticEnv.staticEnv, count) = let
1168          val hash = let          val hash = let
# Line 1141  Line 1180 
1180          val syms = ListMergeSort.uniqueSort symCmp (Env.symbols senv)          val syms = ListMergeSort.uniqueSort symCmp (Env.symbols senv)
1181          fun newAccess i = A.PATH (A.EXTERN hash, i)          fun newAccess i = A.PATH (A.EXTERN hash, i)
1182          fun mapbinding (sym, (i, env, lvars)) =          fun mapbinding (sym, (i, env, lvars)) =
1183              case Env.look (senv, sym) of              case StaticEnv.look (senv, sym) of
1184                  B.VALbind (V.VALvar {access=a, info=z, path=p, typ= ref t }) =>                  B.VALbind (V.VALvar {access=a, info=z, path=p, typ= ref t }) =>
1185                      (case a of                      (case a of
1186                           A.LVAR k =>                           A.LVAR k =>
1187                               (i+1,                               (i+1,
1188                                Env.bind (sym,                        StaticEnv.bind (sym,
1189                                          B.VALbind (V.VALvar                                          B.VALbind (V.VALvar
1190                                                     { access = newAccess i,                                                     { access = newAccess i,
1191                                                       info = z, path = p,                                                       info = z, path = p,
# Line 1158  Line 1197 
1197                       (case a of                       (case a of
1198                            A.LVAR k =>                            A.LVAR k =>
1199                                (i+1,                                (i+1,
1200                                 Env.bind (sym,                        StaticEnv.bind (sym,
1201                                           B.STRbind (M.STR                                           B.STRbind (M.STR
1202                                                      { access = newAccess i,                                                      { access = newAccess i,
1203                                                        sign = s, rlzn = r,                                                        sign = s, rlzn = r,
# Line 1170  Line 1209 
1209                        (case a of                        (case a of
1210                             A.LVAR k =>                             A.LVAR k =>
1211                                 (i+1,                                 (i+1,
1212                                  Env.bind (sym,                        StaticEnv.bind (sym,
1213                                            B.FCTbind (M.FCT                                            B.FCTbind (M.FCT
1214                                                       { access = newAccess i,                                                       { access = newAccess i,
1215                                                         sign = s, rlzn = r,                                                         sign = s, rlzn = r,
# Line 1185  Line 1224 
1224                      case a of                      case a of
1225                          A.LVAR k =>                          A.LVAR k =>
1226                              (i+1,                              (i+1,
1227                               Env.bind (sym,                           StaticEnv.bind (sym,
1228                                         B.CONbind (T.DATACON                                         B.CONbind (T.DATACON
1229                                                    { rep = newrep, name = n,                                                          { rep = newrep,
1230                                                              name = n,
1231                                                      lazyp = false,                                                      lazyp = false,
1232                                                      const = c, typ = t,                                                      const = c, typ = t,
1233                                                      sign = s }),                                                      sign = s }),
# Line 1195  Line 1235 
1235                               k :: lvars)                               k :: lvars)
1236                        | _ => bug ("dontPickle 4" ^ A.prAcc a)                        | _ => bug ("dontPickle 4" ^ A.prAcc a)
1237                  end                  end
1238                | binding =>  (i, Env.bind (sym, binding, env), lvars)                | binding => (i, StaticEnv.bind (sym, binding, env), lvars)
1239          val (_,newenv,lvars) = foldl mapbinding (0, StaticEnv.empty, nil) syms          val (_,newenv,lvars) = foldl mapbinding (0, StaticEnv.empty, nil) syms
1240          val exportPid =          val exportPid =
1241              case lvars of              case lvars of

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

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