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 506, Fri Dec 10 00:15:35 1999 UTC revision 515, Sun Jan 9 09:59:14 2000 UTC
# Line 164  Line 164 
164           DTF, TYCON, T, II, VAR, SD, SG, FSG,  SP, EN,           DTF, TYCON, T, II, VAR, SD, SG, FSG,  SP, EN,
165           STR, F, STE, TCE, STRE, FE, EE, ED, EEV, FX,           STR, F, STE, TCE, STRE, FE, EE, ED, EEV, FX,
166           B, DCON, DICT, FPRIM, FUNDEC, TFUNDEC, DATACON, DTMEM, NRD,           B, DCON, DICT, FPRIM, FUNDEC, TFUNDEC, DATACON, DTMEM, NRD,
167           OVERLD, FCTC, SEN, FEN) =           OVERLD, FCTC, SEN, FEN, SPATH, IPATH) =
168          (1, 2, 3, 4, 5, 6, 7, 8, 9, 10,          (1, 2, 3, 4, 5, 6, 7, 8, 9, 10,
169           11, 12, 13, 14, 15, 16, 17, 18, 19, 20,           11, 12, 13, 14, 15, 16, 17, 18, 19, 20,
170           21, 22, 23, 24, 25, 26, 27, 28, 29, 30,           21, 22, 23, 24, 25, 26, 27, 28, 29, 30,
171           31, 32, 33, 34, 35, 36, 37, 38, 39, 40,           31, 32, 33, 34, 35, 36, 37, 38, 39, 40,
172           41, 42, 43, 44, 45, 46, 47, 48, 49,           41, 42, 43, 44, 45, 46, 47, 48, 49,
173           50, 51, 52, 53)           50, 51, 52, 53, 54, 55)
174    
175      (* this is a bit awful...      (* this is a bit awful...
176       * (we really ought to have syntax for "functional update") *)       * (we really ought to have syntax for "functional update") *)
# Line 224  Line 224 
224                               mi = MIMap.insert (mi, x, v) } }                               mi = MIMap.insert (mi, x, v) } }
225    
226      infix 3 $      infix 3 $
     infixr 4 &  
     val op & = PU.&  
     val % = PU.%  
227    
228      val int = PU.w_int      val int = PU.w_int
229      val int32 = PU.w_int32      val int32 = PU.w_int32
# Line 260  Line 257 
257    
258      fun numkind arg = let      fun numkind arg = let
259          val op $ = PU.$ NK          val op $ = PU.$ NK
260          fun nk (P.INT i) = "A" $ int i          fun nk (P.INT i) = "A" $ [int i]
261            | nk (P.UINT i) = "B" $ int i            | nk (P.UINT i) = "B" $ [int i]
262            | nk (P.FLOAT i) = "C" $ int i            | nk (P.FLOAT i) = "C" $ [int i]
263      in      in
264          nk arg          nk arg
265      end      end
266    
267      fun arithop oper = let      fun arithop oper = let
268            val op $ = PU.$ AO
269          fun arithopc P.+ = "\000"          fun arithopc P.+ = "\000"
270            | arithopc P.- = "\001"            | arithopc P.- = "\001"
271            | arithopc P.* = "\002"            | arithopc P.* = "\002"
# Line 282  Line 280 
280            | arithopc P.XORB = "\011"            | arithopc P.XORB = "\011"
281            | arithopc P.NOTB = "\012"            | arithopc P.NOTB = "\012"
282      in      in
283          % AO (arithopc oper)          arithopc oper $ []
284      end      end
285    
286      fun cmpop oper = let      fun cmpop oper = let
287            val op $ = PU.$ CO
288          fun cmpopc P.> = "\000"          fun cmpopc P.> = "\000"
289            | cmpopc P.>= = "\001"            | cmpopc P.>= = "\001"
290            | cmpopc P.< = "\002"            | cmpopc P.< = "\002"
# Line 297  Line 296 
296            | cmpopc P.EQL = "\008"            | cmpopc P.EQL = "\008"
297            | cmpopc P.NEQ = "\009"            | cmpopc P.NEQ = "\009"
298      in      in
299          % CO (cmpopc oper)          cmpopc oper $ []
300      end      end
301    
302      fun primop p = let      fun primop p = let
303          val op $ = PU.$ PO          val op $ = PU.$ PO
304          fun ?n = String.str (Char.chr n)          fun ?n = String.str (Char.chr n)
305          fun fromto tag (from, to) = ?tag $ int from & int to          fun fromto tag (from, to) = ?tag $ [int from, int to]
306          fun %?n = % PO (?n)          fun %?n = ?n $ []
307          in          in
308              case p of              case p of
309                  P.ARITH { oper, overflow, kind } =>                  P.ARITH { oper, overflow, kind } =>
310                      ?100 $ arithop oper & bool overflow & numkind kind                      ?100 $ [arithop oper, bool overflow, numkind kind]
311                | P.CMP { oper, kind } => ?101 $ cmpop oper & numkind kind                | P.CMP { oper, kind } => ?101 $ [cmpop oper, numkind kind]
312                | P.TEST x => fromto 102 x                | P.TEST x => fromto 102 x
313                | P.TESTU x => fromto 103 x                | P.TESTU x => fromto 103 x
314                | P.TRUNC x => fromto 104 x                | P.TRUNC x => fromto 104 x
315                | P.EXTEND x => fromto 105 x                | P.EXTEND x => fromto 105 x
316                | P.COPY x => fromto 106 x                | P.COPY x => fromto 106 x
317                | P.INLLSHIFT kind => ?107 $ numkind kind                | P.INLLSHIFT kind => ?107 $ [numkind kind]
318                | P.INLRSHIFT kind => ?108 $ numkind kind                | P.INLRSHIFT kind => ?108 $ [numkind kind]
319                | P.INLRSHIFTL kind => ?109 $ numkind kind                | P.INLRSHIFTL kind => ?109 $ [numkind kind]
320                | P.ROUND { floor, fromkind, tokind } =>                | P.ROUND { floor, fromkind, tokind } =>
321                      ?110 $ bool floor & numkind fromkind & numkind tokind                      ?110 $ [bool floor, numkind fromkind, numkind tokind]
322                | P.REAL { fromkind, tokind } =>                | P.REAL { fromkind, tokind } =>
323                      ?111 $ numkind fromkind & numkind tokind                      ?111 $ [numkind fromkind, numkind tokind]
324                | P.NUMSUBSCRIPT { kind, checked, immutable } =>                | P.NUMSUBSCRIPT { kind, checked, immutable } =>
325                      ?112 $ numkind kind & bool checked & bool immutable                      ?112 $ [numkind kind, bool checked, bool immutable]
326                | P.NUMUPDATE { kind, checked } =>                | P.NUMUPDATE { kind, checked } =>
327                      ?113 $ numkind kind & bool checked                      ?113 $ [numkind kind, bool checked]
328                | P.INL_MONOARRAY kind => ?114 $ numkind kind                | P.INL_MONOARRAY kind => ?114 $ [numkind kind]
329                | P.INL_MONOVECTOR kind => ?115 $ numkind kind                | P.INL_MONOVECTOR kind => ?115 $ [numkind kind]
330    
331                | P.MKETAG => %?0                | P.MKETAG => %?0
332                | P.WRAP => %?1                | P.WRAP => %?1
# Line 397  Line 396 
396    
397      fun consig arg = let      fun consig arg = let
398          val op $ = PU.$ CS          val op $ = PU.$ CS
399          fun cs (A.CSIG (i, j)) = "S" $ int i & int j          fun cs (A.CSIG (i, j)) = "S" $ [int i, int j]
400            | cs A.CNIL = % CS "N"            | cs A.CNIL = "N" $ []
401      in      in
402          cs arg          cs arg
403      end      end
404    
     fun 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  
     end  
   
