-- -- Copyright (c) 2009-2011, ERICSSON AB -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are met: -- -- * Redistributions of source code must retain the above copyright notice, -- this list of conditions and the following disclaimer. -- * Redistributions in binary form must reproduce the above copyright -- notice, this list of conditions and the following disclaimer in the -- documentation and/or other materials provided with the distribution. -- * Neither the name of the ERICSSON AB nor the names of its contributors -- may be used to endorse or promote products derived from this software -- without specific prior written permission. -- -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE -- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE OverlappingInstances #-} module Feldspar.Core.Frontend ( module Data.Patch , Syntactic , Internal , FeldDomainAll , Data , Syntax , module Frontend , reifyFeld , showExpr , printExpr , showAST , drawAST , showDecor , drawDecor , eval , evalTarget , desugar , sugar , resugar -- * QuickCheck , (===>) , (===) -- * Type constraints , tData , tArr1 , tArr2 , tM ) where import Control.Monad.State import Test.QuickCheck import Data.Patch import Language.Syntactic hiding (desugar, sugar, resugar, printExpr, showAST, drawAST) import qualified Language.Syntactic as Syntactic import qualified Language.Syntactic.Constructs.Decoration as Syntactic import Language.Syntactic.Constructs.Binding import Language.Syntactic.Constructs.Binding.HigherOrder import Language.Syntactic.Sharing.SimpleCodeMotion import Feldspar.Lattice import Feldspar.Range import Feldspar.Core.Types import Feldspar.Core.Interpretation hiding (showDecor, drawDecor) import Feldspar.Core.Constructs import Feldspar.Core.Frontend.Array as Frontend import Feldspar.Core.Frontend.Binding as Frontend import Feldspar.Core.Frontend.Bits as Frontend import Feldspar.Core.Frontend.Complex as Frontend import Feldspar.Core.Frontend.Condition as Frontend import Feldspar.Core.Frontend.ConditionM as Frontend import Feldspar.Core.Frontend.Conversion as Frontend import Feldspar.Core.Frontend.Eq as Frontend import Feldspar.Core.Frontend.Error as Frontend import Feldspar.Core.Frontend.FFI as Frontend import Feldspar.Core.Frontend.Floating as Frontend import Feldspar.Core.Frontend.Fractional as Frontend import Feldspar.Core.Frontend.Integral as Frontend import Feldspar.Core.Frontend.Literal as Frontend import Feldspar.Core.Frontend.Logic as Frontend import Feldspar.Core.Frontend.Loop as Frontend import Feldspar.Core.Frontend.Mutable as Frontend import Feldspar.Core.Frontend.MutableArray as Frontend import Feldspar.Core.Frontend.MutableReference as Frontend import Feldspar.Core.Frontend.MutableToPure as Frontend import Feldspar.Core.Frontend.Par as Frontend import Feldspar.Core.Frontend.Num as Frontend import Feldspar.Core.Frontend.Ord as Frontend import Feldspar.Core.Frontend.Save as Frontend import Feldspar.Core.Frontend.SizeProp as Frontend import Feldspar.Core.Frontend.SourceInfo as Frontend import Feldspar.Core.Frontend.Trace as Frontend import Feldspar.Core.Frontend.Tuple as Frontend bindDict :: BindDict TypeCtx (Decor Info (Lambda TypeCtx :+: Variable TypeCtx :+: FeldDomain)) bindDict = BindDict { prjVariable = \a -> case a of Decor _ (prjCtx typeCtx -> Just (Variable v)) -> Just v _ -> Nothing , prjLambda = \a -> case a of Decor _ (prjCtx typeCtx -> Just (Lambda v)) -> Just v _ -> Nothing , injVariable = injVar , injLambda = injLam , injLet = injLt } injVar :: forall a . Sat TypeCtx a => ASTF (Decor Info (Lambda TypeCtx :+: Variable TypeCtx :+: FeldDomain)) a -> VarId -> (Decor Info (Lambda TypeCtx :+: Variable TypeCtx :+: FeldDomain)) (Full a) injVar a v | TypeWit <- witness :: Witness TypeCtx a = Decor (getInfo a) (inj (Variable v `withContext` typeCtx)) injLam :: forall a b . (Sat TypeCtx a, Sat TypeCtx b) => ASTF (Decor Info (Lambda TypeCtx :+: Variable TypeCtx :+: FeldDomain)) b -> VarId -> (Decor Info (Lambda TypeCtx :+: Variable TypeCtx :+: FeldDomain)) (b :-> Full (a -> b)) injLam b v | TypeWit <- witness :: Witness TypeCtx a , TypeWit <- witness :: Witness TypeCtx b = Decor ((mkInfoTy (FunType typeRep typeRep)) {infoSize = infoSize (getInfo b)}) (inj (Lambda v `withContext` typeCtx)) injLt :: forall a b . (Sat TypeCtx a, Sat TypeCtx b) => ASTF (Decor Info (Lambda TypeCtx :+: Variable TypeCtx :+: FeldDomain)) b -> (Decor Info (Lambda TypeCtx :+: Variable TypeCtx :+: FeldDomain)) (a :-> (a -> b) :-> Full b) injLt b | TypeWit <- witness :: Witness TypeCtx b = Decor (getInfo b) (inj (letBind typeCtx)) -- | Reification and optimization of a Feldspar program reifyFeld :: Syntactic a FeldDomainAll => BitWidth n -> a -> ASTF (Decor Info (Lambda TypeCtx :+: Variable TypeCtx :+: FeldDomain)) (Internal a) reifyFeld n = flip evalState 0 . ( return <=< codeMotion bindDict sharableDecor . optimize . targetSpecialization n <=< reifyM . Syntactic.desugar ) -- Note that it's important to do 'codeMotion' after 'optimize'. There may be -- sub-expressions that appear more than once in the original program, but -- where 'optimize' removes all but one occurrence. If 'codeMotion' was run -- first, these sub-expressions would be let bound, preventing subsequent -- optimizations. showExpr :: Syntactic a FeldDomainAll => a -> String showExpr = render . reifyFeld N32 printExpr :: Syntactic a FeldDomainAll => a -> IO () printExpr = Syntactic.printExpr . reifyFeld N32 showAST :: Syntactic a FeldDomainAll => a -> String showAST = Syntactic.showAST . reifyFeld N32 drawAST :: Syntactic a FeldDomainAll => a -> IO () drawAST = Syntactic.drawAST . reifyFeld N32 -- | Draw a syntax tree decorated with type and size information showDecor :: Syntactic a FeldDomainAll => a -> String showDecor = Syntactic.showDecor . reifyFeld N32 -- | Draw a syntax tree decorated with type and size information drawDecor :: Syntactic a FeldDomainAll => a -> IO () drawDecor = Syntactic.drawDecor . reifyFeld N32 eval :: Syntactic a FeldDomainAll => a -> Internal a eval = evalBind . reifyFeld N32 evalTarget :: ( Syntactic a FeldDomainAll , BoundedInt (GenericInt U n) , BoundedInt (GenericInt S n) ) => BitWidth n -> a -> Internal a evalTarget n = evalBind . reifyFeld n -- TODO This doesn't work yet, because 'targetSpecialization' is not -- implemented desugar :: Syntax a => a -> Data (Internal a) desugar = Syntactic.resugar sugar :: Syntax a => Data (Internal a) -> a sugar = Syntactic.resugar resugar :: (Syntax a, Syntax b, Internal a ~ Internal b) => a -> b resugar = Syntactic.resugar -------------------------------------------------------------------------------- -- * QuickCheck -------------------------------------------------------------------------------- instance (Type a, Arbitrary a) => Arbitrary (Data a) where arbitrary = fmap value arbitrary instance Testable (Data Bool) where property = property . eval (===>) :: Testable prop => Data Bool -> prop -> Property a ===> b = eval a ==> b class Equal a where (===) :: a -> a -> Property instance (Prelude.Eq a, Show a) => Equal a where x === y = printTestCase ("Evaluated property: " ++ show x ++ " === " ++ show y) $ property (x Prelude.== y) instance (Show a, Arbitrary a, Equal b) => Equal (a -> b) where f === g = property (\x -> f x === g x) -------------------------------------------------------------------------------- -- * Type annotations -------------------------------------------------------------------------------- tData :: Patch a a -> Patch (Data a) (Data a) tData _ = id tArr1 :: Patch a a -> Patch (Data [a]) (Data [a]) tArr1 _ = id tArr2 :: Patch a a -> Patch (Data [[a]]) (Data [[a]]) tArr2 _ = id tM :: Patch a a -> Patch (M a) (M a) tM _ = id