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 569, Tue Mar 7 04:01:07 2000 UTC revision 587, Thu Mar 30 09:01:52 2000 UTC
# Line 1  Line 1 
1  (*  (*
2   * The revised pickler using the new "generic" pickling facility.   * The revised pickler using the new "generic" pickling facility.
3   *   *
4   * July 1999, Matthias Blume   * March 2000, Matthias Blume
5   *)   *)
6  signature PICKMOD = sig  signature PICKMOD = sig
7    
8      (* "context keys": PrimKey indicates some kind of "primitive" context      (* There are three possible reasons to run the pickler.  Each form
9       * (e.g., the primitive environment), and NodeKey specifies a module       * of context (see datatype context below) corresponds to one of them:
10       * of a library.  The library is given by the string list (CM's "pickle"       *
11       * representation of the abstract path) and the module is given by       *  1. The initial pickle.  This is done right after a new static
12       * a representative export symbol.       *     environment has been constructed by the elaborator.  The context
13       * But these are details that we don't concern us here.  We just have       *     is used to identify those identifiers (ModuleId.<xxx>Id) that
14       * to write this info to a pickle. *)       *     correspond to stubs.  Only the domain of the given map is relevant
15      datatype ckey =       *     here, but since we (usually) need the full map right afterwards
16          PrimKey       *     for unpickling, there is no gain in using a set.
17        | NodeKey of string list * Symbol.symbol       *
18         *  2. Pickling a previously pickled-and-unpickled environment from
19      type 'a context =       *     which some parts may have been pruned.  This is used to calculate
20          { lookSTR: ModuleId.modId -> 'a,       *     a new hash value that is equal to the hash obtained from an initial
21            lookSIG: ModuleId.modId -> 'a,       *     pickle (1.) of the environment if it had been pruned earlier.
22            lookFCT: ModuleId.modId -> 'a,       *     (This is used by the compilation manager's cutoff recompilation
23            lookFSIG: ModuleId.modId -> 'a,       *     system.  Pickles obtained here are never unpickled.)
24            lookTYC: ModuleId.modId -> 'a,       *     No actual context is necessary because stubification info is
25            lookEENV: ModuleId.modId -> 'a }       *     fully embedded in the environment to be pickled.  However, we
26         *     must provide the original pid obtained from the first pickling
27      (* All we really need here is a "bool context", but passing the whole       *     because occurences of that pid have to be treated the same way
28       * CMStaticEnv.staticEnv is more convenient (and backward-compatible). *)       *     it was treated in step 1.
29      val pickleEnv :       *
30          { context: CMStaticEnv.staticEnv, env: StaticEnv.staticEnv  }       *  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         *     The context is a sequence of maps together with information of
33         *     how to get hold of the same map later during unpickling.
34         *     (The full context of a stable library is a set of other stable
35         *     libraries, but during unpickling we want to avoid unpickling
36         *     all of these other libraries in full.)  *)
37        datatype context =
38            INITIAL of ModuleId.tmap
39          | REHASH of PersStamps.persstamp
40          | LIBRARY of ((string list * Symbol.symbol) option * ModuleId.tmap) list
41    
42        type map
43        val emptyMap : map
44    
45        val envPickler : (Access.lvar -> unit) ->
46                         context ->
47                         (map, StaticEnv.staticEnv) PickleUtil.pickler
48    
49        val pickleEnv : context ->
50                        StaticEnv.staticEnv ->
51                        { hash: PersStamps.persstamp,
52               pickle: Word8Vector.vector,               pickle: Word8Vector.vector,
53               exportLvars: Access.lvar list,               exportLvars: Access.lvar list,
54               exportPid: PersStamps.persstamp option }               exportPid: PersStamps.persstamp option }
55    
     (* Re-pickling is done for the purpose of getting the hash value  
      * of a "reduced" (filtered) version of another environment that  
      * has been pickled before.  During re-pickling, the LOCAL->GLOBAL  
      * translation for stamps and the LVAR->EXTERN translation for  
      * accesses is undone so that the resulting hash value is the  
      * same that one would have gotten if the current environment  
      * was pickled using "pickleEnv". The context for repickling is  
      * specified using a set of module IDs instead of an entire  
      * context environment.  The set will have to be obtained from the  
      * unpickling process of the original pickle. *)  
     val repickleEnvHash :  
         { context: ModuleId.Set.set,  
           env: StaticEnv.staticEnv,  
           orig_hash: PersStamps.persstamp } -> PersStamps.persstamp  
   
56      val pickleFLINT:      val pickleFLINT:
57          CompBasic.flint option          CompBasic.flint option
58          -> { hash: PersStamps.persstamp,          -> { hash: PersStamps.persstamp,
59               pickle: Word8Vector.vector }               pickle: Word8Vector.vector }
60    
     (* The following is low-level interface so this pickler can be part  
      * of another, bigger, pickler. *)  
     type map  
     val emptyMap : map  
   
     type env'n'ctxt = { env: StaticEnv.staticEnv, ctxt: ModuleId.Set.set }  
   
     val envPickler :  
         ckey option context -> (map, env'n'ctxt) PickleUtil.pickler  
   
