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 742, Thu Nov 30 14:09:32 2000 UTC revision 1347, Thu Aug 28 21:59:15 2003 UTC
# Line 51  Line 51 
51                      { hash: PersStamps.persstamp,                      { hash: PersStamps.persstamp,
52                        pickle: Word8Vector.vector,                        pickle: Word8Vector.vector,
53                        exportLvars: Access.lvar list,                        exportLvars: Access.lvar list,
54                        exportPid: PersStamps.persstamp option }                        hasExports: bool }
55    
56      val pickleFLINT:      val pickleFLINT: FLINT.prog option -> { hash: PersStamps.persstamp,
         CompBasic.flint option  
         -> { hash: PersStamps.persstamp,  
57               pickle: Word8Vector.vector }               pickle: Word8Vector.vector }
58    
59      val symenvPickler : (map, SymbolicEnv.symenv) PickleUtil.pickler      val symenvPickler : (map, SymbolicEnv.env) PickleUtil.pickler
60    
61      val pickle2hash: Word8Vector.vector -> PersStamps.persstamp      val pickle2hash: Word8Vector.vector -> PersStamps.persstamp
62    
63      val dontPickle :      val dontPickle :
64          StaticEnv.staticEnv * int          { env: StaticEnv.staticEnv, count: int } ->
65                    -> StaticEnv.staticEnv * PersStamps.persstamp *          { newenv: StaticEnv.staticEnv, hash: PersStamps.persstamp,
66                       Access.lvar list * PersStamps.persstamp option            exportLvars: Access.lvar list, hasExports: bool }
67  end  end
68    
69  local  local
# Line 142  Line 140 
140           DTF, TYCON, T, II, VAR, SD, SG, FSG,  SP, EN,           DTF, TYCON, T, II, VAR, SD, SG, FSG,  SP, EN,
141           STR, F, STE, TCE, STRE, FE, EE, ED, EEV, FX,           STR, F, STE, TCE, STRE, FE, EE, ED, EEV, FX,
142           B, DCON, DICT, FPRIM, FUNDEC, TFUNDEC, DATACON, DTMEM, NRD,           B, DCON, DICT, FPRIM, FUNDEC, TFUNDEC, DATACON, DTMEM, NRD,
143           OVERLD, FCTC, SEN, FEN, SPATH, IPATH, STRID, FCTID) =           OVERLD, FCTC, SEN, FEN, SPATH, IPATH, STRID, FCTID, CCI, CTYPE,
144             CCALL_TYPE) =
145          (1, 2, 3, 4, 5, 6, 7, 8, 9, 10,          (1, 2, 3, 4, 5, 6, 7, 8, 9, 10,
146           11, 12, 13, 14, 15, 16, 17, 18, 19, 20,           11, 12, 13, 14, 15, 16, 17, 18, 19, 20,
147           21, 22, 23, 24, 25, 26, 27, 28, 29, 30,           21, 22, 23, 24, 25, 26, 27, 28, 29, 30,
148           31, 32, 33, 34, 35, 36, 37, 38, 39, 40,           31, 32, 33, 34, 35, 36, 37, 38, 39, 40,
149           41, 42, 43, 44, 45, 46, 47, 48, 49,           41, 42, 43, 44, 45, 46, 47, 48, 49,
150           50, 51, 52, 53, 54, 55, 56, 57)           50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60)
151    
152      (* this is a bit awful...      (* this is a bit awful...
153       * (we really ought to have syntax for "functional update") *)       * (we really ought to have syntax for "functional update") *)
# Line 293  Line 292 
292            | arithopc P.FSIN = "\014"            | arithopc P.FSIN = "\014"
293            | arithopc P.FCOS = "\015"            | arithopc P.FCOS = "\015"
294            | arithopc P.FTAN = "\016"            | arithopc P.FTAN = "\016"
295              | arithopc P.REM = "\017"
296              | arithopc P.DIV = "\018"
297              | arithopc P.MOD = "\019"
298      in      in
299          arithopc oper $ []          arithopc oper $ []
300      end      end
# Line 313  Line 315 
315          cmpopc oper $ []          cmpopc oper $ []
316      end      end
317    
318        fun ctype t = let
319            val op $ = PU.$ CTYPE
320            fun ?n = String.str (Char.chr n)
321            fun %?n = ?n $ []
322        in
323            case t of
324                CTypes.C_void => %?0
325              | CTypes.C_float => %?1
326              | CTypes.C_double => %?2
327              | CTypes.C_long_double => %?3
328              | CTypes.C_unsigned CTypes.I_char => %?4
329              | CTypes.C_unsigned CTypes.I_short => %?5
330              | CTypes.C_unsigned CTypes.I_int => %?6
331              | CTypes.C_unsigned CTypes.I_long => %?7
332              | CTypes.C_unsigned CTypes.I_long_long => %?8
333              | CTypes.C_signed CTypes.I_char => %?9
334              | CTypes.C_signed CTypes.I_short => %?10
335              | CTypes.C_signed CTypes.I_int => %?11
336              | CTypes.C_signed CTypes.I_long => %?12
337              | CTypes.C_signed CTypes.I_long_long => %?13
338              | CTypes.C_PTR => %?14
339              | CTypes.C_ARRAY (t, i) => ?20 $ [ctype t, int i]
340              | CTypes.C_STRUCT l => ?21 $ [list ctype l]
341        end
342    
343        fun ccall_type t =
344        let val op $ = PU.$ CCALL_TYPE
345        in  case t of
346              P.CCI32 => "\000" $ []
347            | P.CCI64 => "\001" $ []
348            | P.CCR64 => "\002" $ []
349            | P.CCML  => "\003" $ []
350        end
351    
352        fun ccall_info { c_proto = { conv, retTy, paramTys },
353                         ml_args, ml_res_opt, reentrant } = let
354            val op $ = PU.$ CCI
355        in
356            "C" $ [string conv, ctype retTy, list ctype paramTys,
357                   list ccall_type ml_args, option ccall_type ml_res_opt,
358                   bool reentrant
359                  ]
360        end
361    
362      fun primop p = let      fun primop p = let
363          val op $ = PU.$ PO          val op $ = PU.$ PO
364          fun ?n = String.str (Char.chr n)          fun ?n = String.str (Char.chr n)
# Line 341  Line 387 
387                      ?113 $ [numkind kind, bool checked]                      ?113 $ [numkind kind, bool checked]
388                | P.INL_MONOARRAY kind => ?114 $ [numkind kind]                | P.INL_MONOARRAY kind => ?114 $ [numkind kind]
389                | P.INL_MONOVECTOR kind => ?115 $ [numkind kind]                | P.INL_MONOVECTOR kind => ?115 $ [numkind kind]
390                  | P.RAW_LOAD kind => ?116 $ [numkind kind]
391                  | P.RAW_STORE kind => ?117 $ [numkind kind]
392                  | P.RAW_CCALL (SOME i) => ?118 $ [ccall_info i]
393                  | P.RAW_RECORD { fblock } => ?119 $ [bool fblock]
394    
395                  | P.INLMIN kind => ?120 $ [numkind kind]
396                  | P.INLMAX kind => ?121 $ [numkind kind]
397                  | P.INLABS kind => ?122 $ [numkind kind]
398    
399                  | P.TEST_INF i => ?123 $ [int i]
400                  | P.TRUNC_INF i => ?124 $ [int i]
401                  | P.EXTEND_INF i => ?125 $ [int i]
402                  | P.COPY_INF i => ?126 $ [int i]
403    
404                | P.MKETAG => %?0                | P.MKETAG => %?0
405                | P.WRAP => %?1                | P.WRAP => %?1
# Line 388  Line 447 
447                | P.GETSPECIAL => %?40                | P.GETSPECIAL => %?40
448                | P.USELVAR => %?41                | P.USELVAR => %?41
449                | P.DEFLVAR => %?42                | P.DEFLVAR => %?42
450                | P.INLDIV => %?43                | P.INLNOT => %?43
451                | P.INLMOD => %?44                | P.INLCOMPOSE => %?44
452                | P.INLREM => %?45                | P.INLBEFORE => %?45
453                | P.INLMIN => %?46                | P.INL_ARRAY => %?46
454                | P.INLMAX => %?47                | P.INL_VECTOR => %?47
455                | P.INLABS => %?48                | P.ISOLATE => %?48
456                | P.INLNOT => %?49                | P.WCAST => %?49
457                | P.INLCOMPOSE => %?50                | P.NEW_ARRAY0 => %?50
458                | P.INLBEFORE => %?51                | P.GET_SEQ_DATA => %?51
459                | P.INL_ARRAY => %?52                | P.SUBSCRIPT_REC => %?52
460                | P.INL_VECTOR => %?53                | P.SUBSCRIPT_RAW64 => %?53
461                | P.ISOLATE => %?54                | P.UNBOXEDASSIGN => %?54
462                | P.WCAST => %?55                | P.RAW_CCALL NONE => %?55
463                | P.NEW_ARRAY0 => %?56                | P.INLIGNORE => %?56
464                | P.GET_SEQ_DATA => %?57                | P.INLIDENTITY => %?57
               | P.SUBSCRIPT_REC => %?58  
               | P.SUBSCRIPT_RAW64 => %?59  
               | P.UNBOXEDASSIGN => %?60  
