diff --git a/Examples/Effects/Overdrive.hs b/Examples/Effects/Overdrive.hs new file mode 100644 --- /dev/null +++ b/Examples/Effects/Overdrive.hs @@ -0,0 +1,23 @@ +module Examples.Effects.Overdrive where + +import qualified Prelude +import Feldspar +import Feldspar.Vector +import Feldspar.Compiler + +-- | Generic (not compilable) overdrive function +overdrive :: (Numeric a, Ord a) => DVector a -> Data a -> Data a -> DVector a +overdrive x mul bound = map (\x -> x * mul) $ map mapFn x + where + mapFn elem = (?) (elem > bound) (bound, elseBranch) + where + elseBranch = (?) (elem < - bound) (-bound,elem) + +-- | Wrapper to fix the type and size of the vectors in overdrive. +overdriveInstance :: Data [Float] -> Data Float -> Data Float -> Data [Float] +overdriveInstance x mul bound = + freezeVector $ overdrive (unfreezeVector' 256 x) mul bound + +-- | Wrapper to fix the type and size of the vectors in overdrive. +overdrive_wrapped :: Data' D256 [Float] -> Data Float -> Data Float -> Data [Float] +overdrive_wrapped = wrap (overdrive :: DVector Float -> Data Float -> Data Float -> DVector Float) diff --git a/Examples/Effects/ShiftByOneOctave.hs b/Examples/Effects/ShiftByOneOctave.hs new file mode 100644 --- /dev/null +++ b/Examples/Effects/ShiftByOneOctave.hs @@ -0,0 +1,25 @@ +module Examples.Effects.ShiftByOneOctave where + +import qualified Prelude +import Feldspar +import Feldspar.Vector +import Feldspar.Compiler + +-- | Generic (not compilable) algorithm to double the frequency of a signal. +-- This is an approximate solution without using FFT. +shiftByOneOctave :: (Fractional' a) => DVector a -> DVector a +shiftByOneOctave inp = half ++ half + where + half = everySecond $ map avg $ zip inp $ tail inp + everySecond xs = indexed (length xs `div` 2) $ \idx -> xs ! (2*idx) + avg (x,y) = (x + y) / 2 + +-- | Wrapper to fix the type and size of the vectors in shiftByOneOctave. +shiftByOneOctaveInstance :: Data [Float] -> Data [Float] +shiftByOneOctaveInstance input = freezeVector $ shiftByOneOctave input' + where + input' = unfreezeVector' 256 input + +-- | Wrapper to fix the type and size of the vectors in shiftByOneOctave. +shiftByOneOctave_wrapped :: Data' D256 [Float] -> Data [Float] +shiftByOneOctave_wrapped = wrap (shiftByOneOctave :: DVector Float -> DVector Float) diff --git a/Examples/Math/Convolution.hs b/Examples/Math/Convolution.hs new file mode 100644 --- /dev/null +++ b/Examples/Math/Convolution.hs @@ -0,0 +1,22 @@ +module Examples.Math.Convolution where + +import qualified Prelude +import Feldspar +import Feldspar.Vector +import Feldspar.Compiler +import Feldspar.Matrix + +-- | Generic (not compilable) convolution function +convolution :: (Numeric a) => DVector a -> DVector a -> DVector a +convolution kernel input = map ((scalarProd kernel) . reverse) $ inits input + +-- | Wrappers to define the size and element type of vectors in 'convolution' +convolutionInstance :: Data [Float] -> Data [Float] -> Data [Float] +convolutionInstance kernel input = freezeVector $ convolution kernel' input' + where + input' = unfreezeVector' 256 input + kernel' = unfreezeVector' 16 kernel + +-- | Wrappers to define the size and element type of vectors in 'convolution' +convolution_wrapped :: Data' D16 [Float] -> Data' D256 [Float] -> Data [Float] +convolution_wrapped = wrap (convolution :: DVector Float -> DVector Float -> DVector Float) diff --git a/Examples/Math/Fft.hs b/Examples/Math/Fft.hs new file mode 100644 --- /dev/null +++ b/Examples/Math/Fft.hs @@ -0,0 +1,124 @@ +module Examples.Math.Fft where + +import qualified Prelude as P +import Feldspar +import Feldspar.Vector +import Feldspar.Matrix +import Feldspar.Compiler + +-- | Wrapper to define the size of vectors in 'fft' +fftInstance :: Data [Complex Float] -> Data [Complex Float] +fftInstance = freezeVector . fft . unfreezeVector' 256 + +-- | Wrapper to define the size of vectors in 'fft' +fft_wrapped ::Data' D256 [Complex Float] -> Data [Complex Float] +fft_wrapped = wrap fft + +-- | Wrapper to define the size of vectors in 'ifft' +ifftInstance :: Data [Complex Float] -> Data [Complex Float] +ifftInstance = freezeVector . ifft . unfreezeVector' 256 + +-- | Wrapper to define the size of vectors in 'ifft' +ifft_wrapped ::Data' D256 [Complex Float] -> Data [Complex Float] +ifft_wrapped = wrap ifft + + +-- =================== INTERFACE ================================== +-- | Radix-2 Decimation-In-Frequeny Fast Fourier Transformation of the given complex vector +-- The given vector must be power-of-two sized, (for example 2, 4, 8, 16, 32, etc.) +fft :: DVector (Complex Float) -> DVector (Complex Float) +fft v = bitRev (loglen-1) $ fftCore (loglen-1) v + where loglen = f2i $ logBase 2 $ i2f $ length v + +-- | Radix-2 Decimation-In-Frequeny Inverse Fast Fourier Transformation of the given complex vector +-- The given vector must be power-of-two sized, (for example 2, 4, 8, 16, 32, etc.) +ifft :: DVector (Complex Float) -> DVector (Complex Float) +ifft v = bitRev (loglen-1) $ ifftCore (loglen-1) v + where loglen = f2i $ logBase 2 $ i2f $ length v +-- ================================================================ + + + + +-- | fftCore function uses 2^(n+1) input vector. +-- Output from the last stage needs to be bit reversed using bitRev function (if required) +fftCore :: Data Index -> DVector (Complex Float) -> DVector (Complex Float) +fftCore n v = composeOn stage (reverse (0...n)) v + +stage k (Indexed l ixf Empty) = (Indexed l ixf' Empty) + where + k2 = 1 << k + ixf' i = condition (testBit i k) (twid * (b-a)) (a+b) + where + a = ixf i + b = ixf (i `xor` k2) + twid = cis (-pi*(i2f (lsbs k i)) / i2f k2) + + +-- | ifftCore function uses 2^(n+1) input vector. +-- Output from the last stage needs to be bit reversed using bitRev function (if required) +ifftCore :: Data Index -> DVector (Complex Float) -> DVector (Complex Float) +ifftCore n v = map (/ (complex (i2f (2^(n+1))) 0)) $ composeOn istage (reverse (0...n)) v + +istage k (Indexed l ixf Empty) = (Indexed l ixf' Empty) + where + k2 = 1 << k + ixf' i = condition (testBit i k) (twid * (b-a)) (a+b) + where + a = ixf i + b = ixf (i `xor` k2) + twid = cis (pi*(i2f (lsbs k i)) / i2f k2) + + +-- | bitRev function transforms the given vector to bitreversal order +-- parameter n is the size of the input vector +bitRev :: Type a => Data Index -> Vector (Data a) -> Vector (Data a) +bitRev n = pipe riffle (1...n) + + +-- | Helper functions for fftCore and ifftCore and bitRev +pipe :: (Syntactic a) => (Data Index -> a -> a) -> Vector (Data Index) -> a -> a +pipe = flip.fold.flip + +composeOn f is as = fold (flip f) as is + +allOnes = complement 0 + +oneBits n = complement (allOnes << n) + +lsbs k i = i .&. oneBits k + +par m n f = mat2Vec m n . map f . vec2Mat m n + +-- k at least 1 +rotBit :: Data Index -> Data Index -> Data Index +rotBit 0 _ = error "k should be at least 1" +rotBit k i = lefts .|. rights + where + ir = i >> 1 + rights = ir .&. (oneBits k) + lefts = (((ir >> k) << 1) .|. (i .&. 1)) << k + +riffle k (Indexed l ixf Empty) = indexed l (ixf.rotBit k) + +vec2Mat :: Data Index -> Data Index -> Vector (Data a) -> Matrix a +vec2Mat m n (Indexed l ixf Empty) = indexedMat (1 << m) (1 << n) ixf' + where + ixf' i j = ixf $ (i << n) `xor` j + +mat2Vec :: Type a => Data Index -> Data Index -> Matrix a -> Vector (Data a) +mat2Vec m n matr = Indexed (1 << m << n) ixf Empty + where + ixf i = matr ! y ! x + where + y = i >> n + x = i .&. (oneBits n) + + + +-- Ad-hoc function to generate a power-of-two sequence in order to test fft and ifft +pow2Seq :: Data DefaultWord -> DVector (Complex Float) +pow2Seq n = indexed (2 ^ n) (\i ->complex (i2f i) 0 ) + + + diff --git a/Examples/Simple/Basics.hs b/Examples/Simple/Basics.hs new file mode 100644 --- /dev/null +++ b/Examples/Simple/Basics.hs @@ -0,0 +1,43 @@ +module Examples.Simple.Basics where + +import qualified Prelude +import Feldspar +import Feldspar.Vector +import Feldspar.Compiler + +-- Identity function for 32 bit integers. +example1 :: Data Int32 -> Data Int32 +example1 = id + +-- Constant function +example2 :: Data Int32 +example2 = 2 + +-- A constant core vector +example3 :: Data [Int32] +example3 = value [42,1,2,3] + +-- Examples showing some of the integer and boolean operations: + +example4 :: Data Int32 -> Data Int32 +example4 x = negate x + +example5 :: Data Int32 -> Data Int32 -> Data Int32 +example5 x y = x + y + +example6 :: Data Int32 -> Data Int32 -> Data Bool +example6 x y = x == y + +example7 :: Data Bool +example7 = 2 /= (2 :: Data Int32) -- Type of numeric literals sometimes have to be written explicitly. + +example8 :: Data Bool -> Data Bool +example8 b = not b + +-- Examples on using conditionals: + +example9 :: Data Int32 -> Data Int32 +example9 a = condition (a<5) (3*(a+a)) (30*(a+20)) + +example10 :: Data Int32 -> Data Int32 +example10 a = condition (a<5) (3*(a+a)) (30*(a+a)) diff --git a/Examples/Simple/Complex.hs b/Examples/Simple/Complex.hs new file mode 100644 --- /dev/null +++ b/Examples/Simple/Complex.hs @@ -0,0 +1,35 @@ +module Examples.Simple.Complex where + +import qualified Prelude +import Feldspar +import Feldspar.Vector +import Feldspar.Compiler + +-- | Creation of complex values, addition and conjugation. +complex1 :: Data (Complex Float) +complex1 = conjugate $ value (3 :+ 4) + value (0 :+ 9) + +-- | Constant vector containing complex values. +complex2 :: Data [Complex Float] +complex2 = wrap $ vector + [ 3 :+ 4 :: Complex Float, 0 :+ 9, (-13) :+ (-4), 32 :+ 22 + , 0 :+ 0, 10 :+ 9, 3 :+ (-2), 21 :+ 3 + , 10 :+ 4, 2 :+ 2, 0 :+ 1, 0 :+ (-10) + , (-1) :+ 0, 3 :+ (-3), 5 :+ 55 + ] + +-- | Sum of a complex vector. +complex3 :: Data' D256 [Complex Float] -> Data (Complex Float) +complex3 = wrap (sum :: DVector (Complex Float) -> Data (Complex Float)) + +-- | Generic (not compilable) pairwise multiplication of vectors. +complex4 :: (Syntactic a, Num a) => Vector a -> Vector a -> Vector a +complex4 = zipWith (*) + +-- | Instance of the generic algorithm for complex values and fixed length arrays. +complex4' :: Data' D256 [Complex Float] -> Data' D256 [Complex Float] -> Data [Complex Float] +complex4' = wrap (complex4 :: DVector (Complex Float) -> DVector (Complex Float) -> DVector (Complex Float)) + +-- | Real parts of a complex vector. +complex5 :: Data' D256 [Complex Float] -> Data [Float] +complex5 = wrap $ map (realPart :: Data (Complex Float) -> Data Float) diff --git a/Examples/Simple/Fixedpoint.hs b/Examples/Simple/Fixedpoint.hs new file mode 100644 --- /dev/null +++ b/Examples/Simple/Fixedpoint.hs @@ -0,0 +1,112 @@ +module Examples.Simple.Fixedpoint where + +import Prelude () +import qualified Prelude as P +import Feldspar +import Feldspar.FixedPoint +import Feldspar.Compiler +import Feldspar.Vector + +-- | Generic (not compilable) adder +fpex1 :: (Num a) => a -> a -> a +fpex1 x y = x + y + +-- | Wrapper for 'fpex1' using fixed-point numbers +-- (with type Int32, input exponents are (-2) and (-3), +-- while the output exponent is (-4)) +fpex1Fix32 :: Data Int32 -> Data Int32 -> Data Int32 +fpex1Fix32 x y = freezeFix' (-2) $ fpex1 ((unfreezeFix' (-3) x)) + ((unfreezeFix' (-4) y)) + +-- | Wrapper for 'fpex1' using floating-point numbers +fpex1Float :: Data Float -> Data Float -> Data Float +fpex1Float x y = fpex1 x y + +-- | Generic (not compilable) division +fpex2 :: (Fractional a, Fixable a) => a -> a -> a +fpex2 x y = x / y + +-- | Wrapper for 'fpex2' using fixed-point numbers +fpex2Fix32 :: Data Int32 -> Data Int32 -> Data Int32 +fpex2Fix32 x y = freezeFix' (-4) $ fpex2 ((unfreezeFix' (-8) x)) + ((unfreezeFix' (-4) y)) + +-- | Wrapper for 'fpex3' using floating-point numbers +fpex2Float :: Data Float -> Data Float -> Data Float +fpex2Float x y = fpex2 x y + +-- | Generic (not compilable) function adding 0.25 to the input +fpex3 :: (Num a,Fractional a,Fixable a) => a -> a +fpex3 x = x + (fix (-2) 0.25) + +-- | Wrapper for 'fpex3' using fixed-point numbers (with type Int32) +fpex3Fix32 :: Data Int32 -> Data Int32 +fpex3Fix32 x = freezeFix' (-4) $ fpex3 $ unfreezeFix' (-2) x + +-- | Wrapper for 'fpex3' using floating-point numbers +fpex3Float :: Data Float -> Data Float +fpex3Float x = fpex3 x + +-- | Generic (not compilable) function increasing each element of the input vector +fpex4 :: (Num a) => + a -> Vector a -> Vector a +fpex4 x = map (x+) + +-- | Wrapper for 'fpex4' using fixed-point numbers (with type Int32) +fpex4Fix32 :: Data Int32 -> DVector Int32 -> DVector Int32 +fpex4Fix32 x xs = map (freezeFix' (-4)) $ fpex4 x' xs' + where + xs' :: Vector (Fix Int32) + xs' = map (unfreezeFix' (-6)) xs + x' :: Fix Int32 + x' = unfreezeFix' (-8) x + +-- | Wrapper for 'fpex4' using floating-point numbers +fpex4Float :: Data Float -> Data [Float] -> Data [Float] +fpex4Float x xs = freezeVector $ fpex4 x xs' + where + xs' = unfreezeVector' 256 xs + + +-- | Generic (not compilable) average function +fpex5 :: (Num a,Fractional a) => a -> a -> a +fpex5 x y = (x + y) / 2 + +-- | Wrapper for 'fpex5' using fixed-point numbers (with type Int32) +fpex5Fix32 :: Data Int32 -> Data Int32 -> Data Int32 +fpex5Fix32 x y = freezeFix' (-5) $ fpex5 x' y' + where + x' = unfreezeFix' (-4) x + y' = unfreezeFix' (-6) y + +-- | Wrapper for 'fpex5' using floating-point numbers +fpex5Float :: Data Float -> Data Float -> Data Float +fpex5Float x y = fpex5 x y + +-- | Generic (not compilable) function with condition +fpex6 :: (Fractional a, Syntactic a, Fixable a) => Data Bool -> a -> a +fpex6 cond x = cond ?! (x, x+100.256) + +-- | Wrapper for 'fpex6' using fixed-point numbers (with type Int32) +fpex6Fix32 :: Data Bool -> Data Int32 -> Data Int32 +fpex6Fix32 cond = freezeFix' (-2) . fpex6 cond . unfreezeFix' (-3) + +-- | Wrapper for 'fpex6' using floating-point numbers +fpex6Float :: Data Bool -> Data Float -> Data Float +fpex6Float = fpex6 + +-- | Generic (not compilable) scalar product function +fpScalarProd :: (Num a, Syntactic a, Fixable a) => + Vector a -> Vector a -> a +fpScalarProd x y = fixFold (+) (fix (-8) 0) $ zipWith (*) x y + +-- | Wrapper for 'fpScalarProd' using fixed-point numbers (with type Int32) +fpScalarProdFix32 :: DVector Int32 -> DVector Int32 -> Data Int32 +fpScalarProdFix32 x y = freezeFix' (-8) $ fpScalarProd x' y' + where + x' = map (unfreezeFix' (-6)) x + y' = map (unfreezeFix' (-4)) y + +-- | Wrapper for 'fpScalarProd' using floating-point numbers +fpScalarProdFloat :: DVector Float -> DVector Float -> Data Float +fpScalarProdFloat = fpScalarProd diff --git a/Examples/Simple/Matrices.hs b/Examples/Simple/Matrices.hs new file mode 100644 --- /dev/null +++ b/Examples/Simple/Matrices.hs @@ -0,0 +1,26 @@ +module Examples.Simple.Matrices where + +import qualified Prelude +import Feldspar +import Feldspar.Vector +import Feldspar.Matrix +import Feldspar.Compiler + +-- * Examples on working with matrices. + +-- | Generates a parallel matrix. +matrix1 :: Matrix Index +matrix1 = indexed 2 vec + where + vec x = indexed 10 ((+x) . (*10)) + +-- | Generates a parallel matrix (20x100) and transposes it. +matrix2 :: Matrix Index +matrix2 = transpose $ indexed 20 (\x -> indexed 100 ((+x) . (*10))) + +-- | Matrix multiplication +matMult :: Data' (D16,D16) [[Int32]] -> Data' (D16,D16) [[Int32]] -> Data [[Int32]] +matMult = wrap ((***) :: Matrix Int32 -> Matrix Int32 -> Matrix Int32) + +matMult' :: Data [[Int32]] -> Data [[Int32]] -> Data [[Int32]] +matMult' m1 m2 = freezeMatrix $ (unfreezeMatrix' 16 16 m1) *** (unfreezeMatrix' 16 16 m2) diff --git a/Examples/Simple/Pairs.hs b/Examples/Simple/Pairs.hs new file mode 100644 --- /dev/null +++ b/Examples/Simple/Pairs.hs @@ -0,0 +1,23 @@ +module Examples.Simple.Pairs where + +import Prelude () +import Feldspar +import Feldspar.Vector +import Feldspar.Compiler + +-- | Haskell pairs are compiled to separate variables. +pairs1 :: Data Int32 -> Data Float -> (Data Int32, Data Float) +pairs1 x y = (x,y) + +-- | Feldspar pairs are compiled to structs. +pairs2 :: Data Int32 -> Data Float -> Data (Int32,Float) +pairs2 x y = pair x y + +-- | Selector functions: getFst, getSnd. +pairs3 :: Data (Int32,Float) -> (Data Int32, Data Float) +pairs3 p = (getFst p, getSnd p) + +-- | Zipping two vectors into a vector of pairs. +pairs4 :: Data [Float] -> Data [Int32] -> Data [(Float,Int32)] +pairs4 xs ys = freezeVector $ zipWith pair (unfreezeVector' 256 xs) (unfreezeVector' 256 ys) + diff --git a/Examples/Simple/Sharing.hs b/Examples/Simple/Sharing.hs new file mode 100644 --- /dev/null +++ b/Examples/Simple/Sharing.hs @@ -0,0 +1,35 @@ +module Examples.Simple.Sharing where + +import qualified Prelude +import Feldspar +import Feldspar.Vector +import Feldspar.Compiler + +-- | Examples on the optimization transformation 'sharing' (also called 'common subexpression elimination'). + +share1 :: Data Int32 -> Data Int32 +share1 v = w + w where + w = 2 * v + +share2 :: Data Int32 -> Data Int32 +share2 v = (2*v) + (2*v) + +share3 :: Data Int32 -> DVector Int32 +share3 v = indexed 10 $ const w where + w = 2 * v + v + +share4 :: Data Int32 -> DVector Int32 +share4 v = indexed 10 $ const w where + w = 2 * q + q where + q = v + 1 + +share4' :: Data Int32 -> Data [Int32] +share4' = wrap share4 + +share5 :: Data Index -> DVector Index +share5 v = indexed 10 $ \ix -> w ix where + w ix = 2 * v + ix + +share5' :: Data Index -> Data [Index] +share5' = wrap share5 + diff --git a/Examples/Simple/Streams.hs b/Examples/Simple/Streams.hs new file mode 100644 --- /dev/null +++ b/Examples/Simple/Streams.hs @@ -0,0 +1,25 @@ +module Examples.Simple.Streams where + +import Prelude () +import Feldspar +import Feldspar.Vector +import Feldspar.Stream +import Feldspar.Compiler + +-- | Generic (not compilable) function to introduce usage of scan function for Streams. +-- 'scan f a str' produces a stream by successively applying 'f' to +-- each element of the input stream 'str' and the previous element of +-- the output stream. +stream1 :: (Num a, Syntactic a) => Stream a -> Stream a +stream1 = scan (+) 0 + +-- | Wrapper to turn the parameters of 'stream1' into vectors. +stream1_1 :: (Numeric a) => DVector a -> DVector a +stream1_1 = streamAsVector stream1 + +-- | Wrappers to fix the type and size of the streams in 'stream1_1'. +stream1_1' :: Data [Int32] -> Data [Int32] +stream1_1' xs = freezeVector $ stream1_1 $ unfreezeVector' 64 xs + +stream1_1_wrapped:: Data' D64 [Int32] -> Data [Int32] +stream1_1_wrapped = wrap (stream1_1 :: DVector Int32 -> DVector Int32) diff --git a/Examples/Simple/Trace.hs b/Examples/Simple/Trace.hs new file mode 100644 --- /dev/null +++ b/Examples/Simple/Trace.hs @@ -0,0 +1,13 @@ +module Examples.Simple.Trace where + +import qualified Prelude +import Feldspar +import Feldspar.Vector +import Feldspar.Compiler + +--- | Example showing the application of tracing function. +--- Creating three tracing point for each loop cycle, +--- tracing two inputs and result of '+' operation. + +traceExample :: Data [Int32] -> Data Int32 +traceExample xs = fold (\x y -> trace 3 $ trace 1 x + trace 2 y) 0 $ unfreezeVector' 255 xs diff --git a/Examples/Simple/Vectors.hs b/Examples/Simple/Vectors.hs new file mode 100644 --- /dev/null +++ b/Examples/Simple/Vectors.hs @@ -0,0 +1,60 @@ +module Examples.Simple.Vectors where + +import qualified Prelude +import Feldspar +import Feldspar.Vector +import Feldspar.Compiler + +-- * Examples on working with vectors. + +-- | Generates a vector: [1, 2, 3, ... , 16], +-- adds 3 to every element and +-- reverses the vector then +-- multiplies every element by 10. +vector1 :: DVector Index +vector1 = map (*10) $ reverse $ map (+3) $ enumFromTo 1 16 + +-- | The same computation, but storing each intermediate result into temporal buffers +vector1' :: DVector Index +vector1' = map (*10) $ force $ reverse $ force $ map (+3) $ force $ enumFromTo 1 16 + +-- | Drops the first 3 elements of a vector +vector2 :: DVector Int32 -> DVector Int32 +vector2 = drop 3 + +-- | Wrappers to `vector2` to provide static information on the input vector size +vector2' :: Data' D10 [Int32] -> Data [Int32] +vector2' = wrap vector2 + +vector2'' :: Data [Int32] -> Data [Int32] +vector2'' = freezeVector . vector2 . unfreezeVector' 10 + +-- | Generates a parallel vector of size 10 +vector3 :: Data Index -> DVector Index +vector3 a = indexed 10 ((+a) . (*10)) + +-- | Vector summation. +vector4 :: (Numeric a) => DVector a -> Data a +vector4 xs = fold (+) 0 xs + +-- | Wrappers to provide the necessary type information +vector4' :: DVector Int32 -> Data Int32 +vector4' = vector4 + +vector4'' :: DVector Word8 -> Data Word8 +vector4'' = vector4 + +-- | Generic function to increment vector elements +vector5 :: (Numeric a) => DVector a -> DVector a +vector5 = map (+1) + +-- | Wrappers to provide necessary type information and input size +vector5' :: DVector Int32 -> DVector Int32 +vector5' = vector5 + +vector5'' :: Data' D64 [Int32] -> Data [Int32] +vector5'' = wrap (vector5 :: DVector Int32 -> DVector Int32) + +-- | Concatenation +vector6 :: DVector Int32 -> DVector Int32 +vector6 xs = map (+1) xs ++ map (*2) xs diff --git a/Examples/Tutorial/FixedPoint.hs b/Examples/Tutorial/FixedPoint.hs new file mode 100644 --- /dev/null +++ b/Examples/Tutorial/FixedPoint.hs @@ -0,0 +1,44 @@ +module Fixedpoint where + +import qualified Prelude +import Feldspar +import Feldspar.FixedPoint +import Feldspar.Compiler +import Feldspar.Vector + +generic :: (Fractional a) => Vector a -> Vector a +generic = map (\x -> x+3.14) + +floating :: DVector Float -> DVector Float +floating = generic + +fixed :: DVector Int32 -> DVector Int32 +fixed = map (freezeFix' (-6)) . generic . map (unfreezeFix' (-4)) + +emulation :: Vector (Fix Int16) -> Vector (Fix Int16) +emulation = generic + +branch1 :: Data Bool -> Data Int32 -> Data Int32 -> Data Int32 +branch1 c x y = freezeFix' (-16) $ c ? (x', y') + where + x' = unfreezeFix' (-20) x + y' = unfreezeFix' (-10) y + +branch2 :: Data Bool -> Data Int32 -> Data Int32 -> Data Int32 +branch2 c x y = freezeFix' (-16) $ c ?! (x', y') + where + x' = unfreezeFix' (-20) x + y' = unfreezeFix' (-10) y + +scalarProduct :: (Num a, Syntactic a, Fixable a) => + Data DefaultInt -> Vector a -> Vector a -> a +scalarProduct e xs ys = fixFold (+) (fix e 0) $ zipWith (*) xs ys + +floatScalarProduct :: DVector Float -> DVector Float -> Data Float +floatScalarProduct = scalarProduct undefined + +fixScalarProduct :: DVector Int32 -> DVector Int32 -> Data Int32 +fixScalarProduct xs ys = freezeFix' (-18) $ scalarProduct (-16) xs' ys' + where + xs' = map (unfreezeFix' (-8)) xs + ys' = map (unfreezeFix' (-6)) ys diff --git a/Examples/Tutorial/Stream.hs b/Examples/Tutorial/Stream.hs new file mode 100644 --- /dev/null +++ b/Examples/Tutorial/Stream.hs @@ -0,0 +1,23 @@ +module Examples.Tutorial.Stream where + +import qualified Prelude +import Feldspar +import Feldspar.Stream hiding (fir,iir) +import Feldspar.Vector (Vector, DVector + , replicate, length, scalarProd, reverse, vector) + +fir :: DVector Float -> + Stream (Data Float) -> Stream (Data Float) +fir b input = + recurrenceI (replicate (length b) 0) input + (\input -> scalarProd b (reverse input)) + +iir :: Data Float -> DVector Float -> DVector Float -> + Stream (Data Float) -> Stream (Data Float) +iir a0 a b input = + recurrenceIO (replicate (length b) 0) input + (replicate (length a) 0) + (\input output -> 1 / a0 * + ( scalarProd b (reverse input) + - scalarProd a (reverse output)) + ) diff --git a/Examples/Tutorial/Tutorial.hs b/Examples/Tutorial/Tutorial.hs new file mode 100644 --- /dev/null +++ b/Examples/Tutorial/Tutorial.hs @@ -0,0 +1,606 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} + +module Tutorial where + +import qualified Prelude as P + +import Feldspar +import Feldspar.Compiler +import Feldspar.Vector + +-- This file contains the examples of vector programming +-- covered in the draft Feldspar Tutorial + +type UInt = Data DefaultWord -- Feldspar usigned int + +type VInt = DVector DefaultInt + + +-- some functions for manipulating bits of indices +-- Remove those that are not used when tutorial is finshed + +complN :: Data Index -> Data Index -> Data Index +complN k = (`xor` oneBitsN k) + +oneBitsN :: Data Index -> Data Index +oneBitsN = complement . zeroBitsN + +zeroBitsN :: Data Index -> Data Index +zeroBitsN = (allOnes <<) + +allOnes :: Data Index +allOnes = complement 0 + +complTo :: Data Index -> Data Index -> Data Index +complTo k = (`xor` oneBitsTo k) + +flipBit :: Data Index -> Data Index -> Data Index +flipBit k = (`xor` (1< Data Index -> Data Bool +bitZero k i = (i .&. (1< Data Index -> Data Bool +bitOne k i = (i .&. (1< Data Bool +lsbZero i = (i .&. 1) == 0 + +zeroBitsTo :: Data Index -> Data Index +zeroBitsTo n = (zeroBitsN n) << 1 + +oneBitsTo :: Data Index -> Data Index +oneBitsTo = complement . zeroBitsTo + +lsbsTo :: Data Index -> Data Index -> Data Index +lsbsTo k = (.&. oneBitsTo k) + +lsbsN :: Data Index -> Data Index -> Data Index +lsbsN k i = i .&. oneBitsN k + +lsb :: Data Index -> Data Index +lsb = (.&. 1) + +-- lsb moves from position 0 to position k. Bits 1 to k shift one bit right +rotBitFrom0 :: Data Index -> Data Index -> Data Index +rotBitFrom0 k i = lefts .|. b .|. rights + where + r1s = complement l1s + l1s = zeroBitsTo k -- k+1 0s on right, rest 1s + b = (i .&. 1) << k + rights = (i .&. r1s) >> 1 + lefts = i .&. l1s + + + + +v1 = value [[1,2],[3,4],[5,(6::Int32)]] + +func :: Data Int32 -> Data Int32 -> Data Int32 -> Data Bool +func a b c = a + b == c + + +testParallel :: Data [Index] +testParallel = parallel 25 (\i -> 50-(2 * i)) + +setSize :: (Type a, Type b) => Length -> (Vector (Data a) -> Vector (Data b)) -> + Data [a] -> Vector (Data b) +setSize n f = f . unfreezeVector' n + + + +setSize'' :: (Type a1, Type a2, Type a) => Length -> + (Vector (Data a1) -> Vector (Data a2) -> Data a) -> + Data [a1] -> Data [a2] -> Data a +setSize'' n f as bs = f (unfreezeVector' n as) (unfreezeVector' n bs) + + +scalarProduct1 a b = forLoop (min (length a) (length b)) 0 (\ix sum -> sum + a!ix * b!ix) + +-- This function is actually built in as scalarProd +scalarProduct as bs = sum (zipWith (*) as bs) + + +sc = icompile (setSize'' 256 (scalarProduct :: VInt -> VInt -> Data DefaultInt)) + + +sc' = icompile (scalarProduct :: VInt -> VInt -> Data DefaultInt) + +countUp :: Data Length -> DVector Index +countUp n = indexed n id + +countUp1 :: Data Length -> DVector Index +countUp1 n = map (+1) (countUp n) + +countUpFrom :: Data Index -> Data Length -> DVector Index +countUpFrom m n = indexed n (+m) + + + +countDown :: Data Length -> DVector Index +countDown n = reverse (countUp n) + +ex1 = eval (countUp1 6) + +ex2 = eval (countDown 6) + + +revmap0 :: DVector Float -> DVector Float +revmap0 xs = map (+1) (reverse xs) + +revmap :: DVector Float -> DVector Float +revmap = map (+1) . reverse + +-- revmap1 :: DVector a -> DVector a This type is incorrect +revmap1 :: (Numeric a) => DVector a -> DVector a +revmap1 = map (+1) . reverse + +ex3' = eval (revmap1 (vector [0..5])) -- Missing type declaration + +ex3 = eval (revmap1 (vector [0..5] :: DVector Int32)) + +ex4 f n = eval (f (vector [0..n] :: VInt)) + + +cx1 = icompile (revmap1 :: VInt -> VInt) + +cx2 = icompile (setSize 256 (revmap1 :: VInt -> VInt)) + + +halveZip :: (Syntactic a) => (a -> a -> c) -> Vector a -> Vector c +halveZip f as = ms + where + (ls,rs) = splitAt halfl as + ms = zipWith f ls rs + l = length as + halfl = div l 2 + + + + +cx3 = icompile (setSize 256 (halveZip min :: VInt -> VInt)) + + + + + + +propUniv2 _ _ = universal + +mmin :: (P.Ord a, Type a) => Data a -> Data a -> Data a +mmin = function2 "min" propUniv2 P.min + +mmax :: (P.Ord a, Type a) => Data a -> Data a -> Data a +mmax = function2 "max" propUniv2 P.max + +cx4 = icompile (setSize 256 (halveZip mmin :: VInt -> VInt)) + +cx4' = icompile (setSize 255 (halveZip mmin :: VInt -> VInt)) + +cx4'' = icompile (setSize 256 ((take 3 . halveZip mmin) :: VInt -> VInt)) + + + + +both :: (Syntactic a) => (a -> a -> c) -> (a -> a -> c) -> Vector a -> Vector c +both f g as = fs ++ gs + where + fs = halveZip f as + gs = halveZip g as + + +ex5 n = eval $ (both mmin mmax . reverse) (vector [1..n] :: VInt) + +cx5 = icompile (setSize 256 (both mmin mmax :: VInt -> VInt)) + +cx6 = icompile (setSize 256 (mergeSegments . both mmin mmax :: VInt -> VInt)) + + + +premap :: (Data Index -> Data Index) -> Vector a -> Vector a +premap f (Indexed l ixf Empty) = indexed l (ixf . f) + +swapOE1 :: (Syntactic a) => Vector a -> Vector a +swapOE1 v = indexed (length v) ixf + where + ixf i = condition (i `mod` 2 == 0) (v!(i+1)) (v!(i-1)) + +swapOE2 :: Vector a -> Vector a +swapOE2 = premap (\i -> condition (i `mod` 2 == 0) (i+1)(i-1)) + +swapOE3 :: Vector a -> Vector a +swapOE3 = premap (`xor` 1) + + + +ex6 = eval (swapOE3 (vector [0..15] :: VInt)) + +ex7 = eval (swapOE3 (vector [1..17] :: VInt)) + +cx7' = icompile $ setSize 256 (swapOE1 :: VInt -> VInt) + +cx7'' = icompile $ setSize 256 (swapOE2 :: VInt -> VInt) + +cx7''' = icompile $ setSize 256 (swapOE3 :: VInt -> VInt) + + + +selEvenIx :: Vector a -> Vector a +selEvenIx as = take l (premap (*2) as) + where + l = (length as + 1) `div` 2 + +exer1a = eval (selEvenIx (vector [0..16] :: VInt)) + + +cexer1 = icompile (setSize 256 (selEvenIx :: VInt -> VInt)) + + +rev1 :: Vector a -> Vector a +rev1 v = premap (\i -> l-1-i) v + where + l = length v + + + + + + +ex8 = eval $ map (complN 4)(vector [0..15]) + +ex9 = eval $ map (complN 2)(vector [0..15]) + + +revi :: Data Index -> Vector a -> Vector a +revi k = premap (complN k) + +ex10 = eval (revi 2 (vector [0..15] :: VInt)) + +ex11 = eval (revi 2 (vector [0..31] :: VInt)) + + + +cx7 = icompile (setSize 256 (revi 4 . map (+1) :: VInt -> VInt)) + + + +ex12 = eval (fold (+) 0 (vector [0..15] :: VInt)) + + + + +sumEven :: Vector UInt -> UInt +sumEven = sum . map keepEven + where + keepEven i = condition (i `mod` 2 == 0) i 0 + +exer2a = eval (sumEven (vector [0..31] :: Vector UInt)) + +cexer2 = icompile sumEven + + +onCond :: Data Bool -> UInt -> UInt +onCond b m = m .&. (- (b2i b)) + +isEven i = i .&. 1 == 0 + +exer2b i = eval (onCond (isEven i) i) + +sumEven1 :: Vector UInt -> UInt +sumEven1 = sum . map keepEven1 + where + keepEven1 i = onCond (isEven i) i + +cexer2a = icompile sumEven1 + +pipe :: (Syntactic a) => (Data Index -> a -> a) -> Vector (Data Index) -> a -> a +pipe = flip . fold . flip + + + +fact :: UInt -> UInt +fact i = pipe f (countUp1 i) 1 + where + f i = (* i) + +fact1 :: UInt -> UInt +fact1 i = pipe f (2...i) 1 + where + f i = (* i) + +fact2 :: UInt -> UInt +fact2 i = pipe f (countUpFrom 2 (i-1)) i + where + f i = (* i) + + +fact3 :: UInt -> UInt +fact3 i = pipe f (map (+2) (countUp (i-1))) 1 + where + f i = (* i) + + +fact4 :: UInt -> UInt +fact4 i = fold1 (*) (countUp1 i) + + +ex13' = eval (fact 5) + + + +cx8 = icompile fact + +cx8' = icompile fact1 + +cx8'' = icompile fact2 + + + +bitr :: Data Index -> Data Index -> Data Index +bitr n i = snd (pipe stage (countUp n) (i, i >> n)) + where + stage _ (i,r) = (i>>1, (i .&. 1) .|. (r<<1)) + +bitRev :: Data Index -> Vector a -> Vector a +bitRev n = premap (bitr n) + +cx9 = icompile (bitRev :: Data Index -> VInt -> VInt) + +ex13'' = eval (bitRev 8 (vector [0..255] :: VInt)) +ex13''' = eval (bitRevLog 3 (vector [0..255] :: VInt)) +ex13''''= eval (bitRevH 8 (vector [0..255] :: VInt)) + + +mergeBy :: Data Index -> Data Index -> Data Index -> Data Index +mergeBy m a b = (a .&. m) .|. (b .&. complement m) + + +-- if you know that the number of bits to be reversed is a power +-- of two, you can do this nice trick +-- swap adjacent bits, then swap pairs of bits etc. +-- The number of bits to be reversed is 2^n +bitrLog :: Data Index -> Data Index -> Data Index +bitrLog n i = snd (pipe stage (map (1<<) (countDown n)) (allOnes, i)) + where + stage s (mask, v) = (mask', mergeBy mask' (v>>s) (v< Vector a -> Vector a +bitRevLog n = premap (bitrLog n) + +cx10 = icompile (bitRevLog :: Data Index -> VInt -> VInt) + + +composeN :: Index -> (a -> a) -> a -> a +composeN 0 f = id +composeN n f = (composeN (n-1) f) . f + + + + +-- Make this one an exercise! +composeList :: [ a -> a ] -> a -> a +composeList [] = id +composeList (f:fs) = composeList fs . f + + +-- same as bitr but now n is a Haskell level value +bitrH n i = snd (composeN n stage (i, i >> vn)) + where + stage (i,r) = (i>>1, (i .&. 1) .|. (r<<1)) + vn = value n + + +bitRevH :: Index -> Vector a -> Vector a +bitRevH n = premap (bitrH n) + +cx11 = icompile (bitRevH 8 :: VInt -> VInt) + + + +bitrLogH :: Index -> Data Index -> Data Index +bitrLogH n i = snd (composeList fns (allOnes, i)) + where + fns = [stage (1 << (value ix)) | ix <- P.reverse [0..n-1]] + stage s (mask, v) = (mask', mergeBy mask' (v>>s) (v< Vector a -> Vector a +bitRevLogH n = premap (bitrLogH n) + +cx12 = icompile (bitRevLogH 4 :: VInt -> VInt) + + + + + +comb :: (Syntactic a) => + (t -> t -> a) -> (t -> t -> a) + -> (Data Index -> Data Bool) -> (Data Index -> Data Index) + -> Vector t + -> Vector a +comb f g c p (Indexed l ixf Empty) = indexed l ixf' + where + ixf' i = condition (c i) (f a b) (g a b) + where + a = ixf i + b = ixf (p i) + +apart :: (Syntactic a) => + (t -> t -> a) -> (t -> t -> a) + -> Data Index + -> Vector t + -> Vector a +apart f g k = comb f g (bitZero k) (flipBit k) + + +ex13 k = eval (apart mmin mmax k (vector [7,6,5,4,3,2,1,0] :: VInt)) + +ex14 = [ ex13 (value i) | i <- [0..2] ] + + +batMerge :: (P.Ord a, Type a) => Data Index -> DVector a -> DVector a +batMerge n = pipe (apart mmin mmax) (countDown n) + +halfRev :: (Type a) => Data Index -> DVector a -> DVector a +halfRev n = premap (\i -> (condition (bitZero n' i) i (complN n' i))) + where + n' = n-1 + +-- works on 2^n length sub-arrays +-- works on 2^n length sub-arrays +halfRev1 :: (Type a) => Data Index -> DVector a -> DVector a +halfRev1 n = premap (\i -> i `xor` (onCond (bitOne n' i) (oneBitsN n'))) + where + n' = n-1 + +ex15 = [eval (halfRev1 (value k) (vector [0..15] :: VInt)) | k <- [1..4]] + + + +merge :: (P.Ord a, Type a) => Data Index -> DVector a -> DVector a +merge n = batMerge n . halfRev1 n + +sortV :: (P.Ord a, Type a) => Data Index -> DVector a -> DVector a +sortV n = pipe merge (countUp1 n) + +ex16 k = eval (sortV k (vector [0,1,2,3,12,5,6,7,1,14,13,12,11,19,9,8] :: VInt)) + + +cx13 = icompile (sortV :: Data Index -> VInt -> VInt) + + + +-- sorter on each 2^n length sub-array of inputs, n > 0 +-- inside the merger, one loop body is unwound to permit fusion with halfRev1 +sort1 :: (P.Ord a, Type a) => Data Index -> DVector a -> DVector a +sort1 n = pipe merge (countUp1 n) + where + merge n = batMerge (n-1) . apart mmin mmax (n-1) . halfRev1 n + +cx13' = icompile (sort1 :: Data Index -> VInt -> VInt) + + +fex = apart mmin mmax 0 . apart mmin mmax 1 . apart mmin mmax 2 + +cx14 = icompile (setSize 256 (fex :: VInt -> VInt)) + + +fexforce :: (P.Ord a, Type a) => DVector a -> DVector a +fexforce = apart mmin mmax 0 . force . + apart mmin mmax 1 . force . + apart mmin mmax 2 + +cx15 = icompile (setSize 256 (fexforce :: VInt -> VInt)) + + +fir1 :: Data Float -> Data Float -> DVector Float -> DVector Float +fir1 a0 a1 vec = map (\(x,y) -> a0*x + a1*y) $ zip vec (tail vec) + +lowPass :: Data Float -> DVector Float -> DVector Float +lowPass x = fir1 x (1-x) + +highPass :: Data Float -> DVector Float -> DVector Float +highPass x = fir1 x (x-1) + +bandPass1 :: Data Float -> DVector Float -> DVector Float +bandPass1 x = highPass x . lowPass x + +bandPass2 :: Data Float -> DVector Float -> DVector Float +bandPass2 x = highPass x . force . lowPass x + + +cx16 = icompile (setSize 256 (lowPass 0.5)) + +cx17 = icompile (setSize 256 (highPass 0.5)) + +cx18 = icompile (setSize 256 (bandPass1 0.5)) + +cx19 = icompile (setSize 256 (bandPass2 0.5)) + + + + + +riffle :: Data Index -> Vector a -> Vector a +riffle k = premap (rotBitFrom0 k) + +bitRev1 :: Type a => Data Index -> Vector (Data a) -> Vector (Data a) +bitRev1 n = pipe riffle (countUp1 n) + + + +ex17 = eval (riffle 3 (countUp 16)) + +cx20 = icompile (bitRev1 :: Data Index -> VInt -> VInt) + + + +combx f g c p x (Indexed l ixf Empty) = indexed l ixf' + where + ixf' i = condition (c i) (f ai pi xi) (g pi ai xi) + where + ai = ixf i + pi = ixf (p i) + xi = x i + + +pows2 :: Data Length -> DVector Index +pows2 k = indexed k (1<<) + +-- 2^l input FFT. Applies to sub-parts of input vector +-- of length 2^l. Produces each of the results in bit reversed order. +-- There is currently no check that the input vector is at least of length 2^l +fft :: Data Index -> DVector (Complex Float) -> DVector (Complex Float) +fft l = pipe stage (countDown l) + where + stage k = combx f g (bitZero k) (`xor` p) twid + where + p = 1< DVector (Complex Float) -> DVector (Complex Float) +ifft l = map (/ (complex (i2f (2^l)) 0)) . pipe stage (countDown l) + where + stage k = combx f g (bitZero k) (`xor` p) twid + where + p = 1< DVector (Complex Float) +testseq n = mergeSegments (seq ++ reverse seq) + where seq = (indexed (2 ^ (n - 1)) (\i -> complex (i2f i) 0 )) + +testseq1 :: Data DefaultWord -> DVector (Complex Float) +testseq1 n = indexed (2^n) (\i -> complex (i2f i) 0 ) + + +ex18 k = eval ((bitRev k . ifft k . bitRev k . fft k) (testseq k) :: DVector (Complex Float) ) + + + + + + + + diff --git a/Examples/Tutorial/Vector.hs b/Examples/Tutorial/Vector.hs new file mode 100644 --- /dev/null +++ b/Examples/Tutorial/Vector.hs @@ -0,0 +1,137 @@ +module Vector where + +import qualified Prelude +import Feldspar +import Feldspar.Vector +import Feldspar.Matrix + +-- Blake crypto + +type MessageBlock = DVector Word32 -- 0..15 +type Round = Data Index + +type State = Matrix Word32 -- 0..3 0..3 + +co :: DVector Word32 +co = vector [0x243F6A88,0x85A308D3,0x13198A2E,0x03707344, + 0xA4093822,0x299F31D0,0x082EFA98,0xEC4E6C89, + 0x452821E6,0x38D01377,0xBE5466CF,0x34E90C6C, + 0xC0AC29B7,0xC97C50DD,0x3F84D5B5,0xB5470917] + +sigma :: Matrix Index +sigma = matrix + [[0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15] + ,[14,10,4,8,9,15,13,6,1,12,0,2,11,7,5,3] + ,[11,8,12,0,5,2,15,13,10,14,3,6,7,1,9,4] + ,[7,9,3,1,13,12,11,14,2,6,5,10,4,0,15,8] + ,[9,0,5,7,2,4,10,15,14,1,11,12,6,8,3,13] + ,[2,12,6,10,0,11,8,3,4,13,7,5,15,14,1,9] + ,[12,5,1,15,14,13,4,10,0,7,6,3,9,2,8,11] + ,[13,11,7,14,12,1,3,9,5,0,15,4,8,6,2,10] + ,[6,15,14,9,11,3,0,8,12,2,13,7,1,4,10,5] + ,[10,2,8,4,7,6,1,5,15,11,9,14,3,12,13,0] + ] + +blakeRound :: MessageBlock -> State -> Round -> State +blakeRound m state r = + invDiagonals $ + zipWith (g m r) (4 ... 7) $ + diagonals $ + transpose $ + zipWith (g m r) (0 ... 3) $ + transpose $ + state + +g :: MessageBlock -> Round -> Data Index -> DVector Word32 -> DVector Word32 +g m r i v = fromList [a'',b'',c'',d''] + where [a,b,c,d] = toList 4 v + a' = a + b + (m!(sigma!r!(2*i)) ⊕ (co!(sigma!r!(2*i+1)))) + d' = (d ⊕ a') >> 16 + c' = c + d' + b' = (b ⊕ c') >> 12 + a'' = a' + b' + (m!(sigma!r!(2*i+1)) ⊕ (co!(sigma!r!(2*i)))) + d'' = (d' ⊕ a'') >> 8 + c'' = c' + d'' + b'' = (b' ⊕ c'') >> 7 + +diagonals :: Type a => Matrix a -> Matrix a +diagonals m = map (diag m) (0 ... (length (head m) - 1)) + +diag :: Type a => Matrix a -> Data Index -> Vector (Data a) +diag m i = zipWith lookup m (i ... (l + i)) + where l = length m - 1 + lookup v i = v ! (i `mod` length v) + +invDiagonals :: Type a => Matrix a -> Matrix a +invDiagonals m = zipWith shiftVectorR (0 ... (length m - 1)) (transpose m) + +shiftVectorR :: Syntactic a => Data Index -> Vector a -> Vector a +shiftVectorR i v = reverse $ drop i rev ++ take i rev + where rev = reverse v + +fromList :: Type a => [Data a] -> DVector a +fromList ls = unfreezeVector (loop 1 (parallel (value len) (const (Prelude.head ls)))) + where loop i arr + | i Prelude.< len + = loop (i+1) (setIx arr (value i) (ls !! (fromIntegral i))) + | otherwise = arr + len = fromIntegral (Prelude.length ls) + +toList :: Type a => Index -> Vector (Data a) -> [Data a] +toList n v@(Indexed l ix _) = Prelude.map (v!) $ Prelude.map value [0..n-1] + +-- DCT + +-- Discrete Cosine Transform type 2 +dct2 :: (DVector Float) -> (DVector Float) +dct2 xn = mat *** xn + where + mat = indexedMat (length xn) (length xn) (\k l -> dct2nkl (length xn) k l) + + +-- Helper function defining all the values in the DCT-2n matrix +dct2nkl :: Data Length -> Data DefaultWord -> Data DefaultWord -> Data Float +dct2nkl n k l = cos ( (k' *(2*l' +1)*pi)/(2*n') ) + where + n' = i2f n + k' = i2f k + l' = i2f l + +-- Discrete Cosine Transform type 3 +dct3 :: (DVector Float) -> (DVector Float) +dct3 xn = mat *** xn + where + mat = transpose $ indexedMat (length xn) (length xn) (\k l -> dct2nkl (length xn) k l) + +-- Discrete Cosine Transform type 4 +dct4 :: (DVector Float) -> (DVector Float) +dct4 xn = mat *** xn + where + mat = indexedMat (length xn) (length xn) (\k l -> dct4nkl (length xn) k l) + + +-- Helper function defining all the values in the DCT-4n matrix +dct4nkl :: Data Length -> Data DefaultWord -> Data DefaultWord -> Data Float +dct4nkl n k l = cos ( ((2*k' +1)*(2*l' +1)*pi)/(4*n') ) + where + n' = i2f n + k' = i2f k + l' = i2f l + +-- Low-pass filter + +fft = error "No FFT yet" +ifft = fft + +lowPassCore :: (Numeric a) => Data Index -> DVector a -> DVector a +lowPassCore k v = take k v ++ replicate (length v - k) 0 + +lowPass :: Data Index -> DVector Float -> DVector Float +lowPass k = frequencyTrans (lowPassCore k) + +frequencyTrans :: (DVector (Complex Float) -> DVector (Complex Float)) + -> DVector Float + -> DVector Float +frequencyTrans innerFunction v = map realPart $ ifft + $ innerFunction + $ fft $ map (\a -> complex a 0) v diff --git a/Feldspar.hs b/Feldspar.hs --- a/Feldspar.hs +++ b/Feldspar.hs @@ -1,49 +1,17 @@ --- --- Copyright (c) 2009-2010, ERICSSON AB All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * 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. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT HOLDER 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. --- - --- | Interface to the Feldspar language. +-- | Interface to the essential parts of the Feldspar language. High-level +-- libraries have to be imported separately. module Feldspar ( module Feldspar.Prelude , module Feldspar.Core - , module Feldspar.Vector - , module Feldspar.Matrix - , module Feldspar.FixedPoint ) where import qualified Prelude - -- In order to be able to play with the Feldspar module in GHCi without - -- getting name clashes. + -- In order to be able to use the Feldspar module in GHCi without getting name + -- clashes. import Feldspar.Prelude import Feldspar.Core -import Feldspar.Vector -import Feldspar.Matrix -import Feldspar.FixedPoint + diff --git a/Feldspar/Core.hs b/Feldspar/Core.hs --- a/Feldspar/Core.hs +++ b/Feldspar/Core.hs @@ -1,85 +1,82 @@ --- --- Copyright (c) 2009-2010, ERICSSON AB All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * 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. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT HOLDER 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. --- - --- | The user interface of the core language +-- | The Feldspar core language module Feldspar.Core - ( Range (..) - , (:>) (..) - , Set (..) - , Length - , Unsigned32 - , Signed32 - , Unsigned16 - , Signed16 - , Unsigned8 - , Signed8 - , Storable - , Size - , Data - , dataSize - , Computable - , Internal - , eval - , value - , array - , arrayLen - , unit - , true - , false - , size - , cap - , function - , function2 - , function3 - , function4 - , getIx - , setIx - , RandomAccess (..) - , noInline - , ifThenElse - , while - , parallel - , Program - , showCore - , showCoreWithSize - , printCore - , printCoreWithSize - , module Feldspar.Core.Functions - , trace - ) where + ( + -- * Reexported standard modules + Complex (..) + , module Data.Int + , module Data.Word + -- * DSL library + , Role + , Internal + , Info + -- * Feldspar types + , module Feldspar.Set + , Range (..) + , (:>) (..) + , DefaultWord (..) + , DefaultInt (..) + , Length + , Index + , Type + , Size + , fullProp + -- * Core constructs + , EdgeSize (..) + , Data + , Syntactic + , dataSize + , resizeData + , force + , eval + , viewLiteral + , drawExpr + , drawExpr2 + + , value + , unit + , true + , false + , array + , cap + , function + , function1 + , function2 + , condition + , (?) + , ifThenElse + , parallel'' + , parallel' + , parallel + , forLoop + , sequential + , noinline + , noinline2 + , setLength + + -- * Functions + , module Feldspar.Core.Functions + + -- * Wrapping + , module Feldspar.Core.Wrap + ) where + + + +import Prelude () +import Data.Complex +import Data.Int hiding (Int) +import Data.Word + +import Feldspar.DSL.Network +import Feldspar.Set import Feldspar.Range import Feldspar.Core.Types -import Feldspar.Core.Expr -import Feldspar.Core.Reify +import Feldspar.Core.Representation +import Feldspar.Core.Constructs import Feldspar.Core.Functions -import Feldspar.Core.Trace +import Feldspar.Core.Wrap diff --git a/Feldspar/Core/Constructs.hs b/Feldspar/Core/Constructs.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Core/Constructs.hs @@ -0,0 +1,245 @@ +module Feldspar.Core.Constructs where + + + +import Data.List +import Data.Typeable + +import Feldspar.DSL.Expression +import Feldspar.DSL.Lambda +import Feldspar.DSL.Network +import Feldspar.Set +import Feldspar.Range +import Feldspar.Core.Types +import Feldspar.Core.Representation + + + +value' :: Type a => Size a -> a -> Data a +value' sz a = nodeData (sz \/ sizeOf a) (Inject $ Node $ Literal a) + +-- | A program that computes a constant value +value :: Type a => a -> Data a +value = value' empty + +unit :: Data () +unit = value () + +true :: Data Bool +true = value True + +false :: Data Bool +false = value False + +-- | Like 'value' but with an extra 'Size' argument that can be used to increase +-- the size beyond the given data. +-- +-- Example 1: +-- +-- > array (10 :> 20 :> universal) [] :: Data [[DefaultInt]] +-- +-- gives an uninitialized 10x20 array of 'DefaultInt' elements. +-- +-- Example 2: +-- +-- > array (10 :> 20 :> universal) [[1,2,3]] :: Data [[DefaultInt]] +-- +-- gives a 10x20 array whose first row is initialized to @[1,2,3]@. +array :: Type a => Size a -> a -> Data a +array = value' + +cap :: Type a => Size a -> Data a -> Data a +cap sz a = resizeData (sz /\ dataSize a) a + +function :: (Syntactic a, Type b) + => Bool + -> String + -> (Info a -> Size b) + -> (Internal a -> b) + -> (a -> Data b) +function doConstProp fun sizeProp f a = case viewLiteral a of + Just a' | doConstProp -> value (f a') + _ -> func + where + sz = sizeProp (edgeInfo a) + func = nodeData sz $ Inject (Node (Function fun f)) :$: toEdge a + +function1 :: (Type a, Type b) + => String + -> (Size a -> Size b) + -> (a -> b) + -> (Data a -> Data b) +function1 fun sizeProp = function True fun (sizeProp . edgeSize) + +function2 :: (Type a, Type b, Type c) + => String + -> (Size a -> Size b -> Size c) + -> (a -> b -> c) + -> (Data a -> Data b -> Data c) +function2 fun sizeProp f = curry $ function True fun sizeProp' (uncurry f) + where + sizeProp' (i1,i2) = sizeProp (edgeSize i1) (edgeSize i2) + +condition :: Syntactic a + => Data Bool -- ^ Condition + -> a -- ^ \"Then\" branch + -> a -- ^ \"Else\" branch + -> a +condition cond t e + | toEdge t == toEdge e = t -- TODO This check might be expensive + | Just True <- viewLiteral cond = t + | Just False <- viewLiteral cond = e + | otherwise + = fromOutEdge info + $ Inject (Node Condition) + :$: toEdge cond + :$: toEdge t + :$: toEdge e + where + info = edgeInfo t \/ edgeInfo e + +(?) :: Syntactic a + => Data Bool -- ^ Condition + -> (a,a) -- ^ Alternatives + -> a +cond ? (t,e) = condition cond t e + +infix 1 ? + +-- | Identical to 'condition'. Provided for backwards-compatibility, but will be +-- removed in the future. +ifThenElse :: Syntactic a + => Data Bool -- ^ Condition + -> a -- ^ \"Then\" branch + -> a -- ^ \"Else\" branch + -> a +ifThenElse = condition +{-# DEPRECATED ifThenElse "Please use `condition` or `(?)` instead." #-} + +viewGetIx :: Typeable a => Data Index -> Data a -> Maybe (Data [a]) +viewGetIx (Data i) (Data a) = case undoEdge a of + Inject (Node (Function "(!)" _)) :$: (Inject Group2 :$: as :$: i') + | exprEq i i' -> Data `fmap` exprCast as + _ -> Nothing + +-- | Parallel array with continuation +parallel'' :: Type a => + Bool -> Data Length -> (Data Index -> Data a) -> Data [a] -> Data [a] +parallel'' optimize l ixf cont | l == value 0 = cont +parallel'' optimize l ixf cont = case viewGetIx ix body of + Just arr | optimize, cont == value [] -> setLength l arr + _ + -> nodeData szPar + $ Inject (Node Parallel) + :$: toEdge l + :$: lambda (EdgeSize szi) ixf + :$: toEdge cont + where + szl1 = dataSize l + szi = rangeByRange 0 (szl1-1) + ix = variable (EdgeSize szi) "TODO" + body = ixf ix + sza = dataSize body + szl2 :> sza' = dataSize cont + szPar = (szl1+szl2) :> (sza \/ sza') + -- TODO The optimize argument is a hack to work around a problem with having + -- literals (and other things) as continuations. This is only a problem + -- if the parallel is a continuation of another parallel or sequential. + -- If the parallel is the first segment, enabling optimization should be + -- fine. + +-- | Parallel array with continuation +parallel' :: Type a => + Data Length -> (Data Index -> Data a) -> Data [a] -> Data [a] +parallel' = parallel'' True + +-- | Parallel array +-- +-- Since there are no dependencies between the elements, the compiler is free to +-- compute the elements in any order, or even in parallel. +parallel :: Type a + => Data Length -- ^ Length of resulting array (outermost level) + -> (Data Index -> Data a) + -- ^ Function that maps each index in the range @[0 .. l-1]@ + -- to its element + -> Data [a] +parallel l ixf = parallel' l ixf (value []) + +-- | For loop +forLoop :: Syntactic st + => Data Length -- ^ Number of iterations + -> st -- ^ Initial state + -> (Data Index -> st -> st) + -- ^ Loop body (current index and state to next state) + -> st -- ^ Final state +forLoop l init body | l == value 0 = init +forLoop l init body | l == value 1 = body (value 0) init +forLoop l init body + = fromOutEdge szst + $ Inject (Node ForLoop) + :$: toEdge l + :$: toEdge init + :$: Lambda (\i -> lambda szst $ body $ nodeData szi i) + where + szi = rangeByRange 0 (dataSize l) + szinit = edgeInfo init + fn _ sz = edgeInfo $ body (variable (EdgeSize szi) "ix") + (variable sz "st") + (szst,_) = indexedFixedPoint (cutOffAt 3 fn) szinit + +sequential :: (Type a, Syntactic st) + => Data Length + -> st -- ^ Initial state + -> (Data Index -> st -> (Data a,st)) + -- ^ Current loop index and current state to current element + -- and next state + -> (st -> Data [a]) -- ^ Continuation + -> Data [a] +sequential l init step cont + = nodeData szSeq + $ Inject (Node Sequential) + :$: toEdge l + :$: toEdge init + :$: Lambda (\i -> lambda universal $ step $ nodeData szi i) + :$: lambda universal cont + where + szl1 = dataSize l + -- szl2 :> _ = dataSize cont + -- TODO cont needs an argument + szl2 = universal + szi = rangeByRange 0 (szl1-1) + szSeq = (szl1+szl2) :> universal -- TODO Improve + +-- | Prevent a function from being inlined +noinline :: (Syntactic a, Syntactic b) => String -> (a -> b) -> (a -> b) +noinline name body a + = fromOutEdge szb + $ Inject (Node (NoInline name)) + :$: lambda sza body + :$: toEdge a + where + sza = getInfo a + szb = getInfo $ body a + +noinline2 :: (Syntactic a, Syntactic b, Syntactic c) => + String -> (a -> b -> c) -> (a -> b -> c) +noinline2 name = curry . noinline name . uncurry + +setLength :: Type a => Data Length -> Data [a] -> Data [a] +setLength l arr = case (undoEdge (unData l), undoEdge (unData arr)) of + (Inject (Node (Function "length" _)) :$: a, _) + | Just b <- exprCast a, b == unData arr -> Data b + (Inject (Node (Literal n)), Inject (Node (Literal as))) -> + nodeData (szLen :> szArrElem) $ + Inject $ Node $ Literal $ genericTake n as + (_, Inject (Node Parallel) :$: _ :$: ixf :$: cont) + | cont == unData (value []) -> nodeData (szLen :> szArrElem) $ + Inject (Node Parallel) :$: unData l :$: ixf :$: cont + _ -> nodeData (szLen :> szArrElem) $ + Inject (Node SetLength) :$: toEdge l :$: toEdge arr + where + szl = dataSize l + szArrLen :> szArrElem = dataSize arr + szLen = rangeMin szl szArrLen + -- The only purpose of this function is to enable optimization of 'parallel'. + diff --git a/Feldspar/Core/Expr.hs b/Feldspar/Core/Expr.hs deleted file mode 100644 --- a/Feldspar/Core/Expr.hs +++ /dev/null @@ -1,641 +0,0 @@ --- --- Copyright (c) 2009-2010, ERICSSON AB All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * 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. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT HOLDER 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. --- - -{-# LANGUAGE UndecidableInstances #-} - --- | This module gives a representation core programs as typed expressions (see --- 'Expr' / 'Data'). - -module Feldspar.Core.Expr where - - - -import Data.Function -import Data.Monoid -import Data.Unique - -import Feldspar.Range -import Feldspar.Core.Types -import Feldspar.Core.Ref - - - --- | Typed core language expressions. A value of type @`Expr` a@ is a --- representation of a program that computes a value of type @a@. -data Expr a - where - Val :: a -> Expr a -- XXX Temporary, only used by evalF - Variable :: Expr a -- XXX Risky to rely on obs. sharing for bound variables. - Value :: Storable a => a -> Expr a - Function :: String -> (a -> b) -> Expr (a -> b) - Application :: Expr (a -> b) -> Data a -> Expr b - NoInline :: String -> Ref (a :-> b) -> (Data a -> Expr b) - - IfThenElse - :: Data Bool -- Condition - -> (a :-> b) -- If branch - -> (a :-> b) -- Else branch - -> (Data a -> Expr b) - - While - :: (a :-> Bool) -- Continue? - -> (a :-> a) -- Body - -> Data a -- Initial state - -> Expr a -- Final state - - Parallel - :: Storable a - => Data Length - -> (Int :-> a) -- Index mapping - -> Expr [a] -- Result vector - - - --- | A wrapper around 'Expr' to allow observable sharing (see --- "Feldspar.Core.Ref") and for memoizing size information. -data Data a = Typeable a => Data - { dataSize :: Size a - , dataRef :: Ref (Expr a) - } - -instance Eq (Data a) - where - (==) = (==) `on` dataRef - -instance Ord (Data a) - where - compare = compare `on` dataRef - -data a :-> b = Typeable a => -- Typeable needed by evalF - Lambda (Data a -> Data b) (Data a) (Data b) - - - -dataType :: forall a . Data a -> Tuple StorableType -dataType a@(Data _ _) = typeOf (dataSize a) (T::T a) - -dataId :: Data a -> Unique -dataId = refId . dataRef - -dataToExpr :: Data a -> Expr a -dataToExpr = deref . dataRef - -{-# NOINLINE exprToData #-} -exprToData :: Typeable a => Size a -> Expr a -> Data a -exprToData sz a = Data sz (ref a) - -{-# NOINLINE freshVar #-} -freshVar :: Typeable a => Size a -> Data a -freshVar sz = exprToData sz Variable - -{-# NOINLINE lambda #-} -lambda :: Typeable a => Size a -> (Data a -> Data b) -> (a :-> b) -lambda sz f = Lambda f var (f var) - where - var = freshVar sz - -- XXX It's assumed that `f` is only going to be applied to an argument whose - -- size is `sz`. - -apply :: (a :-> b) -> Data a -> Data b -apply (Lambda f _ _) = f - -resultSize :: (a :-> b) -> Size b -resultSize (Lambda _ _ outp) = dataSize outp - - - -(|$|) :: Expr (a -> b) -> Data a -> Expr b -f |$| a = Application f a - --- XXX Document these constructors. Currently, only _function is used for --- ordinary functions. _function2 etc. are only used to construct tuples. -_function - :: Typeable b - => String -> (Size a -> Size b) -> (a -> b) -> (Data a -> Data b) -_function fun sizeProp f a = exprToData sz $ Function fun f |$| a - where - sz = sizeProp (dataSize a) - -_function2 - :: Typeable c - => String - -> (Size a -> Size b -> Size c) - -> (a -> b -> c) - -> (Data a -> Data b -> Data c) -_function2 fun sizeProp f a b = exprToData sz $ Function fun f |$| a |$| b - where - sz = sizeProp (dataSize a) (dataSize b) - -_function3 - :: Typeable d - => String -> (Size a -> Size b -> Size c -> Size d) - -> (a -> b -> c -> d) - -> (Data a -> Data b -> Data c -> Data d) -_function3 fun sizeProp f a b c = - exprToData sz $ Function fun f |$| a |$| b |$| c - where - sz = sizeProp (dataSize a) (dataSize b) (dataSize c) - -_function4 - :: Typeable e - => String - -> (Size a -> Size b -> Size c -> Size d -> Size e) - -> (a -> b -> c -> d -> e) - -> (Data a -> Data b -> Data c -> Data d -> Data e) -_function4 fun sizeProp f a b c d = - exprToData sz $ Function fun f |$| a |$| b |$| c |$| d - where - sz = sizeProp (dataSize a) (dataSize b) (dataSize c) (dataSize d) - - - -tup2 :: (Typeable a, Typeable b) => Data a -> Data b -> Data (a,b) -tup2 = _function2 "tup2" (,) (,) - -tup3 :: (Typeable a, Typeable b, Typeable c) => - Data a -> Data b -> Data c -> Data (a,b,c) -tup3 = _function3 "tup3" (,,) (,,) - -tup4 :: (Typeable a, Typeable b, Typeable c, Typeable d) => - Data a -> Data b -> Data c -> Data d -> Data (a,b,c,d) -tup4 = _function4 "tup4" (,,,) (,,,) - -get21 :: Typeable a => Data (a,b) -> Data a -get21 = _function "getTup21" get get - where - get (a,b) = a - -get22 :: Typeable b => Data (a,b) -> Data b -get22 = _function "getTup22" get get - where - get (a,b) = b - -get31 :: Typeable a => Data (a,b,c) -> Data a -get31 = _function "getTup31" get get - where - get (a,b,c) = a - -get32 :: Typeable b => Data (a,b,c) -> Data b -get32 = _function "getTup32" get get - where - get (a,b,c) = b - -get33 :: Typeable c => Data (a,b,c) -> Data c -get33 = _function "getTup33" get get - where - get (a,b,c) = c - -get41 :: Typeable a => Data (a,b,c,d) -> Data a -get41 = _function "getTup41" get get - where - get (a,b,c,d) = a - -get42 :: Typeable b => Data (a,b,c,d) -> Data b -get42 = _function "getTup42" get get - where - get (a,b,c,d) = b - -get43 :: Typeable c => Data (a,b,c,d) -> Data c -get43 = _function "getTup43" get get - where - get (a,b,c,d) = c - -get44 :: Typeable d => Data (a,b,c,d) -> Data d -get44 = _function "getTup44" get get - where - get (a,b,c,d) = d - - - --- | Computable types. A computable value completely represents a core program, --- in such a way that @`internalize` `.` `externalize`@ preserves semantics, but --- not necessarily syntax. --- --- The terminology used in this class comes from thinking of the 'Data' type as --- the \"internal\" core language and the "Feldspar.Core" API as the --- \"external\" core language. -class Typeable (Internal a) => Computable a - where - -- | @`Data` (`Internal` a)@ is the internal representation of the type @a@. - type Internal a - - -- | Convert to internal representation - internalize :: a -> Data (Internal a) - - -- | Convert to external representation - externalize :: Data (Internal a) -> a - -instance Storable a => Computable (Data a) - where - type Internal (Data a) = a - - internalize = id - externalize = id - -instance (Computable a, Computable b) => Computable (a,b) - where - type Internal (a,b) = (Internal a, Internal b) - - internalize (a,b) = tup2 (internalize a) (internalize b) - - externalize ab = - ( externalize (get21 ab) - , externalize (get22 ab) - ) - -instance (Computable a, Computable b, Computable c) => Computable (a,b,c) - where - type Internal (a,b,c) = (Internal a, Internal b, Internal c) - - internalize (a,b,c) = tup3 - (internalize a) - (internalize b) - (internalize c) - - externalize abc = - ( externalize (get31 abc) - , externalize (get32 abc) - , externalize (get33 abc) - ) - -instance - ( Computable a - , Computable b - , Computable c - , Computable d - ) => - Computable (a,b,c,d) - where - type Internal (a,b,c,d) = (Internal a, Internal b, Internal c, Internal d) - - internalize (a,b,c,d) = tup4 - (internalize a) - (internalize b) - (internalize c) - (internalize d) - - externalize abcd = - ( externalize (get41 abcd) - , externalize (get42 abcd) - , externalize (get43 abcd) - , externalize (get44 abcd) - ) - - - --- | Lower a function to operate on internal representation. -lowerFun :: (Computable a, Computable b) => - (a -> b) -> (Data (Internal a) -> Data (Internal b)) -lowerFun f = internalize . f . externalize - --- | Lift a function to operate on external representation. -liftFun :: (Computable a, Computable b) => - (Data (Internal a) -> Data (Internal b)) -> (a -> b) -liftFun f = externalize . f . internalize - - - --- | The semantics of expressions -evalE :: Expr a -> a - -evalE (Val a) = a -evalE Variable = error "evaluating free variable" -evalE (Value a) = a -evalE (Function _ f) = f -evalE (Application f a) = evalE f (evalD a) -evalE (NoInline _ f a) = evalD (apply (deref f) a) - -evalE (IfThenElse c t e a) - | evalD c = evalD (apply t a) - | otherwise = evalD (apply e a) - -evalE (While cont body init) = - head $ dropWhile (evalF cont) $ iterate (evalF body) $ evalD init - -evalE (Parallel l ixf) = map (evalF ixf) [0 .. evalD l-1] - - - --- | The semantics of 'Data' -evalD :: Data a -> a -evalD = evalE . dataToExpr - -evalF :: (a :-> b) -> (a -> b) -evalF (Lambda f i o) = evalD . f . exprToData (dataSize i) . Val - --- | The semantics of any 'Computable' type -eval :: Computable a => a -> Internal a -eval = evalD . internalize - - - --- | A program that computes a constant value -value :: Storable a => a -> Data a -value a = exprToData (storableSize a) (Value a) - --- | Like 'value' but with an extra 'Size' argument that can be used to increase --- the size beyond the given data. --- --- Example 1: --- --- > array (10 :> 20 :> universal) [] :: Data [[Int]] --- --- gives an uninitialized 10x20 array of 'Int' elements. --- --- Example 2: --- --- > array (10 :> 20 :> universal) [[1,2,3]] :: Data [[Int]] --- --- gives a 10x20 array whose first row is initialized to @[1,2,3]@. -array :: Storable a => Size a -> a -> Data a -array sz a = exprToData (sz `mappend` storableSize a) (Value a) - -arrayLen :: Storable a => Data Length -> [a] -> Data [a] -arrayLen len = array sz - where - sz = mapMonotonic fromInteger (dataSize len) :> universal - -- XXX This function is a temporary solution. - -unit :: Data () -unit = value () - -true :: Data Bool -true = value True - -false :: Data Bool -false = value False - --- | Returns the size of each level of a multi-dimensional array, starting with --- the outermost level. -size :: forall a . Storable a => Data [a] -> [Range Length] -size = listSize (T::T [a]) . dataSize - -cap :: (Storable a, Size a ~ Range b, Ord b) => Range b -> Data a -> Data a -cap szb (Data sz a) = Data (sz /\ szb) a - -- XXX Should really have the type - -- cap :: Storable a => Size a -> Data a -> Data a - - - --- | Constructs a one-argument primitive function. --- --- @`function` fun szf f@: --- --- * @fun@ is the name of the function. --- --- * @szf@ computes the output size from the input size. --- --- * @f@ gives the evaluation semantics. -function - :: (Storable a, Storable b) - => String -> (Size a -> Size b) -> (a -> b) -> (Data a -> Data b) - -function fun sizeProp f a = case dataToExpr a of - Value a' -> exprToData sz $ Value (f a') - _ -> _function fun sizeProp f a - where - sz = sizeProp (dataSize a) - - - --- | A two-argument primitive function -function2 - :: ( Storable a - , Storable b - , Storable c - ) - => String - -> (Size a -> Size b -> Size c) - -> (a -> b -> c) - -> (Data a -> Data b -> Data c) - -function2 fun sizeProp f a b = case (dataToExpr a, dataToExpr b) of - (Value a', Value b') -> exprToData sz $ Value (f a' b') - _ -> _function fun (uncurry sizeProp) (uncurry f) (tup2 a b) - -- XXX Should perhaps look like this instead: - -- _ -> _function2 fun sizeProp f a b - where - sz = sizeProp (dataSize a) (dataSize b) - - - --- | A three-argument primitive function -function3 - :: ( Storable a - , Storable b - , Storable c - , Storable d - ) - => String - -> (Size a -> Size b -> Size c -> Size d) - -> (a -> b -> c -> d) - -> (Data a -> Data b -> Data c -> Data d) - -function3 fun sizeProp f a b c = case (d2e a, d2e b, d2e c) of - (Value a', Value b', Value c') -> exprToData sz $ Value (f a' b' c') - _ -> _function fun (uncurr sizeProp) (uncurr f) (tup3 a b c) - where - d2e = dataToExpr - sz = sizeProp (dataSize a) (dataSize b) (dataSize c) - uncurr g (a,b,c) = g a b c - - - --- | A four-argument primitive function -function4 - :: ( Storable a - , Storable b - , Storable c - , Storable d - , Storable e - ) - => String - -> (Size a -> Size b -> Size c -> Size d -> Size e) - -> (a -> b -> c -> d -> e) - -> (Data a -> Data b -> Data c -> Data d -> Data e) - -function4 fun sizeProp f a b c d = case (d2e a, d2e b, d2e c, d2e d) of - (Value a', Value b', Value c', Value d') -> exprToData sz $ Value (f a' b' c' d') - _ -> _function fun (uncurr sizeProp) (uncurr f) (tup4 a b c d) - where - d2e = dataToExpr - sz = sizeProp (dataSize a) (dataSize b) (dataSize c) (dataSize d) - uncurr g (a,b,c,d) = g a b c d - - --- | Look up an index in an array (see also '!') -getIx :: Storable a => Data [a] -> Data Int -> Data a -getIx arr = function2 "(!)" sizeProp f arr - where - sizeProp (_:>aSize) _ = aSize - - f as i - | not (i `inRange` r) = error "getIx: index out of bounds" - | i >= la = error "getIx: reading garbage" - | otherwise = as !! i - where - l:>_ = dataSize arr - r = rangeByRange 0 (l-1) - la = length as - - - --- | @`setIx` arr i a@: --- --- Replaces the value at index @i@ in the array @arr@ with the value @a@. -setIx :: Storable a => Data [a] -> Data Int -> Data a -> Data [a] -setIx arr = function3 "setIx" sizeProp f arr - where - sizeProp (l:>aSize) _ aSize' = l :> (aSize `mappend` aSize') - - f as i a - | not (i `inRange` r) = error "setIx: index out of bounds" - | i > la = error "setIx: writing past initialized area" - | otherwise = take i as ++ [a] ++ drop (i+1) as - where - l:>_ = dataSize arr - r = rangeByRange 0 (l-1) - la = length as - - - -infixl 9 ! - -class RandomAccess a - where - -- | The type of elements in a random access structure - type Element a - - -- | Index lookup in a random access structure - (!) :: a -> Data Int -> Element a - -instance Storable a => RandomAccess (Data [a]) - where - type Element (Data [a]) = Data a - (!) = getIx - - - --- | Constructs a non-primitive, non-inlined function. --- --- The normal way to make a non-primitive function is to use an ordinary Haskell --- function, for example: --- --- > myFunc x = x * 4 + 5 --- --- However, such functions are inevitably inlined into the program expression --- when applied. @noInline@ can be thought of as a way to protect a function --- against inlining (but later transformations may choose to inline anyway). --- --- Ideally, it should be posssible to reuse such a function several times, but --- at the moment this does not work. Every application of a @noInline@ function --- results in a new copy of the function in the core program. -noInline :: (Computable a, Computable b) => String -> (a -> b) -> (a -> b) -noInline fun f a = liftFun (exprToData sz . NoInline fun (ref fLam)) a - where - fLam = lambda (dataSize $ internalize a) (lowerFun f) - sz = resultSize fLam - - - --- | @`ifThenElse` cond thenFunc elseFunc@: --- --- Selects between the two functions @thenFunc@ and @elseFunc@ depending on --- whether the condition @cond@ is true or false. -ifThenElse - :: (Computable a, Computable b) - => Data Bool -> (a -> b) -> (a -> b) -> (a -> b) - -ifThenElse cond t e a = case dataToExpr cond of - Value True -> t a - Value False -> e a - _ -> liftFun (exprToData szb . IfThenElse cond thenLam elseLam) a - where - sza = dataSize $ internalize a - thenLam = lambda sza (lowerFun t) - elseLam = lambda sza (lowerFun e) - szb = resultSize thenLam `mappend` resultSize elseLam - - - -whileSized - :: Computable state - => Size (Internal state) - -> Size (Internal state) - -> (state -> Data Bool) - -> (state -> state) - -> (state -> state) - -whileSized szInitCont szInitBody cont body = - liftFun (exprToData szFinal . While contLam bodyLam) - where - contLam = lambda szInitCont (lowerFun cont) - bodyLam = lambda szInitBody (lowerFun body) - szFinal = universal -- XXX The best we can do at the moment... - - - --- | While-loop --- --- @while cont body :: state -> state@: --- --- * @state@ is the type of the state. --- --- * @cont@ determines whether or not to continue based on the current state. --- --- * @body@ computes the next state from the current state. --- --- * The result is a function from initial state to final state. -while - :: Computable state - => (state -> Data Bool) - -> (state -> state) - -> (state -> state) - -while = whileSized universal universal - - - --- | Parallel array --- --- @parallel l ixf@: --- --- * @l@ is the length of the resulting array (outermost level). --- --- * @ifx@ is a function that maps each index in the range @[0 .. l-1]@ to its --- element. --- --- Since there are no dependencies between the elements, the compiler is free to --- compute the elements in any order, or even in parallel. -parallel :: Storable a => Data Length -> (Data Int -> Data a) -> Data [a] -parallel l ixf = exprToData szPar $ Parallel l ixfLam - where - szl = dataSize l - ixfLam = lambda (rangeByRange 0 (szl-1)) ixf - szPar = mapMonotonic fromIntegral szl :> resultSize ixfLam - diff --git a/Feldspar/Core/Functions.hs b/Feldspar/Core/Functions.hs --- a/Feldspar/Core/Functions.hs +++ b/Feldspar/Core/Functions.hs @@ -1,737 +1,40 @@ --- --- Copyright (c) 2009-2010, ERICSSON AB All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * 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. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT HOLDER 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. --- - -{-# LANGUAGE UndecidableInstances #-} - --- | Primitive and helper functions supported by Feldspar - -module Feldspar.Core.Functions where - - - -import qualified Prelude - -import Feldspar.Range -import Feldspar.Core.Types -import Feldspar.Core.Expr -import Feldspar.Core.Reify -import Feldspar.Prelude - -import qualified Data.Bits as B - -infix 4 == -infix 4 /= -infix 4 < -infix 4 > -infix 4 <= -infix 4 >= -infixr 3 && -infixr 3 &&* -infixr 2 || -infixr 2 ||* -infix 1 ? - - - --- * Misc. - -noSizeProp :: a -> () -noSizeProp _ = () - -noSizeProp2 :: a -> b -> () -noSizeProp2 _ _ = () - -class (Prelude.Eq a, Storable a) => Eq a where - (==) :: Data a -> Data a -> Data Bool - a == b - | a Prelude.== b = true - | otherwise = function2 "(==)" noSizeProp2 (Prelude.==) a b - (/=) :: Data a -> Data a -> Data Bool - a /= b - | a Prelude.== b = false - | otherwise = function2 "(/=)" noSizeProp2 (Prelude./=) a b - -optEq :: (Storable a, Size a ~ Range b, Prelude.Ord b, Num b) => - Data a -> Data a -> Data Bool -optEq a b - | a Prelude.== b = true - | sa `disjoint` sb = false - | otherwise = function2 "(==)" noSizeProp2 (Prelude.==) a b - where - sa = dataSize a - sb = dataSize b - -optNeq :: (Storable a, Size a ~ Range b, Prelude.Ord b, Num b) => - Data a -> Data a -> Data Bool -optNeq a b - | a Prelude.== b = false - | sa `disjoint` sb = true - | otherwise = function2 "(/=)" noSizeProp2 (Prelude./=) a b - where - sa = dataSize a - sb = dataSize b - -instance Eq Int where - a == b = optEq a b - a /= b = optNeq a b - -instance Eq Signed32 where - a == b = optEq a b - a /= b = optNeq a b - -instance Eq Unsigned32 where - a == b = optEq a b - a /= b = optNeq a b - -instance Eq Signed16 where - a == b = optEq a b - a /= b = optNeq a b - -instance Eq Unsigned16 where - a == b = optEq a b - a /= b = optNeq a b - -instance Eq Signed8 where - a == b = optEq a b - a /= b = optNeq a b - -instance Eq Unsigned8 where - a == b = optEq a b - a /= b = optNeq a b - -instance Eq Float where - a == b = optEq a b - a /= b = optNeq a b - -instance Eq Bool - -instance Eq () - -class (Prelude.Ord a, Eq a, Storable a) => Ord a where - (<) :: Data a -> Data a -> Data Bool - a < b - | a Prelude.== b = false - | otherwise = function2 "(<)" noSizeProp2 (Prelude.<) a b - (>) :: Data a -> Data a -> Data Bool - a > b - | a Prelude.== b = false - | otherwise = function2 "(>)" noSizeProp2 (Prelude.>) a b - (<=) :: Data a -> Data a -> Data Bool - a <= b - | a Prelude.== b = true - | otherwise = function2 "(<=)" noSizeProp2 (Prelude.<=) a b - (>=) :: Data a -> Data a -> Data Bool - a >= b - | a Prelude.== b = true - | otherwise = function2 "(>=)" noSizeProp2 (Prelude.>=) a b - min :: Data a -> Data a -> Data a - min a b = a Data a -> Data a - max a b = a>b ? (a,b) - -optLT :: (Storable a, Prelude.Ord a, Size a ~ Range b, Prelude.Ord b, Num b) => - Data a -> Data a -> Data Bool -optLT a b - | a Prelude.== b = false - | sa `rangeLess` sb = true - | sb `rangeLessEq` sa = false - | otherwise = function2 "(<)" noSizeProp2 (Prelude.<) a b - where - sa = dataSize a - sb = dataSize b - -optGT :: (Storable a, Prelude.Ord a, Size a ~ Range b, Prelude.Ord b, Num b) => - Data a -> Data a -> Data Bool -optGT a b - | a Prelude.== b = false - | sb `rangeLess` sa = true - | sa `rangeLessEq` sb = false - | otherwise = function2 "(>)" noSizeProp2 (Prelude.>) a b - where - sa = dataSize a - sb = dataSize b - -optLTE :: (Storable a, Prelude.Ord a, Size a ~ Range b, Prelude.Ord b, Num b) => - Data a -> Data a -> Data Bool -optLTE a b - | a Prelude.== b = true - | sa `rangeLessEq` sb = true - | sb `rangeLess` sa = false - | otherwise = function2 "(<=)" noSizeProp2 (Prelude.<=) a b - where - sa = dataSize a - sb = dataSize b - -optGTE :: (Storable a, Prelude.Ord a, Size a ~ Range b, Prelude.Ord b, Num b) => - Data a -> Data a -> Data Bool -optGTE a b - | a Prelude.== b = true - | sb `rangeLessEq` sa = true - | sa `rangeLess` sb = false - | otherwise = function2 "(>=)" noSizeProp2 (Prelude.>=) a b - where - sa = dataSize a - sb = dataSize b - -optMin :: (Ord a, Size a ~ Range b, Prelude.Ord b, Num b) => - Data a -> Data a -> Data a -optMin a b = cap (rangeMin ra rb) $ - case dataToExpr cond1 of - Value _ -> cond1 ? (a,b) - _ -> cond2 ? (b,a) - where - cond1 = a - Data a -> Data a -> Data a -optMax a b = cap (rangeMax ra rb) $ - case dataToExpr cond1 of - Value _ -> cond1 ? (a,b) - _ -> cond2 ? (b,a) - where - cond1 = a>b - cond2 = b>a - ra = dataSize a - rb = dataSize b - -instance Ord Int where - a < b = optLT a b - a > b = optGT a b - a <= b = optLTE a b - a >= b = optGTE a b - min a b = optMin a b - max a b = optMax a b - -instance Ord Unsigned32 where - a < b = optLT a b - a > b = optGT a b - a <= b = optLTE a b - a >= b = optGTE a b - min a b = optMin a b - max a b = optMax a b - -instance Ord Signed32 where - a < b = optLT a b - a > b = optGT a b - a <= b = optLTE a b - a >= b = optGTE a b - min a b = optMin a b - max a b = optMax a b - -instance Ord Unsigned16 where - a < b = optLT a b - a > b = optGT a b - a <= b = optLTE a b - a >= b = optGTE a b - min a b = optMin a b - max a b = optMax a b - -instance Ord Signed16 where - a < b = optLT a b - a > b = optGT a b - a <= b = optLTE a b - a >= b = optGTE a b - min a b = optMin a b - max a b = optMax a b - -instance Ord Unsigned8 where - a < b = optLT a b - a > b = optGT a b - a <= b = optLTE a b - a >= b = optGTE a b - min a b = optMin a b - max a b = optMax a b - -instance Ord Signed8 where - a < b = optLT a b - a > b = optGT a b - a <= b = optLTE a b - a >= b = optGTE a b - min a b = optMin a b - max a b = optMax a b - -instance Ord Float where - a < b = optLT a b - a > b = optGT a b - a <= b = optLTE a b - a >= b = optGTE a b - min a b = optMin a b - max a b = optMax a b - -not :: Data Bool -> Data Bool -not = function "not" noSizeProp Prelude.not - --- | Selects the elements of the pair depending on the condition -(?) :: Computable a => Data Bool -> (a,a) -> a -cond ? (a,b) = ifThenElse cond (const a) (const b) unit - -(&&) :: Data Bool -> Data Bool -> Data Bool -x && y = case (dataToExpr x, dataToExpr y) of - (Value True, _) -> y - (Value False,_) -> false - (_, Value True) -> x - (_,Value False) -> false - _ -> function2 "(&&)" noSizeProp2 (Prelude.&&) x y - -(||) :: Data Bool -> Data Bool -> Data Bool -x || y = case (dataToExpr x, dataToExpr y) of - (Value True, _) -> true - (Value False,_) -> y - (_, Value True) -> true - (_,Value False) -> y - _ -> function2 "(||)" noSizeProp2 (Prelude.||) x y - --- | Lazy conjunction, second argument only run if necessary -(&&*) :: Computable a => - (a -> Data Bool) -> (a -> Data Bool) -> (a -> Data Bool) -(f &&* g) a = ifThenElse (f a) g (const false) a - --- | Lazy disjunction, second argument only run if necessary -(||*) :: Computable a => - (a -> Data Bool) -> (a -> Data Bool) -> (a -> Data Bool) -(f ||* g) a = ifThenElse (f a) (const true) g a - -class (Numeric a, Prelude.Integral a, Ord a, Storable a) => - Integral a where - quot :: Data a -> Data a -> Data a - quot = function2 "quot" (\_ _ -> universal) Prelude.quot - rem :: Data a -> Data a -> Data a - rem = function2 "rem" (\_ _ -> universal) Prelude.rem - div :: Data a -> Data a -> Data a - div x y = rem x y /= 0 && (x > 0 && y < 0 || x < 0 && y > 0) ? - (quotxy - 1, quotxy) - where quotxy = quot x y - mod :: Data a -> Data a -> Data a - mod x y = remxy /= 0 && (x > 0 && y < 0 || x < 0 && y > 0) ? - (remxy + y, remxy) - where remxy = rem x y - (^) :: Data a -> Data a -> Data a - (^) = function2 "(^)" (\_ _ -> universal) (Prelude.^) - -optRem :: (Integral a, Size a ~ Range b, Prelude.Ord b, Num b, Enum b) => - Data a -> Data a -> Data a -optRem x y - | abs rx `rangeLess` abs ry = x - | otherwise = function2 "rem" rangeRem Prelude.rem x y - where rx = dataSize x - ry = dataSize y - -optMod :: (Integral a, Size a ~ Range b, Prelude.Ord b, Num b, Enum b) => - Data a -> Data a -> Data a -optMod x y = cap (rangeMod rx ry) $ - remxy /= 0 && (x > 0 && y < 0 || x < 0 && y > 0) ? - (remxy + y, remxy) - where remxy = rem x y - rx = dataSize x - ry = dataSize y - -optSignedExp :: (Integral a, Bits a, Storable a, - Size a ~ Range b, Prelude.Ord b, Num b) => - Data a -> Data a -> Data a -optSignedExp m e = case dataToExpr m of - -- From Bit Twiddling Hacks - -- "Conditionally negate a value without branching" - -- Here we negate the value 1 if isOdd is true i.e. when e is - -- and odd number - Value (-1) -> cap (range (-1) 1) $ - let isOdd = e .&. 1 - in (1 `xor` (negate isOdd)) + isOdd - _ -> optExp m e - -optExp :: (Integral a, Storable a) => Data a -> Data a -> Data a -optExp m e = case (dataToExpr m,dataToExpr e) of - (Value 1,_) -> value 1 - (_,Value 1) -> m - (_,Value 0) -> value 1 - _ -> function2 "(^)" (\_ _ -> universal) (Prelude.^) m e - -instance Integral Int where - rem = optRem - mod = optMod - (^) = optSignedExp - -instance Integral Signed32 where - rem = optRem - mod = optMod - (^) = optSignedExp - -instance Integral Unsigned32 where - div = quot - rem = optRem - mod = rem - (^) = optExp - -instance Integral Signed16 where - rem = optRem - mod = optMod - (^) = optSignedExp - -instance Integral Unsigned16 where - div = quot - rem = optRem - mod = rem - (^) = optExp - -instance Integral Signed8 where - rem = optRem - mod = optMod - (^) = optSignedExp - -instance Integral Unsigned8 where - div = quot - rem = optRem - mod = rem - (^) = optExp - - - --- * Loops - --- | For-loop --- --- @`for` start end init body@: --- --- * @start@\/@end@ are the start\/end indexes. --- --- * @init@ is the starting state. --- --- * @body@ computes the next state given the current loop index (ranging over --- @[start .. end]@) and the current state. -for :: Computable a => Data Int -> Data Int -> a -> (Data Int -> a -> a) -> a -for start end init body = snd $ whileSized szCont szBody cont body' (start,init) - where - sziCont = rangeByRange (dataSize start) (dataSize end + 1) - szCont = (sziCont,universal) - - sziBody = rangeByRange (dataSize start) (dataSize end) - szBody = (sziBody,universal) - - cont (i,s) = i <= end - body' (i,s) = (i+1, body i s) +module Feldspar.Core.Functions + ( module Feldspar.Core.Functions.Logic + , Eq (..) + , Ord (..) + , Numeric + , Bits (..) + , (⊕) + , (<<) + , (>>) + , Integral (..) + , Fractional' + , module Feldspar.Core.Functions.Complex + , module Feldspar.Core.Functions.Tuple + , arrayLen + , getIx + , setIx + , getLength + , RandomAccess (..) + , module Feldspar.Core.Functions.Conversion + , module Feldspar.Core.Functions.Trace + ) where --- | A sequential \"unfolding\" of an vector --- --- @`unfoldCore` l init step@: --- --- * @l@ is the length of the resulting vector. --- --- * @init@ is the initial state. --- --- * @step@ is a function computing a new element and the next state from the --- current index and current state. The index is the position of the new --- element in the output vector. -unfoldCore - :: (Computable state, Storable a) - => Data Length - -> state - -> (Data Int -> state -> (Data a, state)) - -> (Data [a], state) - -unfoldCore l init step = for 0 (l-1) (outp,init) $ \i (o,state) -> - let (a,state') = step i state - in (setIx o i a, state') - where - outp = array (mapMonotonic fromIntegral (dataSize l) :> universal) [] - -class (Num a, Storable a) => Numeric a - where - fromIntegerNum :: Integer -> Data a - fromIntegerNum = value . fromInteger - - absNum :: Data a -> Data a - signumNum :: Data a -> Data a - addNum :: Data a -> Data a -> Data a - subNum :: Data a -> Data a -> Data a - mulNum :: Data a -> Data a -> Data a - -absNum' :: (Numeric a, Num (Size a)) => Data a -> Data a -absNum' = function "abs" abs abs - -optAbs :: (Numeric a, Size a ~ Range b, Num b, Prelude.Ord b) => - Data a -> Data a -optAbs x | isNatural rx = x - | otherwise = absNum' x - where rx = dataSize x - -signumNum' :: (Numeric a, Num (Size a)) => Data a -> Data a -signumNum' = function "signum" signum signum - -optSignum :: (Numeric a, Size a ~ Range b, Num b, Prelude.Ord b) => Data a -> Data a -optSignum x | 0 `rangeLess` rx = 1 - | rx `rangeLess` 0 = -1 - | rx Prelude.== 0 = 0 - | otherwise = signumNum' x - where rx = dataSize x - -optAdd :: (Numeric a, Num (Size a)) => Data a -> Data a -> Data a -optAdd x y = case (dataToExpr x, dataToExpr y) of - (Value 0, _) -> y - (_, Value 0) -> x - _ -> function2 "(+)" (+) (+) x y - -optSub :: (Numeric a, Num (Size a)) => Data a -> Data a -> Data a -optSub x y = case dataToExpr y of - Value 0 -> x - _ -> function2 "(-)" (-) (-) x y - -optMul :: (Numeric a, Num (Size a)) => Data a -> Data a -> Data a -optMul x y = case (dataToExpr x, dataToExpr y) of - (Value 0,_) -> value 0 - (_,Value 0) -> value 0 - (Value 1,_) -> y - (_,Value 1) -> x - _ -> function2 "(*)" (*) (*) x y - -instance Numeric Int - where - absNum = optAbs - signumNum = optSignum - addNum = optAdd - subNum = optSub - mulNum = optMul - -instance Numeric Unsigned32 - where - absNum = optAbs - signumNum = optSignum - addNum = optAdd - subNum = optSub - mulNum = optMul - -instance Numeric Signed32 - where - absNum = optAbs - signumNum = optSignum - addNum = optAdd - subNum = optSub - mulNum = optMul - -instance Numeric Unsigned16 - where - absNum = optAbs - signumNum = optSignum - addNum = optAdd - subNum = optSub - mulNum = optMul - -instance Numeric Signed16 - where - absNum = optAbs - signumNum = optSignum - addNum = optAdd - subNum = optSub - mulNum = optMul - -instance Numeric Unsigned8 - where - absNum = optAbs - signumNum = optSignum - addNum = optAdd - subNum = optSub - mulNum = optMul - -instance Numeric Signed8 - where - absNum = optAbs - signumNum = optSignum - addNum = optAdd - subNum = optSub - mulNum = optMul - -instance Numeric Float - where - absNum = optAbs - signumNum = optSignum - addNum = optAdd - subNum = optSub - mulNum = optMul - -instance Numeric a => Num (Data a) - where - fromInteger = fromIntegerNum - abs = absNum - signum = signumNum - (+) = addNum - (-) = subNum - (*) = mulNum - -class (Fractional a, Storable a) => Fractional' a - where - fromRationalFrac :: Rational -> Data a - fromRationalFrac = value . fromRational - - divFrac :: Data a -> Data a -> Data a - -instance Fractional' Float - where - divFrac = function2 "(/)" (\_ _ -> fullRange) (/) -- XXX Improve range - -instance (Fractional' a, Numeric a) => Fractional (Data a) - where - fromRational = fromRationalFrac - (/) = divFrac - --- * Bit manipulation - -infixl 5 <<,>> -infixl 4 ⊕ - --- | The following class provides functions for bit level manipulation -class (B.Bits a, Storable a) => Bits a - where - -- Logical operations - (.&.) :: Data a -> Data a -> Data a - (.&.) = optAnd - (.|.) :: Data a -> Data a -> Data a - (.|.) = optOr - xor :: Data a -> Data a -> Data a - xor = optXor - (⊕) :: Data a -> Data a -> Data a - (⊕) = xor - complement :: Data a -> Data a - complement = function "complement" (const universal) B.complement - - -- Operations on individual bits - bit :: Data Int -> Data a - bit = function "bit" (const universal) B.bit - setBit :: Data a -> Data Int -> Data a - setBit = function2 "setBit" (\_ _ -> universal) B.setBit - clearBit :: Data a -> Data Int -> Data a - clearBit = function2 "clearBit" (\_ _ -> universal) B.clearBit - complementBit :: Data a -> Data Int -> Data a - complementBit = function2 "complementBit" (\_ _ -> universal) B.complementBit - testBit :: Data a -> Data Int -> Data Bool - testBit = function2 "testBit" noSizeProp2 B.testBit - - -- Moving bits around - shiftL :: Data a -> Data Int -> Data a - shiftL = optZero (function2 "shiftL" (\_ _ -> universal) B.shiftL) - (<<) :: Data a -> Data Int -> Data a - (<<) = shiftL - shiftR :: Data a -> Data Int -> Data a - shiftR = optZero (function2 "shiftR" (\_ _ -> universal) B.shiftR) - (>>) :: Data a -> Data Int -> Data a - (>>) = shiftR - rotateL :: Data a -> Data Int -> Data a - rotateL = optZero (function2 "rotateL" (\_ _ -> universal) B.rotateL) - rotateR :: Data a -> Data Int -> Data a - rotateR = optZero (function2 "rotateR" (\_ _ -> universal) B.rotateR) - reverseBits :: Data a -> Data a - reverseBits = function "reverseBits" (\_ -> universal) revBits - - -- Bulk bit operations - -- | Returns the number of leading zeroes for unsigned types. - -- For signed types it returns the number of unnecessary sign bits - bitScan :: Data a -> Data Int - bitScan = function "bitScan" (\_ -> universal) scanLeft - bitCount :: Data a -> Data Int - bitCount = function "bitCount" (\_ -> universal) countBits - - -- Queries about the type - bitSize :: Data a -> Data Int - bitSize = function "bitSize" (const naturalRange) B.bitSize - isSigned :: Data a -> Data Bool - isSigned = function "isSigned" noSizeProp B.isSigned - -optAnd :: (B.Bits a, Storable a) => Data a -> Data a -> Data a -optAnd x y = case (dataToExpr x, dataToExpr y) of - (Value 0, _) -> value 0 - (_, Value 0) -> value 0 - (Value x, _) | allOnes x -> y - (_, Value y) | allOnes y -> x - _ -> function2 "(.&.)" (\_ _ -> universal) (B..&.) x y - -optOr :: (B.Bits a, Storable a) => Data a -> Data a -> Data a -optOr x y = case (dataToExpr x, dataToExpr y) of - (Value 0, _) -> y - (_, Value 0) -> x - (Value x, _) | allOnes x -> value (B.complement 0) - (_, Value y) | allOnes y -> value (B.complement 0) - _ -> function2 "(.|.)" (\_ _ -> universal) (B..|.) x y - -optXor :: (Bits a, B.Bits a, Storable a) => Data a -> Data a -> Data a -optXor x y = case (dataToExpr x, dataToExpr y) of - (Value 0, _) -> y - (_, Value 0) -> x - (Value x, _) | allOnes x -> complement y - (_, Value y) | allOnes y -> complement x - _ -> function2 "xor" (\_ _ -> universal) B.xor x y - -allOnes :: (Prelude.Eq a, B.Bits a) => a -> Bool -allOnes x = x Prelude.== B.complement 0 - -optZero :: (a -> Data Int -> a) -> a -> Data Int -> a -optZero f x y = case dataToExpr y of - Value 0 -> x - _ -> f x y - -scanLeft :: B.Bits b => b -> Int -scanLeft b = - if B.isSigned b - then scanLoop b (B.testBit b (B.bitSize b - 1)) (B.bitSize b - 2) 0 - else scanLoop b False (B.bitSize b - 1) 0 - where - scanLoop b bit i n | i Prelude.< 0 = n - scanLoop b bit i n | B.testBit b i Prelude./= bit = n - scanLoop b bit i n | otherwise = scanLoop b bit (i-1) (n+1) - - -countBits :: B.Bits b => b -> Int -countBits b = loop b (B.bitSize b - 1) 0 - where - loop b i n | i Prelude.< 0 = n - loop b i n | B.testBit b i = loop b (i-1) (n+1) - loop b i n | otherwise = loop b (i-1) n - -revBits :: B.Bits b => b -> b -revBits b = revLoop b 0 (0 `asTypeOf` b) - where - bitSize = B.bitSize b - revLoop b i n | i Prelude.>= bitSize = n - revLoop b i n | B.testBit b i = revLoop b (i+1) (B.setBit n (bitSize - i - 1)) - revLoop b i n | otherwise = revLoop b (i+1) n - -instance Bits Int - -instance Bits Unsigned32 - -instance Bits Signed32 - -instance Bits Unsigned16 - -instance Bits Signed16 - -instance Bits Unsigned8 +import Prelude () -instance Bits Signed8 +import Feldspar.Core.Functions.Logic +import Feldspar.Core.Functions.Eq +import Feldspar.Core.Functions.Ord +import Feldspar.Core.Functions.Num +import Feldspar.Core.Functions.Bits +import Feldspar.Core.Functions.Integral +import Feldspar.Core.Functions.Fractional +import Feldspar.Core.Functions.Floating +import Feldspar.Core.Functions.Complex +import Feldspar.Core.Functions.Tuple +import Feldspar.Core.Functions.Array +import Feldspar.Core.Functions.Conversion +import Feldspar.Core.Functions.Trace diff --git a/Feldspar/Core/Functions/Array.hs b/Feldspar/Core/Functions/Array.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Core/Functions/Array.hs @@ -0,0 +1,88 @@ +-- | Core language array operations + +module Feldspar.Core.Functions.Array + ( arrayLen + , getIx + , setIx + , getLength + , RandomAccess (..) + ) where + + + +import Data.List + +import Feldspar.Set +import Feldspar.Range +import Feldspar.Core.Types +import Feldspar.Core.Representation +import Feldspar.Core.Constructs +import Feldspar.Core.Functions.Num () + +import Feldspar.DSL.Expression +import Feldspar.DSL.Lambda +import Feldspar.DSL.Network + +-- | Constructs an array of the given length and initialization. +arrayLen :: Type a => Data Length -> [a] -> Data [a] +arrayLen len = array (dataSize len :> universal) + -- TODO This function is a temporary solution. + +evalGetIx :: Range Length -> [a] -> Index -> a +evalGetIx l as i + | not (i `inRange` r) = error "getIx: index out of bounds" + | i >= la = error "getIx: reading garbage" + | otherwise = genericIndex as i + where + la = genericLength as + r = rangeByRange 0 (l-1) + +-- | Look up an index in an array (see also '!') +getIx :: Type a => Data [a] -> Data Index -> Data a +getIx arr = function2 "(!)" sizeProp (evalGetIx l) arr + where + sizeProp (_:>aSize) _ = aSize + l:>_ = dataSize arr + +-- | Array update +setIx + :: Type a + => Data [a] -- ^ Source array + -> Data Index -- ^ Index to replace + -> Data a -- ^ New value + -> Data [a] +setIx arr i a = + nodeData (dataSize arr) + $ Inject (Node SetIx) + :$: toEdge i + :$: toEdge a + :$: toEdge arr + +-- | Array length +getLength :: Type a => Data [a] -> Data Length +getLength arr = case undoEdge (unData arr) of + Inject (Node Parallel) :$: len :$: _ :$: arr' -> Data len + getLength (Data arr') + Inject (Node SetLength) :$: len :$: _ -> Data len + Inject (Node SetIx) :$: _ :$: _ :$: arr' -> getLength (Data arr') + _ -> case dataSize arr of + (Range l b :> _) + | l == b -> value l + otherwise -> function1 "length" sizeProp genericLength arr + where + sizeProp (lSize:>_) = lSize + +infixl 9 ! + +class RandomAccess a + where + -- | The type of elements in a random access structure + type Element a + + -- | Index lookup in a random access structure + (!) :: a -> Data Index -> Element a + +instance Type a => RandomAccess (Data [a]) + where + type Element (Data [a]) = Data a + (!) = getIx + diff --git a/Feldspar/Core/Functions/Bits.hs b/Feldspar/Core/Functions/Bits.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Core/Functions/Bits.hs @@ -0,0 +1,202 @@ +-- | Bit manipulation + +module Feldspar.Core.Functions.Bits where + +import qualified Data.Bits as B +import Data.Int +import Data.Word + +import Feldspar.Range +import Feldspar.Core.Types +import Feldspar.Core.Representation +import Feldspar.Core.Constructs + +infixl 5 <<,>> +infixl 4 ⊕ + +-- | Redefinition of the standard 'B.Bits' class for Feldspar +class (B.Bits a, Type a, FullProp (Size a)) => Bits a + where + -- Logical operations + (.&.) :: Data a -> Data a -> Data a + (.&.) = optAnd fullProp + (.|.) :: Data a -> Data a -> Data a + (.|.) = optOr fullProp + xor :: Data a -> Data a -> Data a + xor = optXor fullProp + complement :: Data a -> Data a + complement = function1 "complement" fullProp B.complement + + -- Operations on individual bits + bit :: Data Index -> Data a + bit = function1 "bit" fullProp (B.bit . fromIntegral) + setBit :: Data a -> Data Index -> Data a + setBit = function2 "setBit" fullProp (liftIntWord B.setBit) + clearBit :: Data a -> Data Index -> Data a + clearBit = function2 "clearBit" fullProp (liftIntWord B.clearBit) + complementBit :: Data a -> Data Index -> Data a + complementBit = function2 "complementBit" fullProp (liftIntWord B.complementBit) + testBit :: Data a -> Data Index -> Data Bool + testBit = function2 "testBit" fullProp (liftIntWord B.testBit) + + -- Moving bits around + shiftLU :: Data a -> Data Index -> Data a + shiftLU = optZero $ function2 "shiftL" fullProp (liftIntWord B.shiftL) + shiftRU :: Data a -> Data Index -> Data a + shiftRU = optZero $ function2 "shiftR" fullProp cShiftRU + shiftL :: Data a -> Data DefaultInt -> Data a + shiftL = optZero $ function2 "shiftL" fullProp (liftInt B.shiftL) + shiftR :: Data a -> Data DefaultInt -> Data a + shiftR = optZero $ function2 "shiftR" fullProp (liftInt B.shiftR) + rotateLU :: Data a -> Data Index -> Data a + rotateLU = optZero $ function2 "rotateL" fullProp (liftIntWord B.rotateL ) + rotateRU :: Data a -> Data Index -> Data a + rotateRU = optZero $ function2 "rotateR" fullProp (liftIntWord B.rotateR ) + rotateL :: Data a -> Data DefaultInt -> Data a + rotateL = optZero $ function2 "rotateL" fullProp (liftInt B.rotateL) + rotateR :: Data a -> Data DefaultInt -> Data a + rotateR = optZero $ function2 "rotateR" fullProp (liftInt B.rotateR) + reverseBits :: Data a -> Data a + reverseBits = function1 "reverseBits" fullProp evalReverseBits + + -- Bulk bit operations + -- | Returns the number of leading zeroes for unsigned types. + -- For signed types it returns the number of unnecessary sign bits + bitScan :: Data a -> Data Index + bitScan = function1 "bitScan" fullProp (fromIntegral . evalBitScan) + bitCount :: Data a -> Data Index + bitCount = function1 "bitCount" fullProp (fromIntegral . evalBitCount) + + -- Queries about the type + bitSize :: Data a -> Data Index + bitSize = function1 "bitSize" (\_ -> naturalRange) (fromIntegral . B.bitSize) + isSigned :: Data a -> Data Bool + isSigned = function1 "isSigned" fullProp B.isSigned + +-- TODO Some range propagation could be improved. +-- bitSize could have (range 0 32) instead of naturalRange. + +liftIntWord :: (a -> Int -> b) -> (a -> DefaultWord -> b) +liftIntWord f x = f x . fromIntegral + +liftInt :: (a -> Int -> b) -> (a -> DefaultInt -> b) +liftInt f x = f x . fromIntegral + +(⊕) :: Bits a => Data a -> Data a -> Data a +(⊕) = xor +(<<) :: Bits a => Data a -> Data Index -> Data a +(<<) = shiftLU +(>>) :: Bits a => Data a -> Data Index -> Data a +(>>) = shiftRU + +optAnd :: (Bits a) => + (Size a -> Size a -> Size a) + -> Data a -> Data a -> Data a +optAnd rangeProp x y = + case (viewLiteral x, viewLiteral y) of + (Just 0, _) -> value 0 + (_, Just 0) -> value 0 + (Just x, _) | isAllOnes x -> y + (_, Just y) | isAllOnes y -> x + _ -> function2 "(.&.)" rangeProp (B..&.) x y + +optOr :: (Bits a) => + (Size a -> Size a -> Size a) + -> Data a -> Data a -> Data a +optOr rangeProp x y = + case (viewLiteral x, viewLiteral y) of + (Just 0, _) -> y + (_, Just 0) -> x + (Just x, _) | isAllOnes x -> value allOnes + (_, Just y) | isAllOnes y -> value allOnes + _ -> function2 "(.|.)" rangeProp (B..|.) x y + +optXor :: (Bits a) => + (Size a -> Size a -> Size a) + -> Data a -> Data a -> Data a +optXor rangeProp x y = + case (viewLiteral x, viewLiteral y) of + (Just 0, _) -> y + (_, Just 0) -> x + (Just x, _) | isAllOnes x -> complement y + (_, Just y) | isAllOnes y -> complement x + _ -> function2 "xor" rangeProp B.xor x y + +isAllOnes :: B.Bits a => a -> Bool +isAllOnes x = x Prelude.== B.complement 0 + +allOnes :: B.Bits a => a +allOnes = B.complement 0 + +optZero :: (Type n, Num n) => (a -> Data n -> a) -> a -> Data n -> a +optZero f x y = case viewLiteral y of + Just 0 -> x + _ -> f x y + +evalBitScan :: B.Bits b => b -> Word +evalBitScan b = + if B.isSigned b + then scanLoop b (B.testBit b (B.bitSize b - 1)) (B.bitSize b - 2) 0 + else scanLoop b False (B.bitSize b - 1) 0 + where + scanLoop b bit i n | i Prelude.< 0 = n + scanLoop b bit i n | B.testBit b i Prelude./= bit = n + scanLoop b bit i n | otherwise = scanLoop b bit (i-1) (n+1) + +evalBitCount :: B.Bits b => b -> Word +evalBitCount b = loop b (B.bitSize b - 1) 0 + where + loop b i n | i Prelude.< 0 = n + loop b i n | B.testBit b i = loop b (i-1) (n+1) + loop b i n | otherwise = loop b (i-1) n + +evalReverseBits :: B.Bits b => b -> b +evalReverseBits b = revLoop b 0 (0 `asTypeOf` b) + where + bitSize = B.bitSize b + revLoop b i n | i Prelude.>= bitSize = n + revLoop b i n | B.testBit b i = revLoop b (i+1) (B.setBit n (bitSize - i - 1)) + revLoop b i n | otherwise = revLoop b (i+1) n + +{- TODO + This is a hack until we have proper size information for DefaultWord. + We do not want the Range module to have to know about DefaultWord so + we patch the types for this range propagation function here. +-} +propRangeShiftLU r1 r2 + = rangeShiftLU r1 (mapMonotonic (\ (DefaultWord a) -> a) r2) +propRangeShiftRU r1 r2 + = rangeShiftRU r1 (mapMonotonic (\ (DefaultWord a) -> a) r2) +cShiftRU v (DefaultWord i) = correctShiftRU v i + +{- TODO + The reason we have to provide the range propagation functions + in these instances is that if we would try to do it in the default + methods of the class we would get a superclass constraint 'Size a ~ Range a'. + GHC 6.12 doesn't support this. +-} +instance Bits Word8 where + xor = optXor rangeXor + shiftLU = optZero $ function2 "shiftL" propRangeShiftLU (liftIntWord B.shiftL) + shiftRU = optZero $ function2 "shiftR" propRangeShiftRU cShiftRU +instance Bits Int8 where + xor = optXor rangeXor +instance Bits Word16 where + xor = optXor rangeXor + shiftLU = optZero $ function2 "shiftL" propRangeShiftLU (liftIntWord B.shiftL) + shiftRU = optZero $ function2 "shiftR" propRangeShiftRU cShiftRU +instance Bits Int16 where + xor = optXor rangeXor +instance Bits Word32 where + xor = optXor rangeXor + shiftLU = optZero $ function2 "shiftL" propRangeShiftLU (liftIntWord B.shiftL) + shiftRU = optZero $ function2 "shiftR" propRangeShiftRU cShiftRU +instance Bits Int32 where + xor = optXor rangeXor +instance Bits DefaultWord where + xor = optXor rangeXor + shiftLU = optZero $ function2 "shiftL" propRangeShiftLU (liftIntWord B.shiftL) + shiftRU = optZero $ function2 "shiftR" propRangeShiftRU cShiftRU +instance Bits DefaultInt where + xor = optXor rangeXor + diff --git a/Feldspar/Core/Functions/Complex.hs b/Feldspar/Core/Functions/Complex.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Core/Functions/Complex.hs @@ -0,0 +1,51 @@ +-- | Complex numbers + +module Feldspar.Core.Functions.Complex where + + + +import Data.Complex (Complex (..)) +import qualified Data.Complex as C + +import Feldspar.Core.Types +import Feldspar.Core.Representation +import Feldspar.Core.Constructs +import Feldspar.Core.Functions.Num + + + +complex :: (Numeric a, RealFloat a) => Data a -> Data a -> Data (Complex a) +complex = function2 "complex" fullProp (:+) + +realPart :: (Numeric a, RealFloat a) => Data (Complex a) -> Data a +realPart = function1 "creal" fullProp C.realPart + +imagPart :: (Numeric a, RealFloat a) => Data (Complex a) -> Data a +imagPart = function1 "cimag" fullProp C.imagPart + +conjugate :: (Numeric a, RealFloat a) => Data (Complex a) -> Data (Complex a) +conjugate = function1 "conjugate" fullProp C.conjugate + +mkPolar :: (Numeric a, RealFloat a) => Data a -> Data a -> Data (Complex a) +mkPolar = function2 "mkPolar" fullProp C.mkPolar + +cis :: (Numeric a, RealFloat a) => Data a -> Data (Complex a) +cis = function1 "cis" fullProp C.cis + +magnitude :: (Numeric a, RealFloat a) => Data (Complex a) -> Data a +magnitude = function1 "magnitude" fullProp C.magnitude + +phase :: (Numeric a, RealFloat a) => Data (Complex a) -> Data a +phase = function1 "phase" fullProp C.phase + +polar :: (Numeric a, RealFloat a) => Data (Complex a) -> (Data a, Data a) +polar c = (magnitude c, phase c) + +infixl 6 +. + +(+.) :: (Numeric a, RealFloat a) => Data a -> Data a -> Data (Complex a) +(+.) = complex + +iunit :: (Numeric a, RealFloat a) => Data (Complex a) +iunit = 0 +. 1 + diff --git a/Feldspar/Core/Functions/Conversion.hs b/Feldspar/Core/Functions/Conversion.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Core/Functions/Conversion.hs @@ -0,0 +1,46 @@ +-- | Type conversion operations + +module Feldspar.Core.Functions.Conversion where + +import qualified Prelude + +import Data.Tagged + +import Feldspar.Range +import Feldspar.Prelude +import Feldspar.Core.Types +import Feldspar.Core.Representation +import Feldspar.Core.Constructs +import Feldspar.Core.Functions.Num +import Feldspar.Core.Functions.Integral + + + +i2f :: (Integral a, Size a ~ Range a) => Data a -> Data Float +i2f = i2n + +f2i :: Integral a => Data Float -> Data a +f2i = function1 "f2i" fullProp (Prelude.truncate) + +i2n :: forall a b . (Integral a, Numeric b, Size a ~ Range a) => + Data a -> Data b +i2n = function1 "i2n" (unTag . prop) (fromInteger.toInteger) + where prop r = rangeToSize (mapMonotonic toInteger r) + unTag :: Tagged b (Size b) -> Size b + unTag (Tagged sz) = sz + +b2i :: Integral a => Data Bool -> Data a +b2i = function1 "b2i" fullProp (\b -> if b then 1 else 0) + + +truncate :: Integral a => Data Float -> Data a +truncate = f2i + +round :: Integral a => Data Float -> Data a +round = function1 "round" fullProp (Prelude.round) + +ceiling :: Integral a => Data Float -> Data a +ceiling = function1 "ceiling" fullProp (Prelude.ceiling) + +floor :: Integral a => Data Float -> Data a +floor = function1 "floor" fullProp (Prelude.floor) diff --git a/Feldspar/Core/Functions/Eq.hs b/Feldspar/Core/Functions/Eq.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Core/Functions/Eq.hs @@ -0,0 +1,98 @@ +-- | Equality operations + +module Feldspar.Core.Functions.Eq where + +import qualified Prelude +import Data.Complex +import Data.Int +import Data.Word + +import Feldspar.Prelude +import Feldspar.Range +import Feldspar.Core.Types +import Feldspar.Core.Representation +import Feldspar.Core.Constructs + +infix 4 == +infix 4 /= + +-- | Redefinition of the standard 'Prelude.Eq' class for Feldspar +class Type a => Eq a + where + (==) :: Data a -> Data a -> Data Bool + (==) = defaultEq + (/=) :: Data a -> Data a -> Data Bool + (/=) = defaultNeq + +defaultEq :: Eq a => Data a -> Data a -> Data Bool +defaultEq a b + | a Prelude.== b = true + | otherwise = function2 "(==)" fullProp (Prelude.==) a b + +defaultNeq :: Eq a => Data a -> Data a -> Data Bool +defaultNeq a b + | a Prelude.== b = false + | otherwise = function2 "(/=)" fullProp (Prelude./=) a b + +optEq :: (Eq a, BoundedInt b, Size a ~ Range b) => + Data a -> Data a -> Data Bool +optEq a b + | sa `disjoint` sb = false + | otherwise = defaultEq a b + where + sa = dataSize a + sb = dataSize b + +optNeq :: (Eq a, BoundedInt b, Size a ~ Range b) => + Data a -> Data a -> Data Bool +optNeq a b + | sa `disjoint` sb = true + | otherwise = defaultNeq a b + where + sa = dataSize a + sb = dataSize b + +instance Eq () +instance Eq Bool +instance Eq Float + +instance Eq Word8 where + (==) = optEq + (/=) = optNeq + +instance Eq Int8 where + (==) = optEq + (/=) = optNeq + +instance Eq Word16 where + (==) = optEq + (/=) = optNeq + +instance Eq Int16 where + (==) = optEq + (/=) = optNeq + +instance Eq Word32 where + (==) = optEq + (/=) = optNeq + +instance Eq Int32 where + (==) = optEq + (/=) = optNeq + +instance Eq DefaultWord where + (==) = optEq + (/=) = optNeq + +instance Eq DefaultInt where + (==) = optEq + (/=) = optNeq + +instance (Eq a, RealFloat a) => Eq (Complex a) + +instance Eq a => Eq [a] + +instance (Eq a, Eq b) => Eq (a,b) +instance (Eq a, Eq b, Eq c) => Eq (a,b,c) +instance (Eq a, Eq b, Eq c, Eq d) => Eq (a,b,c,d) + diff --git a/Feldspar/Core/Functions/Floating.hs b/Feldspar/Core/Functions/Floating.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Core/Functions/Floating.hs @@ -0,0 +1,31 @@ +-- | This module provides +-- +-- @instance (`Fractional'` a, `Floating` a) => `Floating` (`Data` a)@ + +module Feldspar.Core.Functions.Floating where + +import Feldspar.Core.Types +import Feldspar.Core.Representation +import Feldspar.Core.Constructs +import Feldspar.Core.Functions.Fractional + +instance (Fractional' a, Floating a) => Floating (Data a) where + pi = value Prelude.pi + exp = function1 "exp" fullProp Prelude.exp + sqrt = function1 "sqrt" fullProp Prelude.sqrt + log = function1 "log" fullProp Prelude.log + (**) = function2 "(**)" fullProp (Prelude.**) + logBase = function2 "logBase" fullProp Prelude.logBase + sin = function1 "sin" fullProp Prelude.sin + tan = function1 "tan" fullProp Prelude.tan + cos = function1 "cos" fullProp Prelude.cos + asin = function1 "asin" fullProp Prelude.asin + atan = function1 "atan" fullProp Prelude.atan + acos = function1 "acos" fullProp Prelude.acos + sinh = function1 "sinh" fullProp Prelude.sinh + tanh = function1 "tanh" fullProp Prelude.tanh + cosh = function1 "cosh" fullProp Prelude.cosh + asinh = function1 "asinh" fullProp Prelude.asinh + atanh = function1 "atanh" fullProp Prelude.atanh + acosh = function1 "acosh" fullProp Prelude.acosh + diff --git a/Feldspar/Core/Functions/Fractional.hs b/Feldspar/Core/Functions/Fractional.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Core/Functions/Fractional.hs @@ -0,0 +1,29 @@ +module Feldspar.Core.Functions.Fractional where + +import Data.Complex + +import Feldspar.Core.Types +import Feldspar.Core.Representation +import Feldspar.Core.Constructs +import Feldspar.Core.Functions.Num + +-- | Fractional types. The relation to the standard 'Fractional' class is +-- +-- @instance `Frational'` a => `Fractional` (`Data` a)@ +class (Fractional a, Numeric a) => Fractional' a + where + fromRationalFrac :: Rational -> Data a + fromRationalFrac = value . fromRational + + divFrac :: Data a -> Data a -> Data a + divFrac = function2 "(/)" fullProp (/) + +instance Fractional' Float + +instance (Fractional' a, RealFloat a) => Fractional' (Complex a) + +instance Fractional' a => Fractional (Data a) + where + fromRational = fromRationalFrac + (/) = divFrac + diff --git a/Feldspar/Core/Functions/Integral.hs b/Feldspar/Core/Functions/Integral.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Core/Functions/Integral.hs @@ -0,0 +1,133 @@ +module Feldspar.Core.Functions.Integral where + +import qualified Prelude +import Data.Int +import Data.Word + +import Feldspar.Prelude +import Feldspar.Range +import Feldspar.Core.Types +import Feldspar.Core.Representation +import Feldspar.Core.Constructs +import Feldspar.Core.Functions.Logic +import Feldspar.Core.Functions.Eq +import Feldspar.Core.Functions.Ord +import Feldspar.Core.Functions.Num +import Feldspar.Core.Functions.Bits + +-- | Redefinition of the standard 'Prelude.Integral' class for Feldspar +class (Numeric a, BoundedInt a, Bits a, Ord a) => Integral a where + quot :: Data a -> Data a -> Data a + quot = defaultQuot + rem :: Data a -> Data a -> Data a + div :: Data a -> Data a -> Data a + div = defaultDiv + mod :: Data a -> Data a -> Data a + mod = defaultMod + (^) :: Data a -> Data a -> Data a + (^) = optExp fullProp + +-- TODO Should (^) really be in this class? The standard function has type +-- +-- (Num a, Integral b) => a -> b -> a + +defaultQuot :: Integral a => Data a -> Data a -> Data a +defaultQuot = function2 "quot" fullProp Prelude.quot + +optQuot :: (Integral a, BoundedInt a, Size a ~ Range a) => + Data a -> Data a -> Data a +optQuot x y = function2 "quot" rangeQuot Prelude.quot x y + +defaultDiv :: Integral a => Data a -> Data a -> Data a +defaultDiv x y = rem x y /= 0 && (x > 0 && y < 0 || x < 0 && y > 0) ? + (quotxy - 1, quotxy) + where + quotxy = quot x y + +defaultMod :: Integral a => Data a -> Data a -> Data a +defaultMod x y = remxy /= 0 && (x > 0 && y < 0 || x < 0 && y > 0) ? + (remxy + y, remxy) + where + remxy = rem x y + +optRem :: (Integral a, BoundedInt a, Size a ~ Range a) => + Data a -> Data a -> Data a +optRem x y + -- -- | abs rx `rangeLess` abs ry = x + -- This optimization is invalid if x == (-128) and 'a' is Int8 + | otherwise = function2 "rem" rangeRem Prelude.rem x y + where rx = dataSize x + ry = dataSize y + -- TODO Use as default implementation of 'rem', when equality is allowed as + -- super class constraint (i.e. Size a ~ Range a). + +optMod :: (Integral a, BoundedInt b, Size a ~ Range b) => + Data a -> Data a -> Data a +optMod x y = cap (rangeMod rx ry) $ + remxy /= 0 && (x > 0 && y < 0 || x < 0 && y > 0) ? + (remxy + y, remxy) + where remxy = rem x y + rx = dataSize x + ry = dataSize y + +optExp :: Integral a => + (Size a -> Size a -> Size a) + -> Data a -> Data a -> Data a +optExp prop m e = case (viewLiteral m, viewLiteral e) of + (Just 1,_) -> value 1 + (_,Just 1) -> m + (_,Just 0) -> value 1 + _ -> function2 "(^)" prop (Prelude.^) m e + +optSignedExp :: (Integral a, Signed a, BoundedInt b, Size a ~ Range b) => + Data a -> Data a -> Data a +optSignedExp m e = case viewLiteral m of + -- From Bit Twiddling Hacks + -- "Conditionally negate a value without branching" + -- Here we negate the value 1 if isOdd is true i.e. when e is + -- and odd number + Just (-1) -> cap (range (-1) 1) $ + let isOdd = e .&. 1 + in (1 `xor` (negate isOdd)) + isOdd + _ -> optExp rangeExp m e + +instance Integral Word8 where + div = optQuot + rem = optRem + mod = rem + +instance Integral Int8 where + rem = optRem + mod = optMod + (^) = optSignedExp + +instance Integral Word16 where + div = optQuot + rem = optRem + mod = rem + +instance Integral Int16 where + rem = optRem + mod = optMod + (^) = optSignedExp + +instance Integral Word32 where + div = optQuot + rem = optRem + mod = rem + +instance Integral Int32 where + rem = optRem + mod = optMod + (^) = optSignedExp + +instance Integral DefaultWord where + div = optQuot + rem = optRem + mod = rem + +instance Integral DefaultInt where + rem = optRem + mod = optMod + (^) = optSignedExp + diff --git a/Feldspar/Core/Functions/Logic.hs b/Feldspar/Core/Functions/Logic.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Core/Functions/Logic.hs @@ -0,0 +1,38 @@ +module Feldspar.Core.Functions.Logic where + +import Feldspar.Core.Types +import Feldspar.Core.Representation +import Feldspar.Core.Constructs + +infixr 3 && +infixr 3 &&* +infixr 2 || +infixr 2 ||* + +not :: Data Bool -> Data Bool +not = function1 "not" fullProp Prelude.not + +(&&) :: Data Bool -> Data Bool -> Data Bool +x && y = case (viewLiteral x, viewLiteral y) of + (Just True, _) -> y + (Just False,_) -> false + (_, Just True) -> x + (_,Just False) -> false + _ -> function2 "(&&)" fullProp (Prelude.&&) x y + +(||) :: Data Bool -> Data Bool -> Data Bool +x || y = case (viewLiteral x, viewLiteral y) of + (Just True, _) -> true + (Just False,_) -> y + (_, Just True) -> true + (_,Just False) -> x + _ -> function2 "(||)" fullProp (Prelude.||) x y + +-- | Lazy conjunction, second argument only evaluated if necessary +(&&*) :: Data Bool -> Data Bool -> Data Bool +a &&* b = condition a b false + +-- | Lazy disjunction, second argument only evaluated if necessary +(||*) :: Data Bool -> Data Bool -> Data Bool +a ||* b = condition a true b + diff --git a/Feldspar/Core/Functions/Num.hs b/Feldspar/Core/Functions/Num.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Core/Functions/Num.hs @@ -0,0 +1,179 @@ +-- | Numeric operations + +module Feldspar.Core.Functions.Num where + +import Data.Complex +import Data.Int +import Data.Word + +import Data.Tagged + +import Feldspar.Range +import Feldspar.Core.Types +import Feldspar.Core.Representation +import Feldspar.Core.Constructs + +-- | Numeric types. The relation to the standard 'Num' class is +-- +-- @instance `Numeric` a => `Num` (`Data` a)@ +class (Type a, Num a, FullProp (Size a)) => Numeric a + where + fromIntegerNum :: Integer -> Data a + fromIntegerNum = value . fromInteger + + absNum :: Data a -> Data a + absNum = defaultAbs fullProp + signumNum :: Data a -> Data a + signumNum = defaultSignum fullProp + addNum :: Data a -> Data a -> Data a + addNum = defaultAdd fullProp + subNum :: Data a -> Data a -> Data a + subNum = defaultSub fullProp + mulNum :: Data a -> Data a -> Data a + mulNum = defaultMul fullProp + + rangeToSize :: Range Integer -> Tagged a (Size a) + rangeToSize _ = Tagged fullProp + +defaultAbs :: Numeric a => (Size a -> Size a) -> Data a -> Data a +defaultAbs szProp = function1 "abs" szProp abs + +defaultSignum :: Numeric a => (Size a -> Size a) -> Data a -> Data a +defaultSignum szProp = function1 "signum" szProp signum + +defaultAdd :: Numeric a => + (Size a -> Size a -> Size a) -> Data a -> Data a -> Data a +defaultAdd szProp = function2 "(+)" szProp (+) + +defaultSub :: Numeric a => + (Size a -> Size a -> Size a) -> Data a -> Data a -> Data a +defaultSub szProp = function2 "(-)" szProp (-) + +defaultMul :: Numeric a => + (Size a -> Size a -> Size a) -> Data a -> Data a -> Data a +defaultMul szProp = function2 "(*)" szProp (*) + +optAbs :: (Numeric a, BoundedInt b, Size a ~ Range b) => Data a -> Data a +optAbs x | isNatural rx = x + | otherwise = defaultAbs abs x + where rx = dataSize x + +optSignum :: (Numeric a, BoundedInt b, Size a ~ Range b) => Data a -> Data a +optSignum x | 0 `rangeLess` rx = 1 + | rx `rangeLess` 0 = -1 + | rx Prelude.== 0 = 0 + | otherwise = defaultSignum signum x + where rx = dataSize x + +optAdd :: (Numeric a, Num (Size a)) => Data a -> Data a -> Data a +optAdd x y = case (viewLiteral x, viewLiteral y) of + (Just 0, _) -> y + (_, Just 0) -> x + _ -> defaultAdd (+) x y + +optSub :: (Numeric a, Num (Size a)) => Data a -> Data a -> Data a +optSub x y = case viewLiteral y of + Just 0 -> x + _ -> defaultSub (-) x y + +optMul :: (Numeric a, Num (Size a)) => Data a -> Data a -> Data a +optMul x y = case (viewLiteral x, viewLiteral y) of + (Just 0,_) -> value 0 + (_,Just 0) -> value 0 + (Just 1,_) -> y + (_,Just 1) -> x + _ -> defaultMul (*) x y + +rangeProp :: forall a . (Bounded a, Integral a, Size a ~ Range a) => + Range Integer -> Tagged a (Size a) +rangeProp (Range l u) + | withinBounds l && withinBounds u + = Tagged $ range (fromIntegral l) (fromIntegral u) + | otherwise = Tagged (range minBound maxBound) + where withinBounds i = toInteger (minBound :: a) <= i && + i <= toInteger (maxBound :: a) + +instance Numeric Word8 + where + absNum = optAbs + signumNum = optSignum + addNum = optAdd + subNum = optSub + mulNum = optMul + rangeToSize = rangeProp + +instance Numeric Int8 + where + absNum = optAbs + signumNum = optSignum + addNum = optAdd + subNum = optSub + mulNum = optMul + rangeToSize = rangeProp + +instance Numeric Word16 + where + absNum = optAbs + signumNum = optSignum + addNum = optAdd + subNum = optSub + mulNum = optMul + rangeToSize = rangeProp + +instance Numeric Int16 + where + absNum = optAbs + signumNum = optSignum + addNum = optAdd + subNum = optSub + mulNum = optMul + rangeToSize = rangeProp + +instance Numeric Word32 + where + absNum = optAbs + signumNum = optSignum + addNum = optAdd + subNum = optSub + mulNum = optMul + rangeToSize = rangeProp + +instance Numeric Int32 + where + absNum = optAbs + signumNum = optSignum + addNum = optAdd + subNum = optSub + mulNum = optMul + rangeToSize = rangeProp + +instance Numeric DefaultWord + where + absNum = optAbs + signumNum = optSignum + addNum = optAdd + subNum = optSub + mulNum = optMul + rangeToSize = rangeProp + +instance Numeric DefaultInt + where + absNum = optAbs + signumNum = optSignum + addNum = optAdd + subNum = optSub + mulNum = optMul + rangeToSize = rangeProp + +instance Numeric Float +instance (Type a, RealFloat a) => Numeric (Complex a) + +instance Numeric a => Num (Data a) + where + fromInteger = fromIntegerNum + abs = absNum + signum = signumNum + (+) = addNum + (-) = subNum + (*) = mulNum + diff --git a/Feldspar/Core/Functions/Ord.hs b/Feldspar/Core/Functions/Ord.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Core/Functions/Ord.hs @@ -0,0 +1,185 @@ +module Feldspar.Core.Functions.Ord where + +import qualified Prelude +import Data.Int +import Data.Word + +import Feldspar.Prelude +import Feldspar.Range +import Feldspar.Core.Types +import Feldspar.Core.Representation +import Feldspar.Core.Constructs +import Feldspar.Core.Functions.Eq + +infix 4 < +infix 4 > +infix 4 <= +infix 4 >= + +-- | Redefinition of the standard 'Prelude.Ord' class for Feldspar +class (Eq a, Prelude.Ord a) => Ord a where + (<) :: Data a -> Data a -> Data Bool + (<) = defaultLT + (>) :: Data a -> Data a -> Data Bool + (>) = defaultGT + + (<=) :: Data a -> Data a -> Data Bool + (<=) = defaultLTE + (>=) :: Data a -> Data a -> Data Bool + (>=) = defaultGTE + + min :: Data a -> Data a -> Data a + min a b = a Data a -> Data a + max a b = a>b ? (a,b) + +defaultLT a b + | a Prelude.== b = false + | otherwise = function2 "(<)" fullProp (Prelude.<) a b + +defaultGT a b + | a Prelude.== b = false + | otherwise = function2 "(>)" fullProp (Prelude.>) a b + +defaultLTE a b + | a Prelude.== b = true + | otherwise = function2 "(<=)" fullProp (Prelude.<=) a b + +defaultGTE a b + | a Prelude.== b = true + | otherwise = function2 "(>=)" fullProp (Prelude.>=) a b + +optLT :: (Ord a, BoundedInt b, Size a ~ Range b) => + Data a -> Data a -> Data Bool +optLT a b + | a Prelude.== b = false + | sa `rangeLess` sb = true + | sb `rangeLessEq` sa = false + | otherwise = defaultLT a b + where + sa = dataSize a + sb = dataSize b + +optGT :: (Ord a, BoundedInt b, Size a ~ Range b) => + Data a -> Data a -> Data Bool +optGT a b + | a Prelude.== b = false + | sb `rangeLess` sa = true + | sa `rangeLessEq` sb = false + | otherwise = defaultGT a b + where + sa = dataSize a + sb = dataSize b + +optLTE :: (Ord a, BoundedInt b, Size a ~ Range b) => + Data a -> Data a -> Data Bool +optLTE a b + | a Prelude.== b = true + | sa `rangeLessEq` sb = true + | sb `rangeLess` sa = false + | otherwise = defaultLTE a b + where + sa = dataSize a + sb = dataSize b + +optGTE :: (Ord a, BoundedInt b, Size a ~ Range b) => + Data a -> Data a -> Data Bool +optGTE a b + | a Prelude.== b = true + | sb `rangeLessEq` sa = true + | sa `rangeLess` sb = false + | otherwise = defaultGTE a b + where + sa = dataSize a + sb = dataSize b + +optMin :: (Ord a, BoundedInt b, Size a ~ Range b) => Data a -> Data a -> Data a +optMin a b = cap (rangeMin ra rb) $ + case viewLiteral cond1 of + Just _ -> cond1 ? (a,b) + _ -> cond2 ? (b,a) + where + cond1 = a Data a -> Data a -> Data a +optMax a b = cap (rangeMax ra rb) $ + case viewLiteral cond1 of + Just _ -> cond1 ? (a,b) + _ -> cond2 ? (b,a) + where + cond1 = a>b + cond2 = b>a + ra = dataSize a + rb = dataSize b + +instance Ord () +instance Ord Bool +instance Ord Float + +instance Ord Word8 where + (<) = optLT + (>) = optGT + (<=) = optLTE + (>=) = optGTE + min = optMin + max = optMax + +instance Ord Int8 where + (<) = optLT + (>) = optGT + (<=) = optLTE + (>=) = optGTE + min = optMin + max = optMax + +instance Ord Word16 where + (<) = optLT + (>) = optGT + (<=) = optLTE + (>=) = optGTE + min = optMin + max = optMax + +instance Ord Int16 where + (<) = optLT + (>) = optGT + (<=) = optLTE + (>=) = optGTE + min = optMin + max = optMax + +instance Ord Word32 where + (<) = optLT + (>) = optGT + (<=) = optLTE + (>=) = optGTE + min = optMin + max = optMax + +instance Ord Int32 where + (<) = optLT + (>) = optGT + (<=) = optLTE + (>=) = optGTE + min = optMin + max = optMax + +instance Ord DefaultWord where + (<) = optLT + (>) = optGT + (<=) = optLTE + (>=) = optGTE + min = optMin + max = optMax + +instance Ord DefaultInt where + (<) = optLT + (>) = optGT + (<=) = optLTE + (>=) = optGTE + min = optMin + max = optMax + diff --git a/Feldspar/Core/Functions/Trace.hs b/Feldspar/Core/Functions/Trace.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Core/Functions/Trace.hs @@ -0,0 +1,21 @@ +-- | Tracing execution of Feldspar expressions + +module Feldspar.Core.Functions.Trace where + + + +import Feldspar.Core.Types +import Feldspar.Core.Representation +import Feldspar.Core.Constructs +import Feldspar.Core.Functions.Num + + + +-- | Tracing execution of an expression. Semantically, this is the identity +-- function, but a back end may treat this function specially, for example write +-- its arguments to a log. +trace :: Numeric a => Int -> Data a -> Data a +trace label = function2 "trace" (const id) (const id) label' + where + label' = fromIntegral label :: Data DefaultInt + diff --git a/Feldspar/Core/Functions/Tuple.hs b/Feldspar/Core/Functions/Tuple.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Core/Functions/Tuple.hs @@ -0,0 +1,39 @@ +-- | Tuple construction/destruction + +module Feldspar.Core.Functions.Tuple where + + + +import Feldspar.DSL.Expression +import Feldspar.DSL.Lambda +import Feldspar.DSL.Network +import Feldspar.Core.Types +import Feldspar.Core.Representation +import Feldspar.Core.Constructs + + + +pair :: (Type a, Type b) => Data a -> Data b -> Data (a,b) +pair (Data a) (Data b) = case (undoEdge a, undoEdge b) of + ( Inject (Node (Function "getFst" _)) :$: a' + , Inject (Node (Function "getSnd" _)) :$: b' + ) | exprEq a' b', Just ab <- exprCast b' -> Data ab + _ -> nodeData (edgeSize $ edgeInfo a, edgeSize $ edgeInfo b) $ Inject (Node Pair) :$: a :$: b + +getFst :: (Type a, Type b) => Data (a,b) -> Data a +getFst (Data ab) = case undoEdge ab of + Inject (Node Pair) :$: a :$: _ -> Data a + _ -> function1 "getFst" fst fst (Data ab) + +getSnd :: (Type a, Type b) => Data (a,b) -> Data b +getSnd (Data ab) = case undoEdge ab of + Inject (Node Pair) :$: _ :$: b -> Data b + _ -> function1 "getSnd" snd snd (Data ab) + +-- | Convenient together with view patterns: +-- +-- > f :: Data (a,b) -> ... +-- > f (matchPair -> (a,b)) = ... +matchPair :: (Type a, Type b) => Data (a,b) -> (Data a, Data b) +matchPair ab = (getFst ab, getSnd ab) + diff --git a/Feldspar/Core/Graph.hs b/Feldspar/Core/Graph.hs deleted file mode 100644 --- a/Feldspar/Core/Graph.hs +++ /dev/null @@ -1,555 +0,0 @@ --- --- Copyright (c) 2009-2010, ERICSSON AB All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * 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. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT HOLDER 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. --- - --- | A graph representation of core programs. A graph is a flat structure that --- can be viewed as a program with a global scope. For example, the Haskell --- program --- --- > main x = f 1 --- > where --- > f y = g 2 --- > where --- > g z = x + z --- --- might be represented by the following flat graph: --- --- > graph = Graph --- > { graphNodes = --- > [ Node --- > { nodeId = 0 --- > , function = Input --- > , input = Tup [] --- > , inputType = Tup [] --- > , outputType = intType --- > } --- > , Node --- > { nodeId = 1 --- > , function = Input --- > , input = Tup [] --- > , inputType = Tup [] --- > , outputType = intType --- > } --- > , Node --- > { nodeId = 2 --- > , function = Input --- > , input = Tup [] --- > , inputType = Tup [] --- > , outputType = intType --- > } --- > , Node --- > { nodeId = 3 --- > , function = Function "(+)" --- > , input = Tup [One (Variable (0,[])), One (Variable (2,[]))] --- > , inputType = intPairType --- > , outputType = intType --- > } --- > , Node --- > { nodeId = 4 --- > , function = NoInline "f" (Interface 1 (One (Variable (5,[]))) intType intType) --- > , input = One (Constant (IntData 1)) --- > , inputType = intType --- > , outputType = intType --- > } --- > , Node --- > { nodeId = 5 --- > , function = NoInline "g" (Interface 2 (One (Variable (3,[]))) intType intType) --- > , input = One (Constant (IntData 2)) --- > , inputType = intType --- > , outputType = intType --- > } --- > ] --- > --- > , graphInterface = Interface --- > { interfaceInput = 0 --- > , interfaceOutput = One (Variable (4,[])) --- > , interfaceInputType = intType --- > , interfaceOutputType = intType --- > } --- > } --- > where --- > intType = result (typeOf :: Res [[[Int]]] (Tuple StorableType)) --- > intPairType = result (typeOf :: Res (Int,Int) (Tuple StorableType)) --- --- XXX Check above code again --- --- which corresponds to the following flat program --- --- > main v0 = v4 --- > f v1 = v5 --- > g v2 = v3 --- > v3 = v0 + v2 --- > v4 = f 1 --- > v5 = g 2 --- --- There are a few assumptions on graphs: --- --- * All nodes have unique identifiers. --- --- * There are no cycles. --- --- * The 'input' and 'inputType' tuples of each node should have the same shape. --- --- * Each 'interfaceInput' (including the top-level one) refers to an 'Input' --- node not referred to by any other interface. --- --- * All 'Variable' references are valid (i.e. refer only to those variables --- implicitly defined by each node). --- --- * There should not be any cycles in the constraints introduced by --- 'findLocalities'. (XXX Is this even possible?) --- --- * Sub-function interfaces should be \"consistent\" with the input/output type --- of the node. For example, the body of a while loop should have the same type --- as the whole loop. --- --- In the original program, @g@ was defined locally to @f@, and the addition was --- done locally in @g@. But in the flat program, this hierarchy (called --- /definition hierarchy/) is not represented. The flat program is of course not --- valid Haskell (@v0@ and @v2@ are used outside of their scopes). The function --- 'makeHierarchical' turns a flat graph into a hierarchical one that --- corresponds to syntactically valid Haskell. --- --- 'makeHierarchical' requires some explanation. First a few definitions: --- --- * Nodes that have associated interfaces ('NoInline', 'IfThenElse', 'While' --- and 'Parallel') are said to contain /sub-functions/. These nodes are called --- /super nodes/. In the above program, the super node @v4@ contains the --- sub-function @f@, and @v5@ contains the sub-function @g@. --- --- * A definition @d@ is /local/ to a definition @e@ iff. @d@ is placed --- somewhere within the definition of @e@ (i.e. inside an arbitrarily deeply --- nested @where@ clause). --- --- * A definition @d@ is /owned/ by a definition @e@ iff. @d@ is placed --- immediately under the top-most @where@ clause of @e@. A definition may have --- at most one owner. --- --- The definition hierarchy thus specifies ownership between the definitions in --- the program. There are two types of ownership: --- --- * A super node is always the owner of its sub-functions. --- --- * A sub-function may be the owner of some node definitions. --- --- Assigning nodes to sub-functions in a useful way takes some work. It is done --- by first finding out for each node which sub-functions it must be local to. --- Each locality constraint gives an upper bound on where in the definition --- hierarchy the node may be placed. There is one principle for introducing a --- locality constraint: --- --- * If node @v@ depends on the input of sub-function @f@, then @v@ must be --- local to @f@. --- --- The locality constraints for a graph can thus be found be tracing each --- sub-function input in order to find the nodes that depend on it (see function --- 'findLocalities'). In the above program, we have the sub-functions @f@ and --- @g@ with the inputs @v1@ and @v2@ respectively. We can see immediately that --- no node depends on @v1@, so we get no locality constraints for @f@. The only --- node that depends on @v2@ is @v3@, so the program has a single locality --- constraint: @v3@ is local to @g@. Nodes without constraints are simply taken --- to be local to @main@. With this information, we can now rewrite the flat --- program as --- --- > main v0 = v4 --- > where --- > v4 = f 1 --- > where --- > f v1 = v5 --- > v5 = g 2 --- > where --- > g v2 = v3 --- > where --- > v3 = v0 + v2 --- --- which is syntactically valid Haskell. Note that this program is slightly --- different from the original which defined @g@ locally to @f@. However, in --- general, we want definitions to be as \"global\" as possible in order to --- maximize sharing. For example, we don't want to put definitions in the body --- of a while loop unless they really depend on the loop state, because then --- they will (probably, depending on implementation) be recomputed in every --- iteration. Also note that in this program, it is not strictly necessary to --- have the sub-functions owned by their super nodes -- @f@ and @g@ could have --- been owned by @main@ instead. However, this would cause clashes if two --- sub-functions have the same name. Having sub-functions owned by their super --- nodes is also a way of keeping related definitions together in the program. --- --- There is one caveat with the above method. Consider the following flat --- program: --- --- > main v0 = v4 --- > f v1 = v5 --- > g v2 = v3 --- > v3 = v1 + 2 --- > v4 = f 0 --- > v5 = g 1 --- --- Here, we get the locality constraint: @v3@ is local to @f@. However, to get a --- valid definition hierarchy, we also need @v5@ to be local to @f@. This is --- because @v5@ is the owner of @g@, and the output of @g@ is local to @f@. So --- when looking for dependencies, we should let each super node depend on its --- sub-function output, /except/ for the owner of the very sub-function that is --- being traced (a function cannot be owned by itself). - -module Feldspar.Core.Graph where - - - -import qualified Data.Foldable as Fold -import Data.Function -import Data.List -import Data.Map (Map) -import qualified Data.Map as Map - -import Feldspar.Utils -import Feldspar.Core.Types - - - --- | Node identifier -type NodeId = Int - --- | Variable represented by a node id and a tuple path. For example, in a --- definition (given in Haskell syntax) --- --- > ((a,b),c) = f x --- --- the variable @b@ would be represented as @(i,[0,1])@ (where @i@ is the id of --- the @f@ node). -type Variable = (NodeId, [Int]) - --- | The source of a value is either constant data or a variable. -data Source - = Constant PrimitiveData - | Variable Variable - deriving (Eq, Show) - --- | A node in the program graph. The input is given as a 'Source' tuple. The --- output is implicitly defined by the 'nodeId' and the 'outputType'. For --- example, a node with id @i@ and output type --- --- > Tup [One ..., One ...] --- --- has the implicit output --- --- > Tup [One (i,[0]), One (i,[1])] -data Node = Node - { nodeId :: NodeId - , function :: Function - , input :: Tuple Source - , inputType :: Tuple StorableType - , outputType :: Tuple StorableType - } - deriving (Eq, Show) - --- | The interface of a (sub-)graph. The input is conceptually a --- @Tuple Variable@, but all these variables refer to the same 'Input' node, so --- it is sufficient to track the node id (the tuple shape can be inferred from --- the 'interfaceInputType'). -data Interface = Interface - { interfaceInput :: NodeId - , interfaceOutput :: Tuple Source - , interfaceInputType :: Tuple StorableType - , interfaceOutputType :: Tuple StorableType - } - deriving (Eq, Show) - --- | Node functionality -data Function - = - -- | Primary input - Input - -- | Constant array - | Array StorableData - -- | Primitive function - | Function String - -- | Non-inlined function - | NoInline String Interface - -- | Conditional - | IfThenElse Interface Interface - -- | While-loop - | While Interface Interface - -- | Parallel tiling - | Parallel Interface - deriving (Eq, Show) - --- | A graph is a list of unique nodes with an interface. -data Graph = Graph - { graphNodes :: [Node] - , graphInterface :: Interface - } - -instance Eq Graph - where - Graph ns1 iface1 == Graph ns2 iface2 - = ns1' == ns2' - && iface1 == iface2 - where - ns1' = sortBy (compare `on` nodeId) ns1 - ns2' = sortBy (compare `on` nodeId) ns2 - -- Comparison ignores order of nodes. - --- | A definition hierarchy. A hierarchy consists of number of top-level nodes, --- each one associated with its sub-functions, represented as hierarchies. The --- nodes owned by a sub-function appear as the top-level nodes in the --- corresponding hierarchy. -data Hierarchy = Hierarchy [(Node, [Hierarchy])] - --- | A graph with a hierarchical ordering of the nodes. If the hierarchy is --- flattened it should result in a valid 'Graph'. -data HierarchicalGraph = HierGraph - { graphHierarchy :: Hierarchy - , hierGraphInterface :: Interface - } - --- | A node that contains a sub-function -type SuperNode = NodeId - --- | The branch is used to distinguish between different sub-functions of the --- same super node. For example, the continue condition of a while-loop has --- branch number 0, and the body has number 1 (see 'subFunctions'). -data SubFunction = SubFunction - { sfSuper :: SuperNode - , sfBranch :: Int - , sfInput :: NodeId - , sfOutput :: [NodeId] - } - deriving (Eq, Show) - -instance Ord SubFunction - where - compare (SubFunction o1 b1 _ _) (SubFunction o2 b2 _ _) = - compare (o1,b1) (o2,b2) - -- Ignores inputs/outputs since these should be equal anyway if the super - -- and branch fields are equal. - --- | Locality constraint -data Local = Local SubFunction NodeId - deriving (Eq, Show) - - - --- | Returns the nodes in a source tuple. -sourceNodes :: Tuple Source -> [NodeId] -sourceNodes tup = [i | Variable (i,_) <- Fold.toList tup] - --- | The fanout of each node in a graph. Nodes that are not in the map are --- assumed to have no fanout. -fanout :: Graph -> Map NodeId [NodeId] -fanout graph = Map.fromListWith (++) - [ (inp, [nodeId node]) - | node <- graphNodes graph - , inp <- sourceNodes (input node) - ] - --- | Look up a node in the graph -nodeMap :: Graph -> (NodeId -> Node) -nodeMap graph = (m Map.!) - where - m = Map.fromList [(nodeId node, node) | node <- graphNodes graph] - - - --- | Lists all sub-functions in the graph. -subFunctions :: Graph -> [SubFunction] -subFunctions graph = - concat [subFun i fun | Node i fun _ _ _ <- graphNodes graph] - where - sub i branch (Interface inp outp _ _) = - SubFunction i branch inp (sourceNodes outp) - - subFun i (NoInline _ f) = [sub i 0 f] - subFun i (IfThenElse t e) = [sub i 0 t, sub i 1 e] - subFun i (While cont body) = [sub i 0 cont, sub i 1 body] - subFun i (Parallel ixf) = [sub i 0 ixf] - subFun _ _ = [] - - - --- | Lists all locality constraints of the graph. -findLocalities :: Graph -> [Local] -findLocalities graph = concatMap traceSub sfs - where - fo = fanout graph - sfs = subFunctions graph - - superLink = Map.fromListWith (++) - [(outp,[super]) | SubFunction super _ _ outps <- sfs, outp <- outps] - -- Fanout map with edges from sub-function output to super node - - traceSub sf@(SubFunction _ _ inp outps) = trace inp - where - trace a = Local sf a : concatMap trace bs - where - as = if a `elem` outps then [] else superLink !!! a - bs = (fo !!! a) ++ as - -- Computes locality constraints by tracing the dependencies of - -- sub-function inputs. - - - --- | Returns a total ordering between all super nodes in a graph, such that if --- node @v@ is local to sub-function @f@, then @v@ maps to a lower number than --- the owner of @f@. The converse is not necessarily true. The second argument --- gives the locality constraints for each node in the graph (top-level nodes --- may be left undefined). -orderSuperNodes :: Graph -> Map NodeId [SubFunction] -> Map SuperNode Int -orderSuperNodes graph locals = Map.fromList $ zip (topSort sfOrder) [0..] - where - sfOrder = Map.fromListWith (++) - [ (i, map sfSuper (locals !!! i)) - | SubFunction i _ _ _ <- subFunctions graph - ] - -- A partial ordering between all sub-functions. An edge from `f` to `g` - -- means that `f` is local to `g`. This is a representation of the actual - -- sub-function ordering which is the transitive closure of `sfOrder`. - -- `sfOrder` is a dag. - --- | Returns the minimal sub-function according to the given owner ordering. -minimalSubFun :: Map SuperNode Int -> [SubFunction] -> SubFunction -minimalSubFun ownOrd = head . sortBy (compare `on` ((ownOrd Map.!) . sfSuper)) - --- | Sorts the nodes by their id. -sortNodes :: [Node] -> [Node] -sortNodes = sortBy (compare `on` nodeId) - - - --- | Makes a hierarchical graph from a flat one. The node lists in the hierarchy --- are always sorted according to node id. -makeHierarchical :: Graph -> HierarchicalGraph -makeHierarchical graph@(Graph nodes iface) = - HierGraph (mkHierarchy topLevel) iface - where - locs = findLocalities graph - - locals :: Map NodeId [SubFunction] - locals = Map.fromListWith (++) [(i,[sf]) | Local sf i <- locs] - -- The locality constraints for each node. Nodes that are not in the map - -- have no constraints. - - owner :: Map NodeId SubFunction - owner = fmap (minimalSubFun $ orderSuperNodes graph locals) locals - -- The owner of each node. Nodes that are not in the map have no owner. - - nodeLookup :: NodeId -> Node - nodeLookup = nodeMap graph - - mkHierarchy :: [Node] -> Hierarchy - mkHierarchy nodes = Hierarchy (nodes `zip` map subHierarchies nodes) - - subFunHier :: SuperNode -> Int -> Hierarchy - subFunHier i branch = mkHierarchy nodes - where - ownedBy = fmap (sortNodes . map nodeLookup) $ invertMap owner - sf = SubFunction i branch undefined undefined - nodes = ownedBy Map.! sf - -- Defined for every sub-function, because each sub-function contains - -- at least one node (the input). - - subHierarchies :: Node -> [Hierarchy] - subHierarchies (Node i (NoInline _ _) _ _ _) = map (subFunHier i) [0] - subHierarchies (Node i (IfThenElse _ _) _ _ _) = map (subFunHier i) [0,1] - subHierarchies (Node i (While _ _) _ _ _) = map (subFunHier i) [0,1] - subHierarchies (Node i (Parallel _) _ _ _) = map (subFunHier i) [0] - subHierarchies _ = [] - - topLevel :: [Node] - topLevel = sortNodes - [ nodeLookup i - | node <- nodes - , let i = nodeId node - , Nothing <- [Map.lookup i owner] - ] - -- The nodes that don't have any owner - --------------------- --- show function --------------------- - -instance Show Graph where - show gr = prP 0 gr - -instance Show HierarchicalGraph where - show hgr = prP 0 hgr - - -class PrP a where - prP :: Int -> a -> String - -tab sc = replicate sc ' ' - -listprint :: (a->String) -> String -> [a] -> String -listprint _ _ [] = "" -listprint f _ [x] = f x -listprint f s (x:y:xs) = f x ++ s ++ listprint f s (y:xs) - -instance PrP Graph where - prP sc gr = tab sc ++ "Graph {\n" ++ tab (sc + 1) ++ "graphNodes = [\n" ++ prP (sc+2) (graphNodes gr) - ++ "],\n" ++ tab (sc + 1) ++ "graphInterface = \n" ++ tab (sc + 3) ++ show (graphInterface gr) ++ "\n}" - -instance PrP [Node] where - prP sc ns = (listprint (\n -> (tab sc ++ prP sc n)) ",\n" ns) --- prP sc [] = "" --- prP sc [node] = tab sc ++ prP sc node ++ "\n" --- prP sc (node:ns) = tab sc ++ prP sc node ++ ",\n" ++ prP sc ns - -instance PrP Node where - prP sc node = "Node {nodeId = " ++ show (nodeId node) ++ ",\n" - ++ tab (sc + 6) ++ "function = " ++ prP (sc+8) (function node) ++ ",\n" - ++ tab (sc + 6) ++ "input = " ++ show (input node) ++ ",\n" - ++ tab (sc + 6) ++ "inputType = " ++ show (inputType node) ++ ",\n" - ++ tab (sc + 6) ++ "outputType = " ++ show (outputType node) ++ "}" - -instance PrP Function where - prP sc (IfThenElse if1 if2) = "\n" ++ tab (sc+1) ++ "IfThenElse\n" ++ tab (sc+2) ++ show if1 ++ "\n" - ++ tab (sc+2) ++ show if2 - prP sc (Parallel if1) = "\n" ++ tab (sc+1) ++"Parallel " ++ "\n" ++ tab (sc+2) ++ show if1 - prP sc (While if1 if2) = "\n" ++ tab (sc+1) ++ "While\n" ++ tab (sc+2) ++ show if1 ++ "\n" - ++ tab (sc+2) ++ show if2 - prP sc (NoInline str if1) = "\n" ++ tab (sc+1) ++ "NoInline \"" ++ str ++"\" \n" ++ tab (sc+2) ++ show if1 - prP sc x = show x - -instance PrP HierarchicalGraph where - prP sc hgr = "HierGraph {\n" ++ tab (sc+1) ++ "graphHierarchy =\n" ++ tab (sc+2) ++ prP (sc+2) (graphHierarchy hgr) - ++ ",\n" ++ tab (sc+1) ++ "hierGraphInterface =\n" ++ tab (sc+2) ++ show (hierGraphInterface hgr) ++ "\n}" - -instance PrP Hierarchy where - prP sc (Hierarchy ndhrs) = "Hierarchy [\n" ++ prP (sc+1) ndhrs ++ "\n" ++ tab sc ++ "]" - -instance PrP [(Node, [Hierarchy])] where - prP sc nhrs = (listprint (prP sc) ",\n" nhrs) --- prP sc [] = "" --- prP sc [(node,hrs)] = tab sc ++ "(" ++ prP (sc+1) node ++ ",\n" ++ prP (sc+1) hrs ++ ")" --- prP sc ((node,hrs):ns) = tab sc ++ "(" ++ prP (sc+1) node ++ ",\n" ++ prP (sc+1) hrs ++ "),\n" ++ prP (sc+1) ns - -instance PrP (Node, [Hierarchy]) where - prP sc (node,hrs) = tab sc ++ "(" ++ prP (sc+1) node ++ ",\n" ++ tab sc ++ "[" ++ prP (sc+1) hrs ++ "])" - - -instance PrP [Hierarchy] where - prP sc nhrs = (listprint (prP sc) (",\n" ++ tab sc) nhrs) diff --git a/Feldspar/Core/Ref.hs b/Feldspar/Core/Ref.hs deleted file mode 100644 --- a/Feldspar/Core/Ref.hs +++ /dev/null @@ -1,98 +0,0 @@ --- --- Copyright (c) 2009-2010, ERICSSON AB All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * 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. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT HOLDER 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. --- - --- Copyright (c) 2009 Koen Claessen --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * 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. --- * Neither the name of the Koen Claessen nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT HOLDER 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. - -{-# OPTIONS_GHC -O0 #-} - --- | --- A simple implementation of \"observable sharing\". See --- --- * Koen Claessen, David Sands, --- \"/Observable sharing for functional circuit description/\", --- Asian Computing Science Conference, 1999. --- --- for more details. - -module Feldspar.Core.Ref - ( Ref - , refId - , deref - , ref - ) where - - - -import Data.Function -import Data.Unique -import System.IO.Unsafe - - - -data Ref a = Ref - { refId :: Unique - , deref :: a - } - -instance Eq (Ref a) where - (==) = (==) `on` refId - -instance Ord (Ref a) where - compare = compare `on` refId - - - -ref :: a -> Ref a -ref x = unsafePerformIO $ do - u <- newUnique - return (Ref u x) - diff --git a/Feldspar/Core/Reify.hs b/Feldspar/Core/Reify.hs deleted file mode 100644 --- a/Feldspar/Core/Reify.hs +++ /dev/null @@ -1,315 +0,0 @@ --- --- Copyright (c) 2009-2010, ERICSSON AB All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * 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. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT HOLDER 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. --- - -{-# LANGUAGE OverlappingInstances, UndecidableInstances #-} - --- | Functions for reifying expressions ('Data' / 'Expr') to graphs ('Graph') --- and to textual format. - -module Feldspar.Core.Reify - ( Program (..) - , showCore - , showCoreWithSize - , printCore - , printCoreWithSize - , runGraph - , buildSubFun - , startInfo - ) where - - - -import Control.Monad.State -import Control.Monad.Writer -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe -import Data.Unique - -import Feldspar.Core.Types -import Feldspar.Core.Ref -import Feldspar.Core.Expr -import Feldspar.Core.Graph hiding (function, Function (..), Variable) -import qualified Feldspar.Core.Graph as Graph -import Feldspar.Core.Show - - - -data Info = Info - { -- | Next id - index :: NodeId - -- | Visited references mapped to their id - , visited :: Map Unique NodeId - } - --- | Monad for making graph building easier -type Reify a = WriterT [Node] (State Info) a - -startInfo :: Info -startInfo = Info 0 Map.empty - -runGraph :: Reify a -> Info -> (a, ([Node], Info)) -runGraph graph info = (a, (nodes, info')) - where - ((a,nodes),info') = runState (runWriterT graph) info - -newIndex :: Reify NodeId -newIndex = do - info <- get - put (info {index = succ (index info)}) - return (index info) - -remember :: Data a -> NodeId -> Reify () -remember a i = modify $ \info -> - info {visited = Map.insert (dataId a) i (visited info)} - -checkNode :: Data a -> Reify (Maybe NodeId) -checkNode a = gets ((Map.lookup (dataId a)) . visited) - - - --- | Declare a node -node :: - Data a -> Graph.Function -> Tuple Source -> Tuple StorableType -> Reify () - -node a@(Data _ _) fun inTup inType = do - i <- newIndex - remember a i - tell [Node i fun inTup inType (dataType a)] - - - --- | Declare a source node (one with no inputs) -sourceNode :: Data a -> Graph.Function -> Reify () -sourceNode a fun = node a fun (Tup []) (Tup []) - -isPrimitive :: Data a -> Bool -isPrimitive a@(Data _ _) = case dataType a of - One (StorableType [] _) -> True - _ -> False - --- Creates a source. The node must have been visited. -source :: [Int] -> Data a -> Reify Source -source path a = case dataToExpr a of - - Application (Function ('g':'e':'t':'T':'u':'p':_:n:_) _) tup -> - source ((read [n] - 1) : path) tup - -- XXX This is a bit fragile... - - Value b | isPrimitive a -> - let PrimitiveData b' = storableData b - in return $ Constant b' - - _ -> do - Just i <- checkNode a - return $ Graph.Variable (i,path) - - - -traceTuple :: Data a -> Reify (Tuple Source) -traceTuple a = case dataToExpr a of - - Application (Application (Function "tup2" _) b) c -> do - b' <- traceTuple b - c' <- traceTuple c - return (Tup [b',c']) - - Application (Application (Application (Function "tup3" _) b) c) d -> do - b' <- traceTuple b - c' <- traceTuple c - d' <- traceTuple d - return (Tup [b',c',d']) - - Application (Application (Application (Application - (Function "tup4" _) b) c) d) e -> do - b' <- traceTuple b - c' <- traceTuple c - d' <- traceTuple d - e' <- traceTuple e - return (Tup [b',c',d',e']) - - _ -> liftM One (source [] a) - - - -buildGraph :: forall a . Data a -> Reify () -buildGraph a@(Data _ _) = do - ia <- checkNode a - unless (isJust ia) $ list (dataToExpr a) - where - funcNode fun inp = do - buildGraph inp - inTup <- traceTuple inp - node a fun inTup (dataType inp) - - list :: Expr a -> Reify () - - list Variable = sourceNode a Graph.Input - - list (Value b) - | isPrimitive a = return () - | otherwise = sourceNode a $ Graph.Array $ storableData b - - list (Application (Application (Function fun _) b) c) - | fun == "tup2" = buildGraph b >> buildGraph c - - list (Application (Application (Application (Function "tup3" _) b) c) d) = - buildGraph b >> buildGraph c >> buildGraph d - - list (Application (Application (Application (Application - (Function "tup4" _) b) c) d) e) = - buildGraph b >> buildGraph c >> buildGraph d >> buildGraph e - - list (Application (Function fun _) b) - | take 6 fun == "getTup" = buildGraph b - | otherwise = funcNode (Graph.Function fun) b - - -- XXX Assumes that no other kinds of function application exist. - - list (NoInline fun f b@(Data _ _)) = do - iface <- buildSubFun (deref f) - funcNode (Graph.NoInline fun iface) b - -- XXX Sub-graph is not shared at the moment. - - list (IfThenElse c t e b@(Data _ _)) = do - ifaceThen <- buildSubFun t - ifaceElse <- buildSubFun e - funcNode (Graph.IfThenElse ifaceThen ifaceElse) (tup2 c b) - - list (While cont body b@(Data _ _)) = do - ifaceCont <- buildSubFun cont - ifaceBody <- buildSubFun body - funcNode (Graph.While ifaceCont ifaceBody) b - - list (Parallel l ixf) = do - iface <- buildSubFun ixf - funcNode (Graph.Parallel iface) l - - - -buildSubFun :: forall a b . (Typeable a, Typeable b) => - (a :-> b) -> Reify Interface - -buildSubFun (Lambda _ inp outp) = do - let inType = typeOf (dataSize inp) (T::T a) - outType = typeOf (dataSize outp) (T::T b) - buildGraph inp -- Needed in case input is not used - buildGraph outp - outTup <- traceTuple outp - info <- get - let inId = visited info Map.! dataId inp - return (Interface inId outTup inType outType) - - - -reifyD :: (Typeable a, Typeable b) => (Data a -> Data b) -> Graph -reifyD f = Graph nodes iface - where - subFun = lambda universal f - (iface,(nodes,_)) = runGraph (buildSubFun subFun) startInfo - - - --- | Types that represent core language programs -class Program a - where - -- | Converts a program to a Graph - reify :: a -> Graph - - -- | Returns whether or not the program has an argument. This is needed - -- because the 'Graph' type always assumes the existence of an input. So - -- for programs without input, the 'Graph' representation will have a - -- \"dummy\" input, which is indistinguishable from a real input. - numArgs :: T a -> Int - -instance Computable a => Program a - where - reify = reify_computable - numArgs _ = 0 - -instance (Computable a, Computable b) => Program (a,b) - where - reify = reify_computable - numArgs _ = 0 - -instance (Computable a, Computable b, Computable c) => Program (a,b,c) - where - reify = reify_computable - numArgs _ = 0 - -instance (Computable a, Computable b, Computable c, Computable d) => Program (a,b,c,d) - where - reify = reify_computable - numArgs _ = 0 - -instance (Computable a, Computable b) => Program (a -> b) - where - reify = reifyD . lowerFun - numArgs = const 1 - -instance (Computable a, Computable b, Computable c) => Program (a -> b -> c) - where - reify f = reifyD $ lowerFun $ \(a,b) -> f a b - numArgs = const 2 - -instance (Computable a, Computable b, Computable c, Computable d) => Program (a -> b -> c -> d) - where - reify f = reifyD $ lowerFun $ \(a,b,c) -> f a b c - numArgs = const 3 - -instance (Computable a, Computable b, Computable c, Computable d, Computable e) => Program (a -> b -> c -> d -> e) - where - reify f = reifyD $ lowerFun $ \(a,b,c,d) -> f a b c d - numArgs = const 4 - - - -reify_computable :: forall a . Computable a => a -> Graph -reify_computable a = - reifyD (const (internalize a) :: Data () -> Data (Internal a)) - - - --- | Shows the core code generated by the program. -showCore :: forall a . Program a => a -> String -showCore = showGraph False "program" (numArgs (T::T a) > 0) . reify - --- | Shows the core code with size information as comments. -showCoreWithSize :: forall a . Program a => a -> String -showCoreWithSize = showGraph True "program" (numArgs (T::T a) > 0) . reify - --- | @printCore = putStrLn . showCore@ -printCore :: Program a => a -> IO () -printCore = putStrLn . showCore - --- | @printCoreWithSize = putStrLn . showCoreWithSize@ -printCoreWithSize :: Program a => a -> IO () -printCoreWithSize = putStrLn . showCoreWithSize - -instance Storable a => Show (Data a) where - show = showCore diff --git a/Feldspar/Core/Representation.hs b/Feldspar/Core/Representation.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Core/Representation.hs @@ -0,0 +1,323 @@ +module Feldspar.Core.Representation where + + + +import Data.List +import Data.Typeable hiding (TypeRep) + +import Data.Tagged +import Data.Proxy + +import Feldspar.DSL.Expression hiding (Eval) +import qualified Feldspar.DSL.Expression as E +import Feldspar.DSL.Lambda +import Feldspar.DSL.Sharing +import Feldspar.DSL.Network +import Feldspar.Set +import Feldspar.Core.Types + + + +-------------------------------------------------------------------------------- +-- * Feldspar expressions +-------------------------------------------------------------------------------- + +-- | Feldspar-specific expressions +data Feldspar role a + where + Literal :: (Type a, MetaType () a) => a -> Feldspar (Out ()) a + + Function :: (Typeable (a -> b), MetaType () b) => + String -> (a -> b) -> Feldspar (In ra -> Out ()) (a -> b) + + Pair :: (Type a, Type b, MetaType () (a,b)) => Feldspar (In () -> In () -> Out ()) (a -> b -> (a,b)) + + Condition :: MetaType ra a => Feldspar + (In () -> In ra -> In ra -> Out ra) + (Bool -> a -> a -> a) + + Parallel :: (Type a, MetaType () [a]) => Feldspar + (In () -> (Out () -> In ()) -> In () -> Out ()) + (Length -> (Index -> a) -> [a] -> [a]) + + Sequential :: (Type a, MetaType () [a], MetaType rst st) => Feldspar + (In () -> In rst -> (Out () -> Out rst -> In ((),rst)) -> (Out rst -> In ()) -> Out ()) + (Length -> st -> (Index -> st -> (a,st)) -> (st -> [a]) -> [a]) + + ForLoop :: MetaType rst st => Feldspar + (In () -> In rst -> (Out () -> Out rst -> In rst) -> Out rst) + (Length -> st -> (Index -> st -> st) -> st) + + NoInline :: MetaType rb b => + String -> Feldspar ((Out ra -> In rb) -> (In ra -> Out rb)) ((a -> b) -> (a -> b)) + + SetLength :: Type a => + Feldspar (In () -> In () -> Out ()) (Length -> [a] -> [a]) + + SetIx :: (Type a) => Feldspar + (In () -> In () -> In () -> Out ()) + (Index -> a -> [a] -> [a]) + +-- TODO Missing support for writing to several indices at once in 'Parallel' and +-- 'Sequential'. + + + +instance ExprEq Feldspar + where + exprEq (Literal a) (Literal b) = eqLiteral a b + exprEq (Function n1 f1) (Function n2 f2) = n1==n2 && sameType f1 f2 + exprEq Pair Pair = True + exprEq Condition Condition = True + exprEq Parallel Parallel = True + exprEq Sequential Sequential = True + exprEq ForLoop ForLoop = True + exprEq (NoInline n1) (NoInline n2) = n1 == n2 + exprEq SetLength SetLength = True + exprEq SetIx SetIx = True + exprEq _ _ = False + -- Note that functions are only compared by name. + +eqLiteral :: (Typeable a, Typeable b, Eq b) => a -> b -> Bool +eqLiteral a b = case cast a of + Just a' -> a'==b + _ -> False + +sameType :: forall a b . (Typeable a, Typeable b) => a -> b -> Bool +sameType a b = case cast a :: Maybe b of + Nothing -> False + _ -> True + +instance E.Eval Feldspar + where + eval (Literal a) = a + eval (Function _ f) = f + eval Pair = (,) + eval Condition = \cond t e -> if cond then t else e + eval Parallel = evalParallel + eval Sequential = evalSequential + eval ForLoop = evalForLoop + eval (NoInline _) = id + eval SetLength = evalSetLength + eval SetIx = evalSetIx + +evalParallel :: Length -> (Index -> a) -> [a] -> [a] +evalParallel 0 _ cont = cont +evalParallel l ixf cont = map ixf [0 .. l-1] ++ cont + -- Need a special case for l==0 because 0-1 is a huge number + +evalSequential :: Length -> st -> (Index -> st -> (a,st)) -> (st -> [a]) -> [a] +evalSequential l init step cont = start ++ cont st' + where + (st',start) = mapAccumL evalStep init [0 .. l-1] + evalStep st i = (st',a) where (a,st') = step i st + +evalForLoop :: Length -> st -> (Index -> st -> st) -> st +evalForLoop 0 init body = init +evalForLoop l init body = foldl (flip body) init [0 .. l-1] + -- Need a special case for l==0 because 0-1 is a huge number + +evalSetLength :: Length -> [a] -> [a] +evalSetLength 0 as = [] +evalSetLength l (a:as) = a : evalSetLength (l-1) as +evalSetLength _ _ = error "setLength: reading past the end of an array" + +evalSetIx :: Index -> a -> [a] -> [a] +evalSetIx i v as | i < len = genericTake i as ++ [v] ++ genericDrop (i+1) as + | otherwise = error $ "setIx: assigning index (" ++ show i ++ + ") past the end of an array of length " ++ + show len + where len = genericLength as + +instance ExprShow Feldspar + where + exprShow (Literal a) = show a + exprShow (Function fun _) = fun + exprShow Pair = "pair" + exprShow Condition = "condition" + exprShow Parallel = "parallel" + exprShow Sequential = "sequential" + exprShow ForLoop = "forLoop" + exprShow (NoInline n) = "noinline " ++ show n + exprShow SetLength = "setLength" + exprShow SetIx = "setIx" + + +-------------------------------------------------------------------------------- +-- * Feldspar networks +-------------------------------------------------------------------------------- + +-- | A wrapper around 'Size' to make it look like an expression. The 'Type' +-- constraint ensures that edges in a 'FeldNetwork' always have supported types. +data EdgeSize role a = (Type a, Eq (Size a), Show (Size a)) => + EdgeSize { edgeSize :: Size a } + +instance ExprShow EdgeSize + where + exprShow (EdgeSize a) = show a + +instance Eq (Size a) => Eq (EdgeSize role a) where + EdgeSize sz1 == EdgeSize sz2 = sz1 == sz2 + +instance Type a => Set (EdgeSize role a) + where + empty = EdgeSize empty + universal = EdgeSize universal + EdgeSize sz1 \/ EdgeSize sz2 = EdgeSize (sz1 \/ sz2) + EdgeSize sz1 /\ EdgeSize sz2 = EdgeSize (sz1 /\ sz2) + +-- | 'Network' of 'Feldspar' expressions +type FeldNetwork = Network EdgeSize Feldspar + +-- | A Feldspar program computing a value of type @a@ +newtype Data a = Data { unData :: FeldNetwork (In ()) a } + deriving (Eq) + +instance Show (Data a) + where + show = show . unData + +instance EdgeInfo (Data a) + where + type Info (Data a) = EdgeSize () a + edgeInfo = edgeInfo . unData + +instance Type a => MultiEdge (Data a) Feldspar EdgeSize + where + type Role (Data a) = () + type Internal (Data a) = a + toEdge = toEdge . unData + fromInEdge = Data . fromInEdge + fromOutEdge info = Data . fromOutEdge info + + + +-- | 'Syntactic' is a specialization of the 'MultiEdge' class for 'Feldspar' +-- programs. +class + ( MultiEdge a Feldspar EdgeSize + , Set (Info a) + , Type (Internal a) + , MetaType (Role a) (Internal a) + ) => Syntactic a + +-- TODO There is something strange with the constraint Type (Internal a). It is +-- really only needed when Role a ~ (), but it accidentally works to have +-- this constraint for all Syntactic types. + +instance Type a => Syntactic (Data a) +instance (Syntactic a, Syntactic b) => Syntactic (a,b) +instance (Syntactic a, Syntactic b, Syntactic c) => Syntactic (a,b,c) +instance (Syntactic a, Syntactic b, Syntactic c, Syntactic d) => Syntactic (a,b,c,d) + + + +edgeType :: forall a . EdgeSize () a -> TypeRep +edgeType (EdgeSize sz) = typeRep (Tagged sz :: Tagged a (Size a)) + +dataSize :: Type a => Data a -> Size a +dataSize = edgeSize . edgeInfo . unData + +dataNode :: Data a -> FeldNetwork (Out ()) a +dataNode = undoEdge . unData + +nodeData :: Type a => Size a -> FeldNetwork (Out ()) a -> Data a +nodeData sz = fromOutEdge (EdgeSize sz) + +getInfo :: Syntactic a => a -> Info a +getInfo = edgeInfo + +resizeData :: Type a => Size a -> Data a -> Data a +resizeData sz = nodeData sz . dataNode + +variable :: Syntactic a => Info a -> Ident -> a +variable info = fromOutEdge info . Variable + +lambda :: (Syntactic a, Syntactic b) + => Info a + -> (a -> b) + -> FeldNetwork (Out (Role a) -> In (Role b)) (Internal a -> Internal b) +lambda info f = Lambda (toEdge . f . fromOutEdge info) + +-- | Forcing computation +force :: Syntactic a => a -> a +force = edgeCast + +-- | Evaluation of Feldspar programs +eval :: Syntactic a => a -> Internal a +eval = E.eval . toEdge + +-- | Yield the value of a constant program. If the value is not known +-- statically, the result is 'Nothing'. +viewLiteral :: Syntactic a => a -> Maybe (Internal a) +viewLiteral = mapEdge (\_ a -> lit (undoEdge a)) . toEdge + where + lit :: FeldNetwork (Out ()) a -> Maybe a + lit (Inject (Node (Literal a))) = Just a + lit _ = Nothing + +metaTypes :: forall a ra expr . + MetaType ra a => expr (Out ra) a -> [([Int], TypeRep)] +metaTypes _ = listTypes [] (Proxy :: Proxy ra) (Proxy :: Proxy a) + +-- | List the types of the results produced by a 'Feldspar' expression +resTypes :: FeldNetwork ra a -> [([Int], TypeRep)] -- TODO Should use (Out ra) +resTypes a = case a of + Inject (Node (Literal _)) -> metaTypes a + Inject (Node (Function _ _)) :$: _ -> metaTypes a + Inject (Node Pair) :$: _ :$: _ -> metaTypes a + Inject (Node Condition) :$: _ :$: _ :$: _ -> metaTypes a + Inject (Node Parallel) :$: _ :$: _ :$: _ -> metaTypes a + Inject (Node Sequential) :$: _ :$: _ :$: _ :$: _ -> metaTypes a + Inject (Node ForLoop) :$: _ :$: _ :$: _ -> metaTypes a + Inject (Node (NoInline n)) :$: _ :$: _ -> metaTypes a + Inject (Node SetLength) :$: _ :$: _ -> metaTypes a + Inject (Node SetIx) :$: _ :$: _ :$: _ -> metaTypes a + Let _ :$: _ :$: (Lambda f) -> resTypes (f ph) + _ -> error $ "Representation.resTypes: " ++ show a + +isMulti :: FeldNetwork ra a -> Bool +isMulti a = isNode a && (length (resTypes a) > 1) + +isElem :: FeldNetwork ra a -> Bool +isElem (Inject (Node (Function "(!)" _)) :$: _) = True +isElem _ = False + +isSelector :: FeldNetwork ra a -> Bool +isSelector (Inject (Node (Function fun _)) :$: _) = + fun `elem` ["getFst","getSnd"] +isSelector _ = False + +isArrayLit :: FeldNetwork ra a -> Bool +isArrayLit (Inject (Node (Literal a))) + | ArrayData as <- dataRep a = True +isArrayLit _ = False + +isEmpty :: FeldNetwork ra a -> Bool +isEmpty (Inject (Node (Literal a))) + | ArrayData as <- dataRep a = length as == 0 +isEmpty _ = False + +feldSharing :: (Typeable ra, Typeable a) => FeldNetwork ra a -> FeldNetwork ra a +feldSharing = sharing Params + { necessary = \(SomeLam a) -> isNode a && not (isFunction a || isVar a || isElem a || isSelector a) + , sufficient = \(SomeLam a) -> isMulti a + , sharingPoint = \(SomeLam a) -> not (isFunction a) + -- To avoid introducing 'Let' in the middle of a nested lambda (e.g. the + -- body of a 'ForLoop') + } + +showExprTree :: Syntactic a => a -> String +showExprTree = showLamTree . feldSharing . toEdge + +showExprTree2 :: (Syntactic a, Syntactic b) => (a -> b) -> String +showExprTree2 = showLamTree . feldSharing . lambda universal + -- TODO Only temporary... + +drawExpr :: Syntactic a => a -> IO () +drawExpr = drawLambda . feldSharing . toEdge + +drawExpr2 :: (Syntactic a, Syntactic b) => (a -> b) -> IO () +drawExpr2 = drawLambda . feldSharing . lambda universal + -- TODO Only temporary... + diff --git a/Feldspar/Core/Show.hs b/Feldspar/Core/Show.hs deleted file mode 100644 --- a/Feldspar/Core/Show.hs +++ /dev/null @@ -1,207 +0,0 @@ --- --- Copyright (c) 2009-2010, ERICSSON AB All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * 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. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT HOLDER 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. --- - --- | Defines a function 'showGraph' for showing core language graphs as Haskell --- code. - -module Feldspar.Core.Show where - - - -import Control.Monad -import Data.List - -import Feldspar.Utils -import Feldspar.Haskell -import Feldspar.Core.Types -import Feldspar.Core.Graph - - - -instance HaskellValue Variable - where - haskellValue (i,path) = "v" ++ intercalate "_" (map show (i:path)) - -instance HaskellValue Source - where - haskellValue (Constant a) = haskellValue a - haskellValue (Variable v) = haskellValue v - --- | Creates a tuple pattern of the given type, for the output of the given --- node. -tupPatt :: Tuple StorableType -> NodeId -> Tuple Variable -tupPatt tup i = fmap (\path -> (i,path)) (tuplePath tup) - --- | Matches the string against @\"(...)\"@, and returns @Just ...@ if possible, --- otherwise @Nothing@. -viewBinOp :: String -> Maybe String -viewBinOp "" = Nothing -viewBinOp op - | length op < 2 = Nothing - | (head op == '(') && (last op == ')') = Just $ tail $ init op - | otherwise = Nothing - - - -sizeComment :: Tuple StorableType -> String -sizeComment typ = case size of - "" -> "" - _ -> " -- Size: " ++ size - where - size = showTuple (fmap showStorableSize typ) - - - --- | Shows a single node. -showNode :: Bool -> Node -> [Hierarchy] -> String - -showNode _ (Node i Input inp inType outType) subHiers = "" - -showNode showSize (Node i fun inp inType outType) subHiers - | showSize = appendFirstLine (sizeComment outType) (showNd fun) - | otherwise = showNd fun - where - outp = tupPatt outType i - - showSF' = showSF showSize - - showNd Input = "" - showNd (Array a) = ((i,[])::Variable) -=- a - - showNd (Function fun) - | Just op <- viewBinOp fun = outp -=- opApp op a b - where - Tup [a,b] = inp - - showNd (Function fun) = outp -=- fun -$- inp - - showNd (NoInline fun iface) = - outp -=- fun -$- inp - `local` - showSF' (head subHiers) fun subInp subOutp - where - subInp = tupPatt inType $ interfaceInput iface - subOutp = interfaceOutput iface - - showNd (IfThenElse ifaceThen ifaceElse) = - outp -=- ifExpr - `local` - (thenBranch ++ newline ++ elseBranch) - where - Tup [One cond, a] = inp - Tup [_, aType] = inType - [thenHier,elseHier] = subHiers - - ifExpr = ifThenElse cond - ("thenBranch" -$- a) - ("elseBranch" -$- a) - - subInpThen = tupPatt aType $ interfaceInput ifaceThen - subInpElse = tupPatt aType $ interfaceInput ifaceElse - subOutpThen = interfaceOutput ifaceThen - subOutpElse = interfaceOutput ifaceElse - - thenBranch = showSF' thenHier "thenBranch" subInpThen subOutpThen - elseBranch = showSF' elseHier "elseBranch" subInpElse subOutpElse - - showNd (While ifaceCont ifaceBody) = - outp -=- "while" -$- "cont" -$- "body" -$- inp - `local` - (contBranch ++ newline ++ bodyBranch) - where - [contHier,bodyHier] = subHiers - - subInpCont = tupPatt inType $ interfaceInput ifaceCont - subInpBody = tupPatt inType $ interfaceInput ifaceBody - subOutpCont = interfaceOutput ifaceCont - subOutpBody = interfaceOutput ifaceBody - - contBranch = showSF' contHier "cont" subInpCont subOutpCont - bodyBranch = showSF' bodyHier "body" subInpBody subOutpBody - - showNd (Parallel iface) = - outp -=- "parallel" -$- inp -$- "ixf" - `local` - showSF' (head subHiers) "ixf" subInp subOutp - where - subInp = tupPatt inType $ interfaceInput iface - subOutp = interfaceOutput iface - - - --- | @showSubFun showSize hier name inp outp@: --- --- Shows a sub-function named @name@ represented by the hierarchy @hier@. If --- @inp@ is @Nothing@, it will be shown as a definition without an argument. --- @showSize@ decides whether or not to show size comments. -showSubFun - :: (HaskellValue inp, HaskellValue outp) - => Bool - -> Hierarchy - -> String - -> Maybe inp - -> outp - -> String - -showSubFun showSize (Hierarchy nodes) name inp outp = - funHead inp -=- outp - `local` - unlinesNoTrail (filter (not.null) $ map (uncurry (showNode showSize)) nodes) - where - funHead Nothing = name - funHead (Just inp) = name -$- inp - - - --- | @showSF showSize hier name inp = showSubFun showSize hier name (Just inp)@ -showSF - :: (HaskellValue inp, HaskellValue outp) - => Bool - -> Hierarchy - -> String - -> inp - -> outp - -> String - -showSF showSize hier name inp = showSubFun showSize hier name (Just inp) - - - --- | Shows a graph. The given string is the name of the top-level function. The --- Boolean tells whether the graph has a real or a dummy argument. A graphs with --- that has a dummy argument will be shown as a definition without an argument. --- Of course, this assumes that a dummy argument is not used within the graph. -showGraph :: Bool -> String -> Bool -> Graph -> String -showGraph showSize name hasArg graph@(Graph nodes iface) = - showSubFun showSize hier name inp' outp - where - hier = graphHierarchy $ makeHierarchical graph - inp = tupPatt (interfaceInputType iface) (interfaceInput iface) - inp' = guard hasArg >> Just inp - outp = interfaceOutput iface - diff --git a/Feldspar/Core/Trace.hs b/Feldspar/Core/Trace.hs deleted file mode 100644 --- a/Feldspar/Core/Trace.hs +++ /dev/null @@ -1,38 +0,0 @@ --- --- Copyright (c) 2009-2010, ERICSSON AB All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * 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. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT HOLDER 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. --- - -module Feldspar.Core.Trace where - - -import Feldspar.Core.Expr -import Feldspar.Core.Types - - - -trace :: (Storable a) => Int -> Data a -> Data a -trace label = function2 "trace" (const id) (const id) $ value label diff --git a/Feldspar/Core/Types.hs b/Feldspar/Core/Types.hs --- a/Feldspar/Core/Types.hs +++ b/Feldspar/Core/Types.hs @@ -1,456 +1,314 @@ --- --- Copyright (c) 2009-2010, ERICSSON AB All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * 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. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT HOLDER 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. --- - -{-# LANGUAGE UndecidableInstances #-} - --- | Defines types and classes for the data computed by "Feldspar" programs. - module Feldspar.Core.Types where -import Control.Applicative -import Data.Char -import Data.Foldable (Foldable) -import qualified Data.Foldable as Fold -import Data.Monoid -import Data.Traversable (Traversable, traverse) - +import Data.Bits +import Data.Complex import Data.Int +import Data.List +import Data.Tagged +import Data.Proxy +import Data.Typeable (Typeable) import Data.Word -import Data.Bits -import Feldspar.Utils -import Feldspar.Haskell +import Feldspar.Set import Feldspar.Range --- * Misc. - --- | Used to pass a type to a function without using 'undefined'. -data T a = T - -mkT :: a -> T a -mkT _ = T - - +-------------------------------------------------------------------------------- +-- * Heterogenous lists +-------------------------------------------------------------------------------- -- | Heterogeneous list data a :> b = a :> b - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show) infixr 5 :> -instance (Monoid a, Monoid b) => Monoid (a :> b) - where - mempty = mempty :> mempty - - (a1:>b1) `mappend` (a2:>b2) = (a1 `mappend` a2) :> (b1 `mappend` b2) - - - -class Set a - where - universal :: a - -instance Set () - where - universal = () - -instance Ord a => Set (Range a) - where - universal = fullRange - instance (Set a, Set b) => Set (a :> b) where + empty = empty :> empty universal = universal :> universal - -instance (Set a, Set b) => Set (a,b) - where - universal = (universal,universal) - -instance (Set a, Set b, Set c) => Set (a,b,c) - where - universal = (universal,universal,universal) - -instance (Set a, Set b, Set c, Set d) => Set (a,b,c,d) - where - universal = (universal,universal,universal,universal) + (a1:>a2) \/ (b1:>b2) = (a1 \/ b1) :> (a2 \/ b2) + (a1:>a2) /\ (b1:>b2) = (a1 /\ b1) :> (a2 /\ b2) -type Length = Int - +-------------------------------------------------------------------------------- +-- * Integers +-------------------------------------------------------------------------------- +-- | Platform-independent unsigned integers +newtype DefaultWord = DefaultWord Word32 + deriving (Eq, Ord, Num, Enum, Real, Integral, Bits, Bounded, Typeable) + -- TODO Find better name --- * Tuples +-- | Platform-independent signed integers +newtype DefaultInt = DefaultInt Int32 + deriving (Eq, Ord, Num, Enum, Real, Integral, Bits, Bounded, Typeable) + -- TODO Find better name --- | Untyped representation of nested tuples -data Tuple a - = One a - | Tup [Tuple a] - deriving (Eq, Show) +-- TODO Should really be defined as: +-- +-- data DefaultWord +-- = DefWord32 Word32 +-- | DefWord16 Word16 +-- +-- data DefaultInt +-- = DefInt32 Int32 +-- | DefInt16 Int16 -instance Functor Tuple - where - fmap f (One a) = One (f a) - fmap f (Tup as) = Tup $ map (fmap f) as - -- XXX Can be derived in GHC 6.12 +type Length = DefaultWord +type Index = DefaultWord -instance Foldable Tuple +instance Show DefaultWord where - foldr f x (One a) = f a x - foldr f x (Tup as) = Fold.foldr (flip $ Fold.foldr f) x as - -- XXX Can be derived in GHC 6.12 + show (DefaultWord a) = show a -instance Traversable Tuple +instance Show DefaultInt where - traverse f (One a) = pure One <*> f a - traverse f (Tup as) = pure Tup <*> traverse (traverse f) as - -- XXX Can be derived in GHC 6.12 + show (DefaultInt a) = show a -instance HaskellType a => HaskellType (Tuple a) - where - haskellType = showTuple . fmap haskellType +-- | The set of signed integer types +class Signed a -instance HaskellValue a => HaskellValue (Tuple a) - where - haskellValue = showTuple . fmap haskellValue +instance Signed Int8 +instance Signed Int16 +instance Signed Int32 +instance Signed DefaultInt --- | Shows a nested tuple in Haskell's tuple syntax (e.g @\"(a,(b,c))\"@). -showTuple :: Tuple String -> String -showTuple (One a) = a -showTuple (Tup as) = showSeq "(" (map showTuple as) ")" - --- | Replaces each element by its path in the tuple tree. For example: --- --- > tuplePath (Tup [One 'a',Tup [One 'b', One 'c']]) --- > == --- > Tup [One [0],Tup [One [1,0],One [1,1]]] -tuplePath :: Tuple a -> Tuple [Int] -tuplePath tup = path [] tup - where - path pth (One _) = One pth - path pth (Tup as) = Tup [path (pth++[n]) a | (a,n) <- as `zip` [0..]] - - +-------------------------------------------------------------------------------- +-- * Type/data representation +-------------------------------------------------------------------------------- --- * Data +-- | Representation of types +data TypeRep + = BoolType + | forall a . (BoundedInt a, Typeable a) => IntType { intRange :: Range a } + | FloatType + | UserType String + | ComplexType TypeRep + | ArrayType (Range Length) TypeRep + | StructType [TypeRep] --- | Untyped representation of primitive data -data PrimitiveData - = UnitData () - | BoolData Bool - | IntData Integer +-- | Representation of data +data DataRep + = BoolData Bool + | IntData Integer | FloatData Float - deriving (Eq, Show) - --- | Untyped representation of storable data (arrays of primitive data) -data StorableData - = PrimitiveData PrimitiveData - | StorableData [StorableData] - deriving (Eq, Show) - -instance HaskellValue PrimitiveData - where - haskellValue (UnitData a) = show a - haskellValue (BoolData a) = map toLower (show a) - haskellValue (IntData a) = show a - haskellValue (FloatData a) = show a + | ComplexData DataRep DataRep + | ArrayData [DataRep] + | StructData [DataRep] + deriving (Eq, Show) -instance HaskellValue StorableData +class (Eq a, Show a, Typeable a, Eq (Size a), Show (Size a), Set (Size a)) => Type a where - haskellValue (PrimitiveData a) = haskellValue a - haskellValue (StorableData as) = showSeq "[" (map haskellValue as) "]" - - - --- * Types + type Size a -type Unsigned32 = Word32 -type Signed32 = Int32 -type Unsigned16 = Word16 -type Signed16 = Int16 -type Unsigned8 = Word8 -type Signed8 = Int8 + dataRep :: a -> DataRep --- | Representation of primitive types -data PrimitiveType - = UnitType - | BoolType - | IntType { signed :: Bool, bitSize :: Int, valueSet :: (Range Integer) } - | FloatType (Range Float) - | UserType String - deriving (Eq, Show) + -- | Gives the type representation of a storable value. + typeRep :: Tagged a (Size a) -> TypeRep --- | Representation of storable types (arrays of primitive types). Array size is --- given as a list of ranged lengths, starting with outermost array level. --- Primitive types are treated as zero-dimensional arrays. -data StorableType = StorableType [Range Length] PrimitiveType - deriving (Eq, Show) + -- | Gives the size of a storable value. + sizeOf :: a -> Size a -instance HaskellType PrimitiveType +instance Type () where - haskellType UnitType = "()" - haskellType BoolType = "Bool" - haskellType (IntType True 32 _) = "Int32" - haskellType (IntType False 32 _) = "Word32" - haskellType (IntType True 16 _) = "Int16" - haskellType (IntType False 16 _) = "Word16" - haskellType (IntType True 8 _) = "Int8" - haskellType (IntType False 8 _) = "Word8" - haskellType (FloatType _) = "Float" - haskellType (UserType t) = t + type Size () = () + dataRep _ = BoolData False + typeRep _ = BoolType + sizeOf _ = () -instance HaskellType StorableType +instance Type Bool where - haskellType (StorableType ls t) = arrType - where - d = length ls - arrType = replicate d '[' ++ haskellType t ++ replicate d ']' - -showPrimitiveRange :: PrimitiveType -> String -showPrimitiveRange (IntType _ _ r) = showRange r -showPrimitiveRange (FloatType r) = showRange r -showPrimitiveRange _ = "" - --- | Shows the size of a storable type. -showStorableSize :: StorableType -> String -showStorableSize (StorableType ls t) = - showSeq "" (map (showBound . upperBound) ls) "" ++ showPrimitiveRange t - - - -{-# DEPRECATED Primitive "The class Primitive will be removed. Use Storable instead." #-} --- | Primitive types -class Storable a => Primitive a -instance Storable a => Primitive a + type Size Bool = () + dataRep = BoolData + typeRep _ = BoolType + sizeOf _ = () --- | Storable types (zero- or higher-level arrays of primitive data). -class Typeable a => Storable a +instance Type Word8 where - -- | Converts a storable value to its untyped representation. - storableData :: a -> StorableData - - -- | Gives the type representation of a storable value. - storableType :: Size a -> T a -> StorableType - - -- | Gives the size of a storable value. - storableSize :: a -> Size a - - listSize :: T a -> Size a -> [Range Length] - -- XXX Could be put in a separate class without the (T a). + type Size Word8 = Range Word8 + dataRep = IntData . toInteger + typeRep = IntType . untag + sizeOf a = singletonRange a -instance Storable () +instance Type Int8 where - storableData = PrimitiveData . UnitData - storableType _ _= StorableType [] UnitType - storableSize _ = () - listSize _ _ = [] + type Size Int8 = Range Int8 + dataRep = IntData . toInteger + typeRep = IntType . untag + sizeOf a = singletonRange a -instance Storable Bool +instance Type Word16 where - storableData = PrimitiveData . BoolData - storableType _ _ = StorableType [] BoolType - storableSize _ = () - listSize _ _ = [] + type Size Word16 = Range Word16 + dataRep = IntData . toInteger + typeRep = IntType . untag + sizeOf a = singletonRange a --- XXX Assumes 32 bits which is not necessarily correct -instance Storable Int +instance Type Int16 where - storableData = PrimitiveData . IntData . toInteger - storableType s _ = StorableType [] $ IntType True 32 s - storableSize a = singletonRange $ toInteger a - listSize _ _ = [] + type Size Int16 = Range Int16 + dataRep = IntData . toInteger + typeRep = IntType . untag + sizeOf a = singletonRange a -instance Storable Unsigned32 +instance Type Word32 where - storableData = PrimitiveData . IntData . toInteger - storableType s _ = StorableType [] $ IntType False 32 s - storableSize a = singletonRange $ toInteger a - listSize _ _ = [] + type Size Word32 = Range Word32 + dataRep = IntData . toInteger + typeRep = IntType . untag + sizeOf a = singletonRange a -instance Storable Signed32 +instance Type Int32 where - storableData = PrimitiveData . IntData . toInteger - storableType s _ = StorableType [] $ IntType True 32 s - storableSize a = singletonRange $ toInteger a - listSize _ _ = [] + type Size Int32 = Range Int32 + dataRep = IntData . toInteger + typeRep = IntType . untag + sizeOf a = singletonRange a -instance Storable Unsigned16 +instance Type DefaultWord where - storableData = PrimitiveData . IntData . toInteger - storableType s _ = StorableType [] $ IntType False 16 s - storableSize a = singletonRange $ toInteger a - listSize _ _ = [] + type Size DefaultWord = Range DefaultWord + dataRep = IntData . toInteger + typeRep = IntType . untag + sizeOf a = singletonRange a -instance Storable Signed16 +instance Type DefaultInt where - storableData = PrimitiveData . IntData . toInteger - storableType s _ = StorableType [] $ IntType True 16 s - storableSize a = singletonRange $ toInteger a - listSize _ _ = [] + type Size DefaultInt = Range DefaultInt + dataRep = IntData . toInteger + typeRep = IntType . untag + sizeOf a = singletonRange a -instance Storable Unsigned8 +instance Type Float where - storableData = PrimitiveData . IntData . toInteger - storableType s _ = StorableType [] $ IntType False 8 s - storableSize a = singletonRange $ toInteger a - listSize _ _ = [] + type Size Float = () + dataRep = FloatData + typeRep _ = FloatType + sizeOf _ = () -instance Storable Signed8 +instance (Type a, RealFloat a) => Type (Complex a) + -- 'RealFloat' comes from the constraint on the 'Complex' data type. It + -- implies 'Floating' where - storableData = PrimitiveData . IntData . toInteger - storableType s _ = StorableType [] $ IntType True 8 s - storableSize a = singletonRange $ toInteger a - listSize _ _ = [] + type Size (Complex a) = () + dataRep (r :+ i) = ComplexData (dataRep r) (dataRep i) + typeRep sz = ComplexType $ typeRep (Tagged universal :: Tagged a (Size a)) + sizeOf _ = () -instance Storable Float +instance Type a => Type [a] where - storableData = PrimitiveData . FloatData - storableType s _ = StorableType [] $ FloatType s - storableSize a = singletonRange a - listSize _ _ = [] + type Size [a] = Range Length :> Size a + dataRep as = ArrayData (map dataRep as) + typeRep (Tagged (l:>sz)) = ArrayType l (typeRep sz') + where + sz' = Tagged sz :: Tagged a (Size a) + sizeOf as = singletonRange (genericLength as) :> unions (map sizeOf as) -instance Storable a => Storable [a] +instance (Type a, Type b) => Type (a,b) where - storableData = StorableData . map storableData - - storableType (l:>ls) _ = StorableType (l:ls') t + type Size (a,b) = (Size a, Size b) + dataRep (a,b) = StructData [dataRep a, dataRep b] + typeRep (Tagged (sza,szb)) = StructType [typeRep sza', typeRep szb'] where - StorableType ls' t = storableType ls (T::T a) - - storableSize as = - singletonRange (length as) :> mconcat (map storableSize as) - - listSize _ (l:>ls) = l : listSize (T::T a) ls - - + sza' = Tagged sza :: Tagged a (Size a) + szb' = Tagged szb :: Tagged b (Size b) + sizeOf (a,b) = (sizeOf a, sizeOf b) -class (Eq a, Monoid (Size a), Set (Size a)) => Typeable a +instance (Type a, Type b, Type c) => Type (a,b,c) where - -- | This type provides the necessary extra information to compute a type - -- representation @`Tuple` `StorableType`@ from a type @a@. This is needed - -- because the type @a@ is missing information about sizes of arrays and - -- primitive values. - type Size a - - -- | Gives the type representation of a storable value. - typeOf :: Size a -> T a -> Tuple StorableType + type Size (a,b,c) = (Size a, Size b, Size c) + dataRep (a,b,c) = StructData [dataRep a, dataRep b, dataRep c] + typeRep (Tagged (sza,szb,szc)) = StructType [typeRep sza', typeRep szb', typeRep szc'] + where + sza' = Tagged sza :: Tagged a (Size a) + szb' = Tagged szb :: Tagged b (Size b) + szc' = Tagged szc :: Tagged c (Size c) + sizeOf (a,b,c) = (sizeOf a, sizeOf b, sizeOf c) -instance Typeable () +instance (Type a, Type b, Type c, Type d) => Type (a,b,c,d) where - type Size () = () - typeOf = typeOfStorable + type Size (a,b,c,d) = (Size a, Size b, Size c, Size d) + dataRep (a,b,c,d) = StructData [dataRep a, dataRep b, dataRep c, dataRep d] + typeRep (Tagged (sza,szb,szc,szd)) = StructType [typeRep sza', typeRep szb', typeRep szc', typeRep szd'] + where + sza' = Tagged sza :: Tagged a (Size a) + szb' = Tagged szb :: Tagged b (Size b) + szc' = Tagged szc :: Tagged c (Size c) + szd' = Tagged szd :: Tagged d (Size d) + sizeOf (a,b,c,d) = (sizeOf a, sizeOf b, sizeOf c, sizeOf d) -instance Typeable Bool +-- TODO Document +class MetaType role a where - type Size Bool = () - typeOf = typeOfStorable + listTypes :: [Int] -> Proxy role -> Proxy a -> [([Int], TypeRep)] -instance Typeable Int +instance Type a => MetaType () a where - type Size Int = Range Integer - typeOf = typeOfStorable + listTypes path _ _ = + [(path, typeRep (Tagged universal :: Tagged a (Size a)))] -instance Typeable Unsigned32 +instance (MetaType ra a, MetaType rb b) => MetaType (ra,rb) (a,b) where - type Size Unsigned32 = Range Integer - typeOf = typeOfStorable + listTypes path _ _ + = listTypes (1:path) (Proxy :: Proxy ra) (Proxy :: Proxy a) + ++ listTypes (2:path) (Proxy :: Proxy rb) (Proxy :: Proxy b) -instance Typeable Signed32 +instance (MetaType ra a, MetaType rb b, MetaType rc c) => + MetaType (ra,rb,rc) (a,b,c) where - type Size Signed32 = Range Integer - typeOf = typeOfStorable + listTypes path _ _ + = listTypes (1:path) (Proxy :: Proxy ra) (Proxy :: Proxy a) + ++ listTypes (2:path) (Proxy :: Proxy rb) (Proxy :: Proxy b) + ++ listTypes (3:path) (Proxy :: Proxy rc) (Proxy :: Proxy c) -instance Typeable Unsigned16 +instance (MetaType ra a, MetaType rb b, MetaType rc c, MetaType rd d) => + MetaType (ra,rb,rc,rd) (a,b,c,d) where - type Size Unsigned16 = Range Integer - typeOf = typeOfStorable + listTypes path _ _ + = listTypes (1:path) (Proxy :: Proxy ra) (Proxy :: Proxy a) + ++ listTypes (2:path) (Proxy :: Proxy rb) (Proxy :: Proxy b) + ++ listTypes (3:path) (Proxy :: Proxy rc) (Proxy :: Proxy c) + ++ listTypes (4:path) (Proxy :: Proxy rd) (Proxy :: Proxy d) -instance Typeable Signed16 - where - type Size Signed16 = Range Integer - typeOf = typeOfStorable -instance Typeable Unsigned8 - where - type Size Unsigned8 = Range Integer - typeOf = typeOfStorable -instance Typeable Signed8 - where - type Size Signed8 = Range Integer - typeOf = typeOfStorable +-- | A version of 'typeRep' that gets the 'Size' implicitly from the argument. +typeRep' :: forall a . Type a => a -> TypeRep +typeRep' a = typeRep (Tagged (sizeOf a) :: Tagged a (Size a)) -instance Typeable Float - where - type Size Float = Range Float - typeOf = typeOfStorable +isNil :: Type a => a -> Bool +isNil a = case dataRep a of + ArrayData [] -> True + _ -> False -instance Storable a => Typeable [a] - where - type Size [a] = Range Length :> Size a - typeOf = typeOfStorable -instance (Typeable a, Typeable b) => Typeable (a,b) - where - type Size (a,b) = (Size a, Size b) - typeOf (sa,sb) _ = Tup [typeOf sa (T::T a), typeOf sb (T::T b)] +-------------------------------------------------------------------------------- +-- * Size propagation +-------------------------------------------------------------------------------- -instance (Typeable a, Typeable b, Typeable c) => Typeable (a,b,c) +class FullProp a where - type Size (a,b,c) = (Size a, Size b, Size c) - - typeOf (sa,sb,sc) _ = Tup - [ typeOf sa (T::T a) - , typeOf sb (T::T b) - , typeOf sc (T::T c) - ] + -- | Size propagation function that maps any number of arguments to + -- 'universal'. + fullProp :: a -instance (Typeable a, Typeable b, Typeable c, Typeable d) => Typeable (a,b,c,d) +instance FullProp () where - type Size (a,b,c,d) = (Size a, Size b, Size c, Size d) - - typeOf (sa,sb,sc,sd) _ = Tup - [ typeOf sa (T::T a) - , typeOf sb (T::T b) - , typeOf sc (T::T c) - , typeOf sd (T::T d) - ] - + fullProp = universal +instance BoundedInt a => FullProp (Range a) + where + fullProp = universal --- | Default implementation of 'typeOf' for 'Storable' types. -typeOfStorable :: Storable a => Size a -> T a -> Tuple StorableType -typeOfStorable sz = One . storableType sz +instance FullProp b => FullProp (a -> b) + where + fullProp = const fullProp diff --git a/Feldspar/Core/Wrap.hs b/Feldspar/Core/Wrap.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Core/Wrap.hs @@ -0,0 +1,47 @@ +-- | Module "Data.TypeLevel.Num.Aliases" is re-exported because +-- wrappers use type level numbers frequently +module Feldspar.Core.Wrap ( Wrap(..), Data'(..), module Data.TypeLevel.Num.Aliases, D0, D1, D2, D3, D4, D5, D6, D7, D8, D9) where + + +import Feldspar.DSL.Network +import Feldspar.Core.Types +import Feldspar.Core.Representation + +import Data.TypeLevel.Num.Aliases +import Data.TypeLevel.Num.Reps (D0, D1, D2, D3, D4, D5, D6, D7, D8, D9 ) + + +-- | Wrapping Feldspar functions +class Wrap t w where + wrap :: t -> w + +-- | Basic instances to handle @Data a@ input and output. +-- Other instances are located in the concerned libraries. +instance Wrap (Data a) (Data a) where + wrap = id + +instance (Wrap t u) => Wrap (Data a -> t) (Data a -> u) where + wrap f = \x -> wrap $ f x + +-- | Extended 'Data' to be used in wrappers +data Data' s a = + Data' + { unData' :: Data a + } + +-- Syntactic instance for 'Data'' +instance EdgeInfo (Data' s a) + where + type Info (Data' s a) = EdgeSize () a + edgeInfo = edgeInfo . unData . unData' + +instance Type a => MultiEdge (Data' s a) Feldspar EdgeSize + where + type Role (Data' s a) = () + type Internal (Data' s a) = a + toEdge = toEdge . unData . unData' + fromInEdge = Data' . Data . fromInEdge + fromOutEdge info = Data' . Data . fromOutEdge info + +instance (Type a) => Syntactic (Data' s a) + diff --git a/Feldspar/DSL/Expression.hs b/Feldspar/DSL/Expression.hs new file mode 100644 --- /dev/null +++ b/Feldspar/DSL/Expression.hs @@ -0,0 +1,74 @@ +-- | This module defines the concept of expressions and expression transformers. +-- +-- An expression is a type constructor of kind +-- +-- > * -> * -> * +-- +-- where the first argument denotes the \"role\" of the expression, and the +-- second argument is the type of the value computed by the expression. +-- +-- An expression transformer is a type constructor of kind +-- +-- > (* -> * -> *) -> (* -> * -> *) +-- +-- i.e. a expression parameterized by an expression. + +module Feldspar.DSL.Expression where + + + +import Data.Typeable +import Unsafe.Coerce + + + +-- | Expression type with no constructors. Can be used to turn an expression +-- transformer to an expression. +data Empty role a + +-- | Equality for expressions. The difference between 'Eq' and 'ExprEq' is that +-- 'ExprEq' allows comparison of expressions with different role and value type. +-- It is assumed that when the types differ, the expressions also differ. The +-- reason for allowing comparison of different types is that this is convenient +-- when the types are existentially quantified. +class ExprEq expr + where + exprEq :: expr ra a -> expr rb b -> Bool + +instance ExprEq Empty + where + exprEq _ _ = undefined + +instance Eq (Empty role a) + where + (==) = exprEq + +-- | Evaluation of expressions +class Eval expr + where + eval :: expr role a -> a + +instance Eval Empty + where + eval _ = undefined + +class ExprShow expr + where + exprShow :: expr role a -> String + +instance ExprShow Empty + where + exprShow _ = undefined + +printExpr :: ExprShow expr => expr role a -> IO () +printExpr = putStrLn . exprShow + +-- | Type-safe cast for expressions +exprCast :: forall expr ra a rb b + . (Typeable ra, Typeable a, Typeable rb, Typeable b) + => expr ra a -> Maybe (expr rb b) +exprCast e = do + cast (undefined :: ra) :: Maybe rb -- Check that ra and rb are the same + cast (undefined :: a) :: Maybe b -- Check that a and b are the same + return (unsafeCoerce e) + diff --git a/Feldspar/DSL/Lambda.hs b/Feldspar/DSL/Lambda.hs new file mode 100644 --- /dev/null +++ b/Feldspar/DSL/Lambda.hs @@ -0,0 +1,197 @@ +-- | A module for lambda expressions + +module Feldspar.DSL.Lambda where + + + +import Control.Monad.State +import Data.Tree +import Data.Typeable + +import Feldspar.DSL.Expression + + + +-- | Unique identifier +type Ident = String + +-- | Extensible lambda expressions +data Lam expr role a + where + Variable :: Ident -> Lam expr role a + + Value :: a -> Lam expr role a + + Lambda + :: (Typeable rb, Typeable b) + => (Lam expr ra a -> Lam expr rb b) -> Lam expr (ra -> rb) (a -> b) + + (:$:) + :: (Typeable ra, Typeable a) + => Lam expr (ra -> rb) (a -> b) -> Lam expr ra a -> Lam expr rb b + -- Application. Using an infix operator makes it *a lot* easier to work + -- with the library. + + Let :: String -> Lam expr (ra -> (ra -> rb) -> rb) (a -> (a -> b) -> b) + + Inject :: expr role a -> Lam expr role a + + -- Note: Using an infix operator for application makes it *a lot* easier + -- to work with the library. + + -- TODO 'Value' is used for evaluating 'Lambda' expressions. It should not + -- be exported to the user. This is only a temporary solution. + + -- TODO 'Lambda' should have a base name field instead of 'Let'. + + + +-- | Let binding +let_ :: (Typeable ra, Typeable a, Typeable rb, Typeable b) + => String -- ^ Preferred base name + -> Lam expr ra a -> (Lam expr ra a -> Lam expr rb b) -> Lam expr rb b +let_ base a f = Let base :$: a :$: Lambda f + +instance ExprEq expr => ExprEq (Lam expr) + where + exprEq a b = evalState (exprEqLam a b) 0 + +instance ExprEq expr => Eq (Lam expr role a) + where + (==) = exprEq + +freshVar + :: String -- ^ Base name + -> State Integer (Lam expr role a) +freshVar base = do + v <- get + put (v+1) + return $ Variable (base ++ show v) + +exprEqLam :: ExprEq expr => Lam expr ra a -> Lam expr rb b -> State Integer Bool +exprEqLam (Variable i1) (Variable i2) = return (i1 == i2) +exprEqLam (Lambda f1) (Lambda f2) = do + i <- get + v1 <- freshVar "" + put i + v2 <- freshVar "" + exprEqLam (f1 v1) (f2 v2) +exprEqLam (f1 :$: a1) (f2 :$: a2) = do + aCond <- exprEqLam f1 f2 + if aCond + then exprEqLam a1 a2 + else return False +exprEqLam (Inject a) (Inject b) = return (exprEq a b) +exprEqLam (Let _) (Let _) = return True +exprEqLam _ _ = return False + -- This case includes 'Value', which is only supposed to be used during + -- evaluation. + +instance Eval expr => Eval (Lam expr) + where + eval (Variable ident) = error $ "Evaluating variable " ++ show ident + eval (Value a) = a + eval (Lambda f) = eval . f . Value + eval (f :$: a) = eval f $ eval a + eval (Inject a) = eval a + eval (Let _) = flip ($) + +instance ExprShow expr => ExprShow (Lam expr) + where + exprShow = flip evalState 0 . exprShowLam + +instance ExprShow (Lam expr) => Show (Lam expr role a) + where + show = exprShow + +-- | Shallow application. Function argument must be a 'Lambda'. +shallowApply :: Lam expr (ra -> rb) (a -> b) -> Lam expr ra a -> Lam expr rb b +shallowApply (Lambda f) = f + +infixr 0 $$ +($$) = shallowApply + +isVar :: Lam expr role a -> Bool +isVar (Variable _) = True +isVar _ = False + +isLet :: Lam expr role a -> Bool +isLet (Let _ :$: _ :$: _) = True +isLet _ = False + +-- | Parser for infix operators of the form @"(op)"@ +viewInfix :: String -> Maybe String +viewInfix ('(':op) + | (')':op') <- reverse op = Just op' +viewInfix _ = Nothing + +-- | Shows a partially applied expression +exprShowApp :: ExprShow expr + => [String] -- ^ Missing arguments + -> Lam expr role a -- ^ Partially applied expression + -> State Integer String +exprShowApp args (f :$: a) = do + aStr <- exprShowLam a + exprShowApp (aStr:args) f +exprShowApp args f = do + fStr <- exprShowLam f + return $ case (viewInfix fStr, args) of + (Just op, [a,b]) -> "(" ++ unwords [a,op,b] ++ ")" + _ -> "(" ++ unwords (fStr : args) ++ ")" + +exprShowLam :: ExprShow expr => Lam expr role a -> State Integer String +exprShowLam (Variable ident) = return ident +exprShowLam (Value _) = error "exprShowLam: illegal use of Value" +exprShowLam (Lambda f) = do + v@(Variable ident) <- freshVar "v" + body <- exprShowLam (f v) + return $ "(\\" ++ ident ++ " -> " ++ body ++ ")" +exprShowLam (Let base :$: a :$: Lambda f) = do + v@(Variable ident) <- freshVar base + aStr <- exprShowLam a + body <- exprShowLam (f v) + return $ "(let " ++ ident ++ " = " ++ aStr ++ " in " ++ body ++ ")" +exprShowLam (f :$: a) = do + aStr <- exprShowLam a + exprShowApp [aStr] f +exprShowLam (Inject a) = return (exprShow a) + +-- | Converts a partially applied expression to a tree +lamToTreeApp :: ExprShow expr + => Forest String -- ^ Missing arguments + -> Lam expr role a -- ^ Partially applied expression + -> State Integer (Tree String) +lamToTreeApp args (f :$: a) = do + aTree <- lamToTree a + lamToTreeApp (aTree : args) f +lamToTreeApp args f = do + fTree <- lamToTree f + return $ Node "Apply" (fTree : args) + +-- | Converts a lambda expression to a tree +lamToTree :: ExprShow expr => Lam expr role a -> State Integer (Tree String) +lamToTree (Variable ident) = return $ Node ("Variable " ++ ident) [] +lamToTree (Value a) = return $ Node "Value ..." [] +lamToTree (Lambda f) = do + v@(Variable ident) <- freshVar "v" + body <- lamToTree (f v) + return $ Node ("Lambda " ++ ident) [body] +lamToTree (Let base :$: a :$: Lambda f) = do + v@(Variable ident) <- freshVar base + aTree <- lamToTree a + body <- lamToTree (f v) + return $ Node ("Let " ++ ident) [aTree,body] +lamToTree (f :$: a) = do + aTree <- lamToTree a + lamToTreeApp [aTree] f +lamToTree (Let base) = return $ Node ("Let " ++ base) [] +lamToTree (Inject a) = return $ Node (exprShow a) [] + +-- | Show a lambda expression as a tree +showLamTree :: ExprShow expr => Lam expr role a -> String +showLamTree = drawTree . flip evalState 0 . lamToTree + +-- | Print a lambda expression as a tree +drawLambda :: ExprShow expr => Lam expr role a -> IO () +drawLambda = putStrLn . showLamTree + diff --git a/Feldspar/DSL/Network.hs b/Feldspar/DSL/Network.hs new file mode 100644 --- /dev/null +++ b/Feldspar/DSL/Network.hs @@ -0,0 +1,389 @@ +{-# LANGUAGE UndecidableInstances #-} + +-- | This module defines computational networks. + +module Feldspar.DSL.Network where + + + +import Control.Applicative +import Data.Typeable + +import Feldspar.DSL.Expression +import Feldspar.DSL.Lambda + + + +-- | Empty type denoting an \"out\" role +data Out role deriving Typeable + +-- | Empty type denoting an \"in\" role +data In role deriving Typeable + + + +-- | Expression transformer for representing network connections. +data Connection edge node role a + where + Node :: node role a -> Connection edge node role a + -- Turning a @node@ expression into a network node. + + Edge :: edge () a -> Connection edge node (Out () -> In ()) (a -> a) + -- A network edge: semantically an identity function, but decorated with + -- some @edge@ information + + Group2 :: Connection e n (In ra -> In rb -> In (ra,rb)) (a -> b -> (a,b)) + Group3 :: Connection e n (In ra -> In rb -> In rc -> In (ra,rb,rc)) (a -> b -> c -> (a,b,c)) + Group4 :: Connection e n (In ra -> In rb -> In rc -> In rd -> In (ra,rb,rc,rd)) (a -> b -> c -> d -> (a,b,c,d)) + + Match21 :: Connection e n (Out (ra,rb) -> Out ra) ((a,b) -> a) + Match22 :: Connection e n (Out (ra,rb) -> Out rb) ((a,b) -> b) + Match31 :: Connection e n (Out (ra,rb,rc) -> Out ra) ((a,b,c) -> a) + Match32 :: Connection e n (Out (ra,rb,rc) -> Out rb) ((a,b,c) -> b) + Match33 :: Connection e n (Out (ra,rb,rc) -> Out rc) ((a,b,c) -> c) + Match41 :: Connection e n (Out (ra,rb,rc,rd) -> Out ra) ((a,b,c,d) -> a) + Match42 :: Connection e n (Out (ra,rb,rc,rd) -> Out rb) ((a,b,c,d) -> b) + Match43 :: Connection e n (Out (ra,rb,rc,rd) -> Out rc) ((a,b,c,d) -> c) + Match44 :: Connection e n (Out (ra,rb,rc,rd) -> Out rd) ((a,b,c,d) -> d) + + + +-- | A computational network +-- +-- A value of type @(Network edge node (In role) a)@ is called a in-edge, and a +-- value of type @(Network edge node (Out role) a)@ is called a out-edge. +-- +-- It is assumed that the @node@ type is designed such that it is impossible to +-- construct a in-edge that is an (nested) application of a 'Node'. This means +-- that a value of type @(Network edge node (In ()) a)@ can only be constructed +-- by +-- +-- @`Inject` (`Edge` ...) `:$:` ...@ +-- +-- It also means that values of type @(Network edge node (In role) a)@ are +-- always (nested) applications of 'Edge', 'Group2', 'Group3' or 'Group4'. +-- +-- This ensures that all functions in this module are total. +-- +-- Note that the @edge@ information will be ignored when comparing two networks +-- using 'exprEq'. +type Network edge node = Lam (Connection edge node) + -- TODO The above is not correct anymore: 'Variable' and 'Let' can construct + -- expressions of any type. + + + +instance ExprEq node => ExprEq (Connection edge node) + where + exprEq (Node a) (Node b) = exprEq a b + exprEq (Edge _) (Edge _) = True -- Edge information ignored + exprEq Group2 Group2 = True + exprEq Group3 Group3 = True + exprEq Group4 Group4 = True + exprEq Match21 Match21 = True + exprEq Match22 Match22 = True + exprEq Match31 Match31 = True + exprEq Match32 Match32 = True + exprEq Match33 Match33 = True + exprEq Match41 Match41 = True + exprEq Match42 Match42 = True + exprEq Match43 Match43 = True + exprEq Match44 Match44 = True + exprEq _ _ = False + +instance (ExprEq edge, ExprEq node) => Eq (Connection edge node role a) + where + (==) = exprEq + +instance Eval node => Eval (Connection edge node) + where + eval (Node a) = eval a + eval (Edge _) = id + eval Group2 = (,) + eval Group3 = (,,) + eval Group4 = (,,,) + eval Match21 = fst + eval Match22 = snd + eval Match31 = \(a,b,c) -> a + eval Match32 = \(a,b,c) -> b + eval Match33 = \(a,b,c) -> c + eval Match41 = \(a,b,c,d) -> a + eval Match42 = \(a,b,c,d) -> b + eval Match43 = \(a,b,c,d) -> c + eval Match44 = \(a,b,c,d) -> d + +instance (ExprShow edge, ExprShow node) => ExprShow (Connection edge node) + where + exprShow (Node a) = exprShow a + exprShow (Edge e) = "(edge " ++ exprShow e ++ ")" + exprShow Group2 = "group2" + exprShow Group3 = "group3" + exprShow Group4 = "group4" + exprShow Match21 = "match21" + exprShow Match22 = "match22" + exprShow Match31 = "match21" + exprShow Match32 = "match22" + exprShow Match33 = "match23" + exprShow Match41 = "match41" + exprShow Match42 = "match42" + exprShow Match43 = "match43" + exprShow Match44 = "match44" + + + +-- | This class should be thought of as roughly equivalent to 'MultiEdge'. +-- The difference is that 'EdgeInfo' has fewer constraints. +class EdgeInfo a + where + type Info a + edgeInfo :: a -> Info a + -- This class could be baked into 'MultiEdge', but that leads to unnecessary + -- constraints for 'edgeInfo'. + +-- | Types that can be converted to/from network edges. Instances must fulfill +-- 'prop_edge1' and 'prop_edge2'. +class (Typeable (Role a), Typeable (Internal a), EdgeInfo a) => + MultiEdge a node edge | a -> node edge + where + type Role a + type Internal a + + toEdge :: a -> Network edge node (In (Role a)) (Internal a) + fromInEdge :: Network edge node (In (Role a)) (Internal a) -> a + fromOutEdge :: Info a -> Network edge node (Out (Role a)) (Internal a) -> a + +-- TODO Make node and edge associated types instead. The reason for not doing +-- this now is that it is currently not possible to make a class alias +-- fixing an associated type. But in the future (GHC 7.0, I think) this +-- will be possible. + +prop_edge1 :: forall a node edge + . (Eval node, MultiEdge a node edge, Eq (Internal a)) + => Network edge node (In (Role a)) (Internal a) + -> Bool +prop_edge1 a = eval a == eval (toEdge $ id' $ fromInEdge a) + where + id' = id :: a -> a + +prop_edge2 :: forall a node edge + . (Eval node, MultiEdge a node edge, Eq (Internal a)) + => Info a + -> Network edge node (Out (Role a)) (Internal a) + -> Bool +prop_edge2 info a = eval a == eval (toEdge $ id' $ fromOutEdge info a) + where + id' = id :: a -> a + +instance EdgeInfo (Network edge node (In ()) a) + where + type Info (Network edge node (In ()) a) = edge () a + edgeInfo (Inject (Edge edge) :$: _) = edge + +instance Typeable a => MultiEdge (Network edge node (In ()) a) node edge + where + type Role (Network edge node (In ()) a) = () + type Internal (Network edge node (In ()) a) = a + + toEdge = id + fromInEdge = id + fromOutEdge edge = (Inject (Edge edge) :$:) + +instance (EdgeInfo a, EdgeInfo b) => EdgeInfo (a,b) + where + type Info (a,b) = (Info a, Info b) + edgeInfo (a,b) = (edgeInfo a, edgeInfo b) + +instance + ( MultiEdge a node edge + , MultiEdge b node edge + ) => MultiEdge (a,b) node edge + where + type Role (a,b) = (Role a, Role b) + type Internal (a,b) = (Internal a, Internal b) + + toEdge (a,b) = Inject Group2 :$: toEdge a :$: toEdge b + + fromInEdge (Inject Group2 :$: a :$: b) = (fromInEdge a, fromInEdge b) + + fromOutEdge (ia,ib) a = + ( fromOutEdge ia $ Inject Match21 :$: a + , fromOutEdge ib $ Inject Match22 :$: a + ) + +instance (EdgeInfo a, EdgeInfo b, EdgeInfo c) => EdgeInfo (a,b,c) + where + type Info (a,b,c) = (Info a, Info b, Info c) + edgeInfo (a,b,c) = (edgeInfo a, edgeInfo b, edgeInfo c) + +instance + ( MultiEdge a node edge + , MultiEdge b node edge + , MultiEdge c node edge + ) => MultiEdge (a,b,c) node edge + where + type Role (a,b,c) = (Role a, Role b, Role c) + type Internal (a,b,c) = (Internal a, Internal b, Internal c) + + toEdge (a,b,c) = Inject Group3 :$: toEdge a :$: toEdge b :$: toEdge c + + fromInEdge (Inject Group3 :$: a :$: b :$: c) = + (fromInEdge a, fromInEdge b, fromInEdge c) + + fromOutEdge (ia,ib,ic) a = + ( fromOutEdge ia $ Inject Match31 :$: a + , fromOutEdge ib $ Inject Match32 :$: a + , fromOutEdge ic $ Inject Match33 :$: a + ) + +instance (EdgeInfo a, EdgeInfo b, EdgeInfo c, EdgeInfo d) => EdgeInfo (a,b,c,d) + where + type Info (a,b,c,d) = (Info a, Info b, Info c, Info d) + edgeInfo (a,b,c,d) = (edgeInfo a, edgeInfo b, edgeInfo c, edgeInfo d) + +instance + ( MultiEdge a node edge + , MultiEdge b node edge + , MultiEdge c node edge + , MultiEdge d node edge + ) => MultiEdge (a,b,c,d) node edge + where + type Role (a,b,c,d) = (Role a, Role b, Role c, Role d) + type Internal (a,b,c,d) = (Internal a, Internal b, Internal c, Internal d) + + toEdge (a,b,c,d) + = Inject Group4 + :$: toEdge a + :$: toEdge b + :$: toEdge c + :$: toEdge d + + fromInEdge (Inject Group4 :$: a :$: b :$: c :$: d) = + (fromInEdge a, fromInEdge b, fromInEdge c, fromInEdge d) + + fromOutEdge (ia,ib,ic,id) a = + ( fromOutEdge ia $ Inject Match41 :$: a + , fromOutEdge ib $ Inject Match42 :$: a + , fromOutEdge ic $ Inject Match43 :$: a + , fromOutEdge id $ Inject Match44 :$: a + ) + + + +-- | Remove an 'Edge' application +undoEdge :: Network edge node (In ()) a -> Network edge node (Out ()) a +undoEdge (Inject (Edge _) :$: a) = a + +-- | Cast between two 'MultiEdge' types that have the same internal +-- representation. +edgeCast :: + ( MultiEdge a node edge + , MultiEdge b node edge + , Internal a ~ Internal b + , Role a ~ Role b + ) => a -> b +edgeCast = fromInEdge . toEdge + +-- | Applies a function to each 'Edge' in an in-edge, and collects the result in +-- an applicative functor. The applied function receives the path of the edge as +-- an argument. +mapEdge :: forall app edge node ra a . Applicative app + => (forall b . [Int] -> Network edge node (In ()) b -> app b) + -> Network edge node (In ra) a -> app a +mapEdge f a = mapE [] a + where + mapE :: [Int] -> Network edge node (In rc) c -> app c + mapE path a@(Inject (Edge _) :$: _) = f (reverse path) a + mapE path (Inject Group2 :$: a :$: b) + = pure (,) + <*> mapE (1:path) a + <*> mapE (2:path) b + mapE path (Inject Group3 :$: a :$: b :$: c) + = pure (,,) + <*> mapE (1:path) a + <*> mapE (2:path) b + <*> mapE (3:path) c + mapE path (Inject Group4 :$: a :$: b :$: c :$: d) + = pure (,,,) + <*> mapE (1:path) a + <*> mapE (2:path) b + <*> mapE (3:path) c + <*> mapE (4:path) d + +-- | Applies a function to each 'Edge' in an in-edge, and collects the results +-- in a list. The applied function receives the path of the edge as an argument. +listEdge :: forall edge node ra a b + . (forall c . [Int] -> Network edge node (In ()) c -> b) + -> Network edge node (In ra) a -> [b] +listEdge f a = listE [] a + where + listE :: [Int] -> Network edge node (In rd) d -> [b] + listE path a@(Inject (Edge _) :$: _) = [f (reverse path) a] + listE path (Inject Group2 :$: a :$: b) + = listE (1:path) a + ++ listE (2:path) b + listE path (Inject Group3 :$: a :$: b :$: c) + = listE (1:path) a + ++ listE (2:path) b + ++ listE (3:path) c + listE path (Inject Group4 :$: a :$: b :$: c :$: d) + = listE (1:path) a + ++ listE (2:path) b + ++ listE (3:path) c + ++ listE (4:path) d + +-- | Lists the match constructors of an out-edge +matchPath :: Network edge node (Out ()) a -> [Int] +matchPath = reverse . match + where + match :: Network edge node (Out role) a -> [Int] + match (Inject Match21 :$: a) = 1:match a + match (Inject Match22 :$: a) = 2:match a + match (Inject Match31 :$: a) = 1:match a + match (Inject Match32 :$: a) = 2:match a + match (Inject Match33 :$: a) = 3:match a + match (Inject Match41 :$: a) = 1:match a + match (Inject Match42 :$: a) = 2:match a + match (Inject Match43 :$: a) = 3:match a + match (Inject Match44 :$: a) = 4:match a + match _ = [] + -- Using local function just to be able to give more restricted type to + -- 'matchPath'. + +-- | Count the number of \"single\" edges (i.e. edges with role @In ()@) +countEdges :: Network edge node (In role) a -> Int +countEdges = length . listEdge (\_ _ -> ()) + +isMatch :: Connection edge node (ra -> rb) (a -> b) -> Bool +isMatch Match21 = True +isMatch Match22 = True +isMatch Match31 = True +isMatch Match32 = True +isMatch Match33 = True +isMatch Match41 = True +isMatch Match42 = True +isMatch Match43 = True +isMatch Match44 = True +isMatch _ = False + +traceVar :: Network edge node (Out ()) a -> Maybe Ident +traceVar = trace + where + trace :: Network edge node role a -> Maybe Ident + trace (Variable v) = Just v + trace (Inject f :$: a) | isMatch f = trace a + trace _ = Nothing + -- Using local function just to be able to give more restricted type to + -- 'matchPath'. + +isNode :: Network edge node ra a -> Bool +isNode (Inject (Node _)) = True +isNode (a :$: _) = isNode a +isNode _ = False + +isEdge :: Network edge node ra a -> Bool +isEdge (Inject (Edge _) :$: _) = True +isEdge (Inject Group2 :$: _ :$: _) = True +isEdge (Inject Group3 :$: _ :$: _ :$: _) = True +isEdge (Inject Group4 :$: _ :$: _ :$: _ :$: _) = True +isEdge _ = False + diff --git a/Feldspar/DSL/Sharing.hs b/Feldspar/DSL/Sharing.hs new file mode 100644 --- /dev/null +++ b/Feldspar/DSL/Sharing.hs @@ -0,0 +1,164 @@ +-- | Common sub-expression elimination and variable hoisting for 'Lam' +-- expressions. + +module Feldspar.DSL.Sharing where + + + +import Control.Monad.State +import Data.Typeable + +import Feldspar.DSL.Expression +import Feldspar.DSL.Lambda + + + +-- | Substituting a sub-expression +substitute :: (ExprEq expr, Typeable ra, Typeable a, Typeable rb, Typeable b) + => Lam expr ra a -- ^ Sub-expression to be replaced + -> Lam expr ra a -- ^ Replacing sub-expression + -> Lam expr rb b -- ^ Whole expression + -> Lam expr rb b +substitute x y a | Just y' <- exprCast y, exprEq x a = y' +substitute x y (Lambda f) = Lambda $ \v -> substitute x y (f v) +substitute x y (f :$: a) = substitute x y f :$: substitute x y a +substitute x y a = a + +-- | Count the number of occurrences of a sub-expression +count :: (ExprEq expr, Typeable ra, Typeable a, Typeable rb, Typeable b) + => Lam expr ra a -- ^ Sub-expression + -> Lam expr rb b -- ^ Whole expression + -> Integer +count a b = evalState (countM a b) 0 + +countM :: (ExprEq expr, Typeable ra, Typeable a, Typeable rb, Typeable b) + => Lam expr ra a + -> Lam expr rb b + -> State Integer Integer +countM a b = case exprCast b of + Just b' -> do + eq <- exprEqLam a (b' `asTypeOf` a) + if eq then return 1 else countNonEq a b + _ -> countNonEq a b + +countNonEq :: (ExprEq expr, Typeable ra, Typeable a, Typeable rb, Typeable b) + => Lam expr ra a + -> Lam expr rb b + -> State Integer Integer +countNonEq a (Lambda f) = do + v <- freshVar "" + countM a (f v) +countNonEq a (f :$: b) = liftM2 (+) (countM a f) (countM a b) +countNonEq _ _ = return 0 + + + +data SomeLam expr = forall ra a . + (Typeable ra, Typeable a) => SomeLam (Lam expr ra a) + +-- | Custom parameters to sharing transformation. The 'necessary' predicate +-- gives a necessary condition for lifting an expression, and 'sufficient' gives +-- a sufficient condition. Note that 'necessary' takes precedence over +-- 'sufficient'. +-- +-- The 'sharingPoint' field determines whether the expression is a valid point +-- for introducing a 'Let'. +data Params expr = Params + { necessary :: SomeLam expr -> Bool + , sufficient :: SomeLam expr -> Bool + , sharingPoint :: SomeLam expr -> Bool + } + +data Env expr = Env + { inLambda :: Bool -- ^ Whether the current expression is inside a lambda + , subExpr :: Bool -- ^ Whether the current expression is a sub-expression + , counter :: SomeLam expr -> Integer + -- ^ Counting the number of occurrences of an expression in the + -- environment + } + +simpleParams :: Params expr +simpleParams = Params + { necessary = const True + , sufficient = const False + , sharingPoint = const True + } + +initEnv :: (ExprEq expr, Typeable ra, Typeable a) + => Lam expr ra a + -> Env expr +initEnv a = Env + { inLambda = False + , subExpr = False + , counter = \(SomeLam b) -> count b a + } + +dummy = Variable "" +ph = Variable "PLACEHOLDER" + +-- | Checks whether an expression is compound +compound :: Lam expr ra a -> Bool +compound (Lambda _) = True +compound (_ :$: _) = True +compound _ = False + +-- | Checks if the expression does not contain any @"PLACEHOLDER"@ variables +independent :: Lam expr ra a -> Bool +independent (Variable ident) = ident /= "PLACEHOLDER" +independent (Lambda f) = independent (f dummy) +independent (f :$: a) = independent f && independent a +independent _ = True + +-- | Checks whether a sub-expression in a given environment can be lifted out +liftable :: (Typeable ra, Typeable a) + => Params expr + -> Env expr + -> Lam expr ra a -> Bool +liftable params env a + = independent a -- Lifting dependent expressions is semantically incorrect + && subExpr env -- Otherwise infinite loop + && necessary params (SomeLam a) + && (heuristic || sufficient params (SomeLam a)) + where + heuristic = compound a && (inLambda env || (counter env (SomeLam a) > 1)) + +-- | Chooses a sub-expression to lift out +choose :: (Typeable ra, Typeable a) => + Params expr -> Env expr -> Lam expr ra a -> Maybe (SomeLam expr) +choose par env a | liftable par env a = Just (SomeLam a) +choose par env (Lambda f) = choose par env' (f ph) + where env' = env {inLambda = True, subExpr = True} +choose par env (f :$: a) = choose par env' f `mplus` choose par env' a + where env' = env {subExpr = True} +choose _ _ _ = Nothing + +-- | Perform common sub-expression elimination and variable hoisting +sharing :: forall expr ra a . (ExprEq expr, Typeable ra, Typeable a) + => Params expr + -> Lam expr ra a + -> Lam expr ra a +sharing par a = case choose par (initEnv a) a of + Just b | sharingPoint par (SomeLam a) -> share b + _ -> descend par a + where + share :: SomeLam expr -> Lam expr ra a + share (SomeLam b) = let_ "v" (sharing par b) f + where f x = sharing par (substitute b x a) + +descend :: (ExprEq expr, Typeable ra, Typeable a) + => Params expr + -> Lam expr ra a + -> Lam expr ra a +descend params (Lambda f) = Lambda $ \v -> sharing params (f v) +descend params (f :$: a) = sharing params f :$: sharing params a +descend _ a = a + +simpleSharing :: (ExprEq expr, Typeable ra, Typeable a) => + Lam expr ra a -> Lam expr ra a +simpleSharing = sharing simpleParams + +-- | Checks if the expression computes a function. Can be used in the parameters +-- passed to 'sharing'. +isFunction :: forall expr ra a . Typeable a => Lam expr ra a -> Bool +isFunction _ = show (typeRepTyCon $ typeOf (undefined :: a)) == "->" + diff --git a/Feldspar/DSL/Val.hs b/Feldspar/DSL/Val.hs new file mode 100644 --- /dev/null +++ b/Feldspar/DSL/Val.hs @@ -0,0 +1,78 @@ +-- | Simple example language built using 'Lam'. + +module Feldspar.DSL.Val where + + + +import Data.Typeable + +import Feldspar.DSL.Expression +import Feldspar.DSL.Lambda +import Feldspar.DSL.Sharing + + + +-------------------------------------------------------------------------------- +-- * Library +-------------------------------------------------------------------------------- + +data Val role a = Val String a + +instance ExprEq Val + where + exprEq (Val v1 _) (Val v2 _) = v1==v2 + +instance Eval Val + where + eval (Val _ a) = a + +instance ExprShow Val + where + exprShow (Val val _) = val + +simpleVal :: Show a => a -> Lam Val () a +simpleVal a = Inject $ Val (show a) a + +function :: (Typeable ra, Typeable a) => + String -> (a -> b) -> (Lam Val ra a -> Lam Val rb b) +function name f a = Inject (Val name f) :$: a + +function2 :: (Typeable ra, Typeable a, Typeable rb, Typeable b) => + String -> (a -> b -> c) -> (Lam Val ra a -> Lam Val rb b -> Lam Val rc c) +function2 name f a b = Inject (Val name f) :$: a :$: b + +int :: Int -> Lam Val () Int +int = simpleVal + +true = simpleVal True +false = simpleVal False + +instance (Num a, Typeable a) => Num (Lam Val () a) + where + fromInteger = simpleVal . fromInteger + abs = function "abs" abs + signum = function "signum" signum + (+) = function2 "(+)" (+) + (-) = function2 "(-)" (-) + (*) = function2 "(*)" (*) + + + +-------------------------------------------------------------------------------- +-- * Examples +-------------------------------------------------------------------------------- + +expr1 :: Lam Val (() -> ()) (Int -> Int) +expr1 = Lambda $ \x -> x + (let_ "temp" (2 + 3 + x) $ \y -> y+x) + +expr2 :: Lam Val (() -> ()) (Int -> Int) +expr2 = Lambda $ \x -> x + (let_ "temp" (2 + 3 + x) $ \y -> 2 + 3 + y+x) + +test1 = drawLambda expr2 +test2 = drawLambda $ simpleSharing expr2 + +problem = drawLambda $ + simpleSharing ((1+2+3) + (1+2+4) + (1+2+3+4) :: Lam Val () Int) + -- TODO: 1+2 not shared + -- Use fixpoint iteration? + diff --git a/Feldspar/FixedPoint.hs b/Feldspar/FixedPoint.hs --- a/Feldspar/FixedPoint.hs +++ b/Feldspar/FixedPoint.hs @@ -1,577 +1,228 @@ --- --- Copyright (c) 2009-2010, ERICSSON AB All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * 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. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT HOLDER 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. --- - -module Feldspar.FixedPoint where +{-# LANGUAGE UndecidableInstances #-} +module Feldspar.FixedPoint + ( Fix(..), Fixable(..) + , freezeFix, freezeFix', unfreezeFix, unfreezeFix' + , (?!), fixFold + ) +where import qualified Prelude -import Feldspar.Prelude -import Feldspar.Core.Types -import Feldspar.Core.Expr -import Feldspar.Core +import Feldspar +import Feldspar.DSL.Network hiding (In,Out) +import Feldspar.Core.Representation +import Feldspar.Vector import Data.Ratio -import System.IO.Unsafe -import Feldspar.Core.Functions - -type Fix32 = (Int, Data Signed32) -type UFix32 = (Int, Data Unsigned32) -type Fix16 = (Int, Data Signed16) -type UFix16 = (Int, Data Unsigned16) -type Fix8 = (Int, Data Signed8) -type UFix8 = (Int, Data Unsigned8) -type Fix = (Int,Data Int) - -intToFix :: Int -> Data Int -> Fix -intToFix exp val = (exp, val) - -intToFix32 :: Int -> Data Signed32 -> Fix32 -intToFix32 exp val = (exp, val) - -intToUFix32 :: Int -> Data Unsigned32 -> UFix32 -intToUFix32 exp val = (exp, val) - -intToFix16 :: Int -> Data Signed16 -> Fix16 -intToFix16 exp val = (exp, val) - -intToUFix16 :: Int -> Data Unsigned16 -> UFix16 -intToUFix16 exp val = (exp, val) - -intToFix8 :: Int -> Data Signed8 -> Fix8 -intToFix8 exp val = (exp, val) - -intToUFix8 :: Int -> Data Unsigned8 -> UFix8 -intToUFix8 exp val = (exp, val) - -fixToInt :: Int -> Fix -> Data Int -fixToInt exp' (exp,val) = val `leftShift` (exp-exp') - -fix32ToInt :: Int -> Fix32 -> Data Signed32 -fix32ToInt exp' (exp,val) = val `leftShift` (exp-exp') - -uFix32ToInt :: Int -> UFix32 -> Data Unsigned32 -uFix32ToInt exp' (exp,val) = val `leftShift` (exp-exp') - -fix16ToInt :: Int -> Fix16 -> Data Signed16 -fix16ToInt exp' (exp,val) = val `leftShift` (exp-exp') - -uFix16ToInt :: Int -> UFix16 -> Data Unsigned16 -uFix16ToInt exp' (exp,val) = val `leftShift` (exp-exp') - -fix8ToInt :: Int -> Fix8 -> Data Signed8 -fix8ToInt exp' (exp,val) = val `leftShift` (exp-exp') - -uFix8ToInt :: Int -> UFix8 -> Data Unsigned8 -uFix8ToInt exp' (exp,val) = val `leftShift` (exp-exp') - -floatToFix :: Float -> Fix -floatToFix f = (0, value $ Prelude.round f) - -floatToFix32 :: Float -> Fix32 -floatToFix32 f = (0, value $ Prelude.round f) - -floatToUFix32 :: Float -> UFix32 -floatToUFix32 f = (0, value $ Prelude.round f) - -floatToFix16 :: Float -> Fix16 -floatToFix16 f = (0, value $ Prelude.round f) - -floatToUFix16 :: Float -> UFix16 -floatToUFix16 f = (0, value $ Prelude.round f) - -floatToFix8 :: Float -> Fix8 -floatToFix8 f = (0, value $ Prelude.round f) - -floatToUFix8 :: Float -> UFix8 -floatToUFix8 f = (0, value $ Prelude.round f) - - -floatToFix32' :: Int -> Float -> Fix32 -floatToFix32' exp fl = (exp, value $ Prelude.round $ - (fl Prelude./ (2.0 Prelude.** (fromInteger(toInteger exp)))::Float)) - -floatToUFix32' :: Int -> Float -> UFix32 -floatToUFix32' exp fl = (exp, value $ Prelude.round $ - (fl Prelude./ (2.0 Prelude.** (fromInteger(toInteger exp)))::Float)) - -floatToFix16' :: Int -> Float -> Fix16 -floatToFix16' exp fl = (exp, value $ Prelude.round $ - (fl Prelude./ (2.0 Prelude.** (fromInteger(toInteger exp)))::Float)) - -floatToUFix16' :: Int -> Float -> UFix16 -floatToUFix16' exp fl = (exp, value $ Prelude.round $ - (fl Prelude./ (2.0 Prelude.** (fromInteger(toInteger exp)))::Float)) - -floatToFix8' :: Int -> Float -> Fix8 -floatToFix8' exp fl = (exp, value $ Prelude.round $ - (fl Prelude./ (2.0 Prelude.** (fromInteger(toInteger exp)))::Float)) - -floatToUFix8' :: Int -> Float -> UFix8 -floatToUFix8' exp fl = (exp, value $ Prelude.round $ - (fl Prelude./ (2.0 Prelude.** (fromInteger(toInteger exp)))::Float)) - - -toExp32 :: Int -> Fix32 -> Fix32 -toExp32 exp (e,i) = (exp, i `leftShift` (e-exp)) - -toExpU32 :: Int -> UFix32 -> UFix32 -toExpU32 exp (e,i) = (exp, i `leftShift` (e-exp)) - -toExp16 :: Int -> Fix16 -> Fix16 -toExp16 exp (e,i) = (exp, i `leftShift` (e-exp)) - -toExpU16 :: Int -> UFix16 -> UFix16 -toExpU16 exp (e,i) = (exp, i `leftShift` (e-exp)) - -toExp8 :: Int -> Fix8 -> Fix8 -toExp8 exp (e,i) = (exp, i `leftShift` (e-exp)) - -toExpU8 :: Int -> UFix8 -> UFix8 -toExpU8 exp (e,i) = (exp, i `leftShift` (e-exp)) - -fixToFloat :: (Integral a,Integral b) => ( a , Data b ) -> Float -fixToFloat fix =( 2.0 Prelude.** (fromInteger (toInteger(fst fix)))) Prelude.* - ( (fromInteger ( toInteger ( evalD (snd fix) )) )::Float ) - -fix32ToFloat :: Fix32-> Float -fix32ToFloat fix = fixToFloat fix - -uFix32ToFloat :: UFix32-> Float -uFix32ToFloat fix = fixToFloat fix - -fix16ToFloat :: Fix16-> Float -fix16ToFloat fix = fixToFloat fix - -uFix16ToFloat :: UFix16-> Float -uFix16ToFloat fix = fixToFloat fix +-- | Abstract real number type with exponent and mantissa +data Fix a = + Fix + { exponent :: Data DefaultInt + , mantissa :: Data a + } + deriving (Prelude.Eq,Prelude.Show) -fix8ToFloat :: Fix8-> Float -fix8ToFloat fix = fixToFloat fix +instance + ( Bounded a + , Numeric a + , Bits a + , Ord a + , Range a ~ Size a + , Prelude.Real a + ) => Num (Fix a) + where + fromInteger n = Fix 0 (Prelude.fromInteger n) + (+) = fixAddition + (*) = fixMultiplication + negate = fixNegate + abs = fixAbsolute + signum = fixSignum -uFix8ToFloat :: UFix8-> Float -uFix8ToFloat fix = fixToFloat fix +instance + ( Bounded a + , Numeric a + , Bits a + , Ord a + , Range a ~ Size a + , Prelude.Real a + , Integral a + ) => Fractional (Fix a) + where + (/) = fixDiv' + recip = fixRecip' + fromRational = fixfromRational -inBounds :: Bool -> Int -> Int -> Bool -inBounds s wbits i | s Prelude.&& (i Prelude.> sintmax) = False - | s Prelude.&& (i Prelude.< sintmin) = False - | (Prelude.not s) Prelude.&& (i Prelude.> uintmax) = False - | (Prelude.not s) Prelude.&& (i Prelude.< uintmin) = False - | otherwise = True +fixAddition :: (Bounded a,Numeric a, Bits a, Ord a, Range a ~ Size a, Prelude.Real a) => Fix a -> Fix a -> Fix a +fixAddition f1@(Fix e1 m1) f2@(Fix e2 m2) = Fix e m where - (sintmax :: Int) = 2 Prelude.^ (wbits Prelude.- 1) - 1 - (sintmin :: Int) = -sintmax - (uintmax :: Int) = 2 Prelude.^ wbits Prelude.- 1 - (uintmin :: Int) = 0 - -fl01toFix :: (Integral a,Integral b) => Bool ->Int-> Float - -> (a,Data b) -> Bool -> (a,Data b) -fl01toFix s bts fl fix gt - | (Prelude.not gt) Prelude.&& ( fl1 Prelude.> fl ) = - fl01toFix s bts fl ((fst fix) Prelude.- 1, snd fix ) Prelude.False - | (Prelude.not gt) Prelude.&& ( fl1 Prelude.< fl ) = - fl01toFix s bts fl ((fst fix) Prelude.- 1, snd fix ) Prelude.True - | (Prelude.not gt) Prelude.&& ( fl1 Prelude.== fl ) = - ((fst fix) Prelude.- 1, snd fix ) - | gt Prelude.&& ( (inBounds s bts val') Prelude.&& ( fl2 Prelude.> fl ) ) = - fl01toFix s bts fl ((fst fix) Prelude.- 1, 2 * (snd fix) ) Prelude.True - | gt Prelude.&& ( (inBounds s bts val') Prelude.&& ( fl2 Prelude.< fl ) ) = - fl01toFix s bts fl ((fst fix) Prelude.- 1,2 * ( snd fix) + 1) Prelude.True - | gt Prelude.&& ( (inBounds s bts val') Prelude.&& ( fl2 Prelude.== fl ) ) = - fl01toFix s bts fl ((fst fix) Prelude.- 1, 2 * (snd fix) +1 ) Prelude.True - | otherwise = fix - where - fl2 = (2.0 Prelude.* (fromInteger val) Prelude.+ 1.0 ) Prelude.* - (2.0 Prelude.** ( (fromInteger exp) Prelude.- 1.0 )) - fl1 =( fromInteger val ) Prelude.* - (2.0 Prelude.** ( (fromInteger exp) Prelude.- 1.0 )) - val'= 2 Prelude.* (fromInteger val) Prelude.+ 1 - val = toInteger $ evalD $ snd fix - exp = toInteger $ fst fix - -fl01toFix' :: Float -> Fix -> Bool -> Fix -fl01toFix' = fl01toFix True 31 - -fl01toUFix32 :: Float -> UFix32 -> Bool -> UFix32 -fl01toUFix32 = fl01toFix False 32 - -fl01toFix32 :: Float -> Fix32 -> Bool -> Fix32 -fl01toFix32 = fl01toFix True 31 - -fl01toUFix16 :: Float -> UFix16 -> Bool -> UFix16 -fl01toUFix16 = fl01toFix False 16 - -fl01toFix16 :: Float -> Fix16 -> Bool -> Fix16 -fl01toFix16 = fl01toFix True 15 - -fl01toUFix8 :: Float -> UFix8 -> Bool -> UFix8 -fl01toUFix8 = fl01toFix False 8 - -fl01toFix8 :: Float -> Fix8 -> Bool -> Fix8 -fl01toFix8 = fl01toFix True 7 - -zeroOneToFix :: Float -> Fix -zeroOneToFix fl = fl01toFix' fl (1,1) Prelude.False - -zeroOneToFix32 :: Float -> Fix32 -zeroOneToFix32 fl = fl01toFix32 fl (1,1) Prelude.False - -zeroOneToUFix32 :: Float -> UFix32 -zeroOneToUFix32 fl = fl01toUFix32 fl (1,1) Prelude.False - -zeroOneToFix16 :: Float -> Fix16 -zeroOneToFix16 fl = fl01toFix16 fl (1,1) Prelude.False - -zeroOneToUFix16 :: Float -> UFix16 -zeroOneToUFix16 fl = fl01toUFix16 fl (1,1) Prelude.False - -zeroOneToFix8 :: Float -> Fix8 -zeroOneToFix8 fl = fl01toFix8 fl (1,1) Prelude.False - -zeroOneToUFix8 :: Float -> UFix8 -zeroOneToUFix8 fl = fl01toUFix8 fl (1,1) Prelude.False - - -addFix ::(Integral b,Bits b) => - Int -> (Int,Data b) -> (Int,Data b) -> (Int,Data b) -addFix e (e1,i1) (e2,i2) = - (e, i1 `leftShift` (e1 Prelude.- e) + i2 `leftShift` (e2 Prelude.- e)) - -addFix'' :: Int -> Fix -> Fix -> Fix -addFix'' = addFix - -addFix32 :: Int -> Fix32 -> Fix32 -> Fix32 -addFix32 = addFix - -addUFix32 :: Int -> UFix32 -> UFix32 -> UFix32 -addUFix32 = addFix - -addFix16 :: Int -> Fix16 -> Fix16 -> Fix16 -addFix16 = addFix - -addUFix16 :: Int -> UFix16 -> UFix16 -> UFix16 -addUFix16 = addFix - -addFix8 :: Int -> Fix8 -> Fix8 -> Fix8 -addFix8 = addFix - -addUFix8 :: Int -> UFix8 -> UFix8 -> UFix8 -addUFix8 = addFix + e = max e1 e2 + m = mantissa (fix e f1) + mantissa (fix e f2) -recipFix :: (Integral b,Bits b) => - Int -> (Int,Data b) -> (Int,Data b) -recipFix exp (e,i) = (e2,i2) +fixMultiplication :: (Bounded a,Numeric a, Bits a, Ord a, Range a ~ Size a, Prelude.Real a) => Fix a -> Fix a -> Fix a +fixMultiplication f1@(Fix e1 m1) f2@(Fix e2 m2) = Fix e m where - e2 = exp - i2 = div sh i - sh = 1 `rightShift` (exp Prelude.+ e) - -recipFix' :: Int -> Fix -> Fix -recipFix' = recipFix - -recipFix32 :: Int -> Fix32 -> Fix32 -recipFix32 = recipFix - -recipUFix32 :: Int -> UFix32 -> UFix32 -recipUFix32 = recipFix - -recipFix16 :: Int -> Fix16 -> Fix16 -recipFix16 = recipFix - -recipUFix16 :: Int -> UFix16 -> UFix16 -recipUFix16 = recipFix - -recipFix8 :: Int -> Fix8 -> Fix8 -recipFix8 = recipFix - -recipUFix8 :: Int -> UFix8 -> UFix8 -recipUFix8 = recipFix - -divFix :: (Integral b,Bits b) => - Int -> (Int,Data b) -> (Int,Data b) - -> (Int,Data b) -divFix exp (e1,i1) (e2,i2) = (e,i) + e = e1 + e2 + m = m1 * m2 + +fixNegate :: (Bounded a,Numeric a, Bits a, Ord a, Range a ~ Size a, Prelude.Real a) => Fix a -> Fix a +fixNegate f1@(Fix e1 m1) = Fix e1 m where - e = exp - i = div sh i2 - val = e1 Prelude.- e2 Prelude.- exp - sh = i1 `leftShift` val - -divFix' :: Int -> Fix -> Fix -> Fix -divFix' = divFix - -divFix32 :: Int -> Fix32 -> Fix32 -> Fix32 -divFix32 = divFix - -divUFix32 :: Int -> UFix32 -> UFix32 -> UFix32 -divUFix32 = divFix - -divFix16 :: Int -> Fix16 -> Fix16 -> Fix16 -divFix16 = divFix - -divUFix16 :: Int -> UFix16 -> UFix16 -> UFix16 -divUFix16 = divFix - -divFix8 :: Int -> Fix8 -> Fix8 -> Fix8 -divFix8 = divFix - -divUFix8 :: Int -> UFix8 -> UFix8 -> UFix8 -divUFix8 = divFix + m = negate m1 -addFix' ::(Integral b,Bits b) => - (Int,Data b) -> (Int,Data b) -> (Int,Data b) -addFix' (e1,i1) (e2,i2) = - ( m, ( i1 `leftShift` (e1 Prelude.- m)) + - ( i2 `leftShift` ( e2 Prelude.- m ) ) ) +fixAbsolute :: (Bounded a,Numeric a, Bits a, Ord a, Range a ~ Size a, Prelude.Real a) => Fix a -> Fix a +fixAbsolute f1@(Fix e1 m1) = Fix e1 m where - m = Prelude.max e1 e2 - -mulFix' ::(Integral b,Bits b) => - (Int,Data b) -> (Int,Data b) -> (Int,Data b) -mulFix' (e1,i1) (e2,i2)=(added ,(i1*i2 ) ) - where - added = e1 Prelude.+ e2 - -negate' ::(Integral b,Bits b) => - (Int,Data b) -> (Int,Data b) -negate' (e,i) = (e, negate i ) - -abs' ::(Integral b,Bits b) => - (Int,Data b) -> (Int,Data b) -abs' (e,i) = (e,abs(i)) - -signum' ::(Integral b,Bits b) => - (Int,Data b) -> (Int,Data b) -signum' (e,i) = ( 0 , signum i ) - -fromInteger' ::(Integral b,Bits b) => - Integer -> (Int,Data b) -fromInteger' i = ( 0 , fromInteger i ) - -instance Num Fix where - x + y = addFix' x y - x * y=mulFix' x y - negate = negate' - abs = abs' - signum = signum' - fromInteger = fromInteger' - -instance Num Fix32 where - x + y = addFix' x y - x * y=mulFix' x y - negate = negate' - abs = abs' - signum = signum' - fromInteger = fromInteger' - -instance Num UFix32 where - x + y = addFix' x y - x * y=mulFix' x y - negate = negate' - abs = abs' - signum = signum' - fromInteger = fromInteger' - -instance Num Fix16 where - x + y = addFix' x y - x * y=mulFix' x y - negate = negate' - abs = abs' - signum = signum' - fromInteger = fromInteger' - -instance Num UFix16 where - x + y = addFix' x y - x * y=mulFix' x y - negate = negate' - abs = abs' - signum = signum' - fromInteger = fromInteger' - - -instance Num Fix8 where - x + y = addFix' x y - x * y=mulFix' x y - negate = negate' - abs = abs' - signum = signum' - fromInteger = fromInteger' - -instance Num UFix8 where - x + y = addFix' x y - x * y=mulFix' x y - negate = negate' - abs = abs' - signum = signum' - fromInteger = fromInteger' - -recip' ::(Integral b,Bits b) => - Int -> (Int,Data b) -> (Int,Data b) -recip' bts (e,i) = ( e2, i2 ) - where - k = bts - 2 - e2 = Prelude.negate $ e Prelude.+ k - sh = 1 `leftShift` k - i2 = div sh i - -fromRational' ::(Integral b,Bits b,Num (Int,Data b)) => - Bool -> Int->(Float->(Int,Data b))->(Integer->(Int,Data b)) - -> Rational -> (Int,Data b) -fromRational' s bts zotf fi rat = addFix e integ frac - where - e = (fst frac) Prelude.+ toShift' - toShift' | s = Prelude.min toShift - ((bts Prelude.- 1) Prelude.- bitsInteg) - | (Prelude.not s) = - Prelude.min toShift (bts Prelude.- bitsInteg) - toShift | s = Prelude.max 0 - (bitsFrac Prelude.- (bts Prelude.- 1) Prelude.+ bitsInteg) - | (Prelude.not s) = - Prelude.max 0 (bitsFrac Prelude.- bts Prelude.+ bitsInteg) - bitsFrac = Prelude.floor $ - Prelude.logBase 2.0 (fromInteger (toInteger vfrac)) - bitsInteg = Prelude.floor $ - Prelude.logBase 2.0 (fromInteger (toInteger vinteg)) - vinteg = evalD $ snd integ - vfrac = evalD $ snd frac - frac = zotf fl01 - integ = (fi - ( Prelude.quot (numerator rat) (denominator rat) )) - fl01 = fl - ((Prelude.fromInteger (Prelude.floor fl))::Float) - fl = (Prelude.fromRational rat)::Float - -instance Fractional Fix where - recip = recip' 32 - fromRational = fromRational' True 32 zeroOneToFix fromInteger - -instance Fractional Fix32 where - recip = recip' 32 - fromRational = fromRational' True 32 zeroOneToFix32 fromInteger - -instance Fractional UFix32 where - recip = recip' 31 - fromRational = fromRational' False 31 zeroOneToUFix32 fromInteger - -instance Fractional Fix16 where - recip = recip' 16 - fromRational = fromRational' True 16 zeroOneToFix16 fromInteger + m = abs m1 -instance Fractional UFix16 where - recip = recip' 15 - fromRational = fromRational' False 15 zeroOneToUFix16 fromInteger +fixSignum :: (Bounded a,Numeric a, Bits a, Ord a, Range a ~ Size a, Prelude.Real a) => Fix a -> Fix a +fixSignum f1@(Fix e1 m1) = Fix 0 m + where + m = signum m1 -instance Fractional Fix8 where - recip = recip' 8 - fromRational = fromRational' True 8 zeroOneToFix8 fromInteger +fixFromInteger :: (Bounded a,Numeric a, Bits a, Ord a, Range a ~ Size a, Prelude.Real a) => Integer -> Fix a +fixFromInteger i = Fix 0 m + where + m = fromInteger i -instance Fractional UFix8 where - recip = recip' 7 - fromRational = fromRational' False 7 zeroOneToUFix8 fromInteger +fixDiv' :: (Bounded a,Numeric a, Bits a, Ord a, Range a ~ Size a, Prelude.Real a,Integral a) => Fix a -> Fix a -> Fix a +fixDiv' f1@(Fix e1 m1) f2@(Fix e2 m2) = Fix e m + where + e = e1-e2 + m = div m1 m2 -class FixFloatLike a where - addFF :: Int -> a -> a -> a - recipFF :: Int -> a -> a - divFF :: Int -> a -> a -> a +fixRecip' :: forall a . (Bounded a,Numeric a, Bits a, Ord a, Range a ~ Size a, Prelude.Real a,Integral a) => Fix a -> Fix a +fixRecip' f@(Fix e m) = Fix (e + (value $ wordLength (T :: T a) - 1)) (div sh m) + where + sh :: Data a + sh = (1::Data a) << (value $ fromInteger $ toInteger $ wordLength (T :: T a) - 1) -instance FixFloatLike (Data Float) where - addFF _ x y = x + y - recipFF _ x = 1/x - divFF _ x y = x/y +fixfromRational :: forall a . (Range a ~ Size a, Numeric a, Integral a, Num a,Type a) => + Prelude.Rational -> Fix a +fixfromRational inp = Fix exponent mantissa + where + inpAsFloat :: Float + inpAsFloat = fromRational inp + intPart :: Float + intPart = fromRational $ toRational $ (Prelude.floor inpAsFloat) + intPartWidth :: DefaultInt + intPartWidth = Prelude.ceiling $ logBase 2 intPart + fracPartWith :: DefaultInt + fracPartWith = (wordLength (T :: T a)) - intPartWidth - 2 + mantissa = value $ Prelude.floor $ inpAsFloat * 2.0 ** fromRational (toRational fracPartWith) + exponent = negate $ value fracPartWith +instance (Type a) => EdgeInfo (Fix a) + where + type Info (Fix a) = EdgeSize () (DefaultInt, a) + edgeInfo = edgeInfo . toEdge -instance FixFloatLike Fix where - addFF = addFix'' - recipFF = recipFix' - divFF = divFix' +instance (Type a) => MultiEdge (Fix a) Feldspar EdgeSize + where + type Role (Fix a) = () + type Internal (Fix a) = (DefaultInt, a) + toEdge = toEdge . freezeFix + fromInEdge = unfreezeFix . fromInEdge + fromOutEdge info = unfreezeFix . fromOutEdge info -instance FixFloatLike Fix32 where - addFF = addFix32 - recipFF = recipFix32 - divFF = divFix32 +instance (Type a) => Syntactic (Fix a) -instance FixFloatLike UFix32 where - addFF = addUFix32 - recipFF = recipUFix32 - divFF = divUFix32 +-- | Convers an abstract real number to a pair of exponent and mantissa +freezeFix :: (Type a) => Fix a -> Data (DefaultInt,a) +freezeFix (Fix e m) = pair e m -instance FixFloatLike Fix16 where - addFF = addFix16 - recipFF = recipFix16 - divFF = divFix16 +-- | Convers an abstract real number to fixed point integer with given exponent +freezeFix' :: (Bits a) => DefaultInt -> Fix a -> Data a +freezeFix' e f = mantissa $ fix (value e) f -instance FixFloatLike UFix16 where - addFF = addUFix16 - recipFF = recipUFix16 - divFF = divUFix16 +-- | Converts a pair of exponent and mantissa to an abstract real number +unfreezeFix :: (Type a) => Data (DefaultInt,a) -> Fix a +unfreezeFix p = Fix (getFst p) (getSnd p) -instance FixFloatLike Fix8 where - addFF = addFix8 - recipFF = recipFix8 - divFF = divFix8 +-- | Converts a fixed point integer with given exponent to an abstract real number +unfreezeFix' :: DefaultInt -> Data a -> Fix a +unfreezeFix' e m = Fix (value e) m -instance FixFloatLike UFix8 where - addFF = addUFix8 - recipFF = recipUFix8 - divFF = divUFix8 +significantBits :: forall a . (Type a, Size a ~ Range a, Num a, Ord a, Prelude.Real a) => Data a -> DefaultInt +significantBits x = DefaultInt $ fromInteger $ toInteger $ (Prelude.floor mf)+1 + where + r :: Range a + r = dataSize x + m :: a + m = Prelude.max (Prelude.abs $ lowerBound r) (Prelude.abs $ upperBound r) + mf :: Float + mf = logBase 2 $ fromRational $ toRational m +setSignificantBits :: forall a . (Type a, Size a ~ Range a, Num a, Ord a, Prelude.Real a) => a -> Data a -> Data a +setSignificantBits sb x = resizeData r x + where + r :: Range a + r = Range 0 sb -class FromFloat t where - float :: Float -> t +wordLength :: forall a . (Prelude.Bounded a,Type a,Size a ~ Range a,Num a,Ord a,Prelude.Real a) => T a -> DefaultInt +wordLength x = (Prelude.ceiling $ logBase 2 $ fromRational $ toRational (maxBound :: a)) + 1 -instance FromFloat (Data Float) where - float = value +wordLength' :: forall a . (Prelude.Bounded a,Prelude.Real a) => a -> DefaultInt +wordLength' x = swl + where + b :: a + wl :: DefaultInt + swl :: DefaultInt + b = maxBound::a + wl = Prelude.ceiling $ logBase 2 $ fromRational $ toRational b + swl = wl + 1 -instance FromFloat Fix where - float = floatToFix +-- | Operations to get and set exponent +class (Splittable t) => Fixable t where + fix :: Data DefaultInt -> t -> t + getExp :: t -> Data DefaultInt -instance FromFloat Fix32 where - float = floatToFix32 +instance (Bits a) => Fixable (Fix a) where + fix e' (Fix e m) = Fix e' $ e' > e ? (m >> i2n (e' - e), m << i2n (e - e')) + getExp = Feldspar.FixedPoint.exponent -instance FromFloat UFix32 where - float = floatToUFix32 +instance Fixable (Data Float) where + fix = const id + getExp = const $ fromInteger $ toInteger $ Feldspar.exponent (0.0 :: Float) -instance FromFloat Fix16 where - float = floatToFix16 +data T a = T -instance FromFloat UFix16 where - float = floatToUFix16 +-- | Operations to split data into dynamic and static parts +class (Syntactic (Dynamic t)) => Splittable t where + type Static t + type Dynamic t + store :: t -> (Static t, Dynamic t) + retrieve :: (Static t, Dynamic t) -> t + patch :: Static t -> t -> t + common :: t -> t -> Static t -instance FromFloat Fix8 where - float = floatToFix8 +instance (Type a) => Splittable (Data a) where + type Static (Data a) = () + type Dynamic (Data a) = Data a + store x = ((),x) + retrieve = snd + patch = const id + common _ _ = () -instance FromFloat UFix8 where - float = floatToUFix8 +instance (Type a, Bits a) => Splittable (Fix a) where + type Static (Fix a) = Data DefaultInt + type Dynamic (Fix a) = Data a + store f = (Feldspar.FixedPoint.exponent f, mantissa f) + retrieve = uncurry Fix + patch = fix + common f g = max (Feldspar.FixedPoint.exponent f) (Feldspar.FixedPoint.exponent g) --- Helper functions to generate shift with non-negative parameter -leftShift :: Bits a => Data a -> Int -> Data a -leftShift a b - | b Prelude.>= 0 = a << value b - | otherwise = a >> value (Prelude.negate b) +-- | A version of vector fold for fixed point algorithms +fixFold :: forall a b . (Splittable a) => (a -> b -> a) -> a -> Vector b -> a +fixFold fun ini vec = retrieve (static, fold fun' ini' vec) + where + static = fst $ store ini + ini' = snd $ store ini + fun' st el = snd $ store $ patch static $ retrieve (static,st) `fun` el -rightShift :: Bits a => Data a -> Int -> Data a -rightShift a b - | b Prelude.>= 0 = a >> value b - | otherwise = a << value (Prelude.negate b) +-- | A version of branching for fixed point algorithms +infix 1 ?! +(?!) :: forall a . (Syntactic a, Splittable a) => Data Bool -> (a,a) -> a +cond ?! (x,y) = retrieve (comm, cond ? (x',y')) + where + comm = common x y + x' = snd $ store $ patch comm x + y' = snd $ store $ patch comm y diff --git a/Feldspar/Haskell.hs b/Feldspar/Haskell.hs deleted file mode 100644 --- a/Feldspar/Haskell.hs +++ /dev/null @@ -1,101 +0,0 @@ --- --- Copyright (c) 2009-2010, ERICSSON AB All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * 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. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT HOLDER 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. --- - --- | Helper functions for producing Haskell code - -module Feldspar.Haskell where - - - -import Data.List - - - --- | Types that can represent Haskell types (as source code strings) -class HaskellType a - where - -- | Gives the Haskell type denoted by the argument. - haskellType :: a -> String - - - --- | Types that can represent Haskell values (as source code strings) -class HaskellValue a - where - -- | Gives the Haskell code denoted by the argument. - haskellValue :: a -> String - -instance HaskellValue String - where - haskellValue = id - -instance HaskellValue Int - where - haskellValue = show - - - --- | Like 'Data.List.unlines', but no trailing @\'\\n\'@. -unlinesNoTrail :: [String] -> String -unlinesNoTrail = intercalate "\n" - --- | Indents a string the given number of columns. -indent :: Int -> String -> String -indent n = unlinesNoTrail . map (spc ++) . lines - where - spc = replicate n ' ' - -newline :: String -newline = "\n" - --- | Application -(-$-) :: HaskellValue a => String -> a -> String -fun -$- inp = unwords [fun, haskellValue inp] - --- | Binary operator application -opApp :: (HaskellValue a, HaskellValue b) => String -> a -> b -> String -opApp op a b = unwords [haskellValue a, op, haskellValue b] - --- | Definition -(-=-) :: (HaskellValue patt, HaskellValue def) => patt -> def -> String -patt -=- def = unwords [haskellValue patt, "=", haskellValue def] - --- Places the second string as a local block to the first string. -local :: String -> String -> String -local def "" = def -local def defs = def ++ newline ++ indent 2 "where" ++ newline ++ indent 4 defs - -infixl 8 -$- -infix 7 -=- -infixr 6 `local` - -ifThenElse - :: (HaskellValue c, HaskellValue t, HaskellValue e) => c -> t -> e -> String -ifThenElse c t e = unwords - ["if", haskellValue c, "then", haskellValue t, "else", haskellValue e] - diff --git a/Feldspar/Matrix.hs b/Feldspar/Matrix.hs --- a/Feldspar/Matrix.hs +++ b/Feldspar/Matrix.hs @@ -1,30 +1,4 @@ --- --- Copyright (c) 2009-2010, ERICSSON AB All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * 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. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT HOLDER 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. --- +{-# LANGUAGE UndecidableInstances #-} -- | Operations on matrices (doubly-nested parallel vectors). All operations in -- this module assume rectangular matrices. @@ -34,9 +8,10 @@ import qualified Prelude as P +import Data.List (genericLength) +import qualified Data.TypeLevel as TL import Feldspar.Prelude -import Feldspar.Utils import Feldspar.Core import Feldspar.Vector @@ -47,26 +22,22 @@ -- | Converts a matrix to a core array. -freezeMatrix :: Storable a => Matrix a -> Data [[a]] +freezeMatrix :: Type a => Matrix a -> Data [[a]] freezeMatrix = freezeVector . map freezeVector +-- | Converts a core array to a matrix. +unfreezeMatrix :: Type a => Data [[a]] -> Matrix a +unfreezeMatrix = map unfreezeVector . unfreezeVector + -- | Converts a core array to a matrix. The first length argument is the number -- of rows (outer vector), and the second argument is the number of columns -- (inner argument). -unfreezeMatrix :: Storable a => Data Length -> Data Length -> Data [[a]] -> Matrix a -unfreezeMatrix y x = map (unfreezeVector x) . (unfreezeVector y) +unfreezeMatrix' :: Type a => Length -> Length -> Data [[a]] -> Matrix a +unfreezeMatrix' y x = map (unfreezeVector' x) . (unfreezeVector' y) -- | Constructs a matrix. The elements are stored in a core array. -matrix :: Storable a => [[a]] -> Matrix a -matrix as - | allEqual xs = unfreezeMatrix y x (value as) - | otherwise = error "matrix: Not rectangular" - where - xs = P.map P.length as - y = value $ P.length as - x = value $ P.head (xs P.++ [0]) - - +matrix :: Type a => [[a]] -> Matrix a +matrix = unfreezeMatrix . value -- | Constructing a matrix from an index function. -- @@ -78,25 +49,21 @@ -- -- * @ifx@ is a function mapping indexes to elements (first argument is row -- index; second argument is column index). -indexedMat :: - Data Int -> Data Int -> (Data Int -> Data Int -> Data a) -> Matrix a - +indexedMat + :: Data Length + -> Data Length + -> (Data Index -> Data Index -> Data a) + -> Matrix a indexedMat m n idx = indexed m $ \k -> indexed n $ \l -> idx k l - - -- | Transpose of a matrix -transpose :: Matrix a -> Matrix a +transpose :: Type a => Matrix a -> Matrix a transpose a = indexedMat (length $ head a) (length a) $ \y x -> a ! x ! y - -- XXX This assumes that (head a) can be used even if a is empty. Might this - -- violate size constraints on the index? - -- See the conditional in 'flatten'. - - + -- TODO This assumes that (head a) can be used even if a is empty. -- | Concatenates the rows of a matrix. -flatten :: Matrix a -> Vector (Data a) -flatten matr = Indexed (m*n) ixf +flatten :: Type a => Matrix a -> Vector (Data a) +flatten matr = Indexed (m*n) ixf Empty where m = length matr n = (m==0) ? (0, length (head matr)) @@ -105,18 +72,14 @@ where y = i `div` n x = i `mod` n - -- XXX Should use "linear indexing" - - + -- TODO Should use linear indexing -- | The diagonal vector of a square matrix. It happens to work if the number of -- rows is less than the number of columns, but not the other way around (this -- would require some overhead). -diagonal :: Matrix a -> Vector (Data a) +diagonal :: Type a => Matrix a -> Vector (Data a) diagonal m = zipWith (!) m (0 ... (length m - 1)) - - distributeL :: (a -> b -> c) -> a -> Vector b -> Vector c distributeL f = map . f @@ -130,88 +93,77 @@ type Prod a b -- | General multiplication operator - (**) :: a -> b -> Prod a b - -- XXX This symbol should probably be used for exponentiation instead. + (***) :: a -> b -> Prod a b instance Numeric a => Mul (Data a) (Data a) where type Prod (Data a) (Data a) = Data a - (**) = (*) + (***) = (*) instance Numeric a => Mul (Data a) (DVector a) where type Prod (Data a) (DVector a) = DVector a - (**) = distributeL (**) + (***) = distributeL (***) instance Numeric a => Mul (DVector a) (Data a) where type Prod (DVector a) (Data a) = DVector a - (**) = distributeR (**) + (***) = distributeR (***) instance Numeric a => Mul (Data a) (Matrix a) where type Prod (Data a) (Matrix a) = Matrix a - (**) = distributeL (**) + (***) = distributeL (***) instance Numeric a => Mul (Matrix a) (Data a) where type Prod (Matrix a) (Data a) = Matrix a - (**) = distributeR (**) + (***) = distributeR (***) instance Numeric a => Mul (DVector a) (DVector a) where type Prod (DVector a) (DVector a) = Data a - (**) = scalarProd + (***) = scalarProd instance Numeric a => Mul (DVector a) (Matrix a) where type Prod (DVector a) (Matrix a) = (DVector a) - vec ** mat = distributeL (**) vec (transpose mat) + vec *** mat = distributeL (***) vec (transpose mat) instance Numeric a => Mul (Matrix a) (DVector a) where type Prod (Matrix a) (DVector a) = (DVector a) - (**) = distributeR (**) + (***) = distributeR (***) instance Numeric a => Mul (Matrix a) (Matrix a) where type Prod (Matrix a) (Matrix a) = (Matrix a) - (**) = distributeR (**) + (***) = distributeR (***) -- | Matrix multiplication mulMat :: Numeric a => Matrix a -> Matrix a -> Matrix a -mulMat = (**) - -{-# DEPRECATED mul "Please use `mulMat` or `(**)` instead." #-} --- | Matrix multiplication -mul :: Numeric a => Matrix a -> Matrix a -> Matrix a -mul = (**) +mulMat = (***) -class ElemWise a +class Syntactic a => ElemWise a where type Elem a -- | Operator for general element-wise multiplication elemWise :: (Elem a -> Elem a -> Elem a) -> a -> a -> a -instance ElemWise (Data a) +instance Type a => ElemWise (Data a) where type Elem (Data a) = Data a elemWise = id -instance ElemWise (DVector a) - where - type Elem (DVector a) = Data a - elemWise = zipWith - -instance ElemWise (Matrix a) +instance (ElemWise a, Syntactic (Vector a)) => ElemWise (Vector a) where - type Elem (Matrix a) = Data a - elemWise = elemWise . elemWise + type Elem (Vector a) = Elem a + elemWise = zipWith . elemWise (.+) :: (ElemWise a, Num (Elem a)) => a -> a -> a (.+) = elemWise (+) @@ -222,3 +174,12 @@ (.*) :: (ElemWise a, Num (Elem a)) => a -> a -> a (.*) = elemWise (*) +-- * Wrapping for matrices + +instance (Type a) => Wrap (Matrix a) (Data [[a]]) where + wrap = freezeMatrix + +instance (Wrap t u, Type a, TL.Nat row, TL.Nat col) => Wrap (Matrix a -> t) (Data' (row,col) [[a]] -> u) where + wrap f = \(Data' d) -> wrap $ f $ unfreezeMatrix' row' col' d where + row' = fromInteger $ toInteger $ TL.toInt (undefined :: row) + col' = fromInteger $ toInteger $ TL.toInt (undefined :: col) diff --git a/Feldspar/Prelude.hs b/Feldspar/Prelude.hs --- a/Feldspar/Prelude.hs +++ b/Feldspar/Prelude.hs @@ -1,33 +1,5 @@ --- --- Copyright (c) 2009-2010, ERICSSON AB All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * 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. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT HOLDER 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. --- - --- | Reexports the "Prelude", but hides all identifiers that are redefined in --- the "Feldspar" library. +-- | Reexports the "Prelude" hiding all identifiers that are redefined in the +-- "Feldspar" library. module Feldspar.Prelude ( module Prelude @@ -42,7 +14,7 @@ , (<), (>), (<=), (>=) , not, (&&), (||) , min, max - , (^), (**) + , (^) , Integral , quot, rem , div, mod @@ -61,5 +33,7 @@ , map , zipWith , sum + , Real + , truncate, round, ceiling, floor ) diff --git a/Feldspar/Range.hs b/Feldspar/Range.hs --- a/Feldspar/Range.hs +++ b/Feldspar/Range.hs @@ -1,803 +1,1008 @@ --- --- Copyright (c) 2009-2010, ERICSSON AB All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * 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. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT HOLDER 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. --- - -{-# LANGUAGE NoMonomorphismRestriction #-} - --- | Ranged values - -module Feldspar.Range where - - - -import Control.Monad -import Data.Maybe -import Data.Monoid -import Data.Bits -import Data.Word -import Test.QuickCheck hiding ((.&.)) -import qualified Test.QuickCheck as QC -import System.Random -- Should maybe be exported from QuickCheck -import Text.Printf - - -data Ord a => Range a = Range - { lowerBound :: Maybe a - , upperBound :: Maybe a - } - deriving (Eq, Show) - - - -instance (Ord a, Num a) => Num (Range a) - where - fromInteger = singletonRange . fromInteger - - negate = rangeOp neg - where - neg (Range l u) = Range (liftM negate u) (liftM negate l) - - (+) = rangeOp2 add - where - add (Range l1 u1) (Range l2 u2) = - Range (liftM2 (+) l1 l2) (liftM2 (+) u1 u2) - - (*) = rangeMul - - abs = rangeOp abs' - where - abs' r@(Range l u) - | isNatural r = r - | isNegative r = Range (liftM abs u) (liftM abs l) - | otherwise = - Range (Just 0) (liftM2 max (liftM abs l) (liftM abs u)) - - signum = rangeOp sign - where - sign r - | range (-1) 1 `isSubRangeOf` r = range (-1) 1 - | range (-1) 0 `isSubRangeOf` r = range (-1) 0 - | range 0 1 `isSubRangeOf` r = range 0 1 - | singletonRange 0 `isSubRangeOf` r = singletonRange 0 - | isNatural r = singletonRange 1 - | isNegative r = singletonRange (-1) - -instance (Ord a, Num a) => Monoid (Range a) - where - mempty = emptyRange - mappend = (\/) - - - -rangeOp :: Ord a => (Range a -> Range a) -> (Range a -> Range a) -rangeOp f r = if isEmpty r then r else f r - -rangeOp2 :: Ord a => - (Range a -> Range a -> Range a) -> (Range a -> Range a -> Range a) -rangeOp2 f r1 r2 - | isEmpty r1 = r1 - | isEmpty r2 = r2 - | otherwise = f r1 r2 - -mapMonotonic :: (Ord a, Ord b) => (a -> b) -> Range a -> Range b -mapMonotonic f (Range l u) = Range (liftM f l) (liftM f u) - -rangeMul :: (Ord a, Num a) => Range a -> Range a -> Range a -rangeMul r1 r2 = p1 \/ p2 \/ p3 \/ p4 - where - split r = (r /\ negativeRange, r /\ naturalRange) - - (r1neg,r1pos) = split r1 - (r2neg,r2pos) = split r2 - - p1 = mul (negate r1neg) (negate r2neg) - p2 = negate $ mul (negate r1neg) r2pos - p3 = negate $ mul r1pos (negate r2neg) - p4 = mul r1pos r2pos - - mul = rangeOp2 mul' - where - mul' (Range l1 u1) (Range l2 u2) = - Range (liftM2 (*) l1 l2) (liftM2 (*) u1 u2) - - - -emptyRange :: (Ord a, Num a) => Range a -emptyRange = Range (Just 0) (Just (-1)) - -fullRange :: Ord a => Range a -fullRange = Range Nothing Nothing - -range :: Ord a => a -> a -> Range a -range l u = Range (Just l) (Just u) - -rangeByRange :: Ord a => Range a -> Range a -> Range a -rangeByRange r1 r2 = Range (lowerBound r1) (upperBound r2) - -singletonRange :: Ord a => a -> Range a -singletonRange a = Range (Just a) (Just a) - -naturalRange :: (Ord a, Num a) => Range a -naturalRange = Range (Just 0) Nothing - -negativeRange :: (Ord a, Num a) => Range a -negativeRange = Range Nothing (Just (-1)) - -rangeSize :: (Ord a, Num a) => Range a -> Maybe a -rangeSize (Range l u) = do - l' <- l - u' <- u - return (u'-l'+1) - -isEmpty :: Ord a => Range a -> Bool -isEmpty (Range Nothing _) = False -isEmpty (Range _ Nothing) = False -isEmpty (Range (Just l) (Just u)) = u < l - -isFull :: Ord a => Range a -> Bool -isFull (Range Nothing Nothing) = True -isFull _ = False - -isBounded :: Ord a => Range a -> Bool -isBounded (Range Nothing _) = False -isBounded (Range _ Nothing) = False -isBounded (Range _ _) = True - -isSingleton :: Ord a => Range a -> Bool -isSingleton (Range (Just l) (Just u)) = l==u -isSingleton _ = False - -isSubRangeOf :: Ord a => Range a -> Range a -> Bool -isSubRangeOf r1@(Range l1 u1) r2@(Range l2 u2) - | isEmpty r1 = True - | isEmpty r2 = False - | otherwise - = (isNothing l2 || (isJust l1 && l1>=l2)) - && (isNothing u2 || (isJust u1 && u1<=u2)) - --- | Checks whether a range is a sub-range of the natural numbers. -isNatural :: (Ord a, Num a) => Range a -> Bool -isNatural = (`isSubRangeOf` naturalRange) - --- | Checks whether a range is a sub-range of the negative numbers. -isNegative :: (Ord a, Num a) => Range a -> Bool -isNegative = (`isSubRangeOf` negativeRange) - -inRange :: Ord a => a -> Range a -> Bool -inRange a r = singletonRange a `isSubRangeOf` r - -rangeGap :: (Ord a, Num a) => Range a -> Range a -> Range a -rangeGap = rangeOp2 gap - where - gap (Range _ (Just u1)) (Range (Just l2) _) - | u1 < l2 = Range (Just u1) (Just l2) - gap (Range (Just l1) _) (Range _ (Just u2)) - | u2 < l1 = Range (Just u2) (Just l1) - gap _ _ = emptyRange - -- If the result is non-empty, it will include the boundary elements from the - -- two ranges. - - - -(\/) :: Ord a => Range a -> Range a -> Range a -r1 \/ r2 - | isEmpty r1 = r2 - | isEmpty r2 = r1 - | otherwise = or r1 r2 - where - or (Range l1 u1) (Range l2 u2) = - Range (liftM2 min l1 l2) (liftM2 max u1 u2) - -liftMaybe2 :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a -liftMaybe2 f Nothing b = b -liftMaybe2 f a Nothing = a -liftMaybe2 f (Just a) (Just b) = Just (f a b) - -(/\) :: Ord a => Range a -> Range a -> Range a -(/\) = rangeOp2 and - where - and (Range l1 u1) (Range l2 u2) = - Range (liftMaybe2 max l1 l2) (liftMaybe2 min u1 u2) - -disjoint :: (Ord a, Num a) => Range a -> Range a -> Bool -disjoint r1 r2 = isEmpty (r1 /\ r2) - --- | @r1 \`rangeLess\` r2:@ --- --- Checks if all elements of @r1@ are less than all elements of @r2@. -rangeLess :: Ord a => Range a -> Range a -> Bool -rangeLess r1 r2 - | isEmpty r1 || isEmpty r2 = True -rangeLess (Range _ (Just u1)) (Range (Just l2) _) = u1 < l2 -rangeLess _ _ = False - --- | @r1 \`rangeLessEq\` r2:@ --- --- Checks if all elements of @r1@ are less than or equal to all elements of --- @r2@. -rangeLessEq :: Ord a => Range a -> Range a -> Bool -rangeLessEq (Range _ (Just u1)) (Range (Just l2) _) = u1 <= l2 -rangeLessEq _ _ = False - --- | @rangeAddUnsigned@ correctly and accurately propagates range --- information through an unsigned addition. Code is borrowed from --- Hacker's Delight. -rangeAddUnsigned :: (Ord a, Num a, Bounded a) => Range a -> Range a -> Range a -rangeAddUnsigned = - rangeProp2 $ \a b c d -> - if a + c >= a && b + d < b - then fullRange - else range (a + c) (b + d) - --- | @rangeAddSigned@ correctly and accurately propagates range --- information through a signed addition. Code is borrowed from --- Hacker's Delight. -rangeAddSigned :: (Ord a, Num a, Bounded a, Bits a) => - Range a -> Range a -> Range a -rangeAddSigned = - rangeProp2 $ \a b c d -> - let s = a + c - t = b + d - u = a .&. c .&. complement s .&. - complement (b .&. d .&. complement t) - v = ((xor a c) .|. complement (xor a s)) .&. - (complement b .&. complement d .&. t) - in if (u .|. v) < 0 - then fullRange - else range s t - --- | @rangeSubUnsigned@ propagates range information through unsigned --- subtraction. Code is borrowed from Hacker's Delight -rangeSubUnsigned :: (Ord a, Num a, Bounded a) => Range a -> Range a -> Range a -rangeSubUnsigned = - rangeProp2 $ \a b c d -> - let s = a - d - t = b - c - in if s > a && t <= b - then fullRange - else range s t - --- | Propagates range information through unsigned negation. Code from --- Hacker's Delight -rangeNegUnsigned :: (Ord a, Num a, Bounded a) => Range a -> Range a -rangeNegUnsigned = - rangeProp1 $ \a b -> - if a == 0 && b /= 0 - then fullRange - else range (-b) (-a) - --- | Propagates range information through signed negation. Code from --- Hacker's Delight. -rangeNegSigned :: (Ord a, Num a, Bounded a) => Range a -> Range a -rangeNegSigned = - rangeProp1 $ \a b -> - if a == minBound && b == minBound - then singletonRange minBound - else if a == minBound - then fullRange - else range (-b) (-a) - --- | Cheap and inaccurate range propagation for '.|.' on unsigned numbers. --- Code from Hacker's Delight -rangeOrUnsignedCheap :: (Ord a, Num a, Bounded a) => - Range a -> Range a -> Range a -rangeOrUnsignedCheap = - rangeProp2 $ \a b c d -> range (max a c) (maxPlus b d) - -maxPlus b d = if sum < b then maxBound - else sum - where sum = b + d - --- | Accurate lower bound for '.|.' on unsigned numbers. -minOrUnsigned :: (Ord a, Num a, Bits a) => a -> a -> a -> a -> a -minOrUnsigned a b c d = loop (bit (bitSize a - 1)) - where loop 0 = a .|. c - loop m - | complement a .&. c .&. m > 0 = - let temp = (a .|. m) .&. negate m - in if temp <= b - then temp .|. c - else loop (shiftR m 1) - | a .&. complement c .&. m > 0= - let temp = (c .|. m) .&. negate m - in if temp <= d - then a .|. temp - else loop (shiftR m 1) - | otherwise = loop (shiftR m 1) - --- | Accurate upper bound for '.|.' on unsigned numbers. -maxOrUnsigned :: (Ord a, Num a, Bits a) => a -> a -> a -> a -> a -maxOrUnsigned a b c d= loop (bit (bitSize a - 1)) - where loop 0 = b .|. d - loop m - | b .&. d .&. m > 0 = - let temp = (b - m) .|. (m - 1) - in if temp >= a - then temp .|. d - else let temp = (d - m) .|. (m - 1) - in if temp >= c - then b .|. temp - else loop (shiftR m 1) - | otherwise = loop (shiftR m 1) - -rangeOrUnsignedAccurate :: (Ord a, Num a, Bits a, Bounded a) => - Range a -> Range a -> Range a -rangeOrUnsignedAccurate = - rangeProp2 $ \a b c d -> - range (minOrUnsigned a b c d) (maxOrUnsigned a b c d) - --- | Cheap and inaccurate range propagation for '.&.' on unsigned numbers. --- Code from Hacker's Delight -rangeAndUnsignedCheap :: (Ord a, Num a, Bounded a) => - Range a -> Range a -> Range a -rangeAndUnsignedCheap = rangeProp2 $ \a b c d -> range 0 (min b d) - --- | Range propagation for 'xor' on unsigned numbers. --- Code from Hacker's Delight -rangeXorUnsigned :: (Ord a, Num a, Bounded a) => Range a -> Range a -> Range a -rangeXorUnsigned = rangeProp2 (\a b c d -> range 0 (maxPlus b d)) - --- | Auxiliary function for writing range propagation --- functions. Especially suitable for the code borrowed from Hacker's --- Delight. -rangeProp1 :: (Ord a, Bounded a) => (a -> a -> Range a) -> Range a -> Range a -rangeProp1 f (Range l u) = f a b - where toUpper Nothing = maxBound - toUpper (Just u) = u - toLower Nothing = minBound - toLower (Just l) = l - a = toLower l - b = toUpper u - --- | Auxiliary function for writing range propagation functions for --- two argument functions. Especially suitable for the code borrowed --- from Hacker's Delight. -rangeProp2 :: (Ord a, Bounded a) => - (a -> a -> a -> a -> Range a) -> Range a -> Range a -> Range a -rangeProp2 f (Range l1 u1) (Range l2 u2) = - f a b c d - where toUpper Nothing = maxBound - toUpper (Just u) = u - toLower Nothing = minBound - toLower (Just l) = l - a = toLower l1 - b = toUpper u1 - c = toLower l2 - d = toUpper u2 - --- | Propagates range information through @max@. -rangeMax :: Ord a => Range a -> Range a -> Range a -rangeMax r1 r2 - | isEmpty r1 = r2 - | isEmpty r2 = r1 -rangeMax r1 r2 - | r1 `rangeLess` r2 = r2 - | r2 `rangeLess` r1 = r1 -rangeMax (Range (Just l1) u1) (Range (Just l2) u2) - | l1 < l2 = Range (Just l2) (liftM2 max u1 u2) - | otherwise = Range (Just l1) (liftM2 max u1 u2) -rangeMax (Range Nothing u1) (Range (Just l2) u2) - = Range (Just l2) (liftM2 max u1 u2) -rangeMax (Range (Just l1) u1) (Range Nothing u2) - = Range (Just l1) (liftM2 max u1 u2) -rangeMax (Range Nothing u1) (Range Nothing u2) - = Range Nothing (liftM2 max u1 u2) - --- | Analogous to 'rangeMax' -rangeMin :: Ord a => Range a -> Range a -> Range a -rangeMin r1 r2 - | isEmpty r1 = r2 - | isEmpty r2 = r1 -rangeMin r1 r2 - | r1 `rangeLess` r2 = r1 - | r2 `rangeLess` r1 = r2 -rangeMin (Range l1 (Just u1)) (Range l2 (Just u2)) - | u1 < u2 = Range (liftM2 min l1 l2) (Just u1) - | otherwise = Range (liftM2 min l1 l2) (Just u2) -rangeMin (Range l1 Nothing) (Range l2 (Just u2)) - = Range (liftM2 min l1 l2) (Just u2) -rangeMin (Range l1 (Just u1)) (Range l2 Nothing) - = Range (liftM2 min l1 l2) (Just u1) -rangeMin (Range l1 Nothing) (Range l2 Nothing) - = Range (liftM2 min l1 l2) Nothing - --- | Propagates range information through 'mod'. --- Note that we assume Haskell semantics for 'mod'. -rangeMod :: (Num a, Ord a, Enum a) => Range a -> Range a -> Range a -rangeMod d r - | d `rangeLess` r && isNatural r && isNatural d = d - | isNatural r = Range (Just 0) (fmap pred (upperBound r)) - | r `rangeLess` d && isNegative r && isNegative d = d - | isNegative r = Range (fmap succ (lowerBound r)) (Just 0) - where - isNegative = (`isSubRangeOf` negativeRange) - negativeRange = Range Nothing (Just 0) -rangeMod d (Range l u) - = Range (fmap succ l) (fmap pred u) - --- | Propagates range information through 'rem'. --- Note that we assume Haskell semantics for 'rem'. -rangeRem :: (Num a, Ord a, Enum a) => Range a -> Range a -> Range a -rangeRem d r - | d `rangeLess` abs r && isNatural d = d - | isNatural d = Range (Just 0) (fmap pred (upperBound (abs r))) - | abs d `rangeLess` abs r && isNegative d = d - | isNegative d = Range (fmap negate (upperBound (abs r))) (Just 0) - where - isNegative = (`isSubRangeOf` negativeRange) - negativeRange = Range Nothing (Just 0) -rangeRem d r@(Range l u) - | l `betterThan` u = - Range (fmap (succ . negate .abs) l) (fmap (pred . abs) l) - | otherwise = - Range (fmap (succ . negate . abs) u) (fmap (pred . abs) upper) - where lower = lowerBound r - upper = upperBound r - betterThan (Just a) (Just b) = abs a >= abs b - betterThan Nothing (Just b) = True - betterThan (Just a) Nothing = False - betterThan Nothing Nothing = True - -showBound :: Show a => Maybe a -> String -showBound (Just a) = show a -showBound _ = "*" - -showRange :: (Show a, Ord a) => Range a -> String -showRange r@(Range l u) - | isEmpty r = "[]" - | isSingleton r = let Just a = upperBound r in show [a] - | otherwise = "[" ++ showBound l ++ "," ++ showBound u ++ "]" - - - -instance (Arbitrary a, Ord a, Num a) => Arbitrary (Range a) - where - arbitrary = do - lower <- arbitrary - size <- liftM abs arbitrary - upper <- frequency [(6, return (lower+size)), (1, return (lower-size))] - liftM2 Range (arbMaybe lower) (arbMaybe upper) - where - arbMaybe a = frequency [(5, return (Just a)), (1, return Nothing)] - -instance Random Word32 where - random g = (fromIntegral i,g') - where (i :: Int,g') = random g - randomR (l,u) g = (fromIntegral i,g') - where (i :: Integer, g') = randomR (fromIntegral l,fromIntegral u) g - -prop_arith1 :: (forall a . Num a => a -> a) -> Range Int -> Property -prop_arith1 op r = - not (isEmpty r) ==> - forAll (fromRange r) $ \x -> - op x `inRange` op r - - -prop_arith2 - :: (forall a . Num a => a -> a -> a) - -> Range Int -> Range Int -> Property -prop_arith2 op r1 r2 = rangePropagationSafety op op r1 r2 - - -prop_fromInteger = isSingleton . fromInteger - -prop_neg = prop_arith1 negate -prop_add = prop_arith2 (+) -prop_sub = prop_arith2 (-) -prop_mul = prop_arith2 (*) -prop_abs = prop_arith1 abs -prop_sign = prop_arith1 signum - -prop_addU = rangePropagationSafety ((+) :: Word32 -> Word32 -> Word32) - rangeAddUnsigned -prop_addS = rangePropagationSafety ((+) :: Int -> Int -> Int) - rangeAddSigned -prop_subU = rangePropagationSafety ((-) :: Word32 -> Word32 -> Word32) - rangeSubUnsigned -prop_negU = rangePropSafety1 (negate :: Word32 -> Word32) rangeNegUnsigned -prop_negS = rangePropSafety1 (negate :: Int -> Int) rangeNegSigned -prop_andUCheap = rangePropagationSafety ((.&.) :: Word32 -> Word32 -> Word32) - rangeAndUnsignedCheap -prop_orUCheap = rangePropagationSafety ((.|.) :: Word32 -> Word32 -> Word32) - rangeOrUnsignedCheap -prop_xorU = rangePropagationSafety (xor :: Word32 -> Word32 -> Word32) - rangeXorUnsigned - -prop_abs2 (r::Range Int) = isNatural (abs r) - -prop_empty = isEmpty (emptyRange :: Range Int) - -prop_full = isFull (fullRange :: Range Int) - -prop_isEmpty1 (r::Range Int) = isEmpty r ==> isBounded r -prop_isEmpty2 (r::Range Int) = isEmpty r ==> (upperBound r < lowerBound r) - -prop_isFull (r::Range Int) = isFull r ==> not (isBounded r) - -prop_fullRange = not $ isBounded (fullRange :: Range Int) - -prop_range (a::Int) (b::Int) = isBounded $ range a b - -prop_rangeByRange (r1::Range Int) (r2::Range Int) = - (rangeLess r1 r2 && not (isEmpty (r1/\r2))) ==> isEmpty (rangeByRange r1 r2) - -prop_singletonRange1 (a::Int) = isSingleton (singletonRange a) -prop_singletonRange2 (a::Int) = isBounded (singletonRange a) - -prop_singletonSize (r::Range Int) = isSingleton r ==> (rangeSize r == Just 1) - -prop_subRange (r1::Range Int) (r2::Range Int) = - ((r1 < r2) && (r2 < r1) && not (isEmpty r1)) ==> r1==r2 - where - (<) = isSubRangeOf - -prop_emptySubRange1 (r1::Range Int) (r2::Range Int) = - isEmpty r1 ==> (not (isEmpty r2) ==> not (r2 `isSubRangeOf` r1)) - -prop_emptySubRange2 (r1::Range Int) (r2::Range Int) = - isEmpty r1 ==> (not (isEmpty r2) ==> (r1 `isSubRangeOf` r2)) - -prop_isNegative (r::Range Int) = - not (isEmpty r) ==> (isNegative r ==> not (isNegative $ negate r)) - -prop_rangeGap (r1::Range Int) (r2::Range Int) = - (isEmpty gap1 && isEmpty gap2) || (gap1 == gap2) - where - gap1 = rangeGap r1 r2 - gap2 = rangeGap r2 r1 - -prop_union1 x (r1::Range Int) (r2::Range Int) = - ((x `inRange` r1) || (x `inRange` r2)) ==> (x `inRange` (r1\/r2)) - -prop_union2 x (r1::Range Int) (r2::Range Int) = - (x `inRange` (r1\/r2)) ==> - ((x `inRange` r1) || (x `inRange` r2) || (x `inRange` rangeGap r1 r2)) - -prop_union3 (r1::Range Int) (r2::Range Int) = r1 `isSubRangeOf` (r1\/r2) -prop_union4 (r1::Range Int) (r2::Range Int) = r2 `isSubRangeOf` (r1\/r2) - -prop_intersect1 x (r1::Range Int) (r2::Range Int) = - ((x `inRange` r1) && (x `inRange` r2)) ==> (x `inRange` (r1/\r2)) - -prop_intersect2 x (r1::Range Int) (r2::Range Int) = - (x `inRange` (r1/\r2)) ==> ((x `inRange` r1) && (x `inRange` r2)) - -prop_intersect3 (r1::Range Int) (r2::Range Int) = (r1/\r2) `isSubRangeOf` r1 -prop_intersect4 (r1::Range Int) (r2::Range Int) = (r1/\r2) `isSubRangeOf` r2 -prop_intersect5 (r1::Range Int) (r2::Range Int) = - isEmpty r1 || isEmpty r2 ==> isEmpty (r1/\r2) - -prop_disjoint x (r1::Range Int) (r2::Range Int) = - disjoint r1 r2 ==> (x `inRange` r1) ==> not (x `inRange` r2) - -prop_rangeLess1 (r1::Range Int) (r2::Range Int) = - rangeLess r1 r2 ==> disjoint r1 r2 - -prop_rangeLess2 (r1::Range Int) (r2::Range Int) = - not (isEmpty r1) && not (isEmpty r2) ==> - forAll (fromRange r1) $ \x -> - forAll (fromRange r2) $ \y -> - rangeLess r1 r2 ==> x < y - -prop_rangeLessEq (r1::Range Int) (r2::Range Int) = - not (isEmpty r1) && not (isEmpty r2) ==> - forAll (fromRange r1) $ \x -> - forAll (fromRange r2) $ \y -> - rangeLessEq r1 r2 ==> x <= y - -prop_rangeMax1 (r1::Range Int) = rangeMax r1 r1 == r1 - -prop_rangeMax2 (r1::Range Int) r2 = - not (isEmpty r1) && not (isEmpty r2) ==> - upperBound r1 <= upperBound max && upperBound r2 <= upperBound max - where - max = rangeMax r1 r2 - Nothing <= Nothing = True - Just _ <= Nothing = True - Just a <= Just b = a Prelude.<= b - _ <= _ = False - -prop_rangeMax3 (r1::Range Int) r2 = - not (isEmpty r1) && not (isEmpty r2) ==> - lowerBound (rangeMax r1 r2) == liftMaybe2 max (lowerBound r1) (lowerBound r2) - -prop_rangeMax4 (r1::Range Int) r2 = - not (isEmpty r1) && not (isEmpty r2) ==> - rangeMax r1 r2 == rangeMax r2 r1 - -prop_rangeMax5 (r1::Range Int) r2 = - (isEmpty r1 && not (isEmpty r2) ==> - rangeMax r1 r2 == r2) - QC..&. - (isEmpty r2 && not (isEmpty r1) ==> - rangeMax r1 r2 == r1) - -prop_rangeMax6 (v1::Int) v2 = - max v1 v2 `inRange` rangeMax (singletonRange v1) (singletonRange v2) - -prop_rangeMax7 (r1::Range Int) r2 = - rangePropagationSafety max rangeMax r1 r2 - -prop_rangeMin1 (r1::Range Int) = rangeMin r1 r1 == r1 - -prop_rangeMin2 (r1::Range Int) r2 = - not (isEmpty r1) && not (isEmpty r2) ==> - lowerBound min <= lowerBound r1 && lowerBound min <= lowerBound r2 - where - min = rangeMin r1 r2 - Nothing <= Nothing = True - Nothing <= Just _ = True - Just a <= Just b = a Prelude.<= b - _ <= _ = False - -prop_rangeMin3 (r1::Range Int) r2 = - not (isEmpty r1) && not (isEmpty r2) ==> - upperBound (rangeMin r1 r2) == liftMaybe2 min (upperBound r1) (upperBound r2) - -prop_rangeMin4 (r1::Range Int) r2 = - not (isEmpty r1) && not (isEmpty r2) ==> - rangeMin r1 r2 == rangeMin r2 r1 - -prop_rangeMin5 (r1::Range Int) r2 = - (isEmpty r1 && not (isEmpty r2) ==> - rangeMin r1 r2 == r2) - QC..&. - (isEmpty r2 && not (isEmpty r1) ==> - rangeMin r1 r2 == r1) - -prop_rangeMin6 (v1::Int) v2 = - min v1 v2 `inRange` rangeMin (singletonRange v1) (singletonRange v2) - -prop_rangeMin7 (r1::Range Int) r2 = - rangePropagationSafety min rangeMin r1 r2 - -prop_rangeMod1 (v1::Int) v2 = - v2 /= 0 ==> - mod v1 v2 `inRange` rangeMod (singletonRange v1) (singletonRange v2) - -prop_rangeMod2 = - rangePropagationSafetyPre mod rangeMod (\v1 (v2::Int) -> v2 /= 0) - -prop_rangeRem = - rangePropagationSafetyPre rem rangeRem (\v1 (v2::Int) -> v2 /= 0) - --- This function is useful for range propagation functions like --- rangeMax, rangeMod etc. --- It takes two ranges, picks an element out of either ranges and --- checks if applying the operation to the individual elements is in --- the resulting range after range propagation --- The third argument is a precondition that is satisfied before the test is run -rangePropagationSafetyPre :: (Random a, Ord a, Show a, Bounded a, - Random b, Ord b, Show b, Bounded b, - Ord c) => - (a -> b -> c) -> (Range a -> Range b -> Range c) -> - (a -> b -> Bool) -> - Range a -> Range b -> Property -rangePropagationSafetyPre op rop pre r1 r2 = - not (isEmpty r1) && not (isEmpty r2) ==> - forAll (fromRange r1) $ \v1 -> - forAll (fromRange r2) $ \v2 -> - pre v1 v2 ==> - op v1 v2 `inRange` rop r1 r2 - -rangePropagationSafety op rop r1 r2 = - rangePropagationSafetyPre op rop noPre r1 r2 - -noPre _ _ = True - -rangePropSafety1 :: (Ord a, Show a, Random a, Bounded a, Ord b) => - (a -> b) -> (Range a -> Range b) -> Range a -> Property -rangePropSafety1 op rop ran = - not (isEmpty ran) ==> - forAll (fromRange ran) $ \val -> - op val `inRange` rop ran - -lowBound,uppBound :: (Bounded a, Ord a) => Range a -> a -lowBound r | Just l <- lowerBound r = l -lowBound r = minBound -uppBound r | Just u <- upperBound r = u -uppBound r = maxBound - -fromRange :: (Random a, Bounded a, Ord a) => Range a -> Gen a -fromRange r = choose (lowBound r,uppBound r) - -testAll = do - -- This one is wrong but QuickCheck doesn't spot it - myCheck "prop_neg" prop_neg - - myCheck "prop_negU" prop_negU - myCheck "prop_negS" prop_negS - - -- These three suffer from overflow behaviour - myCheck "prop_add" prop_add - myCheck "prop_sub" prop_sub - myCheck "prop_mul" prop_mul - - myCheck "prop_addU" prop_addU - myCheck "prop_addS" prop_addS - myCheck "prop_subU" prop_subU - myCheck "prop_andUCheap" prop_andUCheap - myCheck "prop_orUCheap" prop_orUCheap - myCheck "prop_xorU" prop_xorU - - myCheck "prop_abs" prop_abs - myCheck "prop_sign" prop_sign - myCheck "prop_abs2" prop_abs2 - myCheck "prop_fromInteger" prop_fromInteger - myCheck "prop_empty" prop_empty - myCheck "prop_full" prop_full - myCheck "prop_isEmpty1" prop_isEmpty1 - myCheck "prop_isEmpty2" prop_isEmpty2 - myCheck "prop_isFull" prop_isFull - myCheck "prop_fullRange" prop_fullRange - myCheck "prop_range" prop_range - -- myCheck prop_rangeByRange - -- XXX "Arguments exhausted after 0 test" - -- Something must be wrong with generator... - myCheck "prop_singletonRange1" prop_singletonRange1 - myCheck "prop_singletonRange2" prop_singletonRange2 - myCheck "prop_singletonSize" prop_singletonSize - myCheck "prop_subRange" prop_subRange - myCheck "prop_emptySubRange1" prop_emptySubRange1 - myCheck "prop_emptySubRange2" prop_emptySubRange2 - myCheck "prop_isNegative" prop_isNegative - myCheck "prop_rangeGap" prop_rangeGap - myCheck "prop_union1" prop_union1 - myCheck "prop_union2" prop_union2 - myCheck "prop_union3" prop_union3 - myCheck "prop_union4" prop_union4 - myCheck "prop_intersect1" prop_intersect1 - myCheck "prop_intersect2" prop_intersect2 - myCheck "prop_intersect3" prop_intersect3 - myCheck "prop_intersect4" prop_intersect4 - myCheck "prop_intersect5" prop_intersect5 - myCheck "prop_disjoint" prop_disjoint - myCheck "prop_rangeLess1" prop_rangeLess1 - myCheck "prop_rangeLess2" prop_rangeLess2 - myCheck "prop_rangeLessEq" prop_rangeLessEq - myCheck "prop_rangeMax1" prop_rangeMax1 - myCheck "prop_rangeMax2" prop_rangeMax2 - myCheck "prop_rangeMax3" prop_rangeMax3 - myCheck "prop_rangeMax4" prop_rangeMax4 - myCheck "prop_rangeMax5" prop_rangeMax5 - myCheck "prop_rangeMax6" prop_rangeMax6 - myCheck "prop_rangeMax7" prop_rangeMax7 - myCheck "prop_rangeMin1" prop_rangeMin1 - myCheck "prop_rangeMin2" prop_rangeMin2 - myCheck "prop_rangeMin3" prop_rangeMin3 - myCheck "prop_rangeMin4" prop_rangeMin4 - myCheck "prop_rangeMin5" prop_rangeMin5 - myCheck "prop_rangeMin6" prop_rangeMin6 - myCheck "prop_rangeMin7" prop_rangeMin7 - myCheck "prop_rangeMod1" prop_rangeMod1 - myCheck "prop_rangeMod2" prop_rangeMod2 - myCheck "prop_rangeRem" prop_rangeRem - where - myCheck name test = - do printf "%-25s" name - quickCheckWith stdArgs {maxDiscard = 10000} test +{-# LANGUAGE UndecidableInstances #-} + +-- | Bounded integer ranges + +module Feldspar.Range where + + + +import Data.Bits +import Data.Int +import Data.Word +import Data.Typeable +import System.Random -- Should maybe be exported from QuickCheck +import Test.QuickCheck hiding ((.&.)) +import qualified Test.QuickCheck as QC +import Text.Printf + +import Feldspar.Set + + + +-------------------------------------------------------------------------------- +-- * Definition +-------------------------------------------------------------------------------- + +-- | A bounded range of values of type @a@ +data Range a = Range + { lowerBound :: a + , upperBound :: a + } + deriving (Eq, Show) + +-- | Convenience alias for bounded integers +class (Eq a, Ord a, Show a, Num a, Bounded a, Integral a, Bits a) => BoundedInt a +instance (Eq a, Ord a, Show a, Num a, Bounded a, Integral a, Bits a) => BoundedInt a + +-- | A convenience function for defining range propagation. +-- @handleSign propU propS@ chooses @propU@ for unsigned types and +-- @propS@ for signed types. +handleSign :: forall a b . BoundedInt a => + (Range a -> b) -> (Range a -> b) -> (Range a -> b) +handleSign u s + | isSigned (minBound::a) = s + | otherwise = u + +-- | Shows a bound. +showBound :: BoundedInt a => a -> String +showBound a + | a `elem` [maxBound,minBound] = "*" + | otherwise = show a + +-- | A textual representation of ranges. +showRange :: BoundedInt a => Range a -> String +showRange r@(Range l u) + | isEmpty r = "[]" + | isSingleton r = show u + | otherwise = "[" ++ showBound l ++ "," ++ showBound u ++ "]" + +-- | Requires a monotonic function +mapMonotonic :: (a -> b) -> Range a -> Range b +mapMonotonic f (Range l u) = Range (f l) (f u) + +-- | Requires a monotonic function +mapMonotonic2 :: (a -> b -> c) -> Range a -> Range b -> Range c +mapMonotonic2 f (Range l1 u1) (Range l2 u2) = Range (f l1 l2) (f u1 u2) + + + +-------------------------------------------------------------------------------- +-- * Set operations +-------------------------------------------------------------------------------- + +instance BoundedInt a => Set (Range a) + where + empty = emptyRange + universal = fullRange + (\/) = rangeUnion + (/\) = rangeIntersection + +-- | The range containing no elements +emptyRange :: BoundedInt a => Range a +emptyRange = Range maxBound minBound + +-- | The range containing all elements of a type +fullRange :: BoundedInt a => Range a +fullRange = Range minBound maxBound + +-- | Construct a range +range :: a -> a -> Range a +range = Range + +rangeByRange :: Range a -> Range a -> Range a +rangeByRange r1 r2 = Range (lowerBound r1) (upperBound r2) + -- TODO Think about semantics of this function + +-- | The range containing one element +singletonRange :: a -> Range a +singletonRange a = Range a a + +-- | The range from @0@ to the maximum element +naturalRange :: BoundedInt a => Range a +naturalRange = Range 0 maxBound + +-- | The range from the smallest negative element to @-1@. +-- Undefined for unsigned types +negativeRange :: BoundedInt a => Range a +negativeRange = Range minBound (-1) + +-- | The size of a range. Beware that the size may not always be representable +-- for signed types. For instance +-- @rangeSize (range minBound maxBound) :: Int@ gives a nonsense answer. +rangeSize :: BoundedInt a => Range a -> a +rangeSize (Range l u) = u-l+1 + +-- | Checks if the range is empty +isEmpty :: BoundedInt a => Range a -> Bool +isEmpty (Range l u) = u < l + +-- | Checks if the range contains all values of the type +isFull :: BoundedInt a => Range a -> Bool +isFull r = lowerBound r == minBound && upperBound r == maxBound + +-- | Checks is the range contains exactly one element +isSingleton :: BoundedInt a => Range a -> Bool +isSingleton (Range l u) = l==u + +-- | @r1 \`isSubRangeOf\` r2@ checks is all the elements in @r1@ are included +-- in @r2@ +isSubRangeOf :: BoundedInt a => Range a -> Range a -> Bool +isSubRangeOf r1@(Range l1 u1) r2@(Range l2 u2) + | isEmpty r1 = True + | isEmpty r2 = False + | otherwise = (l1>=l2) && (u1<=u2) + +-- | Checks whether a range is a sub-range of the natural numbers. +isNatural :: BoundedInt a => Range a -> Bool +isNatural = (`isSubRangeOf` naturalRange) + +-- | Checks whether a range is a sub-range of the negative numbers. +isNegative :: BoundedInt a => Range a -> Bool +isNegative = (`isSubRangeOf` negativeRange) + +-- | @a \`inRange\` r@ checks is @a@ is an element of the range @r@. +inRange :: BoundedInt a => a -> Range a -> Bool +inRange a r = singletonRange a `isSubRangeOf` r + +-- | A convenience function for defining range propagation. If the input +-- range is empty then the result is also empty. +rangeOp :: BoundedInt a => (Range a -> Range a) -> (Range a -> Range a) +rangeOp f r = if isEmpty r then r else f r + +-- | See 'rangeOp'. +rangeOp2 :: BoundedInt a => + (Range a -> Range a -> Range a) -> (Range a -> Range a -> Range a) +rangeOp2 f r1 r2 + | isEmpty r1 = r1 + | isEmpty r2 = r2 + | otherwise = f r1 r2 + +-- | Union on ranges. +rangeUnion :: BoundedInt a => Range a -> Range a -> Range a +r1 `rangeUnion` r2 + | isEmpty r1 = r2 + | isEmpty r2 = r1 + | otherwise = union r1 r2 + where + union (Range l1 u1) (Range l2 u2) = Range (min l1 l2) (max u1 u2) + +-- | Intersection on ranges. +rangeIntersection :: BoundedInt a => Range a -> Range a -> Range a +rangeIntersection = rangeOp2 intersection + where + intersection (Range l1 u1) (Range l2 u2) = Range (max l1 l2) (min u1 u2) + +-- | @disjoint r1 r2@ returns true when @r1@ and @r2@ have no elements in +-- common. +disjoint :: BoundedInt a => Range a -> Range a -> Bool +disjoint r1 r2 = isEmpty (r1 /\ r2) + +-- | @rangeGap r1 r2@ returns a range of all the elements between @r1@ and +-- @r2@ including the boundary elements. If @r1@ and @r2@ have elements in +-- common the result is an empty range. +rangeGap :: BoundedInt a => Range a -> Range a -> Range a +rangeGap = rangeOp2 gap + where + gap (Range l1 u1) (Range l2 u2) + | u1 < l2 = range u1 l2 + | u2 < l1 = range u2 l1 + gap _ _ = emptyRange + -- If the result is non-empty, it will include the boundary elements from the + -- two ranges. + +-- | @r1 \`rangeLess\` r2:@ +-- +-- Checks if all elements of @r1@ are less than all elements of @r2@. +rangeLess :: BoundedInt a => Range a -> Range a -> Bool +rangeLess r1 r2 + | isEmpty r1 || isEmpty r2 = True +rangeLess (Range _ u1) (Range l2 _) = u1 < l2 + +-- | @r1 \`rangeLessEq\` r2:@ +-- +-- Checks if all elements of @r1@ are less than or equal to all elements of +-- @r2@. +rangeLessEq :: BoundedInt a => Range a -> Range a -> Bool +rangeLessEq (Range _ u1) (Range l2 _) = u1 <= l2 + + + +-------------------------------------------------------------------------------- +-- * Propagation +-------------------------------------------------------------------------------- + +-- | Implements 'fromInteger' as a 'singletonRange', and implements correct +-- range propagation for arithmetic operations. +instance BoundedInt a => Num (Range a) + where + fromInteger = singletonRange . fromInteger + abs = rangeAbs + signum = rangeSignum + negate = rangeNeg + (+) = rangeAdd + (*) = rangeMul + +-- | Propagates range information through @abs@. +rangeAbs :: BoundedInt a => Range a -> Range a +rangeAbs = rangeOp $ \r -> case r of + Range l u + | isNatural r -> r + | r == singletonRange minBound -> r + | minBound `inRange` r -> range minBound maxBound + | isNegative r -> range (abs u) (abs l) + | otherwise -> range 0 (abs l `max` abs u) + +-- | Propagates range information through 'signum'. +rangeSignum :: BoundedInt a => Range a -> Range a +rangeSignum = handleSign rangeSignumUnsigned rangeSignumSigned + +-- | Signed case for 'rangeSignum'. +rangeSignumSigned :: BoundedInt a => Range a -> Range a +rangeSignumSigned = rangeOp sign + where + sign r + | range (-1) 1 `isSubRangeOf` r = range (-1) 1 + | range (-1) 0 `isSubRangeOf` r = range (-1) 0 + | range 0 1 `isSubRangeOf` r = range 0 1 + | inRange 0 r = 0 + | isNatural r = 1 + | isNegative r = -1 + +-- | Unsigned case for 'rangeSignum'. +rangeSignumUnsigned :: BoundedInt a => Range a -> Range a +rangeSignumUnsigned = rangeOp sign + where + sign r + | r == singletonRange 0 = r + | not (0 `inRange` r) = singletonRange 1 + | otherwise = range 0 1 + +-- | Propagates range information through negation. +rangeNeg :: BoundedInt a => Range a -> Range a +rangeNeg = handleSign rangeNegUnsigned rangeNegSigned + +-- | Unsigned case for 'rangeNeg'. +rangeNegUnsigned :: BoundedInt a => Range a -> Range a +rangeNegUnsigned (Range l u) + | l == 0 && u /= 0 = fullRange + | otherwise = range (-u) (-l) +-- Code from Hacker's Delight + +-- | Signed case for 'rangeNeg'. +rangeNegSigned :: BoundedInt a => Range a -> Range a +rangeNegSigned (Range l u) + | l == minBound && u == minBound = singletonRange minBound + | l == minBound = fullRange + | otherwise = range (-u) (-l) +-- Code from Hacker's Delight + +-- | Propagates range information through addition. +rangeAdd :: BoundedInt a => Range a -> Range a -> Range a +rangeAdd = handleSign rangeAddUnsigned rangeAddSigned + +-- | Unsigned case for 'rangeAdd'. +rangeAddUnsigned :: BoundedInt a => Range a -> Range a -> Range a +rangeAddUnsigned (Range l1 u1) (Range l2 u2) + | s >= l1 && t < u1 = fullRange + | otherwise = range s t + where + s = l1 + l2 + t = u1 + u2 +-- Code from Hacker's Delight + +-- | Signed case for 'rangeAdd'. +rangeAddSigned :: BoundedInt a => Range a -> Range a -> Range a +rangeAddSigned (Range l1 u1) (Range l2 u2) + | (u .|. v) < 0 = fullRange + | otherwise = range s t + where + s = l1 + l2 + t = u1 + u2 + u = l1 .&. l2 .&. complement s .&. + complement (u1 .&. u2 .&. complement t) + v = ((xor l1 l2) .|. complement (xor l1 s)) .&. + (complement u1 .&. complement u2 .&. t) +-- Code from Hacker's Delight + +-- | Propagates range information through subtraction. +rangeSub :: BoundedInt a => Range a -> Range a -> Range a +rangeSub = handleSign rangeSubUnsigned (-) + +-- | Unsigned case for 'rangeSub'. +rangeSubUnsigned :: BoundedInt a => Range a -> Range a -> Range a +rangeSubUnsigned (Range l1 u1) (Range l2 u2) + | s > l1 && t <= u1 = fullRange + | otherwise = range s t + where + s = l1 - u2 + t = u1 - l2 + -- Note: This is more accurate than the default definition using 'negate', + -- because 'negate' always overflows for unsigned numbers. + -- Code from Hacker's Delight + +-- | Propagates range information through multiplication +rangeMul :: BoundedInt a => Range a -> Range a -> Range a +rangeMul = handleSign rangeMulUnsigned rangeMulSigned + +-- | Signed case for 'rangeMul'. +rangeMulSigned :: forall a . BoundedInt a => Range a -> Range a -> Range a +rangeMulSigned r1 r2 + | r1 == singletonRange 0 || r2 == singletonRange 0 = singletonRange 0 + -- The following case is important because the 'maxAbs' function doesn't + -- work for 'minBound' on signed numbers. + | lowerBound r1 == minBound || lowerBound r2 == minBound + = range minBound maxBound + | bits (maxAbs r1) + bits (maxAbs r2) <= bitSize (undefined :: a) - 1 + = range (minimum [b1,b2,b3,b4]) (maximum [b1,b2,b3,b4]) + | otherwise = range minBound maxBound + where maxAbs (Range l u) = max (abs l) (abs u) + b1 = lowerBound r1 * lowerBound r2 + b2 = lowerBound r1 * upperBound r2 + b3 = upperBound r1 * lowerBound r2 + b4 = upperBound r1 * upperBound r2 + +-- | Unsigned case for 'rangeMul'. +rangeMulUnsigned :: forall a . BoundedInt a => Range a -> Range a -> Range a +rangeMulUnsigned r1 r2 + | bits (upperBound r1) + bits (upperBound r2) + <= bitSize (undefined :: a) + = mapMonotonic2 (*) r1 r2 + | otherwise = universal + +-- | Returns the position of the highest bit set to 1. Counting starts at 1. +-- Beware! It doesn't terminate for negative numbers. +bits :: Bits b => b -> Int +bits b = loop b 0 + where loop 0 c = c + loop n c = loop (n `shiftR` 1) (c+1) + +-- | Propagates range information through exponentiation. +rangeExp :: BoundedInt a => Range a -> Range a -> Range a +rangeExp = handleSign rangeExpUnsigned rangeExpSigned + +-- | Unsigned case for 'rangeExp'. +rangeExpUnsigned :: BoundedInt a => Range a -> Range a -> Range a +rangeExpUnsigned m@(Range l1 u1) e@(Range l2 u2) + | toInteger (bits u1) * toInteger u2 > toInteger (bitSize l1) + 1 = universal + | toInteger u1 ^ toInteger u2 > toInteger (maxBound `asTypeOf` l1) = universal + | 0 `inRange` m && 0 `inRange` e = range 0 (max b1 b2) + | otherwise = range b1 b2 + where b1 = (l1 ^ l2) + b2 = (u1 ^ u2) + +-- | Sigend case for 'rangeExp' +rangeExpSigned :: BoundedInt a => Range a -> Range a -> Range a +rangeExpSigned _ _ = universal + +-- | Propagates range information through '.|.'. +rangeOr :: forall a . BoundedInt a => Range a -> Range a -> Range a +rangeOr = handleSign rangeOrUnsignedAccurate (\_ _ -> universal) + +-- | Cheap and inaccurate range propagation for '.|.' on unsigned numbers. +rangeOrUnsignedCheap :: BoundedInt a => Range a -> Range a -> Range a +rangeOrUnsignedCheap (Range l1 u1) (Range l2 u2) = + range (max l1 l2) (maxPlus u1 u2) +-- Code from Hacker's Delight. + +-- | @a \`maxPlus\` b@ adds @a@ and @b@ but if the addition overflows then +-- 'maxBound' is returned. +maxPlus :: BoundedInt a => a -> a -> a +maxPlus b d = if sum < b then maxBound + else sum + where sum = b + d + +-- | Accurate lower bound for '.|.' on unsigned numbers. +minOrUnsigned :: BoundedInt a => a -> a -> a -> a -> a +minOrUnsigned a b c d = loop (bit (bitSize a - 1)) + where loop 0 = a .|. c + loop m + | complement a .&. c .&. m > 0 = + let temp = (a .|. m) .&. negate m + in if temp <= b + then temp .|. c + else loop (shiftR m 1) + | a .&. complement c .&. m > 0 = + let temp = (c .|. m) .&. negate m + in if temp <= d + then a .|. temp + else loop (shiftR m 1) + | otherwise = loop (shiftR m 1) +-- Code from Hacker's Delight. + +-- | Accurate upper bound for '.|.' on unsigned numbers. +maxOrUnsigned :: BoundedInt a => a -> a -> a -> a -> a +maxOrUnsigned a b c d = loop (bit (bitSize a - 1)) + where loop 0 = b .|. d + loop m + | b .&. d .&. m > 0 = + let temp = (b - m) .|. (m - 1) + in if temp >= a + then temp .|. d + else let temp = (d - m) .|. (m - 1) + in if temp >= c + then b .|. temp + else loop (shiftR m 1) + | otherwise = loop (shiftR m 1) +-- Code from Hacker's Delight. + +-- | Accurate range propagation through '.|.' for unsigned types. +rangeOrUnsignedAccurate :: BoundedInt a => Range a -> Range a -> Range a +rangeOrUnsignedAccurate (Range l1 u1) (Range l2 u2) = + range (minOrUnsigned l1 u1 l2 u2) (maxOrUnsigned l1 u1 l2 u2) +-- Code from Hacker's Delight. + +-- | Propagating range information through '.&.'. +rangeAnd :: forall a . BoundedInt a => Range a -> Range a -> Range a +rangeAnd = handleSign rangeAndUnsignedCheap (\_ _ -> universal) + +-- | Cheap and inaccurate range propagation for '.&.' on unsigned numbers. +rangeAndUnsignedCheap :: BoundedInt a => Range a -> Range a -> Range a +rangeAndUnsignedCheap (Range l1 u1) (Range l2 u2) = range 0 (min u1 u2) +-- Code from Hacker's Delight. + +-- | Propagating range information through 'xor'. +rangeXor :: forall a . BoundedInt a => Range a -> Range a -> Range a +rangeXor = handleSign rangeXorUnsigned (\_ _ -> universal) + +-- | Unsigned case for 'rangeXor'. +rangeXorUnsigned :: BoundedInt a => Range a -> Range a -> Range a +rangeXorUnsigned (Range l1 u1) (Range l2 u2) = range 0 (maxPlus u1 u2) +-- Code from Hacker's Delight. + +-- | Propagating range information through 'shiftLU'. +rangeShiftLU :: BoundedInt a => Range a -> Range Word32 -> Range a +rangeShiftLU = handleSign rangeShiftLUUnsigned (\_ _ -> universal) +-- TODO: improve accuracy + +-- | Unsigned case for 'rangeShiftLU'. +rangeShiftLUUnsigned (Range l1 u1) (Range l2 u2) + | toInteger (bits u1) + fromIntegral u2 > toInteger (bitSize u1) = universal +rangeShiftLUUnsigned (Range l1 u1) (Range l2 u2) + = range (shiftL l1 (fromIntegral l2)) (shiftL u1 (fromIntegral u2)) + +-- | Propagating range information through 'shiftRU'. +rangeShiftRU :: BoundedInt a => Range a -> Range Word32 -> Range a +rangeShiftRU = handleSign rangeShiftRUUnsigned (\_ _ -> universal) +-- TODO: improve accuracy + +-- | Unsigned case for 'rangeShiftRU'. +rangeShiftRUUnsigned (Range l1 u1) (Range l2 u2) + = range (correctShiftRU l1 u2) (correctShiftRU u1 l2) + +-- | This is a replacement fror Haskell's shiftR. If we carelessly use +-- Haskell's variant then we will get left shifts for very large shift values. +correctShiftRU :: Bits a => a -> Word32 -> a +correctShiftRU a i | i > fromIntegral (maxBound :: Int) = 0 +correctShiftRU a i = shiftR a (fromIntegral i) + +-- | Propagates range information through 'max'. +rangeMax :: BoundedInt a => Range a -> Range a -> Range a +rangeMax r1 r2 + | isEmpty r1 = r2 + | isEmpty r2 = r1 + | r1 `rangeLess` r2 = r2 + | r2 `rangeLess` r1 = r1 + | otherwise = mapMonotonic2 max r1 r2 + +-- | Analogous to 'rangeMax' +rangeMin :: BoundedInt a => Range a -> Range a -> Range a +rangeMin r1 r2 + | isEmpty r1 = r2 + | isEmpty r2 = r1 + | r1 `rangeLess` r2 = r1 + | r2 `rangeLess` r1 = r2 + | otherwise = mapMonotonic2 min r1 r2 + +-- | Propagates range information through 'mod'. +-- Note that we assume Haskell semantics for 'mod'. +rangeMod :: BoundedInt a => Range a -> Range a -> Range a +rangeMod d r + | isSigned (lowerBound d) && + minBound `inRange` d && (-1) `inRange` r = fullRange + | d `rangeLess` r && isNatural r && isNatural d = d + | isNatural r = range 0 (pred (upperBound r)) + | r `rangeLess` d && isNeg r && isNeg d = d + | isNeg r = range (succ (lowerBound r)) 0 + where + isNeg = (`isSubRangeOf` negs) + negs = negativeRange \/ 0 +rangeMod d (Range l u) = Range (succ l) (pred u) + +-- | Propagates range information through 'rem'. +-- Note that we assume Haskell semantics for 'rem'. +rangeRem :: BoundedInt a => Range a -> Range a -> Range a +rangeRem d r + | isSigned (lowerBound d) && + minBound `inRange` d && (-1) `inRange` r = fullRange + | d `rangeLessAbs` r && isNatural d = d + | isNatural d = range 0 (pred (upperBound (abs r))) + | d `absRangeLessAbs` r && isNeg d = d + | isNeg d = range (negate (upperBound (abs r))) 0 + where + isNeg = (`isSubRangeOf` negs) + negs = negativeRange \/ 0 +rangeRem d r@(Range l u) + | abs l >= abs u || l == minBound = range (succ $ negate $ abs l) (predAbs l) + | otherwise = range (succ $ negate $ abs u) (predAbs u) + +predAbs l | l == minBound = abs (succ l) + | otherwise = pred (abs l) + +-- | Propagates range information through 'quot'. +rangeQuot :: BoundedInt a => Range a -> Range a -> Range a +rangeQuot = handleSign rangeQuotU (\_ _ -> universal) + +-- | Unsigned case for 'rangeQuot'. +rangeQuotU :: BoundedInt a => Range a -> Range a -> Range a +rangeQuotU (Range l1 u1) (Range l2 u2) | l2 == 0 || u2 == 0 = universal +rangeQuotU (Range l1 u1) (Range l2 u2) = Range (l1 `quot` u2) (u1 `quot` l2) + +-- | Writing @d \`rangeLess\` abs r@ doesn't mean what you think it does because +-- 'r' may contain minBound which doesn't have a positive representation. +-- Instead, this function should be used. +rangeLessAbs d r + | r == singletonRange minBound + = lowerBound d /= minBound + | lowerBound r == minBound + = d `rangeLess` (abs (range (succ (lowerBound r)) (upperBound r))) + | otherwise = d `rangeLess` (abs r) + +-- | Similar to 'rangeLessAbs' but replaces the expression +-- @abs d \`rangeLess\` r@ instead. +absRangeLessAbs d r + | lowerBound d == minBound = False + | otherwise = abs d `rangeLessAbs` r + + +-------------------------------------------------------------------------------- +-- * Testing +-------------------------------------------------------------------------------- + +instance (BoundedInt a, Arbitrary a) => Arbitrary (Range a) + where + arbitrary = do + [bound1,bound2] <- vectorOf 2 $ oneof + [ arbitrary + , elements [minBound,-1,0,1,maxBound]] + frequency + [ (10, return $ + Range (min bound1 bound2) (max bound1 bound2)) + , (1 , return $ + Range (max bound1 bound2) (min bound1 bound2)) -- Empty + , (1 , return $ + Range bound1 bound1) -- Singleton + ] + + shrink (Range x y) = + [ Range x' y | x' <- shrink x ] ++ + [ Range x y' | y' <- shrink y ] + +instance Random Word32 where + random g = (fromIntegral i,g') + where (i :: Int,g') = random g + randomR (l,u) g = (fromIntegral i,g') + where (i :: Integer, g') = randomR (fromIntegral l,fromIntegral u) g + +instance Random Int8 where + random g = (fromIntegral i,g') + where (i :: Int,g') = random g + randomR (l,u) g = (fromIntegral i,g') + where (i :: Integer, g') = randomR (fromIntegral l,fromIntegral u) g + +instance Random Word8 where + random g = (fromIntegral i,g') + where (i :: Int,g') = random g + randomR (l,u) g = (fromIntegral i,g') + where (i :: Integer, g') = randomR (fromIntegral l,fromIntegral u) g + + +fromRange :: Random a => Range a -> Gen a +fromRange r = choose (lowerBound r, upperBound r) + +rangeTy :: Range t -> t -> Range t +rangeTy r t = r + +-- | Applies a (monadic) function to all the types we are interested in testing +-- with for Feldspar. +-- +-- Example usage: 'atAllTypes (quickCheck . prop_mul)' +atAllTypes :: (Monad m) => + (forall t . (BoundedInt t, Random t, Arbitrary t, Typeable t) => + t -> m a) + -> m () +atAllTypes test = sequence_ [test (undefined :: Int) + ,test (undefined :: Int8) + ,test (undefined :: Word32) + ,test (undefined :: Word8) + ] + +-------------------------------------------------------------------------------- +-- ** Set operations +-------------------------------------------------------------------------------- + +prop_empty t = isEmpty (emptyRange `rangeTy` t) + +prop_full t = isFull (fullRange `rangeTy` t) + +prop_isEmpty t r = isEmpty r ==> (upperBound r < lowerBound (r `rangeTy` t)) +{- +prop_rangeByRange t r1 r2 = + (rangeLess r1 r2 && not (isEmpty (r1/\r2))) ==> isEmpty (rangeByRange r1 r2) + where _ = r1 `rangeTy` t +-} +prop_rangeByRange1 t r1 r2 = + lowerBound r1 < lowerBound r2 && upperBound r1 < upperBound r2 ==> + r1 `isSubRangeOf` rangeByRange r1 r2 + where _ = r1 `rangeTy` t + +prop_rangeByRange2 t r1 r2 = + lowerBound r1 < lowerBound r2 && upperBound r1 < upperBound r2 ==> + r2 `isSubRangeOf` rangeByRange r1 r2 + where _ = r1 `rangeTy` t + +prop_rangeByRange3 t r1 r2 = + lowerBound r1 < lowerBound r2 && upperBound r1 < upperBound r2 ==> + (r1 `rangeUnion` r2) `isSubRangeOf` rangeByRange r1 r2 + where _ = r1 `rangeTy` t + +prop_singletonRange t a = isSingleton (singletonRange (a `asTypeOf` t)) + +prop_singletonSize t r = isSingleton (r `rangeTy` t) ==> (rangeSize r == 1) + +prop_emptySubRange1 t r1 r2 = + isEmpty (r1 `rangeTy` t) ==> (not (isEmpty r2) ==> + not (r2 `isSubRangeOf` r1)) + +prop_emptySubRange2 t r1 r2 = + isEmpty (r1 `rangeTy` t) ==> (not (isEmpty r2) ==> (r1 `isSubRangeOf` r2)) + +prop_rangeGap t r1 r2 = + (isEmpty gap1 && isEmpty gap2) || (gap1 == gap2) + where + gap1 = rangeGap r1 r2 + gap2 = rangeGap r2 r1 + _ = r1 `rangeTy` t + +prop_union1 t x r1 r2 = + ((x `inRange` r1) || (x `inRange` r2)) ==> (x `inRange` (r1\/r2)) + where _ = x `asTypeOf` t + +prop_union2 t x r1 r2 = + (x `inRange` (r1\/r2)) ==> + ((x `inRange` r1) || (x `inRange` r2) || (x `inRange` rangeGap r1 r2)) + where _ = x `asTypeOf` t + +prop_union3 t r1 r2 = (r1 `rangeTy` t) `isSubRangeOf` (r1\/r2) +prop_union4 t r1 r2 = (r2 `rangeTy` t) `isSubRangeOf` (r1\/r2) + + +prop_intersect1 t x r1 r2 = + ((x `inRange` r1) && (x `inRange` r2)) ==> (x `inRange` (r1/\r2)) + where _ = x `asTypeOf` t +prop_intersect2 t x r1 r2 = + (x `inRange` (r1/\r2)) ==> ((x `inRange` r1) && (x `inRange` r2)) + where _ = x `asTypeOf` t + +prop_intersect3 t r1 r2 = (r1/\r2) `isSubRangeOf` (r1 `rangeTy` t) +prop_intersect4 t r1 r2 = (r1/\r2) `isSubRangeOf` (r2 `rangeTy` t) + +prop_intersect5 t r1 r2 = + isEmpty r1 || isEmpty r2 ==> isEmpty (r1/\r2) + where _ = r1 `rangeTy` t + +prop_disjoint t x r1 r2 = + disjoint r1 r2 ==> (x `inRange` r1) ==> not (x `inRange` r2) + where _ = x `asTypeOf` t + + +prop_rangeLess1 t r1 r2 = + rangeLess r1 r2 ==> disjoint r1 (r2 `rangeTy` t) + +prop_rangeLess2 t r1 r2 = + not (isEmpty r1) && not (isEmpty r2) ==> + forAll (fromRange r1) $ \x -> + forAll (fromRange r2) $ \y -> + rangeLess r1 r2 ==> x < y + where _ = r1 `rangeTy` t + +prop_rangeLessEq t r1 r2 = + not (isEmpty r1) && not (isEmpty r2) ==> + forAll (fromRange r1) $ \x -> + forAll (fromRange r2) $ \y -> + rangeLessEq r1 r2 ==> x <= y + where _ = r1 `rangeTy` t + + +-------------------------------------------------------------------------------- +-- ** Propagation +-------------------------------------------------------------------------------- + +prop_propagation1 :: (BoundedInt t, Random t) => + t -> (forall a . Num a => a -> a) -> Range t -> Property +prop_propagation1 t op r = + not (isEmpty r) ==> + forAll (fromRange r) $ \x -> + op x `inRange` op r + +-- | This function is useful for range propagation functions like +-- 'rangeMax', 'rangeMod' etc. +-- It takes two ranges, picks an element out of either ranges and +-- checks if applying the operation to the individual elements is in +-- the resulting range after range propagation. +-- +-- The third argument is a precondition that is satisfied before the test is +-- run. A good example is to make sure that the second argument is non-zero +-- when testing division. +rangePropagationSafetyPre :: (Random t, BoundedInt t, BoundedInt a) => + t -> + (t -> t -> a) -> (Range t -> Range t -> Range a) -> + (t -> t -> Bool) -> + Range t -> Range t -> Property +rangePropagationSafetyPre t op rop pre r1 r2 = + not (isEmpty r1) && not (isEmpty r2) ==> + forAll (fromRange r1) $ \v1 -> + forAll (fromRange r2) $ \v2 -> + pre v1 v2 ==> + op v1 v2 `inRange` rop r1 r2 + +rangePropagationSafetyPre2 :: + (Random t, BoundedInt t, Random t2, BoundedInt t2, BoundedInt a) => + t -> + (t -> t2 -> a) -> (Range t -> Range t2 -> Range a) -> + (t -> t2 -> Bool) -> + Range t -> Range t2 -> Property +rangePropagationSafetyPre2 t op rop pre r1 r2 = + not (isEmpty r1) && not (isEmpty r2) ==> + forAll (fromRange r1) $ \v1 -> + forAll (fromRange r2) $ \v2 -> + pre v1 v2 ==> + op v1 v2 `inRange` rop r1 r2 + +rangePropagationSafety t op rop = rangePropagationSafetyPre t op rop noPre + where + noPre _ _ = True + +rangePropSafety1 t op rop ran = + not (isEmpty ran) ==> + forAll (fromRange ran) $ \val -> + op val `inRange` rop ran + where _ = ran `rangeTy` t + +prop_propagation2 + :: (BoundedInt t, Random t) => t -> (forall a . Num a => a -> a -> a) + -> Range t -> Range t -> Property +prop_propagation2 t op r1 r2 = rangePropagationSafety t op op r1 r2 + + +prop_fromInteger t a = isSingleton (fromInteger a `rangeTy` t) + +prop_abs t = prop_propagation1 t abs +prop_sign t = prop_propagation1 t signum +prop_neg t = prop_propagation1 t negate +prop_add t = prop_propagation2 t (+) +prop_sub t = prop_propagation2 t (-) +prop_mul t = prop_propagation2 t (*) + +prop_exp t = rangePropagationSafetyPre t (^) rangeExp (\_ e -> e >= 0) + +prop_mulU t = rangePropagationSafety t (*) rangeMulUnsigned + +-- This property doesn't hold! +-- The problem is the singleton range minBound minBound +prop_isNegative (r::Range Int) = + not (isEmpty r) ==> (isNegative r ==> not (isNegative $ negate r)) + +prop_abs2 t r = + (if isSigned (minBound `asTypeOf` t) then + lowerBound r /= (minBound `asTypeOf` t) + else True) + ==> isNatural (abs r) + + +prop_or t = rangePropagationSafety t (.|.) rangeOr + +prop_and t = rangePropagationSafety t (.&.) rangeAnd + +prop_xor t = rangePropagationSafety t xor rangeXor + +prop_shiftLU t + = rangePropagationSafetyPre2 t fixShiftL rangeShiftLU (\_ _ -> True) + where fixShiftL a b = shiftL a (fromIntegral b) + +prop_shiftRU t + = rangePropagationSafetyPre2 t fixShiftR rangeShiftRU (\_ _ -> True) + where fixShiftR a b = correctShiftRU a (fromIntegral b) + +prop_rangeMax1 t r1 = rangeMax r1 r1 == (r1 `rangeTy` t) + +prop_rangeMax2 t r1 r2 = + not (isEmpty r1) && not (isEmpty r2) ==> + upperBound r1 <= upperBound max && upperBound r2 <= upperBound max + where + max = rangeMax r1 (r2 `rangeTy` t) + +prop_rangeMax3 t r1 r2 = + not (isEmpty r1) && not (isEmpty r2) ==> + lowerBound (rangeMax r1 r2) == max (lowerBound r1) (lowerBound r2) + where _ = r1 `rangeTy` t + +prop_rangeMax4 t r1 r2 = + not (isEmpty r1) && not (isEmpty r2) ==> + rangeMax r1 r2 == rangeMax r2 r1 + where _ = r1 `rangeTy` t + +prop_rangeMax5 t r1 r2 = + (isEmpty r1 && not (isEmpty r2) ==> + rangeMax r1 r2 == r2) + QC..&. + (isEmpty r2 && not (isEmpty r1) ==> + rangeMax r1 r2 == r1) + where _ = r1 `rangeTy` t + +prop_rangeMax6 t v1 v2 = + max v1 v2 `inRange` rangeMax (singletonRange v1) (singletonRange v2) + where _ = v1 `asTypeOf` t + +prop_rangeMax7 a r1 r2 = + rangePropagationSafety a max rangeMax r1 r2 + +prop_rangeMin1 t r1 = rangeMin r1 r1 == (r1 `rangeTy` t) + +prop_rangeMin2 t r1 r2 = + not (isEmpty r1) && not (isEmpty r2) ==> + lowerBound min <= lowerBound r1 && lowerBound min <= lowerBound r2 + where + min = rangeMin r1 (r2 `rangeTy` t) + +prop_rangeMin3 t r1 r2 = + not (isEmpty r1) && not (isEmpty r2) ==> + upperBound (rangeMin r1 r2) == min (upperBound r1) (upperBound r2) + where _ = r1 `rangeTy` t + +prop_rangeMin4 t r1 r2 = + not (isEmpty r1) && not (isEmpty r2) ==> + rangeMin r1 r2 == rangeMin r2 r1 + where _ = r1 `rangeTy` t + +prop_rangeMin5 t r1 r2 = + (isEmpty r1 && not (isEmpty r2) ==> + rangeMin r1 r2 == r2) + QC..&. + (isEmpty r2 && not (isEmpty r1) ==> + rangeMin r1 r2 == r1) + where _ = r1 `rangeTy` t + +prop_rangeMin6 t v1 v2 = + min v1 v2 `inRange` rangeMin (singletonRange v1) (singletonRange v2) + where _ = v1 `asTypeOf` t + +prop_rangeMin7 t r1 r2 = + rangePropagationSafety t min rangeMin r1 r2 + +prop_rangeMod1 t v1 v2 = + v2 /= 0 ==> + mod v1 v2 `inRange` rangeMod (singletonRange v1) (singletonRange v2) + where _ = v1 `asTypeOf` t + +prop_rangeMod2 t = + rangePropagationSafetyPre t mod rangeMod divPre + +prop_rangeMod3 t = + if isSigned t then + isFull $ rangeMod (singletonRange (minBound `asTypeOf` t)) + (singletonRange (-1)) + else + True + +prop_rangeRem t = + rangePropagationSafetyPre t rem rangeRem divPre + +prop_rangeRem1 t = + if isSigned t then + isFull $ rangeRem (singletonRange (minBound `asTypeOf` t)) + (singletonRange (-1)) + else + True + + +prop_rangeQuot t = + rangePropagationSafetyPre t quot rangeQuot divPre + +prop_rangeQuot1 t = + if isSigned t then + isFull $ rangeQuot (singletonRange (minBound `asTypeOf` t)) + (singletonRange (-1)) + else + True + + +-- | Precondition for division like operators. +-- Avoids division by zero and arithmetic overflow. +divPre v1 v2 = v2 /= 0 && not (v1 == minBound && v2 == (-1)) + +-------------------------------------------------------------------------------- +-- ** Running +-------------------------------------------------------------------------------- + +data TestCase = forall t. Testable t => TC String t + +typedTests :: forall a. (BoundedInt a, Random a, Arbitrary a, Integral a) => + a -> [TestCase] +typedTests a = + [TC "prop_empty" (prop_empty a) + ,TC "prop_full" (prop_full a) + ,TC "prop_isEmpty" (prop_isEmpty a) +-- ,TC "prop_rangeByRange" (prop_rangeByRange a) + -- TODO "*** Gave up! Passed only 0 tests." + ,TC "prop_rangeByRange1" (prop_rangeByRange1 a) + ,TC "prop_rangeByRange2" (prop_rangeByRange2 a) + ,TC "prop_rangeByRange3" (prop_rangeByRange3 a) + ,TC "prop_singletonRange" (prop_singletonRange a) + ,TC "prop_singletonSize" (prop_singletonSize a) + ,TC "prop_emptySubRange1" (prop_emptySubRange1 a) + ,TC "prop_emptySubRange2" (prop_emptySubRange2 a) + ,TC "prop_rangeGap" (prop_rangeGap a) + ,TC "prop_union1" (prop_union1 a) + ,TC "prop_union2" (prop_union2 a) + ,TC "prop_union3" (prop_union3 a) + ,TC "prop_union4" (prop_union4 a) + ,TC "prop_intersect1" (prop_intersect1 a) + ,TC "prop_intersect2" (prop_intersect2 a) + ,TC "prop_intersect3" (prop_intersect3 a) + ,TC "prop_intersect4" (prop_intersect4 a) + ,TC "prop_intersect5" (prop_intersect5 a) + ,TC "prop_disjoint" (prop_disjoint a) + ,TC "prop_rangeLess1" (prop_rangeLess1 a) + ,TC "prop_rangeLess2" (prop_rangeLess2 a) + ,TC "prop_rangeLessEq" (prop_rangeLessEq a) + ,TC "prop_fromInteger" (prop_fromInteger a) + ,TC "prop_abs" (prop_abs a) + ,TC "prop_sign" (prop_sign a) + ,TC "prop_neg" (prop_neg a) + ,TC "prop_add" (prop_add a) + ,TC "prop_sub" (prop_sub a) + ,TC "prop_mul" (prop_mul a) + ,TC "prop_exp" (prop_exp a) +-- ,TC "prop_isNegative" (prop_isNegative a) + ,TC "prop_abs2" (prop_abs2 a) + ,TC "prop_and" (prop_and a) + ,TC "prop_or" (prop_or a) + ,TC "prop_xor" (prop_xor a) + ,TC "prop_shiftLU" (prop_shiftLU a) + ,TC "prop_shiftRU" (prop_shiftRU a) + ,TC "prop_rangeMax1" (prop_rangeMax1 a) + ,TC "prop_rangeMax2" (prop_rangeMax2 a) + ,TC "prop_rangeMax3" (prop_rangeMax3 a) + ,TC "prop_rangeMax4" (prop_rangeMax4 a) + ,TC "prop_rangeMax5" (prop_rangeMax5 a) + ,TC "prop_rangeMax6" (prop_rangeMax6 a) + ,TC "prop_rangeMax7" (prop_rangeMax7 a) + ,TC "prop_rangeMin1" (prop_rangeMin1 a) + ,TC "prop_rangeMin2" (prop_rangeMin2 a) + ,TC "prop_rangeMin3" (prop_rangeMin3 a) + ,TC "prop_rangeMin4" (prop_rangeMin4 a) + ,TC "prop_rangeMin5" (prop_rangeMin5 a) + ,TC "prop_rangeMin6" (prop_rangeMin6 a) + ,TC "prop_rangeMin7" (prop_rangeMin7 a) + ,TC "prop_rangeMod1" (prop_rangeMod1 a) + ,TC "prop_rangeMod2" (prop_rangeMod2 a) + ,TC "prop_rangeMod3" (prop_rangeMod3 a) + ,TC "prop_rangeRem" (prop_rangeRem a) + ,TC "prop_rangeRem1" (prop_rangeRem1 a) + ,TC "prop_rangeQuot" (prop_rangeQuot a) + ,TC "prop_rangeQuot1" (prop_rangeQuot1 a) + ] + +testAll = do testAtType (undefined :: Int) + testAtType (undefined :: Int8) + testAtType (undefined :: Word32) + testAtType (undefined :: Word8) + +myCheck (TC name test) = + do printf "%-25s" name + quickCheckWith stdArgs {maxDiscard = 10000} test + +testAtType t = do let tn = tyConString $ typeRepTyCon $ typeOf t + putStrLn $ "Testing using type: " ++ tn + mapM_ myCheck (typedTests t) diff --git a/Feldspar/Set.hs b/Feldspar/Set.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Set.hs @@ -0,0 +1,85 @@ +-- | General operations on sets + +module Feldspar.Set where + + + +-- | A 'Set' is an *over-approximation* of a set of values. The class does not +-- care about how the set is interpreted, but it only makes sense to use +-- interpretations for which the operations are sound. +class Eq a => Set a + where + empty :: a + universal :: a + -- | Union + (\/) :: a -> a -> a + -- | Intersection + (/\) :: a -> a -> a + +-- | Approximates all sets as @()@, which is the 'universal' set. +instance Set () + where + empty = () + universal = () + () \/ () = () + () /\ () = () + +-- | Set product +instance (Set a, Set b) => Set (a,b) + where + empty = (empty,empty) + universal = (universal,universal) + (a1,a2) \/ (b1,b2) = (a1 \/ b1, a2 \/ b2) + (a1,a2) /\ (b1,b2) = (a1 /\ b1, a2 /\ b2) + +-- | Three-way product +instance (Set a, Set b, Set c) => Set (a,b,c) + where + empty = (empty,empty,empty) + universal = (universal,universal,universal) + (a1,a2,a3) \/ (b1,b2,b3) = (a1 \/ b1, a2 \/ b2, a3 \/ b3) + (a1,a2,a3) /\ (b1,b2,b3) = (a1 /\ b1, a2 /\ b2, a3 /\ b3) + +-- | Four-way product +instance (Set a, Set b, Set c, Set d) => Set (a,b,c,d) + where + empty = (empty,empty,empty,empty) + universal = (universal,universal,universal,universal) + (a1,a2,a3,a4) \/ (b1,b2,b3,b4) = (a1 \/ b1, a2 \/ b2, a3 \/ b3, a4 \/ b4) + (a1,a2,a3,a4) /\ (b1,b2,b3,b4) = (a1 /\ b1, a2 /\ b2, a3 /\ b3, a4 /\ b4) + +unions :: Set a => [a] -> a +unions = foldr (\/) empty + +intersections :: Set a => [a] -> a +intersections = foldr (/\) universal + +-- Computing fixed points + +-- | Take the fixed point of a monotonic function. The second argument is +-- an initial element. A sensible default for the initial element is +-- 'empty'. +fixedPoint :: Set a => (a -> a) -> a -> a +fixedPoint f a | fa == a = fa + | otherwise = fixedPoint f fa + where fa = f a \/ a + +-- | Much like 'fixedPoint' but keeps track of the number of iterations +-- in the fixed point iteration. Useful for defining widening operators. +indexedFixedPoint :: Set a => (Int -> a -> a) -> a -> (a,Int) +indexedFixedPoint f a = go 0 f a + where go i f a | fa == a = (fa,i) + | otherwise = go (i+1) f fa + where fa = f i a \/ a + +-- | The type of widening operators. A widening operator modifies a +-- function that is subject to fixed point analysis. A widening +-- operator introduces approximations in order to guarantee (fast) +-- termination of the fixed point analysis. +type Widening a = (Int -> a -> a) -> (Int -> a -> a) + +-- | A widening operator which defaults to 'universal' when the number of +-- iterations goes over the specified value. +cutOffAt :: Set a => Int -> Widening a +cutOffAt n f i a | i >= n = universal + | otherwise = f i a diff --git a/Feldspar/Stream.hs b/Feldspar/Stream.hs --- a/Feldspar/Stream.hs +++ b/Feldspar/Stream.hs @@ -1,57 +1,27 @@ --- --- Copyright (c) 2009-2010, ERICSSON AB All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * 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. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT HOLDER 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. --- - -module Feldspar.Stream +module Feldspar.Stream (Stream ,head ,tail - ,map + ,map,mapNth + ,maps ,intersperse ,interleave + ,downsample + ,duplicate ,scan ,mapAccum ,iterate ,repeat ,unfold ,drop - ,dropWhile - ,filter - ,partition - ,zip - ,zipWith + ,zip,zipWith ,unzip ,take ,splitAt ,cycle - ,recurrence - ,recurrenceI - ,iir - ,fir + ,streamAsVector, streamAsVectorSize + ,recurrenceO,recurrenceI,recurrenceIO + ,iir,fir ) where @@ -62,142 +32,113 @@ import Control.Arrow import Feldspar.Vector (Vector, DVector - ,vector - ,freezeVector,indexed - ,sum,length,replicate) + ,vector,freezeVector,unfreezeVector,indexed + ,sum,length,replicate,reverse,scalarProd) -- | Infinite streams. -data Stream a = forall state . (Computable a, Computable state) => - Stream (StepFunction state a) state - -data StepFunction state a - = Continuous (state -> (a,state)) - | Stuttering (state -> (a,Data Bool, state)) - --- When we want to treat a step function as if it was continuous. --- Use with care! It introduces an extra while loop if the --- argument is stuttering -step :: (Computable state, Computable a) => - StepFunction state a -> (state -> (a,state)) -step (Continuous next) init = next init -step (Stuttering next) init = (a,st) - where (a,_,st) = while (not . snd3) (next . thd3) (next init) - --- When we cannot optimize for the continuous case we can use this function --- to consider all step functions as stuttering and reduce the amount of --- code we have to write. -stuttering :: StepFunction state a -> (state -> (a, Data Bool, state)) -stuttering (Stuttering next) = next -stuttering (Continuous next) = \state -> let (a,st) = next state - in (a,true,st) - --- This helper function enables us to write function using the stuttering --- case only while still propagating the continuous information. --- Helps writing less code. -mapStep :: ((stateA -> (a,Data Bool, stateA)) -> - (stateB -> (b,Data Bool, stateB))) - -> StepFunction stateA a -> StepFunction stateB b -mapStep mkStep (Stuttering next) = Stuttering (mkStep next) -mapStep mkStep (Continuous next) = Continuous newStep - where newStep a = let (b,_,st) = mkStep (\a -> let (b,st) = next a - in (b,true,st)) a - in (b,st) - --- Helper functions for working on triplets -fst3 (a,_,_) = a -snd3 (_,b,_) = b -thd3 (_,_,c) = c -first3 f (a,b,c) = (f a,b,c) -second3 f (a,b,c) = (a,f b,c) -third3 f (a,b,c) = (a,b,f c) +data Stream a where + Stream :: Syntactic state => (state -> (a,state)) -> state -> Stream a -- | Take the first element of a stream -head :: Computable a => Stream a -> a -head (Stream next init) = fst $ step next init +head :: Syntactic a => Stream a -> a +head (Stream next init) = fst $ next init -- | Drop the first element of a stream -tail :: Computable a => Stream a -> Stream a -tail (Stream next init) = Stream next (snd $ step next init) +tail :: Syntactic a => Stream a -> Stream a +tail (Stream next init) = Stream next (snd $ next init) -- | 'map f str' transforms every element of the stream 'str' using the -- function 'f' -map :: (Computable a, Computable b) => +map :: (Syntactic a, Syntactic b) => (a -> b) -> Stream a -> Stream b -map f (Stream next init) = Stream (mapStep (first3 f .) next) init +map f (Stream next init) = Stream newNext init + where newNext st = let (a,st') = next st in (f a, st') +-- | 'mapNth f n k str' transforms every 'n'th element with offset 'k' +-- of the stream 'str' using the function 'f' +mapNth :: (Syntactic a) => + (a -> a) -> Data Index -> Data Index -> Stream a -> Stream a +mapNth f n k (Stream next init) = Stream newNext (init,0) + where newNext (st,i) = let (a,st') = next st in (i==k?(f a,a),(st',(i+1) `mod` n)) + +-- | 'maps fs str' uses one of the functions from 'fs' successively to modify +-- the elements of 'str' +maps :: (Syntactic a) => + [(a -> a)] -> Stream a -> Stream a +maps fs (Stream next init) = Stream newNext (init,0 :: Data Index) + where newNext (st,i) = + let (a,st') = next st in + (Prelude.foldr (\ (k,f) r -> + i==(fromIntegral k)?(f a,r)) + a (Prelude.zip [1..] fs) + ,(st',(i+1) `mod` fromIntegral (Prelude.length fs)) + ) + -- | 'intersperse a str' inserts an 'a' between each element of the stream -- 'str'. -intersperse :: a -> Stream a -> Stream a -intersperse a (Stream next init) = - Stream (mapStep newNext next) (true,init) - where newNext next (b,st) = b ? (let (e,isValid,st') = next st - in isValid ? ( (e,true,(false,st')) - , (e,false,(true,st')) - ) - ,(a,true,(true,st)) - ) +intersperse :: Syntactic a => a -> Stream a -> Stream a +intersperse a (Stream next init) = + Stream newNext (true,init) + where newNext (b,st) = b ? (let (e,st') = next st + in (e,(false,st')) + ,(a,(true,st)) + ) --- | Create a new stream by alternating between the elements from +-- | Create a new stream by alternating between the elements from -- the two input streams -interleave :: Stream a -> Stream a -> Stream a -interleave (Stream (Continuous next1) init1) (Stream (Continuous next2) init2) - = Stream (Continuous next) (true,init1,init2) +interleave :: Syntactic a => Stream a -> Stream a -> Stream a +interleave (Stream next1 init1) (Stream next2 init2) + = Stream next (true,init1,init2) where next (b,st1,st2) = b ? (let (a,st1') = next1 st1 in (a,(false,st1',st2)) ,let (a,st2') = next2 st2 in (a,(true,st1,st2')) ) -interleave (Stream next1 init1) (Stream next2 init2) - = Stream (Stuttering next) (true,init1,init2) - where next (b,st1,st2) = b ? (let (a,isValid,st1') = stuttering next1 st1 - in isValid ? ( (a,true,(false,st1',st2)) - , (a,false,(true,st1',st2)) - ) - ,let (a,isValid,st2') = stuttering next2 st2 - in isValid ? ( (a,true,(true,st1,st2')) - , (a,false,(false,st1,st2')) - ) - ) +-- | 'downsample n str' takes every 'n'th element of the input stream +downsample :: Syntactic a => Data Index -> Stream a -> Stream a +downsample n (Stream next init) = Stream newNext init + where newNext st = forLoop (n-1) (next st) (\_ (_,st) -> next st) + +-- | 'duplicate n str' stretches the stream by duplicating the elements 'n' times +duplicate :: Syntactic a => Data Index -> Stream a -> Stream a +duplicate n (Stream next init) = Stream newNext (next init,1) + where newNext (p@(a,st),i) = i==0 ? (let (b,st') = next st in (b,((b,st'),1)) + ,(a,(p,(i+1)`mod`n)) + ) + -- | 'scan f a str' produces a stream by successively applying 'f' to --- each element of the input stream 'str' and the previous element of +-- each element of the input stream 'str' and the previous element of -- the output stream. -scan :: Computable a => (a -> b -> a) -> a -> Stream b -> Stream a +scan :: Syntactic a => (a -> b -> a) -> a -> Stream b -> Stream a scan f a (Stream next init) - = Stream (mapStep newNext next) (a,init) - where newNext next (acc,st) = let (a,isValid,st') = next st - in isValid ? ( (acc,true, (f acc a,st') ) - , (acc,false, (acc,st') ) - ) + = Stream newNext (a,init) + where newNext (acc,st) = let (a,st') = next st + in (acc, (f acc a,st') ) {- This function is problematic to define for the same reason the index function is problematic, plus that it has the same quirk as correctScan. -} -- | A scan but without an initial element. -scan1 :: Computable a => (a -> a -> a) -> Stream a -> Stream a +scan1 :: Syntactic a => (a -> a -> a) -> Stream a -> Stream a scan1 f (Stream next init) - = Stream (mapStep newNext next) (a,true,newInit) - where (a,newInit) = step next init - newNext next (a,isFirst,st) - = isFirst ? ( (a, true, (a,false,st)) - , let (b,isValid,st') = next st - in isValid ? ( let elem = f a b - in (elem, true, (elem,false,st')) - , (a,false, (a,false,st')) - ) + = Stream newNext (a,true,newInit) + where (a,newInit) = next init + newNext (a,isFirst,st) + = isFirst ? ( (a, (a,false,st)) + , let (b,st') = next st + in let elem = f a b + in (elem, (elem,false,st')) ) --- mapAccum creates a nested loop. It's either that or recomputing the --- function even for non-valid elements in the input stream. - -- | Maps a function over a stream using an accumulator. -mapAccum :: (Computable acc, Computable b) => +mapAccum :: (Syntactic acc, Syntactic b) => (acc -> a -> (acc,b)) -> acc -> Stream a -> Stream b mapAccum f acc (Stream next init) - = Stream (Continuous newNext) (init,acc) + = Stream newNext (init,acc) where newNext (st,acc) - = let (a,st') = step next st + = let (a,st') = next st (acc',b) = f acc a in (b, (st',acc')) @@ -205,236 +146,209 @@ -- results are used to create a stream. -- -- @iterate f a == [a, f a, f (f a), f (f (f a)) ...]@ -iterate :: Computable a => (a -> a) -> a -> Stream a -iterate f init = Stream (Continuous next) init +iterate :: Syntactic a => (a -> a) -> a -> Stream a +iterate f init = Stream next init where next a = (a, f a) -- | Repeat an element indefinitely. -- -- @repeat a = [a, a, a, ...]@ -repeat :: Computable a => a -> Stream a -repeat a = Stream (Continuous next) unit - where next _ = (a,unit) +repeat :: Syntactic a => a -> Stream a +repeat a = Stream next (value ()) + where next _ = (a,value ()) -- | @unfold f acc@ creates a new stream by successively applying 'f' to -- to the accumulator 'acc'. -unfold :: (Computable a, Computable c) => (c -> (a,c)) -> c -> Stream a -unfold next init = Stream (Continuous next) init +unfold :: (Syntactic a, Syntactic c) => (c -> (a,c)) -> c -> Stream a +unfold next init = Stream next init -- | Drop a number of elements from the front of a stream -drop :: Data Unsigned32 -> Stream a -> Stream a -{- This version creates a conditional inside the loop - The output stream is always stuttering -drop i (Stream next init) = Stream (Stuttering newNext) (i,init) - where newNext (i,st) = i == 0 ? (let (a,isValid,st') = stuttering next st - in isValid ? ( (a,true, (0,st')) - , (a,false, (0,st')) - ) - ,let (a,isValid,st') = stuttering next st - in isValid ? ( (a,false, (i-1,st')) - , (a,false, (i, st')) - ) - ) --} --- This version generates a while loop to compute the initial state --- The output stream is continuous if the input stream is +drop :: Data Length -> Stream a -> Stream a drop i (Stream next init) = Stream next newState - where (newState,_) = while cond body (init,i) - cond (st,i) = i > 0 - body (st,i) = let (_,b,st') = stuttering next st - in b ? ( (st',i-1) - , (st',i)) - --- | @dropWhile p str@ drops element from the stream @str@ as long as the --- elements fulfill the predicate @p@. -dropWhile p (Stream next init) = Stream next newState - where (_,newState) = while cond body (step next init) - cond (a,st) = p a - body (_,st) = step next st - --- | 'filter p str' removes elements from the stream 'str' if they are false --- according to the predicate 'p' -filter :: (a -> Data Bool) -> Stream a -> Stream a -filter p (Stream next init) = Stream (Stuttering newNext) init - where newNext st = let (a,isValid,st') = stuttering next st - in isValid && p a ? ( (a,true, st') - , (a,false,st') - ) - --- | Splits a stream in two according to the predicate function. All --- elements which return true go in the first stream, the rest go in the --- second. -partition :: (a -> Data Bool) -> Stream a -> (Stream a, Stream a) -partition p stream = (filter p stream, filter (not . p) stream) - --- In the case that the input streams are stuttering this function --- will introduce nested loops + where newState = forLoop i init body + body _ = snd . next -- | Pairs together two streams into one. zip :: Stream a -> Stream b -> Stream (a,b) zip (Stream next1 init1) (Stream next2 init2) - = Stream (Continuous next) (init1,init2) + = Stream next (init1,init2) where next (st1,st2) = ( (a,b), (st1',st2') ) - where (a,st1') = step next1 st1 - (b,st2') = step next2 st2 - --- This function can also potentially introduce nested loops, just like zip + where (a,st1') = next1 st1 + (b,st2') = next2 st2 --- | Pairs together two streams using a function to combine the +-- | Pairs together two streams using a function to combine the -- corresponding elements. -zipWith :: Computable c => (a -> b -> c) -> Stream a -> Stream b -> Stream c +zipWith :: Syntactic c => (a -> b -> c) -> Stream a -> Stream b -> Stream c zipWith f (Stream next1 init1) (Stream next2 init2) - = Stream (Continuous next) (init1,init2) + = Stream next (init1,init2) where next (st1,st2) = ( f a b, (st1',st2')) - where (a,st1') = step next1 st1 - (b,st2') = step next2 st2 + where (a,st1') = next1 st1 + (b,st2') = next2 st2 --- | Given a stream of pairs, split it into two stream. -unzip :: (Computable a, Computable b) => Stream (a,b) -> (Stream a, Stream b) +-- | Given a stream of pairs, split it into two stream. +unzip :: (Syntactic a, Syntactic b) => Stream (a,b) -> (Stream a, Stream b) unzip stream = (map fst stream, map snd stream) -instance RandomAccess (Stream a) where +instance Syntactic a => RandomAccess (Stream a) where type Element (Stream a) = a - (Stream next init) ! n = fst3 $ while ((/= 0) . thd3) body (a,st,n) - where body (a,st,i) = let (a,isValid,st') = stuttering next st - in isValid ? ( (a,st',i-1) - , (a,st',i) - ) - (a,st) = step next init -- I would like to get rid of this one + (Stream next init) ! n = fst $ forLoop n (next init) body + where body _ (_,st) = next st -- | 'take n str' allocates 'n' elements from the stream 'str' into a -- core array. -take :: Storable a => Data Int -> Stream (Data a) -> Data [a] -take n (Stream next init) - = snd3 $ while cond body - (0,array (mapMonotonic fromIntegral (dataSize n) :> universal) [],init) - where cond (i,_ ,_ ) = i < n - body (i,arr,st) = let (a,isValid,st') = stuttering next st - in isValid ? ( (i+1,setIx arr i a,st') - , (i, arr, st') - ) +take :: (Type a) => Data Length -> Stream (Data a) -> Data [a] +take n (Stream next init) + = sequential n init step (const $ value []) + where step i st = next st --- | 'splitAt n str' allocates 'n' elements from the stream 'str' into a --- core array and returns the rest of the stream continuing from +-- | 'splitAt n str' allocates 'n' elements from the stream 'str' into a +-- core array and returns the rest of the stream continuing from -- element 'n+1'. -splitAt :: Storable a => - Data Int -> Stream (Data a) -> (Data [a], Stream (Data a)) -splitAt n (Stream next init) = (arr,Stream next st) - where - (_,arr,st) = - while cond body - (0,array (mapMonotonic fromIntegral (dataSize n) :> universal) [],init) - cond (i,_ ,_ ) = i < n - body (i,arr,st) = let (a,isValid,st') = stuttering next st - in isValid ? ( (i+1,setIx arr i a,st') - , (i, arr, st') - ) +splitAt :: (Type a) => + Data Length -> Stream (Data a) -> (Data [a], Stream (Data a)) +splitAt n stream = (take n stream,drop n stream) -- | Loops through a vector indefinitely to produce a stream. -cycle :: Computable a => Vector a -> Stream a -cycle vec = Stream (Continuous next) 0 +cycle :: Syntactic a => Vector a -> Stream a +cycle vec = Stream next 0 where next i = (vec ! i, (i + 1) `rem` length vec) +unsafeVectorToStream :: Syntactic a => Vector a -> Stream a +unsafeVectorToStream vec = Stream next 0 + where next i = (vec ! i, i + 1) +-- | A convenience function for translating an algorithm on streams to an algorithm on vectors. +-- The result vector will have the same length as the input vector. +-- It is important that the stream function doesn't drop any elements of +-- the input stream. +-- +-- This function allocates memory for the output vector. +streamAsVector :: (Type a, Type b) => + (Stream (Data a) -> Stream (Data b)) + -> (Vector (Data a) -> Vector (Data b)) +streamAsVector f v + = unfreezeVector $ take (length v) $ f $ unsafeVectorToStream v + +-- | Similar to 'streamAsVector' except the size of the output array is computed by the second argument +-- which is given the size of the input vector as a result. +streamAsVectorSize :: (Type a, Type b) => + (Stream (Data a) -> Stream (Data b)) -> (Data Length -> Data Length) + -> (Vector (Data a) -> Vector (Data b)) +streamAsVectorSize f s v = unfreezeVector $ take (s $ length v) $ f $ cycle v + -- | A combinator for descibing recurrence equations, or feedback loops. --- It uses memory proportional to the input vector +-- The recurrence equation may refer to previous outputs of the stream, +-- but only as many as the length of the input stream +-- It uses memory proportional to the input vector. -- -- For exaple one can define the fibonacci sequence as follows: -- --- > fib = recurrence (vector [0,1]) (\fib -> fib 1 + fib 2) +-- > fib = recurrenceO (vector [0,1]) (\fib -> fib!0 + fib!1) -- --- The expressions @fib 1@ and @fib 2@ refer to previous elements in the +-- The expressions @fib 1@ and @fib 2@ refer to previous elements in the -- stream defined one step back and two steps back respectively. -recurrence :: Storable a => - DVector a -> ((Int -> Data a) -> Data a) -> Stream (Data a) -recurrence init mkExpr = Stream (Continuous next) (buf,0) +recurrenceO :: Type a => + DVector a -> + (DVector a -> Data a) -> + Stream (Data a) +recurrenceO init mkExpr = Stream next (buf,0) where buf = freezeVector init - len = length init - next (buf,ix) = - let a = mkExpr (\i -> getIx buf ((value i + ix) `rem` len)) + len = getLength buf + next (buf,ix) = + let a = mkExpr (indexed len (\i -> getIx buf ((i + ix) `rem` len))) in (getIx buf (ix `rem` len), (setIx buf (ix `rem` len) a, ix + 1)) --- | A recurrence combinator with input + +-- | A recurrence combinator with input. The function 'recurrenceI' is +-- similar to 'recurrenceO'. The difference is that that it has an input +-- stream, and that the recurrence equation may only refer to previous +-- inputs, it may not refer to previous outputs. -- -- The sliding average of a stream can easily be implemented using -- 'recurrenceI'. -- --- > slidingAvg :: Data Int -> Stream (Data Int) -> Stream (Data Int) --- > slidingAvg n str = recurrenceI (replicate n 0) str (vector []) --- > (\input _ -> sum (indexed n input) `quot` n) -recurrenceI :: (Storable a, Storable b) => - DVector a -> Stream (Data a) -> DVector b -> - ((Data Int -> Data a) -> (Data Int -> Data b) -> Data b) -> +-- > slidingAvg :: Data DefaultWord -> Stream (Data DefaultWord) -> Stream (Data DefaultWord) +-- > slidingAvg n str = recurrenceI (replicate n 0) str +-- > (\input _ -> sum input `quot` n) +recurrenceI :: (Type a, Type b) => + DVector a -> Stream (Data a) -> + (DVector a -> Data b) -> Stream (Data b) -recurrenceI ii (Stream (Continuous st) s) io mkExpr - = Stream (Continuous step) (ibuf,obuf,s,0) +recurrenceI ii stream mkExpr + = recurrenceIO ii stream (vector []) (\i o -> mkExpr i) + +-- | 'recurrenceIO' is a combination of 'recurrenceO' and 'recurrenceI'. It +-- has an input stream and the recurrence equation may refer both to +-- previous inputs and outputs. +-- +-- 'recurrenceIO' is used when defining the 'iir' filter. +recurrenceIO :: (Type a, Type b) => + DVector a -> Stream (Data a) -> DVector b -> + (DVector a -> DVector b -> Data b) -> + Stream (Data b) +recurrenceIO ii (Stream st s) io mkExpr + = Stream step (ibuf,obuf,s,0) where ibuf = freezeVector ii obuf = freezeVector io - p = length ii - q = length io - step (ibuf,obuf,s,ix) = + p = getLength ibuf + q = getLength obuf + step (ibuf,obuf,s,ix) = let (a,s') = st s ibuf' = p /= 0 ? (setIx ibuf (ix `rem` p) a, ibuf) - b = mkExpr (\i -> getIx ibuf' ((i + ix) `rem` p)) - (\i -> getIx obuf ((i + ix - 1) `rem` q)) - in (q /= 0 ? (getIx obuf (ix `rem` q),b), + b = mkExpr + (indexed p (\i -> getIx ibuf' ((i + ix) `rem` p))) + (indexed q (\i -> getIx obuf ((i + ix - 1) `rem` q))) + in (q /= 0 ? (getIx obuf (ix `rem` q),b), (ibuf' ,q /= 0 ? (setIx obuf (ix `rem` q) b,obuf) ,s' ,ix + 1)) -recurrenceI ii (Stream (Stuttering st) s) io mkExpr - = Stream (Stuttering step) (ibuf,obuf,s,0) - where ibuf = freezeVector ii - obuf = freezeVector io - p = length ii - q = length io - step (ibuf,obuf,s,ix) = - let (a,isValid,s') = st s - ibuf' = p /= 0 ? (setIx ibuf (ix `rem` p) a,ibuf) - b = mkExpr (\i -> getIx ibuf' ((i + ix) `rem` p)) - (\i -> getIx obuf ((i + ix - 1) `rem` q)) - in isValid ?( (q /= 0 ? (getIx obuf (ix `rem` q), b), true, - (ibuf' - ,q /= 0 ? (setIx obuf (ix `rem` q) b,obuf) - ,s' - ,ix + 1)) - , (q /= 0 ? (getIx obuf (ix `rem` q),b), false, - (ibuf - ,obuf - ,s' - ,ix)) - ) -slidingAvg :: Data Int -> Stream (Data Int) -> Stream (Data Int) -slidingAvg n str = recurrenceI (replicate n 0) str (vector []) - (\input _ -> sum (indexed n input) `quot` n) +recurrenceIIO :: (Type a, Type b, Type c) => + DVector a -> Stream (Data a) -> DVector b -> Stream (Data b) -> + DVector c -> + (DVector a -> DVector b -> DVector c -> Data c) -> + Stream (Data c) +recurrenceIIO i1 (Stream next1 init1) i2 (Stream next2 init2) io mkExpr + = Stream next ((ibuf1,init1),(ibuf2,init2),obuf,0) + where ibuf1 = freezeVector i1 + ibuf2 = freezeVector i2 + obuf = freezeVector io + l1 = getLength ibuf1 + l2 = getLength ibuf2 + lo = getLength obuf + next ((ibuf1,st1),(ibuf2,st2),obuf,ix) = + let (a,st1') = next1 st1 + (b,st2') = next2 st2 + ibuf1' = l1 /= 0 ? (setIx ibuf1 (ix `rem` l1) a, ibuf1) + ibuf2' = l2 /= 0 ? (setIx ibuf2 (ix `rem` l2) b, ibuf2) + c = mkExpr (indexed l1 (\i -> getIx ibuf1' ((i + ix) `rem` l1))) + (indexed l2 (\i -> getIx ibuf2' ((i + ix) `rem` l2))) + (indexed lo (\i -> getIx obuf ((i + ix - 1) `rem` lo))) + in (lo /= 0 ? (getIx obuf (ix `rem` lo),c), + ((ibuf1',st1') + ,(ibuf2',st2') + ,lo /= 0 ? (setIx obuf (ix `rem` lo) c,obuf) + ,ix + 1)) +slidingAvg :: Data DefaultWord -> Stream (Data DefaultWord) -> Stream (Data DefaultWord) +slidingAvg n str = recurrenceI (replicate n 0) str + (\input -> sum input `quot` n) + -- | A fir filter on streams -fir :: DVector Float -> +fir :: DVector Float -> Stream (Data Float) -> Stream (Data Float) -fir b input = - recurrenceI (replicate n 0) input - (vector []) - (\input _ -> sum (indexed n (\i -> b!i * input!(n-i)))) - where n = length b +fir b input = + recurrenceI (replicate (length b) 0) input + (\input -> scalarProd b input) -- | An iir filter on streams -iir :: Data Float -> DVector Float -> DVector Float -> +iir :: Data Float -> DVector Float -> DVector Float -> Stream (Data Float) -> Stream (Data Float) -iir a0 a b input = - recurrenceI (replicate q 0) input - (replicate p 0) - (\input output -> 1 / a0 * - ( sum (indexed p (\i -> b!i * input!(p-i))) - - sum (indexed q (\j -> a!j * output!(q-j)))) +iir a0 a b input = + recurrenceIO (replicate (length b) 0) input + (replicate (length a) 0) + (\input output -> 1 / a0 * + ( scalarProd b input + - scalarProd a output) ) - where p = length b - q = length a - --- A nice instance to have when using the recurrence functions. -instance RandomAccess (Data Int -> Data a) where - type Element (Data Int -> Data a) = Data a - (!) = ($) - --- Function to be used with filter for debuggin purposes -even n = n `rem` 2 == 0 diff --git a/Feldspar/Utils.hs b/Feldspar/Utils.hs deleted file mode 100644 --- a/Feldspar/Utils.hs +++ /dev/null @@ -1,101 +0,0 @@ --- --- Copyright (c) 2009-2010, ERICSSON AB All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * 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. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT HOLDER 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. --- - --- | General utility functions - -module Feldspar.Utils where - - - -import Control.Monad.State -import Data.List -import Data.Map (Map) -import qualified Data.Map as Map - - - --- | Checks if all elements in the list are equal. -allEqual :: Eq a => [a] -> Bool -allEqual [] = True -allEqual (a:as) = all (==a) as - --- | @`showSeq` open strs close@: --- --- Shows the strings @strs@ separated by commas and enclosed within the @open@ --- and @close@ strings. -showSeq :: String -> [String] -> String -> String -showSeq open strs close = open ++ intercalate "," strs ++ close - --- | Append the first argument to the first line of the second argument. -appendFirstLine :: String -> String -> String -appendFirstLine extra str = str1 ++ extra ++ str2 - where - (str1,str2) = break (=='\n') str - - - --- | A 'Map' lookup that treats undefined keys as mapping to empty lists. -(!!!) :: Ord a => Map a [b] -> a -> [b] -m !!! a = case Map.lookup a m of - Just as -> as - _ -> [] - --- | Inverts a 'Map'. The argument map may have several keys mapping to the same --- element, so the inverted map has a list of elements for each key. -invertMap :: (Ord a, Ord b) => Map a b -> Map b [a] -invertMap m = Map.fromListWith (++) [(b,[a]) | (a,b) <- Map.toList m] - - - --- | Topological sort. Lists the nodes in the map such that each node appears --- before its children. The function only terminates for acyclic maps. -topSort :: Ord a => Map a [a] -> [a] -topSort = reverse . evalState sorter - where - findLeaf a = do - dag <- get - let bs = [b | b <- dag Map.! a, Just _ <- [Map.lookup b dag]] - case bs of - [] -> modify (Map.delete a) >> return a - b:_ -> findLeaf b - - sorter = do - dag <- get - if Map.null dag - then return [] - else do - let (a,_) = Map.elemAt 0 dag - leaf <- findLeaf a - liftM (leaf:) sorter - - -- XXX It might be slightly inefficient to always restart findLeaf at the - -- first element (which can be considered a random node in the dag). It - -- would probably be better to restart at the parent of the last leaf. - - -- XXX QuickCheck? - diff --git a/Feldspar/Vector.hs b/Feldspar/Vector.hs --- a/Feldspar/Vector.hs +++ b/Feldspar/Vector.hs @@ -1,62 +1,17 @@ --- --- Copyright (c) 2009-2010, ERICSSON AB All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * 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. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT HOLDER 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. --- +{-# LANGUAGE UndecidableInstances #-} --- | A high-level interface to the operations in the core language --- ("Feldspar.Core"). Many of the functions defined here are imitations of --- Haskell's list operations, and to a first approximation they behave --- accordingly. --- --- A symbolic vector ('Vector') can be thought of as a representation of a --- 'parallel' core array. This view is made precise by the function --- 'freezeVector', which converts a symbolic vector to a core vector using --- 'parallel'. --- --- 'Vector' is instantiated under the 'Computable' class, which means that --- symbolic vectors can be used quite seamlessly with the interface in --- "Feldspar.Core". --- --- Unlike core arrays vectors don't use any physical memory. All --- operations on vectors are \"fused\" which means that intermediate vectors --- are removed. As an example, the following function uses only constant --- space despite using two intermediate vectors of length @n@. --- --- > sumSq n = sum (map (^2) (1...n)) +-- | A module for /virtual vectors/. Many of the functions defined here are +-- imitations of Haskell's list operations, and to a first approximation they +-- behave accordingly. -- --- Memory is only introduced when a vector is explicitly --- written to memory using the function 'memorize' or converted to a core --- array using 'freezeVector'. The function 'vector' for creating a --- vector also allocates memory. +-- A virtual vector normally doesn't use any physical memory. Memory is only +-- introduced explicitly using the function 'force' or converted to a core array +-- using 'freezeVector'. The function 'vector' for creating a vector also +-- allocates memory. -- -- Note also that most operations only introduce a small constant overhead on -- the vector. The exceptions are -- --- * 'dropWhile' --- -- * 'fold' -- -- * 'fold1' @@ -69,9 +24,7 @@ -- vector. -- -- Finally, note that 'freezeVector' can be introduced implicitly by functions --- overloaded by the 'Computable' class. This means that, for example, --- @`printCore` f@, where @f :: Vector (Data Int) -> Vector (Data Int)@, will --- introduce storage for the input and output of @f@. +-- overloaded by the 'Syntactic' class. module Feldspar.Vector where @@ -79,25 +32,26 @@ import qualified Prelude import Control.Arrow ((&&&)) -import qualified Data.List -- Only for documentation of 'unfold' +import Data.List (genericLength) +import qualified Data.TypeLevel as TL +import Feldspar.DSL.Network hiding (In,Out) import Feldspar.Prelude -import Feldspar.Range -import Feldspar.Core.Expr +import Feldspar.Core.Representation import Feldspar.Core -- * Types --- | Vector index -type Ix = Int - -- | Symbolic vector -data Vector a = Indexed - { length :: Data Length - , index :: Data Ix -> a - } +data Vector a + = Empty + | Indexed + { segmentLength :: Data Length + , segmentIndex :: Data Index -> a + , continuation :: Vector a + } -- | Short-hand for non-nested parallel vector type DVector a = Vector (Data a) @@ -106,113 +60,118 @@ -- * Construction/conversion --- | Converts a non-nested vector to a core vector. -freezeVector :: Storable a => Vector (Data a) -> Data [a] -freezeVector (Indexed l ixf) = parallel l ixf - --- | Converts a non-nested core vector to a parallel vector. -unfreezeVector :: Storable a => Data Length -> Data [a] -> Vector (Data a) -unfreezeVector l arr = Indexed l (getIx arr) +indexed :: Data Length -> (Data Index -> a) -> Vector a +indexed l idxFun = Indexed l idxFun Empty --- | Optimizes vector lookup by computing all elements and storing them in a --- core array. -memorize :: Storable a => Vector (Data a) -> Vector (Data a) -memorize vec = unfreezeVector (length vec) $ freezeVector vec - -- XXX Should be generalized to arbitrary dimensions. +-- | Breaks up a segmented vector into a list of single-segment vectors. +segments :: Vector a -> [Vector a] +segments Empty = [] +segments (Indexed l ixf cont) = indexed l ixf : segments cont -indexed :: Data Length -> (Data Ix -> a) -> Vector a -indexed = Indexed +length :: Vector a -> Data Length +length Empty = 0 +length vec = Prelude.foldr (+) 0 $ Prelude.map segmentLength $ segments vec --- | Constructs a non-nested vector. The elements are stored in a core vector. -vector :: Storable a => [a] -> Vector (Data a) -vector as = unfreezeVector l (value as) +-- | Converts a segmented vector to a vector with a single segment. +mergeSegments :: Syntactic a => Vector a -> Vector a +mergeSegments vec = indexed (length vec) (ixFun (segments vec)) where - l = value $ Prelude.length as - -- XXX Should be generalized to arbitrary dimensions. + ixFun (Indexed l ixf _ : vs) = case vs of + [] -> ixf + _ -> \i -> condition (i Data Length) -> Vector a -> Vector a -modifyLength f vec = vec {length = f (length vec)} +-- | Converts a non-nested vector to a core vector. +freezeVector :: Type a => Vector (Data a) -> Data [a] +freezeVector vec = help True vec + where + help _ Empty = value [] + help opt (Indexed l ixf cont) = parallel'' opt l ixf $ help False cont -setLength :: Data Length -> Vector a -> Vector a -setLength = modifyLength . const +-- | Converts a non-nested core vector to a parallel vector. +unfreezeVector :: Type a => Data [a] -> Vector (Data a) +unfreezeVector arr = indexed (getLength arr) (getIx arr) -boundVector :: Int -> Vector a -> Vector a -boundVector maxLen = modifyLength (cap r) +-- | Variant of `unfreezeVector` with additional static size information. +unfreezeVector' :: (Type a) => Length -> Data [a] -> Vector (Data a) +unfreezeVector' len arr = unfreezeVector $ cap (r :> elemSize) arr where - r = negativeRange + singletonRange (fromIntegral maxLen) + 1 - -- XXX fromIntegral might not be needed in future. + (_ :> elemSize) = dataSize arr + r = Range len len +-- | Optimizes vector lookup by computing all elements and storing them in a +-- core array. +memorize :: Syntactic (Vector a) => Vector a -> Vector a +memorize = force +{-# DEPRECATED memorize "Please use `force` instead." #-} +-- | Constructs a non-nested vector. The elements are stored in a core vector. +vector :: Type a => [a] -> Vector (Data a) +vector as = unfreezeVector (value as) + -- TODO Generalize to arbitrary dimensions. -instance Storable a => Computable (Vector (Data a)) +instance + ( Syntactic a + , Role a ~ () + , Info a ~ EdgeSize () (Internal a) + ) => EdgeInfo (Vector a) where - type Internal (Vector (Data a)) = (Length, [Internal (Data a)]) - - internalize vec = - internalize (length vec, freezeVector $ map internalize vec) - - externalize l_a = map externalize $ unfreezeVector l a - where - l = externalize $ get21 l_a - a = externalize $ get22 l_a + type Info (Vector a) = EdgeSize () [Internal a] + edgeInfo = edgeInfo . toEdge -instance Storable a => Computable (Vector (Vector (Data a))) +instance + ( Syntactic a + , Role a ~ () + , Info a ~ EdgeSize () (Internal a) + ) => + MultiEdge (Vector a) Feldspar EdgeSize where - type Internal (Vector (Vector (Data a))) = - (Length, [Length], [[Internal (Data a)]]) + type Role (Vector a) = () + type Internal (Vector a) = [Internal a] - internalize vec = internalize - ( length vec - , freezeVector $ map length vec - , freezeVector $ map (freezeVector . map internalize) vec - ) + toEdge = toEdge . freezeVector . map edgeCast + fromInEdge = map edgeCast . unfreezeVector . fromInEdge + fromOutEdge info = map edgeCast . unfreezeVector . fromOutEdge info - externalize inp - = map (map externalize . uncurry unfreezeVector) - $ zip l2sV (unfreezeVector l1 a) - where - l1 = externalize $ get31 inp - l2s = externalize $ get32 inp - a = externalize $ get33 inp - l2sV = unfreezeVector l1 l2s +instance (Syntactic a, Role a ~ (), Info a ~ EdgeSize () (Internal a)) => + Syntactic (Vector a) -- * Operations -instance RandomAccess (Vector a) +instance Syntactic a => RandomAccess (Vector a) where type Element (Vector a) = a - (!) = index - - + (!) = segmentIndex . mergeSegments --- | Introduces an 'ifThenElse' for each element; use with care! -(++) :: Computable a => Vector a -> Vector a -> Vector a -Indexed l1 ixf1 ++ Indexed l2 ixf2 = Indexed (l1+l2) ixf - where - ixf i = ifThenElse (i < l1) ixf1 (ixf2 . subtract l1) i +(++) :: Vector a -> Vector a -> Vector a +Empty ++ v = v +v ++ Empty = v +Indexed l ixf cont ++ v = Indexed l ixf (cont ++ v) infixr 5 ++ -take :: Data Int -> Vector a -> Vector a -take n (Indexed l ixf) = Indexed (min n l) ixf - -drop :: Data Int -> Vector a -> Vector a -drop n (Indexed l ixf) = Indexed (max 0 (l-n)) (\x -> ixf (x+n)) +take :: Data Length -> Vector a -> Vector a +take _ Empty = Empty +take n (Indexed l ixf cont) = indexed nHead ixf ++ take nCont cont + where + nHead = n Data Bool) -> Vector a -> Vector a -dropWhile cont vec = drop i vec +drop :: Data Length -> Vector a -> Vector a +drop _ Empty = Empty +drop n (Indexed l ixf cont) = indexed nHead (ixf . (+n)) ++ drop nCont cont where - i = while ((< length vec) &&* (cont . (vec !))) (+1) 0 + nHead = n > l ? (0,l-n) + nCont = l > n ? (0,n-l) -splitAt :: Data Int -> Vector a -> (Vector a, Vector a) +splitAt :: Data Index -> Vector a -> (Vector a, Vector a) splitAt n vec = (take n vec, drop n vec) -head :: Vector a -> a +head :: Syntactic a => Vector a -> a head = (!0) -last :: Vector a -> a +last :: Syntactic a => Vector a -> a last vec = vec ! (length vec - 1) tail :: Vector a -> Vector a @@ -222,49 +181,81 @@ init vec = take (length vec - 1) vec tails :: Vector a -> Vector (Vector a) -tails vec = Indexed (length vec + 1) (\n -> drop n vec) +tails vec = indexed (length vec + 1) (\n -> drop n vec) inits :: Vector a -> Vector (Vector a) -inits vec = Indexed (length vec + 1) (\n -> take n vec) +inits vec = indexed (length vec + 1) (\n -> take n vec) inits1 :: Vector a -> Vector (Vector a) inits1 = tail . inits -permute :: (Data Length -> Data Ix -> Data Ix) -> (Vector a -> Vector a) -permute perm (Indexed l ixf) = Indexed l (ixf . perm l) +-- | Permute a single-segment vector +permute' :: (Data Length -> Data Index -> Data Index) -> (Vector a -> Vector a) +permute' _ Empty = Empty +permute' perm (Indexed l ixf Empty) = indexed l (ixf . perm l) -reverse :: Vector a -> Vector a +-- | Permute a vector +permute :: Syntactic a => + (Data Length -> Data Index -> Data Index) -> (Vector a -> Vector a) +permute perm = permute' perm . mergeSegments + +reverse :: Syntactic a => Vector a -> Vector a reverse = permute $ \l i -> l-1-i + -- TODO Can be optimized (reversing each segment separately, and then + -- reversing the segment order) -replicate :: Data Int -> a -> Vector a -replicate n a = Indexed n (const a) +rotateVecL :: Syntactic a => Data Index -> Vector a -> Vector a +rotateVecL ix = permute $ \l i -> (i + ix) `rem` l -enumFromTo :: Data Int -> Data Int -> Vector (Data Int) -enumFromTo m n = Indexed (n-m+1) (+m) - -- XXX Type should be generalized. +rotateVecR :: Syntactic a => Data Index -> Vector a -> Vector a +rotateVecR ix = reverse . rotateVecL ix . reverse -(...) :: Data Int -> Data Int -> Vector (Data Int) -(...) = enumFromTo +replicate :: Data Length -> a -> Vector a +replicate n a = Indexed n (const a) Empty -zip :: Vector a -> Vector b -> Vector (a,b) -zip (Indexed l1 ixf1) (Indexed l2 ixf2) = Indexed (min l1 l2) (ixf1 &&& ixf2) +enumFromTo :: Data Index -> Data Index -> Vector (Data Index) +enumFromTo m n = indexed l (+m) + where + l = n (Vector a, Vector b) -unzip (Indexed l ixf) = (Indexed l (fst.ixf), Indexed l (snd.ixf)) +(...) :: Data Index -> Data Index -> Vector (Data Index) +(...) = enumFromTo map :: (a -> b) -> Vector a -> Vector b -map f (Indexed l ixf) = Indexed l (f . ixf) +map _ Empty = Empty +map f (Indexed l ixf cont) = Indexed l (f . ixf) $ map f cont -zipWith :: (a -> b -> c) -> Vector a -> Vector b -> Vector c +-- | Zipping a single-segment vector +zip' :: Vector a -> Vector b -> Vector (a,b) +zip' Empty _ = Empty +zip' _ Empty = Empty +zip' (Indexed l1 ixf1 Empty) (Indexed l2 ixf2 Empty) = + indexed (min l1 l2) (ixf1 &&& ixf2) + +zip :: (Syntactic a, Syntactic b) => Vector a -> Vector b -> Vector (a,b) +zip vec1 vec2 = zip' (mergeSegments vec1) (mergeSegments vec2) + +unzip :: Vector (a,b) -> (Vector a, Vector b) +unzip Empty = (Empty, Empty) +unzip (Indexed l ixf cont) = + (Indexed l (fst.ixf) cont1, Indexed l (snd.ixf) cont2) + where + (cont1,cont2) = unzip cont + +zipWith :: (Syntactic a, Syntactic b) => + (a -> b -> c) -> Vector a -> Vector b -> Vector c zipWith f aVec bVec = map (uncurry f) $ zip aVec bVec --- | Corresponds to 'foldl'. -fold :: Computable a => (a -> b -> a) -> a -> Vector b -> a -fold f x (Indexed l ixf) = for 0 (l-1) x (\i s -> f s (ixf i)) +-- | Corresponds to the standard 'foldl'. +fold :: Syntactic a => (a -> b -> a) -> a -> Vector b -> a +fold _ x Empty = x +fold f x (Indexed l ixf cont) = + fold f (forLoop l x $ \ix s -> f s (ixf ix)) cont --- | Corresponds to 'foldl1'. -fold1 :: Computable a => (a -> a -> a) -> Vector a -> a -fold1 f a = fold f (head a) a +-- | Corresponds to the standard 'foldl1'. +fold1 :: Type a => (Data a -> Data a -> Data a) -> Vector (Data a) -> Data a +fold1 f a = fold f (head a) (tail a) sum :: Numeric a => Vector (Data a) -> Data a sum = fold (+) 0 @@ -279,3 +270,11 @@ scalarProd :: Numeric a => Vector (Data a) -> Vector (Data a) -> Data a scalarProd a b = sum (zipWith (*) a b) +-- * Wrapping for vectors + +instance (Type a) => Wrap (Vector (Data a)) (Data [a]) where + wrap v = freezeVector v + +instance (Wrap t u, Type a, TL.Nat s) => Wrap (DVector a -> t) (Data' s [a] -> u) where + wrap f = \(Data' d) -> wrap $ f $ unfreezeVector' s' d where + s' = fromInteger $ toInteger $ TL.toInt (undefined :: s) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2009-2010, ERICSSON AB +Copyright (c) 2009-2011, ERICSSON AB All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,31 +1,3 @@ --- --- Copyright (c) 2009-2010, ERICSSON AB All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * 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. --- * Neither the name of the ERICSSON AB nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT HOLDER 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. --- - import Distribution.Simple main = defaultMain diff --git a/examples/Memocode2010.hs b/examples/Memocode2010.hs deleted file mode 100644 --- a/examples/Memocode2010.hs +++ /dev/null @@ -1,228 +0,0 @@ -import qualified Prelude -import Feldspar hiding (cos, cycle) -import Feldspar.Stream (Stream, recurrenceI, cycle) -import qualified Feldspar.Stream as S -import Feldspar.Compiler - - - --------------------------------------------------- --- Missing functions --- --- These ad hoc functions are for various reasons --- not directly included in Feldspar. --------------------------------------------------- - --- Will appear as a call to "intToFloat" in the generated code. -intToFloat :: Data Int -> Data Float -intToFloat = function "intToFloat" (\_ -> universal) (fromInteger.toInteger) - --- Will appear as a call to "cos" in the generated code. -cos :: Data Float -> Data Float -cos = function "cos" (\_ -> universal) Prelude.cos - -toList :: Int -> Vector (Data a) -> [Data a] -toList n v@(Indexed l ix) = Prelude.map (v!) (Prelude.map value [0..n-1]) - --- This function generates very inefficient code. -fromList :: Storable a => [Data a] -> Vector (Data a) -fromList ls = unfreezeVector (value len) - (loop 1 (parallel (value len) (const (Prelude.head ls)))) - where loop i arr - | i Prelude.< len = loop (i+1) (setIx arr (value i) (ls !! i)) - | otherwise = arr - len = Prelude.length ls - - - --------------------------------------------------- --- Examples --------------------------------------------------- - -square :: Data Int -> Data Int -square x = x*x - -sumSq :: Data Int -> Data Int -sumSq n = (sum . map square) (1...n) - --- Convolver -conv1D :: DVector Float -> DVector Float -> DVector Float -conv1D kernel = map (scalarProd kernel . reverse) . inits1 - -modulus :: Data Int -> Data Int -> Data Int -modulus a b = while (>=b) (subtract b) a - -powersOfTwo :: Data [Int] -powersOfTwo = parallel 8 (\i -> 2^i) - - - --------------------------------------------------- --- Discrete cosine transform --------------------------------------------------- - -dct2 :: DVector Float -> DVector Float -dct2 xn = mat ** xn - where - mat = indexedMat (length xn) (length xn) - (\k l -> dct2nkl (length xn) k l) - -dct2nkl :: Data Int -> Data Int -> Data Int -> Data Float -dct2nkl n k l = cos ( (k' * (2*l' + 1)*3.14)/(2*n') ) - where - (n',k',l') = (intToFloat n, intToFloat k, intToFloat l) - - - --------------------------------------------------- --- Sorter --------------------------------------------------- - -minP :: (Storable a, Ord a) => Data a -> Data a -> Data a -minP = function2 "min" (\_ _ -> universal) Prelude.min - -maxP :: (Storable a, Ord a) => Data a -> Data a -> Data a -maxP = function2 "max" (\_ _ -> universal) Prelude.max - -comp :: (Storable a, Ord a) => (Data a,Data a) -> (Data a, Data a) -comp (a,b) = (min a b, max a b) - -cswap :: Data [Int] -> (Data Int, Data Int) -> Data [Int] -cswap as (l,r) = setIx (setIx as r mx) l mn - where - (mn,mx) = comp (as!l,as!r) - -ones k = 2^k-1 - --- j ones, shifted k bits to the left -onesZeros :: Data Int -> Data Int -> Data Int -onesZeros j k = shiftL (ones j) k - -allones = 2^31-1 - --- zero out rightmost i bits of k -zeroBitsR :: Data Int -> Data Int -> Data Int -zeroBitsR i k = k .&. (shiftL allones i) - --- shifts bits j and upwards leftwards one and sets bit j to zero -setBitAndShift :: Data Int -> Data Int -> Data Int -setBitAndShift j k = k + (zeroBitsR j k) - -swapsT n = indexed (n+1) (\j -> (indexed (j+1) (\k -> swapcol n (n-j) (j-k)))) - -swapcol n i v = indexed (2^n) (\k -> g (setBitAndShift (i+v) k)) - where - g k = (k, xor (onesZeros (v+1) i) k) - -sort0 :: Data Length -> Data [Int] -> Data [Int] -sort0 n as = fold (fold (fold cswap)) as (swapsT n) - - - --------------------------------------------------- --- Blake --------------------------------------------------- - -type MessageBlock = DVector Unsigned32 -- 0..15 -type Round = Data Int -type State = Matrix Unsigned32 -- 0..3 0..3 - -co :: DVector Unsigned32 -co = vector [0x243F6A88,0x85A308D3,0x13198A2E,0x03707344, - 0xA4093822,0x299F31D0,0x082EFA98,0xEC4E6C89, - 0x452821E6,0x38D01377,0xBE5466CF,0x34E90C6C, - 0xC0AC29B7,0xC97C50DD,0x3F84D5B5,0xB5470917] - -sigma :: Matrix Int -sigma = matrix - [[0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15] - ,[14,10,4,8,9,15,13,6,1,12,0,2,11,7,5,3] - ,[11,8,12,0,5,2,15,13,10,14,3,6,7,1,9,4] - ,[7,9,3,1,13,12,11,14,2,6,5,10,4,0,15,8] - ,[9,0,5,7,2,4,10,15,14,1,11,12,6,8,3,13] - ,[2,12,6,10,0,11,8,3,4,13,7,5,15,14,1,9] - ,[12,5,1,15,14,13,4,10,0,7,6,3,9,2,8,11] - ,[13,11,7,14,12,1,3,9,5,0,15,4,8,6,2,10] - ,[6,15,14,9,11,3,0,8,12,2,13,7,1,4,10,5] - ,[10,2,8,4,7,6,1,5,15,11,9,14,3,12,13,0] - ] - -diagonals :: Matrix a -> Matrix a -diagonals m = map (diag m) (0 ... (length (head m) - 1)) - --- Return the i'th diagonal -diag :: Matrix a -> Data Int -> Vector (Data a) -diag m i = zipWith lookup m (i ... (l + i)) - where l = length m - 1 - lookup v i = v ! (i `mod` length v) - -invDiagonals :: Storable a => Matrix a -> Matrix a -invDiagonals m = zipWith shiftVectorR (0 ... (length m - 1)) (transpose m) - -shiftVectorR :: Computable a => Data Int -> Vector a -> Vector a -shiftVectorR i v = reverse (drop i rev ++ take i rev) - where rev = reverse v - -blakeRound :: MessageBlock -> State -> Round -> State -blakeRound m state r = - (invDiagonals . - zipWith (g m r) (4 ... 7) . - diagonals . - transpose . - zipWith (g m r) (0 ... 3) . - transpose) - state - -g :: MessageBlock -> Round -> Data Int - -> DVector Unsigned32 -> DVector Unsigned32 -g m r i v = fromList [a'',b'',c'',d''] - where [a,b,c,d] = toList 4 v - a' = a + b + - (m!(sigma!r!(2*i)) ⊕ (co!(sigma!r!(2*i+1)))) - d' = (d ⊕ a') >> 16 - c' = c + d' - b' = (b ⊕ c') >> 12 - a'' = a' + b' + - (m!(sigma!r!(2*i+1)) ⊕ (co!(sigma!r!(2*i)))) - d'' = (d' ⊕ a'') >> 8 - c'' = c' + d'' - b'' = (b' ⊕ c'') >> 7 - - - --------------------------------------------------- --- Streams --------------------------------------------------- - --- IIR filter -iir :: Data Float -> DVector Float -> DVector Float - -> Stream (Data Float) -> Stream (Data Float) -iir a0 a b input = - recurrenceI (replicate q 0) input - (replicate p 0) - (\x y -> 1 / a0 * - ( sum (indexed p (\i -> b!i * x!(p-i))) - - sum (indexed q (\j -> a!j * y!(q-j)))) - ) - where p = length b - q = length a - - - --------------------------------------------------- --- Tests --------------------------------------------------- - -test1 = eval (sumSq 10) -test2 = printCore sumSq -test3 = icompile' sumSq "sumSq" defaultOptions -test4 = printCore conv1D -test5 = eval (modulus 22 6) -test6 = eval powersOfTwo -test7 = printCore dct2 -test8 = printCore sort0 -test9 = printCore iirVec - where - -- Wrapper code to make it operate on vectors - iirVec a0 a b = S.take 100 . iir a0 a b . cycle - diff --git a/feldspar-language.cabal b/feldspar-language.cabal --- a/feldspar-language.cabal +++ b/feldspar-language.cabal @@ -1,12 +1,12 @@ name: feldspar-language -version: 0.3.3 +version: 0.4.0.2 synopsis: A functional embedded language for DSP and parallelism description: Feldspar (Functional Embedded Language for DSP and PARallelism) is an embedded DSL for describing digital signal processing algorithms. This package contains the language front-end and an interpreter. category: Language -copyright: Copyright (c) 2009-2010, ERICSSON AB +copyright: Copyright (c) 2009-2011, ERICSSON AB author: Functional programming group at Chalmers University of Technology maintainer: Emil Axelsson license: BSD3 @@ -15,50 +15,73 @@ homepage: http://feldspar.inf.elte.hu/feldspar/ build-type: Simple cabal-version: >= 1.6 -tested-with: GHC==6.10.* +tested-with: GHC==6.12.*, GHC==7.0.2 -data-files: - examples/Memocode2010.hs +extra-source-files: + Examples/Tutorial/*.hs, + Examples/Simple/*.hs, + Examples/Effects/*.hs, + Examples/Math/*.hs library exposed-modules: Feldspar.Prelude - Feldspar.Utils - Feldspar.Haskell + Feldspar.DSL.Expression + Feldspar.DSL.Lambda + Feldspar.DSL.Sharing + Feldspar.DSL.Val + Feldspar.DSL.Network + Feldspar.Set Feldspar.Range Feldspar.Core.Types - Feldspar.Core.Ref - Feldspar.Core.Expr - Feldspar.Core.Graph - Feldspar.Core.Show - Feldspar.Core.Reify + Feldspar.Core.Representation + Feldspar.Core.Constructs + Feldspar.Core.Functions.Logic + Feldspar.Core.Functions.Eq + Feldspar.Core.Functions.Ord + Feldspar.Core.Functions.Num + Feldspar.Core.Functions.Bits + Feldspar.Core.Functions.Integral + Feldspar.Core.Functions.Fractional + Feldspar.Core.Functions.Floating + Feldspar.Core.Functions.Complex + Feldspar.Core.Functions.Tuple + Feldspar.Core.Functions.Array + Feldspar.Core.Functions.Conversion + Feldspar.Core.Functions.Trace Feldspar.Core.Functions - Feldspar.Core.Trace + Feldspar.Core.Wrap Feldspar.Core Feldspar.Vector Feldspar.Matrix - Feldspar.FixedPoint Feldspar.Stream + Feldspar.FixedPoint Feldspar build-depends: - base >= 4 && < 4.3, + array, + base >= 4 && < 4.4, containers, mtl, + QuickCheck >= 2.4 && < 3, random, - QuickCheck >= 2.3 && < 3 + tagged == 0.2.*, + type-level >= 0.2.4 extensions: + EmptyDataDecls FlexibleInstances FlexibleContexts + FunctionalDependencies GADTs + GeneralizedNewtypeDeriving MultiParamTypeClasses - NoMonomorphismRestriction - OverlappingInstances PatternGuards Rank2Types ScopedTypeVariables + StandaloneDeriving TypeFamilies TypeOperators TypeSynonymInstances UndecidableInstances + DeriveDataTypeable