diff --git a/Data/Array/Base.hs b/Data/Array/Base.hs --- a/Data/Array/Base.hs +++ b/Data/Array/Base.hs @@ -1,7 +1,5 @@ {-# LANGUAGE BangPatterns, CPP, RankNTypes, MagicHash, UnboxedTuples, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, DeriveDataTypeable, UnliftedFFITypes #-} -#if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE RoleAnnotations #-} -#endif {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -32,13 +30,10 @@ import qualified GHC.Arr as Arr import qualified GHC.Arr as ArrST import GHC.ST ( ST(..), runST ) -import GHC.Base ( IO(..) ) +import GHC.Base ( IO(..), divInt# ) import GHC.Exts import GHC.Ptr ( nullPtr, nullFunPtr ) import GHC.Stable ( StablePtr(..) ) -#if !MIN_VERSION_base(4,6,0) -import GHC.Exts ( Word(..) ) -#endif import GHC.Int ( Int8(..), Int16(..), Int32(..), Int64(..) ) import GHC.Word ( Word8(..), Word16(..), Word32(..), Word64(..) ) import GHC.IO ( stToIO ) @@ -404,10 +399,8 @@ -- data UArray i e = UArray !i !i !Int ByteArray# deriving Typeable -#if __GLASGOW_HASKELL__ >= 708 -- There are class-based invariants on both parameters. See also #9220. type role UArray nominal nominal -#endif {-# INLINE unsafeArrayUArray #-} unsafeArrayUArray :: (MArray (STUArray s) e (ST s), Ix i) @@ -504,11 +497,7 @@ {-# INLINE unsafeArray #-} unsafeArray lu ies = runST (unsafeArrayUArray lu ies False) {-# INLINE unsafeAt #-} -#if __GLASGOW_HASKELL__ > 706 unsafeAt (UArray _ _ _ arr#) (I# i#) = isTrue# -#else - unsafeAt (UArray _ _ _ arr#) (I# i#) = -#endif ((indexWordArray# arr# (bOOL_INDEX i#) `and#` bOOL_BIT i#) `neWord#` int2Word# 0#) @@ -991,19 +980,13 @@ -- 'STArray' provides. data STUArray s i e = STUArray !i !i !Int (MutableByteArray# s) deriving Typeable -#if __GLASGOW_HASKELL__ >= 708 -- The "ST" parameter must be nominal for the safety of the ST trick. -- The other parameters have class constraints. See also #9220. type role STUArray nominal nominal nominal -#endif instance Eq (STUArray s i e) where STUArray _ _ _ arr1# == STUArray _ _ _ arr2# = -#if __GLASGOW_HASKELL__ > 706 isTrue# (sameMutableByteArray# arr1# arr2#) -#else - sameMutableByteArray# arr1# arr2# -#endif {-# INLINE unsafeNewArraySTUArray_ #-} unsafeNewArraySTUArray_ :: Ix i @@ -1023,21 +1006,13 @@ getNumElements (STUArray _ _ n _) = return n {-# INLINE newArray #-} newArray (l,u) initialValue = ST $ \s1# -> - case safeRangeSize (l,u) of { n@(I# n#) -> - case newByteArray# (bOOL_SCALE n#) s1# of { (# s2#, marr# #) -> - case bOOL_WORD_SCALE n# of { n'# -> -#if __GLASGOW_HASKELL__ > 706 - let loop i# s3# | isTrue# (i# ==# n'#) = s3# -#else - let loop i# s3# | i# ==# n'# = s3# -#endif - | otherwise = - case writeWordArray# marr# i# e# s3# of { s4# -> - loop (i# +# 1#) s4# } in - case loop 0# s2# of { s3# -> + case safeRangeSize (l,u) of { n@(I# n#) -> + case bOOL_SCALE n# of { nbytes# -> + case newByteArray# nbytes# s1# of { (# s2#, marr# #) -> + case setByteArray# marr# 0# nbytes# e# s2# of { s3# -> (# s3#, STUArray l u n marr# #) }}}} where - !(W# e#) = if initialValue then maxBound else 0 + !(I# e#) = if initialValue then 0xff else 0x0 {-# INLINE unsafeNewArray_ #-} unsafeNewArray_ (l,u) = unsafeNewArraySTUArray_ (l,u) bOOL_SCALE {-# INLINE newArray_ #-} @@ -1045,11 +1020,7 @@ {-# INLINE unsafeRead #-} unsafeRead (STUArray _ _ _ marr#) (I# i#) = ST $ \s1# -> case readWordArray# marr# (bOOL_INDEX i#) s1# of { (# s2#, e# #) -> -#if __GLASGOW_HASKELL__ > 706 (# s2#, isTrue# ((e# `and#` bOOL_BIT i#) `neWord#` int2Word# 0#) :: Bool #) } -#else - (# s2#, (e# `and#` bOOL_BIT i# `neWord#` int2Word# 0#) :: Bool #) } -#endif {-# INLINE unsafeWrite #-} unsafeWrite (STUArray _ _ _ marr#) (I# i#) e = ST $ \s1# -> case bOOL_INDEX i# of { j# -> @@ -1065,7 +1036,7 @@ {-# INLINE getNumElements #-} getNumElements (STUArray _ _ n _) = return n {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ (l,u) = unsafeNewArraySTUArray_ (l,u) (*# 4#) + unsafeNewArray_ (l,u) = unsafeNewArraySTUArray_ (l,u) (safe_scale 4#) {-# INLINE newArray_ #-} newArray_ arrBounds = newArray arrBounds (chr 0) {-# INLINE unsafeRead #-} @@ -1227,7 +1198,7 @@ {-# INLINE getNumElements #-} getNumElements (STUArray _ _ n _) = return n {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ (l,u) = unsafeNewArraySTUArray_ (l,u) (*# 2#) + unsafeNewArray_ (l,u) = unsafeNewArraySTUArray_ (l,u) (safe_scale 2#) {-# INLINE newArray_ #-} newArray_ arrBounds = newArray arrBounds 0 {-# INLINE unsafeRead #-} @@ -1245,7 +1216,7 @@ {-# INLINE getNumElements #-} getNumElements (STUArray _ _ n _) = return n {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ (l,u) = unsafeNewArraySTUArray_ (l,u) (*# 4#) + unsafeNewArray_ (l,u) = unsafeNewArraySTUArray_ (l,u) (safe_scale 4#) {-# INLINE newArray_ #-} newArray_ arrBounds = newArray arrBounds 0 {-# INLINE unsafeRead #-} @@ -1263,7 +1234,7 @@ {-# INLINE getNumElements #-} getNumElements (STUArray _ _ n _) = return n {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ (l,u) = unsafeNewArraySTUArray_ (l,u) (*# 8#) + unsafeNewArray_ (l,u) = unsafeNewArraySTUArray_ (l,u) (safe_scale 8#) {-# INLINE newArray_ #-} newArray_ arrBounds = newArray arrBounds 0 {-# INLINE unsafeRead #-} @@ -1299,7 +1270,7 @@ {-# INLINE getNumElements #-} getNumElements (STUArray _ _ n _) = return n {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ (l,u) = unsafeNewArraySTUArray_ (l,u) (*# 2#) + unsafeNewArray_ (l,u) = unsafeNewArraySTUArray_ (l,u) (safe_scale 2#) {-# INLINE newArray_ #-} newArray_ arrBounds = newArray arrBounds 0 {-# INLINE unsafeRead #-} @@ -1317,7 +1288,7 @@ {-# INLINE getNumElements #-} getNumElements (STUArray _ _ n _) = return n {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ (l,u) = unsafeNewArraySTUArray_ (l,u) (*# 4#) + unsafeNewArray_ (l,u) = unsafeNewArraySTUArray_ (l,u) (safe_scale 4#) {-# INLINE newArray_ #-} newArray_ arrBounds = newArray arrBounds 0 {-# INLINE unsafeRead #-} @@ -1335,7 +1306,7 @@ {-# INLINE getNumElements #-} getNumElements (STUArray _ _ n _) = return n {-# INLINE unsafeNewArray_ #-} - unsafeNewArray_ (l,u) = unsafeNewArraySTUArray_ (l,u) (*# 8#) + unsafeNewArray_ (l,u) = unsafeNewArraySTUArray_ (l,u) (safe_scale 8#) {-# INLINE newArray_ #-} newArray_ arrBounds = newArray arrBounds 0 {-# INLINE unsafeRead #-} @@ -1350,16 +1321,26 @@ ----------------------------------------------------------------------------- -- Translation between elements and bytes -bOOL_SCALE, bOOL_WORD_SCALE, - wORD_SCALE, dOUBLE_SCALE, fLOAT_SCALE :: Int# -> Int# -bOOL_SCALE n# = (n# +# last#) `uncheckedIShiftRA#` 3# - where !(I# last#) = SIZEOF_HSWORD * 8 - 1 -bOOL_WORD_SCALE n# = bOOL_INDEX (n# +# last#) - where !(I# last#) = SIZEOF_HSWORD * 8 - 1 -wORD_SCALE n# = scale# *# n# where !(I# scale#) = SIZEOF_HSWORD -dOUBLE_SCALE n# = scale# *# n# where !(I# scale#) = SIZEOF_HSDOUBLE -fLOAT_SCALE n# = scale# *# n# where !(I# scale#) = SIZEOF_HSFLOAT +bOOL_SCALE, wORD_SCALE, dOUBLE_SCALE, fLOAT_SCALE :: Int# -> Int# +bOOL_SCALE n# = + -- + 7 to handle case where n is not divisible by 8 + (n# +# 7#) `uncheckedIShiftRA#` 3# +wORD_SCALE n# = safe_scale scale# n# where !(I# scale#) = SIZEOF_HSWORD +dOUBLE_SCALE n# = safe_scale scale# n# where !(I# scale#) = SIZEOF_HSDOUBLE +fLOAT_SCALE n# = safe_scale scale# n# where !(I# scale#) = SIZEOF_HSFLOAT +safe_scale :: Int# -> Int# -> Int# +safe_scale scale# n# + | not overflow = res# + | otherwise = error $ "Data.Array.Base.safe_scale: Overflow; scale: " + ++ show (I# scale#) ++ ", n: " ++ show (I# n#) + where + !res# = scale# *# n# + !overflow = isTrue# (maxN# `divInt#` scale# <# n#) + !(I# maxN#) = maxBound +{-# INLINE safe_scale #-} + +-- | The index of the word which the given @Bool@ array elements falls within. bOOL_INDEX :: Int# -> Int# #if SIZEOF_HSWORD == 4 bOOL_INDEX i# = i# `uncheckedIShiftRA#` 5# diff --git a/Data/Array/IO/Internals.hs b/Data/Array/IO/Internals.hs --- a/Data/Array/IO/Internals.hs +++ b/Data/Array/IO/Internals.hs @@ -1,8 +1,6 @@ {-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, CPP #-} -#if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE RoleAnnotations #-} -#endif {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -24,6 +22,7 @@ IOUArray(..), -- instance of: Eq, Typeable castIOUArray, -- :: IOUArray ix a -> IO (IOUArray ix b) unsafeThawIOUArray, + unsafeFreezeIOUArray ) where import Data.Int @@ -54,10 +53,8 @@ -- newtype IOUArray i e = IOUArray (STUArray RealWorld i e) deriving Typeable -#if __GLASGOW_HASKELL__ >= 708 -- Both parameters have class-based invariants. See also #9220. type role IOUArray nominal nominal -#endif instance Eq (IOUArray i e) where IOUArray s1 == IOUArray s2 = s1 == s2 diff --git a/Data/Array/Storable/Internals.hs b/Data/Array/Storable/Internals.hs --- a/Data/Array/Storable/Internals.hs +++ b/Data/Array/Storable/Internals.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, CPP #-} -#if __GLASGOW_HASKELL__ >= 708 -{-# LANGUAGE RoleAnnotations #-} -#endif +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, RoleAnnotations #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | @@ -31,10 +28,8 @@ -- |The array type data StorableArray i e = StorableArray !i !i Int !(ForeignPtr e) -#if __GLASGOW_HASKELL__ >= 708 -- Both parameters have class-based invariants. See also #9220. type role StorableArray nominal nominal -#endif instance Storable e => MArray StorableArray e IO where getBounds (StorableArray l u _ _) = return (l,u) diff --git a/array.cabal b/array.cabal --- a/array.cabal +++ b/array.cabal @@ -1,5 +1,5 @@ name: array -version: 0.5.1.1 +version: 0.5.2.0 -- NOTE: Don't forget to update ./changelog.md license: BSD3 license-file: LICENSE @@ -9,7 +9,7 @@ category: Data Structures build-type: Simple cabal-version: >=1.10 -tested-with: GHC==7.6.3, GHC==7.6.2, GHC==7.6.1, GHC==7.4.2, GHC==7.4.1 +tested-with: GHC==8.2.1, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4 description: In addition to providing the "Data.Array" module , @@ -37,7 +37,7 @@ Trustworthy, UnboxedTuples, UnliftedFFITypes - build-depends: base >= 4.5 && < 4.10 + build-depends: base >= 4.7 && < 4.11 ghc-options: -Wall exposed-modules: Data.Array diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,13 @@ # Changelog for [`array` package](http://hackage.haskell.org/package/array) +## 0.5.2.0 *Jul 2017* + + * Bundled with GHC 8.2.1 + * Overflow check in `unsafeNewArray` (#229) + * Fix and simplify handling of `Bool` arrays + * Export `unsafeFreezeIOUArray` from `Data.Array.IO.Internals` + * Drop support for GHC versions prior to GHC 7.8 + ## 0.5.1.1 *Apr 2016* * Bundled with GHC 8.0.1