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

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

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