feldspar-language 0.2 → 0.3

raw patch · 20 files changed

+2883/−730 lines, 20 filesdep +randomdep ~QuickCheckdep ~basesetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: random

Dependency ranges changed: QuickCheck, base

API changes (from Hackage documentation)

Files

• Feldspar.hs +16/−13
• Feldspar/Core.hs +26/−13
• Feldspar/Core/Expr.hs +199/−223
• Feldspar/Core/Functions.hs +565/−108
• Feldspar/Core/Graph.hs +80/−12
• Feldspar/Core/Ref.hs +33/−4
• Feldspar/Core/Reify.hs +47/−48
• Feldspar/Core/Show.hs +14/−12
• Feldspar/Core/Trace.hs +38/−0
• Feldspar/Core/Types.hs +126/−68
• Feldspar/FixedPoint.hs +577/−0
• Feldspar/Haskell.hs +14/−12
• Feldspar/Matrix.hs +133/−25
• Feldspar/Prelude.hs +20/−14
• Feldspar/Range.hs +470/−66
• Feldspar/Stream.hs +440/−0
• Feldspar/Utils.hs +14/−12
• Feldspar/Vector.hs +33/−95
• Setup.hs +28/−0
• feldspar-language.cabal +10/−5

@@ -1,9 +1,9 @@--- Copyright (c) 2009-2010, ERICSSON AB--- All rights reserved. --+-- Copyright (c) 2009-2010, ERICSSON AB All rights reserved.+--  -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are met:---+--  --     * Redistributions of source code must retain the above copyright notice, --       this list of conditions and the following disclaimer. --     * Redistributions in binary form must reproduce the above copyright@@ -12,17 +12,19 @@ --     * 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.+-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+-- ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS+-- BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY,+-- OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+-- SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+-- INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+-- CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+-- ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF+-- THE POSSIBILITY OF SUCH DAMAGE.+--  -- | Interface to the Feldspar language. @@ -31,6 +33,7 @@   , module Feldspar.Core   , module Feldspar.Vector   , module Feldspar.Matrix+  , module Feldspar.FixedPoint   ) where  @@ -43,4 +46,4 @@ import Feldspar.Core import Feldspar.Vector import Feldspar.Matrix-+import Feldspar.FixedPoint

@@ -1,9 +1,9 @@--- Copyright (c) 2009-2010, ERICSSON AB--- All rights reserved. --+-- Copyright (c) 2009-2010, ERICSSON AB All rights reserved.+--  -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are met:---+--  --     * Redistributions of source code must retain the above copyright notice, --       this list of conditions and the following disclaimer. --     * Redistributions in binary form must reproduce the above copyright@@ -12,17 +12,19 @@ --     * 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.+-- 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 of the core language @@ -31,6 +33,12 @@   , (:>) (..)   , Set (..)   , Length+  , Unsigned32+  , Signed32+  , Unsigned16+  , Signed16+  , Unsigned8+  , Signed8   , Storable   , Size   , Data@@ -46,10 +54,13 @@   , false   , size   , cap+  , function+  , function2+  , function3+  , function4   , getIx   , setIx   , RandomAccess (..)-  , Numeric   , noInline   , ifThenElse   , while@@ -60,6 +71,7 @@   , printCore   , printCoreWithSize   , module Feldspar.Core.Functions+  , trace   ) where  @@ -69,4 +81,5 @@ import Feldspar.Core.Expr import Feldspar.Core.Reify import Feldspar.Core.Functions+import Feldspar.Core.Trace 

