feldspar-language 0.1 → 0.2

raw patch · 18 files changed

+1898/−1254 lines, 18 filesdep +QuickCheckdep −directorydep −processdep −tfpPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck

Dependencies removed: directory, process, tfp

API changes (from Hackage documentation)

Files

• Feldspar.hs +6/−2
• Feldspar/Core.hs +16/−9
• Feldspar/Core/Expr.hs +388/−489
• Feldspar/Core/Functions.hs +187/−24
• Feldspar/Core/Graph.hs +6/−4
• Feldspar/Core/Haskell.hs +0/−77
• Feldspar/Core/Ref.hs +1/−3
• Feldspar/Core/Reify.hs +316/−0
• Feldspar/Core/Show.hs +42/−23
• Feldspar/Core/Types.hs +189/−243
• Feldspar/Haskell.hs +99/−0
• Feldspar/Matrix.hs +29/−32
• Feldspar/Prelude.hs +4/−3
• Feldspar/Range.hs +403/−0
• Feldspar/Utils.hs +8/−2
• Feldspar/Vector.hs +191/−333
• LICENSE +1/−1
• feldspar-language.cabal +12/−9

@@ -1,4 +1,4 @@--- Copyright (c) 2009, ERICSSON AB+-- Copyright (c) 2009-2010, ERICSSON AB -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without@@ -24,7 +24,7 @@ -- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- | Exports everything necessary for ordinary use of the Feldspar language.+-- | Interface to the Feldspar language.  module Feldspar   ( module Feldspar.Prelude@@ -34,6 +34,10 @@   ) where  ++import qualified Prelude+  -- In order to be able to play with the Feldspar module in GHCi without+  -- getting name clashes.  import Feldspar.Prelude import Feldspar.Core

