diff options
author | Dominic Steinitz <dominic@steinitz.org> | 2018-04-03 07:41:34 +0100 |
---|---|---|
committer | Dominic Steinitz <dominic@steinitz.org> | 2018-04-03 07:41:34 +0100 |
commit | 62d745b157313909c275a00cdb0226741678031b (patch) | |
tree | e3ff2d556ce9c0b653d25879a1336ca5ed1ced2a /packages/base/src/Internal/Vector.hs | |
parent | 617625917faa0d8ab514de2b4f0a178e66dfbf1d (diff) | |
parent | 6c120cf8c1271da8c39926b47384ac1b117e7c96 (diff) |
Merge branch 'master' into sundials-clean
Diffstat (limited to 'packages/base/src/Internal/Vector.hs')
-rw-r--r-- | packages/base/src/Internal/Vector.hs | 7 |
1 files changed, 7 insertions, 0 deletions
diff --git a/packages/base/src/Internal/Vector.hs b/packages/base/src/Internal/Vector.hs index 67d0416..dedb822 100644 --- a/packages/base/src/Internal/Vector.hs +++ b/packages/base/src/Internal/Vector.hs | |||
@@ -1,6 +1,7 @@ | |||
1 | {-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns, FlexibleContexts #-} | 1 | {-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns, FlexibleContexts #-} |
2 | {-# LANGUAGE TypeSynonymInstances #-} | 2 | {-# LANGUAGE TypeSynonymInstances #-} |
3 | 3 | ||
4 | {-# OPTIONS_GHC -fno-warn-orphans #-} | ||
4 | 5 | ||
5 | -- | | 6 | -- | |
6 | -- Module : Internal.Vector | 7 | -- Module : Internal.Vector |
@@ -40,6 +41,7 @@ import qualified Data.Vector.Storable as Vector | |||
40 | import Data.Vector.Storable(Vector, fromList, unsafeToForeignPtr, unsafeFromForeignPtr, unsafeWith) | 41 | import Data.Vector.Storable(Vector, fromList, unsafeToForeignPtr, unsafeFromForeignPtr, unsafeWith) |
41 | 42 | ||
42 | import Data.Binary | 43 | import Data.Binary |
44 | import Data.Binary.Put | ||
43 | import Control.Monad(replicateM) | 45 | import Control.Monad(replicateM) |
44 | import qualified Data.ByteString.Internal as BS | 46 | import qualified Data.ByteString.Internal as BS |
45 | import Data.Vector.Storable.Internal(updPtr) | 47 | import Data.Vector.Storable.Internal(updPtr) |
@@ -92,6 +94,7 @@ createVector n = do | |||
92 | 94 | ||
93 | -} | 95 | -} |
94 | 96 | ||
97 | safeRead :: Storable a => Vector a -> (Ptr a -> IO c) -> c | ||
95 | safeRead v = inlinePerformIO . unsafeWith v | 98 | safeRead v = inlinePerformIO . unsafeWith v |
96 | {-# INLINE safeRead #-} | 99 | {-# INLINE safeRead #-} |
97 | 100 | ||
@@ -283,11 +286,13 @@ foldVectorWithIndex f x v = unsafePerformIO $ | |||
283 | go (dim v -1) x | 286 | go (dim v -1) x |
284 | {-# INLINE foldVectorWithIndex #-} | 287 | {-# INLINE foldVectorWithIndex #-} |
285 | 288 | ||
289 | foldLoop :: (Int -> t -> t) -> t -> Int -> t | ||
286 | foldLoop f s0 d = go (d - 1) s0 | 290 | foldLoop f s0 d = go (d - 1) s0 |
287 | where | 291 | where |
288 | go 0 s = f (0::Int) s | 292 | go 0 s = f (0::Int) s |
289 | go !j !s = go (j - 1) (f j s) | 293 | go !j !s = go (j - 1) (f j s) |
290 | 294 | ||
295 | foldVectorG :: Storable t1 => (Int -> (Int -> t1) -> t -> t) -> t -> Vector t1 -> t | ||
291 | foldVectorG f s0 v = foldLoop g s0 (dim v) | 296 | foldVectorG f s0 v = foldLoop g s0 (dim v) |
292 | where g !k !s = f k (safeRead v . flip peekElemOff) s | 297 | where g !k !s = f k (safeRead v . flip peekElemOff) s |
293 | {-# INLINE g #-} -- Thanks to Ryan Ingram (http://permalink.gmane.org/gmane.comp.lang.haskell.cafe/46479) | 298 | {-# INLINE g #-} -- Thanks to Ryan Ingram (http://permalink.gmane.org/gmane.comp.lang.haskell.cafe/46479) |
@@ -390,8 +395,10 @@ chunks d = let c = d `div` chunk | |||
390 | m = d `mod` chunk | 395 | m = d `mod` chunk |
391 | in if m /= 0 then reverse (m:(replicate c chunk)) else (replicate c chunk) | 396 | in if m /= 0 then reverse (m:(replicate c chunk)) else (replicate c chunk) |
392 | 397 | ||
398 | putVector :: (Storable t, Binary t) => Vector t -> Data.Binary.Put.PutM () | ||
393 | putVector v = mapM_ put $! toList v | 399 | putVector v = mapM_ put $! toList v |
394 | 400 | ||
401 | getVector :: (Storable a, Binary a) => Int -> Get (Vector a) | ||
395 | getVector d = do | 402 | getVector d = do |
396 | xs <- replicateM d get | 403 | xs <- replicateM d get |
397 | return $! fromList xs | 404 | return $! fromList xs |