From e04ac4b0162eeeaaeef2d0ff54ad02843efa6dc2 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Justus=20Sagem=C3=BCller?= <sagemueller@geo.uni-koeln.de>
Date: Wed, 27 Sep 2017 01:31:16 +0200
Subject: [PATCH 1/2] Enable GHC call-stack simulation in "safe" partial
 functions.

`(!)` etc. are of course only safer than their `unsafe` pendants in the sense that
errors are raised as proper exceptions, but when used in sizable applications
that by itself does not make the errors easy to find.

GHC-8 has added support for simulated call stack which can actually give some
information on the use site of such errors. In this commit, I added the
necessary constraint to the partial functions which perform bounds checks.
---
 Data/Vector/Fusion/Bundle/Monadic.hs |  9 ++++++---
 Data/Vector/Generic.hs               | 24 ++++++++++++++----------
 Data/Vector/Generic/Mutable.hs       |  4 +++-
 Data/Vector/Internal/Check.hs        | 17 ++++++++++-------
 include/stacktracetools.h            |  6 ++++++
 include/vector.h                     | 14 +++++++++++---
 vector.cabal                         |  1 +
 7 files changed, 51 insertions(+), 24 deletions(-)
 create mode 100644 include/stacktracetools.h

diff --git a/Data/Vector/Fusion/Bundle/Monadic.hs b/Data/Vector/Fusion/Bundle/Monadic.hs
index 46f4a165..d2a257c1 100644
--- a/Data/Vector/Fusion/Bundle/Monadic.hs
+++ b/Data/Vector/Fusion/Bundle/Monadic.hs
@@ -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
@@ -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
@@ -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
@@ -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
diff --git a/Data/Vector/Generic.hs b/Data/Vector/Generic.hs
index cc568df1..b09f46fe 100644
--- a/Data/Vector/Generic.hs
+++ b/Data/Vector/Generic.hs
@@ -222,6 +222,9 @@ mkNoRepType = mkNorepType
 
 import qualified Data.Traversable as T (Traversable(mapM))
 
+GHC_STACKTRACE_IMPORTS
+
+
 -- Length information
 -- ------------------
 
@@ -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)
@@ -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
 
@@ -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)
 
@@ -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
@@ -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
 
@@ -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
@@ -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)
diff --git a/Data/Vector/Generic/Mutable.hs b/Data/Vector/Generic/Mutable.hs
index c3f531d7..7fa28a7f 100644
--- a/Data/Vector/Generic/Mutable.hs
+++ b/Data/Vector/Generic/Mutable.hs
@@ -78,6 +78,8 @@ import Prelude hiding ( length, null, replicate, reverse, map, read,
 
 #include "vector.h"
 
+GHC_STACKTRACE_IMPORTS
+
 {-
 type family Immutable (v :: * -> * -> *) :: * -> *
 
@@ -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
diff --git a/Data/Vector/Internal/Check.hs b/Data/Vector/Internal/Check.hs
index 4a4ef80f..17333bf7 100644
--- a/Data/Vector/Internal/Check.hs
+++ b/Data/Vector/Internal/Check.hs
@@ -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.
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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)
diff --git a/include/stacktracetools.h b/include/stacktracetools.h
new file mode 100644
index 00000000..6105a3a2
--- /dev/null
+++ b/include/stacktracetools.h
@@ -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 ())
+#endif
diff --git a/include/vector.h b/include/vector.h
index 1568bb29..170eb2a3 100644
--- a/include/vector.h
+++ b/include/vector.h
@@ -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
diff --git a/vector.cabal b/vector.cabal
index 326454cf..6a59320f 100644
--- a/vector.cabal
+++ b/vector.cabal
@@ -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

From 732bb34db48fb02f418b9228a816445323eac924 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Justus=20Sagem=C3=BCller?= <sagemueller@geo.uni-koeln.de>
Date: Wed, 27 Sep 2017 01:36:21 +0200
Subject: [PATCH 2/2] Also support call-stack simulation in concrete
 boxed/unboxed interfaces.

