diff --git a/Basement/Alg/Foreign/Prim.hs b/Basement/Alg/Foreign/Prim.hs new file mode 100644 --- /dev/null +++ b/Basement/Alg/Foreign/Prim.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE MagicHash #-} +module Basement.Alg.Foreign.Prim + ( Immutable + , Mutable + , primIndex + , primIndex64 + , primRead + , primWrite + ) where + +import GHC.Types +import GHC.Prim +import GHC.Word +import Basement.Types.OffsetSize +import Basement.PrimType +import Basement.Monad + +type Immutable = Addr# +type Mutable st = Addr# + +primIndex :: PrimType ty => Immutable -> Offset ty -> ty +primIndex = primAddrIndex +{-# INLINE primIndex #-} + +primIndex64 :: Immutable -> Offset Word64 -> Word64 +primIndex64 = primIndex +{-# INLINE primIndex64 #-} + +primRead :: (PrimMonad prim, PrimType ty) => Mutable (PrimState prim) -> Offset ty -> prim ty +primRead = primAddrRead +{-# INLINE primRead #-} + +primWrite :: (PrimMonad prim, PrimType ty) => Mutable (PrimState prim) -> Offset ty -> ty -> prim () +primWrite = primAddrWrite +{-# INLINE primWrite #-} diff --git a/Basement/Alg/Foreign/PrimArray.hs b/Basement/Alg/Foreign/PrimArray.hs new file mode 100644 --- /dev/null +++ b/Basement/Alg/Foreign/PrimArray.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +module Basement.Alg.Foreign.PrimArray + ( findIndexElem + , revFindIndexElem + , findIndexPredicate + , revFindIndexPredicate + , foldl + , foldr + , foldl1 + , all + , any + , filter + , primIndex + , inplaceSortBy + ) where + +import GHC.Types +import GHC.Prim +import Basement.Compat.Base +import Basement.Numerical.Additive +import Basement.Numerical.Multiplicative +import Basement.Types.OffsetSize +import Basement.PrimType +import Basement.Monad + +import Basement.Alg.Foreign.Prim + +findIndexElem :: PrimType ty => ty -> Immutable -> Offset ty -> Offset ty -> Offset ty +findIndexElem ty ba startIndex endIndex = loop startIndex + where + loop !i + | i < endIndex && t /= ty = loop (i+1) + | otherwise = i + where t = primIndex ba i +{-# INLINE findIndexElem #-} + +revFindIndexElem :: PrimType ty => ty -> Immutable -> Offset ty -> Offset ty -> Offset ty +revFindIndexElem ty ba startIndex endIndex + | endIndex > startIndex = loop (endIndex `offsetMinusE` 1) + | otherwise = endIndex + where + loop !i + | t == ty = i + | i > startIndex = loop (i `offsetMinusE` 1) + | otherwise = endIndex + where t = primIndex ba i +{-# INLINE revFindIndexElem #-} + +findIndexPredicate :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Offset ty +findIndexPredicate predicate ba !startIndex !endIndex = loop startIndex + where + loop !i + | i < endIndex && not found = loop (i+1) + | otherwise = i + where found = predicate (primIndex ba i) +{-# INLINE findIndexPredicate #-} + +revFindIndexPredicate :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Offset ty +revFindIndexPredicate predicate ba startIndex endIndex + | endIndex > startIndex = loop (endIndex `offsetMinusE` 1) + | otherwise = endIndex + where + loop !i + | found = i + | i > startIndex = loop (i `offsetMinusE` 1) + | otherwise = endIndex + where found = predicate (primIndex ba i) +{-# INLINE revFindIndexPredicate #-} + +foldl :: PrimType ty => (a -> ty -> a) -> a -> Immutable -> Offset ty -> Offset ty -> a +foldl f !initialAcc ba !startIndex !endIndex = loop startIndex initialAcc + where + loop !i !acc + | i == endIndex = acc + | otherwise = loop (i+1) (f acc (primIndex ba i)) +{-# INLINE foldl #-} + +foldr :: PrimType ty => (ty -> a -> a) -> a -> Immutable -> Offset ty -> Offset ty -> a +foldr f !initialAcc ba startIndex endIndex = loop startIndex + where + loop !i + | i == endIndex = initialAcc + | otherwise = primIndex ba i `f` loop (i+1) +{-# INLINE foldr #-} + +foldl1 :: PrimType ty => (ty -> ty -> ty) -> Immutable -> Offset ty -> Offset ty -> ty +foldl1 f ba startIndex endIndex = loop (startIndex+1) (primIndex ba startIndex) + where + loop !i !acc + | i == endIndex = acc + | otherwise = loop (i+1) (f acc (primIndex ba i)) +{-# INLINE foldl1 #-} + +filter :: (PrimMonad prim, PrimType ty) + => (ty -> Bool) -> MutableByteArray# (PrimState prim) -> Immutable -> Offset ty -> Offset ty -> prim (CountOf ty) +filter predicate dst src start end = loop azero start + where + loop !d !s + | s == end = pure (offsetAsSize d) + | predicate v = primMbaWrite dst d v >> loop (d+Offset 1) (s+Offset 1) + | otherwise = loop d (s+Offset 1) + where + v = primIndex src s + +all :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Bool +all predicate ba start end = loop start + where + loop !i + | i == end = True + | predicate (primIndex ba i) = loop (i+1) + | otherwise = False +{-# INLINE all #-} + +any :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Bool +any predicate ba start end = loop start + where + loop !i + | i == end = False + | predicate (primIndex ba i) = True + | otherwise = loop (i+1) +{-# INLINE any #-} + +inplaceSortBy :: (PrimType ty, PrimMonad prim) + => (ty -> ty -> Ordering) + -> Mutable (PrimState prim) + -> Offset ty + -> Offset ty + -> prim () +inplaceSortBy ford ma start end = qsort start (end `offsetSub` 1) + where + qsort lo hi + | lo >= hi = pure () + | otherwise = do + p <- partition lo hi + qsort lo (pred p) + qsort (p+1) hi + pivotStrategy (Offset low) hi@(Offset high) = do + let mid = Offset $ (low + high) `div` 2 + pivot <- primRead ma mid + primRead ma hi >>= primWrite ma mid + primWrite ma hi pivot -- move pivot @ pivotpos := hi + pure pivot + partition lo hi = do + pivot <- pivotStrategy lo hi + -- RETURN: index of pivot with [=pivot] + -- INVARIANT: i & j are valid array indices; pivotpos==hi + let go i j = do + -- INVARIANT: k <= pivotpos + let fw k = do ak <- primRead ma k + if ford ak pivot == LT + then fw (k+1) + else pure (k, ak) + (i, ai) <- fw i -- POST: ai >= pivot + -- INVARIANT: k >= i + let bw k | k==i = pure (i, ai) + | otherwise = do ak <- primRead ma k + if ford ak pivot /= LT + then bw (pred k) + else pure (k, ak) + (j, aj) <- bw j -- POST: i==j OR (aj=pivot AND (i==j OR aj=p AND aj= pivot + -- complete partitioning by swapping pivot to the center + primWrite ma hi ai + primWrite ma i pivot + pure i + go lo hi +{-# INLINE inplaceSortBy #-} diff --git a/Basement/Alg/Foreign/String.hs b/Basement/Alg/Foreign/String.hs new file mode 100644 --- /dev/null +++ b/Basement/Alg/Foreign/String.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +module Basement.Alg.Foreign.String + ( copyFilter + , validate + , findIndexPredicate + , revFindIndexPredicate + ) where + +import GHC.Prim +import GHC.ST +import Basement.Compat.Base +import Basement.Numerical.Additive +import Basement.Types.OffsetSize + +import qualified Basement.Alg.Native.Prim as PrimNative -- NO SUBST +import qualified Basement.Alg.Native.UTF8 as UTF8Native -- NO SUBST +import qualified Basement.Alg.Foreign.Prim as PrimBackend +import qualified Basement.Alg.Foreign.UTF8 as UTF8Backend +import Basement.UTF8.Helper +import Basement.UTF8.Table +import Basement.UTF8.Types + +copyFilter :: (Char -> Bool) + -> CountOf Word8 + -> MutableByteArray# s + -> PrimBackend.Immutable + -> Offset Word8 + -> ST s (CountOf Word8) +copyFilter predicate !sz dst src start = loop (Offset 0) start + where + !end = start `offsetPlusE` sz + loop !d !s + | s == end = pure (offsetAsSize d) + | otherwise = + let !h = PrimBackend.primIndex src s + in case headerIsAscii h of + True | predicate (toChar1 h) -> PrimNative.primWrite dst d h >> loop (d + Offset 1) (s + Offset 1) + | otherwise -> loop d (s + Offset 1) + False -> + case UTF8Backend.next src s of + Step c s' | predicate c -> UTF8Native.write dst d c >>= \d' -> loop d' s' + | otherwise -> loop d s' + +validate :: Offset Word8 + -> PrimBackend.Immutable + -> Offset Word8 + -> (Offset Word8, Maybe ValidationFailure) +validate end ba ofsStart = loop ofsStart + where + loop !ofs + | ofs > end = error ("validate: internal error: went pass offset : ofs=" <> show ofs <> " end=" <> show end) + | ofs == end = (end, Nothing) + | otherwise = + let !h = PrimBackend.primIndex ba ofs in + case headerIsAscii h of + True -> loop (ofs + Offset 1) + False -> + case one (CountOf $ getNbBytes h) ofs of + (nextOfs, Nothing) -> loop nextOfs + (pos, Just failure) -> (pos, Just failure) + + one (CountOf 0xff) pos = (pos, Just InvalidHeader) + one nbConts pos + | ((pos+Offset 1) `offsetPlusE` nbConts) > end = (pos, Just MissingByte) + | otherwise = + case nbConts of + CountOf 1 -> + let c1 = PrimBackend.primIndex ba (pos + Offset 1) + in if isContinuation c1 + then (pos + Offset 2, Nothing) + else (pos, Just InvalidContinuation) + CountOf 2 -> + let c1 = PrimBackend.primIndex ba (pos + Offset 1) + c2 = PrimBackend.primIndex ba (pos + Offset 2) + in if isContinuation c1 && isContinuation c2 + then (pos + Offset 3, Nothing) + else (pos, Just InvalidContinuation) + CountOf 3 -> + let c1 = PrimBackend.primIndex ba (pos + Offset 1) + c2 = PrimBackend.primIndex ba (pos + Offset 2) + c3 = PrimBackend.primIndex ba (pos + Offset 3) + in if isContinuation c1 && isContinuation c2 && isContinuation c3 + then (pos + Offset 4, Nothing) + else (pos, Just InvalidContinuation) + CountOf _ -> error "internal error" + +findIndexPredicate :: (Char -> Bool) + -> PrimBackend.Immutable + -> Offset Word8 + -> Offset Word8 + -> Offset Word8 +findIndexPredicate predicate ba !startIndex !endIndex = loop startIndex + where + loop !i + | i < endIndex && not (predicate c) = loop (i') + | otherwise = i + where + Step c i' = UTF8Backend.next ba i +{-# INLINE findIndexPredicate #-} + +revFindIndexPredicate :: (Char -> Bool) + -> PrimBackend.Immutable + -> Offset Word8 + -> Offset Word8 + -> Offset Word8 +revFindIndexPredicate predicate ba startIndex endIndex + | endIndex > startIndex = loop endIndex + | otherwise = endIndex + where + loop !i + | predicate c = i' + | i' > startIndex = loop i' + | otherwise = endIndex + where + StepBack c i' = UTF8Backend.prev ba i +{-# INLINE revFindIndexPredicate #-} diff --git a/Basement/Alg/Foreign/UTF8.hs b/Basement/Alg/Foreign/UTF8.hs new file mode 100644 --- /dev/null +++ b/Basement/Alg/Foreign/UTF8.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +module Basement.Alg.Foreign.UTF8 + ( Immutable + , Mutable + -- * functions + , nextAscii + , nextAsciiDigit + , expectAscii + , next + , nextSkip + , prev + , prevSkip + , write + , toList + , all + , any + , foldr + , length + -- temporary + , primIndex64 + , primRead8 + , primWrite8 + ) where + +import GHC.Int +import GHC.Types +import GHC.Word +import GHC.Prim +import Data.Bits +import Basement.Compat.Base hiding (toList) +import Basement.Compat.Primitive +import Basement.Alg.Foreign.Prim +import Data.Proxy +import Basement.Numerical.Additive +import Basement.Numerical.Subtractive +import Basement.Types.OffsetSize +import Basement.Monad +import Basement.PrimType +import Basement.UTF8.Helper +import Basement.UTF8.Table +import Basement.UTF8.Types + +primWrite8 :: PrimMonad prim => Mutable (PrimState prim) -> Offset Word8 -> Word8 -> prim () +primWrite8 = primWrite +{-# INLINE primWrite8 #-} + +primRead8 :: PrimMonad prim => Mutable (PrimState prim) -> Offset Word8 -> prim Word8 +primRead8 = primRead +{-# INLINE primRead8 #-} + +primIndex8 :: Immutable -> Offset Word8 -> Word8 +primIndex8 = primIndex +{-# INLINE primIndex8 #-} + +nextAscii :: Immutable -> Offset Word8 -> StepASCII +nextAscii ba n = StepASCII w + where + !w = primIndex ba n +{-# INLINE nextAscii #-} + +-- | nextAsciiBa specialized to get a digit between 0 and 9 (included) +nextAsciiDigit :: Immutable -> Offset Word8 -> StepDigit +nextAsciiDigit ba n = StepDigit (primIndex8 ba n - 0x30) +{-# INLINE nextAsciiDigit #-} + +expectAscii :: Immutable -> Offset Word8 -> Word8 -> Bool +expectAscii ba n v = primIndex8 ba n == v +{-# INLINE expectAscii #-} + +next :: Immutable -> Offset8 -> Step +next ba n = + case getNbBytes h of + 0 -> Step (toChar1 h) (n + Offset 1) + 1 -> Step (toChar2 h (primIndex8 ba (n + Offset 1))) (n + Offset 2) + 2 -> Step (toChar3 h (primIndex8 ba (n + Offset 1)) + (primIndex8 ba (n + Offset 2))) (n + Offset 3) + 3 -> Step (toChar4 h (primIndex8 ba (n + Offset 1)) + (primIndex8 ba (n + Offset 2)) + (primIndex8 ba (n + Offset 3))) (n + Offset 4) + r -> error ("next: internal error: invalid input: offset=" <> show n <> " table=" <> show r <> " h=" <> show h) + where + !h = primIndex8 ba n +{-# INLINE next #-} + +nextSkip :: Immutable -> Offset Word8 -> Offset Word8 +nextSkip ba n = n + 1 + Offset (getNbBytes (primIndex8 ba n)) +{-# INLINE nextSkip #-} + +-- Given a non null offset, give the previous character and the offset of this character +-- will fail bad if apply at the beginning of string or an empty string. +prev :: Immutable -> Offset Word8 -> StepBack +prev ba offset = + case primIndex8 ba prevOfs1 of + (W8# v1) | isContinuation# v1 -> atLeast2 (maskContinuation# v1) + | otherwise -> StepBack (toChar# v1) prevOfs1 + where + sz1 = CountOf 1 + !prevOfs1 = offset `offsetMinusE` sz1 + prevOfs2 = prevOfs1 `offsetMinusE` sz1 + prevOfs3 = prevOfs2 `offsetMinusE` sz1 + prevOfs4 = prevOfs3 `offsetMinusE` sz1 + atLeast2 !v = + case primIndex8 ba prevOfs2 of + (W8# v2) | isContinuation# v2 -> atLeast3 (or# (uncheckedShiftL# (maskContinuation# v2) 6#) v) + | otherwise -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader2# v2) 6#) v)) prevOfs2 + atLeast3 !v = + case primIndex8 ba prevOfs3 of + (W8# v3) | isContinuation# v3 -> atLeast4 (or# (uncheckedShiftL# (maskContinuation# v3) 12#) v) + | otherwise -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader3# v3) 12#) v)) prevOfs3 + atLeast4 !v = + case primIndex8 ba prevOfs4 of + (W8# v4) -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader4# v4) 18#) v)) prevOfs4 + +prevSkip :: Immutable -> Offset Word8 -> Offset Word8 +prevSkip ba offset = loop (offset `offsetMinusE` sz1) + where + sz1 = CountOf 1 + loop o + | isContinuation (primIndex8 ba o) = loop (o `offsetMinusE` sz1) + | otherwise = o + +write :: PrimMonad prim => Mutable (PrimState prim) -> Offset8 -> Char -> prim Offset8 +write mba !i !c + | bool# (ltWord# x 0x80## ) = encode1 + | bool# (ltWord# x 0x800## ) = encode2 + | bool# (ltWord# x 0x10000##) = encode3 + | otherwise = encode4 + where + !(I# xi) = fromEnum c + !x = int2Word# xi + + encode1 = primWrite8 mba i (W8# x) >> pure (i + Offset 1) + encode2 = do + let x1 = or# (uncheckedShiftRL# x 6#) 0xc0## + x2 = toContinuation x + primWrite8 mba i (W8# x1) + primWrite8 mba (i+1) (W8# x2) + pure (i + Offset 2) + + encode3 = do + let x1 = or# (uncheckedShiftRL# x 12#) 0xe0## + x2 = toContinuation (uncheckedShiftRL# x 6#) + x3 = toContinuation x + primWrite8 mba i (W8# x1) + primWrite8 mba (i+Offset 1) (W8# x2) + primWrite8 mba (i+Offset 2) (W8# x3) + pure (i + Offset 3) + + encode4 = do + let x1 = or# (uncheckedShiftRL# x 18#) 0xf0## + x2 = toContinuation (uncheckedShiftRL# x 12#) + x3 = toContinuation (uncheckedShiftRL# x 6#) + x4 = toContinuation x + primWrite8 mba i (W8# x1) + primWrite8 mba (i+Offset 1) (W8# x2) + primWrite8 mba (i+Offset 2) (W8# x3) + primWrite8 mba (i+Offset 3) (W8# x4) + pure (i + Offset 4) + + toContinuation :: Word# -> Word# + toContinuation w = or# (and# w 0x3f##) 0x80## +{-# INLINE write #-} + +toList :: Immutable -> Offset Word8 -> Offset Word8 -> [Char] +toList ba !start !end = loop start + where + loop !idx + | idx == end = [] + | otherwise = c : loop idx' + where (Step c idx') = next ba idx + +all :: (Char -> Bool) -> Immutable -> Offset Word8 -> Offset Word8 -> Bool +all predicate ba start end = loop start + where + loop !idx + | idx == end = True + | predicate c = loop idx' + | otherwise = False + where (Step c idx') = next ba idx +{-# INLINE all #-} + +any :: (Char -> Bool) -> Immutable -> Offset Word8 -> Offset Word8 -> Bool +any predicate ba start end = loop start + where + loop !idx + | idx == end = False + | predicate c = True + | otherwise = loop idx' + where (Step c idx') = next ba idx +{-# INLINE any #-} + +foldr :: Immutable -> Offset Word8 -> Offset Word8 -> (Char -> a -> a) -> a -> a +foldr dat start end f acc = loop start + where + loop !i + | i == end = acc + | otherwise = + let (Step c i') = next dat i + in c `f` loop i' +{-# INLINE foldr #-} + +length :: Immutable -> Offset Word8 -> Offset Word8 -> CountOf Char +length dat start end + | start == end = 0 + | otherwise = processStart 0 start + where + end64 :: Offset Word64 + end64 = offsetInElements end + + prx64 :: Proxy Word64 + prx64 = Proxy + + mask64_80 :: Word64 + mask64_80 = 0x8080808080808080 + + processStart :: CountOf Char -> Offset Word8 -> CountOf Char + processStart !c !i + | i == end = c + | offsetIsAligned prx64 i = processAligned c (offsetInElements i) + | otherwise = + let h = primIndex8 dat i + cont = (h .&. 0xc0) == 0x80 + c' = if cont then c else c+1 + in processStart c' (i+1) + processAligned :: CountOf Char -> Offset Word64 -> CountOf Char + processAligned !c !i + | i >= end64 = processEnd c (offsetInBytes i) + | otherwise = + let !h = primIndex64 dat i + !h80 = h .&. mask64_80 + in if h80 == 0 + then processAligned (c+8) (i+1) + else let !nbAscii = if h80 == mask64_80 then 0 else CountOf (8 - popCount h80) + !nbHigh = CountOf $ popCount (h .&. (h80 `unsafeShiftR` 1)) + in processAligned (c + nbAscii + nbHigh) (i+1) + processEnd !c !i + | i == end = c + | otherwise = + let h = primIndex8 dat i + cont = (h .&. 0xc0) == 0x80 + c' = if cont then c else c+1 + in processStart c' (i+1) +{-# INLINE length #-} diff --git a/Basement/Alg/Native/Prim.hs b/Basement/Alg/Native/Prim.hs new file mode 100644 --- /dev/null +++ b/Basement/Alg/Native/Prim.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE MagicHash #-} +module Basement.Alg.Native.Prim + ( Immutable + , Mutable + , primIndex + , primIndex64 + , primRead + , primWrite + ) where + +import GHC.Types +import GHC.Prim +import GHC.Word +import Basement.Types.OffsetSize +import Basement.PrimType +import Basement.Monad + +type Immutable = ByteArray# +type Mutable st = MutableByteArray# st + +primIndex :: PrimType ty => Immutable -> Offset ty -> ty +primIndex = primBaIndex +{-# INLINE primIndex #-} + +primIndex64 :: Immutable -> Offset Word64 -> Word64 +primIndex64 = primIndex +{-# INLINE primIndex64 #-} + +primRead :: (PrimMonad prim, PrimType ty) => Mutable (PrimState prim) -> Offset ty -> prim ty +primRead = primMbaRead +{-# INLINE primRead #-} + +primWrite :: (PrimMonad prim, PrimType ty) => Mutable (PrimState prim) -> Offset ty -> ty -> prim () +primWrite = primMbaWrite +{-# INLINE primWrite #-} diff --git a/Basement/Alg/Native/PrimArray.hs b/Basement/Alg/Native/PrimArray.hs new file mode 100644 --- /dev/null +++ b/Basement/Alg/Native/PrimArray.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +module Basement.Alg.Native.PrimArray + ( findIndexElem + , revFindIndexElem + , findIndexPredicate + , revFindIndexPredicate + , foldl + , foldr + , foldl1 + , all + , any + , filter + , primIndex + , inplaceSortBy + ) where + +import GHC.Types +import GHC.Prim +import Basement.Compat.Base +import Basement.Numerical.Additive +import Basement.Numerical.Multiplicative +import Basement.Types.OffsetSize +import Basement.PrimType +import Basement.Monad + +import Basement.Alg.Native.Prim + +findIndexElem :: PrimType ty => ty -> Immutable -> Offset ty -> Offset ty -> Offset ty +findIndexElem ty ba startIndex endIndex = loop startIndex + where + loop !i + | i < endIndex && t /= ty = loop (i+1) + | otherwise = i + where t = primIndex ba i +{-# INLINE findIndexElem #-} + +revFindIndexElem :: PrimType ty => ty -> Immutable -> Offset ty -> Offset ty -> Offset ty +revFindIndexElem ty ba startIndex endIndex + | endIndex > startIndex = loop (endIndex `offsetMinusE` 1) + | otherwise = endIndex + where + loop !i + | t == ty = i + | i > startIndex = loop (i `offsetMinusE` 1) + | otherwise = endIndex + where t = primIndex ba i +{-# INLINE revFindIndexElem #-} + +findIndexPredicate :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Offset ty +findIndexPredicate predicate ba !startIndex !endIndex = loop startIndex + where + loop !i + | i < endIndex && not found = loop (i+1) + | otherwise = i + where found = predicate (primIndex ba i) +{-# INLINE findIndexPredicate #-} + +revFindIndexPredicate :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Offset ty +revFindIndexPredicate predicate ba startIndex endIndex + | endIndex > startIndex = loop (endIndex `offsetMinusE` 1) + | otherwise = endIndex + where + loop !i + | found = i + | i > startIndex = loop (i `offsetMinusE` 1) + | otherwise = endIndex + where found = predicate (primIndex ba i) +{-# INLINE revFindIndexPredicate #-} + +foldl :: PrimType ty => (a -> ty -> a) -> a -> Immutable -> Offset ty -> Offset ty -> a +foldl f !initialAcc ba !startIndex !endIndex = loop startIndex initialAcc + where + loop !i !acc + | i == endIndex = acc + | otherwise = loop (i+1) (f acc (primIndex ba i)) +{-# INLINE foldl #-} + +foldr :: PrimType ty => (ty -> a -> a) -> a -> Immutable -> Offset ty -> Offset ty -> a +foldr f !initialAcc ba startIndex endIndex = loop startIndex + where + loop !i + | i == endIndex = initialAcc + | otherwise = primIndex ba i `f` loop (i+1) +{-# INLINE foldr #-} + +foldl1 :: PrimType ty => (ty -> ty -> ty) -> Immutable -> Offset ty -> Offset ty -> ty +foldl1 f ba startIndex endIndex = loop (startIndex+1) (primIndex ba startIndex) + where + loop !i !acc + | i == endIndex = acc + | otherwise = loop (i+1) (f acc (primIndex ba i)) +{-# INLINE foldl1 #-} + +filter :: (PrimMonad prim, PrimType ty) + => (ty -> Bool) -> MutableByteArray# (PrimState prim) -> Immutable -> Offset ty -> Offset ty -> prim (CountOf ty) +filter predicate dst src start end = loop azero start + where + loop !d !s + | s == end = pure (offsetAsSize d) + | predicate v = primMbaWrite dst d v >> loop (d+Offset 1) (s+Offset 1) + | otherwise = loop d (s+Offset 1) + where + v = primIndex src s + +all :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Bool +all predicate ba start end = loop start + where + loop !i + | i == end = True + | predicate (primIndex ba i) = loop (i+1) + | otherwise = False +{-# INLINE all #-} + +any :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Bool +any predicate ba start end = loop start + where + loop !i + | i == end = False + | predicate (primIndex ba i) = True + | otherwise = loop (i+1) +{-# INLINE any #-} + +inplaceSortBy :: (PrimType ty, PrimMonad prim) + => (ty -> ty -> Ordering) + -> Mutable (PrimState prim) + -> Offset ty + -> Offset ty + -> prim () +inplaceSortBy ford ma start end = qsort start (end `offsetSub` 1) + where + qsort lo hi + | lo >= hi = pure () + | otherwise = do + p <- partition lo hi + qsort lo (pred p) + qsort (p+1) hi + pivotStrategy (Offset low) hi@(Offset high) = do + let mid = Offset $ (low + high) `div` 2 + pivot <- primRead ma mid + primRead ma hi >>= primWrite ma mid + primWrite ma hi pivot -- move pivot @ pivotpos := hi + pure pivot + partition lo hi = do + pivot <- pivotStrategy lo hi + -- RETURN: index of pivot with [=pivot] + -- INVARIANT: i & j are valid array indices; pivotpos==hi + let go i j = do + -- INVARIANT: k <= pivotpos + let fw k = do ak <- primRead ma k + if ford ak pivot == LT + then fw (k+1) + else pure (k, ak) + (i, ai) <- fw i -- POST: ai >= pivot + -- INVARIANT: k >= i + let bw k | k==i = pure (i, ai) + | otherwise = do ak <- primRead ma k + if ford ak pivot /= LT + then bw (pred k) + else pure (k, ak) + (j, aj) <- bw j -- POST: i==j OR (aj=pivot AND (i==j OR aj=p AND aj= pivot + -- complete partitioning by swapping pivot to the center + primWrite ma hi ai + primWrite ma i pivot + pure i + go lo hi +{-# INLINE inplaceSortBy #-} diff --git a/Basement/Alg/Native/String.hs b/Basement/Alg/Native/String.hs new file mode 100644 --- /dev/null +++ b/Basement/Alg/Native/String.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +module Basement.Alg.Native.String + ( copyFilter + , validate + , findIndexPredicate + , revFindIndexPredicate + ) where + +import GHC.Prim +import GHC.ST +import Basement.Compat.Base +import Basement.Numerical.Additive +import Basement.Types.OffsetSize + +import qualified Basement.Alg.Native.Prim as PrimNative -- NO SUBST +import qualified Basement.Alg.Native.UTF8 as UTF8Native -- NO SUBST +import qualified Basement.Alg.Native.Prim as PrimBackend +import qualified Basement.Alg.Native.UTF8 as UTF8Backend +import Basement.UTF8.Helper +import Basement.UTF8.Table +import Basement.UTF8.Types + +copyFilter :: (Char -> Bool) + -> CountOf Word8 + -> MutableByteArray# s + -> PrimBackend.Immutable + -> Offset Word8 + -> ST s (CountOf Word8) +copyFilter predicate !sz dst src start = loop (Offset 0) start + where + !end = start `offsetPlusE` sz + loop !d !s + | s == end = pure (offsetAsSize d) + | otherwise = + let !h = PrimBackend.primIndex src s + in case headerIsAscii h of + True | predicate (toChar1 h) -> PrimNative.primWrite dst d h >> loop (d + Offset 1) (s + Offset 1) + | otherwise -> loop d (s + Offset 1) + False -> + case UTF8Backend.next src s of + Step c s' | predicate c -> UTF8Native.write dst d c >>= \d' -> loop d' s' + | otherwise -> loop d s' + +validate :: Offset Word8 + -> PrimBackend.Immutable + -> Offset Word8 + -> (Offset Word8, Maybe ValidationFailure) +validate end ba ofsStart = loop ofsStart + where + loop !ofs + | ofs > end = error ("validate: internal error: went pass offset : ofs=" <> show ofs <> " end=" <> show end) + | ofs == end = (end, Nothing) + | otherwise = + let !h = PrimBackend.primIndex ba ofs in + case headerIsAscii h of + True -> loop (ofs + Offset 1) + False -> + case one (CountOf $ getNbBytes h) ofs of + (nextOfs, Nothing) -> loop nextOfs + (pos, Just failure) -> (pos, Just failure) + + one (CountOf 0xff) pos = (pos, Just InvalidHeader) + one nbConts pos + | ((pos+Offset 1) `offsetPlusE` nbConts) > end = (pos, Just MissingByte) + | otherwise = + case nbConts of + CountOf 1 -> + let c1 = PrimBackend.primIndex ba (pos + Offset 1) + in if isContinuation c1 + then (pos + Offset 2, Nothing) + else (pos, Just InvalidContinuation) + CountOf 2 -> + let c1 = PrimBackend.primIndex ba (pos + Offset 1) + c2 = PrimBackend.primIndex ba (pos + Offset 2) + in if isContinuation c1 && isContinuation c2 + then (pos + Offset 3, Nothing) + else (pos, Just InvalidContinuation) + CountOf 3 -> + let c1 = PrimBackend.primIndex ba (pos + Offset 1) + c2 = PrimBackend.primIndex ba (pos + Offset 2) + c3 = PrimBackend.primIndex ba (pos + Offset 3) + in if isContinuation c1 && isContinuation c2 && isContinuation c3 + then (pos + Offset 4, Nothing) + else (pos, Just InvalidContinuation) + CountOf _ -> error "internal error" + +findIndexPredicate :: (Char -> Bool) + -> PrimBackend.Immutable + -> Offset Word8 + -> Offset Word8 + -> Offset Word8 +findIndexPredicate predicate ba !startIndex !endIndex = loop startIndex + where + loop !i + | i < endIndex && not (predicate c) = loop (i') + | otherwise = i + where + Step c i' = UTF8Backend.next ba i +{-# INLINE findIndexPredicate #-} + +revFindIndexPredicate :: (Char -> Bool) + -> PrimBackend.Immutable + -> Offset Word8 + -> Offset Word8 + -> Offset Word8 +revFindIndexPredicate predicate ba startIndex endIndex + | endIndex > startIndex = loop endIndex + | otherwise = endIndex + where + loop !i + | predicate c = i' + | i' > startIndex = loop i' + | otherwise = endIndex + where + StepBack c i' = UTF8Backend.prev ba i +{-# INLINE revFindIndexPredicate #-} diff --git a/Basement/Alg/Native/UTF8.hs b/Basement/Alg/Native/UTF8.hs new file mode 100644 --- /dev/null +++ b/Basement/Alg/Native/UTF8.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +module Basement.Alg.Native.UTF8 + ( Immutable + , Mutable + -- * functions + , nextAscii + , nextAsciiDigit + , expectAscii + , next + , nextSkip + , prev + , prevSkip + , write + , toList + , all + , any + , foldr + , length + -- temporary + , primIndex64 + , primRead8 + , primWrite8 + ) where + +import GHC.Int +import GHC.Types +import GHC.Word +import GHC.Prim +import Data.Bits +import Basement.Compat.Base hiding (toList) +import Basement.Compat.Primitive +import Basement.Alg.Native.Prim +import Data.Proxy +import Basement.Numerical.Additive +import Basement.Numerical.Subtractive +import Basement.Types.OffsetSize +import Basement.Monad +import Basement.PrimType +import Basement.UTF8.Helper +import Basement.UTF8.Table +import Basement.UTF8.Types + +primWrite8 :: PrimMonad prim => Mutable (PrimState prim) -> Offset Word8 -> Word8 -> prim () +primWrite8 = primWrite +{-# INLINE primWrite8 #-} + +primRead8 :: PrimMonad prim => Mutable (PrimState prim) -> Offset Word8 -> prim Word8 +primRead8 = primRead +{-# INLINE primRead8 #-} + +primIndex8 :: Immutable -> Offset Word8 -> Word8 +primIndex8 = primIndex +{-# INLINE primIndex8 #-} + +nextAscii :: Immutable -> Offset Word8 -> StepASCII +nextAscii ba n = StepASCII w + where + !w = primIndex ba n +{-# INLINE nextAscii #-} + +-- | nextAsciiBa specialized to get a digit between 0 and 9 (included) +nextAsciiDigit :: Immutable -> Offset Word8 -> StepDigit +nextAsciiDigit ba n = StepDigit (primIndex8 ba n - 0x30) +{-# INLINE nextAsciiDigit #-} + +expectAscii :: Immutable -> Offset Word8 -> Word8 -> Bool +expectAscii ba n v = primIndex8 ba n == v +{-# INLINE expectAscii #-} + +next :: Immutable -> Offset8 -> Step +next ba n = + case getNbBytes h of + 0 -> Step (toChar1 h) (n + Offset 1) + 1 -> Step (toChar2 h (primIndex8 ba (n + Offset 1))) (n + Offset 2) + 2 -> Step (toChar3 h (primIndex8 ba (n + Offset 1)) + (primIndex8 ba (n + Offset 2))) (n + Offset 3) + 3 -> Step (toChar4 h (primIndex8 ba (n + Offset 1)) + (primIndex8 ba (n + Offset 2)) + (primIndex8 ba (n + Offset 3))) (n + Offset 4) + r -> error ("next: internal error: invalid input: offset=" <> show n <> " table=" <> show r <> " h=" <> show h) + where + !h = primIndex8 ba n +{-# INLINE next #-} + +nextSkip :: Immutable -> Offset Word8 -> Offset Word8 +nextSkip ba n = n + 1 + Offset (getNbBytes (primIndex8 ba n)) +{-# INLINE nextSkip #-} + +-- Given a non null offset, give the previous character and the offset of this character +-- will fail bad if apply at the beginning of string or an empty string. +prev :: Immutable -> Offset Word8 -> StepBack +prev ba offset = + case primIndex8 ba prevOfs1 of + (W8# v1) | isContinuation# v1 -> atLeast2 (maskContinuation# v1) + | otherwise -> StepBack (toChar# v1) prevOfs1 + where + sz1 = CountOf 1 + !prevOfs1 = offset `offsetMinusE` sz1 + prevOfs2 = prevOfs1 `offsetMinusE` sz1 + prevOfs3 = prevOfs2 `offsetMinusE` sz1 + prevOfs4 = prevOfs3 `offsetMinusE` sz1 + atLeast2 !v = + case primIndex8 ba prevOfs2 of + (W8# v2) | isContinuation# v2 -> atLeast3 (or# (uncheckedShiftL# (maskContinuation# v2) 6#) v) + | otherwise -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader2# v2) 6#) v)) prevOfs2 + atLeast3 !v = + case primIndex8 ba prevOfs3 of + (W8# v3) | isContinuation# v3 -> atLeast4 (or# (uncheckedShiftL# (maskContinuation# v3) 12#) v) + | otherwise -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader3# v3) 12#) v)) prevOfs3 + atLeast4 !v = + case primIndex8 ba prevOfs4 of + (W8# v4) -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader4# v4) 18#) v)) prevOfs4 + +prevSkip :: Immutable -> Offset Word8 -> Offset Word8 +prevSkip ba offset = loop (offset `offsetMinusE` sz1) + where + sz1 = CountOf 1 + loop o + | isContinuation (primIndex8 ba o) = loop (o `offsetMinusE` sz1) + | otherwise = o + +write :: PrimMonad prim => Mutable (PrimState prim) -> Offset8 -> Char -> prim Offset8 +write mba !i !c + | bool# (ltWord# x 0x80## ) = encode1 + | bool# (ltWord# x 0x800## ) = encode2 + | bool# (ltWord# x 0x10000##) = encode3 + | otherwise = encode4 + where + !(I# xi) = fromEnum c + !x = int2Word# xi + + encode1 = primWrite8 mba i (W8# x) >> pure (i + Offset 1) + encode2 = do + let x1 = or# (uncheckedShiftRL# x 6#) 0xc0## + x2 = toContinuation x + primWrite8 mba i (W8# x1) + primWrite8 mba (i+1) (W8# x2) + pure (i + Offset 2) + + encode3 = do + let x1 = or# (uncheckedShiftRL# x 12#) 0xe0## + x2 = toContinuation (uncheckedShiftRL# x 6#) + x3 = toContinuation x + primWrite8 mba i (W8# x1) + primWrite8 mba (i+Offset 1) (W8# x2) + primWrite8 mba (i+Offset 2) (W8# x3) + pure (i + Offset 3) + + encode4 = do + let x1 = or# (uncheckedShiftRL# x 18#) 0xf0## + x2 = toContinuation (uncheckedShiftRL# x 12#) + x3 = toContinuation (uncheckedShiftRL# x 6#) + x4 = toContinuation x + primWrite8 mba i (W8# x1) + primWrite8 mba (i+Offset 1) (W8# x2) + primWrite8 mba (i+Offset 2) (W8# x3) + primWrite8 mba (i+Offset 3) (W8# x4) + pure (i + Offset 4) + + toContinuation :: Word# -> Word# + toContinuation w = or# (and# w 0x3f##) 0x80## +{-# INLINE write #-} + +toList :: Immutable -> Offset Word8 -> Offset Word8 -> [Char] +toList ba !start !end = loop start + where + loop !idx + | idx == end = [] + | otherwise = c : loop idx' + where (Step c idx') = next ba idx + +all :: (Char -> Bool) -> Immutable -> Offset Word8 -> Offset Word8 -> Bool +all predicate ba start end = loop start + where + loop !idx + | idx == end = True + | predicate c = loop idx' + | otherwise = False + where (Step c idx') = next ba idx +{-# INLINE all #-} + +any :: (Char -> Bool) -> Immutable -> Offset Word8 -> Offset Word8 -> Bool +any predicate ba start end = loop start + where + loop !idx + | idx == end = False + | predicate c = True + | otherwise = loop idx' + where (Step c idx') = next ba idx +{-# INLINE any #-} + +foldr :: Immutable -> Offset Word8 -> Offset Word8 -> (Char -> a -> a) -> a -> a +foldr dat start end f acc = loop start + where + loop !i + | i == end = acc + | otherwise = + let (Step c i') = next dat i + in c `f` loop i' +{-# INLINE foldr #-} + +length :: Immutable -> Offset Word8 -> Offset Word8 -> CountOf Char +length dat start end + | start == end = 0 + | otherwise = processStart 0 start + where + end64 :: Offset Word64 + end64 = offsetInElements end + + prx64 :: Proxy Word64 + prx64 = Proxy + + mask64_80 :: Word64 + mask64_80 = 0x8080808080808080 + + processStart :: CountOf Char -> Offset Word8 -> CountOf Char + processStart !c !i + | i == end = c + | offsetIsAligned prx64 i = processAligned c (offsetInElements i) + | otherwise = + let h = primIndex8 dat i + cont = (h .&. 0xc0) == 0x80 + c' = if cont then c else c+1 + in processStart c' (i+1) + processAligned :: CountOf Char -> Offset Word64 -> CountOf Char + processAligned !c !i + | i >= end64 = processEnd c (offsetInBytes i) + | otherwise = + let !h = primIndex64 dat i + !h80 = h .&. mask64_80 + in if h80 == 0 + then processAligned (c+8) (i+1) + else let !nbAscii = if h80 == mask64_80 then 0 else CountOf (8 - popCount h80) + !nbHigh = CountOf $ popCount (h .&. (h80 `unsafeShiftR` 1)) + in processAligned (c + nbAscii + nbHigh) (i+1) + processEnd !c !i + | i == end = c + | otherwise = + let h = primIndex8 dat i + cont = (h .&. 0xc0) == 0x80 + c' = if cont then c else c+1 + in processStart c' (i+1) +{-# INLINE length #-} diff --git a/Basement/Block.hs b/Basement/Block.hs --- a/Basement/Block.hs +++ b/Basement/Block.hs @@ -47,6 +47,7 @@ , revSplitAt , splitOn , break + , breakEnd , span , elem , all @@ -77,6 +78,7 @@ import Basement.Block.Base import Basement.Numerical.Additive import Basement.Numerical.Subtractive +import qualified Basement.Alg.Native.PrimArray as Alg -- | Copy all the block content to the memory starting at the destination address unsafeCopyToPtr :: forall ty prim . PrimMonad prim @@ -258,6 +260,16 @@ {-# INLINE findBreak #-} {-# SPECIALIZE [2] break :: (Word8 -> Bool) -> Block Word8 -> (Block Word8, Block Word8) #-} +breakEnd :: PrimType ty => (ty -> Bool) -> Block ty -> (Block ty, Block ty) +breakEnd predicate blk@(Block ba) + | k == end = (blk, mempty) + | otherwise = splitAt (offsetAsSize (k+1)) blk + where + k = Alg.revFindIndexPredicate predicate ba 0 end + end = 0 `offsetPlusE` len + !len = length blk +{-# SPECIALIZE [2] breakEnd :: (Word8 -> Bool) -> Block Word8 -> (Block Word8, Block Word8) #-} + span :: PrimType ty => (ty -> Bool) -> Block ty -> (Block ty, Block ty) span p = break (not . p) @@ -338,42 +350,15 @@ | otherwise = unsafeWrite mb o' (unsafeIndex blk i) >> loop o' (i+1) where o' = pred o -sortBy :: forall ty . PrimType ty => (ty -> ty -> Ordering) -> Block ty -> Block ty -sortBy xford vec +sortBy :: PrimType ty => (ty -> ty -> Ordering) -> Block ty -> Block ty +sortBy ford vec | len == 0 = mempty - | otherwise = runST (thaw vec >>= doSort xford) - where - len = length vec - doSort :: (PrimType ty, PrimMonad prim) => (ty -> ty -> Ordering) -> MutableBlock ty (PrimState prim) -> prim (Block ty) - doSort ford ma = qsort 0 (sizeLastOffset len) >> unsafeFreeze ma - where - qsort lo hi - | lo >= hi = pure () - | otherwise = do - p <- partition lo hi - qsort lo (pred p) - qsort (p+1) hi - partition lo hi = do - pivot <- unsafeRead ma hi - let loop i j - | j == hi = pure i - | otherwise = do - aj <- unsafeRead ma j - i' <- if ford aj pivot == GT - then pure i - else do - ai <- unsafeRead ma i - unsafeWrite ma j ai - unsafeWrite ma i aj - pure $ i + 1 - loop i' (j+1) - - i <- loop lo lo - ai <- unsafeRead ma i - ahi <- unsafeRead ma hi - unsafeWrite ma hi ai - unsafeWrite ma i ahi - pure i + | otherwise = runST $ do + mblock@(MutableBlock mba) <- thaw vec + Alg.inplaceSortBy ford mba 0 (sizeAsOffset len) + unsafeFreeze mblock + where len = length vec +{-# SPECIALIZE [2] sortBy :: (Word8 -> Word8 -> Ordering) -> Block Word8 -> Block Word8 #-} intersperse :: forall ty . PrimType ty => ty -> Block ty -> Block ty intersperse sep blk = case len - 1 of diff --git a/Basement/Block/Mutable.hs b/Basement/Block/Mutable.hs --- a/Basement/Block/Mutable.hs +++ b/Basement/Block/Mutable.hs @@ -16,7 +16,8 @@ -- of unboxed array that will benefit from optimisation. -- -- Because it's unpinned, the blocks are compactable / movable, --- at the expense of making them less friendly to C layer / address. +-- at the expense of making them less friendly to interop with the C layer +-- as address. -- -- Note that sadly the bytearray primitive type automatically create -- a pinned bytearray if the size is bigger than a certain threshold @@ -39,6 +40,8 @@ , mutableLengthSize , mutableLengthBytes , mutableGetAddr + , mutableWithAddr + , mutableTouch , new , newPinned , mutableEmpty @@ -84,10 +87,25 @@ -- | Get the address of the context of the mutable block. -- -- if the block is not pinned, this is a _dangerous_ operation +-- +-- Note that if nothing is holding the block, the GC can garbage collect the block +-- and thus the address is dangling on the memory. use 'mutableWithAddr' to prevent +-- this problem by construction mutableGetAddr :: PrimMonad prim => MutableBlock ty (PrimState prim) -> prim (Ptr ty) mutableGetAddr (MutableBlock mba) = primitive $ \s1 -> case unsafeFreezeByteArray# mba s1 of (# s2, ba #) -> (# s2, Ptr (byteArrayContents# ba) #) + +-- | Get the address of the mutable block in a safer construct +-- +-- if the block is not pinned, this is a _dangerous_ operation +mutableWithAddr :: PrimMonad prim + => MutableBlock ty (PrimState prim) + -> (Ptr ty -> prim a) + -> prim a +mutableWithAddr mb f = do + addr <- mutableGetAddr mb + f addr <* mutableTouch mb -- | Set all mutable block element to a value iterSet :: (PrimType ty, PrimMonad prim) diff --git a/Basement/BlockN.hs b/Basement/BlockN.hs --- a/Basement/BlockN.hs +++ b/Basement/BlockN.hs @@ -4,12 +4,13 @@ -- Maintainer : Haskell Foundation -- -- A Nat-sized version of Block -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ConstraintKinds #-} module Basement.BlockN ( BlockN @@ -48,13 +49,13 @@ import Basement.Nat import Basement.NormalForm import Basement.PrimType (PrimType) -import Basement.Types.OffsetSize (CountOf(..), Offset(..)) +import Basement.Types.OffsetSize (CountOf(..), Offset(..), offsetSub) newtype BlockN (n :: Nat) a = BlockN { unBlock :: Block a } deriving (NormalForm, Eq, Show) newtype MutableBlockN (n :: Nat) ty st = MutableBlockN { unMBlock :: MutableBlock ty st } -toBlockN :: forall n ty . (PrimType ty, KnownNat n, NatWithinBound Int n) => Block ty -> Maybe (BlockN n ty) +toBlockN :: forall n ty . (PrimType ty, KnownNat n, Countable ty n) => Block ty -> Maybe (BlockN n ty) toBlockN b | expected == B.length b = Just (BlockN b) | otherwise = Nothing @@ -67,16 +68,16 @@ singleton :: PrimType ty => ty -> BlockN 1 ty singleton a = BlockN (B.singleton a) -replicate :: forall n ty . (KnownNat n, NatWithinBound Int n, PrimType ty) => ty -> BlockN n ty +replicate :: forall n ty . (KnownNat n, Countable ty n, PrimType ty) => ty -> BlockN n ty replicate a = BlockN (B.replicate (toCount @n) a) thaw :: (KnownNat n, PrimMonad prim, PrimType ty) => BlockN n ty -> prim (MutableBlockN n ty (PrimState prim)) thaw b = MutableBlockN <$> B.thaw (unBlock b) -freeze :: (PrimMonad prim, PrimType ty, NatWithinBound Int n) => MutableBlockN n ty (PrimState prim) -> prim (BlockN n ty) +freeze :: (PrimMonad prim, PrimType ty, Countable ty n) => MutableBlockN n ty (PrimState prim) -> prim (BlockN n ty) freeze b = BlockN <$> B.freeze (unMBlock b) -index :: forall i n ty . (KnownNat i, CmpNat i n ~ 'LT, PrimType ty, NatWithinBound Int i) => BlockN n ty -> ty +index :: forall i n ty . (KnownNat i, CmpNat i n ~ 'LT, PrimType ty, Offsetable ty i) => BlockN n ty -> ty index b = unsafeIndex (unBlock b) (toOffset @i) map :: (PrimType a, PrimType b) => (a -> b) -> BlockN n a -> BlockN n b @@ -94,16 +95,32 @@ snoc :: PrimType ty => BlockN n ty -> ty -> BlockN (n+1) ty snoc b = BlockN . B.snoc (unBlock b) -sub :: forall i j n ty . ((i <=? n) ~ 'True, (j <=? n) ~ 'True, (i <=? j) ~ 'True, PrimType ty, KnownNat i, NatWithinBound Int i, KnownNat j, NatWithinBound Int j) => BlockN n ty -> BlockN (j-i) ty +sub :: forall i j n ty + . ( (i <=? n) ~ 'True + , (j <=? n) ~ 'True + , (i <=? j) ~ 'True + , PrimType ty + , KnownNat i + , KnownNat j + , Offsetable ty i + , Offsetable ty j ) + => BlockN n ty + -> BlockN (j-i) ty sub block = BlockN (B.sub (unBlock block) (toOffset @i) (toOffset @j)) -uncons :: forall n ty . (CmpNat 0 n ~ 'LT, PrimType ty, KnownNat n, NatWithinBound Int n) => BlockN n ty -> (ty, BlockN (n-1) ty) +uncons :: forall n ty . (CmpNat 0 n ~ 'LT, PrimType ty, KnownNat n, Offsetable ty n) + => BlockN n ty + -> (ty, BlockN (n-1) ty) uncons b = (index @0 b, BlockN (B.sub (unBlock b) 1 (toOffset @n))) -unsnoc :: forall n ty . (CmpNat 0 n ~ 'LT, KnownNat n, PrimType ty, NatWithinBound Int n) => BlockN n ty -> (BlockN (n-1) ty, ty) -unsnoc b = (BlockN (B.sub (unBlock b) 0 (toOffset @n)), undefined) +unsnoc :: forall n ty . (CmpNat 0 n ~ 'LT, KnownNat n, PrimType ty, Offsetable ty n) + => BlockN n ty + -> (BlockN (n-1) ty, ty) +unsnoc b = + ( BlockN (B.sub (unBlock b) 0 (toOffset @n `offsetSub` 1)) + , unsafeIndex (unBlock b) (toOffset @n `offsetSub` 1)) -splitAt :: forall i n ty . (CmpNat i n ~ 'LT, PrimType ty, KnownNat i, NatWithinBound Int i) => BlockN n ty -> (BlockN i ty, BlockN (n-i) ty) +splitAt :: forall i n ty . (CmpNat i n ~ 'LT, PrimType ty, KnownNat i, Countable ty i) => BlockN n ty -> (BlockN i ty, BlockN (n-i) ty) splitAt b = let (left, right) = B.splitAt (toCount @i) (unBlock b) in (BlockN left, BlockN right) @@ -129,8 +146,11 @@ intersperse :: (CmpNat n 1 ~ 'GT, PrimType ty) => ty -> BlockN n ty -> BlockN (n+n-1) ty intersperse sep b = BlockN (B.intersperse sep (unBlock b)) -toCount :: forall n ty . (KnownNat n, NatWithinBound Int n) => CountOf ty -toCount = CountOf (natValInt (Proxy @n)) +toCount :: forall n ty . (KnownNat n, Countable ty n) => CountOf ty +toCount = natValCountOf (Proxy @n) -toOffset :: forall n ty . (KnownNat n, NatWithinBound Int n) => Offset ty -toOffset = Offset (natValInt (Proxy @n)) +toOffset :: forall n ty . (KnownNat n, Offsetable ty n) => Offset ty +toOffset = natValOffset (Proxy @n) + +type Countable ty n = NatWithinBound (CountOf ty) n +type Offsetable ty n = NatWithinBound (Offset ty) n diff --git a/Basement/Bounded.hs b/Basement/Bounded.hs --- a/Basement/Bounded.hs +++ b/Basement/Bounded.hs @@ -41,7 +41,9 @@ zn64 v = Zn64 (v `Prelude.mod` natValWord64 (Proxy :: Proxy n)) -- | Create an element of ℤ/nℤ from a type level Nat -zn64Nat :: forall m n . (KnownNat m, KnownNat n, NatWithinBound Word64 m, NatWithinBound Word64 n, CmpNat m n ~ 'LT) => Proxy m -> Zn64 n +zn64Nat :: forall m n . (KnownNat m, KnownNat n, NatWithinBound Word64 m, NatWithinBound Word64 n, CmpNat m n ~ 'LT) + => Proxy m + -> Zn64 n zn64Nat p = Zn64 (natValWord64 p) -- | A type level bounded natural diff --git a/Basement/BoxedArray.hs b/Basement/BoxedArray.hs --- a/Basement/BoxedArray.hs +++ b/Basement/BoxedArray.hs @@ -43,7 +43,11 @@ , sub , intersperse , span + , spanEnd , break + , breakEnd + , mapFromUnboxed + , mapToUnboxed , cons , snoc , uncons @@ -70,16 +74,18 @@ import GHC.Prim import GHC.Types import GHC.ST +import Data.Proxy import Basement.Numerical.Additive import Basement.Numerical.Subtractive import Basement.NonEmpty import Basement.Compat.Base -import Data.Proxy import Basement.Compat.MonadTrans import Basement.Types.OffsetSize import Basement.PrimType import Basement.NormalForm import Basement.Monad +import Basement.UArray.Base (UArray) +import qualified Basement.UArray.Base as UArray import Basement.Exception import Basement.MutableBuilder import qualified Basement.Compat.ExtList as List @@ -131,6 +137,7 @@ instance IsList (Array ty) where type Item (Array ty) = ty fromList = vFromList + fromListN len = vFromListN (CountOf len) toList = vToList -- | return the numbers of elements in a mutable array @@ -349,6 +356,27 @@ loop _ [] ma = unsafeFreeze ma loop i (x:xs) ma = unsafeWrite ma i x >> loop (i+1) xs ma +-- | just like vFromList but with a length hint. +-- +-- The resulting array is guarantee to have been allocated to the length +-- specified, but the slice might point to the initialized cells only in +-- case the length is bigger than the list. +-- +-- If the length is too small, then the list is truncated. +-- +vFromListN :: forall a . CountOf a -> [a] -> Array a +vFromListN len l = runST $ do + ma <- new len + sz <- loop 0 l ma + unsafeFreezeShrink ma sz + where + -- TODO rewrite without ma as parameter + loop :: Offset a -> [a] -> MArray a s -> ST s (CountOf a) + loop i [] _ = return (offsetAsSize i) + loop i (x:xs) ma + | i .==# len = return (offsetAsSize i) + | otherwise = unsafeWrite ma i x >> loop (i+1) xs ma + vToList :: Array a -> [a] vToList v | len == 0 = [] @@ -481,6 +509,18 @@ then splitAt (offsetAsSize i) v else findBreak (i+1) +breakEnd :: (ty -> Bool) -> Array ty -> (Array ty, Array ty) +breakEnd predicate v = findBreak (sizeAsOffset len) + where + !len = length v + findBreak !i + | i == 0 = (v, empty) + | predicate e = splitAt (offsetAsSize i) v + | otherwise = findBreak i' + where + e = unsafeIndex v i' + i' = i `offsetSub` 1 + intersperse :: ty -> Array ty -> Array ty intersperse sep v = case len - 1 of Nothing -> v @@ -502,8 +542,17 @@ span :: (ty -> Bool) -> Array ty -> (Array ty, Array ty) span p = break (not . p) +spanEnd :: (ty -> Bool) -> Array ty -> (Array ty, Array ty) +spanEnd p = breakEnd (not . p) + map :: (a -> b) -> Array a -> Array b map f a = create (sizeCast Proxy $ length a) (\i -> f $ unsafeIndex a (offsetCast Proxy i)) + +mapFromUnboxed :: PrimType a => (a -> b) -> UArray a -> Array b +mapFromUnboxed f arr = vFromListN (sizeCast Proxy $ UArray.length arr) . fmap f . toList $ arr + +mapToUnboxed :: PrimType b => (a -> b) -> Array a -> UArray b +mapToUnboxed f arr = UArray.vFromListN (sizeCast Proxy $ length arr) . fmap f . toList $ arr {- mapIndex :: (Int -> a -> b) -> Array a -> Array b diff --git a/Basement/Compat/Natural.hs b/Basement/Compat/Natural.hs --- a/Basement/Compat/Natural.hs +++ b/Basement/Compat/Natural.hs @@ -3,16 +3,17 @@ module Basement.Compat.Natural ( Natural , integerToNatural + , naturalToInteger ) where #if MIN_VERSION_base(4,8,0) import Numeric.Natural -import Prelude (Integer, abs, fromInteger) +import Prelude (Integer, abs, fromInteger, toInteger) #else -import Prelude (Show(..),Eq,Ord,Enum,Num(..),Real(..),Integral(..),Integer,error,(<), (>), otherwise) +import Prelude (Show(..),Eq,Ord,Enum,Num(..),Real(..),Integral(..),Integer,error,(<), (>), otherwise, toInteger) import Data.Typeable newtype Natural = Natural Integer @@ -54,3 +55,6 @@ integerToNatural :: Integer -> Natural integerToNatural i = fromInteger (abs i) + +naturalToInteger :: Natural -> Integer +naturalToInteger n = toInteger n diff --git a/Basement/Error.hs b/Basement/Error.hs --- a/Basement/Error.hs +++ b/Basement/Error.hs @@ -3,6 +3,9 @@ {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# LANGUAGE TypeInType #-} +#endif module Basement.Error ( error ) where diff --git a/Basement/From.hs b/Basement/From.hs --- a/Basement/From.hs +++ b/Basement/From.hs @@ -2,6 +2,25 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UndecidableInstances #-} +-- | +-- Module : Basement.From +-- License : BSD-style +-- Maintainer : Haskell Foundation +-- +-- Flexible Type convertion +-- +-- From is multi parameter type class that allow converting +-- from a to b. +-- +-- Only type that are valid to convert to another type +-- should be From instance; otherwise TryFrom should be used. +-- +-- Into (resp TryInto) allows the contrary instances to be able +-- to specify the destination type before the source. This is +-- practical with TypeApplication module Basement.From ( From(..) , Into @@ -11,10 +30,41 @@ , tryInto ) where -import Basement.Compat.Base -import Basement.IntegralConv +import Basement.Compat.Base --- | Class of things that can be converted from a to b +-- basic instances +import GHC.Types +import GHC.Prim +import GHC.Int +import GHC.Word +import Basement.Numerical.Number +import Basement.Numerical.Conversion +import qualified Basement.Block as Block +import qualified Basement.BoxedArray as BoxArray +import qualified Basement.UArray as UArray +import qualified Basement.String as String +import qualified Basement.Types.AsciiString as AsciiString +import Basement.Types.Word128 (Word128(..)) +import Basement.Types.Word256 (Word256(..)) +import qualified Basement.Types.Word128 as Word128 +import qualified Basement.Types.Word256 as Word256 +import Basement.These +import Basement.PrimType (PrimType) +import Basement.Types.OffsetSize +import Basement.Compat.Natural +import qualified Prelude (fromIntegral) + +-- nat instances +#if __GLASGOW_HASKELL__ >= 800 +import Basement.Nat +import qualified Basement.BlockN as BlockN +import Basement.Bounded +#endif + +-- | Class of things that can be converted from a to b. +-- +-- In a valid instance, the source should be always representable by the destination, +-- otherwise the instance should be using 'TryFrom' class From a b where from :: a -> b @@ -44,7 +94,186 @@ instance From a a where from = id +-- Simple numerical instances instance From Int Word where - from = integralCast + from (I# i) = W# (int2Word# i) instance From Word Int where - from = integralCast + from (W# w) = I# (word2Int# w) + +instance IsNatural n => From n Natural where + from = toNatural +instance IsIntegral n => From n Integer where + from = toInteger + +instance From Int8 Int16 where + from (I8# i) = I16# i +instance From Int8 Int32 where + from (I8# i) = I32# i +instance From Int8 Int64 where + from (I8# i) = intToInt64 (I# i) +instance From Int8 Int where + from (I8# i) = I# i + +instance From Int16 Int32 where + from (I16# i) = I32# i +instance From Int16 Int64 where + from (I16# i) = intToInt64 (I# i) +instance From Int16 Int where + from (I16# i) = I# i + +instance From Int32 Int64 where + from (I32# i) = intToInt64 (I# i) +instance From Int32 Int where + from (I32# i) = I# i + +instance From Int Int64 where + from = intToInt64 + +instance From Word8 Word16 where + from (W8# i) = W16# i +instance From Word8 Word32 where + from (W8# i) = W32# i +instance From Word8 Word64 where + from (W8# i) = wordToWord64 (W# i) +instance From Word8 Word128 where + from (W8# i) = Word128 0 (wordToWord64 $ W# i) +instance From Word8 Word256 where + from (W8# i) = Word256 0 0 0 (wordToWord64 $ W# i) +instance From Word8 Word where + from (W8# i) = W# i +instance From Word8 Int16 where + from (W8# w) = I16# (word2Int# w) +instance From Word8 Int32 where + from (W8# w) = I32# (word2Int# w) +instance From Word8 Int64 where + from (W8# w) = intToInt64 (I# (word2Int# w)) +instance From Word8 Int where + from (W8# w) = I# (word2Int# w) + +instance From Word16 Word32 where + from (W16# i) = W32# i +instance From Word16 Word64 where + from (W16# i) = wordToWord64 (W# i) +instance From Word16 Word128 where + from (W16# i) = Word128 0 (wordToWord64 $ W# i) +instance From Word16 Word256 where + from (W16# i) = Word256 0 0 0 (wordToWord64 $ W# i) +instance From Word16 Word where + from (W16# i) = W# i + +instance From Word32 Word64 where + from (W32# i) = wordToWord64 (W# i) +instance From Word32 Word128 where + from (W32# i) = Word128 0 (wordToWord64 $ W# i) +instance From Word32 Word256 where + from (W32# i) = Word256 0 0 0 (wordToWord64 $ W# i) +instance From Word32 Word where + from (W32# i) = W# i + +instance From Word64 Word128 where + from w = Word128 0 w +instance From Word64 Word256 where + from w = Word256 0 0 0 w + +instance From Word Word64 where + from = wordToWord64 + +-- Simple prelude types +instance From (Maybe a) (Either () a) where + from (Just x) = Right x + from Nothing = Left () + +-- basic basement types +instance From (CountOf ty) Int where + from (CountOf n) = n +instance From (CountOf ty) Word where + from (CountOf n) = from n + +instance From (Either a b) (These a b) where + from (Left a) = This a + from (Right b) = That b + +-- basement instances + +-- uarrays +instance PrimType ty => From (Block.Block ty) (UArray.UArray ty) where + from = UArray.fromBlock +instance PrimType ty => From (BoxArray.Array ty) (UArray.UArray ty) where + from = BoxArray.mapToUnboxed id + +-- blocks +instance PrimType ty => From (UArray.UArray ty) (Block.Block ty) where + from = UArray.toBlock +instance PrimType ty => From (BoxArray.Array ty) (Block.Block ty) where + from = UArray.toBlock . BoxArray.mapToUnboxed id + +-- boxed array +instance PrimType ty => From (UArray.UArray ty) (BoxArray.Array ty) where + from = BoxArray.mapFromUnboxed id + + +instance From String.String (UArray.UArray Word8) where + from = String.toBytes String.UTF8 + +instance From AsciiString.AsciiString String.String where + from = String.fromBytesUnsafe . UArray.unsafeRecast . AsciiString.toBytes +instance From AsciiString.AsciiString (UArray.UArray Word8) where + from = UArray.unsafeRecast . AsciiString.toBytes + +instance TryFrom (UArray.UArray Word8) String.String where + tryFrom arr = case String.fromBytes String.UTF8 arr of + (s, Nothing, _) -> Just s + (_, Just _, _) -> Nothing + +#if __GLASGOW_HASKELL__ >= 800 +instance From (BlockN.BlockN n ty) (Block.Block ty) where + from = BlockN.toBlock +instance (NatWithinBound Int n, PrimType ty) => From (BlockN.BlockN n ty) (UArray.UArray ty) where + from = UArray.fromBlock . BlockN.toBlock +instance (NatWithinBound Int n, PrimType ty) => From (BlockN.BlockN n ty) (BoxArray.Array ty) where + from = BoxArray.mapFromUnboxed id . UArray.fromBlock . BlockN.toBlock + +instance (NatWithinBound (CountOf ty) n, KnownNat n, PrimType ty) + => TryFrom (Block.Block ty) (BlockN.BlockN n ty) where + tryFrom = BlockN.toBlockN +instance (NatWithinBound (CountOf ty) n, KnownNat n, PrimType ty) + => TryFrom (UArray.UArray ty) (BlockN.BlockN n ty) where + tryFrom = BlockN.toBlockN . UArray.toBlock +instance (NatWithinBound (CountOf ty) n, KnownNat n, PrimType ty) + => TryFrom (BoxArray.Array ty) (BlockN.BlockN n ty) where + tryFrom = BlockN.toBlockN . UArray.toBlock . BoxArray.mapToUnboxed id + +instance (KnownNat n, NatWithinBound Word8 n) => From (Zn64 n) Word8 where + from = narrow . unZn64 where narrow (W64# w) = W8# (narrow8Word# (word64ToWord# w)) +instance (KnownNat n, NatWithinBound Word16 n) => From (Zn64 n) Word16 where + from = narrow . unZn64 where narrow (W64# w) = W16# (narrow16Word# (word64ToWord# w)) +instance (KnownNat n, NatWithinBound Word32 n) => From (Zn64 n) Word32 where + from = narrow . unZn64 where narrow (W64# w) = W32# (narrow32Word# (word64ToWord# w)) +instance From (Zn64 n) Word64 where + from = unZn64 +instance From (Zn64 n) Word128 where + from = from . unZn64 +instance From (Zn64 n) Word256 where + from = from . unZn64 + +instance (KnownNat n, NatWithinBound Word8 n) => From (Zn n) Word8 where + from = narrow . naturalToWord64 . unZn where narrow (W64# w) = W8# (narrow8Word# (word64ToWord# w)) +instance (KnownNat n, NatWithinBound Word16 n) => From (Zn n) Word16 where + from = narrow . naturalToWord64 . unZn where narrow (W64# w) = W16# (narrow16Word# (word64ToWord# w)) +instance (KnownNat n, NatWithinBound Word32 n) => From (Zn n) Word32 where + from = narrow . naturalToWord64 . unZn where narrow (W64# w) = W32# (narrow32Word# (word64ToWord# w)) +instance (KnownNat n, NatWithinBound Word64 n) => From (Zn n) Word64 where + from = naturalToWord64 . unZn +instance (KnownNat n, NatWithinBound Word128 n) => From (Zn n) Word128 where + from = Word128.fromNatural . unZn +instance (KnownNat n, NatWithinBound Word256 n) => From (Zn n) Word256 where + from = Word256.fromNatural . unZn + +instance (KnownNat n, NatWithinBound Word64 n) => From (Zn n) (Zn64 n) where + from = zn64 . naturalToWord64 . unZn +instance KnownNat n => From (Zn64 n) (Zn n) where + from = zn . from . unZn64 + +naturalToWord64 :: Natural -> Word64 +naturalToWord64 = Prelude.fromIntegral +#endif diff --git a/Basement/IntegralConv.hs b/Basement/IntegralConv.hs --- a/Basement/IntegralConv.hs +++ b/Basement/IntegralConv.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE FlexibleInstances #-} module Basement.IntegralConv ( IntegralDownsize(..) , IntegralUpsize(..) @@ -12,14 +12,13 @@ , int64ToInt , wordToWord64 , word64ToWord32s + , Word32x2(..) , word64ToWord , wordToChar , wordToInt , charToInt ) where -#include "MachDeps.h" - import GHC.Types import GHC.Prim import GHC.Int @@ -27,10 +26,8 @@ import Prelude (Integer, fromIntegral) import Basement.Compat.Base import Basement.Compat.Natural - -#if WORD_SIZE_IN_BITS < 64 -import GHC.IntWord64 -#endif +import Basement.Numerical.Number +import Basement.Numerical.Conversion -- | Downsize an integral value class IntegralDownsize a b where @@ -62,6 +59,11 @@ | x < integralUpsize (minBound :: b) && x > integralUpsize (maxBound :: b) = Nothing | otherwise = Just (aToB x) +instance IsIntegral a => IntegralUpsize a Integer where + integralUpsize = toInteger +instance IsNatural a => IntegralUpsize a Natural where + integralUpsize = toNatural + instance IntegralUpsize Int8 Int16 where integralUpsize (I8# i) = I16# i instance IntegralUpsize Int8 Int32 where @@ -70,8 +72,6 @@ integralUpsize (I8# i) = intToInt64 (I# i) instance IntegralUpsize Int8 Int where integralUpsize (I8# i) = I# i -instance IntegralUpsize Int8 Integer where - integralUpsize = fromIntegral instance IntegralUpsize Int16 Int32 where integralUpsize (I16# i) = I32# i @@ -79,24 +79,15 @@ integralUpsize (I16# i) = intToInt64 (I# i) instance IntegralUpsize Int16 Int where integralUpsize (I16# i) = I# i -instance IntegralUpsize Int16 Integer where - integralUpsize = fromIntegral instance IntegralUpsize Int32 Int64 where integralUpsize (I32# i) = intToInt64 (I# i) instance IntegralUpsize Int32 Int where integralUpsize (I32# i) = I# i -instance IntegralUpsize Int32 Integer where - integralUpsize = fromIntegral -instance IntegralUpsize Int Integer where - integralUpsize = fromIntegral instance IntegralUpsize Int Int64 where integralUpsize = intToInt64 -instance IntegralUpsize Int64 Integer where - integralUpsize = fromIntegral - instance IntegralUpsize Word8 Word16 where integralUpsize (W8# i) = W16# i instance IntegralUpsize Word8 Word32 where @@ -113,10 +104,6 @@ integralUpsize (W8# w) = intToInt64 (I# (word2Int# w)) instance IntegralUpsize Word8 Int where integralUpsize (W8# w) = I# (word2Int# w) -instance IntegralUpsize Word8 Integer where - integralUpsize = fromIntegral -instance IntegralUpsize Word8 Natural where - integralUpsize = fromIntegral instance IntegralUpsize Word16 Word32 where integralUpsize (W16# i) = W32# i @@ -124,35 +111,15 @@ integralUpsize (W16# i) = wordToWord64 (W# i) instance IntegralUpsize Word16 Word where integralUpsize (W16# i) = W# i -instance IntegralUpsize Word16 Integer where - integralUpsize = fromIntegral -instance IntegralUpsize Word16 Natural where - integralUpsize = fromIntegral instance IntegralUpsize Word32 Word64 where integralUpsize (W32# i) = wordToWord64 (W# i) instance IntegralUpsize Word32 Word where integralUpsize (W32# i) = W# i -instance IntegralUpsize Word32 Integer where - integralUpsize = fromIntegral -instance IntegralUpsize Word32 Natural where - integralUpsize = fromIntegral -instance IntegralUpsize Word Integer where - integralUpsize = fromIntegral -instance IntegralUpsize Word Natural where - integralUpsize = fromIntegral instance IntegralUpsize Word Word64 where integralUpsize = wordToWord64 -instance IntegralUpsize Word64 Integer where - integralUpsize = fromIntegral -instance IntegralUpsize Word64 Natural where - integralUpsize = fromIntegral - -instance IntegralUpsize Natural Integer where - integralUpsize = fromIntegral - instance IntegralDownsize Int Int8 where integralDownsize (I# i) = I8# (narrow8Int# i) integralDownsizeCheck = integralDownsizeBounded integralDownsize @@ -258,17 +225,9 @@ instance IntegralCast Int Word where integralCast (I# i) = W# (int2Word# i) instance IntegralCast Word64 Int64 where -#if WORD_SIZE_IN_BITS == 64 - integralCast (W64# i) = I64# (word2Int# i) -#else - integralCast (W64# i) = I64# (word64ToInt64# i) -#endif + integralCast = word64ToInt64 instance IntegralCast Int64 Word64 where -#if WORD_SIZE_IN_BITS == 64 - integralCast (I64# i) = W64# (int2Word# i) -#else - integralCast (I64# i) = W64# (int64ToWord64# i) -#endif + integralCast = int64ToWord64 instance IntegralCast Int8 Word8 where integralCast (I8# i) = W8# (narrow8Word# (int2Word# i)) @@ -287,54 +246,3 @@ instance IntegralCast Word32 Int32 where integralCast (W32# i) = I32# (narrow32Int# (word2Int# i)) - -intToInt64 :: Int -> Int64 -#if WORD_SIZE_IN_BITS == 64 -intToInt64 (I# i) = I64# i -#else -intToInt64 (I# i) = I64# (intToInt64# i) -#endif - -int64ToInt :: Int64 -> Int -#if WORD_SIZE_IN_BITS == 64 -int64ToInt (I64# i) = I# i -#else -int64ToInt (I64# i) = I# (int64ToInt# i) -#endif - -wordToWord64 :: Word -> Word64 -#if WORD_SIZE_IN_BITS == 64 -wordToWord64 (W# i) = W64# i -#else -wordToWord64 (W# i) = W64# (wordToWord64# i) -#endif - -word64ToWord :: Word64 -> Word -#if WORD_SIZE_IN_BITS == 64 -word64ToWord (W64# i) = W# i -#else -word64ToWord (W64# i) = W# (word64ToWord# i) -#endif - -#if WORD_SIZE_IN_BITS == 64 -word64ToWord# :: Word# -> Word# -word64ToWord# i = i -{-# INLINE word64ToWord# #-} -#endif - -#if WORD_SIZE_IN_BITS == 64 -word64ToWord32s :: Word64 -> (# Word32, Word32 #) -word64ToWord32s (W64# w64) = (# W32# (uncheckedShiftRL# w64 32#), W32# (narrow32Word# w64) #) -#else -word64ToWord32s :: Word64 -> (# Word32, Word32 #) -word64ToWord32s (W64# w64) = (# W32# (word64ToWord# (uncheckedShiftRL64# w64 32#)), W32# (word64ToWord# w64) #) -#endif - -wordToChar :: Word -> Char -wordToChar (W# word) = C# (chr# (word2Int# word)) - -wordToInt :: Word -> Int -wordToInt (W# word) = I# (word2Int# word) - -charToInt :: Char -> Int -charToInt (C# x) = I# (ord# x) diff --git a/Basement/Nat.hs b/Basement/Nat.hs --- a/Basement/Nat.hs +++ b/Basement/Nat.hs @@ -18,6 +18,8 @@ , CmpNat -- * Nat convertion , natValNatural + , natValCountOf + , natValOffset , natValInt , natValInt8 , natValInt16 @@ -40,6 +42,10 @@ import GHC.TypeLits import Basement.Compat.Base import Basement.Compat.Natural +import Basement.Types.OffsetSize +import Basement.Types.Char7 (Char7) +import Basement.Types.Word128 (Word128) +import Basement.Types.Word256 (Word256) import Data.Int (Int8, Int16, Int32, Int64) import Data.Word (Word8, Word16, Word32, Word64) import qualified Prelude (fromIntegral) @@ -51,6 +57,12 @@ natValNatural :: forall n proxy . KnownNat n => proxy n -> Natural natValNatural n = Prelude.fromIntegral (natVal n) +natValCountOf :: forall n ty proxy . (KnownNat n, NatWithinBound (CountOf ty) n) => proxy n -> CountOf ty +natValCountOf n = CountOf $ Prelude.fromIntegral (natVal n) + +natValOffset :: forall n ty proxy . (KnownNat n, NatWithinBound (Offset ty) n) => proxy n -> Offset ty +natValOffset n = Offset $ Prelude.fromIntegral (natVal n) + natValInt :: forall n proxy . (KnownNat n, NatWithinBound Int n) => proxy n -> Int natValInt n = Prelude.fromIntegral (natVal n) @@ -83,10 +95,14 @@ -- | Get Maximum bounds of different Integral / Natural types related to Nat type family NatNumMaxBound ty where + NatNumMaxBound Char = 0x10ffff + NatNumMaxBound Char7 = 0x7f NatNumMaxBound Int64 = 0x7fffffffffffffff NatNumMaxBound Int32 = 0x7fffffff NatNumMaxBound Int16 = 0x7fff NatNumMaxBound Int8 = 0x7f + NatNumMaxBound Word256 = 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + NatNumMaxBound Word128 = 0xffffffffffffffffffffffffffffffff NatNumMaxBound Word64 = 0xffffffffffffffff NatNumMaxBound Word32 = 0xffffffff NatNumMaxBound Word16 = 0xffff @@ -98,6 +114,8 @@ NatNumMaxBound Int = NatNumMaxBound Int32 NatNumMaxBound Word = NatNumMaxBound Word32 #endif + NatNumMaxBound (CountOf x) = NatNumMaxBound Int + NatNumMaxBound (Offset x) = NatNumMaxBound Int -- | Check if a Nat is in bounds of another integral / natural types type family NatInBoundOf ty n where diff --git a/Basement/NormalForm.hs b/Basement/NormalForm.hs --- a/Basement/NormalForm.hs +++ b/Basement/NormalForm.hs @@ -8,6 +8,8 @@ import Basement.Compat.Natural import Basement.Types.OffsetSize import Basement.Types.Char7 +import Basement.Types.Word128 (Word128) +import Basement.Types.Word256 (Word256) import Basement.Endianness import Foreign.C.Types @@ -42,7 +44,6 @@ instance NormalForm Float where toNormalForm !_ = () instance NormalForm Double where toNormalForm !_ = () -instance NormalForm Char7 where toNormalForm !_ = () instance NormalForm Char where toNormalForm !_ = () instance NormalForm Bool where toNormalForm !_ = () instance NormalForm () where toNormalForm !_ = () @@ -71,6 +72,10 @@ -- Basic Foundation primitive types instance NormalForm (Offset a) where toNormalForm !_ = () instance NormalForm (CountOf a) where toNormalForm !_ = () + +instance NormalForm Char7 where toNormalForm !_ = () +instance NormalForm Word128 where toNormalForm !_ = () +instance NormalForm Word256 where toNormalForm !_ = () ----- -- composed type diff --git a/Basement/Numerical/Additive.hs b/Basement/Numerical/Additive.hs --- a/Basement/Numerical/Additive.hs +++ b/Basement/Numerical/Additive.hs @@ -15,6 +15,10 @@ import GHC.Int import GHC.Word import Foreign.C.Types +import Basement.Types.Word128 (Word128) +import Basement.Types.Word256 (Word256) +import qualified Basement.Types.Word128 as Word128 +import qualified Basement.Types.Word256 as Word256 #if WORD_SIZE_IN_BITS < 64 import GHC.IntWord64 @@ -95,6 +99,14 @@ #else (W64# a) + (W64# b) = W64# (int64ToWord64# (word64ToInt64# a `plusInt64#` word64ToInt64# b)) #endif + scale = scaleNum +instance Additive Word128 where + azero = 0 + (+) = (Word128.+) + scale = scaleNum +instance Additive Word256 where + azero = 0 + (+) = (Word256.+) scale = scaleNum instance Additive Prelude.Float where azero = 0.0 diff --git a/Basement/Numerical/Conversion.hs b/Basement/Numerical/Conversion.hs new file mode 100644 --- /dev/null +++ b/Basement/Numerical/Conversion.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +module Basement.Numerical.Conversion + ( intToInt64 + , int64ToInt + , wordToWord64 + , word64ToWord + , Word32x2(..) + , word64ToWord32s + , wordToChar + , wordToInt + , word64ToWord# + , charToInt + , int64ToWord64 + , word64ToInt64 + ) where + +#include "MachDeps.h" + +import GHC.Types +import GHC.Prim +import GHC.Int +import GHC.Word + +#if WORD_SIZE_IN_BITS < 64 +import GHC.IntWord64 +#endif + +intToInt64 :: Int -> Int64 +#if WORD_SIZE_IN_BITS == 64 +intToInt64 (I# i) = I64# i +#else +intToInt64 (I# i) = I64# (intToInt64# i) +#endif + +int64ToInt :: Int64 -> Int +#if WORD_SIZE_IN_BITS == 64 +int64ToInt (I64# i) = I# i +#else +int64ToInt (I64# i) = I# (int64ToInt# i) +#endif + +wordToWord64 :: Word -> Word64 +#if WORD_SIZE_IN_BITS == 64 +wordToWord64 (W# i) = W64# i +#else +wordToWord64 (W# i) = W64# (wordToWord64# i) +#endif + +word64ToWord :: Word64 -> Word +#if WORD_SIZE_IN_BITS == 64 +word64ToWord (W64# i) = W# i +#else +word64ToWord (W64# i) = W# (word64ToWord# i) +#endif + +word64ToInt64 :: Word64 -> Int64 +#if WORD_SIZE_IN_BITS == 64 +word64ToInt64 (W64# i) = I64# (word2Int# i) +#else +word64ToInt64 (W64# i) = I64# (word64ToInt64# i) +#endif + +int64ToWord64 :: Int64 -> Word64 +#if WORD_SIZE_IN_BITS == 64 +int64ToWord64 (I64# i) = W64# (int2Word# i) +#else +int64ToWord64 (I64# i) = W64# (int64ToWord64# i) +#endif + +#if WORD_SIZE_IN_BITS == 64 +word64ToWord# :: Word# -> Word# +word64ToWord# i = i +{-# INLINE word64ToWord# #-} +#endif + +-- | 2 Word32s +data Word32x2 = Word32x2 {-# UNPACK #-} !Word32 + {-# UNPACK #-} !Word32 + +#if WORD_SIZE_IN_BITS == 64 +word64ToWord32s :: Word64 -> Word32x2 +word64ToWord32s (W64# w64) = Word32x2 (W32# (uncheckedShiftRL# w64 32#)) (W32# (narrow32Word# w64)) +#else +word64ToWord32s :: Word64 -> Word32x2 +word64ToWord32s (W64# w64) = Word32x2 (W32# (word64ToWord# (uncheckedShiftRL64# w64 32#))) (W32# (word64ToWord# w64)) +#endif + +wordToChar :: Word -> Char +wordToChar (W# word) = C# (chr# (word2Int# word)) + +wordToInt :: Word -> Int +wordToInt (W# word) = I# (word2Int# word) + +charToInt :: Char -> Int +charToInt (C# x) = I# (ord# x) diff --git a/Basement/Numerical/Multiplicative.hs b/Basement/Numerical/Multiplicative.hs --- a/Basement/Numerical/Multiplicative.hs +++ b/Basement/Numerical/Multiplicative.hs @@ -11,6 +11,10 @@ import Basement.Compat.Natural import Basement.Numerical.Number import Basement.Numerical.Additive +import Basement.Types.Word128 (Word128) +import Basement.Types.Word256 (Word256) +import qualified Basement.Types.Word128 as Word128 +import qualified Basement.Types.Word256 as Word256 import qualified Prelude -- | Represent class of things that can be multiplied together @@ -92,6 +96,12 @@ instance Multiplicative Word64 where midentity = 1 (*) = (Prelude.*) +instance Multiplicative Word128 where + midentity = 1 + (*) = (Word128.*) +instance Multiplicative Word256 where + midentity = 1 + (*) = (Word256.*) instance Multiplicative Prelude.Float where midentity = 1.0 (*) = (Prelude.*) @@ -138,6 +148,12 @@ instance IDivisible Word64 where div = Prelude.quot mod = Prelude.rem +instance IDivisible Word128 where + div = Word128.quot + mod = Word128.rem +instance IDivisible Word256 where + div = Word256.quot + mod = Word256.rem instance Divisible Prelude.Rational where (/) = (Prelude./) diff --git a/Basement/Numerical/Number.hs b/Basement/Numerical/Number.hs --- a/Basement/Numerical/Number.hs +++ b/Basement/Numerical/Number.hs @@ -5,6 +5,7 @@ import Basement.Compat.Base import Basement.Compat.Natural +import Data.Bits import qualified Prelude import Foreign.C.Types diff --git a/Basement/Numerical/Subtractive.hs b/Basement/Numerical/Subtractive.hs --- a/Basement/Numerical/Subtractive.hs +++ b/Basement/Numerical/Subtractive.hs @@ -5,6 +5,10 @@ import Basement.Compat.Base import Basement.Compat.Natural import Basement.IntegralConv +import Basement.Types.Word128 (Word128) +import Basement.Types.Word256 (Word256) +import qualified Basement.Types.Word128 as Word128 +import qualified Basement.Types.Word256 as Word256 import qualified Prelude -- | Represent class of things that can be subtracted. @@ -63,6 +67,12 @@ instance Subtractive Word64 where type Difference Word64 = Word64 (-) = (Prelude.-) +instance Subtractive Word128 where + type Difference Word128 = Word128 + (-) = (Word128.-) +instance Subtractive Word256 where + type Difference Word256 = Word256 + (-) = (Word256.-) instance Subtractive Prelude.Float where type Difference Prelude.Float = Prelude.Float (-) = (Prelude.-) diff --git a/Basement/PrimType.hs b/Basement/PrimType.hs --- a/Basement/PrimType.hs +++ b/Basement/PrimType.hs @@ -46,6 +46,8 @@ import Basement.Types.OffsetSize import Basement.Types.Char7 (Char7(..)) import Basement.Endianness +import Basement.Types.Word128 (Word128(..)) +import Basement.Types.Word256 (Word256(..)) import Basement.Monad import qualified Prelude (quot) @@ -329,6 +331,80 @@ {-# INLINE primAddrRead #-} primAddrWrite addr (Offset (I# n)) (W64# w) = primitive $ \s1 -> (# writeWord64OffAddr# addr n w s1, () #) {-# INLINE primAddrWrite #-} +instance PrimType Word128 where + primSizeInBytes _ = CountOf 16 + {-# INLINE primSizeInBytes #-} + primShiftToBytes _ = 4 + {-# INLINE primShiftToBytes #-} + primBaUIndex ba n = + Word128 (W64# (indexWord64Array# ba n1)) (W64# (indexWord64Array# ba n2)) + where (# n1, n2 #) = offset128_64 n + {-# INLINE primBaUIndex #-} + primMbaURead mba n = primitive $ \s1 -> let !(# s2, r1 #) = readWord64Array# mba n1 s1 + !(# s3, r2 #) = readWord64Array# mba n2 s2 + in (# s3, Word128 (W64# r1) (W64# r2) #) + where (# n1, n2 #) = offset128_64 n + {-# INLINE primMbaURead #-} + primMbaUWrite mba n (Word128 (W64# w1) (W64# w2)) = primitive $ \s1 -> + let !s2 = writeWord64Array# mba n1 w1 s1 + in (# writeWord64Array# mba n2 w2 s2, () #) + where (# n1, n2 #) = offset128_64 n + {-# INLINE primMbaUWrite #-} + primAddrIndex addr n = Word128 (W64# (indexWord64OffAddr# addr n1)) (W64# (indexWord64OffAddr# addr n2)) + where (# n1, n2 #) = offset128_64 n + {-# INLINE primAddrIndex #-} + primAddrRead addr n = primitive $ \s1 -> let !(# s2, r1 #) = readWord64OffAddr# addr n1 s1 + !(# s3, r2 #) = readWord64OffAddr# addr n2 s2 + in (# s3, Word128 (W64# r1) (W64# r2) #) + where (# n1, n2 #) = offset128_64 n + {-# INLINE primAddrRead #-} + primAddrWrite addr n (Word128 (W64# w1) (W64# w2)) = primitive $ \s1 -> + let !s2 = writeWord64OffAddr# addr n1 w1 s1 + in (# writeWord64OffAddr# addr n2 w2 s2, () #) + where (# n1, n2 #) = offset128_64 n + {-# INLINE primAddrWrite #-} +instance PrimType Word256 where + primSizeInBytes _ = CountOf 32 + {-# INLINE primSizeInBytes #-} + primShiftToBytes _ = 5 + {-# INLINE primShiftToBytes #-} + primBaUIndex ba n = + Word256 (W64# (indexWord64Array# ba n1)) (W64# (indexWord64Array# ba n2)) + (W64# (indexWord64Array# ba n3)) (W64# (indexWord64Array# ba n4)) + where (# n1, n2, n3, n4 #) = offset256_64 n + {-# INLINE primBaUIndex #-} + primMbaURead mba n = primitive $ \s1 -> let !(# s2, r1 #) = readWord64Array# mba n1 s1 + !(# s3, r2 #) = readWord64Array# mba n2 s2 + !(# s4, r3 #) = readWord64Array# mba n3 s3 + !(# s5, r4 #) = readWord64Array# mba n4 s4 + in (# s5, Word256 (W64# r1) (W64# r2) (W64# r3) (W64# r4) #) + where (# n1, n2, n3, n4 #) = offset256_64 n + {-# INLINE primMbaURead #-} + primMbaUWrite mba n (Word256 (W64# w1) (W64# w2) (W64# w3) (W64# w4)) = primitive $ \s1 -> + let !s2 = writeWord64Array# mba n1 w1 s1 + !s3 = writeWord64Array# mba n2 w2 s2 + !s4 = writeWord64Array# mba n3 w3 s3 + in (# writeWord64Array# mba n4 w4 s4, () #) + where (# n1, n2, n3, n4 #) = offset256_64 n + {-# INLINE primMbaUWrite #-} + primAddrIndex addr n = Word256 (W64# (indexWord64OffAddr# addr n1)) (W64# (indexWord64OffAddr# addr n2)) + (W64# (indexWord64OffAddr# addr n3)) (W64# (indexWord64OffAddr# addr n4)) + where (# n1, n2, n3, n4 #) = offset256_64 n + {-# INLINE primAddrIndex #-} + primAddrRead addr n = primitive $ \s1 -> let !(# s2, r1 #) = readWord64OffAddr# addr n1 s1 + !(# s3, r2 #) = readWord64OffAddr# addr n2 s2 + !(# s4, r3 #) = readWord64OffAddr# addr n3 s3 + !(# s5, r4 #) = readWord64OffAddr# addr n4 s4 + in (# s5, Word256 (W64# r1) (W64# r2) (W64# r3) (W64# r4) #) + where (# n1, n2, n3, n4 #) = offset256_64 n + {-# INLINE primAddrRead #-} + primAddrWrite addr n (Word256 (W64# w1) (W64# w2) (W64# w3) (W64# w4)) = primitive $ \s1 -> + let !s2 = writeWord64OffAddr# addr n1 w1 s1 + !s3 = writeWord64OffAddr# addr n2 w2 s2 + !s4 = writeWord64OffAddr# addr n3 w3 s3 + in (# writeWord64OffAddr# addr n4 w4 s4, () #) + where (# n1, n2, n3, n4 #) = offset256_64 n + {-# INLINE primAddrWrite #-} instance PrimType Int8 where primSizeInBytes _ = CountOf 1 {-# INLINE primSizeInBytes #-} @@ -553,6 +629,8 @@ instance PrimMemoryComparable Word16 where instance PrimMemoryComparable Word32 where instance PrimMemoryComparable Word64 where +instance PrimMemoryComparable Word128 where +instance PrimMemoryComparable Word256 where instance PrimMemoryComparable Int8 where instance PrimMemoryComparable Int16 where instance PrimMemoryComparable Int32 where @@ -562,6 +640,14 @@ instance PrimMemoryComparable CUChar where instance PrimMemoryComparable a => PrimMemoryComparable (LE a) where instance PrimMemoryComparable a => PrimMemoryComparable (BE a) where + +offset128_64 :: Offset Word128 -> (# Int#, Int# #) +offset128_64 (Offset (I# i)) = (# n , n +# 1# #) + where !n = uncheckedIShiftL# i 1# + +offset256_64 :: Offset Word256 -> (# Int#, Int#, Int#, Int# #) +offset256_64 (Offset (I# i)) = (# n , n +# 1#, n +# 2#, n +# 3# #) + where !n = uncheckedIShiftL# i 2# -- | Cast a CountOf linked to type A (CountOf A) to a CountOf linked to type B (CountOf B) sizeRecast :: forall a b . (PrimType a, PrimType b) => CountOf a -> CountOf b diff --git a/Basement/String.hs b/Basement/String.hs --- a/Basement/String.hs +++ b/Basement/String.hs @@ -50,7 +50,9 @@ , indices , intersperse , span + , spanEnd , break + , breakEnd , breakElem , breakLine , dropWhile @@ -96,6 +98,7 @@ import qualified Basement.UArray as Vec import qualified Basement.UArray as C import qualified Basement.UArray.Mutable as MVec +import Basement.Block.Mutable (MutableBlock(..)) import Basement.Compat.Bifunctor import Basement.Compat.Base import Basement.Compat.Natural @@ -117,10 +120,10 @@ import Basement.UTF8.Base import Basement.UTF8.Types import Basement.UArray.Base as C (onBackendPrim, onBackend, offset, ValidRange(..), offsetsValidRange) -import qualified Basement.UTF8.BA as PrimBA -import qualified Basement.UTF8.Addr as PrimAddr -import qualified Basement.String.BA as BackendBA -import qualified Basement.String.Addr as BackendAddr +import qualified Basement.Alg.Native.UTF8 as PrimBA +import qualified Basement.Alg.Foreign.UTF8 as PrimAddr +import qualified Basement.Alg.Native.String as BackendBA +import qualified Basement.Alg.Foreign.String as BackendAddr import GHC.Prim import GHC.ST import GHC.Types @@ -461,6 +464,20 @@ {-# INLINE loop #-} {-# INLINE [2] break #-} +breakEnd :: (Char -> Bool) -> String -> (String, String) +breakEnd predicate s@(String arr) + | k == end = (s, mempty) + | otherwise = splitIndex k s + where + k = C.onBackend goVec (\_ -> pure . goAddr) arr + (C.ValidRange !start !end) = offsetsValidRange arr + goVec ba = let k = BackendBA.revFindIndexPredicate predicate ba start end + in if k == end then end else PrimBA.nextSkip ba k + goAddr (Ptr addr) = + let k = BackendAddr.revFindIndexPredicate predicate addr start end + in if k == end then end else PrimAddr.nextSkip addr k +{-# INLINE [2] breakEnd #-} + #if MIN_VERSION_base(4,9,0) {-# RULES "break (== 'c')" [3] forall c . break (eqChar c) = breakElem c #-} #else @@ -505,6 +522,11 @@ span :: (Char -> Bool) -> String -> (String, String) span predicate s = break (not . predicate) s +-- | Apply a @predicate@ to the string to return the longest suffix that satisfy the predicate and +-- the remaining +spanEnd :: (Char -> Bool) -> String -> (String, String) +spanEnd predicate s = breakEnd (not . predicate) s + -- | Drop character from the beginning while the predicate is true dropWhile :: (Char -> Bool) -> String -> String dropWhile predicate = snd . break (not . predicate) @@ -762,7 +784,7 @@ -- | Filter characters of a string using the predicate filter :: (Char -> Bool) -> String -> String filter predicate (String arr) = runST $ do - (finalSize, dst) <- newNative sz $ \mba -> + (finalSize, dst) <- newNative sz $ \(MutableBlock mba) -> C.onBackendPrim (\ba -> BackendBA.copyFilter predicate sz mba ba start) (\fptr -> withFinalPtr fptr $ \(Ptr addr) -> BackendAddr.copyFilter predicate sz mba addr start) arr diff --git a/Basement/String/Addr.hs b/Basement/String/Addr.hs deleted file mode 100644 --- a/Basement/String/Addr.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -module Basement.String.Addr - ( copyFilter - , validate - ) where - -import GHC.Prim -import GHC.ST -import Basement.Compat.Base -import Basement.Numerical.Additive -import Basement.Types.OffsetSize - -import qualified Basement.UTF8.BA as PrimBA -import qualified Basement.UTF8.Addr as PrimBackend -import Basement.UTF8.Helper -import Basement.UTF8.Table -import Basement.UTF8.Types - -copyFilter :: (Char -> Bool) - -> CountOf Word8 - -> MutableByteArray# s - -> PrimBackend.Immutable - -> Offset Word8 - -> ST s (CountOf Word8) -copyFilter predicate !sz dst src start = loop (Offset 0) start - where - !end = start `offsetPlusE` sz - loop !d !s - | s == end = pure (offsetAsSize d) - | otherwise = - let !h = PrimBackend.primIndex src s - in case headerIsAscii h of - True | predicate (toChar1 h) -> PrimBA.primWrite dst d h >> loop (d + Offset 1) (s + Offset 1) - | otherwise -> loop d (s + Offset 1) - False -> - case PrimBackend.next src s of - Step c s' | predicate c -> PrimBA.write dst d c >>= \d' -> loop d' s' - | otherwise -> loop d s' - -validate :: Offset Word8 - -> PrimBackend.Immutable - -> Offset Word8 - -> (Offset Word8, Maybe ValidationFailure) -validate end ba ofsStart = loop ofsStart - where - loop !ofs - | ofs > end = error ("validate: internal error: went pass offset : ofs=" <> show ofs <> " end=" <> show end) - | ofs == end = (end, Nothing) - | otherwise = - let !h = PrimBackend.primIndex ba ofs in - case headerIsAscii h of - True -> loop (ofs + Offset 1) - False -> - case one (CountOf $ getNbBytes h) ofs of - (nextOfs, Nothing) -> loop nextOfs - (pos, Just failure) -> (pos, Just failure) - - one (CountOf 0xff) pos = (pos, Just InvalidHeader) - one nbConts pos - | ((pos+Offset 1) `offsetPlusE` nbConts) > end = (pos, Just MissingByte) - | otherwise = - case nbConts of - CountOf 1 -> - let c1 = PrimBackend.primIndex ba (pos + Offset 1) - in if isContinuation c1 - then (pos + Offset 2, Nothing) - else (pos, Just InvalidContinuation) - CountOf 2 -> - let c1 = PrimBackend.primIndex ba (pos + Offset 1) - c2 = PrimBackend.primIndex ba (pos + Offset 2) - in if isContinuation c1 && isContinuation c2 - then (pos + Offset 3, Nothing) - else (pos, Just InvalidContinuation) - CountOf 3 -> - let c1 = PrimBackend.primIndex ba (pos + Offset 1) - c2 = PrimBackend.primIndex ba (pos + Offset 2) - c3 = PrimBackend.primIndex ba (pos + Offset 3) - in if isContinuation c1 && isContinuation c2 && isContinuation c3 - then (pos + Offset 4, Nothing) - else (pos, Just InvalidContinuation) - CountOf _ -> error "internal error" diff --git a/Basement/String/BA.hs b/Basement/String/BA.hs deleted file mode 100644 --- a/Basement/String/BA.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -module Basement.String.BA - ( copyFilter - , validate - ) where - -import GHC.Prim -import GHC.ST -import Basement.Compat.Base -import Basement.Numerical.Additive -import Basement.Types.OffsetSize - -import qualified Basement.UTF8.BA as PrimBA -import qualified Basement.UTF8.BA as PrimBackend -import Basement.UTF8.Helper -import Basement.UTF8.Table -import Basement.UTF8.Types - -copyFilter :: (Char -> Bool) - -> CountOf Word8 - -> MutableByteArray# s - -> PrimBackend.Immutable - -> Offset Word8 - -> ST s (CountOf Word8) -copyFilter predicate !sz dst src start = loop (Offset 0) start - where - !end = start `offsetPlusE` sz - loop !d !s - | s == end = pure (offsetAsSize d) - | otherwise = - let !h = PrimBackend.primIndex src s - in case headerIsAscii h of - True | predicate (toChar1 h) -> PrimBA.primWrite dst d h >> loop (d + Offset 1) (s + Offset 1) - | otherwise -> loop d (s + Offset 1) - False -> - case PrimBackend.next src s of - Step c s' | predicate c -> PrimBA.write dst d c >>= \d' -> loop d' s' - | otherwise -> loop d s' - -validate :: Offset Word8 - -> PrimBackend.Immutable - -> Offset Word8 - -> (Offset Word8, Maybe ValidationFailure) -validate end ba ofsStart = loop ofsStart - where - loop !ofs - | ofs > end = error ("validate: internal error: went pass offset : ofs=" <> show ofs <> " end=" <> show end) - | ofs == end = (end, Nothing) - | otherwise = - let !h = PrimBackend.primIndex ba ofs in - case headerIsAscii h of - True -> loop (ofs + Offset 1) - False -> - case one (CountOf $ getNbBytes h) ofs of - (nextOfs, Nothing) -> loop nextOfs - (pos, Just failure) -> (pos, Just failure) - - one (CountOf 0xff) pos = (pos, Just InvalidHeader) - one nbConts pos - | ((pos+Offset 1) `offsetPlusE` nbConts) > end = (pos, Just MissingByte) - | otherwise = - case nbConts of - CountOf 1 -> - let c1 = PrimBackend.primIndex ba (pos + Offset 1) - in if isContinuation c1 - then (pos + Offset 2, Nothing) - else (pos, Just InvalidContinuation) - CountOf 2 -> - let c1 = PrimBackend.primIndex ba (pos + Offset 1) - c2 = PrimBackend.primIndex ba (pos + Offset 2) - in if isContinuation c1 && isContinuation c2 - then (pos + Offset 3, Nothing) - else (pos, Just InvalidContinuation) - CountOf 3 -> - let c1 = PrimBackend.primIndex ba (pos + Offset 1) - c2 = PrimBackend.primIndex ba (pos + Offset 2) - c3 = PrimBackend.primIndex ba (pos + Offset 3) - in if isContinuation c1 && isContinuation c2 && isContinuation c3 - then (pos + Offset 4, Nothing) - else (pos, Just InvalidContinuation) - CountOf _ -> error "internal error" diff --git a/Basement/Types/OffsetSize.hs b/Basement/Types/OffsetSize.hs --- a/Basement/Types/OffsetSize.hs +++ b/Basement/Types/OffsetSize.hs @@ -48,7 +48,6 @@ import Data.Bits import Basement.Compat.Base import Data.Proxy -import Basement.From import Basement.Numerical.Number import Basement.Numerical.Additive import Basement.Numerical.Subtractive @@ -179,11 +178,6 @@ abs a = a negate _ = error "cannot negate CountOf: use Foundation Numerical hierarchy for this function to not be exposed to CountOf" signum (CountOf a) = CountOf (Prelude.signum a) - -instance From (CountOf ty) Int where - from (CountOf n) = n -instance From (CountOf ty) Word where - from (CountOf n) = from n instance IsIntegral (CountOf ty) where toInteger (CountOf i) = toInteger i diff --git a/Basement/Types/Word128.hs b/Basement/Types/Word128.hs new file mode 100644 --- /dev/null +++ b/Basement/Types/Word128.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +module Basement.Types.Word128 + ( Word128(..) + , (+) + , (-) + , (*) + , quot + , rem + , bitwiseAnd + , bitwiseOr + , bitwiseXor + , fromNatural + ) where + +import GHC.Prim +import GHC.Word +import GHC.Types +import qualified Prelude (fromInteger, show, Num(..), quot, rem, mod) +import Data.Bits hiding (complement, popCount, bit, testBit + , rotateL, rotateR, shiftL, shiftR) +import qualified Data.Bits as Bits +import Data.Function (on) +import Foreign.C +import Foreign.Ptr +import Foreign.Storable + +import Basement.Compat.Base +import Basement.Compat.Natural +import Basement.Compat.Primitive (bool#) +import Basement.Numerical.Conversion +import Basement.Numerical.Number + +#include "MachDeps.h" + +-- | 128 bits Word +data Word128 = Word128 {-# UNPACK #-} !Word64 + {-# UNPACK #-} !Word64 + deriving (Eq) + +instance Show Word128 where + show w = Prelude.show (toNatural w) +instance Enum Word128 where + toEnum i = Word128 0 $ int64ToWord64 (intToInt64 i) + fromEnum (Word128 _ a0) = wordToInt (word64ToWord a0) + succ (Word128 a1 a0) + | a0 == maxBound = Word128 (succ a1) 0 + | otherwise = Word128 a1 (succ a0) + pred (Word128 a1 a0) + | a0 == minBound = Word128 (pred a1) maxBound + | otherwise = Word128 a1 (pred a0) +instance Bounded Word128 where + minBound = Word128 minBound minBound + maxBound = Word128 maxBound maxBound +instance Ord Word128 where + compare (Word128 a1 a0) (Word128 b1 b0) = + case compare a1 b1 of + EQ -> compare a0 b0 + r -> r + (<) (Word128 a1 a0) (Word128 b1 b0) = + case compare a1 b1 of + EQ -> a0 < b0 + r -> r == LT + (<=) (Word128 a1 a0) (Word128 b1 b0) = + case compare a1 b1 of + EQ -> a0 <= b0 + r -> r == LT +instance Storable Word128 where + sizeOf _ = 16 + alignment _ = 16 + peek p = Word128 <$> peek (castPtr p ) + <*> peek (castPtr p `plusPtr` 8) + poke p (Word128 a1 a0) = do + poke (castPtr p ) a1 + poke (castPtr p `plusPtr` 8) a0 + +instance Integral Word128 where + fromInteger = literal +instance HasNegation Word128 where + negate = complement + +instance IsIntegral Word128 where + toInteger (Word128 a1 a0) = + (toInteger a1 `unsafeShiftL` 64) .|. + toInteger a0 +instance IsNatural Word128 where + toNatural (Word128 a1 a0) = + (toNatural a1 `unsafeShiftL` 64) .|. + toNatural a0 + +instance Prelude.Num Word128 where + abs w = w + signum w@(Word128 a1 a0) + | a1 == 0 && a0 == 0 = w + | otherwise = Word128 0 1 + fromInteger = literal + (+) = (+) + (-) = (-) + (*) = (*) + +instance Bits.Bits Word128 where + (.&.) = bitwiseAnd + (.|.) = bitwiseOr + xor = bitwiseXor + complement = complement + shiftL = shiftL + shiftR = shiftR + rotateL = rotateL + rotateR = rotateR + bitSize _ = 128 + bitSizeMaybe _ = Just 128 + isSigned _ = False + testBit = testBit + bit = bit + popCount = popCount + +-- | Add 2 Word128 +(+) :: Word128 -> Word128 -> Word128 +#if WORD_SIZE_IN_BITS < 64 +(+) = applyBiWordOnNatural (Prelude.+) +#else +(+) (Word128 (W64# a1) (W64# a0)) (Word128 (W64# b1) (W64# b0)) = Word128 (W64# s1) (W64# s0) + where + !(# carry, s0 #) = plusWord2# a0 b0 + s1 = plusWord# (plusWord# a1 b1) carry +#endif + +-- temporary available until native operation available +applyBiWordOnNatural :: (Natural -> Natural -> Natural) + -> Word128 + -> Word128 + -> Word128 +applyBiWordOnNatural f = (fromNatural .) . (f `on` toNatural) + +-- | Subtract 2 Word128 +(-) :: Word128 -> Word128 -> Word128 +(-) a b + | a >= b = applyBiWordOnNatural (Prelude.-) a b + | otherwise = complement $ applyBiWordOnNatural (Prelude.-) b a + +-- | Multiplication +(*) :: Word128 -> Word128 -> Word128 +(*) = applyBiWordOnNatural (Prelude.*) + +-- | Division +quot :: Word128 -> Word128 -> Word128 +quot = applyBiWordOnNatural Prelude.quot + +-- | Modulo +rem :: Word128 -> Word128 -> Word128 +rem = applyBiWordOnNatural Prelude.rem + +-- | Bitwise and +bitwiseAnd :: Word128 -> Word128 -> Word128 +bitwiseAnd (Word128 a1 a0) (Word128 b1 b0) = + Word128 (a1 .&. b1) (a0 .&. b0) + +-- | Bitwise or +bitwiseOr :: Word128 -> Word128 -> Word128 +bitwiseOr (Word128 a1 a0) (Word128 b1 b0) = + Word128 (a1 .|. b1) (a0 .|. b0) + +-- | Bitwise xor +bitwiseXor :: Word128 -> Word128 -> Word128 +bitwiseXor (Word128 a1 a0) (Word128 b1 b0) = + Word128 (a1 `Bits.xor` b1) (a0 `Bits.xor` b0) + +-- | Bitwise complement +complement :: Word128 -> Word128 +complement (Word128 a1 a0) = Word128 (Bits.complement a1) (Bits.complement a0) + +-- | Population count +popCount :: Word128 -> Int +popCount (Word128 a1 a0) = Bits.popCount a1 Prelude.+ Bits.popCount a0 + +-- | Bitwise Shift Left +shiftL :: Word128 -> Int -> Word128 +shiftL w@(Word128 a1 a0) n + | n < 0 || n > 127 = Word128 0 0 + | n == 64 = Word128 a0 0 + | n == 0 = w + | n > 64 = Word128 (a0 `Bits.unsafeShiftL` (n Prelude.- 64)) 0 + | otherwise = Word128 ((a1 `Bits.unsafeShiftL` n) .|. (a0 `Bits.unsafeShiftR` (64 Prelude.- n))) + (a0 `Bits.unsafeShiftL` n) + +-- | Bitwise Shift Right +shiftR :: Word128 -> Int -> Word128 +shiftR w@(Word128 a1 a0) n + | n < 0 || n > 127 = Word128 0 0 + | n == 64 = Word128 0 a1 + | n == 0 = w + | n > 64 = Word128 0 (a1 `Bits.unsafeShiftR` (n Prelude.- 64)) + | otherwise = Word128 (a1 `Bits.unsafeShiftR` n) + ((a1 `Bits.unsafeShiftL` (inv64 n)) .|. (a0 `Bits.unsafeShiftR` n)) + +-- | Bitwise rotate Left +rotateL :: Word128 -> Int -> Word128 +rotateL (Word128 a1 a0) n' + | n == 0 = Word128 a1 a0 + | n == 64 = Word128 a0 a1 + | n < 64 = Word128 (comb64 a1 n a0 (inv64 n)) (comb64 a0 n a1 (inv64 n)) + | otherwise = let n = n Prelude.- 64 in Word128 (comb64 a0 n a1 (inv64 n)) (comb64 a1 n a0 (inv64 n)) + where + n :: Int + n | n' >= 0 = n' `Prelude.mod` 128 + | otherwise = 128 Prelude.- (n' `Prelude.mod` 128) + +-- | Bitwise rotate Left +rotateR :: Word128 -> Int -> Word128 +rotateR w n = rotateL w (128 Prelude.- n) + +inv64 :: Int -> Int +inv64 i = 64 Prelude.- i + +comb64 :: Word64 -> Int -> Word64 -> Int -> Word64 +comb64 x i y j = + (x `Bits.unsafeShiftL` i) .|. (y `Bits.unsafeShiftR` j) + +-- | Test bit +testBit :: Word128 -> Int -> Bool +testBit (Word128 a1 a0) n + | n < 0 || n > 127 = False + | n > 63 = Bits.testBit a1 (n Prelude.- 64) + | otherwise = Bits.testBit a0 n + +-- | bit +bit :: Int -> Word128 +bit n + | n < 0 || n > 127 = Word128 0 0 + | n > 63 = Word128 (Bits.bit (n Prelude.- 64)) 0 + | otherwise = Word128 0 (Bits.bit n) + +literal :: Integer -> Word128 +literal i = Word128 + (Prelude.fromInteger (i `Bits.unsafeShiftR` 64)) + (Prelude.fromInteger i) + +fromNatural :: Natural -> Word128 +fromNatural n = Word128 + (Prelude.fromInteger (naturalToInteger n `Bits.unsafeShiftR` 64)) + (Prelude.fromInteger $ naturalToInteger n) diff --git a/Basement/Types/Word256.hs b/Basement/Types/Word256.hs new file mode 100644 --- /dev/null +++ b/Basement/Types/Word256.hs @@ -0,0 +1,317 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +module Basement.Types.Word256 + ( Word256(..) + , (+) + , (-) + , (*) + , quot + , rem + , bitwiseAnd + , bitwiseOr + , bitwiseXor + , fromNatural + ) where + +import GHC.Prim +import GHC.Word +import GHC.Types +import qualified Prelude (fromInteger, show, Num(..), quot, rem, mod) +import Data.Bits hiding (complement, popCount, bit, testBit + , rotateL, rotateR, shiftL, shiftR) +import qualified Data.Bits as Bits +import Data.Function (on) +import Foreign.C +import Foreign.Ptr +import Foreign.Storable + +import Basement.Compat.Base +import Basement.Compat.Natural +import Basement.Compat.Primitive (bool#) +import Basement.Numerical.Conversion +import Basement.Numerical.Number + +#include "MachDeps.h" + +-- | 256 bits Word +data Word256 = Word256 {-# UNPACK #-} !Word64 + {-# UNPACK #-} !Word64 + {-# UNPACK #-} !Word64 + {-# UNPACK #-} !Word64 + deriving (Eq) + +instance Show Word256 where + show w = Prelude.show (toNatural w) +instance Enum Word256 where + toEnum i = Word256 0 0 0 $ int64ToWord64 (intToInt64 i) + fromEnum (Word256 _ _ _ a0) = wordToInt (word64ToWord a0) + succ (Word256 a3 a2 a1 a0) + | a0 == maxBound = + if a1 == maxBound + then if a2 == maxBound + then Word256 (succ a3) 0 0 0 + else Word256 a3 (succ a2) 0 0 + else Word256 a3 a2 (succ a1) 0 + | otherwise = Word256 a3 a2 a1 (succ a0) + pred (Word256 a3 a2 a1 a0) + | a0 == minBound = + if a1 == minBound + then if a2 == minBound + then Word256 (pred a3) maxBound maxBound maxBound + else Word256 a3 (pred a2) maxBound maxBound + else Word256 a3 a2 (pred a1) maxBound + | otherwise = Word256 a3 a2 a1 (pred a0) +instance Bounded Word256 where + minBound = Word256 minBound minBound minBound minBound + maxBound = Word256 maxBound maxBound maxBound maxBound +instance Ord Word256 where + compare (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) = + compareEq a3 b3 $ compareEq a2 b2 $ compareEq a1 b1 $ compare a0 b0 + where compareEq x y next = + case compare x y of + EQ -> next + r -> r + (<) (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) = + compareLt a3 b3 $ compareLt a2 b2 $ compareLt a1 b1 (a0 < b0) + where compareLt x y next = + case compare x y of + EQ -> next + r -> r == LT +instance Storable Word256 where + sizeOf _ = 32 + alignment _ = 32 + peek p = Word256 <$> peek (castPtr p ) + <*> peek (castPtr p `plusPtr` 8) + <*> peek (castPtr p `plusPtr` 16) + <*> peek (castPtr p `plusPtr` 24) + poke p (Word256 a3 a2 a1 a0) = do + poke (castPtr p ) a3 + poke (castPtr p `plusPtr` 8 ) a2 + poke (castPtr p `plusPtr` 16) a1 + poke (castPtr p `plusPtr` 24) a0 + +instance Integral Word256 where + fromInteger = literal +instance HasNegation Word256 where + negate = complement + +instance IsIntegral Word256 where + toInteger (Word256 a3 a2 a1 a0) = + (toInteger a3 `Bits.unsafeShiftL` 192) Bits..|. + (toInteger a2 `Bits.unsafeShiftL` 128) Bits..|. + (toInteger a1 `Bits.unsafeShiftL` 64) Bits..|. + toInteger a0 +instance IsNatural Word256 where + toNatural (Word256 a3 a2 a1 a0) = + (toNatural a3 `Bits.unsafeShiftL` 192) Bits..|. + (toNatural a2 `Bits.unsafeShiftL` 128) Bits..|. + (toNatural a1 `Bits.unsafeShiftL` 64) Bits..|. + toNatural a0 + +instance Prelude.Num Word256 where + abs w = w + signum w@(Word256 a3 a2 a1 a0) + | a3 == 0 && a2 == 0 && a1 == 0 && a0 == 0 = w + | otherwise = Word256 0 0 0 1 + fromInteger = literal + (+) = (+) + (-) = (-) + (*) = (*) + +instance Bits.Bits Word256 where + (.&.) = bitwiseAnd + (.|.) = bitwiseOr + xor = bitwiseXor + complement = complement + shiftL = shiftL + shiftR = shiftR + rotateL = rotateL + rotateR = rotateR + bitSize _ = 256 + bitSizeMaybe _ = Just 256 + isSigned _ = False + testBit = testBit + bit = bit + popCount = popCount + +-- | Add 2 Word256 +(+) :: Word256 -> Word256 -> Word256 +#if WORD_SIZE_IN_BITS < 64 +(+) = applyBiWordOnNatural (Prelude.+) +#else +(+) (Word256 (W64# a3) (W64# a2) (W64# a1) (W64# a0)) + (Word256 (W64# b3) (W64# b2) (W64# b1) (W64# b0)) = + Word256 (W64# s3) (W64# s2) (W64# s1) (W64# s0) + where + !(# c0, s0 #) = plusWord2# a0 b0 + !(# c1, s1 #) = plusWord3# a1 b1 c0 + !(# c2, s2 #) = plusWord3# a2 b2 c1 + !s3 = plusWord3NoCarry# a3 b3 c2 + + plusWord3NoCarry# a b c = plusWord# (plusWord# a b) c + plusWord3# a b c + | bool# (eqWord# carry 0##) = plusWord2# x c + | otherwise = + case plusWord2# x c of + (# carry2, x' #) + | bool# (eqWord# carry2 0##) -> (# carry, x' #) + | otherwise -> (# plusWord# carry carry2, x' #) + where + (# carry, x #) = plusWord2# a b +#endif + +-- temporary available until native operation available +applyBiWordOnNatural :: (Natural -> Natural -> Natural) + -> Word256 + -> Word256 + -> Word256 +applyBiWordOnNatural f = (fromNatural .) . (f `on` toNatural) + +-- | Subtract 2 Word256 +(-) :: Word256 -> Word256 -> Word256 +(-) a b + | a >= b = applyBiWordOnNatural (Prelude.-) a b + | otherwise = complement $ applyBiWordOnNatural (Prelude.-) b a + +-- | Multiplication +(*) :: Word256 -> Word256 -> Word256 +(*) = applyBiWordOnNatural (Prelude.*) + +-- | Division +quot :: Word256 -> Word256 -> Word256 +quot = applyBiWordOnNatural Prelude.quot + +-- | Modulo +rem :: Word256 -> Word256 -> Word256 +rem = applyBiWordOnNatural Prelude.rem + +-- | Bitwise and +bitwiseAnd :: Word256 -> Word256 -> Word256 +bitwiseAnd (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) = + Word256 (a3 Bits..&. b3) (a2 Bits..&. b2) (a1 Bits..&. b1) (a0 Bits..&. b0) + +-- | Bitwise or +bitwiseOr :: Word256 -> Word256 -> Word256 +bitwiseOr (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) = + Word256 (a3 Bits..|. b3) (a2 Bits..|. b2) (a1 Bits..|. b1) (a0 Bits..|. b0) + +-- | Bitwise xor +bitwiseXor :: Word256 -> Word256 -> Word256 +bitwiseXor (Word256 a3 a2 a1 a0) (Word256 b3 b2 b1 b0) = + Word256 (a3 `Bits.xor` b3) (a2 `Bits.xor` b2) (a1 `Bits.xor` b1) (a0 `Bits.xor` b0) + +-- | Bitwise complement +complement :: Word256 -> Word256 +complement (Word256 a3 a2 a1 a0) = + Word256 (Bits.complement a3) (Bits.complement a2) (Bits.complement a1) (Bits.complement a0) + +-- | Population count +popCount :: Word256 -> Int +popCount (Word256 a3 a2 a1 a0) = + Bits.popCount a3 Prelude.+ + Bits.popCount a2 Prelude.+ + Bits.popCount a1 Prelude.+ + Bits.popCount a0 + +-- | Bitwise Shift Left +shiftL :: Word256 -> Int -> Word256 +shiftL w@(Word256 a3 a2 a1 a0) n + | n < 0 || n > 255 = Word256 0 0 0 0 + | n == 0 = w + | n == 64 = Word256 a2 a1 a0 0 + | n == 128 = Word256 a1 a0 0 0 + | n == 192 = Word256 a0 0 0 0 + | n < 64 = mkWordShift a3 a2 a1 a0 n + | n < 128 = mkWordShift a2 a1 a0 0 (n Prelude.- 64) + | n < 192 = mkWordShift a1 a0 0 0 (n Prelude.- 128) + | otherwise = mkWordShift a0 0 0 0 (n Prelude.- 192) + where + mkWordShift :: Word64 -> Word64 -> Word64 -> Word64 -> Int -> Word256 + mkWordShift w x y z s = + Word256 (comb64 w s x s') (comb64 x s y s') (comb64 y s z s') (z `Bits.unsafeShiftL` s) + where s' = inv64 s + +-- | Bitwise Shift Right +shiftR :: Word256 -> Int -> Word256 +shiftR w@(Word256 a3 a2 a1 a0) n + | n < 0 || n > 255 = Word256 0 0 0 0 + | n == 0 = w + | n == 64 = Word256 0 a3 a2 a1 + | n == 128 = Word256 0 0 a3 a2 + | n == 192 = Word256 0 0 0 a3 + | n < 64 = mkWordShift a3 a2 a1 a0 n + | n < 128 = mkWordShift 0 a3 a2 a1 (n Prelude.- 64) + | n < 192 = mkWordShift 0 0 a3 a2 (n Prelude.- 128) + | otherwise = Word256 0 0 0 (a3 `Bits.unsafeShiftR` (n Prelude.- 192)) + where + mkWordShift :: Word64 -> Word64 -> Word64 -> Word64 -> Int -> Word256 + mkWordShift w x y z s = + Word256 (w `Bits.unsafeShiftR` s) (comb64 w s' x s) (comb64 x s' y s) (comb64 y s' z s) + where s' = inv64 s + +-- | Bitwise rotate Left +rotateL :: Word256 -> Int -> Word256 +rotateL (Word256 a3 a2 a1 a0) n' + | n == 0 = Word256 a3 a2 a1 a0 + | n == 192 = Word256 a0 a3 a2 a1 + | n == 128 = Word256 a1 a0 a3 a2 + | n == 64 = Word256 a2 a1 a0 a3 + | n < 64 = Word256 (comb64 a3 n a2 (inv64 n)) (comb64 a2 n a1 (inv64 n)) + (comb64 a1 n a0 (inv64 n)) (comb64 a0 n a3 (inv64 n)) + | n < 128 = let n = n Prelude.- 64 in Word256 + (comb64 a2 n a1 (inv64 n)) (comb64 a1 n a0 (inv64 n)) + (comb64 a0 n a3 (inv64 n)) (comb64 a3 n a2 (inv64 n)) + | n < 192 = let n = n Prelude.- 128 in Word256 + (comb64 a1 n a0 (inv64 n)) (comb64 a0 n a3 (inv64 n)) + (comb64 a3 n a2 (inv64 n)) (comb64 a2 n a1 (inv64 n)) + | otherwise = let n = n Prelude.- 192 in Word256 + (comb64 a0 n a3 (inv64 n)) (comb64 a3 n a2 (inv64 n)) + (comb64 a2 n a1 (inv64 n)) (comb64 a1 n a0 (inv64 n)) + where + n :: Int + n | n' >= 0 = n' `Prelude.mod` 256 + | otherwise = 256 Prelude.- (n' `Prelude.mod` 256) + +-- | Bitwise rotate Left +rotateR :: Word256 -> Int -> Word256 +rotateR w n = rotateL w (256 Prelude.- n) + +inv64 :: Int -> Int +inv64 i = 64 Prelude.- i + +comb64 :: Word64 -> Int -> Word64 -> Int -> Word64 +comb64 x i y j = + (x `Bits.unsafeShiftL` i) .|. (y `Bits.unsafeShiftR` j) + +-- | Test bit +testBit :: Word256 -> Int -> Bool +testBit (Word256 a3 a2 a1 a0) n + | n < 0 || n > 255 = False + | n > 191 = Bits.testBit a3 (n Prelude.- 192) + | n > 127 = Bits.testBit a2 (n Prelude.- 128) + | n > 63 = Bits.testBit a1 (n Prelude.- 64) + | otherwise = Bits.testBit a0 n + +-- | bit +bit :: Int -> Word256 +bit n + | n < 0 || n > 255 = Word256 0 0 0 0 + | n > 191 = Word256 (Bits.bit (n Prelude.- 192)) 0 0 0 + | n > 127 = Word256 0 (Bits.bit (n Prelude.- 128)) 0 0 + | n > 63 = Word256 0 0 (Bits.bit (n Prelude.- 64)) 0 + | otherwise = Word256 0 0 0 (Bits.bit n) + +literal :: Integer -> Word256 +literal i = Word256 + (Prelude.fromInteger (i `Bits.unsafeShiftR` 192)) + (Prelude.fromInteger (i `Bits.unsafeShiftR` 128)) + (Prelude.fromInteger (i `Bits.unsafeShiftR` 64)) + (Prelude.fromInteger i) + +fromNatural :: Natural -> Word256 +fromNatural n = Word256 + (Prelude.fromInteger (naturalToInteger n `Bits.unsafeShiftR` 192)) + (Prelude.fromInteger (naturalToInteger n `Bits.unsafeShiftR` 128)) + (Prelude.fromInteger (naturalToInteger n `Bits.unsafeShiftR` 64)) + (Prelude.fromInteger $ naturalToInteger n) diff --git a/Basement/UArray.hs b/Basement/UArray.hs --- a/Basement/UArray.hs +++ b/Basement/UArray.hs @@ -29,6 +29,7 @@ , thaw , unsafeThaw -- * Creation + , vFromListN , new , create , createFromIO @@ -39,7 +40,8 @@ , withMutablePtr , unsafeFreezeShrink , freezeShrink - , unsafeSlide + , fromBlock + , toBlock -- * accessors , update , unsafeUpdate @@ -68,12 +70,14 @@ , revSplitAt , splitOn , break + , breakEnd , breakElem , breakLine , elem , indices , intersperse , span + , spanEnd , cons , snoc , uncons @@ -118,9 +122,10 @@ import Basement.PrimType import Basement.FinalPtr import Basement.Exception -import Basement.Utils import Basement.UArray.Base import Basement.Block (Block(..), MutableBlock(..)) +import qualified Basement.Block as BLK +import qualified Basement.Block.Base as BLK (touch, unsafeWrite) import Basement.UArray.Mutable hiding (sub, copyToPtr) import Basement.Numerical.Additive import Basement.Numerical.Subtractive @@ -129,23 +134,8 @@ import Basement.Bindings.Memory (sysHsMemFindByteBa, sysHsMemFindByteAddr) import qualified Basement.Compat.ExtList as List import qualified Basement.Base16 as Base16 -import qualified Basement.UArray.BA as PrimBA -import qualified Basement.UArray.Addr as PrimAddr - --- | Copy every cells of an existing array to a new array -copy :: PrimType ty => UArray ty -> UArray ty -copy array = runST (thaw array >>= unsafeFreeze) - --- | Thaw an array to a mutable array. --- --- the array is not modified, instead a new mutable array is created --- and every values is copied, before returning the mutable array. -thaw :: (PrimMonad prim, PrimType ty) => UArray ty -> prim (MUArray ty (PrimState prim)) -thaw array = do - ma <- new (length array) - unsafeCopyAtRO ma azero array (Offset 0) (length array) - pure ma -{-# INLINE thaw #-} +import qualified Basement.Alg.Native.PrimArray as PrimBA +import qualified Basement.Alg.Foreign.PrimArray as PrimAddr -- | Return the element at a specific index from an array. -- @@ -170,6 +160,14 @@ fromForeignPtr (fptr, ofs, len) = UArray (Offset ofs) (CountOf len) (UArrayAddr $ toFinalPtrForeign fptr) +-- | Create a UArray from a Block +-- +-- The block is still used by the uarray +fromBlock :: PrimType ty + => Block ty + -> UArray ty +fromBlock blk = UArray 0 (BLK.length blk) (UArrayBA blk) + -- | Allocate a new array with a fill function that has access to the elements of -- the source array. unsafeCopyFrom :: (PrimType a, PrimType b) @@ -198,15 +196,6 @@ copyAt ma' (Offset 0) ma (Offset 0) n unsafeFreeze ma' -unsafeSlide :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> Offset ty -> Offset ty -> prim () -unsafeSlide mua s e = doSlide mua s e - where - doSlide :: (PrimType ty, PrimMonad prim) => MUArray ty (PrimState prim) -> Offset ty -> Offset ty -> prim () - doSlide (MUArray mbStart _ (MUArrayMBA (MutableBlock mba))) start end = - primMutableByteArraySlideToStart mba (offsetInBytes $ mbStart+start) (offsetInBytes end) - doSlide (MUArray mbStart _ (MUArrayAddr fptr)) start end = withFinalPtr fptr $ \(Ptr addr) -> - primMutableAddrSlideToStart addr (offsetInBytes $ mbStart+start) (offsetInBytes end) - -- | Create a new array of size @n by settings each cells through the -- function @f. create :: forall ty . PrimType ty @@ -304,7 +293,7 @@ -> prim a withPtr a f | isPinned a == Pinned = - onBackendPrim (\ba -> f (Ptr (byteArrayContents# ba) `plusPtr` os)) + onBackendPrim (\ba -> f (Ptr (byteArrayContents# ba) `plusPtr` os) <* BLK.touch (Block ba)) (\fptr -> withFinalPtr fptr $ \ptr -> f (ptr `plusPtr` os)) a | otherwise = do @@ -312,9 +301,7 @@ trampoline <- newPinned (length a) unsafeCopyAtRO trampoline 0 a 0 (length a) unsafeFreeze trampoline - r <- withPtr arr f - touch arr - pure r + withPtr arr f where !sz = primSizeInBytes (Proxy :: Proxy ty) !(Offset os) = offsetOfE sz $ offset a @@ -377,6 +364,7 @@ ,UArray (start `offsetPlusE` nbElems) nbTails backend) | otherwise = (arr, empty) + breakElem :: PrimType ty => ty -> UArray ty -> (UArray ty, UArray ty) breakElem !ty arr@(UArray start len backend) | k == end = (arr, empty) @@ -505,7 +493,18 @@ {-# SPECIALIZE [3] revFindIndex :: Word8 -> UArray Word8 -> Maybe (Offset Word8) #-} break :: forall ty . PrimType ty => (ty -> Bool) -> UArray ty -> (UArray ty, UArray ty) -break xpredicate xv +break predicate arr + | k == end = (arr, mempty) + | otherwise = splitAt (offsetAsSize (k `offsetSub` start)) arr + where + !k = onBackend goBa (\_ -> pure . goAddr) arr + !start = offset arr + !end = start `offsetPlusE` length arr + goBa ba = PrimBA.findIndexPredicate predicate ba start end + goAddr (Ptr addr) = PrimAddr.findIndexPredicate predicate addr start end + +{- +{-# SPECIALIZE [3] findIndex :: Word8 -> UArray Word8 -> Maybe (Offset Word8) #-} | len == 0 = (mempty, mempty) | otherwise = runST $ unsafeIndexer xv (go xv xpredicate) where @@ -519,6 +518,7 @@ | otherwise = findBreak (i + Offset 1) {-# INLINE findBreak #-} {-# INLINE go #-} + -} {-# NOINLINE [2] break #-} {-# SPECIALIZE [2] break :: (Word8 -> Bool) -> UArray Word8 -> (UArray Word8, UArray Word8) #-} @@ -528,6 +528,22 @@ {-# RULES "break (== ty)" [3] forall (x :: Word8) . break (== x) = breakElem x #-} -} +-- | Similar to break but start the search of the breakpoint from the end +-- +-- > breakEnd (> 0) [1,2,3,0,0,0] +-- ([1,2,3], [0,0,0]) +breakEnd :: forall ty . PrimType ty => (ty -> Bool) -> UArray ty -> (UArray ty, UArray ty) +breakEnd predicate arr + | k == end = (arr, mempty) + | otherwise = splitAt (offsetAsSize (k+1) `sizeSub` offsetAsSize start) arr + where + !k = onBackend goBa (\_ -> pure . goAddr) arr + !start = offset arr + !end = start `offsetPlusE` length arr + goBa ba = PrimBA.revFindIndexPredicate predicate ba start end + goAddr (Ptr addr) = PrimAddr.revFindIndexPredicate predicate addr start end +{-# SPECIALIZE [3] breakEnd :: (Word8 -> Bool) -> UArray Word8 -> (UArray Word8, UArray Word8) #-} + elem :: PrimType ty => ty -> UArray ty -> Bool elem !ty arr = onBackend goBa (\_ -> pure . goAddr) arr /= end where @@ -558,6 +574,9 @@ span :: PrimType ty => (ty -> Bool) -> UArray ty -> (UArray ty, UArray ty) span p = break (not . p) +spanEnd :: PrimType ty => (ty -> Bool) -> UArray ty -> (UArray ty, UArray ty) +spanEnd p = breakEnd (not . p) + map :: (PrimType a, PrimType b) => (a -> b) -> UArray a -> UArray b map f a = create lenB (\i -> f $ unsafeIndex a (offsetCast Proxy i)) where !lenB = sizeCast (Proxy :: Proxy (a -> b)) (length a) @@ -611,45 +630,24 @@ in if predicate e then Just e else loop (i+1) sortBy :: forall ty . PrimType ty => (ty -> ty -> Ordering) -> UArray ty -> UArray ty -sortBy xford vec - | len == 0 = mempty - | otherwise = runST (thaw vec >>= doSort xford) +sortBy ford vec = runST $ do + mvec <- thaw vec + onMutableBackend goNative (\fptr -> withFinalPtr fptr goAddr) mvec + unsafeFreeze mvec where - len = length vec - doSort :: (PrimType ty, PrimMonad prim) => (ty -> ty -> Ordering) -> MUArray ty (PrimState prim) -> prim (UArray ty) - doSort ford ma = qsort 0 (sizeLastOffset len) >> unsafeFreeze ma - where - qsort lo hi - | lo >= hi = pure () - | otherwise = do - p <- partition lo hi - qsort lo (pred p) - qsort (p+1) hi - partition lo hi = do - pivot <- unsafeRead ma hi - let loop i j - | j == hi = pure i - | otherwise = do - aj <- unsafeRead ma j - i' <- if ford aj pivot == GT - then pure i - else do - ai <- unsafeRead ma i - unsafeWrite ma j ai - unsafeWrite ma i aj - pure $ i + 1 - loop i' (j+1) + !len = length vec + !end = 0 `offsetPlusE` len + !start = offset vec - i <- loop lo lo - ai <- unsafeRead ma i - ahi <- unsafeRead ma hi - unsafeWrite ma hi ai - unsafeWrite ma i ahi - pure i + goNative :: MutableByteArray# (PrimState (ST s)) -> ST s () + goNative mba = PrimBA.inplaceSortBy ford mba start end + goAddr :: Ptr ty -> ST s () + goAddr (Ptr addr) = PrimAddr.inplaceSortBy ford addr start end +{-# SPECIALIZE [3] sortBy :: (Word8 -> Word8 -> Ordering) -> UArray Word8 -> UArray Word8 #-} filter :: forall ty . PrimType ty => (ty -> Bool) -> UArray ty -> UArray ty filter predicate arr = runST $ do - (newLen, ma) <- newNative (length arr) $ \mba -> + (newLen, ma) <- newNative (length arr) $ \(MutableBlock mba) -> onBackendPrim (\ba -> PrimBA.filter predicate mba ba start end) (\fptr -> withFinalPtr fptr $ \(Ptr addr) -> PrimAddr.filter predicate mba addr start end) @@ -660,7 +658,7 @@ !start = offset arr !end = start `offsetPlusE` len -reverse :: PrimType ty => UArray ty -> UArray ty +reverse :: forall ty . PrimType ty => UArray ty -> UArray ty reverse a | len == 0 = mempty | otherwise = runST $ do @@ -674,18 +672,18 @@ !start = offset a !endI = sizeAsOffset ((start + end) - Offset 1) - goNative :: MutableByteArray# s -> ByteArray# -> ST s () + goNative :: MutableBlock ty s -> ByteArray# -> ST s () goNative !ma !ba = loop 0 where loop !i | i == end = pure () - | otherwise = primMbaWrite ma i (primBaIndex ba (sizeAsOffset (endI - i))) >> loop (i+1) - goAddr :: MutableByteArray# s -> Ptr ty -> ST s () + | otherwise = BLK.unsafeWrite ma i (primBaIndex ba (sizeAsOffset (endI - i))) >> loop (i+1) + goAddr :: MutableBlock ty s -> Ptr ty -> ST s () goAddr !ma (Ptr addr) = loop 0 where loop !i | i == end = pure () - | otherwise = primMbaWrite ma i (primAddrIndex addr (sizeAsOffset (endI - i))) >> loop (i+1) + | otherwise = BLK.unsafeWrite ma i (primAddrIndex addr (sizeAsOffset (endI - i))) >> loop (i+1) {-# SPECIALIZE [3] reverse :: UArray Word8 -> UArray Word8 #-} -- Finds where are the insertion points when we search for a `needle` diff --git a/Basement/UArray/Addr.hs b/Basement/UArray/Addr.hs deleted file mode 100644 --- a/Basement/UArray/Addr.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE CPP #-} -module Basement.UArray.Addr - ( findIndexElem - , revFindIndexElem - , findIndexPredicate - , foldl - , foldr - , foldl1 - , all - , any - , filter - , primIndex - ) where - -import GHC.Types -import GHC.Prim -import Basement.Compat.Base -import Basement.Numerical.Additive -import Basement.Types.OffsetSize -import Basement.PrimType -import Basement.Monad - -type Immutable = Addr# - -primIndex :: PrimType ty => Immutable -> Offset ty -> ty -primIndex = primAddrIndex - -findIndexElem :: PrimType ty => ty -> Immutable -> Offset ty -> Offset ty -> Offset ty -findIndexElem ty ba startIndex endIndex = loop startIndex - where - loop !i - | i < endIndex && t /= ty = loop (i+1) - | otherwise = i - where t = primIndex ba i -{-# INLINE findIndexElem #-} - -revFindIndexElem :: PrimType ty => ty -> Immutable -> Offset ty -> Offset ty -> Offset ty -revFindIndexElem ty ba startIndex endIndex - | endIndex > startIndex = loop (endIndex `offsetMinusE` 1) - | otherwise = endIndex - where - loop !i - | t == ty = i - | i > startIndex = loop (i `offsetMinusE` 1) - | otherwise = endIndex - where t = primIndex ba i -{-# INLINE revFindIndexElem #-} - -findIndexPredicate :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Offset ty -findIndexPredicate predicate ba !startIndex !endIndex = loop startIndex - where - loop !i - | i < endIndex && not found = loop (i+1) - | otherwise = i - where found = predicate (primIndex ba i) -{-# INLINE findIndexPredicate #-} - -foldl :: PrimType ty => (a -> ty -> a) -> a -> Immutable -> Offset ty -> Offset ty -> a -foldl f !initialAcc ba !startIndex !endIndex = loop startIndex initialAcc - where - loop !i !acc - | i == endIndex = acc - | otherwise = loop (i+1) (f acc (primIndex ba i)) -{-# INLINE foldl #-} - -foldr :: PrimType ty => (ty -> a -> a) -> a -> Immutable -> Offset ty -> Offset ty -> a -foldr f !initialAcc ba startIndex endIndex = loop startIndex - where - loop !i - | i == endIndex = initialAcc - | otherwise = primIndex ba i `f` loop (i+1) -{-# INLINE foldr #-} - -foldl1 :: PrimType ty => (ty -> ty -> ty) -> Immutable -> Offset ty -> Offset ty -> ty -foldl1 f ba startIndex endIndex = loop (startIndex+1) (primIndex ba startIndex) - where - loop !i !acc - | i == endIndex = acc - | otherwise = loop (i+1) (f acc (primIndex ba i)) -{-# INLINE foldl1 #-} - -filter :: (PrimMonad prim, PrimType ty) - => (ty -> Bool) -> MutableByteArray# (PrimState prim) -> Immutable -> Offset ty -> Offset ty -> prim (CountOf ty) -filter predicate dst src start end = loop azero start - where - loop !d !s - | s == end = pure (offsetAsSize d) - | predicate v = primMbaWrite dst d v >> loop (d+Offset 1) (s+Offset 1) - | otherwise = loop d (s+Offset 1) - where - v = primIndex src s - -all :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Bool -all predicate ba start end = loop start - where - loop !i - | i == end = True - | predicate (primIndex ba i) = loop (i+1) - | otherwise = False -{-# INLINE all #-} - -any :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Bool -any predicate ba start end = loop start - where - loop !i - | i == end = False - | predicate (primIndex ba i) = True - | otherwise = loop (i+1) -{-# INLINE any #-} diff --git a/Basement/UArray/BA.hs b/Basement/UArray/BA.hs deleted file mode 100644 --- a/Basement/UArray/BA.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -module Basement.UArray.BA - ( findIndexElem - , revFindIndexElem - , findIndexPredicate - , foldl - , foldr - , foldl1 - , all - , any - , filter - , primIndex - ) where - -import GHC.Types -import GHC.Prim -import Basement.Compat.Base -import Basement.Numerical.Additive -import Basement.Types.OffsetSize -import Basement.PrimType -import Basement.Monad - -type Immutable = ByteArray# - -primIndex :: PrimType ty => Immutable -> Offset ty -> ty -primIndex = primBaIndex - -findIndexElem :: PrimType ty => ty -> Immutable -> Offset ty -> Offset ty -> Offset ty -findIndexElem ty ba startIndex endIndex = loop startIndex - where - loop !i - | i < endIndex && t /= ty = loop (i+1) - | otherwise = i - where t = primIndex ba i -{-# INLINE findIndexElem #-} - -revFindIndexElem :: PrimType ty => ty -> Immutable -> Offset ty -> Offset ty -> Offset ty -revFindIndexElem ty ba startIndex endIndex - | endIndex > startIndex = loop (endIndex `offsetMinusE` 1) - | otherwise = endIndex - where - loop !i - | t == ty = i - | i > startIndex = loop (i `offsetMinusE` 1) - | otherwise = endIndex - where t = primIndex ba i -{-# INLINE revFindIndexElem #-} - -findIndexPredicate :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Offset ty -findIndexPredicate predicate ba !startIndex !endIndex = loop startIndex - where - loop !i - | i < endIndex && not found = loop (i+1) - | otherwise = i - where found = predicate (primIndex ba i) -{-# INLINE findIndexPredicate #-} - -foldl :: PrimType ty => (a -> ty -> a) -> a -> Immutable -> Offset ty -> Offset ty -> a -foldl f !initialAcc ba !startIndex !endIndex = loop startIndex initialAcc - where - loop !i !acc - | i == endIndex = acc - | otherwise = loop (i+1) (f acc (primIndex ba i)) -{-# INLINE foldl #-} - -foldr :: PrimType ty => (ty -> a -> a) -> a -> Immutable -> Offset ty -> Offset ty -> a -foldr f !initialAcc ba startIndex endIndex = loop startIndex - where - loop !i - | i == endIndex = initialAcc - | otherwise = primIndex ba i `f` loop (i+1) -{-# INLINE foldr #-} - -foldl1 :: PrimType ty => (ty -> ty -> ty) -> Immutable -> Offset ty -> Offset ty -> ty -foldl1 f ba startIndex endIndex = loop (startIndex+1) (primIndex ba startIndex) - where - loop !i !acc - | i == endIndex = acc - | otherwise = loop (i+1) (f acc (primIndex ba i)) -{-# INLINE foldl1 #-} - -filter :: (PrimMonad prim, PrimType ty) - => (ty -> Bool) -> MutableByteArray# (PrimState prim) -> Immutable -> Offset ty -> Offset ty -> prim (CountOf ty) -filter predicate dst src start end = loop azero start - where - loop !d !s - | s == end = pure (offsetAsSize d) - | predicate v = primMbaWrite dst d v >> loop (d+Offset 1) (s+Offset 1) - | otherwise = loop d (s+Offset 1) - where - v = primIndex src s - -all :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Bool -all predicate ba start end = loop start - where - loop !i - | i == end = True - | predicate (primIndex ba i) = loop (i+1) - | otherwise = False -{-# INLINE all #-} - -any :: PrimType ty => (ty -> Bool) -> Immutable -> Offset ty -> Offset ty -> Bool -any predicate ba start end = loop start - where - loop !i - | i == end = False - | predicate (primIndex ba i) = True - | otherwise = loop (i+1) -{-# INLINE any #-} diff --git a/Basement/UArray/Base.hs b/Basement/UArray/Base.hs --- a/Basement/UArray/Base.hs +++ b/Basement/UArray/Base.hs @@ -22,6 +22,8 @@ , unsafeFreezeShrink , unsafeFreeze , unsafeThaw + , thaw + , copy -- * Array accessor , unsafeIndex , unsafeIndexer @@ -31,6 +33,7 @@ , unsafeDewrap , unsafeDewrap2 -- * Basic lowlevel functions + , vFromListN , empty , length , offset @@ -42,6 +45,7 @@ , copyAt , unsafeCopyAtRO , touch + , toBlock -- * temporary , pureST ) where @@ -118,6 +122,7 @@ instance PrimType ty => IsList (UArray ty) where type Item (UArray ty) = ty fromList = vFromList + fromListN len = vFromListN (CountOf len) toList = vToList length :: UArray ty -> CountOf ty @@ -158,11 +163,11 @@ newNative :: (PrimMonad prim, PrimType ty) => CountOf ty - -> (MutableByteArray# (PrimState prim) -> prim a) -- ^ move to a MutableBlock + -> (MutableBlock ty (PrimState prim) -> prim a) -> prim (a, MUArray ty (PrimState prim)) newNative n f = do - mb@(MutableBlock mba) <- MBLK.new n - a <- f mba + mb <- MBLK.new n + a <- f mb pure (a, MUArray 0 n (MUArrayMBA mb)) -- | Create a new mutable array of size @n. @@ -238,6 +243,22 @@ unsafeThaw (UArray start len (UArrayAddr fptr)) = pure $ MUArray start len (MUArrayAddr fptr) {-# INLINE unsafeThaw #-} +-- | Thaw an array to a mutable array. +-- +-- the array is not modified, instead a new mutable array is created +-- and every values is copied, before returning the mutable array. +thaw :: (PrimMonad prim, PrimType ty) => UArray ty -> prim (MUArray ty (PrimState prim)) +thaw array = do + ma <- new (length array) + unsafeCopyAtRO ma azero array (Offset 0) (length array) + pure ma +{-# INLINE thaw #-} + +-- | Copy every cells of an existing array to a new array +copy :: PrimType ty => UArray ty -> UArray ty +copy array = runST (thaw array >>= unsafeFreeze) + + onBackend :: (ByteArray# -> a) -> (FinalPtr ty -> Ptr ty -> ST s a) -> UArray ty @@ -292,15 +313,41 @@ pureST = pure -- | make an array from a list of elements. -vFromList :: PrimType ty => [ty] -> UArray ty +vFromList :: forall ty . PrimType ty => [ty] -> UArray ty vFromList l = runST $ do - ma <- new (CountOf len) - iter azero l $ \i x -> unsafeWrite ma i x + ((), ma) <- newNative (CountOf len) copyList unsafeFreeze ma - where len = List.length l - iter _ [] _ = return () - iter !i (x:xs) z = z i x >> iter (i+1) xs z + where + len = List.length l + copyList :: MutableBlock ty s -> ST s () + copyList mb = loop 0 l + where + loop _ [] = pure () + loop !i (x:xs) = MBLK.unsafeWrite mb i x >> loop (i+1) xs +-- | Make an array from a list of elements with a size hint. +-- +-- The list should be of the same size as the hint, as otherwise: +-- +-- * The length of the list is smaller than the hint: +-- the array allocated is of the size of the hint, but is sliced +-- to only represent the valid bits +-- * The length of the list is bigger than the hint: +-- The allocated array is the size of the hint, and the list is truncated to +-- fit. +vFromListN :: forall ty . PrimType ty => CountOf ty -> [ty] -> UArray ty +vFromListN len l = runST $ do + (sz, ma) <- newNative len copyList + unsafeFreezeShrink ma sz + where + copyList :: MutableBlock ty s -> ST s (CountOf ty) + copyList mb = loop 0 l + where + loop !i [] = pure (offsetAsSize i) + loop !i (x:xs) + | i .==# len = pure (offsetAsSize i) + | otherwise = MBLK.unsafeWrite mb i x >> loop (i+1) xs + -- | transform an array to a list. vToList :: forall ty . PrimType ty => UArray ty -> [ty] vToList a @@ -548,3 +595,14 @@ touch :: PrimMonad prim => UArray ty -> prim () touch (UArray _ _ (UArrayBA blk)) = BLK.touch blk touch (UArray _ _ (UArrayAddr fptr)) = touchFinalPtr fptr + +-- | Create a Block from a UArray. +-- +-- Note that because of the slice, the destination block +-- is re-allocated and copied, unless the slice point +-- at the whole array +toBlock :: PrimType ty => UArray ty -> Block ty +toBlock arr@(UArray start len (UArrayBA blk)) + | start == 0 && BLK.length blk == len = blk + | otherwise = toBlock $ copy arr +toBlock arr = toBlock $ copy arr diff --git a/Basement/UArray/Mutable.hs b/Basement/UArray/Mutable.hs --- a/Basement/UArray/Mutable.hs +++ b/Basement/UArray/Mutable.hs @@ -49,6 +49,7 @@ import Basement.PrimType import Basement.FinalPtr import Basement.Exception +import qualified Basement.Block as BLK import qualified Basement.Block.Mutable as MBLK import Basement.Block (MutableBlock(..)) import Basement.UArray.Base hiding (empty) @@ -123,9 +124,9 @@ where sz = primSizeInBytes (Proxy :: Proxy ty) !(Offset os) = offsetOfE sz start -withMutablePtrHint skipCopy skipCopyBack vec@(MUArray start vecSz (MUArrayMBA (MutableBlock a))) f - | isMutablePinned vec == Pinned = mutableByteArrayContent a >>= \ptr -> f (ptr `plusPtr` os) - | otherwise = do +withMutablePtrHint skipCopy skipCopyBack vec@(MUArray start vecSz (MUArrayMBA mb)) f + | BLK.isMutablePinned mb == Pinned = MBLK.mutableWithAddr mb (\ptr -> f (ptr `plusPtr` os)) + | otherwise = do trampoline <- newPinned vecSz if not skipCopy then copyAt trampoline 0 vec 0 vecSz @@ -138,11 +139,6 @@ where !(Offset os) = offsetOfE sz start sz = primSizeInBytes (Proxy :: Proxy ty) - - mutableByteArrayContent :: PrimMonad prim => MutableByteArray# (PrimState prim) -> prim (Ptr ty) - mutableByteArrayContent mba = primitive $ \s1 -> - case unsafeFreezeByteArray# mba s1 of - (# s2, ba #) -> (# s2, Ptr (byteArrayContents# ba) #) -- | Create a pointer on the beginning of the mutable array -- and call a function 'f'. diff --git a/Basement/UTF8/Addr.hs b/Basement/UTF8/Addr.hs deleted file mode 100644 --- a/Basement/UTF8/Addr.hs +++ /dev/null @@ -1,245 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -module Basement.UTF8.Addr - ( Immutable - , Mutable - -- * functions - , nextAscii - , nextAsciiDigit - , expectAscii - , next - , prev - , prevSkip - , write - , toList - , all - , any - , foldr - , length - -- temporary - , primIndex - , primIndex64 - , primRead - , primWrite - ) where - -import GHC.Int -import GHC.Types -import GHC.Word -import GHC.Prim -import Data.Bits -import Basement.Compat.Base hiding (toList) -import Basement.Compat.Primitive -import Data.Proxy -import Basement.Numerical.Additive -import Basement.Numerical.Subtractive -import Basement.Types.OffsetSize -import Basement.Monad -import Basement.PrimType -import Basement.UTF8.Helper -import Basement.UTF8.Table -import Basement.UTF8.Types - -type Immutable = Addr# -type Mutable (prim :: * -> *) = Addr# - -primWrite :: PrimMonad prim => Mutable prim -> Offset Word8 -> Word8 -> prim () -primWrite = primAddrWrite - -primRead :: PrimMonad prim => Mutable prim -> Offset Word8 -> prim Word8 -primRead = primAddrRead - -primIndex :: Immutable -> Offset Word8 -> Word8 -primIndex = primAddrIndex - -primIndex64 :: Immutable -> Offset Word64 -> Word64 -primIndex64 = primAddrIndex - -nextAscii :: Immutable -> Offset Word8 -> StepASCII -nextAscii ba n = StepASCII w - where - !w = primIndex ba n -{-# INLINE nextAscii #-} - --- | nextAsciiBa specialized to get a digit between 0 and 9 (included) -nextAsciiDigit :: Immutable -> Offset Word8 -> StepDigit -nextAsciiDigit ba n = StepDigit (primIndex ba n - 0x30) -{-# INLINE nextAsciiDigit #-} - -expectAscii :: Immutable -> Offset Word8 -> Word8 -> Bool -expectAscii ba n v = primIndex ba n == v -{-# INLINE expectAscii #-} - -next :: Immutable -> Offset8 -> Step -next ba n = - case getNbBytes h of - 0 -> Step (toChar1 h) (n + Offset 1) - 1 -> Step (toChar2 h (primIndex ba (n + Offset 1))) (n + Offset 2) - 2 -> Step (toChar3 h (primIndex ba (n + Offset 1)) - (primIndex ba (n + Offset 2))) (n + Offset 3) - 3 -> Step (toChar4 h (primIndex ba (n + Offset 1)) - (primIndex ba (n + Offset 2)) - (primIndex ba (n + Offset 3))) (n + Offset 4) - r -> error ("next: internal error: invalid input: offset=" <> show n <> " table=" <> show r <> " h=" <> show h) - where - !h = primIndex ba n -{-# INLINE next #-} - --- Given a non null offset, give the previous character and the offset of this character --- will fail bad if apply at the beginning of string or an empty string. -prev :: Immutable -> Offset Word8 -> StepBack -prev ba offset = - case primIndex ba prevOfs1 of - (W8# v1) | isContinuation# v1 -> atLeast2 (maskContinuation# v1) - | otherwise -> StepBack (toChar# v1) prevOfs1 - where - sz1 = CountOf 1 - !prevOfs1 = offset `offsetMinusE` sz1 - prevOfs2 = prevOfs1 `offsetMinusE` sz1 - prevOfs3 = prevOfs2 `offsetMinusE` sz1 - prevOfs4 = prevOfs3 `offsetMinusE` sz1 - atLeast2 !v = - case primIndex ba prevOfs2 of - (W8# v2) | isContinuation# v2 -> atLeast3 (or# (uncheckedShiftL# (maskContinuation# v2) 6#) v) - | otherwise -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader2# v2) 6#) v)) prevOfs2 - atLeast3 !v = - case primIndex ba prevOfs3 of - (W8# v3) | isContinuation# v3 -> atLeast4 (or# (uncheckedShiftL# (maskContinuation# v3) 12#) v) - | otherwise -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader3# v3) 12#) v)) prevOfs3 - atLeast4 !v = - case primIndex ba prevOfs4 of - (W8# v4) -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader4# v4) 18#) v)) prevOfs4 - -prevSkip :: Immutable -> Offset Word8 -> Offset Word8 -prevSkip ba offset = loop (offset `offsetMinusE` sz1) - where - sz1 = CountOf 1 - loop o - | isContinuation (primIndex ba o) = loop (o `offsetMinusE` sz1) - | otherwise = o - -write :: PrimMonad prim => Mutable prim -> Offset8 -> Char -> prim Offset8 -write mba !i !c - | bool# (ltWord# x 0x80## ) = encode1 - | bool# (ltWord# x 0x800## ) = encode2 - | bool# (ltWord# x 0x10000##) = encode3 - | otherwise = encode4 - where - !(I# xi) = fromEnum c - !x = int2Word# xi - - encode1 = primWrite mba i (W8# x) >> pure (i + Offset 1) - encode2 = do - let x1 = or# (uncheckedShiftRL# x 6#) 0xc0## - x2 = toContinuation x - primWrite mba i (W8# x1) - primWrite mba (i+1) (W8# x2) - pure (i + Offset 2) - - encode3 = do - let x1 = or# (uncheckedShiftRL# x 12#) 0xe0## - x2 = toContinuation (uncheckedShiftRL# x 6#) - x3 = toContinuation x - primWrite mba i (W8# x1) - primWrite mba (i+Offset 1) (W8# x2) - primWrite mba (i+Offset 2) (W8# x3) - pure (i + Offset 3) - - encode4 = do - let x1 = or# (uncheckedShiftRL# x 18#) 0xf0## - x2 = toContinuation (uncheckedShiftRL# x 12#) - x3 = toContinuation (uncheckedShiftRL# x 6#) - x4 = toContinuation x - primWrite mba i (W8# x1) - primWrite mba (i+Offset 1) (W8# x2) - primWrite mba (i+Offset 2) (W8# x3) - primWrite mba (i+Offset 3) (W8# x4) - pure (i + Offset 4) - - toContinuation :: Word# -> Word# - toContinuation w = or# (and# w 0x3f##) 0x80## -{-# INLINE write #-} - -toList :: Immutable -> Offset Word8 -> Offset Word8 -> [Char] -toList ba !start !end = loop start - where - loop !idx - | idx == end = [] - | otherwise = c : loop idx' - where (Step c idx') = next ba idx - -all :: (Char -> Bool) -> Immutable -> Offset Word8 -> Offset Word8 -> Bool -all predicate ba start end = loop start - where - loop !idx - | idx == end = True - | predicate c = loop idx' - | otherwise = False - where (Step c idx') = next ba idx -{-# INLINE all #-} - -any :: (Char -> Bool) -> Immutable -> Offset Word8 -> Offset Word8 -> Bool -any predicate ba start end = loop start - where - loop !idx - | idx == end = False - | predicate c = True - | otherwise = loop idx' - where (Step c idx') = next ba idx -{-# INLINE any #-} - -foldr :: Immutable -> Offset Word8 -> Offset Word8 -> (Char -> a -> a) -> a -> a -foldr dat start end f acc = loop start - where - loop !i - | i == end = acc - | otherwise = - let (Step c i') = next dat i - in c `f` loop i' -{-# INLINE foldr #-} - -length :: Immutable -> Offset Word8 -> Offset Word8 -> CountOf Char -length dat start end - | start == end = 0 - | otherwise = processStart 0 start - where - end64 :: Offset Word64 - end64 = offsetInElements end - - prx64 :: Proxy Word64 - prx64 = Proxy - - mask64_80 :: Word64 - mask64_80 = 0x8080808080808080 - - processStart :: CountOf Char -> Offset Word8 -> CountOf Char - processStart !c !i - | i == end = c - | offsetIsAligned prx64 i = processAligned c (offsetInElements i) - | otherwise = - let h = primIndex dat i - cont = (h .&. 0xc0) == 0x80 - c' = if cont then c else c+1 - in processStart c' (i+1) - processAligned :: CountOf Char -> Offset Word64 -> CountOf Char - processAligned !c !i - | i >= end64 = processEnd c (offsetInBytes i) - | otherwise = - let !h = primIndex64 dat i - !h80 = h .&. mask64_80 - in if h80 == 0 - then processAligned (c+8) (i+1) - else let !nbAscii = if h80 == mask64_80 then 0 else CountOf (8 - popCount h80) - !nbHigh = CountOf $ popCount (h .&. (h80 `unsafeShiftR` 1)) - in processAligned (c + nbAscii + nbHigh) (i+1) - processEnd !c !i - | i == end = c - | otherwise = - let h = primIndex dat i - cont = (h .&. 0xc0) == 0x80 - c' = if cont then c else c+1 - in processStart c' (i+1) -{-# INLINE length #-} diff --git a/Basement/UTF8/BA.hs b/Basement/UTF8/BA.hs deleted file mode 100644 --- a/Basement/UTF8/BA.hs +++ /dev/null @@ -1,245 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -module Basement.UTF8.BA - ( Immutable - , Mutable - -- * functions - , nextAscii - , nextAsciiDigit - , expectAscii - , next - , prev - , prevSkip - , write - , toList - , all - , any - , foldr - , length - -- temporary - , primIndex - , primIndex64 - , primRead - , primWrite - ) where - -import GHC.Int -import GHC.Types -import GHC.Word -import GHC.Prim -import Data.Bits -import Basement.Compat.Base hiding (toList) -import Basement.Compat.Primitive -import Data.Proxy -import Basement.Numerical.Additive -import Basement.Numerical.Subtractive -import Basement.Types.OffsetSize -import Basement.Monad -import Basement.PrimType -import Basement.UTF8.Helper -import Basement.UTF8.Table -import Basement.UTF8.Types - -type Immutable = ByteArray# -type Mutable prim = MutableByteArray# (PrimState prim) - -primWrite :: PrimMonad prim => Mutable prim -> Offset Word8 -> Word8 -> prim () -primWrite = primMbaWrite - -primRead :: PrimMonad prim => Mutable prim -> Offset Word8 -> prim Word8 -primRead = primMbaRead - -primIndex :: Immutable -> Offset Word8 -> Word8 -primIndex = primBaIndex - -primIndex64 :: Immutable -> Offset Word64 -> Word64 -primIndex64 = primBaIndex - -nextAscii :: Immutable -> Offset Word8 -> StepASCII -nextAscii ba n = StepASCII w - where - !w = primIndex ba n -{-# INLINE nextAscii #-} - --- | nextAsciiBa specialized to get a digit between 0 and 9 (included) -nextAsciiDigit :: Immutable -> Offset Word8 -> StepDigit -nextAsciiDigit ba n = StepDigit (primIndex ba n - 0x30) -{-# INLINE nextAsciiDigit #-} - -expectAscii :: Immutable -> Offset Word8 -> Word8 -> Bool -expectAscii ba n v = primIndex ba n == v -{-# INLINE expectAscii #-} - -next :: Immutable -> Offset8 -> Step -next ba n = - case getNbBytes h of - 0 -> Step (toChar1 h) (n + Offset 1) - 1 -> Step (toChar2 h (primIndex ba (n + Offset 1))) (n + Offset 2) - 2 -> Step (toChar3 h (primIndex ba (n + Offset 1)) - (primIndex ba (n + Offset 2))) (n + Offset 3) - 3 -> Step (toChar4 h (primIndex ba (n + Offset 1)) - (primIndex ba (n + Offset 2)) - (primIndex ba (n + Offset 3))) (n + Offset 4) - r -> error ("next: internal error: invalid input: offset=" <> show n <> " table=" <> show r <> " h=" <> show h) - where - !h = primIndex ba n -{-# INLINE next #-} - --- Given a non null offset, give the previous character and the offset of this character --- will fail bad if apply at the beginning of string or an empty string. -prev :: Immutable -> Offset Word8 -> StepBack -prev ba offset = - case primIndex ba prevOfs1 of - (W8# v1) | isContinuation# v1 -> atLeast2 (maskContinuation# v1) - | otherwise -> StepBack (toChar# v1) prevOfs1 - where - sz1 = CountOf 1 - !prevOfs1 = offset `offsetMinusE` sz1 - prevOfs2 = prevOfs1 `offsetMinusE` sz1 - prevOfs3 = prevOfs2 `offsetMinusE` sz1 - prevOfs4 = prevOfs3 `offsetMinusE` sz1 - atLeast2 !v = - case primIndex ba prevOfs2 of - (W8# v2) | isContinuation# v2 -> atLeast3 (or# (uncheckedShiftL# (maskContinuation# v2) 6#) v) - | otherwise -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader2# v2) 6#) v)) prevOfs2 - atLeast3 !v = - case primIndex ba prevOfs3 of - (W8# v3) | isContinuation# v3 -> atLeast4 (or# (uncheckedShiftL# (maskContinuation# v3) 12#) v) - | otherwise -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader3# v3) 12#) v)) prevOfs3 - atLeast4 !v = - case primIndex ba prevOfs4 of - (W8# v4) -> StepBack (toChar# (or# (uncheckedShiftL# (maskHeader4# v4) 18#) v)) prevOfs4 - -prevSkip :: Immutable -> Offset Word8 -> Offset Word8 -prevSkip ba offset = loop (offset `offsetMinusE` sz1) - where - sz1 = CountOf 1 - loop o - | isContinuation (primIndex ba o) = loop (o `offsetMinusE` sz1) - | otherwise = o - -write :: PrimMonad prim => Mutable prim -> Offset8 -> Char -> prim Offset8 -write mba !i !c - | bool# (ltWord# x 0x80## ) = encode1 - | bool# (ltWord# x 0x800## ) = encode2 - | bool# (ltWord# x 0x10000##) = encode3 - | otherwise = encode4 - where - !(I# xi) = fromEnum c - !x = int2Word# xi - - encode1 = primWrite mba i (W8# x) >> pure (i + Offset 1) - encode2 = do - let x1 = or# (uncheckedShiftRL# x 6#) 0xc0## - x2 = toContinuation x - primWrite mba i (W8# x1) - primWrite mba (i+1) (W8# x2) - pure (i + Offset 2) - - encode3 = do - let x1 = or# (uncheckedShiftRL# x 12#) 0xe0## - x2 = toContinuation (uncheckedShiftRL# x 6#) - x3 = toContinuation x - primWrite mba i (W8# x1) - primWrite mba (i+Offset 1) (W8# x2) - primWrite mba (i+Offset 2) (W8# x3) - pure (i + Offset 3) - - encode4 = do - let x1 = or# (uncheckedShiftRL# x 18#) 0xf0## - x2 = toContinuation (uncheckedShiftRL# x 12#) - x3 = toContinuation (uncheckedShiftRL# x 6#) - x4 = toContinuation x - primWrite mba i (W8# x1) - primWrite mba (i+Offset 1) (W8# x2) - primWrite mba (i+Offset 2) (W8# x3) - primWrite mba (i+Offset 3) (W8# x4) - pure (i + Offset 4) - - toContinuation :: Word# -> Word# - toContinuation w = or# (and# w 0x3f##) 0x80## -{-# INLINE write #-} - -toList :: Immutable -> Offset Word8 -> Offset Word8 -> [Char] -toList ba !start !end = loop start - where - loop !idx - | idx == end = [] - | otherwise = c : loop idx' - where (Step c idx') = next ba idx - -all :: (Char -> Bool) -> Immutable -> Offset Word8 -> Offset Word8 -> Bool -all predicate ba start end = loop start - where - loop !idx - | idx == end = True - | predicate c = loop idx' - | otherwise = False - where (Step c idx') = next ba idx -{-# INLINE all #-} - -any :: (Char -> Bool) -> Immutable -> Offset Word8 -> Offset Word8 -> Bool -any predicate ba start end = loop start - where - loop !idx - | idx == end = False - | predicate c = True - | otherwise = loop idx' - where (Step c idx') = next ba idx -{-# INLINE any #-} - -foldr :: Immutable -> Offset Word8 -> Offset Word8 -> (Char -> a -> a) -> a -> a -foldr dat start end f acc = loop start - where - loop !i - | i == end = acc - | otherwise = - let (Step c i') = next dat i - in c `f` loop i' -{-# INLINE foldr #-} - -length :: Immutable -> Offset Word8 -> Offset Word8 -> CountOf Char -length dat start end - | start == end = 0 - | otherwise = processStart 0 start - where - end64 :: Offset Word64 - end64 = offsetInElements end - - prx64 :: Proxy Word64 - prx64 = Proxy - - mask64_80 :: Word64 - mask64_80 = 0x8080808080808080 - - processStart :: CountOf Char -> Offset Word8 -> CountOf Char - processStart !c !i - | i == end = c - | offsetIsAligned prx64 i = processAligned c (offsetInElements i) - | otherwise = - let h = primIndex dat i - cont = (h .&. 0xc0) == 0x80 - c' = if cont then c else c+1 - in processStart c' (i+1) - processAligned :: CountOf Char -> Offset Word64 -> CountOf Char - processAligned !c !i - | i >= end64 = processEnd c (offsetInBytes i) - | otherwise = - let !h = primIndex64 dat i - !h80 = h .&. mask64_80 - in if h80 == 0 - then processAligned (c+8) (i+1) - else let !nbAscii = if h80 == mask64_80 then 0 else CountOf (8 - popCount h80) - !nbHigh = CountOf $ popCount (h .&. (h80 `unsafeShiftR` 1)) - in processAligned (c + nbAscii + nbHigh) (i+1) - processEnd !c !i - | i == end = c - | otherwise = - let h = primIndex dat i - cont = (h .&. 0xc0) == 0x80 - c' = if cont then c else c+1 - in processStart c' (i+1) -{-# INLINE length #-} diff --git a/Basement/UTF8/Base.hs b/Basement/UTF8/Base.hs --- a/Basement/UTF8/Base.hs +++ b/Basement/UTF8/Base.hs @@ -29,9 +29,11 @@ import Basement.FinalPtr import Basement.UTF8.Helper import Basement.UTF8.Types -import qualified Basement.UTF8.BA as PrimBA -import qualified Basement.UTF8.Addr as PrimAddr +import qualified Basement.Alg.Native.UTF8 as PrimBA +import qualified Basement.Alg.Foreign.UTF8 as PrimAddr import Basement.UArray (UArray) +import Basement.Block (MutableBlock) +import qualified Basement.Block.Mutable as BLK import qualified Basement.UArray as Vec import qualified Basement.UArray as C import qualified Basement.UArray.Mutable as MVec @@ -115,16 +117,16 @@ _ -> countAndCopy (count+2) (ofs+2) _ -> countAndCopy (count+1) (ofs+1) - copy :: CountOf Word8 -> MutableByteArray# st -> ST st () + copy :: CountOf Word8 -> MutableBlock Word8 st -> ST st () copy count mba = loop 0 0 where loop o i | o .==# count = pure () | otherwise = case primAddrIndex addr i of 0xC0 -> case primAddrIndex addr (i+1) of - 0x80 -> primMbaUWrite mba o 0x00 >> loop (o+1) (i+2) - b2 -> primMbaUWrite mba o 0xC0 >> primMbaUWrite mba (o+1) b2 >> loop (o+2) (i+2) - b1 -> primMbaUWrite mba o b1 >> loop (o+1) (i+1) + 0x80 -> BLK.unsafeWrite mba o 0x00 >> loop (o+1) (i+2) + b2 -> BLK.unsafeWrite mba o 0xC0 >> BLK.unsafeWrite mba (o+1) b2 >> loop (o+2) (i+2) + b1 -> BLK.unsafeWrite mba o b1 >> loop (o+1) (i+1) -- | Create a new String from a list of characters @@ -187,7 +189,7 @@ newNative :: PrimMonad prim => CountOf Word8 -- ^ in number of bytes, not of elements. - -> (MutableByteArray# (PrimState prim) -> prim a) + -> (MutableBlock Word8 (PrimState prim) -> prim a) -> prim (a, MutableString (PrimState prim)) newNative n f = second MutableString `fmap` MVec.newNative n f diff --git a/Basement/Utils.hs b/Basement/Utils.hs deleted file mode 100644 --- a/Basement/Utils.hs +++ /dev/null @@ -1,72 +0,0 @@ --- | --- Module : Basement.Utils --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : portable --- -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -module Basement.Utils - ( primCopyFreezedBytes - , primCopyFreezedBytesOffset - , primCopyFreezedW32 - , primCopyFreezedW64 - , primMutableAddrSlideToStart - , primMutableByteArraySlideToStart - ) where - -import Basement.Compat.Base -import Basement.Types.OffsetSize -import Basement.Compat.Primitive -import Basement.Monad -import GHC.Prim -import GHC.Types - --- | Copy all bytes from a byteArray# to a mutableByteArray# -primCopyFreezedBytes :: PrimMonad m => MutableByteArray# (PrimState m) -> ByteArray# -> m () -primCopyFreezedBytes mba ba = primitive $ \st -> - (# copyByteArray# ba 0# mba 0# (sizeofByteArray# ba) st , () #) -{-# INLINE primCopyFreezedBytes #-} - --- | Copy @nbBytes bytes from a byteArray# to a mutableByteArray# starting at an offset -primCopyFreezedBytesOffset :: PrimMonad m => MutableByteArray# (PrimState m) -> Int# -> ByteArray# -> Int# -> m () -primCopyFreezedBytesOffset mba ofs ba nbBytes = primitive $ \st -> - (# copyByteArray# ba 0# mba ofs nbBytes st , () #) -{-# INLINE primCopyFreezedBytesOffset #-} - --- | same as 'primCopyFreezedBytes' except copy using 32 bits word -primCopyFreezedW32 :: PrimMonad m => MutableByteArray# (PrimState m) -> ByteArray# -> m () -primCopyFreezedW32 mba ba = primitive $ \st -> (# loop st 0#, () #) - where - !len = quotInt# (sizeofByteArray# ba) 8# - loop !st !n - | bool# (n ==# len) = st - | otherwise = loop (writeWord32Array# mba n (indexWord32Array# ba n) st) (n +# 1#) - {-# INLINE loop #-} -{-# INLINE primCopyFreezedW32 #-} - --- | same as 'primCopyFreezedBytes' except copy using 64 bits word -primCopyFreezedW64 :: PrimMonad m => MutableByteArray# (PrimState m) -> ByteArray# -> m () -primCopyFreezedW64 mba ba = primitive $ \st -> (# loop st 0#, () #) - where - !len = quotInt# (sizeofByteArray# ba) 8# - loop !st !n - | bool# (n ==# len) = st - | otherwise = loop (writeWord64Array# mba n (indexWord64Array# ba n) st) (n +# 1#) - {-# INLINE loop #-} -{-# INLINE primCopyFreezedW64 #-} - -primMutableByteArraySlideToStart :: PrimMonad m => MutableByteArray# (PrimState m) -> Offset8 -> Offset8 -> m () -primMutableByteArraySlideToStart mba (Offset (I# ofs)) (Offset (I# end)) = primitive $ \st -> - (# copyMutableByteArray# mba 0# mba ofs (end -# ofs) st, () #) - -primMutableAddrSlideToStart :: PrimMonad m => Addr# -> Offset8 -> Offset8 -> m () -primMutableAddrSlideToStart addr (Offset (I# ofsIni)) (Offset (I# end)) = primitive $ \st -> (# loop st 0# ofsIni, () #) - where - loop !st !dst !ofs - | bool# (ofs ==# end) = st - | otherwise = - case readWord8OffAddr# addr ofs st of { (# st', v #) -> - case writeWord8OffAddr# addr dst v st' of { st'' -> - loop st'' (dst +# 1#) (ofs +# 1#) }} diff --git a/basement.cabal b/basement.cabal --- a/basement.cabal +++ b/basement.cabal @@ -1,5 +1,5 @@ name: basement -version: 0.0.0 +version: 0.0.1 synopsis: Foundation scrap box of array & string description: Foundation most basic primitives without any dependencies homepage: https://github.com/haskell-foundation/foundation#readme @@ -39,6 +39,8 @@ Basement.Types.OffsetSize Basement.Types.Ptr Basement.Types.AsciiString + Basement.Types.Word128 + Basement.Types.Word256 Basement.Monad Basement.MutableBuilder Basement.FinalPtr @@ -88,23 +90,27 @@ Basement.Show Basement.Runtime - Basement.Utils + Basement.Alg.Native.Prim + Basement.Alg.Native.UTF8 + Basement.Alg.Native.String + Basement.Alg.Native.PrimArray + Basement.Alg.Foreign.Prim + Basement.Alg.Foreign.UTF8 + Basement.Alg.Foreign.String + Basement.Alg.Foreign.PrimArray + + Basement.Numerical.Conversion + Basement.Block.Base - Basement.UTF8.Addr - Basement.UTF8.BA Basement.UTF8.Base Basement.UTF8.Helper Basement.UTF8.Table Basement.UTF8.Types - Basement.UArray.Addr - Basement.UArray.BA Basement.UArray.Base - Basement.String.BA - Basement.String.Addr Basement.String.Encoding.Encoding Basement.String.Encoding.UTF16 Basement.String.Encoding.UTF32