{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Copilot.Compile.C99.CodeGen where
import Control.Monad.State (runState)
import Data.List (union, unzip4)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Typeable (Typeable)
import qualified Language.C99.Simple as C
import Copilot.Core
import Copilot.Compile.C99.Util
import Copilot.Compile.C99.External
import Copilot.Compile.C99.Settings
import Copilot.Compile.C99.Translate
gendecln :: String -> Type a -> C.Decln
gendecln :: forall a. String -> Type a -> Decln
gendecln String
name Type a
ty = Maybe StorageSpec -> Type -> String -> [Param] -> Decln
C.FunDecln forall a. Maybe a
Nothing Type
cty String
name []
where
cty :: Type
cty = Type -> Type
C.decay forall a b. (a -> b) -> a -> b
$ forall a. Type a -> Type
transtype Type a
ty
genfun :: String -> Expr a -> Type a -> C.FunDef
genfun :: forall a. String -> Expr a -> Type a -> FunDef
genfun String
name Expr a
expr Type a
ty = Type -> String -> [Param] -> FunEnv -> [Stmt] -> FunDef
C.FunDef Type
cty String
name [] FunEnv
cvars [Maybe Expr -> Stmt
C.Return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Expr
cexpr]
where
cty :: Type
cty = Type -> Type
C.decay forall a b. (a -> b) -> a -> b
$ forall a. Type a -> Type
transtype Type a
ty
(Expr
cexpr, FunEnv
cvars) = forall s a. State s a -> s -> (a, s)
runState (forall a. Expr a -> State FunEnv Expr
transexpr Expr a
expr) forall a. Monoid a => a
mempty
mkextdecln :: External -> C.Decln
mkextdecln :: External -> Decln
mkextdecln (External String
name String
_ Type a
ty) = Decln
decln
where
decln :: Decln
decln = Maybe StorageSpec -> Type -> String -> Maybe Init -> Decln
C.VarDecln (forall a. a -> Maybe a
Just StorageSpec
C.Extern) Type
cty String
name forall a. Maybe a
Nothing
cty :: Type
cty = forall a. Type a -> Type
transtype Type a
ty
mkextcpydecln :: External -> C.Decln
mkextcpydecln :: External -> Decln
mkextcpydecln (External String
name String
cpyname Type a
ty) = Decln
decln
where
cty :: Type
cty = forall a. Type a -> Type
transtype Type a
ty
decln :: Decln
decln = Maybe StorageSpec -> Type -> String -> Maybe Init -> Decln
C.VarDecln (forall a. a -> Maybe a
Just StorageSpec
C.Static) Type
cty String
cpyname forall a. Maybe a
Nothing
mkbuffdecln :: Id -> Type a -> [a] -> C.Decln
mkbuffdecln :: forall a. Id -> Type a -> [a] -> Decln
mkbuffdecln Id
sid Type a
ty [a]
xs = Maybe StorageSpec -> Type -> String -> Maybe Init -> Decln
C.VarDecln (forall a. a -> Maybe a
Just StorageSpec
C.Static) Type
cty String
name Maybe Init
initvals
where
name :: String
name = Id -> String
streamname Id
sid
cty :: Type
cty = Type -> Maybe Expr -> Type
C.Array (forall a. Type a -> Type
transtype Type a
ty) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Expr
C.LitInt forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Id
buffsize)
buffsize :: Id
buffsize = forall (t :: * -> *) a. Foldable t => t a -> Id
length [a]
xs
initvals :: Maybe Init
initvals = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ NonEmpty InitItem -> Init
C.InitList forall a b. (a -> b) -> a -> b
$ forall a. Type a -> [a] -> NonEmpty InitItem
constarray Type a
ty [a]
xs
mkindexdecln :: Id -> C.Decln
mkindexdecln :: Id -> Decln
mkindexdecln Id
sid = Maybe StorageSpec -> Type -> String -> Maybe Init -> Decln
C.VarDecln (forall a. a -> Maybe a
Just StorageSpec
C.Static) Type
cty String
name Maybe Init
initval
where
name :: String
name = Id -> String
indexname Id
sid
cty :: Type
cty = TypeSpec -> Type
C.TypeSpec forall a b. (a -> b) -> a -> b
$ String -> TypeSpec
C.TypedefName String
"size_t"
initval :: Maybe Init
initval = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Expr -> Init
C.InitExpr forall a b. (a -> b) -> a -> b
$ Integer -> Expr
C.LitInt Integer
0
mkaccessdecln :: Id -> Type a -> [a] -> C.FunDef
mkaccessdecln :: forall a. Id -> Type a -> [a] -> FunDef
mkaccessdecln Id
sid Type a
ty [a]
xs = Type -> String -> [Param] -> FunEnv -> [Stmt] -> FunDef
C.FunDef Type
cty String
name [Param]
params [] [Maybe Expr -> Stmt
C.Return (forall a. a -> Maybe a
Just Expr
expr)]
where
cty :: Type
cty = Type -> Type
C.decay forall a b. (a -> b) -> a -> b
$ forall a. Type a -> Type
transtype Type a
ty
name :: String
name = Id -> String
streamaccessorname Id
sid
bufflength :: Expr
bufflength = Integer -> Expr
C.LitInt forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Id
length [a]
xs
params :: [Param]
params = [Type -> String -> Param
C.Param (TypeSpec -> Type
C.TypeSpec forall a b. (a -> b) -> a -> b
$ String -> TypeSpec
C.TypedefName String
"size_t") String
"x"]
index :: Expr
index = (String -> Expr
C.Ident (Id -> String
indexname Id
sid) Expr -> Expr -> Expr
C..+ String -> Expr
C.Ident String
"x") Expr -> Expr -> Expr
C..% Expr
bufflength
expr :: Expr
expr = Expr -> Expr -> Expr
C.Index (String -> Expr
C.Ident (Id -> String
streamname Id
sid)) Expr
index
mkstep :: CSettings -> [Stream] -> [Trigger] -> [External] -> C.FunDef
mkstep :: CSettings -> [Stream] -> [Trigger] -> [External] -> FunDef
mkstep CSettings
cSettings [Stream]
streams [Trigger]
triggers [External]
exts =
Type -> String -> [Param] -> FunEnv -> [Stmt] -> FunDef
C.FunDef Type
void (CSettings -> String
cSettingsStepFunctionName CSettings
cSettings) [] FunEnv
declns [Stmt]
stmts
where
void :: Type
void = TypeSpec -> Type
C.TypeSpec TypeSpec
C.Void
stmts :: [Stmt]
stmts = forall a b. (a -> b) -> [a] -> [b]
map External -> Stmt
mkexcopy [External]
exts
forall a. [a] -> [a] -> [a]
++ [Stmt]
triggerStmts
forall a. [a] -> [a] -> [a]
++ [Stmt]
tmpassigns
forall a. [a] -> [a] -> [a]
++ [Stmt]
bufferupdates
forall a. [a] -> [a] -> [a]
++ [Stmt]
indexupdates
declns :: FunEnv
declns = FunEnv
streamDeclns
forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [FunEnv]
triggerDeclns
(FunEnv
streamDeclns, [Stmt]
tmpassigns, [Stmt]
bufferupdates, [Stmt]
indexupdates) =
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Stream -> (Decln, Stmt, Stmt, Stmt)
mkupdateglobals [Stream]
streams
([FunEnv]
triggerDeclns, [Stmt]
triggerStmts) =
forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Trigger -> (FunEnv, Stmt)
mktriggercheck [Trigger]
triggers
mkupdateglobals :: Stream -> (C.Decln, C.Stmt, C.Stmt, C.Stmt)
mkupdateglobals :: Stream -> (Decln, Stmt, Stmt, Stmt)
mkupdateglobals (Stream Id
sid [a]
buff Expr a
expr Type a
ty) =
(Decln
tmpdecln, Stmt
tmpassign, Stmt
bufferupdate, Stmt
indexupdate)
where
tmpdecln :: Decln
tmpdecln = Maybe StorageSpec -> Type -> String -> Maybe Init -> Decln
C.VarDecln forall a. Maybe a
Nothing Type
cty String
tmp_var forall a. Maybe a
Nothing
tmpassign :: Stmt
tmpassign = case Type a
ty of
Array Type t
_ -> Expr -> Stmt
C.Expr forall a b. (a -> b) -> a -> b
$ Expr -> Expr -> Expr -> Expr
memcpy (String -> Expr
C.Ident String
tmp_var) Expr
val Expr
size
where
size :: Expr
size = Integer -> Expr
C.LitInt (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (n :: Nat) t. KnownNat n => Type (Array n t) -> Id
tysize Type a
ty)
Expr -> Expr -> Expr
C..* TypeName -> Expr
C.SizeOfType (Type -> TypeName
C.TypeName (forall a. Type a -> Type
tyElemName Type a
ty))
Type a
_ -> Expr -> Stmt
C.Expr forall a b. (a -> b) -> a -> b
$ String -> Expr
C.Ident String
tmp_var Expr -> Expr -> Expr
C..= Expr
val
bufferupdate :: Stmt
bufferupdate = case Type a
ty of
Array Type t
_ -> Expr -> Stmt
C.Expr forall a b. (a -> b) -> a -> b
$ Expr -> Expr -> Expr -> Expr
memcpy Expr
dest (String -> Expr
C.Ident String
tmp_var) Expr
size
where
dest :: Expr
dest = Expr -> Expr -> Expr
C.Index Expr
buff_var Expr
index_var
size :: Expr
size = Integer -> Expr
C.LitInt (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (n :: Nat) t. KnownNat n => Type (Array n t) -> Id
tysize Type a
ty)
Expr -> Expr -> Expr
C..* TypeName -> Expr
C.SizeOfType (Type -> TypeName
C.TypeName (forall a. Type a -> Type
tyElemName Type a
ty))
Type a
_ -> Expr -> Stmt
C.Expr forall a b. (a -> b) -> a -> b
$
Expr -> Expr -> Expr
C.Index Expr
buff_var Expr
index_var Expr -> Expr -> Expr
C..= (String -> Expr
C.Ident String
tmp_var)
indexupdate :: Stmt
indexupdate = Expr -> Stmt
C.Expr forall a b. (a -> b) -> a -> b
$ Expr
index_var Expr -> Expr -> Expr
C..= (Expr
incindex Expr -> Expr -> Expr
C..% Expr
bufflength)
where
bufflength :: Expr
bufflength = Integer -> Expr
C.LitInt forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Id
length [a]
buff
incindex :: Expr
incindex = Expr
index_var Expr -> Expr -> Expr
C..+ Integer -> Expr
C.LitInt Integer
1
tmp_var :: String
tmp_var = Id -> String
streamname Id
sid forall a. [a] -> [a] -> [a]
++ String
"_tmp"
buff_var :: Expr
buff_var = String -> Expr
C.Ident forall a b. (a -> b) -> a -> b
$ Id -> String
streamname Id
sid
index_var :: Expr
index_var = String -> Expr
C.Ident forall a b. (a -> b) -> a -> b
$ Id -> String
indexname Id
sid
val :: Expr
val = Expr -> [Expr] -> Expr
C.Funcall (String -> Expr
C.Ident forall a b. (a -> b) -> a -> b
$ Id -> String
generatorname Id
sid) []
cty :: Type
cty = forall a. Type a -> Type
transtype Type a
ty
mkexcopy :: External -> C.Stmt
mkexcopy :: External -> Stmt
mkexcopy (External String
name String
cpyname Type a
ty) = Expr -> Stmt
C.Expr forall a b. (a -> b) -> a -> b
$ case Type a
ty of
Array Type t
_ -> Expr -> Expr -> Expr -> Expr
memcpy Expr
exvar Expr
locvar Expr
size
where
exvar :: Expr
exvar = String -> Expr
C.Ident String
cpyname
locvar :: Expr
locvar = String -> Expr
C.Ident String
name
size :: Expr
size = Integer -> Expr
C.LitInt (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (n :: Nat) t. KnownNat n => Type (Array n t) -> Id
tysize Type a
ty)
Expr -> Expr -> Expr
C..* TypeName -> Expr
C.SizeOfType (Type -> TypeName
C.TypeName (forall a. Type a -> Type
tyElemName Type a
ty))
Type a
_ -> String -> Expr
C.Ident String
cpyname Expr -> Expr -> Expr
C..= String -> Expr
C.Ident String
name
mktriggercheck :: Trigger -> ([C.Decln], C.Stmt)
mktriggercheck :: Trigger -> (FunEnv, Stmt)
mktriggercheck (Trigger String
name Expr Bool
guard [UExpr]
args) =
(FunEnv
aTmpDeclns, Stmt
ifStmt)
where
aTmpDeclns :: FunEnv
aTmpDeclns = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\String
tmpVar UExpr
arg ->
Maybe StorageSpec -> Type -> String -> Maybe Init -> Decln
C.VarDecln forall a. Maybe a
Nothing (UExpr -> Type
tempType UExpr
arg) String
tmpVar forall a. Maybe a
Nothing)
[String]
aTempNames
[UExpr]
args
where
tempType :: UExpr -> Type
tempType (UExpr { uExprType :: ()
uExprType = Type a
ty }) =
case Type a
ty of
Array Type t
ty' -> Type -> Type
C.Ptr forall a b. (a -> b) -> a -> b
$ forall a. Type a -> Type
transtype Type t
ty'
Type a
_ -> forall a. Type a -> Type
transtype Type a
ty
aTempNames :: [String]
aTempNames = forall a. Id -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Id
length [UExpr]
args) (String -> [String]
argTempNames String
name)
ifStmt :: Stmt
ifStmt = Expr -> [Stmt] -> Stmt
C.If Expr
guard' [Stmt]
firetrigger
guard' :: Expr
guard' = Expr -> [Expr] -> Expr
C.Funcall (String -> Expr
C.Ident forall a b. (a -> b) -> a -> b
$ String -> String
guardname String
name) []
firetrigger :: [Stmt]
firetrigger = forall a b. (a -> b) -> [a] -> [b]
map Expr -> Stmt
C.Expr [Expr]
argAssigns forall a. [a] -> [a] -> [a]
++
[Expr -> Stmt
C.Expr forall a b. (a -> b) -> a -> b
$ Expr -> [Expr] -> Expr
C.Funcall (String -> Expr
C.Ident String
name)
(forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith String -> UExpr -> Expr
passArg [String]
aTempNames [UExpr]
args)]
where
passArg :: String -> UExpr -> Expr
passArg String
aTempName (UExpr { uExprType :: ()
uExprType = Type a
ty }) =
case Type a
ty of
Struct a
_ -> UnaryOp -> Expr -> Expr
C.UnaryOp UnaryOp
C.Ref forall a b. (a -> b) -> a -> b
$ String -> Expr
C.Ident String
aTempName
Type a
_ -> String -> Expr
C.Ident String
aTempName
argAssigns :: [Expr]
argAssigns = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\String
aTempName Expr
arg ->
AssignOp -> Expr -> Expr -> Expr
C.AssignOp AssignOp
C.Assign (String -> Expr
C.Ident String
aTempName) Expr
arg)
[String]
aTempNames
[Expr]
args'
args' :: [Expr]
args' = forall a. Id -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Id
length [UExpr]
args) (forall a b. (a -> b) -> [a] -> [b]
map String -> Expr
argcall (String -> [String]
argnames String
name))
argcall :: String -> Expr
argcall String
name = Expr -> [Expr] -> Expr
C.Funcall (String -> Expr
C.Ident String
name) []
memcpy :: C.Expr -> C.Expr -> C.Expr -> C.Expr
memcpy :: Expr -> Expr -> Expr -> Expr
memcpy Expr
dest Expr
src Expr
size = Expr -> [Expr] -> Expr
C.Funcall (String -> Expr
C.Ident String
"memcpy") [Expr
dest, Expr
src, Expr
size]
tyElemName :: Type a -> C.Type
tyElemName :: forall a. Type a -> Type
tyElemName Type a
ty = case Type a
ty of
Array Type t
ty' -> forall a. Type a -> Type
tyElemName Type t
ty'
Type a
_ -> forall a. Type a -> Type
transtype Type a
ty
mkstructdecln :: Struct a => Type a -> C.Decln
mkstructdecln :: forall a. Struct a => Type a -> Decln
mkstructdecln (Struct a
x) = Type -> Decln
C.TypeDecln Type
struct
where
struct :: Type
struct = TypeSpec -> Type
C.TypeSpec forall a b. (a -> b) -> a -> b
$ Maybe String -> NonEmpty FieldDecln -> TypeSpec
C.StructDecln (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Struct a => a -> String
typename a
x) NonEmpty FieldDecln
fields
fields :: NonEmpty FieldDecln
fields = forall a. [a] -> NonEmpty a
NonEmpty.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Value a -> FieldDecln
mkfield (forall a. Struct a => a -> [Value a]
toValues a
x)
mkfield :: Value a -> C.FieldDecln
mkfield :: forall a. Value a -> FieldDecln
mkfield (Value Type t
ty Field s t
field) = Type -> String -> FieldDecln
C.FieldDecln (forall a. Type a -> Type
transtype Type t
ty) (forall (s :: Symbol) t. KnownSymbol s => Field s t -> String
fieldname Field s t
field)
mkstructforwdecln :: Struct a => Type a -> C.Decln
mkstructforwdecln :: forall a. Struct a => Type a -> Decln
mkstructforwdecln (Struct a
x) = Type -> Decln
C.TypeDecln Type
struct
where
struct :: Type
struct = TypeSpec -> Type
C.TypeSpec forall a b. (a -> b) -> a -> b
$ String -> TypeSpec
C.Struct (forall a. Struct a => a -> String
typename a
x)
exprtypes :: Typeable a => Expr a -> [UType]
exprtypes :: forall a. Typeable a => Expr a -> [UType]
exprtypes Expr a
e = case Expr a
e of
Const Type a
ty a
_ -> forall a. Typeable a => Type a -> [UType]
typetypes Type a
ty
Local Type a1
ty1 Type a
ty2 String
_ Expr a1
e1 Expr a
e2 -> forall a. Typeable a => Type a -> [UType]
typetypes Type a1
ty1 forall a. Eq a => [a] -> [a] -> [a]
`union` forall a. Typeable a => Type a -> [UType]
typetypes Type a
ty2
forall a. Eq a => [a] -> [a] -> [a]
`union` forall a. Typeable a => Expr a -> [UType]
exprtypes Expr a1
e1 forall a. Eq a => [a] -> [a] -> [a]
`union` forall a. Typeable a => Expr a -> [UType]
exprtypes Expr a
e2
Var Type a
ty String
_ -> forall a. Typeable a => Type a -> [UType]
typetypes Type a
ty
Drop Type a
ty DropIdx
_ Id
_ -> forall a. Typeable a => Type a -> [UType]
typetypes Type a
ty
ExternVar Type a
ty String
_ Maybe [a]
_ -> forall a. Typeable a => Type a -> [UType]
typetypes Type a
ty
Op1 Op1 a1 a
_ Expr a1
e1 -> forall a. Typeable a => Expr a -> [UType]
exprtypes Expr a1
e1
Op2 Op2 a1 b a
_ Expr a1
e1 Expr b
e2 -> forall a. Typeable a => Expr a -> [UType]
exprtypes Expr a1
e1 forall a. Eq a => [a] -> [a] -> [a]
`union` forall a. Typeable a => Expr a -> [UType]
exprtypes Expr b
e2
Op3 Op3 a1 b c a
_ Expr a1
e1 Expr b
e2 Expr c
e3 -> forall a. Typeable a => Expr a -> [UType]
exprtypes Expr a1
e1 forall a. Eq a => [a] -> [a] -> [a]
`union` forall a. Typeable a => Expr a -> [UType]
exprtypes Expr b
e2 forall a. Eq a => [a] -> [a] -> [a]
`union` forall a. Typeable a => Expr a -> [UType]
exprtypes Expr c
e3
Label Type a
ty String
_ Expr a
_ -> forall a. Typeable a => Type a -> [UType]
typetypes Type a
ty
typetypes :: Typeable a => Type a -> [UType]
typetypes :: forall a. Typeable a => Type a -> [UType]
typetypes Type a
ty = case Type a
ty of
Array Type t
ty' -> forall a. Typeable a => Type a -> [UType]
typetypes Type t
ty' forall a. Eq a => [a] -> [a] -> [a]
`union` [forall a. Typeable a => Type a -> UType
UType Type a
ty]
Struct a
x -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Value Type t
ty' Field s t
_) -> forall a. Typeable a => Type a -> [UType]
typetypes Type t
ty') (forall a. Struct a => a -> [Value a]
toValues a
x) forall a. Eq a => [a] -> [a] -> [a]
`union` [forall a. Typeable a => Type a -> UType
UType Type a
ty]
Type a
_ -> [forall a. Typeable a => Type a -> UType
UType Type a
ty]
gatherexprs :: [Stream] -> [Trigger] -> [UExpr]
gatherexprs :: [Stream] -> [Trigger] -> [UExpr]
gatherexprs [Stream]
streams [Trigger]
triggers = forall a b. (a -> b) -> [a] -> [b]
map Stream -> UExpr
streamexpr [Stream]
streams
forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Trigger -> [UExpr]
triggerexpr [Trigger]
triggers
where
streamexpr :: Stream -> UExpr
streamexpr (Stream Id
_ [a]
_ Expr a
expr Type a
ty) = forall a. Typeable a => Type a -> Expr a -> UExpr
UExpr Type a
ty Expr a
expr
triggerexpr :: Trigger -> [UExpr]
triggerexpr (Trigger String
_ Expr Bool
guard [UExpr]
args) = forall a. Typeable a => Type a -> Expr a -> UExpr
UExpr Type Bool
Bool Expr Bool
guard forall a. a -> [a] -> [a]
: [UExpr]
args