465      end      end
466    
467      fun consig arg = let      fun consig arg = let
# Line 762  Line 818 
818          val op $ = PU.$ IPATH          val op $ = PU.$ IPATH
819          fun ipath (IP.IPATH p) = "i" $ [list symbol p]          fun ipath (IP.IPATH p) = "i" $ [list symbol p]
820    
821              (* for debugging *)
822            fun showipath (IP.IPATH p) =
823                concat (map (fn s => Symbol.symbolToString s ^ ".") (rev p))
824    
825          val label = symbol          val label = symbol
826    
827          fun eqprop eqp = let          fun eqprop eqp = let
# Line 786  Line 846 
846    
847          and tyckind arg = let          and tyckind arg = let
848              val op $ = PU.$ TYCKIND              val op $ = PU.$ TYCKIND
849              fun tk (T.PRIMITIVE pt) = "a" $ [int (PT.pt_toint pt)]              fun tk (T.PRIMITIVE pt) = "a" $ [int pt]
850                | tk (T.DATATYPE { index, family, stamps, root,freetycs }) =                | tk (T.DATATYPE { index, family, stamps, root,freetycs }) =
851                  "b" $ [int index, option entVar root,                  "b" $ [int index, option entVar root,
852                         dtypeInfo (stamps, family, freetycs)]                         dtypeInfo (stamps, family, freetycs)]
# Line 816  Line 876 
876    
877          and dtFamily x = let          and dtFamily x = let
878              val op $ = PU.$ DTF              val op $ = PU.$ DTF
879              fun dtf_raw { mkey, members, lambdatyc } =              fun dtf_raw { mkey, members, properties } =
880                  "b" $ [stamp mkey,                  "b" $ [stamp mkey,
881                         list dtmember (Vector.foldr (op ::) [] members)]                         list dtmember (Vector.foldr (op ::) [] members)]
882          in          in
# Line 886  Line 946 
946          end          end
947    
948          val op $ = PU.$ II          val op $ = PU.$ II
949          fun inl_info (II.INL_PRIM (p, t)) = "A" $ [primop p, option ty t]          fun inl_info i =
950            | inl_info (II.INL_STR sl) = "B" $ [list inl_info sl]              II.match i { inl_prim = fn (p, t) => "A" $ [primop p, ty t],
951            | inl_info II.INL_NO = "C" $ []                           inl_str = fn sl => "B" $ [list inl_info sl],
952            | inl_info _ = bug "unexpected inl_info in pickmod"                           inl_no = fn () => "C" $ [] }
953    
954          val op $ = PU.$ VAR          val op $ = PU.$ VAR
955          fun var (V.VALvar { access = a, info, path, typ = ref t }) =          fun var (V.VALvar { access = a, info, path, typ = ref t }) =
# Line 927  Line 987 
987                           fun sig_raw (s: M.sigrec) = let                           fun sig_raw (s: M.sigrec) = let
988                               val { stamp = sta, name, closed,                               val { stamp = sta, name, closed,
989                                     fctflag, symbols, elements,                                     fctflag, symbols, elements,
990                                     boundeps = ref b,                                     properties,
991                                     lambdaty = _, stub,                                     (* boundeps = ref b, *)
992                                     typsharing, strsharing } = s                                     (* lambdaty = _, *)
993                                       stub, typsharing, strsharing } = s
994                                 val b = ModulePropLists.sigBoundeps s
995                               val b = NONE (* currently turned off *)                               val b = NONE (* currently turned off *)
996                           in                           in
997                               "C" $ ([stamp sta,                               "C" $ ([stamp sta,
# Line 1107  Line 1169 
1169            | entityEnv M.NILeenv = "B" $ []            | entityEnv M.NILeenv = "B" $ []
1170            | entityEnv M.ERReenv = "C" $ []            | entityEnv M.ERReenv = "C" $ []
1171    
1172          and strEntity { stamp = s, entities, lambdaty = _, rpath, stub } =          and strEntity { stamp = s, entities, properties, rpath, stub } =
1173              let val op $ = PU.$ SEN              let val op $ = PU.$ SEN
1174              in              in
1175                  "s" $ ([stamp s, entityEnv entities, ipath rpath]                  "s" $ ([stamp s, entityEnv entities, ipath rpath]
# Line 1116  Line 1178 
1178    
1179          and shStrEntity id = share (STRs id) strEntity          and shStrEntity id = share (STRs id) strEntity
1180    
1181          and fctEntity { stamp = s, closure, lambdaty, tycpath, rpath, stub } =          and fctEntity { stamp = s,
1182                            closure, properties, tycpath, rpath, stub } =
1183              let val op $ = PU.$ FEN              let val op $ = PU.$ FEN
1184              in              in
1185                  "f" $ ([stamp s, fctClosure closure, ipath rpath]                  "f" $ ([stamp s, fctClosure closure, ipath rpath]
# Line 1141  Line 1204 
1204            | binding (B.FIXbind x) = "8" $ [fixity x]            | binding (B.FIXbind x) = "8" $ [fixity x]
1205    
1206          fun env e = let          fun env e = let
1207              val syms = ListMergeSort.uniqueSort symCmp (Env.symbols e)              val syms = ListMergeSort.uniqueSort symCmp (StaticEnv.symbols e)
1208              val pairs = map (fn s => (s, StaticEnv.look (e, s))) syms              val pairs = map (fn s => (s, StaticEnv.look (e, s))) syms
1209          in          in
1210              list (pair (symbol, binding)) pairs              list (pair (symbol, binding)) pairs
# Line 1157  Line 1220 
1220          val pickle = Byte.stringToBytes (PU.pickle emptyMap (pickler e))          val pickle = Byte.stringToBytes (PU.pickle emptyMap (pickler e))
1221          val exportLvars = rev (!lvlist)          val exportLvars = rev (!lvlist)
1222          val hash = pickle2hash pickle          val hash = pickle2hash pickle
1223          val exportPid =          val hasExports = not (List.null exportLvars)
             case exportLvars of  
                 [] => NONE  
               | _ => SOME hash  
1224      in      in
1225          addPickles (Word8Vector.length pickle);          addPickles (Word8Vector.length pickle);
1226          { hash = hash, pickle = pickle, exportLvars = exportLvars,          { hash = hash, pickle = pickle, exportLvars = exportLvars,
1227            exportPid = exportPid }            hasExports = hasExports }
1228      end      end
1229    
1230      (* the dummy environment pickler *)      (* the dummy environment pickler *)
1231      fun dontPickle (senv : StaticEnv.staticEnv, count) = let      fun dontPickle { env = senv, count } = let
1232          val hash = let          val hash = let
1233              val toByte = Word8.fromLargeWord o Word32.toLargeWord              val toByte = Word8.fromLargeWord o Word32.toLargeWord
1234              val >> = Word32.>>              val >> = Word32.>>
# Line 1181  Line 1241 
1241                  0w0,0w0,0w0,toByte(w >> 0w8),0w0,0w0,0w0,toByte(w)])                  0w0,0w0,0w0,toByte(w >> 0w8),0w0,0w0,0w0,toByte(w)])
1242          end          end
1243          (* next line is an alternative to using Env.consolidate *)          (* next line is an alternative to using Env.consolidate *)
1244          val syms = ListMergeSort.uniqueSort symCmp (Env.symbols senv)          val syms = ListMergeSort.uniqueSort symCmp (StaticEnv.symbols senv)
1245          fun newAccess i = A.PATH (A.EXTERN hash, i)          fun newAccess i = A.PATH (A.EXTERN hash, i)
1246          fun mapbinding (sym, (i, env, lvars)) =          fun mapbinding (sym, (i, env, lvars)) =
1247              case StaticEnv.look (senv, sym) of              case StaticEnv.look (senv, sym) of
# Line 1241  Line 1301 
1301                  end                  end
1302                | binding => (i, StaticEnv.bind (sym, binding, env), lvars)                | binding => (i, StaticEnv.bind (sym, binding, env), lvars)
1303          val (_,newenv,lvars) = foldl mapbinding (0, StaticEnv.empty, nil) syms          val (_,newenv,lvars) = foldl mapbinding (0, StaticEnv.empty, nil) syms
1304          val exportPid =          val hasExports = not (List.null lvars)
             case lvars of  
                 [] => NONE  
               | _ => SOME hash  
1305      in      in
1306          (newenv, hash, rev lvars, exportPid)          { newenv = newenv, hash = hash,
1307              exportLvars = rev lvars, hasExports = hasExports }
1308      end      end
1309    end    end
1310  end  end

Legend:
Removed from v.742  
changed lines
  Added in v.1347

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