module Feldspar.Core.Constructs.Loop
where
import Data.Typeable
import Control.Monad (forM_, when)
import Language.Syntactic
import Language.Syntactic.Constructs.Binding hiding (betaReduce)
import Language.Syntactic.Constructs.Binding.HigherOrder (CLambda)
import Feldspar.Range
import Feldspar.Core.Types
import Feldspar.Core.Interpretation
import Feldspar.Core.Constructs.Binding
import Feldspar.Core.Constructs.Literal
data LoopM m a
where
While :: (Size (m ()) ~ AnySize) => LoopM m (m Bool :-> m a :-> Full (m ()))
For :: (Size (m ()) ~ AnySize) => LoopM m (Length :-> (Index -> m a) :-> Full (m ()))
data Loop a
where
ForLoop :: Type a => Loop (Length :-> a :-> (Index -> a -> a) :-> Full a)
WhileLoop :: Type a => Loop (a :-> (a -> Bool) :-> (a -> a) :-> Full a)
instance Monad m => Semantic (LoopM m)
where
semantics While = Sem "while" while
where
while cond body = do
c <- cond
when c (body >> while cond body)
semantics For = Sem "for" for
where
for 0 _ = return ()
for l body = forM_ [0..l1] body
instance Semantic Loop
where
semantics ForLoop = Sem "forLoop" forLoop
where
forLoop 0 initial _ = initial
forLoop l initial body = foldl (flip body) initial [0..l1]
semantics WhileLoop = Sem "whileLoop" whileLoop
where
whileLoop initial cond body = go initial
where
go st | cond st = go $ body st
| otherwise = st
instance Monad m => Equality (LoopM m) where equal = equalDefault; exprHash = exprHashDefault
instance Monad m => Render (LoopM m) where renderArgs = renderArgsDefault
instance Monad m => ToTree (LoopM m)
instance Monad m => Eval (LoopM m) where evaluate = evaluateDefault
instance Monad m => EvalBind (LoopM m) where evalBindSym = evalBindSymDefault
instance Sharable (LoopM m)
instance Equality Loop where equal = equalDefault; exprHash = exprHashDefault
instance Render Loop where renderArgs = renderArgsDefault
instance ToTree Loop
instance Eval Loop where evaluate = evaluateDefault
instance EvalBind Loop where evalBindSym = evalBindSymDefault
instance Sharable Loop
instance (AlphaEq dom dom dom env, Monad m) =>
AlphaEq (LoopM m) (LoopM m) dom env
where
alphaEqSym = alphaEqSymDefault
instance AlphaEq dom dom dom env => AlphaEq Loop Loop dom env
where
alphaEqSym = alphaEqSymDefault
instance SizeProp (LoopM m)
where
sizeProp While _ = AnySize
sizeProp For _ = AnySize
instance SizeProp (Loop :|| Type)
where
sizeProp (C' ForLoop) (_ :* _ :* WrapFull step :* Nil) = infoSize step
sizeProp (C' WhileLoop) (_ :* _ :* WrapFull step :* Nil) = infoSize step
instance ( MonadType m
, LoopM m :<: dom
, CLambda Type :<: dom
, Optimize dom dom
)
=> Optimize (LoopM m) dom
where
optimizeFeat for@For (len :* step :* Nil) = do
len' <- optimizeM len
let szI = infoSize (getInfo len')
ixRange = rangeByRange 0 (szI1)
step' <- optimizeFunction optimizeM (mkInfo ixRange) step
case getInfo step' of
Info{} -> constructFeat for (len' :* step' :* Nil)
optimizeFeat a args = optimizeFeatDefault a args
constructFeatUnOpt While args = constructFeatUnOptDefaultTyp voidTypeRep While args
constructFeatUnOpt For args = constructFeatUnOptDefaultTyp voidTypeRep For args
instance ( (Literal :|| Type) :<: dom
, (Loop :|| Type) :<: dom
, (Variable :|| Type) :<: dom
, CLambda Type :<: dom
, OptimizeSuper dom
)
=> Optimize (Loop :|| Type) dom
where
optimizeFeat sym@(C' ForLoop) (len :* initial :* step :* Nil) = do
len' <- optimizeM len
init' <- optimizeM initial
let szI = infoSize (getInfo len')
ixRange = Range 0 (upperBound szI1)
step' <- optimizeFunction
(optimizeFunction optimizeM (mkInfoTy typeRep))
(mkInfo ixRange)
step
constructFeat sym (len' :* init' :* step' :* Nil)
optimizeFeat sym@(C' WhileLoop) (initial :* cond :* body :* Nil) = do
init' <- optimizeM initial
body' <- optimizeFunction optimizeM (mkInfoTy typeRep) body
let info = getInfo init'
let info' = info { infoSize = infoSize (getInfo body') }
cond' <- optimizeFunction optimizeM info' cond
constructFeat sym (init' :* cond' :* body' :* Nil)
constructFeatOpt feat args = constructFeatUnOpt feat args
constructFeatUnOpt x@(C' _) = constructFeatUnOptDefault x