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/unpickmod-new.sml
ViewVC logotype

Diff of /sml/trunk/src/compiler/Semant/pickle/unpickmod-new.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 586, Thu Mar 30 05:08:07 2000 UTC revision 587, Thu Mar 30 09:01:52 2000 UTC
# Line 1  Line 1 
1  (*  (*
2   * The new unpickler (based on the new generic unpickling facility).   * The new unpickler (based on the new generic unpickling facility).
3   *   *
4   * July 1999, Matthias Blume   * The unpickler embeds a "modtree" into the unpickled environment.
5     * The modtree allows for very rapid construction of modmaps so that
6     * modmaps do not have to be stored permanently but can be built on-demand.
7     * (Permanently stored modmaps incur space problems: one has to be careful
8     * that they don't hang on to bindings that no longer exist, and because
9     * of sharing there can be significant overlap--and space overhead--in what
10     * each such map points to.  Modtrees do not have these problems.)
11     *
12     * March 2000, Matthias Blume
13   *)   *)
14  signature UNPICKMOD = sig  signature UNPICKMOD = sig
15    
16      type env'n'ctxt = { env: StaticEnv.staticEnv, ctxt: ModuleId.Set.set }      type context = (string list * Symbol.symbol) option -> ModuleId.tmap
17    
18      val unpickleEnv :      val unpickleEnv : context ->
19          { context: CMStaticEnv.staticEnv,                        PersStamps.persstamp * Word8Vector.vector ->
20            hash: PersStamps.persstamp,                        StaticEnv.staticEnv
           pickle: Word8Vector.vector }  
         -> env'n'ctxt  
21    
22      val unpickleFLINT : Word8Vector.vector -> CompBasic.flint option      val unpickleFLINT : Word8Vector.vector -> CompBasic.flint option
23    
24      (*      (* The env unpickler resulting from "mkUnpicklers" cannot be used for
      * The env unpickler resulting from "mkUnpicklers" cannot be used for  
25       * "original" environments that come out of the elaborator.  For those,       * "original" environments that come out of the elaborator.  For those,
26       * continue to use "unpickleEnv".  "mkUnpicklers" is intended to be       * continue to use "unpickleEnv".  "mkUnpicklers" is intended to be
27       * used by CM's stable library mechanism.       * used by CM's stable library mechanism. *)
      *)  
28      val mkUnpicklers :      val mkUnpicklers :
29          UnpickleUtil.session ->          { session: UnpickleUtil.session,
30          { prim_context: CMStaticEnv.staticEnv,            stringlist: string list UnpickleUtil.reader } ->
31            node_context:          context ->
32                 string list * Symbol.symbol -> CMStaticEnv.staticEnv option,          { symenv: SymbolicEnv.symenv UnpickleUtil.reader,
33            stringlist: string list UnpickleUtil.reader }            statenv: StaticEnv.staticEnv UnpickleUtil.reader,
         -> { symenv: SymbolicEnv.symenv UnpickleUtil.reader,  
              env: env'n'ctxt UnpickleUtil.reader,  
34               symbol: Symbol.symbol UnpickleUtil.reader,               symbol: Symbol.symbol UnpickleUtil.reader,
35               symbollist: Symbol.symbol list UnpickleUtil.reader }               symbollist: Symbol.symbol list UnpickleUtil.reader }
36  end  end
37    
38  structure UnpickMod : UNPICKMOD = struct  structure UnpickMod : UNPICKMOD = struct
39    
40        type context = (string list * Symbol.symbol) option -> ModuleId.tmap
41    
42      structure A = Access      structure A = Access
43      structure DI = DebIndex      structure DI = DebIndex
44      structure LT = LtyDef      structure LT = LtyDef
# Line 56  Line 60 
60      structure UU = UnpickleUtil      structure UU = UnpickleUtil
61      exception Format = UU.Format      exception Format = UU.Format
62    
     type env'n'ctxt = { env: StaticEnv.staticEnv, ctxt: ModuleId.Set.set }  
   
63      (* The order of the entries in the following tables      (* The order of the entries in the following tables
64       * must be coordinated with pickmod! *)       * must be coordinated with pickmod! *)
65      val primop_table =      val primop_table =
# Line 135  Line 137 
137      val eqprop_table =      val eqprop_table =
138          #[T.YES, T.NO, T.IND, T.OBJ, T.DATA, T.ABS, T.UNDEF]          #[T.YES, T.NO, T.IND, T.OBJ, T.DATA, T.ABS, T.UNDEF]
139    
140        fun & c (x, t) = (c x, t)
141    
142        fun branch l = let
143            fun loop ([], [x]) = x
144              | loop ([], l) = M.BRANCH l
145              | loop (M.BRANCH [] :: t, l) = loop (t, l)
146              | loop (M.BRANCH [x] :: t, l) = loop (t, x :: l) (* never occurs! *)
147              | loop (x :: t, l) = loop (t, x :: l)
148        in
149            loop (l, [])
150        end
151    
152        val notree = M.BRANCH []
153    
154      fun mkSharedStuff (session, lvar) = let      fun mkSharedStuff (session, lvar) = let
155    
156          fun share m f = UU.share session m f          fun share m f = UU.share session m f
# Line 268  Line 284 
284            tkind = tkind, tkindlist = tkindlist }            tkind = tkind, tkindlist = tkindlist }
285      end      end
286    
287      fun mkEnvUnpickler arg = let      fun mkEnvUnpickler extraInfo sessionInfo context = let
288          val (session, symbollist, stringlist,          val { globalPid, symbollist, sharedStuff, lib } = extraInfo
289               sharedStuff, context0, globalPid) = arg          val { session, stringlist } = sessionInfo
290    
291          val { lookTYC, lookSIG, lookFSIG, lookSTR, lookFCT, lookEENV,          local
292                lookTYCp, lookSIGp, lookFSIGp, lookSTRp, lookFCTp, lookEENVp,              fun look lk (m, i) =
293                lookTYCn, lookSIGn, lookFSIGn, lookSTRn, lookFCTn, lookEENVn } =                  case lk (context m, i) of
294              context0                      SOME x => x
295                      | NONE =>
296                        (ErrorMsg.impossible "UnpickMod: stub lookup failed";
297                         raise Format)
298            in
299                val lookTyc = look MI.lookTyc
300                val lookSig = look MI.lookSig
301                val lookStr = look MI.lookStr
302                val lookFct = look MI.lookFct
303                val lookEnv = look MI.lookEnv
304            end
305    
306          fun list m r = UU.r_list session m r          fun list m r = UU.r_list session m r
307          fun option m r = UU.r_option session m r          fun option m r = UU.r_option session m r
# Line 289  Line 315 
315          (* The following maps all acquire different types by being used          (* The following maps all acquire different types by being used
316           * in different contexts: *)           * in different contexts: *)
317          val stampM = UU.mkMap ()          val stampM = UU.mkMap ()
318            val strIdM = UU.mkMap ()
319            val fctIdM = UU.mkMap ()
320          val stampOptionM = UU.mkMap ()          val stampOptionM = UU.mkMap ()
321          val stampListM = UU.mkMap ()          val stampListM = UU.mkMap ()
         val modIdM = UU.mkMap ()  
