module Feldspar.Core.Constructs.Par where
import Language.Syntactic
import Language.Syntactic.Constructs.Monad
import Language.Syntactic.Constructs.Binding
import Language.Syntactic.Constructs.Binding.HigherOrder
import qualified Control.Monad.Par as CMP
import Control.Monad.Par.Scheds.TraceInternal (yield)
import Feldspar.Lattice
import Feldspar.Core.Types
import Feldspar.Core.Interpretation
import Feldspar.Core.Constructs.Binding
import Data.Map
import Data.Typeable
data ParFeature a
where
ParRun :: Type a => ParFeature (Par a :-> Full a)
ParNew :: Type a => ParFeature (Full (Par (IV a)))
ParGet :: Type a => ParFeature (IV a :-> Full (Par a))
ParPut :: Type a => ParFeature (IV a :-> a :-> Full (Par ()))
ParFork :: ParFeature (Par () :-> Full (Par ()))
ParYield :: ParFeature (Full (Par ()))
instance Semantic ParFeature
where
semantics ParRun = Sem "runPar" CMP.runPar
semantics ParNew = Sem "new" CMP.new
semantics ParGet = Sem "get" CMP.get
semantics ParPut = Sem "put" CMP.put_
semantics ParFork = Sem "fork" CMP.fork
semantics ParYield = Sem "yield" yield
instance Equality ParFeature where equal = equalDefault; exprHash = exprHashDefault
instance Render ParFeature where renderArgs = renderArgsDefault
instance ToTree ParFeature
instance Eval ParFeature where evaluate = evaluateDefault
instance EvalBind ParFeature where evalBindSym = evalBindSymDefault
instance Sharable ParFeature
instance AlphaEq dom dom dom env => AlphaEq ParFeature ParFeature dom env
where
alphaEqSym = alphaEqSymDefault
instance Sharable (MONAD Par)
instance SizeProp ParFeature
where
sizeProp ParRun (WrapFull a :* Nil) = infoSize a
sizeProp ParNew _ = universal
sizeProp ParGet _ = universal
sizeProp ParPut _ = universal
sizeProp ParFork _ = universal
sizeProp ParYield _ = universal
instance ( MONAD Par :<: dom
, ParFeature :<: dom
, Optimize dom dom
)
=> Optimize ParFeature dom
where
constructFeatUnOpt ParRun args = constructFeatUnOptDefault ParRun args
constructFeatUnOpt ParNew args = constructFeatUnOptDefaultTyp (ParType $ IVarType typeRep) ParNew args
constructFeatUnOpt ParGet args = constructFeatUnOptDefaultTyp (ParType typeRep) ParGet args
constructFeatUnOpt ParPut args = constructFeatUnOptDefaultTyp (ParType typeRep) ParPut args
constructFeatUnOpt ParFork args = constructFeatUnOptDefaultTyp (ParType typeRep) ParFork args
constructFeatUnOpt ParYield args = constructFeatUnOptDefaultTyp (ParType typeRep) ParYield args
monadProxy :: P Par
monadProxy = P
instance SizeProp (MONAD Par)
where
sizeProp Return (WrapFull a :* Nil) = infoSize a
sizeProp Bind (_ :* WrapFull f :* Nil) = infoSize f
sizeProp Then (_ :* WrapFull b :* Nil) = infoSize b
sizeProp When _ = AnySize
instance ( MONAD Par :<: dom
, (Variable :|| Type) :<: dom
, CLambda Type :<: dom
, OptimizeSuper dom
)
=> Optimize (MONAD Par) dom
where
optimizeFeat bnd@Bind (ma :* f :* Nil) = do
ma' <- optimizeM ma
case getInfo ma' of
Info (ParType ty) sz vs src -> do
f' <- optimizeFunction optimizeM (Info ty sz vs src) f
case getInfo f' of
Info{} -> constructFeat bnd (ma' :* f' :* Nil)
optimizeFeat a args = optimizeFeatDefault a args
constructFeatOpt Bind (ma :* (lam :$ (Sym (Decor _ ret) :$ var)) :* Nil)
| Just (SubConstr2 (Lambda v1)) <- prjLambda lam
, Just Return <- prjMonad monadProxy ret
, Just (C' (Variable v2)) <- prjF var
, v1 == v2
, Just ma' <- gcast ma
= return ma'
constructFeatOpt Bind (ma :* (lam :$ body) :* Nil)
| Just (SubConstr2 (Lambda v)) <- prjLambda lam
, v `notMember` vars
= constructFeat Then (ma :* body :* Nil)
where
vars = infoVars $ getInfo body
constructFeatOpt Then ((Sym (Decor _ ret) :$ _) :* mb :* Nil)
| Just Return <- prjMonad monadProxy ret
= return mb
constructFeatOpt Then (ma :* (Sym (Decor info ret) :$ u) :* Nil)
| Just Return <- prjMonad monadProxy ret
, Just TypeEq <- typeEq (infoType $ getInfo ma) (ParType UnitType)
, Just TypeEq <- typeEq (infoType info) (ParType UnitType)
, Just () <- viewLiteral u
= return ma
constructFeatOpt a args = constructFeatUnOpt a args
constructFeatUnOpt Return args@(a :* Nil)
| Info {infoType = t} <- getInfo a
= constructFeatUnOptDefaultTyp (ParType t) Return args
constructFeatUnOpt Bind args@(_ :* f :* Nil)
| Info {infoType = FunType _ t} <- getInfo f
= constructFeatUnOptDefaultTyp t Bind args
constructFeatUnOpt Then args@(_ :* mb :* Nil)
| Info {infoType = t} <- getInfo mb
= constructFeatUnOptDefaultTyp t Then args
constructFeatUnOpt When args =
constructFeatUnOptDefaultTyp voidTypeRep When args