diff --git a/Feldspar.hs b/Feldspar.hs new file mode 100644 --- /dev/null +++ b/Feldspar.hs @@ -0,0 +1,42 @@ +-- 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. + +-- | Exports everything necessary for ordinary use of the Feldspar language. + +module Feldspar + ( module Feldspar.Prelude + , module Feldspar.Core + , module Feldspar.Vector + , module Feldspar.Matrix + ) where + + + +import Feldspar.Prelude +import Feldspar.Core +import Feldspar.Vector +import Feldspar.Matrix + diff --git a/Feldspar/Core.hs b/Feldspar/Core.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Core.hs @@ -0,0 +1,65 @@ +-- 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. + +-- | The user interface to the core language + +module Feldspar.Core + ( module Types.Data.Num + , Primitive + , (:>) + , Storable + , ListBased + , Data + , Computable + , Internal + , eval + , value + , unit + , true + , false + , array + , size + , getIx + , setIx + , RandomAccess (..) + , noInline + , ifThenElse + , while + , parallel + , Program + , showCore + , printCore + , module Feldspar.Core.Functions + ) where + + + +import Types.Data.Num + +import Feldspar.Core.Types +import Feldspar.Core.Expr +import Feldspar.Core.Functions + diff --git a/Feldspar/Core/Expr.hs b/Feldspar/Core/Expr.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Core/Expr.hs @@ -0,0 +1,766 @@ +-- 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. + +{-# LANGUAGE IncoherentInstances #-} + +-- | 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. + +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.Unique + +import Types.Data.Num + +import Feldspar.Core.Ref (Ref) +import qualified Feldspar.Core.Ref as Ref +import Feldspar.Core.Types +import Feldspar.Core.Graph hiding (function, Function (..)) +import qualified Feldspar.Core.Graph as Graph +import Feldspar.Core.Show + + + +-- * Expressions + +-- | A wrapper around 'Expr' to allow observable sharing (see +-- "Feldspar.Core.Ref"). +data Data a = Typeable a => Data (Ref (Expr a)) + +instance Eq (Data a) + where + Data a == Data b = a==b + +instance Ord (Data a) + where + Data a `compare` Data b = a `compare` b + + + +ref :: Typeable a => Expr a -> Data a +ref = Data . Ref.ref + +refId :: Data a -> Unique +refId (Data r) = Ref.refId r + +deref :: Data a -> Expr a +deref (Data r) = Ref.deref r + +typeOfData :: forall a . Typeable a => Data a -> Tuple StorableType +typeOfData _ = typeOf (T::T a) + + + +-- | 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 + where + Input :: Expr a -- XXX Risky to rely on observable sharing? + Value :: Storable 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) + GetTuple :: GetTuple n a => T n -> Data a -> Expr (Part n a) + + Function :: String -> (a -> b) -> (Data a -> Expr b) + + NoInline + :: (Typeable a, Typeable b) + => String -> Ref.Ref (Data a -> Data b) -> (Data a -> Expr b) + + IfThenElse + :: (Typeable a, Typeable b) + => Data Bool -- Condition + -> (Data a -> Data b) -- If branch + -> (Data a -> Data b) -- Else branch + -> (Data a -> Expr b) + + While + :: Typeable a + => (Data a -> Data Bool) -- Continue? + -> (Data a -> Data a) -- Body + -> Data a -- Initial state + -> Expr a -- Final state + + Parallel + :: (NaturalT n, Storable a) + => Data Int -- Dynamic size (must be <= array size) + -> (Data Int -> Data a) -- Index mapping + -> Expr (n :> a) -- Result vector + + -- 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? + + + +-- | Computable types. A computable value completely represents a core program, +-- in such a way that @internalize . externalize@ preserves semantics, but not +-- necessarily syntax. +-- +-- The terminology used in this class comes from thinking of the 'Data' type as +-- the \"internal core language\" and the 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). + type Internal a + + -- | Convert to internal representation + internalize :: a -> Data (Internal a) + + -- | Convert to external representation + externalize :: Data (Internal a) -> a + +instance Storable a => Computable (Data a) + where + type Internal (Data a) = a + + internalize = id + externalize = id + +instance (Computable a, Computable b) => Computable (a,b) + where + type Internal (a,b) = (Internal a, Internal b) + + internalize (a,b) = ref $ Tuple2 (internalize a) (internalize b) + + externalize ab = + ( externalize $ ref $ GetTuple (T::T D0) ab + , externalize $ ref $ GetTuple (T::T D1) 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) + (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 + ) + +instance + ( Computable a + , Computable b + , Computable c + , Computable d + ) => + Computable (a,b,c,d) + where + type Internal (a,b,c,d) = (Internal a, Internal b, Internal c, Internal d) + + internalize (a,b,c,d) = ref $ 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 + ) + + + +wrap :: (Computable a, Computable b) => + (a -> b) -> (Data (Internal a) -> Data (Internal b)) +wrap f = internalize . f . externalize + +unwrap :: (Computable a, Computable b) => + (Data (Internal a) -> Data (Internal b)) -> (a -> b) +unwrap f = externalize . f . internalize + + + +-- | The semantics of expressions +evalE :: Expr 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 (While continue body init) = loop init + where + loop s + | done = evalD s + | otherwise = loop (body s) + where + done = not $ evalD $ continue s + +evalE (Parallel sz ixf) = + mapArray (evalD . ixf . value) $ fromList [(0::Int) .. n-1] + where + n = evalD sz + + + +-- | Evaluation of 'Data' +evalD :: Data a -> a +evalD = evalE . deref + +-- | Evaluation of any 'Computable' type +eval :: Computable a => a -> Internal a +eval = evalD . internalize + + + +instance Primitive a => Show (Data a) + where + show a = "... :: Data a" + -- Needed for the @Num@ instance. + +instance (Num n, Primitive n) => Num (Data n) + where + fromInteger = value . fromInteger + abs = functionFold "abs" abs + signum = functionFold "signum" signum + (+) = functionFold2 "(+)" (+) + (-) = functionFold2 "(-)" (-) + (*) = functionFold2 "(*)" (*) + + + +instance Fractional (Data Float) + where + fromRational = value . fromRational + (/) = functionFold2 "(/)" (/) + + + +-- | 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_ + +unit :: Data () +unit = value () + +true :: Data Bool +true = value True + +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 + + + +-- | 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 + + + +-- | A two-argument function +function2 + :: ( Storable a + , Storable b + , Storable c + ) + => String -> (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) + + + +-- | A three-argument function +function3 + :: ( Storable a + , Storable b + , Storable c + , Storable d + ) + => String -> (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) + + + +-- | A four-argument function +function4 + :: ( 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) + +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 + + + +-- | 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 + + + +-- | 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) + +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 + + + +-- | 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 + where + f (ArrayList as) i + | i >= n || i < 0 = error "getIx: index out of bounds" + | i >= l = error "getIx: reading garbage" + | otherwise = as !! i + where + n = fromIntegerT (undefined :: n) + l = length as + + + +-- | @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 + 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 + + + +class RandomAccess a + where + type Elem a + + -- | Index lookup in random access structures + (!) :: a -> Data Int -> Elem a + +instance (NaturalT n, Storable a) => RandomAccess (Data (n :> a)) + where + type Elem (Data (n :> a)) = Data a + (!) = getIx + + + +-- | Constructs a non-primitive, non-inlined function. +-- +-- The normal way to make a non-primitive function is to use an ordinary Haskell +-- function, for example: +-- +-- > myFunc x = x * 4 + 5 +-- +-- However, such functions are inevitably inlined into the program expression +-- when applied. @noInline@ can be thought of as a way to protect a function +-- against inlining (but later transformations may choose to inline anyway). +-- +-- Ideally, it should be posssible to reuse such a function several times, but +-- at the moment this does not work. Every application of a @noInline@ function +-- results in a new copy of the function in the core program. +noInline :: (Computable a, Computable b) => String -> (a -> b) -> (a -> b) +noInline fun = unwrap . (ref .) . NoInline fun . Ref.ref . wrap + + + +-- | @ifThenElse cond thenFunc elseFunc@: +-- +-- Selects between the two functions @thenFunc@ and @elseFunc@ depending on +-- whether the condition @cond@ is true or false. +ifThenElse + :: (Computable a, Computable b) + => Data Bool -> (a -> b) -> (a -> b) -> (a -> b) + +ifThenElse cond t e = case deref cond of + Value True -> t + Value False -> e +-- 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')) + 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) + + + +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) + + + +buildGraph :: forall a . Data a -> GraphBuilder () +buildGraph dat@(Data _) = do + idat <- checkNode dat + unless (isJust idat) $ list (deref dat) + 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 + + + +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) + + + +toGraphD :: (Typeable a, Typeable b) => (Data a -> Data b) -> Graph +toGraphD f = Graph nodes iface + where + (iface,(nodes,_)) = runGraph (buildSubFun f) startInfo + + + +-- | 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) + 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 + diff --git a/Feldspar/Core/Functions.hs b/Feldspar/Core/Functions.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Core/Functions.hs @@ -0,0 +1,117 @@ +-- 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. + +-- | Primitive and helper functions supported by Feldspar + +module Feldspar.Core.Functions where + + + +import qualified Prelude + +import Feldspar.Prelude +import Feldspar.Core.Types +import Feldspar.Core.Expr + + + +infix 4 == +infix 4 /= +infix 4 < +infix 4 > +infix 4 <= +infix 4 >= +infix 1 ? + + + +(==) :: Storable a => Data a -> Data a -> Data Bool +(==) = functionFold2 "(==)" (Prelude.==) + +(/=) :: Storable a => Data a -> Data a -> Data Bool +(/=) = functionFold2 "(/=)" (Prelude./=) + +(<) :: Storable a => Data a -> Data a -> Data Bool +(<) = functionFold2 "(<)" (Prelude.<) + +(>) :: Storable a => Data a -> Data a -> Data Bool +(>) = functionFold2 "(>)" (Prelude.>) + +(<=) :: Storable a => Data a -> Data a -> Data Bool +(<=) = functionFold2 "(<=)" (Prelude.<=) + +(>=) :: Storable a => Data a -> Data a -> Data Bool +(>=) = functionFold2 "(>=)" (Prelude.>=) + +not :: Data Bool -> Data Bool +not = functionFold "not" 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.&&) + +(||) :: Data Bool -> Data Bool -> Data Bool +(||) = functionFold2 "(||)" (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 + +-- | 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 + +min :: Storable a => Data a -> Data a -> Data a +min a b = a<=b ? (a,b) + +max :: Storable a => Data a -> Data a -> Data a +max a b = a>=b ? (a,b) + +div :: Data Int -> Data Int -> Data Int +div = functionFold2 "div" (Prelude.div) + +mod :: Data Int -> Data Int -> Data Int +mod = functionFold2 "mod" (Prelude.mod) + +(^) :: Data Int -> Data Int -> Data Int +(^) = functionFold2 "(^)" (Prelude.^) + +-- | @for start end init body@: +-- +-- 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 :: Computable a => Data Int -> Data Int -> a -> (Data Int -> a -> a) -> a +for start end init body = snd $ while cont body' (start,init) + where + cont (i,s) = i <= end + body' (i,s) = (i+1, body i s) + diff --git a/Feldspar/Core/Graph.hs b/Feldspar/Core/Graph.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Core/Graph.hs @@ -0,0 +1,485 @@ +-- 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. + +-- | A graph representation of core programs. A graph is a flat structure that +-- can be viewed as a program with a global scope. For example, the Haskell +-- program +-- +-- > main x = f 1 +-- > where +-- > f y = g 2 +-- > where +-- > g z = x + z +-- +-- might be represented by the following flat graph: +-- +-- > graph = Graph +-- > { graphNodes = +-- > [ Node +-- > { nodeId = 0 +-- > , function = Input +-- > , input = Tup [] +-- > , inputType = Tup [] +-- > , outputType = intType +-- > } +-- > , Node +-- > { nodeId = 1 +-- > , function = Input +-- > , input = Tup [] +-- > , inputType = Tup [] +-- > , outputType = intType +-- > } +-- > , Node +-- > { nodeId = 2 +-- > , function = Input +-- > , input = Tup [] +-- > , inputType = Tup [] +-- > , outputType = intType +-- > } +-- > , Node +-- > { nodeId = 3 +-- > , function = Function "(+)" +-- > , input = Tup [One (Variable (0,[])), One (Variable (2,[]))] +-- > , inputType = intPairType +-- > , outputType = intType +-- > } +-- > , Node +-- > { nodeId = 4 +-- > , function = NoInline "f" (Interface 1 (One (Variable (5,[]))) intType intType) +-- > , input = One (Constant (IntData 1)) +-- > , inputType = intType +-- > , outputType = intType +-- > } +-- > , Node +-- > { nodeId = 5 +-- > , function = NoInline "g" (Interface 2 (One (Variable (3,[]))) intType intType) +-- > , input = One (Constant (IntData 2)) +-- > , inputType = intType +-- > , outputType = intType +-- > } +-- > ] +-- > +-- > , graphInterface = Interface +-- > { interfaceInput = 0 +-- > , interfaceOutput = One (Variable (4,[])) +-- > , interfaceInputType = intType +-- > , interfaceOutputType = intType +-- > } +-- > } +-- > where +-- > intType = result (typeOf :: Res [[[Int]]] (Tuple StorableType)) +-- > intPairType = result (typeOf :: Res (Int,Int) (Tuple StorableType)) +-- +-- which corresponds to the following flat program +-- +-- > main v0 = v4 +-- > f v1 = v5 +-- > g v2 = v3 +-- > v3 = v0 + v2 +-- > v4 = f 1 +-- > v5 = g 2 +-- +-- There are a few assumptions on graphs: +-- +-- * All nodes have unique identifiers. +-- +-- * There are no cycles. +-- +-- * The 'input' and 'inputType' tuples of each node should have the same shape. +-- +-- * Each 'interfaceInput' (including the top-level one) refers to an 'Input' +-- node not referred to by any other interface. +-- +-- * All 'Variable' references are valid (i.e. refer only to those variables +-- implicitly defined by each node). +-- +-- * There should not be any cycles in the constraints introduced by +-- 'findLocalities'. (XXX Is this even possible?) +-- +-- * Sub-function interfaces should be \"consistent\" with the input/output type +-- of the node. For example, the body of a while loop should have the same type +-- as the whole loop. +-- +-- In the original program, @g@ was defined locally to @f@, and the addition was +-- done locally in @g@. But in the flat program, this hierarchy (called +-- /definition hierarchy/) is not represented. The flat program is of course not +-- valid Haskell (@v0@ and @v2@ are used outside of their scopes). The function +-- 'makeHierarchical' turns a flat graph into a hierarchical one that +-- corresponds to syntactically valid Haskell. +-- +-- 'makeHierarchical' requires some explanation. First a few definitions: +-- +-- * Nodes that have associated interfaces ('NoInline', 'IfThenElse', 'While' +-- and 'Parallel') are said to contain /sub-functions/. These nodes are called +-- /super nodes/. In the above program, the super node @v4@ contains the +-- sub-function @f@, and @v5@ contains the sub-function @g@. +-- +-- * A definition @d@ is /local/ to a definition @e@ iff. @d@ is placed +-- somewhere within the definition of @e@ (i.e. inside an arbitrarily deeply +-- nested @where@ clause). +-- +-- * A definition @d@ is /owned/ by a definition @e@ iff. @d@ is placed +-- immediately under the top-most @where@ clause of @e@. A definition may have +-- at most one owner. +-- +-- The definition hierarchy thus specifies ownership between the definitions in +-- the program. There are two types of ownership: +-- +-- * A super node is always the owner of its sub-functions. +-- +-- * A sub-function may be the owner of some node definitions. +-- +-- Assigning nodes to sub-functions in a useful way takes some work. It is done +-- by first finding out for each node which sub-functions it must be local to. +-- Each locality constraint gives an upper bound on where in the definition +-- hierarchy the node may be placed. There is one principle for introducing a +-- locality constraint: +-- +-- * If node @v@ depends on the input of sub-function @f@, then @v@ must be +-- local to @f@. +-- +-- The locality constraints for a graph can thus be found be tracing each +-- sub-function input in order to find the nodes that depend on it (see function +-- 'findLocalities'). In the above program, we have the sub-functions @f@ and +-- @g@ with the inputs @v1@ and @v2@ respectively. We can see immediately that +-- no node depends on @v1@, so we get no locality constraints for @f@. The only +-- node that depends on @v2@ is @v3@, so the program has a single locality +-- constraint: @v3@ is local to @g@. Nodes without constraints are simply taken +-- to be local to @main@. With this information, we can now rewrite the flat +-- program as +-- +-- > main v0 = v4 +-- > where +-- > v4 = f 1 +-- > where +-- > f v1 = v5 +-- > v5 = g 2 +-- > where +-- > g v2 = v3 +-- > where +-- > v3 = v0 + v2 +-- +-- which is syntactically valid Haskell. Note that this program is slightly +-- different from the original which defined @g@ locally to @f@. However, in +-- general, we want definitions to be as \"global\" as possible in order to +-- maximize sharing. For example, we don't want to put definitions in the body +-- of a while loop unless they really depend on the loop state, because then +-- they will (probably, depending on implementation) be recomputed in every +-- iteration. Also note that in this program, it is not strictly necessary to +-- have the sub-functions owned by their super nodes -- @f@ and @g@ could have +-- been owned by @main@ instead. However, this would cause clashes if two +-- sub-functions have the same name. Having sub-functions owned by their super +-- nodes is also a way of keeping related definitions together in the program. +-- +-- There is one caveat with the above method. Consider the following flat +-- program: +-- +-- > main v0 = v4 +-- > f v1 = v5 +-- > g v2 = v3 +-- > v3 = v1 + 2 +-- > v4 = f 0 +-- > v5 = g 1 +-- +-- Here, we get the locality constraint: @v3@ is local to @f@. However, to get a +-- valid definition hierarchy, we also need @v5@ to be local to @f@. This is +-- because @v5@ is the owner of @g@, and the output of @g@ is local to @f@. So +-- when looking for dependencies, we should let each super node depend on its +-- sub-function output, /except/ for the owner of the very sub-function that is +-- being traced (a function cannot be owned by itself). + +module Feldspar.Core.Graph where + + + +import qualified Data.Foldable as Fold +import Data.Function +import Data.List +import Data.Map (Map) +import qualified Data.Map as Map + +import Feldspar.Utils +import Feldspar.Core.Types + + + +-- | Node identifier +type NodeId = Int + +-- | Variable represented by a node id and a tuple path. For example, in a +-- definition (given in Haskell syntax) +-- +-- > ((a,b),c) = f x +-- +-- the variable @b@ would be represented as @(i,[0,1])@ (where @i@ is the id of +-- the @f@ node). +type Variable = (NodeId, [Int]) + +-- | The source of a value is either constant data or a variable. +data Source + = Constant PrimitiveData + | Variable Variable + deriving (Eq, Show) + +-- | A node in the program graph. The input is given as a 'Source' tuple. The +-- output is implicitly defined by the 'nodeId' and the 'outputType'. For +-- example, a node with id @i@ and output type +-- +-- > Tup [One ..., One ...] +-- +-- has the implicit output +-- +-- > Tup [One (i,[0]), One (i,[1])] +data Node = Node + { nodeId :: NodeId + , function :: Function + , input :: Tuple Source + , inputType :: Tuple StorableType + , outputType :: Tuple StorableType + } + deriving (Eq, Show) + +-- | The interface of a (sub-)graph. The input is conceptually a +-- @Tuple Variable@, but all these variables refer to the same 'Input' node, so +-- it is sufficient to track the node id (the tuple shape can be inferred from +-- the 'interfaceInputType'). +data Interface = Interface + { interfaceInput :: NodeId + , interfaceOutput :: Tuple Source + , interfaceInputType :: Tuple StorableType + , interfaceOutputType :: Tuple StorableType + } + deriving (Eq, Show) + +-- | Node functionality +data Function + = + -- | Primary input + Input + -- | Constant array + | Array StorableData + -- | Primitive function + | Function String + -- | Non-inlined function + | NoInline String Interface + -- | Conditional + | IfThenElse Interface Interface + -- | While-loop + | While Interface Interface + -- | Parallel tiling + | Parallel Int Interface + deriving (Eq, Show) + +-- | A graph is a list of unique nodes with an interface. +data Graph = Graph + { graphNodes :: [Node] + , graphInterface :: Interface + } + +instance Eq Graph + where + Graph ns1 iface1 == Graph ns2 iface2 + = ns1' == ns2' + && iface1 == iface2 + where + ns1' = sortBy (compare `on` nodeId) ns1 + ns2' = sortBy (compare `on` nodeId) ns2 + -- Comparison ignores order of nodes. + +-- | A definition hierarchy. A hierarchy consists of number of top-level nodes, +-- each one associated with its sub-functions, represented as hierarchies. The +-- nodes owned by a sub-function appear as the top-level nodes in the +-- corresponding hierarchy. +data Hierarchy = Hierarchy [(Node, [Hierarchy])] + +-- | A graph with a hierarchical ordering of the nodes. If the hierarchy is +-- flattened it should result in a valid 'Graph'. +data HierarchicalGraph = HierGraph + { graphHierarchy :: Hierarchy + , hierGraphInterface :: Interface + } + +-- | A node that contains a sub-function +type SuperNode = NodeId + +-- | The branch is used to distinguish between different sub-functions of the +-- same super node. For example, the continue condition of a while-loop has +-- branch number 0, and the body has number 1 (see 'subFunctions'). +data SubFunction = SubFunction + { sfSuper :: SuperNode + , sfBranch :: Int + , sfInput :: NodeId + , sfOutput :: [NodeId] + } + deriving (Eq, Show) + +instance Ord SubFunction + where + compare (SubFunction o1 b1 _ _) (SubFunction o2 b2 _ _) = + compare (o1,b1) (o2,b2) + -- Ignores inputs/outputs since these should be equal anyway if the super + -- and branch fields are equal. + +-- | Locality constraint +data Local = Local SubFunction NodeId + deriving (Eq, Show) + + + +-- | Returns the nodes in a source tuple. +sourceNodes :: Tuple Source -> [NodeId] +sourceNodes tup = [i | Variable (i,_) <- Fold.toList tup] + +-- | The fanout of each node in a graph. Nodes that are not in the map are +-- assumed to have no fanout. +fanout :: Graph -> Map NodeId [NodeId] +fanout graph = Map.fromListWith (++) + [ (inp, [nodeId node]) + | node <- graphNodes graph + , inp <- sourceNodes (input node) + ] + +-- | Look up a node in the graph +nodeMap :: Graph -> (NodeId -> Node) +nodeMap graph = (m Map.!) + where + m = Map.fromList [(nodeId node, node) | node <- graphNodes graph] + + + +-- | Lists all sub-functions in the graph. +subFunctions :: Graph -> [SubFunction] +subFunctions graph = + concat [subFun i fun | Node i fun _ _ _ <- graphNodes graph] + where + sub i branch (Interface inp outp _ _) = + SubFunction i branch inp (sourceNodes outp) + + subFun i (NoInline _ f) = [sub i 0 f] + subFun i (IfThenElse t e) = [sub i 0 t, sub i 1 e] + subFun i (While cont body) = [sub i 0 cont, sub i 1 body] + subFun i (Parallel _ ixf) = [sub i 0 ixf] + subFun _ _ = [] + + + +-- | Lists all locality constraints of the graph. +findLocalities :: Graph -> [Local] +findLocalities graph = concatMap traceSub sfs + where + fo = fanout graph + sfs = subFunctions graph + + superLink = Map.fromListWith (++) + [(outp,[super]) | SubFunction super _ _ outps <- sfs, outp <- outps] + -- Fanout map with edges from sub-function output to super node + + traceSub sf@(SubFunction _ _ inp outps) = trace inp + where + trace a = Local sf a : concatMap trace bs + where + as = if a `elem` outps then [] else superLink !!! a + bs = (fo !!! a) ++ as + -- Computes locality constraints by tracing the dependencies of + -- sub-function inputs. + + + +-- | Returns a total ordering between all super nodes in a graph, such that if +-- node @v@ is local to sub-function @f@, then @v@ maps to a lower number than +-- the owner of @f@. The converse is not necessarily true. The second argument +-- gives the locality constraints for each node in the graph (top-level nodes +-- may be left undefined). +orderSuperNodes :: Graph -> Map NodeId [SubFunction] -> Map SuperNode Int +orderSuperNodes graph locals = Map.fromList $ zip (topSort sfOrder) [0..] + where + sfOrder = Map.fromListWith (++) + [ (i, map sfSuper (locals !!! i)) + | SubFunction i _ _ _ <- subFunctions graph + ] + -- A partial ordering between all sub-functions. An edge from `f` to `g` + -- means that `f` is local to `g`. This is a representation of the actual + -- sub-function ordering which is the transitive closure of `sfOrder`. + -- `sfOrder` is a dag. + +-- | Returns the minimal sub-function according to the given owner ordering. +minimalSubFun :: Map SuperNode Int -> [SubFunction] -> SubFunction +minimalSubFun ownOrd = head . sortBy (compare `on` ((ownOrd Map.!) . sfSuper)) + +-- | Sorts the nodes by their id. +sortNodes :: [Node] -> [Node] +sortNodes = sortBy (compare `on` nodeId) + + + +-- | Makes a hierarchical graph from a flat one. The node lists in the hierarchy +-- are always sorted according to node id. +makeHierarchical :: Graph -> HierarchicalGraph +makeHierarchical graph@(Graph nodes iface) = + HierGraph (mkHierarchy topLevel) iface + where + locs = findLocalities graph + + locals :: Map NodeId [SubFunction] + locals = Map.fromListWith (++) [(i,[sf]) | Local sf i <- locs] + -- The locality constraints for each node. Nodes that are not in the map + -- have no constraints. + + owner :: Map NodeId SubFunction + owner = fmap (minimalSubFun $ orderSuperNodes graph locals) locals + -- The owner of each node. Nodes that are not in the map have no owner. + + nodeLookup :: NodeId -> Node + nodeLookup = nodeMap graph + + mkHierarchy :: [Node] -> Hierarchy + mkHierarchy nodes = Hierarchy (nodes `zip` map subHierarchies nodes) + + subFunHier :: SuperNode -> Int -> Hierarchy + subFunHier i branch = mkHierarchy nodes + where + ownedBy = fmap (sortNodes . map nodeLookup) $ invertMap owner + sf = SubFunction i branch undefined undefined + nodes = ownedBy Map.! sf + -- Defined for every sub-function, because each sub-function contains + -- at least one node (the input). + + subHierarchies :: Node -> [Hierarchy] + subHierarchies (Node i (NoInline _ _) _ _ _) = map (subFunHier i) [0] + subHierarchies (Node i (IfThenElse _ _) _ _ _) = map (subFunHier i) [0,1] + subHierarchies (Node i (While _ _) _ _ _) = map (subFunHier i) [0,1] + subHierarchies (Node i (Parallel _ _) _ _ _) = map (subFunHier i) [0] + subHierarchies _ = [] + + topLevel :: [Node] + topLevel = sortNodes + [ nodeLookup i + | node <- nodes + , let i = nodeId node + , Nothing <- [Map.lookup i owner] + ] + -- The nodes that don't have any owner + diff --git a/Feldspar/Core/Haskell.hs b/Feldspar/Core/Haskell.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Core/Haskell.hs @@ -0,0 +1,77 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/Feldspar/Core/Ref.hs @@ -0,0 +1,71 @@ +-- 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. + +{-# OPTIONS_GHC -O0 #-} + +-- | +-- Copyright : Copyright (c) 2009, Koen Claessen +-- +-- A simple implementation of \"observable sharing\". See +-- +-- * Koen Claessen, David Sands, +-- \"/Observable sharing for functional circuit description/\", +-- Asian Computing Science Conference, 1999. +-- +-- for more details. + +module Feldspar.Core.Ref + ( Ref + , refId + , deref + , ref + ) where + + + +import Data.Unique +import System.IO.Unsafe + + + +data Ref a = Ref + { refId :: Unique + , deref :: a + } + +instance Eq (Ref a) where + Ref x _ == Ref y _ = x == y + +instance Ord (Ref a) where + Ref x _ `compare` Ref y _ = x `compare` y + + + +ref :: a -> Ref a +ref x = unsafePerformIO $ do + u <- newUnique + return (Ref u x) + diff --git a/Feldspar/Core/Show.hs b/Feldspar/Core/Show.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Core/Show.hs @@ -0,0 +1,186 @@ +-- 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. + +-- | Defines a function 'showGraph' for showing core language graphs as Haskell +-- code. + +module Feldspar.Core.Show where + + + +import Control.Monad +import Data.List + +import Feldspar.Core.Types +import Feldspar.Core.Haskell +import Feldspar.Core.Graph + + + +instance HaskellValue Variable + where + haskellValue (i,path) = "v" ++ intercalate "_" (map show (i:path)) + +instance HaskellValue Source + where + haskellValue (Constant a) = haskellValue a + haskellValue (Variable v) = haskellValue v + +-- | Creates a tuple pattern of the given type, for the output of the given +-- node. +tupPatt :: Tuple StorableType -> NodeId -> Tuple Variable +tupPatt tup i = fmap (\path -> (i,path)) (tuplePath tup) + +-- | Matches the string against @\"(...)\"@, and returns @Just ...@ if possible, +-- otherwise @Nothing@. +viewBinOp :: String -> Maybe String +viewBinOp "" = Nothing +viewBinOp op + | length op < 2 = Nothing + | (head op == '(') && (last op == ')') = Just $ tail $ init op + | otherwise = Nothing + + + +-- | Shows a single node. The first argument associates each sub-function with +-- the nodes it owns. +showNode :: Node -> [Hierarchy] -> String + +showNode (Node i fun inp inType outType) subHiers = showNd fun + where + outp = tupPatt outType i + + showNd Input = "" + showNd (Array a) = ((i,[])::Variable) -=- a + + showNd (Function fun) + | Just op <- viewBinOp fun = outp -=- opApp op a b + where + Tup [a,b] = inp + + showNd (Function fun) = outp -=- fun -$- inp + + showNd (NoInline fun iface) = + outp -=- fun -$- inp + `local` + showSF (head subHiers) fun subInp subOutp + where + subInp = tupPatt inType $ interfaceInput iface + subOutp = interfaceOutput iface + + showNd (IfThenElse ifaceThen ifaceElse) = + outp -=- ifExpr + `local` + (thenBranch ++ newline ++ elseBranch) + where + Tup [One cond, a] = inp + Tup [_, aType] = inType + [thenHier,elseHier] = subHiers + + ifExpr = ifThenElse cond + ("thenBranch" -$- a) + ("elseBranch" -$- a) + + subInpThen = tupPatt aType $ interfaceInput ifaceThen + subInpElse = tupPatt aType $ interfaceInput ifaceElse + subOutpThen = interfaceOutput ifaceThen + subOutpElse = interfaceOutput ifaceElse + + thenBranch = showSF thenHier "thenBranch" subInpThen subOutpThen + elseBranch = showSF elseHier "elseBranch" subInpElse subOutpElse + + showNd (While ifaceCont ifaceBody) = + outp -=- "while" -$- "cont" -$- "body" -$- inp + `local` + (contBranch ++ newline ++ bodyBranch) + where + [contHier,bodyHier] = subHiers + + subInpCont = tupPatt inType $ interfaceInput ifaceCont + subInpBody = tupPatt inType $ interfaceInput ifaceBody + subOutpCont = interfaceOutput ifaceCont + subOutpBody = interfaceOutput ifaceBody + + contBranch = showSF contHier "cont" subInpCont subOutpCont + bodyBranch = showSF bodyHier "body" subInpBody subOutpBody + + showNd (Parallel szs iface) = + outp -=- "parallel" -$- szs -$- inp -$- "ixf" + `local` + showSF (head subHiers) "ixf" subInp subOutp + where + subInp = tupPatt inType $ interfaceInput iface + subOutp = interfaceOutput iface + + + +-- | @showSubFun 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. +showSubFun + :: (HaskellValue inp, HaskellValue outp) + => Hierarchy + -> String + -> Maybe inp + -> outp + -> String + +showSubFun (Hierarchy nodes) name inp outp = + funHead inp -=- outp + `local` + unlinesNoTrail (filter (not.null) $ map (uncurry showNode) nodes) + where + funHead Nothing = name + funHead (Just inp) = name -$- inp + + + +-- | @showSF hier name inp = showSubFun hier name (Just inp)@ +showSF + :: (HaskellValue inp, HaskellValue outp) + => Hierarchy + -> String + -> inp + -> outp + -> String + +showSF hier name inp = showSubFun hier name (Just inp) + + + +-- | Shows a graph. The given string is the name of the top-level function. The +-- Boolean tells whether the graph has a real or a dummy argument. A graphs with +-- that has a dummy argument will be shown as a definition without an argument. +-- Of course, this assumes that a dummy argument is not used within the graph. +showGraph :: String -> Bool -> Graph -> String +showGraph name hasArg graph@(Graph nodes iface) = showSubFun hier name inp' outp + where + hier = graphHierarchy $ makeHierarchical graph + inp = tupPatt (interfaceInputType iface) (interfaceInput iface) + inp' = guard hasArg >> Just inp + outp = interfaceOutput iface + diff --git a/Feldspar/Core/Types.hs b/Feldspar/Core/Types.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Core/Types.hs @@ -0,0 +1,452 @@ +-- 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. + +-- | Defines types and classes for the data computed by "Feldspar" programs. + +module Feldspar.Core.Types where + + + +import Control.Applicative +import Control.Monad +import Data.Char +import Data.Foldable (Foldable) +import qualified Data.Foldable as Fold +import Data.Maybe +import Data.Traversable (Traversable, traverse) + +import Types.Data.Num + +import Feldspar.Utils + + + +-- * Types as arguments + +-- | 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) + + + +-- * Haskell source code + +-- | 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 + +instance HaskellType a => HaskellType (Tuple a) + where + haskellType = showTuple . fmap haskellType + + + +-- | 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 + +instance HaskellValue a => HaskellValue (Tuple a) + where + haskellValue = showTuple . fmap haskellValue + + + +-- * Tuples + +-- | General tuple projection +class NaturalT n => GetTuple n a + where + type Part n a + getTup :: T n -> a -> Part n a + +instance GetTuple D0 (a,b) + where + type Part D0 (a,b) = a + getTup _ (a,b) = a + +instance GetTuple D1 (a,b) + where + type Part D1 (a,b) = b + getTup _ (a,b) = b + +instance GetTuple D0 (a,b,c) + where + type Part D0 (a,b,c) = a + getTup _ (a,b,c) = a + +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 + + + +-- | Untyped representation of nested tuples +data Tuple a + = One a + | Tup [Tuple a] + deriving (Eq, Show) + +instance Functor Tuple + where + fmap f (One a) = One (f a) + fmap f (Tup as) = Tup $ map (fmap f) as + +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 + +instance Traversable Tuple + where + traverse f (One a) = pure One <*> f a + traverse f (Tup as) = pure Tup <*> traverse (traverse f) as + + + +-- | 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) ")" + +-- | Replaces each element by its path in the tuple tree. For example: +-- +-- > tuplePath (Tup [One 'a',Tup [One 'b', One 'c']]) +-- > == +-- > Tup [One [0],Tup [One [1,0],One [1,1]]] +tuplePath :: Tuple a -> Tuple [Int] +tuplePath tup = path [] tup + where + path pth (One _) = One pth + path pth (Tup as) = Tup [path (pth++[n]) a | (a,n) <- as `zip` [0..]] + + + +-- * Data + +-- | Representation of primitive types +data PrimitiveType + = UnitType + | BoolType + | IntType + | FloatType + deriving (Eq, Show) + +-- | Untyped representation of primitive data +data PrimitiveData + = UnitData + | BoolData Bool + | IntData Int + | 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. +data StorableData + = PrimitiveData PrimitiveData + | StorableData Int [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 (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) "]" + + + +-- | Primitive types +class Storable a => Primitive a + +instance Primitive () +instance Primitive Bool +instance Primitive Int +instance Primitive 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] + +infixr 5 :> + +instance (NaturalT n, Storable a, Eq a) => Eq (n :> a) + where + ArrayList a == ArrayList b = a == b + +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) + where + ArrayList a `compare` ArrayList b = a `compare` b + + + +mapArray :: + (NaturalT n, Storable a, Storable b) => (a -> b) -> (n :> a) -> (n :> b) + +mapArray f (ArrayList as) = ArrayList $ map f as + -- Couldn't use Functor because of the extra class constraints. + + + +-- | 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]] +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 type to a (zero- or higher-level) nested list. + toList :: a -> ListBased a + + -- | 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 + + -- | Converts a storable value to its untyped representation. + toData :: a -> StorableData + +instance Storable () + where + type ListBased () = () + type Element () = () + + replicateArray = id + toList = id + fromList = id + + toData a = PrimitiveData $ case a of + () -> UnitData + +instance Storable Bool + where + type ListBased Bool = Bool + type Element Bool = Bool + + replicateArray = id + toList = id + fromList = id + toData = PrimitiveData . BoolData + +instance Storable Int + where + type ListBased Int = Int + type Element Int = Int + + replicateArray = id + toList = id + fromList = id + toData = PrimitiveData . IntData + +instance Storable Float + where + type ListBased Float = Float + type Element Float = Float + + replicateArray = id + toList = id + fromList = id + toData = PrimitiveData . FloatData + +instance (NaturalT n, Storable a) => Storable (n :> a) + where + type ListBased (n :> a) = [ListBased a] + type Element (n :> a) = Element a + + replicateArray = ArrayList . replicate n . replicateArray + where + n = fromIntegerT (undefined :: n) + + toList (ArrayList as) = map toList as + + fromList as = ArrayList $ take n $ map fromList as + where + n = fromIntegerT (undefined :: n) + + toData (ArrayList a) = StorableData n $ map toData a + where + n = fromIntegerT (undefined :: n) + + + +isRectangular :: Storable a => a -> Bool +isRectangular = isJust . checkRect . toData + where + checkRect (PrimitiveData _) = return [] + checkRect (StorableData _ []) = return [] + checkRect (StorableData _ as) = do + dims <- mapM checkRect as + guard $ allEqual dims + return (length as : head dims) + + + +-- | 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 + +instance Typeable () + where + typeOf = const $ One $ StorableType [] UnitType + +instance Typeable Bool + where + typeOf = const $ One $ StorableType [] BoolType + +instance Typeable Int + where + typeOf = const $ One $ StorableType [] IntType + +instance Typeable Float + where + typeOf = const $ One $ StorableType [] FloatType + +instance (NaturalT n, Storable a) => Typeable (n :> a) + where + typeOf = const $ One $ StorableType (n:dim) t + where + n = fromIntegerT (undefined :: n) + One (StorableType dim t) = typeOf (T::T a) + +instance (Typeable a, Typeable b) => Typeable (a,b) + where + typeOf = const $ Tup [typeOf (T::T a), typeOf (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)] + +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) + ] + + + +-- | Checks if the given type is primitive. +isPrimitive :: Typeable a => T a -> Bool +isPrimitive a = case typeOf a of + One (StorableType [] _) -> True + _ -> False + diff --git a/Feldspar/Matrix.hs b/Feldspar/Matrix.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Matrix.hs @@ -0,0 +1,113 @@ +-- 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. + +-- | Operations on matrices (nested parallel vectors). All operations in this +-- module assume rectangular matrices. + +module Feldspar.Matrix where + + + +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 + + + +-- | Converts a matrix to a core array. +freezeMatrix :: (NaturalT m, NaturalT n, Storable a) => + Matrix m n a -> Data (m :> n :> 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 + +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 + +matrix as + | allEqual xs = unfreezeMatrix y x $ array as + | otherwise = error "matrix: Not rectangular" + where + y = value $ P.length as + xs = P.map P.length as + x = value $ P.head (xs P.++ [0]) + + + +-- | Transpose of a matrix +transpose :: Matrix m n a -> Matrix n m a +transpose a = Indexed (length $ head a) ixf + where + ixf y = Indexed (length a) (\x -> a ! x ! y) + +-- | Matrix multiplication +mul :: (Primitive a, Num a) => Matrix m n a -> Matrix n p a -> Matrix m p a +mul a b = map (\aRow -> map (scalarProd aRow) b') a + where + b' = transpose b + + + +-- | Concatenates the rows of a matrix. +flatten :: Matrix m n a -> VectorP (m :* n) a +flatten matr = Indexed (m*n) ixf + where + m = length matr + n = (m==0) ? (0, length (head matr)) + + ixf i = matr ! y ! x + where + y = i `div` m + x = i `mod` m + + + +-- | 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) + diff --git a/Feldspar/Prelude.hs b/Feldspar/Prelude.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Prelude.hs @@ -0,0 +1,58 @@ +-- 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. + +-- | Reexports the "Prelude", but hides all identifiers that are redefined in +-- the "Feldspar" library. + +module Feldspar.Prelude + ( module Prelude + ) where + + + +import Prelude hiding + ( (==), (/=) + , (<), (>), (<=), (>=) + , not, (&&), (||) + , min, max + , maximum, minimum + , length + , (++) + , splitAt + , take, drop + , dropWhile + , head, last, tail, init + , reverse + , replicate + , enumFromTo + , zip, unzip + , map + , zipWith + , sum + , (^) + , div, mod + ) + diff --git a/Feldspar/Utils.hs b/Feldspar/Utils.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Utils.hs @@ -0,0 +1,93 @@ +-- 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. + +-- | General utility functions + +module Feldspar.Utils where + + + +import Control.Monad.State +import Data.List +import Data.Map (Map) +import qualified Data.Map as Map + + + +-- | Checks if all elements in the list are equal. +allEqual :: Eq a => [a] -> Bool +allEqual [] = True +allEqual (a:as) = all (==a) as + +-- | @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 + + + +-- | A 'Map' lookup that treats undefined keys as mapping to empty lists. +(!!!) :: Ord a => Map a [b] -> a -> [b] +m !!! a = case Map.lookup a m of + Just as -> as + _ -> [] + +-- | Inverts a 'Map'. The argument map may have several keys mapping to the same +-- element, so the inverted map has a list of elements for each key. +invertMap :: (Ord a, Ord b) => Map a b -> Map b [a] +invertMap m = Map.fromListWith (++) [(b,[a]) | (a,b) <- Map.toList m] + + + +-- | Topological sort. Lists the nodes in the map such that each node appears +-- before its children. The function only terminates for acyclic maps. +topSort :: Ord a => Map a [a] -> [a] +topSort = reverse . evalState sorter + where + findLeaf a = do + dag <- get + let bs = [b | b <- dag Map.! a, Just _ <- [Map.lookup b dag]] + case bs of + [] -> modify (Map.delete a) >> return a + b:_ -> findLeaf b + + sorter = do + dag <- get + if Map.null dag + then return [] + else do + let (a,_) = Map.elemAt 0 dag + leaf <- findLeaf a + liftM (leaf:) sorter + + -- XXX It might be slightly inefficient to always restart findLeaf at the + -- first element (which can be considered a random node in the dag). It + -- would probably be better to restart at the parent of the last leaf. + + -- XXX QuickCheck? + diff --git a/Feldspar/Vector.hs b/Feldspar/Vector.hs new file mode 100644 --- /dev/null +++ b/Feldspar/Vector.hs @@ -0,0 +1,485 @@ +-- 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. + +-- | A high-level interface to the operations in the core language +-- ("Feldspar.Core"). Many of the functions defined here are imitations of +-- Haskell's list operations, and to a first approximation they behave +-- accordingly. + +module Feldspar.Vector where + + + +import qualified Prelude +import Control.Arrow ((***),(&&&)) +import Data.List (unfoldr) + +import Feldspar.Prelude +import Feldspar.Core.Types +import Feldspar.Core.Expr hiding (index) +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 + +type instance (:*) (Dec a) (Dec b) = Dec a :*: Dec b +type instance (:*) () () = () + + + +-- * 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 + + + +-- | 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) + +unfreezeVector sz arr = genericVector vec (toSeq vec) + where + vec = Indexed sz (getIx arr) + + + +-- | 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. + +vector as = unfreezeVector sz $ array as + where + sz = value $ Prelude.length as + + + +-- 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) + where + type Internal (t n :>> Data a) = (Int, n :> Internal (Data 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 + +instance + ( NaturalT n1 + , NaturalT n2 + , Storable a + , AccessPattern t1 + , AccessPattern t2 + ) => + Computable (t1 n1 :>> t2 n2 :>> Data a) + where + type Internal (t1 n1 :>> t2 n2 :>> Data a) = + (Int, n1 :> Int, n1 :> n2 :> Internal (Data a)) + + internalize vec = internalize + ( length vec + , freezeVector $ map length vec + , freezeVector $ map (freezeVector . map internalize) vec + ) + + externalize inp + = map (map externalize . uncurry unfreezeVector) + $ zip sz2sV (unfreezeVector sz1 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 + + + +-- * 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) + where + type Elem (Par n :>> 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)) + 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) + + + +dropWhile :: (a -> Data Bool) -> (t n :>> a) -> (t n :>> a) + +dropWhile cont vec@(Indexed _ _) = 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 n vec = (take n vec, drop n vec) + +head :: (t n :>> a) -> a +head = flip index 0 + +last :: (t n :>> a) -> a +last vec = index vec (length vec - 1) + +tail :: (t n :>> a) -> (t n :>> a) +tail = drop 1 + +init :: (t n :>> a) -> (t n :>> 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 + +-- | 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 + +permute :: (Data Size -> Data Ix -> Data Ix) -> ((Par n :>> a) -> (Par n :>> a)) +permute perm (Indexed sz ixf) = Indexed sz (ixf . perm sz) + +reverse :: (Par n :>> a) -> (Par n :>> a) +reverse = permute $ \sz i -> sz-1-i + +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 + +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 + + + +zip :: (t n :>> a) -> (t n :>> b) -> (t n :>> (a,b)) + +zip (Indexed sz1 ixf1) (Indexed sz2 ixf2) = + Indexed (min sz1 sz2) (ixf1 &&& ixf2) + +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 + + + +unzip :: (t n :>> (a,b)) -> (t n :>> a, t n :>> b) + +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) + + + +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 + + + +-- | 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 Haskell's @foldl1@. +fold1 :: Computable a => (a -> a -> a) -> (t n :>> a) -> a +fold1 f a = fold f (head a) a + + + +-- | 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')) + +scan f a (Unfold sz step s) = Unfold sz step' (s,a) + where + step' (s,a) = (a', (s',a')) + where + (b,s') = step s + a' = f a b + + + +-- | 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 = fold (+) 0 + +maximum :: Storable a => (t n :>> Data a) -> Data a +maximum = fold1 max + +minimum :: Storable a => (t n :>> 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 a b = sum (zipWith (*) a b) + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/feldspar-language.cabal b/feldspar-language.cabal new file mode 100644 --- /dev/null +++ b/feldspar-language.cabal @@ -0,0 +1,53 @@ +name: feldspar-language +version: 0.1 +synopsis: A functional embedded language for DSP and parallelism +description: Feldspar (Functional Embedded Language for DSP and PARallelism) + is an embedded DSL for describing digital signal processing + algorithms. This package contains the language front-end and an + interpreter. +category: Language +copyright: Copyright (c) 2009, ERICSSON AB +author: Functional programming group at Chalmers University of Technology +maintainer: Emil Axelsson +license: BSD3 +license-file: LICENSE +stability: experimental +homepage: http://feldspar.sourceforge.net/ +build-type: Simple +cabal-version: >= 1.2.3 +tested-with: GHC==6.10.* + +library + exposed-modules: + Feldspar.Prelude + Feldspar.Utils + Feldspar.Core.Types + Feldspar.Core.Haskell + Feldspar.Core.Graph + Feldspar.Core.Show + Feldspar.Core.Ref + Feldspar.Core.Expr + Feldspar.Core.Functions + Feldspar.Core + Feldspar.Vector + Feldspar.Matrix + Feldspar + + build-depends: base >= 3 && < 4, containers, directory, mtl, process, tfp + + extensions: + EmptyDataDecls + FlexibleInstances + FlexibleContexts + GADTs + MultiParamTypeClasses + NoMonomorphismRestriction + OverlappingInstances + PatternGuards + Rank2Types + ScopedTypeVariables + StandaloneDeriving + TypeFamilies + TypeOperators + TypeSynonymInstances + UndecidableInstances