module Feldspar.Compiler.Imperative.FromCore.Interpretation where
import Control.Arrow
import Control.Monad.RWS
import Language.Syntactic.Syntax hiding (result)
import Language.Syntactic.Traversal
import Language.Syntactic.Constraint
import Language.Syntactic.Constructs.Binding (VarId)
import Feldspar.Range
import Feldspar.Core.Types hiding (Type)
import Feldspar.Core.Interpretation
import qualified Feldspar.Core.Types as Core
import qualified Feldspar.Core.Constructs.Binding as Core
import qualified Feldspar.Core.Constructs.Literal as Core
import Feldspar.Compiler.Imperative.Frontend
import Feldspar.Compiler.Imperative.Representation (typeof)
type CodeWriter = RWS Readers Writers States
data Readers = Readers { alias :: [(VarId, Expr)]
, sourceInfo :: SourceInfo
}
initReader :: Readers
initReader = Readers [] ""
data Writers = Writers { block :: Block
, def :: [Ent]
}
instance Monoid Writers
where
mempty = Writers { block = mempty
, def = mempty
}
mappend a b = Writers { block = mappend (block a) (block b)
, def = mappend (def a) (def b)
}
type Task = [Prog]
data States = States { fresh :: Integer
}
initState :: States
initState = States 0
type Location = Expr
class Compile sub dom
where
compileProgSym
:: sub a
-> Info (DenResult a)
-> Location
-> Args (AST (Decor Info dom)) a
-> CodeWriter ()
compileProgSym = compileExprLoc
compileExprSym
:: sub a
-> Info (DenResult a)
-> Args (AST (Decor Info dom)) a
-> CodeWriter Expr
compileExprSym = compileProgFresh
instance (Compile sub1 dom, Compile sub2 dom) =>
Compile (sub1 :+: sub2) dom
where
compileProgSym (InjL a) = compileProgSym a
compileProgSym (InjR a) = compileProgSym a
compileExprSym (InjL a) = compileExprSym a
compileExprSym (InjR a) = compileExprSym a
compileExprLoc :: Compile sub dom
=> sub a
-> Info (DenResult a)
-> Location
-> Args (AST (Decor Info dom)) a
-> CodeWriter ()
compileExprLoc a info loc args = do
expr <- compileExprSym a info args
assign loc expr
compileProgFresh :: Compile sub dom
=> sub a
-> Info (DenResult a)
-> Args (AST (Decor Info dom)) a
-> CodeWriter Expr
compileProgFresh a info args = do
loc <- freshVar "e" (infoType info) (infoSize info)
compileProgSym a info loc args
return loc
compileProgDecor :: Compile dom dom
=> Location
-> Decor Info dom a
-> Args (AST (Decor Info dom)) a
-> CodeWriter ()
compileProgDecor result (Decor info a) args = do
let src = infoSource info
aboveSrc <- asks sourceInfo
unless (null src || src==aboveSrc) $ tellProg [BComment src]
local (\env -> env {sourceInfo = src}) $ compileProgSym a info result args
compileExprDecor :: Compile dom dom
=> Decor Info dom a
-> Args (AST (Decor Info dom)) a
-> CodeWriter Expr
compileExprDecor (Decor info a) args = do
let src = infoSource info
aboveSrc <- asks sourceInfo
unless (null src || src==aboveSrc) $ tellProg [BComment src]
local (\env -> env {sourceInfo = src}) $ compileExprSym a info args
compileProg :: Compile dom dom =>
Location -> ASTF (Decor Info dom) a -> CodeWriter ()
compileProg result = simpleMatch (compileProgDecor result)
compileExpr :: Compile dom dom => ASTF (Decor Info dom) a -> CodeWriter Expr
compileExpr = simpleMatch compileExprDecor
compileExprVar :: Compile dom dom => ASTF (Decor Info dom) a -> CodeWriter Expr
compileExprVar e = do
e' <- compileExpr e
case e' of
Var _ _ -> return e'
Ptr _ _ -> return e'
_ -> do
varId <- freshId
let loc = Var (typeof e') ('e' : show varId)
declare loc
assign loc e'
return loc
compileNumType :: Signedness a -> BitWidth n -> Type
compileNumType U N8 = U8
compileNumType S N8 = I8
compileNumType U N16 = U16
compileNumType S N16 = I16
compileNumType U N32 = U32
compileNumType S N32 = I32
compileNumType U N64 = U64
compileNumType S N64 = I64
compileNumType U NNative = U32
compileNumType S NNative = I32
compileTypeRep :: TypeRep a -> Size a -> Type
compileTypeRep UnitType _ = Void
compileTypeRep BoolType _ = Boolean
compileTypeRep (IntType s n) _ = compileNumType s n
compileTypeRep FloatType _ = Floating
compileTypeRep (ComplexType t) _ = Complex (compileTypeRep t (defaultSize t))
compileTypeRep (Tup2Type a b) (sa,sb) = Struct
[ ("member1", compileTypeRep a sa)
, ("member2", compileTypeRep b sb)
]
compileTypeRep (Tup3Type a b c) (sa,sb,sc) = Struct
[ ("member1", compileTypeRep a sa)
, ("member2", compileTypeRep b sb)
, ("member3", compileTypeRep c sc)
]
compileTypeRep (Tup4Type a b c d) (sa,sb,sc,sd) = Struct
[ ("member1", compileTypeRep a sa)
, ("member2", compileTypeRep b sb)
, ("member3", compileTypeRep c sc)
, ("member4", compileTypeRep d sd)
]
compileTypeRep (Tup5Type a b c d e) (sa,sb,sc,sd,se) = Struct
[ ("member1", compileTypeRep a sa)
, ("member2", compileTypeRep b sb)
, ("member3", compileTypeRep c sc)
, ("member4", compileTypeRep d sd)
, ("member5", compileTypeRep e se)
]
compileTypeRep (Tup6Type a b c d e f) (sa,sb,sc,sd,se,sf) = Struct
[ ("member1", compileTypeRep a sa)
, ("member2", compileTypeRep b sb)
, ("member3", compileTypeRep c sc)
, ("member4", compileTypeRep d sd)
, ("member5", compileTypeRep e se)
, ("member6", compileTypeRep f sf)
]
compileTypeRep (Tup7Type a b c d e f g) (sa,sb,sc,sd,se,sf,sg) = Struct
[ ("member1", compileTypeRep a sa)
, ("member2", compileTypeRep b sb)
, ("member3", compileTypeRep c sc)
, ("member4", compileTypeRep d sd)
, ("member5", compileTypeRep e se)
, ("member6", compileTypeRep f sf)
, ("member7", compileTypeRep g sg)
]
compileTypeRep (MutType a) _ = compileTypeRep a (defaultSize a)
compileTypeRep (RefType a) _ = compileTypeRep a (defaultSize a)
compileTypeRep (ArrayType a) (rs :> es) = if unboundedLength
then Array $ compileTypeRep a es
else SizedArray (fromEnum $ upperBound rs) $ compileTypeRep a es
where
unboundedLength
= upperBound rs > fromIntegral (maxBound :: Int)
|| upperBound rs == maxBound
compileTypeRep (MArrType a) _ = Array (compileTypeRep a (defaultSize a))
compileTypeRep (ParType a) _ = compileTypeRep a (defaultSize a)
compileTypeRep (IVarType a) _ = IVar $ compileTypeRep a $ defaultSize a
compileTypeRep (FunType _ b) sz = compileTypeRep b sz
compileTypeRep (FValType a) sz = IVar $ compileTypeRep a sz
compileTypeRep typ _ = error $ "compileTypeRep: missing " ++ show typ
mkVarName :: VarId -> String
mkVarName v = 'v' : show v
mkVar :: Type -> VarId -> Expr
mkVar t = Var t . mkVarName
mkVariable :: Type -> VarId -> Var
mkVariable t = Variable t . mkVarName
freshId :: CodeWriter Integer
freshId = do
s <- get
let v = fresh s
put (s {fresh = v + 1})
return v
freshVar :: String -> TypeRep a -> Size a -> CodeWriter Expr
freshVar base t size = do
v <- freshId
let var =Var (compileTypeRep t size) $ base ++ show v
declare var
return var
declare :: Expr -> CodeWriter ()
declare (Var t n) = tellDecl [Def t n]
declare (Ptr t n) = tellDecl [Def t n]
declare expr = error $ "declare: cannot declare expression: " ++ show expr
tellDef :: [Ent] -> CodeWriter ()
tellDef es = tell $ mempty {def = es}
tellProg :: [Prog] -> CodeWriter ()
tellProg ps = tell $ mempty {block = Bl [] $ Seq ps}
tellDecl :: [Def] -> CodeWriter ()
tellDecl ds = tell $ mempty {block = Bl ds $ Seq []}
assign :: Location -> Expr -> CodeWriter ()
assign lhs rhs = if isArray $ typeof lhs
then
tellProg [ initArray lhs $ arrayLength rhs
, copyProg lhs rhs]
else
tellProg [copyProg lhs rhs]
confiscateBlock :: CodeWriter a -> CodeWriter (a, Block)
confiscateBlock m
= liftM (second block)
$ censor (\rec -> rec {block = mempty})
$ listen m
withAlias :: VarId -> Expr -> CodeWriter a -> CodeWriter a
withAlias v0 expr =
local (\e -> e {alias = (v0,expr) : alias e})
isVariableOrLiteral :: ( Project (Core.Variable :|| Core.Type) dom
, Project (Core.Literal :|| Core.Type) dom)
=> AST (Decor info dom) a -> Bool
isVariableOrLiteral (prjF -> Just (C' (Core.Literal _))) = True
isVariableOrLiteral (prjF -> Just (C' (Core.Variable _))) = True
isVariableOrLiteral _ = False
mkLength :: ( Project (Core.Literal :|| Core.Type) dom
, Project (Core.Variable :|| Core.Type) dom
, Compile dom dom
)
=> ASTF (Decor Info dom) a -> CodeWriter Expr
mkLength a | isVariableOrLiteral a = compileExpr a
| otherwise = do
let lentyp = IntType U N32
lenvar <- freshVar "len" lentyp (defaultSize lentyp)
compileProg lenvar a
return lenvar