Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

bounds checking infastructure, stolen from package vector

Ignore-this: b9cc5d184ed6811baff77c5b7fb3e15e

darcs-hash:20100721041604-dcabc-4d7eb61d7edc67f804d6ac4bc57b7412afe0da2a.gz
  • Loading branch information...
commit 55a0b85f848990b2b7c5dac70ab945eefe4ff1c3 1 parent 4dfd401
@tmcdonell tmcdonell authored
View
107 Data/Array/Accelerate/Internal/Check.hs
@@ -0,0 +1,107 @@
+{-# LANGUAGE CPP #-}
+-- |
+-- Module : Data.Array.Accelerate.Internal.Check
+-- Copyright : [2008..2010] Manuel M T Chakravarty, Gabriele Keller, Sean Lee, Trevor L. McDonell
+-- License : BSD3
+--
+-- Maintainer : Manuel M T Chakravarty <chak@cse.unsw.edu.au>
+-- Stability : experimental
+-- Portability : non-portable (GHC extensions)
+--
+-- Bounds checking infrastructure
+--
+-- Sstolen from the Vector package by Roman Leshchinskiy
+-- <http://hackage.haskell.org/package/vector>
+--
+
+module Data.Array.Accelerate.Internal.Check
+ (
+ Checks(..), doChecks,
+ error, check, assert, checkIndex, checkLength, checkSlice
+ ) where
+
+import Prelude hiding( error )
+import qualified Prelude as P
+
+data Checks = Bounds | Unsafe | Internal deriving( Eq )
+
+doBoundsChecks :: Bool
+#ifdef ACCELERATE_BOUNDS_CHECKS
+doBoundsChecks = True
+#else
+doBoundsChecks = False
+#endif
+
+doUnsafeChecks :: Bool
+#ifdef ACCELERATE_UNSAFE_CHECKS
+doUnsafeChecks = True
+#else
+doUnsafeChecks = False
+#endif
+
+doInternalChecks :: Bool
+#ifdef ACCELERATE_INTERNAL_CHECKS
+doInternalChecks = True
+#else
+doInternalChecks = False
+#endif
+
+
+doChecks :: Checks -> Bool
+{-# INLINE doChecks #-}
+doChecks Bounds = doBoundsChecks
+doChecks Unsafe = doUnsafeChecks
+doChecks Internal = doInternalChecks
+
+error :: String -> Int -> Checks -> String -> String -> a
+error file line kind loc msg
+ = P.error $ unlines $
+ (if kind == Internal
+ then (["*** Internal error in package accelerate ***"
+ ,"*** Please submit a bug report at http://trac.haskell.org/accelerate"]++)
+ else id) $
+ [ file ++ ":" ++ show line ++ " (" ++ loc ++ "): " ++ msg ]
+
+check :: String -> Int -> Checks -> String -> String -> Bool -> a -> a
+{-# INLINE check #-}
+check file line kind loc msg cond x
+ | not (doChecks kind) || cond = x
+ | otherwise = error file line kind loc msg
+
+assert_msg :: String
+assert_msg = "assertion failure"
+
+assert :: String -> Int -> Checks -> String -> Bool -> a -> a
+{-# INLINE assert #-}
+assert file line kind loc = check file line kind loc assert_msg
+
+checkIndex_msg :: Int -> Int -> String
+{-# NOINLINE checkIndex_msg #-}
+checkIndex_msg i n = "index out of bounds " ++ show (i,n)
+
+checkIndex :: 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
+
+
+checkLength_msg :: Int -> String
+{-# NOINLINE checkLength_msg #-}
+checkLength_msg n = "negative length " ++ show n
+
+checkLength :: 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
+
+
+checkSlice_msg :: Int -> Int -> Int -> String
+{-# NOINLINE checkSlice_msg #-}
+checkSlice_msg i m n = "invalid slice " ++ show (i,m,n)
+
+checkSlice :: 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)
+ (i >= 0 && m >= 0 && i+m <= n) x
+
View
33 accelerate.cabal
@@ -66,15 +66,27 @@ Extra-source-files: INSTALL
examples/rasterize/rasterize.hs
Flag llvm
- Description: enable the LLVM backend (sequential)
+ Description: Enable the LLVM backend (sequential)
Default: False
Flag cuda
- Description: enable the CUDA parallel backend for NVIDIA GPUs
+ Description: Enable the CUDA parallel backend for NVIDIA GPUs
Default: True
Flag test-suite
- Description: export extra test modules
+ Description: Export extra test modules
+ Default: False
+
+Flag bounds-checks
+ Description: Enable bounds checking
+ Default: True
+
+Flag unsafe-checks
+ Description: Enable bounds checking in unsafe operations
+ Default: False
+
+Flag internal-checks
+ Description: Enable internal consistency checks
Default: False
Library
@@ -83,6 +95,10 @@ Library
ghc-prim,
haskell98,
pretty
+
+ Include-Dirs: include
+ Install-Includes: accelerate.h
+
If flag(llvm)
Build-depends: llvm >= 0.6.8
@@ -100,7 +116,7 @@ Library
unix
if flag(test-suite)
- Build-depends: QuickCheck >= 2
+ Build-depends: QuickCheck == 2.*
Exposed-modules: Data.Array.Accelerate
Data.Array.Accelerate.Interpreter
@@ -146,6 +162,15 @@ Library
Data.Array.Accelerate.CUDA.Execute
Data.Array.Accelerate.CUDA.State
+ if flag(bounds-checks)
+ cpp-options: -DACCELERATE_BOUNDS_CHECKS
+
+ if flag(unsafe-checks)
+ cpp-options: -DACCELERATE_UNSAFE_CHECKS
+
+ if flag(internal-checks)
+ cpp-options: -DACCELERATE_INTERNAL_CHECKS
+
Ghc-options: -O2 -Wall -fno-warn-orphans -fno-warn-name-shadowing
Extensions: FlexibleContexts, FlexibleInstances,
ExistentialQuantification, GADTs, TypeFamilies,
View
25 include/accelerate.h
@@ -0,0 +1,25 @@
+
+#ifndef NOT_ACCELERATE_MODULE
+import qualified Data.Array.Accelerate.Internal.Check as Ck
+#endif
+
+#define ERROR(f) (Ck.f __FILE__ __LINE__)
+#define ASSERT (Ck.assert __FILE__ __LINE__)
+#define ENSURE (Ck.f __FILE__ __LINE__)
+#define CHECK(f) (Ck.f __FILE__ __LINE__)
+
+#define BOUNDS_ERROR(f) (ERROR(f) Ck.Bounds)
+#define BOUNDS_ASSERT (ASSERT Ck.Bounds)
+#define BOUNDS_ENSURE (ENSURE Ck.Bounds)
+#define BOUNDS_CHECK(f) (CHECK(f) Ck.Bounds)
+
+#define UNSAFE_ERROR(f) (ERROR(f) Ck.Unsafe)
+#define UNSAFE_ASSERT (ASSERT Ck.Unsafe)
+#define UNSAFE_ENSURE (ENSURE Ck.Unsafe)
+#define UNSAFE_CHECK(f) (CHECK(f) Ck.Unsafe)
+
+#define INTERNAL_ERROR(f) (ERROR(f) Ck.Internal)
+#define INTERNAL_ASSERT (ASSERT Ck.Internal)
+#define INTERNAL_ENSURE (ENSURE Ck.Internal)
+#define INTERNAL_CHECK(f) (CHECK(f) Ck.Internal)
+
Please sign in to comment.
Something went wrong with that request. Please try again.