module Feldspar.Compiler.Imperative.FromCore.Literal where
import Control.Monad.RWS
import Data.Complex
import GHC.Float (float2Double)
import Language.Syntactic
import Feldspar.Core.Types as Core
import Feldspar.Core.Interpretation
import Feldspar.Core.Constructs.Literal
import Feldspar.Range (upperBound)
import Feldspar.Compiler.Imperative.Frontend
import Feldspar.Compiler.Imperative.FromCore.Interpretation
instance Compile (Literal :|| Core.Type) dom
where
compileExprSym (C' (Literal a)) info Nil = literal (infoType info) (infoSize info) a
compileProgSym (C' (Literal a)) info loc Nil = literalLoc loc (infoType info) (infoSize info) a
literal :: TypeRep a -> Size a -> a -> CodeWriter Expr
literal UnitType _ () = return $ LitI I32 0
literal BoolType _ a = return $ boolToExpr a
literal trep@IntType{} sz a = return $ LitI (compileTypeRep trep sz) (toInteger a)
literal FloatType _ a = return $ LitF $ float2Double a
literal (ComplexType t) _ (r:+i) = do re <- literal t (defaultSize t) r
ie <- literal t (defaultSize t) i
return $ LitC re ie
literal t s a = do loc <- freshVar "x" t s
literalLoc loc t s a
return loc
literalLoc :: Location -> TypeRep a -> Size a -> a -> CodeWriter ()
literalLoc loc (ArrayType t) (rs :> es) e
= do
tellProg [initArray loc $ LitI I32 $ toInteger $ upperBound rs]
zipWithM_ (writeElement t es) (map (LitI I32) [0..]) e
where writeElement :: TypeRep a -> Size a -> Expr -> a -> CodeWriter ()
writeElement ty sz ix x = do
expr <- literal ty sz x
assign (loc :!: ix) expr
literalLoc loc (Tup2Type ta tb) (sa,sb) (a,b) =
do aExpr <- literal ta sa a
bExpr <- literal tb sb b
assign (loc :.: "member1") aExpr
assign (loc :.: "member2") bExpr
literalLoc loc (Tup3Type ta tb tc) (sa,sb,sc) (a,b,c) =
do aExpr <- literal ta sa a
bExpr <- literal tb sb b
cExpr <- literal tc sc c
assign (loc :.: "member1") aExpr
assign (loc :.: "member2") bExpr
assign (loc :.: "member3") cExpr
literalLoc loc (Tup4Type ta tb tc td) (sa,sb,sc,sd) (a,b,c,d) =
do aExpr <- literal ta sa a
bExpr <- literal tb sb b
cExpr <- literal tc sc c
dExpr <- literal td sd d
assign (loc :.: "member1") aExpr
assign (loc :.: "member2") bExpr
assign (loc :.: "member3") cExpr
assign (loc :.: "member4") dExpr
literalLoc loc (Tup5Type ta tb tc td te) (sa,sb,sc,sd,se) (a,b,c,d,e) =
do aExpr <- literal ta sa a
bExpr <- literal tb sb b
cExpr <- literal tc sc c
dExpr <- literal td sd d
eExpr <- literal te se e
assign (loc :.: "member1") aExpr
assign (loc :.: "member2") bExpr
assign (loc :.: "member3") cExpr
assign (loc :.: "member4") dExpr
assign (loc :.: "member5") eExpr
literalLoc loc (Tup6Type ta tb tc td te tf) (sa,sb,sc,sd,se,sf) (a,b,c,d,e,f) =
do aExpr <- literal ta sa a
bExpr <- literal tb sb b
cExpr <- literal tc sc c
dExpr <- literal td sd d
eExpr <- literal te se e
fExpr <- literal tf sf f
assign (loc :.: "member1") aExpr
assign (loc :.: "member2") bExpr
assign (loc :.: "member3") cExpr
assign (loc :.: "member4") dExpr
assign (loc :.: "member5") eExpr
assign (loc :.: "member6") fExpr
literalLoc loc (Tup7Type ta tb tc td te tf tg) (sa,sb,sc,sd,se,sf,sg) (a,b,c,d,e,f,g) =
do aExpr <- literal ta sa a
bExpr <- literal tb sb b
cExpr <- literal tc sc c
dExpr <- literal td sd d
eExpr <- literal te se e
fExpr <- literal tf sf f
gExpr <- literal tg sg g
assign (loc :.: "member1") aExpr
assign (loc :.: "member2") bExpr
assign (loc :.: "member3") cExpr
assign (loc :.: "member4") dExpr
assign (loc :.: "member5") eExpr
assign (loc :.: "member6") fExpr
assign (loc :.: "member7") gExpr
literalLoc loc t sz a =
do rhs <- literal t sz a
assign loc rhs