322          val symbolOptionM = UU.mkMap ()          val symbolOptionM = UU.mkMap ()
323          val symbolListM = UU.mkMap ()          val symbolListM = UU.mkMap ()
324          val spathListM = UU.mkMap ()          val spathListM = UU.mkMap ()
# Line 341  Line 368 
368          val edListM = UU.mkMap ()          val edListM = UU.mkMap ()
369          val eenvBindM = UU.mkMap ()          val eenvBindM = UU.mkMap ()
370          val envM = UU.mkMap ()          val envM = UU.mkMap ()
         val milM = UU.mkMap ()  
371          val spathM = UU.mkMap ()          val spathM = UU.mkMap ()
372          val ipathM = UU.mkMap ()          val ipathM = UU.mkMap ()
373          val symSpecPM = UU.mkMap ()          val symSpecPM = UU.mkMap ()
# Line 349  Line 375 
375          val sdIntPM = UU.mkMap ()          val sdIntPM = UU.mkMap ()
376          val evEntPM = UU.mkMap ()          val evEntPM = UU.mkMap ()
377          val symBindPM = UU.mkMap ()          val symBindPM = UU.mkMap ()
378          val envMilPM = UU.mkMap ()          val pidOptionM = UU.mkMap ()
379            val lmsOptM = UU.mkMap ()
380            val lmsPairM = UU.mkMap ()
381    
382          val { pid, string, symbol, access, conrep, consig,          val { pid, string, symbol, access, conrep, consig,
383                primop, boollist, tkind, tkindlist } = sharedStuff                primop, boollist, tkind, tkindlist } = sharedStuff
384    
385            fun libModSpec () =
386                option lmsOptM (pair lmsPairM (stringlist, symbol)) ()
387    
388          fun stamp () = let          fun stamp () = let
389              fun st #"A" = Stamps.STAMP { scope = Stamps.GLOBAL (globalPid ()),              fun st #"A" = Stamps.global { pid = globalPid (),
390                                           count = int () }                                            cnt = int () }
391                | st #"B" = Stamps.STAMP { scope = Stamps.GLOBAL (pid ()),                | st #"B" = Stamps.global { pid = pid (),
392                                           count = int () }                                            cnt = int () }
393                | st #"C" = Stamps.STAMP { scope = Stamps.SPECIAL (string ()),                | st #"C" = Stamps.special (string ())
                                          count = int () }  
394                | st _ = raise Format                | st _ = raise Format
395          in          in
396              share stampM st              share stampM st
397          end          end
398    
399            val tycId = stamp
400            val sigId = stamp
401            fun strId () = let
402                fun si #"D" = { sign = stamp (), rlzn = stamp () }
403                  | si _ = raise Format
404            in
405                share strIdM si
406            end
407            fun fctId () = let
408                fun fi #"E" = { paramsig = stamp (), bodysig = stamp (),
409                                rlzn = stamp () }
410                  | fi _ = raise Format
411            in
412                share fctIdM fi
413            end
414            val envId = stamp
415    
416          val stamplist = list stampListM stamp          val stamplist = list stampListM stamp
417          val stampoption = option stampOptionM stamp          val stampoption = option stampOptionM stamp
418            val pidoption = option pidOptionM pid
419    
420          val entVar = stamp          val entVar = stamp
421          val entVarOption = stampoption          val entVarOption = stampoption
422          val entPath = stamplist          val entPath = stamplist
423    
         fun modId () = let  
             fun mi #"1" = MI.STRid { rlzn = stamp (), sign = stamp () }  
               | mi #"2" = MI.SIGid (stamp ())  
               | mi #"3" = MI.FCTid { rlzn = stamp (), sign = modId () }  
               | mi #"4" = MI.FSIGid { paramsig = stamp (),  
                                       bodysig  = stamp () }  
               | mi #"5" = MI.TYCid (stamp ())  
               | mi #"6" = MI.EENVid (stamp ())  
               | mi _ = raise Format  
         in  
             share modIdM mi  
         end  
   
424          val symbollist = list symbolListM symbol          val symbollist = list symbolListM symbol
425          val symboloption = option symbolOptionM symbol          val symboloption = option symbolOptionM symbol
426    
   
