guarded-allocation (empty) → 0.0

raw patch · 9 files changed

+268/−0 lines, 9 filesdep +basesetup-changed

Dependencies added: base

Files

LICENSE +27/−0
Makefile +10/−0
README.md +29/−0
Setup.lhs +3/−0
frontend/debug/Foreign/Marshal/Array/Guarded.hs +6/−0
frontend/plain/Foreign/Marshal/Array/Guarded.hs +6/−0
guarded-allocation.cabal +67/−0
src/Foreign/Marshal/Array/Guarded/Debug.hs +100/−0
src/Foreign/Marshal/Array/Guarded/Plain.hs +20/−0

+ LICENSE view

@@ -0,0 +1,27 @@+Copyright (c) Henning Thielemann 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.

+ Makefile view

@@ -0,0 +1,10 @@+test-build:+	runhaskell Setup configure --user -f-debug+	runhaskell Setup build+	runhaskell Setup haddock++	runhaskell Setup configure --user -fdebug+	runhaskell Setup build++%.html:	%.md+	pandoc $< --output=$@

+ README.md view

@@ -0,0 +1,29 @@+The overall idea of the package is to make programming mistakes+let low-level programs fail reproducibly.++What the routines do:++ *  After allocation fill the memory with the hex string 0xDEADF00D.+    This allows to check whether the caller+    properly initialises allocated buffers.++ *  Allocate some memory before and after the actual buffer+    and fill it with 0xABADCAFE.+    On deallocation it is checked that this pattern is still intact.+    If not, abort with an error.+    This allows to check for range violations.++ *  Before deallocation fill the memory with 0xDEADBEEF.+    This helps to detect when the program reads memory after its deallocation.++ *  The `create` routine additionally makes a copy of the initialized buffer.+    The finalizer compares the contents of the buffer and its copy.+    This way it can detect if an immutable array was altered after its creation.+++Range violations might alternatively be detected by range checking techniques.+Allocation problems might be solved using Regions.+The provided functions might overlook range violations+but they help detecting bugs+when you have not full control over the code that processes memory content,+e.g. when calling external routines via FFI.

+ Setup.lhs view

@@ -0,0 +1,3 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain

+ frontend/debug/Foreign/Marshal/Array/Guarded.hs view

@@ -0,0 +1,6 @@+module Foreign.Marshal.Array.Guarded (+   Array.create,+   Array.alloca,+   ) where++import qualified Foreign.Marshal.Array.Guarded.Debug as Array

+ frontend/plain/Foreign/Marshal/Array/Guarded.hs view

@@ -0,0 +1,6 @@+module Foreign.Marshal.Array.Guarded (+   Array.create,+   Array.alloca,+   ) where++import qualified Foreign.Marshal.Array.Guarded.Plain as Array

+ guarded-allocation.cabal view

@@ -0,0 +1,67 @@+Name:             guarded-allocation+Version:          0.0+License:          BSD3+License-File:     LICENSE+Author:           Henning Thielemann <haskell@henning-thielemann.de>+Maintainer:       Henning Thielemann <haskell@henning-thielemann.de>+Homepage:         http://hub.darcs.net/thielema/guarded-allocation/+Category:         Debug+Synopsis:         Memory allocation with added stress tests and integrity checks+Description:+  Provide adaptions of @mallocForeignPtrArray@ and @allocaArray@+  that add stress tests and integrity checks.+  .+  There are three modules:+  .+  * @Guarded.Plain@: exports the original allocation routines+  .+  * @Guarded.Debug@: exports allocation routines that add stress and checks+  .+  * @Guarded@: exports either @Guarded.Plain@ or @Guarded.Debug@+    depending on the Cabal @debug@ flag.+  .+  It is intended that you always import the @Guarded@ module in user code+  and install a package version with enabled debug flag+  to a custom package database for debugging.+  If you compile your user program you can choose production or debugging mode+  by choosing the default or the custom debugging package database,+  respectively.+  .+  This package is inspired by the famous Amiga debug tool MungWall.+  The Linux counterpart is Electric Fence.++Tested-With:      GHC==7.4.2, GHC==7.8.4, GHC==8.4.3+Cabal-Version:    >=1.6+Build-Type:       Simple+Extra-Source-Files:+  Makefile+  README.md++Source-Repository this+  Tag:         0.1+  Type:        darcs+  Location:    http://hub.darcs.net/thielema/guarded-allocation/++Source-Repository head+  Type:        darcs+  Location:    http://hub.darcs.net/thielema/guarded-allocation/++Flag debug+  Description: Add stress tests and integrity checks to allocations+  Default:     False+  Manual:      True++Library+  Build-Depends:+    base >=4.5 && <5++  GHC-Options:      -Wall+  Hs-Source-Dirs:   src+  If flag(debug)+    Hs-Source-Dirs: frontend/debug+  Else+    Hs-Source-Dirs: frontend/plain+  Exposed-Modules:+    Foreign.Marshal.Array.Guarded+    Foreign.Marshal.Array.Guarded.Plain+    Foreign.Marshal.Array.Guarded.Debug

+ src/Foreign/Marshal/Array/Guarded/Debug.hs view

