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 427, Wed Sep 8 09:40:08 1999 UTC revision 774, Wed Jan 10 12:50:56 2001 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     * The embedding of modtrees into static environments follows the example
13     * of the control-flow in the original "cmstatenv.sml" module.  This means
14     * that not all possible branches of the environment data structure are
15     * explored when building modmaps.  I dearly hope that the original code
16     * was correct in its assumptions...
17     *
18     * March 2000, Matthias Blume
19   *)   *)
20  signature UNPICKMOD = sig  signature UNPICKMOD = sig
21    
22      val unpickleEnv :      type context = (int * Symbol.symbol) option -> ModuleId.tmap
23          { context: CMStaticEnv.staticEnv,  
24            hash: PersStamps.persstamp,      val unpickleEnv : context ->
25            pickle: Word8Vector.vector }                        PersStamps.persstamp * Word8Vector.vector ->
26          -> StaticEnv.staticEnv                        StaticEnv.staticEnv
27    
28      val unpickleFLINT : Word8Vector.vector -> CompBasic.flint option      val unpickleFLINT : Word8Vector.vector -> CompBasic.flint option
29    
30      (*      (* The env unpickler resulting from "mkUnpicklers" cannot be used for
      * The env unpickler resulting from "mkUnpicklers" cannot be used for  
31       * "original" environments that come out of the elaborator.  For those,       * "original" environments that come out of the elaborator.  For those,
32       * continue to use "unpickleEnv".  "mkUnpicklers" is intended to be       * continue to use "unpickleEnv".  "mkUnpicklers" is intended to be
33       * used by CM's stable library mechanism.       * used by CM's stable library mechanism. *)
      *)  
34      val mkUnpicklers :      val mkUnpicklers :
35          UnpickleUtil.session ->          { session: UnpickleUtil.session,
36          { prim_context: string -> CMStaticEnv.staticEnv option,            stringlist: string list UnpickleUtil.reader } ->
37            node_context: int * Symbol.symbol -> CMStaticEnv.staticEnv option }          context ->
38          -> { symenv: SymbolicEnv.symenv UnpickleUtil.reader,          { symenv: SymbolicEnv.symenv UnpickleUtil.reader,
39               env: StaticEnv.staticEnv UnpickleUtil.reader,            statenv: StaticEnv.staticEnv UnpickleUtil.reader,
40               symbol: Symbol.symbol UnpickleUtil.reader,               symbol: Symbol.symbol UnpickleUtil.reader,
41               symbollist: Symbol.symbol list UnpickleUtil.reader }               symbollist: Symbol.symbol list UnpickleUtil.reader }
42  end  end
43    
44  structure UnpickMod : UNPICKMOD = struct  structure UnpickMod : UNPICKMOD = struct
45    
46        type context = (int * Symbol.symbol) option -> ModuleId.tmap
47    
48      structure A = Access      structure A = Access
49      structure DI = DebIndex      structure DI = DebIndex
50      structure LT = LtyDef      structure LT = LtyDef
# Line 117  Line 131 
131            P.GET_SEQ_DATA,            P.GET_SEQ_DATA,
132            P.SUBSCRIPT_REC,            P.SUBSCRIPT_REC,
133            P.SUBSCRIPT_RAW64,            P.SUBSCRIPT_RAW64,
134            P.UNBOXEDASSIGN]            P.UNBOXEDASSIGN,
135              P.RAW_CCALL NONE]
136    
137      val cmpop_table =      val cmpop_table =
138          #[P.>, P.>=, P.<, P.<=, P.LEU, P.LTU, P.GEU, P.GTU, P.EQL, P.NEQ]          #[P.>, P.>=, P.<, P.<=, P.LEU, P.LTU, P.GEU, P.GTU, P.EQL, P.NEQ]
139    
140      val arithop_table =      val arithop_table =
141          #[P.+, P.-, P.*, P./, P.~, P.ABS, P.LSHIFT, P.RSHIFT, P.RSHIFTL,          #[P.+, P.-, P.*, P./, P.~, P.ABS, P.LSHIFT, P.RSHIFT, P.RSHIFTL,
142            P.ANDB, P.ORB, P.XORB, P.NOTB]            P.ANDB, P.ORB, P.XORB, P.NOTB, P.FSQRT, P.FSIN, P.FCOS, P.FTAN]
143    
144      val eqprop_table =      val eqprop_table =
145          #[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]
146    
147        val ctype_table =
148            #[CTypes.C_void,
149              CTypes.C_float,
150              CTypes.C_double,
151              CTypes.C_long_double,
152              CTypes.C_unsigned CTypes.I_char,
153              CTypes.C_unsigned CTypes.I_short,
154              CTypes.C_unsigned CTypes.I_int,
155              CTypes.C_unsigned CTypes.I_long,
156              CTypes.C_unsigned CTypes.I_long_long,
157              CTypes.C_signed CTypes.I_char,
158              CTypes.C_signed CTypes.I_short,
159              CTypes.C_signed CTypes.I_int,
160              CTypes.C_signed CTypes.I_long,
161              CTypes.C_signed CTypes.I_long_long,
162              CTypes.C_PTR]
163    
164        fun & c (x, t) = (c x, t)
165    
166        fun branch l = let
167            fun loop ([], [x]) = x
168              | loop ([], l) = M.BRANCH l
169              | loop (M.BRANCH [] :: t, l) = loop (t, l)
170              | loop (M.BRANCH [x] :: t, l) = loop (t, x :: l) (* never occurs! *)
171              | loop (x :: t, l) = loop (t, x :: l)
172        in
173            loop (l, [])
174        end
175    
176        val notree = M.BRANCH []
177    
178      fun mkSharedStuff (session, lvar) = let      fun mkSharedStuff (session, lvar) = let
179    
180          fun share m f = UU.share session m f          fun share m f = UU.share session m f
# Line 137  Line 183 
183          val int = UU.r_int session          val int = UU.r_int session
184          val bool = UU.r_bool session          val bool = UU.r_bool session
185          fun list m r = UU.r_list session m r          fun list m r = UU.r_list session m r
186            fun option m r = UU.r_option session m r
187          val string = UU.r_string session          val string = UU.r_string session
188          val symbol = UnpickleSymPid.r_symbol (session, string)          val symbol = UnpickleSymPid.r_symbol (session, string)
189    
# Line 145  Line 192 
192          val accM = UU.mkMap ()          val accM = UU.mkMap ()
193          val crM = UU.mkMap ()          val crM = UU.mkMap ()
194          val csM = UU.mkMap ()          val csM = UU.mkMap ()
         val ltyM = UU.mkMap ()  
         val ltyListM = UU.mkMap ()  
         val tycM = UU.mkMap ()  
         val tycListM = UU.mkMap ()  
         val tkindM = UU.mkMap ()  
         val tkindListM = UU.mkMap ()  