@@ -1,9 +1,9 @@--- Copyright (c) 2009-2010, ERICSSON AB--- All rights reserved. --+-- Copyright (c) 2009-2010, ERICSSON AB All rights reserved.+--  -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are met:---+--  --     * Redistributions of source code must retain the above copyright notice, --       this list of conditions and the following disclaimer. --     * Redistributions in binary form must reproduce the above copyright@@ -12,17 +12,19 @@ --     * 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.+-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+-- ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS+-- BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY,+-- OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+-- SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+-- INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+-- CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+-- ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF+-- THE POSSIBILITY OF SUCH DAMAGE.+--  {-# LANGUAGE UndecidableInstances #-} @@ -33,6 +35,7 @@   +import Data.Function import Data.Monoid import Data.Unique @@ -46,32 +49,12 @@ -- representation of a program that computes a value of type @a@. data Expr a   where-    Input :: Size a -> Expr a-      -- XXX Risky to rely on observable sharing?--    Value :: Storable a => Size a -> a -> Expr a--    Tuple2 :: Data a -> Data b -> Expr (a,b)-    Tuple3 :: Data a -> Data b -> Data c -> Expr (a,b,c)-    Tuple4 :: Data a -> Data b -> Data c -> Data d -> Expr (a,b,c,d)-      -- XXX Tuple construction should be generalized.--    Get21 :: Data (a,b) -> Expr a-    Get22 :: Data (a,b) -> Expr b--    Get31 :: Data (a,b,c) -> Expr a-    Get32 :: Data (a,b,c) -> Expr b-    Get33 :: Data (a,b,c) -> Expr c--    Get41 :: Data (a,b,c,d) -> Expr a-    Get42 :: Data (a,b,c,d) -> Expr b-    Get43 :: Data (a,b,c,d) -> Expr c-    Get44 :: Data (a,b,c,d) -> Expr d-      -- XXX Tuple projection should be generalized.--    Function :: String -> Size b -> (a -> b) -> (Data a -> Expr b)--    NoInline :: String -> Ref (a :-> b) -> (Data a -> Expr b)+    Val         :: a -> Expr a  -- XXX Temporary, only used by evalF+    Variable    :: Expr a  -- XXX Risky to rely on obs. sharing for bound variables.+    Value       :: Storable a => a -> Expr a+    Function    :: String -> (a -> b) -> Expr (a -> b)+    Application :: Expr (a -> b) -> Data a -> Expr b+    NoInline    :: String -> Ref (a :-> b) -> (Data a -> Expr b)      IfThenElse       :: Data Bool           -- Condition@@ -93,103 +76,162 @@   -data a :-> b = SubFunction (Data a -> Data b) (Data a) (Data b)--- -- | A wrapper around 'Expr' to allow observable sharing (see -- "Feldspar.Core.Ref") and for memoizing size information.-data Data a = Typeable a => Data (Size a) (Ref (Expr a))+data Data a = Typeable a => Data+  { dataSize :: Size a+  , dataRef  :: Ref (Expr a)+  }  instance Eq (Data a)   where-    Data _ a == Data _ b = a==b-      -- Reference equality+    (==) = (==) `on` dataRef  instance Ord (Data a)   where-    Data _ a `compare` Data _ b = a `compare` b-      -- Reference comparison+    compare = compare `on` dataRef +data a :-> b = Typeable a =>  -- Typeable needed by evalF+    Lambda (Data a -> Data b) (Data a) (Data b)  -dataSize :: Data a -> Size a-dataSize (Data sz _) = sz  dataType :: forall a . Data a -> Tuple StorableType dataType a@(Data _ _) = typeOf (dataSize a) (T::T a)  dataId :: Data a -> Unique-dataId (Data _ r) = refId r+dataId = refId . dataRef  dataToExpr :: Data a -> Expr a-dataToExpr (Data _ r) = deref r+dataToExpr = deref . dataRef -subFunSize :: (a :-> b) -> Size b-subFunSize (SubFunction _ _ outp) = dataSize outp+{-# NOINLINE exprToData #-}+exprToData :: Typeable a => Size a -> Expr a -> Data a+exprToData sz a = Data sz (ref a) -subAp :: (a :-> b) -> (Data a -> Data b)-subAp (SubFunction f _ _) = f+{-# NOINLINE freshVar #-}+freshVar :: Typeable a => Size a -> Data a+freshVar sz = exprToData sz Variable -exprToData :: Typeable a => Expr a -> Data a-exprToData a = Data (exprSize a) (ref a)+{-# NOINLINE lambda #-}+lambda :: Typeable a => Size a -> (Data a -> Data b) -> (a :-> b)+lambda sz f = Lambda f var (f var)+  where+    var = freshVar sz+  -- XXX It's assumed that `f` is only going to be applied to an argument whose+  --     size is `sz`. +apply :: (a :-> b) -> Data a -> Data b+apply (Lambda f _ _) = f +resultSize :: (a :-> b) -> Size b+resultSize (Lambda _ _ outp) = dataSize outp -exprSize :: forall a . Typeable a => Expr a -> Size a -exprSize (Input sz)   = sz-exprSize (Value sz _) = sz -exprSize (Tuple2 a b)     = (dataSize a, dataSize b)-exprSize (Tuple3 a b c)   = (dataSize a, dataSize b, dataSize c)-exprSize (Tuple4 a b c d) = (dataSize a, dataSize b, dataSize c, dataSize d)+(|$|) :: Expr (a -> b) -> Data a -> Expr b+f |$| a = Application f a -exprSize (Get21 ab) = da+-- XXX Document these constructors. Currently, only _function is used for+-- ordinary functions. _function2 etc. are only used to construct tuples.+_function+    :: Typeable b+    => String -> (Size a -> Size b) -> (a -> b) -> (Data a -> Data b)+_function fun sizeProp f a = exprToData sz $ Function fun f |$| a   where-    (da,db) = dataSize ab+    sz = sizeProp (dataSize a) -exprSize (Get22 ab) = db+_function2+    :: Typeable c+    => String+    -> (Size a -> Size b -> Size c)+    -> (a -> b -> c)+    -> (Data a -> Data b -> Data c)+_function2 fun sizeProp f a b = exprToData sz $ Function fun f |$| a |$| b   where-    (da,db) = dataSize ab+    sz = sizeProp (dataSize a) (dataSize b) -exprSize (Get31 abc) = da+_function3+    :: Typeable d+    => String -> (Size a -> Size b -> Size c -> Size d)+    -> (a -> b -> c -> d)+    -> (Data a -> Data b -> Data c -> Data d)+_function3 fun sizeProp f a b c =+    exprToData sz $ Function fun f |$| a |$| b |$| c   where-    (da,db,dc) = dataSize abc+    sz = sizeProp (dataSize a) (dataSize b) (dataSize c) -exprSize (Get32 abc) = db+_function4+    :: Typeable e+    => String+    -> (Size a -> Size b -> Size c -> Size d -> Size e)+    -> (a -> b -> c -> d -> e)+    -> (Data a -> Data b -> Data c -> Data d -> Data e)+_function4 fun sizeProp f a b c d =+    exprToData sz $ Function fun f |$| a |$| b |$| c |$| d   where-    (da,db,dc) = dataSize abc+    sz = sizeProp (dataSize a) (dataSize b) (dataSize c) (dataSize d) -exprSize (Get33 abc) = dc+++tup2 :: (Typeable a, Typeable b) => Data a -> Data b -> Data (a,b)+tup2 = _function2 "tup2" (,) (,)++tup3 :: (Typeable a, Typeable b, Typeable c) =>+    Data a -> Data b -> Data c -> Data (a,b,c)+tup3 = _function3 "tup3" (,,) (,,)++tup4 :: (Typeable a, Typeable b, Typeable c, Typeable d) =>+    Data a -> Data b -> Data c -> Data d -> Data (a,b,c,d)+tup4 = _function4 "tup4" (,,,) (,,,)++get21 :: Typeable a => Data (a,b) -> Data a+get21 = _function "getTup21" get get   where-    (da,db,dc) = dataSize abc+    get (a,b) = a -exprSize (Get41 abcd) = da+get22 :: Typeable b => Data (a,b) -> Data b+get22 = _function "getTup22" get get   where-    (da,db,dc,dd) = dataSize abcd+    get (a,b) = b -exprSize (Get42 abcd) = db+get31 :: Typeable a => Data (a,b,c) -> Data a+get31 = _function "getTup31" get get   where-    (da,db,dc,dd) = dataSize abcd+    get (a,b,c) = a -exprSize (Get43 abcd) = dc+get32 :: Typeable b => Data (a,b,c) -> Data b+get32 = _function "getTup32" get get   where-    (da,db,dc,dd) = dataSize abcd+    get (a,b,c) = b -exprSize (Get44 abcd) = dd+get33 :: Typeable c => Data (a,b,c) -> Data c+get33 = _function "getTup33" get get   where-    (da,db,dc,dd) = dataSize abcd+    get (a,b,c) = c -exprSize (Function _ sz _ _)  = sz-exprSize (NoInline _ f a)     = subFunSize (deref f)-exprSize (IfThenElse _ t e a) = subFunSize t `mappend` subFunSize e-exprSize (While _ b i)        = dataSize i   `mappend` subFunSize b-exprSize (Parallel l ixf)     = mapMonotonic fromIntegral (dataSize l)-                                :> subFunSize ixf+get41 :: Typeable a => Data (a,b,c,d) -> Data a+get41 = _function "getTup41" get get+  where+    get (a,b,c,d) = a +get42 :: Typeable b => Data (a,b,c,d) -> Data b+get42 = _function "getTup42" get get+  where+    get (a,b,c,d) = b +get43 :: Typeable c => Data (a,b,c,d) -> Data c+get43 = _function "getTup43" get get+  where+    get (a,b,c,d) = c +get44 :: Typeable d => Data (a,b,c,d) -> Data d+get44 = _function "getTup44" get get+  where+    get (a,b,c,d) = d+++ -- | Computable types. A computable value completely represents a core program, -- in such a way that @`internalize` `.` `externalize`@ preserves semantics, but -- not necessarily syntax.@@ -219,26 +261,26 @@   where     type Internal (a,b) = (Internal a, Internal b) -    internalize (a,b) = exprToData $ Tuple2 (internalize a) (internalize b)+    internalize (a,b) = tup2 (internalize a) (internalize b)      externalize ab =-        ( externalizeE $ Get21 ab-        , externalizeE $ Get22 ab+        ( externalize (get21 ab)+        , externalize (get22 ab)         )  instance (Computable a, Computable b, Computable c) => Computable (a,b,c)   where     type Internal (a,b,c) = (Internal a, Internal b, Internal c) -    internalize (a,b,c) = exprToData $ Tuple3+    internalize (a,b,c) = tup3       (internalize a)       (internalize b)       (internalize c)      externalize abc =-        ( externalizeE $ Get31 abc-        , externalizeE $ Get32 abc-        , externalizeE $ Get33 abc+        ( externalize (get31 abc)+        , externalize (get32 abc)+        , externalize (get33 abc)         )  instance@@ -251,24 +293,21 @@   where     type Internal (a,b,c,d) = (Internal a, Internal b, Internal c, Internal d) -    internalize (a,b,c,d) = exprToData $ Tuple4+    internalize (a,b,c,d) = tup4       (internalize a)       (internalize b)       (internalize c)       (internalize d)      externalize abcd =-        ( externalizeE $ Get41 abcd-        , externalizeE $ Get42 abcd-        , externalizeE $ Get43 abcd-        , externalizeE $ Get44 abcd+        ( externalize (get41 abcd)+        , externalize (get42 abcd)+        , externalize (get43 abcd)+        , externalize (get44 abcd)         )   -externalizeE :: Computable a => Expr (Internal a) -> a-externalizeE = externalize . exprToData- -- | Lower a function to operate on internal representation. lowerFun :: (Computable a, Computable b) =>     (a -> b) -> (Data (Internal a) -> Data (Internal b))@@ -284,66 +323,21 @@ -- | 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 (Get21 ab) = a-  where-    (a,b) = evalD ab--evalE (Get22 ab) = b-  where-    (a,b) = evalD ab--evalE (Get31 abc) = a-  where-    (a,b,c) = evalD abc--evalE (Get32 abc) = b-  where-    (a,b,c) = evalD abc--evalE (Get33 abc) = c-  where-    (a,b,c) = evalD abc--evalE (Get41 abcd) = a-  where-    (a,b,c,d) = evalD abcd--evalE (Get42 abcd) = b-  where-    (a,b,c,d) = evalD abcd--evalE (Get43 abcd) = c-  where-    (a,b,c,d) = evalD abcd--evalE (Get44 abcd) = d-  where-    (a,b,c,d) = evalD abcd+evalE (Val a)           = a+evalE Variable          = error "evaluating free variable"+evalE (Value a)         = a+evalE (Function _ f)    = f+evalE (Application f a) = evalE f (evalD a)+evalE (NoInline _ f a)  = evalD (apply (deref f) a) -evalE (Function _ _ f a)   = f (evalD a)-evalE (NoInline _ f a)     = evalD $ subAp (deref f) a-evalE (IfThenElse c t e a) = if evalD c-    then evalD (subAp t a)-    else evalD (subAp e a)+evalE (IfThenElse c t e a)+    | evalD c   = evalD (apply t a)+    | otherwise = evalD (apply e a) -evalE (While continue body init) = loop init-  where-    loop s = if done-        then evalD s-        else loop (subAp body s)-      where-        done = not $ evalD $ subAp continue s+evalE (While cont body init) =+    head $ dropWhile (evalF cont) $ iterate (evalF body) $ evalD init -evalE (Parallel l ixf) = map (evalD . subAp ixf . value) [0 .. n-1]-  where-    n = evalD l+evalE (Parallel l ixf) = map (evalF ixf) [0 .. evalD l-1]   @@ -351,6 +345,9 @@ evalD :: Data a -> a evalD = evalE . dataToExpr +evalF :: (a :-> b) -> (a -> b)+evalF (Lambda f i o) = evalD . f . exprToData (dataSize i) . Val+ -- | The semantics of any 'Computable' type eval :: Computable a => a -> Internal a eval = evalD . internalize@@ -359,7 +356,7 @@  -- | A program that computes a constant value value :: Storable a => a -> Data a-value a = exprToData (Value (storableSize a) a)+value a = exprToData (storableSize a) (Value a)  -- | Like 'value' but with an extra 'Size' argument that can be used to increase -- the size beyond the given data.@@ -376,7 +373,7 @@ -- -- gives a 10x20 array whose first row is initialized to @[1,2,3]@. array :: Storable a => Size a -> a -> Data a-array sz a = exprToData $ Value (sz `mappend` storableSize a) a+array sz a = exprToData (sz `mappend` storableSize a) (Value a)  arrayLen :: Storable a => Data Length -> [a] -> Data [a] arrayLen len = array sz@@ -419,10 +416,10 @@     => String -> (Size a -> Size b) -> (a -> b) -> (Data a -> Data b)  function fun sizeProp f a = case dataToExpr a of-    Value _ a' -> Data s (ref $ Value s $ f a')-    _          -> exprToData $ Function fun s f a+    Value a' -> exprToData sz $ Value (f a')+    _        -> _function fun sizeProp f a   where-    s = sizeProp (dataSize a)+    sz = sizeProp (dataSize a)   @@ -438,11 +435,12 @@     -> (Data a -> Data b -> Data c)  function2 fun sizeProp f a b = case (dataToExpr a, dataToExpr b) of-    (Value _ a', Value _ b') -> Data s (ref $ Value s $ f a' b')-    _ -> exprToData $ Function fun s f' $ exprToData $ Tuple2 a b+    (Value a', Value b') -> exprToData sz $ Value (f a' b')+    _ -> _function fun (uncurry sizeProp) (uncurry f) (tup2 a b)+    -- XXX Should perhaps look like this instead:+    -- _ -> _function2 fun sizeProp f a b   where-    s = sizeProp (dataSize a) (dataSize b)-    f' (a,b) = f a b+    sz = sizeProp (dataSize a) (dataSize b)   @@ -459,12 +457,12 @@     -> (Data a -> Data b -> Data c -> Data d)  function3 fun sizeProp f a b c = case (d2e a, d2e b, d2e c) of-    (Value _ a', Value _ b', Value _ c') -> Data s (ref $ Value s $ f a' b' c')-    _ -> exprToData $ Function fun s f' $ exprToData $ Tuple3 a b c+    (Value a', Value b', Value c') -> exprToData sz $ Value (f a' b' c')+    _ -> _function fun (uncurr sizeProp) (uncurr f) (tup3 a b c)   where     d2e = dataToExpr-    s = sizeProp (dataSize a) (dataSize b) (dataSize c)-    f' (a,b,c) = f a b c+    sz  = sizeProp (dataSize a) (dataSize b) (dataSize c)+    uncurr g (a,b,c) = g a b c   @@ -482,34 +480,12 @@     -> (Data a -> Data b -> Data c -> Data d -> Data e)  function4 fun sizeProp f a b c d = case (d2e a, d2e b, d2e c, d2e d) of-    (Value _ a', Value _ b', Value _ c', Value _ d') -> Data s (ref $ Value s $ f a' b' c' d')-    _ -> exprToData $ Function fun s f' $ exprToData $ Tuple4 a b c d+    (Value a', Value b', Value c', Value d') -> exprToData sz $ Value (f a' b' c' d')+    _ -> _function fun (uncurr sizeProp) (uncurr f) (tup4 a b c d)   where     d2e = dataToExpr-    s = sizeProp (dataSize a) (dataSize b) (dataSize c) (dataSize d)-    f' (a,b,c,d) = f a b c d----instance Show (Data a)-  where-    show _ = "... :: Data a"-  -- Needed for the 'Num' instance.--instance Numeric a => Num (Data a)-  where-    fromInteger = value . fromInteger-    abs         = function  "abs"    abs    abs-    signum      = function  "signum" signum signum-    (+)         = function2 "(+)"    (+)    (+)-    (-)         = function2 "(-)"    (-)    (-)-    (*)         = function2 "(*)"    (*)    (*)--instance Fractional (Data Float)-  where-    fromRational = value . fromRational-    (/)          = function2 "(/)" (\_ _ -> fullRange) (/)  -- XXX Improve range-+    sz  = sizeProp (dataSize a) (dataSize b) (dataSize c) (dataSize d)+    uncurr g (a,b,c,d) = g a b c d   -- | Look up an index in an array (see also '!')@@ -523,9 +499,9 @@         | i >= la             = error "getIx: reading garbage"         | otherwise           = as !! i       where-        l :> _ = dataSize arr-        r      = rangeByRange 0 (l-1)-        la     = length as+        l:>_ = dataSize arr+        r    = rangeByRange 0 (l-1)+        la   = length as   @@ -546,6 +522,8 @@         r    = rangeByRange 0 (l-1)         la   = length as ++ infixl 9 !  class RandomAccess a@@ -563,12 +541,6 @@   -mkSubFun :: Typeable a => Size a -> (Data a -> Data b) -> (a :-> b)-mkSubFun sz f = SubFunction f inp (f inp)-  where-    inp = exprToData $ Input sz-- -- | Constructs a non-primitive, non-inlined function. -- -- The normal way to make a non-primitive function is to use an ordinary Haskell@@ -584,9 +556,10 @@ -- 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 f a = liftFun (exprToData . NoInline fun (ref subFun)) a+noInline fun f a = liftFun (exprToData sz . NoInline fun (ref fLam)) a   where-    subFun = mkSubFun (dataSize $ internalize a) (lowerFun f)+    fLam = lambda (dataSize $ internalize a) (lowerFun f)+    sz   = resultSize fLam   @@ -599,29 +572,31 @@     => Data Bool -> (a -> b) -> (a -> b) -> (a -> b)  ifThenElse cond t e a = case dataToExpr cond of-    Value _ True       -> t a-    Value _ False      -> e a---     Function "not" _ c -> ifThenElse c e t--- XXX Not possible...-    _ -> liftFun (exprToData . IfThenElse cond thenSub elseSub) a+    Value True  -> t a+    Value False -> e a+    _           -> liftFun (exprToData szb . IfThenElse cond thenLam elseLam) a   where-    sz      = dataSize $ internalize a-    thenSub = mkSubFun sz $ lowerFun t-    elseSub = mkSubFun sz $ lowerFun e+    sza     = dataSize $ internalize a+    thenLam = lambda sza (lowerFun t)+    elseLam = lambda sza (lowerFun e)+    szb     = resultSize thenLam `mappend` resultSize elseLam    whileSized     :: Computable state     => Size (Internal state)+    -> Size (Internal state)     -> (state -> Data Bool)     -> (state -> state)     -> (state -> state) -whileSized sz cont body init = liftFun (exprToData . While contSub bodySub) init+whileSized szInitCont szInitBody cont body =+    liftFun (exprToData szFinal . While contLam bodyLam)   where-    contSub = mkSubFun sz $ lowerFun cont-    bodySub = mkSubFun sz $ lowerFun body+    contLam = lambda szInitCont (lowerFun cont)+    bodyLam = lambda szInitBody (lowerFun body)+    szFinal = universal  -- XXX The best we can do at the moment...   @@ -642,7 +617,7 @@     -> (state -> state)     -> (state -> state) -while = whileSized universal+while = whileSized universal universal   @@ -658,8 +633,9 @@ -- Since there are no dependencies between the elements, the compiler is free to -- compute the elements in any order, or even in parallel. parallel :: Storable a => Data Length -> (Data Int -> Data a) -> Data [a]-parallel l ixf = exprToData $ Parallel l ixfSub+parallel l ixf = exprToData szPar $ Parallel l ixfLam   where     szl    = dataSize l-    ixfSub = mkSubFun (rangeByRange 0 (szl-1)) ixf+    ixfLam = lambda (rangeByRange 0 (szl-1)) ixf+    szPar  = mapMonotonic fromIntegral szl :> resultSize ixfLam 

@@ -1,9 +1,9 @@--- Copyright (c) 2009-2010, ERICSSON AB--- All rights reserved. --+-- Copyright (c) 2009-2010, ERICSSON AB All rights reserved.+--  -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are met:---+--  --     * Redistributions of source code must retain the above copyright notice, --       this list of conditions and the following disclaimer. --     * Redistributions in binary form must reproduce the above copyright@@ -12,18 +12,22 @@ --     * 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.+-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+-- ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS+-- BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY,+-- OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+-- SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+-- INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+-- CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+-- ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF+-- THE POSSIBILITY OF SUCH DAMAGE.+-- +{-# LANGUAGE UndecidableInstances #-}+ -- | Primitive and helper functions supported by Feldspar  module Feldspar.Core.Functions where@@ -35,17 +39,22 @@ import Feldspar.Range import Feldspar.Core.Types import Feldspar.Core.Expr+import Feldspar.Core.Reify import Feldspar.Prelude  import qualified Data.Bits as B -infix 4 ==-infix 4 /=-infix 4 <-infix 4 >-infix 4 <=-infix 4 >=-infix 1 ?+infix  4 ==+infix  4 /=+infix  4 <+infix  4 >+infix  4 <=+infix  4 >=+infixr 3 &&+infixr 3 &&*+infixr 2 ||+infixr 2 ||*+infix  1 ?   @@ -57,66 +66,226 @@ noSizeProp2 :: a -> b -> () noSizeProp2 _ _ = () +class (Prelude.Eq a, Storable a) => Eq a where+  (==) :: Data a -> Data a -> Data Bool+  a == b+    | a Prelude.== b = true+    | otherwise      = function2 "(==)" noSizeProp2 (Prelude.==) a b+  (/=) :: Data a -> Data a -> Data Bool+  a /= b+    | a Prelude.== b = false+    | otherwise      = function2 "(/=)" noSizeProp2 (Prelude./=) a b +optEq :: (Storable a, Size a ~ Range b, Prelude.Ord b, Num b) =>+         Data a -> Data a -> Data Bool+optEq a b+    | a Prelude.== b   = true+    | sa `disjoint` sb = false+    | otherwise        = function2 "(==)" noSizeProp2 (Prelude.==) a b+   where+     sa = dataSize a+     sb = dataSize b -(==) :: Storable a => Data a -> Data a -> Data Bool-a == b-  | a Prelude.== b = true-  | otherwise      = function2 "(==)" noSizeProp2 (Prelude.==) a b-  -- XXX Partial evaluation+optNeq :: (Storable a, Size a ~ Range b, Prelude.Ord b, Num b) =>+         Data a -> Data a -> Data Bool+optNeq a b+    | a Prelude.== b   = false+    | sa `disjoint` sb = true+    | otherwise        = function2 "(/=)" noSizeProp2 (Prelude./=) a b+   where+     sa = dataSize a+     sb = dataSize b -(/=) :: Storable a => Data a -> Data a -> Data Bool-a /= b-  | a Prelude.== b = false-  | otherwise      = function2 "(/=)" noSizeProp2 (Prelude./=) a b-  -- XXX Partial evaluation+instance Eq Int where+  a == b = optEq  a b+  a /= b = optNeq a b -(<) :: Storable a => Data a -> Data a -> Data Bool-a < b-  | a Prelude.== b = false-  | otherwise      = function2 "(<)" noSizeProp2 (Prelude.<) a b+instance Eq Signed32 where+  a == b = optEq  a b+  a /= b = optNeq a b -(>) :: Storable a => Data a -> Data a -> Data Bool-a > b-  | a Prelude.== b = false-  | otherwise      = function2 "(>)" noSizeProp2 (Prelude.>) a b+instance Eq Unsigned32 where+  a == b = optEq  a b+  a /= b = optNeq a b -(<<<) :: Data Int -> Data Int -> Data Bool-a <<< b-  | a Prelude.== b      = false-  | sa `rangeLess`   sb = true-  | sb `rangeLessEq` sa = false-  | otherwise           = function2 "(<)" noSizeProp2 (Prelude.<) a b+instance Eq Signed16 where+  a == b = optEq  a b+  a /= b = optNeq a b++instance Eq Unsigned16 where+  a == b = optEq  a b+  a /= b = optNeq a b++instance Eq Signed8 where+  a == b = optEq  a b+  a /= b = optNeq a b++instance Eq Unsigned8 where+  a == b = optEq  a b+  a /= b = optNeq a b++instance Eq Float where+  a == b = optEq  a b+  a /= b = optNeq a b++instance Eq Bool++instance Eq ()++class (Prelude.Ord a, Eq a, Storable a) => Ord a where+  (<)  :: Data a -> Data a -> Data Bool+  a < b+    | a Prelude.== b = false+    | otherwise      = function2 "(<)" noSizeProp2 (Prelude.<) a b+  (>)  :: Data a -> Data a -> Data Bool+  a > b+    | a Prelude.== b = false+    | otherwise      = function2 "(>)" noSizeProp2 (Prelude.>) a b+  (<=) :: Data a -> Data a -> Data Bool+  a <= b+    | a Prelude.== b = true+    | otherwise      = function2 "(<=)" noSizeProp2 (Prelude.<=) a b+  (>=) :: Data a -> Data a -> Data Bool+  a >= b+    | a Prelude.== b = true+    | otherwise      = function2 "(>=)" noSizeProp2 (Prelude.>=) a b+  min  ::  Data a -> Data a -> Data a+  min a b = a<b ? (a,b)+  max  :: Data a -> Data a -> Data a+  max a b = a>b ? (a,b)++optLT :: (Storable a, Prelude.Ord a, Size a ~ Range b, Prelude.Ord b, Num b) =>+         Data a -> Data a -> Data Bool+optLT a b+    | a Prelude.== b      = false+    | sa `rangeLess`   sb = true+    | sb `rangeLessEq` sa = false+    | otherwise           = function2 "(<)" noSizeProp2 (Prelude.<) a b+    where+      sa = dataSize a+      sb = dataSize b++optGT :: (Storable a, Prelude.Ord a, Size a ~ Range b, Prelude.Ord b, Num b) =>+         Data a -> Data a -> Data Bool+optGT a b+    | a Prelude.== b      = false+    | sb `rangeLess`   sa = true+    | sa `rangeLessEq` sb = false+    | otherwise           = function2 "(>)" noSizeProp2 (Prelude.>) a b+    where+      sa = dataSize a+      sb = dataSize b++optLTE :: (Storable a, Prelude.Ord a, Size a ~ Range b, Prelude.Ord b, Num b) =>+         Data a -> Data a -> Data Bool+optLTE a b+    | a Prelude.== b      = true+    | sa `rangeLessEq` sb = true+    | sb `rangeLess`   sa = false+    | otherwise           = function2 "(<=)" noSizeProp2 (Prelude.<=) a b+    where+      sa = dataSize a+      sb = dataSize b++optGTE :: (Storable a, Prelude.Ord a, Size a ~ Range b, Prelude.Ord b, Num b) =>+         Data a -> Data a -> Data Bool+optGTE a b+    | a Prelude.== b      = true+    | sb `rangeLessEq` sa = true+    | sa `rangeLess`   sb = false+    | otherwise           = function2 "(>=)" noSizeProp2 (Prelude.>=) a b+    where+      sa = dataSize a+      sb = dataSize b++optMin :: (Ord a, Size a ~ Range b, Prelude.Ord b, Num b) =>+          Data a -> Data a -> Data a+optMin a b = cap (rangeMin ra rb) $+    case dataToExpr cond1 of+      Value _ -> cond1 ? (a,b)+      _       -> cond2 ? (b,a)   where-    sa = dataSize a-    sb = dataSize b-  -- XXX Enables more partial evaluation than (<). This function should be-  --     generalized and then replace (<).+    cond1 = a<b+    cond2 = b<a+    ra    = dataSize a+    rb    = dataSize b -(>>>) :: Data Int -> Data Int -> Data Bool-a >>> b-  | a Prelude.== b      = false-  | sb `rangeLess`   sa = true-  | sa `rangeLessEq` sb = false-  | otherwise           = function2 "(>)" noSizeProp2 (Prelude.>) a b+optMax :: (Ord a, Size a ~ Range b, Prelude.Ord b, Num b) =>+          Data a -> Data a -> Data a+optMax a b = cap (rangeMax ra rb) $+    case dataToExpr cond1 of+      Value _ -> cond1 ? (a,b)+      _       -> cond2 ? (b,a)   where-    sa = dataSize a-    sb = dataSize b-  -- XXX Enables more partial evaluation than (>). This function should be-  --     generalized and then replace (>).+    cond1 = a>b+    cond2 = b>a+    ra    = dataSize a+    rb    = dataSize b -(<=) :: Storable a => Data a -> Data a -> Data Bool-a <= b-  | a Prelude.== b = true-  | otherwise      = function2 "(<=)" noSizeProp2 (Prelude.<=) a b-  -- XXX Partial evaluation+instance Ord Int where+  a <  b  = optLT  a b+  a >  b  = optGT  a b+  a <= b  = optLTE a b+  a >= b  = optGTE a b+  min a b = optMin a b+  max a b = optMax a b -(>=) :: Storable a => Data a -> Data a -> Data Bool-a >= b-  | a Prelude.== b = true-  | otherwise      = function2 "(>=)" noSizeProp2 (Prelude.>=) a b-  -- XXX Partial evaluation+instance Ord Unsigned32 where+  a <  b  = optLT  a b+  a >  b  = optGT  a b+  a <= b  = optLTE a b+  a >= b  = optGTE a b+  min a b = optMin a b+  max a b = optMax a b +instance Ord Signed32 where+  a <  b  = optLT  a b+  a >  b  = optGT  a b+  a <= b  = optLTE a b+  a >= b  = optGTE a b+  min a b = optMin a b+  max a b = optMax a b++instance Ord Unsigned16 where+  a <  b  = optLT  a b+  a >  b  = optGT  a b+  a <= b  = optLTE a b+  a >= b  = optGTE a b+  min a b = optMin a b+  max a b = optMax a b++instance Ord Signed16 where+  a <  b  = optLT  a b+  a >  b  = optGT  a b+  a <= b  = optLTE a b+  a >= b  = optGTE a b+  min a b = optMin a b+  max a b = optMax a b++instance Ord Unsigned8 where+  a <  b  = optLT  a b+  a >  b  = optGT  a b+  a <= b  = optLTE a b+  a >= b  = optGTE a b+  min a b = optMin a b+  max a b = optMax a b++instance Ord Signed8 where+  a <  b  = optLT  a b+  a >  b  = optGT  a b+  a <= b  = optLTE a b+  a >= b  = optGTE a b+  min a b = optMin a b+  max a b = optMax a b++instance Ord Float where+  a <  b  = optLT  a b+  a >  b  = optGT  a b+  a <= b  = optLTE a b+  a >= b  = optGTE a b+  min a b = optMin a b+  max a b = optMax a b+ not :: Data Bool -> Data Bool not = function "not" noSizeProp Prelude.not @@ -125,10 +294,20 @@ cond ? (a,b) = ifThenElse cond (const a) (const b) unit  (&&) :: Data Bool -> Data Bool -> Data Bool-(&&) = function2 "(&&)" noSizeProp2 (Prelude.&&)+x && y = case (dataToExpr x, dataToExpr y) of+           (Value True, _) -> y+           (Value False,_) -> false+           (_, Value True) -> x+           (_,Value False) -> false+           _               -> function2 "(&&)" noSizeProp2 (Prelude.&&) x y  (||) :: Data Bool -> Data Bool -> Data Bool-(||) = function2 "(||)" noSizeProp2 (Prelude.||)+x || y = case (dataToExpr x, dataToExpr y) of+           (Value True, _) -> true+           (Value False,_) -> y+           (_, Value True) -> true+           (_,Value False) -> y+           _               -> function2 "(||)" noSizeProp2 (Prelude.||) x y  -- | Lazy conjunction, second argument only run if necessary (&&*) :: Computable a =>@@ -140,43 +319,100 @@     (a -> Data Bool) -> (a -> Data Bool) -> (a -> Data Bool) (f ||* g) a = ifThenElse (f a) (const true) g a -min :: Storable a => Data a -> Data a -> Data a-min a b = a<b ? (a,b)+class (Numeric a, Prelude.Integral a, Ord a, Storable a) =>+    Integral a where+  quot    :: Data a -> Data a -> Data a+  quot    = function2 "quot" (\_ _ -> universal) Prelude.quot+  rem     :: Data a -> Data a -> Data a+  rem     = function2 "rem"  (\_ _ -> universal) Prelude.rem+  div     :: Data a -> Data a -> Data a+  div x y = rem x y /= 0 && (x > 0 && y < 0 || x < 0 && y > 0) ?+            (quotxy - 1, quotxy)+      where quotxy = quot x y+  mod     :: Data a -> Data a -> Data a+  mod x y = remxy  /= 0 && (x > 0 && y < 0 || x < 0 && y > 0) ?+            (remxy + y, remxy)+      where remxy = rem x y+  (^)     :: Data a -> Data a -> Data a+  (^)     = function2 "(^)" (\_ _ -> universal) (Prelude.^) -max :: Storable a => Data a -> Data a -> Data a-max a b = a>b ? (a,b)+optRem  :: (Integral a, Size a ~ Range b, Prelude.Ord b, Num b, Enum b) =>+           Data a -> Data a -> Data a+optRem x y+    | abs rx `rangeLess` abs ry = x+    | otherwise                 = function2 "rem"  rangeRem  Prelude.rem x y+    where rx = dataSize x+          ry = dataSize y -minX :: Data Int -> Data Int -> Data Int-minX a b = case dataToExpr cond1 of-    Value _ _ -> cond1 ? (a,b)-    _         -> cond2 ? (b,a)-  where-    cond1 = a<<<b-    cond2 = b<<<a-  -- XXX Enables more partial evaluation than min. This function should be-  --     generalized and then replace min.+optMod :: (Integral a, Size a ~ Range b, Prelude.Ord b, Num b, Enum b) =>+       Data a -> Data a -> Data a+optMod x y = cap (rangeMod rx ry) $+             remxy  /= 0 && (x > 0 && y < 0 || x < 0 && y > 0) ?+             (remxy + y, remxy)+  where remxy = rem x y+        rx    = dataSize x+        ry    = dataSize y -maxX :: Data Int -> Data Int -> Data Int-maxX a b = case dataToExpr cond1 of-    Value _ _ -> cond1 ? (a,b)-    _         -> cond2 ? (b,a)-  where-    cond1 = a>>>b-    cond2 = b>>>a-  -- XXX Enables more partial evaluation than max. This function should be-  --     generalized and then replace max.+optSignedExp :: (Integral a, Bits a, Storable a,+                Size a ~ Range b, Prelude.Ord b, Num b) =>+                Data a -> Data a -> Data a+optSignedExp m e = case dataToExpr m of+                   -- From Bit Twiddling Hacks+                   -- "Conditionally negate a value without branching"+                   -- Here we negate the value 1 if isOdd is true i.e. when e is+                   -- and odd number+                     Value (-1) -> cap (range (-1) 1) $+                                   let isOdd = e .&. 1+                                   in (1 `xor` (negate isOdd)) + isOdd+                     _ -> optExp m e -div :: Data Int -> Data Int -> Data Int-div = function2 "div" (\_ _ -> fullRange) Prelude.div  -- XXX Improve size propagation+optExp :: (Integral a, Storable a) => Data a -> Data a -> Data a+optExp m e = case (dataToExpr m,dataToExpr e) of+               (Value 1,_) -> value 1+               (_,Value 1) -> m+               (_,Value 0) -> value 1+               _           -> function2 "(^)" (\_ _ -> universal) (Prelude.^) m e -mod :: Data Int -> Data Int -> Data Int-mod = function2 "mod" (\_ _ -> fullRange) Prelude.mod  -- XXX Improve size propagation+instance Integral Int where+  rem = optRem+  mod = optMod+  (^) = optSignedExp -(^) :: Data Int -> Data Int -> Data Int-(^) = function2 "(^)" (\_ _ -> fullRange) (Prelude.^)  -- XXX Improve size propagation+instance Integral Signed32 where+  rem = optRem+  mod = optMod+  (^) = optSignedExp +instance Integral Unsigned32 where+  div = quot+  rem = optRem+  mod = rem+  (^) = optExp +instance Integral Signed16 where+  rem = optRem+  mod = optMod+  (^) = optSignedExp +instance Integral Unsigned16 where+  div = quot+  rem = optRem+  mod = rem+  (^) = optExp++instance Integral Signed8 where+  rem = optRem+  mod = optMod+  (^) = optSignedExp++instance Integral Unsigned8 where+  div = quot+  rem = optRem+  mod = rem+  (^) = optExp+++ -- * Loops  -- | For-loop@@ -190,11 +426,14 @@ --   * @body@ computes the next state given the current loop index (ranging over --     @[start .. end]@) and the current state. for :: Computable a => Data Int -> Data Int -> a -> (Data Int -> a -> a) -> a-for start end init body = snd $ whileSized sz cont body' (start,init)+for start end init body = snd $ whileSized szCont szBody cont body' (start,init)   where-    szi = rangeByRange (dataSize start) (dataSize end)-    sz  = (szi,universal)+    sziCont = rangeByRange (dataSize start) (dataSize end + 1)+    szCont  = (sziCont,universal) +    sziBody = rangeByRange (dataSize start) (dataSize end)+    szBody  = (sziBody,universal)+     cont  (i,s) = i <= end     body' (i,s) = (i+1, body i s) @@ -224,7 +463,144 @@   where     outp = array (mapMonotonic fromIntegral (dataSize l) :> universal) [] +class (Num a, Storable a) => Numeric a+  where+    fromIntegerNum :: Integer -> Data a+    fromIntegerNum = value . fromInteger +    absNum    :: Data a -> Data a+    signumNum :: Data a -> Data a+    addNum    :: Data a -> Data a -> Data a+    subNum    :: Data a -> Data a -> Data a+    mulNum    :: Data a -> Data a -> Data a++absNum' :: (Numeric a, Num (Size a)) => Data a -> Data a+absNum' = function "abs" abs abs++optAbs :: (Numeric a, Size a ~ Range b, Num b, Prelude.Ord b) =>+          Data a -> Data a+optAbs x | isNatural rx = x+         | otherwise    = absNum' x+  where rx = dataSize x++signumNum' :: (Numeric a, Num (Size a)) => Data a -> Data a+signumNum' = function "signum" signum signum++optSignum :: (Numeric a, Size a ~ Range b, Num b, Prelude.Ord b) => Data a -> Data a+optSignum x | 0  `rangeLess` rx =  1+            | rx `rangeLess` 0  = -1+            | rx Prelude.==  0  =  0+            | otherwise         = signumNum' x+  where rx = dataSize x++optAdd :: (Numeric a, Num (Size a)) => Data a -> Data a -> Data a+optAdd x y = case (dataToExpr x, dataToExpr y) of+               (Value 0, _) -> y+               (_, Value 0) -> x+               _            -> function2 "(+)" (+) (+) x y++optSub  :: (Numeric a, Num (Size a)) => Data a -> Data a -> Data a+optSub x y = case dataToExpr y of+               Value 0 -> x+               _       -> function2 "(-)" (-) (-) x y++optMul :: (Numeric a, Num (Size a)) => Data a -> Data a -> Data a+optMul x y = case (dataToExpr x, dataToExpr y) of+               (Value 0,_) -> value 0+               (_,Value 0) -> value 0+               (Value 1,_) -> y+               (_,Value 1) -> x+               _           -> function2 "(*)" (*) (*) x y++instance Numeric Int+  where+    absNum    = optAbs+    signumNum = optSignum+    addNum    = optAdd+    subNum    = optSub+    mulNum    = optMul++instance Numeric Unsigned32+  where+    absNum    = optAbs+    signumNum = optSignum+    addNum    = optAdd+    subNum    = optSub+    mulNum    = optMul++instance Numeric Signed32+  where+    absNum    = optAbs+    signumNum = optSignum+    addNum    = optAdd+    subNum    = optSub+    mulNum    = optMul++instance Numeric Unsigned16+  where+    absNum    = optAbs+    signumNum = optSignum+    addNum    = optAdd+    subNum    = optSub+    mulNum    = optMul++instance Numeric Signed16+  where+    absNum    = optAbs+    signumNum = optSignum+    addNum    = optAdd+    subNum    = optSub+    mulNum    = optMul++instance Numeric Unsigned8+  where+    absNum    = optAbs+    signumNum = optSignum+    addNum    = optAdd+    subNum    = optSub+    mulNum    = optMul++instance Numeric Signed8+  where+    absNum    = optAbs+    signumNum = optSignum+    addNum    = optAdd+    subNum    = optSub+    mulNum    = optMul++instance Numeric Float+  where+    absNum    = optAbs+    signumNum = optSignum+    addNum    = optAdd+    subNum    = optSub+    mulNum    = optMul++instance Numeric a => Num (Data a)+  where+    fromInteger = fromIntegerNum+    abs         = absNum+    signum      = signumNum+    (+)         = addNum+    (-)         = subNum+    (*)         = mulNum++class (Fractional a, Storable a) => Fractional' a+  where+    fromRationalFrac :: Rational -> Data a+    fromRationalFrac = value . fromRational++    divFrac :: Data a -> Data a -> Data a++instance Fractional' Float+  where+    divFrac = function2 "(/)" (\_ _ -> fullRange) (/)  -- XXX Improve range++instance (Fractional' a, Numeric a) => Fractional (Data a)+  where+    fromRational = fromRationalFrac+    (/)          = divFrac+ -- * Bit manipulation  infixl 5 <<,>>@@ -235,13 +611,13 @@   where   -- Logical operations   (.&.)         :: Data a -> Data a -> Data a-  (.&.)         =  function2 "(.&.)" (\_ _ -> universal) (B..&.)+  (.&.)         =  optAnd   (.|.)         :: Data a -> Data a -> Data a-  (.|.)         =  function2 "(.|.)" (\_ _ -> universal) (B..|.)+  (.|.)         =  optOr   xor           :: Data a -> Data a -> Data a-  xor           =  function2 "xor" (\_ _ -> universal) B.xor+  xor           =  optXor   (⊕)           :: Data a -> Data a -> Data a-  (⊕)           = xor+  (⊕)           =  xor   complement    :: Data a -> Data a   complement    =  function "complement" (const universal) B.complement @@ -259,22 +635,103 @@    -- Moving bits around   shiftL        :: Data a -> Data Int -> Data a-  shiftL        =  function2 "shiftL" (\_ _ -> universal) B.shiftL+  shiftL        =  optZero (function2 "shiftL" (\_ _ -> universal) B.shiftL)   (<<)          :: Data a -> Data Int -> Data a   (<<)          =  shiftL   shiftR        :: Data a -> Data Int -> Data a-  shiftR        =  function2 "shiftR" (\_ _ -> universal) B.shiftR+  shiftR        =  optZero (function2 "shiftR" (\_ _ -> universal) B.shiftR)   (>>)          :: Data a -> Data Int -> Data a   (>>)          =  shiftR   rotateL       :: Data a -> Data Int -> Data a-  rotateL       =  function2 "rotateL" (\_ _ -> universal) B.rotateL+  rotateL       =  optZero (function2 "rotateL" (\_ _ -> universal) B.rotateL)   rotateR       :: Data a -> Data Int -> Data a-  rotateR       =  function2 "rotateR" (\_ _ -> universal) B.rotateR+  rotateR       =  optZero (function2 "rotateR" (\_ _ -> universal) B.rotateR)+  reverseBits   :: Data a -> Data a+  reverseBits   =  function "reverseBits" (\_ -> universal) revBits +  -- Bulk bit operations+  -- | Returns the number of leading zeroes for unsigned types.+  -- For signed types it returns the number of unnecessary sign bits+  bitScan       :: Data a -> Data Int+  bitScan       =  function "bitScan" (\_ -> universal) scanLeft+  bitCount      :: Data a -> Data Int+  bitCount      =  function "bitCount" (\_ -> universal) countBits+   -- Queries about the type   bitSize       :: Data a -> Data Int   bitSize       =  function "bitSize" (const naturalRange) B.bitSize   isSigned      :: Data a -> Data Bool   isSigned      =  function "isSigned" noSizeProp B.isSigned +optAnd :: (B.Bits a, Storable a) => Data a -> Data a -> Data a+optAnd x y = case (dataToExpr x, dataToExpr y) of+               (Value 0, _) -> value 0+               (_, Value 0) -> value 0+               (Value x, _) | allOnes x -> y+               (_, Value y) | allOnes y -> x+               _            -> function2 "(.&.)" (\_ _ -> universal) (B..&.) x y++optOr :: (B.Bits a, Storable a) => Data a -> Data a -> Data a+optOr x y = case (dataToExpr x, dataToExpr y) of+              (Value 0, _) -> y+              (_, Value 0) -> x+              (Value x, _) | allOnes x -> value (B.complement 0)+              (_, Value y) | allOnes y -> value (B.complement 0)+              _            -> function2 "(.|.)" (\_ _ -> universal) (B..|.) x y++optXor :: (Bits a, B.Bits a, Storable a) => Data a -> Data a -> Data a+optXor x y = case (dataToExpr x, dataToExpr y) of+               (Value 0, _) -> y+               (_, Value 0) -> x+               (Value x, _) | allOnes x -> complement y+               (_, Value y) | allOnes y -> complement x+               _            -> function2 "xor" (\_ _ -> universal) B.xor x y++allOnes :: (Prelude.Eq a, B.Bits a) => a -> Bool+allOnes x = x Prelude.== B.complement 0++optZero :: (a -> Data Int -> a) -> a -> Data Int -> a+optZero f x y = case dataToExpr y of+                  Value 0 -> x+                  _       -> f x y++scanLeft :: B.Bits b => b -> Int+scanLeft b =+   if B.isSigned b+   then scanLoop b (B.testBit b (B.bitSize b - 1)) (B.bitSize b - 2) 0+         else scanLoop b False (B.bitSize b - 1) 0+  where+    scanLoop b bit i n | i Prelude.< 0                = n+    scanLoop b bit i n | B.testBit b i Prelude./= bit = n+    scanLoop b bit i n | otherwise                    = scanLoop b bit (i-1) (n+1)+++countBits :: B.Bits b => b -> Int+countBits b = loop b (B.bitSize b - 1) 0+  where+    loop b i n | i Prelude.< 0 = n+    loop b i n | B.testBit b i = loop b (i-1) (n+1)+    loop b i n | otherwise     = loop b (i-1) n++revBits :: B.Bits b => b -> b+revBits b = revLoop b 0 (0 `asTypeOf` b)+  where+    bitSize = B.bitSize b+    revLoop b i n | i Prelude.>= bitSize  = n+    revLoop b i n | B.testBit b i = revLoop b (i+1) (B.setBit n (bitSize - i - 1))+    revLoop b i n | otherwise     = revLoop b (i+1) n+ instance Bits Int++instance Bits Unsigned32++instance Bits Signed32++instance Bits Unsigned16++instance Bits Signed16++instance Bits Unsigned8++instance Bits Signed8+

@@ -1,9 +1,9 @@--- Copyright (c) 2009-2010, ERICSSON AB--- All rights reserved. --+-- Copyright (c) 2009-2010, ERICSSON AB All rights reserved.+--  -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are met:---+--  --     * Redistributions of source code must retain the above copyright notice, --       this list of conditions and the following disclaimer. --     * Redistributions in binary form must reproduce the above copyright@@ -12,17 +12,19 @@ --     * 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.+-- 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@@ -485,3 +487,69 @@         ]       -- The nodes that don't have any owner +-------------------- +-- show function +-------------------- ++instance Show Graph where +  show gr = prP 0 gr ++instance Show HierarchicalGraph where +  show hgr = prP 0 hgr +++class PrP a where +    prP :: Int -> a -> String ++tab sc = replicate sc ' ' ++listprint :: (a->String) -> String -> [a] -> String +listprint _ _ [] = "" +listprint f _ [x] = f x +listprint f s (x:y:xs) = f x ++ s ++ listprint f s (y:xs) ++instance PrP Graph where +  prP sc gr = tab sc ++ "Graph {\n" ++ tab (sc + 1) ++ "graphNodes = [\n" ++ prP (sc+2) (graphNodes gr)  +                 ++ "],\n" ++ tab (sc + 1) ++ "graphInterface = \n" ++ tab (sc + 3) ++ show (graphInterface gr) ++ "\n}" ++instance PrP [Node] where +  prP sc ns = (listprint (\n -> (tab sc ++ prP sc n)) ",\n" ns) +--  prP sc [] = "" +--  prP sc [node] = tab sc ++ prP sc node ++ "\n" +--  prP sc (node:ns) = tab sc ++ prP sc node ++ ",\n" ++ prP sc ns  ++instance PrP Node where +  prP sc node = "Node {nodeId = " ++ show (nodeId node) ++ ",\n"  +                   ++ tab (sc + 6) ++ "function = " ++ prP (sc+8) (function node) ++ ",\n"    +                    ++ tab (sc + 6) ++ "input = " ++ show (input node) ++ ",\n" +                     ++ tab (sc + 6) ++ "inputType = " ++ show (inputType node) ++ ",\n" +                      ++ tab (sc + 6) ++ "outputType = " ++ show (outputType node) ++ "}" ++instance PrP Function where +  prP sc (IfThenElse if1 if2) = "\n" ++ tab (sc+1) ++ "IfThenElse\n" ++ tab (sc+2) ++ show if1 ++ "\n" +                                   ++ tab (sc+2) ++ show if2 +  prP sc (Parallel if1) = "\n" ++ tab (sc+1) ++"Parallel " ++ "\n" ++ tab (sc+2) ++ show if1 +  prP sc (While if1 if2) = "\n" ++ tab (sc+1) ++ "While\n" ++ tab (sc+2) ++ show if1 ++ "\n" +                                   ++ tab (sc+2) ++ show if2  +  prP sc (NoInline str if1) = "\n" ++ tab (sc+1) ++ "NoInline \"" ++ str ++"\" \n" ++ tab (sc+2) ++ show if1 +  prP sc x = show x  ++instance PrP HierarchicalGraph where +  prP sc hgr = "HierGraph {\n" ++ tab (sc+1) ++ "graphHierarchy =\n" ++ tab (sc+2) ++ prP (sc+2) (graphHierarchy hgr) +                   ++ ",\n" ++ tab (sc+1) ++ "hierGraphInterface =\n" ++  tab (sc+2) ++ show (hierGraphInterface hgr) ++ "\n}" ++instance PrP Hierarchy where +  prP sc (Hierarchy ndhrs) = "Hierarchy [\n" ++ prP (sc+1) ndhrs ++ "\n" ++ tab sc ++ "]"  ++instance PrP [(Node, [Hierarchy])] where +  prP sc nhrs = (listprint (prP sc) ",\n" nhrs) +-- prP sc [] = "" +--  prP sc [(node,hrs)] = tab sc ++ "(" ++ prP (sc+1) node ++ ",\n" ++ prP (sc+1) hrs ++ ")"  +--  prP sc ((node,hrs):ns) = tab sc ++ "(" ++ prP (sc+1) node ++ ",\n" ++ prP (sc+1) hrs ++ "),\n" ++ prP (sc+1) ns ++instance PrP (Node, [Hierarchy]) where +  prP sc (node,hrs) = tab sc ++ "(" ++ prP (sc+1) node ++ ",\n" ++ tab sc ++ "[" ++ prP (sc+1) hrs ++ "])" +++instance PrP [Hierarchy] where +  prP sc nhrs = (listprint (prP sc) (",\n" ++ tab sc) nhrs) 

@@ -1,4 +1,32 @@--- Copyright (c) 2009-2010, ERICSSON AB, Koen Claessen+--+-- Copyright (c) 2009-2010, ERICSSON AB All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are met:+-- +--     * Redistributions of source code must retain the above copyright notice,+--       this list of conditions and the following disclaimer.+--     * Redistributions in binary form must reproduce the above copyright+--       notice, this list of conditions and the following disclaimer in the+--       documentation and/or other materials provided with the distribution.+--     * Neither the name of the ERICSSON AB nor the names of its contributors+--       may be used to endorse or promote products derived from this software+--       without specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+-- ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS+-- BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY,+-- OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+-- SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+-- INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+-- CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+-- ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF+-- THE POSSIBILITY OF SUCH DAMAGE.+--++-- Copyright (c) 2009 Koen Claessen -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without@@ -9,7 +37,7 @@ --     * 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+--     * Neither the name of the Koen Claessen nor the names of its contributors --       may be used to endorse or promote products derived from this software --       without specific prior written permission. --@@ -44,6 +72,7 @@   +import Data.Function import Data.Unique import System.IO.Unsafe @@ -55,10 +84,10 @@   }  instance Eq (Ref a) where-  Ref x _ == Ref y _ = x == y+  (==) = (==) `on` refId  instance Ord (Ref a) where-  Ref x _ `compare` Ref y _ = x `compare` y+  compare = compare `on` refId   