405      fun mkAccess { lvar, isLocalPid } = let      fun mkAccess { lvar, isLocalPid } = let
406          val op $ = PU.$ A          val op $ = PU.$ A
407          fun access (A.LVAR i) = "A" $ lvar i          fun access (A.LVAR i) = "A" $ [lvar i]
408            | access (A.EXTERN p) = "B" $ pid p            | access (A.EXTERN p) = "B" $ [pid p]
409            | access (A.PATH (a as A.EXTERN p, i)) =            | access (A.PATH (a as A.EXTERN p, i)) =
410              (* isLocalPid always returns false for in the "normal pickler"              (* isLocalPid always returns false for in the "normal pickler"
411               * case.  It returns true in the "repickle" case for the               * case.  It returns true in the "repickle" case for the
412               * pid that was the hash of the original whole pickle.               * pid that was the hash of the original whole pickle.
413               * Since alpha-conversion has already taken place if we find               * Since alpha-conversion has already taken place if we find
414               * an EXTERN pid, we don't call "lvar" but "int". *)               * an EXTERN pid, we don't call "lvar" but "int". *)
415              if isLocalPid p then "A" $ int i              if isLocalPid p then "A" $ [int i]
416              else "C" $ access a & int i              else "C" $ [access a, int i]
417            | access (A.PATH (a, i)) = "C" $ access a & int i            | access (A.PATH (a, i)) = "C" $ [access a, int i]
418            | access A.NO_ACCESS = % A "D"            | access A.NO_ACCESS = "D" $ []
419    
420          val op $ = PU.$ CR          val op $ = PU.$ CR
421          fun conrep A.UNTAGGED = % CR "A"          fun conrep A.UNTAGGED = "A" $ []
422            | conrep (A.TAGGED i) = "B" $ int i            | conrep (A.TAGGED i) = "B" $ [int i]
423            | conrep A.TRANSPARENT = %CR "C"            | conrep A.TRANSPARENT = "C" $ []
424            | conrep (A.CONSTANT i) = "D" $ int i            | conrep (A.CONSTANT i) = "D" $ [int i]
425            | conrep A.REF = %CR "E"            | conrep A.REF = "E" $ []
426            | conrep (A.EXN a) = "F" $ access a            | conrep (A.EXN a) = "F" $ [access a]
427            | conrep A.LISTCONS = %CR "G"            | conrep A.LISTCONS = "G" $ []
428            | conrep A.LISTNIL = %CR "H"            | conrep A.LISTNIL = "H" $ []
429            | conrep (A.SUSP NONE) = %CR "I"            | conrep (A.SUSP NONE) = "I" $ []
430            | conrep (A.SUSP (SOME (a, b))) = "J" $ access a & access b            | conrep (A.SUSP (SOME (a, b))) = "J" $ [access a, access b]
431      in      in
432          { access = access, conrep = conrep }          { access = access, conrep = conrep }
433      end      end
434    
435      (* lambda-type stuff; this is used in both picklers *)      (* lambda-type stuff; some of it is used in both picklers *)
436      and lty alpha x = let      fun tkind x = let
437          val lty = lty alpha          val op $ = PU.$ TK
438          val tyc = tyc alpha          fun tk x =
439          fun ltyI x = let              case LK.tk_out x of
440              val op $ = PU.$ LT              LK.TK_MONO => "A" $ []
441              | LK.TK_BOX => "B" $ []
442              | LK.TK_SEQ ks => "C" $ [list tkind ks]
443              | LK.TK_FUN (ks, kr) => "D" $ [list tkind ks, tkind kr]
444          in          in
445            share TKs tk x
446        end
447    
448        fun mkLty lvar = let
449            fun lty x = let
450                val op $ = PU.$ LT
451                fun ltyI x =
452              case LK.lt_out x of              case LK.lt_out x of
453                  LK.LT_TYC tc => "A" $ tyc tc                      LK.LT_TYC tc => "A" $ [tyc tc]
454                | LK.LT_STR l => "B" $ list lty l                    | LK.LT_STR l => "B" $ [list lty l]
455                | LK.LT_FCT (ts1, ts2) => "C" $ list lty ts1 & list lty ts2                    | LK.LT_FCT (ts1, ts2) => "C" $ [list lty ts1, list lty ts2]
456                | LK.LT_POLY (ks, ts) => "D" $ list tkind ks & list lty ts                    | LK.LT_POLY (ks, ts) => "D" $ [list tkind ks, list lty ts]
457                | LK.LT_IND _ => bug "unexpected LT_IND in mkPickleLty"                | LK.LT_IND _ => bug "unexpected LT_IND in mkPickleLty"
458                | LK.LT_ENV _ => bug "unexpected LT_ENV in mkPickleLty"                | LK.LT_ENV _ => bug "unexpected LT_ENV in mkPickleLty"
459                | LK.LT_CONT _ => bug "unexpected LT_CONT in mkPickleLty"                | LK.LT_CONT _ => bug "unexpected LT_CONT in mkPickleLty"
         end  
460      in      in
461          share LTs ltyI x          share LTs ltyI x
     (* if LK.ltp_norm x then  
        else bug "unexpected complex lambda type in mkPickleLty" ltyI x *)  
462      end      end
463    
464      and tyc alpha x = let          and tyc x = let
         val tyc = tyc alpha  
         val lty = lty alpha  
         fun tycI x = let  
465              val op $ = PU.$ TC              val op $ = PU.$ TC
466          in              fun tycI x =
467              case LK.tc_out x of              case LK.tc_out x of
468                  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]
469                | LK.TC_NVAR n => "B" $ (int o alpha) n                    | LK.TC_NVAR n => "B" $ [lvar n]
470                | LK.TC_PRIM t => "C" $ int (PT.pt_toint t)                    | LK.TC_PRIM t => "C" $ [int (PT.pt_toint t)]
471                | LK.TC_FN (ks, tc) => "D" $ list tkind ks & tyc tc                    | LK.TC_FN (ks, tc) => "D" $ [list tkind ks, tyc tc]
472                | LK.TC_APP (tc, l) => "E" $ tyc tc & list tyc l                    | LK.TC_APP (tc, l) => "E" $ [tyc tc, list tyc l]
473                | LK.TC_SEQ l => "F" $ list tyc l                    | LK.TC_SEQ l => "F" $ [list tyc l]
474                | LK.TC_PROJ (tc, i) => "G" $ tyc tc & int i                    | LK.TC_PROJ (tc, i) => "G" $ [tyc tc, int i]
475                | LK.TC_SUM l => "H" $ list tyc l                    | LK.TC_SUM l => "H" $ [list tyc l]
476                | LK.TC_FIX ((n, tc, ts), i) =>                | LK.TC_FIX ((n, tc, ts), i) =>
477                  "I" $ int n & tyc tc & list tyc ts & int i                          "I" $ [int n, tyc tc, list tyc ts, int i]
478                | LK.TC_ABS tc => "J" $ tyc tc                    | LK.TC_ABS tc => "J" $ [tyc tc]
479                | LK.TC_BOX tc => "K" $ tyc tc                    | LK.TC_BOX tc => "K" $ [tyc tc]
480                | LK.TC_TUPLE (_, l) => "L" $ list tyc l                    | LK.TC_TUPLE (_, l) => "L" $ [list tyc l]
481                | LK.TC_ARROW (LK.FF_VAR (b1, b2), ts1, ts2) =>                | LK.TC_ARROW (LK.FF_VAR (b1, b2), ts1, ts2) =>
482                  "M" $ bool b1 & bool b2 & list tyc ts1 & list tyc ts2                          "M" $ [bool b1, bool b2, list tyc ts1, list tyc ts2]
483                | LK.TC_ARROW (LK.FF_FIXED, ts1, ts2) =>                | LK.TC_ARROW (LK.FF_FIXED, ts1, ts2) =>
484                  "N" $ list tyc ts1 & list tyc ts2                          "N" $ [list tyc ts1, list tyc ts2]
485                | LK.TC_TOKEN (tk, t) => "O" $ int (LK.token_int tk) & tyc t                    | LK.TC_PARROW _ => bug "unexpected TC_PARREW in mkPickleLty"
486                | LK.TC_PARROW _ => bug "unexpected TC_PARROW in mkPickleLty"                    | LK.TC_TOKEN (tk, t) => "O" $ [int (LK.token_int tk), tyc t]
487                | LK.TC_IND _ => bug "unexpected TC_IND in mkPickleLty"                | LK.TC_IND _ => bug "unexpected TC_IND in mkPickleLty"
488                | LK.TC_ENV _ => bug "unexpected TC_ENV in mkPickleLty"                | LK.TC_ENV _ => bug "unexpected TC_ENV in mkPickleLty"
489                | LK.TC_CONT _ => bug "unexpected TC_CONT in mkPickleLty"                | LK.TC_CONT _ => bug "unexpected TC_CONT in mkPickleLty"
         end  