427          fun spath () = let          fun spath () = let
428              fun sp #"s" = SP.SPATH (symbollist ())              fun sp #"s" = SP.SPATH (symbollist ())
429                | sp _ = raise Format                | sp _ = raise Format
# Line 418  Line 452 
452              nonshare eqp              nonshare eqp
453          end          end
454    
455          fun datacon () = let          fun datacon' () = let
456              fun d #"c" =              fun d #"c" =
457                  T.DATACON { name = symbol (), const = bool (), typ = ty (),                  let val n = symbol ()
458                              rep = conrep (), sign = consig (),                      val c = bool ()
459                              lazyp = bool () }                      val (t, ttr) = ty' ()
460                        val r = conrep ()
461                        val s = consig ()
462                        val l = bool ()
463                    in
464                        (T.DATACON { name = n, const = c, typ = t,
465                                     rep = r, sign = s, lazyp = l },
466                         ttr)
467                    end
468                | d _ = raise Format                | d _ = raise Format
469          in          in
470              share dataconM d              share dataconM d
# Line 487  Line 529 
529          and nrdlist () = list nrdListM nameRepDomain ()          and nrdlist () = list nrdListM nameRepDomain ()
530    
531          and tycon () = let          and tycon () = let
532              fun tyc #"A" = lookTYC (modId ())              fun tyc #"A" = T.GENtyc (lookTyc (libModSpec (), tycId ()))
533                | tyc #"B" = T.GENtyc { stamp = stamp (), arity = int (),                | tyc #"B" = T.GENtyc { stamp = stamp (),
534                                        eq = ref (eqprop ()), kind = tyckind (),                                        arity = int (),
535                                        path = ipath () }                                        eq = ref (eqprop ()),
536                                          kind = tyckind (),
537                                          path = ipath (),
538                                          stub = SOME { owner = if lib then pid ()
539                                                                else globalPid (),
540                                                        lib = lib } }
541                | tyc #"C" = T.DEFtyc { stamp = stamp (),                | tyc #"C" = T.DEFtyc { stamp = stamp (),
542                                        tyfun = T.TYFUN { arity = int (),                                        tyfun = T.TYFUN { arity = int (),
543                                                          body = ty () },                                                          body = ty () },
# Line 502  Line 549 
549                | tyc #"F" = T.RECtyc (int ())                | tyc #"F" = T.RECtyc (int ())
550                | tyc #"G" = T.FREEtyc (int ())                | tyc #"G" = T.FREEtyc (int ())
551                | tyc #"H" = T.ERRORtyc                | tyc #"H" = T.ERRORtyc
               | tyc #"I" = lookTYCp (modId ())  
               | tyc #"J" = lookTYCn (stringlist (), symbol(), modId ())  
