Ticket #2589: Vector.hs

File Vector.hs, 7.6 KB (added by gwright, 7 years ago)

File that triggers the reported ghci problem.

Line 
1{-# LANGUAGE CPP, ForeignFunctionInterface #-}
2{-# OPTIONS_GHC -XUnliftedFFITypes -XMagicHash -XUnboxedTuples -XDeriveDataTypeable #-}
3-- |
4-- Module      : Data.Vector.Shore.Interna
5-- License     : BSD-style
6-- Maintainer  : Gregory Wright
7-- Stability   : experimental
8-- Portability : portable
9--
10-- A module containing a low level interface to "Shore Vectors".
11-- "Shore vectors" are unboxed, storable vectors whose contents are managed
12-- as foreign data.  (Whence the name "shore vector" since they live
13-- on the C-side.)
14--
15-- ATM, this is just a transcription of the code from ByteString, generalized
16-- to arbitrary storables.
17--
18module Data.Vector.Shore.Internal (
19
20        -- * The @ByteString@ type and representation
21        Vector(..),             -- instances: Eq, Ord, Show, Read, Data, Typeable
22
23        -- * Low level introduction and elimination
24        create,                 -- :: Int -> (Ptr Word8 -> IO ()) -> IO ByteString
25        unsafeCreate,           -- :: Int -> (Ptr Word8 -> IO ()) ->  ByteString
26        mallocVectorPayload,    -- :: Int -> IO (ForeignPtr a)
27
28        -- * Conversion to and from ForeignPtrs
29        fromForeignPtr,         -- :: ForeignPtr Word8 -> Int -> Int -> ByteString
30        toForeignPtr,           -- :: ByteString -> (ForeignPtr Word8, Int, Int)
31
32        -- * Utilities
33        inlinePerformIO,        -- :: IO a -> a
34        nullForeignPtr,         -- :: ForeignPtr Word8
35  ) where
36
37import Foreign.ForeignPtr       (ForeignPtr, withForeignPtr)
38import Foreign.Marshal.Array    (advancePtr)
39import Foreign.Ptr              (Ptr, FunPtr, plusPtr)
40import Foreign.Storable         (Storable(..))
41import Foreign.C.Types          (CInt, CSize, CULong)
42import Foreign.C.String         (CString)
43
44#ifndef __NHC__
45import Control.Exception        (assert)
46#endif
47
48import Data.Char                (ord)
49import Data.Word                (Word8)
50
51#if defined(__GLASGOW_HASKELL__)
52import Data.Generics            (Data(..), Typeable(..))
53import GHC.Ptr                  (Ptr(..))
54import GHC.Base                 (realWorld#,unsafeChr)
55import GHC.IOBase               (IO(IO), RawBuffer)
56#if __GLASGOW_HASKELL__ >= 608
57import GHC.IOBase               (unsafeDupablePerformIO)
58#else
59import GHC.IOBase               (unsafePerformIO)
60#endif
61#else
62import Data.Char                (chr)
63import System.IO.Unsafe         (unsafePerformIO)
64#endif
65
66#if __GLASGOW_HASKELL__ >= 605 && !defined(SLOW_FOREIGN_PTR)
67import GHC.ForeignPtr           (mallocPlainForeignPtrBytes)
68#else
69import Foreign.ForeignPtr       (mallocForeignPtrBytes)
70#endif
71
72#if __GLASGOW_HASKELL__>=605
73import GHC.ForeignPtr           (ForeignPtr(ForeignPtr))
74import GHC.Base                 (nullAddr#)
75#else
76import Foreign.Ptr              (nullPtr)
77#endif
78
79#if __HUGS__
80import Hugs.ForeignPtr          (newForeignPtr_)
81#elif __GLASGOW_HASKELL__<=604
82import Foreign.ForeignPtr       (newForeignPtr_)
83#endif
84
85-- CFILES stuff is Hugs only
86{-# CFILES cbits/fpstring.c #-}
87
88-- An alternative to Control.Exception (assert) for nhc98
89#ifdef __NHC__
90#define assert  assertS "__FILE__ : __LINE__"
91assertS :: String -> Bool -> a -> a
92assertS _ True  = id
93assertS s False = error ("assertion failed at "++s)
94#endif
95
96-- -----------------------------------------------------------------------------
97--
98-- Useful macros, until we have bang patterns
99--
100
101#define STRICT1(f) f a | a `seq` False = undefined
102#define STRICT2(f) f a b | a `seq` b `seq` False = undefined
103#define STRICT3(f) f a b c | a `seq` b `seq` c `seq` False = undefined
104#define STRICT4(f) f a b c d | a `seq` b `seq` c `seq` d `seq` False = undefined
105#define STRICT5(f) f a b c d e | a `seq` b `seq` c `seq` d `seq` e `seq` False = undefined
106
107-- -----------------------------------------------------------------------------
108
109-- | A space-efficient representation of a Storable vector.
110--
111-- Instances of Eq, Ord, Read, Show, Data, Typeable
112--
113data Vector a = V {-# UNPACK #-} !(ForeignPtr a) -- payload
114                  {-# UNPACK #-} !Int            -- offset
115                  {-# UNPACK #-} !Int            -- length
116
117#if defined(__GLASGOW_HASKELL__)
118    deriving (Data, Typeable)
119#endif
120
121-- | /O(n)/ Converts a 'Vector a' to a '[b]', using a conversion function.
122unpackWith :: Storable a => (a -> b) -> Vector a -> [b]
123unpackWith _ (V _  _ 0) = []
124unpackWith k (V ps s l) = inlinePerformIO $ withForeignPtr ps $ \p ->
125        go (p `plusPtr` s) (l - 1) []
126    where
127        STRICT3(go)
128        go p 0 acc = peek p          >>= \e -> return (k e : acc)
129        go p n acc = peekElemOff p n >>= \e -> go p (n-1) (k e : acc)
130{-# INLINE unpackWith #-}
131
132-- | /O(n)/ Convert a '[a]' into a 'Vector b' using some
133-- conversion function
134packWith :: Storable b => (a -> b) -> [a] -> Vector b
135packWith k str = unsafeCreate (length str) $ \p -> go p str
136    where
137        STRICT2(go)
138        go _ []     = return ()
139        go p (x:xs) = poke p (k x) >> go (p `advancePtr` 1) xs -- less space than pokeElemOff
140{-# INLINE packWith #-}
141
142------------------------------------------------------------------------
143
144-- | The 0 pointer. Used to indicate the empty Bytestring.
145nullForeignPtr :: ForeignPtr a
146#if __GLASGOW_HASKELL__>=605
147nullForeignPtr = ForeignPtr nullAddr# undefined --TODO: should ForeignPtrContents be strict?
148#else
149nullForeignPtr = unsafePerformIO $ newForeignPtr_ nullPtr
150{-# NOINLINE nullForeignPtr #-}
151#endif
152
153-- ---------------------------------------------------------------------
154-- Low level constructors
155
156-- | /O(1)/ Build a ByteString from a ForeignPtr
157fromForeignPtr :: ForeignPtr a
158               -> Int -- ^ Offset
159               -> Int -- ^ Length
160               -> Vector a
161fromForeignPtr fp s l = V fp s l
162{-# INLINE fromForeignPtr #-}
163
164-- | /O(1)/ Deconstruct a ForeignPtr from a ByteString
165toForeignPtr :: Vector a -> (ForeignPtr a, Int, Int) -- ^ (ptr, offset, length)
166toForeignPtr (V ps s l) = (ps, s, l)
167{-# INLINE toForeignPtr #-}
168
169-- | A way of creating ByteStrings outside the IO monad. The @Int@
170-- argument gives the final size of the ByteString. Unlike
171-- 'createAndTrim' the ByteString is not reallocated if the final size
172-- is less than the estimated size.
173unsafeCreate :: Storable a => Int -> (Ptr a -> IO ()) -> Vector a
174unsafeCreate l f = unsafeDupablePerformIO (create l f)
175{-# INLINE unsafeCreate #-}
176
177#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 608
178-- for Hugs   
179unsafeDupablePerformIO :: IO a -> a
180unsafeDupablePerformIO = unsafePerformIO
181#endif
182
183-- | Create ByteString of size @l@ and use action @f@ to fill it's contents.
184create :: Storable a => Int -> (Ptr a -> IO ()) -> IO (Vector a)
185create l f = do
186    fp <- mallocVectorPayload l
187    withForeignPtr fp $ \p -> f p
188    return $! V fp 0 l
189{-# INLINE create #-}
190
191-- | Wrapper of mallocForeignPtrBytes with faster implementation
192-- for GHC 6.5 builds newer than 06/06/06
193mallocVectorPayload :: Storable a => Int -> IO (ForeignPtr a)
194mallocVectorPayload l = doMalloc undefined l
195    where
196        doMalloc :: (Storable b) => b -> Int -> IO (ForeignPtr b)
197        doMalloc dummy len =
198#if __GLASGOW_HASKELL__ >= 605 && !defined(SLOW_FOREIGN_PTR)
199            mallocPlainForeignPtrBytes ((sizeOf dummy) * len)
200#else
201            mallocForeignPtrBytes ((sizeOf dummy) * len)
202#endif
203{-# INLINE mallocVectorPayload #-}
204
205------------------------------------------------------------------------
206
207-- | Just like unsafePerformIO, but we inline it. Big performance gains as
208-- it exposes lots of things to further inlining. /Very unsafe/. In
209-- particular, you should do no memory allocation inside an
210-- 'inlinePerformIO' block. On Hugs this is just @unsafePerformIO@.
211--
212{-# INLINE inlinePerformIO #-}
213inlinePerformIO :: IO a -> a
214#if defined(__GLASGOW_HASKELL__)
215inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r
216#else
217inlinePerformIO = unsafePerformIO
218#endif