diff --git a/Feldspar.hs b/Feldspar.hs --- a/Feldspar.hs +++ b/Feldspar.hs @@ -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 diff --git a/Feldspar/Core.hs b/Feldspar/Core.hs --- a/Feldspar/Core.hs +++ b/Feldspar/Core.hs @@ -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 diff --git a/Feldspar/Core/Expr.hs b/Feldspar/Core/Expr.hs --- a/Feldspar/Core/Expr.hs +++ b/Feldspar/Core/Expr.hs @@ -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 diff --git a/Feldspar/Core/Functions.hs b/Feldspar/Core/Functions.hs --- a/Feldspar/Core/Functions.hs +++ b/Feldspar/Core/Functions.hs @@ -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 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<< 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 diff --git a/Feldspar/Core/Graph.hs b/Feldspar/Core/Graph.hs --- a/Feldspar/Core/Graph.hs +++ b/Feldspar/Core/Graph.hs @@ -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] diff --git a/Feldspar/Core/Haskell.hs b/Feldspar/Core/Haskell.hs deleted file mode 100644 --- a/Feldspar/Core/Haskell.hs +++ /dev/null @@ -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] - diff --git a/Feldspar/Core/Ref.hs b/Feldspar/Core/Ref.hs --- a/Feldspar/Core/Ref.hs +++ b/Feldspar/Core/Ref.hs @@ -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, diff --git a/Feldspar/Core/Reify.hs b/Feldspar/Core/Reify.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Core/Reify.hs @@ -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 + diff --git a/Feldspar/Core/Show.hs b/Feldspar/Core/Show.hs --- a/Feldspar/Core/Show.hs +++ b/Feldspar/Core/Show.hs @@ -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) diff --git a/Feldspar/Core/Types.hs b/Feldspar/Core/Types.hs --- a/Feldspar/Core/Types.hs +++ b/Feldspar/Core/Types.hs @@ -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 diff --git a/Feldspar/Haskell.hs b/Feldspar/Haskell.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Haskell.hs @@ -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] + diff --git a/Feldspar/Matrix.hs b/Feldspar/Matrix.hs --- a/Feldspar/Matrix.hs +++ b/Feldspar/Matrix.hs @@ -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)) diff --git a/Feldspar/Prelude.hs b/Feldspar/Prelude.hs --- a/Feldspar/Prelude.hs +++ b/Feldspar/Prelude.hs @@ -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 ) diff --git a/Feldspar/Range.hs b/Feldspar/Range.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Range.hs @@ -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} + diff --git a/Feldspar/Utils.hs b/Feldspar/Utils.hs --- a/Feldspar/Utils.hs +++ b/Feldspar/Utils.hs @@ -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 diff --git a/Feldspar/Vector.hs b/Feldspar/Vector.hs --- a/Feldspar/Vector.hs +++ b/Feldspar/Vector.hs @@ -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 = (> 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 (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) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/feldspar-language.cabal b/feldspar-language.cabal --- a/feldspar-language.cabal +++ b/feldspar-language.cabal @@ -1,12 +1,12 @@ name: feldspar-language -version: 0.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 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