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 506, Fri Dec 10 00:15:35 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
465            share LTs ltyI x
466        (* if LK.ltp_norm x then
467           else bug "unexpected complex lambda type in mkPickleLty" ltyI x *)
468        end
469    
470      and lty x =      and tyc alpha x = let
471          if LK.ltp_norm x then share LTs ltyI x          val tyc = tyc alpha
472          else (* bug "unexpected complex lambda type in mkPickleLty" *) ltyI x          val lty = lty alpha
473            fun tycI x = let
     and tycI x = let  
474          val op $ = PU.$ TC          val op $ = PU.$ TC
475      in      in
476          case LK.tc_out x of          case LK.tc_out x of
477              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
478            | 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  
479            | LK.TC_PRIM t => "C" $ int (PT.pt_toint t)            | LK.TC_PRIM t => "C" $ int (PT.pt_toint t)
480            | LK.TC_FN (ks, tc) => "D" $ list tkind ks & tyc tc            | LK.TC_FN (ks, tc) => "D" $ list tkind ks & tyc tc
481            | 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 491 
491                  "M" $ bool b1 & bool b2 & list tyc ts1 & list tyc ts2                  "M" $ bool b1 & bool b2 & list tyc ts1 & list tyc ts2
492            | LK.TC_ARROW (LK.FF_FIXED, ts1, ts2) =>            | LK.TC_ARROW (LK.FF_FIXED, ts1, ts2) =>
493                  "N" $ list tyc ts1 & list tyc ts2                  "N" $ list tyc ts1 & list tyc ts2
           | LK.TC_PARROW _ => bug "unexpected TC_PARREW 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_PARROW _ => bug "unexpected TC_PARROW in mkPickleLty"
496            | LK.TC_IND _ => bug "unexpected TC_IND in mkPickleLty"            | LK.TC_IND _ => bug "unexpected TC_IND in mkPickleLty"
497            | LK.TC_ENV _ => bug "unexpected TC_ENV in mkPickleLty"            | LK.TC_ENV _ => bug "unexpected TC_ENV in mkPickleLty"
498            | LK.TC_CONT _ => bug "unexpected TC_CONT in mkPickleLty"            | LK.TC_CONT _ => bug "unexpected TC_CONT in mkPickleLty"
499      end      end
   
     and tyc x =  
         if LK.tcp_norm x then share TCs tycI x  
         else (* bug "unexpected complex lambda tyc in mkPickleLty" *) tycI x  
   
     and tkind x = let  
         val op $ = PU.$ TK  
         fun tk x =  
             case LK.tk_out x of  
             LK.TK_MONO => %TK "A"  
           | LK.TK_BOX => %TK "B"  
           | LK.TK_SEQ ks => "C" $ list tkind ks  
           | LK.TK_FUN (ks, kr) => "D" $ list tkind ks & tkind kr  