490      in      in
491          share TCs tycI x          share TCs tycI x
492      (* if LK.tcp_norm x then          end
493         else bug "unexpected complex lambda tyc in mkPickleLty" tycI x *)      in
494            { tyc = tyc, lty = lty }
495      end      end
496    
497      (* the FLINT pickler *)      (* the FLINT pickler *)
498      fun flint flint_exp = let      fun flint flint_exp = let
499          val alphaConvert = mkAlphaConvert ()          val alphaConvert = mkAlphaConvert ()
500          val lvar = int o alphaConvert          val lvar = int o alphaConvert
         val lty = lty alphaConvert  
         val tyc = tyc alphaConvert  
501          val { access, conrep } = mkAccess { lvar = lvar,          val { access, conrep } = mkAccess { lvar = lvar,
502                                              isLocalPid = fn _ => false }                                              isLocalPid = fn _ => false }
503            val { lty, tyc } = mkLty lvar
504    
505          val op $ = PU.$ V          val op $ = PU.$ V
506          fun value (F.VAR v) = "a" $ lvar v          fun value (F.VAR v) = "a" $ [lvar v]
507            | value (F.INT i) = "b" $ int i            | value (F.INT i) = "b" $ [int i]
508            | value (F.INT32 i32) = "c" $ int32 i32            | value (F.INT32 i32) = "c" $ [int32 i32]
509            | value (F.WORD w) = "d" $ word w            | value (F.WORD w) = "d" $ [word w]
510            | value (F.WORD32 w32) = "e" $ word32 w32            | value (F.WORD32 w32) = "e" $ [word32 w32]
511            | value (F.REAL s) = "f" $ string s            | value (F.REAL s) = "f" $ [string s]
512            | value (F.STRING s) = "g" $ string s            | value (F.STRING s) = "g" $ [string s]
513    
514          fun con arg = let          fun con arg = let
515              val op $ = PU.$ C              val op $ = PU.$ C
516              fun c (F.DATAcon (dc, ts, v), e) =              fun c (F.DATAcon (dc, ts, v), e) =
517                  "1" $ dcon (dc, ts) & lvar v & lexp e                  "1" $ [dcon (dc, ts), lvar v, lexp e]
518                | c (F.INTcon i, e) = "2" $ int i & lexp e                | c (F.INTcon i, e) = "2" $ [int i, lexp e]
519                | c (F.INT32con i32, e) = "3" $ int32 i32 & lexp e                | c (F.INT32con i32, e) = "3" $ [int32 i32, lexp e]
520                | c (F.WORDcon w, e) = "4" $ word w & lexp e                | c (F.WORDcon w, e) = "4" $ [word w, lexp e]
521                | c (F.WORD32con w32, e) = "5" $ word32 w32 & lexp e                | c (F.WORD32con w32, e) = "5" $ [word32 w32, lexp e]
522                | c (F.REALcon s, e) = "6" $ string s & lexp e                | c (F.REALcon s, e) = "6" $ [string s, lexp e]
523                | c (F.STRINGcon s, e) = "7" $ string s & lexp e                | c (F.STRINGcon s, e) = "7" $ [string s, lexp e]
524                | c (F.VLENcon i, e) = "8" $ int i & lexp e                | c (F.VLENcon i, e) = "8" $ [int i, lexp e]
525          in          in
526              c arg              c arg
527          end          end
# Line 538  Line 529 
529          and dcon ((s, cr, t), ts) = let          and dcon ((s, cr, t), ts) = let
530              val op $ = PU.$ DCON              val op $ = PU.$ DCON
531          in          in
532              "x" $ symbol s & conrep cr & lty t & list tyc ts              "x" $ [symbol s, conrep cr, lty t, list tyc ts]
533          end          end
534    
535          and dict { default = v, table = tbls } = let          and dict { default = v, table = tbls } = let
536              val op $ = PU.$ DICT              val op $ = PU.$ DICT
537          in          in
538              "y" $ lvar v & list (pair (list tyc, lvar)) tbls              "y" $ [lvar v, list (pair (list tyc, lvar)) tbls]
539          end          end
540    
541          and fprim (dtopt, p, t, ts) = let          and fprim (dtopt, p, t, ts) = let
542              val op $ = PU.$ FPRIM              val op $ = PU.$ FPRIM
543          in          in
544              "z" $ option dict dtopt & primop p & lty t & list tyc ts              "z" $ [option dict dtopt, primop p, lty t, list tyc ts]
545          end          end
546    
547          and lexp arg = let          and lexp arg = let
548              val op $ = PU.$ E              val op $ = PU.$ E
549              fun l (F.RET vs) = "j" $ list value vs              fun l (F.RET vs) = "j" $ [list value vs]
550                | l (F.LET (vs, e1, e2)) =                | l (F.LET (vs, e1, e2)) =
551                  "k" $ list lvar vs & lexp e1 & lexp e2                  "k" $ [list lvar vs, lexp e1, lexp e2]
552                | l (F.FIX (fdecs, e)) = "l" $ list fundec fdecs & lexp e                | l (F.FIX (fdecs, e)) = "l" $ [list fundec fdecs, lexp e]
553                | l (F.APP (v, vs)) = "m" $ value v & list value vs                | l (F.APP (v, vs)) = "m" $ [value v, list value vs]
554                | l (F.TFN (tfdec, e)) = "n" $ tfundec tfdec & lexp e                | l (F.TFN (tfdec, e)) = "n" $ [tfundec tfdec, lexp e]
555                | l (F.TAPP (v, ts)) = "o" $ value v & list tyc ts                | l (F.TAPP (v, ts)) = "o" $ [value v, list tyc ts]
556                | l (F.SWITCH (v, crl, cel, eo)) =                | l (F.SWITCH (v, crl, cel, eo)) =
557                  "p" $ value v & consig crl & list con cel & option lexp eo                  "p" $ [value v, consig crl, list con cel, option lexp eo]
558                | l (F.CON (dc, ts, u, v, e)) =                | l (F.CON (dc, ts, u, v, e)) =
559                  "q" $ dcon (dc, ts) & value u & lvar v & lexp e                  "q" $ [dcon (dc, ts), value u, lvar v, lexp e]
560                | l (F.RECORD (rk, vl, v, e)) =                | l (F.RECORD (rk, vl, v, e)) =
561                  "r" $ rkind rk & list value vl & lvar v & lexp e                  "r" $ [rkind rk, list value vl, lvar v, lexp e]
562                | l (F.SELECT (u, i, v, e)) =                | l (F.SELECT (u, i, v, e)) =
563                  "s" $ value u & int i & lvar v & lexp e                  "s" $ [value u, int i, lvar v, lexp e]
564                | l (F.RAISE (u, ts)) = "t" $ value u & list lty ts                | l (F.RAISE (u, ts)) = "t" $ [value u, list lty ts]
565                | l (F.HANDLE (e, u)) = "u" $ lexp e & value u                | l (F.HANDLE (e, u)) = "u" $ [lexp e, value u]
566                | l (F.BRANCH (p, vs, e1, e2)) =                | l (F.BRANCH (p, vs, e1, e2)) =
567                  "v" $ fprim p & list value vs & lexp e1 & lexp e2                  "v" $ [fprim p, list value vs, lexp e1, lexp e2]
568                | l (F.PRIMOP (p, vs, v, e)) =                | l (F.PRIMOP (p, vs, v, e)) =
569                  "w" $ fprim p & list value vs & lvar v & lexp e                  "w" $ [fprim p, list value vs, lvar v, lexp e]
570          in          in
571              l arg              l arg
572          end          end
# Line 583  Line 574 
574          and fundec (fk, v, vts, e) = let          and fundec (fk, v, vts, e) = let
575              val op $ = PU.$ FUNDEC              val op $ = PU.$ FUNDEC
576          in          in
577              "a" $ fkind fk & lvar v & list (pair (lvar, lty)) vts & lexp e              "a" $ [fkind fk, lvar v, list (pair (lvar, lty)) vts, lexp e]
578          end          end
579    
580          and tfundec (tfk, v, tvks, e) = let          and tfundec (_, v, tvks, e) = let
581              val op $ = PU.$ TFUNDEC              val op $ = PU.$ TFUNDEC
582          in          in
583              "b" $ lvar v & list (pair (lvar, tkind)) tvks & lexp e              "b" $ [lvar v, list (pair (lvar, tkind)) tvks, lexp e]
584          end          end
585    
586          and fkind arg = let          and fkind arg = let
587              val op $ = PU.$ FK              val op $ = PU.$ FK
588              fun fk { isrec, cconv=F.CC_FCT, known, inline } = %FK "2"              fun isAlways F.IH_ALWAYS = true
589                  | isAlways _ = false
590                fun strip (x, y) = x
591                fun fk { cconv = F.CC_FCT, ... } = "2" $ []
592                | fk { isrec, cconv=F.CC_FUN fixed, known, inline } =                | fk { isrec, cconv=F.CC_FUN fixed, known, inline } =
593                  case fixed of                  case fixed of
594                      LK.FF_VAR (b1, b2) =>                      LK.FF_VAR (b1, b2) =>
595                          "3" $ option (list lty) (Option.map (fn (x,y) => x) isrec) &                          "3" $ [option (list lty) (Option.map strip isrec),
596                          bool b1 & bool b2 & bool known &                                 bool b1, bool b2, bool known,
597                          bool (case inline of F.IH_ALWAYS => true | _ => false)                                 bool (isAlways inline)]
598                    | LK.FF_FIXED =>                    | LK.FF_FIXED =>
599                          "4" $ option (list lty) (Option.map (fn (x,y) => x) isrec) &                          "4" $ [option (list lty) (Option.map strip isrec),
600                          bool known &                                 bool known, bool (isAlways inline)]
                         bool (case inline of F.IH_ALWAYS => true | _ => false)  
