Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Make use of GHC call-stack simulation for the bounds-checked partial functions #184

Closed
wants to merge 2 commits into from
Closed

Make use of GHC call-stack simulation for the bounds-checked partial functions #184

Show file tree
Hide file tree
Changes from 1 commit
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
e04ac4b
Enable GHC call-stack simulation in "safe" partial functions.
leftaroundabout Sep 26, 2017
732bb34
Also support call-stack simulation in concrete boxed/unboxed interfaces.
leftaroundabout Sep 26, 2017
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
9 changes: 6 additions & 3 deletions Data/Vector/Fusion/Bundle/Monadic.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -115,6 +115,9 @@ import Data.Word ( Word )
import Data.Int ( Int64 )
#endif

GHC_STACKTRACE_IMPORTS


data Chunk v a = Chunk Int (forall m. (PrimMonad m, Vector v a) => Mutable v (PrimState m) a -> m ())

-- | Monadic streams
Expand Down Expand Up @@ -806,7 +809,7 @@ enumFromTo_small x y = x `seq` y `seq` fromStream (Stream step x) (Exact n)
-- unsigned types). See http://hackage.haskell.org/trac/ghc/ticket/3744
--

enumFromTo_int :: forall m v. Monad m => Int -> Int -> Bundle m v Int
enumFromTo_int :: forall m v. (Monad m, HasCallStack) => Int -> Int -> Bundle m v Int
{-# INLINE_FUSED enumFromTo_int #-}
enumFromTo_int x y = x `seq` y `seq` fromStream (Stream step x) (Exact (len x y))
where
Expand All @@ -823,7 +826,7 @@ enumFromTo_int x y = x `seq` y `seq` fromStream (Stream step x) (Exact (len x y)
step z | z <= y = return $ Yield z (z+1)
| otherwise = return $ Done

enumFromTo_intlike :: (Integral a, Monad m) => a -> a -> Bundle m v a
enumFromTo_intlike :: (Integral a, Monad m, HasCallStack) => a -> a -> Bundle m v a
{-# INLINE_FUSED enumFromTo_intlike #-}
enumFromTo_intlike x y = x `seq` y `seq` fromStream (Stream step x) (Exact (len x y))
where
Expand Down Expand Up @@ -858,7 +861,7 @@ enumFromTo_intlike x y = x `seq` y `seq` fromStream (Stream step x) (Exact (len



enumFromTo_big_word :: (Integral a, Monad m) => a -> a -> Bundle m v a
enumFromTo_big_word :: (Integral a, Monad m, HasCallStack) => a -> a -> Bundle m v a
{-# INLINE_FUSED enumFromTo_big_word #-}
enumFromTo_big_word x y = x `seq` y `seq` fromStream (Stream step x) (Exact (len x y))
where
Expand Down
24 changes: 14 additions & 10 deletions Data/Vector/Generic.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -222,6 +222,9 @@ mkNoRepType = mkNorepType

import qualified Data.Traversable as T (Traversable(mapM))

GHC_STACKTRACE_IMPORTS


-- Length information
-- ------------------

Expand All @@ -240,7 +243,7 @@ null = Bundle.null . stream

infixl 9 !
-- | O(1) Indexing
(!) :: Vector v a => v a -> Int -> a
(!) :: (Vector v a, HasCallStack) => v a -> Int -> a
{-# INLINE_FUSED (!) #-}
(!) v i = BOUNDS_CHECK(checkIndex) "(!)" i (length v)
$ unId (basicUnsafeIndexM v i)
Expand All @@ -253,7 +256,7 @@ v !? i | i < 0 || i >= length v = Nothing
| otherwise = Just $ unsafeIndex v i

-- | /O(1)/ First element
head :: Vector v a => v a -> a
head :: (Vector v a, HasCallStack) => v a -> a
{-# INLINE_FUSED head #-}
head v = v ! 0

Expand Down Expand Up @@ -325,20 +328,20 @@ unsafeLast v = unsafeIndex v (length v - 1)
-- Here, no references to @v@ are retained because indexing (but /not/ the
-- elements) is evaluated eagerly.
--
indexM :: (Vector v a, Monad m) => v a -> Int -> m a
indexM :: (Vector v a, Monad m, HasCallStack) => v a -> Int -> m a
{-# INLINE_FUSED indexM #-}
indexM v i = BOUNDS_CHECK(checkIndex) "indexM" i (length v)
$ basicUnsafeIndexM v i

-- | /O(1)/ First element of a vector in a monad. See 'indexM' for an
-- explanation of why this is useful.
headM :: (Vector v a, Monad m) => v a -> m a
headM :: (Vector v a, Monad m, HasCallStack) => v a -> m a
{-# INLINE_FUSED headM #-}
headM v = indexM v 0

-- | /O(1)/ Last element of a vector in a monad. See 'indexM' for an
-- explanation of why this is useful.
lastM :: (Vector v a, Monad m) => v a -> m a
lastM :: (Vector v a, Monad m, HasCallStack) => v a -> m a
{-# INLINE_FUSED lastM #-}
lastM v = indexM v (length v - 1)

Expand Down Expand Up @@ -388,7 +391,8 @@ unsafeLastM v = unsafeIndexM v (length v - 1)

-- | /O(1)/ Yield a slice of the vector without copying it. The vector must
-- contain at least @i+n@ elements.
slice :: Vector v a => Int -- ^ @i@ starting index
slice :: (Vector v a, HasCallStack)
=> Int -- ^ @i@ starting index
-> Int -- ^ @n@ length
-> v a
-> v a
Expand All @@ -398,13 +402,13 @@ slice i n v = BOUNDS_CHECK(checkSlice) "slice" i n (length v)

-- | /O(1)/ Yield all but the last element without copying. The vector may not
-- be empty.
init :: Vector v a => v a -> v a
init :: (Vector v a, HasCallStack) => v a -> v a
{-# INLINE_FUSED init #-}
init v = slice 0 (length v - 1) v

-- | /O(1)/ Yield all but the first element without copying. The vector may not
-- be empty.
tail :: Vector v a => v a -> v a
tail :: (Vector v a, HasCallStack) => v a -> v a
{-# INLINE_FUSED tail #-}
tail v = slice 1 (length v - 1) v

Expand Down Expand Up @@ -932,7 +936,7 @@ reverse = unstream . streamR
-- often much more efficient.
--
-- > backpermute <a,b,c,d> <0,3,2,3,1,0> = <a,d,c,d,b,a>
backpermute :: (Vector v a, Vector v Int)
backpermute :: (Vector v a, Vector v Int, HasCallStack)
=> v a -- ^ @xs@ value vector
-> v Int -- ^ @is@ index vector (of length @n@)
-> v a
Expand Down Expand Up @@ -1987,7 +1991,7 @@ thawMany vs = do
-- | /O(n)/ Copy an immutable vector into a mutable one. The two vectors must
-- have the same length.
copy
:: (PrimMonad m, Vector v a) => Mutable v (PrimState m) a -> v a -> m ()
:: (PrimMonad m, Vector v a, HasCallStack) => Mutable v (PrimState m) a -> v a -> m ()
{-# INLINE copy #-}
copy dst src = BOUNDS_CHECK(check) "copy" "length mismatch"
(M.length dst == length src)
Expand Down
4 changes: 3 additions & 1 deletion Data/Vector/Generic/Mutable.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -78,6 +78,8 @@ import Prelude hiding ( length, null, replicate, reverse, map, read,

#include "vector.h"

GHC_STACKTRACE_IMPORTS

{-
type family Immutable (v :: * -> * -> *) :: * -> *

Expand Down Expand Up @@ -509,7 +511,7 @@ null v = length v == 0
-- ---------------------

-- | Yield a part of the mutable vector without copying it.
slice :: MVector v a => Int -> Int -> v s a -> v s a
slice :: (MVector v a, HasCallStack) => Int -> Int -> v s a -> v s a
{-# INLINE slice #-}
slice i n v = BOUNDS_CHECK(checkSlice) "slice" i n (length v)
$ unsafeSlice i n v
Expand Down
17 changes: 10 additions & 7 deletions Data/Vector/Internal/Check.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -26,6 +26,9 @@ import GHC.Prim( Int# )
import Prelude hiding( error, (&&), (||), not )
import qualified Prelude as P


#include "stacktracetools.h"

-- NOTE: This is a workaround for GHC's weird behaviour where it doesn't inline
-- these functions into unfoldings which makes the intermediate code size
-- explode. See http://hackage.haskell.org/trac/ghc/ticket/5539.
Expand Down Expand Up @@ -81,12 +84,12 @@ doChecks Internal = doInternalChecks
error_msg :: String -> Int -> String -> String -> String
error_msg file line loc msg = file ++ ":" ++ show line ++ " (" ++ loc ++ "): " ++ msg

error :: String -> Int -> String -> String -> a
error :: HasCallStack => String -> Int -> String -> String -> a
{-# NOINLINE error #-}
error file line loc msg
= P.error $ error_msg file line loc msg

internalError :: String -> Int -> String -> String -> a
internalError :: HasCallStack => String -> Int -> String -> String -> a
{-# NOINLINE internalError #-}
internalError file line loc msg
= P.error $ unlines
Expand All @@ -95,14 +98,14 @@ internalError file line loc msg
,error_msg file line loc msg]


checkError :: String -> Int -> Checks -> String -> String -> a
checkError :: HasCallStack => String -> Int -> Checks -> String -> String -> a
{-# NOINLINE checkError #-}
checkError file line kind loc msg
= case kind of
Internal -> internalError file line loc msg
_ -> error file line loc msg

check :: String -> Int -> Checks -> String -> String -> Bool -> a -> a
check :: HasCallStack => String -> Int -> Checks -> String -> String -> Bool -> a -> a
{-# INLINE check #-}
check file line kind loc msg cond x
| not (doChecks kind) || cond = x
Expand All @@ -116,7 +119,7 @@ checkIndex_msg# :: Int# -> Int# -> String
{-# NOINLINE checkIndex_msg# #-}
checkIndex_msg# i# n# = "index out of bounds " ++ show (I# i#, I# n#)

checkIndex :: String -> Int -> Checks -> String -> Int -> Int -> a -> a
checkIndex :: HasCallStack => String -> Int -> Checks -> String -> Int -> Int -> a -> a
{-# INLINE checkIndex #-}
checkIndex file line kind loc i n x
= check file line kind loc (checkIndex_msg i n) (i >= 0 && i<n) x
Expand All @@ -130,7 +133,7 @@ checkLength_msg# :: Int# -> String
{-# NOINLINE checkLength_msg# #-}
checkLength_msg# n# = "negative length " ++ show (I# n#)

checkLength :: String -> Int -> Checks -> String -> Int -> a -> a
checkLength :: HasCallStack => String -> Int -> Checks -> String -> Int -> a -> a
{-# INLINE checkLength #-}
checkLength file line kind loc n x
= check file line kind loc (checkLength_msg n) (n >= 0) x
Expand All @@ -144,7 +147,7 @@ checkSlice_msg# :: Int# -> Int# -> Int# -> String
{-# NOINLINE checkSlice_msg# #-}
checkSlice_msg# i# m# n# = "invalid slice " ++ show (I# i#, I# m#, I# n#)

checkSlice :: String -> Int -> Checks -> String -> Int -> Int -> Int -> a -> a
checkSlice :: HasCallStack => String -> Int -> Checks -> String -> Int -> Int -> Int -> a -> a
{-# INLINE checkSlice #-}
checkSlice file line kind loc i m n x
= check file line kind loc (checkSlice_msg i m n)
Expand Down
6 changes: 6 additions & 0 deletions include/stacktracetools.h
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,6 @@
#if MIN_VERSION_base(4,9,0)
import GHC.Stack (HasCallStack)
#define CHECK(f) (withFrozenCallStack Ck.f __FILE__ __LINE__)
#else
#define HasCallStack (Eq ())
Copy link
Contributor Author

@leftaroundabout leftaroundabout Sep 27, 2017 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

That Eq () fallback constraint was just a rough hack, to replace HasCallStack with something as simple as possible on GHC versions that don't support it yet. It turns out even that super-simple hack doesn't work just like that, it would require tossing in FlexibleContexts:

Data/Vector/Internal/Check.hs:122:15:
    Non type-variable argument in the constraint: Eq ()
    (Use FlexibleContexts to permit this)
    In the type signature for ‘checkIndex’:
      checkIndex :: (Eq ()) =>
                    String -> Int -> Checks -> String -> Int -> Int -> a -> a

Any ideas how this could be properly done, short of cluttering every signature with an #if MIN_VERSION_base?

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I would do what the call-stack library does:

#if MIN_VERSION_base(4,9,0)
import           GHC.Stack (HasCallStack)
#elif MIN_VERSION_base(4,8,1)
type HasCallStack = (?callStack :: GHC.CallStack)
#else
import GHC.Exts (Constraint)
type HasCallStack = (() :: Constraint)
#endif

This requires base-4.5 (GHC 7.4) or later, but those are precisely the version bounds that vector has. Moreover, this shouldn't require the use of FlexibleContexts.

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I don't suppose it would be ok for vector to actually depend on call-stack?

#endif
14 changes: 11 additions & 3 deletions include/vector.h
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -11,10 +11,18 @@ import qualified Data.Vector.Internal.Check as Ck
#define ERROR (Ck.error __FILE__ __LINE__)
#define INTERNAL_ERROR (Ck.internalError __FILE__ __LINE__)

#define CHECK(f) (Ck.f __FILE__ __LINE__)
#define UNTRACED_CHECK(f) (Ck.f __FILE__ __LINE__)
#if MIN_VERSION_base(4,9,0)
#define GHC_STACKTRACE_IMPORTS import GHC.Stack
#define CHECK(f) (withFrozenCallStack Ck.f __FILE__ __LINE__)
#else
#define GHC_STACKTRACE_IMPORTS
#define HasCallStack (Eq ())
#define CHECK(f) UNTRACED_CHECK(f)
#endif
#define BOUNDS_CHECK(f) (CHECK(f) Ck.Bounds)
#define UNSAFE_CHECK(f) (CHECK(f) Ck.Unsafe)
#define INTERNAL_CHECK(f) (CHECK(f) Ck.Internal)
#define UNSAFE_CHECK(f) (UNTRACED_CHECK(f) Ck.Unsafe)
#define INTERNAL_CHECK(f) (UNTRACED_CHECK(f) Ck.Internal)

#define PHASE_STREAM Please use "PHASE_FUSED" instead
#define INLINE_STREAM Please use "INLINE_FUSED" instead
1 change: 1 addition & 0 deletions vector.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -143,6 +143,7 @@ Library

Install-Includes:
vector.h
stacktracetools.h

Build-Depends: base >= 4.5 && < 4.11
, primitive >= 0.5.0.1 && < 0.7
Expand Down