memory 0.4 → 0.5
raw patch · 9 files changed
+565/−31 lines, 9 files
Files
- CHANGELOG.md +9/−1
- Data/ByteArray/Encoding.hs +18/−0
- Data/ByteArray/ScrubbedBytes.hs +2/−22
- Data/Memory/Encoding/Base32.hs +253/−0
- Data/Memory/Hash/FNV.hs +20/−7
- Data/Memory/Internal/CompatPrim64.hs +167/−0
- Data/Memory/Internal/Scrubber.hs +72/−0
- memory.cabal +4/−1
- tests/Tests.hs +20/−0
CHANGELOG.md view
@@ -1,6 +1,14 @@+## 0.5++* Add Base32 support (Nicolas Di Prima)+* Fix build on 32 bit by simplifying scrubber, and adding Word64 type + operations compatibility+ ## 0.4 -* add Ord instances for SipHash and FnvHash (Nicolas Di Prima)+* Add Ord instances for SipHash and FnvHash (Nicolas Di Prima)+* Fix GHC-7.2 build by defining unsafeShiftL (Adam Bergmark)+* Fix show instance of Bytes to properly display each bytes instead of just the end one+* Add View type that emulate a view on a ByteArray type (Nicolas Di Prima) ## 0.3
Data/ByteArray/Encoding.hs view
@@ -18,10 +18,12 @@ import qualified Data.ByteArray.Methods as B import Data.Memory.Internal.Compat import Data.Memory.Encoding.Base16+import Data.Memory.Encoding.Base32 import Data.Memory.Encoding.Base64 -- | Different bases that can be used data Base = Base16 -- ^ similar to hexadecimal+ | Base32 | Base64 deriving (Show,Eq) @@ -31,6 +33,12 @@ B.unsafeCreate (B.length b * 2) $ \bout -> B.withByteArray b $ \bin -> toHexadecimal bout bin (B.length b)+convertToBase Base32 b =+ B.unsafeCreate outLen $ \bout ->+ B.withByteArray b $ \bin ->+ toBase32 bout bin (B.length b)+ where (q,r) = B.length b `divMod` 5+ outLen = 8 * (if r == 0 then q else q + 1) convertToBase Base64 b = B.unsafeCreate outLen $ \bout -> withByteArray b $ \bin ->@@ -50,6 +58,16 @@ case ret of Nothing -> return $ Right out Just ofs -> return $ Left ("base16: input: invalid encoding at offset: " ++ show ofs)+convertFromBase Base32 b = unsafeDoIO $+ withByteArray b $ \bin -> do+ mDstLen <- unBase32Length bin (B.length b)+ case mDstLen of+ Nothing -> return $ Left "base32: input: invalid length"+ Just dstLen -> do+ (ret, out) <- B.allocRet dstLen $ \bout -> fromBase32 bout bin (B.length b)+ case ret of+ Nothing -> return $ Right out+ Just ofs -> return $ Left ("base32: input: invalid encoding at offset: " ++ show ofs) convertFromBase Base64 b = unsafeDoIO $ withByteArray b $ \bin -> do mDstLen <- unBase64Length bin (B.length b)
Data/ByteArray/ScrubbedBytes.hs view
@@ -21,6 +21,7 @@ import Data.Memory.Internal.CompatPrim import Data.Memory.Internal.Compat (unsafeDoIO) import Data.Memory.Internal.Imports+import Data.Memory.Internal.Scrubber (getScrubber) import Data.ByteArray.Types -- | ScrubbedBytes is a memory chunk which have the properties of:@@ -63,31 +64,10 @@ | otherwise = IO $ \s -> case newAlignedPinnedByteArray# sz 8# s of (# s1, mbarr #) ->- let !scrubber = getScrubber+ let !scrubber = getScrubber sz !mba = ScrubbedBytes mbarr in case mkWeak# mbarr () (scrubber (byteArrayContents# (unsafeCoerce# mbarr)) >> touchScrubbedBytes mba) s1 of (# s2, _ #) -> (# s2, mba #)- where- getScrubber :: Addr# -> IO ()- getScrubber = eitherDivideBy8# sz scrubber64 scrubber8-- scrubber64 :: Int# -> Addr# -> IO ()- scrubber64 sz64 addr = IO $ \s -> (# loop sz64 addr s, () #)- where loop :: Int# -> Addr# -> State# RealWorld -> State# RealWorld- loop n a s- | booleanPrim (n ==# 0#) = s- | otherwise =- case writeWord64OffAddr# a 0# 0## s of- s' -> loop (n -# 1#) (plusAddr# a 8#) s'-- scrubber8 :: Int# -> Addr# -> IO ()- scrubber8 sz8 addr = IO $ \s -> (# loop sz8 addr s, () #)- where loop :: Int# -> Addr# -> State# RealWorld -> State# RealWorld- loop n a s- | booleanPrim (n ==# 0#) = s- | otherwise =- case writeWord8OffAddr# a 0# 0## s of- s' -> loop (n -# 1#) (plusAddr# a 1#) s' scrubbedBytesAllocRet :: Int -> (Ptr p -> IO a) -> IO (a, ScrubbedBytes) scrubbedBytesAllocRet sz f = do
+ Data/Memory/Encoding/Base32.hs view
@@ -0,0 +1,253 @@+-- |+-- Module : Data.Memory.Encoding.Base32+-- License : BSD-style+-- Maintainer : Nicolas DI PRIMA <nicolas@di-prima.fr>+-- Stability : experimental+-- Portability : unknown+--+-- Base32+--+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE Rank2Types #-}+module Data.Memory.Encoding.Base32+ ( toBase32+ , unBase32Length+ , fromBase32+ ) where++import Data.Memory.Internal.Compat+import Data.Memory.Internal.CompatPrim+import Data.Word+import Data.Bits ((.|.))+import GHC.Prim+import GHC.Word+import Control.Monad+import Foreign.Storable+import Foreign.Ptr (Ptr)++-- | Transform a number of bytes pointed by.@src in the base32 binary representation in @dst+--+-- destination memory need to be of correct size, otherwise it will lead+-- to really bad things.+toBase32 :: Ptr Word8 -- ^ input+ -> Ptr Word8 -- ^ output+ -> Int -- ^ input len+ -> IO ()+toBase32 dst src len = loop 0 0+ where+ eqChar :: Word8+ eqChar = 0x3d++ peekOrZero :: Int -> IO Word8+ peekOrZero i+ | i >= len = return 0+ | otherwise = peekByteOff src i++ pokeOrPadding :: Int -- for the test+ -> Int -- src index+ -> Word8 -- the value+ -> IO ()+ pokeOrPadding i di v+ | i < len = pokeByteOff dst di v+ | otherwise = pokeByteOff dst di eqChar++ loop :: Int -- index input+ -> Int -- index output+ -> IO ()+ loop i di+ | i > len = return ()+ | otherwise = do+ i1 <- peekByteOff src i+ i2 <- peekOrZero (i + 1)+ i3 <- peekOrZero (i + 2)+ i4 <- peekOrZero (i + 3)+ i5 <- peekOrZero (i + 4)++ let (o1,o2,o3,o4,o5,o6,o7,o8) = toBase32Per5Bytes (i1, i2, i3, i4, i5)++ pokeByteOff dst di o1+ pokeByteOff dst (di + 1) o2+ pokeOrPadding (i + 1) (di + 2) o3+ pokeOrPadding (i + 1) (di + 3) o4+ pokeOrPadding (i + 2) (di + 4) o5+ pokeOrPadding (i + 3) (di + 5) o6+ pokeOrPadding (i + 3) (di + 6) o7+ pokeOrPadding (i + 4) (di + 7) o8++ loop (i+5) (di+8)++toBase32Per5Bytes :: (Word8, Word8, Word8, Word8, Word8)+ -> (Word8, Word8, Word8, Word8, Word8, Word8, Word8, Word8)+toBase32Per5Bytes (W8# i1, W8# i2, W8# i3, W8# i4, W8# i5) =+ (index o1, index o2, index o3, index o4, index o5, index o6, index o7, index o8)+ where+ -- 1111 1000 >> 3+ !o1 = (uncheckedShiftRL# (and# i1 0xF8##) 3#)+ -- 0000 0111 << 2 | 1100 0000 >> 6+ !o2 = or# (uncheckedShiftL# (and# i1 0x07##) 2#) (uncheckedShiftRL# (and# i2 0xC0##) 6#)+ -- 0011 1110 >> 1+ !o3 = (uncheckedShiftRL# (and# i2 0x3E##) 1#)+ -- 0000 0001 << 4 | 1111 0000 >> 4+ !o4 = or# (uncheckedShiftL# (and# i2 0x01##) 4#) (uncheckedShiftRL# (and# i3 0xF0##) 4#)+ -- 0000 1111 << 1 | 1000 0000 >> 7+ !o5 = or# (uncheckedShiftL# (and# i3 0x0F##) 1#) (uncheckedShiftRL# (and# i4 0x80##) 7#)+ -- 0111 1100 >> 2+ !o6 = (uncheckedShiftRL# (and# i4 0x7C##) 2#)+ -- 0000 0011 << 3 | 1110 0000 >> 5+ !o7 = or# (uncheckedShiftL# (and# i4 0x03##) 3#) (uncheckedShiftRL# (and# i5 0xE0##) 5#)+ -- 0001 1111+ !o8 = ((and# i5 0x1F##))++ !set = "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"#++ index :: Word# -> Word8+ index idx = W8# (indexWord8OffAddr# set (word2Int# idx))++-- | Get the length needed for the destination buffer for a base32 decoding.+--+-- if the length is not a multiple of 8, Nothing is returned+unBase32Length :: Ptr Word8 -> Int -> IO (Maybe Int)+unBase32Length src len+ | (len `mod` 8) /= 0 = return Nothing+ | otherwise = do+ last1Byte <- peekByteOff src (len - 1)+ last2Byte <- peekByteOff src (len - 2)+ last3Byte <- peekByteOff src (len - 3)+ last4Byte <- peekByteOff src (len - 4)+ last5Byte <- peekByteOff src (len - 5)+ last6Byte <- peekByteOff src (len - 6)++ let dstLen = caseByte last1Byte last2Byte last3Byte last4Byte last5Byte last6Byte+ return $ Just $ (len `div` 8) * 5 - dstLen+ where+ caseByte :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Int+ caseByte last1 last2 last3 last4 last5 last6+ | last6 == eqAscii = 4+ | last5 == eqAscii = 3 -- error this padding is not expected (error will be detected in fromBase32)+ | last4 == eqAscii = 3+ | last3 == eqAscii = 2+ | last2 == eqAscii = 1 -- error this padding is not expected (error will be detected in fromBase32)+ | last1 == eqAscii = 1+ | otherwise = 0++ eqAscii :: Word8+ eqAscii = 0x3D++-- | convert from base32 in @src to binary in @dst, using the number of bytes specified+--+-- the user should use unBase32Length to compute the correct length, or check that+-- the length specification is proper. no check is done here.+fromBase32 :: Ptr Word8 -> Ptr Word8 -> Int -> IO (Maybe Int)+fromBase32 dst src len+ | len == 0 = return Nothing+ | otherwise = loop 0 0+ where+ loop :: Int -- the index dst+ -> Int -- the index src+ -> IO (Maybe Int)+ loop di i+ | i == (len - 8) = do+ i1 <- peekByteOff src i+ i2 <- peekByteOff src (i + 1)+ i3 <- peekByteOff src (i + 2)+ i4 <- peekByteOff src (i + 3)+ i5 <- peekByteOff src (i + 4)+ i6 <- peekByteOff src (i + 5)+ i7 <- peekByteOff src (i + 6)+ i8 <- peekByteOff src (i + 7)++ let (nbBytes, i3', i4', i5', i6', i7', i8') =+ case (i3, i4, i5, i6, i7, i8) of+ (0x3D, 0x3D, 0x3D, 0x3D, 0x3D, 0x3D) -> (6, 0x41, 0x41, 0x41, 0x41, 0x41, 0x41)+ (0x3D, _ , _ , _ , _ , _ ) -> (0, i3, i4, i5, i6, i7, i8) -- invalid+ (_ , 0x3D, 0x3D, 0x3D, 0x3D, 0x3D) -> (5, i3 , 0x41, 0x41, 0x41, 0x41, 0x41)+ (_ , 0x3D, _ , _ , _ , _ ) -> (0, i3, i4, i5, i6, i7, i8) -- invalid+ (_ , _ , 0x3D, 0x3D, 0x3D, 0x3D) -> (4, i3 , i4 , 0x41, 0x41, 0x41, 0x41)+ (_ , _ , 0x3D, _ , _ , _ ) -> (0, i3, i4, i5, i6, i7, i8) -- invalid+ (_ , _ , _ , 0x3D, 0x3D, 0x3D) -> (3, i3 , i4 , i5 , 0x41, 0x41, 0x41)+ (_ , _ , _ , 0x3D, _ , _ ) -> (0, i3, i4, i5, i6, i7, i8) -- invalid+ (_ , _ , _ , _ , 0x3D, 0x3D) -> (2, i3 , i4 , i5 , i6 , 0x41, 0x41)+ (_ , _ , _ , _ , 0x3D, _ ) -> (0, i3, i4, i5, i6, i7, i8) -- invalid+ (_ , _ , _ , _ , _ , 0x3D) -> (1, i3 , i4 , i5 , i6 , i7 , 0x41)+ (_ , _ , _ , _ , _ , _ ) -> (0 :: Int, i3, i4, i5, i6, i7, i8)++ case fromBase32Per8Bytes (i1, i2, i3', i4', i5', i6', i7', i8') of+ Left ofs -> return $ Just (i + ofs)+ Right (o1, o2, o3, o4, o5) -> do+ pokeByteOff dst di o1+ pokeByteOff dst (di+1) o2+ when (nbBytes < 5) $ pokeByteOff dst (di+2) o3+ when (nbBytes < 4) $ pokeByteOff dst (di+3) o4+ when (nbBytes < 2) $ pokeByteOff dst (di+4) o5+ return Nothing++ | otherwise = do+ i1 <- peekByteOff src i+ i2 <- peekByteOff src (i + 1)+ i3 <- peekByteOff src (i + 2)+ i4 <- peekByteOff src (i + 3)+ i5 <- peekByteOff src (i + 4)+ i6 <- peekByteOff src (i + 5)+ i7 <- peekByteOff src (i + 6)+ i8 <- peekByteOff src (i + 7)++ case fromBase32Per8Bytes (i1, i2, i3, i4, i5, i6, i7, i8) of+ Left ofs -> return $ Just (i + ofs)+ Right (o1, o2, o3, o4, o5) -> do+ pokeByteOff dst di o1+ pokeByteOff dst (di+1) o2+ pokeByteOff dst (di+2) o3+ pokeByteOff dst (di+3) o4+ pokeByteOff dst (di+4) o5+ loop (di+5) (i+8)++fromBase32Per8Bytes :: (Word8, Word8, Word8, Word8, Word8, Word8, Word8, Word8)+ -> Either Int (Word8, Word8, Word8, Word8, Word8)+fromBase32Per8Bytes (i1, i2, i3, i4, i5, i6, i7, i8) =+ case (rset i1, rset i2, rset i3, rset i4, rset i5, rset i6, rset i7, rset i8) of+ (0xFF, _ , _ , _ , _ , _ , _ , _ ) -> Left 0+ (_ , 0xFF, _ , _ , _ , _ , _ , _ ) -> Left 1+ (_ , _ , 0xFF, _ , _ , _ , _ , _ ) -> Left 2+ (_ , _ , _ , 0xFF, _ , _ , _ , _ ) -> Left 3+ (_ , _ , _ , _ , 0xFF, _ , _ , _ ) -> Left 4+ (_ , _ , _ , _ , _ , 0xFF, _ , _ ) -> Left 5+ (_ , _ , _ , _ , _ , _ , 0xFF, _ ) -> Left 6+ (_ , _ , _ , _ , _ , _ , _ , 0xFF) -> Left 7+ (ri1 , ri2 , ri3 , ri4 , ri5 , ri6 , ri7 , ri8 ) ->+ -- 0001 1111 << 3 | 0001 11xx >> 2+ let o1 = (ri1 `unsafeShiftL` 3) .|. (ri2 `unsafeShiftR` 2)+ -- 000x xx11 << 6 | 0001 1111 << 1 | 0001 xxxx >> 4+ o2 = (ri2 `unsafeShiftL` 6) .|. (ri3 `unsafeShiftL` 1) .|. (ri4 `unsafeShiftR` 4)+ -- 000x 1111 << 4 | 0001 111x >> 1+ o3 = (ri4 `unsafeShiftL` 4) .|. (ri5 `unsafeShiftR` 1)+ -- 000x xxx1 << 7 | 0001 1111 << 2 | 0001 1xxx >> 3+ o4 = (ri5 `unsafeShiftL` 7) .|. (ri6 `unsafeShiftL` 2) .|. (ri7 `unsafeShiftR` 3)+ -- 000x x111 << 5 | 0001 1111+ o5 = (ri7 `unsafeShiftL` 5) .|. ri8+ in Right (o1, o2, o3, o4, o5)+ where+ rset :: Word8 -> Word8+ rset (W8# w)+ | booleanPrim (w `leWord#` 0xff##) = W8# (indexWord8OffAddr# rsetTable (word2Int# w))+ | otherwise = 0xff++ !rsetTable = "\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\+ \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\+ \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\+ \\xFF\xFF\x1A\x1B\x1C\x1D\x1E\x1F\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\+ \\xFF\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0A\x0B\x0C\x0D\x0E\+ \\x0F\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\xFF\xFF\xFF\xFF\xFF\+ \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\+ \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\+ \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\+ \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\+ \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\+ \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\+ \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\+ \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\+ \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\+ \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF"#+
Data/Memory/Hash/FNV.hs view
@@ -26,9 +26,10 @@ import Data.Memory.Internal.Compat () import Data.Memory.Internal.CompatPrim+import Data.Memory.Internal.CompatPrim64 import Data.Memory.Internal.Imports import GHC.Word-import GHC.Prim+import GHC.Prim hiding (Word64#, Int64#) import GHC.Types import GHC.Ptr @@ -68,26 +69,38 @@ -- | compute FNV1 (64 bit variant) of a raw piece of memory fnv1_64 :: Ptr Word8 -> Int -> IO FnvHash64-fnv1_64 (Ptr addr) (I# n) = IO $ \s -> loop 0xcbf29ce484222325## 0# s+fnv1_64 (Ptr addr) (I# n) = IO $ \s -> loop fnv64Const 0# s where - loop :: Word# -> Int# -> State# s -> (# State# s, FnvHash64 #)+ loop :: Word64# -> Int# -> State# s -> (# State# s, FnvHash64 #) loop !acc i s | booleanPrim (i ==# n) = (# s, FnvHash64 $ W64# acc #) | otherwise = case readWord8OffAddr# addr i s of (# s2, v #) ->- let !nacc = (0x100000001b3## `timesWord#` acc) `xor#` v+ let !nacc = (fnv64Prime `timesWord64#` acc) `xor64#` (wordToWord64# v) in loop nacc (i +# 1#) s2 + fnv64Const :: Word64#+ !fnv64Const = w64# 0xcbf29ce484222325## 0xcbf29ce4## 0x84222325##++ fnv64Prime :: Word64#+ !fnv64Prime = w64# 0x100000001b3## 0x100## 0x000001b3##+ -- | compute FNV1a (64 bit variant) of a raw piece of memory fnv1a_64 :: Ptr Word8 -> Int -> IO FnvHash64-fnv1a_64 (Ptr addr) (I# n) = IO $ \s -> loop 0xcbf29ce484222325## 0# s+fnv1a_64 (Ptr addr) (I# n) = IO $ \s -> loop fnv64Const 0# s where - loop :: Word# -> Int# -> State# s -> (# State# s, FnvHash64 #)+ loop :: Word64# -> Int# -> State# s -> (# State# s, FnvHash64 #) loop !acc i s | booleanPrim (i ==# n) = (# s, FnvHash64 $ W64# acc #) | otherwise = case readWord8OffAddr# addr i s of (# s2, v #) ->- let !nacc = 0x100000001b3## `timesWord#` (acc `xor#` v)+ let !nacc = fnv64Prime `timesWord64#` (acc `xor64#` wordToWord64# v) in loop nacc (i +# 1#) s2++ fnv64Const :: Word64#+ !fnv64Const = w64# 0xcbf29ce484222325## 0xcbf29ce4## 0x84222325##++ fnv64Prime :: Word64#+ !fnv64Prime = w64# 0x100000001b3## 0x100## 0x000001b3##
+ Data/Memory/Internal/CompatPrim64.hs view
@@ -0,0 +1,167 @@+-- |+-- Module : Data.Memory.Internal.CompatPrim+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : stable+-- Portability : Compat+--+-- This module try to keep all the difference between versions of ghc primitive+-- or other needed packages, so that modules don't need to use CPP.+--+-- Note that MagicHash and CPP conflicts in places, making it "more interesting"+-- to write compat code for primitives+--+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+#include "MachDeps.h"+module Data.Memory.Internal.CompatPrim64+ ( Word64#+ , Int64#+ , eqInt64#+ , neInt64#+ , ltInt64#+ , leInt64#+ , gtInt64#+ , geInt64#+ , quotInt64#+ , remInt64#+ , eqWord64#+ , neWord64#+ , ltWord64#+ , leWord64#+ , gtWord64#+ , geWord64#+ , and64#+ , or64#+ , xor64#+ , not64#+ , timesWord64#+ , uncheckedShiftL64#+ , uncheckedShiftRL64#++ , int64ToWord64#+ , word64ToInt64#+ , intToInt64#+ , int64ToInt#+ , wordToWord64#+ , word64ToWord#+ , w64#+ ) where+++#if WORD_SIZE_IN_BITS == 64+import GHC.Prim hiding (Word64#, Int64#)++#if __GLASGOW_HASKELL__ >= 708+type OutBool = Int#+#else+type OutBool = Bool+#endif++type Word64# = Word#+type Int64# = Int#++eqWord64# :: Word64# -> Word64# -> OutBool+eqWord64# = eqWord#++neWord64# :: Word64# -> Word64# -> OutBool+neWord64# = neWord#++ltWord64# :: Word64# -> Word64# -> OutBool+ltWord64# = ltWord#++leWord64# :: Word64# -> Word64# -> OutBool+leWord64# = leWord#++gtWord64# :: Word64# -> Word64# -> OutBool+gtWord64# = gtWord#++geWord64# :: Word64# -> Word64# -> OutBool+geWord64# = geWord#++eqInt64# :: Int64# -> Int64# -> OutBool+eqInt64# = (==#)++neInt64# :: Int64# -> Int64# -> OutBool+neInt64# = (/=#)++ltInt64# :: Int64# -> Int64# -> OutBool+ltInt64# = (<#)++leInt64# :: Int64# -> Int64# -> OutBool+leInt64# = (<=#)++gtInt64# :: Int64# -> Int64# -> OutBool+gtInt64# = (>#)++geInt64# :: Int64# -> Int64# -> OutBool+geInt64# = (<=#)++quotInt64# :: Int64# -> Int64# -> Int64#+quotInt64# = quotInt#++remInt64# :: Int64# -> Int64# -> Int64#+remInt64# = remInt#++and64# :: Word64# -> Word64# -> Word64#+and64# = and#++or64# :: Word64# -> Word64# -> Word64#+or64# = or#++xor64# :: Word64# -> Word64# -> Word64#+xor64# = xor#++not64# :: Word64# -> Word64#+not64# = not#++uncheckedShiftL64# :: Word64# -> Int# -> Word64#+uncheckedShiftL64# = uncheckedShiftL#++uncheckedShiftRL64# :: Word64# -> Int# -> Word64#+uncheckedShiftRL64# = uncheckedShiftL#++int64ToWord64# :: Int64# -> Word64#+int64ToWord64# = int2Word#++word64ToInt64# :: Word64# -> Int64#+word64ToInt64# = word2Int#++intToInt64# :: Int# -> Int64#+intToInt64# w = w++int64ToInt# :: Int64# -> Int#+int64ToInt# w = w++wordToWord64# :: Word# -> Word64#+wordToWord64# w = w++word64ToWord# :: Word64# -> Word#+word64ToWord# w = w++timesWord64# :: Word64# -> Word64# -> Word64#+timesWord64# = timesWord#++w64# :: Word# -> Word# -> Word# -> Word64#+w64# w _ _ = w++#elif WORD_SIZE_IN_BITS == 32+import GHC.IntWord64+import GHC.Prim (Word#)++timesWord64# :: Word64# -> Word64# -> Word64#+timesWord64# a b =+ let !ai = word64ToInt64# a+ !bi = word64ToInt64# b+ in int64ToWord64# (timesInt64# ai bi)++w64# :: Word# -> Word# -> Word# -> Word64#+w64# _ hw lw =+ let !h = wordToWord64# hw+ !l = wordToWord64# lw+ in or64# (uncheckedShiftL64# h 32#) l+#else+#error "not a supported architecture. supported WORD_SIZE_IN_BITS is 32 bits or 64 bits"+#endif
+ Data/Memory/Internal/Scrubber.hs view
@@ -0,0 +1,72 @@+-- |+-- Module : Data.Memory.Internal.Scrubber+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : stable+-- Portability : Compat+--+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+#include "MachDeps.h"+module Data.Memory.Internal.Scrubber+ ( getScrubber+ ) where++import GHC.Prim+import GHC.IO+import Data.Memory.Internal.CompatPrim (booleanPrim)++getScrubber :: Int# -> (Addr# -> IO ())+getScrubber sz + | booleanPrim (sz ==# 4#) = scrub4+ | booleanPrim (sz ==# 8#) = scrub8+ | booleanPrim (sz ==# 16#) = scrub16+ | booleanPrim (sz ==# 32#) = scrub32+ | otherwise = scrubBytes sz+ where+ scrub4 a = IO $ \s -> (# writeWord32OffAddr# a 0# 0## s, () #)+#if WORD_SIZE_IN_BITS == 64+ scrub8 a = IO $ \s -> (# writeWord64OffAddr# a 0# 0## s, () #)+ scrub16 a = IO $ \s1 ->+ let !s2 = writeWord64OffAddr# a 0# 0## s1+ !s3 = writeWord64OffAddr# a 8# 0## s2+ in (# s3, () #)+ scrub32 a = IO $ \s1 ->+ let !s2 = writeWord64OffAddr# a 0# 0## s1+ !s3 = writeWord64OffAddr# a 8# 0## s2+ !s4 = writeWord64OffAddr# a 16# 0## s3+ !s5 = writeWord64OffAddr# a 24# 0## s4+ in (# s5, () #)+#else+ scrub8 a = IO $ \s1 ->+ let !s2 = writeWord32OffAddr# a 0# 0## s1+ !s3 = writeWord32OffAddr# a 4# 0## s2+ in (# s3, () #)+ scrub16 a = IO $ \s1 ->+ let !s2 = writeWord32OffAddr# a 0# 0## s1+ !s3 = writeWord32OffAddr# a 4# 0## s2+ !s4 = writeWord32OffAddr# a 8# 0## s3+ !s5 = writeWord32OffAddr# a 12# 0## s4+ in (# s5, () #)+ scrub32 a = IO $ \s1 ->+ let !s2 = writeWord32OffAddr# a 0# 0## s1+ !s3 = writeWord32OffAddr# a 4# 0## s2+ !s4 = writeWord32OffAddr# a 8# 0## s3+ !s5 = writeWord32OffAddr# a 12# 0## s4+ !s6 = writeWord32OffAddr# a 16# 0## s5+ !s7 = writeWord32OffAddr# a 20# 0## s6+ !s8 = writeWord32OffAddr# a 24# 0## s7+ !s9 = writeWord32OffAddr# a 28# 0## s8+ in (# s9, () #)+#endif++scrubBytes :: Int# -> Addr# -> IO ()+scrubBytes sz8 addr = IO $ \s -> (# loop sz8 addr s, () #)+ where loop :: Int# -> Addr# -> State# RealWorld -> State# RealWorld+ loop n a s+ | booleanPrim (n ==# 0#) = s+ | otherwise =+ case writeWord8OffAddr# a 0# 0## s of+ s' -> loop (n -# 1#) (plusAddr# a 1#) s'
memory.cabal view
@@ -1,5 +1,5 @@ Name: memory-Version: 0.4+Version: 0.5 Synopsis: memory and related abtraction stuff Description: Chunk of memory, polymorphic byte array management and manipulation@@ -49,11 +49,14 @@ Data.Memory.PtrMethods Data.Memory.ExtendedWords Data.Memory.Encoding.Base16+ Data.Memory.Encoding.Base32 Data.Memory.Encoding.Base64 Other-modules: Data.Memory.Internal.Compat Data.Memory.Internal.CompatPrim+ Data.Memory.Internal.CompatPrim64 Data.Memory.Internal.DeepSeq Data.Memory.Internal.Imports+ Data.Memory.Internal.Scrubber Data.Memory.Hash.SipHash Data.Memory.Hash.FNV Data.ByteArray.Pack.Internal
tests/Tests.hs view
@@ -63,11 +63,29 @@ base16Kats = [ ("this is a string", "74686973206973206120737472696e67") ] +base32Kats =+ [ ("-pleasure.", "FVYGYZLBON2XEZJO")+ , ("pleasure.", "OBWGKYLTOVZGKLQ=")+ , ("leasure.", "NRSWC43VOJSS4===")+ , ("easure.", "MVQXG5LSMUXA====")+ , ("asure.", "MFZXK4TFFY======")+ , ("sure.", "ON2XEZJO")+ , ("ure.", "OVZGKLQ=")+ , ("re.", "OJSS4===")+ , ("e.", "MUXA====")+ , (".", "FY======")+ , ("", "")+ ]+ encodingTests witnessID = [ testGroup "BASE64" [ testGroup "encode-KAT" encodeKats64 , testGroup "decode-KAT" decodeKats64 ]+ , testGroup "BASE32"+ [ testGroup "encode-KAT" encodeKats32+ , testGroup "decode-KAT" decodeKats32+ ] , testGroup "BASE16" [ testGroup "encode-KAT" encodeKats16 , testGroup "decode-KAT" decodeKats16@@ -76,6 +94,8 @@ where encodeKats64 = map (toTest B.Base64) $ zip [1..] base64Kats decodeKats64 = map (toBackTest B.Base64) $ zip [1..] base64Kats+ encodeKats32 = map (toTest B.Base32) $ zip [1..] base32Kats+ decodeKats32 = map (toBackTest B.Base32) $ zip [1..] base32Kats encodeKats16 = map (toTest B.Base16) $ zip [1..] base16Kats decodeKats16 = map (toBackTest B.Base16) $ zip [1..] base16Kats