195          val nkM = UU.mkMap ()          val nkM = UU.mkMap ()
196          val poM = UU.mkMap ()          val poM = UU.mkMap ()
197          val boolListM = UU.mkMap ()          val boolListM = UU.mkMap ()
198            val boolOptionM = UU.mkMap ()
199            val tkindM = UU.mkMap ()
200            val tkindListM = UU.mkMap ()
201            val ctypeM = UU.mkMap ()
202            val ctypeListM = UU.mkMap ()
203            val cciM = UU.mkMap ()
204    
205          val boollist = list boolListM bool          val boollist = list boolListM bool
206            val booloption = option boolOptionM bool
207    
208          val pid = UnpickleSymPid.r_pid string          val pid = UnpickleSymPid.r_pid (session, string)
209    
210          fun access () = let          fun access () = let
211              fun a #"A" = lvar (int ())              fun a #"A" = lvar (int ())
# Line 193  Line 241 
241              share csM cs              share csM cs
242          end          end
243    
244          fun lty () = let          fun tkind () = let
             fun lt #"A" = LT.ltc_tyc (tyc ())  
               | lt #"B" = LT.ltc_str (ltylist ())  
               | lt #"C" = LT.ltc_fct (ltylist (), ltylist ())  
               | lt #"D" = LT.ltc_poly (tkindlist (), ltylist ())  
               | lt _ = raise Format  
         in  
             share ltyM lt  
         end  
   
         and ltylist () = list ltyListM lty ()  
   
         and tyc () = let  
             fun tc #"A" = LT.tcc_var (DI.di_fromint (int ()), int ())  
               | tc #"B" = LT.tcc_nvar (int (), DI.di_fromint (int ()), int ())  
               | tc #"C" = LT.tcc_prim (PT.pt_fromint (int ()))  
               | tc #"D" = LT.tcc_fn (tkindlist (), tyc ())  
               | tc #"E" = LT.tcc_app (tyc (), tyclist ())  
               | tc #"F" = LT.tcc_seq (tyclist ())  
               | tc #"G" = LT.tcc_proj (tyc (), int ())  
               | tc #"H" = LT.tcc_sum (tyclist ())  
               | tc #"I" = LT.tcc_fix ((int (), tyc (), tyclist ()), int ())  
               | tc #"J" = LT.tcc_abs (tyc ())  
               | tc #"K" = LT.tcc_box (tyc ())  
               | tc #"L" = LT.tcc_tuple (tyclist ())  
               | tc #"M" = LT.tcc_arrow (LT.ffc_var (bool (), bool ()),  
                                         tyclist (), tyclist ())  
               | tc #"N" = LT.tcc_arrow (LT.ffc_fixed, tyclist (), tyclist ())  
               | tc #"O" = LK.tc_inj (LK.TC_TOKEN (LK.token_key (int ()),  
                                                   tyc ()))  
               | tc _ = raise Format  
         in  
             share tycM tc  
         end  
   
         and tyclist () = list tycListM tyc ()  
   
         and tkind () = let  
245              fun tk #"A" = LT.tkc_mono              fun tk #"A" = LT.tkc_mono
246                | tk #"B" = LT.tkc_box                | tk #"B" = LT.tkc_box
247                | tk #"C" = LT.tkc_seq (tkindlist ())                | tk #"C" = LT.tkc_seq (tkindlist ())
# Line 267  Line 278 
278              nonshare co              nonshare co
279          end          end
280    
281            fun ctype () = let
282                fun ct #"\020" = CTypes.C_ARRAY (ctype (), int ())
283                  | ct #"\021" = CTypes.C_STRUCT (ctypelist ())
284                  | ct c =
285                    Vector.sub (ctype_table, Char.ord c)
286                    handle General.Subscript => raise Format
287            in
288                share ctypeM ct
289            end
290    
291            and ctypelist () = list ctypeListM ctype ()
292    
293            fun ccall_info () = let
294                fun cp #"C" =
295                    { c_proto = { conv = string (),
296                                  retTy = ctype (),
297                                  paramTys = ctypelist () },
298                      ml_flt_args = boollist (),
299                      ml_flt_res_opt = booloption () }
300                  | cp _ = raise Format
301            in
302                share cciM cp
303            end
304    
305          fun primop () = let          fun primop () = let
306              fun po #"\100" = P.ARITH { oper = arithop (), overflow = bool (),              fun po #"\100" = P.ARITH { oper = arithop (), overflow = bool (),
307                                         kind = numkind () }                                         kind = numkind () }
# Line 290  Line 325 
325                                             checked = bool () }                                             checked = bool () }
326                | po #"\114" = P.INL_MONOARRAY (numkind ())                | po #"\114" = P.INL_MONOARRAY (numkind ())
327                | po #"\115" = P.INL_MONOVECTOR (numkind ())                | po #"\115" = P.INL_MONOVECTOR (numkind ())
328                  | po #"\116" = P.RAW_LOAD (numkind ())
329                  | po #"\117" = P.RAW_STORE (numkind ())
330                  | po #"\118" = P.RAW_CCALL (SOME (ccall_info ()))
331                | po c =                | po c =
332                  Vector.sub (primop_table, Char.ord c)                  Vector.sub (primop_table, Char.ord c)
333                  handle General.Subscript => raise Format                  handle General.Subscript => raise Format
# Line 299  Line 337 
337      in      in
338          { pid = pid, string = string, symbol = symbol,          { pid = pid, string = string, symbol = symbol,
339            access = access, conrep = conrep, consig = consig,            access = access, conrep = conrep, consig = consig,
340            lty = lty, tyc = tyc, tkind = tkind,            primop = primop, boollist = boollist,
341            ltylist = ltylist, tyclist = tyclist,            tkind = tkind, tkindlist = tkindlist }
           primop = primop, boollist = boollist }  
342      end      end
343    
344      fun mkEnvUnpickler arg = let      fun mkEnvUnpickler extraInfo sessionInfo context = let
345          val (session, symbollist, sharedStuff, context0, globalPid) = arg          val { globalPid, symbollist, sharedStuff, lib } = extraInfo
346            val { session, stringlist } = sessionInfo
347          val { lookTYC, lookSIG, lookFSIG, lookSTR, lookFCT, lookEENV,  
348                lookTYCp, lookSIGp, lookFSIGp, lookSTRp, lookFCTp, lookEENVp,          local
349                lookTYCn, lookSIGn, lookFSIGn, lookSTRn, lookFCTn, lookEENVn } =              fun look lk (m, i) =
350              context0                  case lk (context m, i) of
351                        SOME x => x
352                      | NONE =>
353                        (ErrorMsg.impossible "UnpickMod: stub lookup failed";
354                         raise Format)
355            in
356                val lookTyc = look MI.lookTyc
357                val lookSig = look MI.lookSig
358                val lookStr = look MI.lookStr
359                val lookFct = look MI.lookFct
360                val lookEnv = look MI.lookEnv
361            end
362    
363          fun list m r = UU.r_list session m r          fun list m r = UU.r_list session m r
364          fun option m r = UU.r_option session m r          fun option m r = UU.r_option session m r
365          val bool = UU.r_bool session          val bool = UU.r_bool session
366          val pair = UU.r_pair          fun pair m fp p = UU.r_pair session m fp p
367          val int = UU.r_int session          val int = UU.r_int session
368    
369          fun share m f = UU.share session m f          fun share m f = UU.share session m f
# Line 324  Line 372 
372          (* The following maps all acquire different types by being used          (* The following maps all acquire different types by being used
373           * in different contexts: *)           * in different contexts: *)
374          val stampM = UU.mkMap ()          val stampM = UU.mkMap ()
375            val strIdM = UU.mkMap ()
376            val fctIdM = UU.mkMap ()
377          val stampOptionM = UU.mkMap ()          val stampOptionM = UU.mkMap ()
378          val stampListM = UU.mkMap ()          val stampListM = UU.mkMap ()
         val modIdM = UU.mkMap ()  
