halfs-0.2: BinArray.hs

{-# OPTIONS -cpp -fglasgow-exts #-}

module BinArray
  ( BinArray
  , newBinArray
  , sizeBinArray
  , zeroBinArray 
  , readWord8
  , writeWord8
  , readWord32
  , writeWord32
  , copy
  , getBinArrayRawBuffer 	-- :: BinArray -> MutableByteArray# RealWorld
  ) where

import GHC.Base
import GHC.IOBase
import GHC.Word
--import GHC.Int



-- This is a hack to prevent the profiling version from
-- being *significantly* slower than the unprofiling version.

#ifdef PROFILING
#define IOSCC(label) (\ fn -> IO $ \ s ->  {-# SCC label #-} case fn of { IO m -> m s })
#else
#define IOSCC(label) id
#endif

data BinArray = BinArray Int# 	-- size in *bytes*
     			 (MutableByteArray# RealWorld)
                                -- byte array, padded to 32 bits sized

getBinArrayRawBuffer :: BinArray -> MutableByteArray# RealWorld
getBinArrayRawBuffer (BinArray _ arr) = arr

newBinArray :: Int -> IO BinArray
newBinArray (I# sz) = IO $ \ s_in ->  
  case newByteArray# size s_in of { (# s, arr #) ->
  (# s, BinArray sz arr #) }
  where (I# size) = ((I# sz + 3) `div` 4) * 4


sizeBinArray :: BinArray -> Int
sizeBinArray (BinArray sz _) = I# sz

zeroBinArray :: BinArray -> IO ()
zeroBinArray arr@(BinArray sz _) = 
   sequence_ [ writeWord8 arr i 0x0 | i <- take (I# sz) [0..] ]


-- TODO: this copy needs reworked, to use the FFI.

-- | copy a BinArray onto another BinArray.
--   Requires that the target be the same size, or bigger.

copy :: BinArray -> BinArray -> IO ()
copy ba1@(BinArray i1 _) ba2@(BinArray i2 _) 
     | i1 <=# i2 
       && ((I# i1) `mod` 4) == 0
       && ((I# i2) `mod` 4) == 0 = IOSCC("copy") $ 
         do let loop i t | t == 0 = return ()
                         | otherwise =
                           do v <- unsafeReadWord32 ba1 (I# i)
                              unsafeWriteWord32 ba2 (I# i) v
                              loop (i +# 1#) (t - 1)
            loop 0# ((I# i1) `div` (4 :: Int))
     | otherwise = error "BinArray.copy: BinArray's need to be the same size (or bigger) for copy, and power of 4"


readWord8 :: BinArray -> Int -> IO Word8
readWord8 ba@(BinArray i1 _) (I# i) 
    | i <# i1 = unsafeReadWord8 ba (I# i)
    | otherwise = fail "Bad index value in readWord8"

{-# INLINE unsafeReadWord8 #-}
unsafeReadWord8 :: BinArray -> Int -> IO Word8
unsafeReadWord8 (BinArray _ arr) (I# i) =
    IO $ \ s_in -> case readWord8Array# arr i s_in of { (# s, v #) ->
                     (# s, W8# v #) }

writeWord8 :: BinArray -> Int -> Word8 -> IO ()
writeWord8 ba@(BinArray i1 _) (I# i) v
     | i <# i1 = unsafeWriteWord8 ba (I# i) v
     | otherwise = fail "Bad index value in writeWord8"

{-# INLINE unsafeWriteWord8 #-}
unsafeWriteWord8 :: BinArray -> Int -> Word8 -> IO ()
unsafeWriteWord8 (BinArray _ arr) (I# i) (W8# v) =
    IO $ \ s_in -> case writeWord8Array# arr i v s_in of { s ->
                (# s, () #) }
                 
-- | The addressing is done by Word32 blocks, not the byte address.

readWord32 :: BinArray -> Int -> IO Word32
readWord32 ba@(BinArray i1 _) (I# i) 
    | (i *# 4#) <# i1 = unsafeReadWord32 ba (I# i)
    | otherwise = fail "Bad index value in readWord32"

{-# INLINE unsafeReadWord32 #-}
unsafeReadWord32 :: BinArray -> Int -> IO Word32
unsafeReadWord32 (BinArray _ arr) (I# i) =
    IO $ \ s_in -> case readWord32Array# arr i s_in of { (# s, v #) ->
                (# s, W32# v #) }

-- | The addressing is done by Word32 blocks, not the byte address.

writeWord32 :: BinArray -> Int -> Word32 -> IO ()
writeWord32 ba@(BinArray i1 _) (I# i) v 
    | (i *# 4#) <# i1 = unsafeWriteWord32 ba (I# i) v
    | otherwise = fail "Bad index value in writeWord32"

{-# INLINE unsafeWriteWord32 #-}
unsafeWriteWord32 :: BinArray -> Int -> Word32 -> IO ()
unsafeWriteWord32 (BinArray _ arr) (I# i) (W32# v) =
    IO $ \ s_in -> case writeWord32Array# arr i v s_in of { s ->
                (# s, () #) }