feldspar-language 0.3.3 → 0.4.0.2

raw patch · 61 files changed

+6119/−5460 lines, 61 filesdep +arraydep +taggeddep +type-leveldep ~QuickCheckdep ~basesetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: array, tagged, type-level

Dependency ranges changed: QuickCheck, base

API changes (from Hackage documentation)

Files

• Examples/Effects/Overdrive.hs +23/−0
• Examples/Effects/ShiftByOneOctave.hs +25/−0
• Examples/Math/Convolution.hs +22/−0
• Examples/Math/Fft.hs +124/−0
• Examples/Simple/Basics.hs +43/−0
• Examples/Simple/Complex.hs +35/−0
• Examples/Simple/Fixedpoint.hs +112/−0
• Examples/Simple/Matrices.hs +26/−0
• Examples/Simple/Pairs.hs +23/−0
• Examples/Simple/Sharing.hs +35/−0
• Examples/Simple/Streams.hs +25/−0
• Examples/Simple/Trace.hs +13/−0
• Examples/Simple/Vectors.hs +60/−0
• Examples/Tutorial/FixedPoint.hs +44/−0
• Examples/Tutorial/Stream.hs +23/−0
• Examples/Tutorial/Tutorial.hs +606/−0
• Examples/Tutorial/Vector.hs +137/−0
• Feldspar.hs +5/−37
• Feldspar/Core.hs +73/−76
• Feldspar/Core/Constructs.hs +245/−0
• Feldspar/Core/Expr.hs +0/−641
• Feldspar/Core/Functions.hs +35/−732
• Feldspar/Core/Functions/Array.hs +88/−0
• Feldspar/Core/Functions/Bits.hs +202/−0
• Feldspar/Core/Functions/Complex.hs +51/−0
• Feldspar/Core/Functions/Conversion.hs +46/−0
• Feldspar/Core/Functions/Eq.hs +98/−0
• Feldspar/Core/Functions/Floating.hs +31/−0
• Feldspar/Core/Functions/Fractional.hs +29/−0
• Feldspar/Core/Functions/Integral.hs +133/−0
• Feldspar/Core/Functions/Logic.hs +38/−0
• Feldspar/Core/Functions/Num.hs +179/−0
• Feldspar/Core/Functions/Ord.hs +185/−0
• Feldspar/Core/Functions/Trace.hs +21/−0
• Feldspar/Core/Functions/Tuple.hs +39/−0
• Feldspar/Core/Graph.hs +0/−555
• Feldspar/Core/Ref.hs +0/−98
• Feldspar/Core/Reify.hs +0/−315
• Feldspar/Core/Representation.hs +323/−0
• Feldspar/Core/Show.hs +0/−207
• Feldspar/Core/Trace.hs +0/−38
• Feldspar/Core/Types.hs +213/−355
• Feldspar/Core/Wrap.hs +47/−0
• Feldspar/DSL/Expression.hs +74/−0
• Feldspar/DSL/Lambda.hs +197/−0
• Feldspar/DSL/Network.hs +389/−0
• Feldspar/DSL/Sharing.hs +164/−0
• Feldspar/DSL/Val.hs +78/−0
• Feldspar/FixedPoint.hs +190/−539
• Feldspar/Haskell.hs +0/−101
• Feldspar/Matrix.hs +48/−87
• Feldspar/Prelude.hs +5/−31
• Feldspar/Range.hs +1007/−802
• Feldspar/Set.hs +85/−0
• Feldspar/Stream.hs +221/−307
• Feldspar/Utils.hs +0/−101
• Feldspar/Vector.hs +162/−163
• LICENSE +1/−1
• Setup.hs +0/−28
• examples/Memocode2010.hs +0/−228
• feldspar-language.cabal +41/−18

@@ -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)

@@ -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)

@@ -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)

@@ -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 )+++

@@ -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))

@@ -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)

@@ -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

@@ -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)

@@ -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)+

@@ -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+

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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))+      )

@@ -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<<k))
+
+bitZero :: Data Index -> Data Index -> Data Bool
+bitZero k i = (i .&. (1<<k)) == 0
+
+bitOne :: Data Index -> Data Index -> Data Bool
+bitOne k i = (i .&. (1<<k)) /= 0
+
+lsbZero :: Data Index -> 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<<s))
+      where
+        mask' = (mask `xor` (mask << s)) .|. zeroBitsN (1 << n)
+
+bitRevLog :: Data Index -> 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<<s))
+      where
+        mask' = (mask `xor` (mask << s)) .|. zeroBitsN (1 << (value n))
+
+bitRevLogH :: Index -> 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<<k
+        f a b _ = a + b
+        g a b t = t * (a-b)
+        twid i  = cis (-pi*(i2f (lsbsN k i)) / i2f p)
+
+
+
+ex18' = eval ((bitRev 3 . fft 3) (testseq1 3))
+
+
+
+
+-- 2^l input IFFT. Produces output in bit reversed order.
+ifft :: Data Index ->  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<<k
+        f a b _ = a + b
+        g a b t = t * (a-b)
+        twid i  = cis (pi*(i2f (lsbsN k i)) / i2f p)
+
+
+
+
+
+cx21 = icompile fft
+
+testseq :: Data DefaultWord -> 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) )
+
+
+
+
+
+
+
+

@@ -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

@@ -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+

@@ -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 

@@ -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'.+

@@ -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-

@@ -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<b ? (a,b)-  max  :: Data 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<b-    cond2 = b<a-    ra    = dataSize a-    rb    = dataSize b--optMax :: (Ord a, Size a ~ Range b, Prelude.Ord b, Num b) =>-          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 

@@ -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+

@@ -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+

@@ -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+

@@ -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)

@@ -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)+

@@ -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+

@@ -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+

@@ -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+

@@ -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+

@@ -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+

@@ -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<b ? (a,b)+  max :: Data 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<b+    cond2 = b<a+    ra    = dataSize a+    rb    = dataSize b++optMax :: (Ord a, BoundedInt b, Size a ~ Range b) => 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+

@@ -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+

@@ -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)+

@@ -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) 

@@ -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)-

@@ -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

@@ -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...+

@@ -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-

@@ -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