module Feldspar.Compiler.Imperative.FromCore.Loop where
import Prelude hiding (init)
import Language.Syntactic
import Language.Syntactic.Constructs.Binding
import Language.Syntactic.Constructs.Binding.HigherOrder
import Feldspar.Core.Types
import Feldspar.Core.Interpretation
import Feldspar.Core.Constructs.Binding
import Feldspar.Core.Constructs.Loop hiding (For, While)
import Feldspar.Core.Constructs.Literal
import qualified Feldspar.Core.Constructs.Loop as Core
import Feldspar.Compiler.Imperative.Frontend hiding (Type)
import Feldspar.Compiler.Imperative.FromCore.Interpretation
instance ( Compile dom dom
, Project (CLambda Type) dom
, Project (Literal :|| Type) dom
, Project (Variable :|| Type) dom
)
=> Compile (Loop :|| Type) dom
where
compileProgSym (C' ForLoop) _ loc (len :* init :* (lam1 :$ (lam2 :$ ixf)) :* Nil)
| Just (SubConstr2 (Lambda ix)) <- prjLambda lam1
, Just (SubConstr2 (Lambda st)) <- prjLambda lam2
= do
let info1 = getInfo lam1
info2 = getInfo lam2
let (Var _ name) = mkVar (compileTypeRep (infoType info1) (infoSize info1)) ix
let stvar = mkVar (compileTypeRep (infoType info2) (infoSize info2)) st
len' <- mkLength len
compileProg loc init
(_, Bl ds body) <- withAlias st loc $ confiscateBlock $ compileProg stvar ixf >> assign loc stvar
declare stvar
tellProg [For name len' 1 (Block ds body)]
compileProgSym (C' WhileLoop) _ loc (init :* (lam1 :$ cond) :* (lam2 :$ body) :* Nil)
| Just (SubConstr2 (Lambda cv)) <- prjLambda lam1
, Just (SubConstr2 (Lambda cb)) <- prjLambda lam2
= do
let info2 = getInfo lam2
let stvar = mkVar (compileTypeRep (infoType info2) (infoSize info2)) cb
compileProg loc init
cond' <- withAlias cv loc $ compileExpr cond
(_, Bl ds body') <- withAlias cb loc $ confiscateBlock $ compileProg stvar body >> assign loc stvar
declare stvar
tellProg [While Skip cond' (Block ds body')]
instance ( Compile dom dom
, Project (CLambda Type) dom
, Project (Literal :|| Type) dom
, Project (Variable :|| Type) dom
)
=> Compile (LoopM Mut) dom
where
compileProgSym Core.For _ loc (len :* (lam :$ ixf) :* Nil)
| Just (SubConstr2 (Lambda v)) <- prjLambda lam
= do
let ta = argType $ infoType $ getInfo lam
let sa = defaultSize ta
let (Var _ name) = mkVar (compileTypeRep ta sa) v
len' <- mkLength len
(_, Bl _ body) <- confiscateBlock $ compileProg loc ixf
tellProg [For name len' 1 body]
compileProgSym Core.While _ loc (cond :* step :* Nil)
= do
cond' <- compileExpr cond
(_, Bl _ step') <- confiscateBlock $ compileProg loc step
tellProg [While Skip cond' step']