61      val symenvPickler : (map, SymbolicEnv.symenv) PickleUtil.pickler      val symenvPickler : (map, SymbolicEnv.symenv) PickleUtil.pickler
62    
63      val pickle2hash: Word8Vector.vector -> PersStamps.persstamp      val pickle2hash: Word8Vector.vector -> PersStamps.persstamp
# Line 79  Line 74 
74  in  in
75    structure PickMod :> PICKMOD = struct    structure PickMod :> PICKMOD = struct
76    
77        datatype context =
78            INITIAL of ModuleId.tmap
79          | REHASH of PersStamps.persstamp
80          | LIBRARY of ((string list * Symbol.symbol) option * ModuleId.tmap) list
81    
82      (* to gather some statistics... *)      (* to gather some statistics... *)
83      val addPickles = Stats.addStat (Stats.makeStat "Pickle Bytes")      val addPickles = Stats.addStat (Stats.makeStat "Pickle Bytes")
84    
# Line 119  Line 119 
119          (struct type ord_key = LK.tyc val compare = LK.tc_cmp end)          (struct type ord_key = LK.tyc val compare = LK.tc_cmp end)
120      structure TKMap = MapFn      structure TKMap = MapFn
121          (struct type ord_key = LK.tkind val compare = LK.tk_cmp end)          (struct type ord_key = LK.tkind val compare = LK.tk_cmp end)
     local  
         structure StampMap = MapFn  
             (struct type ord_key = Stamps.stamp val compare = Stamps.cmp end)  
     in  
