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

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

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