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 774, Wed Jan 10 12:50:56 2001 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, CCI, CTYPE) =           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, 58, 59)           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 334  Line 336 
336            | CTypes.C_signed CTypes.I_long => %?12            | CTypes.C_signed CTypes.I_long => %?12
337            | CTypes.C_signed CTypes.I_long_long => %?13            | CTypes.C_signed CTypes.I_long_long => %?13
338            | CTypes.C_PTR => %?14            | CTypes.C_PTR => %?14
   
339            | CTypes.C_ARRAY (t, i) => ?20 $ [ctype t, int i]            | CTypes.C_ARRAY (t, i) => ?20 $ [ctype t, int i]
340            | CTypes.C_STRUCT l => ?21 $ [list ctype l]            | CTypes.C_STRUCT l => ?21 $ [list ctype l]
341      end      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 },      fun ccall_info { c_proto = { conv, retTy, paramTys },
353                       ml_flt_args, ml_flt_res_opt } = let                       ml_args, ml_res_opt, reentrant } = let
354          val op $ = PU.$ CCI          val op $ = PU.$ CCI
355      in      in
356          "C" $ [string conv, ctype retTy, list ctype paramTys,          "C" $ [string conv, ctype retTy, list ctype paramTys,
357                 list bool ml_flt_args, option bool ml_flt_res_opt]                 list ccall_type ml_args, option ccall_type ml_res_opt,
358                   bool reentrant
359                  ]
360      end      end
361    
362      fun primop p = let      fun primop p = let
# Line 378  Line 390 
390                | P.RAW_LOAD kind => ?116 $ [numkind kind]                | P.RAW_LOAD kind => ?116 $ [numkind kind]
391                | P.RAW_STORE kind => ?117 $ [numkind kind]                | P.RAW_STORE kind => ?117 $ [numkind kind]
392                | P.RAW_CCALL (SOME i) => ?118 $ [ccall_info i]                | 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 425  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  
               | P.RAW_CCALL NONE => %?61  
465      end      end
466    
467      fun consig arg = let      fun consig arg = let
# Line 828  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 858  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 928  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, 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 969  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 1149  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 1158  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 1183  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 1199  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 1223  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 1283  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.774  
changed lines
  Added in v.1347

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