diff --git a/Data/HashMap/Internal.hs b/Data/HashMap/Internal.hs index 0bc3c4db..1ff5c872 100644 --- a/Data/HashMap/Internal.hs +++ b/Data/HashMap/Internal.hs @@ -4,12 +4,12 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeInType #-} {-# LANGUAGE UnboxedSums #-} {-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_GHC -fno-full-laziness -funbox-strict-fields #-} @@ -166,7 +166,7 @@ import Data.HashMap.Internal.List (isPermutationBy, unorderedCompare) import Data.Semigroup (Semigroup (..), stimesIdempotentMonoid) import GHC.Exts (Int (..), Int#, TYPE, (==#)) import GHC.Stack (HasCallStack) -import Prelude hiding (Foldable(..), filter, lookup, map, +import Prelude hiding (Foldable (..), filter, lookup, map, pred) import Text.Read hiding (step) @@ -1948,13 +1948,14 @@ intersectionArrayBy f !b1 !b2 !ary1 !ary2 intersectionCollisions :: Eq k => (k -> v1 -> v2 -> (# v3 #)) -> Hash -> Hash -> A.Array (Leaf k v1) -> A.Array (Leaf k v2) -> HashMap k v3 intersectionCollisions f h1 h2 ary1 ary2 | h1 == h2 = runST $ do - mary2 <- A.thaw ary2 0 $ A.length ary2 - mary <- A.new_ $ min (A.length ary1) (A.length ary2) + let !n2 = A.length ary2 + mary2 <- A.thaw ary2 0 n2 + mary <- A.new_ $ min (A.length ary1) n2 let go i j - | i >= A.length ary1 || j >= A.lengthM mary2 = pure j + | i >= A.length ary1 || j >= n2 = pure j | otherwise = do L k1 v1 <- A.indexM ary1 i - searchSwap k1 j mary2 >>= \case + searchSwap mary2 n2 k1 j >>= \case Just (L _k2 v2) -> do let !(# v3 #) = f k1 v1 v2 A.write mary j $ L k1 v3 @@ -1978,18 +1979,18 @@ intersectionCollisions f h1 h2 ary1 ary2 -- undefined 2 1 4 -- @ -- We don't actually need to write undefined, we just have to make sure that the next search starts 1 after the current one. -searchSwap :: Eq k => k -> Int -> A.MArray s (Leaf k v) -> ST s (Maybe (Leaf k v)) -searchSwap toFind start = go start toFind start +searchSwap :: Eq k => A.MArray s (Leaf k v) -> Int -> k -> Int -> ST s (Maybe (Leaf k v)) +searchSwap mary n toFind start = go start toFind start where - go i0 k i mary - | i >= A.lengthM mary = pure Nothing + go i0 k i + | i >= n = pure Nothing | otherwise = do l@(L k' _v) <- A.read mary i if k == k' then do A.write mary i =<< A.read mary i0 pure $ Just l - else go i0 k (i + 1) mary + else go i0 k (i + 1) {-# INLINE searchSwap #-} ------------------------------------------------------------------------ diff --git a/Data/HashMap/Internal/Array.hs b/Data/HashMap/Internal/Array.hs index 4ba10953..3e47b0c4 100644 --- a/Data/HashMap/Internal/Array.hs +++ b/Data/HashMap/Internal/Array.hs @@ -80,26 +80,28 @@ module Data.HashMap.Internal.Array , shrink ) where -import Control.Applicative (liftA2) +import Control.Applicative (Applicative (..)) import Control.DeepSeq (NFData (..), NFData1 (..)) import Control.Monad ((>=>)) import Control.Monad.ST (runST, stToIO) import GHC.Exts (Int (..), SmallArray#, SmallMutableArray#, cloneSmallMutableArray#, copySmallArray#, - copySmallMutableArray#, indexSmallArray#, - newSmallArray#, readSmallArray#, + copySmallMutableArray#, getSizeofSmallMutableArray#, + indexSmallArray#, newSmallArray#, readSmallArray#, reallyUnsafePtrEquality#, sizeofSmallArray#, - sizeofSmallMutableArray#, tagToEnum#, - thawSmallArray#, unsafeCoerce#, + tagToEnum#, thawSmallArray#, unsafeCoerce#, unsafeFreezeSmallArray#, unsafeThawSmallArray#, writeSmallArray#) import GHC.ST (ST (..)) -import Prelude hiding (Foldable(..), all, filter, +import Prelude hiding (Applicative (..), Foldable (..), all, filter, map, read, traverse) import qualified GHC.Exts as Exts import qualified Language.Haskell.TH.Syntax as TH + #if defined(ASSERTS) +import GHC.Exts (sizeofSmallMutableArray#) + import qualified Prelude #endif @@ -158,10 +160,19 @@ data MArray s a = MArray { unMArray :: !(SmallMutableArray# s a) } -lengthM :: MArray s a -> Int -lengthM mary = I# (sizeofSmallMutableArray# (unMArray mary)) +lengthM :: MArray s a -> ST s Int +lengthM (MArray ary) = ST $ \s -> + case getSizeofSmallMutableArray# ary s of + (# s', n #) -> (# s', I# n #) {-# INLINE lengthM #-} +#if defined(ASSERTS) +-- | Unsafe. Only for use in the @CHECK_*@ pragmas. +unsafeLengthM :: MArray s a -> Int +unsafeLengthM mary = I# (sizeofSmallMutableArray# (unMArray mary)) +{-# INLINE unsafeLengthM #-} +#endif + ------------------------------------------------------------------------ instance NFData a => NFData (Array a) where @@ -211,7 +222,7 @@ new_ n = new n undefinedElem shrink :: MArray s a -> Int -> ST s (MArray s a) shrink mary _n@(I# n#) = CHECK_GT("shrink", _n, (0 :: Int)) - CHECK_LE("shrink", _n, (lengthM mary)) + CHECK_LE("shrink", _n, (unsafeLengthM mary)) ST $ \s -> case Exts.shrinkSmallMutableArray# (unMArray mary) n# s of s' -> (# s', mary #) {-# INLINE shrink #-} @@ -242,13 +253,13 @@ pair x y = run $ do read :: MArray s a -> Int -> ST s a read ary _i@(I# i#) = ST $ \ s -> - CHECK_BOUNDS("read", lengthM ary, _i) + CHECK_BOUNDS("read", unsafeLengthM ary, _i) readSmallArray# (unMArray ary) i# s {-# INLINE read #-} write :: MArray s a -> Int -> a -> ST s () write ary _i@(I# i#) b = ST $ \ s -> - CHECK_BOUNDS("write", lengthM ary, _i) + CHECK_BOUNDS("write", unsafeLengthM ary, _i) case writeSmallArray# (unMArray ary) i# b s of s' -> (# s' , () #) {-# INLINE write #-} @@ -291,7 +302,7 @@ run act = runST $ act >>= unsafeFreeze copy :: Array e -> Int -> MArray s e -> Int -> Int -> ST s () copy !src !_sidx@(I# sidx#) !dst !_didx@(I# didx#) _n@(I# n#) = CHECK_LE("copy", _sidx + _n, length src) - CHECK_LE("copy", _didx + _n, lengthM dst) + CHECK_LE("copy", _didx + _n, unsafeLengthM dst) ST $ \ s# -> case copySmallArray# (unArray src) sidx# (unMArray dst) didx# n# s# of s2 -> (# s2, () #) @@ -299,16 +310,16 @@ copy !src !_sidx@(I# sidx#) !dst !_didx@(I# didx#) _n@(I# n#) = -- | Unsafely copy the elements of an array. Array bounds are not checked. copyM :: MArray s e -> Int -> MArray s e -> Int -> Int -> ST s () copyM !src !_sidx@(I# sidx#) !dst !_didx@(I# didx#) _n@(I# n#) = - CHECK_BOUNDS("copyM: src", lengthM src, _sidx + _n - 1) - CHECK_BOUNDS("copyM: dst", lengthM dst, _didx + _n - 1) + CHECK_BOUNDS("copyM: src", unsafeLengthM src, _sidx + _n - 1) + CHECK_BOUNDS("copyM: dst", unsafeLengthM dst, _didx + _n - 1) ST $ \ s# -> case copySmallMutableArray# (unMArray src) sidx# (unMArray dst) didx# n# s# of s2 -> (# s2, () #) cloneM :: MArray s a -> Int -> Int -> ST s (MArray s a) cloneM _mary@(MArray mary#) _off@(I# off#) _len@(I# len#) = - CHECK_BOUNDS("cloneM_off", lengthM _mary, _off) - CHECK_BOUNDS("cloneM_end", lengthM _mary, _off + _len - 1) + CHECK_BOUNDS("cloneM_off", unsafeLengthM _mary, _off) + CHECK_BOUNDS("cloneM_end", unsafeLengthM _mary, _off + _len - 1) ST $ \ s -> case cloneSmallMutableArray# mary# off# len# s of (# s', mary'# #) -> (# s', MArray mary'# #) diff --git a/benchmarks/Benchmarks.hs b/benchmarks/Benchmarks.hs index ae05c422..67591a9b 100644 --- a/benchmarks/Benchmarks.hs +++ b/benchmarks/Benchmarks.hs @@ -9,12 +9,12 @@ module Main where import Control.DeepSeq (NFData (..)) import Data.Bits ((.&.)) +import Data.Foldable (Foldable (..)) import Data.Functor.Identity (Identity (..)) import Data.Hashable (Hashable, hash) -import Data.List (foldl') import Data.Maybe (fromMaybe) import GHC.Generics (Generic) -import Prelude hiding (lookup) +import Prelude hiding (Foldable (..), lookup) import Test.Tasty.Bench (bench, bgroup, defaultMain, env, nf, whnf) import qualified Data.ByteString as BS diff --git a/tests/Main.hs b/tests/Main.hs index 5880ba72..24d43715 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,7 +1,7 @@ module Main (main) where import GHC.IO.Encoding (setLocaleEncoding, utf8) -import Test.Tasty (defaultMain, testGroup) +import Test.Tasty (defaultMain, testGroup) import qualified Properties import qualified Regressions diff --git a/tests/Regressions.hs b/tests/Regressions.hs index 8e86e2b7..486932ee 100644 --- a/tests/Regressions.hs +++ b/tests/Regressions.hs @@ -4,6 +4,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -Wno-x-partial #-} module Regressions (tests) where import Control.Exception (evaluate) diff --git a/tests/Strictness.hs b/tests/Strictness.hs index 46062df7..b446ce14 100644 --- a/tests/Strictness.hs +++ b/tests/Strictness.hs @@ -4,7 +4,7 @@ module Strictness (tests) where import Control.Arrow (second) import Control.Monad (guard) -import Data.Foldable (foldl') +import Data.Foldable (Foldable (..)) import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import Data.Maybe (fromMaybe, isJust) @@ -17,6 +17,8 @@ import Test.Tasty.QuickCheck (testProperty) import Text.Show.Functions () import Util.Key (Key) +import Prelude hiding (Foldable (..)) + import qualified Data.HashMap.Strict as HM instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where