la_ancapo/stellar-veritas
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Initial commit

Browse source
This commit is contained in:
La Ancapo 2026-01-25 02:27:22 +01:00
commit c101616e62
309 changed files with 53937 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

176
bundled/Data/Memory/Encoding/Base16.hs Normal file
View file

@ -0,0 +1,176 @@
-- |
-- Module : Data.Memory.Encoding.Base16
-- License : BSD-style
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : unknown
--
-- Low-level Base16 encoding and decoding.
--
-- If you just want to encode or decode some bytes, you probably want to use
-- the "Data.ByteArray.Encoding" module.
--
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE Rank2Types #-}
module Data.Memory.Encoding.Base16
( showHexadecimal
, toHexadecimal
, fromHexadecimal
) where
import Data.Memory.Internal.Compat
import Data.Word
import Basement.Bits
import Basement.IntegralConv
import GHC.Prim
import GHC.Types
import GHC.Word
import GHC.Char (chr)
import Control.Monad
import Foreign.Storable
import Foreign.Ptr (Ptr)
-- | Transform a raw memory to an hexadecimal 'String'
--
-- user beware, no checks are made
showHexadecimal :: (forall a . (Ptr Word8 -> IO a) -> IO a) -- ^ a 'with' type of function to hold reference to the object
-> Int -- ^ length in bytes
-> String
showHexadecimal withPtr = doChunks 0
where
doChunks ofs len
| len < 4 = doUnique ofs len
| otherwise = do
let !(a, b, c, d) = unsafeDoIO $ withPtr (read4 ofs)
!(# w1, w2 #) = convertByte a
!(# w3, w4 #) = convertByte b
!(# w5, w6 #) = convertByte c
!(# w7, w8 #) = convertByte d
in wToChar w1 : wToChar w2 : wToChar w3 : wToChar w4
: wToChar w5 : wToChar w6 : wToChar w7 : wToChar w8
: doChunks (ofs + 4) (len - 4)
doUnique ofs len
| len == 0 = []
| otherwise =
let !b = unsafeDoIO $ withPtr (byteIndex ofs)
!(# w1, w2 #) = convertByte b
in wToChar w1 : wToChar w2 : doUnique (ofs + 1) (len - 1)
read4 :: Int -> Ptr Word8 -> IO (Word8, Word8, Word8, Word8)
read4 ofs p =
liftM4 (,,,) (byteIndex ofs p) (byteIndex (ofs+1) p)
(byteIndex (ofs+2) p) (byteIndex (ofs+3) p)
wToChar :: Word8 -> Char
wToChar w = chr (integralUpsize w)
byteIndex :: Int -> Ptr Word8 -> IO Word8
byteIndex i p = peekByteOff p i
-- | Transform a number of bytes pointed by.@src in the hexadecimal binary representation in @dst
--
-- destination memory need to be of correct size, otherwise it will lead
-- to really bad things.
toHexadecimal :: Ptr Word8 -- ^ destination memory
-> Ptr Word8 -- ^ source memory
-> Int -- ^ number of bytes
-> IO ()
toHexadecimal bout bin n = loop 0
where loop i
| i == n = return ()
| otherwise = do
!w <- peekByteOff bin i
let !(# !w1, !w2 #) = convertByte w
pokeByteOff bout (i * 2) w1
pokeByteOff bout (i * 2 + 1) w2
loop (i+1)
-- | Convert a value Word# to two Word#s containing
-- the hexadecimal representation of the Word#
convertByte :: Word8 -> (# Word8, Word8 #)
convertByte bwrap = (# r tableHi b, r tableLo b #)
where
!(W# b) = integralUpsize bwrap
r :: Addr# -> Word# -> Word8
r table index = W8# (indexWord8OffAddr# table (word2Int# index))
!tableLo =
"0123456789abcdef0123456789abcdef\
\0123456789abcdef0123456789abcdef\
\0123456789abcdef0123456789abcdef\
\0123456789abcdef0123456789abcdef\
\0123456789abcdef0123456789abcdef\
\0123456789abcdef0123456789abcdef\
\0123456789abcdef0123456789abcdef\
\0123456789abcdef0123456789abcdef"#
!tableHi =
"00000000000000001111111111111111\
\22222222222222223333333333333333\
\44444444444444445555555555555555\
\66666666666666667777777777777777\
\88888888888888889999999999999999\
\aaaaaaaaaaaaaaaabbbbbbbbbbbbbbbb\
\ccccccccccccccccdddddddddddddddd\
\eeeeeeeeeeeeeeeeffffffffffffffff"#
{-# INLINE convertByte #-}
-- | convert a base16 @src in @dst.
--
-- n need to even
fromHexadecimal :: Ptr Word8 -> Ptr Word8 -> Int -> IO (Maybe Int)
fromHexadecimal dst src n
| odd n = error "fromHexadecimal: invalid odd length."
| otherwise = loop 0 0
where loop di i
| i == n = return Nothing
| otherwise = do
a <- rHi `fmap` peekByteOff src i
b <- rLo `fmap` peekByteOff src (i+1)
if a == 0xff || b == 0xff
then return $ Just i
else pokeByteOff dst di (a .|. b) >> loop (di+1) (i+2)
rLo, rHi :: Word8 -> Word8
rLo index = W8# (indexWord8OffAddr# tableLo (word2Int# widx))
where !(W# widx) = integralUpsize index
rHi index = W8# (indexWord8OffAddr# tableHi (word2Int# widx))
where !(W# widx) = integralUpsize index
!tableLo =
"\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\
\\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\xff\xff\xff\xff\xff\xff\
\\xff\x0a\x0b\x0c\x0d\x0e\x0f\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\x0a\x0b\x0c\x0d\x0e\x0f\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"#
!tableHi =
"\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\
\\x00\x10\x20\x30\x40\x50\x60\x70\x80\x90\xff\xff\xff\xff\xff\xff\
\\xff\xa0\xb0\xc0\xd0\xe0\xf0\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\xa0\xb0\xc0\xd0\xe0\xf0\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"#

256
bundled/Data/Memory/Encoding/Base32.hs Normal file
View file

@ -0,0 +1,256 @@
-- |
-- Module : Data.Memory.Encoding.Base32
-- License : BSD-style
-- Maintainer : Nicolas DI PRIMA <nicolas@di-prima.fr>
-- Stability : experimental
-- Portability : unknown
--
-- Low-level Base32 encoding and decoding.
--
-- If you just want to encode or decode some bytes, you probably want to use
-- the "Data.ByteArray.Encoding" module.
--
{-# 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.Word
import Basement.Bits
import Basement.IntegralConv
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 (!i1, !i2, !i3, !i4, !i5) =
(index o1, index o2, index o3, index o4, index o5, index o6, index o7, index o8)
where
-- 1111 1000 >> 3
!o1 = (i1 .&. 0xF8) .>>. 3
-- 0000 0111 << 2 | 1100 0000 >> 6
!o2 = ((i1 .&. 0x07) .<<. 2) .|. ((i2 .&. 0xC0) .>>. 6)
-- 0011 1110 >> 1
!o3 = ((i2 .&. 0x3E) .>>. 1)
-- 0000 0001 << 4 | 1111 0000 >> 4
!o4 = ((i2 .&. 0x01) .<<. 4) .|. ((i3 .&. 0xF0) .>>. 4)
-- 0000 1111 << 1 | 1000 0000 >> 7
!o5 = ( (i3 .&. 0x0F) .<<. 1) .|. ((i4 .&. 0x80) .>>. 7)
-- 0111 1100 >> 2
!o6 = (i4 .&. 0x7C) .>>. 2
-- 0000 0011 << 3 | 1110 0000 >> 5
!o7 = ((i4 .&. 0x03) .<<. 3) .|. ((i5 .&. 0xE0) .>>. 5)
-- 0001 1111
!o8 = i5 .&. 0x1F
!set = "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"#
index :: Word8 -> Word8
index idx = W8# (indexWord8OffAddr# set (word2Int# widx))
where !(W# widx) = integralUpsize 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 < 1 = return $ Just 0
| (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 w = W8# (indexWord8OffAddr# rsetTable (word2Int# widx))
where !(W# widx) = integralUpsize w
!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"#

328
bundled/Data/Memory/Encoding/Base64.hs Normal file
View file

@ -0,0 +1,328 @@
-- |
-- Module : Data.Memory.Encoding.Base64
-- License : BSD-style
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : unknown
--
-- Low-level Base64 encoding and decoding.
--
-- If you just want to encode or decode some bytes, you probably want to use
-- the "Data.ByteArray.Encoding" module.
--
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE Rank2Types #-}
module Data.Memory.Encoding.Base64
( toBase64
, toBase64URL
, toBase64OpenBSD
, unBase64Length
, unBase64LengthUnpadded
, fromBase64
, fromBase64URLUnpadded
, fromBase64OpenBSD
) where
import Data.Memory.Internal.Compat
import Data.Memory.Internal.Imports
import Basement.Bits
import Basement.IntegralConv (integralUpsize)
import GHC.Prim
import GHC.Word
import Foreign.Storable
import Foreign.Ptr (Ptr)
-- | Transform a number of bytes pointed by @src@ to base64 binary representation in @dst@
--
-- The destination memory need to be of correct size, otherwise it will lead
-- to really bad things.
toBase64 :: Ptr Word8 -> Ptr Word8 -> Int -> IO ()
toBase64 dst src len = toBase64Internal set dst src len True
where
!set = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"#
-- | Transform a number of bytes pointed by @src@ to, URL-safe base64 binary
-- representation in @dst@. The result will be either padded or unpadded,
-- depending on the boolean @padded@ argument.
--
-- The destination memory need to be of correct size, otherwise it will lead
-- to really bad things.
toBase64URL :: Bool -> Ptr Word8 -> Ptr Word8 -> Int -> IO ()
toBase64URL padded dst src len = toBase64Internal set dst src len padded
where
!set = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_"#
toBase64OpenBSD :: Ptr Word8 -> Ptr Word8 -> Int -> IO ()
toBase64OpenBSD dst src len = toBase64Internal set dst src len False
where
!set = "./ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"#
toBase64Internal :: Addr# -> Ptr Word8 -> Ptr Word8 -> Int -> Bool -> IO ()
toBase64Internal table dst src len padded = loop 0 0
where
eqChar = 0x3d :: Word8
loop i di
| i >= len = return ()
| otherwise = do
a <- peekByteOff src i
b <- if i + 1 >= len then return 0 else peekByteOff src (i+1)
c <- if i + 2 >= len then return 0 else peekByteOff src (i+2)
let (w,x,y,z) = convert3 table a b c
pokeByteOff dst di w
pokeByteOff dst (di+1) x
if i + 1 < len
then
pokeByteOff dst (di+2) y
else
when padded (pokeByteOff dst (di+2) eqChar)
if i + 2 < len
then
pokeByteOff dst (di+3) z
else
when padded (pokeByteOff dst (di+3) eqChar)
loop (i+3) (di+4)
convert3 :: Addr# -> Word8 -> Word8 -> Word8 -> (Word8, Word8, Word8, Word8)
convert3 table !a !b !c =
let !w = a .>>. 2
!x = ((a .<<. 4) .&. 0x30) .|. (b .>>. 4)
!y = ((b .<<. 2) .&. 0x3c) .|. (c .>>. 6)
!z = c .&. 0x3f
in (index w, index x, index y, index z)
where
index :: Word8 -> Word8
index !idxb = W8# (indexWord8OffAddr# table (word2Int# idx))
where !(W# idx) = integralUpsize idxb
-- | Get the length needed for the destination buffer for a base64 decoding.
--
-- if the length is not a multiple of 4, Nothing is returned
unBase64Length :: Ptr Word8 -> Int -> IO (Maybe Int)
unBase64Length src len
| len < 1 = return $ Just 0
| (len `mod` 4) /= 0 = return Nothing
| otherwise = do
last1Byte <- peekByteOff src (len - 1)
last2Byte <- peekByteOff src (len - 2)
let dstLen = if last1Byte == eqAscii
then if last2Byte == eqAscii then 2 else 1
else 0
return $ Just $ (len `div` 4) * 3 - dstLen
where
eqAscii :: Word8
eqAscii = fromIntegral (fromEnum '=')
-- | Get the length needed for the destination buffer for an
-- <http://tools.ietf.org/html/rfc4648#section-3.2 unpadded> base64 decoding.
--
-- If the length of the encoded string is a multiple of 4, plus one, Nothing is
-- returned. Any other value can be valid without padding.
unBase64LengthUnpadded :: Int -> Maybe Int
unBase64LengthUnpadded len = case r of
0 -> Just (3*q)
2 -> Just (3*q + 1)
3 -> Just (3*q + 2)
_ -> Nothing
where (q, r) = len `divMod` 4
fromBase64OpenBSD :: Ptr Word8 -> Ptr Word8 -> Int -> IO (Maybe Int)
fromBase64OpenBSD dst src len = fromBase64Unpadded rsetOpenBSD dst src len
fromBase64URLUnpadded :: Ptr Word8 -> Ptr Word8 -> Int -> IO (Maybe Int)
fromBase64URLUnpadded dst src len = fromBase64Unpadded rsetURL dst src len
fromBase64Unpadded :: (Word8 -> Word8) -> Ptr Word8 -> Ptr Word8 -> Int -> IO (Maybe Int)
fromBase64Unpadded rset dst src len = loop 0 0
where loop di i
| i == len = return Nothing
| i == len - 1 = return Nothing -- Shouldn't happen if len is valid
| i == len - 2 = do
a <- peekByteOff src i
b <- peekByteOff src (i+1)
case decode2 a b of
Left ofs -> return $ Just (i + ofs)
Right x -> do
pokeByteOff dst di x
return Nothing
| i == len - 3 = do
a <- peekByteOff src i
b <- peekByteOff src (i+1)
c <- peekByteOff src (i+2)
case decode3 a b c of
Left ofs -> return $ Just (i + ofs)
Right (x,y) -> do
pokeByteOff dst di x
pokeByteOff dst (di+1) y
return Nothing
| otherwise = do
a <- peekByteOff src i
b <- peekByteOff src (i+1)
c <- peekByteOff src (i+2)
d <- peekByteOff src (i+3)
case decode4 a b c d of
Left ofs -> return $ Just (i + ofs)
Right (x,y,z) -> do
pokeByteOff dst di x
pokeByteOff dst (di+1) y
pokeByteOff dst (di+2) z
loop (di + 3) (i + 4)
decode2 :: Word8 -> Word8 -> Either Int Word8
decode2 a b =
case (rset a, rset b) of
(0xff, _ ) -> Left 0
(_ , 0xff) -> Left 1
(ra , rb ) -> Right ((ra `unsafeShiftL` 2) .|. (rb `unsafeShiftR` 4))
decode3 :: Word8 -> Word8 -> Word8 -> Either Int (Word8, Word8)
decode3 a b c =
case (rset a, rset b, rset c) of
(0xff, _ , _ ) -> Left 0
(_ , 0xff, _ ) -> Left 1
(_ , _ , 0xff) -> Left 2
(ra , rb , rc ) ->
let x = (ra `unsafeShiftL` 2) .|. (rb `unsafeShiftR` 4)
y = (rb `unsafeShiftL` 4) .|. (rc `unsafeShiftR` 2)
in Right (x,y)
decode4 :: Word8 -> Word8 -> Word8 -> Word8 -> Either Int (Word8, Word8, Word8)
decode4 a b c d =
case (rset a, rset b, rset c, rset d) of
(0xff, _ , _ , _ ) -> Left 0
(_ , 0xff, _ , _ ) -> Left 1
(_ , _ , 0xff, _ ) -> Left 2
(_ , _ , _ , 0xff) -> Left 3
(ra , rb , rc , rd ) ->
let x = (ra `unsafeShiftL` 2) .|. (rb `unsafeShiftR` 4)
y = (rb `unsafeShiftL` 4) .|. (rc `unsafeShiftR` 2)
z = (rc `unsafeShiftL` 6) .|. rd
in Right (x,y,z)
rsetURL :: Word8 -> Word8
rsetURL !w = W8# (indexWord8OffAddr# rsetTable (word2Int# widx))
where !(W# widx) = integralUpsize w
!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\x3e\xff\xff\
\\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\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\x3f\
\\xff\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\
\\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\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"#
rsetOpenBSD :: Word8 -> Word8
rsetOpenBSD !w = W8# (indexWord8OffAddr# rsetTable (word2Int# widx))
where !(W# widx) = integralUpsize w
!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\x00\x01\
\\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\xff\xff\xff\xff\xff\xff\
\\xff\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\x0f\x10\
\\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\xff\xff\xff\xff\xff\
\\xff\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\
\\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\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"#
-- | convert from base64 in @src@ to binary in @dst@, using the number of bytes specified
--
-- the user should use unBase64Length to compute the correct length, or check that
-- the length specification is proper. no check is done here.
fromBase64 :: Ptr Word8 -> Ptr Word8 -> Int -> IO (Maybe Int)
fromBase64 dst src len
| len == 0 = return Nothing
| otherwise = loop 0 0
where loop di i
| i == (len-4) = do
a <- peekByteOff src i
b <- peekByteOff src (i+1)
c <- peekByteOff src (i+2)
d <- peekByteOff src (i+3)
let (nbBytes, c',d') =
case (c,d) of
(0x3d, 0x3d) -> (2, 0x30, 0x30)
(0x3d, _ ) -> (0, c, d) -- invalid: automatically 'c' will make it error out
(_ , 0x3d) -> (1, c, 0x30)
(_ , _ ) -> (0 :: Int, c, d)
case decode4 a b c' d' of
Left ofs -> return $ Just (i + ofs)
Right (x,y,z) -> do
pokeByteOff dst di x
when (nbBytes < 2) $ pokeByteOff dst (di+1) y
when (nbBytes < 1) $ pokeByteOff dst (di+2) z
return Nothing
| otherwise = do
a <- peekByteOff src i
b <- peekByteOff src (i+1)
c <- peekByteOff src (i+2)
d <- peekByteOff src (i+3)
case decode4 a b c d of
Left ofs -> return $ Just (i + ofs)
Right (x,y,z) -> do
pokeByteOff dst di x
pokeByteOff dst (di+1) y
pokeByteOff dst (di+2) z
loop (di + 3) (i + 4)
decode4 :: Word8 -> Word8 -> Word8 -> Word8 -> Either Int (Word8, Word8, Word8)
decode4 a b c d =
case (rset a, rset b, rset c, rset d) of
(0xff, _ , _ , _ ) -> Left 0
(_ , 0xff, _ , _ ) -> Left 1
(_ , _ , 0xff, _ ) -> Left 2
(_ , _ , _ , 0xff) -> Left 3
(ra , rb , rc , rd ) ->
let x = (ra `unsafeShiftL` 2) .|. (rb `unsafeShiftR` 4)
y = (rb `unsafeShiftL` 4) .|. (rc `unsafeShiftR` 2)
z = (rc `unsafeShiftL` 6) .|. rd
in Right (x,y,z)
rset :: Word8 -> Word8
rset !w = W8# (indexWord8OffAddr# rsetTable (word2Int# widx))
where !(W# widx) = integralUpsize w
!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\x3e\xff\xff\xff\x3f\
\\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\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\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\
\\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\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"#

121
bundled/Data/Memory/Endian.hs Normal file
View file

@ -0,0 +1,121 @@
-- |
-- Module : Data.Memory.Endian
-- License : BSD-style
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : stable
-- Portability : good
--
{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Data.Memory.Endian
( Endianness(..)
, getSystemEndianness
, BE(..), LE(..)
, fromBE, toBE
, fromLE, toLE
, ByteSwap
) where
import Data.Word (Word16, Word32, Word64)
import Foreign.Storable
#if !defined(ARCH_IS_LITTLE_ENDIAN) && !defined(ARCH_IS_BIG_ENDIAN)
import Data.Word (Word8)
import Data.Memory.Internal.Compat (unsafeDoIO)
import Foreign.Marshal.Alloc
import Foreign.Ptr
#endif
import Data.Memory.Internal.Compat (byteSwap64, byteSwap32, byteSwap16)
-- | represent the CPU endianness
--
-- Big endian system stores bytes with the MSB as the first byte.
-- Little endian system stores bytes with the LSB as the first byte.
--
-- middle endian is purposely avoided.
data Endianness = LittleEndian
| BigEndian
deriving (Show,Eq)
-- | Return the system endianness
getSystemEndianness :: Endianness
#ifdef ARCH_IS_LITTLE_ENDIAN
getSystemEndianness = LittleEndian
#elif ARCH_IS_BIG_ENDIAN
getSystemEndianness = BigEndian
#else
getSystemEndianness
| isLittleEndian = LittleEndian
| isBigEndian = BigEndian
| otherwise = error "cannot determine endianness"
where
isLittleEndian = endianCheck == 2
isBigEndian = endianCheck == 1
endianCheck = unsafeDoIO $ alloca $ \p -> do
poke p (0x01000002 :: Word32)
peek (castPtr p :: Ptr Word8)
#endif
-- | Little Endian value
newtype LE a = LE { unLE :: a }
deriving (Show,Eq,Storable)
-- | Big Endian value
newtype BE a = BE { unBE :: a }
deriving (Show,Eq,Storable)
-- | Convert a value in cpu endianess to big endian
toBE :: ByteSwap a => a -> BE a
#ifdef ARCH_IS_LITTLE_ENDIAN
toBE = BE . byteSwap
#elif ARCH_IS_BIG_ENDIAN
toBE = BE
#else
toBE = BE . (if getSystemEndianness == LittleEndian then byteSwap else id)
#endif
{-# INLINE toBE #-}
-- | Convert from a big endian value to the cpu endianness
fromBE :: ByteSwap a => BE a -> a
#ifdef ARCH_IS_LITTLE_ENDIAN
fromBE (BE a) = byteSwap a
#elif ARCH_IS_BIG_ENDIAN
fromBE (BE a) = a
#else
fromBE (BE a) = if getSystemEndianness == LittleEndian then byteSwap a else a
#endif
{-# INLINE fromBE #-}
-- | Convert a value in cpu endianess to little endian
toLE :: ByteSwap a => a -> LE a
#ifdef ARCH_IS_LITTLE_ENDIAN
toLE = LE
#elif ARCH_IS_BIG_ENDIAN
toLE = LE . byteSwap
#else
toLE = LE . (if getSystemEndianness == LittleEndian then id else byteSwap)
#endif
{-# INLINE toLE #-}
-- | Convert from a little endian value to the cpu endianness
fromLE :: ByteSwap a => LE a -> a
#ifdef ARCH_IS_LITTLE_ENDIAN
fromLE (LE a) = a
#elif ARCH_IS_BIG_ENDIAN
fromLE (LE a) = byteSwap a
#else
fromLE (LE a) = if getSystemEndianness == LittleEndian then a else byteSwap a
#endif
{-# INLINE fromLE #-}
-- | Class of types that can be byte-swapped.
--
-- e.g. Word16, Word32, Word64
class Storable a => ByteSwap a where
byteSwap :: a -> a
instance ByteSwap Word16 where
byteSwap = byteSwap16
instance ByteSwap Word32 where
byteSwap = byteSwap32
instance ByteSwap Word64 where
byteSwap = byteSwap64

17
bundled/Data/Memory/ExtendedWords.hs Normal file
View file

@ -0,0 +1,17 @@
-- |
-- Module : Data.Memory.ExtendedWords
-- License : BSD-style
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : unknown
--
-- Extra Word size
--
module Data.Memory.ExtendedWords
( Word128(..)
) where
import Data.Word (Word64)
-- | A simple Extended Word128 composed of 2 Word64
data Word128 = Word128 !Word64 !Word64 deriving (Show, Eq)

106
bundled/Data/Memory/Hash/FNV.hs Normal file
View file

@ -0,0 +1,106 @@
-- |
-- Module : Data.Memory.Hash.FNV
-- License : BSD-style
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : good
--
-- Fowler Noll Vo Hash (1 and 1a / 32 / 64 bits versions)
-- <http://en.wikipedia.org/wiki/Fowler%E2%80%93Noll%E2%80%93Vo_hash_function>
--
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE BangPatterns #-}
module Data.Memory.Hash.FNV
(
-- * types
FnvHash32(..)
, FnvHash64(..)
-- * methods
, fnv1
, fnv1a
, fnv1_64
, fnv1a_64
) where
import Basement.Bits
import Basement.IntegralConv
import Data.Memory.Internal.Compat ()
import Data.Memory.Internal.Imports
import GHC.Word
import GHC.Prim hiding (Word64#, Int64#)
import GHC.Types
import GHC.Ptr
-- | FNV1(a) hash (32 bit variants)
newtype FnvHash32 = FnvHash32 Word32
deriving (Show,Eq,Ord,NFData)
-- | FNV1(a) hash (64 bit variants)
newtype FnvHash64 = FnvHash64 Word64
deriving (Show,Eq,Ord,NFData)
fnv1_32_Mix8 :: Word8 -> FnvHash32 -> FnvHash32
fnv1_32_Mix8 !w (FnvHash32 acc) = FnvHash32 ((0x01000193 * acc) .^. integralUpsize w)
{-# INLINE fnv1_32_Mix8 #-}
fnv1a_32_Mix8 :: Word8 -> FnvHash32 -> FnvHash32
fnv1a_32_Mix8 !w (FnvHash32 acc) = FnvHash32 (0x01000193 * (acc .^. integralUpsize w))
{-# INLINE fnv1a_32_Mix8 #-}
fnv1_64_Mix8 :: Word8 -> FnvHash64 -> FnvHash64
fnv1_64_Mix8 !w (FnvHash64 acc) = FnvHash64 ((0x100000001b3 * acc) .^. integralUpsize w)
{-# INLINE fnv1_64_Mix8 #-}
fnv1a_64_Mix8 :: Word8 -> FnvHash64 -> FnvHash64
fnv1a_64_Mix8 !w (FnvHash64 acc) = FnvHash64 (0x100000001b3 * (acc .^. integralUpsize w))
{-# INLINE fnv1a_64_Mix8 #-}
-- | compute FNV1 (32 bit variant) of a raw piece of memory
fnv1 :: Ptr Word8 -> Int -> IO FnvHash32
fnv1 (Ptr addr) n = loop (FnvHash32 0x811c9dc5) 0
where
loop :: FnvHash32 -> Int -> IO FnvHash32
loop !acc !i
| i == n = pure $ acc
| otherwise = do
v <- read8 addr i
loop (fnv1_32_Mix8 v acc) (i + 1)
-- | compute FNV1a (32 bit variant) of a raw piece of memory
fnv1a :: Ptr Word8 -> Int -> IO FnvHash32
fnv1a (Ptr addr) n = loop (FnvHash32 0x811c9dc5) 0
where
loop :: FnvHash32 -> Int -> IO FnvHash32
loop !acc !i
| i == n = pure $ acc
| otherwise = do
v <- read8 addr i
loop (fnv1a_32_Mix8 v acc) (i + 1)
-- | compute FNV1 (64 bit variant) of a raw piece of memory
fnv1_64 :: Ptr Word8 -> Int -> IO FnvHash64
fnv1_64 (Ptr addr) n = loop (FnvHash64 0xcbf29ce484222325) 0
where
loop :: FnvHash64 -> Int -> IO FnvHash64
loop !acc !i
| i == n = pure $ acc
| otherwise = do
v <- read8 addr i
loop (fnv1_64_Mix8 v acc) (i + 1)
-- | compute FNV1a (64 bit variant) of a raw piece of memory
fnv1a_64 :: Ptr Word8 -> Int -> IO FnvHash64
fnv1a_64 (Ptr addr) n = loop (FnvHash64 0xcbf29ce484222325) 0
where
loop :: FnvHash64 -> Int -> IO FnvHash64
loop !acc !i
| i == n = pure $ acc
| otherwise = do
v <- read8 addr i
loop (fnv1a_64_Mix8 v acc) (i + 1)
read8 :: Addr# -> Int -> IO Word8
read8 addr (I# i) = IO $ \s -> case readWord8OffAddr# addr i s of
(# s2, e #) -> (# s2, W8# e #)

163
bundled/Data/Memory/Hash/SipHash.hs Normal file
View file

@ -0,0 +1,163 @@
-- |
-- Module : Data.Memory.Hash.SipHash
-- License : BSD-style
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : good
--
-- provide the SipHash algorithm.
-- reference: <http://131002.net/siphash/siphash.pdf>
--
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Data.Memory.Hash.SipHash
( SipKey(..)
, SipHash(..)
, hash
, hashWith
) where
import Data.Memory.Endian
import Data.Memory.Internal.Compat
import Data.Word
import Data.Bits
import Data.Typeable (Typeable)
import Control.Monad
import Foreign.Ptr
import Foreign.Storable
-- | SigHash Key
data SipKey = SipKey {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
-- | Siphash tag value
newtype SipHash = SipHash Word64
deriving (Show,Eq,Ord,Typeable)
data InternalState = InternalState {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
-- | produce a siphash with a key and a memory pointer + length.
hash :: SipKey -> Ptr Word8 -> Int -> IO SipHash
hash = hashWith 2 4
-- | same as 'hash', except also specifies the number of sipround iterations for compression and digest.
hashWith :: Int -- ^ siphash C
-> Int -- ^ siphash D
-> SipKey -- ^ key for the hash
-> Ptr Word8 -- ^ memory pointer
-> Int -- ^ length of the data
-> IO SipHash
hashWith c d key startPtr totalLen = runHash (initSip key) startPtr totalLen
where runHash !st !ptr l
| l > 7 = peek (castPtr ptr) >>= \v -> runHash (process st (fromLE v)) (ptr `plusPtr` 8) (l-8)
| otherwise = do
let !lengthBlock = (fromIntegral totalLen `mod` 256) `unsafeShiftL` 56
(finish . process st) `fmap` case l of
0 -> do return lengthBlock
1 -> do v0 <- peekByteOff ptr 0
return (lengthBlock .|. to64 v0)
2 -> do (v0,v1) <- liftM2 (,) (peekByteOff ptr 0) (peekByteOff ptr 1)
return (lengthBlock
.|. (to64 v1 `unsafeShiftL` 8)
.|. to64 v0)
3 -> do (v0,v1,v2) <- liftM3 (,,) (peekByteOff ptr 0) (peekByteOff ptr 1) (peekByteOff ptr 2)
return ( lengthBlock
.|. (to64 v2 `unsafeShiftL` 16)
.|. (to64 v1 `unsafeShiftL` 8)
.|. to64 v0)
4 -> do (v0,v1,v2,v3) <- liftM4 (,,,) (peekByteOff ptr 0) (peekByteOff ptr 1) (peekByteOff ptr 2)
(peekByteOff ptr 3)
return ( lengthBlock
.|. (to64 v3 `unsafeShiftL` 24)
.|. (to64 v2 `unsafeShiftL` 16)
.|. (to64 v1 `unsafeShiftL` 8)
.|. to64 v0)
5 -> do (v0,v1,v2,v3,v4) <- liftM5 (,,,,) (peekByteOff ptr 0) (peekByteOff ptr 1) (peekByteOff ptr 2)
(peekByteOff ptr 3) (peekByteOff ptr 4)
return ( lengthBlock
.|. (to64 v4 `unsafeShiftL` 32)
.|. (to64 v3 `unsafeShiftL` 24)
.|. (to64 v2 `unsafeShiftL` 16)
.|. (to64 v1 `unsafeShiftL` 8)
.|. to64 v0)
6 -> do v0 <- peekByteOff ptr 0
v1 <- peekByteOff ptr 1
v2 <- peekByteOff ptr 2
v3 <- peekByteOff ptr 3
v4 <- peekByteOff ptr 4
v5 <- peekByteOff ptr 5
return ( lengthBlock
.|. (to64 v5 `unsafeShiftL` 40)
.|. (to64 v4 `unsafeShiftL` 32)
.|. (to64 v3 `unsafeShiftL` 24)
.|. (to64 v2 `unsafeShiftL` 16)
.|. (to64 v1 `unsafeShiftL` 8)
.|. to64 v0)
7 -> do v0 <- peekByteOff ptr 0
v1 <- peekByteOff ptr 1
v2 <- peekByteOff ptr 2
v3 <- peekByteOff ptr 3
v4 <- peekByteOff ptr 4
v5 <- peekByteOff ptr 5
v6 <- peekByteOff ptr 6
return ( lengthBlock
.|. (to64 v6 `unsafeShiftL` 48)
.|. (to64 v5 `unsafeShiftL` 40)
.|. (to64 v4 `unsafeShiftL` 32)
.|. (to64 v3 `unsafeShiftL` 24)
.|. (to64 v2 `unsafeShiftL` 16)
.|. (to64 v1 `unsafeShiftL` 8)
.|. to64 v0)
_ -> error "siphash: internal error: cannot happens"
{-# INLINE to64 #-}
to64 :: Word8 -> Word64
to64 = fromIntegral
{-# INLINE process #-}
process istate m = newState
where newState = postInject $! runRoundsCompression $! preInject istate
preInject (InternalState v0 v1 v2 v3) = InternalState v0 v1 v2 (v3 `xor` m)
postInject (InternalState v0 v1 v2 v3) = InternalState (v0 `xor` m) v1 v2 v3
{-# INLINE finish #-}
finish istate = getDigest $! runRoundsDigest $! preInject istate
where getDigest (InternalState v0 v1 v2 v3) = SipHash (v0 `xor` v1 `xor` v2 `xor` v3)
preInject (InternalState v0 v1 v2 v3) = InternalState v0 v1 (v2 `xor` 0xff) v3
{-# INLINE doRound #-}
doRound (InternalState v0 v1 v2 v3) =
let !v0' = v0 + v1
!v2' = v2 + v3
!v1' = v1 `rotateL` 13
!v3' = v3 `rotateL` 16
!v1'' = v1' `xor` v0'
!v3'' = v3' `xor` v2'
!v0'' = v0' `rotateL` 32
!v2'' = v2' + v1''
!v0''' = v0'' + v3''
!v1''' = v1'' `rotateL` 17
!v3''' = v3'' `rotateL` 21
!v1'''' = v1''' `xor` v2''
!v3'''' = v3''' `xor` v0'''
!v2''' = v2'' `rotateL` 32
in InternalState v0''' v1'''' v2''' v3''''
{-# INLINE runRoundsCompression #-}
runRoundsCompression st
| c == 2 = doRound $! doRound st
| otherwise = loopRounds c st
{-# INLINE runRoundsDigest #-}
runRoundsDigest st
| d == 4 = doRound $! doRound $! doRound $! doRound st
| otherwise = loopRounds d st
{-# INLINE loopRounds #-}
loopRounds 1 !v = doRound v
loopRounds n !v = loopRounds (n-1) (doRound v)
{-# INLINE initSip #-}
initSip (SipKey k0 k1) = InternalState (k0 `xor` 0x736f6d6570736575)
(k1 `xor` 0x646f72616e646f6d)
(k0 `xor` 0x6c7967656e657261)
(k1 `xor` 0x7465646279746573)

76
bundled/Data/Memory/Internal/Compat.hs Normal file
View file

@ -0,0 +1,76 @@
-- |
-- Module : Data.Memory.Internal.Compat
-- License : BSD-style
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : stable
-- Portability : Good
--
-- This module try to keep all the difference between versions of base
-- or other needed packages, so that modules don't need to use CPP
--
{-# LANGUAGE CPP #-}
module Data.Memory.Internal.Compat
( unsafeDoIO
, popCount
, unsafeShiftL
, unsafeShiftR
, byteSwap64
, byteSwap32
, byteSwap16
) where
import System.IO.Unsafe
import Data.Word
import Data.Bits
-- | perform io for hashes that do allocation and ffi.
-- unsafeDupablePerformIO is used when possible as the
-- computation is pure and the output is directly linked
-- to the input. we also do not modify anything after it has
-- been returned to the user.
unsafeDoIO :: IO a -> a
#if __GLASGOW_HASKELL__ > 704
unsafeDoIO = unsafeDupablePerformIO
#else
unsafeDoIO = unsafePerformIO
#endif
#if !(MIN_VERSION_base(4,5,0))
popCount :: Word64 -> Int
popCount n = loop 0 n
where loop c 0 = c
loop c i = loop (c + if testBit c 0 then 1 else 0) (i `shiftR` 1)
#endif
#if !(MIN_VERSION_base(4,7,0))
byteSwap64 :: Word64 -> Word64
byteSwap64 w =
(w `shiftR` 56) .|. (w `shiftL` 56)
.|. ((w `shiftR` 40) .&. 0xff00) .|. ((w .&. 0xff00) `shiftL` 40)
.|. ((w `shiftR` 24) .&. 0xff0000) .|. ((w .&. 0xff0000) `shiftL` 24)
.|. ((w `shiftR` 8) .&. 0xff000000) .|. ((w .&. 0xff000000) `shiftL` 8)
#endif
#if !(MIN_VERSION_base(4,7,0))
byteSwap32 :: Word32 -> Word32
byteSwap32 w =
(w `shiftR` 24)
.|. (w `shiftL` 24)
.|. ((w `shiftR` 8) .&. 0xff00)
.|. ((w .&. 0xff00) `shiftL` 8)
#endif
#if !(MIN_VERSION_base(4,7,0))
byteSwap16 :: Word16 -> Word16
byteSwap16 w =
(w `shiftR` 8) .|. (w `shiftL` 8)
#endif
#if !(MIN_VERSION_base(4,5,0))
unsafeShiftL :: Bits a => a -> Int -> a
unsafeShiftL = shiftL
unsafeShiftR :: Bits a => a -> Int -> a
unsafeShiftR = shiftR
#endif

70
bundled/Data/Memory/Internal/CompatPrim.hs Normal file
View file

@ -0,0 +1,70 @@
-- |
-- 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 #-}
module Data.Memory.Internal.CompatPrim
( be32Prim
, le32Prim
, byteswap32Prim
, booleanPrim
) where
import GHC.Prim
-- | byteswap Word# to or from Big Endian
--
-- on a big endian machine, this function is a nop.
be32Prim :: Word# -> Word#
#ifdef ARCH_IS_LITTLE_ENDIAN
be32Prim = byteswap32Prim
#else
be32Prim w = w
#endif
-- | byteswap Word# to or from Little Endian
--
-- on a little endian machine, this function is a nop.
le32Prim :: Word# -> Word#
#ifdef ARCH_IS_LITTLE_ENDIAN
le32Prim w = w
#else
le32Prim = byteswap32Prim
#endif
-- | Simple compatibility for byteswap the lower 32 bits of a Word#
-- at the primitive level
byteswap32Prim :: Word# -> Word#
#if __GLASGOW_HASKELL__ >= 708
byteswap32Prim w = byteSwap32# w
#else
byteswap32Prim w =
let !a = uncheckedShiftL# w 24#
!b = and# (uncheckedShiftL# w 8#) 0x00ff0000##
!c = and# (uncheckedShiftRL# w 8#) 0x0000ff00##
!d = and# (uncheckedShiftRL# w 24#) 0x000000ff##
in or# a (or# b (or# c d))
#endif
-- | Simple wrapper to handle pre 7.8 and future, where
-- most comparaison functions don't returns a boolean
-- anymore.
#if __GLASGOW_HASKELL__ >= 708
booleanPrim :: Int# -> Bool
booleanPrim v = tagToEnum# v
#else
booleanPrim :: Bool -> Bool
booleanPrim b = b
#endif
{-# INLINE booleanPrim #-}

169
bundled/Data/Memory/Internal/CompatPrim64.hs Normal file
View file

@ -0,0 +1,169 @@
-- |
-- 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#
#if __GLASGOW_HASKELL__ < 904
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#
#endif
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

28
bundled/Data/Memory/Internal/DeepSeq.hs Normal file
View file

@ -0,0 +1,28 @@
-- |
-- Module : Data.Memory.Internal.DeepSeq
-- License : BSD-style
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : unknown
--
-- Simple abstraction module to allow compilation without deepseq
-- by defining our own NFData class if not compiling with deepseq
-- support.
--
{-# LANGUAGE CPP #-}
module Data.Memory.Internal.DeepSeq
( NFData(..)
) where
#ifdef WITH_DEEPSEQ_SUPPORT
import Control.DeepSeq
#else
import Data.Word
class NFData a where rnf :: a -> ()
instance NFData Word8 where rnf w = w `seq` ()
instance NFData Word16 where rnf w = w `seq` ()
instance NFData Word32 where rnf w = w `seq` ()
instance NFData Word64 where rnf w = w `seq` ()
#endif

17
bundled/Data/Memory/Internal/Imports.hs Normal file
View file

@ -0,0 +1,17 @@
-- |
-- Module : Data.Memory.Internal.Imports
-- License : BSD-style
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : unknown
--
{-# LANGUAGE CPP #-}
module Data.Memory.Internal.Imports
( module X
) where
import Data.Word as X
import Control.Applicative as X
import Control.Monad as X (forM, forM_, void, when)
import Control.Arrow as X (first, second)
import Data.Memory.Internal.DeepSeq as X

222
bundled/Data/Memory/MemMap/Posix.hsc Normal file
View file

@ -0,0 +1,222 @@
-----------------------------------------------------------------------------
-- |
-- Module : Data.Memory.MemMap.Posix
-- Copyright : (c) Vincent Hanquez 2014
-- License : BSD-style
--
-- Maintainer : Vincent Hanquez
-- Stability : provisional
-- Portability : non-portable (requires POSIX)
--
-- Functions defined by the POSIX standards for manipulating memory maps
--
-- When a function that calls an underlying POSIX function fails, the errno
-- code is converted to an 'IOError' using 'Foreign.C.Error.errnoToIOError'.
-- For a list of which errno codes may be generated, consult the POSIX
-- documentation for the underlying function.
--
-----------------------------------------------------------------------------
#include <sys/mman.h>
#include <unistd.h>
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE CPP #-}
module Data.Memory.MemMap.Posix
( memoryMap
, memoryUnmap
, memoryAdvise
, memoryLock
, memoryUnlock
, memoryProtect
, memorySync
-- * Flags types
, MemoryMapFlag(..)
, MemoryProtection(..)
, MemoryAdvice(..)
, MemorySyncFlag(..)
-- * system page size
, sysconfPageSize
) where
import System.Posix.Types
import Foreign.Ptr
import Foreign.C.Types
import Foreign.C.Error
import Data.Bits
foreign import ccall unsafe "mmap"
c_mmap :: Ptr a -> CSize -> CInt -> CInt -> CInt -> COff -> IO (Ptr a)
foreign import ccall unsafe "munmap"
c_munmap :: Ptr a -> CSize -> IO CInt
#if defined(POSIX_MADV_NORMAL)
foreign import ccall unsafe "posix_madvise"
c_madvise :: Ptr a -> CSize -> CInt -> IO CInt
#else
foreign import ccall unsafe "madvise"
c_madvise :: Ptr a -> CSize -> CInt -> IO CInt
#endif
foreign import ccall unsafe "msync"
c_msync :: Ptr a -> CSize -> CInt -> IO CInt
foreign import ccall unsafe "mprotect"
c_mprotect :: Ptr a -> CSize -> CInt -> IO CInt
#ifndef __HAIKU__
foreign import ccall unsafe "mlock"
c_mlock :: Ptr a -> CSize -> IO CInt
#else
c_mlock :: Ptr a -> CSize -> IO CInt
c_mlock _ _ = return (-1)
#endif
#ifndef __HAIKU__
foreign import ccall unsafe "munlock"
c_munlock :: Ptr a -> CSize -> IO CInt
#else
c_munlock :: Ptr a -> CSize -> IO CInt
c_munlock _ _ = return (-1)
#endif
foreign import ccall unsafe "sysconf"
c_sysconf :: CInt -> CLong
-- | Mapping flag
data MemoryMapFlag =
MemoryMapShared -- ^ memory changes are shared between process
| MemoryMapPrivate -- ^ memory changes are private to process
deriving (Show,Read,Eq)
-- | Memory protection
data MemoryProtection =
MemoryProtectionNone
| MemoryProtectionRead
| MemoryProtectionWrite
| MemoryProtectionExecute
deriving (Show,Read,Eq)
-- | Advice to put on memory.
--
-- only define the posix one.
data MemoryAdvice =
MemoryAdviceNormal -- ^ no specific advice, the default.
| MemoryAdviceRandom -- ^ Expect page references in random order. No readahead should occur.
| MemoryAdviceSequential -- ^ Expect page references in sequential order. Page should be readahead aggressively.
| MemoryAdviceWillNeed -- ^ Expect access in the near future. Probably a good idea to readahead early
| MemoryAdviceDontNeed -- ^ Do not expect access in the near future.
deriving (Show,Read,Eq)
-- | Memory synchronization flags
data MemorySyncFlag =
MemorySyncAsync -- ^ perform asynchronous write.
| MemorySyncSync -- ^ perform synchronous write.
| MemorySyncInvalidate -- ^ invalidate cache data.
deriving (Show,Read,Eq)
cvalueOfMemoryProts :: [MemoryProtection] -> CInt
cvalueOfMemoryProts = foldl (.|.) 0 . map toProt
where toProt :: MemoryProtection -> CInt
toProt MemoryProtectionNone = (#const PROT_NONE)
toProt MemoryProtectionRead = (#const PROT_READ)
toProt MemoryProtectionWrite = (#const PROT_WRITE)
toProt MemoryProtectionExecute = (#const PROT_EXEC)
cvalueOfMemorySync :: [MemorySyncFlag] -> CInt
cvalueOfMemorySync = foldl (.|.) 0 . map toSync
where toSync MemorySyncAsync = (#const MS_ASYNC)
toSync MemorySyncSync = (#const MS_SYNC)
toSync MemorySyncInvalidate = (#const MS_INVALIDATE)
-- | Map pages of memory.
--
-- If fd is present, this memory will represent the file associated.
-- Otherwise, the memory will be an anonymous mapping.
--
-- use 'mmap'
memoryMap :: Maybe (Ptr a) -- ^ The address to map to if MapFixed is used.
-> CSize -- ^ The length of the mapping
-> [MemoryProtection] -- ^ the memory protection associated with the mapping
-> MemoryMapFlag -- ^
-> Maybe Fd
-> COff
-> IO (Ptr a)
memoryMap initPtr sz prots flag mfd off =
throwErrnoIf (== m1ptr) "mmap" (c_mmap (maybe nullPtr id initPtr) sz cprot cflags fd off)
where m1ptr = nullPtr `plusPtr` (-1)
fd = maybe (-1) (\(Fd v) -> v) mfd
cprot = cvalueOfMemoryProts prots
cflags = maybe cMapAnon (const 0) mfd
.|. maybe 0 (const cMapFixed) initPtr
.|. toMapFlag flag
#ifdef __APPLE__
cMapAnon = (#const MAP_ANON)
#else
cMapAnon = (#const MAP_ANONYMOUS)
#endif
cMapFixed = (#const MAP_FIXED)
toMapFlag MemoryMapShared = (#const MAP_SHARED)
toMapFlag MemoryMapPrivate = (#const MAP_PRIVATE)
-- | Unmap pages of memory
--
-- use 'munmap'
memoryUnmap :: Ptr a -> CSize -> IO ()
memoryUnmap ptr sz = throwErrnoIfMinus1_ "munmap" (c_munmap ptr sz)
-- | give advice to the operating system about use of memory
--
-- call 'madvise'
memoryAdvise :: Ptr a -> CSize -> MemoryAdvice -> IO ()
memoryAdvise ptr sz adv = throwErrnoIfMinus1_ "madvise" (c_madvise ptr sz cadv)
where cadv = toAdvice adv
#if defined(POSIX_MADV_NORMAL)
toAdvice MemoryAdviceNormal = (#const POSIX_MADV_NORMAL)
toAdvice MemoryAdviceRandom = (#const POSIX_MADV_RANDOM)
toAdvice MemoryAdviceSequential = (#const POSIX_MADV_SEQUENTIAL)
toAdvice MemoryAdviceWillNeed = (#const POSIX_MADV_WILLNEED)
toAdvice MemoryAdviceDontNeed = (#const POSIX_MADV_DONTNEED)
#else
toAdvice MemoryAdviceNormal = (#const MADV_NORMAL)
toAdvice MemoryAdviceRandom = (#const MADV_RANDOM)
toAdvice MemoryAdviceSequential = (#const MADV_SEQUENTIAL)
toAdvice MemoryAdviceWillNeed = (#const MADV_WILLNEED)
toAdvice MemoryAdviceDontNeed = (#const MADV_DONTNEED)
#endif
-- | lock a range of process address space
--
-- call 'mlock'
memoryLock :: Ptr a -> CSize -> IO ()
memoryLock ptr sz = throwErrnoIfMinus1_ "mlock" (c_mlock ptr sz)
-- | unlock a range of process address space
--
-- call 'munlock'
memoryUnlock :: Ptr a -> CSize -> IO ()
memoryUnlock ptr sz = throwErrnoIfMinus1_ "munlock" (c_munlock ptr sz)
-- | set protection of memory mapping
--
-- call 'mprotect'
memoryProtect :: Ptr a -> CSize -> [MemoryProtection] -> IO ()
memoryProtect ptr sz prots = throwErrnoIfMinus1_ "mprotect" (c_mprotect ptr sz cprot)
where cprot = cvalueOfMemoryProts prots
-- | memorySync synchronize memory with physical storage.
--
-- On an anonymous mapping this function doesn't have any effect.
-- call 'msync'
memorySync :: Ptr a -> CSize -> [MemorySyncFlag] -> IO ()
memorySync ptr sz flags = throwErrnoIfMinus1_ "msync" (c_msync ptr sz cflags)
where cflags = cvalueOfMemorySync flags
-- | Return the operating system page size.
--
-- call 'sysconf'
sysconfPageSize :: Int
sysconfPageSize = fromIntegral $ c_sysconf (#const _SC_PAGESIZE)

12
bundled/Data/Memory/MemMap/Windows.hs Normal file
View file

@ -0,0 +1,12 @@
-----------------------------------------------------------------------------
-- |
-- Module : Data.Memory.MemMap.Windows
-- Copyright : (c) Vincent Hanquez 2014
-- License : BSD-style
-- Maintainer : Vincent Hanquez
-- Stability : provisional
-- Portability : non-portable (requires Windows)
--
module Data.Memory.MemMap.Windows
(
) where

120
bundled/Data/Memory/PtrMethods.hs Normal file
View file

@ -0,0 +1,120 @@
-- |
-- Module : Data.Memory.PtrMethods
-- License : BSD-style
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : unknown
--
-- methods to manipulate raw memory representation
--
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE ForeignFunctionInterface #-}
module Data.Memory.PtrMethods
( memCreateTemporary
, memXor
, memXorWith
, memCopy
, memSet
, memReverse
, memEqual
, memConstEqual
, memCompare
) where
import Data.Memory.Internal.Imports
import Foreign.Ptr (Ptr, plusPtr)
import Foreign.Storable (peek, poke, peekByteOff)
import Foreign.C.Types
import Foreign.Marshal.Alloc (allocaBytesAligned)
import Data.Bits ((.|.), xor)
-- | Create a new temporary buffer
memCreateTemporary :: Int -> (Ptr Word8 -> IO a) -> IO a
memCreateTemporary size f = allocaBytesAligned size 8 f
-- | xor bytes from source1 and source2 to destination
--
-- d = s1 xor s2
--
-- s1, nor s2 are modified unless d point to s1 or s2
memXor :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> Int -> IO ()
memXor _ _ _ 0 = return ()
memXor d s1 s2 n = do
(xor <$> peek s1 <*> peek s2) >>= poke d
memXor (d `plusPtr` 1) (s1 `plusPtr` 1) (s2 `plusPtr` 1) (n-1)
-- | xor bytes from source with a specific value to destination
--
-- d = replicate (sizeof s) v `xor` s
memXorWith :: Ptr Word8 -> Word8 -> Ptr Word8 -> Int -> IO ()
memXorWith destination !v source bytes
| destination == source = loopInplace source bytes
| otherwise = loop destination source bytes
where
loop !d !s n = when (n > 0) $ do
peek s >>= poke d . xor v
loop (d `plusPtr` 1) (s `plusPtr` 1) (n-1)
loopInplace !s n = when (n > 0) $ do
peek s >>= poke s . xor v
loopInplace (s `plusPtr` 1) (n-1)
-- | Copy a set number of bytes from @src to @dst
memCopy :: Ptr Word8 -> Ptr Word8 -> Int -> IO ()
memCopy dst src n = c_memcpy dst src (fromIntegral n)
{-# INLINE memCopy #-}
-- | Set @n number of bytes to the same value @v
memSet :: Ptr Word8 -> Word8 -> Int -> IO ()
memSet start v n = c_memset start v (fromIntegral n) >>= \_ -> return ()
{-# INLINE memSet #-}
-- | Reverse a set number of bytes from @src@ to @dst@. Memory
-- locations should not overlap.
memReverse :: Ptr Word8 -> Ptr Word8 -> Int -> IO ()
memReverse d s n
| n > 0 = do peekByteOff s (n - 1) >>= poke d
memReverse (d `plusPtr` 1) s (n - 1)
| otherwise = return ()
-- | Check if two piece of memory are equals
memEqual :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool
memEqual p1 p2 n = loop 0
where
loop i
| i == n = return True
| otherwise = do
e <- (==) <$> peekByteOff p1 i <*> (peekByteOff p2 i :: IO Word8)
if e then loop (i+1) else return False
-- | Compare two piece of memory and returns how they compare
memCompare :: Ptr Word8 -> Ptr Word8 -> Int -> IO Ordering
memCompare p1 p2 n = loop 0
where
loop i
| i == n = return EQ
| otherwise = do
e <- compare <$> peekByteOff p1 i <*> (peekByteOff p2 i :: IO Word8)
if e == EQ then loop (i+1) else return e
-- | A constant time equality test for 2 Memory buffers
--
-- compared to normal equality function, this function will go
-- over all the bytes present before yielding a result even when
-- knowing the overall result early in the processing.
memConstEqual :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool
memConstEqual p1 p2 n = loop 0 0
where
loop i !acc
| i == n = return $! acc == 0
| otherwise = do
e <- xor <$> peekByteOff p1 i <*> (peekByteOff p2 i :: IO Word8)
loop (i+1) (acc .|. e)
foreign import ccall unsafe "memset"
c_memset :: Ptr Word8 -> Word8 -> CSize -> IO ()
foreign import ccall unsafe "memcpy"
c_memcpy :: Ptr Word8 -> Ptr Word8 -> CSize -> IO ()