500      in      in
501          share TKs tk x          share TCs tycI x
502        (* if LK.tcp_norm x then
503           else bug "unexpected complex lambda tyc in mkPickleLty" tycI x *)
504      end      end
505    
506      (* the FLINT pickler *)      (* the FLINT pickler *)
507      fun flint flint_exp = let      fun flint flint_exp = let
508          val alphaConvert = mkAlphaConvert ()          val alphaConvert = mkAlphaConvert ()
509          val lvar = int o alphaConvert          val lvar = int o alphaConvert
510          val { access, conrep } = mkAccess lvar          val lty = lty alphaConvert
511            val tyc = tyc alphaConvert
512            val { access, conrep } = mkAccess { lvar = lvar,
513                                                isLocalPid = fn _ => false }
514          val op $ = PU.$ V          val op $ = PU.$ V
515          fun value (F.VAR v) = "a" $ lvar v          fun value (F.VAR v) = "a" $ lvar v
516            | value (F.INT i) = "b" $ int i            | value (F.INT i) = "b" $ int i
# Line 552  Line 586 
586              "a" $ fkind fk & lvar v & list (pair (lvar, lty)) vts & lexp e              "a" $ fkind fk & lvar v & list (pair (lvar, lty)) vts & lexp e
587          end          end
588    
589          and tfundec (v, tvks, e) = let          and tfundec (tfk, v, tvks, e) = let
590              val op $ = PU.$ TFUNDEC              val op $ = PU.$ TFUNDEC
591          in          in
592              "b" $ lvar v & list (pair (lvar, tkind)) tvks & lexp e              "b" $ lvar v & list (pair (lvar, tkind)) tvks & lexp e
# Line 560  Line 594 
594    
595          and fkind arg = let          and fkind arg = let
596              val op $ = PU.$ FK              val op $ = PU.$ FK
597              fun fk F.FK_FCT = %FK "2"              fun fk { isrec, cconv=F.CC_FCT, known, inline } = %FK "2"
598                | fk (F.FK_FUN { isrec, fixed, known, inline }) =                | fk { isrec, cconv=F.CC_FUN fixed, known, inline } =
599                  case fixed of                  case fixed of
600                      LK.FF_VAR (b1, b2) =>                      LK.FF_VAR (b1, b2) =>
601                          "3" $ option (list lty) isrec &                          "3" $ option (list lty) (Option.map (fn (x,y) => x) isrec) &
602                          bool b1 & bool b2 & bool known & bool inline                          bool b1 & bool b2 & bool known &
603                            bool (case inline of F.IH_ALWAYS => true | _ => false)
604                    | LK.FF_FIXED =>                    | LK.FF_FIXED =>
605                          "4" $ option (list lty) isrec &                          "4" $ option (list lty) (Option.map (fn (x,y) => x) isrec) &
606                          bool known & bool inline                          bool known &
607                            bool (case inline of F.IH_ALWAYS => true | _ => false)
608          in          in
609              fk arg              fk arg
610          end          end
# Line 615  Line 651 
651        | NodeStub of int * Symbol.symbol        | NodeStub of int * Symbol.symbol
652    
653      (* the environment pickler *)      (* the environment pickler *)
654      fun mkEnvPickler (context0: stubinfo context) = let      fun mkEnvPickler (context0: stubinfo context, isLocalPid) = let
655    
656          val { lookTYC, lookSIG, lookFSIG, lookSTR, lookFCT, lookEENV } =          val { lookTYC, lookSIG, lookFSIG, lookSTR, lookFCT, lookEENV } =
657              context0              context0
# Line 627  Line 663 
663          in          in
664              case scope of              case scope of
665                  Stamps.LOCAL => "A" $ int (alphaConvert count)                  Stamps.LOCAL => "A" $ int (alphaConvert count)
666                | Stamps.GLOBAL p => "B" $ pid p & int count                | Stamps.GLOBAL p =>
667                        if isLocalPid p then "A" $ int count
668                        else "B" $ pid p & int count
669                | Stamps.SPECIAL s => "C" $ string s & int count                | Stamps.SPECIAL s => "C" $ string s & int count
670          end          end
671    
# Line 654  Line 692 
692              j              j
693          end          end
694    
695          val { access, conrep } = mkAccess (int o anotherLvar)          val { access, conrep } = mkAccess { lvar = int o anotherLvar,
696                                                isLocalPid = isLocalPid }
697    
698          fun spath (SP.SPATH p) = list symbol p          fun spath (SP.SPATH p) = list symbol p
699          fun ipath (IP.IPATH p) = list symbol p          fun ipath (IP.IPATH p) = list symbol p
# Line 1072  Line 1111 
1111          in          in
1112              list (pair (symbol, binding)) pairs              list (pair (symbol, binding)) pairs
1113          end          end
1114    
1115            fun env'n'ctxt { env = e, ctxt } =
1116                pair (env, list modId) (e, ModuleId.Set.listItems ctxt)
1117      in      in
1118          { pickler = env, exportLvarsGetter = fn () => rev (!lvlist) }          { pickler = env, pickler' = env'n'ctxt,
1119              exportLvarsGetter = fn () => rev (!lvlist) }
1120      end      end
1121    
1122      fun pickleEnv { context, env } = let      fun pickleEnv { context, env } = let
# Line 1089  Line 1132 
1132                    lookTYC = cvt CMStaticEnv.lookTYC,                    lookTYC = cvt CMStaticEnv.lookTYC,
1133                    lookEENV = cvt CMStaticEnv.lookEENV }                    lookEENV = cvt CMStaticEnv.lookEENV }
1134    
1135          val { pickler, exportLvarsGetter } = mkEnvPickler c          val { pickler, exportLvarsGetter, ... } =
1136                mkEnvPickler (c, fn _ => false)
1137          val pickle = Byte.stringToBytes (PU.pickle emptyMap (pickler env))          val pickle = Byte.stringToBytes (PU.pickle emptyMap (pickler env))
1138          val exportLvars = exportLvarsGetter ()          val exportLvars = exportLvarsGetter ()
1139    
# Line 1105  Line 1149 
1149            exportPid = exportPid }            exportPid = exportPid }
1150      end      end
1151    
1152        fun repickleEnvHash { context, env, orig_hash } = let
1153            fun lk i =
1154                if ModuleId.Set.member (context, i) then SimpleStub else NoStub
1155            val c = { lookSTR = lk, lookSIG = lk, lookFCT = lk,
1156                      lookFSIG = lk, lookTYC = lk, lookEENV = lk }
1157            fun isLocalPid p = PersStamps.compare (p, orig_hash) = EQUAL
1158            val { pickler, ... } = mkEnvPickler (c, isLocalPid)
1159            val pickle = Byte.stringToBytes (PU.pickle emptyMap (pickler env))
1160        in
1161            pickle2hash pickle
1162        end
1163    
1164        type env'n'ctxt = { env: StaticEnv.staticEnv, ctxt: ModuleId.Set.set }
1165    
1166      fun envPickler context = let      fun envPickler context = let
1167          val { lookSTR, lookSIG, lookFCT, lookFSIG, lookTYC, lookEENV } =          val { lookSTR, lookSIG, lookFCT, lookFSIG, lookTYC, lookEENV } =
1168              context              context
# Line 1119  Line 1177 
1177                    lookFSIG = cvt lookFSIG,                    lookFSIG = cvt lookFSIG,
1178                    lookTYC = cvt lookTYC,                    lookTYC = cvt lookTYC,
1179                    lookEENV = cvt lookEENV }                    lookEENV = cvt lookEENV }
1180          val { pickler, ... } = mkEnvPickler c          val { pickler', ... } = mkEnvPickler (c, fn _ => false)
1181      in      in
1182          pickler          pickler'
1183      end      end
1184    
1185      (* the dummy environment pickler *)      (* the dummy environment pickler *)

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

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