Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/trunk/src/compiler/Semant/pickle/pickmod-new.sml
ViewVC logotype

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

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

revision 476, Wed Nov 10 22:59:58 1999 UTC revision 504, Tue Dec 7 18:31:05 1999 UTC
# Line 26  Line 26 
26               exportLvars: Access.lvar list,               exportLvars: Access.lvar list,
27               exportPid: PersStamps.persstamp option}               exportPid: PersStamps.persstamp option}
28    
29        (* Re-pickling is done for the purpose of getting the hash value
30         * of a "reduced" (filtered) version of another environment that
31         * has been pickled before.  During re-pickling, the LOCAL->GLOBAL
32         * translation for stamps and the LVAR->EXTERN translation for
33         * accesses is undone so that the resulting hash value is the
34         * same that one would have gotten if the current environment
35         * was pickled using "pickleEnv". The context for repickling is
36         * specified using a set of module IDs instead of an entire
37         * context environment.  The set will have to be obtained from the
38         * unpickling process of the original pickle. *)
39        val repickleEnvHash :
40            { context: ModuleId.Set.set,
41              env: StaticEnv.staticEnv,
42              orig_hash: PersStamps.persstamp } -> PersStamps.persstamp
43    
44      val pickleFLINT:      val pickleFLINT:
45          CompBasic.flint option          CompBasic.flint option
46          -> { hash: PersStamps.persstamp,          -> { hash: PersStamps.persstamp,
# Line 36  Line 51 
51      type map      type map
52      val emptyMap : map      val emptyMap : map
53    
54        type env'n'ctxt = { env: StaticEnv.staticEnv, ctxt: ModuleId.Set.set }
55    
56      val envPickler :      val envPickler :
57          ckey option context -> (map, StaticEnv.staticEnv) PickleUtil.pickler          ckey option context -> (map, env'n'ctxt) PickleUtil.pickler
58    
59      val symenvPickler : (map, SymbolicEnv.symenv) PickleUtil.pickler      val symenvPickler : (map, SymbolicEnv.symenv) PickleUtil.pickler
60    
# Line 386  Line 403 
403          cs arg          cs arg
404      end      end
405    
406      fun mkAccess lvar = let      fun tkind x = let
407            val op $ = PU.$ TK
408            fun tk x =
409                case LK.tk_out x of
410                LK.TK_MONO => %TK "A"
411              | LK.TK_BOX => %TK "B"
412              | LK.TK_SEQ ks => "C" $ list tkind ks
413              | LK.TK_FUN (ks, kr) => "D" $ list tkind ks & tkind kr
414        in
415            share TKs tk x
416        end
417    
418        fun mkAccess { lvar, isLocalPid } = let
419          val op $ = PU.$ A          val op $ = PU.$ A
420          fun access (A.LVAR i) = "A" $ lvar i          fun access (A.LVAR i) = "A" $ lvar i
421            | access (A.EXTERN p) = "B" $ pid p            | access (A.EXTERN p) = "B" $ pid p
422              | access (A.PATH (a as A.EXTERN p, i)) =
423                (* isLocalPid always returns false for in the "normal pickler"
424                 * case.  It returns true in the "repickle" case for the
425                 * pid that was the hash of the original whole pickle.
426                 * Since alpha-conversion has already taken place if we find
427                 * an EXTERN pid, we don't call "lvar" but "int". *)
428                if isLocalPid p then "A" $ int i
429                else "C" $ access a & int i
430            | access (A.PATH (a, i)) = "C" $ access a & int i            | access (A.PATH (a, i)) = "C" $ access a & int i
431            | access A.NO_ACCESS = % A "D"            | access A.NO_ACCESS = % A "D"
432    
# Line 409  Line 446 
446      end      end
447    
448      (* lambda-type stuff; this is used in both picklers *)      (* lambda-type stuff; this is used in both picklers *)
449        and lty alpha x = let
450            val lty = lty alpha
451            val tyc = tyc alpha
452      fun ltyI x = let      fun ltyI x = let
453          val op $ = PU.$ LT          val op $ = PU.$ LT
454      in      in
# Line 421  Line 461 
461            | LK.LT_ENV _ => bug "unexpected LT_ENV in mkPickleLty"            | LK.LT_ENV _ => bug "unexpected LT_ENV in mkPickleLty"
462            | LK.LT_CONT _ => bug "unexpected LT_CONT in mkPickleLty"            | LK.LT_CONT _ => bug "unexpected LT_CONT in mkPickleLty"
463      end      end
464        in
     and lty x =  
465          if LK.ltp_norm x then share LTs ltyI x          if LK.ltp_norm x then share LTs ltyI x
466          else (* bug "unexpected complex lambda type in mkPickleLty" *) ltyI x          else (* bug "unexpected complex lambda type in mkPickleLty" *) ltyI x
467        end
468    
469      and tycI x = let      and tyc alpha x = let
470            val tyc = tyc alpha
471            val lty = lty alpha
472            fun tycI x = let
473          val op $ = PU.$ TC          val op $ = PU.$ TC
474      in      in
475          case LK.tc_out x of          case LK.tc_out x of
476              LK.TC_VAR (db, i) => "A" $ int (DI.di_toint db) & int i              LK.TC_VAR (db, i) => "A" $ int (DI.di_toint db) & int i
477            | LK.TC_NVAR (n, dp, i) =>                | LK.TC_NVAR n => "B" $ (int o alpha) n
                 "B" $ int n & int (DI.dp_toint dp) & int i  
478            | LK.TC_PRIM t => "C" $ int (PT.pt_toint t)            | LK.TC_PRIM t => "C" $ int (PT.pt_toint t)
479            | LK.TC_FN (ks, tc) => "D" $ list tkind ks & tyc tc            | LK.TC_FN (ks, tc) => "D" $ list tkind ks & tyc tc
480            | LK.TC_APP (tc, l) => "E" $ tyc tc & list tyc l            | LK.TC_APP (tc, l) => "E" $ tyc tc & list tyc l
# Line 448  Line 490 
490                  "M" $ bool b1 & bool b2 & list tyc ts1 & list tyc ts2                  "M" $ bool b1 & bool b2 & list tyc ts1 & list tyc ts2
491            | LK.TC_ARROW (LK.FF_FIXED, ts1, ts2) =>            | LK.TC_ARROW (LK.FF_FIXED, ts1, ts2) =>
492                  "N" $ list tyc ts1 & list tyc ts2                  "N" $ list tyc ts1 & list tyc ts2
493            | LK.TC_PARROW _ => bug "unexpected TC_PARREW in mkPickleLty"                | LK.TC_PARROW _ => bug "unexpected TC_PARROW in mkPickleLty"
494            | LK.TC_TOKEN (tk, t) => "O" $ int (LK.token_int tk) & tyc t            | LK.TC_TOKEN (tk, t) => "O" $ int (LK.token_int tk) & tyc t
495            | LK.TC_IND _ => bug "unexpected TC_IND in mkPickleLty"            | LK.TC_IND _ => bug "unexpected TC_IND in mkPickleLty"
496            | LK.TC_ENV _ => bug "unexpected TC_ENV in mkPickleLty"            | LK.TC_ENV _ => bug "unexpected TC_ENV in mkPickleLty"
497            | LK.TC_CONT _ => bug "unexpected TC_CONT in mkPickleLty"            | LK.TC_CONT _ => bug "unexpected TC_CONT in mkPickleLty"
498      end      end
499        in
     and tyc x =  
500          if LK.tcp_norm x then share TCs tycI x          if LK.tcp_norm x then share TCs tycI x
501          else (* bug "unexpected complex lambda tyc in mkPickleLty" *) tycI x          else (* bug "unexpected complex lambda tyc in mkPickleLty" *) tycI x
   
     and tkind x = let  
         val op $ = PU.$ TK  
         fun tk x =  
             case LK.tk_out x of  
             LK.TK_MONO => %TK "A"  
           | LK.TK_BOX => %TK "B"  
           | LK.TK_SEQ ks => "C" $ list tkind ks  
           | LK.TK_FUN (ks, kr) => "D" $ list tkind ks & tkind kr  
     in  
         share TKs tk x  
502      end      end
503    
504      (* the FLINT pickler *)      (* the FLINT pickler *)
505      fun flint flint_exp = let      fun flint flint_exp = let
506          val alphaConvert = mkAlphaConvert ()          val alphaConvert = mkAlphaConvert ()
507          val lvar = int o alphaConvert          val lvar = int o alphaConvert
508          val { access, conrep } = mkAccess lvar          val lty = lty alphaConvert
509            val tyc = tyc alphaConvert
510            val { access, conrep } = mkAccess { lvar = lvar,
511                                                isLocalPid = fn _ => false }
512          val op $ = PU.$ V          val op $ = PU.$ V
513          fun value (F.VAR v) = "a" $ lvar v          fun value (F.VAR v) = "a" $ lvar v
514            | value (F.INT i) = "b" $ int i            | value (F.INT i) = "b" $ int i
# Line 552  Line 584 
584              "a" $ fkind fk & lvar v & list (pair (lvar, lty)) vts & lexp e              "a" $ fkind fk & lvar v & list (pair (lvar, lty)) vts & lexp e
585          end          end
586    
587          and tfundec (v, tvks, e) = let          and tfundec (tfk, v, tvks, e) = let
588              val op $ = PU.$ TFUNDEC              val op $ = PU.$ TFUNDEC
589          in          in
590              "b" $ lvar v & list (pair (lvar, tkind)) tvks & lexp e              "b" $ lvar v & list (pair (lvar, tkind)) tvks & lexp e
# Line 560  Line 592 
592    
593          and fkind arg = let          and fkind arg = let
594              val op $ = PU.$ FK              val op $ = PU.$ FK
595              fun fk F.FK_FCT = %FK "2"              fun fk { isrec, cconv=F.CC_FCT, known, inline } = %FK "2"
596                | fk (F.FK_FUN { isrec, fixed, known, inline }) =                | fk { isrec, cconv=F.CC_FUN fixed, known, inline } =
597                  case fixed of                  case fixed of
598                      LK.FF_VAR (b1, b2) =>                      LK.FF_VAR (b1, b2) =>
599                          "3" $ option (list lty) isrec &                          "3" $ option (list lty) (Option.map (fn (x,y) => x) isrec) &
600                          bool b1 & bool b2 & bool known & bool inline                          bool b1 & bool b2 & bool known &
601                            bool (case inline of F.IH_ALWAYS => true | _ => false)
602                    | LK.FF_FIXED =>                    | LK.FF_FIXED =>
603                          "4" $ option (list lty) isrec &                          "4" $ option (list lty) (Option.map (fn (x,y) => x) isrec) &
604                          bool known & bool inline                          bool known &
605                            bool (case inline of F.IH_ALWAYS => true | _ => false)
606          in          in
607              fk arg              fk arg
608          end          end
# Line 615  Line 649 
649        | NodeStub of int * Symbol.symbol        | NodeStub of int * Symbol.symbol
650    
651      (* the environment pickler *)      (* the environment pickler *)
652      fun mkEnvPickler (context0: stubinfo context) = let      fun mkEnvPickler (context0: stubinfo context, isLocalPid) = let
653    
654          val { lookTYC, lookSIG, lookFSIG, lookSTR, lookFCT, lookEENV } =          val { lookTYC, lookSIG, lookFSIG, lookSTR, lookFCT, lookEENV } =
655              context0              context0
# Line 627  Line 661 
661          in          in
662              case scope of              case scope of
663                  Stamps.LOCAL => "A" $ int (alphaConvert count)                  Stamps.LOCAL => "A" $ int (alphaConvert count)
664                | Stamps.GLOBAL p => "B" $ pid p & int count                | Stamps.GLOBAL p =>
665                        if isLocalPid p then "A" $ int count
666                        else "B" $ pid p & int count
667                | Stamps.SPECIAL s => "C" $ string s & int count                | Stamps.SPECIAL s => "C" $ string s & int count
668          end          end
669    
# Line 654  Line 690 
690              j              j
691          end          end
692    
693          val { access, conrep } = mkAccess (int o anotherLvar)          val { access, conrep } = mkAccess { lvar = int o anotherLvar,
694                                                isLocalPid = isLocalPid }
695    
696          fun spath (SP.SPATH p) = list symbol p          fun spath (SP.SPATH p) = list symbol p
697          fun ipath (IP.IPATH p) = list symbol p          fun ipath (IP.IPATH p) = list symbol p
# Line 1072  Line 1109 
1109          in          in
1110              list (pair (symbol, binding)) pairs              list (pair (symbol, binding)) pairs
1111          end          end
1112    
1113            fun env'n'ctxt { env = e, ctxt } =
1114                pair (env, list modId) (e, ModuleId.Set.listItems ctxt)
1115      in      in
1116          { pickler = env, exportLvarsGetter = fn () => rev (!lvlist) }          { pickler = env, pickler' = env'n'ctxt,
1117              exportLvarsGetter = fn () => rev (!lvlist) }
1118      end      end
1119    
1120      fun pickleEnv { context, env } = let      fun pickleEnv { context, env } = let
# Line 1089  Line 1130 
1130                    lookTYC = cvt CMStaticEnv.lookTYC,                    lookTYC = cvt CMStaticEnv.lookTYC,
1131                    lookEENV = cvt CMStaticEnv.lookEENV }                    lookEENV = cvt CMStaticEnv.lookEENV }
1132    
1133          val { pickler, exportLvarsGetter } = mkEnvPickler c          val { pickler, exportLvarsGetter, ... } =
1134                mkEnvPickler (c, fn _ => false)
1135          val pickle = Byte.stringToBytes (PU.pickle emptyMap (pickler env))          val pickle = Byte.stringToBytes (PU.pickle emptyMap (pickler env))
1136          val exportLvars = exportLvarsGetter ()          val exportLvars = exportLvarsGetter ()
1137    
# Line 1105  Line 1147 
1147            exportPid = exportPid }            exportPid = exportPid }
1148      end      end
1149    
1150        fun repickleEnvHash { context, env, orig_hash } = let
1151            fun lk i =
1152                if ModuleId.Set.member (context, i) then SimpleStub else NoStub
1153            val c = { lookSTR = lk, lookSIG = lk, lookFCT = lk,
1154                      lookFSIG = lk, lookTYC = lk, lookEENV = lk }
1155            fun isLocalPid p = PersStamps.compare (p, orig_hash) = EQUAL
1156            val { pickler, ... } = mkEnvPickler (c, isLocalPid)
1157            val pickle = Byte.stringToBytes (PU.pickle emptyMap (pickler env))
1158        in
1159            pickle2hash pickle
1160        end
1161    
1162        type env'n'ctxt = { env: StaticEnv.staticEnv, ctxt: ModuleId.Set.set }
1163    
1164      fun envPickler context = let      fun envPickler context = let
1165          val { lookSTR, lookSIG, lookFCT, lookFSIG, lookTYC, lookEENV } =          val { lookSTR, lookSIG, lookFCT, lookFSIG, lookTYC, lookEENV } =
1166              context              context
# Line 1119  Line 1175 
1175                    lookFSIG = cvt lookFSIG,                    lookFSIG = cvt lookFSIG,
1176                    lookTYC = cvt lookTYC,                    lookTYC = cvt lookTYC,
1177                    lookEENV = cvt lookEENV }                    lookEENV = cvt lookEENV }
1178          val { pickler, ... } = mkEnvPickler c          val { pickler', ... } = mkEnvPickler (c, fn _ => false)
1179      in      in
1180          pickler          pickler'
1181      end      end
1182    
1183      (* the dummy environment pickler *)      (* the dummy environment pickler *)

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

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