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

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

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