packages feed

feldspar-language 0.5.0.1 → 0.6.0.2

raw patch · 186 files changed

+12991/−12490 lines, 186 filesdep +bytestringdep +feldspar-languagedep +test-frameworkdep ~QuickAnnotatedep ~QuickCheckdep ~arraynew-uploader

Dependencies added: bytestring, feldspar-language, test-framework, test-framework-golden, test-framework-quickcheck2, test-framework-th

Dependency ranges changed: QuickAnnotate, QuickCheck, array, base, containers, data-hash, data-lens, monad-par, mtl, random, syntactic, tagged, type-level

Files

− CEFP/cefpNotes.hs 
@@ -1,210 +0,0 @@-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 
@@ -1,24 +0,0 @@-module Examples.Effects.Overdrive where--import qualified Prelude-import Feldspar-import Feldspar.Wrap-import Feldspar.Vector-import Feldspar.Compiler---- | Generic (not compilable) overdrive function-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)-      where-        elseBranch = (?) (elem < - bound) (-bound,elem)---- | Wrapper to fix the type and size of the vectors in overdrive.-overdriveInstance :: Data [Float] -> Data Float -> Data Float -> Data [Float]-overdriveInstance x mul bound =-    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 :: Vector1 Float -> Data Float -> Data Float -> Vector1 Float)
− Examples/Effects/ShiftByOneOctave.hs 
@@ -1,26 +0,0 @@-module Examples.Effects.ShiftByOneOctave where--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 :: (Fraction a) => Vector1 a -> Vector1 a-shiftByOneOctave inp = half ++ half-    where-        half = everySecond $ map avg $ zip inp $ tail inp-        everySecond xs = indexed (length xs `div` 2) $ \idx -> xs ! (2*idx)-        avg (x,y) = (x + y) / 2---- | Wrapper to fix the type and size of the vectors in shiftByOneOctave.-shiftByOneOctaveInstance :: Data [Float] -> Data [Float]-shiftByOneOctaveInstance input = desugar $ shiftByOneOctave input'-    where-        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 :: Vector1 Float -> Vector1 Float)
− Examples/Math/Convolution.hs 
@@ -1,23 +0,0 @@-module Examples.Math.Convolution where--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) => 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 = desugar $ convolution kernel' input'-    where-        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 :: Vector1 Float -> Vector1 Float -> Vector1 Float)
− Examples/Math/Fft.hs 
@@ -1,125 +0,0 @@-module Examples.Math.Fft where--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 = desugar . fft . thawVector' 256---- | Wrapper to define the size of vectors in 'fft'-fft_wrapped ::Data' D256 [Complex Float] ->  Data [Complex Float]-fft_wrapped = wrap fft---- | Wrapper to define the size of vectors in 'ifft'-ifftInstance :: Data [Complex Float] -> Data [Complex Float]-ifftInstance = desugar . ifft . thawVector' 256---- | Wrapper to define the size of vectors in 'ifft'-ifft_wrapped ::Data' D256 [Complex Float] ->  Data [Complex Float]-ifft_wrapped = wrap ifft----- =================== INTERFACE ==================================--- | Radix-2 Decimation-In-Frequeny Fast Fourier Transformation of the given complex vector---   The given vector must be power-of-two sized, (for example 2, 4, 8, 16, 32, etc.)-fft :: 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 :: Vector1 (Complex Float) -> Vector1 (Complex Float)-ifft v = bitRev (loglen-1) $ ifftCore (loglen-1) v-    where loglen = f2i $ logBase 2 $ i2f $ length v--- ================================================================------- | fftCore function uses 2^(n+1) input vector.---   Output from the last stage needs to be bit reversed using bitRev function (if required)-fftCore ::  Data Index ->  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-    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 ->  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-    ixf' i = condition (testBit i k)   (twid * (b-a))   (a+b)-      where-        a = ixf i-        b = ixf (i `xor` k2)-        twid = cis (pi*(i2f (lsbs k i)) / i2f k2)----- | bitRev function transforms the given vector to bitreversal order---   parameter n is the size of the input vector-bitRev :: Type a => Data Index -> Vector (Data a) -> Vector (Data a)-bitRev n = pipe riffle (1...n)----- | Helper functions for fftCore and ifftCore and bitRev-pipe :: (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)--lsbs k i = i .&. oneBits k--par m n f = mat2Vec m n . map f . vec2Mat m n---- k at least 1-rotBit :: Data Index -> Data Index -> Data Index-rotBit 0 _ = P.error "k should be at least 1"-rotBit k i = lefts .|. rights-  where-    ir = i .>>. 1-    rights = ir .&. (oneBits k)-    lefts  = (((ir .>>. k) .<<. 1) .|. (i .&. 1)) .<<. k--riffle k (Indexed l ixf Empty) = indexed l (ixf.rotBit k)--vec2Mat :: Data Index -> Data Index -> Vector (Data a) -> Matrix a-vec2Mat m n (Indexed l ixf Empty) = indexedMat (1 .<<. m) (1 .<<. n) ixf'-  where-    ixf' i j = ixf $ (i .<<. n) `xor` j--mat2Vec :: Type a => Data Index -> Data Index -> Matrix a -> Vector (Data a)-mat2Vec m n matr = Indexed (1 .<<. m .<<. n) ixf Empty-  where-    ixf i = matr ! y ! x-      where-        y = i .>>. n-        x = i .&. (oneBits n)------ Ad-hoc function to generate a power-of-two sequence in order to test fft and ifft-pow2Seq :: Data WordN -> Vector1 (Complex Float)-pow2Seq n = indexed (2 ^ n) (\i ->complex (i2f i) 0 )---
− Examples/Simple/Basics.hs 
@@ -1,44 +0,0 @@-module Examples.Simple.Basics where--import qualified Prelude-import Feldspar-import Feldspar.Vector-import Feldspar.Compiler---- Identity function for 32 bit integers.-example1 :: Data Int32 -> Data Int32-example1 = id---- Constant function-example2 :: Data Int32-example2 = 2---- A constant core vector-example3 :: Data [Int32]-example3 = value [42,1,2,3]---- Examples showing some of the integer and boolean operations:--example4 :: Data Int32 -> Data Int32-example4 x = negate x--example5 :: Data Int32 -> Data Int32 -> Data Int32-example5 x y = x + y--example6 :: Data Int32 -> Data Int32 -> Data Bool-example6 x y = x == y--example7 :: Data Bool-example7 = 2 /= (2 :: Data Int32) -- Type of numeric literals sometimes have to be written explicitly.--example8 :: Data Bool -> Data Bool-example8 b = not b---- Examples on using conditionals:--example9 :: Data Int32 -> Data Int32-example9 a = condition (a<5) (3*(a+a)) (30*(a+20))--example10 :: Data Int32 -> Data Int32-example10 a = condition (a<5) (3*(a+a)) (30*(a+a))-
− Examples/Simple/BitVectors.hs 
@@ -1,29 +0,0 @@-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 
@@ -1,37 +0,0 @@-module Examples.Simple.Complex where--import qualified Prelude-import Feldspar-import Feldspar.Wrap-import Feldspar.Vector-import Feldspar.Compiler---- | Creation of complex values, addition and conjugation.-complex1 :: Data (Complex Float)-complex1 = conjugate $ value (3 :+ 4) + value (0 :+ 9)---- | Constant vector containing complex values.-complex2 :: Data [Complex Float]-complex2 = 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)-    , (-1) :+ 0, 3 :+ (-3), 5 :+ 55-    ]---- | Sum of a complex vector.-complex3 :: Data' D256 [Complex Float] -> Data (Complex Float)-complex3 = wrap (sum :: Vector1 (Complex Float) -> Data (Complex Float))---- | Generic (not compilable) pairwise multiplication of vectors.-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 :: 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 
@@ -1,113 +0,0 @@-module Examples.Simple.Fixedpoint where--import Prelude ()-import qualified Prelude as P-import Feldspar-import Feldspar.FixedPoint-import Feldspar.Compiler-import Feldspar.Vector---- | Generic (not compilable) adder-fpex1 :: (Num a) => a -> a -> a-fpex1 x y = x + y---- | Wrapper for 'fpex1' using fixed-point numbers--- (with type Int32, input exponents are (-2) and (-3),---                     while the output exponent is (-4))-fpex1Fix32 :: Data Int32 -> Data Int32 -> Data Int32-fpex1Fix32 x y = freezeFix' (-2) $ fpex1 ((unfreezeFix' (-3) x))-                                        ((unfreezeFix' (-4) y))---- | Wrapper for 'fpex1' using floating-point numbers-fpex1Float :: Data Float -> Data Float -> Data Float-fpex1Float x y = fpex1 x y---- | Generic (not compilable) division-fpex2 :: (Fractional a, Fixable a) => a -> a -> a-fpex2 x y = x / y---- | Wrapper for 'fpex2' using fixed-point numbers-fpex2Fix32 :: Data Int32 -> Data Int32 -> Data Int32-fpex2Fix32 x y = freezeFix' (-4) $ fpex2 ((unfreezeFix' (-8) x))-                                        ((unfreezeFix' (-4) y))---- | Wrapper for 'fpex3' using floating-point numbers-fpex2Float :: Data Float -> Data Float -> Data Float-fpex2Float x y = fpex2 x y---- | Generic (not compilable) function adding 0.25 to the input-fpex3 :: (Num a,Fractional a,Fixable a) => a -> a-fpex3 x = x + (fix (-2) 0.25)---- | Wrapper for 'fpex3' using fixed-point numbers (with type Int32)-fpex3Fix32 :: Data Int32 -> Data Int32-fpex3Fix32 x = freezeFix' (-4) $ fpex3 $ unfreezeFix' (-2) x---- | Wrapper for 'fpex3' using floating-point numbers-fpex3Float :: Data Float -> Data Float-fpex3Float x = fpex3 x---- | Generic (not compilable) function increasing each element of the input vector-fpex4 :: (Num a) =>-         a -> Vector a -> Vector a-fpex4 x = map (x+)---- | Wrapper for 'fpex4' using fixed-point numbers (with type Int32)-fpex4Fix32 :: Data Int32 -> Vector1 Int32 -> Vector1 Int32-fpex4Fix32 x xs = map (freezeFix' (-4)) $ fpex4 x' xs'-   where-      xs' :: Vector (Fix Int32)-      xs' = map (unfreezeFix' (-6)) xs-      x'  :: Fix Int32-      x'  = unfreezeFix' (-8) x---- | Wrapper for 'fpex4' using floating-point numbers-fpex4Float :: Data Float -> Data [Float] -> Data [Float]-fpex4Float x xs = desugar $ fpex4 x xs'-   where-      xs' = thawVector' 256 xs----- | Generic (not compilable) average function-fpex5 :: (Num a,Fractional a) => a -> a -> a-fpex5 x y = (x + y) / 2---- | Wrapper for 'fpex5' using fixed-point numbers (with type Int32)-fpex5Fix32 :: Data Int32 -> Data Int32 -> Data Int32-fpex5Fix32 x y = freezeFix' (-5)  $ fpex5 x' y'-  where-    x' = unfreezeFix' (-4) x-    y' = unfreezeFix' (-6) y---- | Wrapper for 'fpex5' using floating-point numbers-fpex5Float :: Data Float -> Data Float -> Data Float-fpex5Float x y = fpex5 x y---- | Generic (not compilable) function with condition-fpex6 :: (Fractional a, 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)-fpex6Fix32 :: Data Bool -> Data Int32 -> Data Int32-fpex6Fix32 cond = freezeFix' (-2) . fpex6 cond . unfreezeFix' (-3)---- | Wrapper for 'fpex6' using floating-point numbers-fpex6Float :: Data Bool -> Data Float -> Data Float-fpex6Float = fpex6---- | Generic (not compilable) scalar product function-fpScalarProd :: (Num a, 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 :: 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 :: Vector1 Float -> Vector1 Float -> Data Float-fpScalarProdFloat = fpScalarProd-
− Examples/Simple/Matrices.hs 
@@ -1,28 +0,0 @@-module Examples.Simple.Matrices where--import qualified Prelude-import Feldspar-import Feldspar.Wrap-import Feldspar.Vector-import Feldspar.Matrix-import Feldspar.Compiler---- * Examples on working with matrices.---- | Generates a parallel matrix.-matrix1 :: Matrix Index-matrix1 = indexed 2 vec-  where-    vec x = indexed 10 ((+x) . (*10))---- | Generates a parallel matrix (20x100) and transposes it.-matrix2 :: Matrix Index-matrix2 = transpose $ indexed 20 (\x -> indexed 100 ((+x) . (*10)))---- | Matrix multiplication-matMult ::  Data' (D16,D16) [[Int32]] -> Data' (D16,D16) [[Int32]] -> Data [[Int32]]-matMult = wrap ((***) :: Matrix Int32 -> Matrix Int32 -> Matrix Int32)--matMult' :: Data [[Int32]] -> Data [[Int32]] -> Data [[Int32]]-matMult' m1 m2 = freezeMatrix $ (thawMatrix' 16 16 m1) *** (thawMatrix' 16 16 m2)-
− Examples/Simple/Pairs.hs 
@@ -1,19 +0,0 @@-module Examples.Simple.Pairs where--import Prelude ()-import Feldspar-import Feldspar.Vector-import Feldspar.Compiler---- | Haskell pairs are compiled to separate variables.-pairs1 :: Data Int32 -> Data Float -> (Data Int32, Data Float)-pairs1 x y = (x,y)---- | Selector functions: getFst, getSnd.-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 = desugar $ zipWith (\a b -> desugar (a,b)) (thawVector' 256 xs) (thawVector' 256 ys)-
− Examples/Simple/Sharing.hs 
@@ -1,45 +0,0 @@-module Examples.Simple.Sharing where--import qualified Prelude-import Feldspar-import Feldspar.Wrap-import Feldspar.Vector-import Feldspar.Compiler---- | Examples on the optimization transformation 'sharing' (also called 'common subexpression elimination').--share1 :: Data Int32 -> Data Int32-share1 v = w + w where-    w = 2 * v--share2 :: Data Int32 -> Data Int32-share2 v = (2*v) + (2*v)--share3 :: Data Int32 -> Vector1 Int32-share3 v = indexed 10 $ const w where-    w = 2 * v + v--share4 :: Data Int32 -> Vector1 Int32-share4 v = indexed 10 $ const w where-    w = 2 * q + q where-     q = v + 1--share4' :: Data Int32 -> Data [Int32]-share4' = wrap share4--share5 :: Data Index -> 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 
@@ -1,35 +0,0 @@-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 
@@ -1,26 +0,0 @@-module Examples.Simple.Streams where--import Prelude ()-import Feldspar-import Feldspar.Wrap-import Feldspar.Vector-import Feldspar.Stream-import Feldspar.Compiler---- | Generic (not compilable) function to introduce usage of scan function for Streams.---   'scan f a str' produces a stream by successively applying 'f' to---   each element of the input stream 'str' and the previous element of---   the output stream.-stream1 :: (Num a, Syntax a) => Stream a -> Stream a-stream1 = scan (+) 0---- | Wrapper to turn the parameters of 'stream1' into vectors.-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 = desugar $ stream1_1 $ thawVector' 64 xs--stream1_1_wrapped:: Data' D64 [Int32] -> Data [Int32]-stream1_1_wrapped  = wrap (stream1_1 :: Vector1 Int32 -> Vector1 Int32)
− Examples/Simple/Trace.hs 
@@ -1,14 +0,0 @@-module Examples.Simple.Trace where--import qualified Prelude-import Feldspar-import Feldspar.Vector-import Feldspar.Compiler----- | Example showing the application of tracing function.----   Creating three tracing point for each loop cycle,----   tracing two inputs and result of '+' operation.--traceExample :: Data [Int32] -> Data Int32-traceExample xs = fold (\x y -> trace 3 $ trace 1 x + trace 2 y) 0 $ thawVector' 255 xs-
− Examples/Simple/Vectors.hs 
@@ -1,62 +0,0 @@-module Examples.Simple.Vectors where--import qualified Prelude-import Feldspar-import Feldspar.Wrap-import Feldspar.Vector-import Feldspar.Compiler---- * Examples on working with vectors.---- | Generates a vector: [1, 2, 3, ... , 16],--- adds 3 to every element and--- reverses the vector then--- multiplies every element by 10.-vector1 :: Vector1 Index-vector1 = map (*10) $ reverse $ map (+3) $ enumFromTo 1 16---- | The same computation, but storing each intermediate result into temporal buffers-vector1' :: Vector1 Index-vector1' = map (*10) $ force $ reverse $ force $ map (+3) $ force $ enumFromTo 1 16---- | Drops the first 3 elements of a vector-vector2 :: Vector1 Int32 -> Vector1 Int32-vector2 = drop 3---- | Wrappers to `vector2` to provide static information on the input vector size-vector2' :: Data' D10 [Int32] -> Data [Int32]-vector2' = wrap vector2--vector2'' :: Data [Int32] -> Data [Int32]-vector2'' = desugar . vector2 . thawVector' 10---- | Generates a parallel vector of size 10-vector3 :: Data Index -> Vector1 Index-vector3 a = indexed 10 ((+a) . (*10))---- | Vector summation.-vector4 :: (Numeric a, Type a) => Vector1 a -> Data a-vector4 xs = fold (+) 0 xs---- | Wrappers to provide the necessary type information-vector4' :: Vector1 Int32 -> Data Int32-vector4' = vector4--vector4'' :: Vector1 Word8 -> Data Word8-vector4'' = vector4---- | Generic function to increment vector elements-vector5 :: (Type a, Numeric a) => Vector1 a -> Vector1 a-vector5 = map (+1)---- | Wrappers to provide necessary type information and input size-vector5' :: Vector1 Int32 -> Vector1 Int32-vector5' = vector5--vector5'' :: Data' D64 [Int32] -> Data [Int32]-vector5'' = wrap (vector5 :: Vector1 Int32 -> Vector1 Int32)---- | Concatenation-vector6 :: Vector1 Int32 -> Vector1 Int32-vector6 xs = map (+1) xs ++ map (*2) xs-
− Feldspar.hs 
@@ -1,45 +0,0 @@------ 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.--module Feldspar-  ( module Feldspar.Prelude-  , module Feldspar.Core-  ) where----import qualified Prelude-  -- In order to be able to use the Feldspar module in GHCi without getting name-  -- clashes.--import Feldspar.Prelude-import Feldspar.Core-
− Feldspar/BitVector.hs 
@@ -1,374 +0,0 @@------ 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 
@@ -1,59 +0,0 @@------ 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-    (-      -- * Reexported standard modules-      Complex (..)-    , module Data.Int-    , module Data.Word--      -- * Feldspar types-    , Range (..)-    , BoundedInt-    , module Feldspar.Core.Types--    -- * Frontend-    , module Feldspar.Core.Frontend-    , module Feldspar.Core.Collection-    ) where----import Data.Complex-import Data.Int hiding (Int)-import Data.Word--import Feldspar.Lattice-import Feldspar.Range-import Feldspar.Core.Types-import Feldspar.Core.Frontend-import Feldspar.Core.Collection-
− Feldspar/Core/Collection.hs 
@@ -1,88 +0,0 @@------ 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 
@@ -1,194 +0,0 @@------ 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.Typeable--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-------------------------------------------------------------------------------------- * Domain-----------------------------------------------------------------------------------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--newtype FeldDomain a = FeldDomain (FeldSymbols a)--deriving instance (sym :<: FeldSymbols) => sym :<: FeldDomain--deriving instance WitnessCons FeldDomain-deriving instance MaybeWitnessSat TypeCtx FeldDomain--deriving instance ExprEq   FeldDomain-deriving instance Render   FeldDomain-deriving instance ToTree   FeldDomain-deriving instance Eval     FeldDomain-deriving instance EvalBind FeldDomain--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--instance AlphaEq-    FeldDomain-    FeldDomain-    (Decor Info (Lambda TypeCtx :+: (Variable TypeCtx :+: FeldDomain)))-    [(VarId, VarId)]-  where-    alphaEqSym (FeldDomain a) aArgs (FeldDomain b) bArgs =-        alphaEqSym a aArgs b bArgs--deriving instance Sharable FeldDomain--instance Optimize FeldDomain (Lambda TypeCtx :+: (Variable TypeCtx :+: FeldDomain))-  where-    optimizeFeat       (FeldDomain a) = optimizeFeat       a-    constructFeatOpt   (FeldDomain a) = constructFeatOpt   a-    constructFeatUnOpt (FeldDomain a) = constructFeatUnOpt a--type FeldDomainAll = HODomain TypeCtx FeldDomain--------------------------------------------------------------------------------------- * Front end-----------------------------------------------------------------------------------newtype Data a = Data { unData :: ASTF FeldDomainAll a }--deriving instance Typeable1 Data--instance Type a => Syntactic (Data a) FeldDomainAll-  where-    type Internal (Data a) = a-    desugar = unData-    sugar   = Data---- | 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.--instance Type a => Syntax (Data a)--instance Type a => Eq (Data a)-  where-    Data a == Data b = alphaEq (reify a) (reify b)--instance Type a => Show (Data a)-  where-    show (Data a) = render $ reify a-
− Feldspar/Core/Constructs/Array.hs 
@@ -1,252 +0,0 @@------ 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 
@@ -1,190 +0,0 @@------ 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 
@@ -1,270 +0,0 @@------ 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 
@@ -1,111 +0,0 @@------ 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 
@@ -1,77 +0,0 @@------ 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 
@@ -1,112 +0,0 @@------ 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 
@@ -1,129 +0,0 @@------ 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 
@@ -1,105 +0,0 @@------ 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 
@@ -1,90 +0,0 @@------ 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 
@@ -1,86 +0,0 @@------ 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 
@@ -1,146 +0,0 @@------ 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 
@@ -1,85 +0,0 @@------ 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 
@@ -1,210 +0,0 @@------ 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 
@@ -1,60 +0,0 @@------ 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 
@@ -1,123 +0,0 @@------ 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 
@@ -1,212 +0,0 @@------ 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 
@@ -1,170 +0,0 @@------ 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 
@@ -1,103 +0,0 @@------ 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 
@@ -1,91 +0,0 @@------ 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 
@@ -1,98 +0,0 @@------ 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 
@@ -1,218 +0,0 @@------ 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 
@@ -1,205 +0,0 @@------ 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 
@@ -1,196 +0,0 @@------ 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 
@@ -1,83 +0,0 @@------ 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 
@@ -1,93 +0,0 @@------ 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 
@@ -1,81 +0,0 @@------ 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 
@@ -1,90 +0,0 @@------ 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 
@@ -1,326 +0,0 @@------ 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 
@@ -1,270 +0,0 @@------ 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 
@@ -1,63 +0,0 @@------ 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 
@@ -1,43 +0,0 @@------ 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 
@@ -1,122 +0,0 @@------ 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 
@@ -1,75 +0,0 @@------ 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 
@@ -1,48 +0,0 @@------ 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 
@@ -1,42 +0,0 @@------ 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 
@@ -1,67 +0,0 @@------ 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 
@@ -1,77 +0,0 @@------ 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 
@@ -1,55 +0,0 @@------ 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 
@@ -1,45 +0,0 @@------ 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 
@@ -1,85 +0,0 @@------ 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 
@@ -1,62 +0,0 @@------ 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 
@@ -1,84 +0,0 @@------ 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 
@@ -1,55 +0,0 @@------ 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 
@@ -1,62 +0,0 @@------ 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 
@@ -1,51 +0,0 @@------ 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 
@@ -1,65 +0,0 @@------ 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 
@@ -1,78 +0,0 @@------ 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 
@@ -1,62 +0,0 @@------ 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 
@@ -1,57 +0,0 @@------ 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 
@@ -1,82 +0,0 @@------ 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 
@@ -1,86 +0,0 @@------ 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 
@@ -1,59 +0,0 @@------ 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 
@@ -1,60 +0,0 @@------ 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 
@@ -1,80 +0,0 @@------ 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 
@@ -1,54 +0,0 @@------ 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 
@@ -1,45 +0,0 @@------ 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 
@@ -1,264 +0,0 @@------ 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/Interpretation.hs 
@@ -1,398 +0,0 @@------ 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/Types.hs 
@@ -1,831 +0,0 @@------ 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.Typeable (Typeable, gcast)-import Data.Word-import Test.QuickCheck-import qualified Control.Monad.Par as MonadPar--import Data.Patch--import Data.Proxy--import Data.Typeable (Typeable1)--import Language.Syntactic--import Feldspar.Lattice-import Feldspar.Range--------------------------------------------------------------------------------------- * Heterogenous lists------------------------------------------------------------------------------------- | Heterogeneous list-data a :> b = a :> b-  deriving (Eq, Ord, Show)--infixr 5 :>--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)--------------------------------------------------------------------------------------- * Integers------------------------------------------------------------------------------------- | Target-dependent unsigned integers-newtype WordN = WordN Word32-  deriving-    ( Eq, Ord, Num, Enum, Ix, Real, Integral, Bits, Bounded, Typeable-    , Arbitrary )---- | Target-dependent signed integers-newtype IntN = IntN Int32-  deriving-    ( Eq, Ord, Num, Enum, Ix, Real, Integral, Bits, Bounded, Typeable-    , Arbitrary )--instance Show WordN-  where-    show (WordN a) = show a--instance Show IntN-  where-    show (IntN a) = show a---- | 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-    N8      :: BitWidth N8-    N16     :: BitWidth N16-    N32     :: BitWidth N32-    N64     :: BitWidth N64-    NNative :: BitWidth NNative--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-    U :: Signedness U-    S :: Signedness S--signedness :: Signedness s -> String-signedness U = "Word"-signedness S = "Int"---- | 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--------------------------------------------------------------------------------------- * Arrays------------------------------------------------------------------------------------- | Array whose length is represented by an @n@-bit word-data TargetArr n a = TargetArr (GenericInt U n) [a]-------------------------------------------------------------------------------------- * Monadic Types------------------------------------------------------------------------------------- | This class is used to allow constructs to be abstract in the monad-class MonadType m-  where-    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.--------------------------------------------------------------------------------------- * Mutable data------------------------------------------------------------------------------------- TODO Make newtypes?---- | Monad for manipulation of mutable data-type Mut = IO---- | Mutable references-instance Show (IORef a)-  where-    show _ = "IORef"---- | Mutable arrays-type MArr a = IOArray Index a--instance Show (MArr a)-  where-    show _ = "MArr"--instance MonadType Mut-  where-    voidTypeRep = MutType UnitType-------------------------------------------------------------------------------------- * 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-    show _ = "IVar"--instance Eq (IV a)-  where-    a == b = False--instance MonadType Par-  where-    voidTypeRep = ParType UnitType------------------------------------------------------------------------------------- * Type representation------------------------------------------------------------------------------------- | Representation of supported types-data TypeRep a-  where-    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 Show (TypeRep a)-  where-    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]--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-    TypeEq :: TypeEq a a--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-    -- | 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)-  where-    typeRep             = ComplexType typeRep-    sizeOf _            = AnySize-    toTarget n (r :+ i) = error "TODO" -- toTarget n r :+ toTarget n i--instance Type a => Type [a]-  where-    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-    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-    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-    typeRep = Tup4Type typeRep typeRep typeRep typeRep--    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-    typeRep = Tup5Type typeRep typeRep typeRep typeRep typeRep--    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-    typeRep = Tup6Type typeRep typeRep typeRep typeRep typeRep typeRep--    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-    typeRep = Tup7Type typeRep typeRep typeRep typeRep typeRep typeRep typeRep--    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-    typeRep = RefType typeRep--    sizeOf _ = universal--    toTarget = error "toTarget: IORef"  -- TODO Requires IO--instance Type a => Type (MArr a)-  where-    typeRep = MArrType typeRep--    sizeOf _ = universal--    toTarget = error "toTarget: MArr"  -- TODO Requires IO--instance Type a => Type (IV a)-  where-    typeRep = IVarType typeRep--    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--------------------------------------------------------------------------------------- * Sized types-----------------------------------------------------------------------------------data AnySize = AnySize-    deriving (Eq, Show, Ord)--anySizeFun :: AnySize -> AnySize-anySizeFun AnySize = AnySize--anySizeFun2 :: AnySize -> AnySize -> AnySize-anySizeFun2 AnySize AnySize = AnySize--instance Num AnySize-  where-    fromInteger _ = AnySize-    abs           = anySizeFun-    signum        = anySizeFun-    (+)           = anySizeFun2-    (-)           = anySizeFun2-    (*)           = anySizeFun2--instance Lattice AnySize-  where-    empty     = AnySize-    universal = AnySize-    (\/)      = anySizeFun2-    (/\)      = anySizeFun2--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-    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/FixedPoint.hs 
@@ -1,251 +0,0 @@------ 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(..)-    , freezeFix, freezeFix', unfreezeFix, unfreezeFix'-    , (?!), fixFold-    )-where--import qualified Prelude-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 IntN-    , mantissa  :: Data a-    }-    deriving (Prelude.Eq,Prelude.Show)--instance-    ( Integral a-    , Bits a-    , Prelude.Real a-    , Size a ~ Range a-    ) => Num (Fix a)-  where-    fromInteger n = Fix 0 (Prelude.fromInteger n)-    (+) = fixAddition-    (*) = fixMultiplication-    negate = fixNegate-    abs = fixAbsolute-    signum = fixSignum--instance-    ( Integral a-    , Bits a-    , Prelude.Real a-    , Size a ~ Range a-    ) => Fractional (Fix a)-  where-    (/) = fixDiv'-    recip = fixRecip'-    fromRational = fixfromRational--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 :: (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 :: (Integral a, Bits a, Prelude.Real a) => Fix a -> Fix a-fixNegate f1@(Fix e1 m1)  = Fix e1 m-   where-     m = negate m1--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 :: (Integral a, Bits a, Prelude.Real a) => Fix a -> Fix a-fixSignum f1@(Fix e1 m1)  = Fix 0 m-   where-     m = signum m1--fixFromInteger :: (Integral a, Bits a, Prelude.Real a) =>  Integer -> Fix a-fixFromInteger i  = Fix 0 m-   where-     m = fromInteger i--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 . (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)--fixfromRational :: forall a . (Integral a, Size a ~ Range a) =>-                   Prelude.Rational -> Fix a-fixfromRational inp = Fix exponent mantissa-   where-      inpAsFloat :: Float-      inpAsFloat =  fromRational inp-      intPart :: Float-      intPart =  fromRational $ toRational $ (Prelude.floor inpAsFloat)-      intPartWidth :: IntN-      intPartWidth =  Prelude.ceiling $ Prelude.logBase 2 intPart-      fracPartWith :: IntN-      fracPartWith =  (wordLength (T :: T a)) - intPartWidth - 2-      mantissa = value $ Prelude.floor $ inpAsFloat * 2.0 Prelude.** fromRational (toRational fracPartWith)-      exponent = negate $ value fracPartWith--instance (Type a) => Syntactic (Fix a) FeldDomainAll where-  type Internal (Fix a) = (IntN, a)-  desugar = desugar . freezeFix-  sugar   = unfreezeFix . sugar--instance (Type a) => Syntax (Fix a)---- | 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)---- | 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 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' :: IntN -> Data a -> Fix a-unfreezeFix' e m = Fix (value e) m---- 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-    m :: a-    m = Prelude.max (Prelude.abs $ lowerBound r) (Prelude.abs $ upperBound r)-    mf :: Float-    mf = logBase 2 $ fromRational $ toRational m--}-{--setSignificantBits :: forall a . (Type a, 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 . (Integral a, Prelude.Real a) => T a -> IntN-wordLength x = (Prelude.ceiling $ Prelude.logBase 2 $ fromRational $ toRational (maxBound :: a)) + 1--wordLength' :: forall a . (Integral a, Prelude.Real a) => a -> IntN-wordLength' x = swl-   where-    b   :: a-    wl  :: IntN-    swl :: IntN-    b   = maxBound::a-    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 IntN -> t -> t-    getExp :: t -> Data IntN--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-    fix = const id-    getExp = const $ fromInteger $ toInteger $ Feldspar.exponent (0.0 :: Float)--data T a = T---- | Operations to split data into dynamic and static parts-class (Syntax (Dynamic t)) => Splittable t where-    type Static t-    type Dynamic t-    store       :: t -> (Static t, Dynamic t)-    retrieve    :: (Static t, Dynamic t) -> t-    patch       :: Static t -> t -> t-    common      :: t -> t -> Static t--instance (Type a) => Splittable (Data a) where-    type Static (Data a) = ()-    type Dynamic (Data a) = Data a-    store x = ((),x)-    retrieve = snd-    patch = const id-    common _ _ = ()--instance (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-    patch = fix-    common f g = max (Feldspar.FixedPoint.exponent f) (Feldspar.FixedPoint.exponent g)---- | A version of vector fold for fixed point algorithms-fixFold :: forall a b . (Splittable a) => (a -> b -> a) -> a -> Vector b -> a-fixFold fun ini vec = retrieve (static, fold fun' ini' vec)-  where-    static = fst $ store ini-    ini' = snd $ store ini-    fun' st el = snd $ store $ patch static $ retrieve (static,st) `fun` el---- | A version of branching for fixed point algorithms-infix 1 ?!-(?!) :: forall a . (Syntax a, Splittable a) => Data Bool -> (a,a) -> a-cond ?! (x,y) = retrieve (comm, cond ? (x',y'))-  where-    comm = common x y-    x' = snd $ store $ patch comm x-    y' = snd $ store $ patch comm y
− Feldspar/Lattice.hs 
@@ -1,196 +0,0 @@------ 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 
@@ -1,226 +0,0 @@------ 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--- this module assume rectangular matrices.--module Feldspar.Matrix where----import qualified Prelude as P-import Data.List (genericLength)-import qualified Data.TypeLevel as TL--import Feldspar.Prelude-import Feldspar.Core-import Feldspar.Wrap-import Feldspar.Vector.Internal----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.-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 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' = 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 = value---- | Constructing a matrix from an index function.------ @indexedMat m n ixf@:------   * @m@ is the number of rows.------   * @n@ is the number of columns.------   * @ifx@ is a function mapping indexes to elements (first argument is row---     index; second argument is column index).-indexedMat-    :: Data Length-    -> Data Length-    -> (Data Index -> Data Index -> Data a)-    -> Matrix a-indexedMat m n idx = indexed m $ \k -> indexed n $ \l -> idx k l---- | Transpose of a matrix. 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.---- | Concatenates the rows of a matrix.-flatten :: Type a => Matrix a -> Vector (Data a)-flatten matr = Indexed (m*n) ixf Empty-  where-    m = length matr-    n = (m==0) ? (0, length (head matr))--    ixf i = matr ! y ! x-      where-        y = i `div` n-        x = i `mod` n-  -- TODO Should use linear indexing---- | The diagonal vector of a square matrix. It happens to work if the number of--- rows is less than the number of columns, but not the other way around (this--- would require some overhead).-diagonal :: Type a => Matrix a -> Vector (Data a)-diagonal m = zipWith (!) m (0 ... (length m - 1))--distributeL :: (a -> b -> c) -> a -> Vector b -> Vector c-distributeL f = map . f--distributeR :: (a -> b -> c) -> Vector a -> b -> Vector c-distributeR = flip . distributeL . flip----class Mul a b-  where-    type Prod a b--    -- | General multiplication operator-    (***) :: a -> b -> Prod a b--instance Numeric a => Mul (Data a) (Data a)-  where-    type Prod (Data a) (Data a) = Data a-    (***) = (*)--instance Numeric a => Mul (Data a) (Vector1 a)-  where-    type Prod (Data a) (Vector1 a) = Vector1 a-    (***) = distributeL (***)--instance Numeric a => Mul (Vector1 a) (Data a)-  where-    type Prod (Vector1 a) (Data a) = Vector1 a-    (***) = distributeR (***)--instance Numeric a => Mul (Data a) (Matrix a)-  where-    type Prod (Data a) (Matrix a) = Matrix a-    (***) = distributeL (***)--instance Numeric a => Mul (Matrix a) (Data a)-  where-    type Prod (Matrix a) (Data a) = Matrix a-    (***) = distributeR (***)--instance Numeric a => Mul (Vector1 a) (Vector1 a)-  where-    type Prod (Vector1 a) (Vector1 a) = Data a-    (***) = scalarProd--instance Numeric a => Mul (Vector1 a) (Matrix a)-  where-    type Prod (Vector1 a) (Matrix a) = (Vector1 a)-    vec *** mat = distributeL (***) vec (transpose mat)--instance Numeric a => Mul (Matrix a) (Vector1 a)-  where-    type Prod (Matrix a) (Vector1 a) = (Vector1 a)-    (***) = distributeR (***)--instance Numeric a => Mul (Matrix a) (Matrix a)-  where-    type Prod (Matrix a) (Matrix a) = (Matrix a)-    (***) = distributeR (***)------ | Matrix multiplication-mulMat :: Numeric a => Matrix a -> Matrix a -> Matrix a-mulMat = (***)----class Syntax a => ElemWise a-  where-    type Scalar a--    -- | Operator for general element-wise multiplication-    elemWise :: (Scalar a -> Scalar a -> Scalar a) -> a -> a -> a--instance Type a => ElemWise (Data a)-  where-    type Scalar (Data a) = Data a-    elemWise = id--instance (ElemWise a, Syntax (Vector a)) => ElemWise (Vector a)-  where-    type Scalar (Vector a) = Scalar a-    elemWise = zipWith . elemWise--(.+) :: (ElemWise a, Num (Scalar a)) => a -> a -> a-(.+) = elemWise (+)--(.-) :: (ElemWise a, Num (Scalar a)) => a -> a -> a-(.-) = elemWise (-)--(.*) :: (ElemWise a, Num (Scalar a)) => a -> a -> a-(.*) = elemWise (*)---- * Wrapping for matrices--instance (Type a) => Wrap (Matrix a) (Data [[a]]) where-    wrap = freezeMatrix--instance (Wrap t u, Type a, TL.Nat row, TL.Nat col) => Wrap (Matrix a -> t) (Data' (row,col) [[a]] -> u) where-    wrap f = \(Data' d) -> wrap $ f $ thawMatrix' row' col' d where-        row' = fromInteger $ toInteger $ TL.toInt (undefined :: row)-        col' = fromInteger $ toInteger $ TL.toInt (undefined :: col)-
− Feldspar/Option.hs 
@@ -1,114 +0,0 @@------ 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 
@@ -1,94 +0,0 @@------ 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 
@@ -1,77 +0,0 @@------ 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-  ( 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 
@@ -1,1035 +0,0 @@------ 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--module Feldspar.Range where------ 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-import Data.Typeable-import System.Random -- Should maybe be exported from QuickCheck-import Test.QuickCheck hiding ((.&.))-import qualified Test.QuickCheck as QC-import Text.Printf--import Feldspar.Lattice--------------------------------------------------------------------------------------- * Definition------------------------------------------------------------------------------------- | A bounded range of values of type @a@-data Range a = Range-  { lowerBound :: a-  , upperBound :: a-  }-    deriving (Eq, Show)---- | Convenience alias for bounded integers-class    (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.---   @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 (undefined::a) = s-    | otherwise               = u---- | Shows a bound.-showBound :: BoundedInt a => a -> String-showBound a-    | a  `elem` [maxBound,minBound] = "*"-    | otherwise                     = show a---- | A textual representation of ranges.-showRange :: BoundedInt a => Range a -> String-showRange r@(Range l u)-  | isEmpty r     = "[]"-  | isSingleton r = show u-  | otherwise     = "[" ++ showBound l ++ "," ++ showBound u ++ "]"---- | Requires a monotonic function-mapMonotonic :: (a -> b) -> Range a -> Range b-mapMonotonic f (Range l u) = Range (f l) (f u)---- | Requires a monotonic function-mapMonotonic2 :: (a -> b -> c) -> Range a -> Range b -> Range c-mapMonotonic2 f (Range l1 u1) (Range l2 u2) = Range (f l1 l2) (f u1 u2)--------------------------------------------------------------------------------------- * Lattice operations-----------------------------------------------------------------------------------instance BoundedInt a => Lattice (Range a)-  where-    empty     = emptyRange-    universal = fullRange-    (\/)      = rangeUnion-    (/\)      = rangeIntersection---- | The range containing no elements-emptyRange :: BoundedInt a => Range a-emptyRange = Range maxBound minBound---- | The range containing all elements of a type-fullRange :: BoundedInt a => Range a-fullRange = Range minBound maxBound---- | Construct a range-range :: a -> a -> Range a-range = Range---- | The range containing one element-singletonRange :: a -> Range a-singletonRange a = Range a a---- | The range from @0@ to the maximum element-naturalRange :: BoundedInt a => Range a-naturalRange = Range 0 maxBound---- | The range from the smallest negative element to @-1@.---   Undefined for unsigned types-negativeRange :: 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---   @rangeSize (range minBound maxBound) :: Int@ gives a nonsense answer.-rangeSize :: BoundedInt a => Range a -> a-rangeSize (Range l u) = u-l+1---- | Checks if the range is empty-isEmpty :: BoundedInt a => Range a -> Bool-isEmpty (Range l u) = u < l---- | Checks if the range contains all values of the type-isFull :: BoundedInt a => Range a -> Bool-isFull = (==fullRange)---- | Checks is the range contains exactly one element-isSingleton :: BoundedInt a => Range a -> Bool-isSingleton (Range l u) = l==u---- | @r1 \`isSubRangeOf\` r2@ checks is all the elements in @r1@ are included---   in @r2@-isSubRangeOf :: BoundedInt a => Range a -> Range a -> Bool-isSubRangeOf r1@(Range l1 u1) r2@(Range l2 u2)-    | isEmpty r1 = True-    | isEmpty r2 = False-    | otherwise  = (l1>=l2) && (u1<=u2)---- | Checks whether a range is a sub-range of the natural numbers.-isNatural :: BoundedInt a => Range a -> Bool-isNatural = (`isSubRangeOf` naturalRange)---- | Checks whether a range is a sub-range of the negative numbers.-isNegative :: BoundedInt a => Range a -> Bool-isNegative = (`isSubRangeOf` negativeRange)---- | @a \`inRange\` r@ checks is @a@ is an element of the range @r@.-inRange :: BoundedInt a => a -> Range a -> Bool-inRange a r = singletonRange a `isSubRangeOf` r---- | A convenience function for defining range propagation. If the input---   range is empty then the result is also empty.-rangeOp :: BoundedInt a => (Range a -> Range a) -> (Range a -> Range a)-rangeOp f r = if isEmpty r then r else f r---- | See 'rangeOp'.-rangeOp2 :: BoundedInt a =>-    (Range a -> Range a -> Range a) -> (Range a -> Range a -> Range a)-rangeOp2 f r1 r2-  | isEmpty r1 = r1-  | isEmpty r2 = r2-  | otherwise  = f r1 r2---- | Union on ranges.-rangeUnion :: BoundedInt a => Range a -> Range a -> Range a-r1 `rangeUnion` r2-    | isEmpty r1 = r2-    | isEmpty r2 = r1-    | otherwise  = union r1 r2-  where-    union (Range l1 u1) (Range l2 u2) = Range (min l1 l2) (max u1 u2)---- | Intersection on ranges.-rangeIntersection :: BoundedInt a => Range a -> Range a -> Range a-rangeIntersection = rangeOp2 intersection-  where-    intersection (Range l1 u1) (Range l2 u2) = Range (max l1 l2) (min u1 u2)---- | @disjoint r1 r2@ returns true when @r1@ and @r2@ have no elements in---   common.-disjoint :: BoundedInt a => Range a -> Range a -> Bool-disjoint r1 r2 = isEmpty (r1 /\ r2)---- | @rangeGap r1 r2@ returns a range of all the elements between @r1@ and---   @r2@ including the boundary elements. If @r1@ and @r2@ have elements in---   common the result is an empty range.-rangeGap :: BoundedInt a => Range a -> Range a -> Range a-rangeGap = rangeOp2 gap-  where-    gap (Range l1 u1) (Range l2 u2)-      | u1 < l2 = range u1 l2-      | u2 < l1 = range u2 l1-    gap _ _     = emptyRange-  -- If the result is non-empty, it will include the boundary elements from the-  -- two ranges.---- | @r1 \`rangeLess\` r2:@------ Checks if all elements of @r1@ are less than all elements of @r2@.-rangeLess :: BoundedInt a => Range a -> Range a -> Bool-rangeLess r1 r2-  | isEmpty r1 || isEmpty r2 = True-rangeLess (Range _ u1) (Range l2 _) = u1 < l2---- | @r1 \`rangeLessEq\` r2:@------ Checks if all elements of @r1@ are less than or equal to all elements of--- @r2@.-rangeLessEq :: BoundedInt a => Range a -> Range a -> Bool-rangeLessEq (Range _ u1) (Range l2 _) = u1 <= l2--------------------------------------------------------------------------------------- * Propagation------------------------------------------------------------------------------------- | @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)-  where-    fromInteger = singletonRange . fromInteger-    abs         = rangeAbs-    signum      = rangeSignum-    negate      = rangeNeg-    (+)         = rangeAdd-    (*)         = rangeMul---- | Propagates range information through @abs@.-rangeAbs :: BoundedInt a => Range a -> Range a-rangeAbs = rangeOp $ \r -> case r of-    Range l u-      | isNatural  r -> r-      | r == singletonRange minBound -> r-      | minBound `inRange` r -> range minBound maxBound-      | isNegative r -> range (abs u) (abs l)-      | otherwise    -> range 0 (abs l `max` abs u)---- | Propagates range information through 'signum'.-rangeSignum :: BoundedInt a => Range a -> Range a-rangeSignum = handleSign rangeSignumUnsigned rangeSignumSigned---- | Signed case for 'rangeSignum'.-rangeSignumSigned :: BoundedInt a => Range a -> Range a-rangeSignumSigned = rangeOp sign-  where-    sign r-      | range (-1) 1 `isSubRangeOf` r = range (-1) 1-      | range (-1) 0 `isSubRangeOf` r = range (-1) 0-      | range 0 1    `isSubRangeOf` r = range 0 1-      | inRange 0 r                   = 0-      | isNatural r                   = 1-      | isNegative r                  = -1---- | Unsigned case for 'rangeSignum'.-rangeSignumUnsigned :: BoundedInt a => Range a -> Range a-rangeSignumUnsigned = rangeOp sign-    where-      sign r-          | r == singletonRange 0 = r-          | not (0 `inRange` r)   = singletonRange 1-          | otherwise             = range 0 1---- | Propagates range information through negation.-rangeNeg :: BoundedInt a => Range a -> Range a-rangeNeg = handleSign rangeNegUnsigned rangeNegSigned---- | Unsigned case for 'rangeNeg'.-rangeNegUnsigned :: BoundedInt a => Range a -> Range a-rangeNegUnsigned (Range l u)-    | l == 0 && u /= 0 = fullRange-    | otherwise        = range (-u) (-l)--- Code from Hacker's Delight---- | Signed case for 'rangeNeg'.-rangeNegSigned :: BoundedInt a => Range a -> Range a-rangeNegSigned (Range l u)-    | l == minBound && u == minBound = singletonRange minBound-    | l == minBound                  = fullRange-    | otherwise                      = range (-u) (-l)--- Code from Hacker's Delight---- | Propagates range information through addition.-rangeAdd :: BoundedInt a => Range a -> Range a -> Range a-rangeAdd = handleSign rangeAddUnsigned rangeAddSigned---- | Unsigned case for 'rangeAdd'.-rangeAddUnsigned :: BoundedInt a => Range a -> Range a -> Range a-rangeAddUnsigned (Range l1 u1) (Range l2 u2)-    | s >= l1 && t < u1 = fullRange-    | otherwise         = range s t-  where-    s = l1 + l2-    t = u1 + u2--- Code from Hacker's Delight---- | Signed case for 'rangeAdd'.-rangeAddSigned :: BoundedInt a => Range a -> Range a -> Range a-rangeAddSigned (Range l1 u1) (Range l2 u2)-    | (u .|. v) < 0 = fullRange-    | otherwise     = range s t-  where-    s = l1 + l2-    t = u1 + u2-    u = l1 .&. l2 .&. complement s .&.-        complement (u1 .&. u2 .&. complement t)-    v = ((xor l1 l2) .|. complement (xor l1 s)) .&.-        (complement u1 .&. complement u2 .&. t)--- Code from Hacker's Delight---- | Propagates range information through subtraction.-rangeSub :: BoundedInt a => Range a -> Range a -> Range a-rangeSub = handleSign rangeSubUnsigned (-)---- | Unsigned case for 'rangeSub'.-rangeSubUnsigned :: BoundedInt a => Range a -> Range a -> Range a-rangeSubUnsigned (Range l1 u1) (Range l2 u2)-    | s > l1 && t <= u1 = fullRange-    | otherwise         = range s t-  where-    s = l1 - u2-    t = u1 - l2-  -- Note: This is more accurate than the default definition using 'negate',-  --       because 'negate' always overflows for unsigned numbers.-  -- Code from Hacker's Delight---- | 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---- | Signed case for 'rangeMul'.-rangeMulSigned :: forall a . BoundedInt a => Range a -> Range a -> Range a-rangeMulSigned r1 r2-    | r1 == singletonRange 0 || r2 == singletonRange 0 = singletonRange 0-    -- The following case is important because the 'maxAbs' function doesn't-    -- work for 'minBound' on signed numbers.-    | lowerBound r1 == minBound || lowerBound r2 == minBound-        = range minBound maxBound-    | bits (maxAbs r1) + bits (maxAbs r2) <= bitSize (undefined :: a) - 1-        = range (minimum [b1,b2,b3,b4]) (maximum [b1,b2,b3,b4])-    | otherwise = range minBound maxBound-  where maxAbs (Range l u) = max (abs l) (abs u)-        b1 = lowerBound r1 * lowerBound r2-        b2 = lowerBound r1 * upperBound r2-        b3 = upperBound r1 * lowerBound r2-        b4 = upperBound r1 * upperBound r2---- | Unsigned case for 'rangeMul'.-rangeMulUnsigned :: forall a . BoundedInt a => Range a -> Range a -> Range a-rangeMulUnsigned r1 r2-    | bits (upperBound r1) + bits (upperBound r2)-      <= bitSize (undefined :: a)-        = mapMonotonic2 (*) r1 r2-    | otherwise = universal---- | Returns the position of the highest bit set to 1. Counting starts at 1.--- Beware! It doesn't terminate for negative numbers.-bits :: Bits b => b -> Int-bits b = loop b 0-    where loop 0 c = c-          loop n c = loop (n `shiftR` 1) (c+1)---- | Propagates range information through exponentiation.-rangeExp :: BoundedInt a => Range a -> Range a -> Range a-rangeExp = handleSign rangeExpUnsigned rangeExpSigned---- | Unsigned case for 'rangeExp'.-rangeExpUnsigned :: BoundedInt a => Range a -> Range a -> Range a-rangeExpUnsigned m@(Range l1 u1) e@(Range l2 u2)-    | toInteger (bits u1) * toInteger u2 > toInteger (bitSize l1) + 1 = universal-    | toInteger u1 ^ toInteger u2 > toInteger (maxBound `asTypeOf` l1) = universal-    | 0 `inRange` m && 0 `inRange` e = range 0 (max b1 b2)-    | otherwise = range b1 b2-  where b1 = (l1 ^ l2)-        b2 = (u1 ^ u2)---- | Sigend case for 'rangeExp'-rangeExpSigned :: BoundedInt a => Range a -> Range a -> Range a-rangeExpSigned m e | m == singletonRange (-1) = range (-1) 1-rangeExpSigned _ _ = universal---- | Propagates range information through '.|.'.-rangeOr :: forall a . BoundedInt a => Range a -> Range a -> Range a-rangeOr = handleSign rangeOrUnsignedAccurate (\_ _ -> universal)---- | Cheap and inaccurate range propagation for '.|.' on unsigned numbers.-rangeOrUnsignedCheap :: BoundedInt a => Range a -> Range a -> Range a-rangeOrUnsignedCheap (Range l1 u1) (Range l2 u2) =-    range (max l1 l2) (maxPlus u1 u2)--- Code from Hacker's Delight.---- | @a \`maxPlus\` b@ adds @a@ and @b@ but if the addition overflows then---   'maxBound' is returned.-maxPlus :: BoundedInt a => a -> a -> a-maxPlus b d = if sum < b then maxBound-              else sum-  where sum = b + d---- | Accurate lower bound for '.|.' on unsigned numbers.-minOrUnsigned :: BoundedInt a => a -> a -> a -> a -> a-minOrUnsigned a b c d = loop (bit (bitSize a - 1))-  where loop 0 = a .|. c-        loop m-            | complement a .&. c .&. m > 0 =-                let temp = (a .|. m) .&. negate m-                in if temp <= b-                   then temp .|. c-                   else loop (shiftR m 1)-            | a .&. complement c .&. m > 0 =-                let temp = (c .|. m) .&. negate m-                in if temp <= d-                   then a .|. temp-                   else loop (shiftR m 1)-            | otherwise = loop (shiftR m 1)--- Code from Hacker's Delight.---- | Accurate upper bound for '.|.' on unsigned numbers.-maxOrUnsigned :: BoundedInt a => a -> a -> a -> a -> a-maxOrUnsigned a b c d = loop (bit (bitSize a - 1))-  where loop 0 = b .|. d-        loop m-             | b .&. d .&. m > 0 =-                 let temp = (b - m) .|. (m - 1)-                 in if temp >= a-                    then temp .|. d-                    else let temp = (d - m) .|. (m - 1)-                         in if temp >= c-                            then b .|. temp-                            else loop (shiftR m 1)-             | otherwise = loop (shiftR m 1)--- Code from Hacker's Delight.---- | Accurate range propagation through '.|.' for unsigned types.-rangeOrUnsignedAccurate :: BoundedInt a => Range a -> Range a -> Range a-rangeOrUnsignedAccurate (Range l1 u1) (Range l2 u2) =-    range (minOrUnsigned l1 u1 l2 u2) (maxOrUnsigned l1 u1 l2 u2)--- Code from Hacker's Delight.---- | Propagating range information through '.&.'.-rangeAnd :: forall a . BoundedInt a => Range a -> Range a -> Range a-rangeAnd = handleSign rangeAndUnsignedCheap (\_ _ -> universal)---- | Cheap and inaccurate range propagation for '.&.' on unsigned numbers.-rangeAndUnsignedCheap :: BoundedInt a => Range a -> Range a -> Range a-rangeAndUnsignedCheap (Range l1 u1) (Range l2 u2) = range 0 (min u1 u2)--- Code from Hacker's Delight.---- | Propagating range information through 'xor'.-rangeXor :: forall a . BoundedInt a => Range a -> Range a -> Range a-rangeXor = handleSign rangeXorUnsigned  (\_ _ -> universal)---- | Unsigned case for 'rangeXor'.-rangeXorUnsigned :: BoundedInt a => Range a -> Range a -> Range a-rangeXorUnsigned (Range l1 u1) (Range l2 u2) = range 0 (maxPlus u1 u2)--- Code from Hacker's Delight.---- | Propagating range information through 'shiftLU'.-rangeShiftLU :: (BoundedInt a, BoundedInt b) => Range a -> Range b -> Range a-rangeShiftLU = handleSign rangeShiftLUUnsigned (\_ _ -> universal)--- TODO: improve accuracy---- | Unsigned case for 'rangeShiftLU'.-rangeShiftLUUnsigned (Range l1 u1) (Range l2 u2)-    | toInteger (bits u1) + fromIntegral u2 > toInteger (bitSize u1) = universal-rangeShiftLUUnsigned (Range l1 u1) (Range l2 u2)-    = range (shiftL l1 (fromIntegral l2)) (shiftL u1 (fromIntegral u2))---- | Propagating range information through 'shiftRU'.-rangeShiftRU :: (BoundedInt a, BoundedInt b) => Range a -> Range b -> Range a-rangeShiftRU = handleSign rangeShiftRUUnsigned (\_ _ -> universal)--- TODO: improve accuracy---- | Unsigned case for 'rangeShiftRU'.-rangeShiftRUUnsigned (Range l1 u1) (Range l2 u2)-    = range (correctShiftRU l1 u2) (correctShiftRU u1 l2)---- | This is a replacement fror Haskell's shiftR. If we carelessly use---   Haskell's variant then we will get left shifts for very large shift values.-correctShiftRU :: (Bits a, BoundedInt b) => a -> b -> a-correctShiftRU a i | i > fromIntegral (maxBound :: Int) = 0-correctShiftRU a i = shiftR a (fromIntegral i)---- | Propagates range information through 'max'.-rangeMax :: BoundedInt a => Range a -> Range a -> Range a-rangeMax r1 r2-    | isEmpty r1        = r2-    | isEmpty r2        = r1-    | r1 `rangeLess` r2 = r2-    | r2 `rangeLess` r1 = r1-    | otherwise         = mapMonotonic2 max r1 r2---- | Analogous to 'rangeMax'-rangeMin :: BoundedInt a => Range a -> Range a -> Range a-rangeMin r1 r2-    | isEmpty r1        = r2-    | isEmpty r2        = r1-    | r1 `rangeLess` r2 = r1-    | r2 `rangeLess` r1 = r2-    | otherwise         = mapMonotonic2 min r1 r2--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) &&-      minBound `inRange` d && (-1) `inRange` r = fullRange-    | d `rangeLess` r && isNatural r && isNatural d = d-    | isNatural r = range 0 (pred (upperBound r))-    | r `rangeLess` d && isNeg r && isNeg d = d-    | isNeg r = range (succ (lowerBound r)) 0-    where-      isNeg = (`isSubRangeOf` negs)-      negs  = negativeRange \/ 0-rangeMod d (Range l u) = Range (succ l) (pred u)---- | Propagates range information through 'rem'.--- Note that we assume Haskell semantics for 'rem'.-rangeRem :: BoundedInt a => Range a -> Range a -> Range a-rangeRem d r-    | isSigned (lowerBound d) &&-      minBound `inRange` d && (-1) `inRange` r = fullRange-    | d `rangeLessAbs` r && isNatural d = d-    | isNatural d = range 0 (pred (upperBound (abs r)))-    | d `absRangeLessAbs` r && isNeg d = d-    | isNeg d = range (negate (upperBound (abs r))) 0-    where-      isNeg = (`isSubRangeOf` negs)-      negs  = negativeRange \/ 0-rangeRem d r@(Range l u)-    | abs l >= abs u || l == minBound = range (succ $ negate $ abs l) (predAbs l)-    | otherwise      = range (succ $ negate $ abs u) (predAbs u)--predAbs l | l == minBound = abs (succ l)-          | otherwise     = pred (abs l)--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)---- | Unsigned case for 'rangeQuot'.-rangeQuotU :: BoundedInt a => Range a -> Range a -> Range a-rangeQuotU (Range l1 u1) (Range l2 u2) | l2 == 0 || u2 == 0 = universal-rangeQuotU (Range l1 u1) (Range l2 u2) = Range (l1 `quot` u2) (u1 `quot` l2)---- | Writing @d \`rangeLess\` abs r@ doesn't mean what you think it does because--- 'r' may contain minBound which doesn't have a positive representation.--- Instead, this function should be used.-rangeLessAbs d r-    | r == singletonRange minBound-        = lowerBound d /= minBound-    | lowerBound r == minBound-        = d `rangeLess` (abs (range (succ (lowerBound r)) (upperBound r)))-    | otherwise = d `rangeLess` (abs r)---- | Similar to 'rangeLessAbs' but replaces the expression---   @abs d \`rangeLess\` 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-----------------------------------------------------------------------------------instance (BoundedInt a, Arbitrary a) => Arbitrary (Range a)-  where-    arbitrary = do-      [bound1,bound2] <- vectorOf 2 $ oneof-                         [ arbitrary-                         , elements [minBound,-1,0,1,maxBound]]-      frequency-                [ (10, return $-                     Range (min bound1 bound2) (max bound1 bound2))-                , (1 , return $-                     Range (max bound1 bound2) (min bound1 bound2)) -- Empty-                , (1 , return $-                     Range bound1 bound1)  -- Singleton-                ]--    shrink (Range x y) =-      [ Range x' y | x' <- shrink x ] ++-      [ Range x y' | y' <- shrink y ]--instance Random Word32 where-  random g = (fromIntegral i,g')-   where (i :: Int,g') = random g-  randomR (l,u) g = (fromIntegral i,g')-    where (i :: Integer, g') = randomR (fromIntegral l,fromIntegral u) g--instance Random Int8 where-  random g = (fromIntegral i,g')-   where (i :: Int,g') = random g-  randomR (l,u) g = (fromIntegral i,g')-    where (i :: Integer, g') = randomR (fromIntegral l,fromIntegral u) g--instance Random Word8 where-  random g = (fromIntegral i,g')-   where (i :: Int,g') = random g-  randomR (l,u) g = (fromIntegral i,g')-    where (i :: Integer, g') = randomR (fromIntegral l,fromIntegral u) g---fromRange :: 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---- | Applies a (monadic) function to all the types we are interested in testing--- with for Feldspar.------ Example usage: 'atAllTypes (quickCheck . prop_mul)'-atAllTypes :: (Monad m) =>-              (forall t . (BoundedInt t, Random t, Arbitrary t, Typeable t) =>-                      t -> m a)-                  -> m ()-atAllTypes test = sequence_ [test (undefined :: Int)-                            ,test (undefined :: Int8)-                            ,test (undefined :: Word32)-                            ,test (undefined :: Word8)-                            ]---- | 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}--------------------------------------------------------------------------------------- ** Lattice operations-----------------------------------------------------------------------------------prop_empty t = isEmpty (emptyRange `rangeTy` t)--prop_full t = isFull (fullRange `rangeTy` t)--prop_isEmpty t r = isEmpty r ==> (upperBound r < lowerBound (r `rangeTy` t))--prop_singletonRange t a = isSingleton (singletonRange (a `asTypeOf` t))--prop_singletonSize t r = isSingleton (r `rangeTy` t) ==> (rangeSize r == 1)--prop_emptySubRange1 t r1 r2 =-    isEmpty (r1 `rangeTy` t) ==> (not (isEmpty r2) ==>-                                      not (r2 `isSubRangeOf` r1))--prop_emptySubRange2 t r1 r2 =-    isEmpty (r1 `rangeTy` t) ==> (not (isEmpty r2) ==> (r1 `isSubRangeOf` r2))--prop_rangeGap t r1 r2 =-    (isEmpty gap1 && isEmpty gap2) || (gap1 == gap2)-  where-    gap1 = rangeGap r1 r2-    gap2 = rangeGap r2 r1-    _    = r1 `rangeTy` t--prop_union1 t x r1 r2 =-    ((x `inRange` r1) || (x `inRange` r2)) ==> (x `inRange` (r1\/r2))-  where _ = x `asTypeOf` t--prop_union2 t x r1 r2 =-    (x `inRange` (r1\/r2)) ==>-        ((x `inRange` r1) || (x `inRange` r2) || (x `inRange` rangeGap r1 r2))-  where _ = x `asTypeOf` t--prop_union3 t r1 r2 = (r1 `rangeTy` t) `isSubRangeOf` (r1\/r2)-prop_union4 t r1 r2 = (r2 `rangeTy` t) `isSubRangeOf` (r1\/r2)---prop_intersect1 t x r1 r2 =-    ((x `inRange` r1) && (x `inRange` r2)) ==> (x `inRange` (r1/\r2))-  where _ = x `asTypeOf` t-prop_intersect2 t x r1 r2 =-    (x `inRange` (r1/\r2)) ==> ((x `inRange` r1) && (x `inRange` r2))-  where _ = x `asTypeOf` t--prop_intersect3 t r1 r2 = (r1/\r2) `isSubRangeOf` (r1 `rangeTy` t)-prop_intersect4 t r1 r2 = (r1/\r2) `isSubRangeOf` (r2 `rangeTy` t)--prop_intersect5 t r1 r2 =-    isEmpty r1 || isEmpty r2 ==> isEmpty (r1/\r2)-  where _ = r1 `rangeTy` t--prop_disjoint t x r1 r2 =-    disjoint r1 r2 ==> (x `inRange` r1) ==> not (x `inRange` r2)-  where _ = x `asTypeOf` t---prop_rangeLess1 t r1 r2 =-    rangeLess r1 r2 ==> disjoint r1 (r2 `rangeTy` t)--prop_rangeLess2 t r1 r2 =-    not (isEmpty r1) && not (isEmpty r2) ==>-    forAll (fromRange r1) $ \x ->-    forAll (fromRange r2) $ \y ->-    rangeLess r1 r2 ==> x < y-  where _ = r1 `rangeTy` t--prop_rangeLessEq t r1 r2 =-    not (isEmpty r1) && not (isEmpty r2) ==>-    forAll (fromRange r1) $ \x ->-    forAll (fromRange r2) $ \y ->-    rangeLessEq r1 r2 ==> x <= y-  where _ = r1 `rangeTy` t-------------------------------------------------------------------------------------- ** Propagation-----------------------------------------------------------------------------------prop_propagation1 :: (BoundedInt t, Random t) =>-                     t -> (forall a . Num a => a -> a) -> Range t -> Property-prop_propagation1 t op r =-    not (isEmpty r) ==>-    forAll (fromRange r) $ \x ->-    op x `inRange` op r---- | This function is useful for range propagation functions like--- 'rangeMax', 'rangeMod' etc.--- It takes two ranges, picks an element out of either ranges and--- checks if applying the operation to the individual elements is in--- the resulting range after range propagation.------ The third argument is a precondition that is satisfied before the test is--- run. A good example is to make sure that the second argument is non-zero--- when testing division.-rangePropagationSafetyPre :: (Random t, BoundedInt t, BoundedInt a) =>-    t ->-    (t -> t -> a) -> (Range t -> Range t -> Range a) ->-    (t -> t -> Bool) ->-    Range t -> Range t -> Property-rangePropagationSafetyPre t op rop pre r1 r2 =-    not (isEmpty r1) && not (isEmpty r2) ==>-    forAll (fromRange r1) $ \v1 ->-    forAll (fromRange r2) $ \v2 ->-        pre v1 v2 ==>-        op v1 v2 `inRange` rop r1 r2--rangePropagationSafetyPre2 ::-    (Random t, BoundedInt t, Random t2, BoundedInt t2, BoundedInt a) =>-    t -> t2 ->-    (t -> t2 -> a) -> (Range t -> Range t2 -> Range a) ->-    (t -> t2 -> Bool) ->-    Range t -> Range t2 -> Property-rangePropagationSafetyPre2 t1 t2 op rop pre r1 r2 =-    not (isEmpty r1) && not (isEmpty r2) ==>-    forAll (fromRange r1) $ \v1 ->-    forAll (fromRange r2) $ \v2 ->-        pre v1 v2 ==>-        op v1 v2 `inRange` rop r1 r2--rangePropagationSafety t op rop = rangePropagationSafetyPre t op rop noPre-  where-    noPre _ _ = True--rangePropSafety1 t op rop ran =-    not (isEmpty ran) ==>-    forAll (fromRange ran) $ \val ->-        op val `inRange` rop ran-  where _ = ran `rangeTy` t--prop_propagation2-    :: (BoundedInt t, Random t) => t -> (forall a . Num a => a -> a -> a)-    -> Range t -> Range t -> Property-prop_propagation2 t op r1 r2 = rangePropagationSafety t op op r1 r2--prop_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-prop_sign t = prop_propagation1 t signum-prop_neg  t = prop_propagation1 t negate-prop_add  t = prop_propagation2 t (+)-prop_sub  t = prop_propagation2 t (-)-prop_mul  t = prop_propagation2 t (*)--prop_exp  t = rangePropagationSafetyPre t (^) rangeExp (\_ e -> e >= 0)--prop_mulU t = rangePropagationSafety t (*) rangeMulUnsigned--prop_subSat t = rangePropagationSafety t subSat rangeSubSat--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--prop_and t = rangePropagationSafety t (.&.) rangeAnd--prop_xor t = rangePropagationSafety t xor rangeXor--prop_shiftLU t1 t2-    = rangePropagationSafetyPre2 t1 t2 fixShiftL rangeShiftLU (\_ _ -> True)-  where fixShiftL a b = shiftL 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)--prop_rangeMax2 t r1 r2 =-    not (isEmpty r1) && not (isEmpty r2) ==>-    upperBound r1 <= upperBound max && upperBound r2 <= upperBound max-    where-      max = rangeMax r1 (r2 `rangeTy` t)--prop_rangeMax3 t r1 r2 =-    not (isEmpty r1) && not (isEmpty r2) ==>-  lowerBound (rangeMax r1 r2) == max (lowerBound r1) (lowerBound r2)-  where _ = r1 `rangeTy` t--prop_rangeMax4 t r1 r2 =-    not (isEmpty r1) && not (isEmpty r2) ==>-    rangeMax r1 r2 == rangeMax r2 r1-  where _ = r1 `rangeTy` t--prop_rangeMax5 t r1 r2 =-    (isEmpty r1 && not (isEmpty r2) ==>-    rangeMax r1 r2 == r2)-    QC..&.-    (isEmpty r2 && not (isEmpty r1) ==>-    rangeMax r1 r2 == r1)-  where _ = r1 `rangeTy` t--prop_rangeMax6 t v1 v2 =-    max v1 v2 `inRange` rangeMax (singletonRange v1) (singletonRange v2)-  where _ = v1 `asTypeOf` t--prop_rangeMax7 a r1 r2 =-    rangePropagationSafety a max rangeMax r1 r2--prop_rangeMin1 t r1 = rangeMin r1 r1 == (r1 `rangeTy` t)--prop_rangeMin2 t r1 r2 =-    not (isEmpty r1) && not (isEmpty r2) ==>-    lowerBound min <= lowerBound r1 && lowerBound min <= lowerBound r2-    where-      min = rangeMin r1 (r2 `rangeTy` t)--prop_rangeMin3 t r1 r2 =-    not (isEmpty r1) && not (isEmpty r2) ==>-  upperBound (rangeMin r1 r2) == min (upperBound r1) (upperBound r2)-  where _ = r1 `rangeTy` t--prop_rangeMin4 t r1 r2 =-    not (isEmpty r1) && not (isEmpty r2) ==>-    rangeMin r1 r2 == rangeMin r2 r1-  where _ = r1 `rangeTy` t--prop_rangeMin5 t r1 r2 =-    (isEmpty r1 && not (isEmpty r2) ==>-    rangeMin r1 r2 == r2)-    QC..&.-    (isEmpty r2 && not (isEmpty r1) ==>-    rangeMin r1 r2 == r1)-  where _ = r1 `rangeTy` t--prop_rangeMin6 t v1 v2 =-    min v1 v2 `inRange` rangeMin (singletonRange v1) (singletonRange v2)-  where _ = v1 `asTypeOf` t--prop_rangeMin7 t r1 r2 =-    rangePropagationSafety t min rangeMin r1 r2--prop_rangeMod1 t v1 v2 =-    v2 /= 0 ==>-    mod v1 v2 `inRange` rangeMod (singletonRange v1) (singletonRange v2)-  where _ = v1 `asTypeOf` t--prop_rangeMod2 t =-    rangePropagationSafetyPre t mod rangeMod divPre--prop_rangeMod3 t =-        isFull $ rangeMod (singletonRange (minBound `asTypeOf` t))-                          (singletonRange (-1))--prop_rangeRem t =-    rangePropagationSafetyPre t rem rangeRem divPre--prop_rangeRem1 t =-        isFull $ rangeRem (singletonRange (minBound `asTypeOf` t))-                          (singletonRange (-1))--prop_rangeQuot t =-    rangePropagationSafetyPre t quot rangeQuot divPre--prop_rangeQuot1 t =-        isFull $ rangeQuot (singletonRange (minBound `asTypeOf` t))-                           (singletonRange (-1))---- | Precondition for division like operators.---   Avoids division by zero and arithmetic overflow.-divPre v1 v2 = v2 /= 0 && not (v1 == minBound && v2 == (-1))-
− Feldspar/Repa.hs 
@@ -1,339 +0,0 @@------ 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/Stream.hs 
@@ -1,493 +0,0 @@------ 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-    ,tail-    ,map,mapNth-    ,maps-    ,intersperse-    ,interleave-    ,downsample-    ,duplicate-    ,scan, scan1-    ,mapAccum-    ,iterate-    ,repeat-    ,unfold-    ,drop-    ,zip,zipWith-    ,unzip-    ,take-    ,splitAt-    ,cycle-    ,streamAsVector, streamAsVectorSize-    ,recurrenceO, recurrenceI, recurrenceIO-    ,iir,fir-    )-    where--import qualified Prelude as P--import Control.Arrow--import Feldspar-import Feldspar.Vector.Internal-         (Vector, Vector1-         ,freezeVector,thawVector,indexed-         ,sum,length,replicate,reverse,scalarProd)---- | Infinite streams.-data Stream a where-  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 :: Syntax a => Stream a -> a-head (Stream next init) = runMutable (init >>= next)---- | Drop the first element of a stream-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 :: (Syntax a, Syntax b) =>-       (a -> b) -> Stream a -> Stream b-map f (Stream next init) = Stream newNext init-  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 :: (Syntax a) =>-          (a -> a) -> Data Index -> Data Index -> Stream a -> Stream a-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 :: (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 :: 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 :: Syntax a => Stream a -> Stream a -> Stream a-interleave (Stream next1 init1) (Stream next2 init2)-    = 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 :: Syntax a => Data Index -> Stream a -> Stream a-downsample n (Stream next init) = Stream newNext init-  where newNext st = do forM (n-1) (\_ -> next st)-                        next st---- | 'duplicate n str' stretches the stream by duplicating the elements 'n' times-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 :: 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----- | A scan but without an initial element.-scan1 :: Syntax a => (a -> a -> a) -> Stream a -> Stream a-scan1 f (Stream next init)-    = 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 :: (Syntax acc, Syntax b) =>-            (acc -> a -> (acc,b)) -> acc -> Stream a -> Stream b-mapAccum f acc (Stream next init)-    = 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 :: 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 :: 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 :: (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 :: 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 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 :: 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 :: (Syntax a, Syntax b) => Stream (a,b) -> (Stream a, Stream b)-unzip stream = (map fst stream, map snd stream)--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)-    = 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---   element 'n+1'.-splitAt :: (Type a) =>-           Data Length -> Stream (Data a) -> (Data [a], Stream (Data a))-splitAt n stream = (take n stream,drop n stream)---- | Loops through a vector indefinitely to produce a stream.-cycle :: 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 :: 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))-               -> (Vector (Data a) -> Vector (Data b))-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)-                   -> (Vector (Data a) -> Vector (Data b))-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,---   but only as many as the length of the input stream---   It uses memory proportional to the input vector.------ For exaple one can define the fibonacci sequence as follows:------ > fib = recurrenceO (vector [0,1]) (\fib -> fib!0 + fib!1)------ 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 =>-               Vector1 a ->-               (Vector1 a -> Data a) ->-               Stream (Data a)-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---   similar to 'recurrenceO'. The difference is that that it has an input---   stream, and that the recurrence equation may only refer to previous---   inputs, it may not refer to previous outputs.------ The sliding average of a stream can easily be implemented using--- 'recurrenceI'.------ > slidingAvg :: Data WordN -> Stream (Data WordN) -> Stream (Data WordN)--- > slidingAvg n str = recurrenceI (replicate n 0) str--- >                    (\input -> sum input `quot` n)-recurrenceI :: (Type a, Type b) =>-               Vector1 a -> Stream (Data a) ->-               (Vector1 a -> Data b) ->-               Stream (Data b)-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---   previous inputs and outputs.------   'recurrenceIO' is used when defining the 'iir' filter.-recurrenceIO :: (Type a, Type b) =>-                Vector1 a -> Stream (Data a) -> Vector1 b ->-                (Vector1 a -> Vector1 b -> Data b) ->-                Stream (Data b)-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) =>-                 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 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 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 :: 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 -> Vector1 Float -> Vector1 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 input-                        - scalarProd a output)-      )-
− Feldspar/Vector.hs 
@@ -1,65 +0,0 @@------ 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 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------   * 'fold'------   * 'fold1'------   * Functions that introduce storage (see above)------   * \"Folding\" functions: 'sum', 'maximum', etc.------ These functions introduce overhead that is linear in the length of the--- vector.--module Feldspar.Vector-    ( module Feldspar.Vector.Internal-    ) where----import Feldspar  -- For Haddock-import Feldspar.Vector.Internal hiding (freezeVector)-
− Feldspar/Vector/Internal.hs 
@@ -1,345 +0,0 @@------ 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 
@@ -1,70 +0,0 @@------ 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)-
LICENSE view
@@ -1,3 +1,5 @@+Copyright (c) 2012, Emil Axelsson, Gergely Dévai, Anders Persson and+                    Josef Svenningsson Copyright (c) 2009-2011, ERICSSON AB All rights reserved.
+ examples/Examples/Simple/Basics.hs view
@@ -0,0 +1,41 @@+module Examples.Simple.Basics where++import qualified Prelude+import Feldspar++-- Identity function for 32 bit integers.+example1 :: Data Int32 -> Data Int32+example1 = id++-- Constant function+example2 :: Data Int32+example2 = 2++-- A constant core vector+example3 :: Data [Int32]+example3 = value [42,1,2,3]++-- Examples showing some of the integer and boolean operations:++example4 :: Data Int32 -> Data Int32+example4 x = negate x++example5 :: Data Int32 -> Data Int32 -> Data Int32+example5 x y = x + y++example6 :: Data Int32 -> Data Int32 -> Data Bool+example6 x y = x == y++example7 :: Data Bool+example7 = 2 /= (2 :: Data Int32) -- Type of numeric literals sometimes have to be written explicitly.++example8 :: Data Bool -> Data Bool+example8 b = not b++-- Examples on using conditionals:++example9 :: Data Int32 -> Data Int32+example9 a = condition (a<5) (3*(a+20)) (30*(a+20))++example10 :: Data Int32 -> Data Int32+example10 a = condition (a<5) (3*(a+a)) (30*(a+a))
feldspar-language.cabal view
@@ -1,35 +1,43 @@ name:           feldspar-language-version:        0.5.0.1+version:        0.6.0.2 synopsis:       A functional embedded language for DSP and parallelism description:    Feldspar (Functional Embedded Language for DSP and PARallelism)                 is an embedded DSL for describing digital signal processing                 algorithms. This package contains the language front-end and an                 interpreter. category:       Language-copyright:      Copyright (c) 2009-2011, ERICSSON AB+copyright:      Copyright (c) 2012 Emil Axelsson, Gergely Dévai,+                                   Anders Persson, Josef Svenningsson+                Copyright (c) 2009-2011, ERICSSON AB author:         Functional programming group at Chalmers University of Technology maintainer:     Emil Axelsson <emax@chalmers.se>+                Anders Persson <anders.cj.persson@gmail.com> license:        BSD3 license-file:   LICENSE stability:      experimental-homepage:       http://feldspar.inf.elte.hu/feldspar/+homepage:       https://feldspar.github.com+bug-reports:    https://github.com/feldspar/feldspar-language/issues build-type:     Simple-cabal-version:  >= 1.6-tested-with:    GHC==7.0+cabal-version:  >= 1.14+tested-with:    GHC==7.6.1, GHC==7.4.2  extra-source-files:-  Examples/Simple/*.hs,-  Examples/Effects/*.hs,-  Examples/Math/*.hs-  CEFP/cefpNotes.hs+  examples/Examples/Simple/Basics.hs +source-repository head+  type:     git+  location: git://github.com/feldspar/feldspar-language.git+ library   exposed-modules:     Feldspar.Prelude     Feldspar.Lattice     Feldspar.Range+    Feldspar.Algorithm.CRC+    Feldspar.Algorithm.FFT     Feldspar.Core.Types     Feldspar.Core.Interpretation+    Feldspar.Core.Interpretation.Typed     Feldspar.Core.Constructs.Array     Feldspar.Core.Constructs.Binding     Feldspar.Core.Constructs.Bits@@ -41,6 +49,7 @@     Feldspar.Core.Constructs.Error     Feldspar.Core.Constructs.Floating     Feldspar.Core.Constructs.Fractional+    Feldspar.Core.Constructs.Future     Feldspar.Core.Constructs.Integral     Feldspar.Core.Constructs.Literal     Feldspar.Core.Constructs.Logic@@ -49,6 +58,7 @@     Feldspar.Core.Constructs.MutableArray     Feldspar.Core.Constructs.MutableReference     Feldspar.Core.Constructs.MutableToPure+    Feldspar.Core.Constructs.NoInline     Feldspar.Core.Constructs.Par     Feldspar.Core.Constructs.Num     Feldspar.Core.Constructs.Ord@@ -70,6 +80,7 @@     Feldspar.Core.Frontend.Error     Feldspar.Core.Frontend.Floating     Feldspar.Core.Frontend.Fractional+    Feldspar.Core.Frontend.Future     Feldspar.Core.Frontend.Integral     Feldspar.Core.Frontend.Literal     Feldspar.Core.Frontend.Logic@@ -78,9 +89,11 @@     Feldspar.Core.Frontend.MutableArray     Feldspar.Core.Frontend.MutableReference     Feldspar.Core.Frontend.MutableToPure+    Feldspar.Core.Frontend.NoInline     Feldspar.Core.Frontend.Par     Feldspar.Core.Frontend.Num     Feldspar.Core.Frontend.Ord+    Feldspar.Core.Frontend.Select     Feldspar.Core.Frontend.SizeProp     Feldspar.Core.Frontend.SourceInfo     Feldspar.Core.Frontend.Trace@@ -92,35 +105,37 @@     Feldspar.Core     Feldspar.BitVector     Feldspar.FixedPoint+    Feldspar.Future     Feldspar.Matrix     Feldspar.Option     Feldspar.Repa     Feldspar.Stream     Feldspar.Vector.Internal     Feldspar.Vector+    Feldspar.Vector.Push     Feldspar.Wrap     Feldspar.Par     Feldspar +  default-language: Haskell2010+   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.*,-    tuple == 0.2.*,-    type-level >= 0.2.4,-    monad-par >= 0.1 && < 0.2,-    QuickAnnotate+    array                       >= 0.4    && < 0.5,+    base                        >= 4      && < 4.7,+    containers                  >= 0.4    && < 0.6,+    data-hash                   >= 0.1    && < 0.3,+    data-lens                   >= 2.10   && < 2.11,+    mtl                         >= 2.0    && < 2.2,+    QuickCheck                  >= 2.5    && < 3,+    patch-combinators           >= 0.1    && < 0.2,+    syntactic                   >= 1.4    && < 1.5,+    tagged                      >= 0.4    && < 0.5,+    tuple                       >= 0.2    && < 0.3,+    type-level                  >= 0.2.4  && < 0.3,+    monad-par                   >= 0.3    && < 0.4,+    QuickAnnotate               >= 0.6    && < 0.7 -  extensions:+  other-extensions:     DeriveDataTypeable     EmptyDataDecls     FlexibleInstances@@ -138,5 +153,64 @@     TypeSynonymInstances     ViewPatterns +  hs-source-dirs: src examples+   ghc-options: -fcontext-stack=100++test-suite range+  type: exitcode-stdio-1.0++  hs-source-dirs: tests++  main-is: RangeTest.hs++  other-modules:+    Feldspar.Range.Test++  default-language: Haskell2010++  build-depends:+    feldspar-language,+    base >= 4 && < 4.7,+    random >= 1 && <2,+    QuickCheck >= 2.4 && <3,+    test-framework >= 0.6 && < 0.7,+    test-framework-quickcheck2 >= 0.2 && < 0.3++test-suite semantics+  type: exitcode-stdio-1.0++  hs-source-dirs: tests examples++  main-is: SemanticsTest.hs++  other-modules:+    Feldspar.Vector.Test+    SemanticsTest++  default-language: Haskell2010++  build-depends:+    feldspar-language,+    base                       >= 4   && < 4.7,+    QuickCheck                 >= 2.4 && < 3,+    test-framework             >= 0.6 && < 0.7,+    test-framework-th          >= 0.2 && < 0.3,+    test-framework-quickcheck2 >= 0.2 && < 0.3++test-suite decoration+  type: exitcode-stdio-1.0++  hs-source-dirs: tests examples++  main-is: DecorationTests.hs++  default-language: Haskell2010++  build-depends:+    feldspar-language,+    base                  >= 4   && < 4.7,+    bytestring            >= 0.9 && < 0.11,+    test-framework        >= 0.6 && < 0.7,+    test-framework-golden >= 1.1 && < 1.2
+ src/Feldspar.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.+--++-- | Interface to the essential parts of the Feldspar language. High-level+-- libraries have to be imported separately.++module Feldspar+  ( module Feldspar.Prelude+  , module Feldspar.Core+  ) where++++import qualified Prelude+  -- In order to be able to use the Feldspar module in GHCi without getting name+  -- clashes.++import Feldspar.Prelude+import Feldspar.Core+
+ src/Feldspar/Algorithm/CRC.hs view
@@ -0,0 +1,87 @@+--+-- 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.Algorithm.CRC where++import qualified Prelude++import Feldspar+import Feldspar.Vector++tstBit :: Bits a => Data a -> Data Index -> Data Bool+tstBit w b = w .&. (1 .<<. b) /= 0++makeCrcTable :: (Bits a) => Data a -> Vector1 a+makeCrcTable polynomial = indexed 256 $ \i -> forLoop 8 (i2n i .<<. (sz - 8)) step+  where+    sz       = bitSize polynomial+    step _ r = let r' = r .<<. 1+               in condition (tstBit r (sz-1)) (r' `xor` polynomial) r'++-- | Calculate the normal form CRC using a table+crcNormal :: (Bits a)+          => Vector1 a -> Data a -> Vector1 Word8 -> Data a+crcNormal table initial xs = fold step initial xs+  where+    sz         = bitSize initial+    step crc a = (table ! i2n ((i2n (crc .>>. (sz - 8)) .&. 0xFF) `xor` a)) `xor` (crc .<<. 8)++-- | Calculate the reflected form CRC using a table+-- needs reflected tables+crcReflected :: (Bits a)+             => Vector1 a -> Data a -> Vector1 Word8 -> Data a+crcReflected table = fold step+  where+    step crc a = (table ! i2n ((crc `xor` i2n a) .&. 0xFF)) `xor` (crc .>>. 8)++-- | Calculate normal form CRC from a polynominal+crcNaive :: (Bits a) => Data a -> Data a -> Vector1 Word8 -> Data a+crcNaive = crcNormal . makeCrcTable++-- Future work+--+data CRC a = CRC { name       :: String+                 , width      :: Index+                 , poly       :: a+                 , init       :: a+                 , reflectIn  :: Bool+                 , reflectOut :: Bool+                 , xorOut     :: a+                 }++crc16 :: CRC (Data Word16)+crc16 = CRC "CRC-16" 16 0x8005 0x0000 True True 0x0000++-- | Reflect the bottom b bits of value t+reflect :: (Bits a) => Data a -> Data Length -> Data a+reflect t b = forLoop b t $ \i v -> let mask = bit ((b-1)-i) in condition (testBit t i) (v .|. mask) (v .&. complement mask)++-- References+-- The functions in this module are inspired by the follow guide+-- http://www.ross.net/crc/download/crc_v3.txt+
+ src/Feldspar/Algorithm/FFT.hs view
@@ -0,0 +1,102 @@+--+-- 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.Algorithm.FFT+    ( fft+    , ifft+    )+  where++import qualified Prelude as P++import Feldspar+import Feldspar.Vector++-- | 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 :: Vector1 (Complex Float) -> Vector1 (Complex Float)+fft v = newLen (length v) $ bitRev steps $ fftCore steps v+    where steps = ilog2 (length v) - 1++-- | 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 :: Vector1 (Complex Float) -> Vector1 (Complex Float)+ifft v = newLen (length v) $ bitRev steps $ ifftCore steps v+    where steps = ilog2 (length v) - 1++fftCore :: Data Index -> Vector1 (Complex Float) -> Vector1 (Complex Float)+fftCore n = composeOn stage (reverse (0...n))+  where+    stage k (Indexed l ixf Empty) = indexed l ixf'+      where+        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)+            k2   = 1 .<<. k++ifftCore :: Data Index -> Vector1 (Complex Float) -> Vector1 (Complex Float)+ifftCore n = map (/ complex (i2f (2^(n+1))) 0) . composeOn stage (reverse (0...n))+  where+    stage k (Indexed l ixf Empty) = indexed l ixf'+      where+        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)+            k2   = 1 .<<. k++bitRev :: Type a => Data Index -> Vector1 a -> Vector1 a+bitRev n = composeOn riffle (1...n)++riffle :: Syntax a => Data Index -> Vector a -> Vector a+riffle k = permute (const $ rotBit k)++-- Helper functions+composeOn :: (Syntax a) => (b -> a -> a) -> Vector b -> a -> a+composeOn = flip . fold . flip++rotBit :: Data Index -> Data Index -> Data Index+rotBit 0 _ = P.error "rotBit: k should be at least 1"+rotBit k i = lefts .|. rights+  where+    ir = i .>>. 1+    rights = ir .&. oneBits k+    lefts  = (((ir .>>. k) .<<. 1) .|. (i .&. 1)) .<<. k++oneBits :: (Bits a) => Data Index -> Data a+oneBits n = complement (allOnes .<<. n)++allOnes :: (Bits a) => Data a+allOnes = complement 0++lsbs :: Bits a => Data Index -> Data a -> Data a+lsbs k i = i .&. oneBits k+
+ src/Feldspar/BitVector.hs view
@@ -0,0 +1,386 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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 #-}++-- | A 'Vector' interface to packed sequences of bits+--+module Feldspar.BitVector where++import qualified Prelude+import Data.Word+import Data.List (inits)+import Data.Proxy+import qualified Data.TypeLevel as TL++import Language.Syntactic hiding (fold)++import Feldspar.Wrap+import Feldspar.Prelude+import Feldspar hiding (sugar, desugar, resugar)+import qualified Feldspar.Vector as Vec++-- * Types and classes++-- | A 'Unit' is the internal representation of a 'BitVector'+class (Type w, Numeric w, Bits w, Integral w) => Unit w+  where+    width :: Proxy w -> Length++instance Unit Word8+  where+    width _ = 8++instance Unit Word16+  where+    width _ = 16++instance Unit Word32+  where+    width _ = 32++data BitVector w+     = BitVector+     { segments         :: [Segment w]+     }++data 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+type instance CollSize  (BitVector w) = Data Length++instance (Unit a) => Syntactic (BitVector a)+  where+    type Domain (BitVector a)   = FeldDomainAll+    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.sum $ Prelude.map segmentLen $ segments bv+  where+    segmentLen s = numUnits s * w+    w = value $ width (Proxy :: Proxy w)++numOfUnits :: (Unit w) => BitVector w -> Data Length+numOfUnits bv = Prelude.sum $ 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 (Proxy :: Proxy 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 _      [] = false+            -- XXX Should be an error here...+        help accum [s] = ixf s accum i+        help accum (s:ss) = i < accum + numUnits s * w ?+            ( ixf s accum i+            , help (accum + numUnits s * w) ss+            )+        w = value $ width (Proxy :: Proxy w)+        ixf s accum ix = testBit (elements s ((ix - accum) `div` w)) (w - 1 - ((ix - accum) `mod` w))++fromBits :: forall w . (Unit w) => [Bool] -> BitVector w+fromBits bs = unfreezeBitVector $ value xs+  where+    xs = [ conv (Proxy :: Proxy w) $ Prelude.take w (Prelude.drop (i*w) bs) | i <- [0..Prelude.length bs `Prelude.div` w Prelude.- 1]]+    w = fromInteger $ toInteger $ width (Proxy :: Proxy w)+    conv :: (Unit w) => Proxy 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 res+  where+    res 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 _ 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 _ [] = 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 (Proxy :: Proxy w)+    dropSegments _ [] = 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 _ [] = 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 _ 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 (Proxy :: Proxy 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 res+  where+    res f' = Prelude.foldl (++) (BitVector [])+        [ zipSegments f' s z | s <- segIdxs bv, z <- segIdxs bw ]+    segIdxs bvec = Prelude.zip (segments bvec) $+        Prelude.map (Prelude.sum . Prelude.map numUnits) $+        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 = drop 1 (b2i b `shiftLU` (w - 1))+  where+    w = value $ width (Proxy :: Proxy 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 $ \_ _ -> complement 0+          , c $ (.|.)+          )+        , f false false ?+          ( c $ \x y -> x .|. complement y+          , c $ \x _ -> x+          )+        )+      , f false true ?+        ( f false false ?+          ( c $ \x y -> complement x .|. y+          , c $ \_ y -> y+          )+        , f false false ?+          ( c $ \x y -> complement (x `xor` y)+          , c $ (.&.)+          )+        )+      )+    , f true false ?+      ( f false true ?+        ( f false false ?+          ( c $ \x y -> complement (x .&. y)+          , c $ \x y -> x `xor` y+          )+        , f false false ?+          ( c $ \_ y -> complement y+          , c $ \x y -> x .&. complement y+          )+        )+      , f false true ?+        ( f false false ?+          ( c $ \x _ -> complement x+          , c $ \x y -> complement x .&. y+          )+        , f false false ?+          ( c $ \x y -> complement (x .|. y)+          , c $ \_ _ -> 0+          )+        )+      )+    )++-- * Wrapping for bitvectors++instance (Unit w) => Wrap (BitVector w) (Data [w]) where+    wrap = freezeBitVector++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)++-- * Patch combinators for bitvectors++tBV :: Patch w w -> Patch (BitVector w) (BitVector w)+tBV _ = id
+ src/Feldspar/Core.hs view
@@ -0,0 +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.+--++-- | The Feldspar core language++module Feldspar.Core+    (+      -- * Reexported standard modules+      Complex (..)+    , module Data.Int+    , module Data.Word++      -- * Feldspar types+    , Range (..)+    , BoundedInt+    , module Feldspar.Core.Types++    -- * Frontend+    , module Feldspar.Core.Frontend+    , module Feldspar.Core.Collection+    ) where++++import Data.Complex+import Data.Int hiding (Int)+import Data.Word++import Feldspar.Range+import Feldspar.Core.Types+import Feldspar.Core.Frontend+import Feldspar.Core.Collection+
+ src/Feldspar/Core/Collection.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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++++-- | Collection element type+type family Elem a++-- | Collection index type+type family CollIndex a++-- | Collection size type+type family CollSize a++-- | Data structures that support indexing+class Indexed a+  where+    (!) :: a -> CollIndex a -> Elem a++infixl 9 !++-- | Sized data structures+class Sized a+  where+    collSize    :: a -> CollSize a+    setCollSize :: CollSize a -> a -> a++-- | Mapping over collections+class CollMap a b+  where+    collMap :: (Elem a -> Elem b) -> a -> b+
+ src/Feldspar/Core/Constructs.hs view
@@ -0,0 +1,239 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++--+-- 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.Constructs where++import Data.Typeable++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.Future+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.NoInline+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++--------------------------------------------------------------------------------+-- * Domain+--------------------------------------------------------------------------------++type FeldSymbols+    =   (Decor SourceInfo1 Identity :|| Type)+    :+: (Condition  :|| Type)+    :+: (FFI        :|| Type)+    :+: (Let        :|| Type)+    :+: (Literal    :|| Type)+    :+: (Select     :|| Type)+    :+: (Tuple      :|| Type)+    :+: (Array      :|| Type)+    :+: (BITS       :|| Type)+    :+: (COMPLEX    :|| Type)+    :+: (Conversion :|| Type)+    :+: (EQ         :|| Type)+    :+: (Error      :|| Type)+    :+: (FLOATING   :|| Type)+    :+: (FRACTIONAL :|| Type)+    :+: (FUTURE     :|| Type)+    :+: (INTEGRAL   :|| Type)+    :+: (Logic      :|| Type)+    :+: (Loop       :|| Type)+    :+: (NUM        :|| Type)+    :+: (NoInline   :|| Type)+    :+: (ORD        :|| Type)+    :+: (PropSize   :|| Type)+    :+: (Save       :|| Type)+    :+: (Trace      :|| Type)+    :+: ConditionM Mut+    :+: LoopM Mut+    :+: MONAD Mut+    :+: Mutable+    :+: MutableArray+    :+: MutableReference+    :+: MutableToPure+    :+: MONAD Par+    :+: ParFeature+    :+: Empty++-- TODO We are currently a bit inconsistent in that `Type` constraints are sometimes attached+--      separately using `(:||)` and sometimes baked into the symbol type. `Mutable` and+--      `MutableToPure` (at least) have `Type` baked in. Note that `(MutableToPure :|| Type)` would+--      currently not work, since `WithArray` has monadic result type.++type FeldDomain    = FODomain FeldSymbols Typeable Type++type FeldDomainAll = HODomain FeldSymbols Typeable Type++--newtype FeldDomain a = FeldDomain (FeldSymbols a)+++--deriving instance (sym :<: FeldSymbols) => sym :<: FeldDomain+--deriving instance (Project sym FeldSymbols) => Project sym FeldDomain++----instance (InjectC sym FeldSymbols a) => InjectC sym FeldDomain a+----    where+----      injC = injC . FeldDomain++----instance Constrained FeldDomain+--    where+--        type Sat FeldDomain = Sat FeldSymbols+--        exprDict (FeldDomain a) = exprDict a++--deriving instance Equality FeldDomain+--deriving instance Render   FeldDomain+--deriving instance ToTree   FeldDomain+--deriving instance Eval     FeldDomain+--deriving instance EvalBind FeldDomain++--instance VarEqEnv env => AlphaEq+--    FeldDomain+--    FeldDomain+--    ((Lambda :+: (Variable :+: ((FeldDomain :|| Eq) :| Show))) :|| Typeable)+--    env+--  where+--    alphaEqSym (FeldDomain a) aArgs (FeldDomain b) bArgs =+--        alphaEqSym a aArgs b bArgs++--instance AlphaEq+--    FeldDomain+--    FeldDomain+--    ((Lambda :+: (Variable :+: ((FeldDomain :|| Eq) :| Show))) :|| Typeable)+--    [(VarId, VarId)]+--  where+--    alphaEqSym (FeldDomain a) aArgs (FeldDomain b) bArgs =+--        alphaEqSym a aArgs b bArgs++{-+instance Equality dom => AlphaEq dom dom (Decor Info (dom :|| Typeable)) [(VarId,VarId)]+  where+    alphaEqSym = alphaEqSymDefault+-}++--deriving instance Sharable FeldDomain++{-+instance Optimize FeldDomain (Lambda TypeCtx :+: (Variable TypeCtx :+: FeldDomain))+  where+    optimizeFeat       (FeldDomain a) = optimizeFeat       a+    constructFeatOpt   (FeldDomain a) = constructFeatOpt   a+    constructFeatUnOpt (FeldDomain a) = constructFeatUnOpt a+-}+++++--------------------------------------------------------------------------------+-- * Front end+--------------------------------------------------------------------------------++newtype Data a = Data { unData :: ASTF FeldDomainAll a }++deriving instance Typeable1 Data++instance Type a => Syntactic (Data a)+  where+    type Domain (Data a)   = FeldDomainAll+    type Internal (Data a) = a+    desugar = unData+    sugar   = Data++-- | Specialization of the 'Syntactic' class for the Feldspar domain+class+    ( Syntactic a+    , Domain a ~ FeldDomainAll+    , 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.++instance Type a => Syntax (Data a)++instance Type a => Eq (Data a)+  where+    Data a == Data b = alphaEq (reify a) (reify b)++instance Type a => Show (Data a)+  where+    show (Data a) = render $ reify a++--c' :: (Type (DenResult sig)) => feature sig -> (feature :|| Type) sig+--c' = C'++sugarSymF :: ( ApplySym sig b dom+             , SyntacticN c b+             , InjectC (feature :|| Type) dom (DenResult sig)+             , Type (DenResult sig)+             )+          => feature sig -> c+sugarSymF sym = sugarSymC (c' sym)+
+ src/Feldspar/Core/Constructs/Array.hs view
@@ -0,0 +1,247 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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 Data.List+import Data.Map (notMember)++import Language.Syntactic+import Language.Syntactic.Constructs.Binding hiding (betaReduce)+import Language.Syntactic.Constructs.Binding.HigherOrder (CLambda)++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 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 Equality Array where equal = equalDefault; exprHash = exprHashDefault+instance Render   Array where renderArgs = renderArgsDefault+instance ToTree   Array+instance Eval     Array where evaluate = evaluateDefault+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 :|| Type)+  where+    sizeProp (C' Parallel) (WrapFull len :* WrapFull ixf :* Nil) =+        infoSize len :> infoSize ixf+    sizeProp (C' Sequential) (WrapFull len :* _ :* WrapFull step :* Nil) =+        infoSize len :> fst (infoSize step)+    sizeProp (C' Append) (WrapFull arra :* WrapFull arrb :* Nil) =+        (alen + blen) :> (aelem \/ belem)+      where+        alen :> aelem = infoSize arra+        blen :> belem = infoSize arrb+    sizeProp (C' GetIx) (WrapFull arr :* _ :* Nil) = el+      where+        _ :> el = infoSize arr+    sizeProp (C' SetIx) (WrapFull arr :* _ :* WrapFull e :* Nil) =+        len :> (el \/ infoSize e)+      where+        len :> el = infoSize arr+    sizeProp (C' GetLength) (WrapFull arr :* Nil) = len+      where+        len :> _ = infoSize arr+    sizeProp (C' SetLength) (WrapFull len :* WrapFull arr :* Nil) =+        infoSize len :> el+      where+        _ :> el = infoSize arr++instance+    ( (Array :|| Type) :<: dom+    , (NUM   :|| Type) :<: dom+    , (ORD   :|| Type) :<: dom+    , (Variable :|| Type) :<: dom+    , CLambda Type :<: dom+    , OptimizeSuper dom+    ) =>+      Optimize (Array :|| Type) dom+  where+    optimizeFeat sym@(C' 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 sym (len' :* ixf' :* Nil)++    optimizeFeat sym@(C' Sequential) (len :* inital :* step :* Nil) = do+        len'  <- optimizeM len+        init' <- optimizeM inital+        let szI     = infoSize (getInfo len')+            ixRange = rangeByRange 0 (szI-1)+        step' <- optimizeFunction+            optimizeM  -- TODO (optimizeFunctionFix optimizeM (mkInfo universal))+            (mkInfo ixRange)+            step+        constructFeat sym (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 (C' Parallel) (len :* _ :* 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 (C' Parallel) (len :* (lam :$ (gix :$ arr2 :$ ix)) :* Nil)+        | Just (SubConstr2 (Lambda v1))   <- prjLambda lam+        , Just (C' GetIx)         <- prjF gix+        , Just (C' (Variable v2)) <- prjF ix+        , v1 == v2+        , v1 `notMember` infoVars (getInfo arr2)+        = constructFeat (c' SetLength) (len :* arr2 :* Nil)++    constructFeatOpt (C' Sequential) (len :* _ :* _ :* 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 (C' Append) (a :* b :* Nil)+        | Just [] <- viewLiteral a = return b+        | Just [] <- viewLiteral b = return a++    constructFeatOpt (C' GetIx) ((op :$ _ :$ ixf) :* ix :* Nil)+        | Just (C' Parallel) <- prjF op+        = optimizeM $ betaReduce (stripDecor ix) (stripDecor ixf)+          -- TODO should not need to drop the decorations++    constructFeatOpt s@(C' GetIx) ((op :$ _ :$ arr) :* ix :* Nil)+        | Just (C' SetLength) <- prjF op+        = constructFeat s (arr :* ix :* Nil)++    constructFeatOpt (C' GetLength) (arr :* Nil)+        | Just as <- viewLiteral arr = return $ literalDecor $ genericLength as++    constructFeatOpt s@(C' GetLength) ((op :$ a :$ _ :$ _) :* Nil)+        | Just (C' Sequential) <- prjF op = return a+        | Just (C' SetIx)      <- prjF op = constructFeat s (a :* Nil)++    constructFeatOpt sym@(C' GetLength) ((op :$ a :$ b) :* Nil)+        | Just (C' Append) <- prjF op = do+            aLen <- constructFeat sym (a :* Nil)+            bLen <- constructFeat sym (b :* Nil)+            constructFeatOpt (c' Add) (aLen :* bLen :* Nil)+        | Just (C' Parallel)  <- prjF op = return a+        | Just (C' SetLength) <- prjF op = return a++    -- TODO remove this optimization when the singletonRange -> literal+    -- optimization in Feldspar.Core.Interpretation has been implemented+    constructFeatOpt (C' GetLength) (arr :* Nil)+        | len :> _ <- infoSize $ getInfo arr+        , isSingleton len+        = return $ literalDecor $ lowerBound len++    constructFeatOpt (C' SetLength) (len :* _ :* Nil)+        | Just 0 <- viewLiteral len = return $ literalDecor []++    constructFeatOpt (C' SetLength) ((getLength :$ arr') :* arr :* Nil)+        | Just (C' GetLength) <- prjF getLength+        , alphaEq arr arr'+        = return arr++    constructFeatOpt (C' SetLength) (len :* arr :* Nil)+        | rlen      <- infoSize $ getInfo len+        , rarr :> _ <- infoSize $ getInfo arr+        , isSingleton rlen+        , isSingleton rarr+        , rlen == rarr+        = return arr++    constructFeatOpt a args = constructFeatUnOpt a args++    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+
+ src/Feldspar/Core/Constructs/Binding.hs view
@@ -0,0 +1,251 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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+    , prjLambda+    , betaReduce+    , cLambda+    ) 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 hiding (subst,betaReduce)+import Language.Syntactic.Constructs.Binding.HigherOrder (CLambda)++import Feldspar.Lattice+import Feldspar.Core.Types+import Feldspar.Core.Interpretation++instance Sharable Variable  -- `codeMotion` will not share variables anyway+instance Sharable Lambda    -- Will not be shared anyway because we disallow variables of `->` type+instance Sharable Let++-- | Should be a capture-avoiding substitution, but it is currently not correct.+--+-- Note: Variables with a different type than the new expression will be+-- silently ignored.+subst :: forall constr dom a b+    .  ( Constrained dom+       , CLambda Type :<: dom+       , (Variable :|| Type) :<: dom+       )+    => VarId       -- ^ Variable to be substituted+    -> ASTF (dom :|| Typeable) a  -- ^ Expression to substitute for+    -> ASTF (dom :|| Typeable) b  -- ^ Expression to substitute in+    -> ASTF (dom :|| Typeable) b+subst v new a = go a+  where+    go :: AST (dom :|| Typeable) c -> AST (dom :|| Typeable) c+    go a@((prjLambda -> Just (SubConstr2 (Lambda w))) :$ _)+        | v==w = a  -- Capture+    go (f :$ a) = go f :$ go a+    go var+        | Just (C' (Variable w)) <- prjF var+        , v==w+        , Dict <- exprDictSub pTypeable new+        , Dict <- exprDictSub pTypeable var+        , Just new' <- gcast new+        = new'+    go a = a+  -- TODO Make it correct (may need to alpha-convert `new` before inserting it)+  -- TODO Should there be an error if `gcast` fails? (See note in Haddock+  --      comment.)++betaReduce+    :: ( Constrained dom+       , CLambda Type :<: dom+       , (Variable :|| Type) :<: dom+       )+    => ASTF (dom :|| Typeable) a         -- ^ Argument+    -> ASTF (dom :|| Typeable) (a -> b)  -- ^ Function to be reduced+    -> ASTF (dom :|| Typeable) b+betaReduce new (lam :$ body)+    | Just (SubConstr2 (Lambda v)) <- prjLambda lam = subst v new body++optimizeLambda :: ( CLambda Type :<: dom+                  , OptimizeSuper dom)+    => (ASTF (dom :|| Typeable) b -> Opt (ASTF (Decor Info (dom :|| Typeable)) b))  -- ^ Optimization of the body+    -> Info a+    -> CLambda Type (b :-> Full (a -> b))+    -> Args (AST (dom :|| Typeable)) (b :-> Full (a -> b))+    -> Opt (ASTF (Decor Info (dom :|| Typeable)) (a -> b))+optimizeLambda opt info lam@(SubConstr2 (Lambda v)) (body :* Nil)+    | Dict <- exprDict body+    = do+        body' <- localVar v info $ opt body+        constructFeatUnOpt lam (body' :* Nil)++-- | Assumes that the expression is a 'Lambda'+optimizeFunction :: ( CLambda Type :<: dom+                    , OptimizeSuper dom)+    => (ASTF (dom :|| Typeable) b -> Opt (ASTF (Decor Info (dom :|| Typeable)) b))  -- ^ Optimization of the body+    -> Info a+    -> (ASTF (dom :|| Typeable) (a -> b) -> Opt (ASTF (Decor Info (dom :|| Typeable)) (a -> b)))+optimizeFunction opt info a@(sym :$ body)+    | Dict <- exprDict a+    , Dict <- exprDict body+    , Just (lam@(SubConstr2 (Lambda v))) <- prjLambda sym+    = optimizeLambda opt info lam (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 inf -> inf {infoSize = sz})++        let bLens :: Lens (ASTF (Decor Info dom) a) (Size a)+            bLens = lens (infoSize . getInfo)+                (\sz a -> updateDecor (\inf -> inf {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 :|| Type) :<: dom+         , OptimizeSuper dom)+      => Optimize (Variable :|| Type) dom+  where+    constructFeatUnOpt var@(C' (Variable v)) Nil+        = 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 (SomeType $ infoType info) }+                 in Sym $ Decor info' $ C' $ inj $ c' (Variable v)++instance ( CLambda Type :<: dom+         , OptimizeSuper dom)+      => Optimize (CLambda Type) 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@(SubConstr2 (Lambda v))+        | Dict <- exprDict lam+        = optimizeLambda optimizeM (mkInfo universal) lam++    constructFeatUnOpt lam@(SubConstr2 (Lambda v)) (body :* Nil)+        | Dict <- exprDict lam+        , Info t sz vars _ <- getInfo body+        = do+            src <- asks sourceEnv+            let info = Info (FunType typeRep t) sz (delete v vars) src+            return $ (Sym $ Decor info $ C' $ inj lam) :$ body++instance SizeProp (Let :|| Type)+  where+    sizeProp (C' Let) (_ :* WrapFull f :* Nil) = infoSize f++instance+    ( (Let      :|| Type) :<: dom+    , (Variable :|| Type) :<: dom+    , CLambda Type        :<: dom+    , OptimizeSuper dom+    ) =>+      Optimize (Let :|| Type) dom+  where+    optimizeFeat lt@(C' 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 (C' Let) (a :* (lam :$ var) :* Nil)+        | Just (C' (Variable v2))       <- prjF var+        , Just (SubConstr2 (Lambda v1)) <- prjLambda lam+        , v1 == v2+        = return $ fromJust $ gcast a++    constructFeatOpt a args = constructFeatUnOpt a args++    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x++prjLambda :: (Project (CLambda Type) dom)+          => dom sig -> Maybe (CLambda Type sig)+prjLambda = prj++cLambda :: Type a => VarId -> CLambda Type (b :-> Full (a -> b))+cLambda = SubConstr2 . Lambda+
+ src/Feldspar/Core/Constructs/Bits.hs view
@@ -0,0 +1,238 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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 #-}++-- | Implementation of constructs and operations on 'Bits'+module Feldspar.Core.Constructs.Bits+    ( BITS (..)+    ) where++import Data.Typeable++import Language.Syntactic+import Language.Syntactic.Constructs.Literal+import Language.Syntactic.Constructs.Binding++import Feldspar.Range+import Feldspar.Core.Types+import Feldspar.Core.Interpretation+import Feldspar.Core.Constructs.Logic+import Feldspar.Core.Constructs.Eq+import Feldspar.Core.Constructs.Ord++import Data.Bits++-- | Bits constructs+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)++    IsSigned      :: (Type a, Bits a, BoundedInt a, Size a ~ Range a) => BITS (a :-> Full Bool)++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 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 :: (Num b, Bits b) => b -> b+evalReverseBits b = revLoop b 0 (0 `asTypeOf` b)+  where+    bSz = bitSize b+    revLoop x i n | i >= bSz    = n+                  | testBit x i = revLoop x (i+1) (setBit n (bSz - i - 1))+                  | otherwise   = revLoop x (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 x t i n | i Prelude.< 0            = n+                     | testBit x i Prelude./= t = n+                     | otherwise                = scanLoop x t (i-1) (n+1)++evalBitCount :: Bits b => b -> WordN+evalBitCount b = loop b (bitSize b - 1) 0+  where+    loop x i n | i Prelude.< 0 = n+               | testBit x i   = loop x (i-1) (n+1)+               | otherwise     = loop x (i-1) n++instance Equality BITS where equal = equalDefault; exprHash = exprHashDefault+instance Render   BITS where renderArgs = renderArgsDefault+instance ToTree   BITS+instance Eval     BITS where evaluate = evaluateDefault+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 :|| Type)+  where+    sizeProp (C' BAnd) (WrapFull a :* WrapFull b :* Nil) = rangeAnd (infoSize a) (infoSize b)+    sizeProp (C' BOr) (WrapFull a :* WrapFull b :* Nil) = rangeOr (infoSize a) (infoSize b)+    sizeProp (C' BXor) (WrapFull a :* WrapFull b :* Nil) = rangeXor (infoSize a) (infoSize b)++    sizeProp (C' ShiftLU) (WrapFull a :* WrapFull b :* Nil) = rangeShiftLU (infoSize a) (infoSize b)+    sizeProp (C' ShiftRU) (WrapFull a :* WrapFull b :* Nil) = rangeShiftRU (infoSize a) (infoSize b)++    sizeProp (C' Complement) (WrapFull a :* Nil) = rangeComplement (infoSize a)++    sizeProp a@(C' _) args = sizePropDefault a args+++instance ( (BITS  :|| Type) :<: dom+         , (Logic :|| Type) :<: dom+         , (EQ    :|| Type) :<: dom+         , (ORD   :|| Type) :<: dom+         , OptimizeSuper dom+         )+      => Optimize (BITS :|| Type) dom+  where+    constructFeatOpt (C' 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 (C' 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 (C' BXor) (a :* b :* Nil)+        | Just 0 <- viewLiteral a              = return b+        | Just x <- viewLiteral a, isAllOnes x = constructFeat (c' Complement) (b :* Nil)+        | Just 0 <- viewLiteral b              = return a+        | Just x <- viewLiteral b, isAllOnes x = constructFeat (c' Complement) (a :* Nil)++    constructFeatOpt (C' BXor) ((xo :$ v1 :$ v2) :* v3 :* Nil)+        | Just (C' BXor) <- prjF xo+        , alphaEq v2 v3+        = return v1++    constructFeatOpt (C' TestBit) ((xo :$ v1 :$ v2) :* v3 :* Nil)+        | Just (C' BXor) <- prjF xo+        , Just a <- viewLiteral v2+        , Just b <- viewLiteral v3+        , a == 2 ^ b+        = do tb <- constructFeat (c' TestBit) (v1 :* v3 :* Nil)+             constructFeat (c' Not) (tb :* Nil)++    constructFeatOpt x@(C' ShiftLU)  args = optZero x args+    constructFeatOpt x@(C' ShiftRU)  args = optZero x args+    constructFeatOpt x@(C' ShiftL)   args = optZero x args+    constructFeatOpt x@(C' ShiftR)   args = optZero x args+    constructFeatOpt x@(C' RotateLU) args = optZero x args+    constructFeatOpt x@(C' RotateRU) args = optZero x args+    constructFeatOpt x@(C' RotateL)  args = optZero x args+    constructFeatOpt x@(C' RotateR)  args = optZero x args++    constructFeatOpt feat args = constructFeatUnOpt feat args++    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+++isAllOnes :: (Num a, Bits a) => a -> Bool+isAllOnes x = x Prelude.== complement 0++optZero :: ( Eq b, Num b+           , (Literal :|| Type) :<: dom+           , Typeable a+           , Optimize feature dom+           )+        => feature (a :-> (b :-> Full a))+        -> Args (AST (Decor Info (dom :|| Typeable))) (a :-> (b :-> Full a))+        -> Opt (AST (Decor Info (dom :|| Typeable)) (Full a))+optZero f (a :* b :* Nil)+    | Just 0 <- viewLiteral b = return a+    | otherwise               = constructFeatUnOpt f (a :* b :* Nil)+
+ src/Feldspar/Core/Constructs/Complex.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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.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 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 Equality COMPLEX where equal = equalDefault; exprHash = exprHashDefault+instance Render   COMPLEX where renderArgs = renderArgsDefault+instance ToTree   COMPLEX+instance Eval     COMPLEX where evaluate = evaluateDefault+instance EvalBind COMPLEX where evalBindSym = evalBindSymDefault+instance Sharable COMPLEX++instance SizeProp (COMPLEX :|| Type)+  where+    sizeProp (C' s) = sizePropDefault s++instance AlphaEq dom dom dom env => AlphaEq COMPLEX COMPLEX dom env+  where+    alphaEqSym = alphaEqSymDefault++instance ( (COMPLEX :|| Type) :<: dom+         , OptimizeSuper dom)+      => Optimize (COMPLEX :|| Type) dom+  where+    constructFeatOpt (C' MkComplex) ((rp :$ a) :* (ip :$ b) :* Nil)+        | Just (C' RealPart) <- prjF rp+        , Just (C' ImagPart) <- prjF ip+        , alphaEq a b+        = return a++    constructFeatOpt (C' RealPart) ((mkc :$ r :$ _) :* Nil)+        | Just (C' MkComplex) <- prjF mkc+        = return r++    constructFeatOpt (C' ImagPart) ((mkc :$ _ :$ i) :* Nil)+        | Just (C' MkComplex) <- prjF mkc+        = return i++    constructFeatOpt (C' MkPolar) ((mag :$ a) :* (ph :$ b) :* Nil)+        | Just (C' Magnitude) <- prjF mag+        , Just (C' Phase)     <- prjF ph+        , alphaEq a b+        = return a++    constructFeatOpt (C' Magnitude) ((mkp :$ m :$ _) :* Nil)+        | Just (C' MkPolar) <- prjF mkp+        = return m++    constructFeatOpt (C' Phase) ((mkp :$ _ :$ p) :* Nil)+        | Just (C' MkPolar) <- prjF mkp+        = return p++    constructFeatOpt (C' Conjugate) ((conj :$ a) :* Nil)+        | Just (C' Conjugate) <- prjF conj+        = return a++    constructFeatOpt sym args = constructFeatUnOpt sym args++    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+
+ src/Feldspar/Core/Constructs/Condition.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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++instance SizeProp (Condition :|| Type)+  where+    sizeProp (C' Condition) (_ :* WrapFull t :* WrapFull f :* Nil)+        = infoSize t \/ infoSize f++instance ( (Condition :|| Type) :<: dom+         , (Logic     :|| Type) :<: dom+         , OptimizeSuper dom+         )+      => Optimize (Condition :|| Type) dom+  where+    constructFeatOpt (C' Condition) (c :* t :* f :* Nil)+        | Just c' <- viewLiteral c = return $ if c' then t else f++    constructFeatOpt (C' Condition) (_ :* t :* f :* Nil)+        | alphaEq t f = return t++    constructFeatOpt cond@(C' Condition) ((op :$ c) :* t :* f :* Nil)+        | Just (C' Not) <- prjF op+        = constructFeat cond (c :* f :* t :* Nil)++    constructFeatOpt a args = constructFeatUnOpt a args++    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x++      -- TODO Propagate size information from the condition to the branches. For+      --      example+      --+      --        condition (x<10) (min x 20) x  ==>  x+
+ src/Feldspar/Core/Constructs/ConditionM.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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 Language.Syntactic+import Language.Syntactic.Constructs.Binding++import Feldspar.Core.Types+import Feldspar.Core.Interpretation+import Feldspar.Core.Constructs.Logic++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 Semantic (ConditionM m)+  where+    semantics ConditionM = Sem "if" ifM+      where+        ifM cond e t = if cond then e else t++instance Equality (ConditionM m) where equal = equalDefault; exprHash = exprHashDefault+instance Render   (ConditionM m) where renderArgs = renderArgsDefault+instance ToTree   (ConditionM m)+instance Eval     (ConditionM m) where evaluate = evaluateDefault+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 :|| Type) :<: dom+         , OptimizeSuper 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 (C' Not) <- prjF 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+
+ src/Feldspar/Core/Constructs/Conversion.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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.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 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 Equality Conversion where equal = equalDefault; exprHash = exprHashDefault+instance Render   Conversion where renderArgs = renderArgsDefault+instance Eval     Conversion where evaluate = evaluateDefault+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 :|| Type)+  where+    sizeProp (C' F2I)     _ = universal+    sizeProp (C' i2n@I2N) (WrapFull a :* Nil)+        = rangeToSize (resultType i2n) (mapMonotonic toInteger (infoSize a))+    sizeProp (C' B2I)     _ = universal+    sizeProp (C' Round)   _ = universal+    sizeProp (C' Ceiling) _ = universal+    sizeProp (C' Floor)   _ = universal++instance ( (Conversion :|| Type) :<: dom+         , OptimizeSuper dom)+      => Optimize (Conversion :|| Type) dom+  where+    constructFeatOpt (C' i2n@I2N) (a :* Nil)+        | Just TypeEq <- typeEq (resultType i2n) (infoType $ getInfo a)+        = return a++    constructFeatOpt a args = constructFeatUnOpt a args++    constructFeatUnOpt a@(C' _) = constructFeatUnOptDefault a+
+ src/Feldspar/Core/Constructs/Eq.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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 #-}++-- | Implementation of Equality constructs++module Feldspar.Core.Constructs.Eq+where++import Language.Syntactic+import Language.Syntactic.Constructs.Binding++import Feldspar.Range+import Feldspar.Core.Types+import Feldspar.Core.Interpretation++-- | Equality constructs+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 Semantic EQ+  where+    semantics Equal    = Sem "(==)" (==)+    semantics NotEqual = Sem "(/=)" (/=)++instance Equality EQ where equal = equalDefault; exprHash = exprHashDefault+instance Render   EQ where renderArgs = renderArgsDefault+instance ToTree   EQ+instance Eval     EQ where evaluate = evaluateDefault+instance EvalBind EQ where evalBindSym = evalBindSymDefault+instance Sharable EQ++instance AlphaEq dom dom dom env => AlphaEq EQ EQ dom env+  where+    alphaEqSym = alphaEqSymDefault++instance SizeProp (EQ :|| Type)+  where sizeProp a@(C' _) = sizePropDefault a++instance ((EQ :|| Type) :<: dom, OptimizeSuper dom) => Optimize (EQ :|| Type) dom+  where+    constructFeatOpt (C' Equal) (a :* b :* Nil)+        | alphaEq a b+        = return $ literalDecor True++    constructFeatOpt (C' Equal) (a :* b :* Nil)+        | RangeSet ra <- infoRange (getInfo a)+        , RangeSet rb <- infoRange (getInfo b)+        , ra `disjoint` rb+        = return $ literalDecor False++    constructFeatOpt (C' NotEqual) (a :* b :* Nil)+        | alphaEq a b+        = return $ literalDecor False++    constructFeatOpt (C' 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 x@(C' _) = constructFeatUnOptDefault x+
+ src/Feldspar/Core/Constructs/Error.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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.Constructs.Binding++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 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 Equality Error where equal = equalDefault; exprHash = exprHashDefault+instance ToTree   Error+instance Eval     Error where evaluate = evaluateDefault+instance EvalBind Error where evalBindSym = evalBindSymDefault+--instance SizeProp Error where sizeProp = sizePropDefault+instance Sharable Error++instance SizeProp (Error :|| Type)+  where+    sizeProp a@(C' _) = sizePropDefault a++instance AlphaEq dom dom dom env => AlphaEq Error Error dom env+  where+    alphaEqSym = alphaEqSymDefault++instance ((Error :|| Type) :<: dom, Optimize dom dom)+    => Optimize (Error :|| Type) dom+  where+    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+
+ src/Feldspar/Core/Constructs/FFI.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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.Constructs.Binding++import Feldspar.Core.Types+import Feldspar.Core.Interpretation++data FFI a+  where+    ForeignImport :: (Type (DenResult a))+                  => String -> Denotation a -> FFI a++instance Semantic FFI+  where+    semantics (ForeignImport name f) = Sem name f++instance Equality FFI where equal = equalDefault; exprHash = exprHashDefault+instance Render   FFI where renderArgs = renderArgsDefault+instance ToTree   FFI+instance Eval     FFI where evaluate = evaluateDefault+instance EvalBind FFI where evalBindSym = evalBindSymDefault+instance Sharable FFI++instance AlphaEq dom dom dom env => AlphaEq FFI FFI dom env+  where+    alphaEqSym = alphaEqSymDefault++instance SizeProp (FFI :|| Type)+  where+    sizeProp (C' s) = sizePropDefault s++instance ( (FFI :|| Type) :<: dom+         , OptimizeSuper dom+         )+      => Optimize (FFI :|| Type) dom+  where+    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+
+ src/Feldspar/Core/Constructs/Floating.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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.Constructs.Binding++import Feldspar.Core.Types+import Feldspar.Core.Interpretation++data FLOATING a+  where+    Pi      :: (Type a, Floating a) => FLOATING (Full a)+    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 Semantic FLOATING+  where+    semantics Pi      = Sem "pi"      Prelude.pi+    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 Equality FLOATING where equal = equalDefault; exprHash = exprHashDefault+instance Render   FLOATING where renderArgs = renderArgsDefault+instance ToTree   FLOATING+instance Eval     FLOATING where evaluate = evaluateDefault+instance EvalBind FLOATING where evalBindSym = evalBindSymDefault+instance Sharable FLOATING++instance SizeProp (FLOATING :|| Type)+  where+    sizeProp (C' s) = sizePropDefault s++instance AlphaEq dom dom dom env => AlphaEq FLOATING FLOATING dom env+  where+    alphaEqSym = alphaEqSymDefault++instance ( (FLOATING :|| Type) :<: dom+         , OptimizeSuper dom)+      => Optimize (FLOATING :|| Type) dom+  where+    constructFeatUnOpt a@(C' _) = constructFeatUnOptDefault a+
+ src/Feldspar/Core/Constructs/Fractional.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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.Constructs.Binding++import Feldspar.Core.Types+import Feldspar.Core.Interpretation+import Feldspar.Core.Constructs.Num++data FRACTIONAL a+  where+    DivFrac :: (Type a, Fractional a) => FRACTIONAL (a :-> a :-> Full a)++instance Semantic FRACTIONAL+  where+    semantics DivFrac = Sem "(/)" (/)++instance Equality FRACTIONAL where equal = equalDefault; exprHash = exprHashDefault+instance Render   FRACTIONAL where renderArgs = renderArgsDefault+instance ToTree   FRACTIONAL+instance Eval     FRACTIONAL where evaluate = evaluateDefault+instance EvalBind FRACTIONAL where evalBindSym = evalBindSymDefault+instance Sharable FRACTIONAL++instance SizeProp (FRACTIONAL :|| Type)+  where+    sizeProp (C' s) = sizePropDefault s++instance AlphaEq dom dom dom env => AlphaEq FRACTIONAL FRACTIONAL dom env+  where+    alphaEqSym = alphaEqSymDefault++instance ( (FRACTIONAL :|| Type) :<: dom+         , (NUM :|| Type) :<: dom+         , OptimizeSuper dom)+      => Optimize (FRACTIONAL :|| Type) dom+  where+    constructFeatOpt (C' DivFrac) (a :* b :* Nil)+        | Just 1 <- viewLiteral b = return a+        | alphaEq a b = return $ literalDecor 1++    constructFeatOpt (C' DivFrac) ((op :$ a :$ b) :* c :* Nil)+        | Just (C' Mul) <- prjF op+        , alphaEq b c+        = return a++    constructFeatOpt (C' DivFrac) ((op :$ a :$ b) :* c :* Nil)+        | Just (C' Mul) <- prjF op+        , alphaEq a c+        = return b++    constructFeatOpt a args = constructFeatUnOpt a args++    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+
+ src/Feldspar/Core/Constructs/Future.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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.Future where++import Language.Syntactic++import Feldspar.Core.Types+import Feldspar.Core.Interpretation+import Feldspar.Core.Constructs.Binding++data FUTURE a where+  MkFuture :: Type a => FUTURE (a :-> Full (FVal a))+  Await    :: Type a => FUTURE (FVal a :-> Full a)++instance Semantic FUTURE+  where+    semantics MkFuture = Sem "future" FVal+    semantics Await    = Sem "await"  unFVal++instance Equality FUTURE where equal = equalDefault; exprHash = exprHashDefault+instance Render   FUTURE where renderArgs = renderArgsDefault+instance ToTree   FUTURE+instance Eval     FUTURE where evaluate = evaluateDefault+instance EvalBind FUTURE where evalBindSym = evalBindSymDefault+instance Sharable FUTURE++instance AlphaEq dom dom dom env => AlphaEq FUTURE FUTURE dom env+  where+    alphaEqSym = alphaEqSymDefault++instance SizeProp (FUTURE :|| Type)+  where+    sizeProp (C' MkFuture) (WrapFull a :* Nil) = infoSize a+    sizeProp (C' Await)    (WrapFull a :* Nil) = infoSize a++instance ( (FUTURE :|| Type) :<: dom+         , OptimizeSuper dom+         )+      => Optimize (FUTURE :|| Type) dom+  where+    constructFeatOpt (C' Await) ((op :$ a) :* Nil)+      | Just (C' MkFuture) <- prjF op+      = return a++    constructFeatOpt (C' MkFuture) ((op :$ a) :* Nil)+      | Just (C' Await) <- prjF op+      = return a++    constructFeatOpt feature args = constructFeatUnOpt feature args++    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+
+ src/Feldspar/Core/Constructs/Integral.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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.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+import Feldspar.Core.Constructs.Logic++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 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 Equality INTEGRAL where equal = equalDefault; exprHash = exprHashDefault+instance Render   INTEGRAL where renderArgs = renderArgsDefault+instance ToTree   INTEGRAL+instance Eval     INTEGRAL where evaluate = evaluateDefault+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 :|| Type)+  where+    sizeProp (C' Quot) (WrapFull a :* WrapFull b :* Nil) = rangeQuot (infoSize a) (infoSize b)+    sizeProp (C' Rem)  (WrapFull a :* WrapFull b :* Nil) = rangeRem (infoSize a) (infoSize b)+    sizeProp (C' Div)  (WrapFull a :* WrapFull b :* Nil) = rangeDiv (infoSize a) (infoSize b)+    sizeProp (C' Mod)  (WrapFull a :* WrapFull b :* Nil) = rangeMod (infoSize a) (infoSize b)+    sizeProp (C' Exp)  (WrapFull a :* WrapFull b :* Nil) = rangeExp (infoSize a) (infoSize b)++instance+    ( (INTEGRAL  :||Type) :<: dom+    , (BITS      :||Type) :<: dom+    , (NUM       :||Type) :<: dom+    , (EQ        :||Type) :<: dom+    , (ORD       :||Type) :<: dom+    , (Condition :||Type) :<: dom+    , (Logic     :||Type) :<: dom+    , OptimizeSuper dom+    , Optimize (Condition :|| Type) dom+    ) =>+      Optimize (INTEGRAL :|| Type) dom+  where+    constructFeatOpt (C' Quot) (a :* b :* Nil)+        | Just 1 <- viewLiteral b = return a++    constructFeatOpt (C' 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 (c' ShiftR) (a :* lLit :* Nil)+            else do+                aIsNeg  <- constructFeat (c' LTH) (a :* literalDecor 0 :* Nil)+                a'      <- constructFeat (c' Add) (a :* literalDecor (2^l-1) :* Nil)+                negCase <- constructFeat (c' ShiftR) (a' :* lLit :* Nil)+                posCase <- constructFeat (c' ShiftR) (a :* lLit :* Nil)+                constructFeat (c' Condition)+                    (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 (C' Rem) (a :* b :* Nil)+        | rangeLess sza szb+        , isNatural sza+        = return a+      where+        sza = infoSize $ getInfo a+        szb = infoSize $ getInfo b++    constructFeatOpt (C' Div) (a :* b :* Nil)+        | Just 1 <- viewLiteral b = return a++    constructFeatOpt (C' Div) (a :* b :* Nil)+        | Just b' <- viewLiteral b+        , b' > 0+        , isPowerOfTwo b'+        = constructFeat (c' ShiftR) (a :* literalDecor (log2 b') :* Nil)++    constructFeatOpt (C' Div) (a :* b :* Nil)+        | sameSign (infoSize (getInfo a)) (infoSize (getInfo b))+        = constructFeat (c' Quot) (a :* b :* Nil)++    constructFeatOpt (C' Mod) (a :* b :* Nil)+        | rangeLess sza szb+        , isNatural sza+        = return a+      where+        sza = infoSize $ getInfo a+        szb = infoSize $ getInfo b++    constructFeatOpt (C' Mod) (a :* b :* Nil)+        | sameSign (infoSize (getInfo a)) (infoSize (getInfo b))+        = constructFeat (c' Rem) (a :* b :* Nil)++    constructFeatOpt (C' 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 (C' Exp) (a :* b :* Nil)+        | Just (-1) <- viewLiteral a = do+            bLSB    <- constructFeat (c' BAnd) (b :* literalDecor 1 :* Nil)+            bIsEven <- constructFeat (c' Equal) (bLSB :* literalDecor 0 :* Nil)  -- TODO Use testBit? (remove EQ :<: dom and import)+            constructFeat (c' Condition)+                (bIsEven :* literalDecor 1 :* literalDecor (-1) :* Nil)++    constructFeatOpt a args = constructFeatUnOpt a args++    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x++-- Auxiliary functions++-- shouldn't be used for negative numbers+isPowerOfTwo :: (Num a, Bits a) => a -> Bool+isPowerOfTwo x = x .&. (x - 1) == 0 && (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+
+ src/Feldspar/Core/Constructs/Literal.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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++import Data.Typeable+import Debug.Trace++instance Sharable Literal+  where+    sharable (Literal a) = typeRepTyCon (typeOf a) == typeRepTyCon (typeOf [()])++instance SizeProp (Literal :|| Type)+  where+    sizeProp lit@(C' (Literal a)) Nil = sizeOf a++instance ((Literal :|| Type) :<: dom, OptimizeSuper dom) =>+    Optimize (Literal :|| Type) dom+  where+    constructFeatUnOpt l@(C' _) = constructFeatUnOptDefault l+
+ src/Feldspar/Core/Constructs/Logic.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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 #-}++-- | Implementation of Logic constructs+--+module Feldspar.Core.Constructs.Logic+    ( Logic (..)+    ) where++++import Language.Syntactic+import Language.Syntactic.Constructs.Binding++import Feldspar.Core.Types+import Feldspar.Core.Interpretation+import Feldspar.Core.Constructs.Eq+import Feldspar.Core.Constructs.Ord+++-- | Logic constructs+data Logic a+  where+    And :: Logic (Bool :-> Bool :-> Full Bool)+    Or  :: Logic (Bool :-> Bool :-> Full Bool)+    Not :: Logic (Bool :->          Full Bool)++instance Semantic Logic+  where+    semantics And = Sem "(&&)" (&&)+    semantics Or  = Sem "(||)" (||)+    semantics Not = Sem "not"  not++instance Equality Logic where equal = equalDefault; exprHash = exprHashDefault+instance Render   Logic where renderArgs = renderArgsDefault+instance ToTree   Logic+instance Eval     Logic where evaluate = evaluateDefault+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 SizeProp (Logic :|| Type)+  where+    sizeProp a@(C' _) args = sizePropDefault a args++instance ( (Logic :|| Type) :<: dom+         , (EQ    :|| Type) :<: dom+         , (ORD   :|| Type) :<: dom+         , OptimizeSuper dom+         )+      => Optimize (Logic :|| Type) dom+  where+    constructFeatOpt (C' 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 (C' 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 (C' Not) ((op :$ a) :* Nil)+        | Just (C' Not) <- prjF op = return a++    constructFeatOpt (C' Not) ((op :$ a :$ b) :* Nil)+        | Just (C' Equal)    <- prjF op = constructFeat (c' NotEqual) (a :* b :* Nil)+        | Just (C' NotEqual) <- prjF op = constructFeat (c' Equal)    (a :* b :* Nil)+        | Just (C' LTH)      <- prjF op = constructFeat (c' GTE)      (a :* b :* Nil)+        | Just (C' GTH)      <- prjF op = constructFeat (c' LTE)      (a :* b :* Nil)+        | Just (C' LTE)      <- prjF op = constructFeat (c' GTH)      (a :* b :* Nil)+        | Just (C' GTE)      <- prjF op = constructFeat (c' LTH)      (a :* b :* Nil)++    constructFeatOpt a args = constructFeatUnOpt a args++    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+
+ src/Feldspar/Core/Constructs/Loop.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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 Data.Typeable++import Control.Monad (forM_, when)++import Language.Syntactic+import Language.Syntactic.Constructs.Binding hiding (betaReduce)+import Language.Syntactic.Constructs.Binding.HigherOrder (CLambda)++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 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 initial _    = initial+        forLoop l initial body = foldl (flip body) initial [0..l-1]+    semantics WhileLoop = Sem "whileLoop" whileLoop+      where+        whileLoop initial cond body = go initial+          where+            go st | cond st   = go $ body st+                  | otherwise = st++instance Monad m => Equality (LoopM m) where equal = equalDefault; exprHash = exprHashDefault+instance Monad m => Render   (LoopM m) where renderArgs = renderArgsDefault+instance Monad m => ToTree   (LoopM m)+instance Monad m => Eval     (LoopM m) where evaluate = evaluateDefault+instance Monad m => EvalBind (LoopM m) where evalBindSym = evalBindSymDefault+instance Sharable (LoopM m)+  -- Will not be shared anyway, because 'maybeWitnessSat' returns 'Nothing'++instance Equality Loop where equal = equalDefault; exprHash = exprHashDefault+instance Render   Loop where renderArgs = renderArgsDefault+instance ToTree   Loop+instance Eval     Loop where evaluate = evaluateDefault+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 :|| Type)+  where+    sizeProp (C' ForLoop)   (_ :* _ :* WrapFull step :* Nil) = infoSize step+    sizeProp (C' WhileLoop) (_ :* _ :* WrapFull step :* Nil) = infoSize step+++instance ( MonadType m+         , LoopM m :<: dom+         , CLambda Type :<: 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 ( (Literal  :|| Type) :<: dom+         , (Loop     :|| Type) :<: dom+         , (Variable :|| Type) :<: dom+         , CLambda Type :<: dom+         , OptimizeSuper dom+         )+      => Optimize (Loop :|| Type) dom+  where+    optimizeFeat sym@(C' ForLoop) (len :* initial :* step :* Nil) = do+        len'  <- optimizeM len+        init' <- optimizeM initial+        let szI     = infoSize (getInfo len')+            ixRange = Range 0 (upperBound szI-1)+        step' <- optimizeFunction+            (optimizeFunction optimizeM (mkInfoTy typeRep))+            -- (optimizeFunctionFix optimizeM (getInfo init'))+            -- TODO The above optimization is unsound, as shown by the following+            --      program:+            --+            --        drawAST $ fold max (value minBound) -:: tVec1 tWordN >-> id+            (mkInfo ixRange)+            step+        constructFeat sym (len' :* init' :* step' :* Nil)++    optimizeFeat sym@(C' WhileLoop) (initial :* cond :* body :* Nil) = do+        init' <- optimizeM initial+        body' <- optimizeFunction optimizeM (mkInfoTy typeRep) body+        -- body' <- optimizeFunctionFix optimizeM info body+        -- TODO See comment above++        let info  = getInfo init'+        let info' = info { infoSize = infoSize (getInfo body') }+        cond' <- optimizeFunction optimizeM info' cond+        constructFeat sym (init' :* cond' :* body' :* Nil)++{-+    constructFeatOpt (C' ForLoop) (len :* initial :* step :* Nil)+        | Just 0 <- viewLiteral len = return initial+        | Just 1 <- viewLiteral len = do+          let init' = stripDecor initial+              step' = stripDecor step+          optimizeM $ betaReduce init' $ betaReduce (appSym (c' (Literal 0))) step'+        -- TODO add an optional unroll limit?++      -- ForLoop len init (const id) ==> init+    constructFeatOpt (C' ForLoop) (_ :* initial :* step :* Nil)+        | alphaEq step' (fun `asTypeOf` step') = optimizeM $ stripDecor initial+      where+        step' = stripDecor step+        fun = appSym (Lambda 0) $ appSym (Lambda 1) $ appSym (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 x@(C' _) = constructFeatUnOptDefault x+
+ src/Feldspar/Core/Constructs/Mutable.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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 Language.Syntactic+import Language.Syntactic.Constructs.Binding+import Language.Syntactic.Constructs.Binding.HigherOrder+import Language.Syntactic.Constructs.Monad++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 Semantic Mutable+  where+    semantics Run = Sem "runMutable" unsafePerformIO++instance Equality Mutable where equal = equalDefault; exprHash = exprHashDefault+instance Render   Mutable where renderArgs = renderArgsDefault+instance ToTree   Mutable+instance Eval     Mutable where evaluate = evaluateDefault+instance EvalBind Mutable where evalBindSym = evalBindSymDefault+instance Sharable Mutable++instance Typed Mutable+  where+    typeDictSym Run = Just Dict++instance AlphaEq dom dom dom env => AlphaEq Mutable Mutable dom env+  where+    alphaEqSym = alphaEqSymDefault++instance Sharable (MONAD Mut)++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 :: P Mut+monadProxy = P++instance ( MONAD Mut :<: dom+         , (Variable :|| Type) :<: dom+         , CLambda Type :<: dom+         , OptimizeSuper 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 (SubConstr2 (Lambda v1)) <- prjLambda lam+      , Just Return                   <- prjMonad monadProxy ret+      , Just (C' (Variable v2))       <- prjF var+      , v1 == v2+      , Just ma' <- gcast ma+      = return ma'++    constructFeatOpt Bind (ma :* (lam :$ body) :* Nil)+        | Just (SubConstr2 (Lambda v)) <- prjLambda 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, OptimizeSuper dom) => Optimize Mutable dom+  where+    constructFeatUnOpt Run args = constructFeatUnOptDefault Run args+
+ src/Feldspar/Core/Constructs/MutableArray.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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.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 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 Equality MutableArray where equal = equalDefault; exprHash = exprHashDefault+instance Render   MutableArray where renderArgs = renderArgsDefault+instance ToTree   MutableArray+instance Eval     MutableArray where evaluate = evaluateDefault+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 :* _ :* 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+
+ src/Feldspar/Core/Constructs/MutableReference.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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.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 Semantic MutableReference+  where+    semantics NewRef = Sem "newRef" newIORef+    semantics GetRef = Sem "getRef" readIORef+    semantics SetRef = Sem "setRef" writeIORef++instance Equality MutableReference where equal = equalDefault; exprHash = exprHashDefault+instance Render   MutableReference where renderArgs = renderArgsDefault+instance ToTree   MutableReference+instance Eval     MutableReference where evaluate = evaluateDefault+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+
+ src/Feldspar/Core/Constructs/MutableToPure.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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 CPP #-}++module Feldspar.Core.Constructs.MutableToPure+    ( MutableToPure (..)+    ) where++import qualified Control.Exception as C+import Data.Array.IArray+#if __GLASGOW_HASKELL__>=704+import Data.Array.MArray (freeze)+import Data.Array.Unsafe (unsafeFreeze)+#else+import Data.Array.MArray (freeze, unsafeFreeze)+#endif+import System.IO.Unsafe++import Language.Syntactic+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 Semantic MutableToPure+  where+    semantics RunMutableArray = Sem "runMutableArray" runMutableArrayEval+    semantics WithArray       = Sem "withArray"       withArrayEval++runMutableArrayEval :: forall a . Mut (MArr a) -> [a]+runMutableArrayEval m = unsafePerformIO $+                        do marr <- m+                           iarr <- unsafeFreeze marr+                           return (elems (iarr :: Array WordN a))++withArrayEval :: forall 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 Equality MutableToPure where equal = equalDefault; exprHash = exprHashDefault+instance Render   MutableToPure where renderArgs = renderArgsDefault+instance ToTree   MutableToPure+instance Eval     MutableToPure where evaluate = evaluateDefault+instance EvalBind MutableToPure where evalBindSym = evalBindSymDefault+instance Sharable MutableToPure++instance Typed MutableToPure+  where+    typeDictSym RunMutableArray = Just Dict+    typeDictSym _ = Nothing+++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+
+ src/Feldspar/Core/Constructs/NoInline.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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.NoInline where++import Language.Syntactic+import Language.Syntactic.Constructs.Binding++import Feldspar.Core.Types+import Feldspar.Core.Interpretation++data NoInline a+  where+    NoInline :: (Type a) => NoInline (a :-> Full a)++instance Semantic NoInline+  where+    semantics NoInline  = Sem "NoInline" id++instance Equality NoInline where equal = equalDefault; exprHash = exprHashDefault+instance Render   NoInline where renderArgs = renderArgsDefault+instance ToTree   NoInline+instance Eval     NoInline where evaluate = evaluateDefault+instance EvalBind NoInline where evalBindSym = evalBindSymDefault+instance Sharable NoInline++instance SizeProp (NoInline :|| Type)+  where+    sizeProp (C' s) = sizePropDefault s++instance AlphaEq dom dom dom env => AlphaEq NoInline NoInline dom env+  where+    alphaEqSym = alphaEqSymDefault++instance ( (NoInline :|| Type) :<: dom+         , OptimizeSuper dom)+      => Optimize (NoInline :|| Type) dom+  where+    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+
+ src/Feldspar/Core/Constructs/Num.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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.Constructs.Binding++import Feldspar.Range+import Feldspar.Core.Types+import Feldspar.Core.Interpretation+import Feldspar.Core.Constructs.Literal+++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 Semantic NUM+  where+    semantics Abs  = Sem "abs" abs+    semantics Sign = Sem "signum" signum+    semantics Add  = Sem "(+)" (+)+    semantics Sub  = Sem "(-)" (-)+    semantics Mul  = Sem "(*)" (*)++instance Equality NUM where equal = equalDefault; exprHash = exprHashDefault+instance Render   NUM where renderArgs = renderArgsDefault+instance ToTree   NUM+instance Eval     NUM where evaluate = evaluateDefault+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 :|| Type)+  where+    sizeProp (C' Abs)  (WrapFull a :* Nil)               = abs (infoSize a)+    sizeProp (C' Sign) (WrapFull a :* Nil)               = signum (infoSize a)+    sizeProp (C' Add)  (WrapFull a :* WrapFull b :* Nil) = infoSize a + infoSize b+    sizeProp (C' Sub)  (WrapFull a :* WrapFull b :* Nil) = infoSize a - infoSize b+    sizeProp (C' Mul)  (WrapFull a :* WrapFull b :* Nil) = infoSize a * infoSize b+++instance ( (NUM     :|| Type) :<: dom+         , (Literal :|| Type) :<: dom+         , OptimizeSuper dom+         )+      => Optimize (NUM :|| Type) dom+  where+    constructFeatOpt (C' Abs) (a :* Nil)+        | RangeSet r <- infoRange (getInfo a)+        , isNatural r+        = return a++    constructFeatOpt (C' Sign) (a :* Nil)+        | RangeSet ra <- infoRange (getInfo a)+        , 0 `rangeLess` ra+        = return (literalDecor 1)++    constructFeatOpt (C' Sign) (a :* Nil)+        | RangeSet ra <- infoRange (getInfo a)+        , ra `rangeLess` 0+        = return (literalDecor (-1))++    constructFeatOpt (C' Add) (a :* b :* Nil)+        | Just 0 <- viewLiteral b = return a+        | Just 0 <- viewLiteral a = return b+        | alphaEq a b = constructFeatOpt (c' Mul) (a :* literalDecor 2 :* Nil)++    constructFeatOpt s@(C' Add) (a :* (op :$ b :$ c) :* Nil)+        | Just a'      <- viewLiteral a+        , Just (C' Add) <- prjF op+        , Just c'      <- viewLiteral c+        = constructFeat s (b :* literalDecor (a'+c') :* Nil)++    constructFeatOpt s@(C' Add) (a :* (op :$ b :$ c) :* Nil)+        | Just a'      <- viewLiteral a+        , Just (C' Sub) <- prjF op+        , Just c'      <- viewLiteral c+        = constructFeat s (b :* literalDecor (a'-c') :* Nil)++    constructFeatOpt s@(C' Add) ((op :$ a :$ b) :* c :* Nil)+        | Just c'      <- viewLiteral c+        , Just (C' Add) <- prjF op+        , Just b'      <- viewLiteral b+        = constructFeat s (a :* literalDecor (b'+c') :* Nil)++    constructFeatOpt s@(C' Add) ((op :$ a :$ b) :* c :* Nil)+        | Just c'      <- viewLiteral c+        , Just (C' Sub) <- prjF op+        , Just b'      <- viewLiteral b+        = constructFeat s (a :* literalDecor (c'-b') :* Nil)++    constructFeatOpt (C' Add) ((op1 :$ a :$ b) :* (op2 :$ c :$ d) :* Nil)+        | Just (C' Add) <- prjF op1+        , Just (C' Add) <- prjF op2+        , Just b'      <- viewLiteral b+        , Just d'      <- viewLiteral d+        = do+            ac <- constructFeat (c' Add) (a :* c :* Nil)+            constructFeat (c' Add) (ac :* literalDecor (b'+d') :* Nil)++    constructFeatOpt (C' Add) ((op1 :$ a :$ b) :* (op2 :$ c :$ d) :* Nil)+        | Just (C' Add) <- prjF op1+        , Just (C' Sub) <- prjF op2+        , alphaEq a c+        , alphaEq b d+        = constructFeat (c' Add) (a :* c :* Nil)++    constructFeatOpt (C' Sub) ((op1 :$ a :$ b) :* (op2 :$ c :$ d) :* Nil)+        | Just (C' Add) <- prjF op1+        , Just (C' Sub) <- prjF op2+        , alphaEq a c+        , alphaEq b d+        = constructFeat (c' Add) (b :* d :* Nil)++    constructFeatOpt (C' Sub) (a :* b :* Nil)+        | Just 0 <- viewLiteral b = return a+        | alphaEq a b             = return $ literalDecor 0++    constructFeatOpt (C' 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 s@(C' Mul) (a :* (op :$ b :$ c) :* Nil)+        | Just a'      <- viewLiteral a+        , Just (C' Mul) <- prjF op+        , Just c'      <- viewLiteral c+        = constructFeat s (b :* literalDecor (a'*c') :* Nil)++    constructFeatOpt s@(C' Mul) ((op :$ a :$ b) :* c :* Nil)+        | Just c'      <- viewLiteral c+        , Just (C' Mul) <- prjF op+        , Just b'      <- viewLiteral b+        = constructFeat s (a :* literalDecor (b'*c') :* Nil)++    constructFeatOpt (C' Mul) ((op1 :$ a :$ b) :* (op2 :$ c :$ d) :* Nil)+        | Just (C' Mul) <- prjF op1+        , Just (C' Mul) <- prjF op2+        , Just b'      <- viewLiteral b+        , Just d'      <- viewLiteral d+        = do+            ac <- constructFeat (c' Mul) (a :* c :* Nil)+            constructFeat (c' Mul) (ac :* literalDecor (b'*d') :* Nil)++    -- Cases to make sure literals end up to the right:+    constructFeatOpt (C' Add) (a :* b :* Nil)+        | Just _ <- viewLiteral a = constructFeatUnOpt (c' Add) (b :* a :* Nil)++    constructFeatOpt (C' Mul) (a :* b :* Nil)+        | Just _ <- viewLiteral a = constructFeatUnOpt (c' Mul) (b :* a :* Nil)++    constructFeatOpt a args = constructFeatUnOpt a args++    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x
+ src/Feldspar/Core/Constructs/Ord.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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 #-}++-- | Implementation of ordering constructs++module Feldspar.Core.Constructs.Ord+    ( ORD (..)+    ) where++++import Language.Syntactic+import Language.Syntactic.Constructs.Binding++import Feldspar.Range+import Feldspar.Core.Types+import Feldspar.Core.Interpretation+++-- | Ordering constructs+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 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 Equality ORD where equal = equalDefault; exprHash = exprHashDefault+instance Render   ORD where renderArgs = renderArgsDefault+instance ToTree   ORD+instance Eval     ORD where evaluate = evaluateDefault+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 :|| Type)+  where+    sizeProp (C' Min) (WrapFull a :* WrapFull b :* Nil) = min (infoSize a) (infoSize b)+    sizeProp (C' Max) (WrapFull a :* WrapFull b :* Nil) = max (infoSize a) (infoSize b)+    sizeProp a@(C' _) args = sizePropDefault a args+++instance ( (ORD :|| Type) :<: dom+         , OptimizeSuper dom+         )+      => Optimize (ORD :|| Type) dom+  where+    constructFeatOpt (C' LTH) (a :* b :* Nil)+        | RangeSet ra <- infoRange (getInfo a)+        , RangeSet rb <- infoRange (getInfo b)+        , ra `rangeLess` rb+        = return (literalDecor True)++    constructFeatOpt (C' LTH) (a :* b :* Nil)+        | RangeSet ra <- infoRange (getInfo a)+        , RangeSet rb <- infoRange (getInfo b)+        , rb `rangeLessEq` ra+        = return (literalDecor False)++    constructFeatOpt (C' GTH) (a :* b :* Nil)+        | RangeSet ra <- infoRange (getInfo a)+        , RangeSet rb <- infoRange (getInfo b)+        , rb `rangeLess` ra+        = return (literalDecor True)++    constructFeatOpt (C' GTH) (a :* b :* Nil)+        | RangeSet ra <- infoRange (getInfo a)+        , RangeSet rb <- infoRange (getInfo b)+        , ra `rangeLessEq` rb+        = return (literalDecor False)++    constructFeatOpt (C' LTE) (a :* b :* Nil)+        | RangeSet ra <- infoRange (getInfo a)+        , RangeSet rb <- infoRange (getInfo b)+        , ra `rangeLessEq` rb+        = return (literalDecor True)++    constructFeatOpt (C' LTE) (a :* b :* Nil)+        | RangeSet ra <- infoRange (getInfo a)+        , RangeSet rb <- infoRange (getInfo b)+        , rb `rangeLess` ra+        = return (literalDecor False)++    constructFeatOpt (C' LTE) (a :* b :* Nil)+        | alphaEq a b+        = return $ literalDecor True++    constructFeatOpt (C' GTE) (a :* b :* Nil)+        | RangeSet ra <- infoRange (getInfo a)+        , RangeSet rb <- infoRange (getInfo b)+        , rb `rangeLessEq` ra+        = return (literalDecor True)++    constructFeatOpt (C' GTE) (a :* b :* Nil)+        | RangeSet ra <- infoRange (getInfo a)+        , RangeSet rb <- infoRange (getInfo b)+        , ra `rangeLess` rb+        = return (literalDecor False)++    constructFeatOpt (C' GTE) (a :* b :* Nil)+        | alphaEq a b+        = return $ literalDecor True++    constructFeatOpt (C' Min) (a :* b :* Nil)+        | RangeSet ra <- infoRange (getInfo a)+        , RangeSet rb <- infoRange (getInfo b)+        , ra `rangeLessEq` rb+        = return a++    constructFeatOpt (C' Min) (a :* b :* Nil)+        | RangeSet ra <- infoRange (getInfo a)+        , RangeSet rb <- infoRange (getInfo b)+        , rb `rangeLessEq` ra+        = return b++    constructFeatOpt (C' Min) (a :* b :* Nil)+        | alphaEq a b+        = return a++    constructFeatOpt (C' Max) (a :* b :* Nil)+        | RangeSet ra <- infoRange (getInfo a)+        , RangeSet rb <- infoRange (getInfo b)+        , ra `rangeLessEq` rb+        = return b++    constructFeatOpt (C' Max) (a :* b :* Nil)+        | RangeSet ra <- infoRange (getInfo a)+        , RangeSet rb <- infoRange (getInfo b)+        , rb `rangeLessEq` ra+        = return a++    constructFeatOpt (C' Max) (a :* b :* Nil)+        | alphaEq a b+        = return a++    constructFeatOpt a args = constructFeatUnOpt a args++    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+
+ src/Feldspar/Core/Constructs/Par.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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.Constructs.Monad+import Language.Syntactic.Constructs.Binding+import Language.Syntactic.Constructs.Binding.HigherOrder++import qualified Control.Monad.Par as CMP+import Control.Monad.Par.Scheds.TraceInternal (yield)++import Feldspar.Lattice+import Feldspar.Core.Types+import Feldspar.Core.Interpretation+import Feldspar.Core.Constructs.Binding++import Data.Map+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" yield++instance Equality ParFeature where equal = equalDefault; exprHash = exprHashDefault+instance Render   ParFeature where renderArgs = renderArgsDefault+instance ToTree   ParFeature+instance Eval     ParFeature where evaluate = evaluateDefault+instance EvalBind ParFeature where evalBindSym = evalBindSymDefault+instance Sharable ParFeature+  -- Will not be shared anyway, because 'maybeWitnessSat' returns '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 :: P Par+monadProxy = P++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+         , (Variable :|| Type) :<: dom+         , CLambda Type :<: dom+         , OptimizeSuper 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 (SubConstr2 (Lambda v1)) <- prjLambda lam+      , Just Return                   <- prjMonad monadProxy ret+      , Just (C' (Variable v2))       <- prjF var+      , v1 == v2+      , Just ma' <- gcast ma+      = return ma'++    constructFeatOpt Bind (ma :* (lam :$ body) :* Nil)+        | Just (SubConstr2 (Lambda v)) <- prjLambda 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+
+ src/Feldspar/Core/Constructs/Save.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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.Constructs.Binding++import Feldspar.Core.Types+import Feldspar.Core.Interpretation++data Save a+  where+    Save :: Type a => Save (a :-> Full a)++instance Semantic Save+  where+    semantics Save = Sem "save" id++instance Equality Save where equal = equalDefault; exprHash = exprHashDefault+instance Render   Save where renderArgs = renderArgsDefault+instance ToTree   Save+instance Eval     Save where evaluate = evaluateDefault+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 :|| Type)+  where+    sizeProp (C' Save) (WrapFull a :* Nil) = infoSize a++instance ( (Save :|| Type) :<: dom+         , OptimizeSuper dom)+      => Optimize (Save :|| Type) dom+  where+    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+
+ src/Feldspar/Core/Constructs/SizeProp.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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.Constructs.Binding++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 Semantic PropSize+  where+    semantics (PropSize _) = Sem "propSize" (const id)++instance Equality PropSize where equal = equalDefault; exprHash = exprHashDefault+instance Render   PropSize where renderArgs = renderArgsDefault+instance ToTree   PropSize+instance Eval     PropSize where evaluate = evaluateDefault+instance EvalBind PropSize where evalBindSym = evalBindSymDefault+instance Sharable PropSize++instance SizeProp (PropSize :|| Type)+  where+    sizeProp (C' (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 :|| Type) :<: dom+         , OptimizeSuper dom)+      => Optimize (PropSize :|| Type) dom+  where+    constructFeatOpt (C' (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 x@(C' _) = constructFeatUnOptDefault x+
+ src/Feldspar/Core/Constructs/SourceInfo.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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)+        (Decor SourceInfo1 Identity)+        dom+        env+  where+    alphaEqSym = alphaEqSymDefault+-}++instance Sharable (Decor SourceInfo1 Identity)+  where+    sharable _ = True++instance SizeProp Identity+  where+    sizeProp Id (WrapFull a :* Nil) = infoSize a++instance SizeProp ((Decor SourceInfo1 Identity) :|| Type)+  where+    sizeProp (C' a) = sizeProp $ decorExpr a++instance ((Decor SourceInfo1 Identity :|| Type) :<: dom, Optimize dom dom) =>+    Optimize ((Decor SourceInfo1 Identity) :|| Type) dom+  where+    optimizeFeat (C' (Decor (SourceInfo1 src) Id)) (a :* Nil) =+        localSource src $ optimizeM a++    constructFeatOpt (C' (Decor (SourceInfo1 _) Id)) (a :* Nil) = return a++    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x++
+ src/Feldspar/Core/Constructs/Trace.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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.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 Semantic Trace+  where+    semantics Trace = Sem "trace" (\i a -> trace (show i ++ ":" ++ show a) a)++instance Constrained Trace+    where+      type Sat Trace = Type+      exprDict Trace = Dict++instance Equality Trace where equal = equalDefault; exprHash = exprHashDefault+instance Render   Trace where renderArgs = renderArgsDefault+instance ToTree   Trace+instance Eval     Trace where evaluate = evaluateDefault+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 :|| Type)+  where+    sizeProp (C' Trace) (WrapFull _ :* WrapFull a :* Nil) = infoSize a++instance ( (Trace :|| Type) :<: dom+         , OptimizeSuper dom)+      => Optimize (Trace :|| Type) dom+  where+    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+
+ src/Feldspar/Core/Constructs/Tuple.hs view
@@ -0,0 +1,323 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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.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++instance SizeProp (Tuple :|| Type)+  where+    sizeProp (C' Tup2) (a :* b :* Nil)+        | WrapFull ia <- a+        , WrapFull ib <- b+        = (infoSize ia, infoSize ib)+    sizeProp (C' Tup3) (a :* b :* c :* Nil)+        | WrapFull ia <- a+        , WrapFull ib <- b+        , WrapFull ic <- c+        = ( infoSize ia+          , infoSize ib+          , infoSize ic+          )+    sizeProp (C' 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 (C' 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 (C' 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 (C' 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+  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 :|| Type)+  where+    sizeProp (C' Sel1) (WrapFull ia :* Nil) =+        sel1Size (infoType ia) (infoSize ia)+    sizeProp (C' Sel2) (WrapFull ia :* Nil) =+        sel2Size (infoType ia) (infoSize ia)+    sizeProp (C' Sel3) (WrapFull ia :* Nil) =+        sel3Size (infoType ia) (infoSize ia)+    sizeProp (C' Sel4) (WrapFull ia :* Nil) =+        sel4Size (infoType ia) (infoSize ia)+    sizeProp (C' Sel5) (WrapFull ia :* Nil) =+        sel5Size (infoType ia) (infoSize ia)+    sizeProp (C' Sel6) (WrapFull ia :* Nil) =+        sel6Size (infoType ia) (infoSize ia)+    sizeProp (C' 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  :|| Type) :<: dom+    , (Select :|| Type) :<: dom+    , OptimizeSuper dom+    ) =>+      Optimize (Tuple :|| Type) dom+  where+    constructFeatOpt (C' tup@Tup2) (s1 :* s2 :* Nil)+        | (prjF -> Just (C' Sel1)) :$ a <- s1+        , (prjF -> Just (C' Sel2)) :$ b <- s2+        , alphaEq a b+        , Just TypeEq <- tupEq tup a+        = return a++    constructFeatOpt (C' tup@Tup3) (s1 :* s2 :* s3 :* Nil)+        | (prjF -> Just (C' Sel1)) :$ a <- s1+        , (prjF -> Just (C' Sel2)) :$ b <- s2+        , (prjF -> Just (C' Sel3)) :$ c <- s3+        , alphaEq a b+        , alphaEq a c+        , Just TypeEq <- tupEq tup a+        = return a++    constructFeatOpt (C' tup@Tup4) (s1 :* s2 :* s3 :* s4 :* Nil)+        | (prjF -> Just (C' Sel1)) :$ a <- s1+        , (prjF -> Just (C' Sel2)) :$ b <- s2+        , (prjF -> Just (C' Sel3)) :$ c <- s3+        , (prjF -> Just (C' Sel4)) :$ d <- s4+        , alphaEq a b+        , alphaEq a c+        , alphaEq a d+        , Just TypeEq <- tupEq tup a+        = return a++    constructFeatOpt (C' tup@Tup5) (s1 :* s2 :* s3 :* s4 :* s5 :* Nil)+        | (prjF -> Just (C' Sel1)) :$ a <- s1+        , (prjF -> Just (C' Sel2)) :$ b <- s2+        , (prjF -> Just (C' Sel3)) :$ c <- s3+        , (prjF -> Just (C' Sel4)) :$ d <- s4+        , (prjF -> Just (C' Sel5)) :$ e <- s5+        , alphaEq a b+        , alphaEq a c+        , alphaEq a d+        , alphaEq a e+        , Just TypeEq <- tupEq tup a+        = return a++    constructFeatOpt (C' tup@Tup6) (s1 :* s2 :* s3 :* s4 :* s5 :* s6 :* Nil)+        | (prjF -> Just (C' Sel1)) :$ a <- s1+        , (prjF -> Just (C' Sel2)) :$ b <- s2+        , (prjF -> Just (C' Sel3)) :$ c <- s3+        , (prjF -> Just (C' Sel4)) :$ d <- s4+        , (prjF -> Just (C' Sel5)) :$ e <- s5+        , (prjF -> Just (C' Sel6)) :$ f <- s6+        , alphaEq a b+        , alphaEq a c+        , alphaEq a d+        , alphaEq a e+        , alphaEq a f+        , Just TypeEq <- tupEq tup a+        = return a++    constructFeatOpt (C' tup@Tup7) (s1 :* s2 :* s3 :* s4 :* s5 :* s6 :* s7 :* Nil)+        | (prjF -> Just (C' Sel1)) :$ a <- s1+        , (prjF -> Just (C' Sel2)) :$ b <- s2+        , (prjF -> Just (C' Sel3)) :$ c <- s3+        , (prjF -> Just (C' Sel4)) :$ d <- s4+        , (prjF -> Just (C' Sel5)) :$ e <- s5+        , (prjF -> Just (C' Sel6)) :$ f <- s6+        , (prjF -> Just (C' Sel7)) :$ g <- s7+        , alphaEq a b+        , alphaEq a c+        , alphaEq a d+        , alphaEq a e+        , alphaEq a f+        , alphaEq a g+        , Just TypeEq <- tupEq tup a+        = return a++    constructFeatOpt feat args = constructFeatUnOpt feat args++    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+++instance+    ( (Select :|| Type) :<: dom+    , (Tuple  :|| Type) :<: dom+    , Optimize dom dom+    ) =>+      Optimize (Select :|| Type) dom+  where+    constructFeatOpt (C' Sel1) (t :* Nil)+        | ((prjF -> Just (C' Tup2)) :$ a :$ _) <- t                          = return a+        | ((prjF -> Just (C' Tup3)) :$ a :$ _ :$ _) <- t                     = return a+        | ((prjF -> Just (C' Tup4)) :$ a :$ _ :$ _ :$ _) <- t                = return a+        | ((prjF -> Just (C' Tup5)) :$ a :$ _ :$ _ :$ _ :$ _) <- t           = return a+        | ((prjF -> Just (C' Tup6)) :$ a :$ _ :$ _ :$ _ :$ _ :$ _) <- t      = return a+        | ((prjF -> Just (C' Tup7)) :$ a :$ _ :$ _ :$ _ :$ _ :$ _ :$ _) <- t = return a++    constructFeatOpt (C' Sel2) (t :* Nil)+        | ((prjF -> Just (C' Tup2)) :$ _ :$ a) <- t                          = return a+        | ((prjF -> Just (C' Tup3)) :$ _ :$ a :$ _) <- t                     = return a+        | ((prjF -> Just (C' Tup4)) :$ _ :$ a :$ _ :$ _) <- t                = return a+        | ((prjF -> Just (C' Tup5)) :$ _ :$ a :$ _ :$ _ :$ _) <- t           = return a+        | ((prjF -> Just (C' Tup6)) :$ _ :$ a :$ _ :$ _ :$ _ :$ _) <- t      = return a+        | ((prjF -> Just (C' Tup7)) :$ _ :$ a :$ _ :$ _ :$ _ :$ _ :$ _) <- t = return a++    constructFeatOpt (C' Sel3) (t :* Nil)+        | ((prjF -> Just (C' Tup3)) :$ _ :$ _ :$ a) <- t                     = return a+        | ((prjF -> Just (C' Tup4)) :$ _ :$ _ :$ a :$ _) <- t                = return a+        | ((prjF -> Just (C' Tup5)) :$ _ :$ _ :$ a :$ _ :$ _) <- t           = return a+        | ((prjF -> Just (C' Tup6)) :$ _ :$ _ :$ a :$ _ :$ _ :$ _) <- t      = return a+        | ((prjF -> Just (C' Tup7)) :$ _ :$ _ :$ a :$ _ :$ _ :$ _ :$ _) <- t = return a++    constructFeatOpt (C' Sel4) (t :* Nil)+        | ((prjF -> Just (C' Tup4)) :$ _ :$ _ :$ _ :$ a) <- t                = return a+        | ((prjF -> Just (C' Tup5)) :$ _ :$ _ :$ _ :$ a :$ _) <- t           = return a+        | ((prjF -> Just (C' Tup6)) :$ _ :$ _ :$ _ :$ a :$ _ :$ _) <- t      = return a+        | ((prjF -> Just (C' Tup7)) :$ _ :$ _ :$ _ :$ a :$ _ :$ _ :$ _) <- t = return a++    constructFeatOpt (C' Sel5) (t :* Nil)+        | ((prjF -> Just (C' Tup5)) :$ _ :$ _ :$ _ :$ _ :$ a) <- t           = return a+        | ((prjF -> Just (C' Tup6)) :$ _ :$ _ :$ _ :$ _ :$ a :$ _) <- t      = return a+        | ((prjF -> Just (C' Tup7)) :$ _ :$ _ :$ _ :$ _ :$ a :$ _ :$ _) <- t = return a++    constructFeatOpt (C' Sel6) (t :* Nil)+        | ((prjF -> Just (C' Tup6)) :$ _ :$ _ :$ _ :$ _ :$ _ :$ a) <- t      = return a+        | ((prjF -> Just (C' Tup7)) :$ _ :$ _ :$ _ :$ _ :$ _ :$ a :$ _) <- t = return a++    constructFeatOpt (C' Sel7) (t :* Nil)+        | ((prjF -> Just (C' Tup7)) :$ _ :$ _ :$ _ :$ _ :$ _ :$ _ :$ a) <- t = return a++    constructFeatOpt feat args = constructFeatUnOpt feat args++    constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x+
+ src/Feldspar/Core/Frontend.hs view
@@ -0,0 +1,282 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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+    ( module Data.Patch+    , Syntactic+    , SyntacticFeld+    , 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++    -- * Functions+    , ilog2+    , nlz+    ) where++import Prelude as P++import Control.Monad.State+import Test.QuickCheck++import Data.Patch+import Data.Typeable++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.Range+import Feldspar.Core.Types+import Feldspar.Core.Interpretation hiding (showDecor, drawDecor)+import Feldspar.Core.Constructs+import Feldspar.Core.Constructs.Binding (cLambda)+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.Future           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.NoInline         as Frontend+import Feldspar.Core.Frontend.Num              as Frontend+import Feldspar.Core.Frontend.Ord              as Frontend+import Feldspar.Core.Frontend.Par              as Frontend+import Feldspar.Core.Frontend.Save             as Frontend+import Feldspar.Core.Frontend.Select           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+++prjDict :: PrjDict (Decor Info FeldDomain)+prjDict = PrjDict+    (prjVariable prjDictFO . decorExpr)+    (prjLambda   prjDictFO . decorExpr)++mkId :: MkInjDict (Decor Info FeldDomain)+mkId a b | simpleMatch (const . sharable) a+         , Just Dict <- typeDict b+         , Just Dict <- typeDict a+         = Just InjDict+             { injVariable = Decor (getInfo a) . injC . c' . Variable+             , injLambda   = let info = ((mkInfoTy (FunType typeRep typeRep)) { infoSize = infoSize (getInfo b)})+                             in Decor info . injC . cLambda+             , injLet      = Decor (getInfo b) $ injC $ c' Let+             }+mkId _ _ = Nothing+++type SyntacticFeld a = (Syntactic a, Domain a ~  FeldDomainAll, Typeable (Internal a))+  -- TODO Typeable needed?++-- | Reification and optimization of a Feldspar program+reifyFeld :: SyntacticFeld a+    => BitWidth n+    -> a+    -> ASTF (Decor Info FeldDomain) (Internal a)+reifyFeld n = flip evalState 0 .+    (   return+    <=< codeMotion prjDict mkId+    .   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 :: SyntacticFeld a => a -> String+showExpr = render . reifyFeld N32++printExpr :: SyntacticFeld a => a -> IO ()+printExpr = Syntactic.printExpr . reifyFeld N32++showAST :: SyntacticFeld a => a -> String+showAST = Syntactic.showAST . reifyFeld N32++drawAST :: SyntacticFeld a => a -> IO ()+drawAST = Syntactic.drawAST . reifyFeld N32++-- | Draw a syntax tree decorated with type and size information+showDecor :: SyntacticFeld a => a -> String+showDecor = Syntactic.showDecor . reifyFeld N32++-- | Draw a syntax tree decorated with type and size information+drawDecor :: SyntacticFeld a => a -> IO ()+drawDecor = Syntactic.drawDecor . reifyFeld N32++eval :: SyntacticFeld a => a -> Internal a+eval = evalBind . reifyFeld N32++evalTarget+    :: ( SyntacticFeld a+       , 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 (P.Eq a, Show a) => Equal a+  where+    x === y = printTestCase ("Evaluated property: " ++ show x ++ " === " ++ show y)+            $ property (x P.== 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+++--------------------------------------------------------------------------------+-- * Functions+--------------------------------------------------------------------------------++-- | Integer logarithm in base 2+--   Based on an algorithm in Hacker's Delight+ilog2 :: (Bits a) => Data a -> Data Index+ilog2 x = bitSize x - 1 - nlz x++-- | Count leading zeros+--   Based on an algorithm in Hacker's Delight+nlz :: (Bits a) => Data a -> Data Index+nlz x = bitCount $ complement $ foldl go x $ takeWhile (P.< bitSize' x) $ P.map (2 P.^) [(0::Integer)..]+  where+    go b s = b .|. (b .>>. value s)+
+ src/Feldspar/Core/Frontend/Array.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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 Data.Patch++import Feldspar.Core.Types+import Feldspar.Core.Collection+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 = sugarSymF Parallel+++sequential :: (Type a, Syntax s) =>+              Data Length -> s -> (Data Index -> s -> (Data a,s)) -> Data [a]+sequential = sugarSymF Sequential+++append :: Type a => Data [a] -> Data [a] -> Data [a]+append = sugarSymF Append++getLength :: Type a => Data [a] -> Data Length+getLength = sugarSymF 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 = sugarSymF SetLength++getIx :: Type a => Data [a] -> Data Index -> Data a+getIx = sugarSymF GetIx++setIx :: Type a => Data [a] -> Data Index -> Data a -> Data [a]+setIx = sugarSymF SetIx++type instance Elem      (Data [a]) = Data a+type instance CollIndex (Data [a]) = Data Index+type instance CollSize  (Data [a]) = Data Length++instance Type a => Indexed (Data [a])+  where+    (!) = getIx++instance Type a => Sized (Data [a])+  where+    collSize    = getLength+    setCollSize = setLength++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+
+ src/Feldspar/Core/Frontend/Binding.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.Binding where++import Language.Syntactic++import Feldspar.Core.Types+import Feldspar.Core.Constructs.Binding+import Feldspar.Core.Constructs++-- | Share an expression in the scope of a function+share :: (Syntax a, Syntax b) => a -> (a -> b) -> b+share = sugarSymF Let++-- | Share the intermediate result when composing functions+(.<) :: (Syntax b, Syntax c) => (b -> c) -> (a -> b) -> a -> c+(.<) f g a = share (g a) f++-- | Share an expression in the scope of a function+($<) :: (Syntax a, Syntax b) => (a -> b) -> a -> b+($<) = flip share+
+ src/Feldspar/Core/Frontend/Bits.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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 Feldspar.Core.Frontend.Literal++import qualified Data.Bits as B++infixl 5 .<<.,.>>.+infixl 4 ⊕++class (Type a, B.Bits a, Integral a, Bounded a, Size a ~ Range a) => Bits a+  where+    -- Logical operations+    (.&.)         :: Data a -> Data a -> Data a+    (.&.)         = sugarSymF BAnd+    (.|.)         :: Data a -> Data a -> Data a+    (.|.)         = sugarSymF BOr+    xor           :: Data a -> Data a -> Data a+    xor           = sugarSymF BXor+    complement    :: Data a -> Data a+    complement    = sugarSymF Complement++    -- Bitwise operations+    bit           :: Data Index -> Data a+    bit           = sugarSymF Bit+    setBit        :: Data a -> Data Index -> Data a+    setBit        = sugarSymF SetBit+    clearBit      :: Data a -> Data Index -> Data a+    clearBit      = sugarSymF ClearBit+    complementBit :: Data a -> Data Index -> Data a+    complementBit = sugarSymF ComplementBit+    testBit       :: Data a -> Data Index -> Data Bool+    testBit       = sugarSymF TestBit++    -- Movement operations+    shiftLU       :: Data a -> Data Index -> Data a+    shiftLU       = sugarSymF ShiftLU+    shiftRU       :: Data a -> Data Index -> Data a+    shiftRU       = sugarSymF ShiftRU+    shiftL        :: Data a -> Data IntN -> Data a+    shiftL        = sugarSymF ShiftL+    shiftR        :: Data a -> Data IntN -> Data a+    shiftR        = sugarSymF ShiftR+    rotateLU      :: Data a -> Data Index -> Data a+    rotateLU      = sugarSymF RotateLU+    rotateRU      :: Data a -> Data Index -> Data a+    rotateRU      = sugarSymF RotateRU+    rotateL       :: Data a -> Data IntN -> Data a+    rotateL       = sugarSymF RotateL+    rotateR       :: Data a -> Data IntN -> Data a+    rotateR       = sugarSymF RotateR+    reverseBits   :: Data a -> Data a+    reverseBits   = sugarSymF ReverseBits++    bitScan       :: Data a -> Data Index+    bitScan       = sugarSymF BitScan+    bitCount      :: Data a -> Data Index+    bitCount      = sugarSymF BitCount++    bitSize       :: Data a -> Data Index+    bitSize       = value . bitSize'++    bitSize'      :: Data a -> Index+    bitSize'      = const $ fromIntegral $ B.bitSize (undefined :: a)+    isSigned      :: Data a -> Data Bool+    isSigned      = sugarSymF IsSigned++(⊕)    :: (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++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+
+ src/Feldspar/Core/Frontend/Complex.hs view
@@ -0,0 +1,74 @@+--+-- 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.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 = sugarSymF MkComplex++realPart :: (Numeric a, RealFloat a) => Data (Complex a) -> Data a+realPart = sugarSymF RealPart++imagPart :: (Numeric a, RealFloat a) => Data (Complex a) -> Data a+imagPart = sugarSymF ImagPart++conjugate :: (Numeric a, RealFloat a) => Data (Complex a) -> Data (Complex a)+conjugate = sugarSymF Conjugate++mkPolar :: (Numeric a, RealFloat a) => Data a -> Data a -> Data (Complex a)+mkPolar = sugarSymF MkPolar++cis :: (Numeric a, RealFloat a) => Data a -> Data (Complex a)+cis = sugarSymF Cis++magnitude :: (Numeric a, RealFloat a) => Data (Complex a) -> Data a+magnitude = sugarSymF Magnitude++phase :: (Numeric a, RealFloat a) => Data (Complex a) -> Data a+phase = sugarSymF 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+
+ src/Feldspar/Core/Frontend/Condition.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.Condition where++import Language.Syntactic++import Feldspar.Core.Constructs.Condition+import Feldspar.Core.Constructs++condition :: (Syntax a) => Data Bool -> a -> a -> a+condition c t f = sugarSymF Condition c t f++(?) :: (Syntax a) => Data Bool -> (a, a) -> a+c ? (t, e) = condition c t e++infix 1 ?+
+ src/Feldspar/Core/Frontend/ConditionM.hs view
@@ -0,0 +1,40 @@+--+-- 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.Constructs.ConditionM+import Feldspar.Core.Constructs++import Feldspar.Core.Frontend.Mutable++ifM :: Syntax a => Data Bool -> M a -> M a -> M a+ifM = sugarSymC ConditionM+
+ src/Feldspar/Core/Frontend/Conversion.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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) => Data a -> Data Float+i2f = i2n++f2i :: Integral a => Data Float -> Data a+f2i = sugarSymF F2I++i2n :: (Integral a, Numeric b) => Data a -> Data b+i2n = sugarSymF I2N++b2i :: Integral a => Data Bool -> Data a+b2i = sugarSymF B2I++truncate :: Integral a => Data Float -> Data a+truncate = f2i++round :: Integral a => Data Float -> Data a+round = sugarSymF Round++ceiling :: Integral a => Data Float -> Data a+ceiling = sugarSymF Ceiling++floor :: Integral a => Data Float -> Data a+floor = sugarSymF Floor+
+ src/Feldspar/Core/Frontend/Eq.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.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+    (==) = sugarSymF Equal+    (/=) :: Data a -> Data a -> Data Bool+    (/=) = sugarSymF 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)+
+ src/Feldspar/Core/Frontend/Error.hs view
@@ -0,0 +1,50 @@+--+-- 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.Constructs+import Feldspar.Core.Constructs.Error+import Feldspar.Core.Frontend.Literal++undef :: Syntax a => a+undef = sugarSymF Undefined++-- | Assert that the condition holds or fail with message+assertMsg :: Syntax a => String -> Data Bool -> a -> a+assertMsg = sugarSymF . 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+
+ src/Feldspar/Core/Frontend/FFI.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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.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)+
+ src/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.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        =  sugarSymF Pi+  exp       :: Data a -> Data a+  exp       =  sugarSymF Exp+  sqrt      :: Data a -> Data a+  sqrt      =  sugarSymF Sqrt+  log       :: Data a -> Data a+  log       =  sugarSymF Log+  (**)      :: Data a -> Data a -> Data a+  (**)      =  sugarSymF Pow+  logBase   :: Data a -> Data a -> Data a+  logBase   =  sugarSymF LogBase+  sin       :: Data a -> Data a+  sin       =  sugarSymF Sin+  tan       :: Data a -> Data a+  tan       =  sugarSymF Tan+  cos       :: Data a -> Data a+  cos       =  sugarSymF Cos+  asin      :: Data a -> Data a+  asin      =  sugarSymF Asin+  atan      :: Data a -> Data a+  atan      =  sugarSymF Atan+  acos      :: Data a -> Data a+  acos      =  sugarSymF Acos+  sinh      :: Data a -> Data a+  sinh      =  sugarSymF Sinh+  tanh      :: Data a -> Data a+  tanh      =  sugarSymF Tanh+  cosh      :: Data a -> Data a+  cosh      =  sugarSymF Cosh+  asinh     :: Data a -> Data a+  asinh     =  sugarSymF Asinh+  atanh     :: Data a -> Data a+  atanh     =  sugarSymF Atanh+  acosh     :: Data a -> Data a+  acosh     =  sugarSymF Acosh++instance Floating Float+instance (Fraction a, Prelude.RealFloat a) => Floating (Complex a)+
+ src/Feldspar/Core/Frontend/Fractional.hs view
@@ -0,0 +1,61 @@+--+-- 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.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 `Fraction` 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 = sugarSymF DivFrac++instance Fraction Float++instance (Fraction a, RealFloat a) => Fraction (Complex a)++instance (Fraction a) => Fractional (Data a)+  where+    fromRational = fromRationalFrac+    (/)          = divFrac+
+ src/Feldspar/Core/Frontend/Future.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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.Future where++import Language.Syntactic++import Feldspar.Core.Types+import Feldspar.Core.Constructs+import Feldspar.Core.Constructs.Future+import Feldspar.Core.Frontend.Save++newtype Future a = Future { unFuture :: Data (FVal (Internal a)) }++later :: (Syntax a, Syntax b) => (a -> b) -> Future a -> Future b+later f = future . f . await++pval :: (Syntax a, Syntax b) => (a -> b) -> a -> b+pval f x = await $ force $ future (f x)++instance Syntax a => Syntactic (Future a)+  where+    type Domain (Future a)   = FeldDomainAll+    type Internal (Future a) = FVal (Internal a)+    desugar = desugar . unFuture+    sugar   = Future . sugar++instance Syntax a => Syntax (Future a)++future :: Syntax a => a -> Future a+future = sugarSymF MkFuture++await :: Syntax a => Future a -> a+await = sugarSymF Await+
+ src/Feldspar/Core/Frontend/Integral.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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++class (Ord a, Numeric a, BoundedInt a, P.Integral a, Size a ~ Range a) => Integral a+  where+    quot :: Data a -> Data a -> Data a+    quot = sugarSymF Quot+    rem  :: Data a -> Data a -> Data a+    rem  = sugarSymF Rem+    div  :: Data a -> Data a -> Data a+    div  = divSem+    mod  :: Data a -> Data a -> Data a+    mod  = sugarSymF Mod+    (^)  :: Data a -> Data a -> Data a+    (^)  = sugarSymF 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 :: (Integral a)+       => Data a -> Data a -> Data a+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+
+ src/Feldspar/Core/Frontend/Literal.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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+import Feldspar.Core.Interpretation++value :: Syntax a => Internal a -> a+value = sugarSymF . Literal++false :: Data Bool+false = value False++true :: Data Bool+true = value True++instance Syntactic ()+  where+    type Domain ()   = FeldDomainAll+    type Internal () = ()+    desugar = appSymC . c' . Literal+    sugar _ = ()++instance Syntax ()+
+ src/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 Prelude hiding ((&&), (||))+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 = sugarSymF Not++(&&) :: Data Bool -> Data Bool -> Data Bool+(&&) = sugarSymF And++(||) :: Data Bool -> Data Bool -> Data Bool+(||) = sugarSymF 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)+
+ src/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 = sugarSymF ForLoop++whileLoop :: Syntax a => a -> (a -> Data Bool) -> (a -> a) -> a+whileLoop = sugarSymF WhileLoop++forM :: (Syntax a) => Data Length -> (Data Index -> M a) -> M ()+forM = sugarSymC For++whileM :: Syntax a => M (Data Bool) -> M a -> M ()+whileM = sugarSymC While+
+ src/Feldspar/Core/Frontend/Mutable.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++--+-- 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 Language.Syntactic+import Language.Syntactic.Frontend.Monad++import Feldspar.Core.Types+import Feldspar.Core.Constructs+import Feldspar.Core.Frontend.Logic+import qualified Feldspar.Core.Constructs.Mutable as Feature++newtype M a = M { unM :: Mon FeldSymbols Type Mut a }+  deriving (Functor, Monad)++instance Syntax a => Syntactic (M a)+  where+    type Domain (M a)   = FeldDomainAll+    type Internal (M a) = Mut (Internal a)+    desugar = desugar . unM+    sugar   = M . sugar++runMutable :: (Syntax a) => M a -> a+runMutable = sugarSymC Feature.Run++when :: Data Bool -> M () -> M ()+when = sugarSymC Feature.When++unless :: Data Bool -> M () -> M ()+unless = when . not+
+ src/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 = sugarSymC NewArr++newArr_ :: Type a => Data Length -> M (Data (MArr a))+newArr_ = sugarSymC NewArr_++newListArr :: Type a => [Data a] -> M (Data (MArr a))+newListArr _ = error "newListArr: unimplemented" -- TODO++getArr :: Type a => Data (MArr a) -> Data Index -> M (Data a)+getArr = sugarSymC GetArr++setArr :: Type a => Data (MArr a) -> Data Index -> Data a -> M ()+setArr = sugarSymC 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 = sugarSymC 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 = sugarSymC 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 ()+
+ src/Feldspar/Core/Frontend/MutableReference.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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.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)+  where+    type Domain (Ref a)   = FeldDomainAll+    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 = sugarSymC NewRef++getRef :: Syntax a => Ref a -> M a+getRef = sugarSymC GetRef++setRef :: Syntax a => Ref a -> a -> M ()+setRef = sugarSymC SetRef++modifyRef :: Syntax a => Ref a -> (a -> a) -> M ()+modifyRef r f = getRef r >>= setRef r . f+
+ src/Feldspar/Core/Frontend/MutableToPure.hs view
@@ -0,0 +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.+--++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 = sugarSymC WithArray++runMutableArray :: Type a => M (Data (MArr a)) -> Data [a]+runMutableArray = sugarSymC 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+
+ src/Feldspar/Core/Frontend/NoInline.hs view
@@ -0,0 +1,38 @@+--+-- 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.NoInline where++import Language.Syntactic++import Feldspar.Core.Constructs+import Feldspar.Core.Constructs.NoInline++noInline :: (Syntax a) => a -> a+noInline = sugarSymF NoInline+
+ src/Feldspar/Core/Frontend/Num.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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         =  sugarSymF Abs+    signumNum      :: Data a -> Data a+    signumNum      =  sugarSymF Sign+    addNum         :: Data a -> Data a -> Data a+    addNum         =  sugarSymF Add+    subNum         :: Data a -> Data a -> Data a+    subNum         =  sugarSymF Sub+    mulNum         :: Data a -> Data a -> Data a+    mulNum         =  sugarSymF 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++
+ src/Feldspar/Core/Frontend/Ord.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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.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+  (<)  =  sugarSymF LTH+  (>)  :: Data a -> Data a -> Data Bool+  (>)  =  sugarSymF GTH++  (<=) :: Data a -> Data a -> Data Bool+  (<=) =  sugarSymF LTE+  (>=) :: Data a -> Data a -> Data Bool+  (>=) =  sugarSymF GTE++  min :: Data a -> Data a -> Data a+  min = sugarSymF Min+  max :: Data a -> Data a -> Data a+  max = sugarSymF 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?+
+ src/Feldspar/Core/Frontend/Par.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++--+-- 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 hiding (P)+import Language.Syntactic.Frontend.Monad (Mon(..))++import Feldspar.Core.Types+import Feldspar.Core.Constructs+import Feldspar.Core.Frontend.Literal ()++newtype P a = P { unP :: Mon FeldSymbols Type Par a }+  deriving (Functor, Monad)++instance Syntax a => Syntactic (P a)+  where+    type Domain (P a)   = FeldDomainAll+    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)+  where+    type Domain (IVar a)   = FeldDomainAll+    type Internal (IVar a) = IV (Internal a)+    desugar = desugar . unIVar+    sugar   = IVar . sugar++instance Syntax a => Syntax (IVar a)+
+ src/Feldspar/Core/Frontend/Save.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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 = sugarSymF 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+
+ src/Feldspar/Core/Frontend/Select.hs view
@@ -0,0 +1,41 @@+--+-- 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.Select where++import qualified Prelude as P++import Feldspar.Core.Frontend.Eq+import Feldspar.Core.Frontend.Condition+import Feldspar.Core.Constructs++-- | Select between the cases based on the value of the scrutinee.+-- TODO: This implementation should be replaces by a proper construct+select :: (Eq a, Syntax b) => Data a -> [(Data a, b)] -> b -> b+select scrutinee cases fallback = P.foldr (\(c,a) b -> c == scrutinee ? (a,b)) fallback cases+
+ src/Feldspar/Core/Frontend/SizeProp.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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 = sugarSymF . 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 (Range minBound . upperBound)++-- | @notBelow a b@: A guarantee that @b >= a@ holds+notBelow :: (Type a, Bounded a, Size a ~ Range a) => Data a -> SizeCap a+notBelow = sizeProp (flip Range maxBound . lowerBound)++-- | @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+
+ src/Feldspar/Core/Frontend/SourceInfo.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.+--++{-# 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 = sugarSymF (Decor info Id)++instance Type a => Annotatable (Data a)+  where+    annotate = sourceData . SourceInfo1+
+ src/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 = sugarSymF Trace (fromIntegral label :: Data IntN)+
+ src/Feldspar/Core/Frontend/Tuple.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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 Language.Syntactic.Frontend.TupleConstrained++import Feldspar.Core.Types+import Feldspar.Core.Constructs+import Feldspar.Core.Constructs.Tuple ()++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+        )+
+ src/Feldspar/Core/Interpretation.hs view
@@ -0,0 +1,489 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ConstraintKinds #-}++--+-- 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+    , module Feldspar.Core.Interpretation.Typed++    , targetSpecialization+    , Sharable (..)+    , SizeProp (..)+    , sizePropDefault+    , resultType+    , SourceInfo+    , Info (..)+    , mkInfo+    , mkInfoTy+    , infoRange+    , LatticeSize1 (..)+    , viewLiteral+    , literalDecor+    , constFold+    , SomeInfo (..)+    , SomeType (..)+    , Env (..)+    , localVar+    , localSource+    , Opt+    , Optimize (..)+    , OptimizeSuper+    , constructFeat+    , optimizeM+    , optimize+    , constructFeatUnOptDefaultTyp+    , constructFeatUnOptDefault+    , optimizeFeatDefault+    , prjF+    , c'+    ) where++++import Control.Monad.Reader+import Data.Map as Map+import Data.Typeable (Typeable)++import Language.Syntactic+import Language.Syntactic.Constructs.Decoration+import Language.Syntactic.Constructs.Literal+import Language.Syntactic.Constructs.Binding+import Language.Syntactic.Constructs.Binding.HigherOrder++import Feldspar.Lattice+import Feldspar.Core.Types+import Feldspar.Core.Interpretation.Typed+++--------------------------------------------------------------------------------+-- * 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+--------------------------------------------------------------------------------++-- | Indication whether a symbol is sharable or not+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++instance Sharable sym => Sharable (sym :|| pred)+  where+    sharable (C' s) = sharable s++instance Sharable sym => Sharable (SubConstr2 c sym p1 p2)+  where+    sharable (SubConstr2 s) = sharable s++instance Sharable dom => Sharable (Decor Info dom)+  where+    sharable = sharable . decorExpr++instance Sharable Empty++++--------------------------------------------------------------------------------+-- * 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 :: (Type (DenResult a))+                => feature a -> Args (WrapFull Info) a -> Size (DenResult a)+sizePropDefault _ _ = 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++data SomeType+  where+    SomeType :: TypeRep a -> SomeType++type VarInfo = Map VarId SomeType++-- | 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   :: VarInfo+         , 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 :: forall info dom a. ((Literal :|| Type) :<: dom)+            => ASTF (Decor info (dom :|| Typeable)) a -> Maybe a+viewLiteral (prjF -> Just (C' (Literal a))) = Just a+viewLiteral _ = Nothing++prjF :: Project (sub :|| Type) sup => sup sig -> Maybe ((sub :|| Type) sig)+prjF = prj++-- | Construct a 'Literal' decorated with 'Info'+literalDecorSrc :: (Type a, (Literal :|| Type) :<: dom) =>+    SourceInfo -> a -> ASTF (Decor Info (dom :|| Typeable)) a+literalDecorSrc src a = Sym $ Decor+    ((mkInfo (sizeOf a)) {infoSource = src})+    (C' $ inj $ c' $ Literal a)++c' :: (Type (DenResult sig)) => feature sig -> (feature :|| Type) sig+c' = C'++-- | Construct a 'Literal' decorated with 'Info'+literalDecor :: (Type a, (Literal :|| Type) :<: dom) =>+    a -> ASTF (Decor Info (dom :|| Typeable)) 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 :: (Typed dom, (Literal :|| Type) :<: dom) =>+    SourceInfo -> ASTF (Decor Info (dom :|| Typeable)) a -> a -> ASTF (Decor Info (dom :|| Typeable)) a+constFold src expr a+    | Just Dict <- typeDict 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 Optimize feature dom+  where+    -- | Top-down and bottom-up optimization of a feature+    optimizeFeat+        :: ( Typeable (DenResult a)+           , OptimizeSuper dom+           )+        => feature a+        -> Args (AST (dom :|| Typeable)) a+        -> Opt (ASTF (Decor Info (dom :|| Typeable)) (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+        :: ( Typeable (DenResult a))+        => feature a+        -> Args (AST (Decor Info (dom :|| Typeable))) a+        -> Opt (ASTF (Decor Info (dom :|| Typeable)) (DenResult a))+    constructFeatOpt = constructFeatUnOpt++    -- | Unoptimized construction of an expression from a symbol and its+    -- optimized arguments+    constructFeatUnOpt+        :: ( Typeable (DenResult a))+        => feature a+        -> Args (AST (Decor Info (dom :|| Typeable))) a+        -> Opt (ASTF (Decor Info (dom :|| Typeable)) (DenResult a))+++instance Optimize Empty dom+  where+    constructFeatUnOpt = error "Not implemented: constructFeatUnOpt for Empty"++-- These classes used to be super-classes of `Optimize`, but after switching to+-- GHC 7.4, that lead to looping dictionaries (at run time). The problem arises+-- when you make instances like+--+--     instance Optimize dom dom => Optimize MyConstruct dom+--+-- Since the second parameter does not change, this seems to create a loop+-- whenever you want to access super-class methods through a+-- `Optimize MyConstruct dom` constraint.+--+-- This may or may not be related to the following (unconfirmed) bug:+--+--   http://hackage.haskell.org/trac/ghc/ticket/5913+--+-- To revert the class hierarchy:+--+--   * Make `OptimizeSuper` (expanded) a super-class of `Optimize`+--   * Make `WitnessCons feature` a super-class of `Optimize`+--   * Replace the context of `optimizeFeat` with `Optimize dom dom`+--   * Replace all references to `OptimizeSuper dom` with `Optimize dom dom`+--   * Remove `OptimizeSuper`+class+    ( AlphaEq dom dom (dom :|| Typeable) [(VarId, VarId)]+    , AlphaEq dom dom (Decor Info (dom :|| Typeable)) [(VarId, VarId)]+    , EvalBind dom+    , (Literal :|| Type) :<: dom+    , Typed dom+    , Constrained dom+    , Optimize dom dom+    ) =>+      OptimizeSuper dom++instance+    ( AlphaEq dom dom (dom :|| Typeable) [(VarId, VarId)]+    , AlphaEq dom dom (Decor Info (dom :|| Typeable)) [(VarId, VarId)]+    , EvalBind dom+    , (Literal  :|| Type) :<: dom+    , Typed dom+    , Constrained dom+    , Optimize dom dom+    ) =>+      OptimizeSuper dom++++-- 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 :: ( Typeable (DenResult a)+                 , Optimize feature dom)+    => feature a+    -> Args (AST (Decor Info (dom :|| Typeable))) a+    -> Opt (ASTF (Decor Info (dom :|| Typeable)) (DenResult a))+constructFeat a args = do+    aUnOpt <- constructFeatUnOpt a args+    aOpt   <- constructFeatOpt a args+    return $ updateDecor+        (\info -> info {infoSize = infoSize (getInfo aUnOpt)})+        aOpt+  -- This function uses `constructFeatOpt` for optimization and+  -- `constructFeatUnOpt` for size propagation. This is because+  -- `constructFeatOpt` may produce less accurate size information than+  -- `constructFeatUnOpt`.++  -- TODO It might be better to use `sizeProp` instead of `constructFeatUnOpt`+  --      (but this changes class dependencies a bit). Is there any other use of+  --      `constructFeatUnOpt`?++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 :: (OptimizeSuper dom)+          => ASTF (dom :|| Typeable) a -> Opt (ASTF (Decor Info (dom :|| Typeable)) a)+optimizeM a+    | Dict <- exprDict a+    = do+        aOpt <- matchTrans (\(C' x) -> optimizeFeat x) a+        let vars  = infoVars $ getInfo aOpt+            value = evalBind aOpt+            src   = infoSource $ getInfo aOpt+    --    return 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 :: ( Typeable a+            , OptimizeSuper dom+            )+         => ASTF (dom :|| Typeable) a -> ASTF (Decor Info (dom :|| Typeable)) a+optimize = flip runReader initEnv . optimizeM++-- | Convenient default implementation of 'constructFeatUnOpt'. Uses 'sizeProp'+-- to propagate size.+constructFeatUnOptDefaultTyp+    :: ( feature :<: dom+       , SizeProp feature+       , Typeable (DenResult a)+       , Show (Size (DenResult a))+       )+    => TypeRep (DenResult a)+    -> feature a+    -> Args (AST (Decor Info (dom :|| Typeable))) a+    -> Opt (ASTF (Decor Info (dom :|| Typeable)) (DenResult a))+constructFeatUnOptDefaultTyp typ feat args+    = do+        src <- asks sourceEnv+        let sz   = sizeProp feat $ mapArgs (WrapFull . getInfo) args+            vars = Map.unions $ listArgs (infoVars . getInfo) args+        return $ appArgs (Sym $ Decor (Info typ sz vars src) $ C' $ inj feat) args++-- | Like 'constructFeatUnOptDefaultTyp' but without an explicit 'TypeRep'+constructFeatUnOptDefault+    :: ( feature :<: dom+       , SizeProp feature+       , Type (DenResult a)+       )+    => feature a+    -> Args (AST (Decor Info (dom :|| Typeable))) a+    -> Opt (ASTF (Decor Info (dom :|| Typeable)) (DenResult a))+constructFeatUnOptDefault feat args+    = do+        src <- asks sourceEnv+        let sz   = sizeProp feat $ mapArgs (WrapFull . getInfo) args+            vars = Map.unions $ listArgs (infoVars . getInfo) args+        return $ appArgs (Sym $ Decor (Info typeRep sz vars src) $ C' $ inj feat) args++-- | Convenient default implementation of 'optimizeFeat'+optimizeFeatDefault+    :: ( Optimize feature dom+       , Typeable (DenResult a)+       , OptimizeSuper dom+       )+    => feature a+    -> Args (AST (dom :|| Typeable)) a+    -> Opt (ASTF (Decor Info (dom :|| Typeable)) (DenResult a))+optimizeFeatDefault feat args+    = constructFeat feat =<< mapArgsM optimizeM args+
+ src/Feldspar/Core/Interpretation/Typed.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverlappingInstances #-}++-- | Witness 'Type' constraints++module Feldspar.Core.Interpretation.Typed+  ( Typed(..)+  , typeDict+  )+where++import Language.Syntactic+import Language.Syntactic.Constructs.Binding.HigherOrder+import Language.Syntactic.Constructs.Decoration++import Feldspar.Core.Types (Type)++-- | Class representing a possible dictionary to witness a 'Type'+-- constraint.+class Typed dom+  where+    typeDictSym :: dom a -> Maybe (Dict (Type (DenResult a)))+    typeDictSym _ = Nothing++instance Typed (sub :|| Type)+  where typeDictSym (C' _) = Just Dict++instance Typed sub => Typed (sub :|| pred)+  where typeDictSym (C' s) = typeDictSym s++instance Typed sub => Typed (sub :| pred)+  where typeDictSym (C s) = typeDictSym s++instance Typed (SubConstr2 c sub Type Top)+  where typeDictSym (SubConstr2 s) = Nothing++instance (Typed sub, Typed sup) => Typed (sub :+: sup)+  where typeDictSym (InjL s) = typeDictSym s+        typeDictSym (InjR s) = typeDictSym s++instance (Typed sub) => Typed (Decor info sub)+  where typeDictSym (Decor _ s) = typeDictSym s++instance Typed Empty+instance Typed dom++-- | Extract a possible 'Type' constraint witness from an 'AST'+typeDict :: Typed dom => ASTF dom a -> Maybe (Dict (Type a))+typeDict = simpleMatch (const . typeDictSym)+
+ src/Feldspar/Core/Types.hs view
@@ -0,0 +1,863 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++--+-- 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.Types where++++import Data.Array.IO+import Data.Bits+import Data.Complex+import Data.Int+import Data.IORef+import Data.List+import Data.Typeable (Typeable, Typeable1)+import Data.Word+import Test.QuickCheck+import qualified Control.Monad.Par as MonadPar++import Data.Patch++import Data.Proxy++import Language.Syntactic++import Feldspar.Lattice+import Feldspar.Range++++--------------------------------------------------------------------------------+-- * Heterogenous lists+--------------------------------------------------------------------------------++-- | Heterogeneous list+data a :> b = a :> b+  deriving (Eq, Ord, Show)++infixr 5 :>++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)++++--------------------------------------------------------------------------------+-- * Integers+--------------------------------------------------------------------------------++-- | Target-dependent unsigned integers+newtype WordN = WordN Word32+  deriving+    ( Eq, Ord, Num, Enum, Ix, Real, Integral, Bits, Bounded, Typeable+    , Arbitrary )++-- | Target-dependent signed integers+newtype IntN = IntN Int32+  deriving+    ( Eq, Ord, Num, Enum, Ix, Real, Integral, Bits, Bounded, Typeable+    , Arbitrary )++instance Show WordN+  where+    show (WordN a) = show a++instance Show IntN+  where+    show (IntN a) = show a++-- | 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+    N8      :: BitWidth N8+    N16     :: BitWidth N16+    N32     :: BitWidth N32+    N64     :: BitWidth N64+    NNative :: BitWidth NNative++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+    U :: Signedness U+    S :: Signedness S++signedness :: Signedness s -> String+signedness U = "Word"+signedness S = "Int"++-- | 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++++--------------------------------------------------------------------------------+-- * Arrays+--------------------------------------------------------------------------------++-- | Array whose length is represented by an @n@-bit word+data TargetArr n a = TargetArr (GenericInt U n) [a]+++--------------------------------------------------------------------------------+-- * Monadic Types+--------------------------------------------------------------------------------++-- | This class is used to allow constructs to be abstract in the monad+class MonadType m+  where+    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.++++--------------------------------------------------------------------------------+-- * Mutable data+--------------------------------------------------------------------------------++-- TODO Make newtypes?++-- | Monad for manipulation of mutable data+type Mut = IO++-- | Mutable references+instance Show (IORef a)+  where+    show _ = "IORef"++-- | Mutable arrays+type MArr a = IOArray Index a++instance Show (MArr a)+  where+    show _ = "MArr"++instance MonadType Mut+  where+    voidTypeRep = MutType UnitType+++--------------------------------------------------------------------------------+-- * 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+    show _ = "IVar"++instance Eq (IV a)+  where+    _ == _ = False++instance MonadType Par+  where+    voidTypeRep = ParType UnitType++--------------------------------------------------------------------------------+-- * Future values+--------------------------------------------------------------------------------++newtype FVal a = FVal {unFVal :: a}++deriving instance Typeable1 FVal++instance Show (FVal a)+  where+    show _ = "future"++instance Eq a => Eq (FVal a)+  where+    (FVal a) == (FVal b) = a == b+++--------------------------------------------------------------------------------+-- * Type representation+--------------------------------------------------------------------------------++-- | Representation of supported types+data TypeRep a+  where+    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)+    FValType      :: TypeRep a -> TypeRep (FVal 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 Show (TypeRep a)+  where+    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]+    show (FValType ta)                   = unwords ["FVal", show ta]++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+    TypeEq :: TypeEq a a++defaultSize :: TypeRep a -> Size a+defaultSize UnitType = universal+defaultSize BoolType = universal+defaultSize (IntType _ _) = universal+defaultSize FloatType = universal+defaultSize (ComplexType _) = 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 _ 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+defaultSize (FValType 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 (FValType t1) (FValType t2) = do+    TypeEq <- typeEq t1 t2+    return TypeEq++typeEq _ _ = Nothing++showTup :: [String] -> String+showTup as =  "(" ++ intercalate "," 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)+type instance TargetType n (FVal a)        = FVal (TargetType n a)++-- | The set of supported types+class (Eq a, Show a, Typeable a, Show (Size a), Lattice (Size a)) => Type a+  where+    -- | Gives the type representation a value.+    typeRep  :: TypeRep a+    sizeOf   :: a -> Size a+    toTarget :: BitWidth n -> a -> TargetType n a+  -- TODO Typeable needed?++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)+  where+    typeRep             = ComplexType typeRep+    sizeOf _            = AnySize+    toTarget _ (_ :+ _) = error "TODO" -- toTarget n r :+ toTarget n i++instance Type a => Type [a]+  where+    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+    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+    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+    typeRep = Tup4Type typeRep typeRep typeRep typeRep++    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+    typeRep = Tup5Type typeRep typeRep typeRep typeRep typeRep++    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+    typeRep = Tup6Type typeRep typeRep typeRep typeRep typeRep typeRep++    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+    typeRep = Tup7Type typeRep typeRep typeRep typeRep typeRep typeRep typeRep++    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+    typeRep = RefType typeRep++    sizeOf _ = universal++    toTarget = error "toTarget: IORef"  -- TODO Requires IO++instance Type a => Type (MArr a)+  where+    typeRep = MArrType typeRep++    sizeOf _ = universal++    toTarget = error "toTarget: MArr"  -- TODO Requires IO++instance Type a => Type (IV a)+  where+    typeRep = IVarType typeRep++    sizeOf _ = universal++    toTarget = error "toTarget: IVar" -- TODO Requires IO++instance Type a => Type (FVal a)+  where+    typeRep = FValType typeRep++    sizeOf _ = universal++    toTarget = error "toTarget: FVal" -- TODO++++typeRepByProxy :: Type a => Proxy a -> TypeRep a+typeRepByProxy _ = typeRep++++--------------------------------------------------------------------------------+-- * Sized types+--------------------------------------------------------------------------------++data AnySize = AnySize+    deriving (Eq, Show, Ord)++anySizeFun :: AnySize -> AnySize+anySizeFun AnySize = AnySize++anySizeFun2 :: AnySize -> AnySize -> AnySize+anySizeFun2 AnySize AnySize = AnySize++instance Num AnySize+  where+    fromInteger _ = AnySize+    abs           = anySizeFun+    signum        = anySizeFun+    (+)           = anySizeFun2+    (-)           = anySizeFun2+    (*)           = anySizeFun2++instance Lattice AnySize+  where+    empty     = AnySize+    universal = AnySize+    (\/)      = anySizeFun2+    (/\)      = anySizeFun2++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+type instance Size (FVal 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+    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+
+ src/Feldspar/FixedPoint.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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(..)+    , freezeFix, freezeFix', unfreezeFix, unfreezeFix'+    , (?!), fixFold+    )+where++import qualified Prelude+import Feldspar hiding (sugar,desugar)+import Feldspar.Vector++import Language.Syntactic hiding (fold)++-- | Abstract real number type with exponent and mantissa+data Fix a =+    Fix+    { exponent  :: Data IntN+    , mantissa  :: Data a+    }+    deriving (Prelude.Eq,Prelude.Show)++instance+    ( Integral a+    , Bits a+    , Prelude.Real a+    ) => Num (Fix a)+  where+    fromInteger n = Fix 0 (Prelude.fromInteger n)+    (+) = fixAddition+    (*) = fixMultiplication+    negate = fixNegate+    abs = fixAbsolute+    signum = fixSignum++instance+    ( Integral a+    , Bits a+    , Prelude.Real a+    ) => Fractional (Fix a)+  where+    (/) = fixDiv'+    recip = fixRecip'+    fromRational = fixfromRational++fixAddition :: (Integral a, Bits a, Prelude.Real a) => Fix a -> Fix a -> Fix a+fixAddition f1@(Fix e1 _) f2@(Fix e2 _) = Fix e m+   where+     e = max e1 e2+     m = mantissa (fix e f1) + mantissa (fix e f2)++fixMultiplication :: (Integral a, Bits a, Prelude.Real a) => Fix a -> Fix a -> Fix a+fixMultiplication (Fix e1 m1) (Fix e2 m2) = Fix e m+   where+     e =  e1 + e2+     m =  m1 * m2++fixNegate :: (Integral a, Bits a, Prelude.Real a) => Fix a -> Fix a+fixNegate (Fix e1 m1)  = Fix e1 m+   where+     m = negate m1++fixAbsolute :: (Integral a, Bits a, Prelude.Real a) => Fix a -> Fix a+fixAbsolute (Fix e1 m1)  = Fix e1 m+   where+     m = abs m1++fixSignum :: (Integral a, Bits a, Prelude.Real a) => Fix a -> Fix a+fixSignum (Fix _ m1)  = Fix 0 m+   where+     m = signum m1++fixDiv' :: (Integral a, Bits a, Prelude.Real a)+           => Fix a -> Fix a -> Fix a+fixDiv' (Fix e1 m1) (Fix e2 m2) = Fix e m+   where+     e = e1 - e2+     m = div m1 m2++fixRecip' :: forall a . (Integral a, Bits a, Prelude.Real a)+             => Fix a -> Fix a+fixRecip' (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)++fixfromRational :: forall a . (Integral a) =>+                   Prelude.Rational -> Fix a+fixfromRational inp = Fix e m+   where+      inpAsFloat :: Float+      inpAsFloat = fromRational inp+      intPart :: Float+      intPart = fromRational $ toRational $ Prelude.floor inpAsFloat+      intPartWidth :: IntN+      intPartWidth =  Prelude.ceiling $ Prelude.logBase 2 intPart+      fracPartWith :: IntN+      fracPartWith =  wordLength (T :: T a) - intPartWidth - 2+      m = value $ Prelude.floor $ inpAsFloat * 2.0 Prelude.** fromRational (toRational fracPartWith)+      e = negate $ value fracPartWith++instance (Type a) => Syntactic (Fix a) where+  type Domain (Fix a)   = FeldDomainAll+  type Internal (Fix a) = (IntN, a)+  desugar = desugar . freezeFix+  sugar   = unfreezeFix . sugar++instance (Type a) => Syntax (Fix a)++-- | 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)++-- | Converts an abstract real number to fixed point integer with given exponent+freezeFix' :: (Bits 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 IntN, Data a) -> Fix a+unfreezeFix = uncurry Fix++-- | Converts a fixed point integer with given exponent to an abstract real number+unfreezeFix' :: IntN -> Data a -> Fix a+unfreezeFix' e = Fix (value e)++-- 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+    m :: a+    m = Prelude.max (Prelude.abs $ lowerBound r) (Prelude.abs $ upperBound r)+    mf :: Float+    mf = logBase 2 $ fromRational $ toRational m+-}+{-+setSignificantBits :: forall a . (Type a, 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 . (Integral a, Prelude.Real a) => T a -> IntN+wordLength _ = Prelude.ceiling ( Prelude.logBase 2 $ fromRational $ toRational (maxBound :: a)) + 1++-- | Operations to get and set exponent+class (Splittable t) => Fixable t where+    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'))+    getExp = Feldspar.FixedPoint.exponent++instance Fixable (Data Float) where+    fix = const id+    getExp = const $ fromInteger $ toInteger $ Feldspar.exponent (0.0 :: Float)++data T a = T++-- | Operations to split data into dynamic and static parts+class (Syntax (Dynamic t)) => Splittable t where+    type Static t+    type Dynamic t+    store       :: t -> (Static t, Dynamic t)+    retrieve    :: (Static t, Dynamic t) -> t+    patch       :: Static t -> t -> t+    common      :: t -> t -> Static t++instance (Type a) => Splittable (Data a) where+    type Static (Data a) = ()+    type Dynamic (Data a) = Data a+    store x = ((),x)+    retrieve = snd+    patch = const id+    common _ _ = ()++instance (Bits 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+    patch = fix+    common f g = max (Feldspar.FixedPoint.exponent f) (Feldspar.FixedPoint.exponent g)++-- | A version of vector fold for fixed point algorithms+fixFold :: forall a b . (Splittable a) => (a -> b -> a) -> a -> Vector b -> a+fixFold fun ini vec = retrieve (static, fold fun' ini' vec)+  where+    static = fst $ store ini+    ini' = snd $ store ini+    fun' st el = snd $ store $ patch static $ retrieve (static,st) `fun` el++-- | A version of branching for fixed point algorithms+infix 1 ?!+(?!) :: forall a . (Syntax a, Splittable a) => Data Bool -> (a,a) -> a+cond ?! (x,y) = retrieve (comm, cond ? (x',y'))+  where+    comm = common x y+    x' = snd $ store $ patch comm x+    y' = snd $ store $ patch comm y
+ src/Feldspar/Future.hs view
@@ -0,0 +1,41 @@+--+-- 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.Future where++import Feldspar+import Feldspar.Vector as V++withFuture :: (Syntax a, Syntax b)+           => a -> (Future a -> b) -> b+withFuture = share . future++withFutures :: (Syntax a, Syntax b)+            => Vector a -> (Vector (Future a) -> b) -> b+withFutures coll = share $ indexed (V.length coll) $ \i -> future $ coll!i+
+ src/Feldspar/Lattice.hs view
@@ -0,0 +1,198 @@+--+-- 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)++-- | Accumulated union+unions :: Lattice a => [a] -> a+unions = foldr (\/) empty++-- | Accumulated intersection+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 = go 0+  where+    go i a+        | aLat == bLat = ((bLens ^= aLat) b, i)+        | otherwise    = go (i+1) 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 = go 0+  where+    go i a+        | aLat == bLat = ((bLens ^= aLat) b, i)+        | i >= n-1     = ((bLens ^= universal) b, i)+        | otherwise    = go (i+1) 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.)+
+ src/Feldspar/Matrix.hs view
@@ -0,0 +1,222 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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+-- this module assume rectangular matrices.++module Feldspar.Matrix where++import qualified Prelude as P+import qualified Data.TypeLevel as TL++import Feldspar.Prelude+import Feldspar.Core+import Feldspar.Wrap+import Feldspar.Vector.Internal++++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.+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 vector).+thawMatrix' :: Type a => Length -> Length -> Data [[a]] -> Matrix a+thawMatrix' y x = map (thawVector' x) . thawVector' y++-- | Constructs a matrix. The elements are stored in a core array.+matrix :: Type a => [[a]] -> Matrix a+matrix = value++-- | Constructing a matrix from an index function.+--+-- @indexedMat m n ixf@:+--+--   * @m@ is the number of rows.+--+--   * @n@ is the number of columns.+--+--   * @ifx@ is a function mapping indexes to elements (first argument is row+--     index; second argument is column index).+indexedMat+    :: Data Length+    -> Data Length+    -> (Data Index -> Data Index -> Data a)+    -> Matrix a+indexedMat m n idx = indexed m $ \k -> indexed n $ \l -> idx k l++-- | Transpose of a matrix. 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.++-- | Concatenates the rows of a matrix.+flatten :: Type a => Matrix a -> Vector (Data a)+flatten matr = Indexed (m*n) ixf Empty+  where+    m = length matr+    n = (m==0) ? (0, length (head matr))++    ixf i = matr ! y ! x+      where+        y = i `div` n+        x = i `mod` n+  -- TODO Should use linear indexing++-- | The diagonal vector of a square matrix. It happens to work if the number of+-- rows is less than the number of columns, but not the other way around (this+-- would require some overhead).+diagonal :: Type a => Matrix a -> Vector (Data a)+diagonal m = zipWith (!) m (0 ... (length m - 1))++distributeL :: (a -> b -> c) -> a -> Vector b -> Vector c+distributeL f = map . f++distributeR :: (a -> b -> c) -> Vector a -> b -> Vector c+distributeR = flip . distributeL . flip++++class Mul a b+  where+    type Prod a b++    -- | General multiplication operator+    (***) :: a -> b -> Prod a b++instance Numeric a => Mul (Data a) (Data a)+  where+    type Prod (Data a) (Data a) = Data a+    (***) = (*)++instance Numeric a => Mul (Data a) (Vector1 a)+  where+    type Prod (Data a) (Vector1 a) = Vector1 a+    (***) = distributeL (***)++instance Numeric a => Mul (Vector1 a) (Data a)+  where+    type Prod (Vector1 a) (Data a) = Vector1 a+    (***) = distributeR (***)++instance Numeric a => Mul (Data a) (Matrix a)+  where+    type Prod (Data a) (Matrix a) = Matrix a+    (***) = distributeL (***)++instance Numeric a => Mul (Matrix a) (Data a)+  where+    type Prod (Matrix a) (Data a) = Matrix a+    (***) = distributeR (***)++instance Numeric a => Mul (Vector1 a) (Vector1 a)+  where+    type Prod (Vector1 a) (Vector1 a) = Data a+    (***) = scalarProd++instance Numeric a => Mul (Vector1 a) (Matrix a)+  where+    type Prod (Vector1 a) (Matrix a) = (Vector1 a)+    vec *** mat = distributeL (***) vec (transpose mat)++instance Numeric a => Mul (Matrix a) (Vector1 a)+  where+    type Prod (Matrix a) (Vector1 a) = (Vector1 a)+    (***) = distributeR (***)++instance Numeric a => Mul (Matrix a) (Matrix a)+  where+    type Prod (Matrix a) (Matrix a) = (Matrix a)+    (***) = distributeR (***)++++-- | Matrix multiplication+mulMat :: Numeric a => Matrix a -> Matrix a -> Matrix a+mulMat = (***)++++class Syntax a => ElemWise a+  where+    type Scalar a++    -- | Operator for general element-wise multiplication+    elemWise :: (Scalar a -> Scalar a -> Scalar a) -> a -> a -> a++instance Type a => ElemWise (Data a)+  where+    type Scalar (Data a) = Data a+    elemWise = id++instance (ElemWise a, Syntax (Vector a)) => ElemWise (Vector a)+  where+    type Scalar (Vector a) = Scalar a+    elemWise = zipWith . elemWise++(.+) :: (ElemWise a, Num (Scalar a)) => a -> a -> a+(.+) = elemWise (+)++(.-) :: (ElemWise a, Num (Scalar a)) => a -> a -> a+(.-) = elemWise (-)++(.*) :: (ElemWise a, Num (Scalar a)) => a -> a -> a+(.*) = elemWise (*)++-- * Wrapping for matrices++instance (Type a) => Wrap (Matrix a) (Data [[a]]) where+    wrap = freezeMatrix++instance (Wrap t u, Type a, TL.Nat row, TL.Nat col) => Wrap (Matrix a -> t) (Data' (row,col) [[a]] -> u) where+    wrap f = \(Data' d) -> wrap $ f $ thawMatrix' row' col' d where+        row' = fromInteger $ toInteger $ TL.toInt (undefined :: row)+        col' = fromInteger $ toInteger $ TL.toInt (undefined :: col)+
+ src/Feldspar/Option.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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)+  where+    type Domain (Option a)   = FeldDomainAll+    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 ?>+
+ src/Feldspar/Par.hs view
@@ -0,0 +1,92 @@+--+-- 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+  , divConq+  )+where++import Language.Syntactic (sugarSymC)++import Feldspar.Core.Constructs (Syntax())+import Feldspar.Core.Constructs.Par+import Feldspar.Core.Frontend.Par++runPar :: Syntax a => P a -> a+runPar = sugarSymC ParRun++new :: Syntax a => P (IVar a)+new = sugarSymC ParNew++get :: Syntax a => IVar a -> P a+get = sugarSymC ParGet++put :: Syntax a => IVar a -> a -> P ()+put = sugarSymC ParPut++fork :: P () -> P ()+fork = sugarSymC ParFork++yield :: P ()+yield = sugarSymC ParYield++spawn :: Syntax a => P a -> P (IVar a)+spawn p = do+    r <- new+    fork (p >>= put r)+    return r++pval :: Syntax a => a -> P (IVar a)+pval a = spawn (return a)++parMap :: Syntax b => (a -> b) -> [a] -> P [b]+parMap f xs = mapM (pval . f) xs >>= mapM get++parMapM :: Syntax b => (a -> P b) -> [a] -> P [b]+parMapM f xs = mapM (spawn . f) xs >>= mapM get++divConq :: Syntax b => (a -> Bool) -> (a -> [a]) -> ([b] -> b) -> (a -> b) -> a -> P b+divConq indiv split join f = go+  where+    go prob | indiv prob = return (f prob)+            | otherwise  = do+                sols <- parMapM go (split prob)+                return (join sols)+
+ src/Feldspar/Prelude.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.+--++-- | Reexports a minimal subset of the "Prelude" to open up for reusing+-- "Prelude" identifiers in Feldspar++module Feldspar.Prelude+  ( module Prelude+  ) where++++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+  )+
+ src/Feldspar/Range.hs view
@@ -0,0 +1,686 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# 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.+--++-- | Bounded integer ranges++module Feldspar.Range where++-- 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 Feldspar.Lattice++--------------------------------------------------------------------------------+-- * Definition+--------------------------------------------------------------------------------++-- | A bounded range of values of type @a@+data Range a = Range+  { lowerBound :: a+  , upperBound :: a+  }+    deriving (Eq, Show)++-- | Convenience alias for bounded integers+class    (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.+--   @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 (undefined::a) = s+    | otherwise               = u++-- | Shows a bound.+showBound :: (Show a, BoundedInt a) => a -> String+showBound a+    | a  `elem` [maxBound,minBound] = "*"+    | otherwise                     = show a++-- | A textual representation of ranges.+showRange :: (Show a, BoundedInt a) => Range a -> String+showRange r@(Range l u)+  | isEmpty r     = "[]"+  | isSingleton r = show u+  | otherwise     = "[" ++ showBound l ++ "," ++ showBound u ++ "]"++-- | Requires a monotonic function+mapMonotonic :: (a -> b) -> Range a -> Range b+mapMonotonic f (Range l u) = Range (f l) (f u)++-- | Requires a monotonic function+mapMonotonic2 :: (a -> b -> c) -> Range a -> Range b -> Range c+mapMonotonic2 f (Range l1 u1) (Range l2 u2) = Range (f l1 l2) (f u1 u2)++++--------------------------------------------------------------------------------+-- * Lattice operations+--------------------------------------------------------------------------------++instance BoundedInt a => Lattice (Range a)+  where+    empty     = emptyRange+    universal = fullRange+    (\/)      = rangeUnion+    (/\)      = rangeIntersection++-- | The range containing no elements+emptyRange :: BoundedInt a => Range a+emptyRange = Range maxBound minBound++-- | The range containing all elements of a type+fullRange :: BoundedInt a => Range a+fullRange = Range minBound maxBound++-- | Construct a range+range :: Ord a => a -> a -> Range a+range x y | y < x     = Range y x+          | otherwise = Range x y++-- | The range containing one element+singletonRange :: a -> Range a+singletonRange a = Range a a++-- | The range from @0@ to the maximum element+naturalRange :: BoundedInt a => Range a+naturalRange = Range 0 maxBound++-- | The range from the smallest negative element to @-1@.+--   Undefined for unsigned types+negativeRange :: 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+--   @rangeSize (range minBound maxBound) :: Int@ gives a nonsense answer.+rangeSize :: BoundedInt a => Range a -> a+rangeSize (Range l u) = u-l+1++-- | Checks if the range is empty+isEmpty :: BoundedInt a => Range a -> Bool+isEmpty (Range l u) = u < l++-- | Checks if the range contains all values of the type+isFull :: BoundedInt a => Range a -> Bool+isFull = (==fullRange)++-- | Checks is the range contains exactly one element+isSingleton :: BoundedInt a => Range a -> Bool+isSingleton (Range l u) = l==u++-- | @r1 \`isSubRangeOf\` r2@ checks is all the elements in @r1@ are included+--   in @r2@+isSubRangeOf :: BoundedInt a => Range a -> Range a -> Bool+isSubRangeOf r1@(Range l1 u1) r2@(Range l2 u2)+    | isEmpty r1 = True+    | isEmpty r2 = False+    | otherwise  = (l1>=l2) && (u1<=u2)++-- | Checks whether a range is a sub-range of the natural numbers.+isNatural :: BoundedInt a => Range a -> Bool+isNatural = (`isSubRangeOf` naturalRange)++-- | Checks whether a range is a sub-range of the negative numbers.+isNegative :: BoundedInt a => Range a -> Bool+isNegative = (`isSubRangeOf` negativeRange)++-- | @a \`inRange\` r@ checks is @a@ is an element of the range @r@.+inRange :: BoundedInt a => a -> Range a -> Bool+inRange a r = singletonRange a `isSubRangeOf` r++-- | A convenience function for defining range propagation. If the input+--   range is empty then the result is also empty.+rangeOp :: BoundedInt a => (Range a -> Range a) -> (Range a -> Range a)+rangeOp f r = if isEmpty r then r else f r++-- | See 'rangeOp'.+rangeOp2 :: BoundedInt a =>+    (Range a -> Range a -> Range a) -> (Range a -> Range a -> Range a)+rangeOp2 f r1 r2+  | isEmpty r1 = r1+  | isEmpty r2 = r2+  | otherwise  = f r1 r2++-- | Union on ranges.+rangeUnion :: BoundedInt a => Range a -> Range a -> Range a+r1 `rangeUnion` r2+    | isEmpty r1 = r2+    | isEmpty r2 = r1+    | otherwise  = union r1 r2+  where+    union (Range l1 u1) (Range l2 u2) = Range (min l1 l2) (max u1 u2)++-- | Intersection on ranges.+rangeIntersection :: BoundedInt a => Range a -> Range a -> Range a+rangeIntersection = rangeOp2 intersection+  where+    intersection (Range l1 u1) (Range l2 u2) = Range (max l1 l2) (min u1 u2)++-- | @disjoint r1 r2@ returns true when @r1@ and @r2@ have no elements in+--   common.+disjoint :: BoundedInt a => Range a -> Range a -> Bool+disjoint r1 r2 = isEmpty (r1 /\ r2)++-- | @rangeGap r1 r2@ returns a range of all the elements between @r1@ and+--   @r2@ including the boundary elements. If @r1@ and @r2@ have elements in+--   common the result is an empty range.+rangeGap :: BoundedInt a => Range a -> Range a -> Range a+rangeGap = rangeOp2 gap+  where+    gap (Range l1 u1) (Range l2 u2)+      | u1 < l2 = range u1 l2+      | u2 < l1 = range u2 l1+    gap _ _     = emptyRange+  -- If the result is non-empty, it will include the boundary elements from the+  -- two ranges.++-- | @r1 \`rangeLess\` r2:@+--+-- Checks if all elements of @r1@ are less than all elements of @r2@.+rangeLess :: BoundedInt a => Range a -> Range a -> Bool+rangeLess r1 r2+  | isEmpty r1 || isEmpty r2 = True+rangeLess (Range _ u1) (Range l2 _) = u1 < l2++-- | @r1 \`rangeLessEq\` r2:@+--+-- Checks if all elements of @r1@ are less than or equal to all elements of+-- @r2@.+rangeLessEq :: BoundedInt a => Range a -> Range a -> Bool+rangeLessEq (Range _ u1) (Range l2 _) = u1 <= l2++++--------------------------------------------------------------------------------+-- * Propagation+--------------------------------------------------------------------------------++-- | @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)+  where+    fromInteger = singletonRange . fromInteger+    abs         = rangeAbs+    signum      = rangeSignum+    negate      = rangeNeg+    (+)         = rangeAdd+    (*)         = rangeMul+    (-)         = rangeSub++-- | Propagates range information through @abs@.+rangeAbs :: BoundedInt a => Range a -> Range a+rangeAbs = rangeOp $ \r -> case r of+    Range l u+      | isNatural  r -> r+      | r == singletonRange minBound -> r+      | minBound `inRange` r -> range minBound maxBound+      | isNegative r -> range (abs u) (abs l)+      | otherwise    -> range 0 (abs l `max` abs u)++-- | Propagates range information through 'signum'.+rangeSignum :: BoundedInt a => Range a -> Range a+rangeSignum = handleSign rangeSignumUnsigned rangeSignumSigned++-- | Signed case for 'rangeSignum'.+rangeSignumSigned :: BoundedInt a => Range a -> Range a+rangeSignumSigned = rangeOp sign+  where+    sign r+      | range (-1) 1 `isSubRangeOf` r = range (-1) 1+      | range (-1) 0 `isSubRangeOf` r = range (-1) 0+      | range 0 1    `isSubRangeOf` r = range 0 1+      | inRange 0 r                   = 0+      | isNatural r                   = 1+      | isNegative r                  = -1++-- | Unsigned case for 'rangeSignum'.+rangeSignumUnsigned :: BoundedInt a => Range a -> Range a+rangeSignumUnsigned = rangeOp sign+    where+      sign r+          | r == singletonRange 0 = r+          | not (0 `inRange` r)   = singletonRange 1+          | otherwise             = range 0 1++-- | Propagates range information through negation.+rangeNeg :: BoundedInt a => Range a -> Range a+rangeNeg = handleSign rangeNegUnsigned rangeNegSigned++-- | Unsigned case for 'rangeNeg'.+rangeNegUnsigned :: BoundedInt a => Range a -> Range a+rangeNegUnsigned (Range l u)+    | l == 0 && u /= 0 = fullRange+    | otherwise        = range (-u) (-l)+-- Code from Hacker's Delight++-- | Signed case for 'rangeNeg'.+rangeNegSigned :: BoundedInt a => Range a -> Range a+rangeNegSigned (Range l u)+    | l == minBound && u == minBound = singletonRange minBound+    | l == minBound                  = fullRange+    | otherwise                      = range (-u) (-l)+-- Code from Hacker's Delight++-- | Propagates range information through addition.+rangeAdd :: BoundedInt a => Range a -> Range a -> Range a+rangeAdd = handleSign rangeAddUnsigned rangeAddSigned++-- | Unsigned case for 'rangeAdd'.+rangeAddUnsigned :: BoundedInt a => Range a -> Range a -> Range a+rangeAddUnsigned (Range l1 u1) (Range l2 u2)+    | s >= l1 && t < u1 = fullRange+    | otherwise         = range s t+  where+    s = l1 + l2+    t = u1 + u2+-- Code from Hacker's Delight++-- | Signed case for 'rangeAdd'.+rangeAddSigned :: BoundedInt a => Range a -> Range a -> Range a+rangeAddSigned (Range a b) (Range c d)+    | (u .|. v) < 0 = fullRange+    | otherwise     = range s t+  where+    s = a + c+    t = b + d+    u = a .&. c .&. complement s .&. complement (b .&. d .&. complement t)+    v = ((a `xor` c) .|. complement (a `xor` s)) .&. (complement b .&. complement d .&. t)++-- | Propagates range information through subtraction.+rangeSub :: BoundedInt a => Range a -> Range a -> Range a+rangeSub = handleSign rangeSubUnsigned rangeSubSigned++-- | Unsigned case for 'rangeSub'.+rangeSubUnsigned :: BoundedInt a => Range a -> Range a -> Range a+rangeSubUnsigned (Range l1 u1) (Range l2 u2)+    | s > l1 && t <= u1 = fullRange+    | otherwise         = range s t+  where+    s = l1 - u2+    t = u1 - l2+  -- Note: This is more accurate than the default definition using 'negate',+  --       because 'negate' always overflows for unsigned numbers.+  -- Code from Hacker's Delight++rangeSubSigned :: BoundedInt a => Range a -> Range a -> Range a+rangeSubSigned (Range a b) (Range c d)+    | (u .|. v) < 0 = fullRange+    | otherwise     = range s t+  where+    s = a - d+    t = b - c+    u = a .&. complement d .&. complement s .&.+        complement (b .&. complement c .&. complement t)+    v = (xor a (complement d) .|. complement (xor a s)) .&.+        (complement b .&. c .&. t)+-- 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++-- | Signed case for 'rangeMul'.+rangeMulSigned :: forall a . BoundedInt a => Range a -> Range a -> Range a+rangeMulSigned r1 r2+    | r1 == singletonRange 0 || r2 == singletonRange 0 = singletonRange 0+    -- The following case is important because the 'maxAbs' function doesn't+    -- work for 'minBound' on signed numbers.+    | lowerBound r1 == minBound || lowerBound r2 == minBound+        = range minBound maxBound+    | bits (maxAbs r1) + bits (maxAbs r2) <= bitSize (undefined :: a) - 1+        = range (minimum [b1,b2,b3,b4]) (maximum [b1,b2,b3,b4])+    | otherwise = range minBound maxBound+  where maxAbs (Range l u) = max (abs l) (abs u)+        b1 = lowerBound r1 * lowerBound r2+        b2 = lowerBound r1 * upperBound r2+        b3 = upperBound r1 * lowerBound r2+        b4 = upperBound r1 * upperBound r2++-- | Unsigned case for 'rangeMul'.+rangeMulUnsigned :: forall a . BoundedInt a => Range a -> Range a -> Range a+rangeMulUnsigned r1 r2+    | bits (upperBound r1) + bits (upperBound r2)+      <= bitSize (undefined :: a)+        = mapMonotonic2 (*) r1 r2+    | otherwise = universal++-- | Returns the position of the highest bit set to 1. Counting starts at 1.+-- Beware! It doesn't terminate for negative numbers.+bits :: (Num b, Bits b) => b -> Int+bits b = loop b 0+    where loop 0 c = c+          loop n c = loop (n `shiftR` 1) (c+1)++-- | Propagates range information through exponentiation.+rangeExp :: BoundedInt a => Range a -> Range a -> Range a+rangeExp = handleSign rangeExpUnsigned rangeExpSigned++-- | Unsigned case for 'rangeExp'.+rangeExpUnsigned :: BoundedInt a => Range a -> Range a -> Range a+rangeExpUnsigned m@(Range l1 u1) e@(Range l2 u2)+    | toInteger (bits u1) * toInteger u2 > toInteger (bitSize l1) + 1 = universal+    | toInteger u1 ^ toInteger u2 > toInteger (maxBound `asTypeOf` l1) = universal+    | 0 `inRange` m && 0 `inRange` e = range 0 (max b1 b2)+    | otherwise = range b1 b2+  where b1 = l1 ^ l2+        b2 = u1 ^ u2++-- | Sigend case for 'rangeExp'+rangeExpSigned :: BoundedInt a => Range a -> Range a -> Range a+rangeExpSigned m _ | m == singletonRange (-1) = range (-1) 1+rangeExpSigned _ _ = universal++-- | Propagates range information through '.|.'.+rangeOr :: forall a . BoundedInt a => Range a -> Range a -> Range a+rangeOr = handleSign rangeOrUnsignedAccurate (\_ _ -> universal)++-- | Cheap and inaccurate range propagation for '.|.' on unsigned numbers.+rangeOrUnsignedCheap :: BoundedInt a => Range a -> Range a -> Range a+rangeOrUnsignedCheap (Range l1 u1) (Range l2 u2) =+    range (max l1 l2) (maxPlus u1 u2)+-- Code from Hacker's Delight.++-- | @a \`maxPlus\` b@ adds @a@ and @b@ but if the addition overflows then+--   'maxBound' is returned.+maxPlus :: BoundedInt a => a -> a -> a+maxPlus b d = if s < b then maxBound+              else s+  where s = b + d++-- | Accurate lower bound for '.|.' on unsigned numbers.+minOrUnsigned :: BoundedInt a => a -> a -> a -> a -> a+minOrUnsigned a b c d = loop (bit (bitSize a - 1))+  where loop 0 = a .|. c+        loop m+            | complement a .&. c .&. m > 0 =+                let temp = (a .|. m) .&. negate m+                in if temp <= b+                   then temp .|. c+                   else loop (shiftR m 1)+            | a .&. complement c .&. m > 0 =+                let temp = (c .|. m) .&. negate m+                in if temp <= d+                   then a .|. temp+                   else loop (shiftR m 1)+            | otherwise = loop (shiftR m 1)+-- Code from Hacker's Delight.++-- | Accurate upper bound for '.|.' on unsigned numbers.+maxOrUnsigned :: BoundedInt a => a -> a -> a -> a -> a+maxOrUnsigned a b c d = loop (bit (bitSize a - 1))+  where loop 0 = b .|. d+        loop m+             | b .&. d .&. m > 0 =+                 let temp = (b - m) .|. (m - 1)+                 in if temp >= a+                    then temp .|. d+                    else let tmp = (d - m) .|. (m - 1)+                         in if tmp >= c+                            then b .|. tmp+                            else loop (shiftR m 1)+             | otherwise = loop (shiftR m 1)+-- Code from Hacker's Delight.++-- | Accurate range propagation through '.|.' for unsigned types.+rangeOrUnsignedAccurate :: BoundedInt a => Range a -> Range a -> Range a+rangeOrUnsignedAccurate (Range l1 u1) (Range l2 u2) =+    range (minOrUnsigned l1 u1 l2 u2) (maxOrUnsigned l1 u1 l2 u2)+-- Code from Hacker's Delight.++-- | Propagating range information through '.&.'.+rangeAnd :: forall a . BoundedInt a => Range a -> Range a -> Range a+rangeAnd = handleSign rangeAndUnsignedCheap (\_ _ -> universal)++-- | Cheap and inaccurate range propagation for '.&.' on unsigned numbers.+rangeAndUnsignedCheap :: BoundedInt a => Range a -> Range a -> Range a+rangeAndUnsignedCheap (Range _ u1) (Range _ u2) = range 0 (min u1 u2)+-- Code from Hacker's Delight.++-- | Propagating range information through 'xor'.+rangeXor :: forall a . BoundedInt a => Range a -> Range a -> Range a+rangeXor = handleSign rangeXorUnsigned  (\_ _ -> universal)++-- | Unsigned case for 'rangeXor'.+rangeXorUnsigned :: BoundedInt a => Range a -> Range a -> Range a+rangeXorUnsigned (Range _ u1) (Range _ u2) = range 0 (maxPlus u1 u2)+-- Code from Hacker's Delight.++-- | Propagating range information through 'shiftLU'.+rangeShiftLU :: (BoundedInt a, BoundedInt b) => Range a -> Range b -> Range a+rangeShiftLU = handleSign rangeShiftLUUnsigned (\_ _ -> universal)+-- TODO: improve accuracy++-- | Unsigned case for 'rangeShiftLU'.+rangeShiftLUUnsigned :: (Bounded a, Bits a, Integral a, Integral b)+                     => Range a -> Range b -> Range a+rangeShiftLUUnsigned (Range _ u1) (Range _ u2)+    | toInteger (bits u1) + fromIntegral u2 > toInteger (bitSize u1) = universal+rangeShiftLUUnsigned (Range l1 u1) (Range l2 u2)+    = range (shiftL l1 (fromIntegral l2)) (shiftL u1 (fromIntegral u2))++-- | Propagating range information through 'shiftRU'.+rangeShiftRU :: (BoundedInt a, BoundedInt b) => Range a -> Range b -> Range a+rangeShiftRU = handleSign rangeShiftRUUnsigned (\_ _ -> universal)+-- TODO: improve accuracy++-- | Unsigned case for 'rangeShiftRU'.+rangeShiftRUUnsigned :: (Num a, Bits a, Ord a, Bounded b, Integral b, Bits b)+                     => Range a -> Range b -> Range a+rangeShiftRUUnsigned (Range l1 u1) (Range l2 u2)+    = range (correctShiftRU l1 u2) (correctShiftRU u1 l2)++-- | This is a replacement fror Haskell's shiftR. If we carelessly use+--   Haskell's variant then we will get left shifts for very large shift values.+correctShiftRU :: (Num a, Bits a, BoundedInt b) => a -> b -> a+correctShiftRU _ i | i > fromIntegral (maxBound :: Int) = 0+correctShiftRU a i = shiftR a (fromIntegral i)++-- | Propagating range information through 'complement'+rangeComplement :: (Bits a, BoundedInt a) => Range a -> Range a+rangeComplement (Range l u) = range (complement l) (complement u)++-- | Propagates range information through 'max'.+rangeMax :: BoundedInt a => Range a -> Range a -> Range a+rangeMax r1 r2+    | isEmpty r1        = r2+    | isEmpty r2        = r1+    | r1 `rangeLess` r2 = r2+    | r2 `rangeLess` r1 = r1+    | otherwise         = mapMonotonic2 max r1 r2++-- | Analogous to 'rangeMax'+rangeMin :: BoundedInt a => Range a -> Range a -> Range a+rangeMin r1 r2+    | isEmpty r1        = r2+    | isEmpty r2        = r1+    | r1 `rangeLess` r2 = r1+    | r2 `rangeLess` r1 = r2+    | otherwise         = mapMonotonic2 min r1 r2++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) &&+      minBound `inRange` d && (-1) `inRange` r = fullRange+    | d `rangeLess` r && isNatural r && isNatural d = d+    | isNatural r = range 0 (pred (upperBound r))+    | r `rangeLess` d && isNeg r && isNeg d = d+    | isNeg r = range (succ (lowerBound r)) 0+    where+      isNeg = (`isSubRangeOf` negs)+      negs  = negativeRange \/ 0+rangeMod _ (Range l u) = Range (succ l) (pred u)++-- | Propagates range information through 'rem'.+-- Note that we assume Haskell semantics for 'rem'.+rangeRem :: BoundedInt a => Range a -> Range a -> Range a+rangeRem d r+    | isSigned (lowerBound d) &&+      minBound `inRange` d && (-1) `inRange` r = fullRange+    | d `rangeLessAbs` r && isNatural d = d+    | isNatural d = range 0 (pred (upperBound (abs r)))+    | d `absRangeLessAbs` r && isNeg d = d+    | isNeg d = range (negate (upperBound (abs r))) 0+    where+      isNeg = (`isSubRangeOf` negs)+      negs  = negativeRange \/ 0+rangeRem _ (Range l u)+    | abs l >= abs u || l == minBound = range (succ $ negate $ abs l) (predAbs l)+    | otherwise      = range (succ $ negate $ abs u) (predAbs u)++predAbs :: (Bounded a, Eq a, Num a, Enum a) => a -> a+predAbs l | l == minBound = abs (succ l)+          | otherwise     = pred (abs l)++-- | Propagates range information through 'div'+rangeDiv :: BoundedInt a => Range a -> Range a -> Range a+rangeDiv = handleSign rangeDivU (\_ _ -> universal)++-- | Unsigned case for 'rangeDiv'+rangeDivU :: BoundedInt a => Range a -> Range a -> Range a+rangeDivU (Range _  _ ) (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)++-- | Unsigned case for 'rangeQuot'.+rangeQuotU :: BoundedInt a => Range a -> Range a -> Range a+rangeQuotU (Range _  _ ) (Range l2 u2) | l2 == 0 || u2 == 0 = universal+rangeQuotU (Range l1 u1) (Range l2 u2) = Range (l1 `quot` u2) (u1 `quot` l2)++-- | Writing @d \`rangeLess\` abs r@ doesn't mean what you think it does because+-- 'r' may contain minBound which doesn't have a positive representation.+-- Instead, this function should be used.+rangeLessAbs :: (Bounded a, Integral a, Bits a)+             => Range a -> Range a -> Bool+rangeLessAbs d r+    | r == singletonRange minBound+        = lowerBound d /= minBound+    | lowerBound r == minBound+        = d `rangeLess` abs (range (succ (lowerBound r)) (upperBound r))+    | otherwise = d `rangeLess` abs r++-- | Similar to 'rangeLessAbs' but replaces the expression+--   @abs d \`rangeLess\` abs r@ instead.+absRangeLessAbs :: (Bounded a, Integral a, Bits a)+                => Range a -> Range a -> Bool+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 d. BoundedInt d => Range d -> Range d -> Range d) ->+          (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 d . BoundedInt d => Range d -> Range d) ->+        (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++
+ src/Feldspar/Repa.hs view
@@ -0,0 +1,513 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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.Sugar+import Feldspar hiding (desugar,sugar,resugar)++import QuickAnnotate++-- | * 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 dimensions 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)+  where+    type Domain (Vector sh a)   = FeldDomainAll+    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)++type instance Elem      (Vector sh a) = a+type instance CollIndex (Vector sh a) = sh+type instance CollSize  (Vector sh a) = sh++instance Syntax a => Indexed (Vector sh a)+  where+    (Vector _ ixf) ! i = ixf i++instance (Syntax a, Shape sh) => Sized (Vector sh a)+  where+    collSize    = extent+    setCollSize = newExtent++instance CollMap (Vector sh a) (Vector sh a)+  where+    collMap = map++-- | * 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 the extent of the vector to the supplied value. If the supplied+-- extent will contain more elements than the old extent, the new elements+-- will have undefined value.+newExtent :: sh -> Vector sh a -> Vector sh a+newExtent sh (Vector _ ixf) = Vector sh ixf++-- | 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 Z :. _ :. 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) $+                        const $ fromVector . stencil . toVector (extent vec)+++-- Matrix Multiplication++transpose2D :: Vector DIM2 e -> Vector DIM2 e+transpose2D vec+  = backpermute new_extent swp vec+  where swp (Z :. i :. j) = Z :. j :. i+        new_extent        = swp (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+    vaRepl = replicate (Z :. All   :. colsB :. All) vA+    vbRepl = replicate (Z :. rowsA :. All   :. All) vB+    (Z :. _     :. rowsA) = extent vA+    (Z :. colsB :. _    ) = extent vB++-- One dimensional vectors, meant to help transitioning from+-- the old vector library++mapDIM1 :: (Data Index -> Data Index) -> DIM1 -> DIM1+mapDIM1 ixmap (Z :. i) = (Z :. ixmap i)++indexed :: Data Length -> (Data Index -> a) -> Vector DIM1 a+indexed l idxFun = Vector (Z :. l) (\ (Z :. i) -> idxFun i)++length :: Vector DIM1 a -> Data Length+length (Vector (Z :. l) _) = l++--------------------------------------------------------------------------------+-- * Operations on one dimensional vectors+--------------------------------------------------------------------------------++-- | 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 DIM1 a -> Vector DIM1 a+newLen l (Vector (Z :. _) ixf) = Vector (Z :. l) ixf++(++) :: Syntax a => Vector DIM1 a -> Vector DIM1 a -> Vector DIM1 a+Vector (Z :. l1) ixf1 ++ Vector (Z :. l2) ixf2+    = Vector (Z :. l1 + l2) (\ (Z :. i) -> i < l1 ? (ixf1 (Z :. i)+                                                    ,ixf2 (Z :. (i + l1))))++infixr 5 ++++take :: Data Length -> Vector DIM1 a -> Vector DIM1 a+take n (Vector (Z :. l) ixf) = Vector (Z :. (min n l)) ixf++drop :: Data Length -> Vector DIM1 a -> Vector DIM1 a+drop n (Vector (Z :. l) ixf) = Vector (Z :. (l - min l n)) (ixf . mapDIM1 (+ n))++splitAt :: Data Index -> Vector DIM1 a -> (Vector DIM1 a, Vector DIM1 a)+splitAt n vec = (take n vec, drop n vec)++head :: Syntax a => Vector DIM1 a -> a+head = (! (Z :. 0))++last :: Syntax a => Vector DIM1 a -> a+last vec = vec ! (Z :. (length vec - 1))++tail :: Vector DIM1 a -> Vector DIM1 a+tail = drop 1++init :: Vector DIM1 a -> Vector DIM1 a+init vec = take (length vec - 1) vec++tails :: Vector DIM1 a -> Vector DIM1 (Vector DIM1 a)+tails vec = indexed (length vec + 1) (\n -> drop n vec)++inits :: Vector DIM1 a -> Vector DIM1 (Vector DIM1 a)+inits vec = indexed (length vec + 1) (\n -> take n vec)++inits1 :: Vector DIM1 a -> Vector DIM1 (Vector DIM1 a)+inits1 = tail . inits++-- | Permute a vector+permute :: (Data Length -> Data Index -> Data Index) -> (Vector DIM1 a -> Vector DIM1 a)+permute perm (Vector s@(Z :. l) ixf) = Vector s (ixf . mapDIM1 (perm l))++reverse :: Syntax a => Vector DIM1 a -> Vector DIM1 a+reverse = permute $ \l i -> l-1-i++rotateVecL :: Syntax a => Data Index -> Vector DIM1 a -> Vector DIM1 a+rotateVecL ix = permute $ \l i -> (i + ix) `rem` l++rotateVecR :: Syntax a => Data Index -> Vector DIM1 a -> Vector DIM1 a+rotateVecR ix = reverse . rotateVecL ix . reverse++replicate1 :: Data Length -> a -> Vector DIM1 a+replicate1 n a = Vector (Z :. n) (const a)++-- | @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 DIM1 (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 DIM1 (Data Index)+enumFrom = flip enumFromTo (value maxBound)++unzip :: Vector DIM1 (a,b) -> (Vector DIM1 a, Vector DIM1 b)+unzip (Vector l ixf) = (Vector l (fst.ixf), Vector l (snd.ixf))++-- | Corresponds to the standard 'foldl'.+foldl :: (Syntax a) => (a -> b -> a) -> a -> Vector DIM1 b -> a+foldl f x (Vector (Z :. l) ixf) = forLoop l x $ \ix s -> f s (ixf (Z :. ix))++-- | Corresponds to the standard 'foldl1'.+fold1 :: Syntax a => (a -> a -> a) -> Vector DIM1 a -> a+fold1 f a = foldl f (head a) (tail a)++sum1 :: (Syntax a, Num a) => Vector DIM1 a -> a+sum1  = foldl (+) 0++maximum :: Ord a => Vector DIM1 (Data a) -> Data a+maximum = fold1 max++minimum :: Ord a => Vector DIM1 (Data a) -> Data a+minimum = fold1 min++-- | Scalar product of two vectors+scalarProd :: (Syntax a, Num a) => Vector DIM1 a -> Vector DIM1 a -> a+scalarProd a b = sum1 (zipWith (*) a b)++++--------------------------------------------------------------------------------+-- Misc.+--------------------------------------------------------------------------------++tVec :: Patch a a -> Patch (Vector DIM1 a) (Vector DIM1 a)+tVec _ = id++tVec1 :: Patch a a -> Patch (Vector DIM1 (Data a)) (Vector DIM1 (Data a))+tVec1 _ = id++tVec2 :: Patch a a -> Patch (Vector DIM2 (Data a)) (Vector DIM2 (Data a))+tVec2 _ = id++instance Annotatable a => Annotatable (Vector s a)+  where+    annotate info (Vector len ixf) = Vector+        (annotate (info P.++ " (vector length)") len)+        (annotate (info P.++ " (vector element)") . ixf)+
+ src/Feldspar/Stream.hs view
@@ -0,0 +1,480 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}++--+-- 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+    ,tail+    ,map,mapNth+    ,maps+    ,intersperse+    ,interleave+    ,downsample+    ,duplicate+    ,scan, scan1+    ,mapAccum+    ,iterate+    ,repeat+    ,unfold+    ,drop+    ,zip,zipWith+    ,unzip+    ,take+    ,splitAt+    ,cycle+    ,streamAsVector, streamAsVectorSize+    ,recurrenceO, recurrenceI, recurrenceIO, recurrenceIIO+    ,slidingAvg+    ,iir,fir+    )+    where++import qualified Prelude as P++import Feldspar+import Feldspar.Vector.Internal+         (Vector, Vector1+         ,freezeVector,indexed+         ,sum,length,replicate,scalarProd)++-- | Infinite streams.+data Stream a where+  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 :: Syntax a => Stream a -> a+head (Stream next init) = runMutable (init >>= next)++-- | Drop the first element of a stream+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 :: (Syntax a, Syntax b) =>+       (a -> b) -> Stream a -> Stream b+map f (Stream next init) = Stream newNext init+  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 :: (Syntax a) =>+          (a -> a) -> Data Index -> Data Index -> Stream a -> Stream a+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 :: (Syntax a) =>+        [a -> a] -> Stream a -> Stream a+maps fs (Stream next initial) = Stream newNext newInit+  where+    newInit = do+      r  <- newRef (0 :: Data Index)+      st <- initial+      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) x ->+                            i==(P.fromIntegral k)?(f a,x)))+         a (P.zip [1..] fs)++-- | 'intersperse a str' inserts an 'a' between each element of the stream+--    'str'.+intersperse :: Syntax a => a -> Stream a -> Stream a+intersperse a s = interleave s (repeat a)++-- | Create a new stream by alternating between the elements from+--   the two input streams+interleave :: Syntax a => Stream a -> Stream a -> Stream a+interleave (Stream next1 init1) (Stream next2 init2)+    = 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 :: Syntax a => Data Index -> Stream a -> Stream a+downsample n (Stream next init) = Stream newNext init+  where newNext st = do forM (n-1) (\_ -> next st)+                        next st++-- | 'duplicate n str' stretches the stream by duplicating the elements 'n' times+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 :: 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 x   <- next st+                        acc <- getRef r+                        setRef r (f acc x)+                        return acc+++-- | A scan but without an initial element.+scan1 :: Syntax a => (a -> a -> a) -> Stream a -> Stream a+scan1 f (Stream next init)+    = 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 :: (Syntax acc, Syntax b) =>+            (acc -> a -> (acc,b)) -> acc -> Stream a -> Stream b+mapAccum f acc (Stream next init)+    = Stream newNext newInit+  where+    newInit = do+      st <- init+      r  <- newRef acc+      return (st,r)+    newNext (st,r) = do+      x <- getRef r+      a <- next st+      let (acc',b) = f x 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 :: Syntax a => (a -> a) -> a -> Stream a+iterate f a = Stream next init+  where+    init = newRef a+    next r = do x <- getRef r+                setRef r (f x)+                return x++-- | Repeat an element indefinitely.+--+-- @repeat a = [a, a, a, ...]@+repeat :: Syntax a => a -> Stream a+repeat a = Stream return (return a)++-- | @unfold f acc@ creates a new stream by successively applying 'f' to+--   to the accumulator 'acc'.+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 :: 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 = zipWith (,)++-- | Pairs together two streams using a function to combine the+--   corresponding elements.+zipWith :: (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 :: (Syntax a, Syntax b) => Stream (a,b) -> (Stream a, Stream b)+unzip stream = (map fst stream, map snd stream)++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 :: (Syntax a) => Data Length -> Stream a -> Data [Internal a]+take n (Stream next init)+    = runMutableArray $ do+        marr <- newArr_ n+        st   <- init+        forM n $ \ix -> do+          a <- next st+          setArr marr ix (desugar 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+--   element 'n+1'.+splitAt :: (Syntax a) =>+           Data Length -> Stream a -> (Data [Internal a], Stream a)+splitAt n stream = (take n stream,drop n stream)++-- | Loops through a vector indefinitely to produce a stream.+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 :: 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 :: (Syntax a, Syntax b) =>+                  (Stream a -> Stream b)+               -> (Vector a -> Vector b)+streamAsVector f v = sugar $ 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 :: (Syntax a, Syntax b) =>+                      (Stream a -> Stream b) -> (Data Length -> Data Length)+                   -> (Vector a -> Vector b)+streamAsVectorSize f s v = sugar $ 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,+--   but only as many as the length of the input stream+--   It uses memory proportional to the input vector.+--+-- For exaple one can define the fibonacci sequence as follows:+--+-- > fib = recurrenceO (vector [0,1]) (\fib -> fib!0 + fib!1)+--+-- 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 =>+               Vector1 a ->+               (Vector1 a -> Data a) ->+               Stream (Data a)+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+--   similar to 'recurrenceO'. The difference is that that it has an input+--   stream, and that the recurrence equation may only refer to previous+--   inputs, it may not refer to previous outputs.+--+-- The sliding average of a stream can easily be implemented using+-- 'recurrenceI'.+--+-- > slidingAvg :: Data WordN -> Stream (Data WordN) -> Stream (Data WordN)+-- > slidingAvg n str = recurrenceI (replicate n 0) str+-- >                    (\input -> sum input `quot` n)+recurrenceI :: (Type a, Type b) =>+               Vector1 a -> Stream (Data a) ->+               (Vector1 a -> Data b) ->+               Stream (Data b)+recurrenceI ii stream mkExpr+    = recurrenceIO ii stream (value []) (\i _ -> mkExpr i)++-- | 'recurrenceIO' is a combination of 'recurrenceO' and 'recurrenceI'. It+--   has an input stream and the recurrence equation may refer both to+--   previous inputs and outputs.+--+--   'recurrenceIO' is used when defining the 'iir' filter.+recurrenceIO :: (Type a, Type b) =>+                Vector1 a -> Stream (Data a) -> Vector1 b ->+                (Vector1 a -> Vector1 b -> Data b) ->+                Stream (Data b)+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 (\ib ->+             withArray obuf (\ob ->+               return $ mkExpr+                          (indexed lenI (\i -> getIx ib ((i + ix) `rem` lenI)))+                          (indexed lenO (\i -> getIx ob ((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) =>+                 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 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 (\ib1 ->+               withArray ibuf2 (\ib2 ->+                 withArray obuf (\ob ->+                   return $ mkExpr (indexed len1 (\i -> getIx ib1 ((i + ix) `rem` len1)))+                                   (indexed len2 (\i -> getIx ib2 ((i + ix) `rem` len2)))+                                   (indexed lenO (\i -> getIx ob  ((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 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 :: Vector1 Float ->+       Stream (Data Float) -> Stream (Data Float)+fir b inp =+    recurrenceI (replicate (length b) 0) inp+                (scalarProd b)++-- | An iir filter on streams+iir :: Data Float -> Vector1 Float -> Vector1 Float ->+       Stream (Data Float) -> Stream (Data Float)+iir a0 a b inp =+    recurrenceIO (replicate (length b) 0) inp+                 (replicate (length a) 0)+      (\i o -> 1 / a0 * ( scalarProd b i+                        - scalarProd a o)+      )+
+ src/Feldspar/Vector.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.+--++-- | 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 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+--+--   * 'fold'+--+--   * 'fold1'+--+--   * Functions that introduce storage (see above)+--+--   * \"Folding\" functions: 'sum', 'maximum', etc.+--+-- These functions introduce overhead that is linear in the length of the+-- vector.++module Feldspar.Vector+    ( module Feldspar.Vector.Internal+    ) where++++import Feldspar()  -- For Haddock+import Feldspar.Vector.Internal hiding (freezeVector)+
+ src/Feldspar/Vector/Internal.hs view
@@ -0,0 +1,408 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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.Applicative+import qualified Data.TypeLevel as TL+import Test.QuickCheck++import QuickAnnotate++import Language.Syntactic hiding (fold)++import Feldspar.Range (rangeSubSat)+import Feldspar hiding (sugar,desugar,resugar)+import Feldspar.Wrap++import Data.Tuple.Curry+import Data.Tuple.Select+++--------------------------------------------------------------------------------+-- * 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 Vector1 a = Vector (Data a)++-- | Two-level nested vector+type Vector2 a = Vector (Vector (Data a))++instance Syntax a => Syntactic (Vector a)+  where+    type Domain (Vector a)   = FeldDomainAll+    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.sum $ Prelude.map segmentLength $ segments vec++-- | Converts a segmented vector to a vector with a single segment.+mergeSegments :: Syntax a => Vector a -> Vector a+mergeSegments Empty = Empty+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 []                     = const $ err "indexing in empty vector"+    ixFun (Empty : vs)           = ixFun vs+    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 Empty                = value []+freezeVector (Indexed l ixf cont) = parallel l ixf `append` freezeVector 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++++--------------------------------------------------------------------------------+-- * 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 b)+  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) (`drop` vec)++inits :: Vector a -> Vector (Vector a)+inits vec = indexed (length vec + 1) (`take` 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 integers from @m@ to @n@+--+enumFromTo :: forall a. (Integral a)+           => Data a -> Data a -> Vector (Data a)+enumFromTo 1 n+    | IntType U _ <- typeRep :: TypeRep a+    = indexed (i2n n) ((+1) . i2n)+enumFromTo m n = indexed (i2n l) ((+m) . i2n)+  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 :: (Integral a) => Data a -> Vector (Data a)+enumFrom = flip enumFromTo (value maxBound)++-- | See 'enumFromTo'+(...) :: (Integral a) => Data a -> Data a -> Vector (Data a)+(...) = enumFromTo++-- | 'map' @f v@ is the 'Vector' obtained by applying f to each element of+-- @f@.+map :: (a -> b) -> Vector a -> Vector b+map _ Empty = Empty+map f (Indexed l ixf cont) = Indexed l (f . ixf) $ map f cont++-- | Zipping two 'Vector's+zip :: (Syntax a, Syntax b) => Vector a -> Vector b -> Vector (a,b)+zip v1 v2 = go (mergeSegments v1) (mergeSegments v2)+  where+    go Empty _ = Empty+    go _ Empty = Empty+    go (Indexed l1 ixf1 Empty) (Indexed l2 ixf2 Empty) =+      indexed (min l1 l2) ((,) <$> ixf1 <*> ixf2)++-- | Zipping three 'Vector's+zip3 :: (Syntax a, Syntax b, Syntax c)+     => Vector a -> Vector b -> Vector c -> Vector (a,b,c)+zip3 v1 v2 v3 = go (mergeSegments v1) (mergeSegments v2) (mergeSegments v3)+  where+    go Empty _ _ = Empty+    go _ Empty _ = Empty+    go _ _ Empty = Empty+    go (Indexed l1 ixf1 Empty) (Indexed l2 ixf2 Empty) (Indexed l3 ixf3 Empty) =+      indexed (Prelude.foldr1 min [l1,l2,l3]) ((,,) <$> ixf1 <*> ixf2 <*> ixf3)++-- | Zipping four 'Vector's+zip4 :: (Syntax a, Syntax b, Syntax c, Syntax d)+     => Vector a -> Vector b -> Vector c -> Vector d -> Vector (a,b,c,d)+zip4 v1 v2 v3 v4 = go (mergeSegments v1) (mergeSegments v2) (mergeSegments v3) (mergeSegments v4)+  where+    go Empty _ _ _ = Empty+    go _ Empty _ _ = Empty+    go _ _ Empty _ = Empty+    go _ _ _ Empty = Empty+    go (Indexed l1 ixf1 Empty) (Indexed l2 ixf2 Empty) (Indexed l3 ixf3 Empty) (Indexed l4 ixf4 Empty) =+      indexed (Prelude.foldr1 min [l1,l2,l3,l4]) ((,,,) <$> ixf1 <*> ixf2 <*> ixf3 <*> ixf4)++-- | Zipping five 'Vector's+zip5 :: (Syntax a, Syntax b, Syntax c, Syntax d, Syntax e)+     => Vector a -> Vector b -> Vector c -> Vector d -> Vector e -> Vector (a,b,c,d,e)+zip5 v1 v2 v3 v4 v5 = go (mergeSegments v1) (mergeSegments v2) (mergeSegments v3) (mergeSegments v4) (mergeSegments v5)+  where+    go Empty _ _ _ _ = Empty+    go _ Empty _ _ _ = Empty+    go _ _ Empty _ _ = Empty+    go _ _ _ Empty _ = Empty+    go _ _ _ _ Empty = Empty+    go (Indexed l1 ixf1 Empty) (Indexed l2 ixf2 Empty) (Indexed l3 ixf3 Empty) (Indexed l4 ixf4 Empty) (Indexed l5 ixf5 Empty) =+      indexed (Prelude.foldr1 min [l1,l2,l3,l4,l5]) ((,,,,) <$> ixf1 <*> ixf2 <*> ixf3 <*> ixf4 <*> ixf5)++-- | Unzip to two 'Vector's+unzip :: Vector (a,b) -> (Vector a, Vector b)+unzip v = (map sel1 v, map sel2 v)++-- | Unzip to three 'Vector's+unzip3 :: Vector (a,b,c) -> (Vector a, Vector b, Vector c)+unzip3 v = (map sel1 v, map sel2 v, map sel3 v)++-- | Unzip to four 'Vector's+unzip4 :: Vector (a,b,c,d) -> (Vector a, Vector b, Vector c, Vector d)+unzip4 v = (map sel1 v, map sel2 v, map sel3 v, map sel4 v)++-- | Unzip to five 'Vector's+unzip5 :: Vector (a,b,c,d,e) -> (Vector a, Vector b, Vector c, Vector d, Vector e)+unzip5 v = (map sel1 v, map sel2 v, map sel3 v, map sel4 v, map sel5 v)++-- | Generalization of 'zip' using the supplied function instead of tupling+-- to combine the elements+zipWith :: (Syntax a, Syntax b) =>+    (a -> b -> c) -> Vector a -> Vector b -> Vector c+zipWith f a b = map (uncurryN f) $ zip a b++-- | Generalization of 'zip3' using the supplied function instead of tupling+-- to combine the elements+zipWith3 :: (Syntax a, Syntax b, Syntax c) =>+    (a -> b -> c -> d) -> Vector a -> Vector b -> Vector c -> Vector d+zipWith3 f a b c = map (uncurryN f) $ zip3 a b c++-- | Generalization of 'zip4' using the supplied function instead of tupling+-- to combine the elements+zipWith4 :: (Syntax a, Syntax b, Syntax c, Syntax d) =>+    (a -> b -> c -> d -> e) -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e+zipWith4 f a b c d = map (uncurryN f) $ zip4 a b c d++-- | Generalization of 'zip5' using the supplied function instead of tupling+-- to combine the elements+zipWith5 :: (Syntax a, Syntax b, Syntax c, Syntax d, Syntax e) =>+    (a -> b -> c -> d -> e -> f) -> Vector a -> Vector b -> Vector c -> Vector d -> Vector e -> Vector f+zipWith5 f a b c d e = map (uncurryN f) $ zip5 a b c d e++-- | 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 = freezeVector++instance (Wrap t u, Type a, TL.Nat s) => Wrap (Vector1 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 _    Empty                  = Empty+    annotate info (Indexed len ixf cont) = Indexed+        (annotate (info Prelude.++ " (vector length)") len)+        (annotate (info Prelude.++ " (vector element)") . ixf)+        (annotate info cont)+
+ src/Feldspar/Vector/Push.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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.Vector.Push where++import qualified Prelude++import Feldspar hiding (sugar,desugar)+import qualified Feldspar.Vector as V++import Language.Syntactic (Syntactic(..))++data PushVector a where+  Push :: ((Data Index -> a -> M ()) -> M ()) -> Data Length -> PushVector a++instance Syntax a => Syntactic (PushVector a)+  where+    type Domain (PushVector a)   = FeldDomainAll+    type Internal (PushVector a) = [Internal a]+    desugar = desugar . freezePush+    sugar   = thawPush . sugar++-- | Store push vectors in memory.+freezePush :: Syntax a => PushVector a -> Data [Internal a]+freezePush (Push k l) = runMutableArray $ do+                          arr <- newArr_ l+                          k (\i a -> setArr arr i (resugar a))+                          return arr++-- | Store a push vector to memory and return it as an ordinary vector.+freezeToVector :: Syntax a => PushVector a -> V.Vector a+freezeToVector = V.map resugar . V.thawVector . freezePush++-- | Create a push vector from an array stored in memory.+thawPush :: Syntax a => Data [Internal a] -> PushVector a+thawPush arr = Push f (getLength arr)+  where f k = forM (getLength arr) $ \ix ->+                k ix (resugar (arr ! ix))++instance Syntax a => Syntax (PushVector a)++-- | Any kind of vector, push or pull, can cheaply be converted to a push vector+class Pushy arr where+  toPush :: Syntax a => arr a -> PushVector a++instance Pushy PushVector where+  toPush = id++instance Pushy V.Vector where+  toPush vec = Push (\k -> forM (length vec) (\i -> k i (vec!i))) (length vec)++instance Functor PushVector where+  fmap f (Push g l) = Push (\k -> g (\i a -> k i (f a))) l++-- | Concatenating two arrays.+(++) :: (Pushy arr, Syntax a) => arr a -> arr a -> PushVector a+v1 ++ v2 = Push (\func -> f func >>+                          g (\i a -> func (l1 + i) a))+                (l1 + l2)+  where+    Push f l1 = toPush v1+    Push g l2 = toPush v2++-- | Given an array of pairs, flatten the array so that the elements of the+--   pairs end up next to each other in the resulting vector.+unpair :: (Pushy arr, Syntax a) => arr (a,a) -> PushVector a+unpair arr = Push (\k -> f (everyOther k)) (2 * l)+  where+    Push f l = toPush arr++everyOther :: (Data Index -> a -> M b)+           -> Data Index -> (a,a) -> M b+everyOther f = \ix (a1,a2) -> f (ix * 2) a1 >> f (ix * 2 + 1) a2++-- | Interleaves the elements of two vectors.+zipUnpair :: Syntax a => V.Vector a -> V.Vector a -> PushVector a+zipUnpair v1 v2 = unpair (V.zip v1 v2)++-- | An overloaded function for reordering elements of a vector.+class Ixmap arr where+  ixmap :: Syntax a => (Data Index -> Data Index) -> arr a -> arr a++instance Ixmap V.Vector where+  ixmap f vec = V.indexed (length vec) (\i -> vec ! (f i))++instance Ixmap PushVector where+  ixmap f (Push g l) = Push (\k -> g (\i a -> k (f i) a)) l++-- | Reverse a vector. Works for both push and pull vectors.+reverse :: (Ixmap arr, Len arr, Syntax a) =>+           arr a -> arr a+reverse arr = ixmap (\ix -> length arr - ix - 1) arr++-- | Split a pull vector in half.+--+--   If the input vector has an odd length the second result vector+--   will be one element longer than the first.+halve :: Syntax a => V.Vector a -> (V.Vector a, V.Vector a)+halve v = (V.indexed (l `div` 2) ixf+       	  ,V.indexed ((l+1) `div` 2) (\i -> ixf (i + (l `div` 2))))+  where l   = length v+  	ixf = (v!)++-- | Split a vector in half and interleave the two two halves.+riffle :: Syntax a => V.Vector a -> PushVector a+riffle = unpair . uncurry V.zip . halve++-- | A class for overloading `length` for both pull and push vectors+class Len arr where+  length :: arr a -> Data Length++instance Len V.Vector where+  length = V.length++instance Len PushVector where+  length (Push _ l) = l++-- | This function can distribute array computations on chunks of a large+--   pull vector. A call `chunk l f g v` will split the vector `v` into chunks+--   of size `l` and apply `f` to these chunks. In case the length of `v` is+--   not a multiple of `l` then the rest of `v` will be processed by `g`.+chunk :: (Pushy arr1, Pushy arr2, Syntax b)+      => Data Length            -- ^ Size of the chunks+      -> (V.Vector a -> arr1 b) -- ^ Applied to every chunk+      -> (V.Vector a -> arr2 b) -- ^ Applied to the rest of the vector+      -> V.Vector a+      -> PushVector b+chunk c f g v = Push loop (noc * c)+             ++ toPush (g (V.drop (noc * c) v))+  where l = length v+        noc = l `div` c+        loop func = forM noc $ \i ->+                      do let (Push k _) = toPush $ f (V.take c (V.drop (c*i) v))+                         k (\j a -> func (c*i + j) a)++-- | The empty push vector.+empty :: PushVector a+empty = Push (const (return ())) 0++-- | Flattens a pull vector containing push vectors into an unnested push vector+--+--   Note that there are no restrictions on the lengths of the push vectors+--   inside the pull vector.+flatten :: Syntax a => V.Vector (PushVector a) -> PushVector a+flatten v = Push f len+  where len = V.sum (V.map length v)+  	f k = do l <- newRef 0+	      	 forM (length v) $ \i ->+		   do let (Push g m) = v ! i+		      n <- getRef l+		      g (\j a -> k (n + j) a)+		      setRef l (n+m)
+ src/Feldspar/Wrap.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--+-- 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 = wrap . f++-- | 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)+  where+    type Domain (Data' s a)   = FeldDomainAll+    type Internal (Data' s a) = a+    desugar = desugar . unData'+    sugar   = Data' . sugar++instance Type a => Syntax (Data' s a)+
+ tests/DecorationTests.hs view
@@ -0,0 +1,19 @@+module Main where++-- To generate the golden files use a script similiar to this one+-- > ghc -e 'B.writeFile "tests/gold/example9.txt" $ B.pack $ showDecor example9' tests/DecorationTests.hs -iexamples++import Test.Framework+import Test.Golden++import qualified Data.ByteString.Lazy.Char8 as B++import Feldspar (showDecor)+import Examples.Simple.Basics++tests = testGroup "DecorationTests"+    [ goldenVsString "example9" "tests/gold/example9.txt" $ return $ B.pack $ showDecor example9+    ]++main = defaultMain [tests]+
+ tests/Feldspar/Range/Test.hs view
@@ -0,0 +1,501 @@+{-# LANGUAGE CPP                  #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ConstraintKinds #-}++--+-- 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.+--++-- | Bounded integer ranges++module Feldspar.Range.Test where++-- 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 Feldspar.Range+import System.Random -- Should maybe be exported from QuickCheck+import Test.QuickCheck hiding ((.&.))+import qualified Test.QuickCheck as QC+import Test.Framework+import Test.Framework.Providers.QuickCheck2++import Data.Bits+import Data.Int+import Data.Word+import Data.Typeable++import Feldspar.Lattice++tests = [ testGroup "Range Int"    $ typedTestsSigned   "Int"    (undefined :: Int)+        , testGroup "Range Int8"   $ typedTestsSigned   "Int8"   (undefined :: Int8)+        , testGroup "Range Word8"  $ typedTestsUnsigned "Word8"  (undefined :: Word8)+        , testGroup "Range Word32" $ typedTestsUnsigned "Word32" (undefined :: Word32)+        ]++typedTests name typ =+    [ testProperty (unwords ["prop_empty"          , name]) (prop_empty typ)+    , testProperty (unwords ["prop_full"           , name]) (prop_full typ)+    , testProperty (unwords ["prop_isEmpty"        , name]) (prop_isEmpty typ)+    , testProperty (unwords ["prop_singletonRange" , name]) (prop_singletonRange typ)+    , testProperty (unwords ["prop_singletonSize"  , name]) (prop_singletonSize typ)+    , testProperty (unwords ["prop_emptySubRange1" , name]) (prop_emptySubRange1 typ)+    , testProperty (unwords ["prop_emptySubRange2" , name]) (prop_emptySubRange2 typ)+    , testProperty (unwords ["prop_rangeGap"       , name]) (prop_rangeGap typ)+    , testProperty (unwords ["prop_union1"         , name]) (prop_union1 typ)+    , testProperty (unwords ["prop_union2"         , name]) (prop_union2 typ)+    , testProperty (unwords ["prop_union3"         , name]) (prop_union3 typ)+    , testProperty (unwords ["prop_union4"         , name]) (prop_union4 typ)+    , testProperty (unwords ["prop_intersect1"     , name]) (prop_intersect1 typ)+    , testProperty (unwords ["prop_intersect2"     , name]) (prop_intersect2 typ)+    , testProperty (unwords ["prop_intersect3"     , name]) (prop_intersect3 typ)+    , testProperty (unwords ["prop_intersect4"     , name]) (prop_intersect4 typ)+    , testProperty (unwords ["prop_intersect5"     , name]) (prop_intersect5 typ)+    , testProperty (unwords ["prop_disjoint"       , name]) (prop_disjoint typ)+    , testProperty (unwords ["prop_rangeLess1"     , name]) (prop_rangeLess1 typ)+    , testProperty (unwords ["prop_rangeLess2"     , name]) (prop_rangeLess2 typ)+    , testProperty (unwords ["prop_rangeLessEq"    , name]) (prop_rangeLessEq typ)+    , testProperty (unwords ["prop_rangeByRange1"  , name]) (prop_rangeByRange1 typ)+    , testProperty (unwords ["prop_rangeByRange2"  , name]) (prop_rangeByRange2 typ)+    , testProperty (unwords ["prop_fromInteger"    , name]) (prop_fromInteger typ)+    , testProperty (unwords ["prop_abs"            , name]) (prop_abs typ)+    , testProperty (unwords ["prop_sign"           , name]) (prop_sign typ)+    , testProperty (unwords ["prop_neg"            , name]) (prop_neg typ)+    , testProperty (unwords ["prop_add"            , name]) (prop_add typ)+    , testProperty (unwords ["prop_sub"            , name]) (prop_sub typ)+    , testProperty (unwords ["prop_mul"            , name]) (prop_mul typ)+    , testProperty (unwords ["prop_exp"            , name]) (prop_exp typ)+    , testProperty (unwords ["prop_abs2"           , name]) (prop_abs2 typ)+    , testProperty (unwords ["prop_or"             , name]) (prop_or typ)+    , testProperty (unwords ["prop_and"            , name]) (prop_and typ)+    , testProperty (unwords ["prop_xor"            , name]) (prop_xor typ)+    , testProperty (unwords ["prop_rangeMax1"      , name]) (prop_rangeMax1 typ)+    , testProperty (unwords ["prop_rangeMax2"      , name]) (prop_rangeMax2 typ)+    , testProperty (unwords ["prop_rangeMax3"      , name]) (prop_rangeMax3 typ)+    , testProperty (unwords ["prop_rangeMax4"      , name]) (prop_rangeMax4 typ)+    , testProperty (unwords ["prop_rangeMax5"      , name]) (prop_rangeMax5 typ)+    , testProperty (unwords ["prop_rangeMax6"      , name]) (prop_rangeMax6 typ)+    , testProperty (unwords ["prop_rangeMax7"      , name]) (prop_rangeMax7 typ)+    , testProperty (unwords ["prop_rangeMin1"      , name]) (prop_rangeMin1 typ)+    , testProperty (unwords ["prop_rangeMin2"      , name]) (prop_rangeMin2 typ)+    , testProperty (unwords ["prop_rangeMin3"      , name]) (prop_rangeMin3 typ)+    , testProperty (unwords ["prop_rangeMin4"      , name]) (prop_rangeMin4 typ)+    , testProperty (unwords ["prop_rangeMin5"      , name]) (prop_rangeMin5 typ)+    , testProperty (unwords ["prop_rangeMin6"      , name]) (prop_rangeMin6 typ)+    , testProperty (unwords ["prop_rangeMin7"      , name]) (prop_rangeMin7 typ)+    , testProperty (unwords ["prop_rangeMod1"      , name]) (prop_rangeMod1 typ)+    , testProperty (unwords ["prop_rangeMod2"      , name]) (prop_rangeMod2 typ)+    , testProperty (unwords ["prop_rangeRem"       , name]) (prop_rangeRem typ)+    , testProperty (unwords ["prop_rangeQuot"      , name]) (prop_rangeQuot typ)+    ]++typedTestsUnsigned name typ = typedTests name typ +++    [ testProperty (unwords ["prop_mulU"           , name]) (prop_mulU typ)+    , testProperty (unwords ["prop_subSat"         , name]) (prop_subSat typ)+    ]++typedTestsSigned name typ = typedTests name typ +++    [ testProperty (unwords ["prop_isNegative"     , name]) (prop_isNegative typ)+    , testProperty (unwords ["prop_rangeMod3"      , name]) (prop_rangeMod3 typ)+    , testProperty (unwords ["prop_rangeRem1"      , name]) (prop_rangeRem1 typ)+    , testProperty (unwords ["prop_rangeQuot1"     , name]) (prop_rangeQuot1 typ)+    ]++--------------------------------------------------------------------------------+-- * Testing+--------------------------------------------------------------------------------++instance (BoundedInt a, Arbitrary a) => Arbitrary (Range a)+  where+    arbitrary = do+      [bound1,bound2] <- vectorOf 2 $ oneof+                         [ arbitrary+                         , elements [minBound,-1,0,1,maxBound]]+      frequency+                [ (10, return $+                     Range (min bound1 bound2) (max bound1 bound2))+                , (1 , return $+                     Range (max bound1 bound2) (min bound1 bound2)) -- Empty+                , (1 , return $+                     Range bound1 bound1)  -- Singleton+                ]++    shrink (Range x y) =+      [ Range x' y | x' <- shrink x ] +++      [ Range x y' | y' <- shrink y ]++#if __GLASGOW_HASKELL__ < 704+instance Random Word32 where+  random g = (fromIntegral i,g')+   where (i :: Int,g') = random g+  randomR (l,u) g = (fromIntegral i,g')+    where (i :: Integer, g') = randomR (fromIntegral l,fromIntegral u) g++instance Random Int8 where+  random g = (fromIntegral i,g')+   where (i :: Int,g') = random g+  randomR (l,u) g = (fromIntegral i,g')+    where (i :: Integer, g') = randomR (fromIntegral l,fromIntegral u) g++instance Random Word8 where+  random g = (fromIntegral i,g')+   where (i :: Int,g') = random g+  randomR (l,u) g = (fromIntegral i,g')+    where (i :: Integer, g') = randomR (fromIntegral l,fromIntegral u) g+#endif++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 _ = r++-- | Applies a (monadic) function to all the types we are interested in testing+-- with for Feldspar.+--+-- Example usage: 'atAllTypes (quickCheck . prop_mul)'+atAllTypes :: (Monad m) =>+              (forall t . (Show t, BoundedInt t, Random t, Arbitrary t, Typeable t) =>+                      t -> m a)+                  -> m ()+atAllTypes test = sequence_ [test (undefined :: Int)+                            ,test (undefined :: Int8)+                            ,test (undefined :: Word32)+                            ,test (undefined :: Word8)+                            ]++-- | 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}++++--------------------------------------------------------------------------------+-- ** Lattice operations+--------------------------------------------------------------------------------++prop_empty t = isEmpty (emptyRange `rangeTy` t)++prop_full t = isFull (fullRange `rangeTy` t)++prop_isEmpty t r = isEmpty r ==> (upperBound r < lowerBound (r `rangeTy` t))++prop_singletonRange t a = isSingleton (singletonRange (a `asTypeOf` t))++prop_singletonSize t r = isSingleton (r `rangeTy` t) ==> (rangeSize r == 1)++prop_emptySubRange1 t r1 r2 =+    isEmpty (r1 `rangeTy` t) ==> (not (isEmpty r2) ==>+                                      not (r2 `isSubRangeOf` r1))++prop_emptySubRange2 t r1 r2 =+    isEmpty (r1 `rangeTy` t) ==> (not (isEmpty r2) ==> (r1 `isSubRangeOf` r2))++prop_rangeGap t r1 r2 =+    (isEmpty gap1 && isEmpty gap2) || (gap1 == gap2)+  where+    gap1 = rangeGap r1 r2+    gap2 = rangeGap r2 r1+    _    = r1 `rangeTy` t++prop_union1 t x r1 r2 =+    ((x `inRange` r1) || (x `inRange` r2)) ==> (x `inRange` (r1\/r2))+  where _ = x `asTypeOf` t++prop_union2 t x r1 r2 =+    (x `inRange` (r1\/r2)) ==>+        ((x `inRange` r1) || (x `inRange` r2) || (x `inRange` rangeGap r1 r2))+  where _ = x `asTypeOf` t++prop_union3 t r1 r2 = (r1 `rangeTy` t) `isSubRangeOf` (r1\/r2)+prop_union4 t r1 r2 = (r2 `rangeTy` t) `isSubRangeOf` (r1\/r2)+++prop_intersect1 t x r1 r2 =+    ((x `inRange` r1) && (x `inRange` r2)) ==> (x `inRange` (r1/\r2))+  where _ = x `asTypeOf` t+prop_intersect2 t x r1 r2 =+    (x `inRange` (r1/\r2)) ==> ((x `inRange` r1) && (x `inRange` r2))+  where _ = x `asTypeOf` t++prop_intersect3 t r1 r2 = (r1/\r2) `isSubRangeOf` (r1 `rangeTy` t)+prop_intersect4 t r1 r2 = (r1/\r2) `isSubRangeOf` (r2 `rangeTy` t)++prop_intersect5 t r1 r2 =+    isEmpty r1 || isEmpty r2 ==> isEmpty (r1/\r2)+  where _ = r1 `rangeTy` t++prop_disjoint t x r1 r2 =+    disjoint r1 r2 ==> (x `inRange` r1) ==> not (x `inRange` r2)+  where _ = x `asTypeOf` t+++prop_rangeLess1 t r1 r2 =+    rangeLess r1 r2 ==> disjoint r1 (r2 `rangeTy` t)++prop_rangeLess2 t r1 r2 =+    not (isEmpty r1) && not (isEmpty r2) ==>+    forAll (fromRange r1) $ \x ->+    forAll (fromRange r2) $ \y ->+    rangeLess r1 r2 ==> x < y+  where _ = r1 `rangeTy` t++prop_rangeLessEq t r1 r2 =+    not (isEmpty r1) && not (isEmpty r2) ==>+    forAll (fromRange r1) $ \x ->+    forAll (fromRange r2) $ \y ->+    rangeLessEq r1 r2 ==> x <= y+  where _ = r1 `rangeTy` t+++--------------------------------------------------------------------------------+-- ** Propagation+--------------------------------------------------------------------------------++prop_propagation1 :: (Show t, BoundedInt t, Random t) =>+                     t -> (forall a . Num a => a -> a) -> Range t -> Property+prop_propagation1 _ op r =+    not (isEmpty r) ==>+    forAll (fromRange r) $ \x ->+    op x `inRange` op r++-- | This function is useful for range propagation functions like+-- 'rangeMax', 'rangeMod' etc.+-- It takes two ranges, picks an element out of either ranges and+-- checks if applying the operation to the individual elements is in+-- the resulting range after range propagation.+--+-- The third argument is a precondition that is satisfied before the test is+-- run. A good example is to make sure that the second argument is non-zero+-- when testing division.+rangePropagationSafetyPre :: (Show t, Random t, BoundedInt t, BoundedInt a) =>+    t ->+    (t -> t -> a) -> (Range t -> Range t -> Range a) ->+    (t -> t -> Bool) ->+    Range t -> Range t -> Property+rangePropagationSafetyPre _ op rop pre r1 r2 =+    not (isEmpty r1) && not (isEmpty r2) ==>+    forAll (fromRange r1) $ \v1 ->+    forAll (fromRange r2) $ \v2 ->+        pre v1 v2 ==>+        op v1 v2 `inRange` rop r1 r2++rangePropagationSafetyPre2 ::+    (Show t, Show t2, Random t, BoundedInt t, Random t2, BoundedInt t2, BoundedInt a) =>+    t -> t2 ->+    (t -> t2 -> a) -> (Range t -> Range t2 -> Range a) ->+    (t -> t2 -> Bool) ->+    Range t -> Range t2 -> Property+rangePropagationSafetyPre2 _ _ op rop pre r1 r2 =+    not (isEmpty r1) && not (isEmpty r2) ==>+    forAll (fromRange r1) $ \v1 ->+    forAll (fromRange r2) $ \v2 ->+        pre v1 v2 ==>+        op v1 v2 `inRange` rop r1 r2++rangePropagationSafety t op rop = rangePropagationSafetyPre t op rop noPre+  where+    noPre _ _ = True++rangePropSafety1 t op rop ran =+    not (isEmpty ran) ==>+    forAll (fromRange ran) $ \val ->+        op val `inRange` rop ran+  where _ = ran `rangeTy` t++prop_propagation2+    :: (Show t, BoundedInt t, Random t) => t -> (forall a . Num a => a -> a -> a)+    -> Range t -> Range t -> Property+prop_propagation2 t op = rangePropagationSafety t op op++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+prop_sign t = prop_propagation1 t signum+prop_neg  t = prop_propagation1 t negate+prop_add  t = prop_propagation2 t (+)+prop_sub  t = prop_propagation2 t (-)+prop_mul  t = prop_propagation2 t (*)++prop_exp  t = rangePropagationSafetyPre t (^) rangeExp (\_ e -> e >= 0)++prop_mulU t = rangePropagationSafety t (*) rangeMulUnsigned++prop_subSat t = rangePropagationSafety t subSat rangeSubSat++prop_isNegative t r =+    not (isEmpty r) && (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++prop_and t = rangePropagationSafety t (.&.) rangeAnd++prop_xor t = rangePropagationSafety t xor rangeXor++prop_shiftLU t1 t2+    = rangePropagationSafetyPre2 t1 t2 fixShiftL rangeShiftLU (\_ _ -> True)+  where fixShiftL a b = shiftL a (fromIntegral b)++prop_shiftRU t1 t2+    = rangePropagationSafetyPre2 t1 t2 fixShiftR rangeShiftRU (\_ _ -> True)+  where fixShiftR = correctShiftRU++prop_rangeMax1 t r1 = rangeMax r1 r1 == (r1 `rangeTy` t)++prop_rangeMax2 t r1 r2 =+    not (isEmpty r1) && not (isEmpty r2) ==>+    upperBound r1 <= upperBound max && upperBound r2 <= upperBound max+    where+      max = rangeMax r1 (r2 `rangeTy` t)++prop_rangeMax3 t r1 r2 =+    not (isEmpty r1) && not (isEmpty r2) ==>+  lowerBound (rangeMax r1 r2) == max (lowerBound r1) (lowerBound r2)+  where _ = r1 `rangeTy` t++prop_rangeMax4 t r1 r2 =+    not (isEmpty r1) && not (isEmpty r2) ==>+    rangeMax r1 r2 == rangeMax r2 r1+  where _ = r1 `rangeTy` t++prop_rangeMax5 t r1 r2 =+    (isEmpty r1 && not (isEmpty r2) ==>+    rangeMax r1 r2 == r2)+    QC..&.+    (isEmpty r2 && not (isEmpty r1) ==>+    rangeMax r1 r2 == r1)+  where _ = r1 `rangeTy` t++prop_rangeMax6 t v1 v2 =+    max v1 v2 `inRange` rangeMax (singletonRange v1) (singletonRange v2)+  where _ = v1 `asTypeOf` t++prop_rangeMax7 a = rangePropagationSafety a max rangeMax++prop_rangeMin1 t r1 = rangeMin r1 r1 == (r1 `rangeTy` t)++prop_rangeMin2 t r1 r2 =+    not (isEmpty r1) && not (isEmpty r2) ==>+    lowerBound min <= lowerBound r1 && lowerBound min <= lowerBound r2+    where+      min = rangeMin r1 (r2 `rangeTy` t)++prop_rangeMin3 t r1 r2 =+    not (isEmpty r1) && not (isEmpty r2) ==>+  upperBound (rangeMin r1 r2) == min (upperBound r1) (upperBound r2)+  where _ = r1 `rangeTy` t++prop_rangeMin4 t r1 r2 =+    not (isEmpty r1) && not (isEmpty r2) ==>+    rangeMin r1 r2 == rangeMin r2 r1+  where _ = r1 `rangeTy` t++prop_rangeMin5 t r1 r2 =+    (isEmpty r1 && not (isEmpty r2) ==>+    rangeMin r1 r2 == r2)+    QC..&.+    (isEmpty r2 && not (isEmpty r1) ==>+    rangeMin r1 r2 == r1)+  where _ = r1 `rangeTy` t++prop_rangeMin6 t v1 v2 =+    min v1 v2 `inRange` rangeMin (singletonRange v1) (singletonRange v2)+  where _ = v1 `asTypeOf` t++prop_rangeMin7 t = rangePropagationSafety t min rangeMin++prop_rangeMod1 t v1 v2 =+    v2 /= 0 ==>+    mod v1 v2 `inRange` rangeMod (singletonRange v1) (singletonRange v2)+  where _ = v1 `asTypeOf` t++prop_rangeMod2 t =+    rangePropagationSafetyPre t mod rangeMod divPre++prop_rangeMod3 t =+        isFull $ rangeMod (singletonRange (minBound `asTypeOf` t))+                          (singletonRange (-1))++prop_rangeRem t =+    rangePropagationSafetyPre t rem rangeRem divPre++prop_rangeRem1 t =+        isFull $ rangeRem (singletonRange (minBound `asTypeOf` t))+                          (singletonRange (-1))++prop_rangeQuot t =+    rangePropagationSafetyPre t quot rangeQuot divPre++prop_rangeQuot1 t =+        isFull $ rangeQuot (singletonRange (minBound `asTypeOf` t))+                           (singletonRange (-1))++-- | Precondition for division like operators.+--   Avoids division by zero and arithmetic overflow.+divPre v1 v2 = v2 /= 0 && not (v1 == minBound && v2 == (-1))+
+ tests/Feldspar/Vector/Test.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE TemplateHaskell #-}++module Feldspar.Vector.Test where++import qualified Prelude as P+import qualified Data.List as P++import Feldspar+import Feldspar.Prelude+import Feldspar.Vector.Internal++import Test.Framework+import Test.Framework.TH+import Test.Framework.Providers.QuickCheck2++tests = $(testGroupGenerator)++prop_freeze_thaw = eval (freezeVector . thawVector) === (id :: [Index] -> [Index])+prop_thaw_freeze = eval (thawVector . freezeVector) === (id :: [Index] -> [Index])++prop_length = eval (length -:: tVec1 tIndex >-> tData tLength) === P.genericLength++prop_append = eval ((++) -:: tVec1 tIndex >-> id >-> id) === (P.++)+prop_take   = eval (take -:: tData tLength >-> tVec1 tIndex >-> id) === P.genericTake+prop_drop   = eval (drop -:: tData tLength >-> tVec1 tIndex >-> id) === P.genericDrop+prop_revrev = eval ((reverse . reverse) -:: tVec1 tIndex >-> id) === id+
+ tests/RangeTest.hs view
@@ -0,0 +1,8 @@+module Main where++import Feldspar.Range.Test++import Test.Framework++main = defaultMain tests+
+ tests/SemanticsTest.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE TemplateHaskell #-}++module Main where++import Test.Framework+import Test.Framework.TH+import Test.Framework.Providers.QuickCheck2++import Feldspar ((===), eval)+import Examples.Simple.Basics+import qualified Feldspar.Vector.Test++prop_example5 = eval example5 === (+)+prop_example9 = eval example9 === \a -> if a<5 then 3*(a+20) else 30*(a+20)++tests = $(testGroupGenerator)++main = defaultMain [ tests+                   , Feldspar.Vector.Test.tests+                   ]+