---
 Data/Vector.hs         | 22 +++++++++++++---------
 Data/Vector/Unboxed.hs | 24 ++++++++++++++----------
 2 files changed, 27 insertions(+), 19 deletions(-)

diff --git a/Data/Vector.hs b/Data/Vector.hs
index 5c04b412..73ca3010 100644
--- a/Data/Vector.hs
+++ b/Data/Vector.hs
@@ -213,6 +213,9 @@ import qualified GHC.Exts as Exts (IsList(..))
 #endif
 
 
+#include "stacktracetools.h"
+
+
 -- | Boxed vectors, supporting efficient slicing.
 data Vector a = Vector {-# UNPACK #-} !Int
                        {-# UNPACK #-} !Int
@@ -450,7 +453,7 @@ null = G.null
 -- --------
 
 -- | O(1) Indexing
-(!) :: Vector a -> Int -> a
+(!) :: HasCallStack => Vector a -> Int -> a
 {-# INLINE (!) #-}
 (!) = (G.!)
 
@@ -460,12 +463,12 @@ null = G.null
 (!?) = (G.!?)
 
 -- | /O(1)/ First element
-head :: Vector a -> a
+head :: HasCallStack => Vector a -> a
 {-# INLINE head #-}
 head = G.head
 
 -- | /O(1)/ Last element
-last :: Vector a -> a
+last :: HasCallStack => Vector a -> a
 {-# INLINE last #-}
 last = G.last
 
@@ -506,19 +509,19 @@ unsafeLast = G.unsafeLast
 -- Here, no references to @v@ are retained because indexing (but /not/ the
 -- elements) is evaluated eagerly.
 --
-indexM :: Monad m => Vector a -> Int -> m a
+indexM :: (Monad m, HasCallStack) => Vector a -> Int -> m a
 {-# INLINE indexM #-}
 indexM = G.indexM
 
 -- | /O(1)/ First element of a vector in a monad. See 'indexM' for an
 -- explanation of why this is useful.
-headM :: Monad m => Vector a -> m a
+headM :: (Monad m, HasCallStack) => Vector a -> m a
 {-# INLINE headM #-}
 headM = G.headM
 
 -- | /O(1)/ Last element of a vector in a monad. See 'indexM' for an
 -- explanation of why this is useful.
-lastM :: Monad m => Vector a -> m a
+lastM :: (Monad m, HasCallStack) => Vector a -> m a
 {-# INLINE lastM #-}
 lastM = G.lastM
 
@@ -545,7 +548,8 @@ unsafeLastM = G.unsafeLastM
 
 -- | /O(1)/ Yield a slice of the vector without copying it. The vector must
 -- contain at least @i+n@ elements.
-slice :: Int   -- ^ @i@ starting index
+slice :: HasCallStack
+                 => Int   -- ^ @i@ starting index
                  -> Int   -- ^ @n@ length
                  -> Vector a
                  -> Vector a
@@ -554,13 +558,13 @@ slice = G.slice
 
 -- | /O(1)/ Yield all but the last element without copying. The vector may not
 -- be empty.
-init :: Vector a -> Vector a
+init :: HasCallStack => Vector a -> Vector a
 {-# INLINE init #-}
 init = G.init
 
 -- | /O(1)/ Yield all but the first element without copying. The vector may not
 -- be empty.
-tail :: Vector a -> Vector a
+tail ::  HasCallStack => Vector a -> Vector a
 {-# INLINE tail #-}
 tail = G.tail
 
diff --git a/Data/Vector/Unboxed.hs b/Data/Vector/Unboxed.hs
index 9f5ae6cd..2f4292d3 100644
--- a/Data/Vector/Unboxed.hs
+++ b/Data/Vector/Unboxed.hs
@@ -202,6 +202,9 @@ import qualified GHC.Exts as Exts (IsList(..))
 #define NOT_VECTOR_MODULE
 #include "vector.h"
 
+#include "stacktracetools.h"
+
+
 -- See http://trac.haskell.org/vector/ticket/12
 instance (Unbox a, Eq a) => Eq (Vector a) where
   {-# INLINE (==) #-}
@@ -278,7 +281,7 @@ null = G.null
 -- --------
 
 -- | O(1) Indexing
-(!) :: Unbox a => Vector a -> Int -> a
+(!) :: (Unbox a, HasCallStack) => Vector a -> Int -> a
 {-# INLINE (!) #-}
 (!) = (G.!)
 
@@ -288,12 +291,12 @@ null = G.null
 (!?) = (G.!?)
 
 -- | /O(1)/ First element
-head :: Unbox a => Vector a -> a
+head :: (Unbox a, HasCallStack) => Vector a -> a
 {-# INLINE head #-}
 head = G.head
 
 -- | /O(1)/ Last element
-last :: Unbox a => Vector a -> a
+last :: (Unbox a, HasCallStack) => Vector a -> a
 {-# INLINE last #-}
 last = G.last
 
@@ -334,19 +337,19 @@ unsafeLast = G.unsafeLast
 -- Here, no references to @v@ are retained because indexing (but /not/ the
 -- elements) is evaluated eagerly.
 --
-indexM :: (Unbox a, Monad m) => Vector a -> Int -> m a
+indexM :: (Unbox a, Monad m, HasCallStack) => Vector a -> Int -> m a
 {-# INLINE indexM #-}
 indexM = G.indexM
 
 -- | /O(1)/ First element of a vector in a monad. See 'indexM' for an
 -- explanation of why this is useful.
-headM :: (Unbox a, Monad m) => Vector a -> m a
+headM :: (Unbox a, Monad m, HasCallStack) => Vector a -> m a
 {-# INLINE headM #-}
 headM = G.headM
 
 -- | /O(1)/ Last element of a vector in a monad. See 'indexM' for an
 -- explanation of why this is useful.
-lastM :: (Unbox a, Monad m) => Vector a -> m a
+lastM :: (Unbox a, Monad m, HasCallStack) => Vector a -> m a
 {-# INLINE lastM #-}
 lastM = G.lastM
 
@@ -373,7 +376,8 @@ unsafeLastM = G.unsafeLastM
 
 -- | /O(1)/ Yield a slice of the vector without copying it. The vector must
 -- contain at least @i+n@ elements.
-slice :: Unbox a => Int   -- ^ @i@ starting index
+slice :: (Unbox a, HasCallStack)
+                 => Int   -- ^ @i@ starting index
                  -> Int   -- ^ @n@ length
                  -> Vector a
                  -> Vector a
@@ -382,13 +386,13 @@ slice = G.slice
 
 -- | /O(1)/ Yield all but the last element without copying. The vector may not
 -- be empty.
-init :: Unbox a => Vector a -> Vector a
+init :: (Unbox a, HasCallStack) => Vector a -> Vector a
 {-# INLINE init #-}
 init = G.init
 
 -- | /O(1)/ Yield all but the first element without copying. The vector may not
 -- be empty.
-tail :: Unbox a => Vector a -> Vector a
+tail :: (Unbox a, HasCallStack) => Vector a -> Vector a
 {-# INLINE tail #-}
 tail = G.tail
 
@@ -782,7 +786,7 @@ reverse = G.reverse
 -- often much more efficient.
 --
 -- > backpermute <a,b,c,d> <0,3,2,3,1,0> = <a,d,c,d,b,a>
-backpermute :: Unbox a => Vector a -> Vector Int -> Vector a
+backpermute :: (Unbox a, HasCallStack) => Vector a -> Vector Int -> Vector a
 {-# INLINE backpermute #-}
 backpermute = G.backpermute