601          in          in
602              fk arg              fk arg
603          end          end
604    
605          and rkind arg = let          and rkind arg = let
606              val op $ = PU.$ RK              val op $ = PU.$ RK
607              fun rk (F.RK_VECTOR tc) = "5" $ tyc tc              fun rk (F.RK_VECTOR tc) = "5" $ [tyc tc]
608                | rk F.RK_STRUCT = %RK "6"                | rk F.RK_STRUCT = "6" $ []
609                | rk (F.RK_TUPLE _) = %RK "7"                | rk (F.RK_TUPLE _) = "7" $ []
610          in          in
611              rk arg              rk arg
612          end          end
# Line 662  Line 655 
655              val op $ = PU.$ ST              val op $ = PU.$ ST
656          in          in
657              case scope of              case scope of
658                  Stamps.LOCAL => "A" $ int (alphaConvert count)                  Stamps.LOCAL => "A" $ [int (alphaConvert count)]
659                | Stamps.GLOBAL p =>                | Stamps.GLOBAL p =>
660                      if isLocalPid p then "A" $ int count                      if isLocalPid p then "A" $ [int count]
661                      else "B" $ pid p & int count                      else "B" $ [pid p, int count]
662                | Stamps.SPECIAL s => "C" $ string s & int count                | Stamps.SPECIAL s => "C" $ [string s, int count]
663          end          end
664    
665          val entVar = stamp          val entVar = stamp
666          val entPath = list entVar          val entPath = list entVar
667    
668          val op $ = PU.$ MI          val op $ = PU.$ MI
669          fun modId (MI.STRid { rlzn, sign }) = "1" $ stamp rlzn & stamp sign          fun modId (MI.STRid { rlzn, sign }) = "1" $ [stamp rlzn, stamp sign]
670            | modId (MI.SIGid s) = "2" $ stamp s            | modId (MI.SIGid s) = "2" $ [stamp s]
671            | modId (MI.FCTid { rlzn, sign }) = "3" $ stamp rlzn & modId sign            | modId (MI.FCTid { rlzn, sign }) = "3" $ [stamp rlzn, modId sign]
672            | modId (MI.FSIGid { paramsig, bodysig }) =            | modId (MI.FSIGid { paramsig, bodysig }) =
673              "4" $ stamp paramsig & stamp bodysig              "4" $ [stamp paramsig, stamp bodysig]
674            | modId (MI.TYCid a) = "5" $ stamp a            | modId (MI.TYCid a) = "5" $ [stamp a]
675            | modId (MI.EENVid s) = "6" $ stamp s            | modId (MI.EENVid s) = "6" $ [stamp s]
676    
677          val lvcount = ref 0          val lvcount = ref 0
678          val lvlist = ref []          val lvlist = ref []
# Line 695  Line 688 
688          val { access, conrep } = mkAccess { lvar = int o anotherLvar,          val { access, conrep } = mkAccess { lvar = int o anotherLvar,
689                                              isLocalPid = isLocalPid }                                              isLocalPid = isLocalPid }
690    
691          fun spath (SP.SPATH p) = list symbol p          val op $ = PU.$ SPATH
692          fun ipath (IP.IPATH p) = list symbol p          fun spath (SP.SPATH p) = "s" $ [list symbol p]
693            val op $ = PU.$ IPATH
694            fun ipath (IP.IPATH p) = "i" $ [list symbol p]
695    
696          val label = symbol          val label = symbol
697    
698          fun eqprop eqp = let          fun eqprop eqp = let
699                val op $ = PU.$ EQP
700              fun eqc T.YES = "\000"              fun eqc T.YES = "\000"
701                | eqc T.NO = "\001"                | eqc T.NO = "\001"
702                | eqc T.IND = "\002"                | eqc T.IND = "\002"
# Line 709  Line 705 
705                | eqc T.ABS = "\005"                | eqc T.ABS = "\005"
706                | eqc T.UNDEF = "\006"                | eqc T.UNDEF = "\006"
707          in          in
708              %EQP (eqc eqp)              eqc eqp $ []
709          end          end
710    
711          fun datacon (T.DATACON { name, const, typ, rep, sign, lazyp }) = let          fun datacon (T.DATACON { name, const, typ, rep, sign, lazyp }) = let
712              val op $ = PU.$ DATACON              val op $ = PU.$ DATACON
713          in          in
714              "c" $ symbol name & bool const & ty typ & conrep rep &              "c" $ [symbol name, bool const, ty typ, conrep rep,
715                    consig sign & bool lazyp                     consig sign, bool lazyp]
716          end          end
717    
718          and tyckind arg = let          and tyckind arg = let
719              val op $ = PU.$ TYCKIND              val op $ = PU.$ TYCKIND
720              fun tk (T.PRIMITIVE pt) = "a" $ int (PT.pt_toint pt)              fun tk (T.PRIMITIVE pt) = "a" $ [int (PT.pt_toint pt)]
721                | tk (T.DATATYPE { index, family, stamps, root,freetycs }) =                | tk (T.DATATYPE { index, family, stamps, root,freetycs }) =
722                  "b" $ int index & option entVar root &                  "b" $ [int index, option entVar root,
723                        dtypeInfo (stamps, family, freetycs)                         dtypeInfo (stamps, family, freetycs)]
724                | tk (T.ABSTRACT tyc) = "c" $ tycon tyc                | tk (T.ABSTRACT tyc) = "c" $ [tycon tyc]
725                | tk (T.FLEXTYC tps) = %TYCKIND "d" (* "f" $ tycpath tps *)                | tk (T.FLEXTYC tps) = "d" $ [] (* "f" $ tycpath tps *)
726                (*** I (Matthias) carried through this message from Zhong:                (*** I (Matthias) carried through this message from Zhong:
727                 tycpath should never be pickled; the only way it can be                 tycpath should never be pickled; the only way it can be
728                 pickled is when pickling the domains of a mutually                 pickled is when pickling the domains of a mutually
# Line 734  Line 730 
730                 datatypes are not assigned accurate domains ... (ZHONG)                 datatypes are not assigned accurate domains ... (ZHONG)
731                 the preceding code is just a temporary gross hack.                 the preceding code is just a temporary gross hack.
732                 ***)                 ***)
733                | tk T.FORMAL = %TYCKIND "d"                | tk T.FORMAL = "d" $ []
734                | tk T.TEMP = %TYCKIND "e"                | tk T.TEMP = "e" $ []
735          in          in
736              tk arg              tk arg
737          end          end
# Line 743  Line 739 
739          and dtypeInfo x = let          and dtypeInfo x = let
740              val op $ = PU.$ DTI              val op $ = PU.$ DTI
741              fun dti_raw (ss, family, freetycs) =              fun dti_raw (ss, family, freetycs) =
742                  "a" $ list stamp (Vector.foldr (op ::) [] ss) &                  "a" $ [list stamp (Vector.foldr (op ::) [] ss),
743                        dtFamily family & list tycon freetycs                         dtFamily family, list tycon freetycs]
744          in          in
745              share (DTs (Vector.sub (#1 x, 0))) dti_raw x              share (DTs (Vector.sub (#1 x, 0))) dti_raw x
746          end          end
# Line 752  Line 748 
748          and dtFamily x = let          and dtFamily x = let
749              val op $ = PU.$ DTF              val op $ = PU.$ DTF
750              fun dtf_raw { mkey, members, lambdatyc } =              fun dtf_raw { mkey, members, lambdatyc } =
751                  "b" $ stamp mkey &                  "b" $ [stamp mkey,
752                        list dtmember (Vector.foldr (op ::) [] members)                         list dtmember (Vector.foldr (op ::) [] members)]
753          in          in
754              share (MBs (#mkey x)) dtf_raw x              share (MBs (#mkey x)) dtf_raw x
755          end          end
# Line 761  Line 757 
757          and dtmember { tycname, dcons, arity, eq = ref e, lazyp, sign } = let          and dtmember { tycname, dcons, arity, eq = ref e, lazyp, sign } = let
758              val op $ = PU.$ DTMEM              val op $ = PU.$ DTMEM
759          in          in
760              "c" $ symbol tycname & list nameRepDomain dcons & int arity &              "c" $ [symbol tycname, list nameRepDomain dcons, int arity,
761                    eqprop e & bool lazyp & consig sign                     eqprop e, bool lazyp, consig sign]
762          end          end
763    
764          and nameRepDomain { name, rep, domain } = let          and nameRepDomain { name, rep, domain } = let
765              val op $ = PU.$ NRD              val op $ = PU.$ NRD
766          in          in
767              "d" $ symbol name & conrep rep & option ty domain              "d" $ [symbol name, conrep rep, option ty domain]
768          end          end
769    
770          and tycon arg = let          and tycon arg = let
# Line 777  Line 773 
773                  let val id = MI.TYCid (#stamp x)                  let val id = MI.TYCid (#stamp x)
774                      fun gt_raw { stamp = s, arity, eq = ref eq, kind, path } =                      fun gt_raw { stamp = s, arity, eq = ref eq, kind, path } =
775                          case lookTYC id of                          case lookTYC id of
776                              SimpleStub => "A" $ modId id                              SimpleStub => "A" $ [modId id]
777                            | NoStub => "B" $ stamp s & int arity & eqprop eq &                            | NoStub => "B" $ [stamp s, int arity, eqprop eq,
778                                              tyckind kind & ipath path                                               tyckind kind, ipath path]
779                            | PrimStub s => "I" $ string s & modId id                            | PrimStub s => "I" $ [string s, modId id]
780                            | NodeStub (i, s) =>                            | NodeStub (i, s) =>
781                                              "J" $ int i & symbol s & modId id                                  "J" $ [int i, symbol s, modId id]
782                  in                  in
783                      share (MIs (id, NONE)) gt_raw x                      share (MIs (id, NONE)) gt_raw x
784                  end                  end
# Line 791  Line 787 
787                          val { stamp = s, tyfun, strict, path } = x                          val { stamp = s, tyfun, strict, path } = x
788                          val T.TYFUN { arity, body } = tyfun                          val T.TYFUN { arity, body } = tyfun
789                      in                      in
790                          "C" $ stamp s & int arity & ty body &                          "C" $ [stamp s, int arity, ty body,
791                                list bool strict & ipath path                                 list bool strict, ipath path]
792                      end                      end
793                  in                  in
794                      share (MIs (MI.TYCid (#stamp x), NONE)) dt_raw x                      share (MIs (MI.TYCid (#stamp x), NONE)) dt_raw x
795                  end                  end
796                | tc (T.PATHtyc { arity, entPath = ep, path }) =                | tc (T.PATHtyc { arity, entPath = ep, path }) =
797                  "D" $ int arity & entPath ep & ipath path                  "D" $ [int arity, entPath ep, ipath path]
798                | tc (T.RECORDtyc l) = "E" $ list label l                | tc (T.RECORDtyc l) = "E" $ [list label l]
799                | tc (T.RECtyc i) = "F" $ int i                | tc (T.RECtyc i) = "F" $ [int i]
800                | tc (T.FREEtyc i) = "G" $ int i                | tc (T.FREEtyc i) = "G" $ [int i]
801                | tc T.ERRORtyc = %TC "H"                | tc T.ERRORtyc = "H" $ []
802          in          in
803              tc arg              tc arg
804          end          end
# Line 812  Line 808 
808              fun ty (T.VARty (ref (T.INSTANTIATED t))) = ty t              fun ty (T.VARty (ref (T.INSTANTIATED t))) = ty t
809                | ty (T.VARty (ref (T.OPEN _))) =                | ty (T.VARty (ref (T.OPEN _))) =
810                  bug "uninstantiated VARty in pickmod"                  bug "uninstantiated VARty in pickmod"
811                | ty (T.CONty (c, l)) = "a" $ tycon c & list ty l                | ty (T.CONty (c, l)) = "a" $ [tycon c, list ty l]
812                | ty (T.IBOUND i) = "b" $ int i                | ty (T.IBOUND i) = "b" $ [int i]
813                | ty T.WILDCARDty = %T "c"                | ty T.WILDCARDty = "c" $ []
814                | ty (T.POLYty { sign, tyfun = T.TYFUN { arity, body } }) =                | ty (T.POLYty { sign, tyfun = T.TYFUN { arity, body } }) =
815                  "d" $ list bool sign & int arity & ty body                  "d" $ [list bool sign, int arity, ty body]
816                | ty T.UNDEFty = %T "e"                | ty T.UNDEFty = "e" $ []
817                | ty _ = bug "unexpected type in pickmod-ty"                | ty _ = bug "unexpected type in pickmod-ty"
818          in          in
819              ty arg              ty arg
820          end          end
821    
822          val op $ = PU.$ II          val op $ = PU.$ II
823          fun inl_info (II.INL_PRIM (p, t)) = "A" $ primop p & option ty t          fun inl_info (II.INL_PRIM (p, t)) = "A" $ [primop p, option ty t]
824            | inl_info (II.INL_STR sl) = "B" $ list inl_info sl            | inl_info (II.INL_STR sl) = "B" $ [list inl_info sl]
825            | inl_info II.INL_NO = %II "C"            | inl_info II.INL_NO = "C" $ []
826            | inl_info _ = bug "unexpected inl_info in pickmod"            | inl_info _ = bug "unexpected inl_info in pickmod"
827    
828          val op $ = PU.$ VAR          val op $ = PU.$ VAR
829          fun var (V.VALvar { access = a, info, path, typ = ref t }) =          fun var (V.VALvar { access = a, info, path, typ = ref t }) =
830              "1" $ access a & inl_info info & spath path & ty t              "1" $ [access a, inl_info info, spath path, ty t]
831            | var (V.OVLDvar { name, options = ref p,            | var (V.OVLDvar { name, options = ref p,
832                               scheme = T.TYFUN { arity, body } }) =                               scheme = T.TYFUN { arity, body } }) =
833              "2" $ symbol name & list overld p & int arity & ty body              "2" $ [symbol name, list overld p, int arity, ty body]
834            | var V.ERRORvar = %VAR "3"            | var V.ERRORvar = "3" $ []
835    
836          and overld { indicator, variant } = let          and overld { indicator, variant } = let
837              val op $ = PU.$ OVERLD              val op $ = PU.$ OVERLD
838          in          in
839              "o" $ ty indicator & var variant              "o" $ [ty indicator, var variant]
840          end          end
841    
842          fun fsigId (M.FSIG { paramsig = M.SIG { stamp = ps, ... },          fun fsigId (M.FSIG { paramsig = M.SIG { stamp = ps, ... },
# Line 851  Line 847 
847    
848          fun strDef arg = let          fun strDef arg = let
849              val op $ = PU.$ SD              val op $ = PU.$ SD
850              fun sd (M.CONSTstrDef s) = "C" $ Structure s              fun sd (M.CONSTstrDef s) = "C" $ [Structure s]
851                | sd (M.VARstrDef (s, p)) = "V" $ Signature s & entPath p                | sd (M.VARstrDef (s, p)) = "V" $ [Signature s, entPath p]
852          in          in
853              sd arg              sd arg
854          end          end
# Line 863  Line 859 
859           *)           *)
860          and Signature arg = let          and Signature arg = let
861              val op $ = PU.$ SG              val op $ = PU.$ SG
862              fun sg  M.ERRORsig = %SG "A"              fun sg  M.ERRORsig = "A" $ []
863                | sg (M.SIG x) = let                | sg (M.SIG x) = let
864                      val id = MI.SIGid (#stamp x)                      val id = MI.SIGid (#stamp x)
865                      fun sig_raw x = let                      fun sig_raw x = let
# Line 873  Line 869 
869                          val b = NONE            (* currently turned off *)                          val b = NONE            (* currently turned off *)
870                      in                      in
871                          case lookSIG id of                          case lookSIG id of
872                              SimpleStub => "B" $ modId id                              SimpleStub => "B" $ [modId id]
873                            | NoStub =>                            | NoStub =>
874                                  "C" $ option symbol name & bool closed &                                  "C" $ [option symbol name, bool closed,
875                                        bool fctflag & stamp sta &                                         bool fctflag, stamp sta,
876                                        list symbol symbols &                                         list symbol symbols,
877                                        list (pair (symbol, spec)) elements &                                         list (pair (symbol, spec)) elements,
878                                        option (list (pair (entPath, tkind))) b &                                         option (list (pair (entPath, tkind))) b,
879                                        list (list spath) typsharing &                                         list (list spath) typsharing,
880                                        list (list spath) strsharing                                         list (list spath) strsharing]
881                            | PrimStub s => "D" $ string s & modId id                            | PrimStub s => "D" $ [string s, modId id]
882                            | NodeStub (i, s) =>                            | NodeStub (i, s) =>
883                                        "E" $ int i & symbol s & modId id                                  "E" $ [int i, symbol s, modId id]
884                      end                      end
885                  in                  in
886                      share (MIs (id, NONE)) sig_raw x                      share (MIs (id, NONE)) sig_raw x
# Line 895  Line 891 
891    
892          and fctSig arg = let          and fctSig arg = let
893              val op $ = PU.$ FSG              val op $ = PU.$ FSG
894              fun fsg M.ERRORfsig = %FSG "a"              fun fsg M.ERRORfsig = "a" $ []
895                | fsg (fs as M.FSIG x) = let                | fsg (fs as M.FSIG x) = let
896                      val id = fsigId fs                      val id = fsigId fs
897                      fun fsig_raw x = let                      fun fsig_raw x = let
898                          val { kind, paramsig, paramvar, paramsym, bodysig } = x                          val { kind, paramsig, paramvar, paramsym, bodysig } = x
899                      in                      in
900                          case lookFSIG id of                          case lookFSIG id of
901                              SimpleStub => "b" $ modId id                              SimpleStub => "b" $ [modId id]
902                            | NoStub =>                            | NoStub =>
903                                  "c" $ option symbol kind & Signature paramsig &                                  "c" $ [option symbol kind, Signature paramsig,
904                                        entVar paramvar &                                         entVar paramvar,
905                                        option symbol paramsym &                                         option symbol paramsym,
906                                        Signature bodysig                                         Signature bodysig]
907                            | PrimStub s => "d" $ string s & modId id                            | PrimStub s => "d" $ [string s, modId id]
908                            | NodeStub (i, s) =>                            | NodeStub (i, s) =>
909                                        "e" $ int i & symbol s & modId id                                  "e" $ [int i, symbol s, modId id]
910                      end                      end
911                  in                  in
912                      share (MIs (id, NONE)) fsig_raw x                      share (MIs (id, NONE)) fsig_raw x
# Line 922  Line 918 
918          and spec arg = let          and spec arg = let
919              val op $ = PU.$ SP              val op $ = PU.$ SP
920              fun sp (M.TYCspec { spec = t, entVar = v, repl, scope }) =              fun sp (M.TYCspec { spec = t, entVar = v, repl, scope }) =
921                  "1" $ tycon t & entVar v & bool repl & int scope                  "1" $ [tycon t, entVar v, bool repl, int scope]
922                | sp (M.STRspec { sign, slot, def, entVar = v }) =                | sp (M.STRspec { sign, slot, def, entVar = v }) =
923                  "2" $ Signature sign & int slot &                  "2" $ [Signature sign, int slot,
924                        option (pair (strDef, int)) def & entVar v                         option (pair (strDef, int)) def, entVar v]
925                | sp (M.FCTspec { sign, slot, entVar = v }) =                | sp (M.FCTspec { sign, slot, entVar = v }) =
926                  "3" $ fctSig sign & int slot & entVar v                  "3" $ [fctSig sign, int slot, entVar v]
927                | sp (M.VALspec { spec = t, slot }) = "4" $ ty t & int slot                | sp (M.VALspec { spec = t, slot }) = "4" $ [ty t, int slot]
928                | sp (M.CONspec { spec = c, slot }) =                | sp (M.CONspec { spec = c, slot }) =
929                  "5" $ datacon c & option int slot                  "5" $ [datacon c, option int slot]
930          in          in
931              sp arg              sp arg
932          end          end
933    
934          and entity arg = let          and entity arg = let
935              val op $ = PU.$ EN              val op $ = PU.$ EN
936              fun en (M.TYCent t) = "A" $ tycEntity t              fun en (M.TYCent t) = "A" $ [tycEntity t]
937                | en (M.STRent t) = "B" $ strEntity t                | en (M.STRent t) = "B" $ [strEntity t]
938                | en (M.FCTent t) = "C" $ fctEntity t                | en (M.FCTent t) = "C" $ [fctEntity t]
939                | en M.ERRORent = %EN "D"                | en M.ERRORent = "D" $ []
940          in          in
941              en arg              en arg
942          end          end
# Line 948  Line 944 
944          and fctClosure (M.CLOSURE { param, body, env }) = let          and fctClosure (M.CLOSURE { param, body, env }) = let
945              val op $ = PU.$ FCTC              val op $ = PU.$ FCTC
946          in          in
947              "f" $ entVar param & strExp body & entityEnv env              "f" $ [entVar param, strExp body, entityEnv env]
948          end          end
949    
950          and Structure arg = let          and Structure arg = let
951              val op $ = PU.$ STR              val op $ = PU.$ STR
952              fun str (M.STRSIG { sign, entPath = p }) =              fun str (M.STRSIG { sign, entPath = p }) =
953                  "A" $ Signature sign & entPath p                  "A" $ [Signature sign, entPath p]
954                | str M.ERRORstr = %STR "B"                | str M.ERRORstr = "B" $ []
955                | str (M.STR (x as { sign = M.SIG sign, ... })) = let                | str (M.STR (x as { sign = M.SIG sign, ... })) = let
956                      val id = MI.STRid { rlzn = #stamp (#rlzn x),                      val id = MI.STRid { rlzn = #stamp (#rlzn x),
957                                          sign = #stamp sign }                                          sign = #stamp sign }
958                      fun s_raw { sign, rlzn, access = a, info } =                      fun s_raw { sign, rlzn, access = a, info } =
959                          case lookSTR id of                          case lookSTR id of
960                              SimpleStub => "C" $ modId id & access a                              SimpleStub => "C" $ [modId id, access a]
961                            | NoStub =>                            | NoStub =>
962                                  "D" $ Signature sign & strEntity rlzn &                                  "D" $ [Signature sign, strEntity rlzn,
963                                        access a & inl_info info                                         access a, inl_info info]
964                            | PrimStub s => "I" $ string s & modId id                            | PrimStub s => "I" $ [string s, modId id]
965                            | NodeStub (i, s) =>                            | NodeStub (i, s) =>
966                                   "J" $ int i & symbol s & modId id & access a                                   "J" $ [int i, symbol s, modId id, access a]
967                  in                  in
968                      share (MIs (id, acc_pid (#access x))) s_raw x                      share (MIs (id, acc_pid (#access x))) s_raw x
969                  end                  end
# Line 978  Line 974 
974    
975          and Functor arg = let          and Functor arg = let
976              val op $ = PU.$ F              val op $ = PU.$ F
977              fun fct M.ERRORfct = %F "E"              fun fct M.ERRORfct = "E" $ []
978                | fct (M.FCT x) = let                | fct (M.FCT x) = let
979                      val id = MI.FCTid { rlzn = #stamp (#rlzn x),                      val id = MI.FCTid { rlzn = #stamp (#rlzn x),
980                                          sign = fsigId (#sign x) }                                          sign = fsigId (#sign x) }
981                      fun f_raw { sign, rlzn, access = a, info } =                      fun f_raw { sign, rlzn, access = a, info } =
982                          case lookFCT id of                          case lookFCT id of
983                              SimpleStub => "F" $ modId id & access a                              SimpleStub => "F" $ [modId id, access a]
984                            | NoStub =>                            | NoStub =>
985                                  "G" $ fctSig sign & fctEntity rlzn &                                  "G" $ [fctSig sign, fctEntity rlzn,
986                                        access a & inl_info info                                         access a, inl_info info]
987                            | PrimStub s => "H" $ string s & modId id                            | PrimStub s => "H" $ [string s, modId id]
988                            | NodeStub (i, s) =>                            | NodeStub (i, s) =>
989                                  "I" $ int i & symbol s & modId id & access a                                  "I" $ [int i, symbol s, modId id, access a]
990                  in                  in
991                      share (MIs (id, acc_pid (#access x))) f_raw x                      share (MIs (id, acc_pid (#access x))) f_raw x
992                  end                  end
# Line 998  Line 994 
994              fct arg              fct arg
995          end          end
996    
997          and stampExp (M.CONST s) = PU.$ STE ("a", stamp s)          and stampExp (M.CONST s) = PU.$ STE ("a", [stamp s])
998            | stampExp (M.GETSTAMP s) = PU.$ STE ("b", strExp s)            | stampExp (M.GETSTAMP s) = PU.$ STE ("b", [strExp s])
999            | stampExp M.NEW = %STE "c"            | stampExp M.NEW = "c" $ []
1000    
1001          and tycExp (M.CONSTtyc t) = PU.$ TCE ("d", tycon t)          and tycExp (M.CONSTtyc t) = PU.$ TCE ("d", [tycon t])
1002            | tycExp (M.FORMtyc t) = PU.$ TCE ("e", tycon t)            | tycExp (M.FORMtyc t) = PU.$ TCE ("e", [tycon t])
1003            | tycExp (M.VARtyc s) = PU.$ TCE ("f", entPath s)            | tycExp (M.VARtyc s) = PU.$ TCE ("f", [entPath s])
1004    
1005          and strExp arg = let          and strExp arg = let
1006              val op $ = PU.$ STRE              val op $ = PU.$ STRE
1007              fun stre (M.VARstr s) = "g" $ entPath s              fun stre (M.VARstr s) = "g" $ [entPath s]
1008                | stre (M.CONSTstr s) = "h" $ strEntity s                | stre (M.CONSTstr s) = "h" $ [strEntity s]
1009                | stre (M.STRUCTURE { stamp = s, entDec }) =                | stre (M.STRUCTURE { stamp = s, entDec }) =
1010                  "i" $ stampExp s & entityDec entDec                  "i" $ [stampExp s, entityDec entDec]
1011                | stre (M.APPLY (f, s)) = "j" $ fctExp f & strExp s                | stre (M.APPLY (f, s)) = "j" $ [fctExp f, strExp s]
1012                | stre (M.LETstr (e, s)) = "k" $ entityDec e & strExp s                | stre (M.LETstr (e, s)) = "k" $ [entityDec e, strExp s]
1013                | stre (M.ABSstr (s, e)) = "l" $ Signature s & strExp e                | stre (M.ABSstr (s, e)) = "l" $ [Signature s, strExp e]
1014                | stre (M.CONSTRAINstr { boundvar, raw, coercion }) =                | stre (M.CONSTRAINstr { boundvar, raw, coercion }) =
1015                  "m" $ entVar boundvar & strExp raw & strExp coercion                  "m" $ [entVar boundvar, strExp raw, strExp coercion]
1016                | stre (M.FORMstr fs) = "n" $ fctSig fs                | stre (M.FORMstr fs) = "n" $ [fctSig fs]
1017          in          in
1018              stre arg              stre arg
1019          end          end
1020    
1021          and fctExp arg = let          and fctExp arg = let
1022              val op $ = PU.$ FE              val op $ = PU.$ FE
1023              fun fe (M.VARfct s) = "o" $ entPath s              fun fe (M.VARfct s) = "o" $ [entPath s]
1024                | fe (M.CONSTfct e) = "p" $ fctEntity e                | fe (M.CONSTfct e) = "p" $ [fctEntity e]
1025                | fe (M.LAMBDA { param, body }) =                | fe (M.LAMBDA { param, body }) =
1026                  "q" $ entVar param & strExp body                  "q" $ [entVar param, strExp body]
1027                | fe (M.LAMBDA_TP { param, body, sign }) =                | fe (M.LAMBDA_TP { param, body, sign }) =
1028                  "r" $ entVar param & strExp body & fctSig sign                  "r" $ [entVar param, strExp body, fctSig sign]
1029                | fe (M.LETfct (e, f)) = "s" $ entityDec e & fctExp f                | fe (M.LETfct (e, f)) = "s" $ [entityDec e, fctExp f]
1030          in          in
1031              fe arg              fe arg
1032          end          end
1033    
1034          and entityExp arg = let          and entityExp arg = let
1035              val op $ = PU.$ EE              val op $ = PU.$ EE
1036              fun ee (M.TYCexp t) = "t" $ tycExp t              fun ee (M.TYCexp t) = "t" $ [tycExp t]
1037                | ee (M.STRexp s) = "u" $ strExp s                | ee (M.STRexp s) = "u" $ [strExp s]
1038                | ee (M.FCTexp f) = "v" $ fctExp f                | ee (M.FCTexp f) = "v" $ [fctExp f]
1039                | ee M.ERRORexp = %EE "w"                | ee M.ERRORexp = "w" $ []
1040                | ee M.DUMMYexp = %EE "x"                | ee M.DUMMYexp = "x" $ []
1041          in          in
1042              ee arg              ee arg
1043          end          end
1044    
1045          and entityDec arg = let          and entityDec arg = let
1046              val op $ = PU.$ ED              val op $ = PU.$ ED
1047              fun ed (M.TYCdec (s, x)) = "A" $ entVar s & tycExp x              fun ed (M.TYCdec (s, x)) = "A" $ [entVar s, tycExp x]
1048                | ed (M.STRdec (s, x, n)) = "B" $ entVar s & strExp x & symbol n                | ed (M.STRdec (s, x, n)) = "B" $ [entVar s, strExp x, symbol n]
1049                | ed (M.FCTdec (s, x)) = "C" $ entVar s & fctExp x                | ed (M.FCTdec (s, x)) = "C" $ [entVar s, fctExp x]
1050                | ed (M.SEQdec e) = "D" $ list entityDec e                | ed (M.SEQdec e) = "D" $ [list entityDec e]
1051                | ed (M.LOCALdec (a, b)) = "E" $ entityDec a & entityDec b                | ed (M.LOCALdec (a, b)) = "E" $ [entityDec a, entityDec b]
1052                | ed M.ERRORdec = %ED "F"                | ed M.ERRORdec = "F" $ []
1053                | ed M.EMPTYdec = %ED "G"                | ed M.EMPTYdec = "G" $ []
1054          in          in
1055              ed arg              ed arg
1056          end          end
# Line 1064  Line 1060 
1060                  val id = MI.EENVid s                  val id = MI.EENVid s
1061                  fun mee_raw (s, r) =                  fun mee_raw (s, r) =
1062                      case lookEENV id of                      case lookEENV id of
1063                          SimpleStub => "D" $ modId id                          SimpleStub => "D" $ [modId id]
1064                        | NoStub => "E" $ stamp s & entityEnv r                        | NoStub => "E" $ [stamp s, entityEnv r]
1065                        | PrimStub s => "F" $ string s & modId id                        | PrimStub s => "F" $ [string s,  modId id]
1066                        | NodeStub (i, s) => "G" $ int i & symbol s & modId id                        | NodeStub (i, s) => "G" $ [int i, symbol s, modId id]
1067              in              in
1068                  share (MIs (id, NONE)) mee_raw (s, r)                  share (MIs (id, NONE)) mee_raw (s, r)
1069              end              end
1070            | entityEnv (M.BINDeenv (d, r)) =            | entityEnv (M.BINDeenv (d, r)) =
1071              PU.$ EEV ("A", list (pair (entVar, entity)) (ED.listItemsi d) &              PU.$ EEV ("A", [list (pair (entVar, entity)) (ED.listItemsi d),
1072                             entityEnv r)                             entityEnv r])
1073            | entityEnv M.NILeenv = %EEV "B"            | entityEnv M.NILeenv = "B" $ []
1074            | entityEnv M.ERReenv = %EEV "C"            | entityEnv M.ERReenv = "C" $ []
1075    
1076          and strEntity { stamp = s, entities, lambdaty = _, rpath } = let          and strEntity { stamp = s, entities, lambdaty = _, rpath } = let
1077              val op $ = PU.$ SEN              val op $ = PU.$ SEN
1078          in          in
1079              "s" $ stamp s & entityEnv entities & ipath rpath              "s" $ [stamp s, entityEnv entities, ipath rpath]
1080          end          end
1081    
1082          and fctEntity fe = let          and fctEntity fe = let
1083              val op $ = PU.$ FEN              val op $ = PU.$ FEN
1084              val { stamp = s, closure, lambdaty = _, tycpath = _, rpath } = fe              val { stamp = s, closure, lambdaty = _, tycpath = _, rpath } = fe
1085          in          in
1086              "f" $ stamp s & fctClosure closure & ipath rpath              "f" $ [stamp s, fctClosure closure, ipath rpath]
1087          end          end
1088    
1089          and tycEntity x = tycon x          and tycEntity x = tycon x
1090    
1091          fun fixity Fixity.NONfix = %FX "N"          fun fixity Fixity.NONfix = "N" $ []
1092            | fixity (Fixity.INfix (i, j)) = PU.$ FX ("I", int i & int j)            | fixity (Fixity.INfix (i, j)) = PU.$ FX ("I", [int i, int j])
1093    
1094          val op $ = PU.$ B          val op $ = PU.$ B
1095          fun binding (B.VALbind x) = "1" $ var x          fun binding (B.VALbind x) = "1" $ [var x]
1096            | binding (B.CONbind x) = "2" $ datacon x            | binding (B.CONbind x) = "2" $ [datacon x]
1097            | binding (B.TYCbind x) = "3" $ tycon x            | binding (B.TYCbind x) = "3" $ [tycon x]
1098            | binding (B.SIGbind x) = "4" $ Signature x            | binding (B.SIGbind x) = "4" $ [Signature x]
1099            | binding (B.STRbind x) = "5" $ Structure x            | binding (B.STRbind x) = "5" $ [Structure x]
1100            | binding (B.FSGbind x) = "6" $ fctSig x            | binding (B.FSGbind x) = "6" $ [fctSig x]
1101            | binding (B.FCTbind x) = "7" $ Functor x            | binding (B.FCTbind x) = "7" $ [Functor x]
1102            | binding (B.FIXbind x) = "8" $ fixity x            | binding (B.FIXbind x) = "8" $ [fixity x]
1103    
1104          fun env e = let          fun env e = let
1105              val syms = ListMergeSort.uniqueSort symCmp (Env.symbols e)              val syms = ListMergeSort.uniqueSort symCmp (Env.symbols e)

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

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