@@ -1,4 +1,4 @@--- Copyright (c) 2009, ERICSSON AB+-- Copyright (c) 2009-2010, ERICSSON AB -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without@@ -24,42 +24,49 @@ -- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- | The user interface to the core language+-- | The user interface of the core language  module Feldspar.Core-  ( module Types.Data.Num-  , Primitive-  , (:>)+  ( Range (..)+  , (:>) (..)+  , Set (..)+  , Length   , Storable-  , ListBased+  , Size   , Data+  , dataSize   , Computable   , Internal   , eval   , value+  , array+  , arrayLen   , unit   , true   , false-  , array   , size+  , cap   , getIx   , setIx   , RandomAccess (..)+  , Numeric   , noInline   , ifThenElse   , while   , parallel   , Program   , showCore+  , showCoreWithSize   , printCore+  , printCoreWithSize   , module Feldspar.Core.Functions   ) where   -import Types.Data.Num-+import Feldspar.Range import Feldspar.Core.Types import Feldspar.Core.Expr+import Feldspar.Core.Reify import Feldspar.Core.Functions 

@@ -1,4 +1,4 @@--- Copyright (c) 2009, ERICSSON AB+-- Copyright (c) 2009-2010, ERICSSON AB -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without@@ -24,120 +24,182 @@ -- OR TORT (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 IncoherentInstances #-}+{-# LANGUAGE UndecidableInstances #-} --- | This module represents core programs as typed expressions (see 'Expr' /--- 'Data'). The idea is for programmers to use an interface based on 'Data',--- while back-end tools use the 'Graph' representation. The function 'toGraph'--- is used to convert between the two representations.+-- | This module gives a representation core programs as typed expressions (see+-- 'Expr' / 'Data').  module Feldspar.Core.Expr where   -import Control.Monad.State-import Control.Monad.Writer-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe+import Data.Monoid import Data.Unique -import Types.Data.Num--import Feldspar.Core.Ref (Ref)-import qualified Feldspar.Core.Ref as Ref+import Feldspar.Range import Feldspar.Core.Types-import Feldspar.Core.Graph hiding (function, Function (..))-import qualified Feldspar.Core.Graph as Graph-import Feldspar.Core.Show+import Feldspar.Core.Ref   --- * Expressions+-- | Typed core language expressions. A value of type @`Expr` a@ is a+-- representation of a program that computes a value of type @a@.+data Expr a+  where+    Input :: Size a -> Expr a+      -- XXX Risky to rely on observable sharing? +    Value :: Storable a => Size a -> a -> Expr a++    Tuple2 :: Data a -> Data b -> Expr (a,b)+    Tuple3 :: Data a -> Data b -> Data c -> Expr (a,b,c)+    Tuple4 :: Data a -> Data b -> Data c -> Data d -> Expr (a,b,c,d)+      -- XXX Tuple construction should be generalized.++    Get21 :: Data (a,b) -> Expr a+    Get22 :: Data (a,b) -> Expr b++    Get31 :: Data (a,b,c) -> Expr a+    Get32 :: Data (a,b,c) -> Expr b+    Get33 :: Data (a,b,c) -> Expr c++    Get41 :: Data (a,b,c,d) -> Expr a+    Get42 :: Data (a,b,c,d) -> Expr b+    Get43 :: Data (a,b,c,d) -> Expr c+    Get44 :: Data (a,b,c,d) -> Expr d+      -- XXX Tuple projection should be generalized.++    Function :: String -> Size b -> (a -> b) -> (Data a -> Expr b)++    NoInline :: String -> Ref (a :-> b) -> (Data a -> Expr b)++    IfThenElse+      :: Data Bool           -- Condition+      -> (a :-> b)           -- If branch+      -> (a :-> b)           -- Else branch+      -> (Data a -> Expr b)++    While+      :: (a :-> Bool)  -- Continue?+      -> (a :-> a)     -- Body+      -> Data a        -- Initial state+      -> Expr a        -- Final state++    Parallel+      :: Storable a+      => Data Length+      -> (Int :-> a)  -- Index mapping+      -> Expr [a]     -- Result vector++++data a :-> b = SubFunction (Data a -> Data b) (Data a) (Data b)+++ -- | A wrapper around 'Expr' to allow observable sharing (see--- "Feldspar.Core.Ref").-data Data a = Typeable a => Data (Ref (Expr a))+-- "Feldspar.Core.Ref") and for memoizing size information.+data Data a = Typeable a => Data (Size a) (Ref (Expr a))  instance Eq (Data a)   where-    Data a == Data b = a==b+    Data _ a == Data _ b = a==b+      -- Reference equality  instance Ord (Data a)   where-    Data a `compare` Data b = a `compare` b+    Data _ a `compare` Data _ b = a `compare` b+      -- Reference comparison   -ref :: Typeable a => Expr a -> Data a-ref = Data . Ref.ref+dataSize :: Data a -> Size a+dataSize (Data sz _) = sz -refId :: Data a -> Unique-refId (Data r) = Ref.refId r+dataType :: forall a . Data a -> Tuple StorableType+dataType a@(Data _ _) = typeOf (dataSize a) (T::T a) -deref :: Data a -> Expr a-deref (Data r) = Ref.deref r+dataId :: Data a -> Unique+dataId (Data _ r) = refId r -typeOfData :: forall a . Typeable a => Data a -> Tuple StorableType-typeOfData _ = typeOf (T::T a)+dataToExpr :: Data a -> Expr a+dataToExpr (Data _ r) = deref r +subFunSize :: (a :-> b) -> Size b+subFunSize (SubFunction _ _ outp) = dataSize outp +subAp :: (a :-> b) -> (Data a -> Data b)+subAp (SubFunction f _ _) = f --- | Typed core language expressions. A value of type @Expr a@ can be thought of--- as a representation of a program that computes a value of type @a@.-data Expr a+exprToData :: Typeable a => Expr a -> Data a+exprToData a = Data (exprSize a) (ref a)++++exprSize :: forall a . Typeable a => Expr a -> Size a++exprSize (Input sz)   = sz+exprSize (Value sz _) = sz++exprSize (Tuple2 a b)     = (dataSize a, dataSize b)+exprSize (Tuple3 a b c)   = (dataSize a, dataSize b, dataSize c)+exprSize (Tuple4 a b c d) = (dataSize a, dataSize b, dataSize c, dataSize d)++exprSize (Get21 ab) = da   where-    Input :: Expr a  -- XXX Risky to rely on observable sharing?-    Value :: Storable a => a -> Expr a+    (da,db) = dataSize ab -    Tuple2   :: Data a -> Data b -> Expr (a,b)-    Tuple3   :: Data a -> Data b -> Data c -> Expr (a,b,c)-    Tuple4   :: Data a -> Data b -> Data c -> Data d -> Expr (a,b,c,d)-    GetTuple :: GetTuple n a => T n -> Data a -> Expr (Part n a)+exprSize (Get22 ab) = db+  where+    (da,db) = dataSize ab -    Function :: String -> (a -> b) -> (Data a -> Expr b)+exprSize (Get31 abc) = da+  where+    (da,db,dc) = dataSize abc -    NoInline-      :: (Typeable a, Typeable b)-      => String -> Ref.Ref (Data a -> Data b) -> (Data a -> Expr b)+exprSize (Get32 abc) = db+  where+    (da,db,dc) = dataSize abc -    IfThenElse-      :: (Typeable a, Typeable b)-      => Data Bool           -- Condition-      -> (Data a -> Data b)  -- If branch-      -> (Data a -> Data b)  -- Else branch-      -> (Data a -> Expr b)+exprSize (Get33 abc) = dc+  where+    (da,db,dc) = dataSize abc -    While-      :: Typeable a-      => (Data a -> Data Bool)  -- Continue?-      -> (Data a -> Data a)     -- Body-      -> Data a                 -- Initial state-      -> Expr a                 -- Final state+exprSize (Get41 abcd) = da+  where+    (da,db,dc,dd) = dataSize abcd -    Parallel-      :: (NaturalT n, Storable a)-      => Data Int              -- Dynamic size (must be <= array size)-      -> (Data Int -> Data a)  -- Index mapping-      -> Expr (n :> a)         -- Result vector+exprSize (Get42 abcd) = db+  where+    (da,db,dc,dd) = dataSize abcd -  -- XXX Some Typeable constraints are needed because the sub-functions need to-  --     be applied to input. Perhaps it's better to scrap the hidden context in-  --     Data and put Typeable context on all Expr constructors instead?+exprSize (Get43 abcd) = dc+  where+    (da,db,dc,dd) = dataSize abcd +exprSize (Get44 abcd) = dd+  where+    (da,db,dc,dd) = dataSize abcd +exprSize (Function _ sz _ _)  = sz+exprSize (NoInline _ f a)     = subFunSize (deref f)+exprSize (IfThenElse _ t e a) = subFunSize t `mappend` subFunSize e+exprSize (While _ b i)        = dataSize i   `mappend` subFunSize b+exprSize (Parallel l ixf)     = mapMonotonic fromIntegral (dataSize l)+                                :> subFunSize ixf ++ -- | Computable types. A computable value completely represents a core program,--- in such a way that @internalize . externalize@ preserves semantics, but not--- necessarily syntax.+-- in such a way that @`internalize` `.` `externalize`@ preserves semantics, but+-- not necessarily syntax. -- -- The terminology used in this class comes from thinking of the 'Data' type as--- the \"internal core language\" and the core API as the \"external core--- language\".+-- the \"internal\" core language and the "Feldspar.Core" API as the+-- \"external\" core language. class Typeable (Internal a) => Computable a   where-    -- | The internal representation of the type @a@ (without the 'Data'-    -- constructor).+    -- | @`Data` (`Internal` a)@ is the internal representation of the type @a@.     type Internal a      -- | Convert to internal representation@@ -157,26 +219,26 @@   where     type Internal (a,b) = (Internal a, Internal b) -    internalize (a,b) = ref $ Tuple2 (internalize a) (internalize b)+    internalize (a,b) = exprToData $ Tuple2 (internalize a) (internalize b)      externalize ab =-        ( externalize $ ref $ GetTuple (T::T D0) ab-        , externalize $ ref $ GetTuple (T::T D1) ab+        ( externalizeE $ Get21 ab+        , externalizeE $ Get22 ab         )  instance (Computable a, Computable b, Computable c) => Computable (a,b,c)   where     type Internal (a,b,c) = (Internal a, Internal b, Internal c) -    internalize (a,b,c) = ref $ Tuple3+    internalize (a,b,c) = exprToData $ Tuple3       (internalize a)       (internalize b)       (internalize c)      externalize abc =-        ( externalize $ ref $ GetTuple (T::T D0) abc-        , externalize $ ref $ GetTuple (T::T D1) abc-        , externalize $ ref $ GetTuple (T::T D2) abc+        ( externalizeE $ Get31 abc+        , externalizeE $ Get32 abc+        , externalizeE $ Get33 abc         )  instance@@ -189,102 +251,139 @@   where     type Internal (a,b,c,d) = (Internal a, Internal b, Internal c, Internal d) -    internalize (a,b,c,d) = ref $ Tuple4+    internalize (a,b,c,d) = exprToData $ Tuple4       (internalize a)       (internalize b)       (internalize c)       (internalize d)      externalize abcd =-        ( externalize $ ref $ GetTuple (T::T D0) abcd-        , externalize $ ref $ GetTuple (T::T D1) abcd-        , externalize $ ref $ GetTuple (T::T D2) abcd-        , externalize $ ref $ GetTuple (T::T D3) abcd+        ( externalizeE $ Get41 abcd+        , externalizeE $ Get42 abcd+        , externalizeE $ Get43 abcd+        , externalizeE $ Get44 abcd         )   -wrap :: (Computable a, Computable b) =>+externalizeE :: Computable a => Expr (Internal a) -> a+externalizeE = externalize . exprToData++-- | Lower a function to operate on internal representation.+lowerFun :: (Computable a, Computable b) =>     (a -> b) -> (Data (Internal a) -> Data (Internal b))-wrap f = internalize . f . externalize+lowerFun f = internalize . f . externalize -unwrap :: (Computable a, Computable b) =>+-- | Lift a function to operate on external representation.+liftFun :: (Computable a, Computable b) =>     (Data (Internal a) -> Data (Internal b)) -> (a -> b)-unwrap f = externalize . f . internalize+liftFun f = externalize . f . internalize    -- | The semantics of expressions evalE :: Expr a -> a -evalE Input     = error "evaluating Input"-evalE (Value a) = a+evalE (Input _)   = error "evaluating Input"+evalE (Value _ a) = a  evalE (Tuple2 a b)     = (evalD a, evalD b) evalE (Tuple3 a b c)   = (evalD a, evalD b, evalD c) evalE (Tuple4 a b c d) = (evalD a, evalD b, evalD c, evalD d)-evalE (GetTuple n a)   = getTup n (evalD a) -evalE (Function _ f a)     = f (evalD a)-evalE (NoInline _ f a)     = evalD (Ref.deref f a)-evalE (IfThenElse c t e a) = if evalD c then evalD (t a) else evalD (e a)+evalE (Get21 ab) = a+  where+    (a,b) = evalD ab -evalE (While continue body init) = loop init+evalE (Get22 ab) = b   where-    loop s-        | done      = evalD s-        | otherwise = loop (body s)-      where-        done = not $ evalD $ continue s+    (a,b) = evalD ab -evalE (Parallel sz ixf) =-    mapArray (evalD . ixf . value) $ fromList [(0::Int) .. n-1]+evalE (Get31 abc) = a   where-    n = evalD sz+    (a,b,c) = evalD abc +evalE (Get32 abc) = b+  where+    (a,b,c) = evalD abc +evalE (Get33 abc) = c+  where+    (a,b,c) = evalD abc --- | Evaluation of 'Data'-evalD :: Data a -> a-evalD = evalE . deref+evalE (Get41 abcd) = a+  where+    (a,b,c,d) = evalD abcd --- | Evaluation of any 'Computable' type-eval :: Computable a => a -> Internal a-eval = evalD . internalize+evalE (Get42 abcd) = b+  where+    (a,b,c,d) = evalD abcd +evalE (Get43 abcd) = c+  where+    (a,b,c,d) = evalD abcd +evalE (Get44 abcd) = d+  where+    (a,b,c,d) = evalD abcd -instance Primitive a => Show (Data a)+evalE (Function _ _ f a)   = f (evalD a)+evalE (NoInline _ f a)     = evalD $ subAp (deref f) a+evalE (IfThenElse c t e a) = if evalD c+    then evalD (subAp t a)+    else evalD (subAp e a)++evalE (While continue body init) = loop init   where-    show a = "... :: Data a"-  -- Needed for the @Num@ instance.+    loop s = if done+        then evalD s+        else loop (subAp body s)+      where+        done = not $ evalD $ subAp continue s -instance (Num n, Primitive n) => Num (Data n)+evalE (Parallel l ixf) = map (evalD . subAp ixf . value) [0 .. n-1]   where-    fromInteger = value . fromInteger-    abs         = functionFold "abs" abs-    signum      = functionFold "signum" signum-    (+)         = functionFold2 "(+)" (+)-    (-)         = functionFold2 "(-)" (-)-    (*)         = functionFold2 "(*)" (*)+    n = evalD l   -instance Fractional (Data Float)-  where-    fromRational = value . fromRational-    (/)          = functionFold2 "(/)" (/)+-- | The semantics of 'Data'+evalD :: Data a -> a+evalD = evalE . dataToExpr +-- | The semantics of any 'Computable' type+eval :: Computable a => a -> Internal a+eval = evalD . internalize  --- | Internal function for constructing storable values.-value_ :: Storable a => a -> Data a-value_ = ref . Value --- | A primitive value (a program that computes a constant value)-value :: Primitive a => a -> Data a-value = value_+-- | A program that computes a constant value+value :: Storable a => a -> Data a+value a = exprToData (Value (storableSize a) a) +-- | Like 'value' but with an extra 'Size' argument that can be used to increase+-- the size beyond the given data.+--+-- Example 1:+--+-- > array (10 :> 20 :> universal) [] :: Data [[Int]]+--+-- gives an uninitialized 10x20 array of 'Int' elements.+--+-- Example 2:+--+-- > array (10 :> 20 :> universal) [[1,2,3]] :: Data [[Int]]+--+-- gives a 10x20 array whose first row is initialized to @[1,2,3]@.+array :: Storable a => Size a -> a -> Data a+array sz a = exprToData $ Value (sz `mappend` storableSize a) a++arrayLen :: Storable a => Data Length -> [a] -> Data [a]+arrayLen len = array sz+  where+    sz = mapMonotonic fromInteger (dataSize len) :> universal+  -- XXX This function is a temporary solution.+ unit :: Data () unit = value () @@ -294,58 +393,82 @@ false :: Data Bool false = value False --- | For example,------ > array [[1,2,3],[4,5]] :: Data (D2 :> D4 :> Int)------ is a 2x4-element array of @Int@s, with the first row initialized to @[1,2,3]@--- and the second row to @[4,5]@.-array :: (NaturalT n, Storable a) => ListBased (n :> a) -> Data (n :> a)-array = value_ . fromList- -- | Returns the size of each level of a multi-dimensional array, starting with -- the outermost level.-size :: (NaturalT n, Storable a) => Data (n :> a) -> [Int]-size arr = szs-  where-    One (StorableType szs _) = typeOfData arr+size :: forall a . Storable a => Data [a] -> [Range Length]+size = listSize (T::T [a]) . dataSize +cap :: (Storable a, Size a ~ Range b, Ord b) => Range b -> Data a -> Data a+cap szb (Data sz a) = Data (sz /\ szb) a+  -- XXX Should really have the type+  --       cap :: Storable a => Size a -> Data a -> Data a  --- | A one-argument primitive function. The first argument is the name of the--- function, and the second argument gives its evaluation semantics.-function :: (Storable a, Storable b) => String -> (a -> b) -> (Data a -> Data b)-function fun f = ref . Function fun f +-- | Constructs a one-argument primitive function.+--+-- @`function` fun szf f@:+--+--   * @fun@ is the name of the function.+--+--   * @szf@ computes the output size from the input size.+--+--   * @f@   gives the evaluation semantics.+function+    :: (Storable a, Storable b)+    => String -> (Size a -> Size b) -> (a -> b) -> (Data a -> Data b) +function fun sizeProp f a = case dataToExpr a of+    Value _ a' -> Data s (ref $ Value s $ f a')+    _          -> exprToData $ Function fun s f a+  where+    s = sizeProp (dataSize a) --- | A two-argument function+++-- | A two-argument primitive function function2     :: ( Storable a        , Storable b        , Storable c        )-    => String -> (a -> b -> c) -> (Data a -> Data b -> Data c)+    => String+    -> (Size a -> Size b -> Size c)+    -> (a -> b -> c)+    -> (Data a -> Data b -> Data c) -function2 fun f a b = ref $ Function fun (\(a,b) -> f a b) (ref $ Tuple2 a b)+function2 fun sizeProp f a b = case (dataToExpr a, dataToExpr b) of+    (Value _ a', Value _ b') -> Data s (ref $ Value s $ f a' b')+    _ -> exprToData $ Function fun s f' $ exprToData $ Tuple2 a b+  where+    s = sizeProp (dataSize a) (dataSize b)+    f' (a,b) = f a b   --- | A three-argument function+-- | A three-argument primitive function function3     :: ( Storable a        , Storable b        , Storable c        , Storable d        )-    => String -> (a -> b -> c -> d) -> (Data a -> Data b -> Data c -> Data d)+    => String+    -> (Size a -> Size b -> Size c -> Size d)+    -> (a -> b -> c -> d)+    -> (Data a -> Data b -> Data c -> Data d) -function3 fun f a b c =-    ref $ Function fun (\(a,b,c) -> f a b c) (ref $ Tuple3 a b c)+function3 fun sizeProp f a b c = case (d2e a, d2e b, d2e c) of+    (Value _ a', Value _ b', Value _ c') -> Data s (ref $ Value s $ f a' b' c')+    _ -> exprToData $ Function fun s f' $ exprToData $ Tuple3 a b c+  where+    d2e = dataToExpr+    s = sizeProp (dataSize a) (dataSize b) (dataSize c)+    f' (a,b,c) = f a b c   --- | A four-argument function+-- | A four-argument primitive function function4     :: ( Storable a        , Storable b@@ -354,119 +477,98 @@        , Storable e        )     => String+    -> (Size a -> Size b -> Size c -> Size d -> Size e)     -> (a -> b -> c -> d -> e)     -> (Data a -> Data b -> Data c -> Data d -> Data e) -function4 fun f a b c d =-    ref $ Function fun (\(a,b,c,d) -> f a b c d) (ref $ Tuple4 a b c d)------ | A one-argument function with constant folding-functionFold-    :: (Storable a, Storable b) => String -> (a -> b) -> (Data a -> Data b)--functionFold fun f a = case deref a of-    Value a' -> value_ (f a')-    _        -> function fun f a------ | A two-argument function with constant folding-functionFold2-    :: ( Storable a-       , Storable b-       , Storable c-       )-    => String -> (a -> b -> c) -> (Data a -> Data b -> Data c)--functionFold2 fun f a b = case (deref a, deref b) of-    (Value a', Value b') -> value_ (f a' b')-    _ -> function2 fun f a b+function4 fun sizeProp f a b c d = case (d2e a, d2e b, d2e c, d2e d) of+    (Value _ a', Value _ b', Value _ c', Value _ d') -> Data s (ref $ Value s $ f a' b' c' d')+    _ -> exprToData $ Function fun s f' $ exprToData $ Tuple4 a b c d+  where+    d2e = dataToExpr+    s = sizeProp (dataSize a) (dataSize b) (dataSize c) (dataSize d)+    f' (a,b,c,d) = f a b c d   --- | A three-argument function with constant folding-functionFold3-    :: ( Storable a-       , Storable b-       , Storable c-       , Storable d-       )-    => String -> (a -> b -> c -> d) -> (Data a -> Data b -> Data c -> Data d)--functionFold3 fun f a b c = case (deref a, deref b, deref c) of-    (Value a', Value b', Value c') -> value_ (f a' b' c')-    _ -> function3 fun f a b c--+instance Show (Data a)+  where+    show _ = "... :: Data a"+  -- Needed for the 'Num' instance. --- | A four-argument function with constant folding-functionFold4-    :: ( Storable a-       , Storable b-       , Storable c-       , Storable d-       , Storable e-       )-    => String -> (a -> b -> c -> d -> e)-    -> (Data a -> Data b -> Data c -> Data d -> Data e)+instance Numeric a => Num (Data a)+  where+    fromInteger = value . fromInteger+    abs         = function  "abs"    abs    abs+    signum      = function  "signum" signum signum+    (+)         = function2 "(+)"    (+)    (+)+    (-)         = function2 "(-)"    (-)    (-)+    (*)         = function2 "(*)"    (*)    (*) -functionFold4 fun f a b c d = case (deref a, deref b, deref c, deref d) of-    (Value a', Value b', Value c', Value d') -> value_ (f a' b' c' d')-    _ -> function4 fun f a b c d+instance Fractional (Data Float)+  where+    fromRational = value . fromRational+    (/)          = function2 "(/)" (\_ _ -> fullRange) (/)  -- XXX Improve range   --- | Look up an index in an array-getIx :: forall n a . (NaturalT n, Storable a) =>-    Data (n :> a) -> Data Int -> Data a--getIx = functionFold2 "(!)" f+-- | Look up an index in an array (see also '!')+getIx :: Storable a => Data [a] -> Data Int -> Data a+getIx arr = function2 "(!)" sizeProp f arr   where-    f (ArrayList as) i-        | i >= n || i < 0 = error "getIx: index out of bounds"-        | i >= l          = error "getIx: reading garbage"-        | otherwise       = as !! i+    sizeProp (_:>aSize) _ = aSize++    f as i+        | not (i `inRange` r) = error "getIx: index out of bounds"+        | i >= la             = error "getIx: reading garbage"+        | otherwise           = as !! i       where-        n = fromIntegerT (undefined :: n)-        l = length as+        l :> _ = dataSize arr+        r      = rangeByRange 0 (l-1)+        la     = length as   --- | @setIx arr i a@:+-- | @`setIx` arr i a@: -- -- Replaces the value at index @i@ in the array @arr@ with the value @a@.-setIx :: forall n a . (NaturalT n, Storable a) =>-    Data (n :> a) -> Data Int -> Data a -> Data (n :> a)--setIx = functionFold3 "setIx" f+setIx :: Storable a => Data [a] -> Data Int -> Data a -> Data [a]+setIx arr = function3 "setIx" sizeProp f arr   where-    f :: (n :> a) -> Int -> a -> (n :> a)-    f (ArrayList as) i a-        | i >= n || i < 0 = error "setIx: index out of bounds"-        | i > l           = error "setIx: writing past initialized area"-        | otherwise       = ArrayList $ take i as ++ [a] ++ drop (i+1) as-      where-        n = fromIntegerT (undefined :: n)-        l = length as+    sizeProp (l:>aSize) _ aSize' = l :> (aSize `mappend` aSize') +    f as i a+        | not (i `inRange` r) = error "setIx: index out of bounds"+        | i > la              = error "setIx: writing past initialized area"+        | otherwise           = take i as ++ [a] ++ drop (i+1) as+      where+        l:>_ = dataSize arr+        r    = rangeByRange 0 (l-1)+        la   = length as +infixl 9 !  class RandomAccess a   where-    type Elem a+    -- | The type of elements in a random access structure+    type Element a -    -- | Index lookup in random access structures-    (!) :: a -> Data Int -> Elem a+    -- | Index lookup in a random access structure+    (!) :: a -> Data Int -> Element a -instance (NaturalT n, Storable a) => RandomAccess (Data (n :> a))+instance Storable a => RandomAccess (Data [a])   where-    type Elem (Data (n :> a)) = Data a+    type Element (Data [a]) = Data a     (!) = getIx   +mkSubFun :: Typeable a => Size a -> (Data a -> Data b) -> (a :-> b)+mkSubFun sz f = SubFunction f inp (f inp)+  where+    inp = exprToData $ Input sz++ -- | Constructs a non-primitive, non-inlined function. -- -- The normal way to make a non-primitive function is to use an ordinary Haskell@@ -482,11 +584,13 @@ -- at the moment this does not work. Every application of a @noInline@ function -- results in a new copy of the function in the core program. noInline :: (Computable a, Computable b) => String -> (a -> b) -> (a -> b)-noInline fun = unwrap . (ref .) . NoInline fun . Ref.ref . wrap+noInline fun f a = liftFun (exprToData . NoInline fun (ref subFun)) a+  where+    subFun = mkSubFun (dataSize $ internalize a) (lowerFun f)   --- | @ifThenElse cond thenFunc elseFunc@:+-- | @`ifThenElse` cond thenFunc elseFunc@: -- -- Selects between the two functions @thenFunc@ and @elseFunc@ depending on -- whether the condition @cond@ is true or false.@@ -494,273 +598,68 @@     :: (Computable a, Computable b)     => Data Bool -> (a -> b) -> (a -> b) -> (a -> b) -ifThenElse cond t e = case deref cond of-    Value True         -> t-    Value False        -> e+ifThenElse cond t e a = case dataToExpr cond of+    Value _ True       -> t a+    Value _ False      -> e a --     Function "not" _ c -> ifThenElse c e t -- XXX Not possible...-    _ -> unwrap $ (ref .) $ IfThenElse cond (wrap t) (wrap e)------ | @while cont body@:------ A while-loop. The condition @cont@ determines whether the loop should--- continue one more iteration. @body@ computes the next state. The result is a--- function from initial state to final state.-while-    :: Computable a-    => (a -> Data Bool)-    -> (a -> a)-    -> (a -> a)--while cont = unwrap . (ref .) . While (cont . externalize) . wrap------ | @parallel sz ixf@:------ Parallel tiling. Computes the elements of a vector. @sz@ is the dynamic size,--- i.e. how many of the allocated elements that should be computed. The function--- @ixf@ maps each index to its value.------ Since there are no dependencies between the elements, the compiler is free to--- compute the elements in parallel (or any other order).-parallel :: (NaturalT n, Storable a) =>-    Data Int -> (Data Int -> Data a) -> Data (n :> a)-parallel sz = ref . Parallel sz------ * Graph conversion--data Info = Info-  { -- | Next id-    index   :: NodeId-    -- | Visited references mapped to their id-  , visited :: Map Unique NodeId-  }---- | Monad for making graph building easier-type GraphBuilder a = WriterT [Node] (State Info) a--startInfo :: Info-startInfo = Info 0 Map.empty--runGraph :: GraphBuilder a -> Info -> (a, ([Node], Info))-runGraph graph info = (a, (nodes, info'))+    _ -> liftFun (exprToData . IfThenElse cond thenSub elseSub) a   where-    ((a,nodes),info') = runState (runWriterT graph) info--newIndex :: GraphBuilder NodeId-newIndex = do-    info <- get-    put (info {index = succ (index info)})-    return (index info)--remember :: Data a -> NodeId -> GraphBuilder ()-remember dat i = modify $ \info ->-    info {visited = Map.insert (refId dat) i (visited info)}--checkNode :: Data a -> GraphBuilder (Maybe NodeId)-checkNode dat = gets ((Map.lookup (refId dat)) . visited)--tupleBind :: Typeable a => NodeId -> T a -> Tuple Variable-tupleBind i = fmap (\path -> (i,path)) . tuplePath . typeOf------ | Declare a node-node-    :: forall a . Typeable a-    => Data a-    -> Graph.Function-    -> Tuple Source-    -> Tuple StorableType-    -> GraphBuilder ()--node dat fun inTup inType = do-    i <- newIndex-    remember dat i-    let outType = typeOf (T::T a)-    tell [Node i fun inTup inType outType]------ | Declare a source node (one with no inputs)-sourceNode :: Data a -> Graph.Function -> GraphBuilder ()-sourceNode dat@(Data _) fun = node dat fun (Tup []) (Tup [])------ Creates a source. The node must have been visited.-source :: forall a . [Int] -> Data a -> GraphBuilder Source-source path a = case deref a of--    GetTuple n tup -> source (numberT n : path) tup--    Value a | isPrimitive (T::T a) ->-      let PrimitiveData a' = toData a-       in return $ Constant a'--    _ -> do-      Just i <- checkNode a-      return $ Variable (i,path)+    sz      = dataSize $ internalize a+    thenSub = mkSubFun sz $ lowerFun t+    elseSub = mkSubFun sz $ lowerFun e   -traceTuple :: Data a -> GraphBuilder (Tuple Source)-traceTuple a = case deref a of--    Tuple2 b c -> do-      b' <- traceTuple b-      c' <- traceTuple c-      return (Tup [b',c'])--    Tuple3 b c d -> do-      b' <- traceTuple b-      c' <- traceTuple c-      d' <- traceTuple d-      return (Tup [b',c',d'])--    Tuple4 b c d e -> do-      b' <- traceTuple b-      c' <- traceTuple c-      d' <- traceTuple d-      e' <- traceTuple e-      return (Tup [b',c',d',e'])--    _ -> liftM One (source [] a)--+whileSized+    :: Computable state+    => Size (Internal state)+    -> (state -> Data Bool)+    -> (state -> state)+    -> (state -> state) -buildGraph :: forall a . Data a -> GraphBuilder ()-buildGraph dat@(Data _) = do-    idat <- checkNode dat-    unless (isJust idat) $ list (deref dat)+whileSized sz cont body init = liftFun (exprToData . While contSub bodySub) init   where-    funcNode fun inp@(Data _) = do-      buildGraph inp-      inTup <- traceTuple inp-      node dat fun inTup (typeOfData inp)--    list :: Expr a -> GraphBuilder ()--    list Input = sourceNode dat Graph.Input--    list (Value a)-      | isPrimitive (T::T a) = return ()-      | otherwise            = sourceNode dat $ Graph.Array $ toData a--    list (Tuple2 a b)     = buildGraph a >> buildGraph b-    list (Tuple3 a b c)   = buildGraph a >> buildGraph b >> buildGraph c-    list (Tuple4 a b c d) =-        buildGraph a >> buildGraph b >> buildGraph c >> buildGraph d--    list (GetTuple _ a) = buildGraph a--    list (Function fun _ a) = funcNode (Graph.Function fun) a--    list (NoInline fun f a) = do-      iface <- buildSubFun (Ref.deref f)-      funcNode (Graph.NoInline fun iface) a-      -- XXX Sub-graph is not shared at the moment.--    list (IfThenElse cond t e a) = do-      ifaceThen <- buildSubFun t-      ifaceElse <- buildSubFun e-      funcNode (Graph.IfThenElse ifaceThen ifaceElse) (ref $ Tuple2 cond a)--    list (While cont body a) = do-      ifaceCont <- buildSubFun cont-      ifaceBody <- buildSubFun body-      funcNode (Graph.While ifaceCont ifaceBody) a--    list (Parallel sz ixf) = do-        iface <- buildSubFun ixf-        funcNode (Graph.Parallel n iface) sz-      where-        One (StorableType (n:_) _) = typeOfData dat+    contSub = mkSubFun sz $ lowerFun cont+    bodySub = mkSubFun sz $ lowerFun body   -buildSubFun :: forall a b . (Typeable a, Typeable b) =>-    (Data a -> Data b) -> GraphBuilder Interface--buildSubFun f = do-    let inp  = ref Input :: Data a-        outp = f inp-    buildGraph inp  -- Needed in case input is not used-    buildGraph outp-    outTup <- traceTuple outp-    info   <- get-    let inId    = visited info Map.! refId inp-        inType  = typeOf (T::T a)-        outType = typeOf (T::T b)-    return (Interface inId outTup inType outType)--+-- | While-loop+--+-- @while cont body :: state -> state@:+--+--   * @state@ is the type of the state.+--+--   * @cont@ determines whether or not to continue based on the current state.+--+--   * @body@ computes the next state from the current state.+--+--   * The result is a function from initial state to final state.+while+    :: Computable state+    => (state -> Data Bool)+    -> (state -> state)+    -> (state -> state) -toGraphD :: (Typeable a, Typeable b) => (Data a -> Data b) -> Graph-toGraphD f = Graph nodes iface-  where-    (iface,(nodes,_)) = runGraph (buildSubFun f) startInfo+while = whileSized universal   --- | Types that represents core language programs-class Program a-  where-    -- | Converts a program to a Graph-    toGraph :: a -> Graph--    -- | Returns whether or not the program has an argument. This is needed-    -- because the 'Graph' type always assumes the existence of an input. So-    -- for programs without input, the 'Graph' representation will have a-    -- \"dummy\" input, which is indistinguishable from a real input.-    hasArg :: T a -> Bool--instance Computable a => Program a-  where-    toGraph a = toGraphD (const (internalize a) :: Data () -> Data (Internal a))-    hasArg    = const False--instance (Computable a, Computable b) => Program (a -> b)-  where-    toGraph = toGraphD . wrap-    hasArg  = const True--instance (Computable a, Computable b, Computable c)-      => Program (a -> b -> c)-  where-    toGraph = toGraph . uncurry-    hasArg  = const True--instance (Computable a, Computable b, Computable c, Computable d)-      => Program (a -> b -> c -> d)-  where-    toGraph f = toGraph (\(a,b,c) -> f a b c)-    hasArg    = const True--instance-    ( Computable a-    , Computable b-    , Computable c-    , Computable d-    , Computable e-    ) =>-      Program (a -> b -> c -> d -> e)+-- | Parallel array+--+-- @parallel l ixf@:+--+--   * @l@ is the length of the resulting array (outermost level).+--+--   * @ifx@ is a function that maps each index in the range @[0 .. l-1]@ to its+--     element.+--+-- Since there are no dependencies between the elements, the compiler is free to+-- compute the elements in any order, or even in parallel.+parallel :: Storable a => Data Length -> (Data Int -> Data a) -> Data [a]+parallel l ixf = exprToData $ Parallel l ixfSub   where-    toGraph f = toGraph (\(a,b,c,d) -> f a b c d)-    hasArg    = const True------ | Shows the core code generated by program.-showCore :: forall a . Program a => a -> String-showCore = showGraph "program" (hasArg (T::T a)) . toGraph---- | @printCore = putStrLn . showCore@-printCore :: Program a => a -> IO ()-printCore = putStrLn . showCore+    szl    = dataSize l+    ixfSub = mkSubFun (rangeByRange 0 (szl-1)) ixf 

@@ -1,4 +1,4 @@--- Copyright (c) 2009, ERICSSON AB+-- Copyright (c) 2009-2010, ERICSSON AB -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without@@ -32,11 +32,12 @@  import qualified Prelude -import Feldspar.Prelude+import Feldspar.Range import Feldspar.Core.Types import Feldspar.Core.Expr-+import Feldspar.Prelude +import qualified Data.Bits as B  infix 4 == infix 4 /=@@ -48,70 +49,232 @@   +-- * Misc.++noSizeProp :: a -> ()+noSizeProp _ = ()++noSizeProp2 :: a -> b -> ()+noSizeProp2 _ _ = ()+++ (==) :: Storable a => Data a -> Data a -> Data Bool-(==) = functionFold2 "(==)" (Prelude.==)+a == b+  | a Prelude.== b = true+  | otherwise      = function2 "(==)" noSizeProp2 (Prelude.==) a b+  -- XXX Partial evaluation  (/=) :: Storable a => Data a -> Data a -> Data Bool-(/=) = functionFold2 "(/=)" (Prelude./=)+a /= b+  | a Prelude.== b = false+  | otherwise      = function2 "(/=)" noSizeProp2 (Prelude./=) a b+  -- XXX Partial evaluation  (<) :: Storable a => Data a -> Data a -> Data Bool-(<) = functionFold2 "(<)" (Prelude.<)+a < b+  | a Prelude.== b = false+  | otherwise      = function2 "(<)" noSizeProp2 (Prelude.<) a b  (>) :: Storable a => Data a -> Data a -> Data Bool-(>) = functionFold2 "(>)" (Prelude.>)+a > b+  | a Prelude.== b = false+  | otherwise      = function2 "(>)" noSizeProp2 (Prelude.>) a b +(<<<) :: Data Int -> Data Int -> Data Bool+a <<< b+  | a Prelude.== b      = false+  | sa `rangeLess`   sb = true+  | sb `rangeLessEq` sa = false+  | otherwise           = function2 "(<)" noSizeProp2 (Prelude.<) a b+  where+    sa = dataSize a+    sb = dataSize b+  -- XXX Enables more partial evaluation than (<). This function should be+  --     generalized and then replace (<).++(>>>) :: Data Int -> Data Int -> Data Bool+a >>> b+  | a Prelude.== b      = false+  | sb `rangeLess`   sa = true+  | sa `rangeLessEq` sb = false+  | otherwise           = function2 "(>)" noSizeProp2 (Prelude.>) a b+  where+    sa = dataSize a+    sb = dataSize b+  -- XXX Enables more partial evaluation than (>). This function should be+  --     generalized and then replace (>).+ (<=) :: Storable a => Data a -> Data a -> Data Bool-(<=) = functionFold2 "(<=)" (Prelude.<=)+a <= b+  | a Prelude.== b = true+  | otherwise      = function2 "(<=)" noSizeProp2 (Prelude.<=) a b+  -- XXX Partial evaluation  (>=) :: Storable a => Data a -> Data a -> Data Bool-(>=) = functionFold2 "(>=)" (Prelude.>=)+a >= b+  | a Prelude.== b = true+  | otherwise      = function2 "(>=)" noSizeProp2 (Prelude.>=) a b+  -- XXX Partial evaluation  not :: Data Bool -> Data Bool-not = functionFold "not" Prelude.not+not = function "not" noSizeProp Prelude.not  -- | Selects the elements of the pair depending on the condition (?) :: Computable a => Data Bool -> (a,a) -> a cond ? (a,b) = ifThenElse cond (const a) (const b) unit  (&&) :: Data Bool -> Data Bool -> Data Bool-(&&) = functionFold2 "(&&)" (Prelude.&&)+(&&) = function2 "(&&)" noSizeProp2 (Prelude.&&)  (||) :: Data Bool -> Data Bool -> Data Bool-(||) = functionFold2 "(||)" (Prelude.||)+(||) = function2 "(||)" noSizeProp2 (Prelude.||)  -- | Lazy conjunction, second argument only run if necessary (&&*) :: Computable a =>     (a -> Data Bool) -> (a -> Data Bool) -> (a -> Data Bool)-(f &&* g) a = let fa = f a in ifThenElse fa g (const false) a+(f &&* g) a = ifThenElse (f a) g (const false) a  -- | Lazy disjunction, second argument only run if necessary (||*) :: Computable a =>     (a -> Data Bool) -> (a -> Data Bool) -> (a -> Data Bool)-(f ||* g) a = let fa = f a in ifThenElse fa (const true) g a+(f ||* g) a = ifThenElse (f a) (const true) g a  min :: Storable a => Data a -> Data a -> Data a-min a b = a<=b ? (a,b)+min a b = a<b ? (a,b)  max :: Storable a => Data a -> Data a -> Data a-max a b = a>=b ? (a,b)+max a b = a>b ? (a,b) +minX :: Data Int -> Data Int -> Data Int+minX a b = case dataToExpr cond1 of+    Value _ _ -> cond1 ? (a,b)+    _         -> cond2 ? (b,a)+  where+    cond1 = a<<<b+    cond2 = b<<<a+  -- XXX Enables more partial evaluation than min. This function should be+  --     generalized and then replace min.++maxX :: Data Int -> Data Int -> Data Int+maxX a b = case dataToExpr cond1 of+    Value _ _ -> cond1 ? (a,b)+    _         -> cond2 ? (b,a)+  where+    cond1 = a>>>b+    cond2 = b>>>a+  -- XXX Enables more partial evaluation than max. This function should be+  --     generalized and then replace max.+ div :: Data Int -> Data Int -> Data Int-div = functionFold2 "div" (Prelude.div)+div = function2 "div" (\_ _ -> fullRange) Prelude.div  -- XXX Improve size propagation  mod :: Data Int -> Data Int -> Data Int-mod = functionFold2 "mod" (Prelude.mod)+mod = function2 "mod" (\_ _ -> fullRange) Prelude.mod  -- XXX Improve size propagation  (^) :: Data Int -> Data Int -> Data Int-(^) = functionFold2 "(^)" (Prelude.^)+(^) = function2 "(^)" (\_ _ -> fullRange) (Prelude.^)  -- XXX Improve size propagation --- | @for start end init body@:+++-- * Loops++-- | For-loop ----- A for-loop ranging over @[start .. end]@. @init@ is the starting state. The--- @body@ computes the next state given the current state and the current loop--- index.+-- @`for` start end init body@:+--+--   * @start@\/@end@ are the start\/end indexes.+--+--   * @init@ is the starting state.+--+--   * @body@ computes the next state given the current loop index (ranging over+--     @[start .. end]@) and the current state. for :: Computable a => Data Int -> Data Int -> a -> (Data Int -> a -> a) -> a-for start end init body = snd $ while cont body' (start,init)+for start end init body = snd $ whileSized sz cont body' (start,init)   where+    szi = rangeByRange (dataSize start) (dataSize end)+    sz  = (szi,universal)+     cont  (i,s) = i <= end     body' (i,s) = (i+1, body i s) +++-- | A sequential \"unfolding\" of an vector+--+-- @`unfoldCore` l init step@:+--+--   * @l@ is the length of the resulting vector.+--+--   * @init@ is the initial state.+--+--   * @step@ is a function computing a new element and the next state from the+--     current index and current state. The index is the position of the new+--     element in the output vector.+unfoldCore+    :: (Computable state, Storable a)+    => Data Length+    -> state+    -> (Data Int -> state -> (Data a, state))+    -> (Data [a], state)++unfoldCore l init step = for 0 (l-1) (outp,init) $ \i (o,state) ->+    let (a,state') = step i state+     in (setIx o i a, state')+  where+    outp = array (mapMonotonic fromIntegral (dataSize l) :> universal) []+++-- * Bit manipulation++infixl 5 <<,>>+infixl 4 ⊕++-- | The following class provides functions for bit level manipulation+class (B.Bits a, Storable a) => Bits a+  where+  -- Logical operations+  (.&.)         :: Data a -> Data a -> Data a+  (.&.)         =  function2 "(.&.)" (\_ _ -> universal) (B..&.)+  (.|.)         :: Data a -> Data a -> Data a+  (.|.)         =  function2 "(.|.)" (\_ _ -> universal) (B..|.)+  xor           :: Data a -> Data a -> Data a+  xor           =  function2 "xor" (\_ _ -> universal) B.xor+  (⊕)           :: Data a -> Data a -> Data a+  (⊕)           = xor+  complement    :: Data a -> Data a+  complement    =  function "complement" (const universal) B.complement++  -- Operations on individual bits+  bit           :: Data Int -> Data a+  bit           =  function "bit" (const universal) B.bit+  setBit        :: Data a -> Data Int -> Data a+  setBit        =  function2 "setBit" (\_ _ -> universal) B.setBit+  clearBit      :: Data a -> Data Int -> Data a+  clearBit      =  function2 "clearBit" (\_ _ -> universal) B.clearBit+  complementBit :: Data a -> Data Int -> Data a+  complementBit =  function2 "complementBit" (\_ _ -> universal) B.complementBit+  testBit       :: Data a -> Data Int -> Data Bool+  testBit       =  function2 "testBit" noSizeProp2 B.testBit++  -- Moving bits around+  shiftL        :: Data a -> Data Int -> Data a+  shiftL        =  function2 "shiftL" (\_ _ -> universal) B.shiftL+  (<<)          :: Data a -> Data Int -> Data a+  (<<)          =  shiftL+  shiftR        :: Data a -> Data Int -> Data a+  shiftR        =  function2 "shiftR" (\_ _ -> universal) B.shiftR+  (>>)          :: Data a -> Data Int -> Data a+  (>>)          =  shiftR+  rotateL       :: Data a -> Data Int -> Data a+  rotateL       =  function2 "rotateL" (\_ _ -> universal) B.rotateL+  rotateR       :: Data a -> Data Int -> Data a+  rotateR       =  function2 "rotateR" (\_ _ -> universal) B.rotateR++  -- Queries about the type+  bitSize       :: Data a -> Data Int+  bitSize       =  function "bitSize" (const naturalRange) B.bitSize+  isSigned      :: Data a -> Data Bool+  isSigned      =  function "isSigned" noSizeProp B.isSigned++instance Bits Int

@@ -1,4 +1,4 @@--- Copyright (c) 2009, ERICSSON AB+-- Copyright (c) 2009-2010, ERICSSON AB -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without@@ -93,6 +93,8 @@ -- >     intType     = result (typeOf :: Res [[[Int]]] (Tuple StorableType)) -- >     intPairType = result (typeOf :: Res (Int,Int) (Tuple StorableType)) --+-- XXX Check above code again+-- -- which corresponds to the following flat program -- -- > main v0 = v4@@ -290,7 +292,7 @@     -- | While-loop   | While Interface Interface     -- | Parallel tiling-  | Parallel Int Interface+  | Parallel Interface     deriving (Eq, Show)  -- | A graph is a list of unique nodes with an interface.@@ -381,7 +383,7 @@     subFun i (NoInline _ f)    = [sub i 0 f]     subFun i (IfThenElse t e)  = [sub i 0 t, sub i 1 e]     subFun i (While cont body) = [sub i 0 cont, sub i 1 body]-    subFun i (Parallel _ ixf)  = [sub i 0 ixf]+    subFun i (Parallel ixf)    = [sub i 0 ixf]     subFun _ _                 = []  @@ -471,7 +473,7 @@     subHierarchies (Node i (NoInline _ _) _ _ _)   = map (subFunHier i) [0]     subHierarchies (Node i (IfThenElse _ _) _ _ _) = map (subFunHier i) [0,1]     subHierarchies (Node i (While _ _) _ _ _)      = map (subFunHier i) [0,1]-    subHierarchies (Node i (Parallel _ _) _ _ _)   = map (subFunHier i) [0]+    subHierarchies (Node i (Parallel _) _ _ _)     = map (subFunHier i) [0]     subHierarchies _ = []      topLevel :: [Node]

@@ -1,77 +0,0 @@--- Copyright (c) 2009, ERICSSON AB--- All rights reserved.------ Redistribution and use in source and binary forms, with or without--- modification, are permitted provided that the following conditions are met:------     * Redistributions of source code must retain the above copyright notice,---       this list of conditions and the following disclaimer.---     * Redistributions in binary form must reproduce the above copyright---       notice, this list of conditions and the following disclaimer in the---       documentation and/or other materials provided with the distribution.---     * Neither the name of the ERICSSON AB nor the names of its contributors---       may be used to endorse or promote products derived from this software---       without specific prior written permission.------ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"--- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE--- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE--- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE--- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR--- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER--- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,--- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE--- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.---- | Helper functions for producing Haskell code--module Feldspar.Core.Haskell where----import Data.List--import Feldspar.Core.Types------ | No trailing @\'\\n\'@.-unlinesNoTrail :: [String] -> String-unlinesNoTrail = intercalate "\n"---- | Indents a string the given amount of columns.-indent :: Int -> String -> String-indent n = unlinesNoTrail . map (spc ++) . lines-  where-    spc = replicate n ' '--newline :: String-newline = "\n"---- | Application-(-$-) :: HaskellValue a => String -> a -> String-fun -$- inp = unwords [fun, haskellValue inp]---- | Binary operator application-opApp :: (HaskellValue a, HaskellValue b) => String -> a -> b -> String-opApp op a b = unwords [haskellValue a, op, haskellValue b]---- | Definition-(-=-) :: (HaskellValue patt, HaskellValue def) => patt -> def -> String-patt -=- def = unwords [haskellValue patt, "=", haskellValue def]---- Places the second string as a local block to the first string.-local :: String -> String -> String-local def ""   = def-local def defs = def ++ newline ++ indent 2 "where" ++ newline ++ indent 4 defs--infixl 8 -$--infix  7 -=--infixr 6 `local`--ifThenElse-    :: (HaskellValue c, HaskellValue t, HaskellValue e) => c -> t -> e -> String-ifThenElse c t e = unwords-    ["if", haskellValue c, "then", haskellValue t, "else", haskellValue e]-

@@ -1,4 +1,4 @@--- Copyright (c) 2009, ERICSSON AB+-- Copyright (c) 2009-2010, ERICSSON AB, Koen Claessen -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without@@ -27,8 +27,6 @@ {-# OPTIONS_GHC -O0 #-}  -- |--- Copyright : Copyright (c) 2009, Koen Claessen--- -- A simple implementation of \"observable sharing\". See -- -- * Koen Claessen, David Sands,

@@ -0,0 +1,316 @@+-- Copyright (c) 2009-2010, ERICSSON AB+-- All rights reserved.+--+-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are met:+--+--     * Redistributions of source code must retain the above copyright notice,+--       this list of conditions and the following disclaimer.+--     * Redistributions in binary form must reproduce the above copyright+--       notice, this list of conditions and the following disclaimer in the+--       documentation and/or other materials provided with the distribution.+--     * Neither the name of the ERICSSON AB nor the names of its contributors+--       may be used to endorse or promote products derived from this software+--       without specific prior written permission.+--+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++{-# LANGUAGE OverlappingInstances, UndecidableInstances #-}++-- | Functions for reifying expressions ('Data' / 'Expr') to graphs ('Graph')+-- and to textual format.++module Feldspar.Core.Reify+  ( Program (..)+  , showCore+  , showCoreWithSize+  , printCore+  , printCoreWithSize+  ) where++++import Control.Monad.State+import Control.Monad.Writer+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.Unique++import Feldspar.Core.Types+import Feldspar.Core.Ref+import Feldspar.Core.Expr+import Feldspar.Core.Graph hiding (function, Function (..), SubFunction)+import qualified Feldspar.Core.Graph as Graph+import Feldspar.Core.Show++++data Info = Info+  { -- | Next id+    index :: NodeId+    -- | Visited references mapped to their id+  , visited :: Map Unique NodeId+  }++-- | Monad for making graph building easier+type Reify a = WriterT [Node] (State Info) a++startInfo :: Info+startInfo = Info 0 Map.empty++runGraph :: Reify a -> Info -> (a, ([Node], Info))+runGraph graph info = (a, (nodes, info'))+  where+    ((a,nodes),info') = runState (runWriterT graph) info++newIndex :: Reify NodeId+newIndex = do+    info <- get+    put (info {index = succ (index info)})+    return (index info)++remember :: Data a -> NodeId -> Reify ()+remember a i = modify $ \info ->+    info {visited = Map.insert (dataId a) i (visited info)}++checkNode :: Data a -> Reify (Maybe NodeId)+checkNode a = gets ((Map.lookup (dataId a)) . visited)++++-- | Declare a node+node ::+    Data a -> Graph.Function -> Tuple Source -> Tuple StorableType -> Reify ()++node a@(Data _ _) fun inTup inType = do+    i <- newIndex+    remember a i+    tell [Node i fun inTup inType (dataType a)]++++-- | Declare a source node (one with no inputs)+sourceNode :: Data a -> Graph.Function -> Reify ()+sourceNode a fun = node a fun (Tup []) (Tup [])++isPrimitive :: Data a -> Bool+isPrimitive a@(Data _ _) = case dataType a of+    One (StorableType [] _) -> True+    _ -> False++++-- Creates a source. The node must have been visited.+source :: [Int] -> Data a -> Reify Source+source path a = case dataToExpr a of++    Get21 tup -> source (0:path) tup+    Get22 tup -> source (1:path) tup+    Get31 tup -> source (0:path) tup+    Get32 tup -> source (1:path) tup+    Get33 tup -> source (2:path) tup+    Get41 tup -> source (0:path) tup+    Get42 tup -> source (1:path) tup+    Get43 tup -> source (2:path) tup+    Get44 tup -> source (3:path) tup++    Value _ b | isPrimitive a ->+      let PrimitiveData b' = storableData b+       in return $ Constant b'++    _ -> do+      Just i <- checkNode a+      return $ Variable (i,path)++++traceTuple :: Data a -> Reify (Tuple Source)+traceTuple a = case dataToExpr a of++    Tuple2 b c -> do+      b' <- traceTuple b+      c' <- traceTuple c+      return (Tup [b',c'])++    Tuple3 b c d -> do+      b' <- traceTuple b+      c' <- traceTuple c+      d' <- traceTuple d+      return (Tup [b',c',d'])++    Tuple4 b c d e -> do+      b' <- traceTuple b+      c' <- traceTuple c+      d' <- traceTuple d+      e' <- traceTuple e+      return (Tup [b',c',d',e'])++    _ -> liftM One (source [] a)++++buildGraph :: forall a . Data a -> Reify ()+buildGraph a@(Data _ _) = do+    ia <- checkNode a+    unless (isJust ia) $ list (dataToExpr a)+  where+    funcNode fun inp = do+      buildGraph inp+      inTup <- traceTuple inp+      node a fun inTup (dataType inp)++    list :: Expr a -> Reify ()++    list (Input _) = sourceNode a Graph.Input++    list (Value _ b)+      | isPrimitive a = return ()+      | otherwise     = sourceNode a $ Graph.Array $ storableData b++    list (Tuple2 b c)     = buildGraph b >> buildGraph c+    list (Tuple3 b c d)   = buildGraph b >> buildGraph c >> buildGraph d+    list (Tuple4 b c d e) =+        buildGraph b >> buildGraph c >> buildGraph d >> buildGraph e++    list (Get21 b) = buildGraph b+    list (Get22 b) = buildGraph b+    list (Get31 b) = buildGraph b+    list (Get32 b) = buildGraph b+    list (Get33 b) = buildGraph b+    list (Get41 b) = buildGraph b+    list (Get42 b) = buildGraph b+    list (Get43 b) = buildGraph b+    list (Get44 b) = buildGraph b++    list (Function fun _ _ b) = funcNode (Graph.Function fun) b++    list (NoInline fun f b@(Data _ _)) = do+      iface <- buildSubFun (deref f)+      funcNode (Graph.NoInline fun iface) b+      -- XXX Sub-graph is not shared at the moment.++    list (IfThenElse c t e b@(Data _ _)) = do+      ifaceThen <- buildSubFun t+      ifaceElse <- buildSubFun e+      funcNode (Graph.IfThenElse ifaceThen ifaceElse) (exprToData $ Tuple2 c b)++    list (While cont body b@(Data _ _)) = do+      ifaceCont <- buildSubFun cont+      ifaceBody <- buildSubFun body+      funcNode (Graph.While ifaceCont ifaceBody) b++    list (Parallel l ixf) = do+      iface <- buildSubFun ixf+      funcNode (Graph.Parallel iface) l++++buildSubFun :: forall a b . (Typeable a, Typeable b) =>+    (a :-> b) -> Reify Interface++buildSubFun (SubFunction _ inp outp) = do+    let inType  = typeOf (dataSize inp) (T::T a)+        outType = typeOf (dataSize outp) (T::T b)+    buildGraph inp  -- Needed in case input is not used+    buildGraph outp+    outTup <- traceTuple outp+    info   <- get+    let inId = visited info Map.! dataId inp+    return (Interface inId outTup inType outType)++++reifyD :: (Typeable a, Typeable b) => (Data a -> Data b) -> Graph+reifyD f = Graph nodes iface+  where+    subFun            = mkSubFun universal f+    (iface,(nodes,_)) = runGraph (buildSubFun subFun) startInfo++++-- | Types that represent core language programs+class Program a+  where+    -- | Converts a program to a Graph+    reify :: a -> Graph++    -- | Returns whether or not the program has an argument. This is needed+    -- because the 'Graph' type always assumes the existence of an input. So+    -- for programs without input, the 'Graph' representation will have a+    -- \"dummy\" input, which is indistinguishable from a real input.+    numArgs :: T a -> Int++instance Computable a => Program a+  where+    reify     = reify_computable+    numArgs _ = 0++instance (Computable a, Computable b) => Program (a,b)+  where+    reify     = reify_computable+    numArgs _ = 0++instance (Computable a, Computable b, Computable c) => Program (a,b,c)+  where+    reify     = reify_computable+    numArgs _ = 0++instance (Computable a, Computable b, Computable c, Computable d) => Program (a,b,c,d)+  where+    reify     = reify_computable+    numArgs _ = 0++instance (Computable a, Computable b) => Program (a -> b)+  where+    reify   = reifyD . lowerFun+    numArgs = const 1++instance (Computable a, Computable b, Computable c) => Program (a -> b -> c)+  where+    reify f = reifyD $ lowerFun $ \(a,b) -> f a b+    numArgs = const 2++instance (Computable a, Computable b, Computable c, Computable d) => Program (a -> b -> c -> d)+  where+    reify f = reifyD $ lowerFun $ \(a,b,c) -> f a b c+    numArgs = const 3++instance (Computable a, Computable b, Computable c, Computable d, Computable e) => Program (a -> b -> c -> d -> e)+  where+    reify f = reifyD $ lowerFun $ \(a,b,c,d) -> f a b c d+    numArgs = const 4++++reify_computable :: forall a . Computable a => a -> Graph+reify_computable a =+    reifyD (const (internalize a) :: Data () -> Data (Internal a))++++-- | Shows the core code generated by the program.+showCore :: forall a . Program a => a -> String+showCore = showGraph False "program" (numArgs (T::T a) > 0) . reify++-- | Shows the core code with size information as comments.+showCoreWithSize :: forall a . Program a => a -> String+showCoreWithSize = showGraph True "program" (numArgs (T::T a) > 0) . reify++-- | @printCore = putStrLn . showCore@+printCore :: Program a => a -> IO ()+printCore = putStrLn . showCore++-- | @printCoreWithSize = putStrLn . showCoreWithSize@+printCoreWithSize :: Program a => a -> IO ()+printCoreWithSize = putStrLn . showCoreWithSize+

@@ -1,4 +1,4 @@--- Copyright (c) 2009, ERICSSON AB+-- Copyright (c) 2009-2010, ERICSSON AB -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without@@ -34,8 +34,9 @@ import Control.Monad import Data.List +import Feldspar.Utils+import Feldspar.Haskell import Feldspar.Core.Types-import Feldspar.Core.Haskell import Feldspar.Core.Graph  @@ -65,14 +66,28 @@   --- | Shows a single node. The first argument associates each sub-function with--- the nodes it owns.-showNode :: Node -> [Hierarchy] -> String+sizeComment :: Tuple StorableType -> String+sizeComment typ = case size of+    "" -> ""+    _  -> "  -- Size: " ++ size+  where+    size = showTuple (fmap showStorableSize typ) -showNode (Node i fun inp inType outType) subHiers = showNd fun+++-- | Shows a single node.+showNode :: Bool -> Node -> [Hierarchy] -> String++showNode _ (Node i Input inp inType outType) subHiers = ""++showNode showSize (Node i fun inp inType outType) subHiers+    | showSize  = appendFirstLine (sizeComment outType) (showNd fun)+    | otherwise = showNd fun   where     outp = tupPatt outType i +    showSF' = showSF showSize+     showNd Input     = ""     showNd (Array a) = ((i,[])::Variable) -=- a @@ -86,7 +101,7 @@     showNd (NoInline fun iface) =         outp -=- fun -$- inp           `local`-        showSF (head subHiers) fun subInp subOutp+        showSF' (head subHiers) fun subInp subOutp       where         subInp  = tupPatt inType $ interfaceInput iface         subOutp = interfaceOutput iface@@ -109,8 +124,8 @@         subOutpThen = interfaceOutput ifaceThen         subOutpElse = interfaceOutput ifaceElse -        thenBranch = showSF thenHier "thenBranch" subInpThen subOutpThen-        elseBranch = showSF elseHier "elseBranch" subInpElse subOutpElse+        thenBranch = showSF' thenHier "thenBranch" subInpThen subOutpThen+        elseBranch = showSF' elseHier "elseBranch" subInpElse subOutpElse      showNd (While ifaceCont ifaceBody) =         outp -=- "while" -$- "cont" -$- "body" -$- inp@@ -124,51 +139,54 @@         subOutpCont = interfaceOutput ifaceCont         subOutpBody = interfaceOutput ifaceBody -        contBranch = showSF contHier "cont" subInpCont subOutpCont-        bodyBranch = showSF bodyHier "body" subInpBody subOutpBody+        contBranch = showSF' contHier "cont" subInpCont subOutpCont+        bodyBranch = showSF' bodyHier "body" subInpBody subOutpBody -    showNd (Parallel szs iface) =-        outp -=- "parallel" -$- szs -$- inp -$- "ixf"+    showNd (Parallel iface) =+        outp -=- "parallel" -$- inp -$- "ixf"           `local`-        showSF (head subHiers) "ixf" subInp subOutp+        showSF' (head subHiers) "ixf" subInp subOutp       where         subInp  = tupPatt inType $ interfaceInput iface         subOutp = interfaceOutput iface   --- | @showSubFun hier name inp outp@:+-- | @showSubFun showSize hier name inp outp@: -- -- Shows a sub-function named @name@ represented by the hierarchy @hier@. If -- @inp@ is @Nothing@, it will be shown as a definition without an argument.+-- @showSize@ decides whether or not to show size comments. showSubFun     :: (HaskellValue inp, HaskellValue outp)-    => Hierarchy+    => Bool+    -> Hierarchy     -> String     -> Maybe inp     -> outp     -> String -showSubFun (Hierarchy nodes) name inp outp =+showSubFun showSize (Hierarchy nodes) name inp outp =     funHead inp -=- outp       `local`-    unlinesNoTrail (filter (not.null) $ map (uncurry showNode) nodes)+    unlinesNoTrail (filter (not.null) $ map (uncurry (showNode showSize)) nodes)   where     funHead Nothing    = name     funHead (Just inp) = name -$- inp   --- | @showSF hier name inp = showSubFun hier name (Just inp)@+-- | @showSF showSize hier name inp = showSubFun showSize hier name (Just inp)@ showSF     :: (HaskellValue inp, HaskellValue outp)-    => Hierarchy+    => Bool+    -> Hierarchy     -> String     -> inp     -> outp     -> String -showSF hier name inp = showSubFun hier name (Just inp)+showSF showSize hier name inp = showSubFun showSize hier name (Just inp)   @@ -176,8 +194,9 @@ -- Boolean tells whether the graph has a real or a dummy argument. A graphs with -- that has a dummy argument will be shown as a definition without an argument. -- Of course, this assumes that a dummy argument is not used within the graph.-showGraph :: String -> Bool -> Graph -> String-showGraph name hasArg graph@(Graph nodes iface) = showSubFun hier name inp' outp+showGraph :: Bool -> String -> Bool -> Graph -> String+showGraph showSize name hasArg graph@(Graph nodes iface) =+    showSubFun showSize hier name inp' outp   where     hier = graphHierarchy $ makeHierarchical graph     inp  = tupPatt (interfaceInputType iface) (interfaceInput iface)

@@ -1,4 +1,4 @@--- Copyright (c) 2009, ERICSSON AB+-- Copyright (c) 2009-2010, ERICSSON AB -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without@@ -24,6 +24,8 @@ -- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +{-# LANGUAGE UndecidableInstances #-}+ -- | Defines types and classes for the data computed by "Feldspar" programs.  module Feldspar.Core.Types where@@ -31,117 +33,80 @@   import Control.Applicative-import Control.Monad import Data.Char import Data.Foldable (Foldable) import qualified Data.Foldable as Fold-import Data.Maybe+import Data.Monoid import Data.Traversable (Traversable, traverse) -import Types.Data.Num+import Data.Int+import Data.Word+import Data.Bits  import Feldspar.Utils+import Feldspar.Haskell+import Feldspar.Range   --- * Types as arguments+-- * Misc.  -- | Used to pass a type to a function without using 'undefined'. data T a = T -numberT :: forall n . IntegerT n => T n -> Int-numberT _ = fromIntegerT (undefined :: n)+mkT :: a -> T a+mkT _ = T   --- * Haskell source code+-- | Heterogeneous list+data a :> b = a :> b+    deriving (Eq, Ord, Show) --- | Types that can represent Haskell types (as source code strings)-class HaskellType a-  where-    -- | Gives the Haskell type denoted by the argument.-    haskellType :: a -> String+infixr 5 :> -instance HaskellType a => HaskellType (Tuple a)+instance (Monoid a, Monoid b) => Monoid (a :> b)   where-    haskellType = showTuple . fmap haskellType+    mempty = mempty :> mempty +    (a1:>b1) `mappend` (a2:>b2) = (a1 `mappend` a2) :> (b1 `mappend` b2)  --- | Types that can represent Haskell values (as source code strings)-class HaskellValue a-  where-    -- | Gives the Haskell code denoted by the argument.-    haskellValue :: a -> String -instance HaskellValue String+class Set a   where-    haskellValue = id+    universal :: a -instance HaskellValue Int+instance Set ()   where-    haskellValue = show+    universal     = () -instance HaskellValue a => HaskellValue (Tuple a)+instance Ord a => Set (Range a)   where-    haskellValue = showTuple . fmap haskellValue------ * Tuples+    universal = fullRange --- | General tuple projection-class NaturalT n => GetTuple n a+instance (Set a, Set b) => Set (a :> b)   where-    type Part n a-    getTup :: T n -> a -> Part n a+    universal = universal :> universal -instance GetTuple D0 (a,b)+instance (Set a, Set b) => Set (a,b)   where-    type Part D0 (a,b) = a-    getTup _ (a,b) = a+    universal = (universal,universal) -instance GetTuple D1 (a,b)+instance (Set a, Set b, Set c) => Set (a,b,c)   where-    type Part D1 (a,b) = b-    getTup _ (a,b) = b+    universal = (universal,universal,universal) -instance GetTuple D0 (a,b,c)+instance (Set a, Set b, Set c, Set d) => Set (a,b,c,d)   where-    type Part D0 (a,b,c) = a-    getTup _ (a,b,c) = a+    universal = (universal,universal,universal,universal) -instance GetTuple D1 (a,b,c)-  where-    type Part D1 (a,b,c) = b-    getTup _ (a,b,c) = b -instance GetTuple D2 (a,b,c)-  where-    type Part D2 (a,b,c) = c-    getTup _ (a,b,c) = c -instance GetTuple D0 (a,b,c,d)-  where-    type Part D0 (a,b,c,d) = a-    getTup _ (a,b,c,d) = a--instance GetTuple D1 (a,b,c,d)-  where-    type Part D1 (a,b,c,d) = b-    getTup _ (a,b,c,d) = b--instance GetTuple D2 (a,b,c,d)-  where-    type Part D2 (a,b,c,d) = c-    getTup _ (a,b,c,d) = c--instance GetTuple D3 (a,b,c,d)-  where-    type Part D3 (a,b,c,d) = d-    getTup _ (a,b,c,d) = d+type Length = Int  +-- * Tuples  -- | Untyped representation of nested tuples data Tuple a@@ -153,20 +118,31 @@   where     fmap f (One a)  = One (f a)     fmap f (Tup as) = Tup $ map (fmap f) as+  -- XXX Can be derived in GHC 6.12  instance Foldable Tuple   where     foldr f x (One a)  = f a x     foldr f x (Tup as) = Fold.foldr (flip $ Fold.foldr f) x as+  -- XXX Can be derived in GHC 6.12  instance Traversable Tuple   where     traverse f (One a)  = pure One <*> f a     traverse f (Tup as) = pure Tup <*> traverse (traverse f) as+  -- XXX Can be derived in GHC 6.12 +instance HaskellType a => HaskellType (Tuple a)+  where+    haskellType = showTuple . fmap haskellType +instance HaskellValue a => HaskellValue (Tuple a)+  where+    haskellValue = showTuple . fmap haskellValue --- | Shows a nested tuple in Haskell's tuple syntax (e.g @\"(a,(b,c))\"@)+++-- | Shows a nested tuple in Haskell's tuple syntax (e.g @\"(a,(b,c))\"@). showTuple :: Tuple String -> String showTuple (One a)  = a showTuple (Tup as) = showSeq "(" (map showTuple as) ")"@@ -186,267 +162,237 @@  -- * Data --- | Representation of primitive types-data PrimitiveType-  = UnitType-  | BoolType-  | IntType-  | FloatType-    deriving (Eq, Show)- -- | Untyped representation of primitive data data PrimitiveData-  = UnitData+  = UnitData  ()   | BoolData  Bool-  | IntData   Int+  | IntData   Integer   | FloatData Float     deriving (Eq, Show) --- | Representation of storable types (arrays of primitive data). Array--- dimensions are given as a list of integers, starting with outermost array--- level. Primitive types are treated as zero-dimensional arrays.-data StorableType = StorableType [Int] PrimitiveType-    deriving (Eq, Show)---- | Untyped representation of storable data. Arrays have a length argument that--- gives the number of elements on the outermost array level. If the data list--- is shorter than this length, the missing elements are taken to have--- undefined value. If the data list is longer, the excessive elements are just--- ignored.+-- | Untyped representation of storable data (arrays of primitive data) data StorableData   = PrimitiveData PrimitiveData-  | StorableData Int [StorableData]+  | StorableData [StorableData]     deriving (Eq, Show) -instance HaskellType PrimitiveType-  where-    haskellType UnitType  = "()"-    haskellType BoolType  = "Bool"-    haskellType IntType   = "Int"-    haskellType FloatType = "Float"- instance HaskellValue PrimitiveData   where-    haskellValue UnitData      = "()"+    haskellValue (UnitData  a) = show a     haskellValue (BoolData  a) = map toLower (show a)     haskellValue (IntData   a) = show a     haskellValue (FloatData a) = show a -instance HaskellType StorableType-  where-    haskellType (StorableType dim t) = arrType ++ dimComment-      where-        l       = length dim-        arrType = replicate l '[' ++ haskellType t ++ replicate l ']'-        dimComment-          | [] <- dim = ""-          | otherwise = showSeq "{-" (map haskellValue dim) "-}"- instance HaskellValue StorableData   where-    haskellValue (PrimitiveData a)   = haskellValue a-    haskellValue (StorableData _ as) = showSeq "[" (map haskellValue as) "]"+    haskellValue (PrimitiveData a) = haskellValue a+    haskellValue (StorableData as) = showSeq "[" (map haskellValue as) "]"   --- | Primitive types-class Storable a => Primitive a+-- * Types -instance Primitive ()-instance Primitive Bool-instance Primitive Int-instance Primitive Float+-- | Representation of primitive types+data PrimitiveType+  = UnitType+  | BoolType+  | IntType { signed :: Bool, bitSize :: Int, valueSet :: (Range Integer) }+  | FloatType (Range Float)+    deriving (Eq, Show) +-- | Representation of storable types (arrays of primitive types). Array size is+-- given as a list of ranged lengths, starting with outermost array level.+-- Primitive types are treated as zero-dimensional arrays.+data StorableType = StorableType [Range Length] PrimitiveType+    deriving (Eq, Show) +instance HaskellType PrimitiveType+  where+    haskellType UnitType        = "()"+    haskellType BoolType        = "Bool"+    haskellType (IntType _ _ _) = "Int"+    haskellType (FloatType _)   = "Float" --- | Array represented as (nested) list. If @a@ is a storable type and @n@ is a--- type-level natural number, @n :> a@ represents an array of @n@ elements of--- type @a@. For example, @D3:>D10:>Int@ is a 3 by 10 array of integers. Arrays--- constructed using 'fromList' are guaranteed not to contain too many elements--- in any dimension. If there are too few elements in any dimension, the missing--- ones are taken to have undefined value.-data n :> a = (NaturalT n, Storable a) => ArrayList [a]+instance HaskellType StorableType+  where+    haskellType (StorableType ls t) = arrType+      where+        d       = length ls+        arrType = replicate d '[' ++ haskellType t ++ replicate d ']' -infixr 5 :>+showPrimitiveRange UnitType        = ""+showPrimitiveRange BoolType        = ""+showPrimitiveRange (IntType _ _ r) = showRange r+showPrimitiveRange (FloatType r)   = showRange r -instance (NaturalT n, Storable a, Eq a) => Eq (n :> a)-  where-    ArrayList a == ArrayList b = a == b+-- | Shows the size of a storable type.+showStorableSize :: StorableType -> String+showStorableSize (StorableType ls t) =+    showSeq "" (map (showBound . upperBound) ls) "" ++ showPrimitiveRange t -instance (NaturalT n, Storable a, Show (ListBased a)) => Show (n :> a)-  where-    show = show . toList -instance (NaturalT n, Storable a, Ord a) => Ord (n :> a)++-- | Primitive types+class Storable a => Primitive a   where-    ArrayList a `compare` ArrayList b = a `compare` b+    -- | Converts a primitive value to its untyped representation.+    primitiveData :: a -> PrimitiveData +    -- | Gives the type representation of a primitive value.+    primitiveType :: Size a -> T a -> PrimitiveType +instance Primitive ()+  where+    primitiveData     = UnitData+    primitiveType _ _ = UnitType -mapArray ::-    (NaturalT n, Storable a, Storable b) => (a -> b) -> (n :> a) -> (n :> b)+instance Primitive Bool+  where+    primitiveData     = BoolData+    primitiveType _ _ = BoolType -mapArray f (ArrayList as) = ArrayList $ map f as-  -- Couldn't use Functor because of the extra class constraints.+-- Assumes 32 bits which is not necessarily correct+instance Primitive Int+  where+    primitiveData     = IntData . toInteger+    primitiveType s _ = IntType True 32 s +instance Primitive Float+  where+    primitiveData     = FloatData+    primitiveType s _ = FloatType s  --- | Storable types (zero- or higher-level arrays of primitive data). Should be--- the same set of types as 'Storable', but this class has no 'Typeable'--- context, so it doesn't cause a cycle.------ Example:------ > *Feldspar.Core.Types> toList (replicateArray 3 :: D4 :> D2 :> Int)--- > [[3,3],[3,3],[3,3],[3,3]]++-- | Storable types (zero- or higher-level arrays of primitive data). class Typeable a => Storable a   where-    -- | List-based representation of a storable type-    type ListBased a :: *-    -- | The innermost element of a storable type-    type Element a :: *--    -- | Constructs an array filled with the given element. For primitive types,-    -- this is just the identity function.-    replicateArray :: Element a -> a+    -- | Converts a storable value to its untyped representation.+    storableData :: a -> StorableData -    -- | Converts a storable type to a (zero- or higher-level) nested list.-    toList :: a -> ListBased a+    -- | Gives the type representation of a storable value.+    storableType :: Size a -> T a -> StorableType -    -- | Constructs a storable type from a (zero- or higher-level) nested list.-    -- The resulting value is guaranteed not to have too many elements in any-    -- dimension. Excessive elements are simply cut away.-    fromList :: ListBased a -> a+    -- | Gives the size of a storable value.+    storableSize :: a -> Size a -    -- | Converts a storable value to its untyped representation.-    toData :: a -> StorableData+    listSize :: T a -> Size a -> [Range Length]+      -- XXX Could be put in a separate class without the (T a).  instance Storable ()   where-    type ListBased () = ()-    type Element   () = ()--    replicateArray = id-    toList         = id-    fromList       = id--    toData a = PrimitiveData $ case a of-      () -> UnitData+    storableData    = PrimitiveData . primitiveData+    storableType s  = StorableType [] . primitiveType s+    storableSize _  = ()+    listSize _ _    = []  instance Storable Bool   where-    type ListBased Bool = Bool-    type Element   Bool = Bool--    replicateArray = id-    toList         = id-    fromList       = id-    toData         = PrimitiveData . BoolData+    storableData   = PrimitiveData . primitiveData+    storableType s = StorableType [] . primitiveType s+    storableSize _ = ()+    listSize _ _   = []  instance Storable Int   where-    type ListBased Int = Int-    type Element   Int = Int--    replicateArray = id-    toList         = id-    fromList       = id-    toData         = PrimitiveData . IntData+    storableData   = PrimitiveData . primitiveData+    storableType s = StorableType [] . primitiveType s+    storableSize a = singletonRange $ toInteger a+    listSize _ _   = []  instance Storable Float   where-    type ListBased Float = Float-    type Element   Float = Float--    replicateArray = id-    toList         = id-    fromList       = id-    toData         = PrimitiveData . FloatData+    storableData   = PrimitiveData . primitiveData+    storableType s = StorableType [] . primitiveType s+    storableSize a = singletonRange a+    listSize _ _   = [] -instance (NaturalT n, Storable a) => Storable (n :> a)+instance Storable a => Storable [a]   where-    type ListBased (n :> a) = [ListBased a]-    type Element   (n :> a) = Element a+    storableData = StorableData . map storableData -    replicateArray = ArrayList . replicate n . replicateArray+    storableType (l:>ls) _ = StorableType (l:ls') t       where-        n = fromIntegerT (undefined :: n)--    toList (ArrayList as) = map toList as+        StorableType ls' t = storableType ls (T::T a) -    fromList as = ArrayList $ take n $ map fromList as-      where-        n = fromIntegerT (undefined :: n)+    storableSize as =+        singletonRange (length as) :> mconcat (map storableSize as) -    toData (ArrayList a) = StorableData n $ map toData a-      where-        n = fromIntegerT (undefined :: n)+    listSize _ (l:>ls) = l : listSize (T::T a) ls   -isRectangular :: Storable a => a -> Bool-isRectangular = isJust . checkRect . toData+class (Eq a, Ord a, Monoid (Size a), Set (Size a)) => Typeable a   where-    checkRect (PrimitiveData _)   = return []-    checkRect (StorableData _ []) = return []-    checkRect (StorableData _ as) = do-        dims <- mapM checkRect as-        guard $ allEqual dims-        return (length as : head dims)--+    -- | This type provides the necessary extra information to compute a type+    -- representation @`Tuple` `StorableType`@ from a type @a@. This is needed+    -- because the type @a@ is missing information about sizes of arrays and+    -- primitive values.+    type Size a --- | All supported types of data (nested tuples of storable data)-class (Eq a, Ord a) => Typeable a-  where-    -- | Gives the representation of the indexing type.-    typeOf :: T a -> Tuple StorableType+    -- | Gives the type representation of a storable value.+    typeOf :: Size a -> T a -> Tuple StorableType  instance Typeable ()   where-    typeOf = const $ One $ StorableType [] UnitType+    type Size () = ()+    typeOf       = typeOfStorable  instance Typeable Bool   where-    typeOf = const $ One $ StorableType [] BoolType+    type Size Bool = ()+    typeOf         = typeOfStorable  instance Typeable Int   where-    typeOf = const $ One $ StorableType [] IntType+    type Size Int = Range Integer+    typeOf        = typeOfStorable  instance Typeable Float   where-    typeOf = const $ One $ StorableType [] FloatType+    type Size Float = Range Float+    typeOf          = typeOfStorable -instance (NaturalT n, Storable a) => Typeable (n :> a)+instance Storable a => Typeable [a]   where-    typeOf = const $ One $ StorableType (n:dim) t-     where-       n = fromIntegerT (undefined :: n)-       One (StorableType dim t) = typeOf (T::T a)+    type Size [a] = Range Length :> Size a+    typeOf        = typeOfStorable  instance (Typeable a, Typeable b) => Typeable (a,b)   where-    typeOf = const $ Tup [typeOf (T::T a), typeOf (T::T b)]+    type Size (a,b) = (Size a, Size b) +    typeOf (sa,sb) _ = Tup [typeOf sa (T::T a), typeOf sb (T::T b)]+ instance (Typeable a, Typeable b, Typeable c) => Typeable (a,b,c)   where-    typeOf = const $ Tup [typeOf (T::T a), typeOf (T::T b), typeOf (T::T c)]+    type Size (a,b,c) = (Size a, Size b, Size c) +    typeOf (sa,sb,sc) _ = Tup+        [ typeOf sa (T::T a)+        , typeOf sb (T::T b)+        , typeOf sc (T::T c)+        ]+ instance (Typeable a, Typeable b, Typeable c, Typeable d) => Typeable (a,b,c,d)   where-    typeOf = const $ Tup-      [ typeOf (T::T a)-      , typeOf (T::T b)-      , typeOf (T::T c)-      , typeOf (T::T d)-      ]+    type Size (a,b,c,d) = (Size a, Size b, Size c, Size d) +    typeOf (sa,sb,sc,sd) _ = Tup+        [ typeOf sa (T::T a)+        , typeOf sb (T::T b)+        , typeOf sc (T::T c)+        , typeOf sd (T::T d)+        ]  --- | Checks if the given type is primitive.-isPrimitive :: Typeable a => T a -> Bool-isPrimitive a = case typeOf a of-    One (StorableType [] _) -> True-    _                       -> False +-- | Default implementation of 'typeOf' for 'Storable' types.+typeOfStorable :: Storable a => Size a -> T a -> Tuple StorableType+typeOfStorable sz = One . storableType sz++class (Num a, Primitive a, Num (Size a)) => Numeric a++instance Numeric Int++instance Numeric Float

@@ -0,0 +1,99 @@+-- Copyright (c) 2009-2010, ERICSSON AB+-- All rights reserved.+--+-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are met:+--+--     * Redistributions of source code must retain the above copyright notice,+--       this list of conditions and the following disclaimer.+--     * Redistributions in binary form must reproduce the above copyright+--       notice, this list of conditions and the following disclaimer in the+--       documentation and/or other materials provided with the distribution.+--     * Neither the name of the ERICSSON AB nor the names of its contributors+--       may be used to endorse or promote products derived from this software+--       without specific prior written permission.+--+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++-- | Helper functions for producing Haskell code++module Feldspar.Haskell where++++import Data.List++++-- | Types that can represent Haskell types (as source code strings)+class HaskellType a+  where+    -- | Gives the Haskell type denoted by the argument.+    haskellType :: a -> String++++-- | Types that can represent Haskell values (as source code strings)+class HaskellValue a+  where+    -- | Gives the Haskell code denoted by the argument.+    haskellValue :: a -> String++instance HaskellValue String+  where+    haskellValue = id++instance HaskellValue Int+  where+    haskellValue = show++++-- | Like 'Data.List.unlines', but no trailing @\'\\n\'@.+unlinesNoTrail :: [String] -> String+unlinesNoTrail = intercalate "\n"++-- | Indents a string the given number of columns.+indent :: Int -> String -> String+indent n = unlinesNoTrail . map (spc ++) . lines+  where+    spc = replicate n ' '++newline :: String+newline = "\n"++-- | Application+(-$-) :: HaskellValue a => String -> a -> String+fun -$- inp = unwords [fun, haskellValue inp]++-- | Binary operator application+opApp :: (HaskellValue a, HaskellValue b) => String -> a -> b -> String+opApp op a b = unwords [haskellValue a, op, haskellValue b]++-- | Definition+(-=-) :: (HaskellValue patt, HaskellValue def) => patt -> def -> String+patt -=- def = unwords [haskellValue patt, "=", haskellValue def]++-- Places the second string as a local block to the first string.+local :: String -> String -> String+local def ""   = def+local def defs = def ++ newline ++ indent 2 "where" ++ newline ++ indent 4 defs++infixl 8 -$-+infix  7 -=-+infixr 6 `local`++ifThenElse+    :: (HaskellValue c, HaskellValue t, HaskellValue e) => c -> t -> e -> String+ifThenElse c t e = unwords+    ["if", haskellValue c, "then", haskellValue t, "else", haskellValue e]+

@@ -1,4 +1,4 @@--- Copyright (c) 2009, ERICSSON AB+-- Copyright (c) 2009-2010, ERICSSON AB -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without@@ -24,8 +24,8 @@ -- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- | Operations on matrices (nested parallel vectors). All operations in this--- module assume rectangular matrices.+-- | Operations on matrices (doubly-nested parallel vectors). All operations in+-- this module assume rectangular matrices.  module Feldspar.Matrix where @@ -33,58 +33,54 @@  import qualified Prelude as P -import Types.Data.Ord- import Feldspar.Prelude import Feldspar.Utils-import Feldspar.Core.Types import Feldspar.Core import Feldspar.Vector   -type Matrix m n a = Par m :>> Par n :>> Data a+type Matrix a = Vector (Vector (Data a))    -- | Converts a matrix to a core array.-freezeMatrix :: (NaturalT m, NaturalT n, Storable a) =>-    Matrix m n a -> Data (m :> n :> a)-+freezeMatrix :: Storable a => Matrix a -> Data [[a]] freezeMatrix = freezeVector . map freezeVector ----- | Converts a core array to a matrix.-unfreezeMatrix :: (NaturalT m, NaturalT n, Storable a) =>-    Data Int -> Data Int -> Data (m :> n :> a) -> Matrix m n a-+-- | Converts a core array to a matrix. The first length argument is the number+-- of rows (outer vector), and the second argument is the number of columns+-- (inner argument).+unfreezeMatrix :: Storable a => Data Length -> Data Length -> Data [[a]] -> Matrix a unfreezeMatrix y x = map (unfreezeVector x) . (unfreezeVector y) ----- | Constructs a matrix.-matrix :: (NaturalT m, NaturalT n, Storable a, ListBased a ~ a) =>-    [[a]] -> Matrix m n a-+-- | Constructs a matrix. The elements are stored in a core array.+matrix :: Storable a => [[a]] -> Matrix a matrix as-    | allEqual xs = unfreezeMatrix y x $ array as+    | allEqual xs = unfreezeMatrix y x (value as)     | otherwise   = error "matrix: Not rectangular"   where-    y  = value $ P.length as     xs = P.map P.length as+    y  = value $ P.length as     x  = value $ P.head (xs P.++ [0])    -- | Transpose of a matrix-transpose :: Matrix m n a -> Matrix n m a+transpose :: Matrix a -> Matrix a transpose a = Indexed (length $ head a) ixf   where-    ixf y = Indexed (length a) (\x -> a ! x ! y)+    ixf y = Indexed (length a) $ \x -> a ! x ! y+  -- XXX This assumes that (head a) can be used even if a is empty. Might this+  --     violate size constraints on the index?+  --     See the conditional in 'flatten'. +  -- XXX Should be written using indexMat.+++ -- | Matrix multiplication-mul :: (Primitive a, Num a) => Matrix m n a -> Matrix n p a -> Matrix m p a+mul :: Numeric a => Matrix a -> Matrix a -> Matrix a mul a b = map (\aRow -> map (scalarProd aRow) b') a   where     b' = transpose b@@ -92,7 +88,7 @@   -- | Concatenates the rows of a matrix.-flatten :: Matrix m n a -> VectorP (m :* n) a+flatten :: Matrix a -> Vector (Data a) flatten matr = Indexed (m*n) ixf   where     m = length matr@@ -100,14 +96,15 @@      ixf i = matr ! y ! x       where-        y = i `div` m-        x = i `mod` m+        y = i `div` n+        x = i `mod` n+  -- XXX Should use "linear indexing"    -- | The diagonal vector of a square matrix. It happens to work if the number of -- rows is less than the number of columns, but not the other way around (this -- would require some overhead).-diagonal :: Matrix n n a -> VectorP n a-diagonal m = map (uncurry (!)) $ zip m $ enumFromTo 0 (length m - 1)+diagonal :: Matrix a -> Vector (Data a)+diagonal m = zipWith (!) m (0 ... (length m - 1)) 

@@ -1,4 +1,4 @@--- Copyright (c) 2009, ERICSSON AB+-- Copyright (c) 2009-2010, ERICSSON AB -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without@@ -38,6 +38,9 @@   , (<), (>), (<=), (>=)   , not, (&&), (||)   , min, max+  , (^)+  , div, mod+  , (>>)   , maximum, minimum   , length   , (++)@@ -52,7 +55,5 @@   , map   , zipWith   , sum-  , (^)-  , div, mod   ) 

@@ -0,0 +1,403 @@+-- Copyright (c) 2009-2010, ERICSSON AB+-- All rights reserved.+--+-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are met:+--+--     * Redistributions of source code must retain the above copyright notice,+--       this list of conditions and the following disclaimer.+--     * Redistributions in binary form must reproduce the above copyright+--       notice, this list of conditions and the following disclaimer in the+--       documentation and/or other materials provided with the distribution.+--     * Neither the name of the ERICSSON AB nor the names of its contributors+--       may be used to endorse or promote products derived from this software+--       without specific prior written permission.+--+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++{-# LANGUAGE NoMonomorphismRestriction #-}++-- | Ranged values++module Feldspar.Range where++++import Control.Monad+import Data.Maybe+import Data.Monoid+import Test.QuickCheck++++data Ord a => Range a = Range+  { lowerBound :: Maybe a+  , upperBound :: Maybe a+  }+    deriving (Eq, Show)++++instance (Ord a, Num a) => Num (Range a)+  where+    fromInteger = singletonRange . fromInteger++    negate = rangeOp neg+      where+        neg (Range l u) = Range (liftM negate u) (liftM negate l)++    (+) = rangeOp2 add+      where+        add (Range l1 u1) (Range l2 u2) =+          Range (liftM2 (+) l1 l2) (liftM2 (+) u1 u2)++    (*) = rangeMul++    abs = rangeOp abs'+      where+        abs' (Range l u) =+          Range (Just 0) (liftM2 max (liftM abs l) (liftM abs u))++    signum = rangeOp sign+      where+        sign r+          | range (-1) 1     `isSubRangeOf` r = range (-1) 1+          | range (-1) 0     `isSubRangeOf` r = range (-1) 0+          | range 0 1        `isSubRangeOf` r = range 0 1+          | singletonRange 0 `isSubRangeOf` r = singletonRange 0+          | isNatural r                       = singletonRange 1+          | isNegative r                      = singletonRange (-1)++instance (Ord a, Num a) => Monoid (Range a)+  where+    mempty  = emptyRange+    mappend = (\/)++++rangeOp :: Ord a => (Range a -> Range a) -> (Range a -> Range a)+rangeOp f r = if isEmpty r then r else f r++rangeOp2 :: Ord a =>+    (Range a -> Range a -> Range a) -> (Range a -> Range a -> Range a)+rangeOp2 f r1 r2+  | isEmpty r1 = r1+  | isEmpty r2 = r2+  | otherwise  = f r1 r2++mapMonotonic :: (Ord a, Ord b) => (a -> b) -> Range a -> Range b+mapMonotonic f (Range l u) = Range (liftM f l) (liftM f u)++rangeMul :: (Ord a, Num a) => Range a -> Range a -> Range a+rangeMul r1 r2 = p1 \/ p2 \/ p3 \/ p4+  where+    split r = (r /\ negativeRange, r /\ naturalRange)++    (r1neg,r1pos) = split r1+    (r2neg,r2pos) = split r2++    p1 = mul (negate r1neg) (negate r2neg)+    p2 = negate $ mul (negate r1neg) r2pos+    p3 = negate $ mul r1pos (negate r2neg)+    p4 = mul r1pos r2pos++    mul = rangeOp2 mul'+      where+        mul' (Range l1 u1) (Range l2 u2) =+          Range (liftM2 (*) l1 l2) (liftM2 (*) u1 u2)++++emptyRange :: (Ord a, Num a) => Range a+emptyRange = Range (Just 0) (Just (-1))++fullRange :: Ord a => Range a+fullRange = Range Nothing Nothing++range :: Ord a => a -> a -> Range a+range l u = Range (Just l) (Just u)++rangeByRange :: Ord a => Range a -> Range a -> Range a+rangeByRange r1 r2 = Range (lowerBound r1) (upperBound r2)++singletonRange :: Ord a => a -> Range a+singletonRange a = Range (Just a) (Just a)++naturalRange :: (Ord a, Num a) => Range a+naturalRange = Range (Just 0) Nothing++negativeRange :: (Ord a, Num a) => Range a+negativeRange = Range Nothing (Just (-1))++rangeSize :: (Ord a, Num a) => Range a -> Maybe a+rangeSize (Range l u) = do+    l' <- l+    u' <- u+    return (u'-l'+1)++isEmpty :: Ord a => Range a -> Bool+isEmpty (Range Nothing _)         = False+isEmpty (Range _ Nothing)         = False+isEmpty (Range (Just l) (Just u)) = u < l++isFull :: Ord a => Range a -> Bool+isFull (Range Nothing Nothing) = True+isFull _                       = False++isBounded :: Ord a => Range a -> Bool+isBounded (Range Nothing _) = False+isBounded (Range _ Nothing) = False+isBounded (Range _ _)       = True++isSingleton :: Ord a => Range a -> Bool+isSingleton (Range (Just l) (Just u)) = l==u+isSingleton _                         = False++isSubRangeOf :: Ord a => Range a -> Range a -> Bool+isSubRangeOf r1@(Range l1 u1) r2@(Range l2 u2)+    | isEmpty r1 = True+    | isEmpty r2 = False+    | otherwise+         = (isNothing l2 || (isJust l1 && l1>=l2))+        && (isNothing u2 || (isJust u1 && u1<=u2))++-- | Checks whether a range is a sub-range of the natural numbers.+isNatural :: (Ord a, Num a) => Range a -> Bool+isNatural = (`isSubRangeOf` naturalRange)++-- | Checks whether a range is a sub-range of the negative numbers.+isNegative :: (Ord a, Num a) => Range a -> Bool+isNegative = (`isSubRangeOf` negativeRange)++inRange :: Ord a => a -> Range a -> Bool+inRange a r = singletonRange a `isSubRangeOf` r++rangeGap :: (Ord a, Num a) => Range a -> Range a -> Range a+rangeGap = rangeOp2 gap+  where+    gap (Range _ (Just u1)) (Range (Just l2) _)+      | u1 < l2 = Range (Just u1) (Just l2)+    gap (Range (Just l1) _) (Range _ (Just u2))+      | u2 < l1 = Range (Just u2) (Just l1)+    gap _ _ = emptyRange+  -- If the result is non-empty, it will include the boundary elements from the+  -- two ranges.++++(\/) :: Ord a => Range a -> Range a -> Range a+r1 \/ r2+    | isEmpty r1 = r2+    | isEmpty r2 = r1+    | otherwise  = or r1 r2+  where+    or (Range l1 u1) (Range l2 u2) =+      Range (liftM2 min l1 l2) (liftM2 max u1 u2)++liftMaybe2 :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a+liftMaybe2 f Nothing b         = b+liftMaybe2 f a Nothing         = a+liftMaybe2 f (Just a) (Just b) = Just (f a b)++(/\) :: Ord a => Range a -> Range a -> Range a+(/\) = rangeOp2 and+  where+    and (Range l1 u1) (Range l2 u2) =+        Range (liftMaybe2 max l1 l2) (liftMaybe2 min u1 u2)++disjoint :: (Ord a, Num a) => Range a -> Range a -> Bool+disjoint r1 r2 = isEmpty (r1 /\ r2)++-- | @r1 \`rangeLess\` r2:@+--+-- Checks if all elements of @r1@ are less than all elements of @r2@.+rangeLess :: Ord a => Range a -> Range a -> Bool+rangeLess r1 r2+  | isEmpty r1 || isEmpty r2 = True+rangeLess (Range _ (Just u1)) (Range (Just l2) _) = u1 < l2+rangeLess _ _                                     = False++-- | @r1 \`rangeLessEq\` r2:@+--+-- Checks if all elements of @r1@ are less than or equal to all elements of+-- @r2@.+rangeLessEq :: Ord a => Range a -> Range a -> Bool+rangeLessEq (Range _ (Just u1)) (Range (Just l2) _) = u1 <= l2+rangeLessEq _ _                                     = False++showBound :: Show a => Maybe a -> String+showBound (Just a) = show a+showBound _        = "*"++showRange :: (Show a, Ord a) => Range a -> String+showRange r@(Range l u)+  | isEmpty r     = "[]"+  | isSingleton r = let Just a = upperBound r in show [a]+  | otherwise     = "[" ++ showBound l ++ "," ++ showBound u ++ "]"++++instance (Arbitrary a, Ord a, Num a) => Arbitrary (Range a)+  where+    coarbitrary = error "coarbitrary not defined for (Range a)"++    arbitrary = do+        lower <- arbitrary+        size  <- liftM abs arbitrary+        upper <- frequency [(6, return (lower+size)), (1, return (lower-size))]+        liftM2 Range (arbMaybe lower) (arbMaybe upper)+      where+        arbMaybe a = frequency [(5, return (Just a)), (1, return Nothing)]++++prop_arith1 :: (forall a . Num a => a -> a) -> Int -> Range Int -> Property+prop_arith1 op x r = (x `inRange` r) ==> (op x `inRange` op r)++++prop_arith2+    :: (forall a . Num a => a -> a -> a)+    -> Int -> Int -> Range Int -> Range Int -> Property++prop_arith2 op x y r1 r2 =+    (inRange x r1 && inRange y r2) ==> (op x y `inRange` op r1 r2)++++prop_fromInteger = isSingleton . fromInteger++prop_neg  = prop_arith1 negate+prop_add  = prop_arith2 (+)+prop_sub  = prop_arith2 (-)+prop_mul  = prop_arith2 (*)+prop_abs  = prop_arith1 abs+prop_sign = prop_arith1 signum++prop_abs2 (r::Range Int) = isNatural (abs r)++prop_empty = isEmpty (emptyRange :: Range Int)++prop_full = isFull (fullRange :: Range Int)++prop_isEmpty1 (r::Range Int) = isEmpty r ==> isBounded r+prop_isEmpty2 (r::Range Int) = isEmpty r ==> (upperBound r < lowerBound r)++prop_isFull (r::Range Int) = isFull r ==> not (isBounded r)++prop_fullRange = not $ isBounded (fullRange :: Range Int)++prop_range (a::Int) (b::Int) = isBounded $ range a b++prop_rangeByRange (r1::Range Int) (r2::Range Int) =+    (rangeLess r1 r2 && not (isEmpty (r1/\r2))) ==> isEmpty (rangeByRange r1 r2)++prop_singletonRange1 (a::Int) = isSingleton (singletonRange a)+prop_singletonRange2 (a::Int) = isBounded   (singletonRange a)++prop_singletonSize (r::Range Int) = isSingleton r ==> (rangeSize r == Just 1)++prop_subRange (r1::Range Int) (r2::Range Int) =+    ((r1 < r2) && (r2 < r1) && not (isEmpty r1)) ==> r1==r2+  where+    (<) = isSubRangeOf++prop_emptySubRange1 (r1::Range Int) (r2::Range Int) =+    isEmpty r1 ==> (not (isEmpty r2) ==> not (r2 `isSubRangeOf` r1))++prop_emptySubRange2 (r1::Range Int) (r2::Range Int) =+    isEmpty r1 ==> (not (isEmpty r2) ==> (r1 `isSubRangeOf` r2))++prop_isNegative (r::Range Int) =+    not (isEmpty r) ==> (isNegative r ==> not (isNegative $ negate r))++prop_rangeGap (r1::Range Int) (r2::Range Int) =+    (isEmpty gap1 && isEmpty gap2) || (gap1 == gap2)+  where+    gap1 = rangeGap r1 r2+    gap2 = rangeGap r2 r1++prop_union1 x (r1::Range Int) (r2::Range Int) =+    ((x `inRange` r1) || (x `inRange` r2)) ==> (x `inRange` (r1\/r2))++prop_union2 x (r1::Range Int) (r2::Range Int) =+    (x `inRange` (r1\/r2)) ==>+        ((x `inRange` r1) || (x `inRange` r2) || (x `inRange` rangeGap r1 r2))++prop_union3 (r1::Range Int) (r2::Range Int) = r1 `isSubRangeOf` (r1\/r2)+prop_union4 (r1::Range Int) (r2::Range Int) = r2 `isSubRangeOf` (r1\/r2)++prop_intersect1 x (r1::Range Int) (r2::Range Int) =+    ((x `inRange` r1) && (x `inRange` r2)) ==> (x `inRange` (r1/\r2))++prop_intersect2 x (r1::Range Int) (r2::Range Int) =+    (x `inRange` (r1/\r2)) ==> ((x `inRange` r1) && (x `inRange` r2))++prop_intersect3 (r1::Range Int) (r2::Range Int) = (r1/\r2) `isSubRangeOf` r1+prop_intersect4 (r1::Range Int) (r2::Range Int) = (r1/\r2) `isSubRangeOf` r2++prop_disjoint x (r1::Range Int) (r2::Range Int) =+    disjoint r1 r2 ==> (x `inRange` r1) ==> not (x `inRange` r2)++prop_rangeLess1 (r1::Range Int) (r2::Range Int) =+    rangeLess r1 r2 ==> disjoint r1 r2++prop_rangeLess2 x y (r1::Range Int) (r2::Range Int) =+    (rangeLess r1 r2 && inRange x r1 && inRange y r2) ==> x < y++prop_rangeLessEq x y (r1::Range Int) (r2::Range Int) =+    (rangeLessEq r1 r2 && inRange x r1 && inRange y r2) ==> x <= y++++testAll = do+    myCheck prop_neg+    myCheck prop_add+    myCheck prop_sub+    myCheck prop_mul+    myCheck prop_abs+    myCheck prop_sign+    myCheck prop_abs2+    myCheck prop_fromInteger+    myCheck prop_empty+    myCheck prop_full+    myCheck prop_isEmpty1+    myCheck prop_isEmpty2+    myCheck prop_isFull+    myCheck prop_fullRange+    myCheck prop_range+    -- myCheck prop_rangeByRange+    -- XXX "Arguments exhausted after 0 test"+    --     Something must be wrong with generator...+    myCheck prop_singletonRange1+    myCheck prop_singletonRange2+    myCheck prop_singletonSize+    myCheck prop_subRange+    myCheck prop_emptySubRange1+    myCheck prop_emptySubRange2+    myCheck prop_isNegative+    myCheck prop_rangeGap+    myCheck prop_union1+    myCheck prop_union2+    myCheck prop_union3+    myCheck prop_union4+    myCheck prop_intersect1+    myCheck prop_intersect2+    myCheck prop_intersect3+    myCheck prop_intersect4+    myCheck prop_disjoint+    myCheck prop_rangeLess1+    myCheck prop_rangeLess2+    myCheck prop_rangeLessEq+  where+    myCheck = check defaultConfig {configMaxFail = 100000}+

@@ -1,4 +1,4 @@--- Copyright (c) 2009, ERICSSON AB+-- Copyright (c) 2009-2010, ERICSSON AB -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without@@ -42,12 +42,18 @@ allEqual []     = True allEqual (a:as) = all (==a) as --- | @showSeq open strs close@:+-- | @`showSeq` open strs close@: -- -- Shows the strings @strs@ separated by commas and enclosed within the @open@ -- and @close@ strings. showSeq :: String -> [String] -> String -> String showSeq open strs close = open ++ intercalate "," strs ++ close++-- | Append the first argument to the first line of the second argument.+appendFirstLine :: String -> String -> String+appendFirstLine extra str = str1 ++ extra ++ str2+  where+    (str1,str2) = break (=='\n') str   

@@ -1,4 +1,4 @@--- Copyright (c) 2009, ERICSSON AB+-- Copyright (c) 2009-2010, ERICSSON AB -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without@@ -28,198 +28,144 @@ -- ("Feldspar.Core"). Many of the functions defined here are imitations of -- Haskell's list operations, and to a first approximation they behave -- accordingly.+--+-- A symbolic vector ('Vector') can be thought of as a representation of a+-- 'parallel' core array. This view is made precise by the function+-- 'freezeVector', which converts a symbolic vector to a core vector using+-- 'parallel'.+--+-- 'Vector' is instantiated under the 'Computable' class, which means that+-- symbolic vectors can be used quite seamlessly with the interface in+-- "Feldspar.Core".+--+-- Note that the only operations in this module that introduce storage (through+-- core arrays) are+--+--   * 'freezeVector'+--+--   * 'memorize'+--+--   * 'vector'+--+--   * 'unfoldVec'+--+--   * 'unfold'+--+--   * 'scan'+--+--   * 'mapAccum'+--+-- This means that vector operations not involving these operations will be+-- completely \"fused\" without using any intermediate storage.+--+-- Note also that most operations only introduce a small constant overhead on+-- the vector. The exceptions are+--+--   * 'dropWhile'+--+--   * '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.+--+-- Finally, note that 'freezeVector' can be introduced implicitly by functions+-- overloaded by the 'Computable' class. This means that, for example,+-- @`printCore` f@, where @f :: Vector (Data Int) -> Vector (Data Int)@, will+-- introduce storage for the input and output of @f@.  module Feldspar.Vector where    import qualified Prelude-import Control.Arrow ((***),(&&&))-import Data.List (unfoldr)+import Control.Arrow ((&&&))+import qualified Data.List  -- Only for documentation of 'unfold'  import Feldspar.Prelude-import Feldspar.Core.Types-import Feldspar.Core.Expr hiding (index)+import Feldspar.Range+import Feldspar.Core.Expr import Feldspar.Core    -- * Types --- | Dynamic size of a vector-type Size = Int- -- | Vector index type Ix = Int --- | Empty type denoting a parallel (random) access pattern for elements in a--- vector. The argument denotes the static size of the vector.-data Par n---- | Empty type denoting a sequential access pattern for elements in a vector.--- The argument denotes the static size of the vector.-data Seq n---- | Symbolic vector. For example,------ > Seq D10 :>> Par D5 :>> Data Int------ is a sequential (symbolic) vector of parallel vectors of integers. The type--- numbers @D10@ and @D5@ denote the /static size/ of the vector, i.e. the--- allocated size of the array used if and when the vector gets written to--- memory (e.g. by 'toPar').------ If it is known that the vector will never be written to memory, it is--- not needed to specify a static size. In that case, it is possible to use @()@--- as the static size type. This way, attempting to write to memory will--- result in a type error.------ The 'Size' argument to the 'Indexed' and 'Unfold' constructors is called the--- /dynamic/ size, since it can vary freely during execution.-data n :>> a-  where-    Indexed  -- Constructor for parallel vectors-      :: Data Size-      -> (Data Ix -> a)  -- A mapping from indexes to elements-      -> (Par n :>> a)--    Unfold  -- Constructor for sequential vectors-      :: Computable s-      => Data Size-      -> (s -> (a,s))  -- "Step function"-      -> s             -- Initial state-      -> (Seq n :>> a)--infixr 5 :>>---- | Non-nested parallel vector-type VectorP n a = Par n :>> Data a---- | Non-nested sequential vector-type VectorS n a = Seq n :>> Data a------ | Addition for static vector size-type family (:+) a b--type instance (:+) (Dec a) (Dec b) = Dec a :+: Dec b-type instance (:+) ()      ()      = ()------ | Multiplication for static vector size-type family (:*) a b+-- | Symbolic vector+data Vector a = Indexed+  { length :: Data Length+  , index  :: Data Ix -> a+  } -type instance (:*) (Dec a) (Dec b) = Dec a :*: Dec b-type instance (:*) ()      ()      = ()+-- | Short-hand for non-nested parallel vector+type DVector a = Vector (Data a)    -- * Construction/conversion --- | A class for generalizing over parallel and sequential vectors.-class AccessPattern t-  where-    genericVector :: (Par n :>> a) -> (Seq n :>> a) -> (t n :>> a)--instance AccessPattern Par-  where-    genericVector vecP _ = vecP--instance AccessPattern Seq-  where-    genericVector _ vecS = vecS---- | Constructs a parallel vector from an index function. The function is--- assumed to be defined for the domain @[0 .. n-1]@, were @n@ is the dynamic--- size.-indexed :: Data Size -> (Data Ix -> a) -> (Par n :>> a)-indexed = Indexed---- | Constructs a sequential vector from a \"step\" function and an initial--- state.-unfold :: Computable s => Data Size -> (s -> (a,s)) -> s -> (Seq n :>> a)-unfold = Unfold--- -- | Converts a non-nested vector to a core vector.-freezeVector :: forall t n a . (NaturalT n, Storable a) =>-    (t n :>> Data a) -> Data (n :> a)--freezeVector (Indexed sz ixf) = parallel sz ixf--freezeVector (Unfold sz step s) = snd $ for 0 end (s,arr) body-  where-    end = value $ fromIntegerT (undefined :: n) - 1-    arr = array [] :: Data (n :> a)--    body i (s, arr :: Data (n :> a)) = (s', setIx arr i a)-      where-        (a,s') = step s+freezeVector :: Storable a => Vector (Data a) -> Data [a]+freezeVector (Indexed l ixf) = parallel l ixf +-- | Converts a non-nested core vector to a parallel vector.+unfreezeVector :: Storable a => Data Length -> Data [a] -> Vector (Data a)+unfreezeVector l arr = Indexed l (getIx arr) +-- | Optimizes vector lookup by computing all elements and storing them in a+-- core array.+memorize :: Storable a => Vector (Data a) -> Vector (Data a)+memorize vec = unfreezeVector (length vec) $ freezeVector vec+  -- XXX Should be generalized to arbitrary dimensions. --- | Converts a non-nested core vector to a parallel vector.-unfreezeVector :: (NaturalT n, Storable a, AccessPattern t) =>-    Data Size -> Data (n :> a) -> (t n :>> Data a)+indexed :: Data Length -> (Data Ix -> a) -> Vector a+indexed = Indexed -unfreezeVector sz arr = genericVector vec (toSeq vec)+-- | Constructs a non-nested vector. The elements are stored in a core vector.+vector :: Storable a => [a] -> Vector (Data a)+vector as = unfreezeVector l (value as)   where-    vec = Indexed sz (getIx arr)-+    l = value $ Prelude.length as+  -- XXX Should be generalized to arbitrary dimensions. +modifyLength :: (Data Length -> Data Length) -> Vector a -> Vector a+modifyLength f vec = vec {length = f (length vec)} --- | Constructs a non-nested vector.-vector :: (NaturalT n, Storable a, AccessPattern t, ListBased a ~ a) =>-    [a] -> (t n :>> Data a)-  -- (ListBased a ~ a) means no nesting.+setLength :: Data Length -> Vector a -> Vector a+setLength = modifyLength . const -vector as = unfreezeVector sz $ array as+boundVector :: Int -> Vector a -> Vector a+boundVector maxLen = modifyLength (cap r)   where-    sz = value $ Prelude.length as+    r = negativeRange + singletonRange (fromIntegral maxLen) + 1+      -- XXX fromIntegral might not be needed in future.   --- instance (NaturalT n, Storable (Internal a), Computable a) =>---     Computable (Par n :>> a)---   where---     type Internal (Par n :>> a) = (Int, n :> Internal a)----     internalize vec =---      internalize (length vec, freezeVector $ map internalize vec)----     externalize sz_a = map externalize $ unfreezeVector sz a---       where---         sz = externalize $ ref $ GetTuple (T::T D0) sz_a---         a  = externalize $ ref $ GetTuple (T::T D1) sz_a-  -- XXX This would require first class tuples.--instance (NaturalT n, Storable a, AccessPattern t)-      => Computable (t n :>> Data a)+instance Storable a => Computable (Vector (Data a))   where-    type Internal (t n :>> Data a) = (Int, n :> Internal (Data a))+    type Internal (Vector (Data a)) = (Length, [Internal (Data a)])      internalize vec =       internalize (length vec, freezeVector $ map internalize vec) -    externalize sz_a = map externalize $ unfreezeVector sz a+    externalize l_a = map externalize $ unfreezeVector l a       where-        sz = externalize $ ref $ GetTuple (T::T D0) sz_a-        a  = externalize $ ref $ GetTuple (T::T D1) sz_a+        l = externalize $ exprToData $ Get21 l_a+        a = externalize $ exprToData $ Get22 l_a -instance-    ( NaturalT n1-    , NaturalT n2-    , Storable a-    , AccessPattern t1-    , AccessPattern t2-    ) =>-      Computable (t1 n1 :>> t2 n2 :>> Data a)+instance Storable a => Computable (Vector (Vector (Data a)))   where-    type Internal (t1 n1 :>> t2 n2 :>> Data a) =-           (Int, n1 :> Int, n1 :> n2 :> Internal (Data a))+    type Internal (Vector (Vector (Data a))) =+           (Length, [Length], [[Internal (Data a)]])      internalize vec = internalize       ( length vec@@ -229,257 +175,169 @@      externalize inp         = map (map externalize . uncurry unfreezeVector)-        $ zip sz2sV (unfreezeVector sz1 a)+        $ zip l2sV (unfreezeVector l1 a)       where-        sz1   = externalize $ ref $ GetTuple (T::T D0) inp-        sz2s  = externalize $ ref $ GetTuple (T::T D1) inp-        a     = externalize $ ref $ GetTuple (T::T D2) inp-        sz2sV = unfreezeVector sz1 sz2s :: t1 n1 :>> Data Int------ | Convert any vector to a sequential one. This operation is always \"cheap\".-toSeq :: (t n :>> a) -> (Seq n :>> a)-toSeq (Indexed sz ixf)   = Unfold sz (\i -> (ixf i, i+1)) 0-toSeq (Unfold sz step s) = Unfold sz step s---- | Changes the static size of a vector.-resize :: NaturalT n => (t m :>> a) -> (t n :>> a)-resize (Indexed sz ixf)   = Indexed sz ixf-resize (Unfold sz step s) = Unfold sz step s-  -- The NaturalT constraint is needed because otherwise it would be possible to-  -- make an existing NaturalT constraint disappear. That would ruin the-  -- property that vectors with fully polymorphic sizes do not represent their-  -- elements in memory.---- | Convert any non-nested vector to a parallel one with cheap lookups.--- Internally, this is done by writing the vector to memory.-toPar :: (NaturalT n, Storable a) => (t n :>> Data a) -> VectorP n a-toPar vec = unfreezeVector (length vec) $ freezeVector vec+        l1   = externalize $ exprToData $ Get31 inp+        l2s  = externalize $ exprToData $ Get32 inp+        a    = externalize $ exprToData $ Get33 inp+        l2sV = unfreezeVector l1 l2s    -- * Operations --- | Look up an index in a vector. This operation takes linear time for--- sequential vectors.-index :: (t :>> a) -> Data Ix -> a-index (Indexed _ ixf)   i = ixf i-index (Unfold _ step s) i = fst $ step $ fst $ while cont body (s,0)-  where-    cont = (<i) . snd-    body = ((snd . step) *** (+1))--instance RandomAccess (Par n :>> a)+instance RandomAccess (Vector a)   where-    type Elem (Par n :>> a) = a+    type Element (Vector a) = a     (!) = index   --- | The dynamic size of a vector-length :: (t n :>> a) -> Data Size-length (Indexed sz _)   = sz-length (Unfold  sz _ _) = sz----(++) :: Computable a => (t m :>> a) -> (t n :>> a) -> (t (m :+ n) :>> a)--Indexed sz1 ixf1 ++ Indexed sz2 ixf2 = Indexed (sz1+sz2) ixf-  where-    ixf i = ifThenElse (i < sz1) ixf1 (ixf2 . subtract sz1) i--Unfold sz1 step1 s1 ++ Unfold sz2 step2 s2 = Unfold (sz1+sz2) step (0, (s1,s2))+-- | Introduces an 'ifThenElse' for each element; use with care!+(++) :: Computable a => Vector a -> Vector a -> Vector a+Indexed l1 ixf1 ++ Indexed l2 ixf2 = Indexed (l1+l2) ixf   where-    step (n, (s1',s2')) = n<sz1 ?-      ( let (a,s1'') = step1 s1' in (a, (n+1, (s1'', s2')))-      , let (a,s2'') = step2 s2' in (a, (n+1, (s1', s2'')))-      )+    ixf i = ifThenElse (i < l1) ixf1 (ixf2 . subtract l1) i  infixr 5 ++ ---take :: Data Int -> (t n :>> a) -> (t n :>> a)--take n (Indexed sz ixf) = Indexed sz' ixf-  where-    sz' = min sz n--take n (Unfold sz step s) = Unfold sz' step s-  where-    sz' = min sz n----drop :: Data Int -> (t n :>> a) -> (t n :>> a)--drop n (Indexed sz ixf) = Indexed sz' (\x -> ixf (x+n))-  where-    sz' = max 0 (sz-n)--drop n (Unfold sz step s) = Unfold sz' step s'-  where-    sz' = max 0 (sz-n)-    s'  = for 0 (n-1) s (\_ -> snd . step)--+take :: Data Int -> Vector a -> Vector a+take n (Indexed l ixf) = Indexed (minX n l) ixf -dropWhile :: (a -> Data Bool) -> (t n :>> a) -> (t n :>> a)+drop :: Data Int -> Vector a -> Vector a+drop n (Indexed l ixf) = Indexed (maxX 0 (l-n)) (\x -> ixf (x+n)) -dropWhile cont vec@(Indexed _ _) = drop i vec+dropWhile :: (a -> Data Bool) -> Vector a -> Vector a+dropWhile cont vec = drop i vec   where     i = while ((< length vec) &&* (cont . (vec !))) (+1) 0 -dropWhile cont vec@(Unfold sz step s) = Unfold (sz-i) step s'-  where-    (s',i) = while condition (\(s,i) -> (snd $ step s, i+1)) (s,0)-      where-        condition = ((\(s,i) -> i <= length vec) &&* (cont.fst.step.fst))----splitAt :: Data Int -> (t n :>> a) -> (t n :>> a, t n :>> a)+splitAt :: Data Int -> Vector a -> (Vector a, Vector a) splitAt n vec = (take n vec, drop n vec) -head :: (t n :>> a) -> a-head = flip index 0+head :: Vector a -> a+head = (!0) -last :: (t n :>> a) -> a-last vec = index vec (length vec - 1)+last :: Vector a -> a+last vec = vec ! (length vec - 1) -tail :: (t n :>> a) -> (t n :>> a)+tail :: Vector a -> Vector a tail = drop 1 -init :: (t n :>> a) -> (t n :>> a)+init :: Vector a -> Vector a init vec = take (length vec - 1) vec --- | Like Haskell's 'tails', but does not include the empty vector. This is--- actually just to make the types simpler (the result is square).-tails :: AccessPattern u => (t n :>> a) -> (u n :>> t n :>> a)-tails vec = genericVector vecP vecS-  where-    sz   = length vec-    vecP = Indexed sz (\n -> drop n vec)-    vecS = Unfold sz (\n -> (drop n vec, n+1)) 0+tails :: Vector a -> Vector (Vector a)+tails vec = Indexed (length vec + 1) (\n -> drop n vec) --- | Like Haskell's 'inits', but does not include the empty vector. This is--- actually just to make the types simpler (the result is square).-inits :: AccessPattern u => (t n :>> a) -> (u n :>> t n :>> a)-inits vec = genericVector vecP vecS-  where-    sz   = length vec-    vecP = Indexed sz (\n -> take n vec)-    vecS = Unfold sz (\n -> (take n vec, n+1)) 0+inits :: Vector a -> Vector (Vector a)+inits vec = Indexed (length vec + 1) (\n -> take n vec) -permute :: (Data Size -> Data Ix -> Data Ix) -> ((Par n :>> a) -> (Par n :>> a))-permute perm (Indexed sz ixf) = Indexed sz (ixf . perm sz)+inits1 :: Vector a -> Vector (Vector a)+inits1 = tail . inits -reverse :: (Par n :>> a) -> (Par n :>> a)-reverse = permute $ \sz i -> sz-1-i+permute :: (Data Length -> Data Ix -> Data Ix) -> (Vector a -> Vector a)+permute perm (Indexed l ixf) = Indexed l (ixf . perm l) -replicate :: AccessPattern t => Data Int -> a -> (t n :>> a)-replicate n a = genericVector vecP vecS-  where-    vecP = Indexed n (const a)-    vecS = Unfold n (const (a, unit)) unit+reverse :: Vector a -> Vector a+reverse = permute $ \l i -> l-1-i -enumFromTo :: AccessPattern t => Data Int -> Data Int -> (t n :>> Data Int)-enumFromTo m n = genericVector vecP vecS-  where-    sz   = n-m+1-    vecP = indexed sz (+m)-    vecS = unfold sz (\x -> (x,x+1)) m+replicate :: Data Int -> a -> Vector a+replicate n a = Indexed n (const a) +enumFromTo :: Data Int -> Data Int -> Vector (Data Int)+enumFromTo m n = Indexed (n-m+1) (+m)+  -- XXX Type should be generalized. +(...) :: Data Int -> Data Int -> Vector (Data Int)+(...) = enumFromTo -zip :: (t n :>> a) -> (t n :>> b) -> (t n :>> (a,b))+zip :: Vector a -> Vector b -> Vector (a,b)+zip (Indexed l1 ixf1) (Indexed l2 ixf2) = Indexed (min l1 l2) (ixf1 &&& ixf2) -zip (Indexed sz1 ixf1) (Indexed sz2 ixf2) =-    Indexed (min sz1 sz2) (ixf1 &&& ixf2)+unzip :: Vector (a,b) -> (Vector a, Vector b)+unzip (Indexed l ixf) = (Indexed l (fst.ixf), Indexed l (snd.ixf)) -zip (Unfold sz1 step1 s1) (Unfold sz2 step2 s2) = Unfold sz step (s1, s2)-  where-    sz = min sz1 sz2-    step (s1,s2) = ((a,b), (s1',s2'))-      where-        (a,s1') = step1 s1-        (b,s2') = step2 s2+map :: (a -> b) -> Vector a -> Vector b+map f (Indexed l ixf) = Indexed l (f . ixf) +zipWith :: (a -> b -> c) -> Vector a -> Vector b -> Vector c+zipWith f aVec bVec = map (uncurry f) $ zip aVec bVec +-- | Corresponds to 'foldl'.+fold :: Computable a => (a -> b -> a) -> a -> Vector b -> a+fold f x (Indexed l ixf) = for 0 (l-1) x (\i s -> f s (ixf i)) -unzip :: (t n :>> (a,b)) -> (t n :>> a, t n :>> b)+-- | Corresponds to 'foldl1'.+fold1 :: Computable a => (a -> a -> a) -> Vector a -> a+fold1 f a = fold f (head a) a -unzip (Indexed sz ixf) = (Indexed sz (fst.ixf), Indexed sz (snd.ixf)) -unzip (Unfold sz step s) =-    (Unfold sz ((fst***id).step) s, Unfold sz ((snd***id).step) s) +-- | Like 'unfoldCore', but for symbolic vectors. The output elements are stored+-- in a core vector.+unfoldVec+    :: (Computable state, Storable a)+    => Data Length+    -> state+    -> (Data Int -> state -> (Data a, state))+    -> (Vector (Data a), state) +unfoldVec l init step = (unfreezeVector l arr, final)+  where+    (arr,final) = unfoldCore l init step -map :: (a -> b) -> ((t n :>> a) -> (t n :>> b))-map f (Indexed sz ixf)   = Indexed sz (f . ixf)-map f (Unfold sz step s) = Unfold sz ((f *** id) . step) s -zipWith :: (a -> b -> c) -> (t n :>> a) -> (t n :>> b) -> (t n :>> c)-zipWith f aVec bVec = map (uncurry f) $ zip aVec bVec +-- | Somewhat similar to Haskell's 'Data.List.unfoldr'. The output elements are+-- stored in a core vector.+--+-- @`unfold` l init step@:+--+--   * @l@ is the length of the resulting vector.+--+--   * @init@ is the initial state.+--+--   * @step@ is a function computing a new element and the next state from the+--     current state.+unfold :: (Computable state, Storable a) =>+    Data Length -> state -> (state -> (Data a, state)) -> Vector (Data a) +unfold l init = fst . unfoldVec l init . const --- | Corresponds to Haskell's @foldl@.-fold :: Computable a => (a -> b -> a) -> a -> (t n :>> b) -> a -fold f x (Unfold sz step s) = fst $ for 0 (sz-1) (x,s) body-  where-    body i (m,n) = (f m m', n')-      where-        (m',n') = step n -fold f x (Indexed sz ixf) = for 0 (sz-1) x (\i s -> f s (ixf i))--+-- | Corresponds to 'scanl'. The output elements are stored in a core vector.+scan :: (Storable a, Computable b) =>+    (Data a -> b -> Data a) -> Data a -> Vector b -> Vector (Data a) --- | Corresponds to Haskell's @foldl1@.-fold1 :: Computable a => (a -> a -> a) -> (t n :>> a) -> a-fold1 f a = fold f (head a) a+scan f a vec = fst $ unfoldVec (length vec + 1) a $ \i a -> (a, f a (vec!i))   --- | Corresponds to Haskell's @scanl@.-scan :: Computable a => (a -> b -> a) -> a -> (t n :>> b) -> (Seq n :>> a)--scan f a (Indexed sz ixf) = Unfold sz step (0,a)-  where-    step (i,a) = let a' = f a (ixf i) in (a', (i+1, a'))+-- | Corresponds to 'Data.List.mapAccumL'. The output elements are stored in a+-- core vector.+mapAccum :: (Storable a, Computable acc, Storable b)+    => (acc -> Data a -> (acc, Data b))+    -> acc -> Vector (Data a) -> (acc, Vector (Data b)) -scan f a (Unfold sz step s) = Unfold sz step' (s,a)+mapAccum f init vecA = (final,vecB)   where-    step' (s,a) = (a', (s',a'))-      where-        (b,s') = step s-        a'     = f a b+    (vecB,final) = unfoldVec (length vecA) init $ \i acc ->+      let (acc',b) = f acc (vecA!i) in (b,acc')   --- | Corresponds to Haskell's @scanl1@.-scan1 :: Computable a => (a -> a -> a) -> (t n :>> a) -> (Seq n :>> a)-scan1 f vec = scan f (head vec) (tail vec)--sum :: (Num a, Computable a) => (t n :>> a) -> a+sum :: (Num a, Computable a) => Vector a -> a sum = fold (+) 0 -maximum :: Storable a => (t n :>> Data a) -> Data a+maximum :: Storable a => Vector (Data a) -> Data a maximum = fold1 max -minimum :: Storable a => (t n :>> Data a) -> Data a+minimum :: Storable a => Vector (Data a) -> Data a minimum = fold1 min -- -- | Scalar product of two vectors-scalarProd :: (Primitive a, Num a) =>-    (t n :>> Data a) -> (t n :>> Data a) -> Data a-+scalarProd :: Numeric a => Vector (Data a) -> Vector (Data a) -> Data a scalarProd a b = sum (zipWith (*) a b) 

@@ -1,4 +1,4 @@-Copyright (c) 2009, ERICSSON AB+Copyright (c) 2009-2010, ERICSSON AB All rights reserved.  Redistribution and use in source and binary forms, with or without

@@ -1,12 +1,12 @@ name:           feldspar-language-version:        0.1+version:        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, ERICSSON AB+copyright:      Copyright (c) 2009-2010, ERICSSON AB author:         Functional programming group at Chalmers University of Technology maintainer:     Emil Axelsson <emax@chalmers.se> license:        BSD3@@ -21,32 +21,35 @@   exposed-modules:     Feldspar.Prelude     Feldspar.Utils+    Feldspar.Haskell+    Feldspar.Range     Feldspar.Core.Types-    Feldspar.Core.Haskell-    Feldspar.Core.Graph-    Feldspar.Core.Show     Feldspar.Core.Ref     Feldspar.Core.Expr+    Feldspar.Core.Graph+    Feldspar.Core.Show+    Feldspar.Core.Reify     Feldspar.Core.Functions     Feldspar.Core     Feldspar.Vector     Feldspar.Matrix     Feldspar -  build-depends: base >= 3 && < 4, containers, directory, mtl, process, tfp+  build-depends:+    base >= 3 && < 4,+    containers,+    mtl,+    QuickCheck >= 1.2 && < 2    extensions:-    EmptyDataDecls     FlexibleInstances     FlexibleContexts     GADTs-    MultiParamTypeClasses     NoMonomorphismRestriction     OverlappingInstances     PatternGuards     Rank2Types     ScopedTypeVariables-    StandaloneDeriving     TypeFamilies     TypeOperators     TypeSynonymInstances