packages feed

feldspar-language 0.4.0.2 → 0.5.0.1

raw patch · 120 files changed

+10533/−4651 lines, 120 filesdep +QuickAnnotatedep +data-hashdep +data-lenssetup-changed

Dependencies added: QuickAnnotate, data-hash, data-lens, monad-par, patch-combinators, syntactic, tuple

Files

+ CEFP/cefpNotes.hs view
@@ -0,0 +1,210 @@+import qualified Prelude
+import Feldspar
+import Feldspar.Vector
+import Feldspar.Compiler
+import Feldspar.Matrix
+
+
+
+-- This code accompanies our lecture notes
+-- "Feldspar: Application and Implementation", in CEFP,
+-- Springer LNCS 7241, 2012.
+-- The code is documented in the notes.
+
+
+square :: Data WordN -> Data WordN
+square x = x*x
+
+
+
+f :: Data Int32 -> Data Int32
+f i = (testBit i 0) ? (2*i, i)
+
+
+arr1n :: Data WordN -> Data [WordN]
+arr1n n = parallel n (\i -> (i+1))
+
+squareEach :: Data [WordN] -> Data [WordN]
+squareEach as = parallel (getLength as) (\i -> square (getIx as i))
+
+
+sfac :: Data WordN -> Data [WordN]
+sfac n = sequential n 1 g
+  where
+    g ix st = (j,j)
+      where j = (ix + 1)  * st
+
+
+fib :: Data Index -> Data Index
+fib n = fst $ forLoop n (1,1) $ \i (a,b) -> (b,a+b)
+
+
+intLog :: Data WordN -> Data WordN
+intLog n = fst $ whileLoop (0,n)
+                  (\(_,b) -> (b > 1))
+                  (\ (a,b) -> (a+1, b `div` 2))
+
+
+
+
+
+
+tw :: Data WordN -> Data WordN -> Data (Complex Float)
+tw n k = exp (-2 * pi * iunit * i2n k / i2n n)
+
+tws n = indexed n (tw n)
+
+
+
+squares :: Data WordN -> Vector1 WordN
+squares n = map square (1...n)
+
+
+
+flipBit ::  Data Index -> Data Index -> Data Index
+flipBit i k = i `xor` (bit k)
+
+flips :: Data WordN -> Vector1 WordN -> Vector1 WordN
+flips k = map (\e -> flipBit e k)
+
+
+sumSqVn :: Data WordN -> Data WordN
+sumSqVn n = fold (+) 0 $ map square (1...n)
+
+
+-- Transforms
+
+
+-- DFT
+
+dft :: Vector (Data (Complex Float)) -> Vector (Data (Complex Float))
+dft xs = indexed n (\k -> sum (indexed n (\j -> xs!j * tw n (j*k))))
+  where
+    n = length xs
+
+
+-- FFT
+
+premap :: (Data Index -> Data Index) -> Vector a -> Vector a
+premap f (Indexed l ixf Empty) = indexed l (ixf . f)
+
+
+revp :: (Bits a) => Data Index -> Vector1 a -> Vector1 a
+revp k  = premap (`xor` (2^k - 1))
+
+
+bfly :: Data Index ->  Vector (Data (Complex Float))
+                   -> Vector (Data (Complex Float))
+bfly k as = indexed l ixf
+  where
+    l = length as
+    ixf i = (testBit i k) ? (b-a, a+b)
+      where
+        a = as ! i
+        b = as ! (flipBit i k)
+
+
+
+
+
+
+-- Recursive
+-- works on sub-arrays of length 2^n
+fftr0 :: Index ->  Vector (Data (Complex Float)) ->
+         Vector (Data (Complex Float))
+fftr0 0 = id
+fftr0 n = fftr0 n' . twids0 vn' . bfly vn'
+      where
+        n'  = n - 1
+        vn' = value n'
+
+
+-- Needs bit reversal on the output
+fft0 :: Index ->  Vector (Data (Complex Float)) ->
+        Vector (Data (Complex Float))
+fft0 n = bitRev (value n) . fftr0 n
+
+
+
+oneBitsN :: Data Index -> Data Index
+oneBitsN  k = complement (shiftLU (complement 0) k)
+
+
+
+-- bit reversal
+bitr :: Data Index -> Data Index -> Data Index
+bitr n a = let mask = (oneBitsN n) in
+    (complement mask .&. a) .|. rotateLU (reverseBits (mask .&. a)) n
+
+
+bitRev :: Data Index -> Vector a -> Vector a
+bitRev n = premap (bitr n)
+
+
+
+dt4 = zipWith (+.) (value [1,2,3,1 :: Float]) (value [4,-2,2,2])
+
+
+
+
+-- Iterative
+fft1 :: Data Index -> Vector (Data (Complex Float)) ->
+         Vector (Data (Complex Float))
+fft1 n as = bitRev n $ forLoop n as (\k -> twids0 (n-1-k) . bfly (n-1-k))
+
+
+
+
+fft2 :: Data Index -> Vector (Data (Complex Float))
+                    -> Vector (Data (Complex Float))
+fft2 n as = bitRev n $ forLoop n as (\k -> bfly2 (n-1-k))
+  where
+    bfly2 k as = indexed l ixf
+      where
+        l = length as
+        ixf i = (testBit i k) ? (t*(b-a), a+b)
+          where
+            a = as ! i
+            b = as ! (flipBit i k)
+            t = tw (2^(k+1)) (i `mod` (2^k))
+
+
+
+twids0 :: Data Index -> Vector1 (Complex Float) -> Vector1 (Complex Float)
+twids0 k as = indexed l ixf
+  where
+    l = length as
+    ixf i = (testBit i k) ? (t*(as!i),as!i)
+      where
+        t = tw (2^(k+1)) (i `mod` (2^k))
+
+
+
+twids1 :: Data Index -> Data Index -> Vector1 (Complex Float)
+                                   -> Vector1 (Complex Float)
+twids1 n k as = indexed (length as) ixf
+  where
+    ixf i = (testBit i k) ? (t * (as!i), as!i)
+      where
+        t = tw (2^n) ((i `mod` (2^k)) .<<. (n-1-k))
+
+
+
+twids2 :: Data Index -> Data Index -> Vector1 (Complex Float)
+                                   -> Vector1 (Complex Float)
+twids2 n k as = indexed (length as) ixf
+  where
+    ts = force $ indexed (2^(n-1)) (tw (2^n))
+    ixf i = (testBit i k) ? (t * (as!i), as!i)
+      where
+        t = ts ! ((i `mod` (2^k)) .<<. (n-1-k))
+
+
+fft3 :: Data Index -> Vector1 (Complex Float) -> Vector1 (Complex Float)
+fft3 n as = bitRev n $ forLoop n as (\k -> twids2 n (n-1-k) . bfly (n-1-k))
+
+
+-- Decimation in Time (Earlier versions are Decimation in Frequency)
+fft4 :: Data Index -> Vector1 (Complex Float) -> Vector1 (Complex Float)
+fft4 n as = forLoop n (bitRev n as) (\k -> bfly k . twids2 n k)
+
Examples/Effects/Overdrive.hs view
@@ -2,11 +2,12 @@  import qualified Prelude import Feldspar+import Feldspar.Wrap 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 :: (Numeric a, Ord a) => Vector1 a -> Data a -> Data a -> Vector1 a overdrive x mul bound = map (\x -> x * mul) $ map mapFn x   where     mapFn elem = (?) (elem > bound) (bound, elseBranch)@@ -16,8 +17,8 @@ -- | 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-    +    desugar $ overdrive (thawVector' 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)+overdrive_wrapped = wrap (overdrive :: Vector1 Float -> Data Float -> Data Float -> Vector1 Float)
Examples/Effects/ShiftByOneOctave.hs view
@@ -2,12 +2,13 @@  import qualified Prelude import Feldspar+import Feldspar.Wrap 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 :: (Fraction a) => Vector1 a -> Vector1 a shiftByOneOctave inp = half ++ half     where         half = everySecond $ map avg $ zip inp $ tail inp@@ -16,10 +17,10 @@  -- | Wrapper to fix the type and size of the vectors in shiftByOneOctave. shiftByOneOctaveInstance :: Data [Float] -> Data [Float]-shiftByOneOctaveInstance input = freezeVector $ shiftByOneOctave input'+shiftByOneOctaveInstance input = desugar $ shiftByOneOctave input'     where-        input' = unfreezeVector' 256 input+        input' = thawVector' 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)+shiftByOneOctave_wrapped = wrap (shiftByOneOctave :: Vector1 Float -> Vector1 Float)
Examples/Math/Convolution.hs view
@@ -2,21 +2,22 @@  import qualified Prelude import Feldspar+import Feldspar.Wrap import Feldspar.Vector import Feldspar.Compiler import Feldspar.Matrix  -- | Generic (not compilable) convolution function-convolution :: (Numeric a) => DVector a -> DVector a -> DVector a+convolution :: (Numeric a) => Vector1 a -> Vector1 a -> Vector1 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'+convolutionInstance kernel input = desugar $ convolution kernel' input'     where-        input'  = unfreezeVector' 256 input-        kernel' = unfreezeVector'  16 kernel+        input'  = thawVector' 256 input+        kernel' = thawVector'  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)+convolution_wrapped = wrap (convolution :: Vector1 Float -> Vector1 Float -> Vector1 Float)
Examples/Math/Fft.hs view
@@ -2,13 +2,14 @@  import qualified Prelude as P import Feldspar+import Feldspar.Wrap 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+fftInstance = desugar . fft . thawVector' 256  -- | Wrapper to define the size of vectors in 'fft' fft_wrapped ::Data' D256 [Complex Float] ->  Data [Complex Float]@@ -16,7 +17,7 @@  -- | Wrapper to define the size of vectors in 'ifft' ifftInstance :: Data [Complex Float] -> Data [Complex Float]-ifftInstance = freezeVector . ifft . unfreezeVector' 256+ifftInstance = desugar . ifft . thawVector' 256  -- | Wrapper to define the size of vectors in 'ifft' ifft_wrapped ::Data' D256 [Complex Float] ->  Data [Complex Float]@@ -26,13 +27,13 @@ -- =================== 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 :: Vector1 (Complex Float) -> Vector1 (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 :: Vector1 (Complex Float) -> Vector1 (Complex Float) ifft v = bitRev (loglen-1) $ ifftCore (loglen-1) v     where loglen = f2i $ logBase 2 $ i2f $ length v -- ================================================================@@ -41,35 +42,35 @@   -- | 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) +--   Output from the last stage needs to be bit reversed using bitRev function (if required)+fftCore ::  Data Index ->  Vector1 (Complex Float) -> Vector1 (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+    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) +--   Output from the last stage needs to be bit reversed using bitRev function (if required)+ifftCore ::  Data Index ->  Vector1 (Complex Float) -> Vector1 (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+    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)@@ -77,47 +78,47 @@   -- | Helper functions for fftCore and ifftCore and bitRev-pipe :: (Syntactic a) => (Data Index -> a -> a) -> Vector (Data Index) -> a -> a+pipe :: (Syntax 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)+oneBits n = complement (allOnes .<<. n)  lsbs k i = i .&. oneBits k -par m n f = mat2Vec m n . map f . vec2Mat m n +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 0 _ = P.error "k should be at least 1" rotBit k i = lefts .|. rights   where-    ir = i >> 1+    ir = i .>>. 1     rights = ir .&. (oneBits k)-    lefts  = (((ir >> k) << 1) .|. (i .&. 1)) << 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'+vec2Mat m n (Indexed l ixf Empty) = indexedMat (1 .<<. m) (1 .<<. n) ixf'   where-    ixf' i j = ixf $ (i << n) `xor` j -      +    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+mat2Vec m n matr = Indexed (1 .<<. m .<<. n) ixf Empty   where     ixf i = matr ! y ! x       where-        y = i >> n+        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 :: Data WordN -> Vector1 (Complex Float) pow2Seq n = indexed (2 ^ n) (\i ->complex (i2f i) 0 )
Examples/Simple/Basics.hs view
@@ -41,3 +41,4 @@  example10 :: Data Int32 -> Data Int32 example10 a = condition (a<5) (3*(a+a)) (30*(a+a))+
+ Examples/Simple/BitVectors.hs view
@@ -0,0 +1,29 @@+module Examples.Simple.BitVectors where++import qualified Prelude+import Feldspar+import Feldspar.Wrap+import Feldspar.BitVector+import Feldspar.Compiler++-- | Counting 1 bits in a bitvector+countOnes :: (Unit w, Size w ~ Range w) => BitVector w -> Data Length+countOnes = fold (\a b -> a + b2i b) (0 :: Data Length)++countOnes' :: Data' D10 [Word32] -> Data Length+countOnes' = wrap (countOnes :: BitVector Word32 -> Data Length)++-- | CRC+crc :: (Unit w, Size w ~ Range w) => BitVector w -> BitVector w -> BitVector w+crc input control+  = fold step (takeUnits n padded) $ dropUnits n padded+  where+    n = numOfUnits control+    padded = input ++ replUnit n 0+    step window bit = head window ?+        ( zipWith (/=) (tail bit window) control+        , tail bit window+        )++crc' :: Data' D10 [Word16] -> Data' D1 [Word16] -> Data [Word16]+crc' = wrap (crc :: BitVector Word16 -> BitVector Word16 -> BitVector Word16)
Examples/Simple/Complex.hs view
@@ -2,6 +2,7 @@  import qualified Prelude import Feldspar+import Feldspar.Wrap import Feldspar.Vector import Feldspar.Compiler @@ -11,7 +12,7 @@  -- | Constant vector containing complex values. complex2 :: Data [Complex Float]-complex2 = wrap $ vector+complex2 = value     [ 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)@@ -20,16 +21,17 @@  -- | Sum of a complex vector. complex3 :: Data' D256 [Complex Float] -> Data (Complex Float)-complex3 = wrap (sum :: DVector (Complex Float) -> Data (Complex Float))- +complex3 = wrap (sum :: Vector1 (Complex Float) -> Data (Complex Float))+ -- | Generic (not compilable) pairwise multiplication of vectors.-complex4 :: (Syntactic a, Num a) => Vector a -> Vector a -> Vector a+complex4 :: (Syntax 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))+complex4' = wrap (complex4 :: Vector1 (Complex Float) -> Vector1 (Complex Float) -> Vector1 (Complex Float))  -- | Real parts of a complex vector. complex5 :: Data' D256 [Complex Float] -> Data [Float] complex5 = wrap $ map (realPart :: Data (Complex Float) -> Data Float)+
Examples/Simple/Fixedpoint.hs view
@@ -12,10 +12,10 @@ fpex1 x y = x + y  -- | Wrapper for 'fpex1' using fixed-point numbers--- (with type Int32, input exponents are (-2) and (-3), +-- (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)) +fpex1Fix32 x y = freezeFix' (-2) $ fpex1 ((unfreezeFix' (-3) x))                                         ((unfreezeFix' (-4) y))  -- | Wrapper for 'fpex1' using floating-point numbers@@ -28,7 +28,7 @@  -- | Wrapper for 'fpex2' using fixed-point numbers fpex2Fix32 :: Data Int32 -> Data Int32 -> Data Int32-fpex2Fix32 x y = freezeFix' (-4) $ fpex2 ((unfreezeFix' (-8) x)) +fpex2Fix32 x y = freezeFix' (-4) $ fpex2 ((unfreezeFix' (-8) x))                                         ((unfreezeFix' (-4) y))  -- | Wrapper for 'fpex3' using floating-point numbers@@ -48,12 +48,12 @@ fpex3Float x = fpex3 x  -- | Generic (not compilable) function increasing each element of the input vector-fpex4 :: (Num a) => +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 :: Data Int32 -> Vector1 Int32 -> Vector1 Int32 fpex4Fix32 x xs = map (freezeFix' (-4)) $ fpex4 x' xs'    where       xs' :: Vector (Fix Int32)@@ -63,14 +63,14 @@  -- | Wrapper for 'fpex4' using floating-point numbers fpex4Float :: Data Float -> Data [Float] -> Data [Float]-fpex4Float x xs = freezeVector $ fpex4 x xs'+fpex4Float x xs = desugar $ fpex4 x xs'    where-      xs' = unfreezeVector' 256 xs-      +      xs' = thawVector' 256 xs + -- | Generic (not compilable) average function fpex5 :: (Num a,Fractional a) => a -> a -> a-fpex5 x y = (x + y) / 2 +fpex5 x y = (x + y) / 2  -- | Wrapper for 'fpex5' using fixed-point numbers (with type Int32) fpex5Fix32 :: Data Int32 -> Data Int32 -> Data Int32@@ -84,7 +84,7 @@ fpex5Float x y = fpex5 x y  -- | Generic (not compilable) function with condition-fpex6 :: (Fractional a, Syntactic a, Fixable a) => Data Bool -> a -> a+fpex6 :: (Fractional a, Syntax 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)@@ -96,17 +96,18 @@ fpex6Float = fpex6  -- | Generic (not compilable) scalar product function-fpScalarProd :: (Num a, Syntactic a, Fixable a) =>+fpScalarProd :: (Num a, Syntax 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 :: Vector1 Int32 -> Vector1 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 :: Vector1 Float -> Vector1 Float -> Data Float fpScalarProdFloat = fpScalarProd+
Examples/Simple/Matrices.hs view
@@ -2,6 +2,7 @@  import qualified Prelude import Feldspar+import Feldspar.Wrap import Feldspar.Vector import Feldspar.Matrix import Feldspar.Compiler@@ -23,4 +24,5 @@ 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)+matMult' m1 m2 = freezeMatrix $ (thawMatrix' 16 16 m1) *** (thawMatrix' 16 16 m2)+
Examples/Simple/Pairs.hs view
@@ -9,15 +9,11 @@ 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)+pairs3 :: (Data Int32, Data Float) -> (Data Int32, Data Float)+pairs3 p = (fst p, snd 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)+pairs4 xs ys = desugar $ zipWith (\a b -> desugar (a,b)) (thawVector' 256 xs) (thawVector' 256 ys)
Examples/Simple/Sharing.hs view
@@ -2,6 +2,7 @@  import qualified Prelude import Feldspar+import Feldspar.Wrap import Feldspar.Vector import Feldspar.Compiler @@ -14,11 +15,11 @@ share2 :: Data Int32 -> Data Int32 share2 v = (2*v) + (2*v) -share3 :: Data Int32 -> DVector Int32+share3 :: Data Int32 -> Vector1 Int32 share3 v = indexed 10 $ const w where     w = 2 * v + v -share4 :: Data Int32 -> DVector Int32+share4 :: Data Int32 -> Vector1 Int32 share4 v = indexed 10 $ const w where     w = 2 * q + q where      q = v + 1@@ -26,10 +27,19 @@ share4' :: Data Int32 -> Data [Int32] share4' = wrap share4 -share5 :: Data Index -> DVector Index+share5 :: Data Index -> Vector1 Index share5 v = indexed 10 $ \ix -> w ix where     w ix = 2 * v + ix  share5' :: Data Index -> Data [Index] share5' = wrap share5++share6 :: Vector1 Int32 -> Vector1 Int32+share6 v = share (map (*2) v) $ \w -> zipWith (+) w w++save1 :: Vector1 Index -> Vector1 Index+save1 = map (*3) . save . reverse++save2 :: Data Index -> Data Index+save2 = (*3) . save . (+2)
+ Examples/Simple/SizeInference.hs view
@@ -0,0 +1,35 @@+module Examples.Simple.SizeInference where++++import qualified Prelude as P++import Feldspar+import Feldspar.Compiler hiding (setLength)++++-- This example shows that size inference works through `forLoop` if the step+-- function does not increase the size of the state.+reverse :: Type a => Data [a] -> Data [a]+reverse a = forLoop l a $ \i a' -> setIx a' i (a ! (l-i-1))+  where+    l = getLength a++test_reverse = icompile $ reverse+    -:: tArr1 tI32 >-> id+    -:: notAbove 100 |> id >-> id++++-- This example shows that size inference fails if the step function increases+-- the size of the state.+reverseBad :: Type a => Data [a] -> Data [a]+reverseBad a = forLoop l a $ \i a' -> setLength (l-1) $ setIx a' i (a ! (l-i-1))+  where+    l = getLength a++test_reverseBad = drawDecor $ reverseBad+    -:: tArr1 tI32 >-> id+    -:: notAbove 100 |> id >-> id+
Examples/Simple/Streams.hs view
@@ -2,6 +2,7 @@  import Prelude () import Feldspar+import Feldspar.Wrap import Feldspar.Vector import Feldspar.Stream import Feldspar.Compiler@@ -10,16 +11,16 @@ --   '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 :: (Num a, Syntax 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 :: (Numeric a) => Vector1 a -> Vector1 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' xs = desugar $ stream1_1 $ thawVector' 64 xs  stream1_1_wrapped:: Data' D64 [Int32] -> Data [Int32]-stream1_1_wrapped  = wrap (stream1_1 :: DVector Int32 -> DVector Int32)+stream1_1_wrapped  = wrap (stream1_1 :: Vector1 Int32 -> Vector1 Int32)
Examples/Simple/Trace.hs view
@@ -8,6 +8,7 @@ --- | 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+traceExample xs = fold (\x y -> trace 3 $ trace 1 x + trace 2 y) 0 $ thawVector' 255 xs+
Examples/Simple/Vectors.hs view
@@ -2,6 +2,7 @@  import qualified Prelude import Feldspar+import Feldspar.Wrap import Feldspar.Vector import Feldspar.Compiler @@ -11,15 +12,15 @@ -- adds 3 to every element and -- reverses the vector then -- multiplies every element by 10.-vector1 :: DVector Index+vector1 :: Vector1 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' :: Vector1 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 :: Vector1 Int32 -> Vector1 Int32 vector2 = drop 3  -- | Wrappers to `vector2` to provide static information on the input vector size@@ -27,34 +28,35 @@ vector2' = wrap vector2  vector2'' :: Data [Int32] -> Data [Int32]-vector2'' = freezeVector . vector2 . unfreezeVector' 10+vector2'' = desugar . vector2 . thawVector' 10  -- | Generates a parallel vector of size 10-vector3 :: Data Index -> DVector Index+vector3 :: Data Index -> Vector1 Index vector3 a = indexed 10 ((+a) . (*10))  -- | Vector summation.-vector4 :: (Numeric a) => DVector a -> Data a+vector4 :: (Numeric a, Type a) => Vector1 a -> Data a vector4 xs = fold (+) 0 xs  -- | Wrappers to provide the necessary type information-vector4' :: DVector Int32 -> Data Int32+vector4' :: Vector1 Int32 -> Data Int32 vector4' = vector4 -vector4'' :: DVector Word8 -> Data Word8+vector4'' :: Vector1 Word8 -> Data Word8 vector4'' = vector4  -- | Generic function to increment vector elements-vector5 :: (Numeric a) => DVector a -> DVector a+vector5 :: (Type a, Numeric a) => Vector1 a -> Vector1 a vector5 = map (+1)  -- | Wrappers to provide necessary type information and input size-vector5' :: DVector Int32 -> DVector Int32+vector5' :: Vector1 Int32 -> Vector1 Int32 vector5' = vector5  vector5'' :: Data' D64 [Int32] -> Data [Int32]-vector5'' = wrap (vector5 :: DVector Int32 -> DVector Int32)+vector5'' = wrap (vector5 :: Vector1 Int32 -> Vector1 Int32)  -- | Concatenation-vector6 :: DVector Int32 -> DVector Int32+vector6 :: Vector1 Int32 -> Vector1 Int32 vector6 xs = map (+1) xs ++ map (*2) xs+
− Examples/Tutorial/FixedPoint.hs 
@@ -1,44 +0,0 @@-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
− Examples/Tutorial/Stream.hs 
@@ -1,23 +0,0 @@-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))-      )
− Examples/Tutorial/Tutorial.hs 
@@ -1,606 +0,0 @@-{-# 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) )
-
-
-
-
-
-
-
-
− Examples/Tutorial/Vector.hs 
@@ -1,137 +0,0 @@-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
Feldspar.hs view
@@ -1,3 +1,31 @@+--+-- Copyright (c) 2009-2011, 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 essential parts of the Feldspar language. High-level -- libraries have to be imported separately.
+ Feldspar/BitVector.hs view
@@ -0,0 +1,374 @@+--+-- Copyright (c) 2009-2011, 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 #-}++module Feldspar.BitVector where++import qualified Prelude+import qualified Data.TypeLevel+import Data.Int+import Data.Word+import Data.Typeable+import Data.List (inits)+import qualified Data.TypeLevel as TL++import Language.Syntactic++import Feldspar.Wrap+import Feldspar.Prelude+import Feldspar hiding (sugar, desugar, resugar)+import qualified Feldspar.Vector as Vec++-- * Types and classes++data T a = T+  -- TODO Use `Data.Proxy.Proxy` instead++class (Type w, Numeric w, Bits w, Integral w) => Unit w+  where+    width :: T w -> Length++instance Unit Word8+  where+    width _ = 8++instance Unit Word16+  where+    width _ = 16++instance Unit Word32+  where+    width _ = 32++data (Unit w) => BitVector w+     = BitVector+     { segments         :: [Segment w]+     }++data (Unit w) => Segment w+    = Segment+    { numUnits  :: Data Length+    , elements  :: Data Index -> Data w+    }++-- * Feldspar integration of BitVector++type instance Elem      (BitVector w) = Data Bool+type instance CollIndex (BitVector w) = Data Index++instance (Unit a) => Syntactic (BitVector a) FeldDomainAll+  where+    type Internal (BitVector a) = [a]+    desugar = desugar . freezeBitVector+    sugar   = unfreezeBitVector . sugar++instance (Unit a) => Syntax (BitVector a)++-- * Operations++length :: forall w . (Unit w) => BitVector w -> Data Length+length bv = Prelude.foldl (+) 0 $ Prelude.map segmentLen $ segments bv+  where+    segmentLen s = numUnits s * w+    w = value $ width (T :: T w)++numOfUnits :: (Unit w) => BitVector w -> Data Length+numOfUnits bv = Prelude.foldl (+) 0 $ Prelude.map numUnits $ segments bv++freezeBitVector :: forall w . (Unit w) => BitVector w -> Data [w]+freezeBitVector bv = freezeSegments $ segments bv+  where+    freezeSegments segs = case segs of+        []      -> value []+        (s:ss)  -> parallel (numUnits s) (elements s) `append` freezeSegments ss++unfreezeBitVector :: forall w . (Unit w) => Data [w] -> BitVector w+unfreezeBitVector ws = BitVector [Segment (getLength ws) (ws!)]++{- TODO+-- | Variant of `unfreezeBitVector` with additional static size information.+unfreezeBitVector' :: forall w . (Unit w) => Length -> Data [w] -> BitVector w+unfreezeBitVector' len arr = unfreezeBitVector $ cap (r :> elemSize) arr+  where+    (_ :> elemSize) = dataSize arr+    singleton :: a -> Range a+    singleton x = Range x x+    r = (singleton (fromIntegral len),singleton (fromIntegral len)+        ,singleton (fromIntegral len))+-}++-- | Transforms a bool vector to a bitvector.+-- Length of the vector has to be divisible by the wordlength,+-- otherwise booleans at the end will be dropped.+fromVector :: forall w . (Unit w, Size w ~ Range w) => Vec.Vector (Data Bool) -> BitVector w+fromVector v = BitVector+    { segments = [Segment wl (loop w)]+        -- TODO: Should Vector segments be transformed to BitVector segments+        -- for the sake of efficiency?+    }+  where+    w = value $ width (T :: T w)+    wl = Vec.length v `div` w+    loop n ix = forLoop n 0 $ \i st ->+        st `shiftLU` 1 .|. (v ! (w * ix + i) ? (1,0))++toVector :: forall w . (Unit w, Size w ~ Range w) => BitVector w -> Vec.Vector (Data Bool)+toVector bv = Vec.indexed (length bv) (bv!)++instance (Unit w, Size w ~ Range w) => Indexed (BitVector w)+  where+    bv ! i = help 0 (segments bv)+      where+        help accum [] = false+            -- XXX Should be an error here...+        help accum [s] = bit s accum i+        help accum (s:ss) = i < accum + numUnits s * w ?+            ( bit s accum i+            , help (accum + numUnits s * w) ss+            )+        w = value $ width (T :: T w)+        bit s accum i = testBit (elements s ((i - accum) `div` w)) (w - 1 - ((i - accum) `mod` w))++fromBits :: forall w . (Unit w) => [Bool] -> BitVector w+fromBits bs = unfreezeBitVector $ value xs+  where+    xs = [ conv (T :: T w) $ Prelude.take w (Prelude.drop (i*w) bs) | i <- [0..Prelude.length bs `Prelude.div` w Prelude.- 1]]+    w = fromInteger $ toInteger $ width (T :: T w)+    conv :: (Unit w) => T w -> [Bool] -> w+    conv _ = Prelude.foldl (\n b -> if b then n Prelude.* 2 Prelude.+ 1 else n Prelude.* 2) 0++fromUnits :: (Unit w) => [w] -> BitVector w+fromUnits = unfreezeBitVector . value++replUnit :: (Unit w) => Data Length -> w -> BitVector w+replUnit n u = BitVector [Segment n $ const $ value u]++indexed :: (Unit w, Size w ~ Range w) =>+    Data Length -> (Data Index -> Data Bool) -> BitVector w+indexed l ixf = fromVector $ Vec.indexed l ixf++map :: (Unit w, Size w ~ Range w) =>+    (Data Bool -> Data Bool) -> BitVector w -> BitVector w+map f bv = boolFun1 f result+  where+    result f' = BitVector $+        Prelude.map (\s -> s{elements = f' . elements s}) $ segments bv++takeUnits :: forall w . (Unit w) =>+    Data Length -> BitVector w -> BitVector w+takeUnits len bv = help len [] $ segments bv+  where+    help n acc [] = BitVector acc+    help n acc (s:ss) = n < numUnits s ?+        ( BitVector (acc Prelude.++ [s{numUnits = n}])+        , help (n - numUnits s) (acc Prelude.++ [s]) ss+        )++dropUnits :: forall w . (Unit w) =>+    Data Length -> BitVector w -> BitVector w+dropUnits len bv = help len $ segments bv+  where+    help n [] = BitVector []+    help n (s:ss) = n < numUnits s ?+        ( BitVector $ s':ss+        , help (n - numUnits s) ss+        )+      where+        s' = Segment+            { numUnits = numUnits s - n+            , elements = \i -> elements s (i + n)+            }++(++) :: forall w . (Unit w) =>+    BitVector w -> BitVector w -> BitVector w+(BitVector ss) ++ (BitVector zs) = BitVector $ ss Prelude.++ zs++drop :: forall w . (Unit w, Size w ~ Range w) =>+    Data Length -> Data w -> BitVector w -> BitVector w+drop len end bv = dropSegments len $ segments bv+  where+    w = value $ width (T :: T w)+    dropSegments n [] = BitVector []+    dropSegments n (s:ss) = n < sLen ?+        ( dropUnits n s ss+        , dropSegments (n - sLen) ss+        )+      where+        sLen = numUnits s * w+    dropUnits n s ss = dropBits bitsToDrop (s':ss)+      where+        s' = Segment+            { numUnits = numUnits s - wordsToDrop+            , elements = \i -> elements s (i + wordsToDrop)+            }+        wordsToDrop = n `div` w+        bitsToDrop = n `mod` w+    dropBits n [] = BitVector []+    dropBits n (s:ss) = n > 0 ?+        ( BitVector $ s' : segments bv'+        , BitVector (s:ss)+        )+      where+        s' = Segment+            { numUnits = numUnits s - 1+            , elements = \i ->+                (elements s i `shiftLU` n)+                .|.+                (elements s (i+1) `shiftRU` (w-n))+            }+        bv' = addBits (w - n) (elements s (numUnits s - 1) `shiftLU` n) ss+    addBits n bs [] = BitVector [Segment 1 $ const $ bs .|. (end `shiftRU` n)]+    addBits n bs (s:ss) = numUnits s > 0 ?+        ( BitVector $ s':(segments bv')+        , addBits n bs ss+        )+      where+        s' = Segment+            { numUnits = 1+            , elements = const $ bs .|. (elements s 0 `shiftRU` n)+            }+        bv' = dropBits (w - n) (s:ss)++fold :: forall w a. (Syntax a, Unit w, Size w ~ Range w) =>+    (a -> Data Bool -> a) -> a -> BitVector w -> a+fold f ini (BitVector []) = ini+fold f ini (BitVector (s:ss)) = fold f (forLoop (numUnits s) ini f') $ BitVector ss+  where+    f' :: Data Index -> a -> a+    f' i st = Prelude.snd $ forLoop w (elements s i, st) f''+    f'' :: Data Index -> (Data w,a) -> (Data w,a)+    f'' _ (unit,st) = (unit `shiftLU` 1, f st $ testBit unit $ w-1)+    w = value $ width (T :: T w)++zipWith :: forall w. (Unit w, Size w ~ Range w) =>+    (Data Bool -> Data Bool -> Data Bool)+    -> BitVector w+    -> BitVector w+    -> BitVector w+zipWith f bv bw = boolFun2 f result+  where+    result f' = Prelude.foldl (++) (BitVector [])+        [ zipSegments f' s z | s <- segIdxs bv, z <- segIdxs bw ]+    segIdxs bvec = Prelude.zip (segments bvec) $+        Prelude.map (\ss -> Prelude.foldl (+) 0 $ Prelude.map numUnits ss) $+        inits $ segments bvec+    zipSegments f' (s,sStart) (z,zStart) = BitVector+        [ Segment+            { numUnits = end - start+            , elements = \i ->+                f' (elements s (i+sOffset)) (elements z (i+zOffset))+            }+        ]+      where+        sEnd = sStart + numUnits s+        zEnd = zStart + numUnits z+        start = max sStart zStart+        end = min sEnd zEnd+        sOffset = start - sStart+        zOffset = start - zStart++head :: (Unit w, Size w ~ Range w) => BitVector w -> Data Bool+head = (!0)++tail :: forall w. (Unit w, Size w ~ Range w) => Data Bool -> BitVector w -> BitVector w+tail b bv = drop 1 (b2i b `shiftLU` (w - 1)) bv+  where+    w = value $ width (T :: T w)++-- * Boolean functions extended to words++boolFun1 :: (Syntax t, Unit w, Size w ~ Range w) =>+    (Data Bool -> Data Bool)+    -> ((Data w -> Data w) -> t)+    -> t+boolFun1 f c = f true ?+        ( f false ? (c (const $ complement 0), c id)+        , f false ? (c complement, c (const 0))+        )++boolFun2 :: (Syntax t, Unit w, Size w ~ Range w) =>+    (Data Bool -> Data Bool -> Data Bool)+    -> ((Data w -> Data w -> Data w) -> t)+    -> t+boolFun2 f c =+    f true true ?+    ( f true false ?+      ( f false true ?+        ( f false false ?+          ( c $ \a b -> complement 0+          , c $ \a b -> a .|. b+          )+        , f false false ?+          ( c $ \a b -> a .|. complement b+          , c $ \a _ -> a+          )+        )+      , f false true ?+        ( f false false ?+          ( c $ \a b -> complement a .|. b+          , c $ \a b -> b+          )+        , f false false ?+          ( c $ \a b -> complement (a `xor` b)+          , c $ \a b -> a .&. b+          )+        )+      )+    , f true false ?+      ( f false true ?+        ( f false false ?+          ( c $ \a b -> complement (a .&. b)+          , c $ \a b -> a `xor` b+          )+        , f false false ?+          ( c $ \a b -> complement b+          , c $ \a b -> a .&. complement b+          )+        )+      , f false true ?+        ( f false false ?+          ( c $ \a b -> complement a+          , c $ \a b -> complement a .&. b+          )+        , f false false ?+          ( c $ \a b -> complement (a .|. b)+          , c $ \a b -> 0+          )+        )+      )+    )++-- * Wrapping for bitvectors++instance (Unit w) => Wrap (BitVector w) (Data [w]) where+    wrap v = freezeBitVector v++instance (Wrap t u, Unit w, TL.Nat s) => Wrap (BitVector w -> t) (Data' s [w] -> u) where+    wrap f = \(Data' d) -> wrap $ f $ unfreezeBitVector $ setLength s' d where+        s' = fromInteger $ toInteger $ TL.toInt (undefined :: s)
Feldspar/Core.hs view
@@ -1,3 +1,31 @@+--+-- Copyright (c) 2009-2011, 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 Feldspar core language  module Feldspar.Core@@ -7,76 +35,25 @@     , 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+    , BoundedInt+    , module Feldspar.Core.Types -    -- * Wrapping-    , module Feldspar.Core.Wrap+    -- * Frontend+    , module Feldspar.Core.Frontend+    , module Feldspar.Core.Collection     ) where   -import Prelude () import Data.Complex import Data.Int hiding (Int) import Data.Word -import Feldspar.DSL.Network-import Feldspar.Set+import Feldspar.Lattice import Feldspar.Range import Feldspar.Core.Types-import Feldspar.Core.Representation-import Feldspar.Core.Constructs-import Feldspar.Core.Functions-import Feldspar.Core.Wrap+import Feldspar.Core.Frontend+import Feldspar.Core.Collection
+ Feldspar/Core/Collection.hs view
@@ -0,0 +1,88 @@+--+-- Copyright (c) 2009-2011, ERICSSON AB+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are met:+-- +--     * Redistributions of source code must retain the above copyright notice, +--       this list of conditions and the following disclaimer.+--     * Redistributions in binary form must reproduce the above copyright+--       notice, this list of conditions and the following disclaimer in the+--       documentation and/or other materials provided with the distribution.+--     * Neither the name of the ERICSSON AB nor the names of its contributors+--       may be used to endorse or promote products derived from this software+--       without specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+--++-- | General interfaces to collections of data++module Feldspar.Core.Collection where++++import Feldspar.Core.Types+import Feldspar.Core.Frontend++++-- | Collection element type+type family Elem a++-- | Collection index type+type family CollIndex a++-- | Collection size type+type family CollSize a++type instance Elem      (Data [a]) = Data a+type instance CollIndex (Data [a]) = Data Index+type instance CollSize  (Data [a]) = Data Length++-- | Data structures that support indexing+class Indexed a+  where+    (!) :: a -> CollIndex a -> Elem a++infixl 9 !++instance Type a => Indexed (Data [a])+  where+    (!) = getIx++-- | Sized data structures+class Sized a+  where+    collSize    :: a -> CollSize a+    setCollSize :: CollSize a -> a -> a++instance Type a => Sized (Data [a])+  where+    collSize    = getLength+    setCollSize = setLength++class CollMap a b+  where+    collMap :: (Elem a -> Elem b) -> a -> b++instance (Type a, Type b) => CollMap (Data [a]) (Data [b])+  where+    collMap f arr = parallel (getLength arr) (f . getIx arr)++-- | Array patch+(|>) :: (Sized a, CollMap a a) =>+    Patch (CollSize a) (CollSize a) -> Patch (Elem a) (Elem a) -> Patch a a+(sizePatch |> elemPatch) a =+    collMap elemPatch $ setCollSize (sizePatch (collSize a)) a+
Feldspar/Core/Constructs.hs view
@@ -1,245 +1,194 @@+--+-- Copyright (c) 2009-2011, 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 #-}+{-# LANGUAGE UndecidableInstances #-}+ 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+import Language.Syntactic+import Language.Syntactic.Constructs.Binding.HigherOrder +import Feldspar.Core.Types+import Feldspar.Core.Interpretation+import Feldspar.Core.Constructs.Array+import Feldspar.Core.Constructs.Binding+import Feldspar.Core.Constructs.Bits+import Feldspar.Core.Constructs.Complex+import Feldspar.Core.Constructs.Condition+import Feldspar.Core.Constructs.ConditionM+import Feldspar.Core.Constructs.Conversion+import Feldspar.Core.Constructs.Eq+import Feldspar.Core.Constructs.Error+import Feldspar.Core.Constructs.FFI+import Feldspar.Core.Constructs.Floating+import Feldspar.Core.Constructs.Fractional+import Feldspar.Core.Constructs.Integral+import Feldspar.Core.Constructs.Literal+import Feldspar.Core.Constructs.Logic+import Feldspar.Core.Constructs.Loop+import Feldspar.Core.Constructs.Mutable+import Feldspar.Core.Constructs.MutableArray+import Feldspar.Core.Constructs.MutableReference+import Feldspar.Core.Constructs.MutableToPure+import Feldspar.Core.Constructs.Par+import Feldspar.Core.Constructs.Num+import Feldspar.Core.Constructs.Ord+import Feldspar.Core.Constructs.Save+import Feldspar.Core.Constructs.SizeProp+import Feldspar.Core.Constructs.SourceInfo+import Feldspar.Core.Constructs.Trace+import Feldspar.Core.Constructs.Tuple  -value' :: Type a => Size a -> a -> Data a-value' sz a = nodeData (sz \/ sizeOf a) (Inject $ Node $ Literal a)+--------------------------------------------------------------------------------+-- * Domain+-------------------------------------------------------------------------------- --- | A program that computes a constant value-value :: Type a => a -> Data a-value = value' empty+type FeldSymbols+    =   Decor SourceInfo1 (Identity TypeCtx)+    :+: Condition TypeCtx+    :+: ConditionM Mut+    :+: FFI+    :+: Let TypeCtx TypeCtx+    :+: Literal TypeCtx+    :+: Select TypeCtx+    :+: Tuple TypeCtx+    :+: Array+    :+: BITS+    :+: COMPLEX+    :+: Conversion+    :+: EQ+    :+: Error+    :+: FLOATING+    :+: FRACTIONAL+    :+: INTEGRAL+    :+: Logic+    :+: Loop+    :+: LoopM Mut+    :+: MONAD Mut+    :+: Mutable+    :+: MutableArray+    :+: MutableReference+    :+: MutableToPure+    :+: MONAD Par+    :+: NUM+    :+: ORD+    :+: ParFeature+    :+: PropSize+    :+: Save+    :+: Trace -unit :: Data ()-unit = value ()+newtype FeldDomain a = FeldDomain (FeldSymbols a) -true :: Data Bool-true = value True+deriving instance (sym :<: FeldSymbols) => sym :<: FeldDomain -false :: Data Bool-false = value False+deriving instance WitnessCons FeldDomain+deriving instance MaybeWitnessSat TypeCtx FeldDomain --- | 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'+deriving instance ExprEq   FeldDomain+deriving instance Render   FeldDomain+deriving instance ToTree   FeldDomain+deriving instance Eval     FeldDomain+deriving instance EvalBind FeldDomain -cap :: Type a => Size a -> Data a -> Data a-cap sz a = resizeData (sz /\ dataSize a) a+instance VarEqEnv env => AlphaEq+    FeldDomain+    FeldDomain+    (Lambda TypeCtx :+: (Variable TypeCtx :+: FeldDomain))+    env+  where+    alphaEqSym (FeldDomain a) aArgs (FeldDomain b) bArgs =+        alphaEqSym a aArgs b bArgs -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+instance AlphaEq+    FeldDomain+    FeldDomain+    (Decor Info (Lambda TypeCtx :+: (Variable TypeCtx :+: FeldDomain)))+    [(VarId, VarId)]   where-    sz   = sizeProp (edgeInfo a)-    func = nodeData sz $ Inject (Node (Function fun f)) :$: toEdge a+    alphaEqSym (FeldDomain a) aArgs (FeldDomain b) bArgs =+        alphaEqSym a aArgs b bArgs -function1 :: (Type a, Type b)-    => String-    -> (Size a -> Size b)-    -> (a      -> b)-    -> (Data a -> Data b)-function1 fun sizeProp = function True fun (sizeProp . edgeSize)+deriving instance Sharable FeldDomain -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)+instance Optimize FeldDomain (Lambda TypeCtx :+: (Variable TypeCtx :+: FeldDomain))   where-    sizeProp' (i1,i2) = sizeProp (edgeSize i1) (edgeSize i2)+    optimizeFeat       (FeldDomain a) = optimizeFeat       a+    constructFeatOpt   (FeldDomain a) = constructFeatOpt   a+    constructFeatUnOpt (FeldDomain a) = constructFeatUnOpt a -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+type FeldDomainAll = HODomain TypeCtx FeldDomain -(?) :: 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.+--------------------------------------------------------------------------------+-- * Front end+-------------------------------------------------------------------------------- --- | Parallel array with continuation-parallel' :: Type a =>-    Data Length -> (Data Index -> Data a) -> Data [a] -> Data [a]-parallel' = parallel'' True+newtype Data a = Data { unData :: ASTF FeldDomainAll a } --- | 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 [])+deriving instance Typeable1 Data --- | 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)+instance Type a => Syntactic (Data a) FeldDomainAll   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+    type Internal (Data a) = a+    desugar = unData+    sugar   = Data -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+-- | Specialization of the 'Syntactic' class for the Feldspar domain+class+    ( Syntactic a FeldDomainAll+    , SyntacticN a (ASTF FeldDomainAll (Internal a))+    , Type (Internal a)+    ) =>+      Syntax a+  -- It would be possible to let 'Syntax' be an alias instead of giving separate+  -- instances for all types. However, this leads to horrible error messages.+  -- For example, if 'Syntax' is an alias, the following expression gives a huge+  -- type error:+  --+  -- > eval (forLoop 10 0 (const (+id)))+  --+  -- The type error is not very readable now either, but at least it fits on the+  -- screen. --- | 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+instance Type a => Syntax (Data a) -noinline2 :: (Syntactic a, Syntactic b, Syntactic c) =>-    String -> (a -> b -> c) -> (a -> b -> c)-noinline2 name = curry . noinline name . uncurry+instance Type a => Eq (Data a)+  where+    Data a == Data b = alphaEq (reify a) (reify b) -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+instance Type a => Show (Data a)   where-    szl                   = dataSize l-    szArrLen :> szArrElem = dataSize arr-    szLen                 = rangeMin szl szArrLen-  -- The only purpose of this function is to enable optimization of 'parallel'.+    show (Data a) = render $ reify a
+ Feldspar/Core/Constructs/Array.hs view
@@ -0,0 +1,252 @@+--+-- Copyright (c) 2009-2011, 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 #-}++module Feldspar.Core.Constructs.Array+where++import Control.Monad+import Data.List+import Data.Map (notMember)++import Language.Syntactic+import Language.Syntactic.Interpretation.Semantics+import Language.Syntactic.Constructs.Binding+import Language.Syntactic.Constructs.Literal++import Feldspar.Range+import Feldspar.Lattice+import Feldspar.Core.Types+import Feldspar.Core.Interpretation+import Feldspar.Core.Constructs.Binding+import Feldspar.Core.Constructs.Num+import Feldspar.Core.Constructs.Ord++data Array a+  where+    Parallel   :: Type a => Array (Length :-> (Index -> a) :-> Full [a])+    Sequential :: (Type a, Type st) =>+                  Array (Length :-> st :-> (Index -> st -> (a,st)) :-> Full [a])+    Append     :: Type a => Array ([a] :-> [a] :-> Full [a])+    GetIx      :: Type a => Array ([a] :-> Index :-> Full a)+    SetIx      :: Type a => Array ([a] :-> Index :-> a :-> Full [a])+    GetLength  :: Type a => Array ([a] :-> Full Length)+    SetLength  :: Type a => Array (Length :-> [a] :-> Full [a])++instance WitnessCons Array+  where+    witnessCons Parallel   = ConsWit+    witnessCons Sequential = ConsWit+    witnessCons Append     = ConsWit+    witnessCons GetIx      = ConsWit+    witnessCons SetIx      = ConsWit+    witnessCons GetLength  = ConsWit+    witnessCons SetLength  = ConsWit++instance WitnessSat Array+  where+    type SatContext Array = TypeCtx+    witnessSat Parallel   = SatWit+    witnessSat Sequential = SatWit+    witnessSat Append     = SatWit+    witnessSat GetIx      = SatWit+    witnessSat SetIx      = SatWit+    witnessSat GetLength  = SatWit+    witnessSat SetLength  = SatWit++instance MaybeWitnessSat TypeCtx Array+  where+    maybeWitnessSat = maybeWitnessSatDefault++instance Semantic Array+  where+    semantics Append    = Sem "(++)"      (++)+    semantics GetIx     = Sem "(!)"       genericIndex+    semantics GetLength = Sem "getLength" genericLength+    semantics SetLength = Sem "setLength"+        (\n as -> genericTake n (as ++ repeat err))+      where+        err = error "reading uninitialized array element"++    semantics Parallel = Sem "parallel"+        (\len ixf -> genericTake len $ map ixf [0..])++    semantics Sequential = Sem "sequential"+        (\len i step -> genericTake len $+                        snd $ mapAccumL (\a ix -> swap (step ix a)) i [0..])+      where swap (a,b) = (b,a)++    semantics SetIx = Sem "setIx" evalSetIx+      where+        evalSetIx as i v+            | i < len   = genericTake i as ++ [v] ++ genericDrop (i+1) as+            | otherwise = error $ unwords+                [ "setIx: assigning index"+                , show i+                , "past the end of an array of length"+                , show len+                ]+          where+            len = genericLength as++instance ExprEq   Array where exprEq = exprEqSem; exprHash = exprHashSem+instance Render   Array where renderPart = renderPartSem+instance ToTree   Array+instance Eval     Array where evaluate = evaluateSem+instance EvalBind Array where evalBindSym = evalBindSymDefault++instance AlphaEq dom dom dom env => AlphaEq Array Array dom env+  where+    alphaEqSym = alphaEqSymDefault++instance Sharable Array+  where+    sharable GetIx = False+    sharable _     = True++instance SizeProp Array+  where+    sizeProp Parallel (WrapFull len :* WrapFull ixf :* Nil) =+        infoSize len :> infoSize ixf+    sizeProp Sequential (WrapFull len :* init :* WrapFull step :* Nil) =+        infoSize len :> fst (infoSize step)+    sizeProp Append (WrapFull arra :* WrapFull arrb :* Nil) =+        (alen + blen) :> (aelem \/ belem)+      where+        alen :> aelem = infoSize arra+        blen :> belem = infoSize arrb+    sizeProp GetIx (WrapFull arr :* ix :* Nil) = elem+      where+        _ :> elem = infoSize arr+    sizeProp SetIx (WrapFull arr :* ix :* WrapFull e :* Nil) =+        len :> (elem \/ infoSize e)+      where+        len :> elem = infoSize arr+    sizeProp GetLength (WrapFull arr :* Nil) = len+      where+        len :> _ = infoSize arr+    sizeProp SetLength (WrapFull len :* WrapFull arr :* Nil) =+        infoSize len :> elem+      where+        _ :> elem = infoSize arr++++instance+    ( Array :<: dom+    , NUM :<: dom+    , ORD :<: dom+    , Optimize dom dom+    ) =>+      Optimize Array dom+  where+    optimizeFeat Parallel (len :* ixf :* Nil) = do+        len' <- optimizeM len+        let szI     = infoSize (getInfo len')+            ixRange = rangeByRange 0 (szI-1)+        ixf' <- optimizeFunction optimizeM (mkInfo ixRange) ixf+        constructFeat Parallel (len' :* ixf' :* Nil)++    optimizeFeat Sequential (len :* init :* step :* Nil) = do+        len'  <- optimizeM len+        init' <- optimizeM init+        let szI     = infoSize (getInfo len')+            ixRange = rangeByRange 0 (szI-1)+        step' <- optimizeFunction+            optimizeM  -- TODO (optimizeFunctionFix optimizeM (mkInfo universal))+            (mkInfo ixRange)+            step+        constructFeat Sequential (len' :* init' :* step' :* Nil)+      -- TODO Should use fixed-point iteration, but `optimizeFunctionFix` only+      --      works for functions of type `a -> a`.++    optimizeFeat a args = optimizeFeatDefault a args++    constructFeatOpt Parallel (len :* ixf :* Nil)+        | Just 0 <- viewLiteral len+        = return $ literalDecor []+      -- TODO Optimize when length is one. This requires a way to create an+      --      uninitialized array of length one, and setting the first element.+      --      Use `betaReduce` to apply `ixf` to the literal 0.++    constructFeatOpt Parallel (len :* (lam :$ (gix :$ arr2 :$ ix)) :* Nil)+        | Just (_,Lambda v1)   <- prjDecorCtx typeCtx lam+        , Just (_,GetIx)       <- prjDecor gix+        , Just (_,Variable v2) <- prjDecorCtx typeCtx ix+        , v1 == v2+        , v1 `notMember` infoVars (getInfo arr2)+        = constructFeat SetLength (len :* arr2 :* Nil)++    constructFeatOpt Sequential (len :* init :* ixf :* Nil)+        | Just 0 <- viewLiteral len+        = return $ literalDecor []+      -- TODO Optimize when length is one. This requires a way to create an+      --      uninitialized array of length one, and setting the first element.+      --      Use `betaReduce` to apply the step function.++    constructFeatOpt Append (a :* b :* Nil)+        | Just [] <- viewLiteral a = return b+        | Just [] <- viewLiteral b = return a++    constructFeatOpt GetIx ((op :$ _ :$ ixf) :* ix :* Nil)+        | Just (_, Parallel) <- prjDecor op+        = optimizeM $ betaReduce typeCtx (stripDecor ix) (stripDecor ixf)+          -- TODO should not need to drop the decorations++    constructFeatOpt GetIx ((op :$ len :$ arr) :* ix :* Nil)+        | Just (_, SetLength) <- prjDecor op+        = constructFeat GetIx (arr :* ix :* Nil)++    constructFeatOpt GetLength (arr :* Nil)+        | Just as <- viewLiteral arr = return $ literalDecor $ genericLength as++    constructFeatOpt GetLength (((prjDecor -> Just (_,op)) :$ a :$ _ :$ _) :* Nil)+        | Sequential <- op = return a+        | SetIx      <- op = constructFeat GetLength (a :* Nil)++    constructFeatOpt GetLength (((prjDecor -> Just (_,op)) :$ a :$ b) :* Nil)+        | Append <- op = do+            aLen <- constructFeat GetLength (a :* Nil)+            bLen <- constructFeat GetLength (b :* Nil)+            constructFeatOpt Add (aLen :* bLen :* Nil)+        | Parallel  <- op = return a+        | SetLength <- op = return a++    constructFeatOpt SetLength (len :* arr :* Nil)+        | Just 0 <- viewLiteral len = return $ literalDecor []++    constructFeatOpt SetLength ((getLength :$ arr') :* arr :* Nil)+        | Just (_,GetLength) <- prjDecor getLength+        , alphaEq arr arr'+        = return arr++    constructFeatOpt a args = constructFeatUnOpt a args++    constructFeatUnOpt = constructFeatUnOptDefault+
+ Feldspar/Core/Constructs/Binding.hs view
@@ -0,0 +1,190 @@+--+-- Copyright (c) 2009-2011, 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 #-}++-- | Interpretation of binding constructs++module Feldspar.Core.Constructs.Binding+    ( module Language.Syntactic.Constructs.Binding+    , optimizeLambda+    , optimizeFunction+    , optimizeFunctionFix+    ) where++import Control.Monad.Reader+import Data.Maybe+import Data.Map+import Data.Typeable (Typeable, gcast)++import Data.Lens.Common+import Data.Proxy++import Language.Syntactic+import Language.Syntactic.Constructs.Binding++import Feldspar.Lattice+import Feldspar.Core.Types+import Feldspar.Core.Interpretation++++instance Sharable (Variable TypeCtx)+  -- Will not be shared anyway, because it's a terminal++instance Sharable (Lambda TypeCtx)+  where+    sharable _ = False++instance Sharable (Let TypeCtx TypeCtx)++++optimizeLambda :: (Lambda TypeCtx :<: dom, Optimize dom dom)+    => (ASTF dom b -> Opt (ASTF (Decor Info dom) b))  -- ^ Optimization of the body+    -> Info a+    -> Lambda TypeCtx (b :-> Full (a -> b))+    -> Args (AST dom) (b :-> Full (a -> b))+    -> Opt (ASTF (Decor Info dom) (a -> b))+optimizeLambda opt info lam@(Lambda v) (body :* Nil) = do+    body' <- localVar v info $ opt body+    constructFeatUnOpt lam (body' :* Nil)++-- | Assumes that the expression is a 'Lambda'+optimizeFunction :: (Lambda TypeCtx :<: dom, Optimize dom dom)+    => (ASTF dom b -> Opt (ASTF (Decor Info dom) b))  -- ^ Optimization of the body+    -> Info a+    -> (ASTF dom (a -> b) -> Opt (ASTF (Decor Info dom) (a -> b)))+optimizeFunction opt info (lam :$ body)+    | Just (Lambda v) <- prjCtx typeCtx lam+    = optimizeLambda opt info (Lambda v) (body :* Nil)++optimizeFunBody :: (Lambda TypeCtx :<: dom, Optimize dom dom, Typeable a)+    => (ASTF dom a -> Opt (ASTF (Decor Info dom) a))  -- ^ Optimization of the body+    -> Env                                            -- ^ Environment (instead of using 'Opt')+    -> VarId                                          -- ^ Bound variable+    -> ASTF dom a                                     -- ^ Body+    -> Info a                                         -- ^ 'Info' of bound variable+    -> ASTF (Decor Info dom) a+optimizeFunBody opt env v body info =+    flip runReader env $ localVar v info $ opt body++-- | Assumes that the expression is a 'Lambda'+optimizeFunctionFix+    :: forall dom a+    .  (Lambda TypeCtx :<: dom, Optimize dom dom, Type a)+    => (ASTF dom a -> Opt (ASTF (Decor Info dom) a))  -- ^ Optimization of the body+    -> Info a+    -> (ASTF dom (a -> a) -> Opt (ASTF (Decor Info dom) (a -> a)))+optimizeFunctionFix opt info (lam :$ body)+    | Just (Lambda v) <- prjCtx typeCtx lam+    = do+        env <- ask++        let aLens :: Lens (Info a) (Size a)+            aLens = lens infoSize (\sz info -> info {infoSize = sz})++        let bLens :: Lens (ASTF (Decor Info dom) a) (Size a)+            bLens = lens (infoSize . getInfo)+                (\sz a -> updateDecor (\info -> info {infoSize = sz}) a)++        let body' = fst $ boundedLensedFixedPoint 1 aLens bLens+                (optimizeFunBody opt env v body)+                info+              -- Using 1 as bound is motivated by the fact that a higher number+              -- leads to exponential blowup when there are many nested+              -- iterations. Since it is probably uncommon to have very deeply+              -- nested loops, it might be fine to increase the bound. However+              -- it is not clear that we gain anything by doing so, other than+              -- in very special cases.++        constructFeatUnOpt (Lambda v `withContext` typeCtx) (body' :* Nil)++++instance (Variable TypeCtx :<: dom, Optimize dom dom) =>+    Optimize (Variable TypeCtx) dom+  where+    constructFeatUnOpt var@(Variable v) Nil+        | TypeWit <- fromSatWit $ witnessSat var+        = reader $ \env -> case Prelude.lookup v (varEnv env) of+            Nothing -> error $+                "optimizeFeat: can't get size of free variable: v" ++ show v+            Just (SomeInfo info) ->+                let info' = (fromJust $ gcast info) {infoVars = singleton v 1}+                in  injDecorCtx typeCtx info' (Variable v)++instance (Lambda TypeCtx :<: dom, Optimize dom dom) =>+    Optimize (Lambda TypeCtx) dom+  where+    -- | Assigns a 'universal' size to the bound variable. This only makes sense+    -- for top-level lambdas. For other uses, use 'optimizeLambda' instead.+    optimizeFeat lam@(Lambda v)+        | TypeWit <- witnessByProxy typeCtx (argProxy lam)+        = optimizeLambda optimizeM (mkInfo universal) (Lambda v)++    constructFeatUnOpt lam@(Lambda v) (body :* Nil)+        | TypeWit <- witnessByProxy typeCtx (argProxy lam)+        , Info t sz vars _ <- getInfo body+        = do+            src <- asks sourceEnv+            let info = Info (FunType typeRep t) sz (delete v vars) src+            return $ injDecorCtx typeCtx info (Lambda v) :$ body++argProxy :: Lambda TypeCtx (b :-> Full (a -> b)) -> Proxy a+argProxy (Lambda _) = Proxy++instance SizeProp (Let TypeCtx TypeCtx)+  where+    sizeProp Let (_ :* WrapFull f :* Nil) = infoSize f++instance+    ( Let TypeCtx TypeCtx :<: dom+    , Lambda TypeCtx :<: dom+    , Variable TypeCtx :<: dom+    , Optimize dom dom+    ) =>+      Optimize (Let TypeCtx TypeCtx) dom+  where+    optimizeFeat lt@Let (a :* f :* Nil) = do+        a' <- optimizeM a+        f' <- optimizeFunction optimizeM (getInfo a') f+        case getInfo f' of+          Info{} -> constructFeat lt (a' :* f' :* Nil)+            -- TODO Why is this pattern match needed?++    constructFeatOpt Let (a :* (lam :$ var) :* Nil)+        | Just (_,Lambda v1)   <- prjDecorCtx typeCtx lam+        , Just (_,Variable v2) <- prjDecorCtx typeCtx var+        , v1 == v2+        = return $ fromJust $ gcast a++    constructFeatOpt a args = constructFeatUnOpt a args++    constructFeatUnOpt = constructFeatUnOptDefault+
+ Feldspar/Core/Constructs/Bits.hs view
@@ -0,0 +1,270 @@+--+-- Copyright (c) 2009-2011, 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 #-}++module Feldspar.Core.Constructs.Bits+    ( BITS (..)+    ) where++++import Data.Hash++import Language.Syntactic+import Language.Syntactic.Interpretation.Semantics+import Language.Syntactic.Constructs.Binding++import Feldspar.Range+import Feldspar.Lattice+import Feldspar.Core.Types+import Feldspar.Core.Interpretation++import Data.Bits++data BITS a+  where+    BAnd          :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> a :-> Full a)+    BOr           :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> a :-> Full a)+    BXor          :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> a :-> Full a)+    Complement    :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :->       Full a)++    Bit           :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (Index :->       Full a)+    SetBit        :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> Index :-> Full a)+    ClearBit      :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> Index :-> Full a)+    ComplementBit :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> Index :-> Full a)+    TestBit       :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> Index :-> Full Bool)++    ShiftLU       :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> Index :-> Full a)+    ShiftRU       :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> Index :-> Full a)+    ShiftL        :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> IntN  :-> Full a)+    ShiftR        :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> IntN  :-> Full a)+    RotateLU      :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> Index :-> Full a)+    RotateRU      :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> Index :-> Full a)+    RotateL       :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> IntN  :-> Full a)+    RotateR       :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> IntN  :-> Full a)+    ReverseBits   :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :->           Full a)++    BitScan       :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> Full Index)+    BitCount      :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> Full Index)++    BitSize       :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> Full Index)+    IsSigned      :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> Full Bool)+++instance WitnessCons BITS+  where+    witnessCons BAnd          = ConsWit+    witnessCons BOr           = ConsWit+    witnessCons BXor          = ConsWit+    witnessCons Complement    = ConsWit++    witnessCons Bit           = ConsWit+    witnessCons SetBit        = ConsWit+    witnessCons ClearBit      = ConsWit+    witnessCons ComplementBit = ConsWit+    witnessCons TestBit       = ConsWit++    witnessCons ShiftLU       = ConsWit+    witnessCons ShiftRU       = ConsWit+    witnessCons ShiftL        = ConsWit+    witnessCons ShiftR        = ConsWit+    witnessCons RotateLU      = ConsWit+    witnessCons RotateRU      = ConsWit+    witnessCons RotateL       = ConsWit+    witnessCons RotateR       = ConsWit+    witnessCons ReverseBits   = ConsWit++    witnessCons BitScan       = ConsWit+    witnessCons BitCount      = ConsWit++    witnessCons BitSize       = ConsWit+    witnessCons IsSigned      = ConsWit+++instance WitnessSat BITS+  where+    type SatContext BITS = TypeCtx+    witnessSat BAnd          = SatWit+    witnessSat BOr           = SatWit+    witnessSat BXor          = SatWit+    witnessSat Complement    = SatWit++    witnessSat Bit           = SatWit+    witnessSat SetBit        = SatWit+    witnessSat ClearBit      = SatWit+    witnessSat ComplementBit = SatWit+    witnessSat TestBit       = SatWit++    witnessSat ShiftLU       = SatWit+    witnessSat ShiftRU       = SatWit+    witnessSat ShiftL        = SatWit+    witnessSat ShiftR        = SatWit+    witnessSat RotateLU      = SatWit+    witnessSat RotateRU      = SatWit+    witnessSat RotateL       = SatWit+    witnessSat RotateR       = SatWit+    witnessSat ReverseBits   = SatWit++    witnessSat BitScan       = SatWit+    witnessSat BitCount      = SatWit++    witnessSat BitSize       = SatWit+    witnessSat IsSigned      = SatWit+++instance MaybeWitnessSat TypeCtx BITS+  where+    maybeWitnessSat = maybeWitnessSatDefault+++instance Semantic BITS+  where+    semantics BAnd          = Sem "(.&.)"      (.&.)+    semantics BOr           = Sem "(.|.)"      (.|.)+    semantics BXor          = Sem "xor"        xor+    semantics Complement    = Sem "complement" complement++    semantics Bit           = Sem "bit"           (bit . fromIntegral)+    semantics SetBit        = Sem "setBit"        (liftIntWord setBit)+    semantics ClearBit      = Sem "clearBit"      (liftIntWord clearBit)+    semantics ComplementBit = Sem "complementBit" (liftIntWord complementBit)+    semantics TestBit       = Sem "testBit"       (liftIntWord testBit)++    semantics ShiftLU       = Sem "shiftL"      (liftIntWord shiftL)+    semantics ShiftRU       = Sem "shiftR"      (liftIntWord shiftR)+    semantics ShiftL        = Sem "shiftL"      (liftInt shiftL)+    semantics ShiftR        = Sem "shiftR"      (liftInt shiftR)+    semantics RotateLU      = Sem "rotateL"     (liftIntWord rotateL)+    semantics RotateRU      = Sem "rotateR"     (liftIntWord rotateR)+    semantics RotateL       = Sem "rotateL"     (liftInt rotateL)+    semantics RotateR       = Sem "rotateR"     (liftInt rotateR)+    semantics ReverseBits   = Sem "reverseBits" evalReverseBits++    semantics BitScan       = Sem "bitScan"  evalBitScan+    semantics BitCount      = Sem "bitCount" evalBitCount++    semantics BitSize       = Sem "bitSize"  (fromIntegral . bitSize)+    semantics IsSigned      = Sem "isSigned" isSigned+++liftIntWord :: (a -> Int -> b) -> (a -> WordN -> b)+liftIntWord f x = f x . fromIntegral++liftInt :: (a -> Int -> b) -> (a -> IntN -> b)+liftInt f x = f x . fromIntegral++evalReverseBits :: Bits b => b -> b+evalReverseBits b = revLoop b 0 (0 `asTypeOf` b)+  where+    bSz = bitSize b+    revLoop b i n | i >= bSz    = n+    revLoop b i n | testBit b i = revLoop b (i+1) (setBit n (bSz - i - 1))+    revLoop b i n | otherwise   = revLoop b (i+1) n++evalBitScan :: Bits b => b -> WordN+evalBitScan b =+   if isSigned b+   then scanLoop b (testBit b (bitSize b - 1)) (bitSize b - 2) 0+   else scanLoop b False (bitSize b - 1) 0+  where+    scanLoop b bit i n | i Prelude.< 0              = n+    scanLoop b bit i n | testBit b i Prelude./= bit = n+    scanLoop b bit i n | otherwise                  = scanLoop b bit (i-1) (n+1)++evalBitCount :: Bits b => b -> WordN+evalBitCount b = loop b (bitSize b - 1) 0+  where+    loop b i n | i Prelude.< 0 = n+    loop b i n | testBit b i   = loop b (i-1) (n+1)+    loop b i n | otherwise     = loop b (i-1) n++instance ExprEq   BITS where exprEq = exprEqSem; exprHash = exprHashSem+instance Render   BITS where renderPart = renderPartSem+instance ToTree   BITS+instance Eval     BITS where evaluate = evaluateSem+instance EvalBind BITS where evalBindSym = evalBindSymDefault+instance Sharable BITS++instance AlphaEq dom dom dom env => AlphaEq BITS BITS dom env+  where+    alphaEqSym = alphaEqSymDefault++instance SizeProp BITS+  where+    sizeProp BAnd (WrapFull a :* WrapFull b :* Nil) = rangeAnd (infoSize a) (infoSize b)+    sizeProp BOr  (WrapFull a :* WrapFull b :* Nil) = rangeOr (infoSize a) (infoSize b)+    sizeProp BXor (WrapFull a :* WrapFull b :* Nil) = rangeXor (infoSize a) (infoSize b)++    sizeProp ShiftLU (WrapFull a :* WrapFull b :* Nil) = rangeShiftLU (infoSize a) (infoSize b)+    sizeProp ShiftRU (WrapFull a :* WrapFull b :* Nil) = rangeShiftRU (infoSize a) (infoSize b)++    sizeProp a args = sizePropDefault a args+++instance (BITS :<: dom, Optimize dom dom) => Optimize BITS dom+  where+    constructFeatOpt BAnd (a :* b :* Nil)+        | Just 0 <- viewLiteral a              = return a+        | Just x <- viewLiteral a, isAllOnes x = return b+        | Just 0 <- viewLiteral b              = return b+        | Just x <- viewLiteral b, isAllOnes x = return a++    constructFeatOpt BOr (a :* b :* Nil)+        | Just 0 <- viewLiteral a              = return b+        | Just x <- viewLiteral a, isAllOnes x = return a+        | Just 0 <- viewLiteral b              = return a+        | Just x <- viewLiteral b, isAllOnes x = return b++    constructFeatOpt BXor (a :* b :* Nil)+        | Just 0 <- viewLiteral a              = return b+        | Just x <- viewLiteral a, isAllOnes x = constructFeat Complement (b :* Nil)+        | Just 0 <- viewLiteral b              = return a+        | Just x <- viewLiteral b, isAllOnes x = constructFeat Complement (a :* Nil)++    constructFeatOpt ShiftLU  args = optZero ShiftLU  args+    constructFeatOpt ShiftRU  args = optZero ShiftRU  args+    constructFeatOpt ShiftL   args = optZero ShiftL   args+    constructFeatOpt ShiftR   args = optZero ShiftR   args+    constructFeatOpt RotateLU args = optZero RotateLU args+    constructFeatOpt RotateRU args = optZero RotateRU args+    constructFeatOpt RotateL  args = optZero RotateL  args+    constructFeatOpt RotateR  args = optZero RotateR  args++    constructFeatOpt feat args = constructFeatUnOpt feat args++    constructFeatUnOpt = constructFeatUnOptDefault+++isAllOnes :: Bits a => a -> Bool+isAllOnes x = x Prelude.== complement 0++optZero f (a :* b :* Nil)+    | Just 0 <- viewLiteral b = return a+    | otherwise               = constructFeatUnOpt f (a :* b :* Nil)+
+ Feldspar/Core/Constructs/Complex.hs view
@@ -0,0 +1,111 @@+--+-- Copyright (c) 2009-2011, 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 #-}++module Feldspar.Core.Constructs.Complex+where++import Language.Syntactic+import Language.Syntactic.Interpretation.Semantics+import Language.Syntactic.Constructs.Binding++import Data.Complex++import Feldspar.Core.Types+import Feldspar.Core.Interpretation++data COMPLEX a+  where+    MkComplex :: (Type a, RealFloat a) => COMPLEX (a :-> a :-> Full (Complex a))+    RealPart  :: (Type a, RealFloat a) => COMPLEX (Complex a :-> Full a)+    ImagPart  :: (Type a, RealFloat a) => COMPLEX (Complex a :-> Full a)+    Conjugate :: (Type a, RealFloat a) => COMPLEX (Complex a :-> Full (Complex a))+    MkPolar   :: (Type a, RealFloat a) => COMPLEX (a :-> a :-> Full (Complex a))+    Magnitude :: (Type a, RealFloat a) => COMPLEX (Complex a :-> Full a)+    Phase     :: (Type a, RealFloat a) => COMPLEX (Complex a :-> Full a)+    Cis       :: (Type a, RealFloat a) => COMPLEX (a :-> Full (Complex a))++instance WitnessCons COMPLEX+  where+    witnessCons MkComplex = ConsWit+    witnessCons RealPart  = ConsWit+    witnessCons ImagPart  = ConsWit+    witnessCons Conjugate = ConsWit+    witnessCons MkPolar   = ConsWit+    witnessCons Magnitude = ConsWit+    witnessCons Phase     = ConsWit+    witnessCons Cis       = ConsWit++instance WitnessSat COMPLEX+  where+    type SatContext COMPLEX = TypeCtx+    witnessSat MkComplex = SatWit+    witnessSat RealPart  = SatWit+    witnessSat ImagPart  = SatWit+    witnessSat Conjugate = SatWit+    witnessSat MkPolar   = SatWit+    witnessSat Magnitude = SatWit+    witnessSat Phase     = SatWit+    witnessSat Cis       = SatWit++instance MaybeWitnessSat TypeCtx COMPLEX+  where+    maybeWitnessSat = maybeWitnessSatDefault++instance Semantic COMPLEX+  where+    semantics MkComplex = Sem "complex"   (:+)+    semantics RealPart  = Sem "creal"     realPart+    semantics ImagPart  = Sem "cimag"     imagPart+    semantics Conjugate = Sem "conjugate" conjugate+    semantics MkPolar   = Sem "mkPolar"   mkPolar+    semantics Magnitude = Sem "magnitude" magnitude+    semantics Phase     = Sem "phase"     phase+    semantics Cis       = Sem "cis"       cis++instance ExprEq   COMPLEX where exprEq = exprEqSem; exprHash = exprHashSem+instance Render   COMPLEX where renderPart = renderPartSem+instance ToTree   COMPLEX+instance Eval     COMPLEX where evaluate = evaluateSem+instance EvalBind COMPLEX where evalBindSym = evalBindSymDefault+instance Sharable COMPLEX+instance SizeProp COMPLEX where sizeProp = sizePropDefault++instance AlphaEq dom dom dom env => AlphaEq COMPLEX COMPLEX dom env+  where+    alphaEqSym = alphaEqSymDefault++instance (COMPLEX :<: dom, Optimize dom dom) => Optimize COMPLEX dom+  where+    constructFeatUnOpt = constructFeatUnOptDefault+      -- TODO Optimize e.g.+      --+      --        complex (realPart a) (imagPart a)  ==>  a+      --        conjugate . conjugate              ==>  id+
+ Feldspar/Core/Constructs/Condition.hs view
@@ -0,0 +1,77 @@+--+-- Copyright (c) 2009-2011, 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 #-}++module Feldspar.Core.Constructs.Condition+    ( module Language.Syntactic.Constructs.Condition+    ) where++++import Language.Syntactic+import Language.Syntactic.Constructs.Binding+import Language.Syntactic.Constructs.Condition++import Feldspar.Lattice+import Feldspar.Core.Types+import Feldspar.Core.Interpretation+import Feldspar.Core.Constructs.Logic++++instance Sharable (Condition TypeCtx)++instance SizeProp (Condition TypeCtx)+  where+    sizeProp cond@Condition (_ :* WrapFull t :* WrapFull f :* Nil)+        | TypeWit <- fromSatWit $ witnessSat cond+        = infoSize t \/ infoSize f++instance (Condition TypeCtx :<: dom, Logic :<: dom, Optimize dom dom) =>+    Optimize (Condition TypeCtx) dom+  where+    constructFeatOpt Condition (c :* t :* f :* Nil)+        | Just c' <- viewLiteral c = return $ if c' then t else f++    constructFeatOpt Condition (c :* t :* f :* Nil)+        | alphaEq t f = return t++    constructFeatOpt cond@Condition ((op :$ c) :* t :* f :* Nil)+        | Just (_,Not) <- prjDecor op+        = constructFeat cond (c :* f :* t :* Nil)++    constructFeatOpt a args = constructFeatUnOpt a args++    constructFeatUnOpt = constructFeatUnOptDefault++      -- TODO Propagate size information from the condition to the branches. For+      --      example+      --+      --        condition (x<10) (min x 20) x  ==>  x+
+ Feldspar/Core/Constructs/ConditionM.hs view
@@ -0,0 +1,112 @@+--+-- Copyright (c) 2009-2011, 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 #-}++module Feldspar.Core.Constructs.ConditionM+    ( ConditionM (..)+    ) where++import Data.Map++import Language.Syntactic+import Language.Syntactic.Interpretation.Semantics+import Language.Syntactic.Constructs.Binding++import Feldspar.Core.Types+import Feldspar.Core.Interpretation+import Feldspar.Core.Constructs.Logic++import Feldspar.Lattice++data ConditionM m a+  where+    ConditionM :: (Monad m, Type a) =>+                  ConditionM m (Bool :-> m a :-> m a :-> Full (m a))+    -- TODO Can't we just use `Condition` instead?++instance WitnessCons (ConditionM m)+  where+    witnessCons ConditionM = ConsWit++instance MaybeWitnessSat TypeCtx (ConditionM m)+  where+    maybeWitnessSat _ _ = Nothing++instance Semantic (ConditionM m)+  where+    semantics ConditionM = Sem "if" ifM+      where+        ifM cond e t = if cond then e else t++instance ExprEq   (ConditionM m) where exprEq = exprEqSem; exprHash = exprHashSem+instance Render   (ConditionM m) where renderPart = renderPartSem+instance ToTree   (ConditionM m)+instance Eval     (ConditionM m) where evaluate = evaluateSem+instance EvalBind (ConditionM m) where evalBindSym = evalBindSymDefault+instance Sharable (ConditionM m)+  -- Will not be shared anyway, because 'maybeWitnessSat' returns 'Nothing'++instance AlphaEq dom dom dom env =>+    AlphaEq (ConditionM m) (ConditionM m) dom env+  where+    alphaEqSym = alphaEqSymDefault++instance LatticeSize1 m => SizeProp (ConditionM m)+  where+    sizeProp ConditionM (_ :* WrapFull t :* WrapFull f :* Nil) =+        mergeSize t (infoSize t) (infoSize f)++instance ( ConditionM m :<: dom+         , Logic :<: dom+         , Optimize dom dom+         , LatticeSize1 m+         )+      => Optimize (ConditionM m) dom+  where+    constructFeatOpt ConditionM (c :* t :* f :* Nil)+        | Just c' <- viewLiteral c = return $ if c' then t else f++    constructFeatOpt ConditionM (_ :* t :* f :* Nil)+        | alphaEq t f = return t++    constructFeatOpt cond@ConditionM ((op :$ c) :* t :* f :* Nil)+        | Just (_, Not) <- prjDecor op+        = constructFeat cond (c :* f :* t :* Nil)++    constructFeatOpt a args = constructFeatUnOpt a args++    constructFeatUnOpt ConditionM args@(_ :* t :* _ :* Nil)+        | Info {infoType = tType} <- getInfo t+        = constructFeatUnOptDefaultTyp tType ConditionM args++      -- TODO Propagate size information from the condition to the branches. For+      --      example+      --+      --        condition (x<10) (min x 20) x  ==>  x+
+ Feldspar/Core/Constructs/Conversion.hs view
@@ -0,0 +1,129 @@+--+-- Copyright (c) 2009-2011, 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 #-}++module Feldspar.Core.Constructs.Conversion+    ( Conversion (..)+    ) where++import Language.Syntactic+import Language.Syntactic.Interpretation.Semantics+import Language.Syntactic.Constructs.Binding++import Feldspar.Range+import Feldspar.Lattice+import Feldspar.Core.Types+import Feldspar.Core.Interpretation++data Conversion a+  where+    F2I     :: (Type a, Integral a) => Conversion (Float :-> Full a)+    I2N     :: (Type a, Type b, Integral a, Num b+               ,Size a ~ Range a+               ) =>+               Conversion (a :-> Full b)+    B2I     :: (Type a, Integral a) => Conversion (Bool  :-> Full a)+    Round   :: (Type a, Integral a) => Conversion (Float :-> Full a)+    Ceiling :: (Type a, Integral a) => Conversion (Float :-> Full a)+    Floor   :: (Type a, Integral a) => Conversion (Float :-> Full a)++rangeToSize :: Lattice (Size a) => TypeRep a -> Range Integer -> Size a+rangeToSize (IntType _ _) r = rangeProp r+rangeToSize _ _             = universal++rangeProp :: forall a . (Bounded a, Integral a) => Range Integer -> Range a+rangeProp (Range l u)+    | withinBounds l && withinBounds u+        = range (fromIntegral l) (fromIntegral u)+    | otherwise = range minBound maxBound+  where withinBounds i = toInteger (minBound :: a) <= i &&+                         i <= toInteger (maxBound :: a)++instance WitnessCons Conversion+  where+    witnessCons F2I     = ConsWit+    witnessCons I2N     = ConsWit+    witnessCons B2I     = ConsWit+    witnessCons Round   = ConsWit+    witnessCons Ceiling = ConsWit+    witnessCons Floor   = ConsWit++instance WitnessSat Conversion+  where+    type SatContext Conversion = TypeCtx+    witnessSat F2I     = SatWit+    witnessSat I2N     = SatWit+    witnessSat B2I     = SatWit+    witnessSat Round   = SatWit+    witnessSat Ceiling = SatWit+    witnessSat Floor   = SatWit++instance MaybeWitnessSat TypeCtx Conversion+  where+    maybeWitnessSat = maybeWitnessSatDefault++instance Semantic Conversion+  where+    semantics F2I     = Sem "f2i"     truncate+    semantics I2N     = Sem "i2n"     (fromInteger.toInteger)+    semantics B2I     = Sem "b2i"     (\b -> if b then 1 else 0)+    semantics Round   = Sem "round"   round+    semantics Ceiling = Sem "ceiling" ceiling+    semantics Floor   = Sem "floor"   floor++instance ExprEq   Conversion where exprEq = exprEqSem; exprHash = exprHashSem+instance Render   Conversion where renderPart = renderPartSem+instance Eval     Conversion where evaluate = evaluateSem+instance ToTree   Conversion+instance EvalBind Conversion where evalBindSym = evalBindSymDefault+instance Sharable Conversion++instance AlphaEq dom dom dom env => AlphaEq Conversion Conversion dom env+  where+    alphaEqSym = alphaEqSymDefault++instance SizeProp Conversion+  where+    sizeProp F2I     _ = universal+    sizeProp i2n@I2N (WrapFull a :* Nil)+        = rangeToSize (resultType i2n) (mapMonotonic toInteger (infoSize a))+    sizeProp B2I     _ = universal+    sizeProp Round   _ = universal+    sizeProp Ceiling _ = universal+    sizeProp Floor   _ = universal++instance (Conversion :<: dom, Optimize dom dom) => Optimize Conversion dom+  where+    constructFeatOpt i2n@I2N (a :* Nil)+        | Just TypeEq <- typeEq (resultType i2n) (infoType $ getInfo a)+        = return a+    constructFeatOpt a args = constructFeatUnOpt a args++    constructFeatUnOpt = constructFeatUnOptDefault+
+ Feldspar/Core/Constructs/Eq.hs view
@@ -0,0 +1,105 @@+--+-- Copyright (c) 2009-2011, 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 #-}++module Feldspar.Core.Constructs.Eq+where++import Language.Syntactic+import Language.Syntactic.Interpretation.Semantics+import Language.Syntactic.Constructs.Binding+import Language.Syntactic.Constructs.Literal++import Feldspar.Range+import Feldspar.Core.Types+import Feldspar.Core.Interpretation++data EQ a+  where+    Equal    :: (Type a, Eq a) => EQ (a :-> a :-> Full Bool)+    NotEqual :: (Type a, Eq a) => EQ (a :-> a :-> Full Bool)++instance WitnessCons EQ+  where+    witnessCons Equal    = ConsWit+    witnessCons NotEqual = ConsWit++instance WitnessSat EQ+  where+    type SatContext EQ  = TypeCtx+    witnessSat Equal    = SatWit+    witnessSat NotEqual = SatWit++instance MaybeWitnessSat TypeCtx EQ+  where+    maybeWitnessSat = maybeWitnessSatDefault++instance Semantic EQ+  where+    semantics Equal    = Sem "(==)" (==)+    semantics NotEqual = Sem "(/=)" (/=)++instance ExprEq   EQ where exprEq = exprEqSem; exprHash = exprHashSem+instance Render   EQ where renderPart = renderPartSem+instance ToTree   EQ+instance Eval     EQ where evaluate = evaluateSem+instance EvalBind EQ where evalBindSym = evalBindSymDefault+instance SizeProp EQ where sizeProp = sizePropDefault+instance Sharable EQ++instance AlphaEq dom dom dom env => AlphaEq EQ EQ dom env+  where+    alphaEqSym = alphaEqSymDefault++instance (EQ :<: dom, Optimize dom dom) => Optimize EQ dom+  where+    constructFeatOpt Equal (a :* b :* Nil)+        | alphaEq a b+        = return $ literalDecor True++    constructFeatOpt Equal (a :* b :* Nil)+        | RangeSet ra <- infoRange (getInfo a)+        , RangeSet rb <- infoRange (getInfo b)+        , ra `disjoint` rb+        = return $ literalDecor False++    constructFeatOpt NotEqual (a :* b :* Nil)+        | alphaEq a b+        = return $ literalDecor False++    constructFeatOpt NotEqual (a :* b :* Nil)+        | RangeSet ra <- infoRange (getInfo a)+        , RangeSet rb <- infoRange (getInfo b)+        , ra `disjoint` rb+        = return $ literalDecor True++    constructFeatOpt a args = constructFeatUnOpt a args++    constructFeatUnOpt = constructFeatUnOptDefault+
+ Feldspar/Core/Constructs/Error.hs view
@@ -0,0 +1,90 @@+--+-- Copyright (c) 2009-2011, 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 #-}++module Feldspar.Core.Constructs.Error where++++import Language.Syntactic+import Language.Syntactic.Interpretation.Semantics+import Language.Syntactic.Constructs.Binding++import Feldspar.Range+import Feldspar.Core.Types+import Feldspar.Core.Interpretation++++data Error a+  where+    Undefined :: Type a => Error (Full a)+    Assert    :: Type a => String -> Error (Bool :-> a :-> Full a)++instance WitnessCons Error+  where+    witnessCons Undefined  = ConsWit+    witnessCons (Assert _) = ConsWit++instance WitnessSat Error+  where+    type SatContext Error = TypeCtx+    witnessSat Undefined  = SatWit+    witnessSat (Assert _) = SatWit++instance MaybeWitnessSat TypeCtx Error+  where+    maybeWitnessSat = maybeWitnessSatDefault++instance Semantic Error+  where+    semantics Undefined    = Sem "undefined" undefined+    semantics (Assert msg) = Sem "assert"+        (\cond a -> if cond then a else error ("Assert failed: " ++ msg))++instance Render Error+  where+    render Undefined    = "undefined"+    render (Assert msg) = "assert " ++ show msg++instance ExprEq   Error where exprEq = exprEqSem; exprHash = exprHashSem+instance ToTree   Error+instance Eval     Error where evaluate = evaluateSem+instance EvalBind Error where evalBindSym = evalBindSymDefault+instance SizeProp Error where sizeProp = sizePropDefault+instance Sharable Error++instance AlphaEq dom dom dom env => AlphaEq Error Error dom env+  where+    alphaEqSym = alphaEqSymDefault++instance (Error :<: dom, Optimize dom dom) => Optimize Error dom+  where+    constructFeatUnOpt = constructFeatUnOptDefault+
+ Feldspar/Core/Constructs/FFI.hs view
@@ -0,0 +1,86 @@+--+-- Copyright (c) 2009-2011, 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 #-}++module Feldspar.Core.Constructs.FFI where++import Language.Syntactic+import Language.Syntactic.Interpretation.Semantics+import Language.Syntactic.Constructs.Binding++import Feldspar.Lattice+import Feldspar.Core.Types+import Feldspar.Core.Interpretation++data FFI a+  where+    ForeignImport :: ( Type (DenResult a)+                     , Signature a+                     )+                  => String -> Denotation a -> FFI a++instance Semantic FFI+  where+    semantics (ForeignImport name f) = Sem name f++instance ExprEq   FFI where exprEq = exprEqSem; exprHash = exprHashSem+instance Render   FFI where renderPart = renderPartSem+instance ToTree   FFI+instance Eval     FFI where evaluate = evaluateSem+instance EvalBind FFI where evalBindSym = evalBindSymDefault+instance Sharable FFI++instance WitnessCons FFI+  where+    witnessCons (ForeignImport _ _) = ConsWit++instance WitnessSat FFI+  where+    type SatContext FFI = TypeCtx+    witnessSat (ForeignImport _ _) = SatWit++instance MaybeWitnessSat ctx FFI+  where+    maybeWitnessSat _ _ = Nothing++instance AlphaEq dom dom dom env => AlphaEq FFI FFI dom env+  where+    alphaEqSym = alphaEqSymDefault++instance SizeProp FFI+  where+    sizeProp = sizePropDefault++instance ( FFI :<: dom+         , Optimize dom dom+         )+      => Optimize FFI dom+  where+    constructFeatUnOpt = constructFeatUnOptDefault+
+ Feldspar/Core/Constructs/Floating.hs view
@@ -0,0 +1,146 @@+--+-- Copyright (c) 2009-2011, 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 #-}++module Feldspar.Core.Constructs.Floating+    ( FLOATING (..)+    ) where++++import Language.Syntactic+import Language.Syntactic.Interpretation.Semantics+import Language.Syntactic.Constructs.Binding++import Feldspar.Core.Types+import Feldspar.Core.Interpretation++++data FLOATING a+  where+    Exp     :: (Type a, Floating a) => FLOATING (a :-> Full a)+    Sqrt    :: (Type a, Floating a) => FLOATING (a :-> Full a)+    Log     :: (Type a, Floating a) => FLOATING (a :-> Full a)+    Pow     :: (Type a, Floating a) => FLOATING (a :-> a :-> Full a)+    LogBase :: (Type a, Floating a) => FLOATING (a :-> a :-> Full a)+    Sin     :: (Type a, Floating a) => FLOATING (a :-> Full a)+    Tan     :: (Type a, Floating a) => FLOATING (a :-> Full a)+    Cos     :: (Type a, Floating a) => FLOATING (a :-> Full a)+    Asin    :: (Type a, Floating a) => FLOATING (a :-> Full a)+    Atan    :: (Type a, Floating a) => FLOATING (a :-> Full a)+    Acos    :: (Type a, Floating a) => FLOATING (a :-> Full a)+    Sinh    :: (Type a, Floating a) => FLOATING (a :-> Full a)+    Tanh    :: (Type a, Floating a) => FLOATING (a :-> Full a)+    Cosh    :: (Type a, Floating a) => FLOATING (a :-> Full a)+    Asinh   :: (Type a, Floating a) => FLOATING (a :-> Full a)+    Atanh   :: (Type a, Floating a) => FLOATING (a :-> Full a)+    Acosh   :: (Type a, Floating a) => FLOATING (a :-> Full a)++instance WitnessCons FLOATING+  where+    witnessCons Exp     = ConsWit+    witnessCons Sqrt    = ConsWit+    witnessCons Log     = ConsWit+    witnessCons Pow     = ConsWit+    witnessCons LogBase = ConsWit+    witnessCons Sin     = ConsWit+    witnessCons Tan     = ConsWit+    witnessCons Cos     = ConsWit+    witnessCons Asin    = ConsWit+    witnessCons Atan    = ConsWit+    witnessCons Acos    = ConsWit+    witnessCons Sinh    = ConsWit+    witnessCons Tanh    = ConsWit+    witnessCons Cosh    = ConsWit+    witnessCons Asinh   = ConsWit+    witnessCons Atanh   = ConsWit+    witnessCons Acosh   = ConsWit++instance WitnessSat FLOATING+  where+    type SatContext FLOATING = TypeCtx+    witnessSat Exp     = SatWit+    witnessSat Sqrt    = SatWit+    witnessSat Log     = SatWit+    witnessSat Pow     = SatWit+    witnessSat LogBase = SatWit+    witnessSat Sin     = SatWit+    witnessSat Tan     = SatWit+    witnessSat Cos     = SatWit+    witnessSat Asin    = SatWit+    witnessSat Atan    = SatWit+    witnessSat Acos    = SatWit+    witnessSat Sinh    = SatWit+    witnessSat Tanh    = SatWit+    witnessSat Cosh    = SatWit+    witnessSat Asinh   = SatWit+    witnessSat Atanh   = SatWit+    witnessSat Acosh   = SatWit++instance MaybeWitnessSat TypeCtx FLOATING+  where+    maybeWitnessSat = maybeWitnessSatDefault++instance Semantic FLOATING+  where+    semantics Exp     = Sem "exp"     Prelude.exp+    semantics Sqrt    = Sem "sqrt"    Prelude.sqrt+    semantics Log     = Sem "log"     Prelude.log+    semantics Pow     = Sem "(**)"    (Prelude.**)+    semantics LogBase = Sem "logBase" Prelude.logBase+    semantics Sin     = Sem "sin"     Prelude.sin+    semantics Tan     = Sem "tan"     Prelude.tan+    semantics Cos     = Sem "cos"     Prelude.cos+    semantics Asin    = Sem "asin"    Prelude.asin+    semantics Atan    = Sem "atan"    Prelude.atan+    semantics Acos    = Sem "acos"    Prelude.acos+    semantics Sinh    = Sem "sinh"    Prelude.sinh+    semantics Tanh    = Sem "tanh"    Prelude.tanh+    semantics Cosh    = Sem "cosh"    Prelude.cosh+    semantics Asinh   = Sem "asinh"   Prelude.asinh+    semantics Atanh   = Sem "atanh"   Prelude.atanh+    semantics Acosh   = Sem "acosh"   Prelude.acosh++instance ExprEq   FLOATING where exprEq = exprEqSem; exprHash = exprHashSem+instance Render   FLOATING where renderPart = renderPartSem+instance ToTree   FLOATING+instance Eval     FLOATING where evaluate = evaluateSem+instance EvalBind FLOATING where evalBindSym = evalBindSymDefault+instance SizeProp FLOATING where sizeProp = sizePropDefault+instance Sharable FLOATING++instance AlphaEq dom dom dom env => AlphaEq FLOATING FLOATING dom env+  where+    alphaEqSym = alphaEqSymDefault++instance (FLOATING :<: dom, Optimize dom dom) => Optimize FLOATING dom+  where+    constructFeatUnOpt = constructFeatUnOptDefault+
+ Feldspar/Core/Constructs/Fractional.hs view
@@ -0,0 +1,85 @@+--+-- Copyright (c) 2009-2011, 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 #-}++module Feldspar.Core.Constructs.Fractional+    ( FRACTIONAL (..)+    ) where++++import Language.Syntactic+import Language.Syntactic.Interpretation.Semantics+import Language.Syntactic.Constructs.Binding++import Feldspar.Core.Types+import Feldspar.Core.Interpretation++data FRACTIONAL a+  where+    DivFrac :: (Type a, Fractional a) => FRACTIONAL (a :-> a :-> Full a)++instance WitnessCons FRACTIONAL+  where+    witnessCons DivFrac = ConsWit++instance WitnessSat FRACTIONAL+  where+    type SatContext FRACTIONAL = TypeCtx+    witnessSat DivFrac = SatWit++instance MaybeWitnessSat TypeCtx FRACTIONAL+  where+    maybeWitnessSat = maybeWitnessSatDefault++instance Semantic FRACTIONAL+  where+    semantics DivFrac = Sem "(/)" (/)++instance ExprEq   FRACTIONAL where exprEq = exprEqSem; exprHash = exprHashSem+instance Render   FRACTIONAL where renderPart = renderPartSem+instance ToTree   FRACTIONAL+instance Eval     FRACTIONAL where evaluate = evaluateSem+instance EvalBind FRACTIONAL where evalBindSym = evalBindSymDefault+instance SizeProp FRACTIONAL where sizeProp = sizePropDefault+instance Sharable FRACTIONAL++instance AlphaEq dom dom dom env => AlphaEq FRACTIONAL FRACTIONAL dom env+  where+    alphaEqSym = alphaEqSymDefault++instance (FRACTIONAL :<: dom, Optimize dom dom) => Optimize FRACTIONAL dom+  where+    constructFeatOpt DivFrac (a :* b :* Nil)+        | Just 1 <- viewLiteral b = return a++    constructFeatOpt a args = constructFeatUnOpt a args++    constructFeatUnOpt = constructFeatUnOptDefault+
+ Feldspar/Core/Constructs/Integral.hs view
@@ -0,0 +1,210 @@+--+-- Copyright (c) 2009-2011, 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 #-}++module Feldspar.Core.Constructs.Integral+    ( INTEGRAL (..)+    ) where++++import Data.Bits++import Language.Syntactic+import Language.Syntactic.Interpretation.Semantics+import Language.Syntactic.Constructs.Binding+import Language.Syntactic.Constructs.Condition++import Feldspar.Range+import Feldspar.Core.Types+import Feldspar.Core.Interpretation+import Feldspar.Core.Constructs.Bits+import Feldspar.Core.Constructs.Eq+import Feldspar.Core.Constructs.Ord+import Feldspar.Core.Constructs.Num++++data INTEGRAL a+  where+    Quot :: (Type a, BoundedInt a, Size a ~ Range a) => INTEGRAL (a :-> a :-> Full a)+    Rem  :: (Type a, BoundedInt a, Size a ~ Range a) => INTEGRAL (a :-> a :-> Full a)+    Div  :: (Type a, BoundedInt a, Size a ~ Range a) => INTEGRAL (a :-> a :-> Full a)+    Mod  :: (Type a, BoundedInt a, Size a ~ Range a) => INTEGRAL (a :-> a :-> Full a)+    Exp  :: (Type a, BoundedInt a, Size a ~ Range a) => INTEGRAL (a :-> a :-> Full a)++instance WitnessCons INTEGRAL+  where+    witnessCons Quot = ConsWit+    witnessCons Rem  = ConsWit+    witnessCons Div  = ConsWit+    witnessCons Mod  = ConsWit+    witnessCons Exp  = ConsWit++instance WitnessSat INTEGRAL+  where+    type SatContext INTEGRAL = TypeCtx+    witnessSat Quot = SatWit+    witnessSat Rem  = SatWit+    witnessSat Div  = SatWit+    witnessSat Mod  = SatWit+    witnessSat Exp  = SatWit++instance MaybeWitnessSat TypeCtx INTEGRAL+  where+    maybeWitnessSat = maybeWitnessSatDefault++instance Semantic INTEGRAL+  where+    semantics Quot = Sem "quot" quot+    semantics Rem  = Sem "rem"  rem+    semantics Div  = Sem "div"  div+    semantics Mod  = Sem "mod"  mod+    semantics Exp  = Sem "(^)"  (^)++instance ExprEq   INTEGRAL where exprEq = exprEqSem; exprHash = exprHashSem+instance Render   INTEGRAL where renderPart = renderPartSem+instance ToTree   INTEGRAL+instance Eval     INTEGRAL where evaluate = evaluateSem+instance EvalBind INTEGRAL where evalBindSym = evalBindSymDefault+instance Sharable INTEGRAL++instance AlphaEq dom dom dom env => AlphaEq INTEGRAL INTEGRAL dom env+  where+    alphaEqSym = alphaEqSymDefault++instance SizeProp INTEGRAL+  where+    sizeProp Quot (WrapFull a :* WrapFull b :* Nil) = rangeQuot (infoSize a) (infoSize b)+    sizeProp Rem  (WrapFull a :* WrapFull b :* Nil) = rangeRem (infoSize a) (infoSize b)+    sizeProp Div  (WrapFull a :* WrapFull b :* Nil) = rangeDiv (infoSize a) (infoSize b)+    sizeProp Mod  (WrapFull a :* WrapFull b :* Nil) = rangeMod (infoSize a) (infoSize b)+    sizeProp Exp  (WrapFull a :* WrapFull b :* Nil) = rangeExp (infoSize a) (infoSize b)++instance+    ( INTEGRAL          :<: dom+    , BITS              :<: dom+    , NUM               :<: dom+    , EQ                :<: dom+    , ORD               :<: dom+    , Condition TypeCtx :<: dom+    , Optimize dom dom+    , Optimize (Condition TypeCtx) dom+    ) =>+      Optimize INTEGRAL dom+  where+    constructFeatOpt Quot (a :* b :* Nil)+        | Just 1 <- viewLiteral b = return a++    constructFeatOpt Quot (a :* b :* Nil)+        | Just b' <- viewLiteral b+        , b' > 0+        , isPowerOfTwo b'+        , let l    = log2 b'+        , let lLit = literalDecor l+        = if isNatural $ infoSize $ getInfo a+            then constructFeat ShiftR (a :* lLit :* Nil)+            else do+                aIsNeg  <- constructFeat LTH (a :* literalDecor 0 :* Nil)+                a'      <- constructFeat Add (a :* literalDecor (2^l-1) :* Nil)+                negCase <- constructFeat ShiftR (a' :* lLit :* Nil)+                posCase <- constructFeat ShiftR (a :* lLit :* Nil)+                constructFeat (Condition `withContext` typeCtx)+                    (aIsNeg :* negCase :* posCase :* Nil)+      -- TODO This rule should also fire when `b` is `2^l` but not a literal.+      -- TODO Make a case for `isNegative $ infoSize $ getInfo a`. Note that+      --      `isNegative /= (not . isNatural)`+      -- TODO Or maybe both `isNegative` and ``isPositive` are handled by the+      --      size-based optimization of `Condition`?++    constructFeatOpt Rem (a :* b :* Nil)+        | rangeLess sza szb+        , isNatural sza+        = return a+      where+        sza = infoSize $ getInfo a+        szb = infoSize $ getInfo b++    constructFeatOpt Div (a :* b :* Nil)+        | Just 1 <- viewLiteral b = return a++    constructFeatOpt Div (a :* b :* Nil)+        | Just b' <- viewLiteral b+        , b' > 0+        , isPowerOfTwo b'+        = constructFeat ShiftR (a :* literalDecor (log2 b') :* Nil)++    constructFeatOpt Div (a :* b :* Nil)+        | sameSign (infoSize (getInfo a)) (infoSize (getInfo b))+        = constructFeat Quot (a :* b :* Nil)++    constructFeatOpt Mod (a :* b :* Nil)+        | rangeLess sza szb+        , isNatural sza+        = return a+      where+        sza = infoSize $ getInfo a+        szb = infoSize $ getInfo b++    constructFeatOpt Mod (a :* b :* Nil)+        | sameSign (infoSize (getInfo a)) (infoSize (getInfo b))+        = constructFeat Rem (a :* b :* Nil)++    constructFeatOpt Exp (a :* b :* Nil)+        | Just 1 <- viewLiteral a = return $ literalDecor 1+        | Just 0 <- viewLiteral a = return $ literalDecor 0+        | Just 1 <- viewLiteral b = return a+        | Just 0 <- viewLiteral b = return $ literalDecor 1++    constructFeatOpt Exp (a :* b :* Nil)+        | Just (-1) <- viewLiteral a = do+            bLSB    <- constructFeat BAnd (b :* literalDecor 1 :* Nil)+            bIsEven <- constructFeat Equal (bLSB :* literalDecor 0 :* Nil)  -- TODO Use testBit? (remove EQ :<: dom and import)+            constructFeat (Condition `withContext` typeCtx)+                (bIsEven :* literalDecor 1 :* literalDecor (-1) :* Nil)++    constructFeatOpt a args = constructFeatUnOpt a args++    constructFeatUnOpt = constructFeatUnOptDefault++-- Auxiliary functions++-- shouldn't be used for negative numbers+isPowerOfTwo :: Bits a => a -> Bool+isPowerOfTwo x = x .&. (x - 1) == 0 && not (x == 0)++log2 :: (BoundedInt a, Integral b) => a -> b+log2 v | v <= 1 = 0+log2 v = 1 + log2 (shiftR v 1)++sameSign :: BoundedInt a => Range a -> Range a -> Bool+sameSign ra rb+    =  isNatural  ra && isNatural  rb+    || isNegative ra && isNegative rb+
+ Feldspar/Core/Constructs/Literal.hs view
@@ -0,0 +1,60 @@+--+-- Copyright (c) 2009-2011, 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 #-}++-- | Interpretation of basic syntactic constructs++module Feldspar.Core.Constructs.Literal+    ( module Language.Syntactic.Constructs.Literal+    ) where++++import Language.Syntactic+import Language.Syntactic.Constructs.Literal++import Feldspar.Core.Types+import Feldspar.Core.Interpretation++++instance Sharable (Literal TypeCtx)+  -- Will not be shared anyway, because it's a terminal++instance SizeProp (Literal TypeCtx)+  where+    sizeProp lit@(Literal a) Nil+        | TypeWit <- fromSatWit $ witnessSat lit+        = sizeOf a++instance (Literal TypeCtx :<: dom, Optimize dom dom) =>+    Optimize (Literal TypeCtx) dom+  where+    constructFeatUnOpt = constructFeatUnOptDefault+
+ Feldspar/Core/Constructs/Logic.hs view
@@ -0,0 +1,123 @@+--+-- Copyright (c) 2009-2011, 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 #-}++module Feldspar.Core.Constructs.Logic+    ( Logic (..)+    ) where++++import Language.Syntactic+import Language.Syntactic.Interpretation.Semantics+import Language.Syntactic.Constructs.Binding++import Feldspar.Core.Types+import Feldspar.Core.Interpretation+import Feldspar.Core.Constructs.Eq+import Feldspar.Core.Constructs.Ord+++data Logic a+  where+    And :: Logic (Bool :-> Bool :-> Full Bool)+    Or  :: Logic (Bool :-> Bool :-> Full Bool)+    Not :: Logic (Bool :->          Full Bool)++instance WitnessCons Logic+  where+    witnessCons And = ConsWit+    witnessCons Or  = ConsWit+    witnessCons Not = ConsWit++instance WitnessSat Logic+  where+    type SatContext Logic = TypeCtx+    witnessSat And = SatWit+    witnessSat Or  = SatWit+    witnessSat Not = SatWit++instance MaybeWitnessSat TypeCtx Logic+  where+    maybeWitnessSat = maybeWitnessSatDefault++instance Semantic Logic+  where+    semantics And = Sem "(&&)" (&&)+    semantics Or  = Sem "(||)" (||)+    semantics Not = Sem "not"  not++instance ExprEq   Logic where exprEq = exprEqSem; exprHash = exprHashSem+instance Render   Logic where renderPart = renderPartSem+instance ToTree   Logic+instance Eval     Logic where evaluate = evaluateSem+instance EvalBind Logic where evalBindSym = evalBindSymDefault+instance SizeProp Logic where sizeProp = sizePropDefault+instance Sharable Logic++instance AlphaEq dom dom dom env => AlphaEq Logic Logic dom env+  where+    alphaEqSym = alphaEqSymDefault++instance ( Logic :<: dom+         , EQ :<: dom+         , ORD :<: dom+         , Optimize dom dom+         )+      => Optimize Logic dom+  where+    constructFeatOpt And (a :* b :* Nil)+        | Just True  <- viewLiteral a = return b+        | Just False <- viewLiteral a = return a+        | Just True  <- viewLiteral b = return a+        | Just False <- viewLiteral b = return b+        | a `alphaEq` b               = return a++    constructFeatOpt Or (a :* b :* Nil)+        | Just True  <- viewLiteral a = return a+        | Just False <- viewLiteral a = return b+        | Just True  <- viewLiteral b = return b+        | Just False <- viewLiteral b = return a+        | a `alphaEq` b               = return a++    constructFeatOpt Not ((not :$ a) :* Nil)+        | Just (_,Not) <- prjDecor not = return a++    constructFeatOpt Not ((op :$ a :$ b) :* Nil)+        | Just (_,Equal)    <- prjDecor op = constructFeat NotEqual (a :* b :* Nil)+        | Just (_,NotEqual) <- prjDecor op = constructFeat Equal    (a :* b :* Nil)+        | Just (_,LTH)      <- prjDecor op = constructFeat GTE      (a :* b :* Nil)+        | Just (_,GTH)      <- prjDecor op = constructFeat LTE      (a :* b :* Nil)+        | Just (_,LTE)      <- prjDecor op = constructFeat GTH      (a :* b :* Nil)+        | Just (_,GTE)      <- prjDecor op = constructFeat LTH      (a :* b :* Nil)++    constructFeatOpt a args = constructFeatUnOpt a args++    constructFeatUnOpt = constructFeatUnOptDefault+
+ Feldspar/Core/Constructs/Loop.hs view
@@ -0,0 +1,212 @@+--+-- Copyright (c) 2009-2011, 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 #-}++module Feldspar.Core.Constructs.Loop+where++import Control.Monad (forM_, when)++import Language.Syntactic+import Language.Syntactic.Interpretation.Semantics+import Language.Syntactic.Constructs.Binding++import Feldspar.Range+import Feldspar.Core.Types+import Feldspar.Core.Interpretation+import Feldspar.Core.Constructs.Binding+import Feldspar.Core.Constructs.Literal++data LoopM m a+  where+    While :: (Size (m ()) ~ AnySize) => LoopM m (m Bool :-> m a :-> Full (m ()))+    For   :: (Size (m ()) ~ AnySize) => LoopM m (Length :-> (Index -> m a) :-> Full (m ()))++data Loop a+  where+    ForLoop   :: Type a => Loop (Length :-> a :-> (Index -> a -> a) :-> Full a)+    WhileLoop :: Type a => Loop (a :-> (a -> Bool) :-> (a -> a) :-> Full a)++instance WitnessCons (LoopM m)+  where+    witnessCons While = ConsWit+    witnessCons For   = ConsWit++instance WitnessCons Loop+  where+    witnessCons ForLoop   = ConsWit+    witnessCons WhileLoop = ConsWit++instance WitnessSat Loop+  where+    type SatContext Loop = TypeCtx+    witnessSat ForLoop   = SatWit+    witnessSat WhileLoop = SatWit++instance MaybeWitnessSat TypeCtx (LoopM m)+  where+    maybeWitnessSat _ _ = Nothing++instance MaybeWitnessSat TypeCtx Loop+  where+    maybeWitnessSat = maybeWitnessSatDefault++instance Monad m => Semantic (LoopM m)+  where+    semantics While = Sem "while" while+      where+        while cond body = do+                            c <- cond+                            when c (body >> while cond body)+    semantics For = Sem "for" for+      where+        for 0 _    = return ()+        for l body = forM_ [0..l-1] body++instance Semantic Loop+  where+    semantics ForLoop = Sem "forLoop" forLoop+      where+        forLoop 0 init _    = init+        forLoop l init body = foldl (flip body) init [0..l-1]+    semantics WhileLoop = Sem "whileLoop" whileLoop+      where+        whileLoop init cond body = go init+          where+            go st | cond st   = go $ body st+                  | otherwise = st++instance Monad m => ExprEq   (LoopM m) where exprEq = exprEqSem; exprHash = exprHashSem+instance Monad m => Render   (LoopM m) where renderPart = renderPartSem+instance Monad m => ToTree   (LoopM m)+instance Monad m => Eval     (LoopM m) where evaluate = evaluateSem+instance Monad m => EvalBind (LoopM m) where evalBindSym = evalBindSymDefault+instance Sharable (LoopM m)+  -- Will not be shared anyway, because 'maybeWitnessSat' returns 'Nothing'++instance ExprEq   Loop where exprEq = exprEqSem; exprHash = exprHashSem+instance Render   Loop where renderPart = renderPartSem+instance ToTree   Loop+instance Eval     Loop where evaluate = evaluateSem+instance EvalBind Loop where evalBindSym = evalBindSymDefault+instance Sharable Loop++instance (AlphaEq dom dom dom env, Monad m) =>+    AlphaEq (LoopM m) (LoopM m) dom env+  where+    alphaEqSym = alphaEqSymDefault++instance AlphaEq dom dom dom env => AlphaEq Loop Loop dom env+  where+    alphaEqSym = alphaEqSymDefault++instance SizeProp (LoopM m)+  where+    sizeProp While _ = AnySize+    sizeProp For   _ = AnySize++instance SizeProp Loop+  where+    sizeProp ForLoop   (_ :* _ :* WrapFull step :* Nil) = infoSize step+    sizeProp WhileLoop (_ :* _ :* WrapFull step :* Nil) = infoSize step++++instance ( MonadType m+         , LoopM m :<: dom+         , Lambda TypeCtx :<: dom+         , WitnessCons (LoopM m)+         , MaybeWitnessSat TypeCtx dom+         , Optimize dom dom+         )+      => Optimize (LoopM m) dom+  where+    optimizeFeat for@For (len :* step :* Nil) = do+        len' <- optimizeM len+        let szI     = infoSize (getInfo len')+            ixRange = rangeByRange 0 (szI-1)+        step' <- optimizeFunction optimizeM (mkInfo ixRange) step+        case getInfo step' of+          Info{} -> constructFeat for (len' :* step' :* Nil)++    optimizeFeat a args = optimizeFeatDefault a args++    constructFeatUnOpt While args = constructFeatUnOptDefaultTyp voidTypeRep While args+    constructFeatUnOpt For   args = constructFeatUnOptDefaultTyp voidTypeRep For   args++instance ( Variable TypeCtx :<: dom+         , Lambda TypeCtx :<: dom+         , Loop :<: dom+         , Optimize dom dom+         , AlphaEq dom dom dom [(VarId, VarId)]+         )+      => Optimize Loop dom+  where+    optimizeFeat ForLoop (len :* init :* step :* Nil) = do+        len'  <- optimizeM len+        init' <- optimizeM init+        let szI     = infoSize (getInfo len')+            ixRange = Range 0 (upperBound szI-1)+        step' <- optimizeFunction+            (optimizeFunctionFix optimizeM (getInfo init'))+            (mkInfo ixRange)+            step+        constructFeat ForLoop (len' :* init' :* step' :* Nil)++    optimizeFeat WhileLoop (init :* cond :* body :* Nil) = do+        init' <- optimizeM init+        let info = getInfo init'+        body' <- optimizeFunctionFix optimizeM info body+        let info' = info { infoSize = infoSize (getInfo body') }+        cond' <- optimizeFunction optimizeM info' cond+        constructFeat WhileLoop (init' :* cond' :* body' :* Nil)++    constructFeatOpt ForLoop (len :* init :* step :* Nil)+        | Just 0 <- viewLiteral len = return init+        | Just 1 <- viewLiteral len = do+          let len' = stripDecor len -- TODO strip since betaReduce can't handle decorations+              init' = stripDecor init+              step' = stripDecor step+          optimizeM $ betaReduce typeCtx init' $ betaReduce typeCtx (appSymCtx typeCtx $ Literal 0) step'+        -- TODO add an optional unroll limit?++      -- ForLoop len init (const id) ==> init+    constructFeatOpt ForLoop (len :* init :* step :* Nil)+        | alphaEq step' (fun `asTypeOf` step') = optimizeM $ stripDecor init+      where+        step' = stripDecor step+        fun = appSymCtx typeCtx (Lambda 0) $ appSymCtx typeCtx (Lambda 1) $ appSymCtx typeCtx (Variable 1)++      -- TODO ForLoop len init (flip (const f)) ==> step (len - 1) init+      -- This optimization requires that the len > 0++    constructFeatOpt feat args = constructFeatUnOpt feat args++    constructFeatUnOpt = constructFeatUnOptDefault+
+ Feldspar/Core/Constructs/Mutable.hs view
@@ -0,0 +1,170 @@+--+-- Copyright (c) 2009-2011, 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 #-}++module Feldspar.Core.Constructs.Mutable+    ( module Feldspar.Core.Constructs.Mutable+    , module Language.Syntactic.Constructs.Monad+    )+where++import Data.Map+import Data.Typeable+import System.IO.Unsafe++import Data.Proxy++import Language.Syntactic+import Language.Syntactic.Interpretation.Semantics+import Language.Syntactic.Constructs.Binding+import Language.Syntactic.Constructs.Monad+import Language.Syntactic.Frontend.Monad++import Feldspar.Lattice+import Feldspar.Core.Types+import Feldspar.Core.Interpretation+import Feldspar.Core.Constructs.Binding++data Mutable a+  where+    Run :: Type a => Mutable (Mut a :-> Full a)++instance WitnessCons Mutable+  where+    witnessCons Run = ConsWit++instance WitnessSat Mutable+  where+    type SatContext Mutable = TypeCtx+    witnessSat Run = SatWit++instance MaybeWitnessSat TypeCtx Mutable+  where+    maybeWitnessSat = maybeWitnessSatDefault++instance Semantic Mutable+  where+    semantics Run = Sem "runMutable" unsafePerformIO++instance ExprEq   Mutable where exprEq = exprEqSem; exprHash = exprHashSem+instance Render   Mutable where renderPart = renderPartSem+instance ToTree   Mutable+instance Eval     Mutable where evaluate = evaluateSem+instance EvalBind Mutable where evalBindSym = evalBindSymDefault+instance Sharable Mutable+  -- Will not be shared anyway, because 'maybeWitnessSat' returns 'Nothing'++instance AlphaEq dom dom dom env => AlphaEq Mutable Mutable dom env+  where+    alphaEqSym = alphaEqSymDefault++instance Sharable (MONAD Mut)+  -- Will not be shared anyway, because 'maybeWitnessSat' returns 'Nothing'++instance SizeProp (MONAD Mut)+  where+    sizeProp Return (WrapFull a :* Nil)      = infoSize a+    sizeProp Bind   (_ :* WrapFull f :* Nil) = infoSize f+    sizeProp Then   (_ :* WrapFull b :* Nil) = infoSize b+    sizeProp When   _                        = AnySize++instance SizeProp Mutable+  where+    sizeProp Run (WrapFull a :* Nil) = infoSize a++monadProxy :: Proxy (Mut a)+monadProxy = Proxy++instance (MONAD Mut :<: dom, Optimize dom dom) => Optimize (MONAD Mut) dom+  where+    optimizeFeat bnd@Bind (ma :* f :* Nil) = do+        ma' <- optimizeM ma+        case getInfo ma' of+          Info (MutType ty) sz vs src -> do+            f' <- optimizeFunction optimizeM (Info ty sz vs src) f+            case getInfo f' of+              Info{} -> constructFeat bnd (ma' :* f' :* Nil)++    optimizeFeat a args = optimizeFeatDefault a args++    constructFeatOpt Bind (ma :* (lam :$ (Sym (Decor _ ret) :$ var)) :* Nil)+      | Just (_,Lambda v1)   <- prjDecorCtx typeCtx lam+      , Just Return          <- prjMonad monadProxy ret+      , Just (_,Variable v2) <- prjDecorCtx typeCtx var+      , v1 == v2+      , Just ma' <- gcast ma+      = return ma'++    constructFeatOpt Bind (ma :* (lam :$ body) :* Nil)+        | Just (_,Lambda v) <- prjDecorCtx typeCtx lam+        , v `notMember` vars+        = constructFeat Then (ma :* body :* Nil)+      where+        vars = infoVars $ getInfo body++      -- return x >> mb ==> mb+    constructFeatOpt Then ((Sym (Decor _ ret) :$ _) :* mb :* Nil)+        | Just Return <- prjMonad monadProxy ret+        = return mb++      -- ma >> return () ==> ma+    constructFeatOpt Then (ma :* (Sym (Decor info ret) :$ u) :* Nil)+        | Just Return <- prjMonad monadProxy ret+        , Just TypeEq <- typeEq (infoType $ getInfo ma) (MutType UnitType)+        , Just TypeEq <- typeEq (infoType $ info)       (MutType UnitType)+        , Just ()     <- viewLiteral u+        = return ma++    constructFeatOpt a args = constructFeatUnOpt a args++    constructFeatUnOpt Return args@(a :* Nil)+        | Info {infoType = t} <- getInfo a+        = constructFeatUnOptDefaultTyp (MutType t) Return args++    constructFeatUnOpt Bind args@(_ :* f :* Nil)+        | Info {infoType = FunType _ t} <- getInfo f+        = constructFeatUnOptDefaultTyp t Bind args+      -- TODO The match on `FunType` is total with the current definition of+      --      `TypeRep`, but there's no guarantee this will remain true in the+      --      future. One way around that would be to match `f` against+      --      `Lambda`, but that is also a partial match (at least possibly, in+      --      the future). Another option would be to add a context parameter to+      --      `MONAD` to be able to add the constraint `Type a`.++    constructFeatUnOpt Then args@(_ :* mb :* Nil)+        | Info {infoType = t} <- getInfo mb+        = constructFeatUnOptDefaultTyp t Then args++    constructFeatUnOpt When args =+        constructFeatUnOptDefaultTyp voidTypeRep When args++instance (Mutable :<: dom, Optimize dom dom) => Optimize Mutable dom+  where+    constructFeatUnOpt = constructFeatUnOptDefault+
+ Feldspar/Core/Constructs/MutableArray.hs view
@@ -0,0 +1,103 @@+--+-- Copyright (c) 2009-2011, 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 #-}++module Feldspar.Core.Constructs.MutableArray+where++import Control.Monad+import Data.Array.IO++import Language.Syntactic+import Language.Syntactic.Interpretation.Semantics+import Language.Syntactic.Constructs.Binding++import Feldspar.Lattice+import Feldspar.Core.Types+import Feldspar.Core.Interpretation++data MutableArray a+  where+    NewArr    :: Type a => MutableArray (Length :-> a :-> Full (Mut (MArr a)))+    NewArr_   :: Type a => MutableArray (Length :-> Full (Mut (MArr a)))+    GetArr    :: Type a => MutableArray (MArr a :-> Index :-> Full (Mut a))+    SetArr    :: MutableArray (MArr a :-> Index :-> a :-> Full (Mut ()))+    ArrLength :: MutableArray (MArr a :-> Full (Mut Length))+      -- TODO Should be pure?++instance WitnessCons MutableArray+  where+    witnessCons NewArr    = ConsWit+    witnessCons NewArr_   = ConsWit+    witnessCons GetArr    = ConsWit+    witnessCons SetArr    = ConsWit+    witnessCons ArrLength = ConsWit++instance MaybeWitnessSat ctx MutableArray+  where+    maybeWitnessSat _ _ = Nothing++instance Semantic MutableArray+  where+    semantics NewArr    = Sem "newMArr"   (\l -> newArray  (0,l-1))+    semantics NewArr_   = Sem "newMArr_"  (\l -> newArray_ (0,l-1))+    semantics GetArr    = Sem "getMArr"   readArray+    semantics SetArr    = Sem "setMArr"   writeArray+    semantics ArrLength = Sem "arrLength" (getBounds >=> \(l,u) -> return (u-l+1))++instance ExprEq   MutableArray where exprEq = exprEqSem; exprHash = exprHashSem+instance Render   MutableArray where renderPart = renderPartSem+instance ToTree   MutableArray+instance Eval     MutableArray where evaluate = evaluateSem+instance EvalBind MutableArray where evalBindSym = evalBindSymDefault+instance Sharable MutableArray+  -- Will not be shared anyway, because 'maybeWitnessSat' returns 'Nothing'++instance AlphaEq dom dom dom env => AlphaEq MutableArray MutableArray dom env+  where+    alphaEqSym = alphaEqSymDefault++instance SizeProp MutableArray+  where+    sizeProp NewArr  (WrapFull len :* a :* Nil) = infoSize len :> universal+    sizeProp NewArr_ (WrapFull len :* Nil)      = infoSize len :> universal+    sizeProp GetArr  _                          = universal+    sizeProp SetArr  _                          = universal+    sizeProp ArrLength (WrapFull arr :* Nil)    = len+      where+        len :> _ = infoSize arr++instance (MutableArray :<: dom, Optimize dom dom) => Optimize MutableArray dom+  where+    constructFeatUnOpt NewArr    args = constructFeatUnOptDefaultTyp (MutType $ MArrType typeRep) NewArr args+    constructFeatUnOpt NewArr_   args = constructFeatUnOptDefaultTyp (MutType $ MArrType typeRep) NewArr_ args+    constructFeatUnOpt GetArr    args = constructFeatUnOptDefaultTyp (MutType typeRep) GetArr args+    constructFeatUnOpt SetArr    args = constructFeatUnOptDefaultTyp (MutType typeRep) SetArr args+    constructFeatUnOpt ArrLength args = constructFeatUnOptDefaultTyp (MutType typeRep) ArrLength args+
+ Feldspar/Core/Constructs/MutableReference.hs view
@@ -0,0 +1,91 @@+--+-- Copyright (c) 2009-2011, 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 #-}++module Feldspar.Core.Constructs.MutableReference+where++import Data.IORef++import Language.Syntactic+import Language.Syntactic.Interpretation.Semantics+import Language.Syntactic.Constructs.Binding++import Feldspar.Lattice+import Feldspar.Core.Types+import Feldspar.Core.Interpretation++data MutableReference a+  where+    NewRef :: Type a => MutableReference (a :-> Full (Mut (IORef a)))+    GetRef :: Type a => MutableReference (IORef a :-> Full (Mut a))+    SetRef :: Type a => MutableReference (IORef a :-> a :-> Full (Mut ()))++instance WitnessCons MutableReference+  where+    witnessCons NewRef = ConsWit+    witnessCons GetRef = ConsWit+    witnessCons SetRef = ConsWit++instance MaybeWitnessSat ctx MutableReference+  where+    maybeWitnessSat _ _ = Nothing++instance Semantic MutableReference+  where+    semantics NewRef = Sem "newRef" newIORef+    semantics GetRef = Sem "getRef" readIORef+    semantics SetRef = Sem "setRef" writeIORef++instance ExprEq   MutableReference where exprEq = exprEqSem; exprHash = exprHashSem+instance Render   MutableReference where renderPart = renderPartSem+instance ToTree   MutableReference+instance Eval     MutableReference where evaluate = evaluateSem+instance EvalBind MutableReference where evalBindSym = evalBindSymDefault+instance Sharable MutableReference+  -- Will not be shared anyway, because 'maybeWitnessSat' returns 'Nothing'++instance AlphaEq dom dom dom env =>+    AlphaEq MutableReference MutableReference dom env+  where+    alphaEqSym = alphaEqSymDefault++instance SizeProp MutableReference+  where+    sizeProp NewRef _ = universal+    sizeProp GetRef _ = universal+    sizeProp SetRef _ = universal++instance (MutableReference :<: dom, Optimize dom dom) =>+    Optimize MutableReference dom+  where+    constructFeatUnOpt NewRef args = constructFeatUnOptDefaultTyp (MutType $ RefType typeRep) NewRef args+    constructFeatUnOpt GetRef args = constructFeatUnOptDefaultTyp (MutType typeRep) GetRef args+    constructFeatUnOpt SetRef args = constructFeatUnOptDefaultTyp (MutType typeRep) SetRef args+
+ Feldspar/Core/Constructs/MutableToPure.hs view
@@ -0,0 +1,98 @@+--+-- Copyright (c) 2009-2011, 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 #-}++module Feldspar.Core.Constructs.MutableToPure+    ( MutableToPure (..)+    ) where++import qualified Control.Exception as C+import Data.Array.MArray+import Data.Array.IArray+import System.IO.Unsafe++import Language.Syntactic+import Language.Syntactic.Interpretation.Semantics+import Language.Syntactic.Constructs.Binding++import Feldspar.Lattice+import Feldspar.Core.Types+import Feldspar.Core.Interpretation++data MutableToPure a where+  RunMutableArray :: Type a => MutableToPure (Mut (MArr a) :-> Full [a])+  WithArray       :: Type b => MutableToPure (MArr a :-> ([a] -> Mut b) :-> Full (Mut b))++instance WitnessCons MutableToPure+  where+    witnessCons RunMutableArray = ConsWit+    witnessCons WithArray       = ConsWit++instance MaybeWitnessSat TypeCtx MutableToPure+  where+    maybeWitnessSat _ RunMutableArray = Just SatWit+    maybeWitnessSat _ _               = Nothing++instance Semantic MutableToPure+  where+    semantics RunMutableArray = Sem "runMutableArray" runMutableArrayEval+    semantics WithArray       = Sem "withArray"       withArrayEval++runMutableArrayEval :: forall i a . Mut (MArr a) -> [a]+runMutableArrayEval m = unsafePerformIO $+                        do marr <- m+                           iarr <- unsafeFreeze marr+                           return (elems (iarr :: Array WordN a))++withArrayEval :: forall i a b. MArr a -> ([a] -> Mut b) -> Mut b+withArrayEval ma f+    = do a <- f (elems (unsafePerformIO $ freeze ma :: Array WordN a))+         C.evaluate a++instance ExprEq   MutableToPure where exprEq = exprEqSem; exprHash = exprHashSem+instance Render   MutableToPure where renderPart = renderPartSem+instance ToTree   MutableToPure+instance Eval     MutableToPure where evaluate = evaluateSem+instance EvalBind MutableToPure where evalBindSym = evalBindSymDefault+instance Sharable MutableToPure++instance AlphaEq dom dom dom env => AlphaEq MutableToPure MutableToPure dom env+  where+    alphaEqSym = alphaEqSymDefault++instance SizeProp MutableToPure+  where+    sizeProp RunMutableArray _ = universal+    sizeProp WithArray       _ = universal++instance (MutableToPure :<: dom, Optimize dom dom) => Optimize MutableToPure dom+  where+    constructFeatUnOpt RunMutableArray args = constructFeatUnOptDefaultTyp typeRep RunMutableArray args+    constructFeatUnOpt WithArray args       = constructFeatUnOptDefaultTyp (MutType typeRep) WithArray args+
+ Feldspar/Core/Constructs/Num.hs view
@@ -0,0 +1,218 @@+--+-- Copyright (c) 2009-2011, 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 #-}++module Feldspar.Core.Constructs.Num+    ( NUM (..)+    ) where++++import Language.Syntactic+import Language.Syntactic.Interpretation.Semantics+import Language.Syntactic.Constructs.Binding++import Feldspar.Range+import Feldspar.Core.Types+import Feldspar.Core.Interpretation++++data NUM a+  where+    Abs  :: (Type a, Num a, Num (Size a)) => NUM (a :-> Full a)+    Sign :: (Type a, Num a, Num (Size a)) => NUM (a :-> Full a)+    Add  :: (Type a, Num a, Num (Size a)) => NUM (a :-> a :-> Full a)+    Sub  :: (Type a, Num a, Num (Size a)) => NUM (a :-> a :-> Full a)+    Mul  :: (Type a, Num a, Num (Size a)) => NUM (a :-> a :-> Full a)++instance WitnessCons NUM+  where+    witnessCons Abs  = ConsWit+    witnessCons Sign = ConsWit+    witnessCons Add  = ConsWit+    witnessCons Sub  = ConsWit+    witnessCons Mul  = ConsWit++instance WitnessSat NUM+  where+    type SatContext NUM = TypeCtx+    witnessSat Abs  = SatWit+    witnessSat Sign = SatWit+    witnessSat Add  = SatWit+    witnessSat Sub  = SatWit+    witnessSat Mul  = SatWit++instance MaybeWitnessSat TypeCtx NUM+  where+    maybeWitnessSat = maybeWitnessSatDefault++instance Semantic NUM+  where+    semantics Abs  = Sem "abs" abs+    semantics Sign = Sem "signum" signum+    semantics Add  = Sem "(+)" (+)+    semantics Sub  = Sem "(-)" (-)+    semantics Mul  = Sem "(*)" (*)++instance ExprEq   NUM where exprEq = exprEqSem; exprHash = exprHashSem+instance Render   NUM where renderPart = renderPartSem+instance ToTree   NUM+instance Eval     NUM where evaluate = evaluateSem+instance EvalBind NUM where evalBindSym = evalBindSymDefault+instance Sharable NUM++instance AlphaEq dom dom dom env => AlphaEq NUM NUM dom env+  where+    alphaEqSym = alphaEqSymDefault++instance SizeProp NUM+  where+    sizeProp Abs  (WrapFull a :* Nil)               = abs (infoSize a)+    sizeProp Sign (WrapFull a :* Nil)               = signum (infoSize a)+    sizeProp Add  (WrapFull a :* WrapFull b :* Nil) = infoSize a + infoSize b+    sizeProp Sub  (WrapFull a :* WrapFull b :* Nil) = infoSize a - infoSize b+    sizeProp Mul  (WrapFull a :* WrapFull b :* Nil) = infoSize a * infoSize b++++instance (NUM :<: dom, Optimize dom dom) => Optimize NUM dom+  where+    constructFeatOpt Abs (a :* Nil)+        | RangeSet r <- infoRange (getInfo a)+        , isNatural r+        = return a++    constructFeatOpt Sign (a :* Nil)+        | RangeSet ra <- infoRange (getInfo a)+        , 0 `rangeLess` ra+        = return (literalDecor 1)++    constructFeatOpt Sign (a :* Nil)+        | RangeSet ra <- infoRange (getInfo a)+        , ra `rangeLess` 0+        = return (literalDecor (-1))++    constructFeatOpt Add (a :* b :* Nil)+        | Just 0 <- viewLiteral b = return a+        | Just 0 <- viewLiteral a = return b++    constructFeatOpt Add (a :* (op :$ b :$ c) :* Nil)+        | Just a'      <- viewLiteral a+        , Just (_,Add) <- prjDecor op+        , Just c'      <- viewLiteral c+        = constructFeat Add (b :* literalDecor (a'+c') :* Nil)++    constructFeatOpt Add (a :* (op :$ b :$ c) :* Nil)+        | Just a'      <- viewLiteral a+        , Just (_,Sub) <- prjDecor op+        , Just c'      <- viewLiteral c+        = constructFeat Add (b :* literalDecor (a'-c') :* Nil)++    constructFeatOpt Add ((op :$ a :$ b) :* c :* Nil)+        | Just c'      <- viewLiteral c+        , Just (_,Add) <- prjDecor op+        , Just b'      <- viewLiteral b+        = constructFeat Add (a :* literalDecor (b'+c') :* Nil)++    constructFeatOpt Add ((op :$ a :$ b) :* c :* Nil)+        | Just c'      <- viewLiteral c+        , Just (_,Sub) <- prjDecor op+        , Just b'      <- viewLiteral b+        = constructFeat Add (a :* literalDecor (c'-b') :* Nil)++    constructFeatOpt Add ((op1 :$ a :$ b) :* (op2 :$ c :$ d) :* Nil)+        | Just (_,Add) <- prjDecor op1+        , Just (_,Add) <- prjDecor op2+        , Just b'      <- viewLiteral b+        , Just d'      <- viewLiteral d+        = do+            ac <- constructFeat Add (a :* c :* Nil)+            constructFeat Add (ac :* literalDecor (b'+d') :* Nil)++    constructFeatOpt Sub (a :* b :* Nil)+        | Just 0 <- viewLiteral b = return a+        | alphaEq a b             = return $ literalDecor 0++    constructFeatOpt Mul (a :* b :* Nil)+        | Just 0 <- viewLiteral a = return a+        | Just 1 <- viewLiteral a = return b+        | Just 0 <- viewLiteral b = return b+        | Just 1 <- viewLiteral b = return a++    constructFeatOpt Mul (a :* (op :$ b :$ c) :* Nil)+        | Just a'      <- viewLiteral a+        , Just (_,Mul) <- prjDecor op+        , Just c'      <- viewLiteral c+        = constructFeat Mul (b :* literalDecor (a'*c') :* Nil)++    constructFeatOpt Mul ((op :$ a :$ b) :* c :* Nil)+        | Just c'      <- viewLiteral c+        , Just (_,Mul) <- prjDecor op+        , Just b'      <- viewLiteral b+        = constructFeat Mul (a :* literalDecor (b'*c') :* Nil)++    constructFeatOpt Mul ((op1 :$ a :$ b) :* (op2 :$ c :$ d) :* Nil)+        | Just (_,Mul) <- prjDecor op1+        , Just (_,Mul) <- prjDecor op2+        , Just b'      <- viewLiteral b+        , Just d'      <- viewLiteral d+        = do+            ac <- constructFeat Mul (a :* c :* Nil)+            constructFeat Mul (ac :* literalDecor (b'*d') :* Nil)++    -- Cases to make sure literals end up to the right:+    constructFeatOpt Add (a :* b :* Nil)+        | Just a' <- viewLiteral a = constructFeatUnOpt Add (b :* a :* Nil)++    constructFeatOpt Mul (a :* b :* Nil)+        | Just a' <- viewLiteral a = constructFeatUnOpt Mul (b :* a :* Nil)++    constructFeatOpt a args = constructFeatUnOpt a args++    constructFeatUnOpt = constructFeatUnOptDefault++-- TODO Improve algebraic simplification+--+-- The current implementation is quite incomplete and it only deals with merging+-- literals, so it can't cancel out variables; e.g.+--+--     (x+x)-x  ===>  x+--+-- It would be better to optimize a whole arithmetic expression at once. Gather+-- all variables in one list, all literals in one list and all non-arithmetic+-- sub-terms in one list. Then make a new optimized  expression by combining the+-- three lists.+--+-- However, doing this compositionally will probably lead to a lot of+-- re-traversals of the same sub-terms, so the optimization framework will+-- probably have to be modified so that arithmetic optimization only happens at+-- feasible places (i.e. arithmetic sub-terms whose parents are not arithmetic+-- expressions).+
+ Feldspar/Core/Constructs/Ord.hs view
@@ -0,0 +1,205 @@+--+-- Copyright (c) 2009-2011, 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 #-}++module Feldspar.Core.Constructs.Ord+    ( ORD (..)+    ) where++++import Language.Syntactic+import Language.Syntactic.Interpretation.Semantics+import Language.Syntactic.Constructs.Binding++import Feldspar.Range+import Feldspar.Core.Types+import Feldspar.Core.Interpretation++++data ORD a+  where+    LTH :: (Type a, Ord a, Ord (Size a)) => ORD (a :-> a :-> Full Bool)+    GTH :: (Type a, Ord a, Ord (Size a)) => ORD (a :-> a :-> Full Bool)+    LTE :: (Type a, Ord a, Ord (Size a)) => ORD (a :-> a :-> Full Bool)+    GTE :: (Type a, Ord a, Ord (Size a)) => ORD (a :-> a :-> Full Bool)+    Min :: (Type a, Ord a, Ord (Size a)) => ORD (a :-> a :-> Full a)+    Max :: (Type a, Ord a, Ord (Size a)) => ORD (a :-> a :-> Full a)++instance WitnessCons ORD+  where+    witnessCons LTH  = ConsWit+    witnessCons GTH = ConsWit+    witnessCons LTE = ConsWit+    witnessCons GTE = ConsWit+    witnessCons Min = ConsWit+    witnessCons Max = ConsWit++instance WitnessSat ORD+  where+    type SatContext ORD = TypeCtx+    witnessSat LTH  = SatWit+    witnessSat GTH = SatWit+    witnessSat LTE = SatWit+    witnessSat GTE = SatWit+    witnessSat Min = SatWit+    witnessSat Max = SatWit++instance MaybeWitnessSat TypeCtx ORD+  where+    maybeWitnessSat = maybeWitnessSatDefault++instance Semantic ORD+  where+    semantics LTH = Sem "(<)"  (<)+    semantics GTH = Sem "(>)"  (>)+    semantics LTE = Sem "(<=)" (<=)+    semantics GTE = Sem "(>=)" (>=)+    semantics Min = Sem "min"  min+    semantics Max = Sem "max"  max++instance ExprEq   ORD where exprEq = exprEqSem; exprHash = exprHashSem+instance Render   ORD where renderPart = renderPartSem+instance ToTree   ORD+instance Eval     ORD where evaluate = evaluateSem+instance EvalBind ORD where evalBindSym = evalBindSymDefault+instance Sharable ORD++instance AlphaEq dom dom dom env => AlphaEq ORD ORD dom env+  where+    alphaEqSym = alphaEqSymDefault++instance SizeProp ORD+  where+    sizeProp Min (WrapFull a :* WrapFull b :* Nil) = min (infoSize a) (infoSize b)+    sizeProp Max (WrapFull a :* WrapFull b :* Nil) = max (infoSize a) (infoSize b)+    sizeProp a args = sizePropDefault a args++++instance+    ( ORD :<: dom+    , MaybeWitnessSat TypeCtx dom+    , Optimize dom dom+    ) =>+      Optimize ORD dom+  where+    constructFeatOpt LTH (a :* b :* Nil)+        | RangeSet ra <- infoRange (getInfo a)+        , RangeSet rb <- infoRange (getInfo b)+        , ra `rangeLess` rb+        = return (literalDecor True)++    constructFeatOpt LTH (a :* b :* Nil)+        | RangeSet ra <- infoRange (getInfo a)+        , RangeSet rb <- infoRange (getInfo b)+        , rb `rangeLessEq` ra+        = return (literalDecor False)++    constructFeatOpt GTH (a :* b :* Nil)+        | RangeSet ra <- infoRange (getInfo a)+        , RangeSet rb <- infoRange (getInfo b)+        , rb `rangeLess` ra+        = return (literalDecor True)++    constructFeatOpt GTH (a :* b :* Nil)+        | RangeSet ra <- infoRange (getInfo a)+        , RangeSet rb <- infoRange (getInfo b)+        , ra `rangeLessEq` rb+        = return (literalDecor False)++    constructFeatOpt LTE (a :* b :* Nil)+        | RangeSet ra <- infoRange (getInfo a)+        , RangeSet rb <- infoRange (getInfo b)+        , ra `rangeLessEq` rb+        = return (literalDecor True)++    constructFeatOpt LTE (a :* b :* Nil)+        | RangeSet ra <- infoRange (getInfo a)+        , RangeSet rb <- infoRange (getInfo b)+        , rb `rangeLess` ra+        = return (literalDecor False)++    constructFeatOpt LTE (a :* b :* Nil)+        | alphaEq a b+        = return $ literalDecor True++    constructFeatOpt GTE (a :* b :* Nil)+        | RangeSet ra <- infoRange (getInfo a)+        , RangeSet rb <- infoRange (getInfo b)+        , rb `rangeLessEq` ra+        = return (literalDecor True)++    constructFeatOpt GTE (a :* b :* Nil)+        | RangeSet ra <- infoRange (getInfo a)+        , RangeSet rb <- infoRange (getInfo b)+        , ra `rangeLess` rb+        = return (literalDecor False)++    constructFeatOpt GTE (a :* b :* Nil)+        | alphaEq a b+        = return $ literalDecor True++    constructFeatOpt Min (a :* b :* Nil)+        | RangeSet ra <- infoRange (getInfo a)+        , RangeSet rb <- infoRange (getInfo b)+        , ra `rangeLessEq` rb+        = return a++    constructFeatOpt Min (a :* b :* Nil)+        | RangeSet ra <- infoRange (getInfo a)+        , RangeSet rb <- infoRange (getInfo b)+        , rb `rangeLessEq` ra+        = return b++    constructFeatOpt Min (a :* b :* Nil)+        | alphaEq a b+        = return a++    constructFeatOpt Max (a :* b :* Nil)+        | RangeSet ra <- infoRange (getInfo a)+        , RangeSet rb <- infoRange (getInfo b)+        , ra `rangeLessEq` rb+        = return b++    constructFeatOpt Max (a :* b :* Nil)+        | RangeSet ra <- infoRange (getInfo a)+        , RangeSet rb <- infoRange (getInfo b)+        , rb `rangeLessEq` ra+        = return a++    constructFeatOpt Max (a :* b :* Nil)+        | alphaEq a b+        = return a++    constructFeatOpt a args = constructFeatUnOpt a args++    constructFeatUnOpt = constructFeatUnOptDefault+
+ Feldspar/Core/Constructs/Par.hs view
@@ -0,0 +1,196 @@+--+-- Copyright (c) 2009-2011, 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 #-}++module Feldspar.Core.Constructs.Par where++import Language.Syntactic+import Language.Syntactic.Interpretation.Semantics+import Language.Syntactic.Constructs.Binding+import Language.Syntactic.Constructs.Binding.HigherOrder+import Language.Syntactic.Constructs.Monad++import qualified Control.Monad.Par as CMP+import qualified Control.Monad.Par.Internal as CMP++import Feldspar.Lattice+import Feldspar.Core.Types+import Feldspar.Core.Interpretation+import Feldspar.Core.Constructs.Binding++import Data.Map+import Data.Proxy+import Data.Typeable++data ParFeature a+  where+    ParRun    :: Type a => ParFeature (Par a :-> Full a)+    ParNew    :: Type a => ParFeature (Full (Par (IV a)))+    ParGet    :: Type a => ParFeature (IV a :-> Full (Par a))+    ParPut    :: Type a => ParFeature (IV a :-> a :-> Full (Par ()))+    ParFork   ::           ParFeature (Par () :-> Full (Par ()))+    ParYield  ::           ParFeature (Full (Par ()))++instance Semantic ParFeature+  where+    semantics ParRun    = Sem "runPar" CMP.runPar+    semantics ParNew    = Sem "new" CMP.new+    semantics ParGet    = Sem "get" CMP.get+    semantics ParPut    = Sem "put" CMP.put_+    semantics ParFork   = Sem "fork" CMP.fork+    semantics ParYield  = Sem "yield" CMP.yield++instance ExprEq   ParFeature where exprEq = exprEqSem; exprHash = exprHashSem+instance Render   ParFeature where renderPart = renderPartSem+instance ToTree   ParFeature+instance Eval     ParFeature where evaluate = evaluateSem+instance EvalBind ParFeature where evalBindSym = evalBindSymDefault+instance Sharable ParFeature+  -- Will not be shared anyway, because 'maybeWitnessSat' returns 'Nothing'++instance WitnessCons ParFeature+  where+    witnessCons ParRun   = ConsWit+    witnessCons ParNew   = ConsWit+    witnessCons ParGet   = ConsWit+    witnessCons ParPut   = ConsWit+    witnessCons ParFork  = ConsWit+    witnessCons ParYield = ConsWit++instance WitnessSat ParFeature+  where+    type SatContext ParFeature = TypeCtx+    witnessSat ParRun = SatWit++instance MaybeWitnessSat ctx ParFeature+  where+    maybeWitnessSat _ _ = Nothing++instance AlphaEq dom dom dom env => AlphaEq ParFeature ParFeature dom env+  where+    alphaEqSym = alphaEqSymDefault++instance Sharable (MONAD Par)+  -- Will not be shared anyway, because 'maybeWitnessSat' returns 'Nothing'++instance SizeProp ParFeature+  where+    sizeProp ParRun   (WrapFull a :* Nil) = infoSize a+    sizeProp ParNew   _                   = universal+    sizeProp ParGet   _                   = universal+    sizeProp ParPut   _                   = universal+    sizeProp ParFork  _                   = universal+    sizeProp ParYield _                   = universal++instance ( MONAD Par :<: dom+         , ParFeature :<: dom+         , Optimize dom dom+         )+      => Optimize ParFeature dom+  where+    constructFeatUnOpt ParRun args   = constructFeatUnOptDefault ParRun args+    constructFeatUnOpt ParNew args   = constructFeatUnOptDefaultTyp (ParType $ IVarType typeRep) ParNew args+    constructFeatUnOpt ParGet args   = constructFeatUnOptDefaultTyp (ParType typeRep) ParGet args+    constructFeatUnOpt ParPut args   = constructFeatUnOptDefaultTyp (ParType typeRep) ParPut args+    constructFeatUnOpt ParFork args  = constructFeatUnOptDefaultTyp (ParType typeRep) ParFork args+    constructFeatUnOpt ParYield args = constructFeatUnOptDefaultTyp (ParType typeRep) ParYield args++monadProxy :: Proxy (Par a)+monadProxy = Proxy++instance SizeProp (MONAD Par)+  where+    sizeProp Return (WrapFull a :* Nil)      = infoSize a+    sizeProp Bind   (_ :* WrapFull f :* Nil) = infoSize f+    sizeProp Then   (_ :* WrapFull b :* Nil) = infoSize b+    sizeProp When   _                        = AnySize++instance (MONAD Par :<: dom, Optimize dom dom) => Optimize (MONAD Par) dom+  where+    optimizeFeat bnd@Bind (ma :* f :* Nil) = do+        ma' <- optimizeM ma+        case getInfo ma' of+          Info (ParType ty) sz vs src -> do+            f' <- optimizeFunction optimizeM (Info ty sz vs src) f+            case getInfo f' of+              Info{} -> constructFeat bnd (ma' :* f' :* Nil)++    optimizeFeat a args = optimizeFeatDefault a args++    constructFeatOpt Bind (ma :* (lam :$ (Sym (Decor _ ret) :$ var)) :* Nil)+      | Just (_,Lambda v1)   <- prjDecorCtx typeCtx lam+      , Just Return          <- prjMonad monadProxy ret+      , Just (_,Variable v2) <- prjDecorCtx typeCtx var+      , v1 == v2+      , Just ma' <- gcast ma+      = return ma'++    constructFeatOpt Bind (ma :* (lam :$ body) :* Nil)+        | Just (_,Lambda v) <- prjDecorCtx typeCtx lam+        , v `notMember` vars+        = constructFeat Then (ma :* body :* Nil)+      where+        vars = infoVars $ getInfo body++      -- return x >> mb ==> mb+    constructFeatOpt Then ((Sym (Decor _ ret) :$ _) :* mb :* Nil)+        | Just Return <- prjMonad monadProxy ret+        = return mb++      -- ma >> return () ==> ma+    constructFeatOpt Then (ma :* (Sym (Decor info ret) :$ u) :* Nil)+        | Just Return <- prjMonad monadProxy ret+        , Just TypeEq <- typeEq (infoType $ getInfo ma) (ParType UnitType)+        , Just TypeEq <- typeEq (infoType $ info)       (ParType UnitType)+        , Just ()     <- viewLiteral u+        = return ma++    constructFeatOpt a args = constructFeatUnOpt a args++    constructFeatUnOpt Return args@(a :* Nil)+        | Info {infoType = t} <- getInfo a+        = constructFeatUnOptDefaultTyp (ParType t) Return args++    constructFeatUnOpt Bind args@(_ :* f :* Nil)+        | Info {infoType = FunType _ t} <- getInfo f+        = constructFeatUnOptDefaultTyp t Bind args+      -- TODO The match on `FunType` is total with the current definition of+      --      `TypeRep`, but there's no guarantee this will remain true in the+      --      future. One way around that would be to match `f` against+      --      `Lambda`, but that is also a partial match (at least possibly, in+      --      the future). Another option would be to add a context parameter to+      --      `MONAD` to be able to add the constraint `Type a`.++    constructFeatUnOpt Then args@(_ :* mb :* Nil)+        | Info {infoType = t} <- getInfo mb+        = constructFeatUnOptDefaultTyp t Then args++    constructFeatUnOpt When args =+        constructFeatUnOptDefaultTyp voidTypeRep When args+
+ Feldspar/Core/Constructs/Save.hs view
@@ -0,0 +1,83 @@+--+-- Copyright (c) 2009-2011, 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 #-}++module Feldspar.Core.Constructs.Save where++++import Language.Syntactic+import Language.Syntactic.Interpretation.Semantics+import Language.Syntactic.Constructs.Binding++import Feldspar.Core.Types+import Feldspar.Core.Interpretation++++data Save a+  where+    Save :: Type a => Save (a :-> Full a)++instance WitnessCons Save+  where+    witnessCons Save = ConsWit++instance WitnessSat Save+  where+    type SatContext Save = TypeCtx+    witnessSat Save = SatWit++instance MaybeWitnessSat TypeCtx Save+  where+    maybeWitnessSat = maybeWitnessSatDefault++instance Semantic Save+  where+    semantics Save = Sem "save" id++instance ExprEq   Save where exprEq = exprEqSem; exprHash = exprHashSem+instance Render   Save where renderPart = renderPartSem+instance ToTree   Save+instance Eval     Save where evaluate = evaluateSem+instance EvalBind Save where evalBindSym = evalBindSymDefault+instance Sharable Save++instance AlphaEq dom dom dom env => AlphaEq Save Save dom env+  where+    alphaEqSym = alphaEqSymDefault++instance SizeProp Save+  where+    sizeProp Save (WrapFull a :* Nil) = infoSize a++instance (Save :<: dom, Optimize dom dom) => Optimize Save dom+  where+    constructFeatUnOpt = constructFeatUnOptDefault+
+ Feldspar/Core/Constructs/SizeProp.hs view
@@ -0,0 +1,93 @@+--+-- Copyright (c) 2009-2011, 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 #-}++module Feldspar.Core.Constructs.SizeProp where++++import Language.Syntactic+import Language.Syntactic.Interpretation.Semantics+import Language.Syntactic.Constructs.Binding+import Language.Syntactic.Constructs.Literal++import Feldspar.Lattice+import Feldspar.Core.Types+import Feldspar.Core.Interpretation++++data PropSize a+  where+    PropSize :: (Type a, Type b) =>+        (Size a -> Size b) -> PropSize (a :-> b :-> Full b)++instance WitnessCons PropSize+  where+    witnessCons (PropSize _) = ConsWit++instance WitnessSat PropSize+  where+    type SatContext PropSize = TypeCtx+    witnessSat (PropSize _)  = SatWit++instance MaybeWitnessSat TypeCtx PropSize+  where+    maybeWitnessSat = maybeWitnessSatDefault++instance Semantic PropSize+  where+    semantics (PropSize _) = Sem "propSize" (const id)++instance ExprEq   PropSize where exprEq = exprEqSem; exprHash = exprHashSem+instance Render   PropSize where renderPart = renderPartSem+instance ToTree   PropSize+instance Eval     PropSize where evaluate = evaluateSem+instance EvalBind PropSize where evalBindSym = evalBindSymDefault+instance Sharable PropSize++instance SizeProp PropSize+  where+    sizeProp (PropSize prop) (WrapFull a :* WrapFull b :* Nil) =+        prop (infoSize a) /\ infoSize b++instance AlphaEq dom dom dom env => AlphaEq PropSize PropSize dom env+  where+    alphaEqSym = alphaEqSymDefault++instance (PropSize :<: dom, Optimize dom dom) => Optimize PropSize dom+  where+    constructFeatOpt (PropSize prop) (a :* b :* Nil) =+        return $ updateDecor (f (prop (infoSize $ getInfo a))) b+      where+        f :: Lattice (Size b) => Size b -> Info b -> Info b+        f newSize info = info {infoSize = infoSize info /\ newSize}++    constructFeatUnOpt = constructFeatUnOptDefault+
+ Feldspar/Core/Constructs/SourceInfo.hs view
@@ -0,0 +1,81 @@+--+-- Copyright (c) 2009-2011, 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 #-}++module Feldspar.Core.Constructs.SourceInfo+    ( module Language.Syntactic.Constructs.Identity+    , module Language.Syntactic.Constructs.Decoration+    , SourceInfo1 (..)+    ) where+++import Language.Syntactic+import Language.Syntactic.Constructs.Binding+import Language.Syntactic.Constructs.Decoration+import Language.Syntactic.Constructs.Identity++import Feldspar.Core.Types+import Feldspar.Core.Interpretation++++-- | Kind @* -> *@ version of 'SourceInfo'+data SourceInfo1 a = SourceInfo1 SourceInfo++instance AlphaEq dom dom dom env =>+    AlphaEq+        (Decor SourceInfo1 (Identity TypeCtx))+        (Decor SourceInfo1 (Identity TypeCtx))+        dom+        env+  where+    alphaEqSym = alphaEqSymDefault++instance Sharable (Decor SourceInfo1 (Identity TypeCtx))+  where+    sharable _ = True++instance SizeProp (Identity TypeCtx)+  where+    sizeProp Id (WrapFull a :* Nil) = infoSize a++instance SizeProp (Decor SourceInfo1 (Identity TypeCtx))+  where+    sizeProp = sizeProp . decorExpr++instance (Decor SourceInfo1 (Identity TypeCtx) :<: dom, Optimize dom dom) =>+    Optimize (Decor SourceInfo1 (Identity TypeCtx)) dom+  where+    optimizeFeat (Decor (SourceInfo1 src) Id) (a :* Nil) =+        localSource src $ optimizeM a++    constructFeatOpt (Decor (SourceInfo1 src) Id) (a :* Nil) = return a++    constructFeatUnOpt = constructFeatUnOptDefault+
+ Feldspar/Core/Constructs/Trace.hs view
@@ -0,0 +1,90 @@+--+-- Copyright (c) 2009-2011, 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 #-}++module Feldspar.Core.Constructs.Trace+    ( Trace (..)+    ) where++++import Language.Syntactic+import Language.Syntactic.Interpretation.Semantics+import Language.Syntactic.Constructs.Binding++import Feldspar.Core.Types+import Feldspar.Core.Interpretation++import Debug.Trace++data Trace a+  where+    Trace :: Type a => Trace (IntN :-> a :-> Full a)+  -- TODO Seems a more suitable definition might be+  --+  --          Trace :: Type a => IntN -> Trace (a :-> Full a)+  --+  --      since the front-end function will always make a literal for the label.++instance WitnessCons Trace+  where+    witnessCons Trace = ConsWit++instance WitnessSat Trace+  where+    type SatContext Trace = TypeCtx+    witnessSat Trace = SatWit++instance MaybeWitnessSat TypeCtx Trace+  where+    maybeWitnessSat = maybeWitnessSatDefault++instance Semantic Trace+  where+    semantics Trace = Sem "trace" (\i a -> trace (show i ++ ":" ++ show a) a)++instance ExprEq   Trace where exprEq = exprEqSem; exprHash = exprHashSem+instance Render   Trace where renderPart = renderPartSem+instance ToTree   Trace+instance Eval     Trace where evaluate = evaluateSem+instance EvalBind Trace where evalBindSym = evalBindSymDefault+instance Sharable Trace++instance AlphaEq dom dom dom env => AlphaEq Trace Trace dom env+  where+    alphaEqSym = alphaEqSymDefault++instance SizeProp Trace+  where+    sizeProp Trace (WrapFull _ :* WrapFull a :* Nil) = infoSize a++instance (Trace :<: dom, Optimize dom dom) => Optimize Trace dom+  where+    constructFeatUnOpt = constructFeatUnOptDefault+
+ Feldspar/Core/Constructs/Tuple.hs view
@@ -0,0 +1,326 @@+--+-- Copyright (c) 2009-2011, 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 #-}++module Feldspar.Core.Constructs.Tuple+    ( module Language.Syntactic.Constructs.Tuple+    ) where+++import Data.Maybe+import Data.Typeable (gcast)+import Data.Tuple.Select++import Language.Syntactic+import Language.Syntactic.Constructs.Binding+import Language.Syntactic.Constructs.Tuple++import Feldspar.Core.Types+import Feldspar.Core.Interpretation++++instance Sharable (Tuple TypeCtx)++instance SizeProp (Tuple TypeCtx)+  where+    sizeProp tup@Tup2 (a :* b :* Nil)+        | WrapFull ia <- a+        , WrapFull ib <- b+        = (infoSize ia, infoSize ib)+    sizeProp tup@Tup3 (a :* b :* c :* Nil)+        | WrapFull ia <- a+        , WrapFull ib <- b+        , WrapFull ic <- c+        = ( infoSize ia+          , infoSize ib+          , infoSize ic+          )+    sizeProp tup@Tup4 (a :* b :* c :* d :* Nil)+        | WrapFull ia <- a+        , WrapFull ib <- b+        , WrapFull ic <- c+        , WrapFull id <- d+        = ( infoSize ia+          , infoSize ib+          , infoSize ic+          , infoSize id+          )+    sizeProp tup@Tup5 (a :* b :* c :* d :* e :* Nil)+        | WrapFull ia <- a+        , WrapFull ib <- b+        , WrapFull ic <- c+        , WrapFull id <- d+        , WrapFull ie <- e+        = ( infoSize ia+          , infoSize ib+          , infoSize ic+          , infoSize id+          , infoSize ie+          )+    sizeProp tup@Tup6 (a :* b :* c :* d :* e :* g :* Nil)+        | WrapFull ia <- a+        , WrapFull ib <- b+        , WrapFull ic <- c+        , WrapFull id <- d+        , WrapFull ie <- e+        , WrapFull ig <- g+        = ( infoSize ia+          , infoSize ib+          , infoSize ic+          , infoSize id+          , infoSize ie+          , infoSize ig+          )+    sizeProp tup@Tup7 (a :* b :* c :* d :* e :* g :* h :* Nil)+        | WrapFull ia <- a+        , WrapFull ib <- b+        , WrapFull ic <- c+        , WrapFull id <- d+        , WrapFull ie <- e+        , WrapFull ig <- g+        , WrapFull ih <- h+        = ( infoSize ia+          , infoSize ib+          , infoSize ic+          , infoSize id+          , infoSize ie+          , infoSize ig+          , infoSize ih+          )++instance Sharable (Select TypeCtx)+  where+    sharable _ = False++sel1Size :: (Sel1' a ~ b) => TypeRep a -> (Size a -> Size b)+sel1Size (Tup2Type _ _)           = sel1+sel1Size (Tup3Type _ _ _)         = sel1+sel1Size (Tup4Type _ _ _ _)       = sel1+sel1Size (Tup5Type _ _ _ _ _)     = sel1+sel1Size (Tup6Type _ _ _ _ _ _)   = sel1+sel1Size (Tup7Type _ _ _ _ _ _ _) = sel1++sel2Size :: (Sel2' a ~ b) => TypeRep a -> (Size a -> Size b)+sel2Size (Tup2Type _ _)           = sel2+sel2Size (Tup3Type _ _ _)         = sel2+sel2Size (Tup4Type _ _ _ _)       = sel2+sel2Size (Tup5Type _ _ _ _ _)     = sel2+sel2Size (Tup6Type _ _ _ _ _ _)   = sel2+sel2Size (Tup7Type _ _ _ _ _ _ _) = sel2++sel3Size :: (Sel3' a ~ b) => TypeRep a -> (Size a -> Size b)+sel3Size (Tup3Type _ _ _)         = sel3+sel3Size (Tup4Type _ _ _ _)       = sel3+sel3Size (Tup5Type _ _ _ _ _)     = sel3+sel3Size (Tup6Type _ _ _ _ _ _)   = sel3+sel3Size (Tup7Type _ _ _ _ _ _ _) = sel3++sel4Size :: (Sel4' a ~ b) => TypeRep a -> (Size a -> Size b)+sel4Size (Tup4Type _ _ _ _)       = sel4+sel4Size (Tup5Type _ _ _ _ _)     = sel4+sel4Size (Tup6Type _ _ _ _ _ _)   = sel4+sel4Size (Tup7Type _ _ _ _ _ _ _) = sel4++sel5Size :: (Sel5' a ~ b) => TypeRep a -> (Size a -> Size b)+sel5Size (Tup5Type _ _ _ _ _)     = sel5+sel5Size (Tup6Type _ _ _ _ _ _)   = sel5+sel5Size (Tup7Type _ _ _ _ _ _ _) = sel5++sel6Size :: (Sel6' a ~ b) => TypeRep a -> (Size a -> Size b)+sel6Size (Tup6Type _ _ _ _ _ _)   = sel6+sel6Size (Tup7Type _ _ _ _ _ _ _) = sel6++sel7Size :: (Sel7' a ~ b) => TypeRep a -> (Size a -> Size b)+sel7Size (Tup7Type _ _ _ _ _ _ _) = sel7++instance SizeProp (Select TypeCtx)+  where+    sizeProp sel@Sel1 (WrapFull ia :* Nil) =+        sel1Size (infoType ia) (infoSize ia)+    sizeProp sel@Sel2 (WrapFull ia :* Nil) =+        sel2Size (infoType ia) (infoSize ia)+    sizeProp sel@Sel3 (WrapFull ia :* Nil) =+        sel3Size (infoType ia) (infoSize ia)+    sizeProp sel@Sel4 (WrapFull ia :* Nil) =+        sel4Size (infoType ia) (infoSize ia)+    sizeProp sel@Sel5 (WrapFull ia :* Nil) =+        sel5Size (infoType ia) (infoSize ia)+    sizeProp sel@Sel6 (WrapFull ia :* Nil) =+        sel6Size (infoType ia) (infoSize ia)+    sizeProp sel@Sel7 (WrapFull ia :* Nil) =+        sel7Size (infoType ia) (infoSize ia)++-- | Compute a witness that a symbol and an expression have the same result type+tupEq :: Type (DenResult a) =>+    sym a -> ASTF (Decor Info dom) b -> Maybe (TypeEq (DenResult a) b)+tupEq _ b = typeEq typeRep (infoType $ getInfo b)++instance+    ( Tuple TypeCtx :<: dom+    , Select TypeCtx :<: dom+    , Optimize dom dom+    ) =>+      Optimize (Tuple TypeCtx) dom+  where+    constructFeatOpt tup@Tup2 (s1 :* s2 :* Nil)+        | (prjDecorCtx typeCtx -> Just (_,Sel1)) :$ a <- s1+        , (prjDecorCtx typeCtx -> Just (_,Sel2)) :$ b <- s2+        , alphaEq a b+        , TypeWit     <- fromSatWit $ witnessSat tup+        , Just TypeEq <- tupEq tup a+        = return a++    constructFeatOpt tup@Tup3 (s1 :* s2 :* s3 :* Nil)+        | (prjDecorCtx typeCtx -> Just (_,Sel1)) :$ a <- s1+        , (prjDecorCtx typeCtx -> Just (_,Sel2)) :$ b <- s2+        , (prjDecorCtx typeCtx -> Just (_,Sel3)) :$ c <- s3+        , alphaEq a b+        , alphaEq a c+        , TypeWit     <- fromSatWit $ witnessSat tup+        , Just TypeEq <- tupEq tup a+        = return a++    constructFeatOpt tup@Tup4 (s1 :* s2 :* s3 :* s4 :* Nil)+        | (prjDecorCtx typeCtx -> Just (_,Sel1)) :$ a <- s1+        , (prjDecorCtx typeCtx -> Just (_,Sel2)) :$ b <- s2+        , (prjDecorCtx typeCtx -> Just (_,Sel3)) :$ c <- s3+        , (prjDecorCtx typeCtx -> Just (_,Sel4)) :$ d <- s4+        , alphaEq a b+        , alphaEq a c+        , alphaEq a d+        , TypeWit     <- fromSatWit $ witnessSat tup+        , Just TypeEq <- tupEq tup a+        = return a++    constructFeatOpt tup@Tup5 (s1 :* s2 :* s3 :* s4 :* s5 :* Nil)+        | (prjDecorCtx typeCtx -> Just (_,Sel1)) :$ a <- s1+        , (prjDecorCtx typeCtx -> Just (_,Sel2)) :$ b <- s2+        , (prjDecorCtx typeCtx -> Just (_,Sel3)) :$ c <- s3+        , (prjDecorCtx typeCtx -> Just (_,Sel4)) :$ d <- s4+        , (prjDecorCtx typeCtx -> Just (_,Sel5)) :$ e <- s5+        , alphaEq a b+        , alphaEq a c+        , alphaEq a d+        , alphaEq a e+        , TypeWit     <- fromSatWit $ witnessSat tup+        , Just TypeEq <- tupEq tup a+        = return a++    constructFeatOpt tup@Tup6 (s1 :* s2 :* s3 :* s4 :* s5 :* s6 :* Nil)+        | (prjDecorCtx typeCtx -> Just (_,Sel1)) :$ a <- s1+        , (prjDecorCtx typeCtx -> Just (_,Sel2)) :$ b <- s2+        , (prjDecorCtx typeCtx -> Just (_,Sel3)) :$ c <- s3+        , (prjDecorCtx typeCtx -> Just (_,Sel4)) :$ d <- s4+        , (prjDecorCtx typeCtx -> Just (_,Sel5)) :$ e <- s5+        , (prjDecorCtx typeCtx -> Just (_,Sel6)) :$ f <- s6+        , alphaEq a b+        , alphaEq a c+        , alphaEq a d+        , alphaEq a e+        , alphaEq a f+        , TypeWit     <- fromSatWit $ witnessSat tup+        , Just TypeEq <- tupEq tup a+        = return a++    constructFeatOpt tup@Tup7 (s1 :* s2 :* s3 :* s4 :* s5 :* s6 :* s7 :* Nil)+        | (prjDecorCtx typeCtx -> Just (_,Sel1)) :$ a <- s1+        , (prjDecorCtx typeCtx -> Just (_,Sel2)) :$ b <- s2+        , (prjDecorCtx typeCtx -> Just (_,Sel3)) :$ c <- s3+        , (prjDecorCtx typeCtx -> Just (_,Sel4)) :$ d <- s4+        , (prjDecorCtx typeCtx -> Just (_,Sel5)) :$ e <- s5+        , (prjDecorCtx typeCtx -> Just (_,Sel6)) :$ f <- s6+        , (prjDecorCtx typeCtx -> Just (_,Sel7)) :$ g <- s7+        , alphaEq a b+        , alphaEq a c+        , alphaEq a d+        , alphaEq a e+        , alphaEq a f+        , alphaEq a g+        , TypeWit     <- fromSatWit $ witnessSat tup+        , Just TypeEq <- tupEq tup a+        = return a++    constructFeatOpt feat args = constructFeatUnOpt feat args++    constructFeatUnOpt = constructFeatUnOptDefault+++instance+    ( Select TypeCtx :<: dom+    , Tuple TypeCtx :<: dom+    , Optimize dom dom+    ) =>+      Optimize (Select TypeCtx) dom+  where+    constructFeatOpt Sel1 (t :* Nil)+        | ((prjDecorCtx typeCtx -> Just (_,Tup2)) :$ a :$ _) <- t                          = return a+        | ((prjDecorCtx typeCtx -> Just (_,Tup3)) :$ a :$ _ :$ _) <- t                     = return a+        | ((prjDecorCtx typeCtx -> Just (_,Tup4)) :$ a :$ _ :$ _ :$ _) <- t                = return a+        | ((prjDecorCtx typeCtx -> Just (_,Tup5)) :$ a :$ _ :$ _ :$ _ :$ _) <- t           = return a+        | ((prjDecorCtx typeCtx -> Just (_,Tup6)) :$ a :$ _ :$ _ :$ _ :$ _ :$ _) <- t      = return a+        | ((prjDecorCtx typeCtx -> Just (_,Tup7)) :$ a :$ _ :$ _ :$ _ :$ _ :$ _ :$ _) <- t = return a++    constructFeatOpt Sel2 (t :* Nil)+        | ((prjDecorCtx typeCtx -> Just (_,Tup2)) :$ _ :$ a) <- t                          = return a+        | ((prjDecorCtx typeCtx -> Just (_,Tup3)) :$ _ :$ a :$ _) <- t                     = return a+        | ((prjDecorCtx typeCtx -> Just (_,Tup4)) :$ _ :$ a :$ _ :$ _) <- t                = return a+        | ((prjDecorCtx typeCtx -> Just (_,Tup5)) :$ _ :$ a :$ _ :$ _ :$ _) <- t           = return a+        | ((prjDecorCtx typeCtx -> Just (_,Tup6)) :$ _ :$ a :$ _ :$ _ :$ _ :$ _) <- t      = return a+        | ((prjDecorCtx typeCtx -> Just (_,Tup7)) :$ _ :$ a :$ _ :$ _ :$ _ :$ _ :$ _) <- t = return a++    constructFeatOpt Sel3 (t :* Nil)+        | ((prjDecorCtx typeCtx -> Just (_,Tup3)) :$ _ :$ _ :$ a) <- t                     = return a+        | ((prjDecorCtx typeCtx -> Just (_,Tup4)) :$ _ :$ _ :$ a :$ _) <- t                = return a+        | ((prjDecorCtx typeCtx -> Just (_,Tup5)) :$ _ :$ _ :$ a :$ _ :$ _) <- t           = return a+        | ((prjDecorCtx typeCtx -> Just (_,Tup6)) :$ _ :$ _ :$ a :$ _ :$ _ :$ _) <- t      = return a+        | ((prjDecorCtx typeCtx -> Just (_,Tup7)) :$ _ :$ _ :$ a :$ _ :$ _ :$ _ :$ _) <- t = return a++    constructFeatOpt Sel4 (t :* Nil)+        | ((prjDecorCtx typeCtx -> Just (_,Tup4)) :$ _ :$ _ :$ _ :$ a) <- t                = return a+        | ((prjDecorCtx typeCtx -> Just (_,Tup5)) :$ _ :$ _ :$ _ :$ a :$ _) <- t           = return a+        | ((prjDecorCtx typeCtx -> Just (_,Tup6)) :$ _ :$ _ :$ _ :$ a :$ _ :$ _) <- t      = return a+        | ((prjDecorCtx typeCtx -> Just (_,Tup7)) :$ _ :$ _ :$ _ :$ a :$ _ :$ _ :$ _) <- t = return a++    constructFeatOpt Sel5 (t :* Nil)+        | ((prjDecorCtx typeCtx -> Just (_,Tup5)) :$ _ :$ _ :$ _ :$ _ :$ a) <- t           = return a+        | ((prjDecorCtx typeCtx -> Just (_,Tup6)) :$ _ :$ _ :$ _ :$ _ :$ a :$ _) <- t      = return a+        | ((prjDecorCtx typeCtx -> Just (_,Tup7)) :$ _ :$ _ :$ _ :$ _ :$ a :$ _ :$ _) <- t = return a++    constructFeatOpt Sel6 (t :* Nil)+        | ((prjDecorCtx typeCtx -> Just (_,Tup6)) :$ _ :$ _ :$ _ :$ _ :$ _ :$ a) <- t      = return a+        | ((prjDecorCtx typeCtx -> Just (_,Tup7)) :$ _ :$ _ :$ _ :$ _ :$ _ :$ a :$ _) <- t = return a++    constructFeatOpt Sel7 (t :* Nil)+        | ((prjDecorCtx typeCtx -> Just (_,Tup7)) :$ _ :$ _ :$ _ :$ _ :$ _ :$ _ :$ a) <- t = return a++    constructFeatOpt feat args = constructFeatUnOpt feat args++    constructFeatUnOpt = constructFeatUnOptDefault+
+ Feldspar/Core/Frontend.hs view
@@ -0,0 +1,270 @@+--+-- Copyright (c) 2009-2011, 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 #-}+{-# LANGUAGE OverlappingInstances #-}++module Feldspar.Core.Frontend+    ( module Data.Patch+    , Syntactic+    , Internal++    , FeldDomainAll+    , Data+    , Syntax++    , module Frontend++    , reifyFeld+    , showExpr+    , printExpr+    , showAST+    , drawAST+    , showDecor+    , drawDecor+    , eval+    , evalTarget+    , desugar+    , sugar+    , resugar++    -- * QuickCheck+    , (===>)+    , (===)++    -- * Type constraints+    , tData+    , tArr1+    , tArr2+    , tM+    ) where++++import Control.Monad.State+import Test.QuickCheck++import Data.Patch++import Language.Syntactic hiding+    (desugar, sugar, resugar, printExpr, showAST, drawAST)+import qualified Language.Syntactic as Syntactic+import qualified Language.Syntactic.Constructs.Decoration as Syntactic+import Language.Syntactic.Constructs.Binding+import Language.Syntactic.Constructs.Binding.HigherOrder+import Language.Syntactic.Sharing.SimpleCodeMotion++import Feldspar.Lattice+import Feldspar.Range+import Feldspar.Core.Types+import Feldspar.Core.Interpretation hiding (showDecor, drawDecor)+import Feldspar.Core.Constructs+import Feldspar.Core.Frontend.Array            as Frontend+import Feldspar.Core.Frontend.Binding          as Frontend+import Feldspar.Core.Frontend.Bits             as Frontend+import Feldspar.Core.Frontend.Complex          as Frontend+import Feldspar.Core.Frontend.Condition        as Frontend+import Feldspar.Core.Frontend.ConditionM       as Frontend+import Feldspar.Core.Frontend.Conversion       as Frontend+import Feldspar.Core.Frontend.Eq               as Frontend+import Feldspar.Core.Frontend.Error            as Frontend+import Feldspar.Core.Frontend.FFI              as Frontend+import Feldspar.Core.Frontend.Floating         as Frontend+import Feldspar.Core.Frontend.Fractional       as Frontend+import Feldspar.Core.Frontend.Integral         as Frontend+import Feldspar.Core.Frontend.Literal          as Frontend+import Feldspar.Core.Frontend.Logic            as Frontend+import Feldspar.Core.Frontend.Loop             as Frontend+import Feldspar.Core.Frontend.Mutable          as Frontend+import Feldspar.Core.Frontend.MutableArray     as Frontend+import Feldspar.Core.Frontend.MutableReference as Frontend+import Feldspar.Core.Frontend.MutableToPure    as Frontend+import Feldspar.Core.Frontend.Par              as Frontend+import Feldspar.Core.Frontend.Num              as Frontend+import Feldspar.Core.Frontend.Ord              as Frontend+import Feldspar.Core.Frontend.Save             as Frontend+import Feldspar.Core.Frontend.SizeProp         as Frontend+import Feldspar.Core.Frontend.SourceInfo       as Frontend+import Feldspar.Core.Frontend.Trace            as Frontend+import Feldspar.Core.Frontend.Tuple            as Frontend+++bindDict :: BindDict+    TypeCtx+    (Decor Info (Lambda TypeCtx :+: Variable TypeCtx :+: FeldDomain))+bindDict = BindDict+    { prjVariable = \a -> case a of+        Decor _ (prjCtx typeCtx -> Just (Variable v)) -> Just v+        _ -> Nothing++    , prjLambda = \a -> case a of+        Decor _ (prjCtx typeCtx -> Just (Lambda v)) -> Just v+        _ -> Nothing++    , injVariable = injVar+    , injLambda   = injLam+    , injLet      = injLt+    }++injVar :: forall a . Sat TypeCtx a+    => ASTF (Decor Info (Lambda TypeCtx :+: Variable TypeCtx :+: FeldDomain)) a+    -> VarId+    -> (Decor Info (Lambda TypeCtx :+: Variable TypeCtx :+: FeldDomain)) (Full a)+injVar a v+    | TypeWit <- witness :: Witness TypeCtx a+    = Decor (getInfo a) (inj (Variable v `withContext` typeCtx))++injLam :: forall a b . (Sat TypeCtx a, Sat TypeCtx b)+    => ASTF (Decor Info (Lambda TypeCtx :+: Variable TypeCtx :+: FeldDomain)) b+    -> VarId+    -> (Decor Info (Lambda TypeCtx :+: Variable TypeCtx :+: FeldDomain)) (b :-> Full (a -> b))+injLam b v+    | TypeWit <- witness :: Witness TypeCtx a+    , TypeWit <- witness :: Witness TypeCtx b+    = Decor+        ((mkInfoTy (FunType typeRep typeRep)) {infoSize = infoSize (getInfo b)})+        (inj (Lambda v `withContext` typeCtx))++injLt :: forall a b . (Sat TypeCtx a, Sat TypeCtx b)+    => ASTF (Decor Info (Lambda TypeCtx :+: Variable TypeCtx :+: FeldDomain)) b+    -> (Decor Info (Lambda TypeCtx :+: Variable TypeCtx :+: FeldDomain)) (a :-> (a -> b) :-> Full b)+injLt b+    | TypeWit <- witness :: Witness TypeCtx b+    = Decor (getInfo b) (inj (letBind typeCtx))++++-- | Reification and optimization of a Feldspar program+reifyFeld :: Syntactic a FeldDomainAll+    => BitWidth n+    -> a+    -> ASTF (Decor Info (Lambda TypeCtx :+: Variable TypeCtx :+: FeldDomain)) (Internal a)+reifyFeld n = flip evalState 0 .+    (   return+    <=< codeMotion bindDict sharableDecor+    .   optimize+    .   targetSpecialization n+    <=< reifyM+    .   Syntactic.desugar+    )+  -- Note that it's important to do 'codeMotion' after 'optimize'. There may be+  -- sub-expressions that appear more than once in the original program, but+  -- where 'optimize' removes all but one occurrence. If 'codeMotion' was run+  -- first, these sub-expressions would be let bound, preventing subsequent+  -- optimizations.++showExpr :: Syntactic a FeldDomainAll => a -> String+showExpr = render . reifyFeld N32++printExpr :: Syntactic a FeldDomainAll => a -> IO ()+printExpr = Syntactic.printExpr . reifyFeld N32++showAST :: Syntactic a FeldDomainAll => a -> String+showAST = Syntactic.showAST . reifyFeld N32++drawAST :: Syntactic a FeldDomainAll => a -> IO ()+drawAST = Syntactic.drawAST . reifyFeld N32++-- | Draw a syntax tree decorated with type and size information+showDecor :: Syntactic a FeldDomainAll => a -> String+showDecor = Syntactic.showDecor . reifyFeld N32++-- | Draw a syntax tree decorated with type and size information+drawDecor :: Syntactic a FeldDomainAll => a -> IO ()+drawDecor = Syntactic.drawDecor . reifyFeld N32++eval :: Syntactic a FeldDomainAll => a -> Internal a+eval = evalBind . reifyFeld N32++evalTarget+    :: ( Syntactic a FeldDomainAll+       , BoundedInt (GenericInt U n)+       , BoundedInt (GenericInt S n)+       )+    => BitWidth n -> a -> Internal a+evalTarget n = evalBind . reifyFeld n+  -- TODO This doesn't work yet, because 'targetSpecialization' is not+  --      implemented++desugar :: Syntax a => a -> Data (Internal a)+desugar = Syntactic.resugar++sugar :: Syntax a => Data (Internal a) -> a+sugar = Syntactic.resugar++resugar :: (Syntax a, Syntax b, Internal a ~ Internal b) => a -> b+resugar = Syntactic.resugar++++--------------------------------------------------------------------------------+-- * QuickCheck+--------------------------------------------------------------------------------++instance (Type a, Arbitrary a) => Arbitrary (Data a)+  where+    arbitrary = fmap value arbitrary++instance Testable (Data Bool)+  where+    property = property . eval++(===>) :: Testable prop => Data Bool -> prop -> Property+a ===> b = eval a ==> b+++class Equal a+  where+    (===) :: a -> a -> Property++instance (Prelude.Eq a, Show a) => Equal a+  where+    x === y = printTestCase ("Evaluated property: " ++ show x ++ " === " ++ show y)+            $ property (x Prelude.== y)++instance (Show a, Arbitrary a, Equal b) => Equal (a -> b)+  where+    f === g = property (\x -> f x === g x)+++--------------------------------------------------------------------------------+-- * Type annotations+--------------------------------------------------------------------------------++tData :: Patch a a -> Patch (Data a) (Data a)+tData _ = id++tArr1 :: Patch a a -> Patch (Data [a]) (Data [a])+tArr1 _ = id++tArr2 :: Patch a a -> Patch (Data [[a]]) (Data [[a]])+tArr2 _ = id++tM :: Patch a a -> Patch (M a) (M a)+tM _ = id+
+ Feldspar/Core/Frontend/Array.hs view
@@ -0,0 +1,63 @@+--+-- Copyright (c) 2009-2011, 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.Frontend.Array+where++import Feldspar.Core.Types+import Feldspar.Core.Constructs+import Feldspar.Core.Constructs.Array+import Feldspar.Core.Frontend.Tuple++import Language.Syntactic++parallel :: Type a => Data Length -> (Data Index -> Data a) -> Data [a]+parallel = sugarSym Parallel++sequential :: (Type a, Syntax s) =>+              Data Length -> s -> (Data Index -> s -> (Data a,s)) -> Data [a]+sequential = sugarSym Sequential++append :: Type a => Data [a] -> Data [a] -> Data [a]+append = sugarSym Append++getLength :: Type a => Data [a] -> Data Length+getLength = sugarSym GetLength++-- | Change the length of the vector to the supplied value. If the supplied+-- length is greater than the old length, the new elements will have undefined+-- value.+setLength :: Type a => Data Length -> Data [a] -> Data [a]+setLength = sugarSym SetLength++getIx :: Type a => Data [a] -> Data Index -> Data a+getIx = sugarSym GetIx++setIx :: Type a => Data [a] -> Data Index -> Data a -> Data [a]+setIx = sugarSym SetIx+
+ Feldspar/Core/Frontend/Binding.hs view
@@ -0,0 +1,43 @@+--+-- Copyright (c) 2009-2011, 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.Frontend.Binding where++++import Language.Syntactic++import Feldspar.Core.Types+import Feldspar.Core.Constructs.Binding+import Feldspar.Core.Constructs++++share :: (Syntax a, Syntax b) => a -> (a -> b) -> b+share = sugarSym (letBind typeCtx)+
+ Feldspar/Core/Frontend/Bits.hs view
@@ -0,0 +1,122 @@+--+-- Copyright (c) 2009-2011, 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.Frontend.Bits+where++import Prelude hiding (Integral(..))++import Data.Int+import Data.Word++import Language.Syntactic++import Feldspar.Range+import Feldspar.Core.Types+import Feldspar.Core.Constructs+import Feldspar.Core.Constructs.Bits+import Feldspar.Core.Frontend.Integral++import qualified Data.Bits as B++infixl 5 .<<.,.>>.+infixl 4 ⊕++-- TODO Make (Size a ~ Range a) a super-class constraint when going to newer GHC+class (Type a, B.Bits a, Integral a, Bounded a) => Bits a+  where+    -- Logical operations+    (.&.)         :: (Size a ~ Range a) => Data a -> Data a -> Data a+    (.&.)         = sugarSym BAnd+    (.|.)         :: (Size a ~ Range a) => Data a -> Data a -> Data a+    (.|.)         = sugarSym BOr+    xor           :: (Size a ~ Range a) => Data a -> Data a -> Data a+    xor           = sugarSym BXor+    complement    :: (Size a ~ Range a) => Data a -> Data a+    complement    = sugarSym Complement++    -- Bitwise operations+    bit           :: (Size a ~ Range a) => Data Index -> Data a+    bit           = sugarSym Bit+    setBit        :: (Size a ~ Range a) => Data a -> Data Index -> Data a+    setBit        = sugarSym SetBit+    clearBit      :: (Size a ~ Range a) => Data a -> Data Index -> Data a+    clearBit      = sugarSym ClearBit+    complementBit :: (Size a ~ Range a) => Data a -> Data Index -> Data a+    complementBit = sugarSym ComplementBit+    testBit       :: (Size a ~ Range a) => Data a -> Data Index -> Data Bool+    testBit       = sugarSym TestBit++    -- Movement operations+    shiftLU       :: (Size a ~ Range a) => Data a -> Data Index -> Data a+    shiftLU       = sugarSym ShiftLU+    shiftRU       :: (Size a ~ Range a) => Data a -> Data Index -> Data a+    shiftRU       = sugarSym ShiftRU+    shiftL        :: (Size a ~ Range a) => Data a -> Data IntN -> Data a+    shiftL        = sugarSym ShiftL+    shiftR        :: (Size a ~ Range a) => Data a -> Data IntN -> Data a+    shiftR        = sugarSym ShiftR+    rotateLU      :: (Size a ~ Range a) => Data a -> Data Index -> Data a+    rotateLU      = sugarSym RotateLU+    rotateRU      :: (Size a ~ Range a) => Data a -> Data Index -> Data a+    rotateRU      = sugarSym RotateRU+    rotateL       :: (Size a ~ Range a) => Data a -> Data IntN -> Data a+    rotateL       = sugarSym RotateL+    rotateR       :: (Size a ~ Range a) => Data a -> Data IntN -> Data a+    rotateR       = sugarSym RotateR+    reverseBits   :: (Size a ~ Range a) => Data a -> Data a+    reverseBits   = sugarSym ReverseBits++    bitScan       :: (Size a ~ Range a) => Data a -> Data Index+    bitScan       = sugarSym BitScan+    bitCount      :: (Size a ~ Range a) => Data a -> Data Index+    bitCount      = sugarSym BitCount++    bitSize       :: (Size a ~ Range a) => Data a -> Data Index+    bitSize       = sugarSym BitSize+    isSigned      :: (Size a ~ Range a) => Data a -> Data Bool+    isSigned      = sugarSym IsSigned++(⊕)    :: (Bits a, Size a ~ Range a) => Data a -> Data a -> Data a+(⊕)    =  xor+(.<<.) :: (Bits a, Size a ~ Range a) => Data a -> Data Index -> Data a+(.<<.) =  shiftLU+(.>>.) :: (Bits a, Size a ~ Range a) => Data a -> Data Index -> Data a+(.>>.) =  shiftRU++instance Bits Word8+instance Bits Word16+instance Bits Word32+instance Bits Word64+instance Bits WordN+instance Bits Int8+instance Bits Int16+instance Bits Int32+instance Bits Int64+instance Bits IntN+
+ Feldspar/Core/Frontend/Complex.hs view
@@ -0,0 +1,75 @@+--+-- Copyright (c) 2009-2011, 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.Frontend.Complex+where++import Data.Complex (Complex)++import Feldspar.Core.Types+import Feldspar.Core.Constructs+import Feldspar.Core.Constructs.Complex+import Feldspar.Core.Frontend.Num++import Language.Syntactic++complex :: (Numeric a, RealFloat a) => Data a -> Data a -> Data (Complex a)+complex = sugarSym MkComplex++realPart :: (Numeric a, RealFloat a) => Data (Complex a) -> Data a+realPart = sugarSym RealPart++imagPart :: (Numeric a, RealFloat a) => Data (Complex a) -> Data a+imagPart = sugarSym ImagPart++conjugate :: (Numeric a, RealFloat a) => Data (Complex a) -> Data (Complex a)+conjugate = sugarSym Conjugate++mkPolar :: (Numeric a, RealFloat a) => Data a -> Data a -> Data (Complex a)+mkPolar = sugarSym MkPolar++cis :: (Numeric a, RealFloat a) => Data a -> Data (Complex a)+cis = sugarSym Cis++magnitude :: (Numeric a, RealFloat a) => Data (Complex a) -> Data a+magnitude = sugarSym Magnitude++phase :: (Numeric a, RealFloat a) => Data (Complex a) -> Data a+phase = sugarSym 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+
+ Feldspar/Core/Frontend/Condition.hs view
@@ -0,0 +1,48 @@+--+-- Copyright (c) 2009-2011, 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.Frontend.Condition where++++import Language.Syntactic++import Feldspar.Core.Types+import Feldspar.Core.Constructs.Condition+import Feldspar.Core.Constructs++++condition :: (Syntax a) => Data Bool -> a -> a -> a+condition = sugarSymCtx typeCtx Condition++(?) :: (Syntax a) => Data Bool -> (a, a) -> a+c ? (t, e) = condition c t e++infix 1 ?+
+ Feldspar/Core/Frontend/ConditionM.hs view
@@ -0,0 +1,42 @@+--+-- Copyright (c) 2009-2011, 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.Frontend.ConditionM where++++import Language.Syntactic++import Feldspar.Core.Types+import Feldspar.Core.Constructs.ConditionM+import Feldspar.Core.Constructs++import Feldspar.Core.Frontend.Mutable++ifM :: Syntax a => Data Bool -> M a -> M a -> M a+ifM = sugarSym ConditionM
+ Feldspar/Core/Frontend/Conversion.hs view
@@ -0,0 +1,67 @@+--+-- Copyright (c) 2009-2011, 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.Frontend.Conversion+where++import Prelude hiding (Integral)++import Language.Syntactic++import Feldspar.Range+import Feldspar.Core.Types+import Feldspar.Core.Constructs+import Feldspar.Core.Constructs.Conversion+import Feldspar.Core.Frontend.Integral+import Feldspar.Core.Frontend.Num++i2f :: (Integral a, Size a ~ Range a) => Data a -> Data Float+i2f = i2n++f2i :: Integral a => Data Float -> Data a+f2i = sugarSym F2I++i2n :: (Integral a, Numeric b, Size a ~ Range a) => Data a -> Data b+i2n = sugarSym I2N++b2i :: Integral a => Data Bool -> Data a+b2i = sugarSym B2I++truncate :: Integral a => Data Float -> Data a+truncate = f2i++round :: Integral a => Data Float -> Data a+round = sugarSym Round++ceiling :: Integral a => Data Float -> Data a+ceiling = sugarSym Ceiling++floor :: Integral a => Data Float -> Data a+floor = sugarSym Floor++
+ Feldspar/Core/Frontend/Eq.hs view
@@ -0,0 +1,77 @@+--+-- Copyright (c) 2009-2011, 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.Frontend.Eq+where++import qualified Prelude as P++import Data.Int+import Data.Word+import Data.Complex++import Language.Syntactic++import Feldspar.Prelude+import Feldspar.Core.Types+import Feldspar.Core.Constructs+import Feldspar.Core.Constructs.Eq++infix 4 ==+infix 4 /=++-- | Redefinition of the standard 'P.Eq' class for Feldspar+class (Type a) => Eq a+  where+    (==) :: Data a -> Data a -> Data Bool+    (==) = sugarSym Equal+    (/=) :: Data a -> Data a -> Data Bool+    (/=) = sugarSym NotEqual++instance Eq ()+instance Eq Bool+instance Eq Float+instance Eq Word8+instance Eq Word16+instance Eq Word32+instance Eq Word64+instance Eq WordN+instance Eq Int8+instance Eq Int16+instance Eq Int32+instance Eq Int64+instance Eq IntN++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)+instance (Eq a, Eq b, Eq c, Eq d, Eq e)             => Eq (a,b,c,d,e)+instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f)       => Eq (a,b,c,d,e,f)+instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g) => Eq (a,b,c,d,e,f,g)++instance (Eq a, RealFloat a) => Eq (Complex a)
+ Feldspar/Core/Frontend/Error.hs view
@@ -0,0 +1,55 @@+--+-- Copyright (c) 2009-2011, 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.Frontend.Error where++++import Language.Syntactic++import Feldspar.Core.Types+import Feldspar.Core.Constructs+import Feldspar.Core.Constructs.Error+import Feldspar.Core.Frontend.Literal++++undef :: Syntax a => a+undef = sugarSym Undefined++-- | Assert that the condition holds or fail with message+assertMsg :: Syntax a => String -> Data Bool -> a -> a+assertMsg = sugarSym . Assert++-- | Assert that the condition holds, the conditions string representation is used as the message+assert :: Syntax a => Data Bool -> a -> a+assert cond = assertMsg (show cond) cond++err :: Syntax a => String -> a+err msg = assertMsg msg false undef+
+ Feldspar/Core/Frontend/FFI.hs view
@@ -0,0 +1,45 @@+--+-- Copyright (c) 2009-2011, 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.Frontend.FFI where++import Language.Syntactic++import Feldspar.Core.Types+import Feldspar.Core.Constructs+import Feldspar.Core.Constructs.FFI++foreignImport :: ( Type (DenResult a)+                 , Signature a+                 , SyntacticN c b+                 , ApplySym a b dom+                 , FFI :<: dom+                 )+              => String -> Denotation a -> c+foreignImport name f = sugarSym (ForeignImport name f)+
+ Feldspar/Core/Frontend/Floating.hs view
@@ -0,0 +1,85 @@+--+-- Copyright (c) 2009-2011, 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.Frontend.Floating where++import qualified Prelude+import Prelude (Float)+import Data.Complex++import Language.Syntactic++import Feldspar.Core.Constructs+import Feldspar.Core.Constructs.Floating+import Feldspar.Core.Frontend.Literal+import Feldspar.Core.Frontend.Fractional++-- Make new class, with "Data" in all the types++infixr 8 **++class (Fraction a, Prelude.Floating a) => Floating a where+  pi        :: Data a+  pi        =  value Prelude.pi+  exp       :: Data a -> Data a+  exp       =  sugarSym Exp+  sqrt      :: Data a -> Data a+  sqrt      =  sugarSym Sqrt+  log       :: Data a -> Data a+  log       =  sugarSym Log+  (**)      :: Data a -> Data a -> Data a+  (**)      =  sugarSym Pow+  logBase   :: Data a -> Data a -> Data a+  logBase   =  sugarSym LogBase+  sin       :: Data a -> Data a+  sin       =  sugarSym Sin+  tan       :: Data a -> Data a+  tan       =  sugarSym Tan+  cos       :: Data a -> Data a+  cos       =  sugarSym Cos+  asin      :: Data a -> Data a+  asin      =  sugarSym Asin+  atan      :: Data a -> Data a+  atan      =  sugarSym Atan+  acos      :: Data a -> Data a+  acos      =  sugarSym Acos+  sinh      :: Data a -> Data a+  sinh      =  sugarSym Sinh+  tanh      :: Data a -> Data a+  tanh      =  sugarSym Tanh+  cosh      :: Data a -> Data a+  cosh      =  sugarSym Cosh+  asinh     :: Data a -> Data a+  asinh     =  sugarSym Asinh+  atanh     :: Data a -> Data a+  atanh     =  sugarSym Atanh+  acosh     :: Data a -> Data a+  acosh     =  sugarSym Acosh++instance Floating Float+instance (Fraction a, Prelude.RealFloat a) => Floating (Complex a)
+ Feldspar/Core/Frontend/Fractional.hs view
@@ -0,0 +1,62 @@+--+-- Copyright (c) 2009-2011, 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.Frontend.Fractional+where++import Data.Complex++import Language.Syntactic++import Feldspar.Core.Types+import Feldspar.Core.Constructs+import Feldspar.Core.Constructs.Fractional++import Feldspar.Core.Frontend.Literal+import Feldspar.Core.Frontend.Num++-- | Fractional types. The relation to the standard 'Fractional' class is+--+-- @instance `Fration` a => `Fractional` (`Data` a)@+class (Fractional a, Numeric a) => Fraction a+  where+    fromRationalFrac :: Rational -> Data a+    fromRationalFrac = value . fromRational++    divFrac :: Data a -> Data a -> Data a+    divFrac = sugarSym DivFrac++instance Fraction Float++instance (Fraction a, RealFloat a) => Fraction (Complex a)++instance (Fraction a) => Fractional (Data a)+  where+    fromRational = fromRationalFrac+    (/)          = divFrac+
+ Feldspar/Core/Frontend/Integral.hs view
@@ -0,0 +1,84 @@+--+-- Copyright (c) 2009-2011, 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.Frontend.Integral+where++import qualified Prelude as P++import Data.Int+import Data.Word++import Language.Syntactic++import Feldspar.Range+import Feldspar.Core.Types+import Feldspar.Core.Constructs+import Feldspar.Core.Constructs.Integral++import Feldspar.Core.Frontend.Condition+import Feldspar.Core.Frontend.Eq+import Feldspar.Core.Frontend.Logic+import Feldspar.Core.Frontend.Num+import Feldspar.Core.Frontend.Ord++import Feldspar.Core.Frontend.Num++-- TODO Make (Size a ~ Range a) a super-class constraint when going to newer GHC+class (Ord a, Numeric a, BoundedInt a, P.Integral a) => Integral a+  where+    quot :: (Size a ~ Range a) => Data a -> Data a -> Data a+    quot = sugarSym Quot+    rem  :: (Size a ~ Range a) => Data a -> Data a -> Data a+    rem  = sugarSym Rem+    div  :: (Size a ~ Range a) => Data a -> Data a -> Data a+    div  = divSem+    mod  :: (Size a ~ Range a) => Data a -> Data a -> Data a+    mod  = sugarSym Mod+    (^)  :: (Size a ~ Range a) => Data a -> Data a -> Data a+    (^)  = sugarSym Exp++-- TODO: This is a short-term hack because the compiler doesn't compile+-- the Div construct correctly. So we give the semantics of div in terms of+-- quot directly, and never use the Div construct. In the long term the+-- compiler should be fixed, but it involves writing type corrector plugins+-- and this solution was quicker.+divSem x y = (x > 0 && y < 0 || x < 0 && y > 0) && rem x y /= 0 ?+             (quot x y P.- 1,quot x y)++instance Integral Word8+instance Integral Word16+instance Integral Word32+instance Integral Word64+instance Integral WordN+instance Integral Int8+instance Integral Int16+instance Integral Int32+instance Integral Int64+instance Integral IntN+
+ Feldspar/Core/Frontend/Literal.hs view
@@ -0,0 +1,55 @@+--+-- Copyright (c) 2009-2011, 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.Frontend.Literal where++++import Language.Syntactic+import Feldspar.Core.Types+import Feldspar.Core.Constructs.Literal+import Feldspar.Core.Constructs+++value :: Syntax a => Internal a -> a+value = sugarSymCtx typeCtx . Literal++false :: Data Bool+false = value False++true :: Data Bool+true = value True++instance Syntactic () FeldDomainAll+  where+    type Internal () = ()+    desugar = appSymCtx typeCtx . Literal+    sugar _ = ()++instance Syntax ()+
+ Feldspar/Core/Frontend/Logic.hs view
@@ -0,0 +1,62 @@+--+-- Copyright (c) 2009-2011, 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.Frontend.Logic+where++import Feldspar.Core.Types+import Feldspar.Core.Constructs+import Feldspar.Core.Constructs.Logic+import Feldspar.Core.Frontend.Literal+import Feldspar.Core.Frontend.Condition++import Language.Syntactic++infixr 3 &&+infixr 3 &&*+infixr 2 ||+infixr 2 ||*++not :: Data Bool -> Data Bool+not = sugarSym Not++(&&) :: Data Bool -> Data Bool -> Data Bool+(&&) = sugarSym And++(||) :: Data Bool -> Data Bool -> Data Bool+(||) = sugarSym Or+++-- | Lazy conjunction, second argument only evaluated if necessary+(&&*) :: Data Bool -> Data Bool -> Data Bool+a &&* b =  a ? (b,false)++-- | Lazy disjunction, second argument only evaluated if necessary+(||*) :: Data Bool -> Data Bool -> Data Bool+a ||* b = a ? (true,b)+
+ Feldspar/Core/Frontend/Loop.hs view
@@ -0,0 +1,51 @@+--+-- Copyright (c) 2009-2011, 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.Frontend.Loop+where++import Language.Syntactic++import Feldspar.Core.Types+import Feldspar.Core.Constructs+import Feldspar.Core.Constructs.Loop++import Feldspar.Core.Frontend.Mutable++forLoop :: Syntax a => Data Length -> a -> (Data Index -> a -> a) -> a+forLoop = sugarSym ForLoop++whileLoop :: Syntax a => a -> (a -> Data Bool) -> (a -> a) -> a+whileLoop = sugarSym WhileLoop++forM :: (Syntax a) => Data Length -> (Data Index -> M a) -> M ()+forM = sugarSym For++whileM :: Syntax a => M (Data Bool) -> M a -> M ()+whileM = sugarSym While+
+ Feldspar/Core/Frontend/Mutable.hs view
@@ -0,0 +1,65 @@+--+-- Copyright (c) 2009-2011, 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.Frontend.Mutable+where++import Prelude hiding (not)++import Data.Typeable++import Language.Syntactic+import Language.Syntactic.Frontend.Monad++import Feldspar.Core.Types+import Feldspar.Core.Constructs+import Feldspar.Core.Constructs.Loop+import Feldspar.Core.Frontend.Num+import Feldspar.Core.Frontend.Logic+import Feldspar.Core.Frontend.Tuple+import qualified Feldspar.Core.Constructs.Mutable as Feature+import qualified Feldspar.Core.Constructs.MutableReference as Feature+import qualified Feldspar.Core.Constructs.MutableArray as Feature++newtype M a = M { unM :: Mon TypeCtx FeldDomain Mut a }+  deriving (Functor, Monad)++instance Syntax a => Syntactic (M a) FeldDomainAll+  where+    type Internal (M a) = Mut (Internal a)+    desugar = desugar . unM+    sugar   = M . sugar++runMutable :: (Syntax a) => M a -> a+runMutable = sugarSym Feature.Run++when :: Data Bool -> M () -> M ()+when = sugarSym Feature.When++unless :: Data Bool -> M () -> M ()+unless = when . not
+ Feldspar/Core/Frontend/MutableArray.hs view
@@ -0,0 +1,78 @@+--+-- Copyright (c) 2009-2011, 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.Frontend.MutableArray+where++import Language.Syntactic++import Feldspar.Core.Types+import Feldspar.Core.Constructs+import Feldspar.Core.Constructs.Loop+import Feldspar.Core.Constructs.MutableArray+import Feldspar.Core.Frontend.Mutable++newArr :: Type a => Data Length -> Data a -> M (Data (MArr a))+newArr = sugarSym NewArr++newArr_ :: Type a => Data Length -> M (Data (MArr a))+newArr_ = sugarSym NewArr_++newListArr :: Type a => [Data a] -> M (Data (MArr a))+newListArr es = error "newListArr: unimplemented" -- TODO++getArr :: Type a => Data (MArr a) -> Data Index -> M (Data a)+getArr = sugarSym GetArr++setArr :: Type a => Data (MArr a) -> Data Index -> Data a -> M ()+setArr = sugarSym SetArr++modifyArr :: Type a+          => Data (MArr a) -> Data Index -> (Data a -> Data a) -> M ()+modifyArr arr i f = getArr arr i >>= setArr arr i . f++arrLength :: Type a => Data (MArr a) -> M (Data Length)+arrLength = sugarSym ArrLength++mapArray :: Type a => (Data a -> Data a) -> Data (MArr a) -> M (Data (MArr a))+mapArray f arr = do+    len <- arrLength arr+    forArr len (flip (modifyArr arr) f)+    return arr++forArr :: Syntax a => Data Length -> (Data Index -> M a) -> M ()+forArr = sugarSym For++swap :: Syntax a+     => Data (MArr (Internal a)) -> Data Index -> Data Index -> M ()+swap a i1 i2 = do+    tmp1 <- getArr a i1+    tmp2 <- getArr a i2+    setArr a i1 tmp2 :: M ()+    setArr a i2 tmp1 :: M ()+
+ Feldspar/Core/Frontend/MutableReference.hs view
@@ -0,0 +1,62 @@+--+-- Copyright (c) 2009-2011, 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.Frontend.MutableReference+where++import Language.Syntactic++import Feldspar.Core.Types+import Feldspar.Core.Constructs+import Feldspar.Core.Constructs.MutableReference+import Feldspar.Core.Frontend.Mutable++import Data.IORef++newtype Ref a = Ref { unRef :: Data (IORef (Internal a)) }++instance Syntax a => Syntactic (Ref a) FeldDomainAll+  where+    type Internal (Ref a) = IORef (Internal a)+    desugar = desugar . unRef+    sugar   = Ref . sugar++instance Syntax a => Syntax (Ref a)++newRef :: Syntax a => a -> M (Ref a)+newRef = sugarSym NewRef++getRef :: Syntax a => Ref a -> M a+getRef = sugarSym GetRef++setRef :: Syntax a => Ref a -> a -> M ()+setRef = sugarSym SetRef++modifyRef :: Syntax a => Ref a -> (a -> a) -> M ()+modifyRef r f = getRef r >>= setRef r . f+
+ Feldspar/Core/Frontend/MutableToPure.hs view
@@ -0,0 +1,57 @@+--+-- Copyright (c) 2009-2011, 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.Frontend.MutableToPure where++import Language.Syntactic++import Feldspar.Core.Types+import Feldspar.Core.Constructs+import Feldspar.Core.Constructs.MutableToPure+import Feldspar.Core.Frontend.Array+import Feldspar.Core.Frontend.Loop+import Feldspar.Core.Frontend.Mutable+import Feldspar.Core.Frontend.MutableArray+++withArray :: (Type a, Syntax b) => Data (MArr a) -> (Data [a] -> M b) -> M b+withArray = sugarSym WithArray++runMutableArray :: Type a => M (Data (MArr a)) -> Data [a]+runMutableArray = sugarSym RunMutableArray++freezeArray :: Type a => Data (MArr a) -> M (Data [a])+freezeArray marr = withArray marr return++thawArray :: Type a => Data [a] -> M (Data (MArr a))+thawArray arr = do+  marr <- newArr_ (getLength arr)+  forM (getLength arr) (\ix ->+    setArr marr ix (getIx arr ix)+   )+  return marr
+ Feldspar/Core/Frontend/Num.hs view
@@ -0,0 +1,82 @@+--+-- Copyright (c) 2009-2011, 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.Frontend.Num where++import Data.Complex+import Data.Int+import Data.Word++import Language.Syntactic++import Feldspar.Core.Types+import Feldspar.Core.Constructs+import Feldspar.Core.Constructs.Num+import Feldspar.Core.Frontend.Literal+++class (Type a, Num a, Num (Size a)) => Numeric a+  where+    fromIntegerNum :: Integer -> Data a+    fromIntegerNum =  value . fromInteger+    absNum         :: Data a -> Data a+    absNum         =  sugarSym Abs+    signumNum      :: Data a -> Data a+    signumNum      =  sugarSym Sign+    addNum         :: Data a -> Data a -> Data a+    addNum         =  sugarSym Add+    subNum         :: Data a -> Data a -> Data a+    subNum         =  sugarSym Sub+    mulNum         :: Data a -> Data a -> Data a+    mulNum         =  sugarSym Mul++instance Numeric Word8+instance Numeric Word16+instance Numeric Word32+instance Numeric Word64+instance Numeric WordN+instance Numeric Int8+instance Numeric Int16+instance Numeric Int32+instance Numeric Int64+instance Numeric IntN++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++
+ Feldspar/Core/Frontend/Ord.hs view
@@ -0,0 +1,86 @@+--+-- Copyright (c) 2009-2011, 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 #-}++module Feldspar.Core.Frontend.Ord where++++import qualified Prelude++import Data.Complex+import Data.Int+import Data.Word++import Language.Syntactic++import Feldspar.Prelude+import Feldspar.Core.Types+import Feldspar.Core.Constructs+import Feldspar.Core.Constructs.Ord+import Feldspar.Core.Frontend.Eq++infix 4 <+infix 4 >+infix 4 <=+infix 4 >=++-- | Redefinition of the standard 'Prelude.Ord' class for Feldspar+class (Eq a, Prelude.Ord a, Prelude.Ord (Size a)) => Ord a where+  (<)  :: Data a -> Data a -> Data Bool+  (<)  =  sugarSym LTH+  (>)  :: Data a -> Data a -> Data Bool+  (>)  =  sugarSym GTH++  (<=) :: Data a -> Data a -> Data Bool+  (<=) =  sugarSym LTE+  (>=) :: Data a -> Data a -> Data Bool+  (>=) =  sugarSym GTE++  min :: Data a -> Data a -> Data a+  min = sugarSym Min+  max :: Data a -> Data a -> Data a+  max = sugarSym Max++instance Ord ()+instance Ord Bool+instance Ord Word8+instance Ord Int8+instance Ord Word16+instance Ord Int16+instance Ord Word32+instance Ord Int32+instance Ord Word64+instance Ord Int64+instance Ord WordN+instance Ord IntN+instance Ord Float++-- TODO Should there be more instances?+
+ Feldspar/Core/Frontend/Par.hs view
@@ -0,0 +1,59 @@+--+-- Copyright (c) 2009-2011, 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.Frontend.Par where++import Language.Syntactic+import Language.Syntactic.Frontend.Monad (Mon(..))++import Feldspar.Core.Types+import Feldspar.Core.Constructs+import Feldspar.Core.Constructs.Par+import Feldspar.Core.Frontend.Literal ()++import Data.Typeable++newtype P a = P { unP :: Mon TypeCtx FeldDomain Par a }+  deriving (Functor, Monad)++instance Syntax a => Syntactic (P a) FeldDomainAll+  where+    type Internal (P a) = Par (Internal a)+    desugar = desugar . unP+    sugar   = P . sugar++newtype IVar a = IVar { unIVar :: Data (IV (Internal a)) }++instance Syntax a => Syntactic (IVar a) FeldDomainAll+  where+    type Internal (IVar a) = IV (Internal a)+    desugar = desugar . unIVar+    sugar   = IVar . sugar++instance Syntax a => Syntax (IVar a)+
+ Feldspar/Core/Frontend/Save.hs view
@@ -0,0 +1,60 @@+--+-- Copyright (c) 2009-2011, 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.+--++-- | Tracing execution of Feldspar expressions++module Feldspar.Core.Frontend.Save where++++import Language.Syntactic++import Feldspar.Core.Constructs+import Feldspar.Core.Constructs.Save++++-- | An identity function that guarantees that the result will be computed as a+-- sub-result of the whole program. This is useful to prevent certain+-- optimizations.+--+-- Exception: Currently constant folding does not respect 'save'.+save :: Syntax a => a -> a+save = sugarSym Save+  -- TODO Make constant folding respect `save`. This could be done by adding a+  --      field to `Info` saying whether or not each node contains `save`.++  -- TODO It would be nice if `save` could take a `String` argument that would+  --      be used in the back-end to identify the saved value (e.g. used as the+  --      variable name).++-- | Equivalent to 'save'. When applied to a lazy data structure, 'force' (and+-- 'save') has the effect of forcing evaluation of the whole structure.+force :: Syntax a => a -> a+force = save+
+ Feldspar/Core/Frontend/SizeProp.hs view
@@ -0,0 +1,80 @@+--+-- Copyright (c) 2009-2011, 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 functions in this module can be used to help size inference (which, in+-- turn, helps deriving upper bounds of array sizes and helps optimization).++module Feldspar.Core.Frontend.SizeProp where++++import Language.Syntactic++import Feldspar.Range+import Feldspar.Core.Types+import Feldspar.Core.Constructs+import Feldspar.Core.Constructs.SizeProp+import Feldspar.Core.Frontend.Literal++++-- | An identity function affecting the abstract size information used during+-- optimization. The application of a 'SizeCap' is a /guarantee/ (by the caller)+-- that the argument is within a certain size (determined by the creator of the+-- 'SizeCap', e.g. 'sizeProp').+--+-- /Warning: If the guarantee is not fulfilled, optimizations become unsound!/+--+-- In general, the size of the resulting value is the intersection of the cap+-- size and the size obtained by ordinary size inference. That is, a 'SizeCap'+-- can only make the size more precise, not less precise.+type SizeCap a = Data a -> Data a++-- | @sizeProp prop a b@: A guarantee that @b@ is within the size @(prop sa)@,+-- where @sa@ is the size of @a@.+sizeProp :: (Syntax a, Type b) =>+    (Size (Internal a) -> Size b) -> a -> SizeCap b+sizeProp = sugarSym . PropSize++-- | A guarantee that the argument is within the given size+cap :: Type a => Size a -> SizeCap a+cap sz = sizeProp (const sz) (Data $ desugar ())++-- | @notAbove a b@: A guarantee that @b <= a@ holds+notAbove :: (Type a, Bounded a, Size a ~ Range a) => Data a -> SizeCap a+notAbove = sizeProp (\r -> Range minBound (upperBound r))++-- | @notBelow a b@: A guarantee that @b >= a@ holds+notBelow :: (Type a, Bounded a, Size a ~ Range a) => Data a -> SizeCap a+notBelow = sizeProp (\r -> Range (lowerBound r) maxBound)++-- | @between l u a@: A guarantee that @l <= a <= u@ holds+between :: (Type a, Bounded a, Size a ~ Range a) =>+    Data a -> Data a -> SizeCap a+between l u = notBelow l . notAbove u+
+ Feldspar/Core/Frontend/SourceInfo.hs view
@@ -0,0 +1,54 @@+--+-- Copyright (c) 2009-2011, 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 #-}++-- | Source-code annotations++module Feldspar.Core.Frontend.SourceInfo where++++import QuickAnnotate++import Language.Syntactic++import Feldspar.Core.Types+import Feldspar.Core.Constructs.SourceInfo+import Feldspar.Core.Constructs++++-- | Annotate an expression with information about its source code+sourceData :: Type a => SourceInfo1 a -> Data a -> Data a+sourceData info = sugarSym (Decor info (Id `withContext` typeCtx))++instance Type a => Annotatable (Data a)+  where+    annotate = sourceData . SourceInfo1+
+ Feldspar/Core/Frontend/Trace.hs view
@@ -0,0 +1,45 @@+--+-- Copyright (c) 2009-2011, 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.+--++-- | Tracing execution of Feldspar expressions++module Feldspar.Core.Frontend.Trace where++import Language.Syntactic++import Feldspar.Core.Types+import Feldspar.Core.Constructs+import Feldspar.Core.Constructs.Trace+import Feldspar.Core.Frontend.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 = sugarSym Trace (fromIntegral label :: Data IntN)
+ Feldspar/Core/Frontend/Tuple.hs view
@@ -0,0 +1,264 @@+--+-- Copyright (c) 2009-2011, 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 #-}++module Feldspar.Core.Frontend.Tuple where++++import QuickAnnotate++import Language.Syntactic++import Feldspar.Core.Types+import Feldspar.Core.Constructs.Tuple+import Feldspar.Core.Constructs+import Feldspar.Core.Frontend.SourceInfo++++instance+    ( Syntax a+    , Syntax b+    ) =>+      Syntactic (a,b) FeldDomainAll+  where+    type Internal (a,b) =+        ( Internal a+        , Internal b+        )++    desugar = desugarTup2 typeCtx+    sugar   = sugarTup2 typeCtx++instance+    ( Syntax a+    , Syntax b+    , Syntax c+    ) =>+      Syntactic (a,b,c) FeldDomainAll+  where+    type Internal (a,b,c) =+        ( Internal a+        , Internal b+        , Internal c+        )++    desugar = desugarTup3 typeCtx+    sugar   = sugarTup3 typeCtx++instance+    ( Syntax a+    , Syntax b+    , Syntax c+    , Syntax d+    ) =>+      Syntactic (a,b,c,d) FeldDomainAll+  where+    type Internal (a,b,c,d) =+        ( Internal a+        , Internal b+        , Internal c+        , Internal d+        )++    desugar = desugarTup4 typeCtx+    sugar   = sugarTup4 typeCtx++instance+    ( Syntax a+    , Syntax b+    , Syntax c+    , Syntax d+    , Syntax e+    ) =>+      Syntactic (a,b,c,d,e) FeldDomainAll+  where+    type Internal (a,b,c,d,e) =+        ( Internal a+        , Internal b+        , Internal c+        , Internal d+        , Internal e+        )++    desugar = desugarTup5 typeCtx+    sugar   = sugarTup5 typeCtx++instance+    ( Syntax a+    , Syntax b+    , Syntax c+    , Syntax d+    , Syntax e+    , Syntax f+    ) =>+      Syntactic (a,b,c,d,e,f) FeldDomainAll+  where+    type Internal (a,b,c,d,e,f) =+        ( Internal a+        , Internal b+        , Internal c+        , Internal d+        , Internal e+        , Internal f+        )++    desugar = desugarTup6 typeCtx+    sugar   = sugarTup6 typeCtx++instance+    ( Syntax a+    , Syntax b+    , Syntax c+    , Syntax d+    , Syntax e+    , Syntax f+    , Syntax g+    ) =>+      Syntactic (a,b,c,d,e,f,g) FeldDomainAll+  where+    type Internal (a,b,c,d,e,f,g) =+        ( Internal a+        , Internal b+        , Internal c+        , Internal d+        , Internal e+        , Internal f+        , Internal g+        )++    desugar = desugarTup7 typeCtx+    sugar   = sugarTup7 typeCtx++instance (Syntax a, Syntax b)                                                   => Syntax (a,b)+instance (Syntax a, Syntax b, Syntax c)                                         => Syntax (a,b,c)+instance (Syntax a, Syntax b, Syntax c, Syntax d)                               => Syntax (a,b,c,d)+instance (Syntax a, Syntax b, Syntax c, Syntax d, Syntax e)                     => Syntax (a,b,c,d,e)+instance (Syntax a, Syntax b, Syntax c, Syntax d, Syntax e, Syntax f)           => Syntax (a,b,c,d,e,f)+instance (Syntax a, Syntax b, Syntax c, Syntax d, Syntax e, Syntax f, Syntax g) => Syntax (a,b,c,d,e,f,g)++++instance+    ( Annotatable a+    , Annotatable b+    ) =>+      Annotatable (a,b)+  where+    annotate info (a,b) =+        ( annotate (info ++ " (tuple element 1)") a+        , annotate (info ++ " (tuple element 2)") b+        )++instance+    ( Annotatable a+    , Annotatable b+    , Annotatable c+    ) =>+      Annotatable (a,b,c)+  where+    annotate info (a,b,c) =+        ( annotate (info ++ " (tuple element 1)") a+        , annotate (info ++ " (tuple element 2)") b+        , annotate (info ++ " (tuple element 3)") c+        )++instance+    ( Annotatable a+    , Annotatable b+    , Annotatable c+    , Annotatable d+    ) =>+      Annotatable (a,b,c,d)+  where+    annotate info (a,b,c,d) =+        ( annotate (info ++ " (tuple element 1)") a+        , annotate (info ++ " (tuple element 2)") b+        , annotate (info ++ " (tuple element 3)") c+        , annotate (info ++ " (tuple element 4)") d+        )++instance+    ( Annotatable a+    , Annotatable b+    , Annotatable c+    , Annotatable d+    , Annotatable e+    ) =>+      Annotatable (a,b,c,d,e)+  where+    annotate info (a,b,c,d,e) =+        ( annotate (info ++ " (tuple element 1)") a+        , annotate (info ++ " (tuple element 2)") b+        , annotate (info ++ " (tuple element 3)") c+        , annotate (info ++ " (tuple element 4)") d+        , annotate (info ++ " (tuple element 5)") e+        )++instance+    ( Annotatable a+    , Annotatable b+    , Annotatable c+    , Annotatable d+    , Annotatable e+    , Annotatable f+    ) =>+      Annotatable (a,b,c,d,e,f)+  where+    annotate info (a,b,c,d,e,f) =+        ( annotate (info ++ " (tuple element 1)") a+        , annotate (info ++ " (tuple element 2)") b+        , annotate (info ++ " (tuple element 3)") c+        , annotate (info ++ " (tuple element 4)") d+        , annotate (info ++ " (tuple element 5)") e+        , annotate (info ++ " (tuple element 6)") f+        )++instance+    ( Annotatable a+    , Annotatable b+    , Annotatable c+    , Annotatable d+    , Annotatable e+    , Annotatable f+    , Annotatable g+    ) =>+      Annotatable (a,b,c,d,e,f,g)+  where+    annotate info (a,b,c,d,e,f,g) =+        ( annotate (info ++ " (tuple element 1)") a+        , annotate (info ++ " (tuple element 2)") b+        , annotate (info ++ " (tuple element 3)") c+        , annotate (info ++ " (tuple element 4)") d+        , annotate (info ++ " (tuple element 5)") e+        , annotate (info ++ " (tuple element 6)") f+        , annotate (info ++ " (tuple element 7)") g+        )+
− Feldspar/Core/Functions.hs 
@@ -1,40 +0,0 @@-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----import Prelude ()--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-
− Feldspar/Core/Functions/Array.hs 
@@ -1,88 +0,0 @@--- | 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-
− Feldspar/Core/Functions/Bits.hs 
@@ -1,202 +0,0 @@--- | 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-
− Feldspar/Core/Functions/Complex.hs 
@@ -1,51 +0,0 @@--- | 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-
− Feldspar/Core/Functions/Conversion.hs 
@@ -1,46 +0,0 @@--- | 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)
− Feldspar/Core/Functions/Eq.hs 
@@ -1,98 +0,0 @@--- | 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)-
− Feldspar/Core/Functions/Floating.hs 
@@ -1,31 +0,0 @@--- | 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-
− Feldspar/Core/Functions/Fractional.hs 
@@ -1,29 +0,0 @@-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-
− Feldspar/Core/Functions/Integral.hs 
@@ -1,133 +0,0 @@-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-
− Feldspar/Core/Functions/Logic.hs 
@@ -1,38 +0,0 @@-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-
− Feldspar/Core/Functions/Num.hs 
@@ -1,179 +0,0 @@--- | 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-
− Feldspar/Core/Functions/Ord.hs 
@@ -1,185 +0,0 @@-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-
− Feldspar/Core/Functions/Trace.hs 
@@ -1,21 +0,0 @@--- | 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-
− Feldspar/Core/Functions/Tuple.hs 
@@ -1,39 +0,0 @@--- | 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)-
+ Feldspar/Core/Interpretation.hs view
@@ -0,0 +1,398 @@+--+-- Copyright (c) 2009-2011, ERICSSON AB+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are met:+-- +--     * Redistributions of source code must retain the above copyright notice, +--       this list of conditions and the following disclaimer.+--     * Redistributions in binary form must reproduce the above copyright+--       notice, this list of conditions and the following disclaimer in the+--       documentation and/or other materials provided with the distribution.+--     * Neither the name of the ERICSSON AB nor the names of its contributors+--       may be used to endorse or promote products derived from this software+--       without specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+--++{-# LANGUAGE UndecidableInstances #-}++-- | Defines different interpretations of Feldspar programs++module Feldspar.Core.Interpretation+    ( module Language.Syntactic.Constructs.Decoration++    , targetSpecialization+    , Sharable (..)+    , sharableDecor+    , SizeProp (..)+    , sizePropDefault+    , resultType+    , SourceInfo+    , Info (..)+    , mkInfo+    , mkInfoTy+    , infoRange+    , LatticeSize1 (..)+    , viewLiteral+    , literalDecor+    , constFold+    , SomeInfo (..)+    , Env (..)+    , localVar+    , localSource+    , Opt+    , Optimize (..)+    , constructFeat+    , optimizeM+    , optimize+    , constructFeatUnOptDefaultTyp+    , constructFeatUnOptDefault+    , optimizeFeatDefault+    ) where++++import Control.Monad.Reader+import Control.Monad.Writer+import Data.Map as Map+-- import Data.Set as Set+import Data.Typeable (Typeable)++import Language.Syntactic+import Language.Syntactic.Constructs.Decoration+import Language.Syntactic.Constructs.Literal+import Language.Syntactic.Constructs.Binding+import qualified Language.Syntactic.Constructs.Binding.Optimize as Synt  -- For Haddock++import Feldspar.Lattice+import Feldspar.Core.Types++++--------------------------------------------------------------------------------+-- * Target specialization+--------------------------------------------------------------------------------++-- | Specialize the program for a target platform with the given native bit+-- width+targetSpecialization :: BitWidth n -> ASTF dom a -> ASTF dom a+-- TODO targetSpecialization :: BitWidth n -> ASTF dom a -> ASTF dom (TargetType n a)+targetSpecialization _ = id++++--------------------------------------------------------------------------------+-- * Code motion+--------------------------------------------------------------------------------++class Sharable dom+  where+    sharable :: dom a -> Bool+    sharable _ = True++instance (Sharable sub1, Sharable sub2) => Sharable (sub1 :+: sub2)+  where+    sharable (InjL a) = sharable a+    sharable (InjR a) = sharable a++sharableDecor :: Sharable dom => Decor info dom a -> Bool+sharableDecor = sharable . decorExpr++++--------------------------------------------------------------------------------+-- * Size propagation+--------------------------------------------------------------------------------++-- | Forwards size propagation+class SizeProp feature+  where+    -- | Size propagation for a symbol given a list of argument sizes+    sizeProp :: feature a -> Args (WrapFull Info) a -> Size (DenResult a)++-- | Convenient default implementation of 'sizeProp'+sizePropDefault :: (WitnessSat feature, SatContext feature ~ TypeCtx) =>+    feature a -> Args (WrapFull Info) a -> Size (DenResult a)+sizePropDefault a _+    | TypeWit <- fromSatWit $ witnessSat a = universal++++--------------------------------------------------------------------------------+-- * Optimization and type/size inference+--------------------------------------------------------------------------------++-- | Compute a type representation of a symbol's result type+resultType :: Type (DenResult a) => c a -> TypeRep (DenResult a)+resultType _ = typeRep++type Bag a = Map a Integer+  -- TODO Currently just used as a set. We should either switch back to+  --      `Data.Set` or provide a proper bag interface. For example,+  --      `Data.Map.member` doesn't do the right thing on a bag, since it should+  --      return false also if the key maps to the value 0.++-- | Information about the source code of an expression+type SourceInfo = String++-- | Type and size information of a Feldspar program+data Info a+  where+    Info+      :: Show (Size a)+      => { infoType   :: TypeRep a+         , infoSize   :: Size a+         , infoVars   :: Bag VarId+         , infoSource :: SourceInfo+         }+      -> Info a++instance Render Info+  where+    render i@(Info {}) = show (infoType i) ++ szStr ++ srcStr+      where+        szStr = case show (infoSize i) of+          "()" -> ""  -- TODO AnySize+          str  -> " | " ++ str++        srcStr = case infoSource i of+          ""  -> ""+          src -> " | " ++ src++instance Eq (Size a) => Eq (Info a)+  where+    ia == ib = infoSize ia == infoSize ib+      -- TODO++mkInfo :: Type a => Size a -> Info a+mkInfo sz = Info typeRep sz Map.empty ""++mkInfoTy :: (Show (Size a), Lattice (Size a)) => TypeRep a -> Info a+mkInfoTy t = Info t universal Map.empty ""++infoRange :: Type a => Info a -> RangeSet a+infoRange = sizeToRange . infoSize++-- | This class is used to allow constructs to be abstract in the monad. Its+-- purpose is similar to that of 'MonadType'.+class LatticeSize1 m+  where+    mergeSize :: Lattice (Size a) =>+        Info (m a) -> Size (m a) -> Size (m a) -> Size (m a)+  -- TODO Is this class needed? See comment to `MonadType`.++instance LatticeSize1 Mut+  where+    mergeSize _ = (\/)++-- | 'Info' with hidden result type+data SomeInfo+  where+    SomeInfo :: Typeable a => Info a -> SomeInfo++data Env = Env+    { varEnv    :: [(VarId, SomeInfo)]+    , sourceEnv :: SourceInfo+    }++-- | Initial environment+initEnv :: Env+initEnv = Env [] ""++-- | Insert a variable into the environment+localVar :: Typeable b => VarId -> Info b -> Opt a -> Opt a+localVar v info = local $ \env -> env {varEnv = (v, SomeInfo info):varEnv env}++-- | Change the 'SourceInfo' environment+localSource :: SourceInfo -> Opt a -> Opt a+localSource src = local $ \env -> env {sourceEnv = src}++-- | It the expression is a literal, its value is returned, otherwise 'Nothing'+viewLiteral :: (Literal TypeCtx :<: dom) => ASTF (Decor info dom) a -> Maybe a+viewLiteral (prjDecorCtx typeCtx -> Just (_,Literal a)) = Just a+viewLiteral _ = Nothing++-- | Construct a 'Literal' decorated with 'Info'+literalDecorSrc :: (Type a, Literal TypeCtx :<: dom) =>+    SourceInfo -> a -> ASTF (Decor Info dom) a+literalDecorSrc src a = injDecor+    ((mkInfo (sizeOf a)) {infoSource = src})+    (Literal a `withContext` typeCtx)++-- | Construct a 'Literal' decorated with 'Info'+literalDecor :: (Type a, Literal TypeCtx :<: dom) =>+    a -> ASTF (Decor Info dom) a+literalDecor = literalDecorSrc ""+  -- Note: This function could get the 'SourceInfo' from the environment and+  -- insert it in the 'infoSource' field. But then it needs to be monadic which+  -- makes optimizations uglier.++-- | Replaces an expression with a literal if the type permits, otherwise+-- returns the expression unchanged.+constFold :: (MaybeWitnessSat TypeCtx dom, Literal TypeCtx :<: dom) =>+    SourceInfo -> ASTF (Decor Info dom) a -> a -> ASTF (Decor Info dom) a+constFold src expr a+    | Just TypeWit <- fromSatWit `fmap` maybeWitnessSat typeCtx expr+    = literalDecorSrc src a+constFold _ expr _ = expr++-- | Environment for optimization+type Opt = Reader Env++-- | Basic optimization of a feature+--+-- This optimization is similar to 'Synt.Optimize', but it also performs size+-- inference. Size inference has to be done simultaneously with other+-- optimizations in order to avoid iterating the phases. (Size information may+-- help optimization and optimization may help size inference.)+class+    ( WitnessCons feature+    , MaybeWitnessSat TypeCtx dom+    , AlphaEq dom dom (Decor Info dom) [(VarId, VarId)]+    , EvalBind dom+    , Literal TypeCtx :<: dom+    , Variable TypeCtx :<: dom+    , Lambda TypeCtx :<: dom+    ) =>+      Optimize feature dom+  where+    -- | Top-down and bottom-up optimization of a feature+    optimizeFeat+        :: Optimize dom dom+        => feature a+        -> Args (AST dom) a+        -> Opt (ASTF (Decor Info dom) (DenResult a))+    optimizeFeat = optimizeFeatDefault++    -- | Optimized construction of an expression from a symbol and its optimized+    -- arguments+    --+    -- Note: This function should normally not be called directly. Instead, use+    -- 'constructFeat' which has more accurate propagation of 'Info'.+    constructFeatOpt+        :: feature a+        -> Args (AST (Decor Info dom)) a+        -> Opt (ASTF (Decor Info dom) (DenResult a))+    constructFeatOpt = constructFeatUnOpt++    -- | Unoptimized construction of an expression from a symbol and its+    -- optimized arguments+    constructFeatUnOpt+        :: feature a+        -> Args (AST (Decor Info dom)) a+        -> Opt (ASTF (Decor Info dom) (DenResult a))++-- TODO Optimization should throw an error when the size of a node is+--      over-constrained. It can only happen if there's a bug in the general+--      size inference, or if the user has stated invalid size constraints. In+--      both cases it may lead to incorrect optimizations, so throwing an error+--      seems preferable.++-- | Optimized construction of an expression from a symbol and its optimized+-- arguments+constructFeat :: Optimize feature dom+    => feature a+    -> Args (AST (Decor Info dom)) a+    -> Opt (ASTF (Decor Info dom) (DenResult a))+constructFeat a args = do+    aUnOpt <- constructFeatUnOpt a args+    aOpt   <- constructFeatOpt a args+    return $ updateDecor (const $ getInfo aUnOpt) aOpt+  -- This function uses `constructFeatOpt` for optimization and+  -- `constructFeatUnOpt` for propagation of `Info`. This is because+  -- `constructFeatOpt` may forget size constraints added by `SizeProp`. It is+  -- reasonable to assume that `aUnOpt` has at least as accurate `Info` as+  -- `aOpt`, so we just replace the `Info` with the one from `aUnOpt`. Another+  -- option would have been to meet the two lattices.++instance (Optimize sub1 dom, Optimize sub2 dom) =>+    Optimize (sub1 :+: sub2) dom+  where+    optimizeFeat (InjL a) = optimizeFeat a+    optimizeFeat (InjR a) = optimizeFeat a++    constructFeatOpt (InjL a) = constructFeatOpt a+    constructFeatOpt (InjR a) = constructFeatOpt a++    constructFeatUnOpt (InjL a) = constructFeatUnOpt a+    constructFeatUnOpt (InjR a) = constructFeatUnOpt a++-- | Optimization of an expression+--+-- In addition to running 'optimizeFeat', this function performs constant+-- folding on all closed expressions, provided that the type permits making a+-- literal.+optimizeM :: Optimize dom dom => ASTF dom a -> Opt (ASTF (Decor Info dom) a)+optimizeM a = do+    aOpt <- transformNode optimizeFeat a+    let vars  = infoVars $ getInfo aOpt+        value = evalBind aOpt+        src   = infoSource $ getInfo aOpt+    if Map.null vars+       then return $ constFold src aOpt value+       else return aOpt+  -- TODO singleton range --> literal+  --      literal         --> singleton range++-- | Optimization of an expression. This function runs 'optimizeM' and extracts+-- the result.+optimize :: Optimize dom dom => ASTF dom a -> ASTF (Decor Info dom) a+optimize = flip runReader initEnv . optimizeM++-- | Convenient default implementation of 'constructFeatUnOpt'. Uses 'sizeProp'+-- to propagate size.+constructFeatUnOptDefaultTyp+    :: ( feature :<: dom+       , WitnessCons feature+       , SizeProp feature+       , Show (Size (DenResult a))+       )+    => TypeRep (DenResult a)+    -> feature a+    -> Args (AST (Decor Info dom)) a+    -> Opt (ASTF (Decor Info dom) (DenResult a))+constructFeatUnOptDefaultTyp typ feat args+    | ConsWit <- witnessCons feat+    = do+        src <- asks sourceEnv+        let sz   = sizeProp feat $ mapArgs (WrapFull . getInfo) args+            vars = Map.unions $ listArgs (infoVars . getInfo) args+        return $ appArgs (injDecor (Info typ sz vars src) feat) args++-- | Like 'constructFeatUnOptDefaultTyp' but without an explicit 'TypeRep'+constructFeatUnOptDefault+    :: ( feature :<: dom+       , WitnessCons feature+       , WitnessSat feature+       , SatContext feature ~ TypeCtx+       , SizeProp feature+       )+    => feature a+    -> Args (AST (Decor Info dom)) a+    -> Opt (ASTF (Decor Info dom) (DenResult a))+constructFeatUnOptDefault feat+    | ConsWit <- witnessCons feat+    , TypeWit <- fromSatWit $ witnessSat feat+    = constructFeatUnOptDefaultTyp typeRep feat++-- | Convenient default implementation of 'optimizeFeat'+optimizeFeatDefault :: (Optimize feature dom, Optimize dom dom)+    => feature a+    -> Args (AST dom) a+    -> Opt (ASTF (Decor Info dom) (DenResult a))+optimizeFeatDefault feat args+    | ConsWit <- witnessCons feat+    = constructFeat feat =<< mapArgsM optimizeM args+
− Feldspar/Core/Representation.hs 
@@ -1,323 +0,0 @@-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...-
Feldspar/Core/Types.hs view
@@ -1,17 +1,58 @@+--+-- Copyright (c) 2009-2011, 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 #-}+ module Feldspar.Core.Types where   +import Control.Monad+import Data.Array.IO import Data.Bits import Data.Complex import Data.Int+import Data.IORef import Data.List-import Data.Tagged-import Data.Proxy-import Data.Typeable (Typeable)+import Data.Typeable (Typeable, gcast) import Data.Word+import Test.QuickCheck+import qualified Control.Monad.Par as MonadPar -import Feldspar.Set+import Data.Patch++import Data.Proxy++import Data.Typeable (Typeable1)++import Language.Syntactic++import Feldspar.Lattice import Feldspar.Range  @@ -26,7 +67,7 @@  infixr 5 :> -instance (Set a, Set b) => Set (a :> b)+instance (Lattice a, Lattice b) => Lattice (a :> b)   where     empty     = empty :> empty     universal = universal :> universal@@ -39,276 +80,752 @@ -- * Integers -------------------------------------------------------------------------------- --- | Platform-independent unsigned integers-newtype DefaultWord = DefaultWord Word32-  deriving (Eq, Ord, Num, Enum, Real, Integral, Bits, Bounded, Typeable)-  -- TODO Find better name+-- | Target-dependent unsigned integers+newtype WordN = WordN Word32+  deriving+    ( Eq, Ord, Num, Enum, Ix, Real, Integral, Bits, Bounded, Typeable+    , Arbitrary ) --- | Platform-independent signed integers-newtype DefaultInt = DefaultInt Int32-  deriving (Eq, Ord, Num, Enum, Real, Integral, Bits, Bounded, Typeable)-  -- TODO Find better name+-- | Target-dependent signed integers+newtype IntN = IntN Int32+  deriving+    ( Eq, Ord, Num, Enum, Ix, Real, Integral, Bits, Bounded, Typeable+    , Arbitrary ) --- TODO Should really be defined as:------     data DefaultWord---         = DefWord32 Word32---         | DefWord16 Word16------     data DefaultInt---         = DefInt32 Int32---         | DefInt16 Int16+instance Show WordN+  where+    show (WordN a) = show a -type Length = DefaultWord-type Index  = DefaultWord+instance Show IntN+  where+    show (IntN a) = show a -instance Show DefaultWord+-- | Type representation of 8 bits+data N8++-- | Type representation of 16 bits+data N16++-- | Type representation of 32 bits+data N32++-- | Type representation of 64 bits+data N64++-- | Type representation of the native number of bits on the target+data NNative++-- | Witness for 'N8', 'N16', 'N32', 'N64' or 'NNative'+data BitWidth n   where-    show (DefaultWord a) = show a+    N8      :: BitWidth N8+    N16     :: BitWidth N16+    N32     :: BitWidth N32+    N64     :: BitWidth N64+    NNative :: BitWidth NNative -instance Show DefaultInt+bitWidth :: BitWidth n -> String+bitWidth N8      = "8"+bitWidth N16     = "16"+bitWidth N32     = "32"+bitWidth N64     = "64"+bitWidth NNative = "N"++-- | Type representation of \"unsigned\"+data U++-- | Type representation of \"signed\"+data S++-- | Witness for 'U' or 'S'+data Signedness s   where-    show (DefaultInt a) = show a+    U :: Signedness U+    S :: Signedness S --- | The set of signed integer types-class Signed a+signedness :: Signedness s -> String+signedness U = "Word"+signedness S = "Int" -instance Signed Int8-instance Signed Int16-instance Signed Int32-instance Signed DefaultInt+-- | A generalization of unsigned and signed integers. The first parameter+-- represents the signedness and the sectond parameter the number of bits.+type family GenericInt s n+type instance GenericInt U N8      = Word8+type instance GenericInt S N8      = Int8+type instance GenericInt U N16     = Word16+type instance GenericInt S N16     = Int16+type instance GenericInt U N32     = Word32+type instance GenericInt S N32     = Int32+type instance GenericInt U N64     = Word64+type instance GenericInt S N64     = Int64+type instance GenericInt U NNative = WordN+type instance GenericInt S NNative = IntN +type family WidthOf a+type instance WidthOf Word8  = N8+type instance WidthOf Int8   = N8+type instance WidthOf Word16 = N16+type instance WidthOf Int16  = N16+type instance WidthOf Word32 = N32+type instance WidthOf Int32  = N32+type instance WidthOf Word64 = N64+type instance WidthOf Int64  = N64+type instance WidthOf WordN  = NNative+type instance WidthOf IntN   = NNative +type family SignOf a+type instance SignOf Word8  = U+type instance SignOf Int8   = S+type instance SignOf Word16 = U+type instance SignOf Int16  = S+type instance SignOf Word32 = U+type instance SignOf Int32  = S+type instance SignOf Word64 = U+type instance SignOf Int64  = S+type instance SignOf WordN  = U+type instance SignOf IntN   = S +fromWordN :: BitWidth n -> WordN -> GenericInt U n+fromWordN N8      = fromInteger . toInteger+fromWordN N16     = fromInteger . toInteger+fromWordN N32     = fromInteger . toInteger+fromWordN N64     = fromInteger . toInteger+fromWordN NNative = id+  -- TODO Check that the number fits++fromIntN :: BitWidth n -> IntN -> GenericInt S n+fromIntN N8      = fromInteger . toInteger+fromIntN N16     = fromInteger . toInteger+fromIntN N32     = fromInteger . toInteger+fromIntN N64     = fromInteger . toInteger+fromIntN NNative = id+  -- TODO Check that the number fits++genericLen :: BitWidth n -> [a] -> GenericInt U n+genericLen N8      = genericLength+genericLen N16     = genericLength+genericLen N32     = genericLength+genericLen N64     = genericLength+genericLen NNative = genericLength++type Length = WordN+type Index  = WordN+++ ----------------------------------------------------------------------------------- * Type/data representation+-- * Arrays -------------------------------------------------------------------------------- --- | Representation of types-data TypeRep-  = BoolType-  | forall a . (BoundedInt a, Typeable a) => IntType { intRange :: Range a }-  | FloatType-  | UserType String-  | ComplexType TypeRep-  | ArrayType (Range Length) TypeRep-  | StructType [TypeRep]+-- | Array whose length is represented by an @n@-bit word+data TargetArr n a = TargetArr (GenericInt U n) [a] --- | Representation of data-data DataRep-  = BoolData Bool-  | IntData Integer-  | FloatData Float-  | ComplexData DataRep DataRep-  | ArrayData [DataRep]-  | StructData [DataRep]-  deriving (Eq, Show) -class (Eq a, Show a, Typeable a, Eq (Size a), Show (Size a), Set (Size a)) => Type a+--------------------------------------------------------------------------------+-- * Monadic Types+--------------------------------------------------------------------------------++-- | This class is used to allow constructs to be abstract in the monad+class MonadType m   where-    type Size a+    voidTypeRep :: TypeRep (m ())+  -- TODO Since the `Mut` monad is already abstract, this class is probably only+  --      needed if we want to be able to use monadic constructs with different+  --      monad types. -    dataRep :: a -> DataRep -    -- | Gives the type representation of a storable value.-    typeRep :: Tagged a (Size a) -> TypeRep -    -- | Gives the size of a storable value.-    sizeOf :: a -> Size a+--------------------------------------------------------------------------------+-- * Mutable data+-------------------------------------------------------------------------------- -instance Type ()-  where-    type Size () = ()-    dataRep _    = BoolData False-    typeRep _    = BoolType-    sizeOf _     = ()+-- TODO Make newtypes? -instance Type Bool+-- | Monad for manipulation of mutable data+type Mut = IO++-- | Mutable references+instance Show (IORef a)   where-    type Size Bool = ()-    dataRep        = BoolData-    typeRep _      = BoolType-    sizeOf _       = ()+    show _ = "IORef" -instance Type Word8+-- | Mutable arrays+type MArr a = IOArray Index a++instance Show (MArr a)   where-    type Size Word8 = Range Word8-    dataRep         = IntData . toInteger-    typeRep         = IntType . untag-    sizeOf a        = singletonRange a+    show _ = "MArr" -instance Type Int8+instance MonadType Mut   where-    type Size Int8 = Range Int8-    dataRep        = IntData . toInteger-    typeRep        = IntType . untag-    sizeOf a       = singletonRange a+    voidTypeRep = MutType UnitType -instance Type Word16++--------------------------------------------------------------------------------+-- * Par Monad+--------------------------------------------------------------------------------++-- | Monad for parallel constructs+type Par = MonadPar.Par++deriving instance Typeable1 Par++-- | Immutable references+type IV = MonadPar.IVar++deriving instance Typeable1 IV++instance Show (IV a)   where-    type Size Word16 = Range Word16-    dataRep          = IntData . toInteger-    typeRep          = IntType . untag-    sizeOf a         = singletonRange a+    show _ = "IVar" -instance Type Int16+instance Eq (IV a)   where-    type Size Int16 = Range Int16-    dataRep         = IntData . toInteger-    typeRep         = IntType . untag-    sizeOf a        = singletonRange a+    a == b = False -instance Type Word32+instance MonadType Par   where-    type Size Word32 = Range Word32-    dataRep          = IntData . toInteger-    typeRep          = IntType . untag-    sizeOf a         = singletonRange a+    voidTypeRep = ParType UnitType -instance Type Int32+--------------------------------------------------------------------------------+-- * Type representation+--------------------------------------------------------------------------------++-- | Representation of supported types+data TypeRep a   where-    type Size Int32 = Range Int32-    dataRep         = IntData . toInteger-    typeRep         = IntType . untag-    sizeOf a        = singletonRange a+    UnitType      :: TypeRep ()+    BoolType      :: TypeRep Bool+    IntType       :: ( BoundedInt (GenericInt s n)+                     , Size (GenericInt s n) ~ Range (GenericInt s n)+                     ) =>+                       Signedness s -> BitWidth n -> TypeRep (GenericInt s n)+    FloatType     :: TypeRep Float+    ComplexType   :: RealFloat a => TypeRep a -> TypeRep (Complex a)+    ArrayType     :: TypeRep a -> TypeRep [a]+    TargetArrType :: BitWidth n -> TypeRep a -> TypeRep (TargetArr n a)+    Tup2Type      :: TypeRep a -> TypeRep b -> TypeRep (a,b)+    Tup3Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep (a,b,c)+    Tup4Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep d -> TypeRep (a,b,c,d)+    Tup5Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep d -> TypeRep e -> TypeRep (a,b,c,d,e)+    Tup6Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep d -> TypeRep e -> TypeRep f -> TypeRep (a,b,c,d,e,f)+    Tup7Type      :: TypeRep a -> TypeRep b -> TypeRep c -> TypeRep d -> TypeRep e -> TypeRep f -> TypeRep g -> TypeRep (a,b,c,d,e,f,g)+    FunType       :: TypeRep a -> TypeRep b -> TypeRep (a -> b)+    MutType       :: TypeRep a -> TypeRep (Mut a)+    RefType       :: TypeRep a -> TypeRep (IORef a)+    MArrType      :: TypeRep a -> TypeRep (MArr a)+    ParType       :: TypeRep a -> TypeRep (Par a)+    IVarType      :: TypeRep a -> TypeRep (IV a)+      -- TODO `MArrType` Should have a target-specialized version. Or perhaps+      --      use a single type with a flag to distinguish between immutable and+      --      mutable arrays. -instance Type DefaultWord+instance Show (TypeRep a)   where-    type Size DefaultWord = Range DefaultWord-    dataRep               = IntData . toInteger-    typeRep               = IntType . untag-    sizeOf a              = singletonRange a+    show UnitType            = "()"+    show BoolType            = "Bool"+    show (IntType s n)       = signedness s ++ bitWidth n+    show FloatType           = "Float"+    show (ComplexType t)     = "(Complex " ++ show t ++ ")"+    show (ArrayType t)       = "[" ++ show t ++ "]"+    show (TargetArrType _ t) = "[" ++ show t ++ "]"+    show (Tup2Type ta tb)                = showTup [show ta, show tb]+    show (Tup3Type ta tb tc)             = showTup [show ta, show tb, show tc]+    show (Tup4Type ta tb tc td)          = showTup [show ta, show tb, show tc, show td]+    show (Tup5Type ta tb tc td te)       = showTup [show ta, show tb, show tc, show td, show te]+    show (Tup6Type ta tb tc td te tf)    = showTup [show ta, show tb, show tc, show td, show te, show tf]+    show (Tup7Type ta tb tc td te tf tg) = showTup [show ta, show tb, show tc, show td, show te, show tf, show tg]+    show (FunType ta tb)                 = show ta ++ " -> " ++ show tb+    show (MutType ta)                    = unwords ["Mut", show ta]+    show (RefType ta)                    = unwords ["Ref", show ta]+    show (MArrType ta)                   = unwords ["MArr", show ta]+    show (ParType ta)                    = unwords ["Par", show ta]+    show (IVarType ta)                   = unwords ["IVar", show ta] -instance Type DefaultInt+argType :: TypeRep (a -> b) -> TypeRep a+argType (FunType ta _) = ta++resType :: TypeRep (a -> b) -> TypeRep b+resType (FunType _ tb) = tb++-- | Type equality witness+data TypeEq a b   where-    type Size DefaultInt = Range DefaultInt-    dataRep              = IntData . toInteger-    typeRep              = IntType . untag-    sizeOf a             = singletonRange a+    TypeEq :: TypeEq a a -instance Type Float+defaultSize :: TypeRep a -> Size a+defaultSize UnitType = universal+defaultSize BoolType = universal+defaultSize (IntType s n) = universal+defaultSize FloatType = universal+defaultSize (ComplexType t) = universal+defaultSize (ArrayType t) = universal :> defaultSize t+--defaultSize (TargetArrType n t) = universal :> defaultSize t -- TODO+defaultSize (Tup2Type ta tb) =  ( defaultSize ta+                                , defaultSize tb+                                )+defaultSize (Tup3Type ta tb tc) = ( defaultSize ta+                                  , defaultSize tb+                                  , defaultSize tc+                                  )+defaultSize (Tup4Type ta tb tc td) = ( defaultSize ta+                                     , defaultSize tb+                                     , defaultSize tc+                                     , defaultSize td+                                     )+defaultSize (Tup5Type ta tb tc td te) = ( defaultSize ta+                                        , defaultSize tb+                                        , defaultSize tc+                                        , defaultSize td+                                        , defaultSize te+                                        )+defaultSize (Tup6Type ta tb tc td te tf) = ( defaultSize ta+                                           , defaultSize tb+                                           , defaultSize tc+                                           , defaultSize td+                                           , defaultSize te+                                           , defaultSize tf+                                           )+defaultSize (Tup7Type ta tb tc td te tf tg) = ( defaultSize ta+                                              , defaultSize tb+                                              , defaultSize tc+                                              , defaultSize td+                                              , defaultSize te+                                              , defaultSize tf+                                              , defaultSize tg+                                              )+defaultSize (FunType ta tb) = defaultSize tb+defaultSize (MutType ta) = defaultSize ta+defaultSize (RefType ta) = defaultSize ta+defaultSize (MArrType ta) = universal :> defaultSize ta+defaultSize (ParType ta) = defaultSize ta+defaultSize (IVarType ta) = defaultSize ta++-- | Type equality on 'Signedness'+signEq :: Signedness s1 -> Signedness s2 -> Maybe (TypeEq s1 s2)+signEq U U = Just TypeEq+signEq S S = Just TypeEq+signEq _ _ = Nothing++-- | Type equality on 'BitWidth'+widthEq :: BitWidth n1 -> BitWidth n2 -> Maybe (TypeEq n1 n2)+widthEq N8      N8      = Just TypeEq+widthEq N16     N16     = Just TypeEq+widthEq N32     N32     = Just TypeEq+widthEq N64     N64     = Just TypeEq+widthEq NNative NNative = Just TypeEq+widthEq _ _ = Nothing++-- | Type equality on 'TypeRep'+typeEq :: TypeRep a -> TypeRep b -> Maybe (TypeEq a b)+typeEq UnitType UnitType = Just TypeEq+typeEq BoolType BoolType = Just TypeEq+typeEq (IntType s1 n1) (IntType s2 n2) = do+    TypeEq <- signEq s1 s2+    TypeEq <- widthEq n1 n2+    return TypeEq+typeEq FloatType FloatType = Just TypeEq+typeEq (ComplexType t1) (ComplexType t2) = do+    TypeEq <- typeEq t1 t2+    return TypeEq+typeEq (ArrayType t1) (ArrayType t2) = do+    TypeEq <- typeEq t1 t2+    return TypeEq+typeEq (TargetArrType n1 t1) (TargetArrType n2 t2) = do+    TypeEq <- widthEq n1 n2+    TypeEq <- typeEq t1 t2+    return TypeEq+typeEq (Tup2Type a1 b1) (Tup2Type a2 b2) = do+    TypeEq <- typeEq a1 a2+    TypeEq <- typeEq b1 b2+    return TypeEq+typeEq (Tup3Type a1 b1 c1) (Tup3Type a2 b2 c2) = do+    TypeEq <- typeEq a1 a2+    TypeEq <- typeEq b1 b2+    TypeEq <- typeEq c1 c2+    return TypeEq+typeEq (Tup4Type a1 b1 c1 d1) (Tup4Type a2 b2 c2 d2) = do+    TypeEq <- typeEq a1 a2+    TypeEq <- typeEq b1 b2+    TypeEq <- typeEq c1 c2+    TypeEq <- typeEq d1 d2+    return TypeEq+typeEq (Tup5Type a1 b1 c1 d1 e1) (Tup5Type a2 b2 c2 d2 e2) = do+    TypeEq <- typeEq a1 a2+    TypeEq <- typeEq b1 b2+    TypeEq <- typeEq c1 c2+    TypeEq <- typeEq d1 d2+    TypeEq <- typeEq e1 e2+    return TypeEq+typeEq (Tup6Type a1 b1 c1 d1 e1 f1) (Tup6Type a2 b2 c2 d2 e2 f2) = do+    TypeEq <- typeEq a1 a2+    TypeEq <- typeEq b1 b2+    TypeEq <- typeEq c1 c2+    TypeEq <- typeEq d1 d2+    TypeEq <- typeEq e1 e2+    TypeEq <- typeEq f1 f2+    return TypeEq+typeEq (Tup7Type a1 b1 c1 d1 e1 f1 g1) (Tup7Type a2 b2 c2 d2 e2 f2 g2) = do+    TypeEq <- typeEq a1 a2+    TypeEq <- typeEq b1 b2+    TypeEq <- typeEq c1 c2+    TypeEq <- typeEq d1 d2+    TypeEq <- typeEq e1 e2+    TypeEq <- typeEq f1 f2+    TypeEq <- typeEq g1 g2+    return TypeEq+typeEq (FunType a1 b1) (FunType a2 b2) = do+    TypeEq <- typeEq a1 a2+    TypeEq <- typeEq b1 b2+    return TypeEq+typeEq (MutType t1) (MutType t2) = do+    TypeEq <- typeEq t1 t2+    return TypeEq+typeEq (RefType t1) (RefType t2) = do+    TypeEq <- typeEq t1 t2+    return TypeEq+typeEq (MArrType a1) (MArrType a2) = do+    TypeEq <- typeEq a1 a2+    return TypeEq+typeEq (ParType t1) (ParType t2) = do+    TypeEq <- typeEq t1 t2+    return TypeEq+typeEq (IVarType t1) (IVarType t2) = do+    TypeEq <- typeEq t1 t2+    return TypeEq++typeEq _ _ = Nothing++showTup :: [String] -> String+showTup as =  "(" ++ concat (intersperse "," as) ++ ")"++type family TargetType n a+type instance TargetType n ()              = ()+type instance TargetType n Bool            = Bool+type instance TargetType n Word8           = Word8+type instance TargetType n Int8            = Int8+type instance TargetType n Word16          = Word16+type instance TargetType n Int16           = Int16+type instance TargetType n Word32          = Word32+type instance TargetType n Int32           = Int32+type instance TargetType n Word64          = Word64+type instance TargetType n Int64           = Int64+type instance TargetType n WordN           = GenericInt U n+type instance TargetType n IntN            = GenericInt S n+type instance TargetType n Float           = Float+type instance TargetType n (Complex a)     = Complex (TargetType n a)+type instance TargetType n [a]             = TargetArr n (TargetType n a)+type instance TargetType n (a,b)           = (TargetType n a, TargetType n b)+type instance TargetType n (a,b,c)         = (TargetType n a, TargetType n b, TargetType n c)+type instance TargetType n (a,b,c,d)       = (TargetType n a, TargetType n b, TargetType n c, TargetType n d)+type instance TargetType n (a,b,c,d,e)     = (TargetType n a, TargetType n b, TargetType n c, TargetType n d, TargetType n e)+type instance TargetType n (a,b,c,d,e,f)   = (TargetType n a, TargetType n b, TargetType n c, TargetType n d, TargetType n e, TargetType n f)+type instance TargetType n (a,b,c,d,e,f,g) = (TargetType n a, TargetType n b, TargetType n c, TargetType n d, TargetType n e, TargetType n f, TargetType n g)+type instance TargetType n (IORef a)       = IORef (TargetType n a)+type instance TargetType n (MArr a)        = MArr (TargetType n a)+type instance TargetType n (IV a)          = IV (TargetType n a)++-- | The set of supported types+class (Eq a, Show a, Typeable a, Show (Size a), Lattice (Size a)) => Type a   where-    type Size Float = ()-    dataRep         = FloatData-    typeRep _       = FloatType-    sizeOf _        = ()+    -- | Gives the type representation a value.+    typeRep  :: TypeRep a+    sizeOf   :: a -> Size a+    toTarget :: BitWidth n -> a -> TargetType n a +instance Type ()      where typeRep = UnitType;          sizeOf _ = AnySize;      toTarget _ = id+instance Type Bool    where typeRep = BoolType;          sizeOf _ = AnySize;      toTarget _ = id+instance Type Word8   where typeRep = IntType U N8;      sizeOf = singletonRange; toTarget _ = id+instance Type Int8    where typeRep = IntType S N8;      sizeOf = singletonRange; toTarget _ = id+instance Type Word16  where typeRep = IntType U N16;     sizeOf = singletonRange; toTarget _ = id+instance Type Int16   where typeRep = IntType S N16;     sizeOf = singletonRange; toTarget _ = id+instance Type Word32  where typeRep = IntType U N32;     sizeOf = singletonRange; toTarget _ = id+instance Type Int32   where typeRep = IntType S N32;     sizeOf = singletonRange; toTarget _ = id+instance Type Word64  where typeRep = IntType U N64;     sizeOf = singletonRange; toTarget _ = id+instance Type Int64   where typeRep = IntType S N64;     sizeOf = singletonRange; toTarget _ = id+instance Type WordN   where typeRep = IntType U NNative; sizeOf = singletonRange; toTarget = fromWordN+instance Type IntN    where typeRep = IntType S NNative; sizeOf = singletonRange; toTarget = fromIntN+instance Type Float   where typeRep = FloatType;         sizeOf _ = AnySize;      toTarget _ = id+ instance (Type a, RealFloat a) => Type (Complex a)-  -- 'RealFloat' comes from the constraint on the 'Complex' data type. It-  -- implies 'Floating'   where-    type Size (Complex a) = ()-    dataRep (r :+ i) = ComplexData (dataRep r) (dataRep i)-    typeRep sz = ComplexType $ typeRep (Tagged universal :: Tagged a (Size a))-    sizeOf  _  = ()+    typeRep             = ComplexType typeRep+    sizeOf _            = AnySize+    toTarget n (r :+ i) = error "TODO" -- toTarget n r :+ toTarget n i  instance Type a => Type [a]   where-    type Size [a]            = Range Length :> Size a-    dataRep as               = ArrayData (map dataRep as)-    typeRep (Tagged (l:>sz)) = ArrayType l (typeRep sz')-      where-        sz' = Tagged sz :: Tagged a (Size a)-    sizeOf as = singletonRange (genericLength as) :> unions (map sizeOf as)+    typeRep       = ArrayType typeRep+    sizeOf as     = singletonRange (genericLength as) :> unions (map sizeOf as)+    toTarget n as = TargetArr (genericLen n as) $ map (toTarget n) as  instance (Type a, Type b) => Type (a,b)   where-    type Size (a,b)            = (Size a, Size b)-    dataRep (a,b)              = StructData [dataRep a, dataRep b]-    typeRep (Tagged (sza,szb)) = StructType [typeRep sza', typeRep szb']-      where-        sza' = Tagged sza :: Tagged a (Size a)-        szb' = Tagged szb :: Tagged b (Size b)-    sizeOf (a,b) = (sizeOf a, sizeOf b)+    typeRep = Tup2Type typeRep typeRep +    sizeOf (a,b) =+        ( sizeOf a+        , sizeOf b+        )++    toTarget n (a,b) =+        ( toTarget n a+        , toTarget n b+        )+ instance (Type a, Type b, Type c) => Type (a,b,c)   where-    type Size (a,b,c) = (Size a, Size b, Size c)-    dataRep (a,b,c)   = StructData [dataRep a, dataRep b, dataRep c]-    typeRep (Tagged (sza,szb,szc)) = StructType [typeRep sza', typeRep szb', typeRep szc']-      where-        sza' = Tagged sza :: Tagged a (Size a)-        szb' = Tagged szb :: Tagged b (Size b)-        szc' = Tagged szc :: Tagged c (Size c)-    sizeOf (a,b,c) = (sizeOf a, sizeOf b, sizeOf c)+    typeRep = Tup3Type typeRep typeRep typeRep +    sizeOf (a,b,c) =+        ( sizeOf a+        , sizeOf b+        , sizeOf c+        )++    toTarget n (a,b,c) =+        ( toTarget n a+        , toTarget n b+        , toTarget n c+        )+ instance (Type a, Type b, Type c, Type d) => Type (a,b,c,d)   where-    type Size (a,b,c,d) = (Size a, Size b, Size c, Size d)-    dataRep (a,b,c,d)   = StructData [dataRep a, dataRep b, dataRep c, dataRep d]-    typeRep (Tagged (sza,szb,szc,szd)) = StructType [typeRep sza', typeRep szb', typeRep szc', typeRep szd']-      where-        sza' = Tagged sza :: Tagged a (Size a)-        szb' = Tagged szb :: Tagged b (Size b)-        szc' = Tagged szc :: Tagged c (Size c)-        szd' = Tagged szd :: Tagged d (Size d)-    sizeOf (a,b,c,d) = (sizeOf a, sizeOf b, sizeOf c, sizeOf d)+    typeRep = Tup4Type typeRep typeRep typeRep typeRep --- TODO Document-class MetaType role a+    sizeOf (a,b,c,d) =+        ( sizeOf a+        , sizeOf b+        , sizeOf c+        , sizeOf d+        )++    toTarget n (a,b,c,d) =+        ( toTarget n a+        , toTarget n b+        , toTarget n c+        , toTarget n d+        )++instance (Type a, Type b, Type c, Type d, Type e) => Type (a,b,c,d,e)   where-    listTypes :: [Int] -> Proxy role -> Proxy a -> [([Int], TypeRep)]+    typeRep = Tup5Type typeRep typeRep typeRep typeRep typeRep -instance Type a => MetaType () a+    sizeOf (a,b,c,d,e) =+        ( sizeOf a+        , sizeOf b+        , sizeOf c+        , sizeOf d+        , sizeOf e+        )++    toTarget n (a,b,c,d,e) =+        ( toTarget n a+        , toTarget n b+        , toTarget n c+        , toTarget n d+        , toTarget n e+        )++instance (Type a, Type b, Type c, Type d, Type e, Type f) => Type (a,b,c,d,e,f)   where-    listTypes path _ _ =-        [(path, typeRep (Tagged universal :: Tagged a (Size a)))]+    typeRep = Tup6Type typeRep typeRep typeRep typeRep typeRep typeRep -instance (MetaType ra a, MetaType rb b) => MetaType (ra,rb) (a,b)+    sizeOf (a,b,c,d,e,f) =+        ( sizeOf a+        , sizeOf b+        , sizeOf c+        , sizeOf d+        , sizeOf e+        , sizeOf f+        )++    toTarget n (a,b,c,d,e,f) =+        ( toTarget n a+        , toTarget n b+        , toTarget n c+        , toTarget n d+        , toTarget n e+        , toTarget n f+        )++instance (Type a, Type b, Type c, Type d, Type e, Type f, Type g) => Type (a,b,c,d,e,f,g)   where-    listTypes path _ _-        =  listTypes (1:path) (Proxy :: Proxy ra) (Proxy :: Proxy a)-        ++ listTypes (2:path) (Proxy :: Proxy rb) (Proxy :: Proxy b)+    typeRep = Tup7Type typeRep typeRep typeRep typeRep typeRep typeRep typeRep -instance (MetaType ra a, MetaType rb b, MetaType rc c) =>-    MetaType (ra,rb,rc) (a,b,c)+    sizeOf (a,b,c,d,e,f,g) =+        ( sizeOf a+        , sizeOf b+        , sizeOf c+        , sizeOf d+        , sizeOf e+        , sizeOf f+        , sizeOf g+        )++    toTarget n (a,b,c,d,e,f,g) =+        ( toTarget n a+        , toTarget n b+        , toTarget n c+        , toTarget n d+        , toTarget n e+        , toTarget n f+        , toTarget n g+        )++instance (Type a, Show (IORef a)) => Type (IORef a)   where-    listTypes path _ _-        =  listTypes (1:path) (Proxy :: Proxy ra) (Proxy :: Proxy a)-        ++ listTypes (2:path) (Proxy :: Proxy rb) (Proxy :: Proxy b)-        ++ listTypes (3:path) (Proxy :: Proxy rc) (Proxy :: Proxy c)+    typeRep = RefType typeRep -instance (MetaType ra a, MetaType rb b, MetaType rc c, MetaType rd d) =>-    MetaType (ra,rb,rc,rd) (a,b,c,d)+    sizeOf _ = universal++    toTarget = error "toTarget: IORef"  -- TODO Requires IO++instance Type a => Type (MArr a)   where-    listTypes path _ _-        =  listTypes (1:path) (Proxy :: Proxy ra) (Proxy :: Proxy a)-        ++ listTypes (2:path) (Proxy :: Proxy rb) (Proxy :: Proxy b)-        ++ listTypes (3:path) (Proxy :: Proxy rc) (Proxy :: Proxy c)-        ++ listTypes (4:path) (Proxy :: Proxy rd) (Proxy :: Proxy d)+    typeRep = MArrType typeRep +    sizeOf _ = universal +    toTarget = error "toTarget: MArr"  -- TODO Requires IO --- | A version of 'typeRep' that gets the 'Size' implicitly from the argument.-typeRep' :: forall a . Type a => a -> TypeRep-typeRep' a = typeRep (Tagged (sizeOf a) :: Tagged a (Size a))+instance Type a => Type (IV a)+  where+    typeRep = IVarType typeRep -isNil :: Type a => a -> Bool-isNil a = case dataRep a of-    ArrayData [] -> True-    _            -> False+    sizeOf _ = universal +    toTarget = error "toTarget: IVar" -- TODO Requires IO +typeRepByProxy :: Type a => Proxy a -> TypeRep a+typeRepByProxy _ = typeRep +++-- | Context for supported types+data TypeCtx++instance Type a => Sat TypeCtx a+  where+    data Witness TypeCtx a = Type a => TypeWit+    witness = TypeWit++typeCtx :: Proxy TypeCtx+typeCtx = Proxy+++ ----------------------------------------------------------------------------------- * Size propagation+-- * Sized types -------------------------------------------------------------------------------- -class FullProp a-  where-    -- | Size propagation function that maps any number of arguments to-    -- 'universal'.-    fullProp :: a+data AnySize = AnySize+    deriving (Eq, Show, Ord) -instance FullProp ()+anySizeFun :: AnySize -> AnySize+anySizeFun AnySize = AnySize++anySizeFun2 :: AnySize -> AnySize -> AnySize+anySizeFun2 AnySize AnySize = AnySize++instance Num AnySize   where-    fullProp = universal+    fromInteger _ = AnySize+    abs           = anySizeFun+    signum        = anySizeFun+    (+)           = anySizeFun2+    (-)           = anySizeFun2+    (*)           = anySizeFun2 -instance BoundedInt a => FullProp (Range a)+instance Lattice AnySize   where-    fullProp = universal+    empty     = AnySize+    universal = AnySize+    (\/)      = anySizeFun2+    (/\)      = anySizeFun2 -instance FullProp b => FullProp (a -> b)+type family Size a++type instance Size ()              = AnySize+type instance Size Bool            = AnySize+type instance Size Word8           = Range Word8+type instance Size Int8            = Range Int8+type instance Size Word16          = Range Word16+type instance Size Int16           = Range Int16+type instance Size Word32          = Range Word32+type instance Size Int32           = Range Int32+type instance Size Word64          = Range Word64+type instance Size Int64           = Range Int64+type instance Size WordN           = Range WordN+type instance Size IntN            = Range IntN+type instance Size Float           = AnySize+type instance Size (Complex a)     = AnySize+type instance Size [a]             = Range Length :> Size a+type instance Size (TargetArr n a) = Range (GenericInt U n) :> Size a+type instance Size (a,b)           = (Size a, Size b)+type instance Size (a,b,c)         = (Size a, Size b, Size c)+type instance Size (a,b,c,d)       = (Size a, Size b, Size c, Size d)+type instance Size (a,b,c,d,e)     = (Size a, Size b, Size c, Size d, Size e)+type instance Size (a,b,c,d,e,f)   = (Size a, Size b, Size c, Size d, Size e, Size f)+type instance Size (a,b,c,d,e,f,g) = (Size a, Size b, Size c, Size d, Size e, Size f, Size g)+type instance Size (a -> b)        = Size b+type instance Size (Mut a)         = Size a+type instance Size (IORef a)       = Size a+type instance Size (MArr a)        = Range Length :> Size a+type instance Size (Par a)         = Size a+type instance Size (IV a)          = Size a++-- Note: The instance+--+--     Size (a -> b) = Size b+--+-- might seem strange. In general, the size of a function result depends on the+-- size of the argument, so it might be more natural to have+--+--     Size (a -> b) = Size a -> Size b+--+-- However, this doesn't really work with the `optimize` function, since+-- optimization is done simultaneously with size inference, and the two+-- influence each other. The result of optimization is an optimized expression+-- decorated with a size. If the expression is of function type, the size of the+-- argument has to be provided before optimizing the function body. Yet, the+-- result will be decorated by a value of type `Size a -> Size b`, which+-- suggests that we do not yet know the size of the argument.+--+-- So instead, we represent the size of a function as the size of its result,+-- which means that the size of a function is only valid in a given context.++++-- | A generalization of 'Range' that serves two purposes: (1) Adding an extra+-- 'Universal' constructor to support unbounded types ('Range' can only+-- represent bounded ranges), and (2) pack a 'BoundedInt' constraint with the+-- 'RangeSet' constructor. This is what allows 'sizeToRange' to be defined as a+-- total function with 'Type' as the only constraint.+data RangeSet a   where-    fullProp = const fullProp+    RangeSet  :: BoundedInt a => Range a -> RangeSet a+    Universal :: RangeSet a++-- | Cast a 'Size' to a 'RangeSet'+sizeToRange :: forall a . Type a => Size a -> RangeSet a+sizeToRange sz = case typeRep :: TypeRep a of+    IntType _ _ -> RangeSet sz+    _           -> Universal+++tIntN :: Patch IntN IntN+tIntN = id++tWordN :: Patch WordN WordN+tWordN = id++tIndex :: Patch Index Index+tIndex  = id++tLength :: Patch Length Length+tLength = id++tArr :: Patch a a -> Patch [a] [a]+tArr _ = id
− Feldspar/Core/Wrap.hs 
@@ -1,47 +0,0 @@--- | Module "Data.TypeLevel.Num.Aliases" is re-exported because--- wrappers use type level numbers frequently-module Feldspar.Core.Wrap ( Wrap(..), Data'(..), module Data.TypeLevel.Num.Aliases, D0, D1, D2, D3, D4, D5, D6, D7, D8, D9) where---import Feldspar.DSL.Network-import Feldspar.Core.Types-import Feldspar.Core.Representation--import Data.TypeLevel.Num.Aliases-import Data.TypeLevel.Num.Reps (D0, D1, D2, D3, D4, D5, D6, D7, D8, D9 )----- | Wrapping Feldspar functions-class Wrap t w where-    wrap :: t -> w---- | Basic instances to handle @Data a@ input and output.--- Other instances are located in the concerned libraries.-instance Wrap (Data a) (Data a) where-    wrap = id--instance (Wrap t u) => Wrap (Data a -> t) (Data a -> u) where-    wrap f = \x -> wrap $ f x---- | Extended 'Data' to be used in wrappers-data Data' s a =-    Data'-    { unData'   :: Data a-    }---- Syntactic instance for 'Data''-instance EdgeInfo (Data' s a)-  where-    type Info (Data' s a)   = EdgeSize () a-    edgeInfo                = edgeInfo . unData . unData'--instance Type a => MultiEdge (Data' s a) Feldspar EdgeSize-  where-    type Role     (Data' s a)   = ()-    type Internal (Data' s a)   = a-    toEdge                      = toEdge . unData . unData'-    fromInEdge                  = Data' . Data . fromInEdge-    fromOutEdge info            = Data' . Data . fromOutEdge info--instance (Type a) => Syntactic (Data' s a)-
− Feldspar/DSL/Expression.hs 
@@ -1,74 +0,0 @@--- | This module defines the concept of expressions and expression transformers.------ An expression is a type constructor of kind------ > * -> * -> *------ where the first argument denotes the \"role\" of the expression, and the--- second argument is the type of the value computed by the expression.------ An expression transformer is a type constructor of kind------ > (* -> * -> *) -> (* -> * -> *)------ i.e. a expression parameterized by an expression.--module Feldspar.DSL.Expression where----import Data.Typeable-import Unsafe.Coerce------ | Expression type with no constructors. Can be used to turn an expression--- transformer to an expression.-data Empty role a---- | Equality for expressions. The difference between 'Eq' and 'ExprEq' is that--- 'ExprEq' allows comparison of expressions with different role and value type.--- It is assumed that when the types differ, the expressions also differ. The--- reason for allowing comparison of different types is that this is convenient--- when the types are existentially quantified.-class ExprEq expr-  where-    exprEq :: expr ra a -> expr rb b -> Bool--instance ExprEq Empty-  where-    exprEq _ _ = undefined--instance Eq (Empty role a)-  where-    (==) = exprEq---- | Evaluation of expressions-class Eval expr-  where-    eval :: expr role a -> a--instance Eval Empty-  where-    eval _ = undefined--class ExprShow expr-  where-    exprShow :: expr role a -> String--instance ExprShow Empty-  where-    exprShow _ = undefined--printExpr :: ExprShow expr => expr role a -> IO ()-printExpr = putStrLn . exprShow---- | Type-safe cast for expressions-exprCast :: forall expr ra a rb b-    .  (Typeable ra, Typeable a, Typeable rb, Typeable b)-    => expr ra a -> Maybe (expr rb b)-exprCast e = do-    cast (undefined :: ra) :: Maybe rb  -- Check that ra and rb are the same-    cast (undefined :: a)  :: Maybe b   -- Check that a and b are the same-    return (unsafeCoerce e)-
− Feldspar/DSL/Lambda.hs 
@@ -1,197 +0,0 @@--- | A module for lambda expressions--module Feldspar.DSL.Lambda where----import Control.Monad.State-import Data.Tree-import Data.Typeable--import Feldspar.DSL.Expression------ | Unique identifier-type Ident = String---- | Extensible lambda expressions-data Lam expr role a-  where-    Variable :: Ident -> Lam expr role a--    Value :: a -> Lam expr role a--    Lambda-        :: (Typeable rb, Typeable b)-        => (Lam expr ra a -> Lam expr rb b) -> Lam expr (ra -> rb) (a -> b)--    (:$:)-        :: (Typeable ra, Typeable a)-        => Lam expr (ra -> rb) (a -> b) -> Lam expr ra a -> Lam expr rb b-      -- Application. Using an infix operator makes it *a lot* easier to work-      -- with the library.--    Let :: String -> Lam expr (ra -> (ra -> rb) -> rb) (a -> (a -> b) -> b)--    Inject :: expr role a -> Lam expr role a--      -- Note: Using an infix operator for application makes it *a lot* easier-      -- to work with the library.--      -- TODO 'Value' is used for evaluating 'Lambda' expressions. It should not-      --      be exported to the user. This is only a temporary solution.--      -- TODO 'Lambda' should have a base name field instead of 'Let'.------ | Let binding-let_ :: (Typeable ra, Typeable a, Typeable rb, Typeable b)-    => String  -- ^ Preferred base name-    -> Lam expr ra a -> (Lam expr ra a -> Lam expr rb b) -> Lam expr rb b-let_ base a f = Let base :$: a :$: Lambda f--instance ExprEq expr => ExprEq (Lam expr)-  where-    exprEq a b = evalState (exprEqLam a b) 0--instance ExprEq expr => Eq (Lam expr role a)-  where-    (==) = exprEq--freshVar-    :: String  -- ^ Base name-    -> State Integer (Lam expr role a)-freshVar base = do-    v <- get-    put (v+1)-    return $ Variable (base ++ show v)--exprEqLam :: ExprEq expr => Lam expr ra a -> Lam expr rb b -> State Integer Bool-exprEqLam (Variable i1) (Variable i2) = return (i1 == i2)-exprEqLam (Lambda f1) (Lambda f2) = do-    i <- get-    v1 <- freshVar ""-    put i-    v2 <- freshVar ""-    exprEqLam (f1 v1) (f2 v2)-exprEqLam (f1 :$: a1) (f2 :$: a2) = do-    aCond <- exprEqLam f1 f2-    if aCond-      then exprEqLam a1 a2-      else return False-exprEqLam (Inject a) (Inject b) = return (exprEq a b)-exprEqLam (Let _)    (Let _)    = return True-exprEqLam _ _ = return False-  -- This case includes 'Value', which is only supposed to be used during-  -- evaluation.--instance Eval expr => Eval (Lam expr)-  where-    eval (Variable ident) = error $ "Evaluating variable " ++ show ident-    eval (Value a)        = a-    eval (Lambda f)       = eval . f . Value-    eval (f :$: a)        = eval f $ eval a-    eval (Inject a)       = eval a-    eval (Let _)          = flip ($)--instance ExprShow expr => ExprShow (Lam expr)-  where-    exprShow = flip evalState 0 . exprShowLam--instance ExprShow (Lam expr) => Show (Lam expr role a)-  where-    show = exprShow---- | Shallow application. Function argument must be a 'Lambda'.-shallowApply :: Lam expr (ra -> rb) (a -> b) -> Lam expr ra a -> Lam expr rb b-shallowApply (Lambda f) = f--infixr 0 $$-($$) = shallowApply--isVar :: Lam expr role a -> Bool-isVar (Variable _) = True-isVar _            = False--isLet :: Lam expr role a -> Bool-isLet (Let _ :$: _ :$: _) = True-isLet _                   = False---- | Parser for infix operators of the form @"(op)"@-viewInfix :: String -> Maybe String-viewInfix ('(':op)-    | (')':op') <- reverse op = Just op'-viewInfix _ = Nothing---- | Shows a partially applied expression-exprShowApp :: ExprShow expr-    => [String]              -- ^ Missing arguments-    -> Lam expr role a       -- ^ Partially applied expression-    -> State Integer String-exprShowApp args (f :$: a) = do-    aStr <- exprShowLam a-    exprShowApp (aStr:args) f-exprShowApp args f = do-    fStr <- exprShowLam f-    return $ case (viewInfix fStr, args) of-        (Just op, [a,b]) -> "(" ++ unwords [a,op,b] ++ ")"-        _                -> "(" ++ unwords (fStr : args) ++ ")"--exprShowLam :: ExprShow expr => Lam expr role a -> State Integer String-exprShowLam (Variable ident) = return ident-exprShowLam (Value _)        = error "exprShowLam: illegal use of Value"-exprShowLam (Lambda f) = do-    v@(Variable ident) <- freshVar "v"-    body <- exprShowLam (f v)-    return $ "(\\" ++ ident ++ " -> "  ++ body ++ ")"-exprShowLam (Let base :$: a :$: Lambda f) = do-    v@(Variable ident) <- freshVar base-    aStr <- exprShowLam a-    body <- exprShowLam (f v)-    return $ "(let " ++ ident ++ " = " ++ aStr ++ " in "  ++ body ++ ")"-exprShowLam (f :$: a) = do-    aStr <- exprShowLam a-    exprShowApp [aStr] f-exprShowLam (Inject a) = return (exprShow a)---- | Converts a partially applied expression to a tree-lamToTreeApp :: ExprShow expr-    => Forest String                -- ^ Missing arguments-    -> Lam expr role a              -- ^ Partially applied expression-    -> State Integer (Tree String)-lamToTreeApp args (f :$: a) = do-    aTree <- lamToTree a-    lamToTreeApp (aTree : args) f-lamToTreeApp args f = do-    fTree <- lamToTree f-    return $ Node "Apply" (fTree : args)---- | Converts a lambda expression to a tree-lamToTree :: ExprShow expr => Lam expr role a -> State Integer (Tree String)-lamToTree (Variable ident) = return $ Node ("Variable " ++ ident) []-lamToTree (Value a)        = return $ Node "Value ..." []-lamToTree (Lambda f) = do-    v@(Variable ident) <- freshVar "v"-    body <- lamToTree (f v)-    return $ Node ("Lambda " ++ ident) [body]-lamToTree (Let base :$: a :$: Lambda f) = do-    v@(Variable ident) <- freshVar base-    aTree <- lamToTree a-    body  <- lamToTree (f v)-    return $ Node ("Let " ++ ident) [aTree,body]-lamToTree (f :$: a) = do-    aTree <- lamToTree a-    lamToTreeApp [aTree] f-lamToTree (Let base) = return $ Node ("Let " ++ base) []-lamToTree (Inject a) = return $ Node (exprShow a) []---- | Show a lambda expression as a tree-showLamTree :: ExprShow expr => Lam expr role a -> String-showLamTree = drawTree . flip evalState 0 . lamToTree---- | Print a lambda expression as a tree-drawLambda :: ExprShow expr => Lam expr role a -> IO ()-drawLambda = putStrLn . showLamTree-
− Feldspar/DSL/Network.hs 
@@ -1,389 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}---- | This module defines computational networks.--module Feldspar.DSL.Network where----import Control.Applicative-import Data.Typeable--import Feldspar.DSL.Expression-import Feldspar.DSL.Lambda------ | Empty type denoting an \"out\" role-data Out role deriving Typeable---- | Empty type denoting an \"in\" role-data In role deriving Typeable------ | Expression transformer for representing network connections.-data Connection edge node role a-  where-    Node :: node role a -> Connection edge node role a-      -- Turning a @node@ expression into a network node.--    Edge :: edge () a -> Connection edge node (Out () -> In ()) (a -> a)-      -- A network edge: semantically an identity function, but decorated with-      -- some @edge@ information--    Group2 :: Connection e n (In ra -> In rb -> In (ra,rb))                         (a -> b -> (a,b))-    Group3 :: Connection e n (In ra -> In rb -> In rc -> In (ra,rb,rc))             (a -> b -> c -> (a,b,c))-    Group4 :: Connection e n (In ra -> In rb -> In rc -> In rd -> In (ra,rb,rc,rd)) (a -> b -> c -> d -> (a,b,c,d))--    Match21 :: Connection e n (Out (ra,rb) -> Out ra)       ((a,b) -> a)-    Match22 :: Connection e n (Out (ra,rb) -> Out rb)       ((a,b) -> b)-    Match31 :: Connection e n (Out (ra,rb,rc) -> Out ra)    ((a,b,c) -> a)-    Match32 :: Connection e n (Out (ra,rb,rc) -> Out rb)    ((a,b,c) -> b)-    Match33 :: Connection e n (Out (ra,rb,rc) -> Out rc)    ((a,b,c) -> c)-    Match41 :: Connection e n (Out (ra,rb,rc,rd) -> Out ra) ((a,b,c,d) -> a)-    Match42 :: Connection e n (Out (ra,rb,rc,rd) -> Out rb) ((a,b,c,d) -> b)-    Match43 :: Connection e n (Out (ra,rb,rc,rd) -> Out rc) ((a,b,c,d) -> c)-    Match44 :: Connection e n (Out (ra,rb,rc,rd) -> Out rd) ((a,b,c,d) -> d)------ | A computational network------ A value of type @(Network edge node (In role) a)@ is called a in-edge, and a--- value of type @(Network edge node (Out role) a)@ is called a out-edge.------ It is assumed that the @node@ type is designed such that it is impossible to--- construct a in-edge that is an (nested) application of a 'Node'. This means--- that a value of type @(Network edge node (In ()) a)@ can only be constructed--- by------ @`Inject` (`Edge` ...) `:$:` ...@------ It also means that values of type @(Network edge node (In role) a)@ are--- always (nested) applications of 'Edge', 'Group2', 'Group3' or 'Group4'.------ This ensures that all functions in this module are total.------ Note that the @edge@ information will be ignored when comparing two networks--- using 'exprEq'.-type Network edge node = Lam (Connection edge node)-  -- TODO The above is not correct anymore: 'Variable' and 'Let' can construct-  --      expressions of any type.----instance ExprEq node => ExprEq (Connection edge node)-  where-    exprEq (Node a) (Node b)  = exprEq a b-    exprEq (Edge _) (Edge _)  = True  -- Edge information ignored-    exprEq Group2   Group2    = True-    exprEq Group3   Group3    = True-    exprEq Group4   Group4    = True-    exprEq Match21  Match21   = True-    exprEq Match22  Match22   = True-    exprEq Match31  Match31   = True-    exprEq Match32  Match32   = True-    exprEq Match33  Match33   = True-    exprEq Match41  Match41   = True-    exprEq Match42  Match42   = True-    exprEq Match43  Match43   = True-    exprEq Match44  Match44   = True-    exprEq _ _                = False--instance (ExprEq edge, ExprEq node) => Eq (Connection edge node role a)-  where-    (==) = exprEq--instance Eval node => Eval (Connection edge node)-  where-    eval (Node a) = eval a-    eval (Edge _) = id-    eval Group2   = (,)-    eval Group3   = (,,)-    eval Group4   = (,,,)-    eval Match21  = fst-    eval Match22  = snd-    eval Match31  = \(a,b,c) -> a-    eval Match32  = \(a,b,c) -> b-    eval Match33  = \(a,b,c) -> c-    eval Match41  = \(a,b,c,d) -> a-    eval Match42  = \(a,b,c,d) -> b-    eval Match43  = \(a,b,c,d) -> c-    eval Match44  = \(a,b,c,d) -> d--instance (ExprShow edge, ExprShow node) => ExprShow (Connection edge node)-  where-    exprShow (Node a) = exprShow a-    exprShow (Edge e) = "(edge " ++ exprShow e ++ ")"-    exprShow Group2   = "group2"-    exprShow Group3   = "group3"-    exprShow Group4   = "group4"-    exprShow Match21  = "match21"-    exprShow Match22  = "match22"-    exprShow Match31  = "match21"-    exprShow Match32  = "match22"-    exprShow Match33  = "match23"-    exprShow Match41  = "match41"-    exprShow Match42  = "match42"-    exprShow Match43  = "match43"-    exprShow Match44  = "match44"------ | This class should be thought of as roughly equivalent to 'MultiEdge'.--- The difference is that 'EdgeInfo' has fewer constraints.-class EdgeInfo a-  where-    type Info a-    edgeInfo :: a -> Info a-  -- This class could be baked into 'MultiEdge', but that leads to unnecessary-  -- constraints for 'edgeInfo'.---- | Types that can be converted to/from network edges. Instances must fulfill--- 'prop_edge1' and 'prop_edge2'.-class (Typeable (Role a), Typeable (Internal a), EdgeInfo a) =>-    MultiEdge a node edge | a -> node edge-  where-    type Role     a-    type Internal a--    toEdge      :: a -> Network edge node (In (Role a)) (Internal a)-    fromInEdge  :: Network edge node (In (Role a)) (Internal a) -> a-    fromOutEdge :: Info a -> Network edge node (Out (Role a)) (Internal a) -> a---- TODO Make node and edge associated types instead. The reason for not doing---      this now is that it is currently not possible to make a class alias---      fixing an associated type. But in the future (GHC 7.0, I think) this---      will be possible.--prop_edge1 :: forall a node edge-    .  (Eval node, MultiEdge a node edge, Eq (Internal a))-    => Network edge node (In (Role a)) (Internal a)-    -> Bool-prop_edge1 a = eval a == eval (toEdge $ id' $ fromInEdge a)-  where-    id' = id :: a -> a--prop_edge2 :: forall a node edge-    .  (Eval node, MultiEdge a node edge, Eq (Internal a))-    => Info a-    -> Network edge node (Out (Role a)) (Internal a)-    -> Bool-prop_edge2 info a = eval a == eval (toEdge $ id' $ fromOutEdge info a)-  where-    id' = id :: a -> a--instance EdgeInfo (Network edge node (In ()) a)-  where-    type Info (Network edge node (In ()) a) = edge () a-    edgeInfo (Inject (Edge edge) :$: _)     = edge--instance Typeable a => MultiEdge (Network edge node (In ()) a) node edge-  where-    type Role     (Network edge node (In ()) a) = ()-    type Internal (Network edge node (In ()) a) = a--    toEdge           = id-    fromInEdge       = id-    fromOutEdge edge = (Inject (Edge edge) :$:)--instance (EdgeInfo a, EdgeInfo b) => EdgeInfo (a,b)-  where-    type Info (a,b) = (Info a, Info b)-    edgeInfo (a,b)  = (edgeInfo a, edgeInfo b)--instance-    ( MultiEdge a node edge-    , MultiEdge b node edge-    ) => MultiEdge (a,b) node edge-  where-    type Role     (a,b) = (Role a, Role b)-    type Internal (a,b) = (Internal a, Internal b)--    toEdge (a,b) = Inject Group2 :$: toEdge a :$: toEdge b--    fromInEdge (Inject Group2 :$: a :$: b) = (fromInEdge a, fromInEdge b)--    fromOutEdge (ia,ib) a =-        ( fromOutEdge ia $ Inject Match21 :$: a-        , fromOutEdge ib $ Inject Match22 :$: a-        )--instance (EdgeInfo a, EdgeInfo b, EdgeInfo c) => EdgeInfo (a,b,c)-  where-    type Info (a,b,c) = (Info a, Info b, Info c)-    edgeInfo (a,b,c)  = (edgeInfo a, edgeInfo b, edgeInfo c)--instance-    ( MultiEdge a node edge-    , MultiEdge b node edge-    , MultiEdge c node edge-    ) => MultiEdge (a,b,c) node edge-  where-    type Role     (a,b,c) = (Role a, Role b, Role c)-    type Internal (a,b,c) = (Internal a, Internal b, Internal c)--    toEdge (a,b,c) = Inject Group3 :$: toEdge a :$: toEdge b :$: toEdge c--    fromInEdge (Inject Group3 :$: a :$: b :$: c) =-        (fromInEdge a, fromInEdge b, fromInEdge c)--    fromOutEdge (ia,ib,ic) a =-        ( fromOutEdge ia $ Inject Match31 :$: a-        , fromOutEdge ib $ Inject Match32 :$: a-        , fromOutEdge ic $ Inject Match33 :$: a-        )--instance (EdgeInfo a, EdgeInfo b, EdgeInfo c, EdgeInfo d) => EdgeInfo (a,b,c,d)-  where-    type Info (a,b,c,d) = (Info a, Info b, Info c, Info d)-    edgeInfo (a,b,c,d)  = (edgeInfo a, edgeInfo b, edgeInfo c, edgeInfo d)--instance-    ( MultiEdge a node edge-    , MultiEdge b node edge-    , MultiEdge c node edge-    , MultiEdge d node edge-    ) => MultiEdge (a,b,c,d) node edge-  where-    type Role     (a,b,c,d) = (Role a, Role b, Role c, Role d)-    type Internal (a,b,c,d) = (Internal a, Internal b, Internal c, Internal d)--    toEdge (a,b,c,d)-        =   Inject Group4-        :$: toEdge a-        :$: toEdge b-        :$: toEdge c-        :$: toEdge d--    fromInEdge (Inject Group4 :$: a :$: b :$: c :$: d) =-        (fromInEdge a, fromInEdge b, fromInEdge c, fromInEdge d)--    fromOutEdge (ia,ib,ic,id) a =-        ( fromOutEdge ia $ Inject Match41 :$: a-        , fromOutEdge ib $ Inject Match42 :$: a-        , fromOutEdge ic $ Inject Match43 :$: a-        , fromOutEdge id $ Inject Match44 :$: a-        )------ | Remove an 'Edge' application-undoEdge :: Network edge node (In ()) a -> Network edge node (Out ()) a-undoEdge (Inject (Edge _) :$: a) = a---- | Cast between two 'MultiEdge' types that have the same internal--- representation.-edgeCast ::-    ( MultiEdge a node edge-    , MultiEdge b node edge-    , Internal a ~ Internal b-    , Role a     ~ Role b-    ) => a -> b-edgeCast = fromInEdge . toEdge---- | Applies a function to each 'Edge' in an in-edge, and collects the result in--- an applicative functor. The applied function receives the path of the edge as--- an argument.-mapEdge :: forall app edge node ra a . Applicative app-    => (forall b . [Int] -> Network edge node (In ()) b -> app b)-    -> Network edge node (In ra) a -> app a-mapEdge f a = mapE [] a-  where-    mapE :: [Int] -> Network edge node (In rc) c -> app c-    mapE path a@(Inject (Edge _) :$: _) = f (reverse path) a-    mapE path (Inject Group2 :$: a :$: b)-        =   pure (,)-        <*> mapE (1:path) a-        <*> mapE (2:path) b-    mapE path (Inject Group3 :$: a :$: b :$: c)-        =   pure (,,)-        <*> mapE (1:path) a-        <*> mapE (2:path) b-        <*> mapE (3:path) c-    mapE path (Inject Group4 :$: a :$: b :$: c :$: d)-        =   pure (,,,)-        <*> mapE (1:path) a-        <*> mapE (2:path) b-        <*> mapE (3:path) c-        <*> mapE (4:path) d---- | Applies a function to each 'Edge' in an in-edge, and collects the results--- in a list. The applied function receives the path of the edge as an argument.-listEdge :: forall edge node ra a b-    .  (forall c . [Int] -> Network edge node (In ()) c -> b)-    -> Network edge node (In ra) a -> [b]-listEdge f a = listE [] a-  where-    listE :: [Int] -> Network edge node (In rd) d -> [b]-    listE path a@(Inject (Edge _) :$: _) = [f (reverse path) a]-    listE path (Inject Group2 :$: a :$: b)-        =  listE (1:path) a-        ++ listE (2:path) b-    listE path (Inject Group3 :$: a :$: b :$: c)-        =  listE (1:path) a-        ++ listE (2:path) b-        ++ listE (3:path) c-    listE path (Inject Group4 :$: a :$: b :$: c :$: d)-        =  listE (1:path) a-        ++ listE (2:path) b-        ++ listE (3:path) c-        ++ listE (4:path) d---- | Lists the match constructors of an out-edge-matchPath :: Network edge node (Out ()) a -> [Int]-matchPath = reverse . match-  where-    match :: Network edge node (Out role) a -> [Int]-    match (Inject Match21 :$: a) = 1:match a-    match (Inject Match22 :$: a) = 2:match a-    match (Inject Match31 :$: a) = 1:match a-    match (Inject Match32 :$: a) = 2:match a-    match (Inject Match33 :$: a) = 3:match a-    match (Inject Match41 :$: a) = 1:match a-    match (Inject Match42 :$: a) = 2:match a-    match (Inject Match43 :$: a) = 3:match a-    match (Inject Match44 :$: a) = 4:match a-    match _                      = []-      -- Using local function just to be able to give more restricted type to-      -- 'matchPath'.---- | Count the number of \"single\" edges (i.e. edges with role @In ()@)-countEdges :: Network edge node (In role) a -> Int-countEdges = length . listEdge (\_ _ -> ())--isMatch :: Connection edge node (ra -> rb) (a -> b) -> Bool-isMatch Match21 = True-isMatch Match22 = True-isMatch Match31 = True-isMatch Match32 = True-isMatch Match33 = True-isMatch Match41 = True-isMatch Match42 = True-isMatch Match43 = True-isMatch Match44 = True-isMatch _       = False--traceVar :: Network edge node (Out ()) a -> Maybe Ident-traceVar = trace-  where-    trace :: Network edge node role a -> Maybe Ident-    trace (Variable v)                 = Just v-    trace (Inject f :$: a) | isMatch f = trace a-    trace _                            = Nothing-      -- Using local function just to be able to give more restricted type to-      -- 'matchPath'.--isNode :: Network edge node ra a -> Bool-isNode (Inject (Node _)) = True-isNode (a :$: _)         = isNode a-isNode _                 = False--isEdge :: Network edge node ra a -> Bool-isEdge (Inject (Edge _) :$: _)                 = True-isEdge (Inject Group2 :$: _ :$: _)             = True-isEdge (Inject Group3 :$: _ :$: _ :$: _)       = True-isEdge (Inject Group4 :$: _ :$: _ :$: _ :$: _) = True-isEdge _ = False-
− Feldspar/DSL/Sharing.hs 
@@ -1,164 +0,0 @@--- | Common sub-expression elimination and variable hoisting for 'Lam'--- expressions.--module Feldspar.DSL.Sharing where----import Control.Monad.State-import Data.Typeable--import Feldspar.DSL.Expression-import Feldspar.DSL.Lambda------ | Substituting a sub-expression-substitute :: (ExprEq expr, Typeable ra, Typeable a, Typeable rb, Typeable b)-    => Lam expr ra a  -- ^ Sub-expression to be replaced-    -> Lam expr ra a  -- ^ Replacing sub-expression-    -> Lam expr rb b  -- ^ Whole expression-    -> Lam expr rb b-substitute x y a | Just y' <- exprCast y, exprEq x a = y'-substitute x y (Lambda f) = Lambda $ \v -> substitute x y (f v)-substitute x y (f :$: a)  = substitute x y f :$: substitute x y a-substitute x y a          = a---- | Count the number of occurrences of a sub-expression-count :: (ExprEq expr, Typeable ra, Typeable a, Typeable rb, Typeable b)-    => Lam expr ra a  -- ^ Sub-expression-    -> Lam expr rb b  -- ^ Whole expression-    -> Integer-count a b = evalState (countM a b) 0--countM :: (ExprEq expr, Typeable ra, Typeable a, Typeable rb, Typeable b)-    => Lam expr ra a-    -> Lam expr rb b-    -> State Integer Integer-countM a b = case exprCast b of-    Just b' -> do-        eq <- exprEqLam a (b' `asTypeOf` a)-        if eq then return 1 else countNonEq a b-    _ -> countNonEq a b--countNonEq :: (ExprEq expr, Typeable ra, Typeable a, Typeable rb, Typeable b)-    => Lam expr ra a-    -> Lam expr rb b-    -> State Integer Integer-countNonEq a (Lambda f) = do-    v <- freshVar ""-    countM a (f v)-countNonEq a (f :$: b) = liftM2 (+) (countM a f) (countM a b)-countNonEq _ _ = return 0----data SomeLam expr = forall ra a .-    (Typeable ra, Typeable a) => SomeLam (Lam expr ra a)---- | Custom parameters to sharing transformation. The 'necessary' predicate--- gives a necessary condition for lifting an expression, and 'sufficient' gives--- a sufficient condition. Note that 'necessary' takes precedence over--- 'sufficient'.------ The 'sharingPoint' field determines whether the expression is a valid point--- for introducing a 'Let'.-data Params expr = Params-    { necessary    :: SomeLam expr -> Bool-    , sufficient   :: SomeLam expr -> Bool-    , sharingPoint :: SomeLam expr -> Bool-    }--data Env expr = Env-    { inLambda :: Bool  -- ^ Whether the current expression is inside a lambda-    , subExpr  :: Bool  -- ^ Whether the current expression is a sub-expression-    , counter  :: SomeLam expr -> Integer-        -- ^ Counting the number of occurrences of an expression in the-        -- environment-    }--simpleParams :: Params expr-simpleParams = Params-    { necessary    = const True-    , sufficient   = const False-    , sharingPoint = const True-    }--initEnv :: (ExprEq expr, Typeable ra, Typeable a)-    => Lam expr ra a-    -> Env expr-initEnv a = Env-    { inLambda = False-    , subExpr  = False-    , counter  = \(SomeLam b) -> count b a-    }--dummy = Variable ""-ph    = Variable "PLACEHOLDER"---- | Checks whether an expression is compound-compound :: Lam expr ra a -> Bool-compound (Lambda _) = True-compound (_ :$: _)  = True-compound _          = False---- | Checks if the expression does not contain any @"PLACEHOLDER"@ variables-independent :: Lam expr ra a -> Bool-independent (Variable ident) = ident /= "PLACEHOLDER"-independent (Lambda f)       = independent (f dummy)-independent (f :$: a)        = independent f && independent a-independent _                = True---- | Checks whether a sub-expression in a given environment can be lifted out-liftable :: (Typeable ra, Typeable a)-    => Params expr-    -> Env expr-    -> Lam expr ra a -> Bool-liftable params env a-    =  independent a  -- Lifting dependent expressions is semantically incorrect-    && subExpr env    -- Otherwise infinite loop-    && necessary params (SomeLam a)-    && (heuristic || sufficient params (SomeLam a))-  where-    heuristic = compound a && (inLambda env || (counter env (SomeLam a) > 1))---- | Chooses a sub-expression to lift out-choose :: (Typeable ra, Typeable a) =>-    Params expr -> Env expr -> Lam expr ra a -> Maybe (SomeLam expr)-choose par env a | liftable par env a = Just (SomeLam a)-choose par env (Lambda f) = choose par env' (f ph)-  where env' = env {inLambda = True, subExpr = True}-choose par env (f :$: a) = choose par env' f `mplus` choose par env' a-  where env' = env {subExpr = True}-choose _ _ _ = Nothing---- | Perform common sub-expression elimination and variable hoisting-sharing :: forall expr ra a . (ExprEq expr, Typeable ra, Typeable a)-    => Params expr-    -> Lam expr ra a-    -> Lam expr ra a-sharing par a = case choose par (initEnv a) a of-    Just b | sharingPoint par (SomeLam a) -> share b-    _ -> descend par a-  where-    share :: SomeLam expr -> Lam expr ra a-    share (SomeLam b) = let_ "v" (sharing par b) f-      where f x = sharing par (substitute b x a)--descend :: (ExprEq expr, Typeable ra, Typeable a)-    => Params expr-    -> Lam expr ra a-    -> Lam expr ra a-descend params (Lambda f) = Lambda $ \v -> sharing params (f v)-descend params (f :$: a)  = sharing params f :$: sharing params a-descend _ a = a--simpleSharing :: (ExprEq expr, Typeable ra, Typeable a) =>-    Lam expr ra a -> Lam expr ra a-simpleSharing = sharing simpleParams---- | Checks if the expression computes a function. Can be used in the parameters--- passed to 'sharing'.-isFunction :: forall expr ra a . Typeable a => Lam expr ra a -> Bool-isFunction _ = show (typeRepTyCon $ typeOf (undefined :: a)) == "->"-
− Feldspar/DSL/Val.hs 
@@ -1,78 +0,0 @@--- | Simple example language built using 'Lam'.--module Feldspar.DSL.Val where----import Data.Typeable--import Feldspar.DSL.Expression-import Feldspar.DSL.Lambda-import Feldspar.DSL.Sharing--------------------------------------------------------------------------------------- * Library-----------------------------------------------------------------------------------data Val role a = Val String a--instance ExprEq Val-  where-    exprEq (Val v1 _) (Val v2 _) = v1==v2--instance Eval Val-  where-    eval (Val _ a) = a--instance ExprShow Val-  where-    exprShow (Val val _) = val--simpleVal :: Show a => a -> Lam Val () a-simpleVal a = Inject $ Val (show a) a--function :: (Typeable ra, Typeable a) =>-    String -> (a -> b) -> (Lam Val ra a -> Lam Val rb b)-function name f a = Inject (Val name f) :$: a--function2 :: (Typeable ra, Typeable a, Typeable rb, Typeable b) =>-    String -> (a -> b -> c) -> (Lam Val ra a -> Lam Val rb b -> Lam Val rc c)-function2 name f a b = Inject (Val name f) :$: a :$: b--int :: Int -> Lam Val () Int-int = simpleVal--true  = simpleVal True-false = simpleVal False--instance (Num a, Typeable a) => Num (Lam Val () a)-  where-    fromInteger = simpleVal . fromInteger-    abs         = function "abs" abs-    signum      = function "signum" signum-    (+)         = function2 "(+)" (+)-    (-)         = function2 "(-)" (-)-    (*)         = function2 "(*)" (*)--------------------------------------------------------------------------------------- * Examples-----------------------------------------------------------------------------------expr1 :: Lam Val (() -> ()) (Int -> Int)-expr1 = Lambda $ \x -> x + (let_ "temp" (2 + 3 + x) $ \y -> y+x)--expr2 :: Lam Val (() -> ()) (Int -> Int)-expr2 = Lambda $ \x -> x + (let_ "temp" (2 + 3 + x) $ \y -> 2 + 3 + y+x)--test1 = drawLambda expr2-test2 = drawLambda $ simpleSharing expr2--problem = drawLambda $-    simpleSharing ((1+2+3) + (1+2+4) + (1+2+3+4) :: Lam Val () Int)-  -- TODO: 1+2 not shared-  --       Use fixpoint iteration?-
Feldspar/FixedPoint.hs view
@@ -1,3 +1,31 @@+--+-- Copyright (c) 2009-2011, 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 #-} module Feldspar.FixedPoint     ( Fix(..), Fixable(..)@@ -7,27 +35,27 @@ where  import qualified Prelude-import Feldspar-import Feldspar.DSL.Network hiding (In,Out)-import Feldspar.Core.Representation+import Feldspar hiding (sugar,desugar)+import Feldspar.Core.Constructs import Feldspar.Vector++import Language.Syntactic+ import Data.Ratio  -- | Abstract real number type with exponent and mantissa data Fix a =     Fix-    { exponent  :: Data DefaultInt+    { exponent  :: Data IntN     , mantissa  :: Data a     }     deriving (Prelude.Eq,Prelude.Show)  instance-    ( Bounded a-    , Numeric a+    ( Integral a     , Bits a-    , Ord a-    , Range a ~ Size a     , Prelude.Real a+    , Size a ~ Range a     ) => Num (Fix a)   where     fromInteger n = Fix 0 (Prelude.fromInteger n)@@ -38,64 +66,63 @@     signum = fixSignum  instance-    ( Bounded a-    , Numeric a+    ( Integral a     , Bits a-    , Ord a-    , Range a ~ Size a     , Prelude.Real a-    , Integral a+    , Size a ~ Range a     ) => Fractional (Fix a)   where     (/) = fixDiv'     recip = fixRecip'     fromRational = fixfromRational -fixAddition :: (Bounded a,Numeric a, Bits a, Ord a, Range a ~ Size a, Prelude.Real a) => Fix a -> Fix a -> Fix a+fixAddition :: (Integral a, Bits a, Prelude.Real a, Size a ~ Range a) => Fix a -> Fix a -> Fix a fixAddition f1@(Fix e1 m1) f2@(Fix e2 m2) = Fix e m    where      e    =  max e1 e2      m    =  mantissa (fix e f1) + mantissa (fix e f2) -fixMultiplication :: (Bounded a,Numeric a, Bits a, Ord a, Range a ~ Size a, Prelude.Real a) => Fix a -> Fix a -> Fix a+fixMultiplication :: (Integral a, Bits a, Prelude.Real a) => Fix a -> Fix a -> Fix a fixMultiplication f1@(Fix e1 m1) f2@(Fix e2 m2) = Fix e m    where      e  =  e1 + e2      m    =  m1 * m2-     -fixNegate :: (Bounded a,Numeric a, Bits a, Ord a, Range a ~ Size a, Prelude.Real a) => Fix a -> Fix a ++fixNegate :: (Integral a, Bits a, Prelude.Real a) => Fix a -> Fix a fixNegate f1@(Fix e1 m1)  = Fix e1 m    where      m = negate m1 -fixAbsolute :: (Bounded a,Numeric a, Bits a, Ord a, Range a ~ Size a, Prelude.Real a) => Fix a -> Fix a +fixAbsolute :: (Integral a, Bits a, Prelude.Real a) => Fix a -> Fix a fixAbsolute f1@(Fix e1 m1)  = Fix e1 m    where      m = abs m1 -fixSignum :: (Bounded a,Numeric a, Bits a, Ord a, Range a ~ Size a, Prelude.Real a) => Fix a -> Fix a +fixSignum :: (Integral a, Bits a, Prelude.Real a) => Fix a -> Fix a fixSignum f1@(Fix e1 m1)  = Fix 0 m    where      m = signum m1 -fixFromInteger :: (Bounded a,Numeric a, Bits a, Ord a, Range a ~ Size a, Prelude.Real a) =>  Integer -> Fix a +fixFromInteger :: (Integral a, Bits a, Prelude.Real a) =>  Integer -> Fix a fixFromInteger i  = Fix 0 m    where      m = fromInteger i -fixDiv' :: (Bounded a,Numeric a, Bits a, Ord a, Range a ~ Size a, Prelude.Real a,Integral a) => Fix a -> Fix a -> Fix a+fixDiv' :: (Integral a, Bits a, Prelude.Real a, Size a ~ Range a)+           => Fix a -> Fix a -> Fix a fixDiv' f1@(Fix e1 m1) f2@(Fix e2 m2) = Fix e m    where      e = e1-e2      m  = div m1 m2 -fixRecip' :: forall a . (Bounded a,Numeric a, Bits a, Ord a, Range a ~ Size a, Prelude.Real a,Integral a) => Fix a -> Fix a+fixRecip' :: forall a . (Integral a, Bits a, Prelude.Real a, Size a ~ Range a)+             => Fix a -> Fix a fixRecip' f@(Fix e m) = Fix (e + (value $ wordLength (T :: T a) - 1)) (div sh m)    where      sh  :: Data a-     sh  = (1::Data a) << (value $ fromInteger $ toInteger $ wordLength (T :: T a) - 1)+     sh  = (1::Data a) .<<. (value $ fromInteger $ toInteger $ wordLength (T :: T a) - 1) -fixfromRational :: forall a . (Range a ~ Size a, Numeric a, Integral a, Num a,Type a) =>+fixfromRational :: forall a . (Integral a, Size a ~ Range a) =>                    Prelude.Rational -> Fix a fixfromRational inp = Fix exponent mantissa    where@@ -103,46 +130,41 @@       inpAsFloat =  fromRational inp       intPart :: Float       intPart =  fromRational $ toRational $ (Prelude.floor inpAsFloat)-      intPartWidth :: DefaultInt-      intPartWidth =  Prelude.ceiling  $ logBase 2 intPart-      fracPartWith :: DefaultInt+      intPartWidth :: IntN+      intPartWidth =  Prelude.ceiling $ Prelude.logBase 2 intPart+      fracPartWith :: IntN       fracPartWith =  (wordLength (T :: T a)) - intPartWidth - 2-      mantissa = value $ Prelude.floor $ inpAsFloat * 2.0 ** fromRational (toRational fracPartWith)-      exponent =  negate $ value fracPartWith--instance (Type a) => EdgeInfo (Fix a)-  where-    type Info (Fix a)   = EdgeSize () (DefaultInt, a)-    edgeInfo            = edgeInfo . toEdge+      mantissa = value $ Prelude.floor $ inpAsFloat * 2.0 Prelude.** fromRational (toRational fracPartWith)+      exponent = negate $ value fracPartWith -instance (Type a) => MultiEdge (Fix a) Feldspar EdgeSize-  where-    type Role     (Fix a)   = ()-    type Internal (Fix a)   = (DefaultInt, a)-    toEdge           = toEdge . freezeFix-    fromInEdge       = unfreezeFix . fromInEdge-    fromOutEdge info = unfreezeFix . fromOutEdge info+instance (Type a) => Syntactic (Fix a) FeldDomainAll where+  type Internal (Fix a) = (IntN, a)+  desugar = desugar . freezeFix+  sugar   = unfreezeFix . sugar -instance (Type a) => Syntactic (Fix a)+instance (Type a) => Syntax (Fix a) --- | Convers an abstract real number to a pair of exponent and mantissa-freezeFix :: (Type a) => Fix a -> Data (DefaultInt,a)-freezeFix (Fix e m) = pair e m+-- | Converts an abstract real number to a pair of exponent and mantissa+freezeFix :: (Type a) => Fix a -> (Data IntN,Data a)+freezeFix (Fix e m) = (e,m) --- | Convers an abstract real number to fixed point integer with given exponent-freezeFix' :: (Bits a) => DefaultInt -> Fix a -> Data a+-- | Converts an abstract real number to fixed point integer with given exponent+freezeFix' :: (Bits a, Size a ~ Range a) => IntN -> Fix a -> Data a freezeFix' e f = mantissa $ fix (value e) f  -- | Converts a pair of exponent and mantissa to an abstract real number-unfreezeFix :: (Type a) => Data (DefaultInt,a) -> Fix a-unfreezeFix p = Fix (getFst p) (getSnd p)+unfreezeFix :: (Type a) => (Data IntN, Data a) -> Fix a+unfreezeFix (e,m) = Fix e m  -- | Converts a fixed point integer with given exponent to an abstract real number-unfreezeFix' :: DefaultInt -> Data a -> Fix a+unfreezeFix' :: IntN -> Data a -> Fix a unfreezeFix' e m = Fix (value e) m -significantBits :: forall a . (Type a, Size a ~ Range a, Num a, Ord a, Prelude.Real a) => Data a -> DefaultInt-significantBits x = DefaultInt $ fromInteger $ toInteger $ (Prelude.floor mf)+1+-- This function cannot be implemented now as we don't have access to range+-- information while building the tree anymore.+{-+significantBits :: forall a . (Type a, Num a, Ord a, Size a ~ Range a, Prelude.Real a) => Data a -> IntN+significantBits x = IntN $ fromInteger $ toInteger $ (Prelude.floor mf)+1   where     r :: Range a     r = dataSize x@@ -150,33 +172,34 @@     m = Prelude.max (Prelude.abs $ lowerBound r) (Prelude.abs $ upperBound r)     mf :: Float     mf = logBase 2 $ fromRational $ toRational m--setSignificantBits :: forall a . (Type a, Size a ~ Range a, Num a, Ord a, Prelude.Real a) => a -> Data a -> Data a+-}+{-+setSignificantBits :: forall a . (Type a, Num a, Ord a, Size a ~ Range a, Prelude.Real a) => a -> Data a -> Data a setSignificantBits sb x = resizeData r x-   where -     r :: Range a-     r =  Range 0 sb--wordLength :: forall a . (Prelude.Bounded a,Type a,Size a ~ Range a,Num a,Ord a,Prelude.Real a) => T a -> DefaultInt-wordLength x = (Prelude.ceiling $ logBase 2 $ fromRational $ toRational (maxBound :: a)) + 1+  where+    r :: Range a+    r =  Range 0 sb+-}+wordLength :: forall a . (Integral a, Prelude.Real a) => T a -> IntN+wordLength x = (Prelude.ceiling $ Prelude.logBase 2 $ fromRational $ toRational (maxBound :: a)) + 1 -wordLength' :: forall a . (Prelude.Bounded a,Prelude.Real a) => a -> DefaultInt+wordLength' :: forall a . (Integral a, Prelude.Real a) => a -> IntN wordLength' x = swl    where     b   :: a-    wl  :: DefaultInt-    swl :: DefaultInt+    wl  :: IntN+    swl :: IntN     b   = maxBound::a-    wl  = Prelude.ceiling $ logBase 2 $ fromRational $ toRational b-    swl = wl + 1 +    wl  = Prelude.ceiling $ Prelude.logBase 2 $ fromRational $ toRational b+    swl = wl + 1  -- | Operations to get and set exponent class (Splittable t) => Fixable t where-    fix :: Data DefaultInt -> t -> t-    getExp :: t -> Data DefaultInt+    fix :: Data IntN -> t -> t+    getExp :: t -> Data IntN -instance (Bits a) => Fixable (Fix a) where-    fix e' (Fix e m) = Fix e' $ e' > e ? (m >> i2n (e' - e), m << i2n (e - e'))+instance (Bits a, Size a ~ Range a) => Fixable (Fix a) where+    fix e' (Fix e m) = Fix e' $ e' > e ? (m .>>. i2n (e' - e), m .<<. i2n (e - e'))     getExp = Feldspar.FixedPoint.exponent  instance Fixable (Data Float) where@@ -186,7 +209,7 @@ data T a = T  -- | Operations to split data into dynamic and static parts-class (Syntactic (Dynamic t)) => Splittable t where+class (Syntax (Dynamic t)) => Splittable t where     type Static t     type Dynamic t     store       :: t -> (Static t, Dynamic t)@@ -202,8 +225,8 @@     patch = const id     common _ _ = () -instance (Type a, Bits a) => Splittable (Fix a) where-    type Static (Fix a) = Data DefaultInt+instance (Bits a, Size a ~ Range a) => Splittable (Fix a) where+    type Static (Fix a) = Data IntN     type Dynamic (Fix a) = Data a     store f = (Feldspar.FixedPoint.exponent f, mantissa f)     retrieve = uncurry Fix@@ -220,7 +243,7 @@  -- | A version of branching for fixed point algorithms infix 1 ?!-(?!) :: forall a . (Syntactic a, Splittable a) => Data Bool -> (a,a) -> a+(?!) :: forall a . (Syntax a, Splittable a) => Data Bool -> (a,a) -> a cond ?! (x,y) = retrieve (comm, cond ? (x',y'))   where     comm = common x y
+ Feldspar/Lattice.hs view
@@ -0,0 +1,196 @@+--+-- Copyright (c) 2009-2011, ERICSSON AB+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are met:+-- +--     * Redistributions of source code must retain the above copyright notice, +--       this list of conditions and the following disclaimer.+--     * Redistributions in binary form must reproduce the above copyright+--       notice, this list of conditions and the following disclaimer in the+--       documentation and/or other materials provided with the distribution.+--     * Neither the name of the ERICSSON AB nor the names of its contributors+--       may be used to endorse or promote products derived from this software+--       without specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+--++-- | General operations on sets++module Feldspar.Lattice where++++import Data.Lens.Common++++-- | Lattice types+class Eq a => Lattice a+  where+    empty     :: a+    universal :: a+    -- | Union+    (\/)      :: a -> a -> a+    -- | Intersection+    (/\)      :: a -> a -> a++instance Lattice ()+  where+    empty     = ()+    universal = ()+    () \/ ()  = ()+    () /\ ()  = ()++-- | Lattice product+instance (Lattice a, Lattice b) => Lattice (a,b)+  where+    empty     = (empty,empty)+    universal = (universal,universal)+    (a1,a2) \/ (b1,b2) = (a1 \/ b1, a2 \/ b2)+    (a1,a2) /\ (b1,b2) = (a1 /\ b1, a2 /\ b2)++-- | Three-way product+instance (Lattice a, Lattice b, Lattice c) => Lattice (a,b,c)+  where+    empty     = (empty,empty,empty)+    universal = (universal,universal,universal)+    (a1,a2,a3) \/ (b1,b2,b3) = (a1 \/ b1, a2 \/ b2, a3 \/ b3)+    (a1,a2,a3) /\ (b1,b2,b3) = (a1 /\ b1, a2 /\ b2, a3 /\ b3)++-- | Four-way product+instance (Lattice a, Lattice b, Lattice c, Lattice d) => Lattice (a,b,c,d)+  where+    empty     = (empty,empty,empty,empty)+    universal = (universal,universal,universal,universal)+    (a1,a2,a3,a4) \/ (b1,b2,b3,b4) = (a1 \/ b1, a2 \/ b2, a3 \/ b3, a4 \/ b4)+    (a1,a2,a3,a4) /\ (b1,b2,b3,b4) = (a1 /\ b1, a2 /\ b2, a3 /\ b3, a4 /\ b4)++-- | Five-way product+instance (Lattice a, Lattice b, Lattice c, Lattice d, Lattice e) => Lattice (a,b,c,d,e)+  where+    empty     = (empty,empty,empty,empty,empty)+    universal = (universal,universal,universal,universal,universal)+    (a1,a2,a3,a4,a5) \/ (b1,b2,b3,b4,b5) = (a1 \/ b1, a2 \/ b2, a3 \/ b3, a4 \/ b4, a5 \/ b5)+    (a1,a2,a3,a4,a5) /\ (b1,b2,b3,b4,b5) = (a1 /\ b1, a2 /\ b2, a3 /\ b3, a4 /\ b4, a5 /\ b5)++-- | Six-way product+instance (Lattice a, Lattice b, Lattice c, Lattice d, Lattice e, Lattice f) => Lattice (a,b,c,d,e,f)+  where+    empty     = (empty,empty,empty,empty,empty,empty)+    universal = (universal,universal,universal,universal,universal,universal)+    (a1,a2,a3,a4,a5,a6) \/ (b1,b2,b3,b4,b5,b6) = (a1 \/ b1, a2 \/ b2, a3 \/ b3, a4 \/ b4, a5 \/ b5, a6 \/ b6)+    (a1,a2,a3,a4,a5,a6) /\ (b1,b2,b3,b4,b5,b6) = (a1 /\ b1, a2 /\ b2, a3 /\ b3, a4 /\ b4, a5 /\ b5, a6 /\ b6)++-- | Seven-way product+instance (Lattice a, Lattice b, Lattice c, Lattice d, Lattice e, Lattice f, Lattice g) => Lattice (a,b,c,d,e,f,g)+  where+    empty     = (empty,empty,empty,empty,empty,empty,empty)+    universal = (universal,universal,universal,universal,universal,universal,universal)+    (a1,a2,a3,a4,a5,a6,a7) \/ (b1,b2,b3,b4,b5,b6,b7) = (a1 \/ b1, a2 \/ b2, a3 \/ b3, a4 \/ b4, a5 \/ b5, a6 \/ b6, a7 \/ b7)+    (a1,a2,a3,a4,a5,a6,a7) /\ (b1,b2,b3,b4,b5,b6,b7) = (a1 /\ b1, a2 /\ b2, a3 /\ b3, a4 /\ b4, a5 /\ b5, a6 /\ b6, a7 /\ b7)++unions :: Lattice a => [a] -> a+unions = foldr (\/) empty++intersections :: Lattice a => [a] -> a+intersections = foldr (/\) universal++++-- * Computing fixed points++-- | Generalization of 'fixedPoint' to functions whose argument and result+-- contain (i.e has a lens to) a common lattice+lensedFixedPoint :: Lattice lat =>+    Lens a lat -> Lens b lat -> (a -> b) -> (a -> b)+lensedFixedPoint aLens bLens f a+    | aLat == bLat = (bLens ^= aLat) b+    | otherwise    = lensedFixedPoint aLens bLens f a'+  where+    aLat = a ^! aLens+    b    = f a+    bLat = (b ^! bLens) \/ aLat+    a'   = (aLens ^= bLat) a++-- | Generalization of 'indexedFixedPoint' to functions whose argument and+-- result contain (i.e has a lens to) a common lattice+lensedIndexedFixedPoint :: Lattice lat =>+    Lens a lat -> Lens b lat -> (Int -> a -> b) -> (a -> (b,Int))+lensedIndexedFixedPoint aLens bLens f a = go 0 f a+  where+    go i f a+        | aLat == bLat = ((bLens ^= aLat) b, i)+        | otherwise    = go (i+1) f a'+      where+        aLat = a ^! aLens+        b    = f i a+        bLat = (b ^! bLens) \/ aLat+        a'   = (aLens ^= bLat) a++-- | Take the fixed point of a function. The second argument is an initial+--  element. A sensible default for the initial element is 'empty'.+--+-- The function is not required to be monotonic. It is made monotonic internally+-- by always taking the union of the result and the previous value.+fixedPoint :: Lattice a => (a -> a) -> a -> a+fixedPoint = lensedFixedPoint (iso id id) (iso id id)++-- | Much like 'fixedPoint' but keeps track of the number of iterations+--   in the fixed point iteration. Useful for defining widening operators.+indexedFixedPoint :: Lattice a => (Int -> a -> a) -> a -> (a,Int)+indexedFixedPoint = lensedIndexedFixedPoint (iso id id) (iso id id)++-- | The type of widening operators. A widening operator modifies a+--   function that is subject to fixed point analysis. A widening+--   operator introduces approximations in order to guarantee (fast)+--   termination of the fixed point analysis.+type Widening a = (Int -> a -> a) -> (Int -> a -> a)++-- | A widening operator which defaults to 'universal' when the number of+--   iterations goes over the specified value.+cutOffAt :: Lattice a => Int -> Widening a+cutOffAt n f i a | i >= n    = universal+                 | otherwise = f i a++-- | A bounded version of 'lensedFixedPoint'. It will always do at least one+-- iteration regardless of the provided bound (in order to return something of+-- the right type).+boundedLensedFixedPoint :: Lattice lat =>+    Int -> Lens a lat -> Lens b lat -> (a -> b) -> (a -> (b,Int))+boundedLensedFixedPoint n aLens bLens f a = go 0 f a+  where+    go i f a+        | aLat == bLat = ((bLens ^= aLat) b, i)+        | i >= n-1     = ((bLens ^= universal) b, i)+        | otherwise    = go (i+1) f a'+      where+        aLat = a ^! aLens+        b    = f a+        bLat = (b ^! bLens) \/ aLat+        a'   = (aLens ^= bLat) a+  -- Note: This function achieves a similar effect to+  -- `indexedFixedPoint (cutOffAt n ...)`. The difference is that it works for+  -- lensed fixed points. It would be possible to define a version of `cutOffAt`+  -- that works for lensed fixed points, but such an operator would be less+  -- efficient since it would have to apply the argument function in the base+  -- case as well as the recursive case (in order to return something of the+  -- right type). This means that there would always be one extra unnecessary+  -- iteration. In particular, it would not be possible to get a meaningful+  -- result from performing a single iteration. To only perform a single+  -- iteration, the cut-off function would have to "fail" immediately, which+  -- means that the whole fixed point iteration would also "fail". (A+  -- single-iteration fixed point is an important special case as it avoids+  -- exponential blowup when performing several nested iterations.)+
Feldspar/Matrix.hs view
@@ -1,3 +1,31 @@+--+-- Copyright (c) 2009-2011, ERICSSON AB+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are met:+-- +--     * Redistributions of source code must retain the above copyright notice, +--       this list of conditions and the following disclaimer.+--     * Redistributions in binary form must reproduce the above copyright+--       notice, this list of conditions and the following disclaimer in the+--       documentation and/or other materials provided with the distribution.+--     * Neither the name of the ERICSSON AB nor the names of its contributors+--       may be used to endorse or promote products derived from this software+--       without specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+--+ {-# LANGUAGE UndecidableInstances #-}  -- | Operations on matrices (doubly-nested parallel vectors). All operations in@@ -13,31 +41,43 @@  import Feldspar.Prelude import Feldspar.Core-import Feldspar.Vector+import Feldspar.Wrap+import Feldspar.Vector.Internal   -type Matrix a = Vector (Vector (Data a))+type Matrix a = Vector2 a +tMat :: Patch a a -> Patch (Matrix a) (Matrix a)+tMat = tVec2  + -- | Converts a matrix to a core array. freezeMatrix :: Type a => Matrix a -> Data [[a]] freezeMatrix = freezeVector . map freezeVector  -- | Converts a core array to a matrix.-unfreezeMatrix :: Type a => Data [[a]] -> Matrix a-unfreezeMatrix = map unfreezeVector . unfreezeVector+thawMatrix :: Type a => Data [[a]] -> Matrix a+thawMatrix = map thawVector . thawVector  -- | Converts a core array to a matrix. The first length argument is the number -- of rows (outer vector), and the second argument is the number of columns--- (inner argument).+-- (inner vector).+thawMatrix' :: Type a => Length -> Length -> Data [[a]] -> Matrix a+thawMatrix' y x = map (thawVector' x) . (thawVector' y)++unfreezeMatrix :: Type a => Data [[a]] -> Matrix a+unfreezeMatrix = thawMatrix+{-# DEPRECATED unfreezeMatrix "Please use `thawMatrix` instead." #-}+ unfreezeMatrix' :: Type a => Length -> Length -> Data [[a]] -> Matrix a-unfreezeMatrix' y x = map (unfreezeVector' x) . (unfreezeVector' y)+unfreezeMatrix' = thawMatrix'+{-# DEPRECATED unfreezeMatrix' "Please use `thawMatrix'` instead." #-}  -- | Constructs a matrix. The elements are stored in a core array. matrix :: Type a => [[a]] -> Matrix a-matrix = unfreezeMatrix . value+matrix = value  -- | Constructing a matrix from an index function. --@@ -56,7 +96,7 @@     -> Matrix a indexedMat m n idx = indexed m $ \k -> indexed n $ \l -> idx k l --- | Transpose of a matrix+-- | Transpose of a matrix. Assumes that the number of rows is > 0. transpose :: Type a => Matrix a -> Matrix a transpose a = indexedMat (length $ head a) (length a) $ \y x -> a ! x ! y   -- TODO This assumes that (head a) can be used even if a is empty.@@ -100,14 +140,14 @@     type Prod (Data a) (Data a) = Data a     (***) = (*) -instance Numeric a => Mul (Data a) (DVector a)+instance Numeric a => Mul (Data a) (Vector1 a)   where-    type Prod (Data a) (DVector a) = DVector a+    type Prod (Data a) (Vector1 a) = Vector1 a     (***) = distributeL (***) -instance Numeric a => Mul (DVector a) (Data a)+instance Numeric a => Mul (Vector1 a) (Data a)   where-    type Prod (DVector a) (Data a) = DVector a+    type Prod (Vector1 a) (Data a) = Vector1 a     (***) = distributeR (***)  instance Numeric a => Mul (Data a) (Matrix a)@@ -120,19 +160,19 @@     type Prod (Matrix a) (Data a) = Matrix a     (***) = distributeR (***) -instance Numeric a => Mul (DVector a) (DVector a)+instance Numeric a => Mul (Vector1 a) (Vector1 a)   where-    type Prod (DVector a) (DVector a) = Data a+    type Prod (Vector1 a) (Vector1 a) = Data a     (***) = scalarProd -instance Numeric a => Mul (DVector a) (Matrix a)+instance Numeric a => Mul (Vector1 a) (Matrix a)   where-    type Prod (DVector a) (Matrix a) = (DVector a)+    type Prod (Vector1 a) (Matrix a) = (Vector1 a)     vec *** mat = distributeL (***) vec (transpose mat) -instance Numeric a => Mul (Matrix a) (DVector a)+instance Numeric a => Mul (Matrix a) (Vector1 a)   where-    type Prod (Matrix a) (DVector a) = (DVector a)+    type Prod (Matrix a) (Vector1 a) = (Vector1 a)     (***) = distributeR (***)  instance Numeric a => Mul (Matrix a) (Matrix a)@@ -148,30 +188,30 @@   -class Syntactic a => ElemWise a+class Syntax a => ElemWise a   where-    type Elem a+    type Scalar a      -- | Operator for general element-wise multiplication-    elemWise :: (Elem a -> Elem a -> Elem a) -> a -> a -> a+    elemWise :: (Scalar a -> Scalar a -> Scalar a) -> a -> a -> a  instance Type a => ElemWise (Data a)   where-    type Elem (Data a) = Data a+    type Scalar (Data a) = Data a     elemWise = id -instance (ElemWise a, Syntactic (Vector a)) => ElemWise (Vector a)+instance (ElemWise a, Syntax (Vector a)) => ElemWise (Vector a)   where-    type Elem (Vector a) = Elem a+    type Scalar (Vector a) = Scalar a     elemWise = zipWith . elemWise -(.+) :: (ElemWise a, Num (Elem a)) => a -> a -> a+(.+) :: (ElemWise a, Num (Scalar a)) => a -> a -> a (.+) = elemWise (+) -(.-) :: (ElemWise a, Num (Elem a)) => a -> a -> a+(.-) :: (ElemWise a, Num (Scalar a)) => a -> a -> a (.-) = elemWise (-) -(.*) :: (ElemWise a, Num (Elem a)) => a -> a -> a+(.*) :: (ElemWise a, Num (Scalar a)) => a -> a -> a (.*) = elemWise (*)  -- * Wrapping for matrices@@ -180,6 +220,7 @@     wrap = freezeMatrix  instance (Wrap t u, Type a, TL.Nat row, TL.Nat col) => Wrap (Matrix a -> t) (Data' (row,col) [[a]] -> u) where-    wrap f = \(Data' d) -> wrap $ f $ unfreezeMatrix' row' col' d where+    wrap f = \(Data' d) -> wrap $ f $ thawMatrix' row' col' d where         row' = fromInteger $ toInteger $ TL.toInt (undefined :: row)         col' = fromInteger $ toInteger $ TL.toInt (undefined :: col)+
+ Feldspar/Option.hs view
@@ -0,0 +1,114 @@+--+-- Copyright (c) 2009-2011, 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.Option where++++import qualified Prelude+import Control.Monad++import Language.Syntactic++import Feldspar hiding (sugar,desugar,resugar)++++data Option a = Option { isSome :: Data Bool, fromSome :: a }++instance Syntax a => Syntactic (Option a) FeldDomainAll+  where+    type Internal (Option a) = (Bool, Internal a)+    desugar = desugar . desugarOption . fmap resugar+    sugar   = fmap resugar . sugarOption . sugar++instance Syntax a => Syntax (Option a)++instance Functor Option+  where+    fmap f opt = opt {fromSome = f (fromSome opt)}++instance Monad Option+  where+    return = some+    a >>= f = b { isSome = isSome a ? (isSome b, false) }+      where+        b = f (fromSome a)++++-- | One-layer desugaring of 'Option'+desugarOption :: Type a => Option (Data a) -> Data (Bool,a)+desugarOption a = resugar (isSome a, fromSome a)++-- | One-layer sugaring of 'Option'+sugarOption :: Type a => Data (Bool,a) -> Option (Data a)+sugarOption (resugar -> (valid,a)) = Option valid a++some :: a -> Option a+some = Option true++none :: Syntax a => Option a+none = Option false (err "fromSome: none")++option :: Syntax b => b -> (a -> b) -> Option a -> b+option noneCase someCase opt = isSome opt ?+    ( someCase (fromSome opt)+    , noneCase+    )++oplus :: Syntax a => Option a -> Option a -> Option a+oplus a b = isSome a ? (a,b)++++--------------------------------------------------------------------------------+-- * Conditional choice operator+--------------------------------------------------------------------------------++-- http://zenzike.com/posts/2011-08-01-the-conditional-choice-operator++-- | Conditional choice operator. Can be used together with '<?' to write+-- guarded choices as follows:+--+-- > prog :: Data Index -> Data Index+-- > prog a+-- >     =  a+1 <? a==0+-- >     ?> a+2 <? a==1+-- >     ?> a+3 <? a==2+-- >     ?> a+4 <? a==3+-- >     ?> a+5+(?>) :: Data Bool -> a -> Option a+cond ?> a = Option (not cond) a++(<?) :: Syntax a => a -> Option a -> a+a <? b = option a id b++infixr 0 <?+infixr 0 ?>+
+ Feldspar/Par.hs view
@@ -0,0 +1,94 @@+--+-- Copyright (c) 2009-2011, 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.Par+  ( P+  , IVar+  , runPar+  , new+  , get+  , put+  , fork+  , yield+  , spawn+  , pval+  , parMap+  , parMapM+  )+where++import Language.Syntactic++import Feldspar.Core.Constructs (Syntax(..))+import Feldspar.Core.Constructs.Par+import Feldspar.Core.Frontend.Par++runPar :: Syntax a => P a -> a+runPar = sugarSym ParRun++new :: Syntax a => P (IVar a)+new = sugarSym ParNew++get :: Syntax a => IVar a -> P a+get = sugarSym ParGet++put :: Syntax a => IVar a -> a -> P ()+put = sugarSym ParPut++fork :: P () -> P ()+fork = sugarSym ParFork++yield :: P ()+yield = sugarSym ParYield++spawn :: Syntax a => P a -> P (IVar a)+spawn p = do+    r <- new+    fork (p >>= put r)+    return r++pval a = spawn (return a)++parMap f xs = mapM (pval . f) xs >>= mapM get++parMapM f xs = mapM (spawn . f) xs >>= mapM get++{-+divConq :: (prob -> Bool)   -- indivisible?+        -> (prob -> [prob]) -- split into subproblems+        -> ([sol] -> [sol]) -- join solutions+        -> (prob -> sol)    -- solve a (sub)problem+        -> (prob -> sol)+-}+divConq indiv split join f prob = go prob+  where+    go prob | indiv prob = return (f prob)+            | otherwise  = do+                sols <- parMapM go (split prob)+                return (join sols)+
Feldspar/Prelude.hs view
@@ -1,39 +1,77 @@--- | Reexports the "Prelude" hiding all identifiers that are redefined in the--- "Feldspar" library.+--+-- Copyright (c) 2009-2011, ERICSSON AB+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are met:+-- +--     * Redistributions of source code must retain the above copyright notice, +--       this list of conditions and the following disclaimer.+--     * Redistributions in binary form must reproduce the above copyright+--       notice, this list of conditions and the following disclaimer in the+--       documentation and/or other materials provided with the distribution.+--     * Neither the name of the ERICSSON AB nor the names of its contributors+--       may be used to endorse or promote products derived from this software+--       without specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+-- +-- | Reexports a minimal subset of the "Prelude" to open up for reusing+-- "Prelude" identifiers in Feldspar+ module Feldspar.Prelude   ( module Prelude   ) where   -import Prelude hiding-  ( Eq-  , (==), (/=)-  , Ord-  , (<), (>), (<=), (>=)-  , not, (&&), (||)-  , min, max-  , (^)-  , Integral-  , quot, rem-  , div, mod-  , (>>)-  , maximum, minimum-  , length-  , (++)-  , splitAt-  , take, drop-  , dropWhile-  , head, last, tail, init-  , reverse-  , replicate-  , enumFromTo-  , zip, unzip-  , map-  , zipWith-  , sum-  , Real-  , truncate, round, ceiling, floor+import Prelude+  ( Bool (..)+  , Double+  , Float+  , Int+  , IO+  , Integer+  , Maybe (..)+  , String++  , Bounded (..)+  , Fractional (..)+  , Functor (..)+  , Monad (..)+  , Num (..)+  , Read (..)+  , RealFloat (..)+  , Show (..)++  , (.)+  , ($)+  , asTypeOf+  , const+  , curry+  , flip+  , fst+  , id+  , otherwise+  , print+  , putStr+  , putStrLn+  , readFile+  , snd+  , toInteger+  , toRational+  , uncurry+  , undefined+  , writeFile   )
Feldspar/Range.hs view
@@ -1,3 +1,31 @@+--+-- Copyright (c) 2009-2011, 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 #-}  -- | Bounded integer ranges@@ -6,6 +34,14 @@   +-- TODO This module should be broken up into smaller pieces. Since most+-- functions seem to be useful not only for Feldspar, it would probably be good+-- to make a separate package. In any case, the modules should go under+-- `Data.Range`. If there are functions that are very Feldspar specific, these+-- should go into `Feldspar.Core.Constructs.*` (or whereever suitable).+++ import Data.Bits import Data.Int import Data.Word@@ -15,7 +51,7 @@ import qualified Test.QuickCheck as QC import Text.Printf -import Feldspar.Set+import Feldspar.Lattice   @@ -31,17 +67,17 @@     deriving (Eq, Show)  -- | Convenience alias for bounded integers-class    (Eq a, Ord a, Show a, Num a, Bounded a, Integral a, Bits a) => BoundedInt a-instance (Eq a, Ord a, Show a, Num a, Bounded a, Integral a, Bits a) => BoundedInt a+class    (Ord a, Num a, Bounded a, Integral a, Bits a) => BoundedInt a+instance (Ord a, Num a, Bounded a, Integral a, Bits a) => BoundedInt a --- | A convenience function for defining range propagation. +-- | A convenience function for defining range propagation. --   @handleSign propU propS@ chooses @propU@ for unsigned types and --   @propS@ for signed types. handleSign :: forall a b . BoundedInt a =>     (Range a -> b) -> (Range a -> b) -> (Range a -> b) handleSign u s-    | isSigned (minBound::a) = s-    | otherwise              = u+    | isSigned (undefined::a) = s+    | otherwise               = u  -- | Shows a bound. showBound :: BoundedInt a => a -> String@@ -67,10 +103,10 @@   ----------------------------------------------------------------------------------- * Set operations+-- * Lattice operations -------------------------------------------------------------------------------- -instance BoundedInt a => Set (Range a)+instance BoundedInt a => Lattice (Range a)   where     empty     = emptyRange     universal = fullRange@@ -89,10 +125,6 @@ range :: a -> a -> Range a range = Range -rangeByRange :: Range a -> Range a -> Range a-rangeByRange r1 r2 = Range (lowerBound r1) (upperBound r2)-  -- TODO Think about semantics of this function- -- | The range containing one element singletonRange :: a -> Range a singletonRange a = Range a a@@ -103,11 +135,13 @@  -- | The range from the smallest negative element to @-1@. --   Undefined for unsigned types-negativeRange :: BoundedInt a => Range a-negativeRange = Range minBound (-1)+negativeRange :: forall a . BoundedInt a => Range a+negativeRange+  | isSigned (undefined::a) = Range minBound (-1)+  | otherwise               = emptyRange  -- | The size of a range. Beware that the size may not always be representable---   for signed types. For instance +--   for signed types. For instance --   @rangeSize (range minBound maxBound) :: Int@ gives a nonsense answer. rangeSize :: BoundedInt a => Range a -> a rangeSize (Range l u) = u-l+1@@ -118,7 +152,7 @@  -- | Checks if the range contains all values of the type isFull :: BoundedInt a => Range a -> Bool-isFull r = lowerBound r == minBound && upperBound r == maxBound+isFull = (==fullRange)  -- | Checks is the range contains exactly one element isSingleton :: BoundedInt a => Range a -> Bool@@ -211,6 +245,15 @@ -- * Propagation -------------------------------------------------------------------------------- +-- | @rangeByRange ra rb@: Computes the range of the following set+--+-- > {x | a <- ra, b <- rb, x <- Range a b}+rangeByRange :: BoundedInt a => Range a -> Range a -> Range a+rangeByRange r1 r2+    | isEmpty r1 = emptyRange+    | isEmpty r2 = emptyRange+    | otherwise = Range (lowerBound r1) (upperBound r2)+ -- | Implements 'fromInteger' as a 'singletonRange', and implements correct -- range propagation for arithmetic operations. instance BoundedInt a => Num (Range a)@@ -320,6 +363,16 @@   --       because 'negate' always overflows for unsigned numbers.   -- Code from Hacker's Delight +-- | Saturating unsigned subtraction+subSat :: BoundedInt a => a -> a -> a+subSat a b = a - min a b++-- | Range propagation for 'subSat'+rangeSubSat :: BoundedInt a => Range a -> Range a -> Range a+rangeSubSat r1 r2 = Range+    (subSat (lowerBound r1) (upperBound r2))+    (subSat (upperBound r1) (lowerBound r2))+ -- | Propagates range information through multiplication rangeMul :: BoundedInt a => Range a -> Range a -> Range a rangeMul = handleSign rangeMulUnsigned rangeMulSigned@@ -362,7 +415,7 @@  -- | Unsigned case for 'rangeExp'. rangeExpUnsigned :: BoundedInt a => Range a -> Range a -> Range a-rangeExpUnsigned m@(Range l1 u1) e@(Range l2 u2) +rangeExpUnsigned m@(Range l1 u1) e@(Range l2 u2)     | toInteger (bits u1) * toInteger u2 > toInteger (bitSize l1) + 1 = universal     | toInteger u1 ^ toInteger u2 > toInteger (maxBound `asTypeOf` l1) = universal     | 0 `inRange` m && 0 `inRange` e = range 0 (max b1 b2)@@ -372,6 +425,7 @@  -- | Sigend case for 'rangeExp' rangeExpSigned :: BoundedInt a => Range a -> Range a -> Range a+rangeExpSigned m e | m == singletonRange (-1) = range (-1) 1 rangeExpSigned _ _ = universal  -- | Propagates range information through '.|.'.@@ -450,7 +504,7 @@ -- Code from Hacker's Delight.  -- | Propagating range information through 'shiftLU'.-rangeShiftLU :: BoundedInt a => Range a -> Range Word32 -> Range a+rangeShiftLU :: (BoundedInt a, BoundedInt b) => Range a -> Range b -> Range a rangeShiftLU = handleSign rangeShiftLUUnsigned (\_ _ -> universal) -- TODO: improve accuracy @@ -461,7 +515,7 @@     = range (shiftL l1 (fromIntegral l2)) (shiftL u1 (fromIntegral u2))  -- | Propagating range information through 'shiftRU'.-rangeShiftRU :: BoundedInt a => Range a -> Range Word32 -> Range a+rangeShiftRU :: (BoundedInt a, BoundedInt b) => Range a -> Range b -> Range a rangeShiftRU = handleSign rangeShiftRUUnsigned (\_ _ -> universal) -- TODO: improve accuracy @@ -471,7 +525,7 @@  -- | This is a replacement fror Haskell's shiftR. If we carelessly use --   Haskell's variant then we will get left shifts for very large shift values.-correctShiftRU :: Bits a => a -> Word32 -> a+correctShiftRU :: (Bits a, BoundedInt b) => a -> b -> a correctShiftRU a i | i > fromIntegral (maxBound :: Int) = 0 correctShiftRU a i = shiftR a (fromIntegral i) @@ -493,11 +547,17 @@     | r2 `rangeLess` r1 = r2     | otherwise         = mapMonotonic2 min r1 r2 +instance BoundedInt a => Ord (Range a)+  where+    compare = error "compare: I don't make sense for (Range a)"+    min = rangeMin+    max = rangeMax+ -- | Propagates range information through 'mod'. -- Note that we assume Haskell semantics for 'mod'. rangeMod :: BoundedInt a => Range a -> Range a -> Range a rangeMod d r-    | isSigned (lowerBound d) && +    | isSigned (lowerBound d) &&       minBound `inRange` d && (-1) `inRange` r = fullRange     | d `rangeLess` r && isNatural r && isNatural d = d     | isNatural r = range 0 (pred (upperBound r))@@ -528,6 +588,13 @@ predAbs l | l == minBound = abs (succ l)           | otherwise     = pred (abs l) +rangeDiv :: BoundedInt a => Range a -> Range a -> Range a+rangeDiv = handleSign rangeDivU (\_ _ -> universal)++rangeDivU :: BoundedInt a => Range a -> Range a -> Range a+rangeDivU (Range l1 u1) (Range l2 u2) | l2 == 0 || u2 == 0 = universal+rangeDivU (Range l1 u1) (Range l2 u2) = Range (l1 `quot` u2) (u1 `quot`l2)+ -- | Propagates range information through 'quot'. rangeQuot :: BoundedInt a => Range a -> Range a -> Range a rangeQuot = handleSign rangeQuotU (\_ _ -> universal)@@ -547,14 +614,61 @@         = d `rangeLess` (abs (range (succ (lowerBound r)) (upperBound r)))     | otherwise = d `rangeLess` (abs r) --- | Similar to 'rangeLessAbs' but replaces the expression ---   @abs d \`rangeLess\` r@ instead.+-- | Similar to 'rangeLessAbs' but replaces the expression+--   @abs d \`rangeLess\` abs r@ instead. absRangeLessAbs d r     | lowerBound d == minBound = False     | otherwise = abs d `rangeLessAbs` r   --------------------------------------------------------------------------------+-- * Products of ranges+--------------------------------------------------------------------------------++{- These functions are used to compute the ranges of DefaultInt and+   DefaultWord. The size information of these two types is the union of the+   sizes for all possible IntX/WordX that we support as defaults -}++liftR :: (BoundedInt b, BoundedInt c, BoundedInt d) =>+         (forall a. (BoundedInt a) => Range a) -> (Range b,Range c,Range d)+liftR r = (r,r,r)++binopR :: (BoundedInt a, BoundedInt b, BoundedInt c) =>+          (forall a. BoundedInt a => Range a -> Range a -> Range a) ->+          (Range a, Range b, Range c) ->+          (Range a, Range b, Range c) ->+          (Range a, Range b, Range c)+binopR bop (a1,b1,c1) (a2,b2,c2)+    = (bop a1 a2, bop b1 b2, bop c1 c2)+++mapR :: (BoundedInt a, BoundedInt b, BoundedInt c) =>+        (forall a . BoundedInt a => Range a -> Range a) ->+        (Range a, Range b, Range c) ->+        (Range a, Range b, Range c)+mapR f (a,b,c) = (f a, f b, f c)++approx :: (BoundedInt a, BoundedInt b, BoundedInt c, BoundedInt d)+          => (Range a, Range b, Range c) -> Range d+approx (r1,r2,r3) | isFull r1 || isFull r2 || isFull r3+                         = fullRange+approx (r1,r2,r3) = mapMonotonic fromIntegral r1 \/+                    mapMonotonic fromIntegral r2 \/+                    mapMonotonic fromIntegral r3++instance (BoundedInt a, BoundedInt b, BoundedInt c) =>+    Num (Range a,Range b,Range c) where+  (+)           = binopR (+)+  (-)           = binopR (-)+  (*)           = binopR (*)+  signum        = mapR rangeSignum+  fromInteger i = liftR (fromInteger i)+  abs           = mapR abs+  negate        = mapR negate++++-------------------------------------------------------------------------------- -- * Testing -------------------------------------------------------------------------------- @@ -596,8 +710,10 @@     where (i :: Integer, g') = randomR (fromIntegral l,fromIntegral u) g  -fromRange :: Random a => Range a -> Gen a-fromRange r = choose (lowerBound r, upperBound r)+fromRange :: BoundedInt a => Random a => Range a -> Gen a+fromRange r+    | isEmpty r = error "fromRange: empty range"+    | otherwise = choose (lowerBound r, upperBound r)  rangeTy :: Range t -> t -> Range t rangeTy r t = r@@ -616,8 +732,28 @@                             ,test (undefined :: Word8)                             ] +-- | Test if a operation is "strict" wrt. empty ranges+prop_isStrict1 t op ra = isEmpty ra ==> isEmpty (op ra)+  where _ = ra `rangeTy` t++-- | Test if an operation is "strict" wrt. empty ranges+prop_isStrict2 t op ra rb =+    isEmpty ra || isEmpty rb ==> isEmpty (op ra rb)+  where _ = ra `rangeTy` t++-- TODO Think about strictness of range operations (in the sense of `isStrict1`+-- and `isStrict2`). Probably all range propagation operations should be strict,+-- but many of them are currently not:+--+--     *Feldspar.Range> quickCheck (prop_isStrict2 (undefined :: Int) (+))+--     *** Failed! Falsifiable (after 1 test and 1 shrink):+--     Range {lowerBound = 0, upperBound = 1}+--     Range {lowerBound = 1, upperBound = 0}+++ ----------------------------------------------------------------------------------- ** Set operations+-- ** Lattice operations --------------------------------------------------------------------------------  prop_empty t = isEmpty (emptyRange `rangeTy` t)@@ -625,26 +761,7 @@ prop_full t = isFull (fullRange `rangeTy` t)  prop_isEmpty t r = isEmpty r ==> (upperBound r < lowerBound (r `rangeTy` t))-{--prop_rangeByRange t r1 r2 =-    (rangeLess r1 r2 && not (isEmpty (r1/\r2))) ==> isEmpty (rangeByRange r1 r2)-  where _ = r1 `rangeTy` t--}-prop_rangeByRange1 t r1 r2 =-    lowerBound r1 < lowerBound r2 && upperBound r1 < upperBound r2 ==>-    r1 `isSubRangeOf` rangeByRange r1 r2-  where _ = r1 `rangeTy` t -prop_rangeByRange2 t r1 r2 =-    lowerBound r1 < lowerBound r2 && upperBound r1 < upperBound r2 ==>-    r2 `isSubRangeOf` rangeByRange r1 r2-  where _ = r1 `rangeTy` t--prop_rangeByRange3 t r1 r2 =-    lowerBound r1 < lowerBound r2 && upperBound r1 < upperBound r2 ==>-    (r1 `rangeUnion` r2) `isSubRangeOf` rangeByRange r1 r2-  where _ = r1 `rangeTy` t- prop_singletonRange t a = isSingleton (singletonRange (a `asTypeOf` t))  prop_singletonSize t r = isSingleton (r `rangeTy` t) ==> (rangeSize r == 1)@@ -730,7 +847,7 @@ -- checks if applying the operation to the individual elements is in -- the resulting range after range propagation. ----- The third argument is a precondition that is satisfied before the test is +-- The third argument is a precondition that is satisfied before the test is -- run. A good example is to make sure that the second argument is non-zero -- when testing division. rangePropagationSafetyPre :: (Random t, BoundedInt t, BoundedInt a) =>@@ -747,11 +864,11 @@  rangePropagationSafetyPre2 ::     (Random t, BoundedInt t, Random t2, BoundedInt t2, BoundedInt a) =>-    t ->+    t -> t2 ->     (t -> t2 -> a) -> (Range t -> Range t2 -> Range a) ->     (t -> t2 -> Bool) ->     Range t -> Range t2 -> Property-rangePropagationSafetyPre2 t op rop pre r1 r2 =+rangePropagationSafetyPre2 t1 t2 op rop pre r1 r2 =     not (isEmpty r1) && not (isEmpty r2) ==>     forAll (fromRange r1) $ \v1 ->     forAll (fromRange r2) $ \v2 ->@@ -773,7 +890,16 @@     -> Range t -> Range t -> Property prop_propagation2 t op r1 r2 = rangePropagationSafety t op op r1 r2 +prop_rangeByRange1 t ra rb =+    forAll (fromRange ra) $ \a ->+    forAll (fromRange rb) $ \b ->+    forAll (fromRange (Range a b)) $ \x ->+        not (isEmpty ra) && not (isEmpty rb) && not (isEmpty (Range a b)) ==>+          inRange x (rangeByRange ra rb)+  where _ = ra `rangeTy` t +prop_rangeByRange2 t = prop_isStrict2 t rangeByRange+ prop_fromInteger t a = isSingleton (fromInteger a `rangeTy` t)  prop_abs  t = prop_propagation1 t abs@@ -787,17 +913,15 @@  prop_mulU t = rangePropagationSafety t (*) rangeMulUnsigned --- This property doesn't hold!--- The problem is the singleton range minBound minBound-prop_isNegative (r::Range Int) =-    not (isEmpty r) ==> (isNegative r ==> not (isNegative $ negate r))+prop_subSat t = rangePropagationSafety t subSat rangeSubSat -prop_abs2 t r = -    (if isSigned (minBound `asTypeOf` t) then-        lowerBound r /= (minBound `asTypeOf` t)-     else True)-    ==> isNatural (abs r)+prop_isNegative t r =+    not (isEmpty r) && not (r == Range minBound minBound) ==>+        isNegative r ==> not (isNegative $ negate r)+  where _ = rangeTy r t +prop_abs2 t r =+    lowerBound r /= (minBound `asTypeOf` t) ==> isNatural (abs r)  prop_or t = rangePropagationSafety t (.|.) rangeOr @@ -805,13 +929,13 @@  prop_xor t = rangePropagationSafety t xor rangeXor -prop_shiftLU t-    = rangePropagationSafetyPre2 t fixShiftL rangeShiftLU (\_ _ -> True)+prop_shiftLU t1 t2+    = rangePropagationSafetyPre2 t1 t2 fixShiftL rangeShiftLU (\_ _ -> True)   where fixShiftL a b = shiftL a (fromIntegral b) -prop_shiftRU t-    = rangePropagationSafetyPre2 t fixShiftR rangeShiftRU (\_ _ -> True)-  where fixShiftR a b = correctShiftRU a (fromIntegral b)+prop_shiftRU t1 t2+    = rangePropagationSafetyPre2 t1 t2 fixShiftR rangeShiftRU (\_ _ -> True)+  where fixShiftR a b = correctShiftRU a b  prop_rangeMax1 t r1 = rangeMax r1 r1 == (r1 `rangeTy` t) @@ -888,121 +1012,24 @@     rangePropagationSafetyPre t mod rangeMod divPre  prop_rangeMod3 t =-    if isSigned t then         isFull $ rangeMod (singletonRange (minBound `asTypeOf` t))                           (singletonRange (-1))-    else-        True  prop_rangeRem t =     rangePropagationSafetyPre t rem rangeRem divPre  prop_rangeRem1 t =-    if isSigned t then         isFull $ rangeRem (singletonRange (minBound `asTypeOf` t))                           (singletonRange (-1))-    else-        True - prop_rangeQuot t =     rangePropagationSafetyPre t quot rangeQuot divPre  prop_rangeQuot1 t =-    if isSigned t then         isFull $ rangeQuot (singletonRange (minBound `asTypeOf` t))                            (singletonRange (-1))-    else-        True ---- | Precondition for division like operators. +-- | Precondition for division like operators. --   Avoids division by zero and arithmetic overflow. divPre v1 v2 = v2 /= 0 && not (v1 == minBound && v2 == (-1))------------------------------------------------------------------------------------- ** Running-----------------------------------------------------------------------------------data TestCase = forall t. Testable t => TC String t--typedTests :: forall a. (BoundedInt a, Random a, Arbitrary a, Integral a) =>-              a -> [TestCase]-typedTests a =-    [TC "prop_empty"           (prop_empty a)-    ,TC "prop_full"            (prop_full a)-    ,TC "prop_isEmpty"         (prop_isEmpty a)---    ,TC "prop_rangeByRange"    (prop_rangeByRange a)-      -- TODO "*** Gave up! Passed only 0 tests."-    ,TC "prop_rangeByRange1"   (prop_rangeByRange1 a)-    ,TC "prop_rangeByRange2"   (prop_rangeByRange2 a)-    ,TC "prop_rangeByRange3"   (prop_rangeByRange3 a)-    ,TC "prop_singletonRange"  (prop_singletonRange a)-    ,TC "prop_singletonSize"   (prop_singletonSize a)-    ,TC "prop_emptySubRange1"  (prop_emptySubRange1 a)-    ,TC "prop_emptySubRange2"  (prop_emptySubRange2 a)-    ,TC "prop_rangeGap"        (prop_rangeGap a)-    ,TC "prop_union1"          (prop_union1 a)-    ,TC "prop_union2"          (prop_union2 a)-    ,TC "prop_union3"          (prop_union3 a)-    ,TC "prop_union4"          (prop_union4 a)-    ,TC "prop_intersect1"      (prop_intersect1 a)-    ,TC "prop_intersect2"      (prop_intersect2 a)-    ,TC "prop_intersect3"      (prop_intersect3 a)-    ,TC "prop_intersect4"      (prop_intersect4 a)-    ,TC "prop_intersect5"      (prop_intersect5 a)-    ,TC "prop_disjoint"        (prop_disjoint a)-    ,TC "prop_rangeLess1"      (prop_rangeLess1 a)-    ,TC "prop_rangeLess2"      (prop_rangeLess2 a)-    ,TC "prop_rangeLessEq"     (prop_rangeLessEq a)-    ,TC "prop_fromInteger"     (prop_fromInteger a)-    ,TC "prop_abs"             (prop_abs a)-    ,TC "prop_sign"            (prop_sign a)-    ,TC "prop_neg"             (prop_neg a)-    ,TC "prop_add"             (prop_add a)-    ,TC "prop_sub"             (prop_sub a)-    ,TC "prop_mul"             (prop_mul a)-    ,TC "prop_exp"             (prop_exp a)---    ,TC "prop_isNegative"      (prop_isNegative a)-    ,TC "prop_abs2"            (prop_abs2 a)-    ,TC "prop_and"             (prop_and a)-    ,TC "prop_or"              (prop_or a)-    ,TC "prop_xor"             (prop_xor a)-    ,TC "prop_shiftLU"         (prop_shiftLU a)-    ,TC "prop_shiftRU"         (prop_shiftRU a)-    ,TC "prop_rangeMax1"       (prop_rangeMax1 a)-    ,TC "prop_rangeMax2"       (prop_rangeMax2 a)-    ,TC "prop_rangeMax3"       (prop_rangeMax3 a)-    ,TC "prop_rangeMax4"       (prop_rangeMax4 a)-    ,TC "prop_rangeMax5"       (prop_rangeMax5 a)-    ,TC "prop_rangeMax6"       (prop_rangeMax6 a)-    ,TC "prop_rangeMax7"       (prop_rangeMax7 a)-    ,TC "prop_rangeMin1"       (prop_rangeMin1 a)-    ,TC "prop_rangeMin2"       (prop_rangeMin2 a)-    ,TC "prop_rangeMin3"       (prop_rangeMin3 a)-    ,TC "prop_rangeMin4"       (prop_rangeMin4 a)-    ,TC "prop_rangeMin5"       (prop_rangeMin5 a)-    ,TC "prop_rangeMin6"       (prop_rangeMin6 a)-    ,TC "prop_rangeMin7"       (prop_rangeMin7 a)-    ,TC "prop_rangeMod1"       (prop_rangeMod1 a)-    ,TC "prop_rangeMod2"       (prop_rangeMod2 a)-    ,TC "prop_rangeMod3"       (prop_rangeMod3 a)-    ,TC "prop_rangeRem"        (prop_rangeRem a)-    ,TC "prop_rangeRem1"       (prop_rangeRem1 a)-    ,TC "prop_rangeQuot"       (prop_rangeQuot a)-    ,TC "prop_rangeQuot1"      (prop_rangeQuot1 a)-    ]--testAll = do testAtType (undefined :: Int)-             testAtType (undefined :: Int8)-             testAtType (undefined :: Word32)-             testAtType (undefined :: Word8)--myCheck (TC name test) =-    do printf "%-25s" name-       quickCheckWith stdArgs {maxDiscard = 10000} test--testAtType t = do let tn = tyConString $ typeRepTyCon $ typeOf t-                  putStrLn $ "Testing using type: " ++ tn-                  mapM_ myCheck (typedTests t)
+ Feldspar/Repa.hs view
@@ -0,0 +1,339 @@+--+-- Copyright (c) 2009-2011, 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 #-}+module Feldspar.Repa where++import qualified Prelude as P++import Language.Syntactic.Syntax+import Feldspar hiding (desugar,sugar,resugar)++-- | * Shapes++infixl 3 :.+data Z = Z+data tail :. head = tail :. head++type DIM0 = Z+type DIM1 = DIM0 :. Data Length+type DIM2 = DIM1 :. Data Length+type DIM3 = DIM2 :. Data Length++class Shape sh where+  -- | Get the number of dimentsions in a shape+  dim          :: sh -> Int+  -- | The shape of an array of size zero, with a particular dimension+  zeroDim      :: sh+  -- | The shape of an array with size one, with a particular dimension+  unitDim      :: sh+  -- | Get the total number of elements in an array with this shape.+  size         :: sh -> Data Length+  -- | Index into flat, linear, row-major representation+  toIndex      :: sh -> sh -> Data Index+  -- | Inverse of `toIndex`.+  fromIndex    :: sh -> Data Index -> sh+  -- | The intersection of two dimensions.+  intersectDim :: sh -> sh -> sh+  -- | Check whether an index is within a given shape.+  -- @inRange l u i@ checks that 'i' fits between 'l' and 'u'.+  inRange      :: sh -> sh -> sh -> Data Bool+  -- | Turn a shape into a list. Used in the 'Syntactic' instance.+  toList       :: sh -> [Data Length]+  -- | Reconstruct a shape. Used in the 'Syntactic' instance.+  toShape      :: Int -> Data [Length] -> sh++instance Shape Z where+  dim Z            = 0+  zeroDim          = Z+  unitDim          = Z+  size Z           = 1+  toIndex _ _      = 0+  fromIndex _ _    = Z+  intersectDim _ _ = Z+  inRange Z Z Z    = true+  toList _         = []+  toShape _ _      = Z++instance Shape sh => Shape (sh :. Data Length) where+  dim (sh :. _)                       = dim sh + 1+  zeroDim                             = zeroDim :. 0+  unitDim                             = unitDim :. 1+  size (sh :. i)                      = size sh * i+  toIndex (sh1 :. sh2) (sh1' :. sh2') = toIndex sh1 sh1' * sh2 + sh2'+  fromIndex (ds :. d) ix+      = fromIndex ds (ix `quot` d) :. (ix `rem` d)+  intersectDim (sh1 :. n1) (sh2 :. n2)+      = (intersectDim sh1 sh2 :. (min n1 n2))+  inRange (shL :. l) (shU :. u) (sh :. i)+      = l <= i && i < u && inRange shL shU sh+  toList (sh :. i)                    = i : toList sh+  toShape i arr+      = toShape (i+1) arr :. (arr ! (P.fromIntegral i))++-- | * Slices++data All = All+data Any sh = Any++type family FullShape ss+type instance FullShape Z                   = Z+type instance FullShape (Any sh)            = sh+type instance FullShape (sl :. Data Length) = FullShape sl :. Data Length+type instance FullShape (sl :. All)         = FullShape sl :. Data Length++type family SliceShape ss+type instance SliceShape Z                   = Z+type instance SliceShape (Any sh)            = sh+type instance SliceShape (sl :. Data Length) = SliceShape sl+type instance SliceShape (sl :. All)         = SliceShape sl :. Data Length++class Slice ss where+  sliceOfFull :: ss -> FullShape ss -> SliceShape ss+  fullOfSlice :: ss -> SliceShape ss -> FullShape ss++instance Slice Z where+  sliceOfFull Z Z = Z+  fullOfSlice Z Z = Z++instance Slice (Any sh) where+  sliceOfFull Any sh = sh+  fullOfSlice Any sh = sh++instance Slice sl => Slice (sl :. Data Length) where+  sliceOfFull (fsl :. _) (ssl :. _) = sliceOfFull fsl ssl+  fullOfSlice (fsl :. n) ssl        = fullOfSlice fsl ssl :. n++instance Slice sl => Slice (sl :. All) where+  sliceOfFull (fsl :. All) (ssl :. s)+   = sliceOfFull fsl ssl :. s+  fullOfSlice (fsl :. All) (ssl :. s)+   = fullOfSlice fsl ssl :. s++++-- | * Vectors++data Vector sh a = Vector sh (sh -> a)+type DVector sh a = Vector sh (Data a)++instance (Shape sh, Syntax a) => Syntactic (Vector sh a) FeldDomainAll+  where+    type Internal (Vector sh a) = ([Length],[Internal a])+    desugar = desugar . freezeVector . map resugar+    sugar   = map resugar . thawVector . sugar++instance (Shape sh, Syntax a) => Syntax (Vector sh a)++-- | * Fuctions++-- | Store a vector in an array.+fromVector :: (Shape sh, Type a) => DVector sh a -> Data [a]+fromVector vec = parallel (size ext) (\ix -> vec !: fromIndex ext ix)+  where ext = extent vec++-- | Restore a vector from an array+toVector :: (Shape sh, Type a) => sh -> Data [a] -> DVector sh a+toVector sh arr = Vector sh (\ix -> arr ! toIndex ix sh)++freezeVector :: (Shape sh, Type a) => DVector sh a -> (Data [Length], Data [a])+freezeVector v   = (shapeArr, fromVector v)+  where shapeArr = fromList (toList $ extent v)++fromList :: Type a => [Data a] -> Data [a]+fromList ls = loop 1 (parallel (value len) (const (P.head ls)))+  where loop i arr+            | i P.< len = loop (i+1) (setIx arr (value i) (ls P.!! (P.fromIntegral i)))+            | otherwise = arr+        len  = P.fromIntegral $ P.length ls++thawVector :: (Shape sh, Type a) => (Data [Length], Data [a]) -> DVector sh a+thawVector (l,arr) = toVector (toShape 0 l) arr++-- | Store a vector in memory. Use this function instead of 'force' if+--   possible as it is both much more safe and faster.+memorize :: (Shape sh, Type a) => DVector sh a -> DVector sh a+memorize vec = toVector (extent vec) (fromVector vec)++-- | The shape and size of the vector+extent :: Vector sh a -> sh+extent (Vector sh _) = sh++-- | Change shape and transform elements of a vector. This function is the+--   most general way of manipulating a vector.+traverse :: (Shape sh, Shape sh') =>+            Vector sh  a -> (sh -> sh') -> ((sh -> a) -> sh' -> a')+         -> Vector sh' a'+traverse (Vector sh ixf) shf elemf+  = Vector (shf sh) (elemf ixf)++-- | Duplicates part of a vector along a new dimension.+replicate :: (Slice sl, Shape (FullShape sl)+             ,Shape (SliceShape sl))+            => sl -> Vector (SliceShape sl) a+                  -> Vector (FullShape  sl) a+replicate sl vec+ = backpermute (fullOfSlice sl (extent vec))+               (sliceOfFull sl) vec++-- | Extracts a slice from a vector.+slice :: (Slice sl+         ,Shape (FullShape sl)+         ,Shape (SliceShape sl))+        => Vector (FullShape sl) a+            -> sl -> Vector (SliceShape sl) a+slice vec sl+ = backpermute (sliceOfFull sl (extent vec))+               (fullOfSlice sl) vec++-- | Change the shape of a vector. This function is potentially unsafe, the+--   new shape need to have fewer or equal number of elements compared to+--   the old shape.+reshape :: (Shape sh, Shape sh') => sh -> Vector sh' a -> Vector sh a+reshape sh' (Vector sh ixf)+ = Vector sh' (ixf . fromIndex sh . toIndex sh')++-- | A scalar (zero dimensional) vector+unit :: a -> Vector Z a+unit a = Vector Z (const a)++-- | Index into a vector+(!:) :: (Shape sh) => Vector sh a -> sh -> a+(Vector _ ixf) !: ix = ixf ix++-- | Extract the diagonal of a two dimensional vector+diagonal :: Vector DIM2 a -> Vector DIM1 a+diagonal vec = backpermute (Z :. width) (\ (_ :. x) -> Z :. x :. x) vec+  where _ :. height :. width = extent vec++-- | Change the shape of a vector.+backpermute :: (Shape sh, Shape sh') =>+               sh' -> (sh' -> sh) -> Vector sh a -> Vector sh' a+backpermute sh perm vec = traverse vec (const sh) (. perm)++-- | Map a function on all the elements of a vector+map :: (a -> b) -> Vector sh a -> Vector sh b+map f (Vector sh ixf) = Vector sh (f . ixf)++-- | Combines the elements of two vectors. The size of the resulting vector+--   will be the intersection of the two argument vectors.+zip :: (Shape sh) => Vector sh a -> Vector sh b -> Vector sh (a,b)+zip = zipWith (\a b -> (a,b))++-- | Combines the elements of two vectors pointwise using a function.+--   The size of the resulting vector will be the intersection of the+--   two argument vectors.+zipWith :: (Shape sh) =>+           (a -> b -> c) -> Vector sh a -> Vector sh b -> Vector sh c+zipWith f arr1 arr2 = Vector (intersectDim (extent arr1) (extent arr2))+                      (\ix -> f (arr1 !: ix) (arr2 !: ix))++-- | Reduce a vector along its last dimension+fold :: (Shape sh, Syntax a) =>+        (a -> a -> a)+     -> a+     -> Vector (sh :. Data Length) a+     -> Vector sh a+fold f x vec = Vector sh ixf+    where sh :. n = extent vec+          ixf i = forLoop n x (\ix s -> f s (vec !: (i :. ix)))++-- Here's another version of fold which has a little bit more freedom+-- when it comes to choosing the initial element when folding++-- | A generalization of 'fold' which allows for different initial+--   values when starting to fold.+fold' :: (Shape sh, Syntax a) =>+        (a -> a -> a)+     -> Vector sh a+     -> Vector (sh :. Data Length) a+     -> Vector sh a+fold' f x vec = Vector sh ixf+    where sh :. n = extent vec+          ixf i = forLoop n (x!:i) (\ix s -> f s (vec !: (i :. ix)))++-- | Summing a vector along its last dimension+sum :: (Shape sh, Type a, Numeric a) =>+       DVector (sh :. Data Length) a -> DVector sh a+sum = fold (+) 0++-- | Enumerating a vector+(...) :: Data Index -> Data Index -> DVector DIM1 Index+from ... to = Vector (Z :. (to - from + 1)) (\(Z :. ix) -> ix + from)++-- This one should generalize to arbitrary shapes++++-- Laplace++stencil :: DVector DIM2 Float -> DVector DIM2 Float+stencil vec+  = traverse vec id update+  where+    _ :. height :. width = extent vec++    update get d@(sh :. i :. j)+      = isBoundary i j ?+        (get d+        , (get (sh :. (i-1) :. j)+         + get (sh :. i     :. (j-1))+         + get (sh :. (i+1) :. j)+         + get (sh :. i     :. (j+1))) / 4)++    isBoundary i j+      =  (i == 0) || (i >= width  - 1)+      || (j == 0) || (j >= height - 1)++laplace :: Data Length -> DVector DIM2 Float -> DVector DIM2 Float+laplace steps vec = toVector (extent vec) $+                    forLoop steps (fromVector vec) (\ix ->+                       fromVector . stencil . toVector (extent vec)+                    )+++-- Matrix Multiplication++transpose2D :: Vector DIM2 e -> Vector DIM2 e+transpose2D vec+  = backpermute new_extent swap vec+  where swap (Z :. i :. j) = Z :. j :. i+        new_extent         = swap (extent vec)++-- | Matrix multiplication+mmMult :: (Type e, Numeric e) =>+          DVector DIM2 e -> DVector DIM2 e+       -> DVector DIM2 e+mmMult vA vB+  = sum (zipWith (*) vaRepl vbRepl)+  where+    tmp = transpose2D vB+    vaRepl = replicate (Z :. All   :. colsB :. All) vA+    vbRepl = replicate (Z :. rowsA :. All   :. All) vB+    (Z :. colsA :. rowsA) = extent vA+    (Z :. colsB :. rowsB) = extent vB
− Feldspar/Set.hs 
@@ -1,85 +0,0 @@--- | General operations on sets--module Feldspar.Set where------ | A 'Set' is an *over-approximation* of a set of values. The class does not--- care about how the set is interpreted, but it only makes sense to use--- interpretations for which the operations are sound.-class Eq a => Set a-  where-    empty     :: a-    universal :: a-    -- | Union-    (\/)      :: a -> a -> a-    -- | Intersection-    (/\)      :: a -> a -> a---- | Approximates all sets as @()@, which is the 'universal' set.-instance Set ()-  where-    empty     = ()-    universal = ()-    () \/ ()  = ()-    () /\ ()  = ()---- | Set product-instance (Set a, Set b) => Set (a,b)-  where-    empty     = (empty,empty)-    universal = (universal,universal)-    (a1,a2) \/ (b1,b2) = (a1 \/ b1, a2 \/ b2)-    (a1,a2) /\ (b1,b2) = (a1 /\ b1, a2 /\ b2)---- | Three-way product-instance (Set a, Set b, Set c) => Set (a,b,c)-  where-    empty     = (empty,empty,empty)-    universal = (universal,universal,universal)-    (a1,a2,a3) \/ (b1,b2,b3) = (a1 \/ b1, a2 \/ b2, a3 \/ b3)-    (a1,a2,a3) /\ (b1,b2,b3) = (a1 /\ b1, a2 /\ b2, a3 /\ b3)---- | Four-way product-instance (Set a, Set b, Set c, Set d) => Set (a,b,c,d)-  where-    empty     = (empty,empty,empty,empty)-    universal = (universal,universal,universal,universal)-    (a1,a2,a3,a4) \/ (b1,b2,b3,b4) = (a1 \/ b1, a2 \/ b2, a3 \/ b3, a4 \/ b4)-    (a1,a2,a3,a4) /\ (b1,b2,b3,b4) = (a1 /\ b1, a2 /\ b2, a3 /\ b3, a4 /\ b4)--unions :: Set a => [a] -> a-unions = foldr (\/) empty--intersections :: Set a => [a] -> a-intersections = foldr (/\) universal---- Computing fixed points---- | Take the fixed point of a monotonic function. The second argument is---   an initial element. A sensible default for the initial element is---   'empty'.-fixedPoint :: Set a => (a -> a) -> a -> a-fixedPoint f a | fa == a   = fa-               | otherwise = fixedPoint f fa-  where fa = f a \/ a---- | Much like 'fixedPoint' but keeps track of the number of iterations---   in the fixed point iteration. Useful for defining widening operators.-indexedFixedPoint :: Set a => (Int -> a -> a) -> a -> (a,Int)-indexedFixedPoint f a = go 0 f a-  where go i f a | fa == a   = (fa,i)-                 | otherwise = go (i+1) f fa-          where fa = f i a \/ a---- | The type of widening operators. A widening operator modifies a---   function that is subject to fixed point analysis. A widening---   operator introduces approximations in order to guarantee (fast)---   termination of the fixed point analysis.-type Widening a = (Int -> a -> a) -> (Int -> a -> a)---- | A widening operator which defaults to 'universal' when the number of---   iterations goes over the specified value.-cutOffAt :: Set a => Int -> Widening a-cutOffAt n f i a | i >= n    = universal-                 | otherwise = f i a
Feldspar/Stream.hs view
@@ -1,3 +1,31 @@+--+-- Copyright (c) 2009-2011, ERICSSON AB+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are met:+-- +--     * Redistributions of source code must retain the above copyright notice, +--       this list of conditions and the following disclaimer.+--     * Redistributions in binary form must reproduce the above copyright+--       notice, this list of conditions and the following disclaimer in the+--       documentation and/or other materials provided with the distribution.+--     * Neither the name of the ERICSSON AB nor the names of its contributors+--       may be used to endorse or promote products derived from this software+--       without specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+--+ module Feldspar.Stream     (Stream     ,head@@ -8,7 +36,7 @@     ,interleave     ,downsample     ,duplicate-    ,scan+    ,scan, scan1     ,mapAccum     ,iterate     ,repeat@@ -20,186 +48,256 @@     ,splitAt     ,cycle     ,streamAsVector, streamAsVectorSize-    ,recurrenceO,recurrenceI,recurrenceIO+    ,recurrenceO, recurrenceI, recurrenceIO     ,iir,fir     )     where -import Feldspar.Core-import qualified Prelude-import Feldspar.Range-import Feldspar.Prelude hiding (filter,repeat,iterate,cycle)+import qualified Prelude as P+ import Control.Arrow -import Feldspar.Vector (Vector, DVector-                       ,vector,freezeVector,unfreezeVector,indexed-                       ,sum,length,replicate,reverse,scalarProd)+import Feldspar+import Feldspar.Vector.Internal+         (Vector, Vector1+         ,freezeVector,thawVector,indexed+         ,sum,length,replicate,reverse,scalarProd)  -- | Infinite streams. data Stream a where-  Stream :: Syntactic state => (state -> (a,state)) -> state -> Stream a+  Stream :: Syntax state => (state -> M a) -> M state -> Stream a +type instance Elem      (Stream a) = a+type instance CollIndex (Stream a) = Data Index+ -- | Take the first element of a stream-head :: Syntactic a => Stream a -> a-head (Stream next init) = fst $ next init+head :: Syntax a => Stream a -> a+head (Stream next init) = runMutable (init >>= next)  -- | Drop the first element of a stream-tail :: Syntactic a => Stream a -> Stream a-tail (Stream next init) = Stream next (snd $ next init)+tail :: Syntax a => Stream a -> Stream a+tail (Stream next init) = Stream next (init >>= \st -> next st >> return st)  -- | 'map f str' transforms every element of the stream 'str' using the --   function 'f'-map :: (Syntactic a, Syntactic b) =>+map :: (Syntax a, Syntax b) =>        (a -> b) -> Stream a -> Stream b map f (Stream next init) = Stream newNext init-  where newNext st = let (a,st') = next st in (f a, st')+  where newNext st = do a <- next st+                        return (f a)  -- | 'mapNth f n k str' transforms every 'n'th element with offset 'k' --    of the stream 'str' using the function 'f'-mapNth :: (Syntactic a) => +mapNth :: (Syntax a) =>           (a -> a) -> Data Index -> Data Index -> Stream a -> Stream a-mapNth f n k (Stream next init) = Stream newNext (init,0)-  where newNext (st,i) = let (a,st') = next st in (i==k?(f a,a),(st',(i+1) `mod` n))+mapNth f n k (Stream next init) = Stream newNext newInit+  where+    newInit = do st <- init+                 r  <- newRef (0 :: Data WordN)+                 return (st,r)+    newNext (st,r) = do a <- next st+                        i <- getRef r+                        setRef r ((i+1) `mod` n)+                        return (i==k?(f a,a))  -- | 'maps fs str' uses one of the functions from 'fs' successively to modify --   the elements of 'str'-maps :: (Syntactic a) =>-        [(a -> a)] -> Stream a -> Stream a-maps fs (Stream next init) = Stream newNext (init,0 :: Data Index)-  where newNext (st,i) = -            let (a,st') = next st in-            (Prelude.foldr (\ (k,f) r -> -                                i==(fromIntegral k)?(f a,r)) -                           a (Prelude.zip [1..] fs)-            ,(st',(i+1) `mod` fromIntegral (Prelude.length fs))-            )+maps :: (Syntax a) =>+        [a -> a] -> Stream a -> Stream a+maps fs (Stream next init) = Stream newNext newInit+  where+    newInit = do+      r  <- newRef (0 :: Data Index)+      st <- init+      return (r,st)+    newNext (r,st) = do+      a <- next st+      i <- getRef r+      setRef r ((i+1) `mod` P.fromIntegral (P.length fs))+      return $+        (P.foldr (\ (k,f) r ->+                            i==(P.fromIntegral k)?(f a,r)))+         a (P.zip [1..] fs)  -- | 'intersperse a str' inserts an 'a' between each element of the stream --    'str'.-intersperse :: Syntactic a => a -> Stream a -> Stream a-intersperse a (Stream next init) =-    Stream newNext (true,init)-  where newNext (b,st) = b ? (let (e,st') = next st-                              in (e,(false,st'))-                             ,(a,(true,st))-                             )+intersperse :: Syntax a => a -> Stream a -> Stream a+intersperse a (Stream next init) = Stream newNext newInit+  where+    newInit = do st <- init+                 r  <- newRef true+                 return (st,r)+    newNext (st,r) = do b <- getRef r+                        setRef r (not b)+                        ifM b (next st) (return a)  -- | Create a new stream by alternating between the elements from --   the two input streams-interleave :: Syntactic a => Stream a -> Stream a -> Stream a+interleave :: Syntax a => Stream a -> Stream a -> Stream a interleave (Stream next1 init1) (Stream next2 init2)-    = Stream next (true,init1,init2)-  where next (b,st1,st2) = b ? (let (a,st1') = next1 st1-                                in (a,(false,st1',st2))-                               ,let (a,st2') = next2 st2-                                in (a,(true,st1,st2'))-                               )+    = Stream next init+  where+    init = do st1 <- init1+              st2 <- init2+              r   <- newRef true+              return (r,st1,st2)+    next (r,st1,st2) = do b <- getRef r+                          setRef r (not b)+                          ifM b (next1 st1) (next2 st2)  -- | 'downsample n str' takes every 'n'th element of the input stream-downsample :: Syntactic a => Data Index -> Stream a -> Stream a+downsample :: Syntax a => Data Index -> Stream a -> Stream a downsample n (Stream next init) = Stream newNext init-  where newNext st = forLoop (n-1) (next st) (\_ (_,st) -> next st)+  where newNext st = do forM (n-1) (\_ -> next st)+                        next st  -- | 'duplicate n str' stretches the stream by duplicating the elements 'n' times-duplicate :: Syntactic a => Data Index -> Stream a -> Stream a-duplicate n (Stream next init) = Stream newNext (next init,1)-  where newNext (p@(a,st),i) = i==0 ? (let (b,st') = next st in (b,((b,st'),1))-                                      ,(a,(p,(i+1)`mod`n))-                                      )+duplicate :: Syntax a => Data Index -> Stream a -> Stream a+duplicate n (Stream next init) = Stream newNext newInit+  where+    newInit = do st <- init+                 a  <- next st+                 r1 <- newRef a+                 r2 <- newRef (1 :: Data Index)+                 return (st,r1,r2)+    newNext (st,r1,r2) = do i <- getRef r2+                            setRef r2 ((i+1)`mod`n)+                            ifM (i==0)+                              (do a <- next st+                                  setRef r1 a+                                  return a)+                              (getRef r1)  -- | '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.-scan :: Syntactic a => (a -> b -> a) -> a -> Stream b -> Stream a-scan f a (Stream next init)-    = Stream newNext (a,init)-  where newNext (acc,st) = let (a,st') = next st-                           in (acc,  (f acc a,st') )+scan :: Syntax a => (a -> b -> a) -> a -> Stream b -> Stream a+scan f a (Stream next init) = Stream newNext newInit+  where+    newInit = do st <- init+                 r  <- newRef a+                 return (st,r)+    newNext (st,r) = do a   <- next st+                        acc <- getRef r+                        setRef r (f acc a)+                        return acc -{- This function is problematic to define for the same reason the index-   function is problematic, plus that it has the same quirk as correctScan.--}  -- | A scan but without an initial element.-scan1 :: Syntactic a => (a -> a -> a) -> Stream a -> Stream a+scan1 :: Syntax a => (a -> a -> a) -> Stream a -> Stream a scan1 f (Stream next init)-    = Stream newNext (a,true,newInit)-  where (a,newInit) = next init-        newNext (a,isFirst,st)-            = isFirst ? ( (a, (a,false,st))-                        , let (b,st') = next st-                          in let elem = f a b-                             in (elem, (elem,false,st'))-                        )+    = Stream newNext newInit+  where+    newInit = do+      st <- init+      a  <- next st+      r  <- newRef a+      return (st,r)+    newNext (st,r) = do+      a <- getRef r+      b <- next st+      let c = f a b+      setRef r c+      return c  -- | Maps a function over a stream using an accumulator.-mapAccum :: (Syntactic acc, Syntactic b) =>+mapAccum :: (Syntax acc, Syntax b) =>             (acc -> a -> (acc,b)) -> acc -> Stream a -> Stream b mapAccum f acc (Stream next init)-    = Stream newNext (init,acc)-  where newNext (st,acc)-            = let (a,st')  = next st-                  (acc',b) = f acc a-              in (b, (st',acc'))+    = Stream newNext newInit+  where+    newInit = do+      st <- init+      r  <- newRef acc+      return (st,r)+    newNext (st,r) = do+      acc <- getRef r+      a   <- next st+      let (acc',b) = f acc a+      setRef r acc'+      return b  -- | Iteratively applies a function to a starting element. All the successive --   results are used to create a stream. -- -- @iterate f a == [a, f a, f (f a), f (f (f a)) ...]@-iterate :: Syntactic a => (a -> a) -> a -> Stream a-iterate f init = Stream next init-  where next a = (a, f a)+iterate :: Syntax a => (a -> a) -> a -> Stream a+iterate f a = Stream next init+  where+    init = newRef a+    next r = do a <- getRef r+                setRef r (f a)+                return a  -- | Repeat an element indefinitely. -- -- @repeat a = [a, a, a, ...]@-repeat :: Syntactic a => a -> Stream a-repeat a = Stream next (value ())-  where next _ = (a,value ())+repeat :: Syntax a => a -> Stream a+repeat a = Stream next (return ())+  where next _ = return a  -- | @unfold f acc@ creates a new stream by successively applying 'f' to --   to the accumulator 'acc'.-unfold :: (Syntactic a, Syntactic c) => (c -> (a,c)) -> c -> Stream a-unfold next init = Stream next init+unfold :: (Syntax a, Syntax c) => (c -> (a,c)) -> c -> Stream a+unfold next init = Stream newNext newInit+  where+    newInit = newRef init+    newNext r = do c <- getRef r+                   let (a,c') = next c+                   setRef r c'+                   return a  -- | Drop a number of elements from the front of a stream-drop :: Data Length -> Stream a -> Stream a-drop i (Stream next init) = Stream next newState-  where newState  = forLoop i init body-        body _    = snd . next+drop :: Syntax a => Data Length -> Stream a -> Stream a+drop i (Stream next init) = Stream next newInit+  where newInit = do st <- init+                     forM i (\_ -> next st)+                     return st  -- | Pairs together two streams into one. zip :: Stream a -> Stream b -> Stream (a,b)-zip (Stream next1 init1) (Stream next2 init2)-    = Stream next (init1,init2)-  where next (st1,st2) = ( (a,b), (st1',st2') )-            where (a,st1') = next1 st1-                  (b,st2') = next2 st2+zip (Stream next1 init1) (Stream next2 init2) = Stream next init+  where+    init = do st1 <- init1+              st2 <- init2+              return (st1,st2)+    next (st1,st2) = do a <- next1 st1+                        b <- next2 st2+                        return (a,b)  -- | Pairs together two streams using a function to combine the --   corresponding elements.-zipWith :: Syntactic c => (a -> b -> c) -> Stream a -> Stream b -> Stream c-zipWith f (Stream next1 init1) (Stream next2 init2)-    = Stream next (init1,init2)-  where next (st1,st2) = ( f a b, (st1',st2'))-            where (a,st1') = next1 st1-                  (b,st2') = next2 st2+zipWith :: Syntax c => (a -> b -> c) -> Stream a -> Stream b -> Stream c+zipWith f (Stream next1 init1) (Stream next2 init2) = Stream next init+  where+    init = do st1 <- init1+              st2 <- init2+              return (st1,st2)+    next (st1,st2) = do a <- next1 st1+                        b <- next2 st2+                        return (f a b)  -- | Given a stream of pairs, split it into two stream.-unzip :: (Syntactic a, Syntactic b) => Stream (a,b) -> (Stream a, Stream b)+unzip :: (Syntax a, Syntax b) => Stream (a,b) -> (Stream a, Stream b) unzip stream = (map fst stream, map snd stream) -instance Syntactic a => RandomAccess (Stream a) where-  type Element (Stream a) = a-  (Stream next init) ! n = fst $ forLoop n (next init) body-    where body _ (_,st) = next st+instance Syntax a => Indexed (Stream a) where+  (Stream next init) ! n = runMutable $ do+                             st <- init+                             forM (n-1) (\_ -> next st)+                             next st  -- | 'take n str' allocates 'n' elements from the stream 'str' into a --   core array. take :: (Type a) => Data Length -> Stream (Data a) -> Data [a] take n (Stream next init)-    = sequential n init step (const $ value [])-  where step i st = next st+    = runMutableArray $ do+        marr <- newArr_ n+        st   <- init+        forM n $ \ix -> do+          a <- next st+          setArr marr ix a+        return marr  -- | 'splitAt n str' allocates 'n' elements from the stream 'str' into a --   core array and returns the rest of the stream continuing from@@ -209,32 +307,39 @@ splitAt n stream = (take n stream,drop n stream)  -- | Loops through a vector indefinitely to produce a stream.-cycle :: Syntactic a => Vector a -> Stream a-cycle vec = Stream next 0-  where next i = (vec ! i, (i + 1) `rem` length vec)+cycle :: Syntax a => Vector a -> Stream a+cycle vec = Stream next init+  where+    init = newRef (0 :: Data Index)+    next r = do i <- getRef r+                setRef r ((i + 1) `rem` length vec)+                return (vec ! i) -unsafeVectorToStream :: Syntactic a => Vector a -> Stream a-unsafeVectorToStream vec = Stream next 0-  where next i = (vec ! i, i + 1)+unsafeVectorToStream :: Syntax a => Vector a -> Stream a+unsafeVectorToStream vec = Stream next init+  where+    init = newRef (0 :: Data Index)+    next r = do i <- getRef r+                setRef r (i + 1)+                return (vec ! i)  -- | A convenience function for translating an algorithm on streams to an algorithm on vectors. --   The result vector will have the same length as the input vector. --   It is important that the stream function doesn't drop any elements of --   the input stream.--- +-- --   This function allocates memory for the output vector.-streamAsVector :: (Type a, Type b) => -                  (Stream (Data a) -> Stream (Data b)) +streamAsVector :: (Type a, Type b) =>+                  (Stream (Data a) -> Stream (Data b))                -> (Vector (Data a) -> Vector (Data b))-streamAsVector f v -    = unfreezeVector $ take (length v) $ f $ unsafeVectorToStream v+streamAsVector f v = thawVector $ take (length v) $ f $ unsafeVectorToStream v  -- | Similar to 'streamAsVector' except the size of the output array is computed by the second argument --   which is given the size of the input vector as a result.-streamAsVectorSize :: (Type a, Type b) => -                      (Stream (Data a) -> Stream (Data b)) -> (Data Length -> Data Length) +streamAsVectorSize :: (Type a, Type b) =>+                      (Stream (Data a) -> Stream (Data b)) -> (Data Length -> Data Length)                    -> (Vector (Data a) -> Vector (Data b))-streamAsVectorSize f s v = unfreezeVector $ take (s $ length v) $ f $ cycle v+streamAsVectorSize f s v = thawVector $ take (s $ length v) $ f $ cycle v  -- | A combinator for descibing recurrence equations, or feedback loops. --   The recurrence equation may refer to previous outputs of the stream,@@ -245,21 +350,31 @@ -- -- > fib = recurrenceO (vector [0,1]) (\fib -> fib!0 + fib!1) ----- The expressions @fib 1@ and @fib 2@ refer to previous elements in the+-- The expressions @fib!0@ and @fib!1@ refer to previous elements in the -- stream defined one step back and two steps back respectively. recurrenceO :: Type a =>-               DVector a -> -               (DVector a -> Data a) -> +               Vector1 a ->+               (Vector1 a -> Data a) ->                Stream (Data a)-recurrenceO init mkExpr = Stream next (buf,0)-  where buf            = freezeVector init-        len            = getLength buf-        next (buf,ix)  =-            let a = mkExpr (indexed len (\i -> getIx buf ((i + ix) `rem` len)))-            in (getIx buf (ix `rem` len), (setIx buf (ix `rem` len) a, ix + 1))+recurrenceO initV mkExpr = Stream next init+  where+    len  = length initV+    init = do+      buf <- thawArray (freezeVector initV)+      r   <- newRef (0 :: Data Index)+      return (buf,r) +    next (buf,r) = do+      ix <- getRef r+      setRef r (ix + 1)+      a <- withArray buf+           (\ibuf -> return $ mkExpr+                     (indexed len (\i -> getIx ibuf ((i + ix) `rem` len))))+      result <- getArr buf (ix `rem` len)+      setArr buf (ix `rem` len) a+      return result --- | A recurrence combinator with input. The function 'recurrenceI' is +-- | A recurrence combinator with input. The function 'recurrenceI' is --   similar to 'recurrenceO'. The difference is that that it has an input --   stream, and that the recurrence equation may only refer to previous --   inputs, it may not refer to previous outputs.@@ -267,15 +382,15 @@ -- The sliding average of a stream can easily be implemented using -- 'recurrenceI'. ----- > slidingAvg :: Data DefaultWord -> Stream (Data DefaultWord) -> Stream (Data DefaultWord)+-- > slidingAvg :: Data WordN -> Stream (Data WordN) -> Stream (Data WordN) -- > slidingAvg n str = recurrenceI (replicate n 0) str--- >                    (\input _ -> sum input `quot` n)+-- >                    (\input -> sum input `quot` n) recurrenceI :: (Type a, Type b) =>-               DVector a -> Stream (Data a) ->-               (DVector a -> Data b) ->+               Vector1 a -> Stream (Data a) ->+               (Vector1 a -> Data b) ->                Stream (Data b)-recurrenceI ii stream mkExpr -    = recurrenceIO ii stream (vector []) (\i o -> mkExpr i)+recurrenceI ii stream mkExpr+    = recurrenceIO ii stream (value []) (\i o -> mkExpr i)  -- | 'recurrenceIO' is a combination of 'recurrenceO' and 'recurrenceI'. It --   has an input stream and the recurrence equation may refer both to@@ -283,67 +398,90 @@ -- --   'recurrenceIO' is used when defining the 'iir' filter. recurrenceIO :: (Type a, Type b) =>-                DVector a -> Stream (Data a) -> DVector b ->-                (DVector a -> DVector b -> Data b) ->+                Vector1 a -> Stream (Data a) -> Vector1 b ->+                (Vector1 a -> Vector1 b -> Data b) ->                 Stream (Data b)-recurrenceIO ii (Stream st s) io mkExpr-    = Stream step (ibuf,obuf,s,0)-  where ibuf = freezeVector ii-        obuf = freezeVector io-        p    = getLength ibuf-        q    = getLength obuf-        step (ibuf,obuf,s,ix) =-            let (a,s') = st s-                ibuf'  = p /= 0 ? (setIx ibuf (ix `rem` p) a, ibuf)-                b = mkExpr -                    (indexed p (\i -> getIx ibuf' ((i + ix)     `rem` p)))-                    (indexed q (\i -> getIx obuf  ((i + ix - 1) `rem` q)))-            in (q /= 0 ? (getIx obuf (ix `rem` q),b),-                          (ibuf'-                          ,q /= 0 ? (setIx obuf (ix `rem` q) b,obuf)-                          ,s'-                          ,ix + 1))+recurrenceIO ii (Stream nxt int) io mkExpr+    = Stream next init+  where+    lenI = length ii+    lenO = length io+    init = do+      ibuf <- thawArray (freezeVector ii)+      obuf <- thawArray (freezeVector io)+      st   <- int+      r    <- newRef (0 :: Data Index)+      return (ibuf,obuf,st,r)+    next (ibuf,obuf,st,r) = do+      ix <- getRef r+      setRef r (ix + 1)+      a <- nxt st+      when (lenI /= 0) $ setArr ibuf (ix `rem` lenI) a+      b <- withArray ibuf (\ibuf ->+             withArray obuf (\obuf ->+               return $ mkExpr+                          (indexed lenI (\i -> getIx ibuf ((i + ix) `rem` lenI)))+                          (indexed lenO (\i -> getIx obuf ((i + ix - 1) `rem` lenO)))+                            ))+      ifM (lenO /= 0)+        (do o <- getArr obuf (ix `rem` lenO)+            setArr obuf (ix `rem` lenO) b+            return o)+        (return b) +-- | Similar to 'recurrenceIO' but takes two input streams. recurrenceIIO :: (Type a, Type b, Type c) =>-                 DVector a -> Stream (Data a) -> DVector b -> Stream (Data b) ->-                 DVector c ->-                 (DVector a -> DVector b -> DVector c -> Data c) ->+                 Vector1 a -> Stream (Data a) -> Vector1 b -> Stream (Data b) ->+                 Vector1 c ->+                 (Vector1 a -> Vector1 b -> Vector1 c -> Data c) ->                  Stream (Data c) recurrenceIIO i1 (Stream next1 init1) i2 (Stream next2 init2) io mkExpr-    = Stream next ((ibuf1,init1),(ibuf2,init2),obuf,0)-  where ibuf1 = freezeVector i1-        ibuf2 = freezeVector i2-        obuf  = freezeVector io-        l1    = getLength ibuf1-        l2    = getLength ibuf2-        lo    = getLength obuf-        next ((ibuf1,st1),(ibuf2,st2),obuf,ix) =             -            let (a,st1') = next1 st1-                (b,st2') = next2 st2-                ibuf1'  = l1 /= 0 ? (setIx ibuf1 (ix `rem` l1) a, ibuf1)-                ibuf2'  = l2 /= 0 ? (setIx ibuf2 (ix `rem` l2) b, ibuf2)-                c = mkExpr (indexed l1 (\i -> getIx ibuf1' ((i + ix)     `rem` l1)))-                           (indexed l2 (\i -> getIx ibuf2' ((i + ix)     `rem` l2)))-                           (indexed lo (\i -> getIx obuf   ((i + ix - 1) `rem` lo)))-            in (lo /= 0 ? (getIx obuf (ix `rem` lo),c),-                          ((ibuf1',st1')-                          ,(ibuf2',st2')-                          ,lo /= 0 ? (setIx obuf (ix `rem` lo) c,obuf)-                          ,ix + 1))+    = Stream next init+  where+    len1 = length i1+    len2 = length i2+    lenO = length io+    init = do+      ibuf1 <- thawArray (freezeVector i1)+      st1   <- init1+      ibuf2 <- thawArray (freezeVector i2)+      st2   <- init2+      obuf  <- thawArray (freezeVector io)+      c     <- newRef (0 :: Data Index)+      return (ibuf1,st1,ibuf2,st2,obuf,c)+    next (ibuf1,st1,ibuf2,st2,obuf,c) = do+      ix <- getRef c+      setRef c (ix + 1)+      a <- next1 st1+      b <- next2 st2+      when (len1 /= 0) $ setArr ibuf1 (ix `rem` len1) a+      when (len2 /= 0) $ setArr ibuf2 (ix `rem` len2) b+      out <- withArray ibuf1 (\ibuf1 ->+               withArray ibuf2 (\ibuf2 ->+                 withArray obuf (\obuf ->+                   return $ mkExpr (indexed len1 (\i -> getIx ibuf1 ((i + ix) `rem` len1)))+                                   (indexed len2 (\i -> getIx ibuf2 ((i + ix) `rem` len2)))+                                   (indexed lenO (\i -> getIx obuf  ((i + ix) `rem` lenO)))+                                )))+      ifM (lenO /= 0)+          (do o <- getArr obuf (ix `rem` lenO)+              setArr obuf (ix `rem` lenO) out+              return o)+          (return out) -slidingAvg :: Data DefaultWord -> Stream (Data DefaultWord) -> Stream (Data DefaultWord)+slidingAvg :: Data WordN -> Stream (Data WordN) -> Stream (Data WordN) slidingAvg n str = recurrenceI (replicate n 0) str                    (\input -> sum input `quot` n)  -- | A fir filter on streams-fir :: DVector Float ->+fir :: Vector1 Float ->        Stream (Data Float) -> Stream (Data Float) fir b input =     recurrenceI (replicate (length b) 0) input                 (\input -> scalarProd b input)  -- | An iir filter on streams-iir :: Data Float -> DVector Float -> DVector Float ->+iir :: Data Float -> Vector1 Float -> Vector1 Float ->        Stream (Data Float) -> Stream (Data Float) iir a0 a b input =     recurrenceIO (replicate (length b) 0) input@@ -352,3 +490,4 @@                         ( scalarProd b input                         - scalarProd a output)       )+
Feldspar/Vector.hs view
@@ -1,14 +1,45 @@-{-# LANGUAGE UndecidableInstances #-}+--+-- Copyright (c) 2009-2011, 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 module for /virtual vectors/. Many of the functions defined here are -- imitations of Haskell's list operations, and to a first approximation they -- behave accordingly. ----- A virtual vector normally doesn't use any physical memory. Memory is only--- introduced explicitly using the function 'force' or converted to a core array--- using 'freezeVector'. The function 'vector' for creating a vector also--- allocates memory.+-- A virtual vector is normally guaranteed not to be present in the generated+-- code. The only exceptions are: --+--   * when it is explicitly forced using the functions 'force' or 'desugar'+--+--   * when it is the input or output of a program+--+--   * when it is accessed by a function outside the "Feldspar.Vector" API, for+--     example, 'condition' or 'forLoop'+-- -- Note also that most operations only introduce a small constant overhead on -- the vector. The exceptions are --@@ -22,259 +53,13 @@ -- -- These functions introduce overhead that is linear in the length of the -- vector.------ Finally, note that 'freezeVector' can be introduced implicitly by functions--- overloaded by the 'Syntactic' class. -module Feldspar.Vector where----import qualified Prelude-import Control.Arrow ((&&&))-import Data.List (genericLength)-import qualified Data.TypeLevel as TL--import Feldspar.DSL.Network hiding (In,Out)-import Feldspar.Prelude-import Feldspar.Core.Representation-import Feldspar.Core------ * Types---- | Symbolic vector-data Vector a-    = Empty-    | Indexed-        { segmentLength :: Data Length-        , segmentIndex  :: Data Index -> a-        , continuation  :: Vector a-        }---- | Short-hand for non-nested parallel vector-type DVector a = Vector (Data a)------ * Construction/conversion--indexed :: Data Length -> (Data Index -> a) -> Vector a-indexed l idxFun = Indexed l idxFun Empty---- | Breaks up a segmented vector into a list of single-segment vectors.-segments :: Vector a -> [Vector a]-segments Empty                = []-segments (Indexed l ixf cont) = indexed l ixf : segments cont--length :: Vector a -> Data Length-length Empty = 0-length vec   = Prelude.foldr (+) 0 $ Prelude.map segmentLength $ segments vec---- | Converts a segmented vector to a vector with a single segment.-mergeSegments :: Syntactic a => Vector a -> Vector a-mergeSegments vec = indexed (length vec) (ixFun (segments vec))-  where-    ixFun (Indexed l ixf _ : vs) = case vs of-      [] -> ixf-      _  -> \i -> condition (i<l) (ixf i) (ixFun vs (i-l))---- | Converts a non-nested vector to a core vector.-freezeVector :: Type a => Vector (Data a) -> Data [a]-freezeVector vec = help True vec-  where-    help _   Empty                = value []-    help opt (Indexed l ixf cont) = parallel'' opt l ixf $ help False cont---- | Converts a non-nested core vector to a parallel vector.-unfreezeVector :: Type a => Data [a] -> Vector (Data a)-unfreezeVector arr = indexed (getLength arr) (getIx arr)---- | Variant of `unfreezeVector` with additional static size information.-unfreezeVector' :: (Type a) => Length -> Data [a] -> Vector (Data a)-unfreezeVector' len arr = unfreezeVector $ cap (r :> elemSize) arr-  where-    (_ :> elemSize) = dataSize arr-    r = Range len len---- | Optimizes vector lookup by computing all elements and storing them in a--- core array.-memorize :: Syntactic (Vector a) => Vector a -> Vector a-memorize = force-{-# DEPRECATED memorize "Please use `force` instead." #-}---- | Constructs a non-nested vector. The elements are stored in a core vector.-vector :: Type a => [a] -> Vector (Data a)-vector as = unfreezeVector (value as)-  -- TODO Generalize to arbitrary dimensions.--instance-    ( Syntactic a-    , Role a ~ ()-    , Info a ~ EdgeSize () (Internal a)-    ) => EdgeInfo (Vector a)-  where-    type Info (Vector a) = EdgeSize () [Internal a]-    edgeInfo             = edgeInfo . toEdge--instance-    ( Syntactic a-    , Role a ~ ()-    , Info a ~ EdgeSize () (Internal a)-    ) =>-    MultiEdge (Vector a) Feldspar EdgeSize-  where-    type Role     (Vector a) = ()-    type Internal (Vector a) = [Internal a]--    toEdge           = toEdge . freezeVector . map edgeCast-    fromInEdge       = map edgeCast . unfreezeVector . fromInEdge-    fromOutEdge info = map edgeCast . unfreezeVector . fromOutEdge info--instance (Syntactic a, Role a ~ (), Info a ~ EdgeSize () (Internal a)) =>-    Syntactic (Vector a)+module Feldspar.Vector+    ( module Feldspar.Vector.Internal+    ) where   --- * Operations--instance Syntactic a => RandomAccess (Vector a)-  where-    type Element (Vector a) = a-    (!) = segmentIndex . mergeSegments--(++) :: Vector a -> Vector a -> Vector a-Empty              ++ v     = v-v                  ++ Empty = v-Indexed l ixf cont ++ v     = Indexed l ixf (cont ++ v)--infixr 5 ++--take :: Data Length -> Vector a -> Vector a-take _ Empty                = Empty-take n (Indexed l ixf cont) = indexed nHead ixf ++ take nCont cont-  where-    nHead = n<l ? (n,l)-    nCont = n<l ? (0,n-l)--drop :: Data Length -> Vector a -> Vector a-drop _ Empty = Empty-drop n (Indexed l ixf cont) = indexed nHead (ixf . (+n)) ++ drop nCont cont-  where-    nHead = n > l ? (0,l-n)-    nCont = l > n ? (0,n-l)--splitAt :: Data Index -> Vector a -> (Vector a, Vector a)-splitAt n vec = (take n vec, drop n vec)--head :: Syntactic a => Vector a -> a-head = (!0)--last :: Syntactic a => Vector a -> a-last vec = vec ! (length vec - 1)--tail :: Vector a -> Vector a-tail = drop 1--init :: Vector a -> Vector a-init vec = take (length vec - 1) vec--tails :: Vector a -> Vector (Vector a)-tails vec = indexed (length vec + 1) (\n -> drop n vec)--inits :: Vector a -> Vector (Vector a)-inits vec = indexed (length vec + 1) (\n -> take n vec)--inits1 :: Vector a -> Vector (Vector a)-inits1 = tail . inits---- | Permute a single-segment vector-permute' :: (Data Length -> Data Index -> Data Index) -> (Vector a -> Vector a)-permute' _    Empty                 = Empty-permute' perm (Indexed l ixf Empty) = indexed l (ixf . perm l)---- | Permute a vector-permute :: Syntactic a =>-    (Data Length -> Data Index -> Data Index) -> (Vector a -> Vector a)-permute perm = permute' perm . mergeSegments--reverse :: Syntactic a => Vector a -> Vector a-reverse = permute $ \l i -> l-1-i-  -- TODO Can be optimized (reversing each segment separately, and then-  --      reversing the segment order)--rotateVecL :: Syntactic a => Data Index -> Vector a -> Vector a-rotateVecL ix = permute $ \l i -> (i + ix) `rem` l--rotateVecR :: Syntactic a => Data Index -> Vector a -> Vector a-rotateVecR ix = reverse . rotateVecL ix . reverse--replicate :: Data Length -> a -> Vector a-replicate n a = Indexed n (const a) Empty--enumFromTo :: Data Index -> Data Index -> Vector (Data Index)-enumFromTo m n = indexed l (+m)-  where-    l = n<m ? (0, n-m+1)-  -- TODO Type should be generalized.--(...) :: Data Index -> Data Index -> Vector (Data Index)-(...) = enumFromTo--map :: (a -> b) -> Vector a -> Vector b-map _ Empty = Empty-map f (Indexed l ixf cont) = Indexed l (f . ixf) $ map f cont---- | Zipping a single-segment vector-zip' :: Vector a -> Vector b -> Vector (a,b)-zip' Empty _ = Empty-zip' _ Empty = Empty-zip' (Indexed l1 ixf1 Empty) (Indexed l2 ixf2 Empty) =-    indexed (min l1 l2) (ixf1 &&& ixf2)--zip :: (Syntactic a, Syntactic b) => Vector a -> Vector b -> Vector (a,b)-zip vec1 vec2 = zip' (mergeSegments vec1) (mergeSegments vec2)--unzip :: Vector (a,b) -> (Vector a, Vector b)-unzip Empty = (Empty, Empty)-unzip (Indexed l ixf cont) =-    (Indexed l (fst.ixf) cont1, Indexed l (snd.ixf) cont2)-  where-    (cont1,cont2) = unzip cont--zipWith :: (Syntactic a, Syntactic b) =>-    (a -> b -> c) -> Vector a -> Vector b -> Vector c-zipWith f aVec bVec = map (uncurry f) $ zip aVec bVec---- | Corresponds to the standard 'foldl'.-fold :: Syntactic a => (a -> b -> a) -> a -> Vector b -> a-fold _ x Empty = x-fold f x (Indexed l ixf cont) =-    fold f (forLoop l x $ \ix s -> f s (ixf ix)) cont---- | Corresponds to the standard 'foldl1'.-fold1 :: Type a => (Data a -> Data a -> Data a) -> Vector (Data a) -> Data a-fold1 f a = fold f (head a) (tail a)--sum :: Numeric a => Vector (Data a) -> Data a-sum = fold (+) 0--maximum :: Ord a => Vector (Data a) -> Data a-maximum = fold1 max--minimum :: Ord a => Vector (Data a) -> Data a-minimum = fold1 min---- | Scalar product of two vectors-scalarProd :: Numeric a => Vector (Data a) -> Vector (Data a) -> Data a-scalarProd a b = sum (zipWith (*) a b)---- * Wrapping for vectors--instance (Type a) => Wrap (Vector (Data a)) (Data [a]) where-    wrap v = freezeVector v+import Feldspar  -- For Haddock+import Feldspar.Vector.Internal hiding (freezeVector) -instance (Wrap t u, Type a, TL.Nat s) => Wrap (DVector a -> t) (Data' s [a] -> u) where-    wrap f = \(Data' d) -> wrap $ f $ unfreezeVector' s' d where-        s' = fromInteger $ toInteger $ TL.toInt (undefined :: s)
+ Feldspar/Vector/Internal.hs view
@@ -0,0 +1,345 @@+--+-- Copyright (c) 2009-2011, 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 #-}++module Feldspar.Vector.Internal where++++import qualified Prelude+import Control.Arrow ((&&&))+import qualified Data.TypeLevel as TL+import Test.QuickCheck++import QuickAnnotate++import Language.Syntactic++import Feldspar.Range (rangeSubSat)+import Feldspar hiding (sugar,desugar,resugar)+import Feldspar.Wrap++++--------------------------------------------------------------------------------+-- * Types+--------------------------------------------------------------------------------++-- | Symbolic vector+data Vector a+    = Empty+    | Indexed+        { segmentLength :: Data Length+        , segmentIndex  :: Data Index -> a+        , continuation  :: Vector a+        }++type instance Elem      (Vector a) = a+type instance CollIndex (Vector a) = Data Index+type instance CollSize  (Vector a) = Data Length++-- | Non-nested vector+type DVector a = Vector (Data a)+{-# DEPRECATED DVector "Please use `Vector1` instead." #-}++-- | Non-nested vector+type Vector1 a = Vector (Data a)++-- | Two-level nested vector+type Vector2 a = Vector (Vector (Data a))++instance Syntax a => Syntactic (Vector a) FeldDomainAll+  where+    type Internal (Vector a) = [Internal a]+    desugar = desugar . freezeVector . map resugar+    sugar   = map resugar . thawVector . sugar++instance Syntax a => Syntax (Vector a)++instance (Syntax a, Show (Internal a)) => Show (Vector a)+  where+    show = show . eval++++--------------------------------------------------------------------------------+-- * Construction/conversion+--------------------------------------------------------------------------------++indexed :: Data Length -> (Data Index -> a) -> Vector a+indexed 0 _      = Empty+indexed l idxFun = Indexed l idxFun Empty++-- | Breaks up a segmented vector into a list of single-segment vectors.+segments :: Vector a -> [Vector a]+segments Empty                = []+segments (Indexed l ixf cont) = Indexed l ixf Empty : segments cont+  -- Note: Important to use `Indexed` instead of `indexed` since we need to+  --       guarantee that each vector has a single segment.++length :: Vector a -> Data Length+length Empty = 0+length vec   = Prelude.foldr (+) 0 $ Prelude.map segmentLength $ segments vec++-- | Converts a segmented vector to a vector with a single segment.+mergeSegments :: Syntax a => Vector a -> Vector a+mergeSegments vec = Indexed (length vec) (ixFun (segments vec)) Empty+    -- Note: Important to use `Indexed` instead of `indexed` since we need to+    --       guarantee that the result has a single segment.+  where+    ixFun [] = \i -> err "indexing in empty vector"+    ixFun (Indexed l ixf _ : vs) = case vs of+      [] -> ixf+      _  -> \i -> (i<l) ? (ixf i, ixFun vs (i-l))++-- | Converts a non-nested vector to a core vector.+freezeVector :: Type a => Vector (Data a) -> Data [a]+freezeVector vec = help True vec+  where+    help _   Empty                 = value []+    help opt (Indexed l ixf cont)  = parallel l ixf `append` help False cont++-- | Converts a non-nested core array to a vector.+thawVector :: Type a => Data [a] -> Vector (Data a)+thawVector arr = indexed (getLength arr) (getIx arr)++thawVector' :: Type a => Length -> Data [a] -> Vector (Data a)+thawVector' len arr = thawVector $ setLength (value len) arr++unfreezeVector :: Type a => Data [a] -> Vector (Data a)+unfreezeVector = thawVector+{-# DEPRECATED unfreezeVector "Please use `thawVector` instead." #-}++unfreezeVector' :: Type a => Length -> Data [a] -> Vector (Data a)+unfreezeVector' = thawVector'+{-# DEPRECATED unfreezeVector' "Please use `thawVector'` instead." #-}++++--------------------------------------------------------------------------------+-- * Operations+--------------------------------------------------------------------------------++instance Syntax a => Indexed (Vector a)+  where+    (!) = segmentIndex . mergeSegments++instance Syntax a => Sized (Vector a)+  where+    collSize    = length+    setCollSize = newLen++instance CollMap (Vector a) (Vector a)+  where+    collMap = map++-- | Change the length of the vector to the supplied value. If the supplied+-- length is greater than the old length, the new elements will have undefined+-- value. The resulting vector has only one segment.+newLen :: Syntax a => Data Length -> Vector a -> Vector a+newLen l vec = (mergeSegments vec) {segmentLength = l}++(++) :: Vector a -> Vector a -> Vector a+Empty              ++ v     = v+v                  ++ Empty = v+Indexed l ixf cont ++ v     = Indexed l ixf (cont ++ v)++infixr 5 ++++take :: Data Length -> Vector a -> Vector a+take _ Empty                = Empty+take n (Indexed l ixf cont) = indexed nHead ixf ++ take nCont cont+  where+    nHead = min l n+    nCont = sizeProp (uncurry rangeSubSat) (n,l) $ n - min l n++drop :: Data Length -> Vector a -> Vector a+drop _ Empty = Empty+drop n (Indexed l ixf cont) = indexed nHead (ixf . (+n)) ++ drop nCont cont+  where+    nHead = sizeProp (uncurry rangeSubSat) (l,n) $ l - min l n+    nCont = sizeProp (uncurry rangeSubSat) (n,l) $ n - min l n++splitAt :: Data Index -> Vector a -> (Vector a, Vector a)+splitAt n vec = (take n vec, drop n vec)++head :: Syntax a => Vector a -> a+head = (!0)++last :: Syntax a => Vector a -> a+last vec = vec ! (length vec - 1)++tail :: Vector a -> Vector a+tail = drop 1++init :: Vector a -> Vector a+init vec = take (length vec - 1) vec++tails :: Vector a -> Vector (Vector a)+tails vec = indexed (length vec + 1) (\n -> drop n vec)++inits :: Vector a -> Vector (Vector a)+inits vec = indexed (length vec + 1) (\n -> take n vec)++inits1 :: Vector a -> Vector (Vector a)+inits1 = tail . inits++-- | Permute a single-segment vector+permute' :: (Data Length -> Data Index -> Data Index) -> (Vector a -> Vector a)+permute' _    Empty                 = Empty+permute' perm (Indexed l ixf Empty) = indexed l (ixf . perm l)++-- | Permute a vector+permute :: Syntax a =>+    (Data Length -> Data Index -> Data Index) -> (Vector a -> Vector a)+permute perm = permute' perm . mergeSegments++reverse :: Syntax a => Vector a -> Vector a+reverse = permute $ \l i -> l-1-i+  -- TODO Can be optimized (reversing each segment separately, and then+  --      reversing the segment order)++rotateVecL :: Syntax a => Data Index -> Vector a -> Vector a+rotateVecL ix = permute $ \l i -> (i + ix) `rem` l++rotateVecR :: Syntax a => Data Index -> Vector a -> Vector a+rotateVecR ix = reverse . rotateVecL ix . reverse++replicate :: Data Length -> a -> Vector a+replicate n a = Indexed n (const a) Empty++-- | @enumFromTo m n@: Enumerate the indexes from @m@ to @n@+--+-- In order to enumerate a different type, use 'i2n', e.g:+--+-- > map i2n (10...20) :: Vector1 Word8+enumFromTo :: Data Index -> Data Index -> Vector (Data Index)+enumFromTo 1 n = indexed n (+1)+enumFromTo m n = indexed l (+m)+  where+    l = (n<m) ? (0, n-m+1)+  -- TODO The first case avoids the comparison when `m` is 1. However, it+  --      cover the case when `m` is a complicated expression that is later+  --      optimized to the literal 1. The same holds for other such+  --      optimizations in this module.+  --+  --      Perhaps we need a language construct that lets the user supply a+  --      custom optimization rule (similar to `sizeProp`)? `sizeProp` could+  --      probably be expressed in terms of this more general construct.++-- | @enumFrom m@: Enumerate the indexes from @m@ to 'maxBound'+enumFrom :: Data Index -> Vector (Data Index)+enumFrom = flip enumFromTo (value maxBound)++-- | See 'enumFromTo'+(...) :: Data Index -> Data Index -> Vector (Data Index)+(...) = enumFromTo++map :: (a -> b) -> Vector a -> Vector b+map _ Empty = Empty+map f (Indexed l ixf cont) = Indexed l (f . ixf) $ map f cont++-- | Zipping a single-segment vector+zip1 :: Vector a -> Vector b -> Vector (a,b)+zip1 Empty _ = Empty+zip1 _ Empty = Empty+zip1 (Indexed l1 ixf1 Empty) (Indexed l2 ixf2 Empty) =+    indexed (min l1 l2) (ixf1 &&& ixf2)++zip :: (Syntax a, Syntax b) => Vector a -> Vector b -> Vector (a,b)+zip vec1 vec2 = zip1 (mergeSegments vec1) (mergeSegments vec2)++unzip :: Vector (a,b) -> (Vector a, Vector b)+unzip Empty = (Empty, Empty)+unzip (Indexed l ixf cont) =+    (Indexed l (fst.ixf) cont1, Indexed l (snd.ixf) cont2)+  where+    (cont1,cont2) = unzip cont++zipWith :: (Syntax a, Syntax b) =>+    (a -> b -> c) -> Vector a -> Vector b -> Vector c+zipWith f aVec bVec = map (uncurry f) $ zip aVec bVec++-- | Corresponds to the standard 'foldl'.+fold :: (Syntax a) => (a -> b -> a) -> a -> Vector b -> a+fold _ x Empty = x+fold f x (Indexed l ixf cont) =+    fold f (forLoop l x $ \ix s -> f s (ixf ix)) cont++-- | Corresponds to the standard 'foldl1'.+fold1 :: Syntax a => (a -> a -> a) -> Vector a -> a+fold1 f a = fold f (head a) (tail a)++sum :: (Syntax a, Num a) => Vector a -> a+sum = fold (+) 0++maximum :: Ord a => Vector (Data a) -> Data a+maximum = fold1 max++minimum :: Ord a => Vector (Data a) -> Data a+minimum = fold1 min++-- | Scalar product of two vectors+scalarProd :: (Syntax a, Num a) => Vector a -> Vector a -> a+scalarProd a b = sum (zipWith (*) a b)++++--------------------------------------------------------------------------------+-- Misc.+--------------------------------------------------------------------------------++tVec :: Patch a a -> Patch (Vector a) (Vector a)+tVec _ = id++tVec1 :: Patch a a -> Patch (Vector (Data a)) (Vector (Data a))+tVec1 _ = id++tVec2 :: Patch a a -> Patch (Vector (Vector (Data a))) (Vector (Vector (Data a)))+tVec2 _ = id++instance (Arbitrary (Internal a), Syntax a) => Arbitrary (Vector a)+  where+    arbitrary = fmap value arbitrary++instance (Type a) => Wrap (Vector (Data a)) (Data [a]) where+    wrap v = freezeVector v++instance (Wrap t u, Type a, TL.Nat s) => Wrap (DVector a -> t) (Data' s [a] -> u) where+    wrap f = \(Data' d) -> wrap $ f $ thawVector $ setLength s' d where+        s' = fromInteger $ toInteger $ TL.toInt (undefined :: s)++instance Annotatable a => Annotatable (Vector a)+  where+    annotate info Empty = Empty+    annotate info (Indexed len ixf cont) = Indexed+        (annotate (info Prelude.++ " (vector length)") len)+        (annotate (info Prelude.++ " (vector element)") . ixf)+        (annotate info cont)+
+ Feldspar/Wrap.hs view
@@ -0,0 +1,70 @@+--+-- Copyright (c) 2009-2011, 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 "Data.TypeLevel.Num.Aliases" is re-exported because+-- wrappers use type level numbers frequently+module Feldspar.Wrap ( Wrap(..), Data'(..), module Data.TypeLevel.Num.Aliases, D0, D1, D2, D3, D4, D5, D6, D7, D8, D9) where+++import Feldspar.Core.Constructs+import Feldspar.Core.Types++import Language.Syntactic++import Data.TypeLevel.Num.Aliases+import Data.TypeLevel.Num.Reps (D0, D1, D2, D3, D4, D5, D6, D7, D8, D9 )+++-- | Wrapping Feldspar functions+class Wrap t w where+    wrap :: t -> w++-- | Basic instances to handle @Data a@ input and output.+-- Other instances are located in the concerned libraries.+instance Wrap (Data a) (Data a) where+    wrap = id++instance (Wrap t u) => Wrap (Data a -> t) (Data a -> u) where+    wrap f = \x -> wrap $ f x++-- | Extended 'Data' to be used in wrappers+data Data' s a =+    Data'+    { unData'   :: Data a+    }++-- Syntactic instance for 'Data''++instance Type a => Syntactic (Data' s a) FeldDomainAll+  where+    type Internal (Data' s a) = a+    desugar = desugar . unData'+    sugar   = Data' . sugar++instance Type a => Syntax (Data' s a)+
Setup.hs view
@@ -1,3 +1,31 @@+--+-- Copyright (c) 2009-2011, ERICSSON AB+-- All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are met:+-- +--     * Redistributions of source code must retain the above copyright notice, +--       this list of conditions and the following disclaimer.+--     * Redistributions in binary form must reproduce the above copyright+--       notice, this list of conditions and the following disclaimer in the+--       documentation and/or other materials provided with the distribution.+--     * Neither the name of the ERICSSON AB nor the names of its contributors+--       may be used to endorse or promote products derived from this software+--       without specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+--+ import Distribution.Simple  main = defaultMain
feldspar-language.cabal view
@@ -1,5 +1,5 @@ name:           feldspar-language-version:        0.4.0.2+version:        0.5.0.1 synopsis:       A functional embedded language for DSP and parallelism description:    Feldspar (Functional Embedded Language for DSP and PARallelism)                 is an embedded DSL for describing digital signal processing@@ -15,60 +15,113 @@ homepage:       http://feldspar.inf.elte.hu/feldspar/ build-type:     Simple cabal-version:  >= 1.6-tested-with:    GHC==6.12.*, GHC==7.0.2+tested-with:    GHC==7.0  extra-source-files:-  Examples/Tutorial/*.hs,   Examples/Simple/*.hs,   Examples/Effects/*.hs,   Examples/Math/*.hs+  CEFP/cefpNotes.hs  library   exposed-modules:     Feldspar.Prelude-    Feldspar.DSL.Expression-    Feldspar.DSL.Lambda-    Feldspar.DSL.Sharing-    Feldspar.DSL.Val-    Feldspar.DSL.Network-    Feldspar.Set+    Feldspar.Lattice     Feldspar.Range     Feldspar.Core.Types-    Feldspar.Core.Representation+    Feldspar.Core.Interpretation+    Feldspar.Core.Constructs.Array+    Feldspar.Core.Constructs.Binding+    Feldspar.Core.Constructs.Bits+    Feldspar.Core.Constructs.Complex+    Feldspar.Core.Constructs.Condition+    Feldspar.Core.Constructs.ConditionM+    Feldspar.Core.Constructs.Conversion+    Feldspar.Core.Constructs.Eq+    Feldspar.Core.Constructs.Error+    Feldspar.Core.Constructs.Floating+    Feldspar.Core.Constructs.Fractional+    Feldspar.Core.Constructs.Integral+    Feldspar.Core.Constructs.Literal+    Feldspar.Core.Constructs.Logic+    Feldspar.Core.Constructs.Loop+    Feldspar.Core.Constructs.Mutable+    Feldspar.Core.Constructs.MutableArray+    Feldspar.Core.Constructs.MutableReference+    Feldspar.Core.Constructs.MutableToPure+    Feldspar.Core.Constructs.Par+    Feldspar.Core.Constructs.Num+    Feldspar.Core.Constructs.Ord+    Feldspar.Core.Constructs.SizeProp+    Feldspar.Core.Constructs.SourceInfo+    Feldspar.Core.Constructs.Trace+    Feldspar.Core.Constructs.Tuple+    Feldspar.Core.Constructs.FFI+    Feldspar.Core.Constructs.Save     Feldspar.Core.Constructs-    Feldspar.Core.Functions.Logic-    Feldspar.Core.Functions.Eq-    Feldspar.Core.Functions.Ord-    Feldspar.Core.Functions.Num-    Feldspar.Core.Functions.Bits-    Feldspar.Core.Functions.Integral-    Feldspar.Core.Functions.Fractional-    Feldspar.Core.Functions.Floating-    Feldspar.Core.Functions.Complex-    Feldspar.Core.Functions.Tuple-    Feldspar.Core.Functions.Array-    Feldspar.Core.Functions.Conversion-    Feldspar.Core.Functions.Trace-    Feldspar.Core.Functions-    Feldspar.Core.Wrap+    Feldspar.Core.Frontend.Array+    Feldspar.Core.Frontend.Binding+    Feldspar.Core.Frontend.Bits+    Feldspar.Core.Frontend.Complex+    Feldspar.Core.Frontend.Condition+    Feldspar.Core.Frontend.ConditionM+    Feldspar.Core.Frontend.Conversion+    Feldspar.Core.Frontend.Eq+    Feldspar.Core.Frontend.Error+    Feldspar.Core.Frontend.Floating+    Feldspar.Core.Frontend.Fractional+    Feldspar.Core.Frontend.Integral+    Feldspar.Core.Frontend.Literal+    Feldspar.Core.Frontend.Logic+    Feldspar.Core.Frontend.Loop+    Feldspar.Core.Frontend.Mutable+    Feldspar.Core.Frontend.MutableArray+    Feldspar.Core.Frontend.MutableReference+    Feldspar.Core.Frontend.MutableToPure+    Feldspar.Core.Frontend.Par+    Feldspar.Core.Frontend.Num+    Feldspar.Core.Frontend.Ord+    Feldspar.Core.Frontend.SizeProp+    Feldspar.Core.Frontend.SourceInfo+    Feldspar.Core.Frontend.Trace+    Feldspar.Core.Frontend.Tuple+    Feldspar.Core.Frontend.FFI+    Feldspar.Core.Frontend.Save+    Feldspar.Core.Frontend+    Feldspar.Core.Collection     Feldspar.Core-    Feldspar.Vector+    Feldspar.BitVector+    Feldspar.FixedPoint     Feldspar.Matrix+    Feldspar.Option+    Feldspar.Repa     Feldspar.Stream-    Feldspar.FixedPoint+    Feldspar.Vector.Internal+    Feldspar.Vector+    Feldspar.Wrap+    Feldspar.Par     Feldspar    build-depends:     array,     base >= 4 && < 4.4,     containers,+    data-hash == 0.1.*,+    data-lens == 2.0.*,+    monad-par,     mtl,     QuickCheck >= 2.4 && < 3,+    patch-combinators == 0.1.*,     random,+    syntactic == 0.8.*,     tagged == 0.2.*,-    type-level >= 0.2.4+    tuple == 0.2.*,+    type-level >= 0.2.4,+    monad-par >= 0.1 && < 0.2,+    QuickAnnotate    extensions:+    DeriveDataTypeable     EmptyDataDecls     FlexibleInstances     FlexibleContexts@@ -83,5 +136,7 @@     TypeFamilies     TypeOperators     TypeSynonymInstances-    UndecidableInstances-    DeriveDataTypeable+    ViewPatterns++  ghc-options: -fcontext-stack=100+