122          structure DTMap = StampMap          structure DTMap = StampMap
123          structure MBMap = StampMap          structure MBMap = StampMap
     end  
   
   
     type pid = PS.persstamp  
     type mi = MI.modId * pid option  
   
     fun mi_cmp ((mi, po), (mi', po')) = let  
         fun po_cmp (NONE, NONE) = EQUAL  
           | po_cmp (NONE, SOME _) = LESS  
           | po_cmp (SOME _, NONE) = GREATER  
           | po_cmp (SOME p, SOME p') = PS.compare (p, p')  
     in  
         case MI.cmp (mi, mi') of  
             EQUAL => po_cmp (po, po')  
           | unequal => unequal  
     end  
   
     fun acc_pid (A.LVAR _) = NONE  
       | acc_pid (A.EXTERN p) = SOME p  
       | acc_pid (A.PATH (a, _)) = acc_pid a  
       | acc_pid A.NO_ACCESS = NONE  
   
     structure MIMap = MapFn  
         (struct type ord_key = mi val compare = mi_cmp end)  
124    
125      structure PU = PickleUtil      structure PU = PickleUtil
126      structure PSymPid = PickleSymPid      structure PSymPid = PickleSymPid
# Line 159  Line 131 
131            tk: PU.id TKMap.map,            tk: PU.id TKMap.map,
132            dt: PU.id DTMap.map,            dt: PU.id DTMap.map,
133            mb: PU.id MBMap.map,            mb: PU.id MBMap.map,
134            mi: PU.id MIMap.map }            mi: PU.id MI.umap }
135    
136      val emptyMap = { lt = LTMap.empty, tc = TCMap.empty, tk = TKMap.empty,      val emptyMap = { lt = LTMap.empty, tc = TCMap.empty, tk = TKMap.empty,
137                       dt = DTMap.empty, mb = MBMap.empty, mi = MIMap.empty }                       dt = DTMap.empty, mb = MBMap.empty, mi = MI.emptyUmap }
138    
139      (* type info *)      (* type info *)
140      val (NK, AO, CO, PO, CS, A, CR, LT, TC, TK,      val (NK, AO, CO, PO, CS, A, CR, LT, TC, TK,
# Line 170  Line 142 
142           DTF, TYCON, T, II, VAR, SD, SG, FSG,  SP, EN,           DTF, TYCON, T, II, VAR, SD, SG, FSG,  SP, EN,
143           STR, F, STE, TCE, STRE, FE, EE, ED, EEV, FX,           STR, F, STE, TCE, STRE, FE, EE, ED, EEV, FX,
144           B, DCON, DICT, FPRIM, FUNDEC, TFUNDEC, DATACON, DTMEM, NRD,           B, DCON, DICT, FPRIM, FUNDEC, TFUNDEC, DATACON, DTMEM, NRD,
145           OVERLD, FCTC, SEN, FEN, SPATH, IPATH) =           OVERLD, FCTC, SEN, FEN, SPATH, IPATH, STRID, FCTID) =
146          (1, 2, 3, 4, 5, 6, 7, 8, 9, 10,          (1, 2, 3, 4, 5, 6, 7, 8, 9, 10,
147           11, 12, 13, 14, 15, 16, 17, 18, 19, 20,           11, 12, 13, 14, 15, 16, 17, 18, 19, 20,
148           21, 22, 23, 24, 25, 26, 27, 28, 29, 30,           21, 22, 23, 24, 25, 26, 27, 28, 29, 30,
149           31, 32, 33, 34, 35, 36, 37, 38, 39, 40,           31, 32, 33, 34, 35, 36, 37, 38, 39, 40,
150           41, 42, 43, 44, 45, 46, 47, 48, 49,           41, 42, 43, 44, 45, 46, 47, 48, 49,
151           50, 51, 52, 53, 54, 55)           50, 51, 52, 53, 54, 55, 56, 57)
152    
153      (* this is a bit awful...      (* this is a bit awful...
154       * (we really ought to have syntax for "functional update") *)       * (we really ought to have syntax for "functional update") *)
# Line 220  Line 192 
192                               dt = dt,                               dt = dt,
193                               mb = MBMap.insert (mb, x, v),                               mb = MBMap.insert (mb, x, v),
194                               mi = mi } }                               mi = mi } }
195      fun MIs x = { find = fn (m: map, _) => MIMap.find (#mi m, x),      fun TYCs id = { find = fn (m: map, _) => MI.uLookTyc (#mi m, id),
196                        insert = fn ({ lt, tc, tk, dt, mb, mi }, _, v) =>
197                                    { lt = lt,
198                                      tc = tc,
199                                      tk = tk,
200                                      dt = dt,
201                                      mb = mb,
202                                      mi = MI.uInsertTyc (mi, id, v) } }
203        val SIGs = { find = fn (m: map, r) => MI.uLookSig (#mi m, MI.sigId r),
204                     insert = fn ({ lt, tc, tk, dt, mb, mi }, r, v) =>
205                                 { lt = lt,
206                                   tc = tc,
207                                   tk = tk,
208                                   dt = dt,
209                                   mb = mb,
210                                   mi = MI.uInsertSig (mi, MI.sigId r, v) } }
211        fun STRs i = { find = fn (m: map, _) => MI.uLookStr (#mi m, i),
212                       insert = fn ({ lt, tc, tk, dt, mb, mi }, _, v) =>
213                                   { lt = lt,
214                                     tc = tc,
215                                     tk = tk,
216                                     dt = dt,
217                                     mb = mb,
218                                     mi = MI.uInsertStr (mi, i, v) } }
219        fun FCTs i = { find = fn (m: map, _) => MI.uLookFct (#mi m, i),
220                    insert = fn ({ lt, tc, tk, dt, mb, mi }, _, v) =>                    insert = fn ({ lt, tc, tk, dt, mb, mi }, _, v) =>
221                             { lt = lt,                             { lt = lt,
222                               tc = tc,                               tc = tc,
223                               tk = tk,                               tk = tk,
224                               dt = dt,                               dt = dt,
225                               mb = mb,                               mb = mb,
226                               mi = MIMap.insert (mi, x, v) } }                                   mi = MI.uInsertFct (mi, i, v) } }
227        val ENVs = { find = fn (m: map, r) => MI.uLookEnv (#mi m, MI.envId r),
228                     insert = fn ({ lt, tc, tk, dt, mb, mi }, r, v) =>
229                                 { lt = lt,
230                                   tc = tc,
231                                   tk = tk,
232                                   dt = dt,
233                                   mb = mb,
234                                   mi = MI.uInsertEnv (mi, MI.envId r, v) } }
235    
236      infix 3 $      infix 3 $
237    
# Line 631  Line 635 
635      fun symenvPickler sye =      fun symenvPickler sye =
636          list (pair (pid, flint)) (SymbolicEnv.listItemsi sye)          list (pair (pid, flint)) (SymbolicEnv.listItemsi sye)
637    
     datatype ckey =                     (* context key *)  
         PrimKey  
       | NodeKey of string list * 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  
       | NodeStub of string list * Symbol.symbol  
   
638      (* the environment pickler *)      (* the environment pickler *)
639      fun mkEnvPickler (context0: stubinfo context, isLocalPid) = let      fun envPickler registerLvar context = let
640            val { tycStub, sigStub, strStub, fctStub, envStub,
641                  isLocalPid, isLib } =
642                case context of
643                    INITIAL tmap => let
644                        fun stub (xId, freshX, lookX) r = let
645                            val id = xId r
646                        in
647                            if freshX id then NONE
648                            else if isSome (lookX (tmap, id)) then SOME (NONE, id)
649                            else NONE
650                        end
651                    in
652                        { tycStub = stub (MI.tycId, MI.freshTyc, MI.lookTyc),
653                          sigStub = stub (MI.sigId, MI.freshSig, MI.lookSig),
654                          strStub = stub (MI.strId, MI.freshStr, MI.lookStr),
655                          fctStub = stub (MI.fctId, MI.freshFct, MI.lookFct),
656                          envStub = stub (MI.envId, MI.freshEnv, MI.lookEnv),
657                          isLocalPid = fn _ => false,
658                          isLib = false }
659                    end
660                  | REHASH myPid => let
661                        fun isLocalPid p = PersStamps.compare (p, myPid) = EQUAL
662                        fun stub (idX, stubX, owner) r =
663                            case stubX r of
664                                NONE => bug "REHASH:no stubinfo"
665                              | SOME stb =>
666                                if isLocalPid (owner stb) then SOME (NONE, idX r)
667                                else NONE
668                    in
669                        { tycStub = stub (MI.tycId, #stub, #owner),
670                          sigStub = stub (MI.sigId, #stub, #owner),
671                          strStub = stub (MI.strId, #stub o #rlzn, #owner),
672                          fctStub = stub (MI.fctId, #stub o #rlzn, #owner),
673                          envStub = stub (MI.envId, #stub, #owner),
674                          isLocalPid = isLocalPid,
675                          isLib = false }
676                    end
677                  | LIBRARY l => let
678                        fun stub (idX, stubX, lookX, lib) r = let
679                            fun get id = let
680                                fun loop [] =
681                                    bug "LIBRARY:import info missing"
682                                  | loop ((lms, m) :: t) =
683                                    if isSome (lookX (m, id)) then lms else loop t
684                            in
685                                loop l
686                            end
687                        in
688                            case stubX r of
689                                NONE => bug "LIBRARY:no stubinfo"
690                              | SOME stb => let
691                                    val id = idX r
692                                in
693                                    if lib stb then SOME (get id, id) else NONE
694                                end
695                        end
696                    in
697                        { tycStub = stub (MI.tycId, #stub, MI.lookTyc, #lib),
698                          sigStub = stub (MI.sigId, #stub, MI.lookSig, #lib),
699                          strStub = stub (MI.strId, #stub o #rlzn,
700                                          MI.lookStr, #lib),
701                          fctStub = stub (MI.fctId, #stub o #rlzn,
702                                          MI.lookFct, #lib),
703                          envStub = stub (MI.envId, #stub, MI.lookEnv, #lib),
704                          isLocalPid = fn _ => false,
705                          isLib = true }
706                    end
707    
708            (* Owner pids of stubs are pickled only in the case of libraries,
709             * otherwise they are ignored completely. *)
710            fun libPid x =
711                if isLib then
712                    case x of
713                        (NONE, _) => []
714                      | (SOME stb, ownerOf) => [pid (ownerOf stb)]
715                else []
716    
717          val { lookTYC, lookSIG, lookFSIG, lookSTR, lookFCT, lookEENV } =          fun libModSpec lms = option (pair (list string, symbol)) lms
             context0  
718    
719          val alphaConvert = mkAlphaConvert ()          val stampConverter = Stamps.newConverter ()
720    
721          fun stamp (Stamps.STAMP { scope, count }) = let          fun stamp s = let
722              val op $ = PU.$ ST              val op $ = PU.$ ST
723          in          in
724              case scope of              Stamps.Case stampConverter s
725                  Stamps.LOCAL => "A" $ [int (alphaConvert count)]                  { fresh = fn i => "A" $ [int i],
726                | Stamps.GLOBAL p =>                    global = fn { pid = p, cnt } =>"B" $ [pid p, int cnt],
727                      if isLocalPid p then "A" $ [int count]                    special = fn s => "C" $ [string s] }
728                      else "B" $ [pid p, int count]          end
729                | Stamps.SPECIAL s => "C" $ [string s, int count]  
730            val tycId = stamp
731            val sigId = stamp
732            fun strId { sign, rlzn } = let
733                val op $ = PU.$ STRID
734            in
735                "D" $ [stamp sign, stamp rlzn]
736          end          end
737            fun fctId { paramsig, bodysig, rlzn } = let
738                val op $ = PU.$ FCTID
739            in
740                "E" $ [stamp paramsig, stamp bodysig, stamp rlzn]
741            end
742            val envId = stamp
743    
744          val entVar = stamp          val entVar = stamp
745          val entPath = list entVar          val entPath = list entVar
746    
747          val op $ = PU.$ MI          val anotherLvar =
748          fun modId (MI.STRid { rlzn, sign }) = "1" $ [stamp rlzn, stamp sign]              let val lvcount = ref 0
749            | modId (MI.SIGid s) = "2" $ [stamp s]              in (fn v => let val j = !lvcount
750            | modId (MI.FCTid { rlzn, sign }) = "3" $ [stamp rlzn, modId sign]                          in registerLvar v; lvcount := j + 1; j end)
           | modId (MI.FSIGid { paramsig, bodysig }) =  
             "4" $ [stamp paramsig, stamp bodysig]  
           | modId (MI.TYCid a) = "5" $ [stamp a]  
           | modId (MI.EENVid s) = "6" $ [stamp s]  
   
         val lvcount = ref 0  
         val lvlist = ref []  
   
         fun anotherLvar v = let  
             val j = !lvcount  
         in  
             lvlist := v :: !lvlist;  
             lvcount := j + 1;  
             j  
751          end          end
752    
753          val { access, conrep } = mkAccess { lvar = int o anotherLvar,          val { access, conrep } = mkAccess { lvar = int o anotherLvar,
# Line 775  Line 834 
834    
835          and tycon arg = let          and tycon arg = let
836              val op $ = PU.$ TYCON              val op $ = PU.$ TYCON
837              fun tc (T.GENtyc x) =              fun tc (tyc as T.GENtyc g) =
838                  let val id = MI.TYCid (#stamp x)                  let fun gt_raw (g as { stamp = s, arity, eq = ref eq, kind,
839                      fun gt_raw { stamp = s, arity, eq = ref eq, kind, path } =                                         path, stub }) =
840                          case lookTYC id of                          case tycStub g of
841                              SimpleStub => "A" $ [modId id]                              SOME (l, i) => "A" $ [libModSpec l, tycId i]
842                            | NoStub => "B" $ [stamp s, int arity, eqprop eq,                            | NONE => "B" $ ([stamp s, int arity, eqprop eq,
843                                               tyckind kind, ipath path]                                               tyckind kind, ipath path]
844                            | PrimStub => "I" $ [modId id]                                             @ libPid (stub, #owner))
845                            | NodeStub (sl, s) =>                  in
846                              "J" $ [list string sl, symbol s, modId id]                      share (TYCs (MI.tycId g)) gt_raw g
847                  in                  end
848                      share (MIs (id, NONE)) gt_raw x                | tc (tyc as T.DEFtyc dt) = let
849                  end                      fun dt_raw { stamp = s, tyfun, strict, path } = let
               | tc (T.DEFtyc x) = let  
                     fun dt_raw x = let  
                         val { stamp = s, tyfun, strict, path } = x  
850                          val T.TYFUN { arity, body } = tyfun                          val T.TYFUN { arity, body } = tyfun
851                      in                      in
852                          "C" $ [stamp s, int arity, ty body,                          "C" $ [stamp s, int arity, ty body,
853                                 list bool strict, ipath path]                                 list bool strict, ipath path]
854                      end                      end
855                  in                  in
856                      share (MIs (MI.TYCid (#stamp x), NONE)) dt_raw x                      share (TYCs (MI.tycId' tyc)) dt_raw dt
857                  end                  end
858                | tc (T.PATHtyc { arity, entPath = ep, path }) =                | tc (T.PATHtyc { arity, entPath = ep, path }) =
859                  "D" $ [int arity, entPath ep, ipath path]                  "D" $ [int arity, entPath ep, ipath path]
# Line 845  Line 901 
901              "o" $ [ty indicator, var variant]              "o" $ [ty indicator, var variant]
902          end          end
903    
         fun fsigId (M.FSIG { paramsig = M.SIG { stamp = ps, ... },  
                              bodysig = M.SIG { stamp = bs, ... },  
                              ... }) =  
             MI.FSIGid { paramsig = ps, bodysig = bs }  
           | fsigId _ = bug "unexpected functor signature in fsigId"  
   
904          fun strDef arg = let          fun strDef arg = let
905              val op $ = PU.$ SD              val op $ = PU.$ SD
906              fun sd (M.CONSTstrDef s) = "C" $ [Structure s]              fun sd (M.CONSTstrDef s) = "C" $ [Structure s]
# Line 866  Line 916 
916          and Signature arg = let          and Signature arg = let
917              val op $ = PU.$ SG              val op $ = PU.$ SG
918              fun sg  M.ERRORsig = "A" $ []              fun sg  M.ERRORsig = "A" $ []
919                | sg (M.SIG x) = let                | sg (M.SIG s) =
920                      val id = MI.SIGid (#stamp x)                  (case sigStub s of
921                      fun sig_raw x = let                       SOME (l, i) => "B" $ [libModSpec l, sigId i]
922                          val { name, closed, fctflag, stamp = sta, symbols,                     | NONE => let
923                                elements, boundeps = ref b, lambdaty = _,                           fun sig_raw (s: M.sigrec) = let
924                                typsharing, strsharing } = x                               val { stamp = sta, name, closed,
925                                       fctflag, symbols, elements,
926                                       boundeps = ref b,
927                                       lambdaty = _, stub,
928                                       typsharing, strsharing } = s
929                          val b = NONE            (* currently turned off *)                          val b = NONE            (* currently turned off *)
930                      in                      in
931                          case lookSIG id of                               "C" $ ([stamp sta,
932                              SimpleStub => "B" $ [modId id]                                       option symbol name, bool closed,
933                            | NoStub =>                                       bool fctflag,
                                 "C" $ [option symbol name, bool closed,  
                                        bool fctflag, stamp sta,  
934                                         list symbol symbols,                                         list symbol symbols,
935                                         list (pair (symbol, spec)) elements,                                         list (pair (symbol, spec)) elements,
936                                         option (list (pair (entPath, tkind))) b,                                         option (list (pair (entPath, tkind))) b,
937                                         list (list spath) typsharing,                                         list (list spath) typsharing,
938                                         list (list spath) strsharing]                                         list (list spath) strsharing]
939                            | PrimStub => "D" $ [modId id]                                      @ libPid (stub, #owner))
                           | NodeStub (sl, s) =>  
                             "E" $ [list string sl, symbol s, modId id]  
940                      end                      end
941                  in                  in
942                      share (MIs (id, NONE)) sig_raw x                           share SIGs sig_raw s
943                  end                       end)
944          in          in
945              sg arg              sg arg
946          end          end
# Line 898  Line 948 
948          and fctSig arg = let          and fctSig arg = let
949              val op $ = PU.$ FSG              val op $ = PU.$ FSG
950              fun fsg M.ERRORfsig = "a" $ []              fun fsg M.ERRORfsig = "a" $ []
951                | fsg (fs as M.FSIG x) = let                | fsg (M.FSIG { kind, paramsig, paramvar, paramsym, bodysig }) =
                     val id = fsigId fs  
                     fun fsig_raw x = let  
                         val { kind, paramsig, paramvar, paramsym, bodysig } = x  
                     in  
                         case lookFSIG id of  
                             SimpleStub => "b" $ [modId id]  
                           | NoStub =>  
952                                  "c" $ [option symbol kind, Signature paramsig,                                  "c" $ [option symbol kind, Signature paramsig,
953                                         entVar paramvar,                                         entVar paramvar,
954                                         option symbol paramsym,                                         option symbol paramsym,
955                                         Signature bodysig]                                         Signature bodysig]
                           | PrimStub => "d" $ [modId id]  
                           | NodeStub (sl, s) => "e" $ [list string sl,  
                                                        symbol s, modId id]  
                     end  
                 in  
                     share (MIs (id, NONE)) fsig_raw x  
                 end  
956          in          in
957              fsg arg              fsg arg
958          end          end
# Line 958  Line 994 
994              fun str (M.STRSIG { sign, entPath = p }) =              fun str (M.STRSIG { sign, entPath = p }) =
995                  "A" $ [Signature sign, entPath p]                  "A" $ [Signature sign, entPath p]
996                | str M.ERRORstr = "B" $ []                | str M.ERRORstr = "B" $ []
997                | str (M.STR (x as { sign = M.SIG sign, ... })) = let                | str (M.STR (s as { sign, rlzn, access = a, info })) =
998                      val id = MI.STRid { rlzn = #stamp (#rlzn x),                  (case strStub s of
999                                          sign = #stamp sign }                       (* stub represents just the strerec suspension! *)
1000                      fun s_raw { sign, rlzn, access = a, info } =                       SOME (l, i) => "C" $ [Signature sign,
1001                          case lookSTR id of                                             libModSpec l,
1002                              SimpleStub => "C" $ [modId id, access a]                                             strId i,
1003                            | NoStub =>                                             access a,
1004                                  "D" $ [Signature sign, strEntity rlzn,                                             inl_info info]
1005                                         access a, inl_info info]                     | NONE => "D" $ [Signature sign,
1006                            | PrimStub => "I" $ [modId id]                                      shStrEntity (MI.strId s) rlzn,
1007                            | NodeStub (sl, s) =>                                      access a, inl_info info])
                             "J" $ [list string sl, symbol s, modId id,  
                                    access a]  
                 in  
                     share (MIs (id, acc_pid (#access x))) s_raw x  
                 end  
               | str _ = bug "unexpected structure in pickmod"  
1008          in          in
1009              str arg              str arg
1010          end          end
# Line 982  Line 1012 
1012          and Functor arg = let          and Functor arg = let
1013              val op $ = PU.$ F              val op $ = PU.$ F
1014              fun fct M.ERRORfct = "E" $ []              fun fct M.ERRORfct = "E" $ []
1015                | fct (M.FCT x) = let                | fct (M.FCT (f as { sign, rlzn, access = a, info })) =
1016                      val id = MI.FCTid { rlzn = #stamp (#rlzn x),                  (case fctStub f of
1017                                          sign = fsigId (#sign x) }                       SOME (l, i) => "F" $ [fctSig sign,
1018                      fun f_raw { sign, rlzn, access = a, info } =                                             libModSpec l,
1019                          case lookFCT id of                                             fctId i,
1020                              SimpleStub => "F" $ [modId id, access a]                                             access a,
1021                            | NoStub =>                                             inl_info info]
1022                              "G" $ [fctSig sign, fctEntity rlzn,                     | NONE => "G" $ [fctSig sign,
1023                                     access a, inl_info info]                                      shFctEntity (MI.fctId f) rlzn,
1024                            | PrimStub => "H" $ [modId id]                                      access a, inl_info info])
                           | NodeStub (sl, s) =>  
                             "I" $ [list string sl, symbol s, modId id,  
                                    access a]  
                 in  
                     share (MIs (id, acc_pid (#access x))) f_raw x  
                 end  
1025          in          in
1026              fct arg              fct arg
1027          end          end
1028    
1029          and stampExp (M.CONST s) = PU.$ STE ("a", [stamp s])          and (* stampExp (M.CONST s) = PU.$ STE ("a", [stamp s])
1030            | stampExp (M.GETSTAMP s) = PU.$ STE ("b", [strExp s])            | *) stampExp (M.GETSTAMP s) = PU.$ STE ("b", [strExp s])
1031            | stampExp M.NEW = "c" $ []            | stampExp M.NEW = "c" $ []
1032    
1033          and tycExp (M.CONSTtyc t) = PU.$ TCE ("d", [tycon t])          and tycExp (M.CONSTtyc t) = PU.$ TCE ("d", [tycon t])
# Line 1063  Line 1087 
1087              ed arg              ed arg
1088          end          end
1089    
1090          and entityEnv (M.MARKeenv (s, r)) =          and entityEnv (M.MARKeenv m) =
1091              let val op $ = PU.$ EEV              (case envStub m of
1092                  val id = MI.EENVid s                   SOME (l, i) => "D" $ [libModSpec l, envId i]
1093                  fun mee_raw (s, r) =                 | NONE => let
1094                      case lookEENV id of                       fun mee_raw { stamp = s, env, stub } =
1095                          SimpleStub => "D" $ [modId id]                           "E" $ ([stamp s, entityEnv env]
1096                        | NoStub => "E" $ [stamp s, entityEnv r]                                  @ libPid (stub: M.stubinfo option, #owner))
                       | PrimStub => "F" $ [modId id]  
                       | NodeStub (sl, s) =>  
                         "G" $ [list string sl, symbol s, modId id]  
1097              in              in
1098                  share (MIs (id, NONE)) mee_raw (s, r)                       share ENVs mee_raw m
1099              end                   end)
1100            | entityEnv (M.BINDeenv (d, r)) =            | entityEnv (M.BINDeenv (d, r)) =
1101              PU.$ EEV ("A", [list (pair (entVar, entity)) (ED.listItemsi d),              PU.$ EEV ("A", [list (pair (entVar, entity)) (ED.listItemsi d),
1102                             entityEnv r])                             entityEnv r])
1103            | entityEnv M.NILeenv = "B" $ []            | entityEnv M.NILeenv = "B" $ []
1104            | entityEnv M.ERReenv = "C" $ []            | entityEnv M.ERReenv = "C" $ []
1105    
1106          and strEntity { stamp = s, entities, lambdaty = _, rpath } = let          and strEntity { stamp = s, entities, lambdaty = _, rpath, stub } =
1107              val op $ = PU.$ SEN              let val op $ = PU.$ SEN
1108          in          in
1109              "s" $ [stamp s, entityEnv entities, ipath rpath]                  "s" $ ([stamp s, entityEnv entities, ipath rpath]
1110                           @ libPid (stub: M.stubinfo option, #owner))
1111          end          end
1112    
1113          and fctEntity fe = let          and shStrEntity id = share (STRs id) strEntity
1114              val op $ = PU.$ FEN  
1115              val { stamp = s, closure, lambdaty = _, tycpath = _, rpath } = fe          and fctEntity { stamp = s, closure, lambdaty, tycpath, rpath, stub } =
1116                let val op $ = PU.$ FEN
1117          in          in
1118              "f" $ [stamp s, fctClosure closure, ipath rpath]                  "f" $ ([stamp s, fctClosure closure, ipath rpath]
1119                           @ libPid (stub: M.stubinfo option, #owner))
1120          end          end
1121    
1122            and shFctEntity id = share (FCTs id) fctEntity
1123    
1124          and tycEntity x = tycon x          and tycEntity x = tycon x
1125    
1126          fun fixity Fixity.NONfix = "N" $ []          fun fixity Fixity.NONfix = "N" $ []
# Line 1112  Line 1138 
1138    
1139          fun env e = let          fun env e = let
1140              val syms = ListMergeSort.uniqueSort symCmp (Env.symbols e)              val syms = ListMergeSort.uniqueSort symCmp (Env.symbols e)
1141              val pairs = map (fn s => (s, Env.look (e, s))) syms              val pairs = map (fn s => (s, StaticEnv.look (e, s))) syms
1142          in          in
1143              list (pair (symbol, binding)) pairs              list (pair (symbol, binding)) pairs
1144          end          end
   
         fun env'n'ctxt { env = e, ctxt } =  
             pair (env, list modId) (e, ModuleId.Set.listItems ctxt)  
1145      in      in
1146          { pickler = env, pickler' = env'n'ctxt,          env
           exportLvarsGetter = fn () => rev (!lvlist) }  
1147      end      end
1148    
1149      fun pickleEnv { context, env } = let      fun pickleEnv context e = let
1150          fun cvt lk i =          val lvlist = ref []
1151              case lk context i of          fun registerLvar v = lvlist := v :: !lvlist
1152                  SOME _ => SimpleStub          val pickler = envPickler registerLvar context
1153                | NONE => NoStub          val pickle = Byte.stringToBytes (PU.pickle emptyMap (pickler e))
1154            val exportLvars = rev (!lvlist)
         val c = { lookSTR = cvt CMStaticEnv.lookSTR,  
                   lookSIG = cvt CMStaticEnv.lookSIG,  
                   lookFCT = cvt CMStaticEnv.lookFCT,  
                   lookFSIG = cvt CMStaticEnv.lookFSIG,  
                   lookTYC = cvt CMStaticEnv.lookTYC,  
                   lookEENV = cvt CMStaticEnv.lookEENV }  
   
         val { pickler, exportLvarsGetter, ... } =  
             mkEnvPickler (c, fn _ => false)  
         val pickle = Byte.stringToBytes (PU.pickle emptyMap (pickler env))  
         val exportLvars = exportLvarsGetter ()  
   
1155          val hash = pickle2hash pickle          val hash = pickle2hash pickle
   
1156          val exportPid =          val exportPid =
1157              case exportLvars of              case exportLvars of
1158                  [] => NONE                  [] => NONE
# Line 1154  Line 1163 
1163            exportPid = exportPid }            exportPid = exportPid }
1164      end      end
1165    
     fun repickleEnvHash { context, env, orig_hash } = let  
         fun lk i =  
             if ModuleId.Set.member (context, i) then SimpleStub else NoStub  
         val c = { lookSTR = lk, lookSIG = lk, lookFCT = lk,  
                   lookFSIG = lk, lookTYC = lk, lookEENV = lk }  
         fun isLocalPid p = PersStamps.compare (p, orig_hash) = EQUAL  
         val { pickler, ... } = mkEnvPickler (c, isLocalPid)  
         val pickle = Byte.stringToBytes (PU.pickle emptyMap (pickler env))  
     in  
         pickle2hash pickle  
     end  
   
     type env'n'ctxt = { env: StaticEnv.staticEnv, ctxt: ModuleId.Set.set }  
   
     fun envPickler context = let  
         val { lookSTR, lookSIG, lookFCT, lookFSIG, lookTYC, lookEENV } =  
             context  
         fun cvt lk i =  
             case lk i of  
                 SOME PrimKey => PrimStub  
               | SOME (NodeKey (sl, s)) => NodeStub (sl, 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, fn _ => false)  
     in  
         pickler'  
     end  
   
1166      (* the dummy environment pickler *)      (* the dummy environment pickler *)
1167      fun dontPickle (senv : StaticEnv.staticEnv, count) = let      fun dontPickle (senv : StaticEnv.staticEnv, count) = let
1168          val hash = let          val hash = let
# Line 1204  Line 1180 
1180          val syms = ListMergeSort.uniqueSort symCmp (Env.symbols senv)          val syms = ListMergeSort.uniqueSort symCmp (Env.symbols senv)
1181          fun newAccess i = A.PATH (A.EXTERN hash, i)          fun newAccess i = A.PATH (A.EXTERN hash, i)
1182          fun mapbinding (sym, (i, env, lvars)) =          fun mapbinding (sym, (i, env, lvars)) =
1183              case Env.look (senv, sym) of              case StaticEnv.look (senv, sym) of
1184                  B.VALbind (V.VALvar {access=a, info=z, path=p, typ= ref t }) =>                  B.VALbind (V.VALvar {access=a, info=z, path=p, typ= ref t }) =>
1185                      (case a of                      (case a of
1186                           A.LVAR k =>                           A.LVAR k =>
1187                               (i+1,                               (i+1,
1188                                Env.bind (sym,                        StaticEnv.bind (sym,
1189                                          B.VALbind (V.VALvar                                          B.VALbind (V.VALvar
1190                                                     { access = newAccess i,                                                     { access = newAccess i,
1191                                                       info = z, path = p,                                                       info = z, path = p,
# Line 1221  Line 1197 
1197                       (case a of                       (case a of
1198                            A.LVAR k =>                            A.LVAR k =>
1199                                (i+1,                                (i+1,
1200                                 Env.bind (sym,                        StaticEnv.bind (sym,
1201                                           B.STRbind (M.STR                                           B.STRbind (M.STR
1202                                                      { access = newAccess i,                                                      { access = newAccess i,
1203                                                        sign = s, rlzn = r,                                                        sign = s, rlzn = r,
# Line 1233  Line 1209 
1209                        (case a of                        (case a of
1210                             A.LVAR k =>                             A.LVAR k =>
1211                                 (i+1,                                 (i+1,
1212                                  Env.bind (sym,                        StaticEnv.bind (sym,
1213                                            B.FCTbind (M.FCT                                            B.FCTbind (M.FCT
1214                                                       { access = newAccess i,                                                       { access = newAccess i,
1215                                                         sign = s, rlzn = r,                                                         sign = s, rlzn = r,
# Line 1248  Line 1224 
1224                      case a of                      case a of
1225                          A.LVAR k =>                          A.LVAR k =>
1226                              (i+1,                              (i+1,
1227                               Env.bind (sym,                           StaticEnv.bind (sym,
1228                                         B.CONbind (T.DATACON                                         B.CONbind (T.DATACON
1229                                                    { rep = newrep, name = n,                                                          { rep = newrep,
1230                                                              name = n,
1231                                                      lazyp = false,                                                      lazyp = false,
1232                                                      const = c, typ = t,                                                      const = c, typ = t,
1233                                                      sign = s }),                                                      sign = s }),
# Line 1258  Line 1235 
1235                               k :: lvars)                               k :: lvars)
1236                        | _ => bug ("dontPickle 4" ^ A.prAcc a)                        | _ => bug ("dontPickle 4" ^ A.prAcc a)
1237                  end                  end
1238                | binding =>  (i, Env.bind (sym, binding, env), lvars)                | binding => (i, StaticEnv.bind (sym, binding, env), lvars)
1239          val (_,newenv,lvars) = foldl mapbinding (0, StaticEnv.empty, nil) syms          val (_,newenv,lvars) = foldl mapbinding (0, StaticEnv.empty, nil) syms
1240          val exportPid =          val exportPid =
1241              case lvars of              case lvars of

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

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