379          val symbolOptionM = UU.mkMap ()          val symbolOptionM = UU.mkMap ()
380          val symbolListM = UU.mkMap ()          val symbolListM = UU.mkMap ()
381          val spathListM = UU.mkMap ()          val spathListM = UU.mkMap ()
# Line 376  Line 425 
425          val edListM = UU.mkMap ()          val edListM = UU.mkMap ()
426          val eenvBindM = UU.mkMap ()          val eenvBindM = UU.mkMap ()
427          val envM = UU.mkMap ()          val envM = UU.mkMap ()
428            val spathM = UU.mkMap ()
429            val ipathM = UU.mkMap ()
430            val symSpecPM = UU.mkMap ()
431            val epTkPM = UU.mkMap ()
432            val sdIntPM = UU.mkMap ()
433            val evEntPM = UU.mkMap ()
434            val symBindPM = UU.mkMap ()
435            val pidOptionM = UU.mkMap ()
436            val lmsOptM = UU.mkMap ()
437            val lmsPairM = UU.mkMap ()
438    
439          val { pid, string, symbol,          val { pid, string, symbol, access, conrep, consig,
440                access, conrep, consig, lty, tyc, tkind, ltylist, tyclist,                primop, boollist, tkind, tkindlist } = sharedStuff
441                primop, boollist } = sharedStuff  
442            fun libModSpec () = option lmsOptM (pair lmsPairM (int, symbol)) ()
443    
444          fun stamp () = let          fun stamp () = let
445              fun st #"A" = Stamps.STAMP { scope = Stamps.GLOBAL (globalPid ()),              fun st #"A" = Stamps.global { pid = globalPid (),
446                                           count = int () }                                            cnt = int () }
447                | st #"B" = Stamps.STAMP { scope = Stamps.GLOBAL (pid ()),                | st #"B" = Stamps.global { pid = pid (),
448                                           count = int () }                                            cnt = int () }
449                | st #"C" = Stamps.STAMP { scope = Stamps.SPECIAL (string ()),                | st #"C" = Stamps.special (string ())
                                          count = int () }  
450                | st _ = raise Format                | st _ = raise Format
451          in          in
452              share stampM st              share stampM st
453          end          end
454    
455            val tycId = stamp
456            val sigId = stamp
457            fun strId () = let
458                fun si #"D" = { sign = stamp (), rlzn = stamp () }
459                  | si _ = raise Format
460            in
461                share strIdM si
462            end
463            fun fctId () = let
464                fun fi #"E" = { paramsig = stamp (), bodysig = stamp (),
465                                rlzn = stamp () }
466                  | fi _ = raise Format
467            in
468                share fctIdM fi
469            end
470            val envId = stamp
471    
472          val stamplist = list stampListM stamp          val stamplist = list stampListM stamp
473          val stampoption = option stampOptionM stamp          val stampoption = option stampOptionM stamp
474            val pidoption = option pidOptionM pid
475    
476          val entVar = stamp          val entVar = stamp
477          val entVarOption = stampoption          val entVarOption = stampoption
478          val entPath = stamplist          val entPath = stamplist
479    
         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  
   
480          val symbollist = list symbolListM symbol          val symbollist = list symbolListM symbol
481          val symboloption = option symbolOptionM symbol          val symboloption = option symbolOptionM symbol
482    
483          fun spath () = SP.SPATH (symbollist ())          fun spath () = let
484          fun ipath () = IP.IPATH (symbollist ())              fun sp #"s" = SP.SPATH (symbollist ())
485                  | sp _ = raise Format
486            in
487                share spathM sp
488            end
489    
490            fun ipath () = let
491                fun ip #"i" = IP.IPATH (symbollist ())
492                  | ip _ = raise Format
493            in
494                share ipathM ip
495            end
496    
497          val spathlist = list spathListM spath          val spathlist = list spathListM spath
498          val spathlistlist = list spathListListM spathlist          val spathlistlist = list spathListListM spathlist
# Line 433  Line 508 
508              nonshare eqp              nonshare eqp
509          end          end
510    
511          fun datacon () = let          fun datacon' () = let
512              fun d #"c" =              fun d #"c" =
513                  T.DATACON { name = symbol (), const = bool (), typ = ty (),                  let val n = symbol ()
514                              rep = conrep (), sign = consig (),                      val c = bool ()
515                              lazyp = bool () }                      val (t, ttr) = ty' ()
516                        val r = conrep ()
517                        val s = consig ()
518                        val l = bool ()
519                    in
520                        (T.DATACON { name = n, const = c, typ = t,
521                                     rep = r, sign = s, lazyp = l },
522                         ttr)
523                    end
524                | d _ = raise Format                | d _ = raise Format
525          in          in
526              share dataconM d              share dataconM d
# Line 502  Line 585 
585          and nrdlist () = list nrdListM nameRepDomain ()          and nrdlist () = list nrdListM nameRepDomain ()
586    
587          and tycon () = let          and tycon () = let
588              fun tyc #"A" = lookTYC (modId ())              fun tyc #"A" = T.GENtyc (lookTyc (libModSpec (), tycId ()))
589                | tyc #"B" = T.GENtyc { stamp = stamp (), arity = int (),                | tyc #"B" = T.GENtyc { stamp = stamp (),
590                                        eq = ref (eqprop ()), kind = tyckind (),                                        arity = int (),
591                                        path = ipath () }                                        eq = ref (eqprop ()),
592                                          kind = tyckind (),
593                                          path = ipath (),
594                                          stub = SOME { owner = if lib then pid ()
595                                                                else globalPid (),
596                                                        lib = lib } }
597                | tyc #"C" = T.DEFtyc { stamp = stamp (),                | tyc #"C" = T.DEFtyc { stamp = stamp (),
598                                        tyfun = T.TYFUN { arity = int (),                                        tyfun = T.TYFUN { arity = int (),
599                                                          body = ty () },                                                          body = ty () },
# Line 517  Line 605 
605                | tyc #"F" = T.RECtyc (int ())                | tyc #"F" = T.RECtyc (int ())
606                | tyc #"G" = T.FREEtyc (int ())                | tyc #"G" = T.FREEtyc (int ())
607                | tyc #"H" = T.ERRORtyc                | tyc #"H" = T.ERRORtyc
               | tyc #"I" = lookTYCp (string (), modId ())  
               | tyc #"J" = lookTYCn (int (), symbol(), modId ())  
