diff --git a/Data/Array/Repa/IO/BMP.hs b/Data/Array/Repa/IO/BMP.hs --- a/Data/Array/Repa/IO/BMP.hs +++ b/Data/Array/Repa/IO/BMP.hs @@ -1,21 +1,29 @@ -{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PackageImports, PatternGuards, ExplicitForAll #-} -- | Reading and writing arrays as uncompressed 24 and 32 bit Windows BMP files. module Data.Array.Repa.IO.BMP ( readImageFromBMP , readComponentsFromBMP + , readComponentsListFromBMP , readMatrixFromGreyscaleBMP + + -- Writing. , writeImageToBMP , writeComponentsToBMP + , writeComponentsListToBMP , writeMatrixToGreyscaleBMP) where -import qualified Data.Array.Parallel.Unlifted as U import Data.Array.Repa as A import Data.Array.Repa.ByteString as A import Prelude as P import Codec.BMP import Data.Word +-- NOTE: We set most of these functions as NOINLINE so it's easier to understand +-- what's going on in the core programs. The top-level IO functions are +-- only called a few times each, so it doesn't matter if they're not +-- worker/wrappered etc. + -- Read ------------------------------------------------------------------------------------------- -- | Read a matrix from a `BMP` file. -- Each pixel is converted to greyscale, normalised to [0..1] and used @@ -24,19 +32,35 @@ :: FilePath -> IO (Either Error (Array DIM2 Double)) +{-# NOINLINE readMatrixFromGreyscaleBMP #-} readMatrixFromGreyscaleBMP filePath = do eComps <- readComponentsFromBMP filePath case eComps of Left err -> return $ Left err Right (arrRed, arrGreen, arrBlue) - -> let arr = force + -> let arr = force2 $ A.fromFunction (extent arrRed) - (\ix -> sqrt ( (fromIntegral (arrRed !: ix) / 255) ^ (2 :: Int) - + (fromIntegral (arrGreen !: ix) / 255) ^ (2 :: Int) - + (fromIntegral (arrBlue !: ix) / 255) ^ (2 :: Int))) + (\ix -> sqrt ( (fromIntegral (arrRed ! ix) / 255) ^ (2 :: Int) + + (fromIntegral (arrGreen ! ix) / 255) ^ (2 :: Int) + + (fromIntegral (arrBlue ! ix) / 255) ^ (2 :: Int))) in arr `deepSeqArray` return (Right arr) - + +-- | Like `readComponentsFromBMP`, but return the components as a list. +readComponentsListFromBMP + :: FilePath + -> IO (Either Error [Array DIM2 Word8]) + +readComponentsListFromBMP filePath + = do eComps <- readComponentsFromBMP filePath + case eComps of + Left err + -> return $ Left err + + Right (arrRed, arrGreen, arrBlue) + -> return $ Right [arrRed, arrGreen, arrBlue] + + -- | Read RGB components from a BMP file. -- Returns arrays of red, green and blue components, all with the same extent. -- If anything goes wrong when loading the file then then `Error`. @@ -44,7 +68,7 @@ :: FilePath -> IO (Either Error (Array DIM2 Word8, Array DIM2 Word8, Array DIM2 Word8)) -{-# INLINE readComponentsFromBMP #-} +{-# NOINLINE readComponentsFromBMP #-} readComponentsFromBMP filePath = do ebmp <- readBMP filePath case ebmp of @@ -60,18 +84,18 @@ shapeFn _ = Z :. height :. width arrRed - = traverse arr shapeFn + = force2 $ traverse arr shapeFn (\get (sh :. x) -> get (sh :. (x * 4))) arrGreen - = traverse arr shapeFn + = force2 $ traverse arr shapeFn (\get (sh :. x) -> get (sh :. (x * 4 + 1))) arrBlue - = traverse arr shapeFn + = force2 $ traverse arr shapeFn (\get (sh :. x) -> get (sh :. (x * 4 + 2))) - in (arrRed, arrGreen, arrBlue) + in [arrRed, arrGreen, arrBlue] `deepSeqArrays` (arrRed, arrGreen, arrBlue) -- | Read a RGBA image from a BMP file. @@ -83,6 +107,7 @@ :: FilePath -> IO (Either Error (Array DIM3 Word8)) +{-# NOINLINE readImageFromBMP #-} readImageFromBMP filePath = do ebmp <- readBMP filePath case ebmp of @@ -102,20 +127,37 @@ -- Negative values are discarded. Positive values are normalised to the maximum -- value in the matrix and used as greyscale pixels. writeMatrixToGreyscaleBMP - :: FilePath - -> Array DIM2 Double + :: forall a. (Num a, Elt a, Fractional a, RealFrac a) + => FilePath + -> Array DIM2 a -> IO () +{-# NOINLINE writeMatrixToGreyscaleBMP #-} +{-# SPECIALISE writeMatrixToGreyscaleBMP :: FilePath -> Array DIM2 Float -> IO () #-} +{-# SPECIALISE writeMatrixToGreyscaleBMP :: FilePath -> Array DIM2 Double -> IO () #-} writeMatrixToGreyscaleBMP fileName arr = let arrNorm = normalisePositive01 arr - - scale :: Double -> Word8 scale x = fromIntegral (truncate (x * 255) :: Int) - arrWord8 = A.map scale arrNorm in writeComponentsToBMP fileName arrWord8 arrWord8 arrWord8 + +-- | Like `writeComponentsToBMP` but take the components as a list. +-- The list must have 3 arrays, for the red, green blue components +-- respectively, else `error`. +writeComponentsListToBMP + :: FilePath + -> [Array DIM2 Word8] + -> IO () +writeComponentsListToBMP filePath comps + | [red, green, blue] <- comps + = writeComponentsToBMP filePath red green blue + + | otherwise + = error "Data.Array.Repa.IO.BMP.writeComponentsListToBMP: wrong number of components" + + -- | Write RGB components to a BMP file. -- All arrays must have the same extent, else `error`. writeComponentsToBMP @@ -125,6 +167,7 @@ -> Array DIM2 Word8 -> IO () +{-# NOINLINE writeComponentsToBMP #-} writeComponentsToBMP fileName arrRed arrGreen arrBlue | not $ ( extent arrRed == extent arrGreen && extent arrGreen == extent arrBlue) @@ -152,6 +195,7 @@ -> Array DIM3 Word8 -> IO () +{-# NOINLINE writeImageToBMP #-} writeImageToBMP fileName arrImage | comps /= 4 = error "Data.Array.Repa.IO.BMP: lowest order dimension must be 4" @@ -169,7 +213,7 @@ -- | Normalise a matrix to to [0 .. 1], discarding negative values. -- If the maximum value is 0 then return the array unchanged. normalisePositive01 - :: (Shape sh, U.Elt a, Fractional a, Ord a) + :: (Shape sh, Elt a, Fractional a, Ord a) => Array sh a -> Array sh a diff --git a/Data/Array/Repa/IO/Matrix.hs b/Data/Array/Repa/IO/Matrix.hs --- a/Data/Array/Repa/IO/Matrix.hs +++ b/Data/Array/Repa/IO/Matrix.hs @@ -19,7 +19,6 @@ import Data.List as L import Data.Array.Repa as A import Prelude as P -import qualified "dph-prim-par" Data.Array.Parallel.Unlifted as U -- | Read a matrix from a text file. @@ -27,7 +26,7 @@ -- WARNING: This doesn't do graceful error handling. If the file has the wrong format -- you'll get a confusing `error`. readMatrixFromTextFile - :: (U.Elt a, Num a, Read a) + :: (Elt a, Num a, Read a) => FilePath -> IO (Array DIM2 a) @@ -47,7 +46,7 @@ -- | Write a matrix as a text file. writeMatrixToTextFile - :: (U.Elt a, Show a) + :: (Elt a, Show a) => FilePath -> Array DIM2 a -> IO () @@ -60,7 +59,7 @@ let Z :. width :. height = extent arr - hPutStrLn file $ show width ++ " " ++ show height + hPutStrLn file $ show width P.++ " " P.++ show height hWriteValues file $ toList arr hClose file diff --git a/Data/Array/Repa/IO/Timing.hs b/Data/Array/Repa/IO/Timing.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Repa/IO/Timing.hs @@ -0,0 +1,86 @@ +module Data.Array.Repa.IO.Timing + ( Time + , milliseconds, cpuTime, wallTime + , time, minus, plus + , showTime + , prettyTime) +where +import GHC.Exts (traceEvent) +import System.CPUTime +import System.Time + + +-- Time ----------------------------------------------------------------------- +-- | Abstract representation of process time. +data Time + = Time + { cpu_time :: Integer + , wall_time :: Integer + } + +zipT :: (Integer -> Integer -> Integer) -> Time -> Time -> Time +zipT f (Time cpu1 wall1) (Time cpu2 wall2) + = Time (f cpu1 cpu2) (f wall1 wall2) + +-- | Subtract second time from the first. +minus :: Time -> Time -> Time +minus = zipT (-) + + +-- | Add two times. +plus :: Time -> Time -> Time +plus = zipT (+) + + +-- TimeUnit ------------------------------------------------------------------- +-- | Conversion +type TimeUnit + = Integer -> Integer + +milliseconds :: TimeUnit +milliseconds n = n `div` 1000000000 + +cpuTime :: TimeUnit -> Time -> Integer +cpuTime f = f . cpu_time + +wallTime :: TimeUnit -> Time -> Integer +wallTime f = f . wall_time + + +-- | Get the current time. +getTime :: IO Time +getTime = + do + cpu <- getCPUTime + TOD sec pico <- getClockTime + return $ Time cpu (pico + sec * 1000000000000) + + +-- | Show a time as a string, in milliseconds. +showTime :: Time -> String +showTime t = (show $ wallTime milliseconds t) + ++ "/" + ++ (show $ cpuTime milliseconds t) + +-- | Pretty print the times, in milliseconds. +prettyTime :: Time -> String +prettyTime t + = unlines + [ "elapsedTimeMS = " ++ (show $ wallTime milliseconds t) + , "cpuTimeMS = " ++ (show $ cpuTime milliseconds t) ] + +-- Timing benchmarks ---------------------------------------------------------- + +-- | Time some IO action. +-- Make sure to deepseq the result before returning it from the action. If you +-- don't do this then there's a good chance that you'll just pass a suspension +-- out of the action, and the computation time will be zero. +time :: IO a -> IO (a, Time) +{-# NOINLINE time #-} +time p = do + start <- getTime + traceEvent "Bench.Benchmark: start timing" + x <- p + traceEvent "Bench.Benchmark: finished timing" + end <- getTime + return (x, end `minus` start) diff --git a/Data/Array/Repa/IO/Vector.hs b/Data/Array/Repa/IO/Vector.hs --- a/Data/Array/Repa/IO/Vector.hs +++ b/Data/Array/Repa/IO/Vector.hs @@ -20,14 +20,13 @@ import System.IO import Control.Monad import Data.Char -import qualified "dph-prim-par" Data.Array.Parallel.Unlifted as U -- | Read a vector from a text file. -- WARNING: This doesn't do graceful error handling. If the file has the wrong format -- you'll get a confusing `error`. readVectorFromTextFile - :: (U.Elt a, Num a, Read a) + :: (Elt a, Num a, Read a) => FilePath -> IO (Array DIM1 a) @@ -55,7 +54,7 @@ -- | Write a vector as a text file. writeVectorToTextFile - :: (U.Elt a, Show a) + :: (Elt a, Show a) => Array DIM1 a -> FilePath -> IO () diff --git a/repa-io.cabal b/repa-io.cabal --- a/repa-io.cabal +++ b/repa-io.cabal @@ -1,5 +1,5 @@ Name: repa-io -Version: 1.1.0.0 +Version: 2.0.0.1 License: BSD3 License-file: LICENSE Author: The DPH Team @@ -11,21 +11,18 @@ Homepage: http://trac.haskell.org/repa Bug-reports: http://trac.haskell.org/repa/newticket Description: - NOTE: You must use the GHC head branch > 6.13.20100309 to get decent performance. Read and write Repa arrays in various formats. Synopsis: Read and write Repa arrays in various formats. -Tested-with: GHC == 6.13.20100309, GHC == 6.12.1 - Library Build-Depends: base == 4.*, - dph-prim-par == 0.4.*, - repa == 1.1.*, - repa-bytestring == 1.1.*, - bmp == 1.1.* + repa == 2.0.*, + repa-bytestring == 2.0.*, + bmp == 1.1.*, + old-time == 1.0.* ghc-options: -Odph -Wall -fno-warn-missing-signatures @@ -35,6 +32,7 @@ Data.Array.Repa.IO.BMP Data.Array.Repa.IO.Vector Data.Array.Repa.IO.Matrix + Data.Array.Repa.IO.Timing Other-modules: Data.Array.Repa.IO.Internals.Text