module Feldspar.Compiler.Imperative.FromCore.Array where
import Language.Syntactic
import Language.Syntactic.Constructs.Binding
import Language.Syntactic.Constructs.Binding.HigherOrder
import Feldspar.Core.Types as Core
import Feldspar.Core.Interpretation
import Feldspar.Core.Constructs.Array
import Feldspar.Core.Constructs.Binding
import Feldspar.Core.Constructs.Literal
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 (Array :|| Type) dom
where
compileProgSym (C' Parallel) _ loc (len :* (lam :$ ixf) :* Nil)
| Just (SubConstr2 (Lambda v)) <- prjLambda lam
= do
let ta = argType $ infoType $ getInfo lam
let sa = defaultSize ta
let ix@(Var _ name) = mkVar (compileTypeRep ta sa) v
len' <- mkLength len
(_, Bl ds body) <- confiscateBlock $ compileProg (loc :!: ix) ixf
tellProg [initArray loc len']
tellProg [For name len' 1 (Block ds body)]
compileProgSym (C' Sequential) _ loc (len :* st :* (lam1 :$ (lam2 :$ step)) :* Nil)
| Just (SubConstr2 (Lambda v)) <- prjLambda lam1
, Just (SubConstr2 (Lambda s)) <- prjLambda lam2
= do
let t = argType $ infoType $ getInfo lam1
let sz = defaultSize t
let ta' = argType $ infoType $ getInfo lam2
let sa' = defaultSize ta'
let tr' = resType $ infoType $ getInfo lam2
let sr' = defaultSize tr'
let ix@(Var _ name) = mkVar (compileTypeRep t sz) v
let stv = mkVar (compileTypeRep ta' sa') s
len' <- mkLength len
tmp <- freshVar "seq" tr' sr'
initSt <- compileExpr st
(_, Bl ds (Seq body)) <- confiscateBlock $ compileProg tmp step
tellProg [initArray loc len']
tellProg [Block (ds ++ [toIni stv initSt]) $
For name len' 1 $
Seq (body ++
[assignProg (loc :!: ix) (tmp :.: "member1")
,assignProg stv (tmp :.: "member2")
])]
where toIni (Var ty str) = Init ty str
compileProgSym (C' Append) _ loc (a :* b :* Nil) = do
a' <- compileExpr a
b' <- compileExpr b
let aLen = arrayLength a'
let bLen = arrayLength b'
tellProg [initArray loc $ Binop U32 "+" [aLen, bLen]]
tellProg [copyProg loc a']
tellProg [copyProgPos loc aLen b']
compileProgSym (C' SetIx) _ loc (arr :* i :* a :* Nil) = do
compileProg loc arr
i' <- compileExpr i
compileProg (loc :!: i') a
compileProgSym (C' SetLength) _ loc (len :* arr :* Nil) = do
len' <- compileExpr len
tellProg [setLength loc len']
compileProg loc arr
compileProgSym a info loc args = compileExprLoc a info loc args
compileExprSym (C' GetLength) info (a :* Nil) = do
aExpr <- compileExpr a
return $ Fun (compileTypeRep (infoType info) (infoSize info)) "getLength" [aExpr]
compileExprSym (C' GetIx) _ (arr :* i :* Nil) = do
a' <- compileExpr arr
i' <- compileExpr i
return $ a' :!: i'
compileExprSym a info args = compileProgFresh a info args