608                | tyc _ = raise Format                | tyc _ = raise Format
609          in          in
610              share tyconM tyc              share tyconM tyc
611          end          end
612    
613            and tycon' () = let
614                val tyc = tycon ()
615                val tree =
616                    case tyc of
617                        T.GENtyc r => M.TYCNODE r
618                      | _ => notree
619            in
620                (tyc, tree)
621            end
622    
623          and tyconlist () = list tyconListM tycon ()          and tyconlist () = list tyconListM tycon ()
624    
625          and ty () = let          and ty' () = let
626              fun t #"a" = T.CONty (tycon (), tylist ())              fun t #"a" =
627                | t #"b" = T.IBOUND (int ())                  let val (tyc, tyctr) = tycon' ()
628                | t #"c" = T.WILDCARDty                      val (tyl, tyltr) = tylist' ()
629                | t #"d" = T.POLYty { sign = boollist (),                  in (T.CONty (tyc, tyl), branch [tyctr, tyltr])
630                                      tyfun = T.TYFUN { arity = int (),                  end
631                                                        body = ty () } }                | t #"b" = (T.IBOUND (int ()), notree)
632                | t #"e" = T.UNDEFty                | t #"c" = (T.WILDCARDty, notree)
633                  | t #"d" =
634                    let val s = boollist ()
635                        val ar = int ()
636                        val (b, btr) = ty' ()
637                    in
638                        (T.POLYty { sign = s, tyfun = T.TYFUN { arity = ar,
639                                                                body = b } },
640                         btr)
641                    end
642                  | t #"e" = (T.UNDEFty, notree)
643                | t _ = raise Format                | t _ = raise Format
644          in          in
645              share tyM t              share tyM t
646          end          end
647    
648            and ty () = #1 (ty' ())
649    
650          and tyoption () = option tyOptionM ty ()          and tyoption () = option tyOptionM ty ()
651          and tylist () = list tyListM ty ()  
652            and tylist' () = let
653                val (l, trl) = ListPair.unzip (list tyListM ty' ())
654            in
655                (l, branch trl)
656            end
657    
658          and inl_info () = let          and inl_info () = let
659              fun ii #"A" = II.INL_PRIM (primop (), tyoption ())              fun ii #"A" = II.INL_PRIM (primop (), ty ())
660                | ii #"B" = II.INL_STR (iilist ())                | ii #"B" = II.INL_STR (iilist ())
661                | ii #"C" = II.INL_NO                | ii #"C" = II.INL_NO
662                | ii _ = raise Format                | ii _ = raise Format
# Line 553  Line 666 
666    
667          and iilist () = list iiListM inl_info ()          and iilist () = list iiListM inl_info ()
668    
669          and var () = let          and var' () = let
670              fun v #"1" = V.VALvar { access = access (), info = inl_info (),              fun v #"1" =
671                                      path = spath (), typ = ref (ty ()) }                  let val a = access ()
672                | v #"2" = V.OVLDvar { name = symbol (),                      val i = inl_info ()
673                                       options = ref (overldlist ()),                      val p = spath ()
674                                       scheme = T.TYFUN { arity = int (),                      val (t, tr) = ty' ()
675                                                          body = ty () } }                  in
676                | v #"3" = V.ERRORvar                      (V.VALvar { access = a, info = i, path = p, typ = ref t },
677                         tr)
678                    end
679                  | v #"2" =
680                    let val n = symbol ()
681                        val (ol, oltr) = overldlist' ()
682                        val ar = int ()
683                        val (b, btr) = ty' ()
684                    in
685                        (V.OVLDvar { name = n,
686                                     options = ref ol,
687                                     scheme = T.TYFUN { arity = ar, body = b } },
688                         branch [oltr, btr])
689                    end
690                  | v #"3" = (V.ERRORvar, notree)
691                | v _ = raise Format                | v _ = raise Format
692          in          in
693              share vM v              share vM v
694          end          end
695    
696          and overld () = let          and overld' () = let
697              fun ov #"o" = { indicator = ty (), variant = var () }              fun ov #"o" =
698                    let val (t, ttr) = ty' ()
699                        val (v, vtr) = var' ()
700                    in
701                        ({ indicator = t, variant = v },
702                         branch [ttr, vtr])
703                    end
704                | ov _ = raise Format                | ov _ = raise Format
705          in          in
706              share overldM ov              share overldM ov
707          end          end
708    
709          and overldlist () = list olListM overld ()          and overldlist' () = let
710                val (l, trl) = ListPair.unzip (list olListM overld' ())
711            in
712                (l, branch trl)
713            end
714    
715          fun strDef () = let          fun strDef () = let
716              fun sd #"C" = M.CONSTstrDef (Structure ())              fun sd #"C" = M.CONSTstrDef (Structure ())
# Line 583  Line 720 
720              share sdM sd              share sdM sd
721          end          end
722    
723          and Signature () = let          and Signature' () = let
724              fun sg #"A" = M.ERRORsig              fun sg #"A" = (M.ERRORsig, notree)
725                | sg #"B" = lookSIG (modId ())                | sg #"B" =
726                | sg #"C" = M.SIG { name = symboloption (),                  let val sr = lookSig (libModSpec (), sigId ())
727                                    closed = bool (),                  in
728                                    fctflag = bool (),                      (M.SIG sr, M.SIGNODE sr)
729                                    stamp = stamp (),                  end
730                                    symbols = symbollist (),                | sg #"C" =
731                                    elements = list elementsM                  let val s = stamp ()
732                                                   (pair (symbol, spec)) (),                      val n = symboloption ()
733                                    boundeps =                      val c = bool ()
734                                      ref (option bepsOM                      val ff = bool ()
735                                           (list bepsLM (pair (entPath,                      val sl = symbollist ()
736                                                               tkind))) ()),                      val (el, eltrl) =
737                            ListPair.unzip
738                                (map (fn (sy, (sp, tr)) => ((sy, sp), tr))
739                                     (list elementsM
740                                      (pair symSpecPM (symbol, spec')) ()))
741                        val beps = option bepsOM
742                                          (list bepsLM
743                                                (pair epTkPM (entPath, tkind))) ()
744                        val ts = spathlistlist ()
745                        val ss = spathlistlist ()
746                        val r = { stamp = s,
747                                  name = n,
748                                  closed = c,
749                                  fctflag = ff,
750                                  symbols = sl,
751                                  elements = el,
752                                  boundeps = ref beps,
753                                    lambdaty = ref NONE,                                    lambdaty = ref NONE,
754                                    typsharing = spathlistlist (),                                typsharing = ts,
755                                    strsharing = spathlistlist () }                                strsharing = ss,
756                | sg #"D" = lookSIGp (string (), modId ())                                stub = SOME { owner = if lib then pid ()
757                | sg #"E" = lookSIGn (int (), symbol (), modId ())                                                      else globalPid (),
758                                                tree = branch eltrl,
759                                                lib = lib } }
760                    in
761                        (M.SIG r, M.SIGNODE r)
762                    end
763                | sg _ = raise Format                | sg _ = raise Format
764          in          in
765              share sigM sg              share sigM sg
766          end          end
767    
768          and fctSig () = let          and Signature () = #1 (Signature' ())
769              fun fsg #"a" = M.ERRORfsig  
770                | fsg #"b" = lookFSIG (modId ())          and fctSig' () = let
771                | fsg #"c" = M.FSIG { kind = symboloption (),              fun fsg #"a" = (M.ERRORfsig, notree)
772                                      paramsig = Signature (),                | fsg #"c" =
773                                      paramvar = entVar (),                  let val k = symboloption ()
774                                      paramsym = symboloption (),                      val (ps, pstr) = Signature' ()
775                                      bodysig = Signature () }                      val pv = entVar ()
776                | fsg #"d" = lookFSIGp (string (), modId ())                      val psy = symboloption ()
777                | fsg #"e" = lookFSIGn (int (), symbol (), modId ())                      val (bs, bstr) = Signature' ()
778                    in
779                        (M.FSIG { kind = k, paramsig = ps,
780                                  paramvar = pv, paramsym = psy,
781                                  bodysig = bs },
782                         branch [pstr, bstr])
783                    end
784                | fsg _ = raise Format                | fsg _ = raise Format
785          in          in
786              share fsigM fsg              share fsigM fsg
787          end          end
788    
789          and spec () = let          and spec' () = let
790              val intoption = option ioM int              val intoption = option ioM int
791              fun sp #"1" = M.TYCspec { spec = tycon (), entVar = entVar (),              fun sp #"1" =
792                                        repl = bool (), scope = int () }                  let val (t, ttr) = tycon' ()
793                | sp #"2" = M.STRspec { sign = Signature (), slot = int (),                  in
794                        (M.TYCspec { spec = t, entVar = entVar (),
795                                     repl = bool (), scope = int () },
796                         ttr)
797                    end
798                  | sp #"2" =
799                    let val (s, str) = Signature' ()
800                    in
801                        (M.STRspec { sign = s, slot = int (),
802                                        def = option spDefM                                        def = option spDefM
803                                                 (pair (strDef, int)) (),                                                (pair sdIntPM (strDef, int)) (),
804                                        entVar = entVar () }                                   entVar = entVar () },
805                | sp #"3" = M.FCTspec { sign = fctSig (), slot = int (),                       str)
806                                        entVar = entVar () }                  end
807                | sp #"4" = M.VALspec { spec = ty (), slot = int () }                | sp #"3" =
808                | sp #"5" = M.CONspec { spec = datacon (), slot = intoption () }                  let val (f, ftr) = fctSig' ()
809                    in
810                        (M.FCTspec { sign = f, slot = int (), entVar = entVar () },
811                         ftr)
812                    end
813                  | sp #"4" =
814                    let val (t, ttr) = ty' ()
815                    in
816                        (M.VALspec { spec = t, slot = int () }, ttr)
817                    end
818                  | sp #"5" =
819                    let val (d, dtr) = datacon' ()
820                    in
821                        (M.CONspec { spec = d, slot = intoption () }, dtr)
822                    end
823                | sp _ = raise Format                | sp _ = raise Format
824          in          in
825              share spM sp              share spM sp
826          end          end
827    
828          and entity () = let          and entity' () = let
829              fun en #"A" = M.TYCent (tycEntity ())              fun en #"A" = & M.TYCent (tycEntity' ())
830                | en #"B" = M.STRent (strEntity ())                | en #"B" = & M.STRent (strEntity' ())
831                | en #"C" = M.FCTent (fctEntity ())                | en #"C" = & M.FCTent (fctEntity' ())
832                | en #"D" = M.ERRORent                | en #"D" = (M.ERRORent, notree)
833                | en _ = raise Format                | en _ = raise Format
834          in          in
835              share enM en              share enM en
836          end          end
837    
838          and fctClosure () = let          and fctClosure' () = let
839              fun f #"f" =M.CLOSURE { param = entVar (), body = strExp (),              fun f #"f" =
840                                      env = entityEnv () }                  let val p = entVar ()
841                        val (b, btr) = strExp' ()
842                        val (e, etr) = entityEnv' ()
843                    in
844                        (M.CLOSURE { param = p, body = b, env = e },
845                         branch [btr, etr])
846                    end
847                | f _ = raise Format                | f _ = raise Format
848          in          in
849              share fctcM f              share fctcM f
850          end          end
851    
852          and Structure () = let          (* The construction of the STRNODE in the modtree deserves some
853              fun stracc (M.STR { sign, rlzn, info, ... }) =           * comment:  Even though it contains the whole strrec, it does
854                  M.STR { sign = sign, rlzn = rlzn, info = info,           * _not_ take care of the Signature contained therein.  The reason
855                          access = access () }           * why STRNODE has the whole strrec and not just the strEntity that
856                | stracc _ = raise Format           * it really guards is that the identity of the strEntity is not
857              fun str #"A" = M.STRSIG { sign = Signature (),           * fully recoverable without also having access to the Signature.
858                                        entPath = entPath () }           * The same situation occurs in the case of FCTNODE. *)
859                | str #"B" = M.ERRORstr          and Structure' () = let
860                | str #"C" = stracc (lookSTR (modId ()))              fun str #"A" =
861                | str #"D" = M.STR { sign = Signature (), rlzn = strEntity (),                  let val (s, str) = Signature' ()
862                                     access = access (), info = inl_info () }                  in
863                | str #"I" = stracc (lookSTRp (string (), modId ()))                      (M.STRSIG { sign = s, entPath = entPath () }, str)
864                | str #"J" = stracc (lookSTRn (int (), symbol (), modId ()))                  end
865                  | str #"B" = (M.ERRORstr, notree)
866                  | str #"C" =
867                    let val (s, str) = Signature' ()
868                        val r = { sign = s,
869                                  rlzn = lookStr (libModSpec (), strId ()),
870                                  access = access (),
871                                  info = inl_info () }
872                    in
873                        (M.STR r, branch [str, M.STRNODE r])
874                    end
875                  | str #"D" =
876                    let val (s, str) = Signature' ()
877                        val r = { sign = s,
878                                  rlzn = strEntity (),
879                                  access = access (),
880                                  info = inl_info () }
881                    in
882                        (M.STR r, branch [str, M.STRNODE r])
883                    end
884                | str _ = raise Format                | str _ = raise Format
885          in          in
886              share strM str              share strM str
887          end          end
888    
889          and Functor () = let          and Structure () = #1 (Structure' ())
890              fun fctacc (M.FCT { sign, rlzn, info, ... }) =  
891                  M.FCT { sign = sign, rlzn = rlzn, info = info,          (* See the comment about STRNODE, strrec, Signature, and strEntity
892                          access = access () }           * in front of Structure'.  The situation for FCTNODE, fctrec,
893                | fctacc _ = raise Format           * fctSig, and fctEntity is analogous. *)
894              fun fct #"E" = M.ERRORfct          and Functor' () = let
895                | fct #"F" = fctacc (lookFCT (modId ()))              fun fct #"E" = (M.ERRORfct, notree)
896                | fct #"G" = M.FCT { sign = fctSig (), rlzn = fctEntity (),                | fct #"F" =
897                                     access = access (), info = inl_info () }                  let val (s, str) = fctSig' ()
898                | fct #"H" = fctacc (lookFCTp (string (), modId ()))                      val r = { sign = s,
899                | fct #"I" = fctacc (lookFCTn (int (), symbol (), modId ()))                                rlzn = lookFct (libModSpec (), fctId ()),
900                                  access = access (),
901                                  info = inl_info () }
902                    in
903                        (M.FCT r, branch [str, M.FCTNODE r])
904                    end
905                  | fct #"G" =
906                    let val (s, str) = fctSig' ()
907                        val r = { sign = s,
908                                  rlzn = fctEntity (),
909                                  access = access (),
910                                  info = inl_info () }
911                    in
912                        (M.FCT r, branch [str, M.FCTNODE r])
913                    end
914                | fct _ = raise Format                | fct _ = raise Format
915          in          in
916              share fctM fct              share fctM fct
917          end          end
918    
919          and stampExp () = let          and stampExp () = let
920              fun ste #"a" = M.CONST (stamp ())              fun ste #"b" = M.GETSTAMP (strExp ())
               | ste #"b" = M.GETSTAMP (strExp ())  
