module Feldspar.Core.Interpretation
( module Language.Syntactic.Constructs.Decoration
, module Feldspar.Core.Interpretation.Typed
, targetSpecialization
, Sharable (..)
, SizeProp (..)
, sizePropDefault
, resultType
, SourceInfo
, Info (..)
, mkInfo
, mkInfoTy
, infoRange
, LatticeSize1 (..)
, viewLiteral
, literalDecor
, constFold
, SomeInfo (..)
, SomeType (..)
, Env (..)
, localVar
, localSource
, Opt
, Optimize (..)
, OptimizeSuper
, constructFeat
, optimizeM
, optimize
, constructFeatUnOptDefaultTyp
, constructFeatUnOptDefault
, optimizeFeatDefault
, prjF
, c'
) where
import Control.Monad.Reader
import Data.Map as Map
import Data.Typeable (Typeable)
import Language.Syntactic
import Language.Syntactic.Constructs.Decoration
import Language.Syntactic.Constructs.Literal
import Language.Syntactic.Constructs.Binding
import Language.Syntactic.Constructs.Binding.HigherOrder
import Feldspar.Lattice
import Feldspar.Core.Types
import Feldspar.Core.Interpretation.Typed
targetSpecialization :: BitWidth n -> ASTF dom a -> ASTF dom a
targetSpecialization _ = id
class Sharable dom
where
sharable :: dom a -> Bool
sharable _ = True
instance (Sharable sub1, Sharable sub2) => Sharable (sub1 :+: sub2)
where
sharable (InjL a) = sharable a
sharable (InjR a) = sharable a
instance Sharable sym => Sharable (sym :|| pred)
where
sharable (C' s) = sharable s
instance Sharable sym => Sharable (SubConstr2 c sym p1 p2)
where
sharable (SubConstr2 s) = sharable s
instance Sharable dom => Sharable (Decor Info dom)
where
sharable = sharable . decorExpr
instance Sharable Empty
class SizeProp feature
where
sizeProp :: feature a -> Args (WrapFull Info) a -> Size (DenResult a)
sizePropDefault :: (Type (DenResult a))
=> feature a -> Args (WrapFull Info) a -> Size (DenResult a)
sizePropDefault _ _ = universal
resultType :: Type (DenResult a) => c a -> TypeRep (DenResult a)
resultType _ = typeRep
data SomeType
where
SomeType :: TypeRep a -> SomeType
type VarInfo = Map VarId SomeType
type SourceInfo = String
data Info a
where
Info
:: Show (Size a)
=> { infoType :: TypeRep a
, infoSize :: Size a
, infoVars :: VarInfo
, infoSource :: SourceInfo
}
-> Info a
instance Render Info
where
render i@(Info {}) = show (infoType i) ++ szStr ++ srcStr
where
szStr = case show (infoSize i) of
"()" -> ""
str -> " | " ++ str
srcStr = case infoSource i of
"" -> ""
src -> " | " ++ src
instance Eq (Size a) => Eq (Info a)
where
ia == ib = infoSize ia == infoSize ib
mkInfo :: Type a => Size a -> Info a
mkInfo sz = Info typeRep sz Map.empty ""
mkInfoTy :: (Show (Size a), Lattice (Size a)) => TypeRep a -> Info a
mkInfoTy t = Info t universal Map.empty ""
infoRange :: Type a => Info a -> RangeSet a
infoRange = sizeToRange . infoSize
class LatticeSize1 m
where
mergeSize :: Lattice (Size a) =>
Info (m a) -> Size (m a) -> Size (m a) -> Size (m a)
instance LatticeSize1 Mut
where
mergeSize _ = (\/)
data SomeInfo
where
SomeInfo :: Typeable a => Info a -> SomeInfo
data Env = Env
{ varEnv :: [(VarId, SomeInfo)]
, sourceEnv :: SourceInfo
}
initEnv :: Env
initEnv = Env [] ""
localVar :: Typeable b => VarId -> Info b -> Opt a -> Opt a
localVar v info = local $ \env -> env {varEnv = (v, SomeInfo info):varEnv env}
localSource :: SourceInfo -> Opt a -> Opt a
localSource src = local $ \env -> env {sourceEnv = src}
viewLiteral :: forall info dom a. ((Literal :|| Type) :<: dom)
=> ASTF (Decor info (dom :|| Typeable)) a -> Maybe a
viewLiteral (prjF -> Just (C' (Literal a))) = Just a
viewLiteral _ = Nothing
prjF :: Project (sub :|| Type) sup => sup sig -> Maybe ((sub :|| Type) sig)
prjF = prj
literalDecorSrc :: (Type a, (Literal :|| Type) :<: dom) =>
SourceInfo -> a -> ASTF (Decor Info (dom :|| Typeable)) a
literalDecorSrc src a = Sym $ Decor
((mkInfo (sizeOf a)) {infoSource = src})
(C' $ inj $ c' $ Literal a)
c' :: (Type (DenResult sig)) => feature sig -> (feature :|| Type) sig
c' = C'
literalDecor :: (Type a, (Literal :|| Type) :<: dom) =>
a -> ASTF (Decor Info (dom :|| Typeable)) a
literalDecor = literalDecorSrc ""
constFold :: (Typed dom, (Literal :|| Type) :<: dom) =>
SourceInfo -> ASTF (Decor Info (dom :|| Typeable)) a -> a -> ASTF (Decor Info (dom :|| Typeable)) a
constFold src expr a
| Just Dict <- typeDict expr
= literalDecorSrc src a
constFold _ expr _ = expr
type Opt = Reader Env
class Optimize feature dom
where
optimizeFeat
:: ( Typeable (DenResult a)
, OptimizeSuper dom
)
=> feature a
-> Args (AST (dom :|| Typeable)) a
-> Opt (ASTF (Decor Info (dom :|| Typeable)) (DenResult a))
optimizeFeat = optimizeFeatDefault
constructFeatOpt
:: ( Typeable (DenResult a))
=> feature a
-> Args (AST (Decor Info (dom :|| Typeable))) a
-> Opt (ASTF (Decor Info (dom :|| Typeable)) (DenResult a))
constructFeatOpt = constructFeatUnOpt
constructFeatUnOpt
:: ( Typeable (DenResult a))
=> feature a
-> Args (AST (Decor Info (dom :|| Typeable))) a
-> Opt (ASTF (Decor Info (dom :|| Typeable)) (DenResult a))
instance Optimize Empty dom
where
constructFeatUnOpt = error "Not implemented: constructFeatUnOpt for Empty"
class
( AlphaEq dom dom (dom :|| Typeable) [(VarId, VarId)]
, AlphaEq dom dom (Decor Info (dom :|| Typeable)) [(VarId, VarId)]
, EvalBind dom
, (Literal :|| Type) :<: dom
, Typed dom
, Constrained dom
, Optimize dom dom
) =>
OptimizeSuper dom
instance
( AlphaEq dom dom (dom :|| Typeable) [(VarId, VarId)]
, AlphaEq dom dom (Decor Info (dom :|| Typeable)) [(VarId, VarId)]
, EvalBind dom
, (Literal :|| Type) :<: dom
, Typed dom
, Constrained dom
, Optimize dom dom
) =>
OptimizeSuper dom
constructFeat :: ( Typeable (DenResult a)
, Optimize feature dom)
=> feature a
-> Args (AST (Decor Info (dom :|| Typeable))) a
-> Opt (ASTF (Decor Info (dom :|| Typeable)) (DenResult a))
constructFeat a args = do
aUnOpt <- constructFeatUnOpt a args
aOpt <- constructFeatOpt a args
return $ updateDecor
(\info -> info {infoSize = infoSize (getInfo aUnOpt)})
aOpt
instance
( Optimize sub1 dom
, Optimize sub2 dom
) =>
Optimize (sub1 :+: sub2) dom
where
optimizeFeat (InjL a) = optimizeFeat a
optimizeFeat (InjR a) = optimizeFeat a
constructFeatOpt (InjL a) = constructFeatOpt a
constructFeatOpt (InjR a) = constructFeatOpt a
constructFeatUnOpt (InjL a) = constructFeatUnOpt a
constructFeatUnOpt (InjR a) = constructFeatUnOpt a
optimizeM :: (OptimizeSuper dom)
=> ASTF (dom :|| Typeable) a -> Opt (ASTF (Decor Info (dom :|| Typeable)) a)
optimizeM a
| Dict <- exprDict a
= do
aOpt <- matchTrans (\(C' x) -> optimizeFeat x) a
let vars = infoVars $ getInfo aOpt
value = evalBind aOpt
src = infoSource $ getInfo aOpt
if Map.null vars
then return $ constFold src aOpt value
else return aOpt
optimize :: ( Typeable a
, OptimizeSuper dom
)
=> ASTF (dom :|| Typeable) a -> ASTF (Decor Info (dom :|| Typeable)) a
optimize = flip runReader initEnv . optimizeM
constructFeatUnOptDefaultTyp
:: ( feature :<: dom
, SizeProp feature
, Typeable (DenResult a)
, Show (Size (DenResult a))
)
=> TypeRep (DenResult a)
-> feature a
-> Args (AST (Decor Info (dom :|| Typeable))) a
-> Opt (ASTF (Decor Info (dom :|| Typeable)) (DenResult a))
constructFeatUnOptDefaultTyp typ feat args
= do
src <- asks sourceEnv
let sz = sizeProp feat $ mapArgs (WrapFull . getInfo) args
vars = Map.unions $ listArgs (infoVars . getInfo) args
return $ appArgs (Sym $ Decor (Info typ sz vars src) $ C' $ inj feat) args
constructFeatUnOptDefault
:: ( feature :<: dom
, SizeProp feature
, Type (DenResult a)
)
=> feature a
-> Args (AST (Decor Info (dom :|| Typeable))) a
-> Opt (ASTF (Decor Info (dom :|| Typeable)) (DenResult a))
constructFeatUnOptDefault feat args
= do
src <- asks sourceEnv
let sz = sizeProp feat $ mapArgs (WrapFull . getInfo) args
vars = Map.unions $ listArgs (infoVars . getInfo) args
return $ appArgs (Sym $ Decor (Info typeRep sz vars src) $ C' $ inj feat) args
optimizeFeatDefault
:: ( Optimize feature dom
, Typeable (DenResult a)
, OptimizeSuper dom
)
=> feature a
-> Args (AST (dom :|| Typeable)) a
-> Opt (ASTF (Decor Info (dom :|| Typeable)) (DenResult a))
optimizeFeatDefault feat args
= constructFeat feat =<< mapArgsM optimizeM args