@@ -0,0 +1,100 @@+module Foreign.Marshal.Array.Guarded.Debug (+   create,+   alloca,+   ) where++import qualified Foreign.Marshal.Array.Guarded.Plain as Plain++import Foreign.Marshal.Array+         (mallocArray, allocaArray, pokeArray, copyArray, advancePtr)+import Foreign.Marshal.Alloc (free)+import Foreign.Storable (Storable, peekByteOff, sizeOf)+import Foreign.Concurrent (newForeignPtr)+import Foreign.ForeignPtr (ForeignPtr)+import Foreign.Ptr (Ptr, castPtr)++import Control.Monad (when)++import Data.Foldable (for_)+import Data.Word (Word8)+++{- |+Array creation with additional immutability check, electrical fence+and pollution of uncleaned memory.++The function checks that the array is not altered anymore after creation.+-}+create :: (Storable a) => Int -> (Ptr a -> IO b) -> IO (ForeignPtr a, b)+create = flip asTypeOf Plain.create $ \size f -> do+   let border = 64+   let fullSize = size + 2*border+   ptrApre <- mallocArray fullSize+   ptrsA@(_ptrApre, ptrA, _ptrApost) <- fillAll border size ptrApre+   result <- f ptrA+   checkAll border ptrsA+   ptrB <- mallocArray size+   copyArray ptrB ptrA size+   fmap (flip (,) result) $ newForeignPtr ptrA $ do+      for_ (take (arraySize ptrA size) [0..]) $ \i -> do+         a <- peekByteOff ptrA i+         b <- peekByteOff ptrB i+         when (a/=(b::Word8)) $+            error $ "immutable array was altered at byte position " ++ show i+      trash fullSize ptrApre+      free ptrApre+      free ptrB+++alloca :: (Storable a) => Int -> (Ptr a -> IO b) -> IO b+alloca = flip asTypeOf Plain.alloca $ \size f -> do+   let border = 64+   let fullSize = size + 2*border+   allocaArray fullSize $ \ptrPre -> do+      ptrs@(_ptrPre, ptr, _ptrPost) <- fillAll border size ptrPre+      result <- f ptr+      checkAll border ptrs+      trash fullSize ptrPre+      return result+++fillAll :: (Storable a) => Int -> Int -> Ptr a -> IO (Ptr a, Ptr a, Ptr a)+fillAll border size ptrPre = do+   let ptr = advancePtr ptrPre border+   let ptrPost = advancePtr ptr size+   fill ptrPre border [0xAB,0xAD,0xCA,0xFE]+   fill ptr size [0xDE,0xAD,0xF0,0x0D]+   fill ptrPost border [0xAB,0xAD,0xCA,0xFE]+   return (ptrPre, ptr, ptrPost)++checkAll :: (Storable a) => Int -> (Ptr a, Ptr a, Ptr a) -> IO ()+checkAll border (ptrPre, _ptr, ptrPost) = do+   check "leading"  ptrPre  border [0xAB,0xAD,0xCA,0xFE]+   check "trailing" ptrPost border [0xAB,0xAD,0xCA,0xFE]++trash :: (Storable a) => Int -> Ptr a -> IO ()+trash fullSize ptrPre = fill ptrPre fullSize [0xDE,0xAD,0xBE,0xEF]+++{-# INLINE fill #-}+fill :: (Storable a) => Ptr a -> Int -> [Word8] -> IO ()+fill ptr n bytes =+   pokeArray (castPtr ptr) $ take (arraySize ptr n) $ cycle bytes++{-# INLINE check #-}+check :: (Storable a) => String -> Ptr a -> Int -> [Word8] -> IO ()+check name ptr n bytes =+   for_ (take (arraySize ptr n) $ zip [0..] $ cycle bytes) $ \(i,b) -> do+      a <- peekByteOff ptr i+      when (a/=(b::Word8)) $+         error $ "damaged " ++ name ++ " fence at position " ++ show i++arraySize :: (Storable a) => Ptr a -> Int -> Int+arraySize ptr n = arraySizeAux ptr n $ error "arraySize: undefined element"++{- |+Correct size computation should also respect padding caused by alignment.+However, mallocArray uses this simple arithmetic.+-}+arraySizeAux :: (Storable a) => Ptr a -> Int -> a -> Int+arraySizeAux _ n a = n * sizeOf a

+ src/Foreign/Marshal/Array/Guarded/Plain.hs view

@@ -0,0 +1,20 @@+module Foreign.Marshal.Array.Guarded.Plain (+   create,+   alloca,+   ) where++import Foreign.Marshal.Array (allocaArray)+import Foreign.Storable (Storable)+import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, mallocForeignPtrArray)+import Foreign.Ptr (Ptr)++import Control.Applicative ((<$>))+++create :: (Storable a) => Int -> (Ptr a -> IO b) -> IO (ForeignPtr a, b)+create size f = do+   fptr <- mallocForeignPtrArray size+   (,) fptr <$> withForeignPtr fptr f++alloca :: (Storable a) => Int -> (Ptr a -> IO b) -> IO b+alloca = allocaArray