@@ -1,9 +1,9 @@--- Copyright (c) 2009-2010, ERICSSON AB--- All rights reserved. --+-- Copyright (c) 2009-2010, ERICSSON AB All rights reserved.+--  -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are met:---+--  --     * Redistributions of source code must retain the above copyright notice, --       this list of conditions and the following disclaimer. --     * Redistributions in binary form must reproduce the above copyright@@ -12,17 +12,19 @@ --     * 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.+-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+-- ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS+-- BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY,+-- OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+-- SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+-- INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+-- CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+-- ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF+-- THE POSSIBILITY OF SUCH DAMAGE.+--  {-# LANGUAGE OverlappingInstances, UndecidableInstances #-} @@ -35,6 +37,9 @@   , showCoreWithSize   , printCore   , printCoreWithSize+  , runGraph+  , buildSubFun+  , startInfo   ) where  @@ -49,7 +54,7 @@ import Feldspar.Core.Types import Feldspar.Core.Ref import Feldspar.Core.Expr-import Feldspar.Core.Graph hiding (function, Function (..), SubFunction)+import Feldspar.Core.Graph hiding (function, Function (..), Variable) import qualified Feldspar.Core.Graph as Graph import Feldspar.Core.Show @@ -108,47 +113,40 @@     One (StorableType [] _) -> True     _ -> False -- -- Creates a source. The node must have been visited. source :: [Int] -> Data a -> Reify Source source path a = case dataToExpr a of -    Get21 tup -> source (0:path) tup-    Get22 tup -> source (1:path) tup-    Get31 tup -> source (0:path) tup-    Get32 tup -> source (1:path) tup-    Get33 tup -> source (2:path) tup-    Get41 tup -> source (0:path) tup-    Get42 tup -> source (1:path) tup-    Get43 tup -> source (2:path) tup-    Get44 tup -> source (3:path) tup+    Application (Function ('g':'e':'t':'T':'u':'p':_:n:_) _) tup ->+      source ((read [n] - 1) : path) tup+        -- XXX This is a bit fragile... -    Value _ b | isPrimitive a ->+    Value b | isPrimitive a ->       let PrimitiveData b' = storableData b        in return $ Constant b'      _ -> do       Just i <- checkNode a-      return $ Variable (i,path)+      return $ Graph.Variable (i,path)    traceTuple :: Data a -> Reify (Tuple Source) traceTuple a = case dataToExpr a of -    Tuple2 b c -> do+    Application (Application (Function "tup2" _) b) c -> do       b' <- traceTuple b       c' <- traceTuple c       return (Tup [b',c']) -    Tuple3 b c d -> do+    Application (Application (Application (Function "tup3" _) b) c) d -> do       b' <- traceTuple b       c' <- traceTuple c       d' <- traceTuple d       return (Tup [b',c',d']) -    Tuple4 b c d e -> do+    Application (Application (Application (Application+                                            (Function "tup4" _) b) c) d) e -> do       b' <- traceTuple b       c' <- traceTuple c       d' <- traceTuple d@@ -171,29 +169,28 @@      list :: Expr a -> Reify () -    list (Input _) = sourceNode a Graph.Input+    list Variable = sourceNode a Graph.Input -    list (Value _ b)+    list (Value b)       | isPrimitive a = return ()       | otherwise     = sourceNode a $ Graph.Array $ storableData b -    list (Tuple2 b c)     = buildGraph b >> buildGraph c-    list (Tuple3 b c d)   = buildGraph b >> buildGraph c >> buildGraph d-    list (Tuple4 b c d e) =-        buildGraph b >> buildGraph c >> buildGraph d >> buildGraph e+    list (Application (Application (Function fun _) b) c)+      | fun == "tup2" = buildGraph b >> buildGraph c -    list (Get21 b) = buildGraph b-    list (Get22 b) = buildGraph b-    list (Get31 b) = buildGraph b-    list (Get32 b) = buildGraph b-    list (Get33 b) = buildGraph b-    list (Get41 b) = buildGraph b-    list (Get42 b) = buildGraph b-    list (Get43 b) = buildGraph b-    list (Get44 b) = buildGraph b+    list (Application (Application (Application (Function "tup3" _) b) c) d) =+      buildGraph b >> buildGraph c >> buildGraph d -    list (Function fun _ _ b) = funcNode (Graph.Function fun) b+    list (Application (Application (Application (Application+                                               (Function "tup4" _) b) c) d) e) =+      buildGraph b >> buildGraph c >> buildGraph d >> buildGraph e +    list (Application (Function fun _) b)+      | take 6 fun == "getTup" = buildGraph b+      | otherwise              = funcNode (Graph.Function fun) b++      -- XXX Assumes that no other kinds of function application exist.+     list (NoInline fun f b@(Data _ _)) = do       iface <- buildSubFun (deref f)       funcNode (Graph.NoInline fun iface) b@@ -202,7 +199,7 @@     list (IfThenElse c t e b@(Data _ _)) = do       ifaceThen <- buildSubFun t       ifaceElse <- buildSubFun e-      funcNode (Graph.IfThenElse ifaceThen ifaceElse) (exprToData $ Tuple2 c b)+      funcNode (Graph.IfThenElse ifaceThen ifaceElse) (tup2 c b)      list (While cont body b@(Data _ _)) = do       ifaceCont <- buildSubFun cont@@ -218,7 +215,7 @@ buildSubFun :: forall a b . (Typeable a, Typeable b) =>     (a :-> b) -> Reify Interface -buildSubFun (SubFunction _ inp outp) = do+buildSubFun (Lambda _ inp outp) = do     let inType  = typeOf (dataSize inp) (T::T a)         outType = typeOf (dataSize outp) (T::T b)     buildGraph inp  -- Needed in case input is not used@@ -233,7 +230,7 @@ reifyD :: (Typeable a, Typeable b) => (Data a -> Data b) -> Graph reifyD f = Graph nodes iface   where-    subFun            = mkSubFun universal f+    subFun            = lambda universal f     (iface,(nodes,_)) = runGraph (buildSubFun subFun) startInfo  @@ -314,3 +311,5 @@ printCoreWithSize :: Program a => a -> IO () printCoreWithSize = putStrLn . showCoreWithSize +instance Storable a => Show (Data a) where+  show = showCore

@@ -1,9 +1,9 @@--- Copyright (c) 2009-2010, ERICSSON AB--- All rights reserved. --+-- Copyright (c) 2009-2010, ERICSSON AB All rights reserved.+--  -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are met:---+--  --     * Redistributions of source code must retain the above copyright notice, --       this list of conditions and the following disclaimer. --     * Redistributions in binary form must reproduce the above copyright@@ -12,17 +12,19 @@ --     * 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.+-- 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.

@@ -0,0 +1,38 @@+--+-- Copyright (c) 2009-2010, ERICSSON AB All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are met:+-- +--     * Redistributions of source code must retain the above copyright notice,+--       this list of conditions and the following disclaimer.+--     * Redistributions in binary form must reproduce the above copyright+--       notice, this list of conditions and the following disclaimer in the+--       documentation and/or other materials provided with the distribution.+--     * Neither the name of the ERICSSON AB nor the names of its contributors+--       may be used to endorse or promote products derived from this software+--       without specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+-- ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS+-- BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY,+-- OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+-- SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+-- INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+-- CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+-- ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF+-- THE POSSIBILITY OF SUCH DAMAGE.+--++module Feldspar.Core.Trace where+++import Feldspar.Core.Expr+import Feldspar.Core.Types++++trace :: (Storable a) => Int -> Data a -> Data a+trace label = function2 "trace" (const id) (const id) $ value label

@@ -1,9 +1,9 @@--- Copyright (c) 2009-2010, ERICSSON AB--- All rights reserved. --+-- Copyright (c) 2009-2010, ERICSSON AB All rights reserved.+--  -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are met:---+--  --     * Redistributions of source code must retain the above copyright notice, --       this list of conditions and the following disclaimer. --     * Redistributions in binary form must reproduce the above copyright@@ -12,17 +12,19 @@ --     * 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.+-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+-- ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS+-- BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY,+-- OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+-- SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+-- INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+-- CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+-- ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF+-- THE POSSIBILITY OF SUCH DAMAGE.+--  {-# LANGUAGE UndecidableInstances #-} @@ -106,6 +108,7 @@ type Length = Int  + -- * Tuples  -- | Untyped representation of nested tuples@@ -192,12 +195,20 @@  -- * Types +type Unsigned32 = Word32+type Signed32   = Int32+type Unsigned16 = Word16+type Signed16   = Int16+type Unsigned8  = Word8+type Signed8    = Int8+ -- | Representation of primitive types data PrimitiveType   = UnitType   | BoolType   | IntType { signed :: Bool, bitSize :: Int, valueSet :: (Range Integer) }   | FloatType (Range Float)+  | UserType String     deriving (Eq, Show)  -- | Representation of storable types (arrays of primitive types). Array size is@@ -208,10 +219,16 @@  instance HaskellType PrimitiveType   where-    haskellType UnitType        = "()"-    haskellType BoolType        = "Bool"-    haskellType (IntType _ _ _) = "Int"-    haskellType (FloatType _)   = "Float"+    haskellType UnitType             = "()"+    haskellType BoolType             = "Bool"+    haskellType (IntType True  32 _) = "Int32"+    haskellType (IntType False 32 _) = "Word32"+    haskellType (IntType True  16 _) = "Int16"+    haskellType (IntType False 16 _) = "Word16"+    haskellType (IntType True   8 _) = "Int8"+    haskellType (IntType False  8 _) = "Word8"+    haskellType (FloatType _)        = "Float"+    haskellType (UserType t)         = t  instance HaskellType StorableType   where@@ -220,10 +237,10 @@         d       = length ls         arrType = replicate d '[' ++ haskellType t ++ replicate d ']' -showPrimitiveRange UnitType        = ""-showPrimitiveRange BoolType        = ""+showPrimitiveRange :: PrimitiveType -> String showPrimitiveRange (IntType _ _ r) = showRange r showPrimitiveRange (FloatType r)   = showRange r+showPrimitiveRange _               = ""  -- | Shows the size of a storable type. showStorableSize :: StorableType -> String@@ -232,37 +249,10 @@   +{-# DEPRECATED Primitive "The class Primitive will be removed. Use Storable instead." #-} -- | Primitive types-class Storable a => Primitive a-  where-    -- | Converts a primitive value to its untyped representation.-    primitiveData :: a -> PrimitiveData--    -- | Gives the type representation of a primitive value.-    primitiveType :: Size a -> T a -> PrimitiveType--instance Primitive ()-  where-    primitiveData     = UnitData-    primitiveType _ _ = UnitType--instance Primitive Bool-  where-    primitiveData     = BoolData-    primitiveType _ _ = BoolType---- Assumes 32 bits which is not necessarily correct-instance Primitive Int-  where-    primitiveData     = IntData . toInteger-    primitiveType s _ = IntType True 32 s--instance Primitive Float-  where-    primitiveData     = FloatData-    primitiveType s _ = FloatType s--+class    Storable a => Primitive a+instance Storable a => Primitive a  -- | Storable types (zero- or higher-level arrays of primitive data). class Typeable a => Storable a@@ -281,31 +271,74 @@  instance Storable ()   where-    storableData    = PrimitiveData . primitiveData-    storableType s  = StorableType [] . primitiveType s+    storableData    = PrimitiveData . UnitData+    storableType _ _= StorableType [] UnitType     storableSize _  = ()     listSize _ _    = []  instance Storable Bool   where-    storableData   = PrimitiveData . primitiveData-    storableType s = StorableType [] . primitiveType s-    storableSize _ = ()-    listSize _ _   = []+    storableData     = PrimitiveData . BoolData+    storableType _ _ = StorableType [] BoolType+    storableSize _   = ()+    listSize _ _     = [] +-- XXX Assumes 32 bits which is not necessarily correct instance Storable Int   where-    storableData   = PrimitiveData . primitiveData-    storableType s = StorableType [] . primitiveType s-    storableSize a = singletonRange $ toInteger a-    listSize _ _   = []+    storableData     = PrimitiveData . IntData . toInteger+    storableType s _ = StorableType [] $ IntType True 32 s+    storableSize a   = singletonRange $ toInteger a+    listSize _ _     = [] +instance Storable Unsigned32+  where+    storableData     = PrimitiveData . IntData . toInteger+    storableType s _ = StorableType [] $ IntType False 32 s+    storableSize a   = singletonRange $ toInteger a+    listSize _ _     = []++instance Storable Signed32+  where+    storableData     = PrimitiveData . IntData . toInteger+    storableType s _ = StorableType [] $ IntType True 32 s+    storableSize a   = singletonRange $ toInteger a+    listSize _ _     = []++instance Storable Unsigned16+  where+    storableData     = PrimitiveData . IntData . toInteger+    storableType s _ = StorableType [] $ IntType False 16 s+    storableSize a   = singletonRange $ toInteger a+    listSize _ _     = []++instance Storable Signed16+  where+    storableData     = PrimitiveData . IntData . toInteger+    storableType s _ = StorableType [] $ IntType True 16 s+    storableSize a   = singletonRange $ toInteger a+    listSize _ _     = []++instance Storable Unsigned8+  where+    storableData     = PrimitiveData . IntData . toInteger+    storableType s _ = StorableType [] $ IntType False 8 s+    storableSize a   = singletonRange $ toInteger a+    listSize _ _     = []++instance Storable Signed8+  where+    storableData     = PrimitiveData . IntData . toInteger+    storableType s _ = StorableType [] $ IntType True 8 s+    storableSize a   = singletonRange $ toInteger a+    listSize _ _     = []+ instance Storable Float   where-    storableData   = PrimitiveData . primitiveData-    storableType s = StorableType [] . primitiveType s-    storableSize a = singletonRange a-    listSize _ _   = []+    storableData     = PrimitiveData . FloatData+    storableType s _ = StorableType [] $ FloatType s+    storableSize a   = singletonRange a+    listSize _ _     = []  instance Storable a => Storable [a]   where@@ -322,7 +355,7 @@   -class (Eq a, Ord a, Monoid (Size a), Set (Size a)) => Typeable a+class (Eq a, Monoid (Size a), Set (Size a)) => Typeable a   where     -- | This type provides the necessary extra information to compute a type     -- representation @`Tuple` `StorableType`@ from a type @a@. This is needed@@ -348,6 +381,36 @@     type Size Int = Range Integer     typeOf        = typeOfStorable +instance Typeable Unsigned32+  where+    type Size Unsigned32 = Range Integer+    typeOf               = typeOfStorable++instance Typeable Signed32+  where+    type Size Signed32 = Range Integer+    typeOf             = typeOfStorable++instance Typeable Unsigned16+  where+    type Size Unsigned16 = Range Integer+    typeOf               = typeOfStorable++instance Typeable Signed16+  where+    type Size Signed16 = Range Integer+    typeOf             = typeOfStorable++instance Typeable Unsigned8+  where+    type Size Unsigned8 = Range Integer+    typeOf              = typeOfStorable++instance Typeable Signed8+  where+    type Size Signed8 = Range Integer+    typeOf            = typeOfStorable+ instance Typeable Float   where     type Size Float = Range Float@@ -391,8 +454,3 @@ typeOfStorable :: Storable a => Size a -> T a -> Tuple StorableType typeOfStorable sz = One . storableType sz -class (Num a, Primitive a, Num (Size a)) => Numeric a--instance Numeric Int--instance Numeric Float

@@ -0,0 +1,577 @@+--+-- Copyright (c) 2009-2010, ERICSSON AB All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are met:+-- +--     * Redistributions of source code must retain the above copyright notice,+--       this list of conditions and the following disclaimer.+--     * Redistributions in binary form must reproduce the above copyright+--       notice, this list of conditions and the following disclaimer in the+--       documentation and/or other materials provided with the distribution.+--     * Neither the name of the ERICSSON AB nor the names of its contributors+--       may be used to endorse or promote products derived from this software+--       without specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+-- ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS+-- BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY,+-- OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+-- SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+-- INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+-- CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+-- ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF+-- THE POSSIBILITY OF SUCH DAMAGE.+--++module Feldspar.FixedPoint where++import qualified Prelude+import Feldspar.Prelude+import Feldspar.Core.Types+import Feldspar.Core.Expr+import Feldspar.Core+import Data.Ratio++import System.IO.Unsafe+import Feldspar.Core.Functions++type Fix32  = (Int, Data Signed32)+type UFix32 = (Int, Data Unsigned32)+type Fix16  = (Int, Data Signed16)+type UFix16 = (Int, Data Unsigned16)+type Fix8  = (Int, Data Signed8)+type UFix8 = (Int, Data Unsigned8)+type Fix  = (Int,Data Int)++intToFix :: Int -> Data Int -> Fix+intToFix exp val = (exp, val)++intToFix32 :: Int -> Data Signed32 -> Fix32+intToFix32 exp val = (exp, val)++intToUFix32 :: Int -> Data Unsigned32 -> UFix32+intToUFix32 exp val = (exp, val)++intToFix16 :: Int -> Data Signed16 -> Fix16+intToFix16 exp val = (exp, val)++intToUFix16 :: Int -> Data Unsigned16 -> UFix16+intToUFix16 exp val = (exp, val)++intToFix8 :: Int -> Data Signed8 -> Fix8+intToFix8 exp val = (exp, val)++intToUFix8 :: Int -> Data Unsigned8 -> UFix8+intToUFix8 exp val = (exp, val)++fixToInt :: Int -> Fix -> Data Int+fixToInt exp' (exp,val) = val `leftShift` (exp-exp')++fix32ToInt :: Int -> Fix32 -> Data Signed32+fix32ToInt exp' (exp,val) = val `leftShift` (exp-exp')++uFix32ToInt :: Int -> UFix32 -> Data Unsigned32+uFix32ToInt exp' (exp,val) = val `leftShift` (exp-exp')++fix16ToInt :: Int -> Fix16 -> Data Signed16+fix16ToInt exp' (exp,val) = val `leftShift` (exp-exp')++uFix16ToInt :: Int -> UFix16 -> Data Unsigned16+uFix16ToInt exp' (exp,val) = val `leftShift` (exp-exp')++fix8ToInt :: Int -> Fix8 -> Data Signed8+fix8ToInt exp' (exp,val) = val `leftShift` (exp-exp')++uFix8ToInt :: Int -> UFix8 -> Data Unsigned8+uFix8ToInt exp' (exp,val) = val `leftShift` (exp-exp')++floatToFix :: Float -> Fix+floatToFix f = (0, value $ Prelude.round f)++floatToFix32 :: Float -> Fix32+floatToFix32 f = (0, value $ Prelude.round f)++floatToUFix32 :: Float -> UFix32+floatToUFix32 f = (0, value $ Prelude.round f)++floatToFix16 :: Float -> Fix16+floatToFix16 f = (0, value $ Prelude.round f)++floatToUFix16 :: Float -> UFix16+floatToUFix16 f = (0, value $ Prelude.round f)++floatToFix8 :: Float -> Fix8+floatToFix8 f = (0, value $ Prelude.round f)++floatToUFix8 :: Float -> UFix8+floatToUFix8 f = (0, value $ Prelude.round f)+++floatToFix32' :: Int -> Float -> Fix32+floatToFix32' exp fl = (exp, value $ Prelude.round $+          (fl Prelude./ (2.0 Prelude.** (fromInteger(toInteger exp)))::Float))++floatToUFix32' :: Int -> Float -> UFix32+floatToUFix32' exp fl = (exp, value $ Prelude.round $+          (fl Prelude./ (2.0 Prelude.** (fromInteger(toInteger exp)))::Float))++floatToFix16' :: Int -> Float -> Fix16+floatToFix16' exp fl = (exp, value $ Prelude.round $+          (fl Prelude./ (2.0 Prelude.** (fromInteger(toInteger exp)))::Float))++floatToUFix16' :: Int -> Float -> UFix16+floatToUFix16' exp fl = (exp, value $ Prelude.round $+          (fl Prelude./ (2.0 Prelude.** (fromInteger(toInteger exp)))::Float))++floatToFix8' :: Int -> Float -> Fix8+floatToFix8' exp fl = (exp, value $ Prelude.round $+          (fl Prelude./ (2.0 Prelude.** (fromInteger(toInteger exp)))::Float))++floatToUFix8' :: Int -> Float -> UFix8+floatToUFix8' exp fl = (exp, value $ Prelude.round $+          (fl Prelude./ (2.0 Prelude.** (fromInteger(toInteger exp)))::Float))+++toExp32 :: Int -> Fix32 -> Fix32+toExp32 exp (e,i) = (exp, i `leftShift` (e-exp))++toExpU32 :: Int -> UFix32 -> UFix32+toExpU32 exp (e,i) = (exp, i `leftShift` (e-exp))++toExp16 :: Int -> Fix16 -> Fix16+toExp16 exp (e,i) = (exp, i `leftShift` (e-exp))++toExpU16 :: Int -> UFix16 -> UFix16+toExpU16 exp (e,i) = (exp, i `leftShift` (e-exp))++toExp8 :: Int -> Fix8 -> Fix8+toExp8 exp (e,i) = (exp, i `leftShift` (e-exp))++toExpU8 :: Int -> UFix8 -> UFix8+toExpU8 exp (e,i) = (exp, i `leftShift` (e-exp))++fixToFloat :: (Integral a,Integral b) => ( a , Data b ) -> Float+fixToFloat fix =( 2.0 Prelude.** (fromInteger (toInteger(fst fix)))) Prelude.*+                 ( (fromInteger ( toInteger ( evalD (snd fix) )) )::Float )++fix32ToFloat :: Fix32-> Float+fix32ToFloat fix = fixToFloat fix++uFix32ToFloat :: UFix32-> Float+uFix32ToFloat fix = fixToFloat fix++fix16ToFloat :: Fix16-> Float+fix16ToFloat fix = fixToFloat fix++uFix16ToFloat :: UFix16-> Float+uFix16ToFloat fix = fixToFloat fix++fix8ToFloat :: Fix8-> Float+fix8ToFloat fix = fixToFloat fix++uFix8ToFloat :: UFix8-> Float+uFix8ToFloat fix = fixToFloat fix++inBounds :: Bool -> Int -> Int -> Bool+inBounds s wbits i | s Prelude.&& (i Prelude.> sintmax)       = False+           | s Prelude.&& (i Prelude.< sintmin)               = False+           | (Prelude.not s) Prelude.&& (i Prelude.> uintmax) = False+           | (Prelude.not s) Prelude.&& (i Prelude.< uintmin) = False+           | otherwise  = True+   where+      (sintmax :: Int) = 2 Prelude.^ (wbits Prelude.- 1) - 1+      (sintmin :: Int) = -sintmax+      (uintmax :: Int) = 2 Prelude.^ wbits Prelude.- 1+      (uintmin :: Int) = 0++fl01toFix :: (Integral a,Integral b) => Bool ->Int-> Float+                                     -> (a,Data b) -> Bool -> (a,Data b)+fl01toFix s bts fl fix gt+  | (Prelude.not gt) Prelude.&& ( fl1 Prelude.> fl   ) =+        fl01toFix s bts fl ((fst fix) Prelude.- 1, snd fix  ) Prelude.False+  | (Prelude.not gt) Prelude.&& ( fl1 Prelude.< fl   ) =+        fl01toFix s bts fl ((fst fix) Prelude.- 1, snd fix  ) Prelude.True+  | (Prelude.not gt) Prelude.&& ( fl1 Prelude.== fl   ) =+        ((fst fix) Prelude.- 1, snd fix  )+  | gt Prelude.&& ( (inBounds s bts val') Prelude.&& ( fl2 Prelude.> fl )  ) =+      fl01toFix s bts fl ((fst fix) Prelude.- 1, 2 * (snd fix) ) Prelude.True+  | gt Prelude.&& ( (inBounds s bts val') Prelude.&& ( fl2 Prelude.< fl )  ) =+      fl01toFix s bts fl ((fst fix) Prelude.- 1,2 * ( snd fix) + 1) Prelude.True+  | gt Prelude.&& ( (inBounds s bts val') Prelude.&& ( fl2 Prelude.== fl )  ) =+      fl01toFix s bts fl ((fst fix) Prelude.- 1, 2 * (snd fix) +1 ) Prelude.True+  | otherwise = fix+    where+      fl2 = (2.0 Prelude.* (fromInteger val) Prelude.+ 1.0 ) Prelude.*+            (2.0 Prelude.** ( (fromInteger exp) Prelude.- 1.0 ))+      fl1 =( fromInteger val ) Prelude.*+           (2.0 Prelude.** ( (fromInteger exp) Prelude.- 1.0 ))+      val'= 2 Prelude.* (fromInteger val) Prelude.+ 1+      val = toInteger $ evalD $ snd fix+      exp = toInteger $ fst fix++fl01toFix' :: Float -> Fix -> Bool -> Fix+fl01toFix' = fl01toFix True 31++fl01toUFix32 :: Float -> UFix32 -> Bool -> UFix32+fl01toUFix32 = fl01toFix False 32++fl01toFix32  :: Float -> Fix32 -> Bool -> Fix32+fl01toFix32 = fl01toFix True 31++fl01toUFix16 :: Float -> UFix16 -> Bool -> UFix16+fl01toUFix16 = fl01toFix False 16++fl01toFix16  :: Float -> Fix16 -> Bool -> Fix16+fl01toFix16 = fl01toFix True 15++fl01toUFix8 :: Float -> UFix8 -> Bool -> UFix8+fl01toUFix8 = fl01toFix False 8++fl01toFix8  :: Float -> Fix8 -> Bool -> Fix8+fl01toFix8 = fl01toFix True 7++zeroOneToFix :: Float -> Fix+zeroOneToFix fl = fl01toFix' fl (1,1) Prelude.False++zeroOneToFix32 :: Float -> Fix32+zeroOneToFix32 fl = fl01toFix32 fl (1,1) Prelude.False++zeroOneToUFix32 :: Float -> UFix32+zeroOneToUFix32 fl = fl01toUFix32 fl (1,1) Prelude.False++zeroOneToFix16 :: Float -> Fix16+zeroOneToFix16 fl = fl01toFix16 fl (1,1) Prelude.False++zeroOneToUFix16 :: Float -> UFix16+zeroOneToUFix16 fl = fl01toUFix16 fl (1,1) Prelude.False++zeroOneToFix8 :: Float -> Fix8+zeroOneToFix8 fl = fl01toFix8 fl (1,1) Prelude.False++zeroOneToUFix8 :: Float -> UFix8+zeroOneToUFix8 fl = fl01toUFix8 fl (1,1) Prelude.False+++addFix ::(Integral b,Bits b) =>+              Int -> (Int,Data b) -> (Int,Data b) -> (Int,Data b)+addFix e (e1,i1) (e2,i2) =+      (e, i1 `leftShift` (e1 Prelude.- e) + i2 `leftShift` (e2 Prelude.- e))++addFix'' :: Int -> Fix -> Fix -> Fix+addFix'' = addFix++addFix32 :: Int -> Fix32 -> Fix32 -> Fix32+addFix32 = addFix++addUFix32 :: Int -> UFix32 -> UFix32 -> UFix32+addUFix32 = addFix++addFix16 :: Int -> Fix16 -> Fix16 -> Fix16+addFix16 = addFix++addUFix16 :: Int -> UFix16 -> UFix16 -> UFix16+addUFix16 = addFix++addFix8 :: Int -> Fix8 -> Fix8 -> Fix8+addFix8 = addFix++addUFix8 :: Int -> UFix8 -> UFix8 -> UFix8+addUFix8 = addFix++recipFix :: (Integral b,Bits b) =>+                Int -> (Int,Data b) -> (Int,Data b)+recipFix exp (e,i) = (e2,i2)+   where+      e2 = exp+      i2 = div sh i+      sh = 1 `rightShift` (exp Prelude.+ e)++recipFix' :: Int -> Fix -> Fix+recipFix' =  recipFix++recipFix32 :: Int -> Fix32 -> Fix32+recipFix32 =  recipFix++recipUFix32 :: Int -> UFix32 -> UFix32+recipUFix32 =  recipFix++recipFix16 :: Int -> Fix16 -> Fix16+recipFix16 =  recipFix++recipUFix16 :: Int -> UFix16 -> UFix16+recipUFix16 =  recipFix++recipFix8 :: Int -> Fix8 -> Fix8+recipFix8 =  recipFix++recipUFix8 :: Int -> UFix8 -> UFix8+recipUFix8 =  recipFix++divFix :: (Integral b,Bits b) =>+               Int -> (Int,Data b) -> (Int,Data b)+           -> (Int,Data b)+divFix exp (e1,i1) (e2,i2) = (e,i)+   where+      e = exp+      i = div sh i2+      val = e1 Prelude.- e2 Prelude.- exp+      sh = i1 `leftShift` val++divFix' :: Int -> Fix -> Fix -> Fix+divFix' = divFix++divFix32 :: Int -> Fix32 -> Fix32 -> Fix32+divFix32 = divFix++divUFix32 :: Int -> UFix32 -> UFix32 -> UFix32+divUFix32 = divFix++divFix16 :: Int -> Fix16 -> Fix16 -> Fix16+divFix16 = divFix++divUFix16 :: Int -> UFix16 -> UFix16 -> UFix16+divUFix16 = divFix++divFix8 :: Int -> Fix8 -> Fix8 -> Fix8+divFix8 = divFix++divUFix8 :: Int -> UFix8 -> UFix8 -> UFix8+divUFix8 = divFix++addFix' ::(Integral b,Bits b) =>+              (Int,Data b) -> (Int,Data b) -> (Int,Data b)+addFix' (e1,i1) (e2,i2) =+      (  m, ( i1 `leftShift` (e1 Prelude.- m)) ++             ( i2 `leftShift` ( e2 Prelude.- m ) ) )+   where+      m = Prelude.max e1 e2++mulFix' ::(Integral b,Bits b) =>+              (Int,Data b) -> (Int,Data b) -> (Int,Data b)+mulFix' (e1,i1) (e2,i2)=(added ,(i1*i2 ) )+      where+        added = e1 Prelude.+ e2++negate' ::(Integral b,Bits b) =>+              (Int,Data b) -> (Int,Data b)+negate' (e,i) = (e, negate i )++abs' ::(Integral b,Bits b) =>+              (Int,Data b) -> (Int,Data b)+abs' (e,i) = (e,abs(i))++signum' ::(Integral b,Bits b) =>+              (Int,Data b) -> (Int,Data b)+signum' (e,i) = ( 0 , signum i )++fromInteger' ::(Integral b,Bits b) =>+                Integer -> (Int,Data b)+fromInteger' i = ( 0 , fromInteger i )++instance Num Fix where+    x + y = addFix' x y+    x * y=mulFix' x y+    negate = negate'+    abs = abs'+    signum = signum'+    fromInteger = fromInteger'++instance Num Fix32 where+    x + y = addFix' x y+    x * y=mulFix' x y+    negate = negate'+    abs = abs'+    signum = signum'+    fromInteger = fromInteger'++instance Num UFix32 where+    x + y = addFix' x y+    x * y=mulFix' x y+    negate = negate'+    abs = abs'+    signum = signum'+    fromInteger = fromInteger'++instance Num Fix16 where+    x + y = addFix' x y+    x * y=mulFix' x y+    negate = negate'+    abs = abs'+    signum = signum'+    fromInteger = fromInteger'++instance Num UFix16 where+    x + y = addFix' x y+    x * y=mulFix' x y+    negate = negate'+    abs = abs'+    signum = signum'+    fromInteger = fromInteger'+++instance Num Fix8 where+    x + y = addFix' x y+    x * y=mulFix' x y+    negate = negate'+    abs = abs'+    signum = signum'+    fromInteger = fromInteger'++instance Num UFix8 where+    x + y = addFix' x y+    x * y=mulFix' x y+    negate = negate'+    abs = abs'+    signum = signum'+    fromInteger = fromInteger'++recip' ::(Integral b,Bits b) =>+              Int -> (Int,Data b) -> (Int,Data b)+recip' bts (e,i) = ( e2, i2 )+      where+        k   = bts - 2+        e2  = Prelude.negate $ e Prelude.+ k+        sh  = 1 `leftShift` k+        i2  = div sh i++fromRational' ::(Integral b,Bits b,Num (Int,Data b)) =>+                Bool -> Int->(Float->(Int,Data b))->(Integer->(Int,Data b))+                    -> Rational -> (Int,Data b)+fromRational' s bts zotf fi  rat = addFix e integ frac+      where+       e      = (fst frac) Prelude.+ toShift'+       toShift' | s = Prelude.min toShift+                    ((bts Prelude.- 1) Prelude.- bitsInteg)+                | (Prelude.not s) =+                    Prelude.min toShift (bts Prelude.- bitsInteg)+       toShift | s = Prelude.max 0+                   (bitsFrac Prelude.- (bts Prelude.- 1) Prelude.+ bitsInteg)+               | (Prelude.not s) =+                   Prelude.max 0 (bitsFrac Prelude.- bts Prelude.+ bitsInteg)+       bitsFrac  = Prelude.floor $+                     Prelude.logBase 2.0 (fromInteger (toInteger vfrac))+       bitsInteg = Prelude.floor $+                     Prelude.logBase 2.0 (fromInteger (toInteger vinteg))+       vinteg = evalD $ snd integ+       vfrac  = evalD $ snd frac+       frac   = zotf fl01+       integ  = (fi+                  ( Prelude.quot (numerator rat) (denominator rat)  ))+       fl01   = fl - ((Prelude.fromInteger (Prelude.floor fl))::Float)+       fl     = (Prelude.fromRational rat)::Float++instance Fractional Fix where+   recip = recip' 32+   fromRational = fromRational' True  32 zeroOneToFix fromInteger++instance Fractional Fix32 where+   recip = recip' 32+   fromRational = fromRational' True 32 zeroOneToFix32 fromInteger++instance Fractional UFix32 where+   recip = recip' 31+   fromRational = fromRational' False 31 zeroOneToUFix32 fromInteger++instance Fractional Fix16 where+   recip = recip' 16+   fromRational = fromRational' True 16 zeroOneToFix16 fromInteger++instance Fractional UFix16 where+   recip = recip' 15+   fromRational = fromRational' False 15 zeroOneToUFix16 fromInteger++instance Fractional Fix8 where+   recip = recip' 8+   fromRational = fromRational' True 8 zeroOneToFix8 fromInteger++instance Fractional UFix8 where+   recip = recip' 7+   fromRational = fromRational' False 7 zeroOneToUFix8 fromInteger++class FixFloatLike a  where+   addFF   :: Int -> a -> a -> a+   recipFF :: Int -> a -> a+   divFF   :: Int -> a -> a -> a++instance FixFloatLike (Data Float) where+   addFF _ x y = x + y+   recipFF _ x = 1/x+   divFF _ x y = x/y+++instance FixFloatLike Fix where+   addFF   = addFix''+   recipFF = recipFix'+   divFF   = divFix'++instance FixFloatLike Fix32 where+   addFF   = addFix32+   recipFF = recipFix32+   divFF   = divFix32++instance FixFloatLike UFix32 where+   addFF   = addUFix32+   recipFF = recipUFix32+   divFF   = divUFix32++instance FixFloatLike Fix16 where+   addFF   = addFix16+   recipFF = recipFix16+   divFF   = divFix16++instance FixFloatLike UFix16 where+   addFF   = addUFix16+   recipFF = recipUFix16+   divFF   = divUFix16++instance FixFloatLike Fix8 where+   addFF   = addFix8+   recipFF = recipFix8+   divFF   = divFix8++instance FixFloatLike UFix8 where+   addFF   = addUFix8+   recipFF = recipUFix8+   divFF   = divUFix8+++class FromFloat t where+   float :: Float -> t++instance FromFloat (Data Float) where+   float = value++instance FromFloat Fix where+   float = floatToFix++instance FromFloat Fix32 where+   float = floatToFix32++instance FromFloat UFix32 where+   float = floatToUFix32++instance FromFloat Fix16 where+   float = floatToFix16++instance FromFloat UFix16 where+   float = floatToUFix16++instance FromFloat Fix8 where+   float = floatToFix8++instance FromFloat UFix8 where+   float = floatToUFix8++-- Helper functions to generate shift with non-negative parameter+leftShift :: Bits a => Data a -> Int -> Data a+leftShift a b+    | b Prelude.>= 0    = a << value b+    | otherwise         = a >> value (Prelude.negate b)++rightShift :: Bits a => Data a -> Int -> Data a+rightShift a b+    | b Prelude.>= 0    = a >> value b+    | otherwise         = a << value (Prelude.negate b)

@@ -1,9 +1,9 @@--- Copyright (c) 2009-2010, ERICSSON AB--- All rights reserved. --+-- Copyright (c) 2009-2010, ERICSSON AB All rights reserved.+--  -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are met:---+--  --     * Redistributions of source code must retain the above copyright notice, --       this list of conditions and the following disclaimer. --     * Redistributions in binary form must reproduce the above copyright@@ -12,17 +12,19 @@ --     * 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.+-- 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 

@@ -1,9 +1,9 @@--- Copyright (c) 2009-2010, ERICSSON AB--- All rights reserved. --+-- Copyright (c) 2009-2010, ERICSSON AB All rights reserved.+--  -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are met:---+--  --     * Redistributions of source code must retain the above copyright notice, --       this list of conditions and the following disclaimer. --     * Redistributions in binary form must reproduce the above copyright@@ -12,17 +12,19 @@ --     * 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.+-- 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 (doubly-nested parallel vectors). All operations in -- this module assume rectangular matrices.@@ -66,27 +68,32 @@   +-- | Constructing a matrix from an index function.+--+-- @indexedMat m n ixf@:+--+--   * @m@ is the number of rows.+--+--   * @n@ is the number of columns.+--+--   * @ifx@ is a function mapping indexes to elements (first argument is row+--     index; second argument is column index).+indexedMat ::+    Data Int -> Data Int -> (Data Int -> Data Int -> Data a) -> Matrix a++indexedMat m n idx = indexed m $ \k -> indexed n $ \l -> idx k l+++ -- | Transpose of a matrix transpose :: Matrix a -> Matrix a-transpose a = Indexed (length $ head a) ixf-  where-    ixf y = Indexed (length a) $ \x -> a ! x ! y+transpose a = indexedMat (length $ head a) (length a) $ \y x -> a ! x ! y   -- XXX This assumes that (head a) can be used even if a is empty. Might this   --     violate size constraints on the index?   --     See the conditional in 'flatten'. -  -- XXX Should be written using indexMat.  ---- | Matrix multiplication-mul :: Numeric a => Matrix a -> Matrix a -> Matrix a-mul a b = map (\aRow -> map (scalarProd aRow) b') a-  where-    b' = transpose b--- -- | Concatenates the rows of a matrix. flatten :: Matrix a -> Vector (Data a) flatten matr = Indexed (m*n) ixf@@ -107,4 +114,105 @@ -- would require some overhead). diagonal :: Matrix a -> Vector (Data a) diagonal m = zipWith (!) m (0 ... (length m - 1))++++distributeL :: (a -> b -> c) -> a -> Vector b -> Vector c+distributeL f = map . f++distributeR :: (a -> b -> c) -> Vector a -> b -> Vector c+distributeR = flip . distributeL . flip++{-# DEPRECATED mul "Please use `(**)` instead." #-}+-- | Matrix multiplication+mul :: Numeric a => Matrix a -> Matrix a -> Matrix a+mul = (**)++++class Mul a b+  where+    type Prod a b++    -- | General multiplication operator+    (**) :: a -> b -> Prod a b+      -- XXX This symbol should probably be used for exponentiation instead.++instance Numeric a => Mul (Data a) (Data a)+  where+    type Prod (Data a) (Data a) = Data a+    (**) = (*)++instance Numeric a => Mul (Data a) (DVector a)+  where+    type Prod (Data a) (DVector a) = DVector a+    (**) = distributeL (**)++instance Numeric a => Mul (DVector a) (Data a)+  where+    type Prod (DVector a) (Data a) = DVector a+    (**) = distributeR (**)++instance Numeric a => Mul (Data a) (Matrix a)+  where+    type Prod (Data a) (Matrix a) = Matrix a+    (**) = distributeL (**)++instance Numeric a => Mul (Matrix a) (Data a)+  where+    type Prod (Matrix a) (Data a) = Matrix a+    (**) = distributeR (**)++instance Numeric a => Mul (DVector a) (DVector a)+  where+    type Prod (DVector a) (DVector a) = Data a+    (**) = scalarProd++instance Numeric a => Mul (DVector a) (Matrix a)+  where+    type Prod (DVector a) (Matrix a) = (DVector a)+    vec ** mat = distributeL (**) vec (transpose mat)++instance Numeric a => Mul (Matrix a) (DVector a)+  where+    type Prod (Matrix a) (DVector a) = (DVector a)+    (**) = distributeR (**)++instance Numeric a => Mul (Matrix a) (Matrix a)+  where+    type Prod (Matrix a) (Matrix a) = (Matrix a)+    a ** b = distributeR (**) a (transpose b)++++class ElemWise a+  where+    type Elem a++    -- | Operator for general element-wise multiplication+    elemWise :: (Elem a -> Elem a -> Elem a) -> a -> a -> a++instance ElemWise (Data a)+  where+    type Elem (Data a) = Data a+    elemWise = id++instance ElemWise (DVector a)+  where+    type Elem (DVector a) = Data a+    elemWise = zipWith++instance ElemWise (Matrix a)+  where+    type Elem (Matrix a) = Data a+    elemWise = elemWise . elemWise++(.+) :: (ElemWise a, Numeric (Elem a)) => a -> a -> a+(.+) = elemWise (+)++(.-) :: (ElemWise a, Numeric (Elem a)) => a -> a -> a+(.-) = elemWise (-)++(.*) :: (ElemWise a, Numeric (Elem a)) => a -> a -> a+(.*) = elemWise (*) 

@@ -1,9 +1,9 @@--- Copyright (c) 2009-2010, ERICSSON AB--- All rights reserved. --+-- Copyright (c) 2009-2010, ERICSSON AB All rights reserved.+--  -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are met:---+--  --     * Redistributions of source code must retain the above copyright notice, --       this list of conditions and the following disclaimer. --     * Redistributions in binary form must reproduce the above copyright@@ -12,17 +12,19 @@ --     * 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.+-- 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.@@ -34,11 +36,15 @@   import Prelude hiding-  ( (==), (/=)+  ( Eq+  , (==), (/=)+  , Ord   , (<), (>), (<=), (>=)   , not, (&&), (||)   , min, max-  , (^)+  , (^), (**)+  , Integral+  , quot, rem   , div, mod   , (>>)   , maximum, minimum

@@ -1,9 +1,9 @@--- Copyright (c) 2009-2010, ERICSSON AB--- All rights reserved. --+-- Copyright (c) 2009-2010, ERICSSON AB All rights reserved.+--  -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are met:---+--  --     * Redistributions of source code must retain the above copyright notice, --       this list of conditions and the following disclaimer. --     * Redistributions in binary form must reproduce the above copyright@@ -12,17 +12,19 @@ --     * 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.+-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+-- ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS+-- BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY,+-- OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+-- SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+-- INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+-- CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+-- ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF+-- THE POSSIBILITY OF SUCH DAMAGE.+--  {-# LANGUAGE NoMonomorphismRestriction #-} @@ -35,8 +37,12 @@ import Control.Monad import Data.Maybe import Data.Monoid-import Test.QuickCheck-+import Data.Bits+import Data.Word+import Test.QuickCheck hiding ((.&.))+import qualified Test.QuickCheck as QC+import System.Random -- Should maybe be exported from QuickCheck+import Text.Printf   data Ord a => Range a = Range@@ -64,8 +70,11 @@      abs = rangeOp abs'       where-        abs' (Range l u) =-          Range (Just 0) (liftM2 max (liftM abs l) (liftM abs u))+        abs' r@(Range l u)+            | isNatural  r = r+            | isNegative r = Range (liftM abs u) (liftM abs l)+            | otherwise    = +                Range (Just 0) (liftM2 max (liftM abs l) (liftM abs u))      signum = rangeOp sign       where@@ -234,6 +243,225 @@ rangeLessEq (Range _ (Just u1)) (Range (Just l2) _) = u1 <= l2 rangeLessEq _ _                                     = False +-- | @rangeAddUnsigned@ correctly and accurately propagates range+-- information through an unsigned addition. Code is borrowed from+-- Hacker's Delight.+rangeAddUnsigned :: (Ord a, Num a, Bounded a) => Range a -> Range a -> Range a+rangeAddUnsigned = +    rangeProp2 $ \a b c d -> +        if a + c >= a && b + d < b +        then fullRange+        else range (a + c) (b + d)+       +-- | @rangeAddSigned@ correctly and accurately propagates range+-- information through a signed addition. Code is borrowed from+-- Hacker's Delight.+rangeAddSigned :: (Ord a, Num a, Bounded a, Bits a) => +                  Range a -> Range a -> Range a+rangeAddSigned = +    rangeProp2 $ \a b c d -> +        let s = a + c+            t = b + d+            u = a .&. c .&. complement s .&. +                complement (b .&. d .&. complement t)+            v = ((xor a c) .|. complement (xor a s)) .&. +                (complement b .&. complement d .&. t)+        in if (u .|. v) < 0 +           then fullRange+           else range s t++-- | @rangeSubUnsigned@ propagates range information through unsigned+--   subtraction. Code is borrowed from Hacker's Delight+rangeSubUnsigned :: (Ord a, Num a, Bounded a) => Range a -> Range a -> Range a+rangeSubUnsigned = +    rangeProp2 $ \a b c d -> +        let s = a - d+            t = b - c+        in if s > a && t <= b+           then fullRange+           else range s t++-- | Propagates range information through unsigned negation. Code from+--   Hacker's Delight+rangeNegUnsigned :: (Ord a, Num a, Bounded a) => Range a -> Range a+rangeNegUnsigned = +    rangeProp1 $ \a b -> +        if a == 0 && b /= 0+        then fullRange+        else range (-b) (-a)++-- | Propagates range information through signed negation. Code from+--   Hacker's Delight.+rangeNegSigned :: (Ord a, Num a, Bounded a) => Range a -> Range a+rangeNegSigned = +    rangeProp1 $ \a b -> +        if a == minBound && b == minBound +        then singletonRange minBound+        else if a == minBound+             then fullRange+             else range (-b) (-a)++-- | Cheap and inaccurate range propagation for '.|.' on unsigned numbers.+-- Code from Hacker's Delight+rangeOrUnsignedCheap :: (Ord a, Num a, Bounded a) => +                        Range a -> Range a -> Range a+rangeOrUnsignedCheap = +    rangeProp2 $ \a b c d -> range (max a c) (maxPlus b d)++maxPlus b d = if sum < b then maxBound+              else sum+  where sum = b + d++-- | Accurate lower bound for '.|.' on unsigned numbers.+minOrUnsigned :: (Ord a, Num a, Bits a) => a -> a -> a -> a -> a+minOrUnsigned a b c d = loop (bit (bitSize a - 1))+  where loop 0 = a .|. c+        loop m +            | complement a .&. c .&. m > 0 = +                let temp = (a .|. m) .&. negate m+                in if temp <= b +                   then temp .|. c+                   else loop (shiftR m 1)+            | a .&. complement c .&. m > 0=+                let temp = (c .|. m) .&. negate m+                in if temp <= d+                   then a .|. temp+                   else loop (shiftR m 1)+            | otherwise = loop (shiftR m 1)++-- | Accurate upper bound for '.|.' on unsigned numbers.+maxOrUnsigned :: (Ord a, Num a, Bits a) => a -> a -> a -> a -> a+maxOrUnsigned a b c d= loop (bit (bitSize a - 1))+  where loop 0 = b .|. d+        loop m+             | b .&. d .&. m > 0 =+                 let temp = (b - m) .|. (m - 1)+                 in if temp >= a+                    then temp .|. d+                    else let temp = (d - m) .|. (m - 1)+                         in if temp >= c+                            then b .|. temp+                            else loop (shiftR m 1)+             | otherwise = loop (shiftR m 1)++rangeOrUnsignedAccurate :: (Ord a, Num a, Bits a, Bounded a) =>+                            Range a -> Range a -> Range a+rangeOrUnsignedAccurate = +    rangeProp2 $ \a b c d -> +        range (minOrUnsigned a b c d) (maxOrUnsigned a b c d)++-- | Cheap and inaccurate range propagation for '.&.' on unsigned numbers.+-- Code from Hacker's Delight+rangeAndUnsignedCheap :: (Ord a, Num a, Bounded a) => +                         Range a -> Range a -> Range a+rangeAndUnsignedCheap = rangeProp2 $ \a b c d -> range 0 (min b d)++-- | Range propagation for 'xor' on unsigned numbers.+-- Code from Hacker's Delight+rangeXorUnsigned :: (Ord a, Num a, Bounded a) => Range a -> Range a -> Range a+rangeXorUnsigned = rangeProp2 (\a b c d -> range 0 (maxPlus b d))++-- | Auxiliary function for writing range propagation+-- functions. Especially suitable for the code borrowed from Hacker's+-- Delight.+rangeProp1 :: (Ord a, Bounded a) => (a -> a -> Range a) -> Range a -> Range a+rangeProp1 f (Range l u) = f a b+  where toUpper Nothing  = maxBound+        toUpper (Just u) = u+        toLower Nothing  = minBound+        toLower (Just l) = l+        a = toLower l+        b = toUpper u++-- | Auxiliary function for writing range propagation functions for+-- two argument functions. Especially suitable for the code borrowed+-- from Hacker's Delight.+rangeProp2 :: (Ord a, Bounded a) => +              (a -> a -> a -> a -> Range a) -> Range a -> Range a -> Range a+rangeProp2 f (Range l1 u1) (Range l2 u2) =+    f a b c d+  where toUpper Nothing  = maxBound+        toUpper (Just u) = u+        toLower Nothing  = minBound+        toLower (Just l) = l+        a = toLower l1+        b = toUpper u1+        c = toLower l2+        d = toUpper u2++-- | Propagates range information through @max@.+rangeMax :: Ord a => Range a -> Range a -> Range a+rangeMax r1 r2+    | isEmpty r1 = r2+    | isEmpty r2 = r1+rangeMax r1 r2+    | r1 `rangeLess` r2 = r2+    | r2 `rangeLess` r1 = r1+rangeMax (Range (Just l1) u1) (Range (Just l2) u2) +    | l1 < l2   = Range (Just l2) (liftM2 max u1 u2)+    | otherwise = Range (Just l1) (liftM2 max u1 u2)+rangeMax (Range Nothing u1) (Range (Just l2) u2)+    = Range (Just l2) (liftM2 max u1 u2)+rangeMax (Range (Just l1) u1) (Range Nothing u2)+    = Range (Just l1) (liftM2 max u1 u2)+rangeMax (Range Nothing u1) (Range Nothing u2)+    = Range Nothing (liftM2 max u1 u2)++-- | Analogous to 'rangeMax'+rangeMin :: Ord a => Range a -> Range a -> Range a+rangeMin r1 r2+    | isEmpty r1 = r2+    | isEmpty r2 = r1+rangeMin r1 r2+    | r1 `rangeLess` r2 = r1+    | r2 `rangeLess` r1 = r2+rangeMin (Range l1 (Just u1)) (Range l2 (Just u2))+    | u1 < u2   = Range (liftM2 min l1 l2) (Just u1)+    | otherwise = Range (liftM2 min l1 l2) (Just u2)+rangeMin (Range l1 Nothing) (Range l2 (Just u2))+    = Range (liftM2 min l1 l2) (Just u2)+rangeMin (Range l1 (Just u1)) (Range l2 Nothing)+    = Range (liftM2 min l1 l2) (Just u1)+rangeMin (Range l1 Nothing) (Range l2 Nothing)+    = Range (liftM2 min l1 l2) Nothing++-- | Propagates range information through 'mod'.+-- Note that we assume Haskell semantics for 'mod'.+rangeMod :: (Num a, Ord a, Enum a) => Range a -> Range a -> Range a+rangeMod d r+    | d `rangeLess` r && isNatural r && isNatural d = d+    | isNatural r  = Range (Just 0) (fmap pred (upperBound r))+    | r `rangeLess` d && isNegative r && isNegative d = d+    | isNegative r = Range (fmap succ (lowerBound r)) (Just 0)+    where +      isNegative = (`isSubRangeOf` negativeRange)+      negativeRange = Range Nothing (Just 0)+rangeMod d (Range l u)+    = Range (fmap succ l) (fmap pred u)++-- | Propagates range information through 'rem'.+-- Note that we assume Haskell semantics for 'rem'.+rangeRem :: (Num a, Ord a, Enum a) => Range a -> Range a -> Range a+rangeRem d r+    | d `rangeLess` abs r && isNatural d = d+    | isNatural d  = Range (Just 0) (fmap pred (upperBound (abs r)))+    | abs d `rangeLess` abs r && isNegative d = d+    | isNegative d = Range (fmap negate (upperBound (abs r))) (Just 0)+    where+      isNegative = (`isSubRangeOf` negativeRange)+      negativeRange = Range Nothing (Just 0)+rangeRem d r@(Range l u)+    | l `betterThan` u = +        Range (fmap (succ . negate .abs) l) (fmap (pred . abs) l)+    | otherwise        = +        Range (fmap (succ . negate . abs) u) (fmap (pred . abs) upper)+  where lower = lowerBound r+        upper = upperBound r+        betterThan (Just a) (Just b) = abs a >= abs b+        betterThan Nothing  (Just b) = True+        betterThan (Just a) Nothing  = False+        betterThan Nothing  Nothing  = True+ showBound :: Show a => Maybe a -> String showBound (Just a) = show a showBound _        = "*"@@ -248,8 +476,6 @@  instance (Arbitrary a, Ord a, Num a) => Arbitrary (Range a)   where-    coarbitrary = error "coarbitrary not defined for (Range a)"-     arbitrary = do         lower <- arbitrary         size  <- liftM abs arbitrary@@ -258,20 +484,27 @@       where         arbMaybe a = frequency [(5, return (Just a)), (1, return Nothing)] -+instance Random Word32 where+  random g = (fromIntegral i,g')+   where (i :: Int,g') = random g+  randomR (l,u) g = (fromIntegral i,g')+    where (i :: Integer, g') = randomR (fromIntegral l,fromIntegral u) g -prop_arith1 :: (forall a . Num a => a -> a) -> Int -> Range Int -> Property-prop_arith1 op x r = (x `inRange` r) ==> (op x `inRange` op r)+instance Arbitrary Word32 where+  arbitrary = choose (0,maxBound)+  shrink i  = [i `div` 2, i `div` 2 - 1, i - 1] +prop_arith1 :: (forall a . Num a => a -> a) -> Range Int -> Property+prop_arith1 op r = +    not (isEmpty r) ==>+    forAll (fromRange r) $ \x ->+    op x `inRange` op r   prop_arith2     :: (forall a . Num a => a -> a -> a)-    -> Int -> Int -> Range Int -> Range Int -> Property--prop_arith2 op x y r1 r2 =-    (inRange x r1 && inRange y r2) ==> (op x y `inRange` op r1 r2)-+    -> Range Int -> Range Int -> Property+prop_arith2 op r1 r2 = rangePropagationSafety op op r1 r2   prop_fromInteger = isSingleton . fromInteger@@ -283,6 +516,21 @@ prop_abs  = prop_arith1 abs prop_sign = prop_arith1 signum +prop_addU = rangePropagationSafety ((+) :: Word32 -> Word32 -> Word32) +                                   rangeAddUnsigned+prop_addS = rangePropagationSafety ((+) :: Int -> Int -> Int)+                                   rangeAddSigned+prop_subU = rangePropagationSafety ((-) :: Word32 -> Word32 -> Word32)+                                   rangeSubUnsigned+prop_negU = rangePropSafety1 (negate :: Word32 -> Word32) rangeNegUnsigned+prop_negS = rangePropSafety1 (negate :: Int -> Int) rangeNegSigned+prop_andUCheap = rangePropagationSafety ((.&.) :: Word32 -> Word32 -> Word32) +                                        rangeAndUnsignedCheap+prop_orUCheap = rangePropagationSafety ((.|.) :: Word32 -> Word32 -> Word32)+                                       rangeOrUnsignedCheap+prop_xorU = rangePropagationSafety (xor :: Word32 -> Word32 -> Word32)+                                   rangeXorUnsigned+ prop_abs2 (r::Range Int) = isNatural (abs r)  prop_empty = isEmpty (emptyRange :: Range Int)@@ -344,6 +592,8 @@  prop_intersect3 (r1::Range Int) (r2::Range Int) = (r1/\r2) `isSubRangeOf` r1 prop_intersect4 (r1::Range Int) (r2::Range Int) = (r1/\r2) `isSubRangeOf` r2+prop_intersect5 (r1::Range Int) (r2::Range Int) =+    isEmpty r1 || isEmpty r2 ==> isEmpty (r1/\r2)  prop_disjoint x (r1::Range Int) (r2::Range Int) =     disjoint r1 r2 ==> (x `inRange` r1) ==> not (x `inRange` r2)@@ -351,53 +601,207 @@ prop_rangeLess1 (r1::Range Int) (r2::Range Int) =     rangeLess r1 r2 ==> disjoint r1 r2 -prop_rangeLess2 x y (r1::Range Int) (r2::Range Int) =-    (rangeLess r1 r2 && inRange x r1 && inRange y r2) ==> x < y+prop_rangeLess2 (r1::Range Int) (r2::Range Int) =+    not (isEmpty r1) && not (isEmpty r2) ==>+    forAll (fromRange r1) $ \x ->+    forAll (fromRange r2) $ \y ->+    rangeLess r1 r2 ==> x < y -prop_rangeLessEq x y (r1::Range Int) (r2::Range Int) =-    (rangeLessEq r1 r2 && inRange x r1 && inRange y r2) ==> x <= y+prop_rangeLessEq (r1::Range Int) (r2::Range Int) =+    not (isEmpty r1) && not (isEmpty r2) ==>+    forAll (fromRange r1) $ \x ->+    forAll (fromRange r2) $ \y ->+    rangeLessEq r1 r2 ==> x <= y +prop_rangeMax1 (r1::Range Int) = rangeMax r1 r1 == r1 +prop_rangeMax2 (r1::Range Int) r2 =+    not (isEmpty r1) && not (isEmpty r2) ==>+    upperBound r1 <= upperBound max && upperBound r2 <= upperBound max+    where +      max = rangeMax r1 r2+      Nothing <= Nothing = True+      Just _  <= Nothing = True+      Just a  <= Just b  = a Prelude.<= b+      _       <= _       = False +prop_rangeMax3 (r1::Range Int) r2 =+    not (isEmpty r1) && not (isEmpty r2) ==> +  lowerBound (rangeMax r1 r2) == liftMaybe2 max (lowerBound r1) (lowerBound r2)++prop_rangeMax4 (r1::Range Int) r2 = +    not (isEmpty r1) && not (isEmpty r2) ==>+    rangeMax r1 r2 == rangeMax r2 r1++prop_rangeMax5 (r1::Range Int) r2 = +    (isEmpty r1 && not (isEmpty r2) ==>+    rangeMax r1 r2 == r2)+    QC..&.+    (isEmpty r2 && not (isEmpty r1) ==>+    rangeMax r1 r2 == r1)++prop_rangeMax6 (v1::Int) v2 = +    max v1 v2 `inRange` rangeMax (singletonRange v1) (singletonRange v2)++prop_rangeMax7 (r1::Range Int) r2 = +    rangePropagationSafety max rangeMax r1 r2++prop_rangeMin1 (r1::Range Int) = rangeMin r1 r1 == r1++prop_rangeMin2 (r1::Range Int) r2 =+    not (isEmpty r1) && not (isEmpty r2) ==>+    lowerBound min <= lowerBound r1 && lowerBound min <= lowerBound r2+    where +      min = rangeMin r1 r2+      Nothing <= Nothing = True+      Nothing <= Just _  = True+      Just a  <= Just b  = a Prelude.<= b+      _       <= _       = False++prop_rangeMin3 (r1::Range Int) r2 =+    not (isEmpty r1) && not (isEmpty r2) ==> +  upperBound (rangeMin r1 r2) == liftMaybe2 min (upperBound r1) (upperBound r2)++prop_rangeMin4 (r1::Range Int) r2 = +    not (isEmpty r1) && not (isEmpty r2) ==>+    rangeMin r1 r2 == rangeMin r2 r1++prop_rangeMin5 (r1::Range Int) r2 = +    (isEmpty r1 && not (isEmpty r2) ==>+    rangeMin r1 r2 == r2)+    QC..&.+    (isEmpty r2 && not (isEmpty r1) ==>+    rangeMin r1 r2 == r1)++prop_rangeMin6 (v1::Int) v2 = +    min v1 v2 `inRange` rangeMin (singletonRange v1) (singletonRange v2)++prop_rangeMin7 (r1::Range Int) r2 = +    rangePropagationSafety min rangeMin r1 r2++prop_rangeMod1 (v1::Int) v2 =+    v2 /= 0 ==>+    mod v1 v2 `inRange` rangeMod (singletonRange v1) (singletonRange v2)++prop_rangeMod2 = +    rangePropagationSafetyPre mod rangeMod (\v1 (v2::Int) -> v2 /= 0)++prop_rangeRem  = +    rangePropagationSafetyPre rem rangeRem (\v1 (v2::Int) -> v2 /= 0)++-- This function is useful for range propagation functions like+-- rangeMax, rangeMod etc. +-- It takes two ranges, picks an element out of either ranges and+-- checks if applying the operation to the individual elements is in+-- the resulting range after range propagation +-- The third argument is a precondition that is satisfied before the test is run+rangePropagationSafetyPre :: (Random a, Ord a, Show a, Bounded a,+                              Random b, Ord b, Show b, Bounded b,+                              Ord c) =>+    (a -> b -> c) -> (Range a -> Range b -> Range c) -> +    (a -> b -> Bool) ->+    Range a -> Range b -> Property+rangePropagationSafetyPre op rop pre r1 r2 =+    not (isEmpty r1) && not (isEmpty r2) ==>+    forAll (fromRange r1) $ \v1 ->+    forAll (fromRange r2) $ \v2 ->+        pre v1 v2 ==>+        op v1 v2 `inRange` rop r1 r2++rangePropagationSafety op rop r1 r2 = +    rangePropagationSafetyPre op rop noPre r1 r2++noPre _ _ = True++rangePropSafety1 :: (Ord a, Show a, Random a, Bounded a, Ord b) => +                    (a -> b) -> (Range a -> Range b) -> Range a -> Property+rangePropSafety1 op rop ran = +    not (isEmpty ran) ==>+    forAll (fromRange ran) $ \val ->+        op val `inRange` rop ran++lowBound,uppBound :: (Bounded a, Ord a) => Range a -> a+lowBound r | Just l <- lowerBound r = l+lowBound r = minBound+uppBound r | Just u <- upperBound r = u+uppBound r = maxBound++fromRange :: (Random a, Bounded a, Ord a) => Range a -> Gen a+fromRange r = choose (lowBound r,uppBound r)+ testAll = do-    myCheck prop_neg-    myCheck prop_add-    myCheck prop_sub-    myCheck prop_mul-    myCheck prop_abs-    myCheck prop_sign-    myCheck prop_abs2-    myCheck prop_fromInteger-    myCheck prop_empty-    myCheck prop_full-    myCheck prop_isEmpty1-    myCheck prop_isEmpty2-    myCheck prop_isFull-    myCheck prop_fullRange-    myCheck prop_range+    -- This one is wrong but QuickCheck doesn't spot it+    myCheck "prop_neg"             prop_neg++    myCheck "prop_negU"            prop_negU+    myCheck "prop_negS"            prop_negS++    -- These three suffer from overflow behaviour+    myCheck "prop_add"             prop_add+    myCheck "prop_sub"             prop_sub+    myCheck "prop_mul"             prop_mul++    myCheck "prop_addU"            prop_addU+    myCheck "prop_addS"            prop_addS+    myCheck "prop_subU"            prop_subU+    myCheck "prop_andUCheap"       prop_andUCheap+    myCheck "prop_orUCheap"        prop_orUCheap+    myCheck "prop_xorU"            prop_xorU++    myCheck "prop_abs"             prop_abs+    myCheck "prop_sign"            prop_sign+    myCheck "prop_abs2"            prop_abs2+    myCheck "prop_fromInteger"     prop_fromInteger+    myCheck "prop_empty"           prop_empty+    myCheck "prop_full"            prop_full+    myCheck "prop_isEmpty1"        prop_isEmpty1+    myCheck "prop_isEmpty2"        prop_isEmpty2+    myCheck "prop_isFull"          prop_isFull+    myCheck "prop_fullRange"       prop_fullRange+    myCheck "prop_range"           prop_range     -- myCheck prop_rangeByRange     -- XXX "Arguments exhausted after 0 test"     --     Something must be wrong with generator...-    myCheck prop_singletonRange1-    myCheck prop_singletonRange2-    myCheck prop_singletonSize-    myCheck prop_subRange-    myCheck prop_emptySubRange1-    myCheck prop_emptySubRange2-    myCheck prop_isNegative-    myCheck prop_rangeGap-    myCheck prop_union1-    myCheck prop_union2-    myCheck prop_union3-    myCheck prop_union4-    myCheck prop_intersect1-    myCheck prop_intersect2-    myCheck prop_intersect3-    myCheck prop_intersect4-    myCheck prop_disjoint-    myCheck prop_rangeLess1-    myCheck prop_rangeLess2-    myCheck prop_rangeLessEq+    myCheck "prop_singletonRange1" prop_singletonRange1+    myCheck "prop_singletonRange2" prop_singletonRange2+    myCheck "prop_singletonSize"   prop_singletonSize+    myCheck "prop_subRange"        prop_subRange+    myCheck "prop_emptySubRange1"  prop_emptySubRange1+    myCheck "prop_emptySubRange2"  prop_emptySubRange2+    myCheck "prop_isNegative"      prop_isNegative+    myCheck "prop_rangeGap"        prop_rangeGap+    myCheck "prop_union1"          prop_union1+    myCheck "prop_union2"          prop_union2+    myCheck "prop_union3"          prop_union3+    myCheck "prop_union4"          prop_union4+    myCheck "prop_intersect1"      prop_intersect1+    myCheck "prop_intersect2"      prop_intersect2+    myCheck "prop_intersect3"      prop_intersect3+    myCheck "prop_intersect4"      prop_intersect4+    myCheck "prop_intersect5"      prop_intersect5+    myCheck "prop_disjoint"        prop_disjoint+    myCheck "prop_rangeLess1"      prop_rangeLess1+    myCheck "prop_rangeLess2"      prop_rangeLess2+    myCheck "prop_rangeLessEq"     prop_rangeLessEq+    myCheck "prop_rangeMax1"       prop_rangeMax1+    myCheck "prop_rangeMax2"       prop_rangeMax2+    myCheck "prop_rangeMax3"       prop_rangeMax3+    myCheck "prop_rangeMax4"       prop_rangeMax4+    myCheck "prop_rangeMax5"       prop_rangeMax5+    myCheck "prop_rangeMax6"       prop_rangeMax6+    myCheck "prop_rangeMax7"       prop_rangeMax7+    myCheck "prop_rangeMin1"       prop_rangeMin1+    myCheck "prop_rangeMin2"       prop_rangeMin2+    myCheck "prop_rangeMin3"       prop_rangeMin3+    myCheck "prop_rangeMin4"       prop_rangeMin4+    myCheck "prop_rangeMin5"       prop_rangeMin5+    myCheck "prop_rangeMin6"       prop_rangeMin6+    myCheck "prop_rangeMin7"       prop_rangeMin7+    myCheck "prop_rangeMod1"       prop_rangeMod1+    myCheck "prop_rangeMod2"       prop_rangeMod2+    myCheck "prop_rangeRem"        prop_rangeRem   where-    myCheck = check defaultConfig {configMaxFail = 100000}+    myCheck name test = +        do printf "%-25s" name+           quickCheckWith stdArgs {maxDiscard = 10000} test 

@@ -0,0 +1,440 @@+--+-- Copyright (c) 2009-2010, ERICSSON AB All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are met:+-- +--     * Redistributions of source code must retain the above copyright notice,+--       this list of conditions and the following disclaimer.+--     * Redistributions in binary form must reproduce the above copyright+--       notice, this list of conditions and the following disclaimer in the+--       documentation and/or other materials provided with the distribution.+--     * Neither the name of the ERICSSON AB nor the names of its contributors+--       may be used to endorse or promote products derived from this software+--       without specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+-- ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS+-- BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY,+-- OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+-- SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+-- INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+-- CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+-- ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF+-- THE POSSIBILITY OF SUCH DAMAGE.+--++module Feldspar.Stream +    (Stream+    ,head+    ,tail+    ,map+    ,intersperse+    ,interleave+    ,scan+    ,mapAccum+    ,iterate+    ,repeat+    ,unfold+    ,drop+    ,dropWhile+    ,filter+    ,partition+    ,zip+    ,zipWith+    ,unzip+    ,take+    ,splitAt+    ,cycle+    ,recurrence+    ,recurrenceI+    ,iir+    ,fir+    )+    where++import Feldspar.Core+import qualified Prelude+import Feldspar.Range+import Feldspar.Prelude hiding (filter,repeat,iterate,cycle)+import Control.Arrow++import Feldspar.Vector (Vector, DVector+                       ,vector+                       ,freezeVector,indexed+                       ,sum,length,replicate)++-- | Infinite streams.+data Stream a = forall state . (Computable a, Computable state) =>+                Stream (StepFunction state a) state++data StepFunction state a +    = Continuous (state -> (a,state))+    | Stuttering (state -> (a,Data Bool, state))++-- When we want to treat a step function as if it was continuous.+-- Use with care! It introduces an extra while loop if the +-- argument is stuttering+step :: (Computable state, Computable a) =>+        StepFunction state a -> (state -> (a,state))+step (Continuous next) init = next init+step (Stuttering next) init = (a,st)+    where (a,_,st) = while (not . snd3) (next . thd3) (next init)++-- When we cannot optimize for the continuous case we can use this function+-- to consider all step functions as stuttering and reduce the amount of+-- code we have to write.+stuttering :: StepFunction state a -> (state -> (a, Data Bool, state))+stuttering (Stuttering next) = next+stuttering (Continuous next) = \state -> let (a,st) = next state+                                         in (a,true,st)++-- This helper function enables us to write function using the stuttering +-- case only while still propagating the continuous information.+-- Helps writing less code.+mapStep :: ((stateA -> (a,Data Bool, stateA)) -> +                (stateB -> (b,Data Bool, stateB))) +        -> StepFunction stateA a -> StepFunction stateB b+mapStep mkStep (Stuttering next) = Stuttering (mkStep next)+mapStep mkStep (Continuous next) = Continuous newStep+  where newStep a = let (b,_,st) = mkStep (\a -> let (b,st) = next a+                                                 in (b,true,st)) a+                    in (b,st)++-- Helper functions for working on triplets+fst3 (a,_,_) = a+snd3 (_,b,_) = b+thd3 (_,_,c) = c+first3  f (a,b,c) = (f a,b,c)+second3 f (a,b,c) = (a,f b,c)+third3  f (a,b,c) = (a,b,f c)++-- | Take the first element of a stream+head :: Computable a => Stream a -> a+head (Stream next init) = fst $ step next init++-- | Drop the first element of a stream+tail :: Computable a => Stream a -> Stream a+tail (Stream next init) = Stream next (snd $ step next init)++-- | 'map f str' transforms every element of the stream 'str' using the+--   function 'f'+map :: (Computable a, Computable b) =>+       (a -> b) -> Stream a -> Stream b+map f (Stream next init) = Stream (mapStep (first3 f .) next) init++-- | 'intersperse a str' inserts an 'a' between each element of the stream+--    'str'.+intersperse :: a -> Stream a -> Stream a+intersperse a (Stream next init) = +    Stream (mapStep newNext next) (true,init)+  where newNext next (b,st) = b ? (let (e,isValid,st') = next st+                                   in isValid ? ( (e,true,(false,st'))+                                                , (e,false,(true,st'))+                                                )+                                  ,(a,true,(true,st))+                                  )++-- | Create a new stream by alternating between the elements from +--   the two input streams+interleave :: Stream a -> Stream a -> Stream a+interleave (Stream (Continuous next1) init1) (Stream (Continuous next2) init2)+    = Stream (Continuous next) (true,init1,init2)+  where next (b,st1,st2) = b ? (let (a,st1') = next1 st1+                                in (a,(false,st1',st2))+                               ,let (a,st2') = next2 st2+                                in (a,(true,st1,st2'))+                               )+interleave (Stream next1 init1) (Stream next2 init2)+    = Stream (Stuttering next) (true,init1,init2)+  where next (b,st1,st2) = b ? (let (a,isValid,st1') = stuttering next1 st1+                                in isValid ? ( (a,true,(false,st1',st2))+                                             , (a,false,(true,st1',st2))+                                             )+                               ,let (a,isValid,st2') = stuttering next2 st2+                                in isValid ? ( (a,true,(true,st1,st2'))+                                             , (a,false,(false,st1,st2'))+                                             )+                               )++-- | 'scan f a str' produces a stream by successively applying 'f' to+--   each element of the input stream 'str' and the previous element of +--   the output stream.+scan :: Computable a => (a -> b -> a) -> a -> Stream b -> Stream a+scan f a (Stream next init)+    = Stream (mapStep newNext next) (a,init)+  where newNext next (acc,st) = let (a,isValid,st') = next st+                                in isValid ? ( (acc,true,  (f acc a,st') )+                                             , (acc,false, (acc,st')     )+                                             )++{- This function is problematic to define for the same reason the index+   function is problematic, plus that it has the same quirk as correctScan.+-}++-- | A scan but without an initial element.+scan1 :: Computable a => (a -> a -> a) -> Stream a -> Stream a+scan1 f (Stream next init)+    = Stream (mapStep newNext next) (a,true,newInit)+  where (a,newInit) = step next init+        newNext next (a,isFirst,st)+            = isFirst ? ( (a, true, (a,false,st))+                        , let (b,isValid,st') = next st+                          in isValid ? ( let elem = f a b+                                         in (elem, true, (elem,false,st'))+                                       , (a,false, (a,false,st'))+                                       )+                        )++-- mapAccum creates a nested loop. It's either that or recomputing the +-- function even for non-valid elements in the input stream.++-- | Maps a function over a stream using an accumulator.+mapAccum :: (Computable acc, Computable b) => +            (acc -> a -> (acc,b)) -> acc -> Stream a -> Stream b+mapAccum f acc (Stream next init)+    = Stream (Continuous newNext) (init,acc)+  where newNext (st,acc)+            = let (a,st')  = step next st+                  (acc',b) = f acc a+              in (b, (st',acc'))++-- | Iteratively applies a function to a starting element. All the successive+--   results are used to create a stream.+--+-- @iterate f a == [a, f a, f (f a), f (f (f a)) ...]@+iterate :: Computable a => (a -> a) -> a -> Stream a+iterate f init = Stream (Continuous next) init+  where next a = (a, f a)++-- | Repeat an element indefinitely.+--+-- @repeat a = [a, a, a, ...]@+repeat :: Computable a => a -> Stream a+repeat a = Stream (Continuous next) unit+  where next _ = (a,unit)++-- | @unfold f acc@ creates a new stream by successively applying 'f' to+--   to the accumulator 'acc'.+unfold :: (Computable a, Computable c) => (c -> (a,c)) -> c -> Stream a+unfold next init = Stream (Continuous next) init++-- | Drop a number of elements from the front of a stream+drop :: Data Unsigned32 -> Stream a -> Stream a+{- This version creates a conditional inside the loop+   The output stream is always stuttering+drop i (Stream next init) = Stream (Stuttering newNext) (i,init)+  where newNext (i,st) = i == 0 ? (let (a,isValid,st') = stuttering next st+                                   in isValid ? ( (a,true,  (0,st'))+                                                , (a,false, (0,st')) +                                                )+                                  ,let (a,isValid,st') = stuttering next st+                                   in isValid ? ( (a,false, (i-1,st'))+                                                , (a,false, (i,  st'))+                                                )+                                  )+-}+-- This version generates a while loop to compute the initial state+-- The output stream is continuous if the input stream is+drop i (Stream next init) = Stream next newState+  where (newState,_) = while cond body (init,i)+        cond (st,i)  = i > 0+        body (st,i)  = let (_,b,st') = stuttering next st+                       in b ? ( (st',i-1)+                              , (st',i))++-- | @dropWhile p str@ drops element from the stream @str@ as long as the+-- elements fulfill the predicate @p@.+dropWhile p (Stream next init) = Stream next newState+  where (_,newState) = while cond body (step next init)+        cond (a,st)  = p a+        body (_,st)  = step next st++-- | 'filter p str' removes elements from the stream 'str' if they are false+--   according to the predicate 'p'+filter :: (a -> Data Bool) -> Stream a -> Stream a+filter p (Stream next init) = Stream (Stuttering newNext) init+  where newNext st = let (a,isValid,st') = stuttering next st+                     in isValid && p a ? ( (a,true, st')+                                         , (a,false,st')+                                         )++-- | Splits a stream in two according to the predicate function. All +--   elements which return true go in the first stream, the rest go in the+--   second.+partition :: (a -> Data Bool) -> Stream a -> (Stream a, Stream a)+partition p stream = (filter p stream, filter (not . p) stream)++-- In the case that the input streams are stuttering this function+-- will introduce nested loops++-- | Pairs together two streams into one.+zip :: Stream a -> Stream b -> Stream (a,b)+zip (Stream next1 init1) (Stream next2 init2)+    = Stream (Continuous next) (init1,init2)+  where next (st1,st2) = ( (a,b), (st1',st2') )+            where (a,st1') = step next1 st1+                  (b,st2') = step next2 st2++-- This function can also potentially introduce nested loops, just like zip++-- | Pairs together two streams using a function to combine the +--   corresponding elements.+zipWith :: Computable c => (a -> b -> c) -> Stream a -> Stream b -> Stream c+zipWith f (Stream next1 init1) (Stream next2 init2)+    = Stream (Continuous next) (init1,init2)+  where next (st1,st2) = ( f a b, (st1',st2'))+            where (a,st1') = step next1 st1+                  (b,st2') = step next2 st2++-- | Given a stream of pairs, split it into two stream. +unzip :: (Computable a, Computable b) => Stream (a,b) -> (Stream a, Stream b)+unzip stream = (map fst stream, map snd stream)++instance RandomAccess (Stream a) where+  type Element (Stream a) = a+  (Stream next init) ! n = fst3 $ while ((/= 0) . thd3) body (a,st,n)+      where body (a,st,i) = let (a,isValid,st') = stuttering next st+                            in isValid ? ( (a,st',i-1)+                                         , (a,st',i)+                                         )+            (a,st) = step next init -- I would like to get rid of this one++-- | 'take n str' allocates 'n' elements from the stream 'str' into a+--   core array.+take :: Storable a => Data Int -> Stream (Data a) -> Data [a]+take n (Stream next init) +    = snd3 $ while cond body +      (0,array (mapMonotonic fromIntegral (dataSize n) :> universal) [],init)+  where cond (i,_  ,_ ) = i < n+        body (i,arr,st) = let (a,isValid,st') = stuttering next st+                          in isValid ? ( (i+1,setIx arr i a,st')+                                       , (i,  arr,          st')+                                       )++-- | 'splitAt n str' allocates 'n' elements from the stream 'str' into a +--   core array and returns the rest of the stream continuing from +--   element 'n+1'.+splitAt :: Storable a => +           Data Int -> Stream (Data a) -> (Data [a], Stream (Data a))+splitAt n (Stream next init) = (arr,Stream next st)+  where +    (_,arr,st) = +        while cond body +        (0,array (mapMonotonic fromIntegral (dataSize n) :> universal) [],init)+    cond (i,_  ,_ ) = i < n+    body (i,arr,st) = let (a,isValid,st') = stuttering next st+                      in isValid ? ( (i+1,setIx arr i a,st')+                                   , (i,  arr,          st')+                                   )++-- | Loops through a vector indefinitely to produce a stream.+cycle :: Computable a => Vector a -> Stream a+cycle vec = Stream (Continuous next) 0+  where next i = (vec ! i, (i + 1) `rem` length vec)+++-- | A combinator for descibing recurrence equations, or feedback loops.+--   It uses memory proportional to the input vector+--+-- For exaple one can define the fibonacci sequence as follows:+--+-- > fib = recurrence (vector [0,1]) (\fib -> fib 1 + fib 2)+--+-- The expressions @fib 1@ and @fib 2@ refer to previous elements in the +-- stream defined one step back and two steps back respectively.+recurrence :: Storable a => +              DVector a -> ((Int -> Data a) -> Data a) -> Stream (Data a)+recurrence init mkExpr = Stream (Continuous next) (buf,0)+  where buf            = freezeVector init+        len            = length init+        next (buf,ix)  = +            let a = mkExpr (\i -> getIx buf ((value i + ix) `rem` len))+            in (getIx buf (ix `rem` len), (setIx buf (ix `rem` len) a, ix + 1))++-- | A recurrence combinator with input+--+-- The sliding average of a stream can easily be implemented using+-- 'recurrenceI'.+--+-- > slidingAvg :: Data Int -> Stream (Data Int) -> Stream (Data Int)+-- > slidingAvg n str = recurrenceI (replicate n 0) str (vector [])+-- >                    (\input _ -> sum (indexed n input) `quot` n)+recurrenceI :: (Storable a, Storable b) => +               DVector a -> Stream (Data a) -> DVector b ->+               ((Data Int -> Data a) -> (Data Int -> Data b) -> Data b) ->+               Stream (Data b)+recurrenceI ii (Stream (Continuous st) s) io mkExpr +    = Stream (Continuous step) (ibuf,obuf,s,0)+  where ibuf = freezeVector ii+        obuf = freezeVector io+        p    = length ii+        q    = length io+        step (ibuf,obuf,s,ix) = +            let (a,s') = st s+                ibuf'  = p /= 0 ? (setIx ibuf (ix `rem` p) a, ibuf)+                b = mkExpr (\i -> getIx ibuf' ((i + ix)     `rem` p))+                           (\i -> getIx obuf  ((i + ix - 1) `rem` q))+            in (q /= 0 ? (getIx obuf (ix `rem` q),b), +                          (ibuf'+                          ,q /= 0 ? (setIx obuf (ix `rem` q) b,obuf)+                          ,s'+                          ,ix + 1))+recurrenceI ii (Stream (Stuttering st) s) io mkExpr+    = Stream (Stuttering step) (ibuf,obuf,s,0)+  where ibuf = freezeVector ii+        obuf = freezeVector io+        p    = length ii+        q    = length io+        step (ibuf,obuf,s,ix) = +            let (a,isValid,s') = st s+                ibuf'  = p /= 0 ? (setIx ibuf (ix `rem` p) a,ibuf)+                b = mkExpr (\i -> getIx ibuf' ((i + ix)     `rem` p))+                           (\i -> getIx obuf  ((i + ix - 1) `rem` q))+            in isValid ?( (q /= 0 ? (getIx obuf (ix `rem` q), b), true,+                                     (ibuf'+                                     ,q /= 0 ? (setIx obuf (ix `rem` q) b,obuf)+                                     ,s'+                                     ,ix + 1))+                        , (q /= 0 ? (getIx obuf (ix `rem` q),b), false,+                                     (ibuf+                                     ,obuf+                                     ,s'+                                     ,ix))+                        )++slidingAvg :: Data Int -> Stream (Data Int) -> Stream (Data Int)+slidingAvg n str = recurrenceI (replicate n 0) str (vector [])+                   (\input _ -> sum (indexed n input) `quot` n)++-- | A fir filter on streams+fir :: DVector Float -> +       Stream (Data Float) -> Stream (Data Float)+fir b input = +    recurrenceI (replicate n 0) input+                (vector [])+                (\input _ -> sum (indexed n (\i -> b!i * input!(n-i))))+  where n = length b++-- | An iir filter on streams+iir :: Data Float -> DVector Float -> DVector Float -> +       Stream (Data Float) -> Stream (Data Float)+iir a0 a b input = +    recurrenceI (replicate q 0) input +                (replicate p 0)+      (\input output -> 1 / a0 * +                        ( sum (indexed p (\i -> b!i *  input!(p-i)))+                        - sum (indexed q (\j -> a!j * output!(q-j))))+      )+  where p = length b+        q = length a++-- A nice instance to have when using the recurrence functions.+instance RandomAccess (Data Int -> Data a) where+  type Element (Data Int -> Data a) = Data a+  (!) = ($)++-- Function to be used with filter for debuggin purposes+even n = n `rem` 2 == 0

@@ -1,9 +1,9 @@--- Copyright (c) 2009-2010, ERICSSON AB--- All rights reserved. --+-- Copyright (c) 2009-2010, ERICSSON AB All rights reserved.+--  -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are met:---+--  --     * Redistributions of source code must retain the above copyright notice, --       this list of conditions and the following disclaimer. --     * Redistributions in binary form must reproduce the above copyright@@ -12,17 +12,19 @@ --     * 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.+-- 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 

@@ -1,9 +1,9 @@--- Copyright (c) 2009-2010, ERICSSON AB--- All rights reserved. --+-- Copyright (c) 2009-2010, ERICSSON AB All rights reserved.+--  -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are met:---+--  --     * Redistributions of source code must retain the above copyright notice, --       this list of conditions and the following disclaimer. --     * Redistributions in binary form must reproduce the above copyright@@ -12,17 +12,19 @@ --     * 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.+-- 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@@ -38,25 +40,17 @@ -- symbolic vectors can be used quite seamlessly with the interface in -- "Feldspar.Core". ----- Note that the only operations in this module that introduce storage (through--- core arrays) are------   * 'freezeVector'------   * 'memorize'------   * 'vector'------   * 'unfoldVec'------   * 'unfold'------   * 'scan'+-- Unlike core arrays vectors don't use any physical memory. All+-- operations on vectors are \"fused\" which means that intermediate vectors+-- are removed. As an example, the following function uses only constant+-- space despite using two intermediate vectors of length @n@. -----   * 'mapAccum'+-- > sumSq n = sum (map (^2) (1...n)) ----- This means that vector operations not involving these operations will be--- completely \"fused\" without using any intermediate storage.+-- Memory is only introduced when a vector is explicitly+-- written to memory using the function 'memorize' or converted to a core+-- array using 'freezeVector'. The function 'vector' for creating a+-- vector also allocates memory. -- -- Note also that most operations only introduce a small constant overhead on -- the vector. The exceptions are@@ -159,8 +153,8 @@      externalize l_a = map externalize $ unfreezeVector l a       where-        l = externalize $ exprToData $ Get21 l_a-        a = externalize $ exprToData $ Get22 l_a+        l = externalize $ get21 l_a+        a = externalize $ get22 l_a  instance Storable a => Computable (Vector (Vector (Data a)))   where@@ -177,9 +171,9 @@         = map (map externalize . uncurry unfreezeVector)         $ zip l2sV (unfreezeVector l1 a)       where-        l1   = externalize $ exprToData $ Get31 inp-        l2s  = externalize $ exprToData $ Get32 inp-        a    = externalize $ exprToData $ Get33 inp+        l1   = externalize $ get31 inp+        l2s  = externalize $ get32 inp+        a    = externalize $ get33 inp         l2sV = unfreezeVector l1 l2s  @@ -202,10 +196,10 @@ infixr 5 ++  take :: Data Int -> Vector a -> Vector a-take n (Indexed l ixf) = Indexed (minX n l) ixf+take n (Indexed l ixf) = Indexed (min n l) ixf  drop :: Data Int -> Vector a -> Vector a-drop n (Indexed l ixf) = Indexed (maxX 0 (l-n)) (\x -> ixf (x+n))+drop n (Indexed l ixf) = Indexed (max 0 (l-n)) (\x -> ixf (x+n))  dropWhile :: (a -> Data Bool) -> Vector a -> Vector a dropWhile cont vec = drop i vec@@ -272,69 +266,13 @@ fold1 :: Computable a => (a -> a -> a) -> Vector a -> a fold1 f a = fold f (head a) a ----- | Like 'unfoldCore', but for symbolic vectors. The output elements are stored--- in a core vector.-unfoldVec-    :: (Computable state, Storable a)-    => Data Length-    -> state-    -> (Data Int -> state -> (Data a, state))-    -> (Vector (Data a), state)--unfoldVec l init step = (unfreezeVector l arr, final)-  where-    (arr,final) = unfoldCore l init step------ | Somewhat similar to Haskell's 'Data.List.unfoldr'. The output elements are--- stored in a core vector.------ @`unfold` l init step@:------   * @l@ is the length of the resulting vector.------   * @init@ is the initial state.------   * @step@ is a function computing a new element and the next state from the---     current state.-unfold :: (Computable state, Storable a) =>-    Data Length -> state -> (state -> (Data a, state)) -> Vector (Data a)--unfold l init = fst . unfoldVec l init . const------ | Corresponds to 'scanl'. The output elements are stored in a core vector.-scan :: (Storable a, Computable b) =>-    (Data a -> b -> Data a) -> Data a -> Vector b -> Vector (Data a)--scan f a vec = fst $ unfoldVec (length vec + 1) a $ \i a -> (a, f a (vec!i))------ | Corresponds to 'Data.List.mapAccumL'. The output elements are stored in a--- core vector.-mapAccum :: (Storable a, Computable acc, Storable b)-    => (acc -> Data a -> (acc, Data b))-    -> acc -> Vector (Data a) -> (acc, Vector (Data b))--mapAccum f init vecA = (final,vecB)-  where-    (vecB,final) = unfoldVec (length vecA) init $ \i acc ->-      let (acc',b) = f acc (vecA!i) in (b,acc')----sum :: (Num a, Computable a) => Vector a -> a+sum :: Numeric a => Vector (Data a) -> Data a sum = fold (+) 0 -maximum :: Storable a => Vector (Data a) -> Data a+maximum :: Ord a => Vector (Data a) -> Data a maximum = fold1 max -minimum :: Storable a => Vector (Data a) -> Data a+minimum :: Ord a => Vector (Data a) -> Data a minimum = fold1 min  -- | Scalar product of two vectors

@@ -1,3 +1,31 @@+--+-- Copyright (c) 2009-2010, ERICSSON AB All rights reserved.+-- +-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are met:+-- +--     * Redistributions of source code must retain the above copyright notice,+--       this list of conditions and the following disclaimer.+--     * Redistributions in binary form must reproduce the above copyright+--       notice, this list of conditions and the following disclaimer in the+--       documentation and/or other materials provided with the distribution.+--     * Neither the name of the ERICSSON AB nor the names of its contributors+--       may be used to endorse or promote products derived from this software+--       without specific prior written permission.+-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+-- ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS+-- BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY,+-- OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+-- SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+-- INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+-- CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+-- ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF+-- THE POSSIBILITY OF SUCH DAMAGE.+--+ import Distribution.Simple  main = defaultMain

@@ -1,5 +1,5 @@ name:           feldspar-language-version:        0.2+version:        0.3 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@@ -12,9 +12,9 @@ license:        BSD3 license-file:   LICENSE stability:      experimental-homepage:       http://feldspar.sourceforge.net/+homepage:       http://feldspar.inf.elte.hu/feldspar/ build-type:     Simple-cabal-version:  >= 1.2.3+cabal-version:  >= 1.6 tested-with:    GHC==6.10.*  library@@ -30,21 +30,26 @@     Feldspar.Core.Show     Feldspar.Core.Reify     Feldspar.Core.Functions+    Feldspar.Core.Trace     Feldspar.Core     Feldspar.Vector     Feldspar.Matrix+    Feldspar.FixedPoint+    Feldspar.Stream     Feldspar    build-depends:-    base >= 3 && < 4,+    base >= 4 && < 4.3,     containers,     mtl,-    QuickCheck >= 1.2 && < 2+    random,+    QuickCheck >= 2 && < 3    extensions:     FlexibleInstances     FlexibleContexts     GADTs+    MultiParamTypeClasses     NoMonomorphismRestriction     OverlappingInstances     PatternGuards