[optimize Binary library in various ways
John Meacham <john@repetae.net>**20060427020713] hunk ./Binary.hs 1
-{-# OPTIONS -fallow-overlapping-instances #-}
+{-# OPTIONS_GHC -funbox-strict-fields -fallow-overlapping-instances #-}
hunk ./Binary.hs 13
--- arch-tag: 1418e09a-9a18-4dca-a0fc-9262c9d97beb
+-- with modifications by John Meacham for jhc
hunk ./Binary.hs 20
-   openBinIO, openBinIO_,
+   openBinIO,
hunk ./Binary.hs 64
-import Control.Monad	
+import Control.Monad
hunk ./Binary.hs 79
-{-
-#if __GLASGOW_HASKELL__ < 503
-type BinArray = MutableByteArray RealWorld Int
-newArray_ bounds     = stToIO (newCharArray bounds)
-unsafeWrite arr ix e = stToIO (writeWord8Array arr ix e)
-unsafeRead  arr ix   = stToIO (readWord8Array arr ix)
-#if __GLASGOW_HASKELL__ < 411
-newByteArray#        = newCharArray#
-#endif
-hPutArray h arr sz   = hPutBufBAFull h arr sz
-hGetArray h sz       = hGetBufBAFull h sz
-
-mkIOError :: IOErrorType -> String -> Maybe Handle -> Maybe FilePath -> Exception
-mkIOError t location maybe_hdl maybe_filename
-  = IOException (IOError maybe_hdl t location ""
-#if __GLASGOW_HASKELL__ > 411
-		         maybe_filename
-#endif
-  		)
-eofErrorType = EOF
-
hunk ./Binary.hs 80
-#ifndef SIZEOF_HSWORD
-#define SIZEOF_HSWORD WORD_SIZE_IN_BYTES
-#endif
-
-#else
hunk ./Binary.hs 81
-#endif
--}
hunk ./Binary.hs 82
---  #define SIZEOF_HSINT 4
-
-type BinArray = IOUArray Int Word8
hunk ./Binary.hs 86
-data BinHandle
-  = BinMem {		-- binary data stored in an unboxed array
-     off_r :: !FastMutInt,		-- the current offset
-     sz_r  :: !FastMutInt,		-- size of the array (cached)
-     arr_r :: !(IORef BinArray) 	-- the array (bounds: (0,size-1))
+data BinHandle = BinHandle {
+    off_r :: !FastMutInt,
+    target_r :: !BinTarget
hunk ./Binary.hs 90
-	-- XXX: should really store a "high water mark" for dumping out
-	-- the binary data to a file.
-
-  | BinIO {		-- binary data stored in a file
-     off_r :: !FastMutInt,		-- the current offset (cached)
-     hdl   :: !IO.Handle		-- the file handle (must be seekable)
-   }
-	-- cache the file ptr in BinIO; using hTell is too expensive
-	-- to call repeatedly.  If anyone else is modifying this Handle
-	-- at the same time, we'll be screwed.
-
---getUserData :: BinHandle -> UserData
---getUserData bh = bh_usr bh
-
---setUserData :: BinHandle -> UserData -> BinHandle
---setUserData bh us = bh { bh_usr = us }
hunk ./Binary.hs 91
+data BinTarget =
+    BinMem {                            -- binary data stored in an unboxed array
+        sz_r  :: !FastMutInt,		-- size of the array (cached)
+        arr_r :: !(IORef BinArray) 	-- the array (bounds: (0,size-1))
+    } |
+    BinIO {		       -- binary data stored in a file
+        hdl   :: !IO.Handle    -- the file handle (must be seekable)
+    }
hunk ./Binary.hs 126
-putAt bh p x = do seekBin bh p; put bh x; return ()
+putAt bh p x = do seekBin bh p; put_ bh x; return ()
hunk ./Binary.hs 131
-openBinIO_ :: IO.Handle -> IO BinHandle
-openBinIO_ h = openBinIO h
hunk ./Binary.hs 136
-  return (BinIO  r h)
+  hSetBinaryMode h True
+  hSetBuffering h (BlockBuffering Nothing)
+  return (BinHandle r (BinIO h))
hunk ./Binary.hs 150
-   return (BinMem ix_r sz_r arr_r)
+   return (BinHandle ix_r (BinMem sz_r arr_r))
hunk ./Binary.hs 153
-tellBin (BinIO   r _)   = do ix <- readFastMutInt r; return (BinPtr ix)
-tellBin (BinMem  r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
+tellBin (BinHandle r _)   = do ix <- readFastMutInt r; return (BinPtr ix)
hunk ./Binary.hs 156
-seekBin (BinIO  ix_r h) (BinPtr p) = do
+seekBin (BinHandle ix_r (BinIO h)) (BinPtr p) = do
hunk ./Binary.hs 159
-seekBin h@(BinMem  ix_r sz_r a) (BinPtr p) = do
+seekBin h@(BinHandle ix_r (BinMem sz_r a)) (BinPtr p) = do
hunk ./Binary.hs 166
-isEOFBin (BinMem  ix_r sz_r a) = do
+isEOFBin (BinHandle ix_r (BinMem sz_r a)) = do
hunk ./Binary.hs 170
-isEOFBin (BinIO  ix_r h) = hIsEOF h
+isEOFBin (BinHandle _ (BinIO h)) = hIsEOF h
hunk ./Binary.hs 173
-writeBinMem (BinIO  _ _) _ = error "Data.Binary.writeBinMem: not a memory handle"
-writeBinMem (BinMem  ix_r sz_r arr_r) fn = do
+writeBinMem (BinHandle ix_r (BinMem sz_r arr_r)) fn = do
hunk ./Binary.hs 196
-  return (BinMem ix_r sz_r arr_r)
+  return (BinHandle ix_r (BinMem sz_r arr_r))
hunk ./Binary.hs 200
-expandBin (BinMem  ix_r sz_r arr_r) off = do
+expandBin (BinHandle ix_r (BinMem sz_r arr_r)) off = do
hunk ./Binary.hs 209
-expandBin (BinIO  _ _) _ = return ()
+expandBin _ _ = return ()
hunk ./Binary.hs 216
-putWord8 h@(BinMem  ix_r sz_r arr_r) w = do
+putWord8 h@(BinHandle ix_r (BinMem  sz_r arr_r)) w = do
hunk ./Binary.hs 230
-putWord8 (BinIO  ix_r h) w = do
-    ix <- readFastMutInt ix_r
+putWord8 (BinHandle ix_r (BinIO h)) w = do
hunk ./Binary.hs 232
+    ix <- readFastMutInt ix_r
hunk ./Binary.hs 237
-getWord8 (BinMem  ix_r sz_r arr_r) = do
+getWord8 (BinHandle ix_r (BinMem sz_r arr_r)) = do
hunk ./Binary.hs 246
-getWord8 (BinIO  ix_r h) = do
+getWord8 (BinHandle ix_r (BinIO h)) = do
hunk ./Binary.hs 248
-    c <- hGetChar h
hunk ./Binary.hs 249
+    c <- hGetChar h
hunk ./Binary.hs 260
+
+-- These do not increment the counter
+
+{-# INLINE putByteIO #-}
+putByteIO :: FastMutInt -> Handle -> Word8 -> IO ()
+putByteIO ix_r h w = do
+    hPutChar h (chr (fromIntegral w))	-- XXX not really correct
+    return ()
+
+{-# INLINE getByteIO #-}
+getByteIO :: FastMutInt -> Handle -> IO Word8
+getByteIO ix_r h = do
+    c <- hGetChar h
+    return $! (fromIntegral (ord c))	-- XXX not really correct
+
+{-# INLINE increment #-}
+increment :: FastMutInt -> Int -> IO ()
+increment ix i = do
+    v <- readFastMutInt ix
+    writeFastMutInt ix (v + i)
+
+
hunk ./Binary.hs 300
+  put_ (BinHandle ix (BinIO h)) w = do
+    putByteIO ix h (fromIntegral (w `shiftR` 24))
+    putByteIO ix h (fromIntegral ((w `shiftR` 16) .&. 0xff))
+    putByteIO ix h (fromIntegral ((w `shiftR` 8)  .&. 0xff))
+    putByteIO ix h (fromIntegral (w .&. 0xff))
+    increment ix 4
hunk ./Binary.hs 311
+  get (BinHandle ix (BinIO h)) = do
+    w1 <- getByteIO ix h
+    w2 <- getByteIO ix h
+    w3 <- getByteIO ix h
+    w4 <- getByteIO ix h
+    increment ix 4
+    return $! ((fromIntegral w1 `shiftL` 24) .|.
+	       (fromIntegral w2 `shiftL` 16) .|.
+	       (fromIntegral w3 `shiftL`  8) .|.
+	       (fromIntegral w4))
hunk ./Binary.hs 397
+-- portability demands ints restricted to 32 bits
hunk ./Binary.hs 399
---  #if SIZEOF_HSINT == 4
hunk ./Binary.hs 403
---  #elif SIZEOF_HSINT == 8
---    put_ bh i = put_ bh (fromIntegral i :: Int64)
---    get  bh = do
---	x <- get bh
---	return $! (fromIntegral (x :: Int64))
---  #else
---  #error "unsupported sizeof(HsInt)"
---  #endif
hunk ./Binary.hs 427
---put_ bh $ (snd $ Data.Array.IArray.bounds a) + 1
---mapM_ (put_ bh) (Data.Array.IArray.elems a)
---sz <- get bh
---x <- sequence $ replicate sz (get bh)
---return $ PS (Data.Array.IArray.listArray (0,sz - 1) x)
-
---put_ bh ps = put_ bh (unpackPS ps)
---get bh = liftM packString $ get bh
---put_ bh ps = putNList_ bh (unpackPS ps)
---get bh = liftM packString $ getNList bh
hunk ./Binary.hs 510
-    put_ bh@(BinIO ix_r h) ua = do
+    put_ bh@(BinHandle ix_r (BinIO h)) ua = do
hunk ./Binary.hs 522
-    get bh@(BinIO ix_r h) = do
+    get bh@(BinHandle ix_r (BinIO h)) = do
hunk ./Binary.hs 535
- {-
-
-instance (Ix a, Binary a) => Binary (UArray a Word8) where
-    put_ bh (UArray s e ba) = do
-        put_ bh s
-        put_ bh e
-        case (rangeSize (s,e)) of
-            I# i -> putByteArray bh ba i
-    get  bh = do
-        s <- get bh
-        e <- get bh
-        BA ba <- getByteArray bh (rangeSize (s,e))
-        return $ UArray s e ba
-
--}
---  #ifdef __GLASGOW_HASKELL__
-