552                | tyc _ = raise Format                | tyc _ = raise Format
553          in          in
554              share tyconM tyc              share tyconM tyc
555          end          end
556    
557            and tycon' () = let
558                val tyc = tycon ()
559                val tree =
560                    case tyc of
561                        T.GENtyc r => M.TYCNODE r
562                      | _ => notree
563            in
564                (tyc, tree)
565            end
566    
567          and tyconlist () = list tyconListM tycon ()          and tyconlist () = list tyconListM tycon ()
568    
569          and ty () = let          and ty' () = let
570              fun t #"a" = T.CONty (tycon (), tylist ())              fun t #"a" =
571                | t #"b" = T.IBOUND (int ())                  let val (tyc, tyctr) = tycon' ()
572                | t #"c" = T.WILDCARDty                      val (tyl, tyltr) = tylist' ()
573                | t #"d" = T.POLYty { sign = boollist (),                  in (T.CONty (tyc, tyl), branch [tyctr, tyltr])
574                                      tyfun = T.TYFUN { arity = int (),                  end
575                                                        body = ty () } }                | t #"b" = (T.IBOUND (int ()), notree)
576                | t #"e" = T.UNDEFty                | t #"c" = (T.WILDCARDty, notree)
577                  | t #"d" =
578                    let val s = boollist ()
579                        val ar = int ()
580                        val (b, btr) = ty' ()
581                    in
582                        (T.POLYty { sign = s, tyfun = T.TYFUN { arity = ar,
583                                                                body = b } },
584                         btr)
585                    end
586                  | t #"e" = (T.UNDEFty, notree)
587                | t _ = raise Format                | t _ = raise Format
588          in          in
589              share tyM t              share tyM t
590          end          end
591    
592            and ty () = #1 (ty' ())
593    
594          and tyoption () = option tyOptionM ty ()          and tyoption () = option tyOptionM ty ()
595          and tylist () = list tyListM ty ()  
596            and tylist' () = let
597                val (l, trl) = ListPair.unzip (list tyListM ty' ())
598            in
599                (l, branch trl)
600            end
601    
602          and inl_info () = let          and inl_info () = let
603              fun ii #"A" = II.INL_PRIM (primop (), tyoption ())              fun ii #"A" = II.INL_PRIM (primop (), tyoption ())
# Line 538  Line 610 
610    
611          and iilist () = list iiListM inl_info ()          and iilist () = list iiListM inl_info ()
612    
613          and var () = let          and var' () = let
614              fun v #"1" = V.VALvar { access = access (), info = inl_info (),              fun v #"1" =
615                                      path = spath (), typ = ref (ty ()) }                  let val a = access ()
616                | v #"2" = V.OVLDvar { name = symbol (),                      val i = inl_info ()
617                                       options = ref (overldlist ()),                      val p = spath ()
618                                       scheme = T.TYFUN { arity = int (),                      val (t, tr) = ty' ()
619                                                          body = ty () } }                  in
620                | v #"3" = V.ERRORvar                      (V.VALvar { access = a, info = i, path = p, typ = ref t },
621                         tr)
622                    end
623                  | v #"2" =
624                    let val n = symbol ()
625                        val (ol, oltr) = overldlist' ()
626                        val ar = int ()
627                        val (b, btr) = ty' ()
628                    in
629                        (V.OVLDvar { name = n,
630                                     options = ref ol,
631                                     scheme = T.TYFUN { arity = ar, body = b } },
632                         branch [oltr, btr])
633                    end
634                  | v #"3" = (V.ERRORvar, notree)
635                | v _ = raise Format                | v _ = raise Format
636          in          in
637              share vM v              share vM v
638          end          end
639    
640          and overld () = let          and overld' () = let
641              fun ov #"o" = { indicator = ty (), variant = var () }              fun ov #"o" =
642                    let val (t, ttr) = ty' ()
643                        val (v, vtr) = var' ()
644                    in
645                        ({ indicator = t, variant = v },
646                         branch [ttr, vtr])
647                    end
648                | ov _ = raise Format                | ov _ = raise Format
649          in          in
650              share overldM ov              share overldM ov
651          end          end
652    
653          and overldlist () = list olListM overld ()          and overldlist' () = let
654                val (l, trl) = ListPair.unzip (list olListM overld' ())
655            in
656                (l, branch trl)
657            end
658    
659          fun strDef () = let          fun strDef () = let
660              fun sd #"C" = M.CONSTstrDef (Structure ())              fun sd #"C" = M.CONSTstrDef (Structure ())
# Line 568  Line 664 
664              share sdM sd              share sdM sd
665          end          end
666    
667          and Signature () = let          and Signature' () = let
668              fun sg #"A" = M.ERRORsig              fun sg #"A" = (M.ERRORsig, notree)
669                | sg #"B" = lookSIG (modId ())                | sg #"B" =
670                | sg #"C" = M.SIG { name = symboloption (),                  let val sr = lookSig (libModSpec (), sigId ())
671                                    closed = bool (),                  in
672                                    fctflag = bool (),                      (M.SIG sr, M.SIGNODE sr)
673                                    stamp = stamp (),                  end
674                                    symbols = symbollist (),                | sg #"C" =
675                                    elements = list elementsM                  let val s = stamp ()
676                                              (pair symSpecPM (symbol, spec)) (),                      val n = symboloption ()
677                                    boundeps =                      val c = bool ()
678                                      ref (option bepsOM                      val ff = bool ()
679                        val sl = symbollist ()
680                        val (el, eltrl) =
681                            ListPair.unzip
682                                (map (fn (sy, (sp, tr)) => ((sy, sp), tr))
683                                     (list elementsM
684                                      (pair symSpecPM (symbol, spec')) ()))
685                        val beps = option bepsOM
686                                           (list bepsLM                                           (list bepsLM
687                                            (pair epTkPM (entPath, tkind))) ()),                                              (pair epTkPM (entPath, tkind))) ()
688                        val ts = spathlistlist ()
689                        val ss = spathlistlist ()
690                        val r = { stamp = s,
691                                  name = n,
692                                  closed = c,
693                                  fctflag = ff,
694                                  symbols = sl,
695                                  elements = el,
696                                  boundeps = ref beps,
697                                    lambdaty = ref NONE,                                    lambdaty = ref NONE,
698                                    typsharing = spathlistlist (),                                typsharing = ts,
699                                    strsharing = spathlistlist () }                                strsharing = ss,
700                | sg #"D" = lookSIGp (modId ())                                stub = SOME { owner = if lib then pid ()
701                | sg #"E" = lookSIGn (stringlist (), symbol (), modId ())                                                      else globalPid (),
702                                                tree = branch eltrl,
703                                                lib = lib } }
704                    in
705                        (M.SIG r, M.SIGNODE r)
706                    end
707                | sg _ = raise Format                | sg _ = raise Format
708          in          in
709              share sigM sg              share sigM sg
710          end          end
711    
712          and fctSig () = let          and Signature () = #1 (Signature' ())
713              fun fsg #"a" = M.ERRORfsig  
714                | fsg #"b" = lookFSIG (modId ())          and fctSig' () = let
715                | fsg #"c" = M.FSIG { kind = symboloption (),              fun fsg #"a" = (M.ERRORfsig, notree)
716                                      paramsig = Signature (),                | fsg #"c" =
717                                      paramvar = entVar (),                  let val k = symboloption ()
718                                      paramsym = symboloption (),                      val (ps, pstr) = Signature' ()
719                                      bodysig = Signature () }                      val pv = entVar ()
720                | fsg #"d" = lookFSIGp (modId ())                      val psy = symboloption ()
721                | fsg #"e" = lookFSIGn (stringlist (), symbol (), modId ())                      val (bs, bstr) = Signature' ()
722                    in
723                        (M.FSIG { kind = k, paramsig = ps,
724                                  paramvar = pv, paramsym = psy,
725                                  bodysig = bs },
726                         branch [pstr, bstr])
727                    end
728                | fsg _ = raise Format                | fsg _ = raise Format
729          in          in
730              share fsigM fsg              share fsigM fsg
731          end          end
732    
733          and spec () = let          and spec' () = let
734              val intoption = option ioM int              val intoption = option ioM int
735              fun sp #"1" = M.TYCspec { spec = tycon (), entVar = entVar (),              fun sp #"1" =
736                                        repl = bool (), scope = int () }                  let val (t, ttr) = tycon' ()
737                | sp #"2" = M.STRspec { sign = Signature (), slot = int (),                  in
738                        (M.TYCspec { spec = t, entVar = entVar (),
739                                     repl = bool (), scope = int () },
740                         ttr)
741                    end
742                  | sp #"2" =
743                    let val (s, str) = Signature' ()
744                    in
745                        (M.STRspec { sign = s, slot = int (),
746                                        def = option spDefM                                        def = option spDefM
747                                                 (pair sdIntPM (strDef, int)) (),                                                 (pair sdIntPM (strDef, int)) (),
748                                        entVar = entVar () }                                   entVar = entVar () },
749                | sp #"3" = M.FCTspec { sign = fctSig (), slot = int (),                       str)
750                                        entVar = entVar () }                  end
751                | sp #"4" = M.VALspec { spec = ty (), slot = int () }                | sp #"3" =
752                | sp #"5" = M.CONspec { spec = datacon (), slot = intoption () }                  let val (f, ftr) = fctSig' ()
753                    in
754                        (M.FCTspec { sign = f, slot = int (), entVar = entVar () },
755                         ftr)
756                    end
757                  | sp #"4" =
758                    let val (t, ttr) = ty' ()
759                    in
760                        (M.VALspec { spec = t, slot = int () }, ttr)
761                    end
762                  | sp #"5" =
763                    let val (d, dtr) = datacon' ()
764                    in
765                        (M.CONspec { spec = d, slot = intoption () }, dtr)
766                    end
767                | sp _ = raise Format                | sp _ = raise Format
768          in          in
769              share spM sp              share spM sp
770          end          end
771    
772          and entity () = let          and entity' () = let
773              fun en #"A" = M.TYCent (tycEntity ())              fun en #"A" = & M.TYCent (tycEntity' ())
774                | en #"B" = M.STRent (strEntity ())                | en #"B" = & M.STRent (strEntity' ())
775                | en #"C" = M.FCTent (fctEntity ())                | en #"C" = & M.FCTent (fctEntity' ())
776                | en #"D" = M.ERRORent                | en #"D" = (M.ERRORent, notree)
777                | en _ = raise Format                | en _ = raise Format
778          in          in
779              share enM en              share enM en
780          end          end
781    
782          and fctClosure () = let          and fctClosure' () = let
783              fun f #"f" =M.CLOSURE { param = entVar (), body = strExp (),              fun f #"f" =
784                                      env = entityEnv () }                  let val p = entVar ()
785                        val (b, btr) = strExp' ()
786                        val (e, etr) = entityEnv' ()
787                    in
788                        (M.CLOSURE { param = p, body = b, env = e },
789                         branch [btr, etr])
790                    end
791                | f _ = raise Format                | f _ = raise Format
792          in          in
793              share fctcM f              share fctcM f
794          end          end
795    
796          and Structure () = let          (* The construction of the STRNODE in the modtree deserves some
797              fun stracc (M.STR { sign, rlzn, info, ... }) =           * comment:  Even though it contains the whole strrec, it does
798                  M.STR { sign = sign, rlzn = rlzn, info = info,           * _not_ take care of the Signature contained therein.  The reason
799                          access = access () }           * why STRNODE has the whole strrec and not just the strEntity that
800                | stracc _ = raise Format           * it really guards is that the identity of the strEntity is not
801              fun str #"A" = M.STRSIG { sign = Signature (),           * fully recoverable without also having access to the Signature.
802                                        entPath = entPath () }           * The same situation occurs in the case of FCTNODE. *)
803                | str #"B" = M.ERRORstr          and Structure' () = let
804                | str #"C" = stracc (lookSTR (modId ()))              fun str #"A" =
805                | str #"D" = M.STR { sign = Signature (), rlzn = strEntity (),                  let val (s, str) = Signature' ()
806                                     access = access (), info = inl_info () }                  in
807                | str #"I" = stracc (lookSTRp (modId ()))                      (M.STRSIG { sign = s, entPath = entPath () }, str)
808                | str #"J" = stracc (lookSTRn (stringlist (), symbol (), modId ()))                  end
809                  | str #"B" = (M.ERRORstr, notree)
810                  | str #"C" =
811                    let val (s, str) = Signature' ()
812                        val r = { sign = s,
813                                  rlzn = lookStr (libModSpec (), strId ()),
814                                  access = access (),
815                                  info = inl_info () }
816                    in
817                        (M.STR r, branch [str, M.STRNODE r])
818                    end
819                  | str #"D" =
820                    let val (s, str) = Signature' ()
821                        val r = { sign = s,
822                                  rlzn = strEntity (),
823                                  access = access (),
824                                  info = inl_info () }
825                    in
826                        (M.STR r, branch [str, M.STRNODE r])
827                    end
828                | str _ = raise Format                | str _ = raise Format
829          in          in
830              share strM str              share strM str
831          end          end
832    
833          and Functor () = let          and Structure () = #1 (Structure' ())
834              fun fctacc (M.FCT { sign, rlzn, info, ... }) =  
835                  M.FCT { sign = sign, rlzn = rlzn, info = info,          (* See the comment about STRNODE, strrec, Signature, and strEntity
836                          access = access () }           * in front of Structure'.  The situation for FCTNODE, fctrec,
837                | fctacc _ = raise Format           * fctSig, and fctEntity is analogous. *)
838              fun fct #"E" = M.ERRORfct          and Functor' () = let
839                | fct #"F" = fctacc (lookFCT (modId ()))              fun fct #"E" = (M.ERRORfct, notree)
840                | fct #"G" = M.FCT { sign = fctSig (), rlzn = fctEntity (),                | fct #"F" =
841                                     access = access (), info = inl_info () }                  let val (s, str) = fctSig' ()
842                | fct #"H" = fctacc (lookFCTp (modId ()))                      val r = { sign = s,
843                | fct #"I" = fctacc (lookFCTn (stringlist (), symbol (),                                rlzn = lookFct (libModSpec (), fctId ()),
844                                               modId ()))                                access = access (),
845                                  info = inl_info () }
846                    in
847                        (M.FCT r, branch [str, M.FCTNODE r])
848                    end
849                  | fct #"G" =
850                    let val (s, str) = fctSig' ()
851                        val r = { sign = s,
852                                  rlzn = fctEntity (),
853                                  access = access (),
854                                  info = inl_info () }
855                    in
856                        (M.FCT r, branch [str, M.FCTNODE r])
857                    end
858                | fct _ = raise Format                | fct _ = raise Format
859          in          in
860              share fctM fct              share fctM fct
861          end          end
862    
863          and stampExp () = let          and stampExp () = let
864              fun ste #"a" = M.CONST (stamp ())              fun ste #"b" = M.GETSTAMP (strExp ())
               | ste #"b" = M.GETSTAMP (strExp ())  
