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

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

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