921                | ste #"c" = M.NEW                | ste #"c" = M.NEW
922                | ste _ = raise Format                | ste _ = raise Format
923          in          in
924              share steM ste              share steM ste
925          end          end
926    
927          and tycExp () = let          and tycExp' () = let
928              fun tce #"d" = M.CONSTtyc (tycon ())              fun tce #"d" = & M.CONSTtyc (tycon' ())
929                | tce #"e" = M.FORMtyc (tycon ())                | tce #"e" = (M.FORMtyc (tycon ()), notree) (* ? *)
930                | tce #"f" = M.VARtyc (entPath ())                | tce #"f" = (M.VARtyc (entPath ()), notree)
931                | tce _ = raise Format                | tce _ = raise Format
932          in          in
933              share tceM tce              share tceM tce
934          end          end
935    
936          and strExp () = let          and tycExp () = #1 (tycExp' ())
937              fun stre #"g" = M.VARstr (entPath ())  
938                | stre #"h" = M.CONSTstr (strEntity ())          and strExp' () = let
939                | stre #"i" = M.STRUCTURE { stamp = stampExp (),              fun stre #"g" = (M.VARstr (entPath ()), notree)
940                                            entDec = entityDec () }                | stre #"h" = & M.CONSTstr (strEntity' ())
941                | stre #"j" = M.APPLY (fctExp (), strExp ())                | stre #"i" =
942                | stre #"k" = M.LETstr (entityDec (), strExp ())                  let val s = stampExp ()
943                | stre #"l" = M.ABSstr (Signature (), strExp ())                      val (d, dtr) = entityDec' ()
944                | stre #"m" = M.CONSTRAINstr { boundvar = entVar (),                  in
945                                               raw = strExp (),                      (M.STRUCTURE { stamp = s, entDec = d }, dtr)
946                                               coercion = strExp () }                  end
947                | stre #"n" = M.FORMstr (fctSig ())                | stre #"j" =
948                    let val (f, ftr) = fctExp' ()
949                        val (s, str) = strExp' ()
950                    in
951                        (M.APPLY (f, s), branch [ftr, str])
952                    end
953                  | stre #"k" =
954                    let val (d, dtr) = entityDec' ()
955                        val (s, str) = strExp' ()
956                    in
957                        (M.LETstr (d, s), branch [dtr, str])
958                    end
959                  | stre #"l" =
960                    let val (s, str) = Signature' ()
961                        val (e, etr) = strExp' ()
962                    in
963                        (M.ABSstr (s, e), branch [str, etr])
964                    end
965                  | stre #"m" =
966                    let val bv = entVar ()
967                        val (r, rtr) = strExp' ()
968                        val (c, ctr) = strExp' ()
969                    in
970                        (M.CONSTRAINstr { boundvar = bv, raw = r, coercion = c },
971                         branch [rtr, ctr])
972                    end
973                  | stre #"n" = & M.FORMstr (fctSig' ())
974                | stre _ = raise Format                | stre _ = raise Format
975          in          in
976              share streM stre              share streM stre
977          end          end
978    
979          and fctExp () = let          and strExp () = #1 (strExp' ())
980              fun fe #"o" = M.VARfct (entPath ())  
981                | fe #"p" = M.CONSTfct (fctEntity ())          and fctExp' () = let
982                | fe #"q" = M.LAMBDA { param = entVar (), body = strExp () }              fun fe #"o" = (M.VARfct (entPath ()), notree)
983                | fe #"r" = M.LAMBDA_TP { param = entVar (), body = strExp (),                | fe #"p" = & M.CONSTfct (fctEntity' ())
984                                          sign = fctSig () }                | fe #"q" =
985                | fe #"s" = M.LETfct (entityDec (), fctExp ())                  let val p = entVar ()
986                        val (b, btr) = strExp' ()
987                    in
988                        (M.LAMBDA { param = p, body = b }, btr)
989                    end
990                  | fe #"r" =
991                    let val p = entVar ()
992                        val (b, btr) = strExp' ()
993                        val (s, str) = fctSig' ()
994                    in
995                        (M.LAMBDA_TP { param = p, body = b, sign = s },
996                         branch [btr, str])
997                    end
998                  | fe #"s" =
999                    let val (d, dtr) = entityDec' ()
1000                        val (f, ftr) = fctExp' ()
1001                    in
1002                        (M.LETfct (d, f), branch [dtr, ftr])
1003                    end
1004                | fe _ = raise Format                | fe _ = raise Format
1005          in          in
1006              share feM fe              share feM fe
1007          end          end
1008    
1009            and fctExp () = #1 (fctExp' ())
1010    
1011          and entityExp () = let          and entityExp () = let
1012              fun ee #"t" = M.TYCexp (tycExp ())              fun ee #"t" = M.TYCexp (tycExp ())
1013                | ee #"u" = M.STRexp (strExp ())                | ee #"u" = M.STRexp (strExp ())
# Line 749  Line 1019 
1019              share eeM ee              share eeM ee
1020          end          end
1021    
1022          and entityDec () = let          and entityDec' () = let
1023              fun ed #"A" = M.TYCdec (entVar (), tycExp ())              fun ed #"A" =
1024                | ed #"B" = M.STRdec (entVar (), strExp (), symbol ())                  let val v = entVar ()
1025                | ed #"C" = M.FCTdec (entVar (), fctExp ())                      val (e, etr) = tycExp' ()
1026                | ed #"D" = M.SEQdec (entityDecList ())                  in
1027                | ed #"E" = M.LOCALdec (entityDec (), entityDec ())                      (M.TYCdec (v, e), etr)
1028                | ed #"F" = M.ERRORdec                  end
1029                | ed #"G" = M.EMPTYdec                | ed #"B" =
1030                    let val v = entVar ()
1031                        val (e, etr) = strExp' ()
1032                        val s = symbol ()
1033                    in
1034                        (M.STRdec (v, e, s), etr)
1035                    end
1036                  | ed #"C" =
1037                    let val v = entVar ()
1038                        val (e, etr) = fctExp' ()
1039                    in
1040                        (M.FCTdec (v, e), etr)
1041                    end
1042                  | ed #"D" = & M.SEQdec (entityDecList' ())
1043                  | ed #"E" =
1044                    let val (d1, d1tr) = entityDec' ()
1045                        val (d2, d2tr) = entityDec' ()
1046                    in
1047                        (M.LOCALdec (d1, d2), branch [d1tr, d2tr])
1048                    end
1049                  | ed #"F" = (M.ERRORdec, notree)
1050                  | ed #"G" = (M.EMPTYdec, notree)
1051                | ed _ = raise Format                | ed _ = raise Format
1052          in          in
1053              share edM ed              share edM ed
1054          end          end
1055    
1056          and entityDecList () = list edListM entityDec ()          and entityDecList' () = let
1057                val (l, trl) = ListPair.unzip (list edListM entityDec' ())
1058            in
1059                (l, branch trl)
1060            end
1061    
1062          and entityEnv () = let          and entityEnv' () = let
1063              fun eenv #"A" =              fun eenv #"A" =
1064                  let                  let val l = list eenvBindM (pair evEntPM (entVar, entity')) ()
1065                      val l = list eenvBindM (pair (entVar, entity)) ()                      val l' = map (fn (v, (e, tr)) => ((v, e), tr)) l
1066                        val (l'', trl) = ListPair.unzip l'
1067                      fun add ((v, e), z) = ED.insert (z, v, e)                      fun add ((v, e), z) = ED.insert (z, v, e)
1068                      val ed = foldr add ED.empty l                      val ed = foldr add ED.empty l''
1069                        val (e, etr) = entityEnv' ()
1070                    in
1071                        (M.BINDeenv (ed, e), branch (etr :: trl))
1072                    end
1073                  | eenv #"B" = (M.NILeenv, notree)
1074                  | eenv #"C" = (M.ERReenv, notree)
1075                  | eenv #"D" =
1076                    let val r = lookEnv (libModSpec (), envId ())
1077                    in
1078                        (M.MARKeenv r, M.ENVNODE r)
1079                    end
1080                  | eenv #"E" =
1081                    let val s = stamp ()
1082                        val (e, etr) = entityEnv' ()
1083                        val r = { stamp = s,
1084                                  env = e,
1085                                  stub = SOME { owner = if lib then pid ()
1086                                                        else globalPid (),
1087                                                tree = etr,
1088                                                lib = lib } }
1089                  in                  in
1090                      M.BINDeenv (ed, entityEnv ())                      (M.MARKeenv r, M.ENVNODE r)
1091                  end                  end
               | eenv #"B" = M.NILeenv  
               | eenv #"C" = M.ERReenv  
               | eenv #"D" = lookEENV (modId ())  
               | eenv #"E" = M.MARKeenv (stamp (), entityEnv ())  
               | eenv #"F" = lookEENVp (string (), modId ())  
               | eenv #"G" = lookEENVn (int (), symbol (), modId ())  
1092                | eenv _ = raise Format                | eenv _ = raise Format
1093          in          in
1094              share eenvM eenv              share eenvM eenv
1095          end          end
1096    
1097          and strEntity () = let          and strEntity' () = let
1098              fun s #"s" =              fun s #"s" =
1099                  { stamp = stamp (), entities = entityEnv (), rpath = ipath (),                  let val s = stamp ()
1100                    lambdaty = ref NONE }                      val (e, etr) = entityEnv' ()
1101                    in
1102                        ({ stamp = s,
1103                           entities = e,
1104                           rpath = ipath (),
1105                           lambdaty = ref NONE,
1106                           stub = SOME { owner = if lib then pid ()
1107                                                 else globalPid (),
1108                                         tree = etr,
1109                                         lib = lib } },
1110                         etr)
1111                    end
1112                | s _ = raise Format                | s _ = raise Format
1113          in          in
1114              share senM s              share senM s
1115          end          end
1116    
1117          and fctEntity () = let          and strEntity () = #1 (strEntity' ())
1118    
1119            and fctEntity' () = let
1120              fun f #"f" =              fun f #"f" =
1121                  { stamp = stamp (), closure = fctClosure (), rpath = ipath (),                  let val s = stamp ()
1122                    lambdaty = ref NONE, tycpath = NONE }                      val (c, ctr) = fctClosure' ()
1123                    in
1124                        ({ stamp = s,
1125                           closure = c,
1126                           rpath = ipath (),
1127                           lambdaty = ref NONE,
1128                           tycpath = NONE,
1129                           stub = SOME { owner = if lib then pid ()
1130                                                 else globalPid (),
1131                                         tree = ctr,
1132                                         lib = lib } },
1133                         ctr)
1134                    end
1135                | f _ = raise Format                | f _ = raise Format
1136          in          in
1137              share fenM f              share fenM f
1138          end          end
1139    
1140          and tycEntity () = tycon ()          and fctEntity () = #1 (fctEntity' ())
1141    
1142            and tycEntity' () = tycon' ()
1143    
1144          fun fixity () = let          fun fixity () = let
1145              fun fx #"N" = Fixity.NONfix              fun fx #"N" = Fixity.NONfix
# Line 812  Line 1149 
1149              share fxM fx              share fxM fx
1150          end          end
1151    
1152          fun binding () = let          fun binding' () = let
1153              fun b #"1" = B.VALbind (var ())              fun b #"1" = & B.VALbind (var' ())
1154                | b #"2" = B.CONbind (datacon ())                | b #"2" = & B.CONbind (datacon' ())
1155                | b #"3" = B.TYCbind (tycon ())                | b #"3" = & B.TYCbind (tycon' ())
1156                | b #"4" = B.SIGbind (Signature ())                | b #"4" = & B.SIGbind (Signature' ())
1157                | b #"5" = B.STRbind (Structure ())                | b #"5" = & B.STRbind (Structure' ())
1158                | b #"6" = B.FSGbind (fctSig ())                | b #"6" = & B.FSGbind (fctSig' ())
1159                | b #"7" = B.FCTbind (Functor ())                | b #"7" = & B.FCTbind (Functor' ())
1160                | b #"8" = B.FIXbind (fixity ())                | b #"8" = (B.FIXbind (fixity ()), notree)
1161                | b _ = raise Format                | b _ = raise Format
1162          in          in
1163              share bM b              share bM b
1164          end          end
1165    
1166          fun env () = let          fun env () = let
1167              val bindlist = list envM (pair (symbol, binding)) ()              val bindlist = list envM (pair symBindPM (symbol, binding')) ()
1168              fun bind ((s, b), e) = Env.bind (s, b, e)              fun bind ((s, (b, t)), e) = StaticEnv.bind0 (s, (b, SOME t), e)
1169          in          in
1170              Env.consolidate (foldl bind Env.empty bindlist)              Env.consolidate (foldl bind StaticEnv.empty bindlist)
1171          end          end
1172      in      in
1173          env          env
1174      end      end
1175    
1176      fun unpickleEnv { context, hash, pickle } = let      fun unpickleEnv context (hash, pickle) = let
         fun cvt lk i = case lk context i of SOME v => 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 }  
1177          val session =          val session =
1178              UU.mkSession (UU.stringGetter (Byte.bytesToString pickle))              UU.mkSession (UU.stringGetter (Byte.bytesToString pickle))
1179          fun import i = A.PATH (A.EXTERN hash, i)          fun import i = A.PATH (A.EXTERN hash, i)
1180          val sharedStuff as { symbol, ... } = mkSharedStuff (session, import)          val slM = UU.mkMap ()
1181          val symbolListM = UU.mkMap ()          val sloM = UU.mkMap ()
1182          val symbollist = UU.r_list session symbolListM symbol          val sylM = UU.mkMap ()
1183          val envUnpickler =          val sharedStuff = mkSharedStuff (session, import)
1184              mkEnvUnpickler (session, symbollist, sharedStuff,          val stringlist = UU.r_list session slM (#string sharedStuff)
1185                              c, fn () => hash)          val symbollist = UU.r_list session sylM (#symbol sharedStuff)
1186            val extraInfo = { globalPid = fn () => hash,
1187                              symbollist = symbollist,
1188                              sharedStuff = sharedStuff,
1189                              lib = false }
1190            val sessionInfo = { session = session, stringlist = stringlist }
1191            val unpickle = mkEnvUnpickler extraInfo sessionInfo context
1192      in      in
1193          envUnpickler ()          unpickle ()
1194      end      end
1195    
1196      fun mkFlintUnpickler (session, sharedStuff) = let      fun mkFlintUnpickler (session, sharedStuff) = let
# Line 877  Line 1200 
1200          fun list m r = UU.r_list session m r          fun list m r = UU.r_list session m r
1201          fun option m r = UU.r_option session m r          fun option m r = UU.r_option session m r
1202    
1203          val pair = UU.r_pair          fun pair m fp p = UU.r_pair session m fp p
1204          val int = UU.r_int session          val int = UU.r_int session
1205          val int32 = UU.r_int32 session          val int32 = UU.r_int32 session
1206          val word = UU.r_word session          val word = UU.r_word session
1207          val word32 = UU.r_word32 session          val word32 = UU.r_word32 session
1208          val bool = UU.r_bool session          val bool = UU.r_bool session
1209    
1210          val { pid, string, symbol,          val { pid, string, symbol, access, conrep, consig,
1211                access, conrep, consig, lty, tyc, tkind, ltylist, tyclist,                primop, boollist, tkind, tkindlist } = sharedStuff
               primop, boollist } = sharedStuff  
1212    
1213            val ltyM = UU.mkMap ()
1214            val ltyListM = UU.mkMap ()
1215            val tycM = UU.mkMap ()
1216            val tycListM = UU.mkMap ()
1217          val valueM = UU.mkMap ()          val valueM = UU.mkMap ()
1218          val conM = UU.mkMap ()          val conM = UU.mkMap ()
1219          val dconM = UU.mkMap ()          val dconM = UU.mkMap ()
# Line 906  Line 1232 
1232          val lexpOptionM = UU.mkMap ()          val lexpOptionM = UU.mkMap ()
1233          val fundecM = UU.mkMap ()          val fundecM = UU.mkMap ()
1234          val tfundecM = UU.mkMap ()          val tfundecM = UU.mkMap ()
1235          val fdplM = UU.mkMap ()          val lvLtPM = UU.mkMap ()
1236          val tfplM = UU.mkMap ()          val lvLtPLM = UU.mkMap ()
1237            val lvTkPM = UU.mkMap ()
1238            val lvTkPLM = UU.mkMap ()
1239            val tycLvPM = UU.mkMap ()
1240    
1241            fun lty () = let
1242                fun lt #"A" = LT.ltc_tyc (tyc ())
1243                  | lt #"B" = LT.ltc_str (ltylist ())
1244                  | lt #"C" = LT.ltc_fct (ltylist (), ltylist ())
1245                  | lt #"D" = LT.ltc_poly (tkindlist (), ltylist ())
1246                  | lt _ = raise Format
1247            in
1248                share ltyM lt
1249            end
1250    
1251            and ltylist () = list ltyListM lty ()
1252    
1253            and tyc () = let
1254                fun tc #"A" = LT.tcc_var (DI.di_fromint (int ()), int ())
1255                  | tc #"B" = LT.tcc_nvar (int ())
1256                  | tc #"C" = LT.tcc_prim (PT.pt_fromint (int ()))
1257                  | tc #"D" = LT.tcc_fn (tkindlist (), tyc ())
1258                  | tc #"E" = LT.tcc_app (tyc (), tyclist ())
1259                  | tc #"F" = LT.tcc_seq (tyclist ())
1260                  | tc #"G" = LT.tcc_proj (tyc (), int ())
1261                  | tc #"H" = LT.tcc_sum (tyclist ())
1262                  | tc #"I" = LT.tcc_fix ((int (), tyc (), tyclist ()), int ())
1263                  | tc #"J" = LT.tcc_abs (tyc ())
1264                  | tc #"K" = LT.tcc_box (tyc ())
1265                  | tc #"L" = LT.tcc_tuple (tyclist ())
1266                  | tc #"M" = LT.tcc_arrow (LT.ffc_var (bool (), bool ()),
1267                                            tyclist (), tyclist ())
1268                  | tc #"N" = LT.tcc_arrow (LT.ffc_fixed, tyclist (), tyclist ())
1269                  | tc #"O" = LK.tc_inj (LK.TC_TOKEN (LK.token_key (int ()),
1270                                                      tyc ()))
1271                  | tc _ = raise Format
1272            in
1273                share tycM tc
1274            end
1275    
1276            and tyclist () = list tycListM tyc ()
1277    
1278          val lvar = int          val lvar = int
1279          val lvarlist = list lvarListM lvar          val lvarlist = list lvarListM lvar
# Line 958  Line 1324 
1324          and dict () = let          and dict () = let
1325              fun d #"y" =              fun d #"y" =
1326                  { default = lvar (),                  { default = lvar (),
1327                    table = list dictTableM (pair (tyclist, lvar)) () }                    table = list dictTableM (pair tycLvPM (tyclist, lvar)) () }
1328                | d _ = raise Format                | d _ = raise Format
1329          in          in
1330              share dictM d              share dictM d
# Line 1001  Line 1367 
1367    
1368          and fundec () = let          and fundec () = let
1369              fun f #"a" =              fun f #"a" =
1370                  (fkind (), lvar (), list fdplM (pair (lvar, lty)) (), lexp ())                  (fkind (), lvar (),
1371                     list lvLtPLM (pair lvLtPM (lvar, lty)) (),
1372                     lexp ())
1373                | f _ = raise Format                | f _ = raise Format
1374          in          in
1375              share fundecM f              share fundecM f
# Line 1010  Line 1378 
1378          and fundeclist () = list fundecListM fundec ()          and fundeclist () = list fundecListM fundec ()
1379    
1380          and tfundec () = let          and tfundec () = let
1381              fun t #"b" = (lvar (), list tfplM (pair (lvar, tkind)) (), lexp ())              fun t #"b" = ({ inline = F.IH_SAFE }, lvar (),
1382                              list lvTkPLM (pair lvTkPM (lvar, tkind)) (),
1383                              lexp ())
1384                | t _ = raise Format                | t _ = raise Format
1385          in          in
1386              share tfundecM t              share tfundecM t
1387          end          end
1388    
1389          and fkind () = let          and fkind () = let
1390              fun fk #"2" = F.FK_FCT              fun aug_unknown x = (x, F.LK_UNKNOWN)
1391                | fk #"3" = F.FK_FUN { isrec = ltylistoption (),              fun inlflag true = F.IH_ALWAYS
1392                                       fixed = LT.ffc_var (bool (), bool ()),                | inlflag false = F.IH_SAFE
1393                                       known = bool (), inline = bool () }              fun fk #"2" = { isrec = NONE, cconv = F.CC_FCT,
1394                | fk #"4" = F.FK_FUN { isrec = ltylistoption (),                              known = false, inline = F.IH_SAFE }
1395                                       fixed = LT.ffc_fixed,                | fk #"3" = { isrec = Option.map aug_unknown (ltylistoption ()),
1396                                       known = bool (), inline = bool () }                              cconv = F.CC_FUN (LT.ffc_var (bool (), bool ())),
1397                                known = bool (),
1398                                inline = inlflag (bool ()) }
1399                  | fk #"4" = { isrec = Option.map aug_unknown (ltylistoption ()),
1400                                cconv = F.CC_FUN LT.ffc_fixed,
1401                                known = bool (),
1402                                inline = inlflag (bool ()) }
1403                | fk _ = raise Format                | fk _ = raise Format
1404          in          in
1405              share fkindM fk              share fkindM fk
# Line 1053  Line 1429 
1429          UU.r_option session foM flint ()          UU.r_option session foM flint ()
1430      end      end
1431    
1432      fun mkUnpicklers session contexts = let      fun mkUnpicklers sessionInfo context = let
1433          val { prim_context, node_context } = contexts          val { session, stringlist } = sessionInfo
1434          fun cvtP lk (s, id) =          val sharedStuff = mkSharedStuff (session, A.LVAR)
1435              case prim_context s of          val { symbol, pid, ... } = sharedStuff
1436                  NONE => raise Format          val sylM = UU.mkMap ()
1437                | SOME e => (case lk e id of SOME v => v | NONE => raise Format)          val symbollist = UU.r_list session sylM symbol
1438          fun cvtN lk (i, s, id) =          val extraInfo = { globalPid = fn () => raise Format,
1439              case node_context (i, s) of                            symbollist = symbollist,
1440                  NONE => raise Format                            sharedStuff = sharedStuff,
1441                | SOME e => (case lk e id of SOME v => v | NONE => raise Format)                            lib = true }
1442          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, sharedStuff,  
                             c, fn () => raise Format)  