865                | ste #"c" = M.NEW                | ste #"c" = M.NEW
866                | ste _ = raise Format                | ste _ = raise Format
867          in          in
868              share steM ste              share steM ste
869          end          end
870    
871          and tycExp () = let          and tycExp' () = let
872              fun tce #"d" = M.CONSTtyc (tycon ())              fun tce #"d" = & M.CONSTtyc (tycon' ())
873                | tce #"e" = M.FORMtyc (tycon ())                | tce #"e" = (M.FORMtyc (tycon ()), notree) (* ? *)
874                | tce #"f" = M.VARtyc (entPath ())                | tce #"f" = (M.VARtyc (entPath ()), notree)
875                | tce _ = raise Format                | tce _ = raise Format
876          in          in
877              share tceM tce              share tceM tce
878          end          end
879    
880          and strExp () = let          and tycExp () = #1 (tycExp' ())
881              fun stre #"g" = M.VARstr (entPath ())  
882                | stre #"h" = M.CONSTstr (strEntity ())          and strExp' () = let
883                | stre #"i" = M.STRUCTURE { stamp = stampExp (),              fun stre #"g" = (M.VARstr (entPath ()), notree)
884                                            entDec = entityDec () }                | stre #"h" = & M.CONSTstr (strEntity' ())
885                | stre #"j" = M.APPLY (fctExp (), strExp ())                | stre #"i" =
886                | stre #"k" = M.LETstr (entityDec (), strExp ())                  let val s = stampExp ()
887                | stre #"l" = M.ABSstr (Signature (), strExp ())                      val (d, dtr) = entityDec' ()
888                | stre #"m" = M.CONSTRAINstr { boundvar = entVar (),                  in
889                                               raw = strExp (),                      (M.STRUCTURE { stamp = s, entDec = d }, dtr)
890                                               coercion = strExp () }                  end
891                | stre #"n" = M.FORMstr (fctSig ())                | stre #"j" =
892                    let val (f, ftr) = fctExp' ()
893                        val (s, str) = strExp' ()
894                    in
895                        (M.APPLY (f, s), branch [ftr, str])
896                    end
897                  | stre #"k" =
898                    let val (d, dtr) = entityDec' ()
899                        val (s, str) = strExp' ()
900                    in
901                        (M.LETstr (d, s), branch [dtr, str])
902                    end
903                  | stre #"l" =
904                    let val (s, str) = Signature' ()
905                        val (e, etr) = strExp' ()
906                    in
907                        (M.ABSstr (s, e), branch [str, etr])
908                    end
909                  | stre #"m" =
910                    let val bv = entVar ()
911                        val (r, rtr) = strExp' ()
912                        val (c, ctr) = strExp' ()
913                    in
914                        (M.CONSTRAINstr { boundvar = bv, raw = r, coercion = c },
915                         branch [rtr, ctr])
916                    end
917                  | stre #"n" = & M.FORMstr (fctSig' ())
918                | stre _ = raise Format                | stre _ = raise Format
919          in          in
920              share streM stre              share streM stre
921          end          end
922    
923          and fctExp () = let          and strExp () = #1 (strExp' ())
924              fun fe #"o" = M.VARfct (entPath ())  
925                | fe #"p" = M.CONSTfct (fctEntity ())          and fctExp' () = let
926                | fe #"q" = M.LAMBDA { param = entVar (), body = strExp () }              fun fe #"o" = (M.VARfct (entPath ()), notree)
927                | fe #"r" = M.LAMBDA_TP { param = entVar (), body = strExp (),                | fe #"p" = & M.CONSTfct (fctEntity' ())
928                                          sign = fctSig () }                | fe #"q" =
929                | fe #"s" = M.LETfct (entityDec (), fctExp ())                  let val p = entVar ()
930                        val (b, btr) = strExp' ()
931                    in
932                        (M.LAMBDA { param = p, body = b }, btr)
933                    end
934                  | fe #"r" =
935                    let val p = entVar ()
936                        val (b, btr) = strExp' ()
937                        val (s, str) = fctSig' ()
938                    in
939                        (M.LAMBDA_TP { param = p, body = b, sign = s },
940                         branch [btr, str])
941                    end
942                  | fe #"s" =
943                    let val (d, dtr) = entityDec' ()
944                        val (f, ftr) = fctExp' ()
945                    in
946                        (M.LETfct (d, f), branch [dtr, ftr])
947                    end
948                | fe _ = raise Format                | fe _ = raise Format
949          in          in
950              share feM fe              share feM fe
951          end          end
952    
953            and fctExp () = #1 (fctExp' ())
954    
955          and entityExp () = let          and entityExp () = let
956              fun ee #"t" = M.TYCexp (tycExp ())              fun ee #"t" = M.TYCexp (tycExp ())
957                | ee #"u" = M.STRexp (strExp ())                | ee #"u" = M.STRexp (strExp ())
# Line 735  Line 963 
963              share eeM ee              share eeM ee
964          end          end
965    
966          and entityDec () = let          and entityDec' () = let
967              fun ed #"A" = M.TYCdec (entVar (), tycExp ())              fun ed #"A" =
968                | ed #"B" = M.STRdec (entVar (), strExp (), symbol ())                  let val v = entVar ()
969                | ed #"C" = M.FCTdec (entVar (), fctExp ())                      val (e, etr) = tycExp' ()
970                | ed #"D" = M.SEQdec (entityDecList ())                  in
971                | ed #"E" = M.LOCALdec (entityDec (), entityDec ())                      (M.TYCdec (v, e), etr)
972                | ed #"F" = M.ERRORdec                  end
973                | ed #"G" = M.EMPTYdec                | ed #"B" =
974                    let val v = entVar ()
975                        val (e, etr) = strExp' ()
976                        val s = symbol ()
977                    in
978                        (M.STRdec (v, e, s), etr)
979                    end
980                  | ed #"C" =
981                    let val v = entVar ()
982                        val (e, etr) = fctExp' ()
983                    in
984                        (M.FCTdec (v, e), etr)
985                    end
986                  | ed #"D" = & M.SEQdec (entityDecList' ())
987                  | ed #"E" =
988                    let val (d1, d1tr) = entityDec' ()
989                        val (d2, d2tr) = entityDec' ()
990                    in
991                        (M.LOCALdec (d1, d2), branch [d1tr, d2tr])
992                    end
993                  | ed #"F" = (M.ERRORdec, notree)
994                  | ed #"G" = (M.EMPTYdec, notree)
995                | ed _ = raise Format                | ed _ = raise Format
996          in          in
997              share edM ed              share edM ed
998          end          end
999    
1000          and entityDecList () = list edListM entityDec ()          and entityDecList' () = let
1001                val (l, trl) = ListPair.unzip (list edListM entityDec' ())
1002            in
1003                (l, branch trl)
1004            end
1005    
1006          and entityEnv () = let          and entityEnv' () = let
1007              fun eenv #"A" =              fun eenv #"A" =
1008                  let                  let val l = list eenvBindM (pair evEntPM (entVar, entity')) ()
1009                      val l = list eenvBindM (pair evEntPM (entVar, entity)) ()                      val l' = map (fn (v, (e, tr)) => ((v, e), tr)) l
1010                        val (l'', trl) = ListPair.unzip l'
1011                      fun add ((v, e), z) = ED.insert (z, v, e)                      fun add ((v, e), z) = ED.insert (z, v, e)
1012                      val ed = foldr add ED.empty l                      val ed = foldr add ED.empty l''
1013                        val (e, etr) = entityEnv' ()
1014                  in                  in
1015                      M.BINDeenv (ed, entityEnv ())                      (M.BINDeenv (ed, e), branch (etr :: trl))
1016                    end
1017                  | eenv #"B" = (M.NILeenv, notree)
1018                  | eenv #"C" = (M.ERReenv, notree)
1019                  | eenv #"D" =
1020                    let val r = lookEnv (libModSpec (), envId ())
1021                    in
1022                        (M.MARKeenv r, M.ENVNODE r)
1023                    end
1024                  | eenv #"E" =
1025                    let val s = stamp ()
1026                        val (e, etr) = entityEnv' ()
1027                        val r = { stamp = s,
1028                                  env = e,
1029                                  stub = SOME { owner = if lib then pid ()
1030                                                        else globalPid (),
1031                                                tree = etr,
1032                                                lib = lib } }
1033                    in
1034                        (M.MARKeenv r, M.ENVNODE r)
1035                  end                  end
               | eenv #"B" = M.NILeenv  
               | eenv #"C" = M.ERReenv  
               | eenv #"D" = lookEENV (modId ())  
               | eenv #"E" = M.MARKeenv (stamp (), entityEnv ())  
               | eenv #"F" = lookEENVp (modId ())  
               | eenv #"G" = lookEENVn (stringlist (), symbol (), modId ())  
1036                | eenv _ = raise Format                | eenv _ = raise Format
1037          in          in
1038              share eenvM eenv              share eenvM eenv
1039          end          end
1040    
1041          and strEntity () = let          and strEntity' () = let
1042              fun s #"s" =              fun s #"s" =
1043                  { stamp = stamp (), entities = entityEnv (), rpath = ipath (),                  let val s = stamp ()
1044                    lambdaty = ref NONE }                      val (e, etr) = entityEnv' ()
1045                    in
1046                        ({ stamp = s,
1047                           entities = e,
1048                           rpath = ipath (),
1049                           lambdaty = ref NONE,
1050                           stub = SOME { owner = if lib then pid ()
1051                                                 else globalPid (),
1052                                         tree = etr,
1053                                         lib = lib } },
1054                         etr)
1055                    end
1056                | s _ = raise Format                | s _ = raise Format
1057          in          in
1058              share senM s              share senM s
1059          end          end
1060    
1061          and fctEntity () = let          and strEntity () = #1 (strEntity' ())
1062    
1063            and fctEntity' () = let
1064              fun f #"f" =              fun f #"f" =
1065                  { stamp = stamp (), closure = fctClosure (), rpath = ipath (),                  let val s = stamp ()
1066                    lambdaty = ref NONE, tycpath = NONE }                      val (c, ctr) = fctClosure' ()
1067                    in
1068                        ({ stamp = s,
1069                           closure = c,
1070                           rpath = ipath (),
1071                           lambdaty = ref NONE,
1072                           tycpath = NONE,
1073                           stub = SOME { owner = if lib then pid ()
1074                                                 else globalPid (),
1075                                         tree = ctr,
1076                                         lib = lib } },
1077                         ctr)
1078                    end
1079                | f _ = raise Format                | f _ = raise Format
1080          in          in
1081              share fenM f              share fenM f
1082          end          end
1083    
1084          and tycEntity () = tycon ()          and fctEntity () = #1 (fctEntity' ())
1085    
1086            and tycEntity' () = tycon' ()
1087    
1088          fun fixity () = let          fun fixity () = let
1089              fun fx #"N" = Fixity.NONfix              fun fx #"N" = Fixity.NONfix
# Line 798  Line 1093 
1093              share fxM fx              share fxM fx
1094          end          end
1095    
1096          fun binding () = let          fun binding' () = let
1097              fun b #"1" = B.VALbind (var ())              fun b #"1" = & B.VALbind (var' ())
1098                | b #"2" = B.CONbind (datacon ())                | b #"2" = & B.CONbind (datacon' ())
1099                | b #"3" = B.TYCbind (tycon ())                | b #"3" = & B.TYCbind (tycon' ())
1100                | b #"4" = B.SIGbind (Signature ())                | b #"4" = & B.SIGbind (Signature' ())
1101                | b #"5" = B.STRbind (Structure ())                | b #"5" = & B.STRbind (Structure' ())
1102                | b #"6" = B.FSGbind (fctSig ())                | b #"6" = & B.FSGbind (fctSig' ())
1103                | b #"7" = B.FCTbind (Functor ())                | b #"7" = & B.FCTbind (Functor' ())
1104                | b #"8" = B.FIXbind (fixity ())                | b #"8" = (B.FIXbind (fixity ()), notree)
1105                | b _ = raise Format                | b _ = raise Format
1106          in          in
1107              share bM b              share bM b
1108          end          end
1109    
1110          fun env () = let          fun env () = let
1111              val bindlist = list envM (pair symBindPM (symbol, binding)) ()              val bindlist = list envM (pair symBindPM (symbol, binding')) ()
1112              fun bind ((s, b), e) = Env.bind (s, b, e)              fun bind ((s, (b, t)), e) = StaticEnv.bind0 (s, (b, SOME t), e)
1113            in
1114                Env.consolidate (foldl bind StaticEnv.empty bindlist)
1115            end
1116          in          in
1117              Env.consolidate (foldl bind Env.empty bindlist)          env
1118          end          end
1119    
1120          fun env' () = let      fun unpickleEnv context (hash, pickle) = let
             val (e, mil) = pair envMilPM (env, list milM modId) ()  
             val ctxt = ModuleId.Set.addList (ModuleId.Set.empty, mil)  
         in  
             { env = e, ctxt = ctxt }  
         end  
     in  
         { envUnpickler = env, envUnpickler' = env' }  
     end  
   
     fun unpickleEnv { context, hash, pickle } = let  
         val cs = ref ModuleId.Set.empty  
         fun cvt lk i =  
             case lk context i of  
                 SOME v => (cs := ModuleId.Set.add (!cs, i); v)  
               | NONE => raise Format  
         fun dont _ = raise Format  
         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,  
                   lookSTRp = dont,  
                   lookSIGp = dont,  
                   lookFCTp = dont,  
                   lookFSIGp = dont,  
                   lookTYCp = dont,  
                   lookEENVp = dont,  
                   lookSTRn = dont,  
                   lookSIGn = dont,  
                   lookFCTn = dont,  
                   lookFSIGn = dont,  
                   lookTYCn = dont,  
                   lookEENVn = dont }  
1121          val session =          val session =
1122              UU.mkSession (UU.stringGetter (Byte.bytesToString pickle))              UU.mkSession (UU.stringGetter (Byte.bytesToString pickle))
1123          fun import i = A.PATH (A.EXTERN hash, i)          fun import i = A.PATH (A.EXTERN hash, i)
1124          val sharedStuff as { symbol, string, ... } =          val slM = UU.mkMap ()
1125              mkSharedStuff (session, import)          val sloM = UU.mkMap ()
1126          val symbolListM = UU.mkMap ()          val sylM = UU.mkMap ()
1127          val symbollist = UU.r_list session symbolListM symbol          val sharedStuff = mkSharedStuff (session, import)
1128          val stringListM = UU.mkMap ()          val stringlist = UU.r_list session slM (#string sharedStuff)
1129          val stringlist = UU.r_list session stringListM string          val symbollist = UU.r_list session sylM (#symbol sharedStuff)
1130          val { envUnpickler, ... } =          val extraInfo = { globalPid = fn () => hash,
1131              mkEnvUnpickler (session, symbollist, stringlist, sharedStuff,                            symbollist = symbollist,
1132                              c, fn () => hash)                            sharedStuff = sharedStuff,
1133                              lib = false }
1134            val sessionInfo = { session = session, stringlist = stringlist }
1135            val unpickle = mkEnvUnpickler extraInfo sessionInfo context
1136      in      in
1137          (* order of evaluation is important here! *)          unpickle ()
         { env = envUnpickler (), ctxt = !cs }  
1138      end      end
1139    
1140      fun mkFlintUnpickler (session, sharedStuff) = let      fun mkFlintUnpickler (session, sharedStuff) = let
# Line 1107  Line 1373 
1373          UU.r_option session foM flint ()          UU.r_option session foM flint ()
1374      end      end
1375    
1376      fun mkUnpicklers session contexts = let      fun mkUnpicklers sessionInfo context = let
1377          val { prim_context, node_context, stringlist } = contexts          val { session, stringlist } = sessionInfo
1378          fun cvtP lk id =          val sharedStuff = mkSharedStuff (session, A.LVAR)
1379              case lk prim_context id of          val { symbol, pid, ... } = sharedStuff
1380                  SOME v => v          val sylM = UU.mkMap ()
1381                | NONE => raise Format          val symbollist = UU.r_list session sylM symbol
1382          fun cvtN lk (sl, s, id) =          val extraInfo = { globalPid = fn () => raise Format,
1383              case node_context (sl, s) of                            symbollist = symbollist,
1384                  NONE => raise Format                            sharedStuff = sharedStuff,
1385                | SOME e => (case lk e id of SOME v => v | NONE => raise Format)                            lib = true }
1386          fun dont i = raise Format          val statenv = mkEnvUnpickler extraInfo sessionInfo context
         val c = { lookSTRn = cvtN CMStaticEnv.lookSTR,  
                   lookSIGn = cvtN CMStaticEnv.lookSIG,  
                   lookFCTn = cvtN CMStaticEnv.lookFCT,  
                   lookFSIGn = cvtN CMStaticEnv.lookFSIG,  
                   lookTYCn = cvtN CMStaticEnv.lookTYC,  
                   lookEENVn = cvtN CMStaticEnv.lookEENV,  
                   lookSTRp = cvtP CMStaticEnv.lookSTR,  
                   lookSIGp = cvtP CMStaticEnv.lookSIG,  
                   lookFCTp = cvtP CMStaticEnv.lookFCT,  
                   lookFSIGp = cvtP CMStaticEnv.lookFSIG,  
                   lookTYCp = cvtP CMStaticEnv.lookTYC,  
                   lookEENVp = cvtP CMStaticEnv.lookEENV,  
                   lookSTR = dont,  
                   lookSIG = dont,  
                   lookFCT = dont,  
                   lookFSIG = dont,  
                   lookTYC = dont,  
                   lookEENV = dont }  
         val sharedStuff as { symbol, pid, ... } =  
             mkSharedStuff (session, A.LVAR)  
         val symbolListM = UU.mkMap ()  
         val symbollist = UU.r_list session symbolListM symbol  
         val { envUnpickler', ... } =  
             mkEnvUnpickler (session, symbollist, stringlist, sharedStuff,  
                             c, fn () => raise Format)  
1387          val flint = mkFlintUnpickler (session, sharedStuff)          val flint = mkFlintUnpickler (session, sharedStuff)
1388          val pidFlintPM = UU.mkMap ()          val pidFlintPM = UU.mkMap ()
1389          val symbind = UU.r_pair session pidFlintPM (pid, flint)          val symbind = UU.r_pair session pidFlintPM (pid, flint)
1390          val sblM = UU.mkMap ()          val sblM = UU.mkMap ()
1391          val sbl = UU.r_list session sblM symbind          val sbl = UU.r_list session sblM symbind
1392          fun symenvUnpickler () = SymbolicEnv.fromListi (sbl ())          fun symenv () = SymbolicEnv.fromListi (sbl ())
1393      in      in
1394          { symenv = symenvUnpickler, env = envUnpickler',          { symenv = symenv, statenv = statenv,
1395            symbol = symbol, symbollist = symbollist }            symbol = symbol, symbollist = symbollist }
1396      end      end
1397    
1398      val unpickleEnv =      val unpickleEnv =
1399          Stats.doPhase (Stats.makePhase "Compiler 087 unpickleEnv") unpickleEnv          fn c => Stats.doPhase (Stats.makePhase "Compiler 087 unpickleEnv")
1400                                  (unpickleEnv c)
1401  end  end

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

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