diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for basics + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2019, Andrew Martin + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Andrew Martin nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/basics.cabal b/basics.cabal new file mode 100644 --- /dev/null +++ b/basics.cabal @@ -0,0 +1,61 @@ +cabal-version: 2.2 +name: basics +version: 0.2.0.0 +synopsis: Modules for primitive types +-- description: +homepage: https://github.com/andrewthad/basics +bug-reports: https://github.com/andrewthad/basics/issues +license: BSD-3-Clause +license-file: LICENSE +author: Andrew Martin +maintainer: andrew.thaddeus@gmail.com +copyright: 2019 Andrew Martin +category: Data +extra-source-files: CHANGELOG.md + +library + exposed-modules: + Basics.ArrayArray + Basics.BitBool + Basics.Bool + Basics.ByteArray + Basics.Char + Basics.Int + Basics.Int8 + Basics.Int64 + Basics.ShortText + Basics.ShortTexts + Basics.Word + Basics.Word8 + Basics.Word16 + Basics.Word32 + Basics.Word64 + Basics.Word128 + Basics.Word128s + Basics.Word256 + build-depends: + , base >=4.16 && <4.17 + , primitive >=0.7 && <0.10 + , primitive-unlifted >=0.1.2 && <2.2 + , text-short >=0.1.3 && <0.2 + , bytestring >=0.10.8 && <0.12 + , bifunctors >=5.5.4 && <5.6 + , wide-word >=0.1.1 + hs-source-dirs: src + ghc-options: -Wall -O2 + default-language: Haskell2010 + +test-suite test + type: exitcode-stdio-1.0 + main-is: Main.hs + build-depends: + , base >=4.12.0.0 && <5 + , basics + , primitive >=0.7 + , quickcheck-instances + , tasty + , tasty-hunit + , tasty-quickcheck + , transformers + hs-source-dirs: test + default-language: Haskell2010 diff --git a/src/Basics/ArrayArray.hs b/src/Basics/ArrayArray.hs new file mode 100644 --- /dev/null +++ b/src/Basics/ArrayArray.hs @@ -0,0 +1,50 @@ +{-# language DataKinds #-} +{-# language MagicHash #-} +{-# language UnboxedTuples #-} + +module Basics.ArrayArray + ( -- Types + A + , M + , R + , A# + , M# + -- Lifting + , lift + , unlift + , liftMutable + , unliftMutable + -- Array + , unsafeFreeze# + ) where + +import GHC.Exts hiding (setByteArray#) +import Data.Bifunctor.Flip (Flip(Flip)) +import Data.Primitive.Unlifted.Array (UnliftedArray(..),MutableUnliftedArray(..)) + +type A = UnliftedArray () +type A# = ArrayArray# +type M = Flip MutableUnliftedArray () +type M# = MutableArrayArray# +type R = 'BoxedRep 'Unlifted + +lift :: A# -> A +{-# inline lift #-} +lift = UnliftedArray + +unlift :: A -> A# +{-# inline unlift #-} +unlift (UnliftedArray i) = i + +liftMutable :: M# s -> M s +{-# inline liftMutable #-} +liftMutable x = Flip (MutableUnliftedArray x) + +unliftMutable :: M s -> M# s +{-# inline unliftMutable #-} +unliftMutable (Flip (MutableUnliftedArray i)) = i + +unsafeFreeze# :: M# s -> State# s -> (# State# s, A# #) +{-# inline unsafeFreeze# #-} +unsafeFreeze# = unsafeFreezeArrayArray# + diff --git a/src/Basics/BitBool.hs b/src/Basics/BitBool.hs new file mode 100644 --- /dev/null +++ b/src/Basics/BitBool.hs @@ -0,0 +1,209 @@ +{-# language BangPatterns #-} +{-# language DataKinds #-} +{-# language LambdaCase #-} +{-# language MagicHash #-} +{-# language UnboxedTuples #-} + +-- This provides an interface to bytearrays in which every +-- boolean is represented by a single bit. +module Basics.BitBool + ( -- Types + T + , T# + , R + -- Lifting + , lift + , unlift + -- Compare + , eq# + , neq# + -- Array + , read# + , write# + , index# + , set# + , uninitialized# + , initialized# + , copy# + , copyMutable# + , shrink# + -- Constants + , def + -- Encoding + , shows + ) where + +import Prelude hiding (shows) + +import GHC.Exts ((+#),(-#),(*#),(==#),(<#),isTrue#) +import GHC.Exts (Int#,State#,MutableByteArray#,ByteArray#) +import GHC.Exts (RuntimeRep(IntRep)) +import GHC.Exts (andI#,orI#,notI#,iShiftL#,iShiftRL#) + +import qualified Prelude +import qualified GHC.Exts as Exts + +type T = Bool +type T# = Int# +type R = 'IntRep + +def :: T +{-# inline def #-} +def = False + +lift :: T# -> T +{-# inline lift #-} +lift x = Exts.tagToEnum# x :: Bool + +unlift :: T -> T# +{-# inline unlift #-} +unlift = \case + True -> 1# + False -> 0# + +eq# :: Int# -> Int# -> Int# +{-# inline eq# #-} +eq# = (==#) + +neq# :: Int# -> Int# -> Int# +{-# inline neq# #-} +neq# = (Exts./=#) + +splitIndex_ :: Int# -> (# Int#, Int# #) +{-# inline splitIndex_ #-} +splitIndex_ bitIx = (# wordIx, intraWordIx #) + where + wordIx = bitIx `iShiftRL#` 6# + intraWordIx = bitIx `andI#` 0x3F# + +index# :: ByteArray# -> Int# -> T# +{-# inline index# #-} +index# arr i = + let !(# wordIx, intraWordIx #) = splitIndex_ i + !bitBundle = Exts.indexInt64Array# arr wordIx + !bit = bitBundle `andI#` (1# `iShiftL#` intraWordIx) + in bit `iShiftRL#` intraWordIx + +read# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, T# #) +{-# inline read# #-} +read# arr i st = + let !(# wordIx, intraWordIx #) = splitIndex_ i + !(# st', bitBundle #) = Exts.readInt64Array# arr wordIx st + !bit = bitBundle `andI#` (1# `iShiftL#` intraWordIx) + in (# st', bit `iShiftRL#` intraWordIx #) + +write# :: MutableByteArray# s -> Int# -> T# -> State# s -> State# s +{-# inline write# #-} +write# arr i v st = + let !(# wordIx, intraWordIx #) = splitIndex_ i + !(# st', bitBundle #) = Exts.readInt64Array# arr wordIx st + !mask = notI# (1# `iShiftL#` intraWordIx) + !bitBundle' = (bitBundle `andI#` mask) `orI#` (v `iShiftL#` intraWordIx) + in Exts.writeInt64Array# arr wordIx bitBundle' st' + +set# :: MutableByteArray# s -> Int# -> Int# -> T# -> State# s -> State# s +{-# inline set# #-} +set# arr off0 len0 v st0 = + let subOff = off0 `andI#` 7# + -- set non-byte-aligned, initial bits + len = min# len0 (8# -# subOff) + st' = bitLoop off0 len st0 + -- set full bytes + off' = off0 +# len + len' = len0 -# len + st'' = writeBytes off' len' st' + -- set trailing bits smaller than a byte + off'' = off' +# ((len' `iShiftRL#` 3#) `iShiftL#` 3#) + len'' = len' `andI#` 7# + in bitLoop off'' len'' st'' + where + -- TODO could split bitLoop into writeBitsUnaligned and writeBitsAligned, which would use masking instead of a loop + bitLoop _ 0# st = st + bitLoop off len st = + let st' = write# arr off v st + in bitLoop (off +# 1#) (len -# 1#) st' + writeBytes off len st = + let !offB = off `iShiftRL#` 3# + !lenB = len `iShiftRL#` 3# + in Exts.setByteArray# arr offB lenB vB st + vB = if isTrue# v then 0xFF# else 0# + +shrink# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, MutableByteArray# s #) +{-# inline shrink# #-} +shrink# marr sz st = + let !(# wordSz, subWordSz #) = splitIndex_ sz + !paddedSz = wordSz +# if isTrue# (subWordSz ==# 0#) then 0# else 1# + !szBytes = paddedSz *# 8# + !st' = Exts.shrinkMutableByteArray# marr szBytes st + in (# st', marr #) + +uninitialized# :: Int# -> State# s -> (# State# s, MutableByteArray# s #) +{-# inline uninitialized# #-} +uninitialized# sz st = + let !(# wordSz, subWordSz #) = splitIndex_ sz + !paddedSz = wordSz +# if isTrue# (subWordSz ==# 0#) then 0# else 1# + !szBytes = paddedSz *# 8# + in Exts.newByteArray# szBytes st + +initialized# :: Int# -> T# -> State# s -> (# State# s, MutableByteArray# s #) +{-# inline initialized# #-} +initialized# sz v0 st = + let !(# wordSz, subWordSz #) = splitIndex_ sz + !paddedSz = wordSz +# if isTrue# (subWordSz ==# 0#) then 0# else 1# + !szBytes = paddedSz *# 8# + !(# st', marr #) = Exts.newByteArray# szBytes st + !v = if isTrue# v0 then 0xFF# else 0# + in (# Exts.setByteArray# marr 0# szBytes v st', marr #) + +copy# :: MutableByteArray# s -> Int# -> ByteArray# -> Int# -> Int# -> State# s -> State# s +{-# inline copy# #-} +copy# dst 0# src 0# len st = +-- TODO when soff == doff, we can do like set# +-- first align with naiveCopy, then copy by bytes, then copy the traling bits with naiveCopy +-- in fact, this can work even when soff - doff divisible by 8 + let !lenB = len `iShiftRL#` 3# + !st' = Exts.copyByteArray# src 0# dst 0# lenB st + !off' = lenB `iShiftL#` 3# + !len' = len `andI#` 7# + in naiveCopy# dst off' src off' len' st' +copy# dst doff src soff len st = naiveCopy# dst doff src soff len st + +naiveCopy# :: MutableByteArray# s -> Int# -> ByteArray# -> Int# -> Int# -> State# s -> State# s +-- TODO if I had an index64 :: ByteArray# -> off:Int# -> len:Int# -> Int# +-- that reads up to `min len 64` unaligned bits starting at off +-- then I could write whole words at a time after aligning the doff, just as in set# +naiveCopy# _ _ _ _ 0# st = st +naiveCopy# dst doff src soff len st = + let !v = index# src soff + !st' = write# dst doff v st + in naiveCopy# dst (doff +# 1#) src (soff +# 1#) (len -# 1#) st' + +copyMutable# :: MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s +{-# inline copyMutable# #-} +copyMutable# dst 0# src 0# len st = +-- TODO when soff == doff, we can do like set# +-- first align with naiveCopyMutable, then copy by bytes, then copy the traling bits with naiveCopyMutable +-- in fact, this can work even when soff - doff divisible by 8 + let !lenB = len `iShiftRL#` 3# + !st' = Exts.copyMutableByteArray# src 0# dst 0# lenB st + !off' = lenB `iShiftL#` 3# + !len' = len `andI#` 7# + in naiveCopyMutable# dst off' src off' len' st' +copyMutable# dst doff src soff len st = naiveCopyMutable# dst doff src soff len st + +naiveCopyMutable# :: MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s +-- TODO if I had an index64 :: ByteArray# -> off:Int# -> len:Int# -> Int# +-- that reads up to `min len 64` unaligned bits starting at off +-- then I could write whole words at a time after aligning the doff, just as in set# +naiveCopyMutable# _ _ _ _ 0# st = st +naiveCopyMutable# dst doff src soff len st = + let !(# st', v #) = read# src soff st + !st'' = write# dst doff v st' + in naiveCopyMutable# dst (doff +# 1#) src (soff +# 1#) (len -# 1#) st'' + +shows :: T -> String -> String +shows = Prelude.shows + +min# :: Int# -> Int# -> Int# +{-# inline min# #-} +min# a b = if isTrue# (a <# b) then a else b diff --git a/src/Basics/Bool.hs b/src/Basics/Bool.hs new file mode 100644 --- /dev/null +++ b/src/Basics/Bool.hs @@ -0,0 +1,121 @@ +{-# language BangPatterns #-} +{-# language DataKinds #-} +{-# language LambdaCase #-} +{-# language MagicHash #-} +{-# language UnboxedTuples #-} + +-- This provides an interface to bytearrays in which every +-- boolean is represented by a full byte, not a bit. This +-- can waste space, so depending on your use case, you may +-- want something different. +module Basics.Bool + ( -- Types + T + , T# + , R + -- Lifting + , lift + , unlift + -- Compare + , eq# + , neq# + -- Array + , read# + , write# + , index# + , set# + , uninitialized# + , initialized# + , copy# + , copyMutable# + , shrink# + -- Constants + , def + -- Metadata + , size + -- Encoding + , shows + ) where + +import Prelude hiding (shows) + +import GHC.Exts (RuntimeRep(IntRep)) +import GHC.Exts (Int#,State#,MutableByteArray#,ByteArray#) + +import qualified Prelude +import qualified GHC.Exts as Exts + +type T = Bool +type T# = Int# +type R = 'IntRep + +def :: T +{-# inline def #-} +def = False + +size :: Int +{-# inline size #-} +size = 1 + +lift :: T# -> T +{-# inline lift #-} +lift x = Exts.tagToEnum# x :: Bool + +unlift :: T -> T# +{-# inline unlift #-} +unlift = \case + True -> 1# + False -> 0# + +eq# :: Int# -> Int# -> Int# +{-# inline eq# #-} +eq# = (Exts.==#) + +neq# :: Int# -> Int# -> Int# +{-# inline neq# #-} +neq# = (Exts./=#) + +index# :: ByteArray# -> Int# -> T# +{-# inline index# #-} +index# arr i = Exts.int8ToInt# (Exts.indexInt8Array# arr i) + +read# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, T# #) +{-# inline read# #-} +read# arr i st = + let !(# st', v #) = Exts.readInt8Array# arr i st + in (# st', Exts.int8ToInt# v #) + +write# :: MutableByteArray# s -> Int# -> T# -> State# s -> State# s +{-# inline write# #-} +write# arr i v st = Exts.writeInt8Array# arr i (Exts.intToInt8# v) st + +set# :: MutableByteArray# s -> Int# -> Int# -> T# -> State# s -> State# s +{-# inline set# #-} +set# = Exts.setByteArray# + +shrink# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, MutableByteArray# s #) +{-# inline shrink# #-} +shrink# m i s = (# Exts.shrinkMutableByteArray# m i s, m #) + +uninitialized# :: Int# -> State# s -> (# State# s, MutableByteArray# s #) +{-# inline uninitialized# #-} +uninitialized# = Exts.newByteArray# + +initialized# :: Int# -> T# -> State# s -> (# State# s, MutableByteArray# s #) +{-# inline initialized# #-} +initialized# n e s0 = case Exts.newByteArray# n s0 of + (# s1, a #) -> case set# a 0# n e s1 of + s2 -> (# s2, a #) + +copy# :: MutableByteArray# s -> Int# -> ByteArray# -> Int# -> Int# -> State# s -> State# s +{-# inline copy# #-} +copy# dst doff src soff len = + Exts.copyByteArray# src soff dst doff len + +copyMutable# :: MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s +{-# inline copyMutable# #-} +copyMutable# dst doff src soff len = + Exts.copyMutableByteArray# src soff dst doff len + +shows :: T -> String -> String +shows = Prelude.shows diff --git a/src/Basics/ByteArray.hs b/src/Basics/ByteArray.hs new file mode 100644 --- /dev/null +++ b/src/Basics/ByteArray.hs @@ -0,0 +1,81 @@ +{-# language DataKinds #-} +{-# language MagicHash #-} +{-# language UnboxedTuples #-} + +-- This can be used with vex-indef as either the element module +-- or the array module. +module Basics.ByteArray + ( -- Types + A + , M + , R + , A# + , M# + -- Element Types + , T + , T# + -- Lifting + , lift + , unlift + , liftMutable + , unliftMutable + -- Array + , unsafeFreeze# + -- Array Element + , read# + , write# + , index# + , set# + ) where + +import GHC.Exts hiding (setByteArray#) +import Data.Primitive (ByteArray(..),MutableByteArray(..)) + +import qualified GHC.Exts as Exts + +type A = ByteArray +type A# = ByteArray# +type M = MutableByteArray +type M# = MutableByteArray# +type R = 'BoxedRep 'Unlifted + +type T = ByteArray +type T# = ByteArray# + +lift :: A# -> A +{-# inline lift #-} +lift = ByteArray + +unlift :: A -> A# +{-# inline unlift #-} +unlift (ByteArray i) = i + +liftMutable :: M# s -> M s +{-# inline liftMutable #-} +liftMutable = MutableByteArray + +unliftMutable :: M s -> M# s +{-# inline unliftMutable #-} +unliftMutable (MutableByteArray i) = i + +unsafeFreeze# :: M# s -> State# s -> (# State# s, A# #) +{-# inline unsafeFreeze# #-} +unsafeFreeze# = unsafeFreezeByteArray# + +index# :: ArrayArray# -> Int# -> T# +{-# inline index# #-} +index# = Exts.indexByteArrayArray# + +read# :: MutableArrayArray# s -> Int# -> State# s -> (# State# s, T# #) +{-# inline read# #-} +read# = Exts.readByteArrayArray# + +write# :: MutableArrayArray# s -> Int# -> T# -> State# s -> State# s +{-# inline write# #-} +write# = Exts.writeByteArrayArray# + +set# :: MutableArrayArray# s -> Int# -> Int# -> T# -> State# s -> State# s +{-# inline set# #-} +set# marr off len x s = case len of + 0# -> s + _ -> set# marr (off +# 1# ) (len -# 1# ) x (write# marr off x s) diff --git a/src/Basics/Char.hs b/src/Basics/Char.hs new file mode 100644 --- /dev/null +++ b/src/Basics/Char.hs @@ -0,0 +1,62 @@ +{-# language DataKinds #-} +{-# language MagicHash #-} +{-# language UnboxedTuples #-} + +module Basics.Char + ( -- Types + T + , T# + , R + -- Lifting + , lift + , unlift + -- Array + , read# + , write# + , index# + , set# + , shrink# + -- Constants + , def + -- Metadata + , size + ) where + +import GHC.Exts hiding (setByteArray#) + +import qualified Foreign.Storable as FS +import qualified GHC.Exts as Exts + +type T = Char +type T# = Char# +type R = 'WordRep + +def :: T +def = 'z' + +size :: Int +size = FS.sizeOf (undefined :: T) + +lift :: T# -> T +lift = C# + +unlift :: T -> T# +unlift (C# i) = i + +index# :: ByteArray# -> Int# -> T# +index# = indexWideCharArray# + +read# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, T# #) +read# = readWideCharArray# + +write# :: MutableByteArray# s -> Int# -> T# -> State# s -> State# s +write# = writeWideCharArray# + +set# :: MutableByteArray# s -> Int# -> Int# -> T# -> State# s -> State# s +set# marr off len x s = case len of + 0# -> s + _ -> set# marr (off +# 1# ) (len -# 1# ) x (write# marr off x s) + +shrink# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, MutableByteArray# s #) +shrink# m i s0 = (# Exts.shrinkMutableByteArray# m (i *# 4#) s0, m #) + diff --git a/src/Basics/Int.hs b/src/Basics/Int.hs new file mode 100644 --- /dev/null +++ b/src/Basics/Int.hs @@ -0,0 +1,236 @@ +{-# language DataKinds #-} +{-# language MagicHash #-} +{-# language UnboxedTuples #-} + +module Basics.Int + ( -- Types + T + , T# + , R + -- Lifting + , lift + , unlift + -- Arithmetic + , plus + , minus + , plus# + , minus# + , times# + , quot# + , rem# + -- Compare + , gt# + , lt# + , gte# + , lte# + , eq# + , neq# + , gt + , lt + , gte + , lte + , eq + , neq + -- Array + , read# + , write# + , index# + , set# + , uninitialized# + , initialized# + , uninitialized + , initialized + , copy# + , copyMutable# + , shrink# + -- Constants + , zero + , def + -- Metadata + , signed + , size + -- Encoding + , shows + ) where + +import Prelude hiding (shows) + +import Data.Primitive (MutableByteArray(..)) +import GHC.Exts ((+#),(*#),(-#)) +import GHC.Exts (Int(I#),RuntimeRep(IntRep)) +import GHC.Exts (State#,MutableByteArray#,Int#,ByteArray#) +import GHC.ST (ST(ST)) + +import qualified Prelude +import qualified GHC.Exts as Exts +import qualified Foreign.Storable as FS + +type T = Int +type T# = Int# +type R = 'IntRep + +def :: T +{-# inline def #-} +def = 0 + +zero :: T +{-# inline zero #-} +zero = 0 + +size :: Int +{-# inline size #-} +size = FS.sizeOf (undefined :: Int) + +signed :: Bool +{-# inline signed #-} +signed = True + +lift :: T# -> T +{-# inline lift #-} +lift = I# + +unlift :: T -> T# +{-# inline unlift #-} +unlift (I# i) = i + +plus :: T -> T -> T +{-# inline plus #-} +plus (I# x) (I# y) = I# (x +# y) + +minus :: T -> T -> T +{-# inline minus #-} +minus (I# x) (I# y) = I# (x -# y) + +times# :: T# -> T# -> T# +{-# inline times# #-} +times# = (*#) + +quot# :: T# -> T# -> T# +{-# inline quot# #-} +quot# = Exts.quotInt# + +rem# :: T# -> T# -> T# +{-# inline rem# #-} +rem# = Exts.remInt# + +plus# :: T# -> T# -> T# +{-# inline plus# #-} +plus# = (+#) + +minus# :: T# -> T# -> T# +{-# inline minus# #-} +minus# = (-#) + +gt# :: T# -> T# -> Int# +{-# inline gt# #-} +gt# = (Exts.>#) + +lt# :: T# -> T# -> Int# +{-# inline lt# #-} +lt# = (Exts.<#) + +gte# :: T# -> T# -> Int# +{-# inline gte# #-} +gte# = (Exts.>=#) + +lte# :: T# -> T# -> Int# +{-# inline lte# #-} +lte# = (Exts.<=#) + +eq# :: T# -> T# -> Int# +{-# inline eq# #-} +eq# = (Exts.==#) + +neq# :: T# -> T# -> Int# +{-# inline neq# #-} +neq# = (Exts./=#) + +gt :: T -> T -> Bool +{-# inline gt #-} +gt = (>) + +lt :: T -> T -> Bool +{-# inline lt #-} +lt = (<) + +gte :: T -> T -> Bool +{-# inline gte #-} +gte = (>=) + +lte :: T -> T -> Bool +{-# inline lte #-} +lte = (<=) + +eq :: T -> T -> Bool +{-# inline eq #-} +eq = (==) + +neq :: T -> T -> Bool +{-# inline neq #-} +neq = (/=) + +index# :: ByteArray# -> Int# -> T# +{-# inline index# #-} +index# = Exts.indexIntArray# + +read# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, T# #) +{-# inline read# #-} +read# = Exts.readIntArray# + +write# :: MutableByteArray# s -> Int# -> T# -> State# s -> State# s +{-# inline write# #-} +write# = Exts.writeIntArray# + +set# :: MutableByteArray# s -> Int# -> Int# -> T# -> State# s -> State# s +{-# inline set# #-} +set# marr off len x s = case len of + 0# -> s + _ -> set# marr (off +# 1# ) (len -# 1# ) x (write# marr off x s) + +uninitialized# :: Int# -> State# s -> (# State# s, MutableByteArray# s #) +{-# inline uninitialized# #-} +uninitialized# sz = Exts.newByteArray# (sz *# (case size of I# i -> i)) + +initialized# :: + Int# -> T# -> State# s + -> (# State# s, MutableByteArray# s #) +{-# inline initialized# #-} +initialized# n e s0 = case uninitialized# n s0 of + (# s1, a #) -> case set# a 0# n e s1 of + s2 -> (# s2, a #) + +uninitialized :: Int -> ST s (MutableByteArray s) +{-# inline uninitialized #-} +uninitialized (I# sz) = ST $ \s0 -> case uninitialized# sz s0 of + (# s1, a #) -> (# s1, MutableByteArray a #) + +initialized :: Int -> T -> ST s (MutableByteArray s) +{-# inline initialized #-} +initialized (I# sz) e = ST $ \s0 -> case initialized# sz (unlift e) s0 of + (# s1, a #) -> (# s1, MutableByteArray a #) + +copy# :: MutableByteArray# s -> Int# -> ByteArray# -> Int# -> Int# -> State# s -> State# s +{-# inline copy# #-} +copy# dst doff src soff len = Exts.copyByteArray# + src + (soff *# (case size of I# i -> i)) + dst + (doff *# (case size of I# i -> i)) + (len *# (case size of I# i -> i)) + +copyMutable# :: MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s +{-# inline copyMutable# #-} +copyMutable# dst doff src soff len = Exts.copyMutableByteArray# + src + (soff *# (case size of I# i -> i)) + dst + (doff *# (case size of I# i -> i)) + (len *# (case size of I# i -> i)) + +shrink# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, MutableByteArray# s #) +{-# inline shrink# #-} +shrink# m i s0 = (# Exts.shrinkMutableByteArray# m (i *# (case size of I# sz -> sz)) s0, m #) + +shows :: T -> String -> String +{-# inline shows #-} +shows = Prelude.shows diff --git a/src/Basics/Int64.hs b/src/Basics/Int64.hs new file mode 100644 --- /dev/null +++ b/src/Basics/Int64.hs @@ -0,0 +1,267 @@ +{-# language DataKinds #-} +{-# language MagicHash #-} +{-# language UnboxedTuples #-} + +module Basics.Int64 + ( -- Types + T + , T# + , R + -- Lifting + , lift + , unlift + -- Arithmetic + , plus + , minus + , plus# + , minus# + , times# + , quot# + , rem# + -- Compare + , gt# + , lt# + , gte# + , lte# + , eq# + , neq# + , gt + , lt + , gte + , lte + , eq + , neq + -- Array + , read# + , write# + , index# + , read + , write + , index + , uninitialized# + , initialized# + , uninitialized + , initialized + , copy# + , copyMutable# + , set# + , shrink# + , shrink + -- Constants + , zero + , def + , minBound + , maxBound + , infimum + , supremum + -- Metadata + , signed + -- Encoding + , shows + ) where + +import Prelude hiding (shows,maxBound,minBound,read) + +import GHC.Exts +import GHC.Int +import Data.Primitive (MutableByteArray(..),ByteArray(..)) +import GHC.ST (ST(ST)) + +import qualified Prelude +import qualified GHC.Exts as Exts + +type T = Int64 +type T# = Int# +type R = 'IntRep + +def :: T +{-# inline def #-} +def = 0 + +zero :: T +{-# inline zero #-} +zero = 0 + +minBound :: T +{-# inline minBound #-} +minBound = I64# (-9223372036854775808#) + +maxBound :: T +{-# inline maxBound #-} +maxBound = I64# (9223372036854775807#) + +infimum :: T +{-# inline infimum #-} +infimum = I64# (-9223372036854775808#) + +supremum :: T +{-# inline supremum #-} +supremum = I64# (9223372036854775807#) + +signed :: Bool +{-# inline signed #-} +signed = True + +lift :: T# -> T +{-# inline lift #-} +lift = I64# + +unlift :: T -> T# +{-# inline unlift #-} +unlift (I64# i) = i + +plus :: T -> T -> T +{-# inline plus #-} +plus (I64# x) (I64# y) = I64# (x +# y) + +minus :: T -> T -> T +{-# inline minus #-} +minus (I64# x) (I64# y) = I64# (x -# y) + +times# :: T# -> T# -> T# +{-# inline times# #-} +times# = (*#) + +quot# :: T# -> T# -> T# +{-# inline quot# #-} +quot# = quotInt# + +rem# :: T# -> T# -> T# +{-# inline rem# #-} +rem# = remInt# + +plus# :: T# -> T# -> T# +{-# inline plus# #-} +plus# = (+#) + +minus# :: T# -> T# -> T# +{-# inline minus# #-} +minus# = (-#) + +gt# :: T# -> T# -> Int# +{-# inline gt# #-} +gt# = (>#) + +lt# :: T# -> T# -> Int# +{-# inline lt# #-} +lt# = (<#) + +gte# :: T# -> T# -> Int# +{-# inline gte# #-} +gte# = (>=#) + +lte# :: T# -> T# -> Int# +{-# inline lte# #-} +lte# = (<=#) + +eq# :: T# -> T# -> Int# +{-# inline eq# #-} +eq# = (==#) + +neq# :: T# -> T# -> Int# +{-# inline neq# #-} +neq# = (/=#) + +gt :: T -> T -> Bool +{-# inline gt #-} +gt = (>) + +lt :: T -> T -> Bool +{-# inline lt #-} +lt = (<) + +gte :: T -> T -> Bool +{-# inline gte #-} +gte = (>=) + +lte :: T -> T -> Bool +{-# inline lte #-} +lte = (<=) + +eq :: T -> T -> Bool +{-# inline eq #-} +eq = (==) + +neq :: T -> T -> Bool +{-# inline neq #-} +neq = (/=) + +index# :: ByteArray# -> Int# -> T# +{-# inline index# #-} +index# = indexIntArray# + +read# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, T# #) +{-# inline read# #-} +read# = readIntArray# + +write# :: MutableByteArray# s -> Int# -> T# -> State# s -> State# s +{-# inline write# #-} +write# = writeIntArray# + +set# :: MutableByteArray# s -> Int# -> Int# -> T# -> State# s -> State# s +{-# inline set# #-} +set# marr off len x s = case len of + 0# -> s + _ -> set# marr (off +# 1# ) (len -# 1# ) x (write# marr off x s) + +uninitialized# :: Int# -> State# s -> (# State# s, MutableByteArray# s #) +{-# inline uninitialized# #-} +uninitialized# sz = Exts.newByteArray# (sz *# 8# ) + +initialized# :: + Int# -> T# -> State# s + -> (# State# s, MutableByteArray# s #) +{-# inline initialized# #-} +initialized# n e s0 = case uninitialized# n s0 of + (# s1, a #) -> case set# a 0# n e s1 of + s2 -> (# s2, a #) + +uninitialized :: Int -> ST s (MutableByteArray s) +{-# inline uninitialized #-} +uninitialized (I# sz) = ST $ \s0 -> case uninitialized# sz s0 of + (# s1, a #) -> (# s1, MutableByteArray a #) + +initialized :: Int -> T -> ST s (MutableByteArray s) +{-# inline initialized #-} +initialized (I# sz) e = ST $ \s0 -> case initialized# sz (unlift e) s0 of + (# s1, a #) -> (# s1, MutableByteArray a #) + +shrink# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, MutableByteArray# s #) +{-# inline shrink# #-} +shrink# m i s0 = (# Exts.shrinkMutableByteArray# m (i *# 8#) s0, m #) + +copy# :: MutableByteArray# s -> Int# -> ByteArray# -> Int# -> Int# -> State# s -> State# s +{-# inline copy# #-} +copy# dst doff src soff len = + Exts.copyByteArray# src (soff *# 8#) dst (doff *# 8#) (len *# 8#) + +copyMutable# :: MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s +{-# inline copyMutable# #-} +copyMutable# dst doff src soff len = + Exts.copyMutableByteArray# src (soff *# 8#) dst (doff *# 8#) (len *# 8#) + +shows :: T -> String -> String +{-# inline shows #-} +shows = Prelude.shows + +index :: ByteArray -> Int -> T +{-# inline index #-} +index (ByteArray x) (I# i) = I64# (indexInt64Array# x i) + +read :: MutableByteArray s -> Int -> ST s T +{-# inline read #-} +read (MutableByteArray x) (I# i) = ST + (\s0 -> case readInt64Array# x i s0 of + (# s1, r #) -> (# s1, I64# r #) + ) + +write :: MutableByteArray s -> Int -> T -> ST s () +{-# inline write #-} +write (MutableByteArray x) (I# i) (I64# e) = ST (\s -> (# writeInt64Array# x i e s, () #) ) + +shrink :: MutableByteArray s -> Int -> ST s (MutableByteArray s) +{-# inline shrink #-} +shrink (MutableByteArray x) (I# i) = ST + (\s0 -> case shrink# x i s0 of + (# s1, r #) -> (# s1, MutableByteArray r #) + ) diff --git a/src/Basics/Int8.hs b/src/Basics/Int8.hs new file mode 100644 --- /dev/null +++ b/src/Basics/Int8.hs @@ -0,0 +1,188 @@ +{-# language BangPatterns #-} +{-# language DataKinds #-} +{-# language MagicHash #-} +{-# language UnboxedTuples #-} + +module Basics.Int8 + ( -- Types + T + , T# + , R + -- Lifting + , lift + , unlift + -- Compare + , gt# + , lt# + , gte# + , lte# + , eq# + , neq# + , gt + , lt + , gte + , lte + , eq + , neq + -- Array + , read# + , write# + , index# + , set# + , uninitialized# + , initialized# + , uninitialized + , initialized + , copy# + , copyMutable# + , shrink# + -- Constants + , zero + , def + -- Metadata + , signed + , size + -- Encoding + , shows + ) where + +import Prelude hiding (shows) + +import Data.Primitive (MutableByteArray(..)) +import GHC.Exts hiding (setByteArray#) +import GHC.Int +import GHC.ST (ST(ST)) + +import qualified Prelude +import qualified GHC.Exts as Exts + +type T = Int8 +type T# = Int# +type R = 'IntRep + +def :: T +{-# inline def #-} +def = 0 + +zero :: T +{-# inline zero #-} +zero = 0 + +signed :: Bool +{-# inline signed #-} +signed = False + +size :: Int +{-# inline size #-} +size = 1 + +lift :: T# -> T +{-# inline lift #-} +lift i = I8# (Exts.intToInt8# i) + +unlift :: T -> T# +{-# inline unlift #-} +unlift (I8# i) = Exts.int8ToInt# i + +gt# :: T# -> T# -> Int# +{-# inline gt# #-} +gt# = (>#) + +lt# :: T# -> T# -> Int# +{-# inline lt# #-} +lt# = (<#) + +gte# :: T# -> T# -> Int# +{-# inline gte# #-} +gte# = (>=#) + +lte# :: T# -> T# -> Int# +{-# inline lte# #-} +lte# = (<=#) + +eq# :: T# -> T# -> Int# +{-# inline eq# #-} +eq# = (==#) + +neq# :: T# -> T# -> Int# +{-# inline neq# #-} +neq# = (/=#) + +gt :: T -> T -> Bool +{-# inline gt #-} +gt = (>) + +lt :: T -> T -> Bool +{-# inline lt #-} +lt = (<) + +gte :: T -> T -> Bool +{-# inline gte #-} +gte = (>=) + +lte :: T -> T -> Bool +{-# inline lte #-} +lte = (<=) + +eq :: T -> T -> Bool +{-# inline eq #-} +eq = (==) + +neq :: T -> T -> Bool +{-# inline neq #-} +neq = (/=) + +index# :: ByteArray# -> Int# -> T# +{-# inline index# #-} +index# arr i = Exts.int8ToInt# (indexInt8Array# arr i) + +read# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, T# #) +{-# inline read# #-} +read# arr i st = + let !(# st', v #) = readInt8Array# arr i st + in (# st', Exts.int8ToInt# v #) + +write# :: MutableByteArray# s -> Int# -> T# -> State# s -> State# s +{-# inline write# #-} +write# arr i v st = writeInt8Array# arr i (Exts.intToInt8# v) st + +set# :: MutableByteArray# s -> Int# -> Int# -> T# -> State# s -> State# s +{-# inline set# #-} +set# marr off len x s = Exts.setByteArray# marr off len x s + +shrink# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, MutableByteArray# s #) +{-# inline shrink# #-} +shrink# m i s = (# Exts.shrinkMutableByteArray# m i s, m #) + +uninitialized# :: Int# -> State# s -> (# State# s, MutableByteArray# s #) +{-# inline uninitialized# #-} +uninitialized# = Exts.newByteArray# + +uninitialized :: Int -> ST s (MutableByteArray s) +{-# inline uninitialized #-} +uninitialized (I# sz) = ST $ \s0 -> case uninitialized# sz s0 of + (# s1, a #) -> (# s1, MutableByteArray a #) + +initialized :: Int -> T -> ST s (MutableByteArray s) +{-# inline initialized #-} +initialized (I# sz) e = ST $ \s0 -> case initialized# sz (unlift e) s0 of + (# s1, a #) -> (# s1, MutableByteArray a #) + +copy# :: MutableByteArray# s -> Int# -> ByteArray# -> Int# -> Int# -> State# s -> State# s +{-# inline copy# #-} +copy# dst doff src soff len = + Exts.copyByteArray# src soff dst doff len + +copyMutable# :: MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s +{-# inline copyMutable# #-} +copyMutable# dst doff src soff len = + Exts.copyMutableByteArray# src soff dst doff len + +initialized# :: Int# -> T# -> State# s -> (# State# s, MutableByteArray# s #) +{-# inline initialized# #-} +initialized# n e s0 = case Exts.newByteArray# n s0 of + (# s1, a #) -> case set# a 0# n e s1 of + s2 -> (# s2, a #) + +shows :: T -> String -> String +shows = Prelude.shows diff --git a/src/Basics/ShortText.hs b/src/Basics/ShortText.hs new file mode 100644 --- /dev/null +++ b/src/Basics/ShortText.hs @@ -0,0 +1,119 @@ +{-# language BangPatterns #-} +{-# language DataKinds #-} +{-# language MagicHash #-} +{-# language UnboxedTuples #-} + +module Basics.ShortText + ( -- Types + T + , T# + , R + -- Lifting + , lift + , unlift + -- Array + , read# + , write# + , index# + , uninitialized# + , initialized# + , copy# + , copyMutable# + , set# + , shrink# + , eq# + , neq# + -- Encode + , shows + ) where + +import Prelude hiding (shows) + +import GHC.Exts hiding (setByteArray#) +import Data.ByteString.Short.Internal (ShortByteString(SBS)) +import Data.Text.Short (ShortText) + +import qualified Prelude +import qualified GHC.Exts as Exts +import qualified Data.Text.Short as TS +import qualified Data.Text.Short.Unsafe as TS + +type T = ShortText +type T# = ByteArray# +type R = 'BoxedRep 'Unlifted + +lift :: T# -> T +{-# inline lift #-} +lift x = TS.fromShortByteStringUnsafe (SBS x) + +unlift :: T -> T# +{-# inline unlift #-} +unlift t = case TS.toShortByteString t of { SBS x -> x } + +index# :: ArrayArray# -> Int# -> T# +{-# inline index# #-} +index# = Exts.indexByteArrayArray# + +read# :: MutableArrayArray# s -> Int# -> State# s -> (# State# s, T# #) +{-# inline read# #-} +read# = Exts.readByteArrayArray# + +write# :: MutableArrayArray# s -> Int# -> T# -> State# s -> State# s +{-# inline write# #-} +write# = Exts.writeByteArrayArray# + +set# :: MutableArrayArray# s -> Int# -> Int# -> T# -> State# s -> State# s +{-# inline set# #-} +set# marr off len x s = case len of + 0# -> s + _ -> set# marr (off +# 1# ) (len -# 1# ) x (write# marr off x s) + +-- | This is very unsafe. +uninitialized# :: Int# -> State# s -> (# State# s, MutableArrayArray# s #) +{-# inline uninitialized# #-} +uninitialized# = Exts.newArrayArray# + +initialized# :: + Int# -> T# -> State# s + -> (# State# s, MutableArrayArray# s #) +{-# inline initialized# #-} +initialized# n e s0 = case uninitialized# n s0 of + (# s1, a #) -> case set# a 0# n e s1 of + s2 -> (# s2, a #) + +copy# :: MutableArrayArray# s -> Int# -> ArrayArray# -> Int# -> Int# -> State# s -> State# s +{-# inline copy# #-} +copy# dst doff src soff len = + Exts.copyArrayArray# src soff dst doff len + +copyMutable# :: MutableArrayArray# s -> Int# -> MutableArrayArray# s -> Int# -> Int# -> State# s -> State# s +{-# inline copyMutable# #-} +copyMutable# dst doff src soff len = + Exts.copyMutableArrayArray# src soff dst doff len + +shrink# :: MutableArrayArray# s -> Int# -> State# s -> (# State# s, MutableArrayArray# s #) +{-# inline shrink# #-} +shrink# m sz s0 = case uninitialized# sz s0 of + (# s1, dst #) -> case copyMutable# dst 0# m 0# sz s1 of + s2 -> (# s2, dst #) + +eq# :: ByteArray# -> ByteArray# -> Int# +{-# inline eq# #-} +eq# a b = case lenA ==# lenB of + 1# -> Exts.compareByteArrays# a 0# b 0# lenA ==# 0# + _ -> 0# + where + !lenA = Exts.sizeofByteArray# a + !lenB = Exts.sizeofByteArray# b + +neq# :: ByteArray# -> ByteArray# -> Int# +{-# inline neq# #-} +neq# a b = case lenA ==# lenB of + 1# -> Exts.compareByteArrays# a 0# b 0# lenA /=# 0# + _ -> 1# + where + !lenA = Exts.sizeofByteArray# a + !lenB = Exts.sizeofByteArray# b + +shows :: T -> String -> String +shows = Prelude.shows diff --git a/src/Basics/ShortTexts.hs b/src/Basics/ShortTexts.hs new file mode 100644 --- /dev/null +++ b/src/Basics/ShortTexts.hs @@ -0,0 +1,128 @@ +{-# language BangPatterns #-} +{-# language DataKinds #-} +{-# language MagicHash #-} +{-# language UnboxedTuples #-} + +module Basics.ShortTexts + ( -- Types + T + , T# + , R + -- Lifting + , lift + , unlift + -- Array + , read# + , write# + , index# + , uninitialized# + , initialized# + , copy# + , copyMutable# + , set# + , shrink# + , eq# + , neq# + -- Encode + , shows + ) where + +import Prelude hiding (shows) + +import GHC.Exts hiding (setByteArray#) +import Data.Primitive.Unlifted.Array (UnliftedArray(..)) +import Data.Text.Short (ShortText) + +import qualified GHC.Exts as Exts + +type T = UnliftedArray ShortText +type T# = ArrayArray# +type R = 'BoxedRep 'Unlifted + +lift :: T# -> T +{-# inline lift #-} +lift = UnliftedArray + +unlift :: T -> T# +{-# inline unlift #-} +unlift (UnliftedArray x) = x + +index# :: ArrayArray# -> Int# -> T# +{-# inline index# #-} +index# = Exts.indexArrayArrayArray# + +read# :: MutableArrayArray# s -> Int# -> State# s -> (# State# s, T# #) +{-# inline read# #-} +read# = Exts.readArrayArrayArray# + +write# :: MutableArrayArray# s -> Int# -> T# -> State# s -> State# s +{-# inline write# #-} +write# = Exts.writeArrayArrayArray# + +set# :: MutableArrayArray# s -> Int# -> Int# -> T# -> State# s -> State# s +{-# inline set# #-} +set# marr off len x s = case len of + 0# -> s + _ -> set# marr (off +# 1# ) (len -# 1# ) x (write# marr off x s) + +-- | This is very unsafe. +uninitialized# :: Int# -> State# s -> (# State# s, MutableArrayArray# s #) +{-# inline uninitialized# #-} +uninitialized# = Exts.newArrayArray# + +initialized# :: + Int# -> T# -> State# s + -> (# State# s, MutableArrayArray# s #) +{-# inline initialized# #-} +initialized# n e s0 = case uninitialized# n s0 of + (# s1, a #) -> case set# a 0# n e s1 of + s2 -> (# s2, a #) + +copy# :: MutableArrayArray# s -> Int# -> ArrayArray# -> Int# -> Int# -> State# s -> State# s +{-# inline copy# #-} +copy# dst doff src soff len = + Exts.copyArrayArray# src soff dst doff len + +copyMutable# :: MutableArrayArray# s -> Int# -> MutableArrayArray# s -> Int# -> Int# -> State# s -> State# s +{-# inline copyMutable# #-} +copyMutable# dst doff src soff len = + Exts.copyMutableArrayArray# src soff dst doff len + +shrink# :: MutableArrayArray# s -> Int# -> State# s -> (# State# s, MutableArrayArray# s #) +{-# inline shrink# #-} +shrink# m sz s0 = case uninitialized# sz s0 of + (# s1, dst #) -> case copyMutable# dst 0# m 0# sz s1 of + s2 -> (# s2, dst #) + +-- We do not forcibly inline this because it might be useful to see this +-- in profiling runs. +eq# :: ArrayArray# -> ArrayArray# -> Int# +eq# a b = case lenA ==# lenB of + 1# -> + let go (-1#) = 1# + go ix = + let x = Exts.indexByteArrayArray# a ix + y = Exts.indexByteArrayArray# b ix + lenX = Exts.sizeofByteArray# x + lenY = Exts.sizeofByteArray# y + in case lenX ==# lenY of + 1# -> case Exts.compareByteArrays# x 0# y 0# lenX of + 0# -> go (ix -# 1#) + _ -> 0# + _ -> 0# + in go (lenA -# 1#) + _ -> 0# + where + !lenA = Exts.sizeofArrayArray# a + !lenB = Exts.sizeofArrayArray# b + +neq# :: ArrayArray# -> ArrayArray# -> Int# +{-# inline neq# #-} +neq# a b = case eq# a b of + 1# -> 0# + _ -> 1# + +-- TODO: fix this +shows :: T -> String -> String +{-# inline shows #-} +shows _ s = "[...]" ++ s diff --git a/src/Basics/Word.hs b/src/Basics/Word.hs new file mode 100644 --- /dev/null +++ b/src/Basics/Word.hs @@ -0,0 +1,107 @@ +{-# language DataKinds #-} +{-# language MagicHash #-} +{-# language UnboxedTuples #-} + +module Basics.Word + ( -- Types + T + , T# + , R + -- Lifting + , lift + , unlift + -- Arithmetic + , plus + , minus + , plus# + , minus# + , times# + , quot# + , rem# + -- Compare + , gt# + , lt# + , gte# + , lte# + , eq# + , neq# + -- Array + , readByteArray# + , writeByteArray# + , indexByteArray# + , shrink# + -- Metadata + , signed + , size + ) where + +import GHC.Exts +import qualified GHC.Exts as Exts +import qualified Foreign.Storable as FS + +type T = Word +type T# = Word# +type R = 'WordRep + +size :: Int +size = FS.sizeOf (undefined :: Word) + +signed :: Bool +signed = False + +lift :: T# -> T +lift = W# + +unlift :: T -> T# +unlift (W# i) = i + +plus :: T -> T -> T +plus (W# x) (W# y) = W# (plusWord# x y) + +minus :: T -> T -> T +minus (W# x) (W# y) = W# (minusWord# x y) + +times# :: T# -> T# -> T# +times# = timesWord# + +quot# :: T# -> T# -> T# +quot# = quotWord# + +rem# :: T# -> T# -> T# +rem# = remWord# + +plus# :: T# -> T# -> T# +plus# = plusWord# + +minus# :: T# -> T# -> T# +minus# = minusWord# + +gt# :: T# -> T# -> Int# +gt# = gtWord# + +lt# :: T# -> T# -> Int# +lt# = ltWord# + +gte# :: T# -> T# -> Int# +gte# = geWord# + +lte# :: T# -> T# -> Int# +lte# = leWord# + +eq# :: T# -> T# -> Int# +eq# = eqWord# + +neq# :: T# -> T# -> Int# +neq# = neWord# + +indexByteArray# :: ByteArray# -> Int# -> T# +indexByteArray# = indexWordArray# + +readByteArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, T# #) +readByteArray# = readWordArray# + +writeByteArray# :: MutableByteArray# s -> Int# -> T# -> State# s -> State# s +writeByteArray# = writeWordArray# + +shrink# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, MutableByteArray# s #) +shrink# m i s0 = (# Exts.shrinkMutableByteArray# m (i *# (case size of I# sz -> sz)) s0, m #) diff --git a/src/Basics/Word128.hs b/src/Basics/Word128.hs new file mode 100644 --- /dev/null +++ b/src/Basics/Word128.hs @@ -0,0 +1,276 @@ +{-# language CPP #-} +{-# language DataKinds #-} +{-# language MagicHash #-} +{-# language TypeApplications #-} +{-# language UnboxedTuples #-} +{-# language ViewPatterns #-} + +#include + +module Basics.Word128 + ( -- Types + T + , T# + , R + -- Lifting + , lift + , unlift + -- Compare + , eq# + , neq# + , lt# + , lte# + , gt# + , gt + , gte + , lt + , lte + , eq + , neq + -- Arithmetic + , minus# + , quot# + -- Array + , read# + , write# + , index# + , read + , write + , index + , set# + , uninitialized# + , initialized# + , uninitialized + , initialized + , copy# + , copyMutable# + , shrink# + , shrink + -- Constants + , def + , zero + , minBound + , maxBound + -- Metadata + , size + -- Encoding + , shows + ) where + +import Prelude hiding (shows,minBound,maxBound,read) + +import Data.Primitive (MutableByteArray(..),ByteArray(..)) +import Data.WideWord.Word128 (Word128(Word128)) +import GHC.Exts hiding (setByteArray#) +import GHC.ST (ST(ST)) +import GHC.Word (Word64(W64#)) + +import qualified Prelude +import qualified GHC.Exts as Exts + +type T = Word128 +type T# = (# Word#, Word# #) +type R = 'TupleRep '[ 'WordRep, 'WordRep ] + +def :: T +{-# inline def #-} +def = 0 + +zero :: T +{-# inline zero #-} +zero = 0 + +maxBound :: T +{-# inline maxBound #-} +maxBound = Word128 18446744073709551615 18446744073709551615 + +minBound :: T +{-# inline minBound #-} +minBound = 0 + +size :: Int +{-# inline size #-} +size = 16 + +lt# :: T# -> T# -> Int# +{-# inline lt# #-} +lt# (# a1, a2 #) (# b1, b2 #) = case ltWord# a1 b1 of + 1# -> 1# + _ -> case eqWord# a1 b1 of + 1# -> ltWord# a2 b2 + _ -> 0# + +gt# :: T# -> T# -> Int# +{-# inline gt# #-} +gt# (# a1, a2 #) (# b1, b2 #) = case gtWord# a1 b1 of + 1# -> 1# + _ -> case eqWord# a1 b1 of + 1# -> gtWord# a2 b2 + _ -> 0# + +gt :: T -> T -> Bool +{-# inline gt #-} +gt = (>) + +lt :: T -> T -> Bool +{-# inline lt #-} +lt = (<) + +gte :: T -> T -> Bool +{-# inline gte #-} +gte = (>=) + +lte :: T -> T -> Bool +{-# inline lte #-} +lte = (<=) + +lte# :: T# -> T# -> Int# +{-# inline lte# #-} +lte# (# a1, a2 #) (# b1, b2 #) = case ltWord# a1 a2 of + 1# -> 1# + _ -> case eqWord# a1 b1 of + 1# -> leWord# a2 b2 + _ -> 0# + +quot# :: T# -> T# -> T# +{-# inline quot# #-} +quot# (# a1, a2 #) (# b1, b2 #) = + case quot (Word128 (W64# a1) (W64# a2)) (Word128 (W64# b1) (W64# b2)) of + Word128 (W64# c1) (W64# c2) -> (# c1, c2 #) + +minus# :: T# -> T# -> T# +{-# inline minus# #-} +minus# (# a1, a2 #) (# b1, b2 #) = + case (Word128 (W64# a1) (W64# a2)) - (Word128 (W64# b1) (W64# b2)) of + Word128 (W64# c1) (W64# c2) -> (# c1, c2 #) + +lift :: T# -> T +{-# inline lift #-} +lift (# a, b #) = Word128 (W64# a) (W64# b) + +unlift :: T -> T# +{-# inline unlift #-} +unlift (Word128 (W64# a) (W64# b)) = (# a, b #) + +eq# :: T# -> T# -> Int# +{-# inline eq# #-} +eq# (# x1, y1 #) (# x2, y2 #) = ((eqWord# x1 x2) `andI#` (eqWord# y1 y2)) + +neq# :: T# -> T# -> Int# +{-# inline neq# #-} +neq# (# x1, y1 #) (# x2, y2 #) = ((neWord# x1 x2) `orI#` (neWord# y1 y2)) + +eq :: T -> T -> Bool +{-# inline eq #-} +eq = (==) + +neq :: T -> T -> Bool +{-# inline neq #-} +neq = (/=) + +index :: ByteArray -> Int -> T +{-# inline index #-} +index (ByteArray x) (I# i) = lift (index# x i) + +read :: MutableByteArray s -> Int -> ST s T +{-# inline read #-} +read (MutableByteArray x) (I# i) = ST + (\s0 -> case read# x i s0 of + (# s1, r #) -> (# s1, lift r #) + ) + +write :: MutableByteArray s -> Int -> T -> ST s () +{-# inline write #-} +write (MutableByteArray x) (I# i) (unlift -> e) = ST (\s -> (# write# x i e s, () #) ) + +set# :: MutableByteArray# s -> Int# -> Int# -> T# -> State# s -> State# s +{-# inline set# #-} +set# marr off len x s = case len of + 0# -> s + _ -> set# marr (off +# 1# ) (len -# 1# ) x (write# marr off x s) + +uninitialized# :: Int# -> State# s -> (# State# s, MutableByteArray# s #) +{-# inline uninitialized# #-} +uninitialized# sz = Exts.newByteArray# (sz *# 16# ) + +initialized# :: + Int# -> T# -> State# s + -> (# State# s, MutableByteArray# s #) +{-# inline initialized# #-} +initialized# n e s0 = case uninitialized# n s0 of + (# s1, a #) -> case set# a 0# n e s1 of + s2 -> (# s2, a #) + +uninitialized :: Int -> ST s (MutableByteArray s) +{-# inline uninitialized #-} +uninitialized (I# sz) = ST $ \s0 -> case uninitialized# sz s0 of + (# s1, a #) -> (# s1, MutableByteArray a #) + +initialized :: Int -> T -> ST s (MutableByteArray s) +{-# inline initialized #-} +initialized (I# sz) e = ST $ \s0 -> case initialized# sz (unlift e) s0 of + (# s1, a #) -> (# s1, MutableByteArray a #) + +copy# :: MutableByteArray# s -> Int# -> ByteArray# -> Int# -> Int# -> State# s -> State# s +{-# inline copy# #-} +copy# dst doff src soff len = + Exts.copyByteArray# src (soff *# 16#) dst (doff *# 16#) (len *# 16#) + +copyMutable# :: MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s +{-# inline copyMutable# #-} +copyMutable# dst doff src soff len = + Exts.copyMutableByteArray# src (soff *# 16#) dst (doff *# 16#) (len *# 16#) + +shrink# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, MutableByteArray# s #) +{-# inline shrink# #-} +shrink# m i s0 = (# Exts.shrinkMutableByteArray# m (i *# 16#) s0, m #) + +shrink :: MutableByteArray s -> Int -> ST s (MutableByteArray s) +{-# inline shrink #-} +shrink (MutableByteArray x) (I# i) = ST + (\s0 -> case shrink# x i s0 of + (# s1, r #) -> (# s1, MutableByteArray r #) + ) + +shows :: T -> String -> String +shows = Prelude.shows + +#if WORDS_BIGENDIAN +index# :: ByteArray# -> Int# -> T# +{-# inline index# #-} +index# arr# i# = + (# Exts.indexWordArray# arr# (2# *# i#) + , Exts.indexWordArray# arr# ((2# *# i#) +# 1#) #) + +read# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, T# #) +{-# inline read# #-} +read# arr# i# s0 = case Exts.readWordArray# arr# (2# *# i#) s0 of + (# s1, i0 #) -> case Exts.readWordArray# arr# ((2# *# i#) +# 1#) s1 of + (# s2, i1 #) -> (# s2, (# i0, i1 #) #) + +write# :: MutableByteArray# s -> Int# -> T# -> State# s -> State# s +{-# inline write# #-} +write# arr# i# (# a, b #) s0 = + case Exts.writeWordArray# arr# (2# *# i#) a s0 of + s1 -> case Exts.writeWordArray# arr# ((2# *# i#) +# 1#) b s1 of + s2 -> s2 +#else +index# :: ByteArray# -> Int# -> T# +{-# inline index# #-} +index# arr# i# = + (# Exts.indexWordArray# arr# ((2# *# i#) +# 1#) + , Exts.indexWordArray# arr# (2# *# i#) #) + +read# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, T# #) +{-# inline read# #-} +read# arr# i# s0 = case Exts.readWordArray# arr# ((2# *# i#) +# 1#) s0 of + (# s1, i0 #) -> case Exts.readWordArray# arr# (2# *# i#) s1 of + (# s2, i1 #) -> (# s2, (# i0, i1 #) #) + +write# :: MutableByteArray# s -> Int# -> T# -> State# s -> State# s +{-# inline write# #-} +write# arr# i# (# a, b #) s0 = + case Exts.writeWordArray# arr# ((2# *# i#) +# 1#) a s0 of + s1 -> case Exts.writeWordArray# arr# (2# *# i#) b s1 of + s2 -> s2 +#endif diff --git a/src/Basics/Word128s.hs b/src/Basics/Word128s.hs new file mode 100644 --- /dev/null +++ b/src/Basics/Word128s.hs @@ -0,0 +1,118 @@ +{-# language BangPatterns #-} +{-# language DataKinds #-} +{-# language MagicHash #-} +{-# language UnboxedTuples #-} + +module Basics.Word128s + ( -- Types + T + , T# + , R + -- Lifting + , lift + , unlift + -- Array + , read# + , write# + , index# + , uninitialized# + , initialized# + , copy# + , copyMutable# + , set# + , shrink# + , eq# + , neq# + -- Encode + , shows + ) where + +import Prelude hiding (shows) + +import GHC.Exts hiding (setByteArray#) +import Data.Primitive (PrimArray(PrimArray)) +import Data.WideWord (Word128) + +import qualified GHC.Exts as Exts + +type T = PrimArray Word128 +type T# = ByteArray# +type R = 'BoxedRep 'Unlifted + +lift :: T# -> T +{-# inline lift #-} +lift = PrimArray + +unlift :: T -> T# +{-# inline unlift #-} +unlift (PrimArray x) = x + +index# :: ArrayArray# -> Int# -> T# +{-# inline index# #-} +index# = Exts.indexByteArrayArray# + +read# :: MutableArrayArray# s -> Int# -> State# s -> (# State# s, T# #) +{-# inline read# #-} +read# = Exts.readByteArrayArray# + +write# :: MutableArrayArray# s -> Int# -> T# -> State# s -> State# s +{-# inline write# #-} +write# = Exts.writeByteArrayArray# + +set# :: MutableArrayArray# s -> Int# -> Int# -> T# -> State# s -> State# s +{-# inline set# #-} +set# marr off len x s = case len of + 0# -> s + _ -> set# marr (off +# 1# ) (len -# 1# ) x (write# marr off x s) + +-- | This is very unsafe. +uninitialized# :: Int# -> State# s -> (# State# s, MutableArrayArray# s #) +{-# inline uninitialized# #-} +uninitialized# = Exts.newArrayArray# + +initialized# :: + Int# -> T# -> State# s + -> (# State# s, MutableArrayArray# s #) +{-# inline initialized# #-} +initialized# n e s0 = case uninitialized# n s0 of + (# s1, a #) -> case set# a 0# n e s1 of + s2 -> (# s2, a #) + +copy# :: MutableArrayArray# s -> Int# -> ArrayArray# -> Int# -> Int# -> State# s -> State# s +{-# inline copy# #-} +copy# dst doff src soff len = + Exts.copyArrayArray# src soff dst doff len + +copyMutable# :: MutableArrayArray# s -> Int# -> MutableArrayArray# s -> Int# -> Int# -> State# s -> State# s +{-# inline copyMutable# #-} +copyMutable# dst doff src soff len = + Exts.copyMutableArrayArray# src soff dst doff len + +shrink# :: MutableArrayArray# s -> Int# -> State# s -> (# State# s, MutableArrayArray# s #) +{-# inline shrink# #-} +shrink# m sz s0 = case uninitialized# sz s0 of + (# s1, dst #) -> case copyMutable# dst 0# m 0# sz s1 of + s2 -> (# s2, dst #) + +eq# :: ByteArray# -> ByteArray# -> Int# +{-# inline eq# #-} +eq# a b = case lenA ==# lenB of + 1# -> Exts.compareByteArrays# a 0# b 0# lenA ==# 0# + _ -> 0# + where + !lenA = Exts.sizeofByteArray# a + !lenB = Exts.sizeofByteArray# b + +neq# :: ByteArray# -> ByteArray# -> Int# +{-# inline neq# #-} +neq# a b = case lenA ==# lenB of + 1# -> Exts.compareByteArrays# a 0# b 0# lenA /=# 0# + _ -> 1# + where + !lenA = Exts.sizeofByteArray# a + !lenB = Exts.sizeofByteArray# b + +-- TODO: fix this +shows :: T -> String -> String +{-# inline shows #-} +shows _ s = "[...]" ++ s diff --git a/src/Basics/Word16.hs b/src/Basics/Word16.hs new file mode 100644 --- /dev/null +++ b/src/Basics/Word16.hs @@ -0,0 +1,264 @@ +{-# language BangPatterns #-} +{-# language DataKinds #-} +{-# language MagicHash #-} +{-# language UnboxedTuples #-} + +module Basics.Word16 + ( -- Types + T + , T# + , R + -- Lifting + , lift + , unlift + -- Arithmetic + , plus + , minus + , plus# + , minus# + , times# + , quot# + , rem# + -- Compare + , gt# + , lt# + , gte# + , lte# + , eq# + , neq# + , gt + , lt + , gte + , lte + , eq + , neq + -- Array + , read# + , write# + , index# + , read + , write + , index + , uninitialized# + , initialized# + , uninitialized + , initialized + , copy# + , copyMutable# + , set# + , shrink# + , shrink + -- Constants + , def + , zero + , maxBound + , minBound + -- Metadata + , signed + , size + -- Encoding + , shows + ) where + +import Prelude hiding (shows,minBound,maxBound,read) + +import GHC.Exts hiding (setByteArray#) +import GHC.Word +import GHC.ST (ST(ST)) +import Data.Primitive (MutableByteArray(..),ByteArray(..)) + +import qualified Prelude +import qualified GHC.Exts as Exts + +type T = Word16 +type T# = Word# +type R = 'WordRep + +def :: T +{-# inline def #-} +def = 0 + +zero :: T +{-# inline zero #-} +zero = 0 + +signed :: Bool +{-# inline signed #-} +signed = False + +size :: Int +{-# inline size #-} +size = 2 + +maxBound :: T +{-# inline maxBound #-} +maxBound = 65535 + +minBound :: T +{-# inline minBound #-} +minBound = 0 + +lift :: T# -> T +{-# inline lift #-} +lift i = W16# (Exts.wordToWord16# i) + +unlift :: T -> T# +{-# inline unlift #-} +unlift (W16# i) = Exts.word16ToWord# i + +plus :: T -> T -> T +{-# inline plus #-} +plus (W16# x) (W16# y) = W16# (plusWord16# x y) + +minus :: T -> T -> T +{-# inline minus #-} +minus (W16# x) (W16# y) = W16# (subWord16# x y) + +times# :: T# -> T# -> T# +{-# inline times# #-} +times# = timesWord# + +quot# :: T# -> T# -> T# +{-# inline quot# #-} +quot# = quotWord# + +rem# :: T# -> T# -> T# +{-# inline rem# #-} +rem# = remWord# + +plus# :: T# -> T# -> T# +{-# inline plus# #-} +plus# = plusWord# + +minus# :: T# -> T# -> T# +{-# inline minus# #-} +minus# x y = narrow16Word# (minusWord# x y) + +gt# :: T# -> T# -> Int# +{-# inline gt# #-} +gt# = gtWord# + +lt# :: T# -> T# -> Int# +{-# inline lt# #-} +lt# = ltWord# + +gte# :: T# -> T# -> Int# +{-# inline gte# #-} +gte# = geWord# + +lte# :: T# -> T# -> Int# +{-# inline lte# #-} +lte# = leWord# + +eq# :: T# -> T# -> Int# +{-# inline eq# #-} +eq# = eqWord# + +neq# :: T# -> T# -> Int# +{-# inline neq# #-} +neq# = neWord# + +gt :: T -> T -> Bool +{-# inline gt #-} +gt = (>) + +lt :: T -> T -> Bool +{-# inline lt #-} +lt = (<) + +gte :: T -> T -> Bool +{-# inline gte #-} +gte = (>=) + +lte :: T -> T -> Bool +{-# inline lte #-} +lte = (<=) + +eq :: T -> T -> Bool +{-# inline eq #-} +eq = (==) + +neq :: T -> T -> Bool +{-# inline neq #-} +neq = (/=) + +index# :: ByteArray# -> Int# -> T# +{-# inline index# #-} +index# arr i = Exts.word16ToWord# (indexWord16Array# arr i) + +read# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, T# #) +{-# inline read# #-} +read# arr i st = + let !(# st', v #) = readWord16Array# arr i st + in (# st', Exts.word16ToWord# v #) + +write# :: MutableByteArray# s -> Int# -> T# -> State# s -> State# s +{-# inline write# #-} +write# arr i v st = writeWord16Array# arr i (Exts.wordToWord16# v) st + +set# :: MutableByteArray# s -> Int# -> Int# -> T# -> State# s -> State# s +{-# inline set# #-} +set# marr off len x s = case len of + 0# -> s + _ -> set# marr (off +# 1# ) (len -# 1# ) x (write# marr off x s) + +uninitialized# :: Int# -> State# s -> (# State# s, MutableByteArray# s #) +{-# inline uninitialized# #-} +uninitialized# sz = Exts.newByteArray# (sz *# 2# ) + +initialized# :: + Int# -> T# -> State# s + -> (# State# s, MutableByteArray# s #) +{-# inline initialized# #-} +initialized# n e s0 = case uninitialized# n s0 of + (# s1, a #) -> case set# a 0# n e s1 of + s2 -> (# s2, a #) + +uninitialized :: Int -> ST s (MutableByteArray s) +{-# inline uninitialized #-} +uninitialized (I# sz) = ST $ \s0 -> case uninitialized# sz s0 of + (# s1, a #) -> (# s1, MutableByteArray a #) + +initialized :: Int -> T -> ST s (MutableByteArray s) +{-# inline initialized #-} +initialized (I# sz) e = ST $ \s0 -> case initialized# sz (unlift e) s0 of + (# s1, a #) -> (# s1, MutableByteArray a #) + +copy# :: MutableByteArray# s -> Int# -> ByteArray# -> Int# -> Int# -> State# s -> State# s +{-# inline copy# #-} +copy# dst doff src soff len = + Exts.copyByteArray# src (soff *# 2#) dst (doff *# 2#) (len *# 2#) + +copyMutable# :: MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s +{-# inline copyMutable# #-} +copyMutable# dst doff src soff len = + Exts.copyMutableByteArray# src (soff *# 2#) dst (doff *# 2#) (len *# 2#) + +shrink# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, MutableByteArray# s #) +{-# inline shrink# #-} +shrink# m i s = (# Exts.shrinkMutableByteArray# m (i *# 2# ) s, m #) + +shows :: T -> String -> String +shows = Prelude.shows + +shrink :: MutableByteArray s -> Int -> ST s (MutableByteArray s) +{-# inline shrink #-} +shrink (MutableByteArray x) (I# i) = ST + (\s0 -> case shrink# x i s0 of + (# s1, r #) -> (# s1, MutableByteArray r #) + ) + +index :: ByteArray -> Int -> T +{-# inline index #-} +index (ByteArray x) (I# i) = W16# (indexWord16Array# x i) + +read :: MutableByteArray s -> Int -> ST s T +{-# inline read #-} +read (MutableByteArray x) (I# i) = ST + (\s0 -> case readWord16Array# x i s0 of + (# s1, r #) -> (# s1, W16# r #) + ) + +write :: MutableByteArray s -> Int -> T -> ST s () +{-# inline write #-} +write (MutableByteArray x) (I# i) (W16# e) = ST (\s -> (# writeWord16Array# x i e s, () #) ) diff --git a/src/Basics/Word256.hs b/src/Basics/Word256.hs new file mode 100644 --- /dev/null +++ b/src/Basics/Word256.hs @@ -0,0 +1,157 @@ +{-# language CPP #-} +{-# language BangPatterns #-} +{-# language DataKinds #-} +{-# language MagicHash #-} +{-# language UnboxedTuples #-} + +#include + +module Basics.Word256 + ( -- Types + T + , T# + , R + -- Lifting + , lift + , unlift + -- Array + , read# + , write# + , index# + , uninitialized# + , initialized# + , copy# + , copyMutable# + , set# + , shrink# + , eq# + , neq# + -- Encode + , shows + ) where + +import Prelude hiding (shows,minBound,maxBound) + +import Data.WideWord.Word256 (Word256(Word256)) +import GHC.Exts hiding (setByteArray#) +import GHC.Word (Word64(W64#)) + +import qualified Data.WideWord.Word256 as Word256 +import qualified GHC.Exts as Exts + +type T = Word256 +type T# = (# Word#, Word#, Word#, Word# #) +type R = 'TupleRep '[ 'WordRep, 'WordRep, 'WordRep, 'WordRep ] + +lift :: T# -> T +{-# inline lift #-} +lift (# a, b, c, d #) = Word256 (W64# a) (W64# b) (W64# c) (W64# d) + +unlift :: T -> T# +{-# inline unlift #-} +unlift (Word256 (W64# a) (W64# b) (W64# c) (W64# d)) = (# a, b, c, d #) + +eq# :: T# -> T# -> Int# +{-# inline eq# #-} +eq# (# x1, y1, z1, w1 #) (# x2, y2, z2, w2 #) = + (eqWord# x1 x2) `andI#` + (eqWord# y1 y2) `andI#` + (eqWord# z1 z2) `andI#` + (eqWord# w1 w2) + +neq# :: T# -> T# -> Int# +{-# inline neq# #-} +neq# (# x1, y1, z1, w1 #) (# x2, y2, z2, w2 #) = + (neWord# x1 x2) `orI#` + (neWord# y1 y2) `orI#` + (neWord# z1 z2) `orI#` + (neWord# w1 w2) + +set# :: MutableByteArray# s -> Int# -> Int# -> T# -> State# s -> State# s +{-# inline set# #-} +set# marr off len x s = case len of + 0# -> s + _ -> set# marr (off +# 1# ) (len -# 1# ) x (write# marr off x s) + +uninitialized# :: Int# -> State# s -> (# State# s, MutableByteArray# s #) +{-# inline uninitialized# #-} +uninitialized# sz = Exts.newByteArray# (sz *# 32# ) + +initialized# :: + Int# -> T# -> State# s + -> (# State# s, MutableByteArray# s #) +{-# inline initialized# #-} +initialized# n e s0 = case uninitialized# n s0 of + (# s1, a #) -> case set# a 0# n e s1 of + s2 -> (# s2, a #) + +copy# :: MutableByteArray# s -> Int# -> ByteArray# -> Int# -> Int# -> State# s -> State# s +{-# inline copy# #-} +copy# dst doff src soff len = + Exts.copyByteArray# src (soff *# 32#) dst (doff *# 32#) (len *# 32#) + +copyMutable# :: MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s +{-# inline copyMutable# #-} +copyMutable# dst doff src soff len = + Exts.copyMutableByteArray# src (soff *# 32#) dst (doff *# 32#) (len *# 32#) + +shrink# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, MutableByteArray# s #) +{-# inline shrink# #-} +shrink# m i s0 = (# Exts.shrinkMutableByteArray# m (i *# 32#) s0, m #) + +shows :: T -> String -> String +shows x = (Word256.showHexWord256 x ++) + +#if WORDS_BIGENDIAN +index# :: ByteArray# -> Int# -> T# +{-# inline index# #-} +index# arr# i# = + (# Exts.indexWordArray# arr# (4# *# i#) + , Exts.indexWordArray# arr# ((4# *# i#) +# 1#) + , Exts.indexWordArray# arr# ((4# *# i#) +# 2#) + , Exts.indexWordArray# arr# ((4# *# i#) +# 3#) + #) + +read# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, T# #) +{-# inline read# #-} +read# arr# i# s0 = case Exts.readWordArray# arr# (4# *# i#) s0 of + (# s1, i0 #) -> case Exts.readWordArray# arr# ((4# *# i#) +# 1#) s1 of + (# s2, i1 #) -> case Exts.readWordArray# arr# ((4# *# i#) +# 2#) s2 of + (# s3, i2 #) -> case Exts.readWordArray# arr# ((4# *# i#) +# 3#) s3 of + (# s4, i3 #) -> (# s4, (# i0, i1, i2, i3 #) #) + +write# :: MutableByteArray# s -> Int# -> T# -> State# s -> State# s +{-# inline write# #-} +write# arr# i# (# a, b, c, d #) s0 = + case Exts.writeWordArray# arr# (4# *# i#) a s0 of + s1 -> case Exts.writeWordArray# arr# ((4# *# i#) +# 1#) b s1 of + s2 -> case Exts.writeWordArray# arr# ((4# *# i#) +# 2#) c s2 of + s3 -> case Exts.writeWordArray# arr# ((4# *# i#) +# 3#) d s3 of + s4 -> s4 +#else +index# :: ByteArray# -> Int# -> T# +{-# inline index# #-} +index# arr# i# = + (# Exts.indexWordArray# arr# ((4# *# i#) +# 3#) + , Exts.indexWordArray# arr# ((4# *# i#) +# 2#) + , Exts.indexWordArray# arr# ((4# *# i#) +# 1#) + , Exts.indexWordArray# arr# (4# *# i#) + #) + +read# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, T# #) +{-# inline read# #-} +read# arr# i# s0 = case Exts.readWordArray# arr# ((4# *# i#) +# 3#) s0 of + (# s1, i0 #) -> case Exts.readWordArray# arr# ((4# *# i#) +# 2#) s1 of + (# s2, i1 #) -> case Exts.readWordArray# arr# ((4# *# i#) +# 1#) s2 of + (# s3, i2 #) -> case Exts.readWordArray# arr# (4# *# i#) s3 of + (# s4, i3 #) -> (# s4, (# i0, i1, i2, i3 #) #) + +write# :: MutableByteArray# s -> Int# -> T# -> State# s -> State# s +{-# inline write# #-} +write# arr# i# (# a, b, c, d #) s0 = + case Exts.writeWordArray# arr# ((4# *# i#) +# 3#) a s0 of + s1 -> case Exts.writeWordArray# arr# ((4# *# i#) +# 2#) b s1 of + s2 -> case Exts.writeWordArray# arr# ((4# *# i#) +# 1#) c s2 of + s3 -> case Exts.writeWordArray# arr# (4# *# i#) d s3 of + s4 -> s4 +#endif diff --git a/src/Basics/Word32.hs b/src/Basics/Word32.hs new file mode 100644 --- /dev/null +++ b/src/Basics/Word32.hs @@ -0,0 +1,244 @@ +{-# language BangPatterns #-} +{-# language DataKinds #-} +{-# language MagicHash #-} +{-# language UnboxedTuples #-} + +module Basics.Word32 + ( -- Types + T + , T# + , R + -- Lifting + , lift + , unlift + -- Compare + , gt# + , lt# + , gte# + , lte# + , eq# + , neq# + , gt + , lt + , gte + , lte + , eq + , neq + -- Arithmetic + , minus# + , quot# + , rem# + -- Array + , read# + , write# + , index# + , read + , write + , index + , uninitialized# + , initialized# + , uninitialized + , initialized + , copy# + , copyMutable# + , set# + , shrink# + , shrink + -- Constants + , zero + , def + , maxBound + , minBound + -- Metadata + , signed + , size + -- Encoding + , shows + ) where + +import Prelude hiding (shows,minBound,maxBound,read) + +import GHC.Exts hiding (setByteArray#) +import GHC.Word +import GHC.ST (ST(ST)) +import Data.Primitive (MutableByteArray(..),ByteArray(..)) + +import qualified Prelude +import qualified GHC.Exts as Exts + +type T = Word32 +type T# = Word# +type R = 'WordRep + +def :: T +{-# inline def #-} +def = 0 + +zero :: T +{-# inline zero #-} +zero = 0 + +maxBound :: T +{-# inline maxBound #-} +maxBound = 4294967295 + +minBound :: T +{-# inline minBound #-} +minBound = 0 + +signed :: Bool +{-# inline signed #-} +signed = False + +size :: Int +{-# inline size #-} +size = 4 + +lift :: T# -> T +{-# inline lift #-} +lift i = W32# (Exts.wordToWord32# i) + +unlift :: T -> T# +{-# inline unlift #-} +unlift (W32# i) = Exts.word32ToWord# i + +gt# :: T# -> T# -> Int# +{-# inline gt# #-} +gt# = gtWord# + +lt# :: T# -> T# -> Int# +{-# inline lt# #-} +lt# = ltWord# + +gte# :: T# -> T# -> Int# +{-# inline gte# #-} +gte# = geWord# + +lte# :: T# -> T# -> Int# +{-# inline lte# #-} +lte# = leWord# + +eq# :: T# -> T# -> Int# +{-# inline eq# #-} +eq# = eqWord# + +neq# :: T# -> T# -> Int# +{-# inline neq# #-} +neq# = neWord# + +gt :: T -> T -> Bool +{-# inline gt #-} +gt = (>) + +lt :: T -> T -> Bool +{-# inline lt #-} +lt = (<) + +gte :: T -> T -> Bool +{-# inline gte #-} +gte = (>=) + +lte :: T -> T -> Bool +{-# inline lte #-} +lte = (<=) + +eq :: T -> T -> Bool +{-# inline eq #-} +eq = (==) + +neq :: T -> T -> Bool +{-# inline neq #-} +neq = (/=) + +minus# :: T# -> T# -> T# +{-# inline minus# #-} +minus# x y = narrow32Word# (minusWord# x y) + +quot# :: T# -> T# -> T# +{-# inline quot# #-} +quot# = quotWord# + +rem# :: T# -> T# -> T# +{-# inline rem# #-} +rem# = remWord# + +index# :: ByteArray# -> Int# -> T# +{-# inline index# #-} +index# arr i = Exts.word32ToWord# (indexWord32Array# arr i) + +read# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, T# #) +{-# inline read# #-} +read# arr i st = + let !(# st', v #) = readWord32Array# arr i st + in (# st', Exts.word32ToWord# v #) + +write# :: MutableByteArray# s -> Int# -> T# -> State# s -> State# s +{-# inline write# #-} +write# arr i v st = writeWord32Array# arr i (Exts.wordToWord32# v) st + +index :: ByteArray -> Int -> T +{-# inline index #-} +index (ByteArray x) (I# i) = W32# (indexWord32Array# x i) + +read :: MutableByteArray s -> Int -> ST s T +{-# inline read #-} +read (MutableByteArray x) (I# i) = ST + (\s0 -> case readWord32Array# x i s0 of + (# s1, r #) -> (# s1, W32# r #) + ) + +write :: MutableByteArray s -> Int -> T -> ST s () +{-# inline write #-} +write (MutableByteArray x) (I# i) (W32# e) = ST (\s -> (# writeWord32Array# x i e s, () #) ) + +set# :: MutableByteArray# s -> Int# -> Int# -> T# -> State# s -> State# s +{-# inline set# #-} +set# marr off len x s = case len of + 0# -> s + _ -> set# marr (off +# 1# ) (len -# 1# ) x (write# marr off x s) + +uninitialized# :: Int# -> State# s -> (# State# s, MutableByteArray# s #) +{-# inline uninitialized# #-} +uninitialized# sz = Exts.newByteArray# (sz *# 4# ) + +initialized# :: + Int# -> T# -> State# s + -> (# State# s, MutableByteArray# s #) +{-# inline initialized# #-} +initialized# n e s0 = case uninitialized# n s0 of + (# s1, a #) -> case set# a 0# n e s1 of + s2 -> (# s2, a #) + +uninitialized :: Int -> ST s (MutableByteArray s) +{-# inline uninitialized #-} +uninitialized (I# sz) = ST $ \s0 -> case uninitialized# sz s0 of + (# s1, a #) -> (# s1, MutableByteArray a #) + +initialized :: Int -> T -> ST s (MutableByteArray s) +{-# inline initialized #-} +initialized (I# sz) e = ST $ \s0 -> case initialized# sz (unlift e) s0 of + (# s1, a #) -> (# s1, MutableByteArray a #) + +copy# :: MutableByteArray# s -> Int# -> ByteArray# -> Int# -> Int# -> State# s -> State# s +{-# inline copy# #-} +copy# dst doff src soff len = + Exts.copyByteArray# src (soff *# 4#) dst (doff *# 4#) (len *# 4#) + +copyMutable# :: MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s +{-# inline copyMutable# #-} +copyMutable# dst doff src soff len = + Exts.copyMutableByteArray# src (soff *# 4#) dst (doff *# 4#) (len *# 4#) + +shrink# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, MutableByteArray# s #) +{-# inline shrink# #-} +shrink# m i s0 = (# Exts.shrinkMutableByteArray# m (i *# 4#) s0, m #) + +shrink :: MutableByteArray s -> Int -> ST s (MutableByteArray s) +{-# inline shrink #-} +shrink (MutableByteArray x) (I# i) = ST + (\s0 -> case shrink# x i s0 of + (# s1, r #) -> (# s1, MutableByteArray r #) + ) + +shows :: T -> String -> String +shows = Prelude.shows diff --git a/src/Basics/Word64.hs b/src/Basics/Word64.hs new file mode 100644 --- /dev/null +++ b/src/Basics/Word64.hs @@ -0,0 +1,262 @@ +{-# language DataKinds #-} +{-# language MagicHash #-} +{-# language UnboxedTuples #-} + +module Basics.Word64 + ( -- Types + T + , T# + , R + -- Lifting + , lift + , unlift + -- Arithmetic + , plus + , minus + , plus# + , minus# + , times# + , quot# + , rem# + -- Compare + , gt# + , lt# + , gte# + , lte# + , eq# + , neq# + , gt + , lt + , gte + , lte + , eq + , neq + -- Array + , read# + , write# + , index# + , read + , write + , index + , uninitialized# + , initialized# + , uninitialized + , initialized + , copy# + , copyMutable# + , set# + , shrink# + , shrink + -- Constants + , zero + , def + , maxBound + , minBound + -- Metadata + , signed + , size + -- Encoding + , shows + ) where + +import Prelude hiding (shows,minBound,maxBound,read) + +import GHC.Exts hiding (setByteArray#) +import GHC.Word +import GHC.ST (ST(ST)) +import Data.Primitive (MutableByteArray(..),ByteArray(..)) + +import qualified Prelude +import qualified GHC.Exts as Exts + +type T = Word64 +type T# = Word# +type R = 'WordRep + +def :: T +{-# inline def #-} +def = 0 + +zero :: T +{-# inline zero #-} +zero = 0 + +signed :: Bool +{-# inline signed #-} +signed = False + +size :: Int +{-# inline size #-} +size = 8 + +maxBound :: T +{-# inline maxBound #-} +maxBound = 18446744073709551615 + +minBound :: T +{-# inline minBound #-} +minBound = 0 + +lift :: T# -> T +{-# inline lift #-} +lift = W64# + +unlift :: T -> T# +{-# inline unlift #-} +unlift (W64# i) = i + +plus :: T -> T -> T +{-# inline plus #-} +plus (W64# x) (W64# y) = W64# (plusWord# x y) + +minus :: T -> T -> T +{-# inline minus #-} +minus (W64# x) (W64# y) = W64# (minusWord# x y) + +times# :: T# -> T# -> T# +{-# inline times# #-} +times# = timesWord# + +quot# :: T# -> T# -> T# +{-# inline quot# #-} +quot# = quotWord# + +rem# :: T# -> T# -> T# +{-# inline rem# #-} +rem# = remWord# + +plus# :: T# -> T# -> T# +{-# inline plus# #-} +plus# = plusWord# + +minus# :: T# -> T# -> T# +{-# inline minus# #-} +minus# = minusWord# + +gt# :: T# -> T# -> Int# +{-# inline gt# #-} +gt# = gtWord# + +lt# :: T# -> T# -> Int# +{-# inline lt# #-} +lt# = ltWord# + +gte# :: T# -> T# -> Int# +{-# inline gte# #-} +gte# = geWord# + +lte# :: T# -> T# -> Int# +{-# inline lte# #-} +lte# = leWord# + +eq# :: T# -> T# -> Int# +{-# inline eq# #-} +eq# = eqWord# + +neq# :: T# -> T# -> Int# +{-# inline neq# #-} +neq# = neWord# + +gt :: T -> T -> Bool +{-# inline gt #-} +gt = (>) + +lt :: T -> T -> Bool +{-# inline lt #-} +lt = (<) + +gte :: T -> T -> Bool +{-# inline gte #-} +gte = (>=) + +lte :: T -> T -> Bool +{-# inline lte #-} +lte = (<=) + +eq :: T -> T -> Bool +{-# inline eq #-} +eq = (==) + +neq :: T -> T -> Bool +{-# inline neq #-} +neq = (/=) + +index# :: ByteArray# -> Int# -> T# +{-# inline index# #-} +index# = indexWordArray# + +read# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, T# #) +{-# inline read# #-} +read# = readWordArray# + +write# :: MutableByteArray# s -> Int# -> T# -> State# s -> State# s +{-# inline write# #-} +write# = writeWordArray# + +set# :: MutableByteArray# s -> Int# -> Int# -> T# -> State# s -> State# s +{-# inline set# #-} +set# marr off len x s = case len of + 0# -> s + _ -> set# marr (off +# 1# ) (len -# 1# ) x (write# marr off x s) + +uninitialized# :: Int# -> State# s -> (# State# s, MutableByteArray# s #) +{-# inline uninitialized# #-} +uninitialized# sz = Exts.newByteArray# (sz *# 8# ) + +initialized# :: + Int# -> T# -> State# s + -> (# State# s, MutableByteArray# s #) +{-# inline initialized# #-} +initialized# n e s0 = case uninitialized# n s0 of + (# s1, a #) -> case set# a 0# n e s1 of + s2 -> (# s2, a #) + +uninitialized :: Int -> ST s (MutableByteArray s) +{-# inline uninitialized #-} +uninitialized (I# sz) = ST $ \s0 -> case uninitialized# sz s0 of + (# s1, a #) -> (# s1, MutableByteArray a #) + +initialized :: Int -> T -> ST s (MutableByteArray s) +{-# inline initialized #-} +initialized (I# sz) e = ST $ \s0 -> case initialized# sz (unlift e) s0 of + (# s1, a #) -> (# s1, MutableByteArray a #) + +copy# :: MutableByteArray# s -> Int# -> ByteArray# -> Int# -> Int# -> State# s -> State# s +{-# inline copy# #-} +copy# dst doff src soff len = + Exts.copyByteArray# src (soff *# 8#) dst (doff *# 8#) (len *# 8#) + +copyMutable# :: MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s +{-# inline copyMutable# #-} +copyMutable# dst doff src soff len = + Exts.copyMutableByteArray# src (soff *# 8#) dst (doff *# 8#) (len *# 8#) + +shrink# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, MutableByteArray# s #) +{-# inline shrink# #-} +shrink# m i s0 = (# Exts.shrinkMutableByteArray# m (i *# 8#) s0, m #) + +shows :: T -> String -> String +shows = Prelude.shows + +index :: ByteArray -> Int -> T +{-# inline index #-} +index (ByteArray x) (I# i) = W64# (indexWord64Array# x i) + +read :: MutableByteArray s -> Int -> ST s T +{-# inline read #-} +read (MutableByteArray x) (I# i) = ST + (\s0 -> case readWord64Array# x i s0 of + (# s1, r #) -> (# s1, W64# r #) + ) + +write :: MutableByteArray s -> Int -> T -> ST s () +{-# inline write #-} +write (MutableByteArray x) (I# i) (W64# e) = ST (\s -> (# writeWord64Array# x i e s, () #) ) + +shrink :: MutableByteArray s -> Int -> ST s (MutableByteArray s) +{-# inline shrink #-} +shrink (MutableByteArray x) (I# i) = ST + (\s0 -> case shrink# x i s0 of + (# s1, r #) -> (# s1, MutableByteArray r #) + ) + diff --git a/src/Basics/Word8.hs b/src/Basics/Word8.hs new file mode 100644 --- /dev/null +++ b/src/Basics/Word8.hs @@ -0,0 +1,215 @@ +{-# language BangPatterns #-} +{-# language DataKinds #-} +{-# language MagicHash #-} +{-# language UnboxedTuples #-} + +module Basics.Word8 + ( -- Types + T + , T# + , R + -- Lifting + , lift + , unlift + -- Arithmetic + , minus# + , quot# + , rem# + -- Compare + , gt# + , lt# + , gte# + , lte# + , eq# + , neq# + , gt + , lt + , gte + , lte + , eq + , neq + -- Array + , read# + , write# + , index# + , set# + , uninitialized# + , initialized# + , uninitialized + , initialized + , copy# + , copyMutable# + , shrink# + -- Constants + , zero + , def + , maxBound + , minBound + -- Metadata + , signed + , size + -- Encode + , shows + ) where + +import Prelude hiding (shows,minBound,maxBound) + +import Data.Primitive (MutableByteArray(..)) +import GHC.Exts hiding (setByteArray#) +import GHC.ST (ST(ST)) +import GHC.Word + +import qualified Prelude +import qualified GHC.Exts as Exts + +type T = Word8 +type T# = Word# +type R = 'WordRep + +def :: T +{-# inline def #-} +def = 0 + +zero :: T +{-# inline zero #-} +zero = 0 + +signed :: Bool +{-# inline signed #-} +signed = False + +size :: Int +{-# inline size #-} +size = 1 + +maxBound :: T +{-# inline maxBound #-} +maxBound = 255 + +minBound :: T +{-# inline minBound #-} +minBound = 0 + +lift :: T# -> T +{-# inline lift #-} +lift i = W8# (Exts.wordToWord8# i) + +unlift :: T -> T# +{-# inline unlift #-} +unlift (W8# i) = Exts.word8ToWord# i + +gt# :: T# -> T# -> Int# +{-# inline gt# #-} +gt# = gtWord# + +lt# :: T# -> T# -> Int# +{-# inline lt# #-} +lt# = ltWord# + +gte# :: T# -> T# -> Int# +{-# inline gte# #-} +gte# = geWord# + +lte# :: T# -> T# -> Int# +{-# inline lte# #-} +lte# = leWord# + +eq# :: T# -> T# -> Int# +{-# inline eq# #-} +eq# = eqWord# + +neq# :: T# -> T# -> Int# +{-# inline neq# #-} +neq# = neWord# + +gt :: T -> T -> Bool +{-# inline gt #-} +gt = (>) + +lt :: T -> T -> Bool +{-# inline lt #-} +lt = (<) + +gte :: T -> T -> Bool +{-# inline gte #-} +gte = (>=) + +lte :: T -> T -> Bool +{-# inline lte #-} +lte = (<=) + +eq :: T -> T -> Bool +{-# inline eq #-} +eq = (==) + +neq :: T -> T -> Bool +{-# inline neq #-} +neq = (/=) + +minus# :: T# -> T# -> T# +{-# inline minus# #-} +minus# x y = narrow8Word# (minusWord# x y) + +quot# :: T# -> T# -> T# +{-# inline quot# #-} +quot# = quotWord# + +rem# :: T# -> T# -> T# +{-# inline rem# #-} +rem# = remWord# + +index# :: ByteArray# -> Int# -> T# +{-# inline index# #-} +index# arr i = Exts.word8ToWord# (indexWord8Array# arr i) + +read# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, T# #) +{-# inline read# #-} +read# arr i st = + let !(# st', v #) = readWord8Array# arr i st + in (# st', Exts.word8ToWord# v #) + +write# :: MutableByteArray# s -> Int# -> T# -> State# s -> State# s +{-# inline write# #-} +write# arr i v st = writeWord8Array# arr i (Exts.wordToWord8# v) st + +set# :: MutableByteArray# s -> Int# -> Int# -> T# -> State# s -> State# s +{-# inline set# #-} +set# marr off len x s = Exts.setByteArray# marr off len (word2Int# x) s + +shrink# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, MutableByteArray# s #) +{-# inline shrink# #-} +shrink# m i s = (# Exts.shrinkMutableByteArray# m i s, m #) + +uninitialized# :: Int# -> State# s -> (# State# s, MutableByteArray# s #) +{-# inline uninitialized# #-} +uninitialized# = Exts.newByteArray# + +initialized# :: Int# -> T# -> State# s -> (# State# s, MutableByteArray# s #) +{-# inline initialized# #-} +initialized# n e s0 = case Exts.newByteArray# n s0 of + (# s1, a #) -> case set# a 0# n e s1 of + s2 -> (# s2, a #) + +uninitialized :: Int -> ST s (MutableByteArray s) +{-# inline uninitialized #-} +uninitialized (I# sz) = ST $ \s0 -> case uninitialized# sz s0 of + (# s1, a #) -> (# s1, MutableByteArray a #) + +initialized :: Int -> T -> ST s (MutableByteArray s) +{-# inline initialized #-} +initialized (I# sz) e = ST $ \s0 -> case initialized# sz (unlift e) s0 of + (# s1, a #) -> (# s1, MutableByteArray a #) + +copy# :: MutableByteArray# s -> Int# -> ByteArray# -> Int# -> Int# -> State# s -> State# s +{-# inline copy# #-} +copy# dst doff src soff len = + Exts.copyByteArray# src soff dst doff len + +copyMutable# :: MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s +{-# inline copyMutable# #-} +copyMutable# dst doff src soff len = + Exts.copyMutableByteArray# src soff dst doff len + +shows :: T -> String -> String +{-# inline shows #-} +shows = Prelude.shows diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE UnboxedTuples #-} + +module Main + ( main + ) where + + +import Basics.BitBool +import Prelude hiding (read) + +import Control.Applicative (liftA2) +import Control.Monad (forM) +import Control.Monad.ST (runST) +import Data.Monoid (All(..)) +import Data.Primitive.ByteArray (ByteArray(..),MutableByteArray(..)) +import Data.Proxy (Proxy(Proxy)) +import Data.Word (Word32) +import GHC.Exts (Int(I#),MutableByteArray#) +import GHC.ST (ST(ST)) +import GHC.TypeNats (KnownNat) +import Test.QuickCheck.Instances.Text () +import Test.Tasty (TestTree,defaultMain,testGroup,adjustOption) +import Test.Tasty.HUnit (testCase,(@=?),assertFailure) +import Test.Tasty.QuickCheck ((===),(=/=),(==>)) +import Test.Tasty.QuickCheck (Gen,testProperty) +import Unsafe.Coerce (unsafeCoerce) + +import qualified Control.Monad.Trans.State.Strict as State +import qualified Data.Foldable as F +import qualified Data.List as L +import qualified Data.List as List +import qualified Data.Primitive.ByteArray as Prim +import qualified GHC.Exts as Exts +import qualified GHC.TypeNats as GHC +import qualified Test.Tasty.QuickCheck as QC + + + +main :: IO () +main = defaultMain + $ adjustOption (\_ -> QC.QuickCheckTests 4000) + $ tests + +tests :: TestTree +tests = testGroup "basics" + [ testGroup "BitBool" + [ testProperty "lift/unlift are inverse" $ \b -> + lift (unlift b) == b + , testCase "initialize with False" $ + let sz = 150 + actual = runST $ do + marr <- initialized sz False + forM [0..sz-1] $ \i -> read marr i + expected = replicate sz False + in actual @=? expected + , testCase "initialize with True" $ + let sz = 150 + actual = runST $ do + marr <- initialized sz True + forM [0..sz-1] $ \i -> read marr i + expected = replicate sz True + in actual @=? expected + , testProperty "read/write single bits" $ \xs -> + let actual = runST $ do + marr <- uninitialized (length xs) + forM (zip [0..] xs) $ \(i, x) -> + write marr i x + forM [0..length xs - 1] $ \i -> read marr i + in actual == xs + , testProperty "index/write single bits" $ \xs -> + let arr = Prim.runByteArray $ do + marr <- uninitialized (length xs) + forM (zip [0..] xs) $ \(i, x) -> + write marr i x + pure marr + actual = index arr <$> [0..length xs - 1] + in actual == xs + , testProperty "shrink" $ \Shrink{xs,sz} -> + let actual = runST $ do + marr <- uninitialized (length xs) + forM (zip [0..] xs) $ \(i, x) -> + write marr i x + marr' <- shrink marr sz + forM [0..sz - 1] $ \i -> read marr' i + in actual == take sz xs + , testProperty "set#" $ \Set{xs,off,len,v} -> + let actual = runST $ do + marr <- uninitialized (length xs) + forM (zip [0..] xs) $ \(i, x) -> + write marr i x + set marr off len v + forM [0..length xs - 1] $ \i -> read marr i + expected = take off xs ++ replicate len v ++ drop (off + len) xs + in actual === expected + , testProperty "copy" $ \Copy{xs,doff,ys,soff,len} -> + let src = Prim.runByteArray $ do + marr <- uninitialized (length ys) + forM (zip [0..] ys) $ \(i, y) -> + write marr i y + pure marr + actual = runST $ do + dst <- uninitialized (length xs) + forM (zip [0..] xs) $ \(i, x) -> + write dst i x + copy dst doff src soff len + forM [0..length xs - 1] $ \i -> read dst i + expected = take doff xs ++ take len (drop soff ys) ++ drop (doff + len) xs + in actual === expected + , testProperty "copyMutable" $ \Copy{xs,doff,ys,soff,len} -> + let actual = runST $ do + src <- uninitialized (length ys) + forM (zip [0..] ys) $ \(i, y) -> + write src i y + dst <- uninitialized (length xs) + forM (zip [0..] xs) $ \(i, x) -> + write dst i x + copyMutable dst doff src soff len + forM [0..length xs - 1] $ \i -> read dst i + expected = take doff xs ++ take len (drop soff ys) ++ drop (doff + len) xs + in actual === expected + ] + ] + +--- Lift the functions under test --- + +index :: ByteArray -> Int -> Bool +index (ByteArray arr) (I# i) = lift (index# arr i) + +read :: MutableByteArray s -> Int -> ST s Bool +read (MutableByteArray marr) (I# ix) = ST (\st -> + let (# st', v #) = read# marr ix st + in (# st', lift v #)) + +write :: MutableByteArray s -> Int -> Bool -> ST s () +write (MutableByteArray marr) (I# i) v = ST (\st -> + (# write# marr i (unlift v) st, () #)) + +uninitialized :: Int -> ST s (MutableByteArray s) +uninitialized (I# n) = ST (\st -> + let (# st', marr #) = uninitialized# n st + in (# st', MutableByteArray marr #)) + +initialized :: Int -> Bool -> ST s (MutableByteArray s) +initialized (I# n) v = ST (\st -> + let (# st', marr #) = initialized# n (unlift v) st + in (# st', MutableByteArray marr #)) + +shrink :: MutableByteArray s -> Int -> ST s (MutableByteArray s) +shrink (MutableByteArray marr) (I# i) = ST (\st -> + let (# st', marr' #) = shrink# marr i st + in (# st', MutableByteArray marr' #)) + +set :: MutableByteArray s -> Int -> Int -> Bool -> ST s () +set (MutableByteArray marr) (I# off) (I# len) v = ST (\st -> + (# set# marr off len (unlift v) st, () #)) + +copy :: MutableByteArray s -> Int -> ByteArray -> Int -> Int -> ST s () +copy (MutableByteArray dst) (I# doff) (ByteArray src) (I# soff) (I# len) = ST (\st -> + (# copy# dst doff src soff len st, () #)) + +copyMutable :: MutableByteArray s -> Int -> MutableByteArray s -> Int -> Int -> ST s () +copyMutable (MutableByteArray dst) (I# doff) (MutableByteArray src) (I# soff) (I# len) = ST (\st -> + (# copyMutable# dst doff src soff len st, () #)) + + +data Shrink = Shrink { xs::[Bool], sz::Int} deriving (Show) +instance QC.Arbitrary Shrink where + arbitrary = do + x' <- QC.arbitrary + xs' <- QC.arbitrary + let xs = x':xs' + sz <- QC.chooseInt (1, length xs) + pure Shrink{xs,sz} + +data Set = Set { xs::[Bool], off::Int, len::Int, v::Bool } deriving (Show) +instance QC.Arbitrary Set where + arbitrary = do + xs <- QC.arbitrary + off <- QC.chooseInt (0,max 0 (length xs - 1)) + len <- QC.chooseInt (0,length xs - off) + v <- QC.arbitrary + pure Set{xs,off,len,v} + +data Copy = Copy { xs::[Bool],doff::Int,ys::[Bool],soff::Int,len::Int } deriving (Show) +instance QC.Arbitrary Copy where + arbitrary = do + xs <- QC.arbitrary + doff <- QC.chooseInt (0, max 0 (length xs - 1)) + ys <- QC.arbitrary + soff <- QC.chooseInt (0, max 0 (length ys - 1)) + len <- QC.chooseInt (0, min (length xs - doff) (length ys - soff)) + pure Copy{xs,doff,ys,soff,len}