1443          val flint = mkFlintUnpickler (session, sharedStuff)          val flint = mkFlintUnpickler (session, sharedStuff)
1444          val symbind = UU.r_pair (pid, flint)          val pidFlintPM = UU.mkMap ()
1445            val symbind = UU.r_pair session pidFlintPM (pid, flint)
1446          val sblM = UU.mkMap ()          val sblM = UU.mkMap ()
1447          val sbl = UU.r_list session sblM symbind          val sbl = UU.r_list session sblM symbind
1448          fun symenvUnpickler () = SymbolicEnv.fromListi (sbl ())          fun symenv () = SymbolicEnv.fromListi (sbl ())
1449      in      in
1450          { symenv = symenvUnpickler, env = envUnpickler,          { symenv = symenv, statenv = statenv,
1451            symbol = symbol, symbollist = symbollist }            symbol = symbol, symbollist = symbollist }
1452      end      end
1453    
1454      val unpickleEnv =      val unpickleEnv =
1455          Stats.doPhase (Stats.makePhase "Compiler 087 unpickleEnv") unpickleEnv          fn c => Stats.doPhase (Stats.makePhase "Compiler 087 unpickleEnv")
1456                                  (unpickleEnv c)
1457  end  end

Legend:
Removed from v.427  
changed lines
  Added in v.774

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