packages feed

feldspar-language (empty) → 0.1

raw patch · 16 files changed

+3091/−0 lines, 16 filesdep +basedep +containersdep +directorysetup-changed

Dependencies added: base, containers, directory, mtl, process, tfp

Files

+ Feldspar.hs view
@@ -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+
+ Feldspar/Core.hs view
@@ -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+
+ Feldspar/Core/Expr.hs view
@@ -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+
+ Feldspar/Core/Functions.hs view
@@ -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)+
+ Feldspar/Core/Graph.hs view
@@ -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+
+ Feldspar/Core/Haskell.hs view
@@ -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]+
+ Feldspar/Core/Ref.hs view
@@ -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)+
+ Feldspar/Core/Show.hs view
@@ -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+
+ Feldspar/Core/Types.hs view
@@ -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+
+ Feldspar/Matrix.hs view
@@ -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)+
+ Feldspar/Prelude.hs view
@@ -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+  )+
+ Feldspar/Utils.hs view
@@ -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?+
+ Feldspar/Vector.hs view
@@ -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 = (<i) . snd+    body = ((snd . step) *** (+1))++instance RandomAccess (Par n :>> 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<sz1 ?+      ( let (a,s1'') = step1 s1' in (a, (n+1, (s1'', s2')))+      , let (a,s2'') = step2 s2' in (a, (n+1, (s1', s2'')))+      )++infixr 5 ++++++take :: Data Int -> (t n :>> a) -> (t n :>> a)++take n (Indexed sz ixf) = Indexed sz' ixf+  where+    sz' = min sz n++take n (Unfold sz step s) = Unfold sz' step s+  where+    sz' = min sz n++++drop :: Data Int -> (t n :>> a) -> (t n :>> a)++drop n (Indexed sz ixf) = Indexed sz' (\x -> ixf (x+n))+  where+    sz' = max 0 (sz-n)++drop n (Unfold sz step s) = Unfold sz' step s'+  where+    sz' = max 0 (sz-n)+    s'  = for 0 (n-1) s (\_ -> snd . step)++++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)+
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ feldspar-language.cabal view
@@ -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 <emax@chalmers.se>+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