-- -- 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 GADTs #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} module Feldspar.Compiler.Imperative.FromCore.Interpretation where import Control.Arrow import Control.Monad.RWS import Language.Syntactic.Syntax hiding (result) import Language.Syntactic.Traversal import Language.Syntactic.Constraint import Language.Syntactic.Constructs.Binding (VarId) import Feldspar.Range import Feldspar.Core.Types hiding (Type) import Feldspar.Core.Interpretation import qualified Feldspar.Core.Types as Core import qualified Feldspar.Core.Constructs.Binding as Core import qualified Feldspar.Core.Constructs.Literal as Core import Feldspar.Compiler.Imperative.Frontend import Feldspar.Compiler.Imperative.Representation (typeof) -- | Code generation monad type CodeWriter = RWS Readers Writers States data Readers = Readers { alias :: [(VarId, Expr)] -- ^ variable aliasing , sourceInfo :: SourceInfo -- ^ Surrounding source info } initReader :: Readers initReader = Readers [] "" data Writers = Writers { block :: Block -- ^ collects code within one block , def :: [Ent] -- ^ collects top level definitions } instance Monoid Writers where mempty = Writers { block = mempty , def = mempty } mappend a b = Writers { block = mappend (block a) (block b) , def = mappend (def a) (def b) } type Task = [Prog] data States = States { fresh :: Integer -- ^ The first fresh variable id } initState :: States initState = States 0 -- | Where to place the program result type Location = Expr -- | A minimal complete instance has to define either 'compileProgSym' or -- 'compileExprSym'. class Compile sub dom where compileProgSym :: sub a -> Info (DenResult a) -> Location -> Args (AST (Decor Info dom)) a -> CodeWriter () compileProgSym = compileExprLoc compileExprSym :: sub a -> Info (DenResult a) -> Args (AST (Decor Info dom)) a -> CodeWriter Expr compileExprSym = compileProgFresh instance (Compile sub1 dom, Compile sub2 dom) => Compile (sub1 :+: sub2) dom where compileProgSym (InjL a) = compileProgSym a compileProgSym (InjR a) = compileProgSym a compileExprSym (InjL a) = compileExprSym a compileExprSym (InjR a) = compileExprSym a -- | Implementation of 'compileExprSym' that assigns an expression to the given -- location. compileExprLoc :: Compile sub dom => sub a -> Info (DenResult a) -> Location -> Args (AST (Decor Info dom)) a -> CodeWriter () compileExprLoc a info loc args = do expr <- compileExprSym a info args assign loc expr -- | Implementation of 'compileProgSym' that generates code into a fresh -- variable. compileProgFresh :: Compile sub dom => sub a -> Info (DenResult a) -> Args (AST (Decor Info dom)) a -> CodeWriter Expr compileProgFresh a info args = do loc <- freshVar "e" (infoType info) (infoSize info) compileProgSym a info loc args return loc compileProgDecor :: Compile dom dom => Location -> Decor Info dom a -> Args (AST (Decor Info dom)) a -> CodeWriter () compileProgDecor result (Decor info a) args = do let src = infoSource info aboveSrc <- asks sourceInfo unless (null src || src==aboveSrc) $ tellProg [BComment src] local (\env -> env {sourceInfo = src}) $ compileProgSym a info result args compileExprDecor :: Compile dom dom => Decor Info dom a -> Args (AST (Decor Info dom)) a -> CodeWriter Expr compileExprDecor (Decor info a) args = do let src = infoSource info aboveSrc <- asks sourceInfo unless (null src || src==aboveSrc) $ tellProg [BComment src] local (\env -> env {sourceInfo = src}) $ compileExprSym a info args compileProg :: Compile dom dom => Location -> ASTF (Decor Info dom) a -> CodeWriter () compileProg result = simpleMatch (compileProgDecor result) compileExpr :: Compile dom dom => ASTF (Decor Info dom) a -> CodeWriter Expr compileExpr = simpleMatch compileExprDecor -- Compile an expression and make sure that the result is stored in a variable compileExprVar :: Compile dom dom => ASTF (Decor Info dom) a -> CodeWriter Expr compileExprVar e = do e' <- compileExpr e case e' of Var _ _ -> return e' Ptr _ _ -> return e' _ -> do varId <- freshId let loc = Var (typeof e') ('e' : show varId) declare loc assign loc e' return loc -------------------------------------------------------------------------------- -- * Utility functions -------------------------------------------------------------------------------- compileNumType :: Signedness a -> BitWidth n -> Type compileNumType U N8 = U8 compileNumType S N8 = I8 compileNumType U N16 = U16 compileNumType S N16 = I16 compileNumType U N32 = U32 compileNumType S N32 = I32 compileNumType U N64 = U64 compileNumType S N64 = I64 compileNumType U NNative = U32 -- TODO compileNumType S NNative = I32 -- TODO compileTypeRep :: TypeRep a -> Size a -> Type compileTypeRep UnitType _ = Void compileTypeRep BoolType _ = Boolean compileTypeRep (IntType s n) _ = compileNumType s n compileTypeRep FloatType _ = Floating compileTypeRep (ComplexType t) _ = Complex (compileTypeRep t (defaultSize t)) compileTypeRep (Tup2Type a b) (sa,sb) = Struct [ ("member1", compileTypeRep a sa) , ("member2", compileTypeRep b sb) ] compileTypeRep (Tup3Type a b c) (sa,sb,sc) = Struct [ ("member1", compileTypeRep a sa) , ("member2", compileTypeRep b sb) , ("member3", compileTypeRep c sc) ] compileTypeRep (Tup4Type a b c d) (sa,sb,sc,sd) = Struct [ ("member1", compileTypeRep a sa) , ("member2", compileTypeRep b sb) , ("member3", compileTypeRep c sc) , ("member4", compileTypeRep d sd) ] compileTypeRep (Tup5Type a b c d e) (sa,sb,sc,sd,se) = Struct [ ("member1", compileTypeRep a sa) , ("member2", compileTypeRep b sb) , ("member3", compileTypeRep c sc) , ("member4", compileTypeRep d sd) , ("member5", compileTypeRep e se) ] compileTypeRep (Tup6Type a b c d e f) (sa,sb,sc,sd,se,sf) = Struct [ ("member1", compileTypeRep a sa) , ("member2", compileTypeRep b sb) , ("member3", compileTypeRep c sc) , ("member4", compileTypeRep d sd) , ("member5", compileTypeRep e se) , ("member6", compileTypeRep f sf) ] compileTypeRep (Tup7Type a b c d e f g) (sa,sb,sc,sd,se,sf,sg) = Struct [ ("member1", compileTypeRep a sa) , ("member2", compileTypeRep b sb) , ("member3", compileTypeRep c sc) , ("member4", compileTypeRep d sd) , ("member5", compileTypeRep e se) , ("member6", compileTypeRep f sf) , ("member7", compileTypeRep g sg) ] compileTypeRep (MutType a) _ = compileTypeRep a (defaultSize a) compileTypeRep (RefType a) _ = compileTypeRep a (defaultSize a) compileTypeRep (ArrayType a) (rs :> es) = if unboundedLength then Array $ compileTypeRep a es else SizedArray (fromEnum $ upperBound rs) $ compileTypeRep a es where unboundedLength = upperBound rs > fromIntegral (maxBound :: Int) -- This ensures that `fromEnum` succeeds || upperBound rs == maxBound -- This `maxBound` might be smaller than `maxBound :: Int` compileTypeRep (MArrType a) _ = Array (compileTypeRep a (defaultSize a)) compileTypeRep (ParType a) _ = compileTypeRep a (defaultSize a) compileTypeRep (IVarType a) _ = IVar $ compileTypeRep a $ defaultSize a compileTypeRep (FunType _ b) sz = compileTypeRep b sz compileTypeRep (FValType a) sz = IVar $ compileTypeRep a sz compileTypeRep typ _ = error $ "compileTypeRep: missing " ++ show typ -- TODO mkVarName :: VarId -> String mkVarName v = 'v' : show v mkVar :: Type -> VarId -> Expr mkVar t = Var t . mkVarName mkVariable :: Type -> VarId -> Var mkVariable t = Variable t . mkVarName freshId :: CodeWriter Integer freshId = do s <- get let v = fresh s put (s {fresh = v + 1}) return v freshVar :: String -> TypeRep a -> Size a -> CodeWriter Expr -- TODO take just info instead of TypeRep and Size? freshVar base t size = do v <- freshId let var =Var (compileTypeRep t size) $ base ++ show v declare var return var declare :: Expr -> CodeWriter () declare (Var t n) = tellDecl [Def t n] declare (Ptr t n) = tellDecl [Def t n] declare expr = error $ "declare: cannot declare expression: " ++ show expr tellDef :: [Ent] -> CodeWriter () tellDef es = tell $ mempty {def = es} tellProg :: [Prog] -> CodeWriter () tellProg ps = tell $ mempty {block = Bl [] $ Seq ps} tellDecl :: [Def] -> CodeWriter () tellDecl ds = tell $ mempty {block = Bl ds $ Seq []} assign :: Location -> Expr -> CodeWriter () assign lhs rhs = if isArray $ typeof lhs then tellProg [ initArray lhs $ arrayLength rhs , copyProg lhs rhs] else tellProg [copyProg lhs rhs] -- | Like 'listen', but also prevents the program from being written in the -- monad. confiscateBlock :: CodeWriter a -> CodeWriter (a, Block) confiscateBlock m = liftM (second block) $ censor (\rec -> rec {block = mempty}) $ listen m withAlias :: VarId -> Expr -> CodeWriter a -> CodeWriter a withAlias v0 expr = local (\e -> e {alias = (v0,expr) : alias e}) isVariableOrLiteral :: ( Project (Core.Variable :|| Core.Type) dom , Project (Core.Literal :|| Core.Type) dom) => AST (Decor info dom) a -> Bool isVariableOrLiteral (prjF -> Just (C' (Core.Literal _))) = True isVariableOrLiteral (prjF -> Just (C' (Core.Variable _))) = True isVariableOrLiteral _ = False mkLength :: ( Project (Core.Literal :|| Core.Type) dom , Project (Core.Variable :|| Core.Type) dom , Compile dom dom ) => ASTF (Decor Info dom) a -> CodeWriter Expr mkLength a | isVariableOrLiteral a = compileExpr a | otherwise = do let lentyp = IntType U N32 lenvar <- freshVar "len" lentyp (defaultSize lentyp) compileProg lenvar a return lenvar