On Dec 16, 2005, at 3:47 PM, Simon Marlow wrote:
interesting... Word8 and Int correspond to the -hd output above,
but '*'
indicates that the type of the <Script.Array.sat_s46N> is polymorphic.
Completely polymorphic closures like this are usually (error
"something"), which is a silly thing to fill up your heap with :-)
Hmm... I'm attaching the pickling code that I use at the end,
together with a sample of how I use it to pickle/unpickle SrvServerInfo.
I'm a bit mystified though, because looking at the code for
Script.Array, all your arrays are unboxed, so I don't know where
all the
Word8s and Ints are coming from. It might be useful to do "+RTS
-hyWord8 -hc" to see who generated the Word8s.
I will do it. Why bother with Word8, though? Shouldn't I be looking
for the polymorphic closures instead?
Oh, and it looks like
you aren't doing -auto-all, that would probably be helpful.
I compile like this:
ghc -O --make -prof -auto-all randomplay.hs -o randomplay -lssl -
lcrypto -lz
and run like this:
./randomplay +RTS -p -hd -hclaunchScripts#8
Did I miss -auto-all somewhere?
I have Cabal 1.1.4 and I give configure the -p option which builds
the profiled libraries for me. Do I need to separately give -auto-all
to the compiler below
ghc-options: -fglasgow-exts -Wall -threaded -fno-warn-name-shadowing
Thanks, Joel
----
{-# OPTIONS_GHC -fglasgow-exts -fth #-}
module Script.Pickle where
import Data.Word
import Data.Int
import Data.Bits
import Data.Char
import Data.Maybe
import Data.Array.MArray
import Script.Array
import Control.Monad
data PU a = PU
{
appP :: MutByteArray -> Index -> a -> IO Index,
appU :: MutByteArray -> Index -> IO (a, Index),
appS :: a -> IO Int
}
pickle :: PU a -> MutByteArray -> Index -> a -> IO Index
pickle p array ix value = appP p array ix value
unpickle :: PU a -> MutByteArray -> Index -> IO (a, Index)
unpickle p array ix = appU p array ix
sizeup :: PU a -> a -> IO Int
sizeup p value = appS p value
lift :: a -> PU a
lift x = PU (\_ ix _ -> return ix) (\_ ix -> return (x, ix)) (\_ ->
return 0)
sequ :: (b -> a) -> PU a -> (a -> PU b) -> PU b
sequ f pa k = PU
(\array ix b ->
do let a = f b
pb = k a
ix1 <- appP pa array ix a
appP pb array ix1 b)
(\array ix ->
do (a, ix1) <- appU pa array ix
let pb = k a
appU pb array ix1)
(\b ->
do let a = f b
pb = k a
sz1 <- appS pa a
sz2 <- appS pb b
return $ sz1 + sz2)
pair :: PU a -> PU b -> PU (a,b)
pair pa pb = sequ fst pa (\ a -> sequ snd pb
(\ b -> lift (a, b)))
triple :: PU a -> PU b -> PU c -> PU (a, b, c)
triple pa pb pc = sequ (\ (x, _, _) -> x) pa
(\a -> sequ (\ (_, y, _) -> y) pb
(\b -> sequ (\ (_, _, z) -> z) pc
(\c -> lift (a, b, c))))
quad :: PU a -> PU b -> PU c -> PU d -> PU (a, b, c, d)
quad pa pb pc pd = sequ (\ (w, _, _, _) -> w) pa
(\a -> sequ (\ (_, x, _, _) -> x) pb
(\b -> sequ (\ (_, _, y, _) -> y) pc
(\c -> sequ (\ (_, _, _, z) -> z) pd
(\d -> lift (a, b, c, d)))))
wrap :: (a -> b, b -> a) -> PU a -> PU b
wrap (i, j) pa = sequ j pa (lift . i)
unit :: PU ()
unit = lift ()
{-# SPECIALIZE num :: PU Word8 #-}
{-# SPECIALIZE num :: PU Word16 #-}
{-# SPECIALIZE num :: PU Word32 #-}
{-# SPECIALIZE num :: PU Word64 #-}
{-# SPECIALIZE num :: PU Int16 #-}
{-# SPECIALIZE num :: PU Int32 #-}
num :: (Integral a, Bits a) => PU a
num = PU appP_num appU_num (return . byteSize)
char :: PU Char
char = wrap (fromByte, toByte) num
bool :: PU Bool
bool = wrap (toenum, fromenum) byte
enum :: (Integral a, Bits a, Enum b) => PU a -> PU b
enum pa = wrap (toenum, fromenum) pa
byte :: PU Word8
byte = num
short :: PU Word16
short = num
uint :: PU Word32
uint = num
fixlist :: PU a -> Int -> PU [a]
fixlist _ 0 = lift []
fixlist pa n = wrap (\(a, b) -> a : b,
\(a : b) -> (a, b))
(pair pa (fixlist pa (n - 1)))
list :: (Integral a, Bits a) => PU a -> PU b -> PU [b]
list pa pb = sequ (fromIntegral . length) pa (\a -> fixlist pb
(fromIntegral a))
alt :: (a -> Word8) -> [PU a] -> PU a
alt tag ps = sequ tag byte (((!!) ps) . fromIntegral)
optional :: PU a -> PU (Maybe a)
optional pa = alt tag [lift Nothing, wrap (Just, fromJust) pa]
where tag Nothing = 0; tag (Just _) = 1
chunk :: Integral a => PU a -> PU ByteArray
chunk pa = sequ
(fromIntegral . (+ 1) . snd . bounds)
pa
(\a -> bytearray $ fromIntegral a)
bytearray :: Int -> PU ByteArray
bytearray sz = PU
(\array ix a ->
do let count = (snd $ bounds a) + 1
copyIArray array ix a 0 count
return $ ix + sz)
(\array ix ->
do new <- emptyByteArray sz
copyMArray new 0 array ix sz
pure <- freeze new
return (pure, ix + sz))
(\a -> return $ (snd $ bounds a) + 1)
--- Basic implementation
byteSize :: forall a.(Num a, Bits a) => a -> Int
byteSize a = bitSize a `div` 8
appP_num :: (Num a, Integral a, Bits a) => MutByteArray -> Index -> a
-> IO Index
appP_num array ix a =
do writeBits array ix a
return $ ix + byteSize a
appU_num :: (Num a, Integral a, Bits a) => MutByteArray -> Index ->
IO (a, Index)
appU_num array ix =
do a <- readBits array ix
return (a, ix + byteSize a)
--- Utility
toenum :: forall a b.(Enum a, Integral b) => b -> a
toenum = toEnum . fromIntegral
fromenum :: forall b a. (Num b, Enum a) => a -> b
fromenum = fromIntegral . fromEnum
fromByte :: Enum a => Word8 -> a
fromByte = toEnum . fromIntegral
toByte :: Enum a => a -> Word8
toByte = fromIntegral . fromEnum
And I use it like this:
puTableInfo :: PU TableInfo
puTableInfo =
sequ tiAvgPot endian64
(\a -> sequ tiNumPlayers endian16
(\b -> sequ tiWaiting endian16
(\c -> sequ tiPlayersFlop byte
(\d -> sequ tiTableName wstring
(\e -> sequ tiTableID endian32
(\f -> sequ tiGameType (enum endian16 :: PU GameType)
(\g -> sequ tiInfoMaxPlayers endian16
(\h -> sequ tiIsRealMoneyTable bool
(\i -> sequ tiLowBet endian64
(\j -> sequ tiHighBet endian64
(\k -> sequ tiMinStartMoney endian64
(\l -> sequ tiMaxStartMoney endian64
(\m -> sequ tiGamesPerHour endian16
(\n -> sequ tiTourType (enum byte)
(\o -> sequ tiTourID endian32
(\p -> sequ tiBetType (enum byte)
(\q -> sequ tiCantReturnLess endian32
(\r -> sequ tiAffiliateID (list endian32
byte)
(\v -> sequ tiLangID endian32
(\w -> lift $
TableInfo a b c d e f g
h i j k l m n
o p q r v w
))))))))))))))))))))
--
http://wagerlabs.com/
_______________________________________________
Haskell-Cafe mailing list
[email protected]
http://www.haskell.org/mailman/listinfo/haskell-cafe
