{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TupleSections #-}
module Futhark.CodeGen.ImpCode
( Definitions (..)
, Functions (..)
, Function
, FunctionT (..)
, Constants (..)
, ValueDesc (..)
, Signedness (..)
, ExternalValue (..)
, Param (..)
, paramName
, SubExp(..)
, MemSize
, DimSize
, Type (..)
, Space (..)
, SpaceId
, Code (..)
, PrimValue (..)
, ExpLeaf (..)
, Exp
, Volatility (..)
, Arg (..)
, var
, vi32
, index
, ErrorMsg(..)
, ErrorMsgPart(..)
, errorMsgArgTypes
, ArrayContents(..)
, Bytes
, Elements
, elements
, bytes
, withElemType
, module Language.Futhark.Core
, module Futhark.Representation.Primitive
, module Futhark.Analysis.PrimExp
, module Futhark.Representation.Kernels.Sizes
)
where
import Data.List (intersperse)
import Data.Loc
import Data.Traversable
import Language.Futhark.Core
import Futhark.Representation.Primitive
import Futhark.Representation.AST.Syntax
(SubExp(..), Space(..), SpaceId,
ErrorMsg(..), ErrorMsgPart(..), errorMsgArgTypes)
import Futhark.Representation.AST.Attributes.Names
import Futhark.Representation.AST.Pretty ()
import Futhark.Analysis.PrimExp
import Futhark.Util.Pretty hiding (space)
import Futhark.Representation.Kernels.Sizes (Count(..))
type MemSize = SubExp
type DimSize = SubExp
data Type = Scalar PrimType | Mem Space
data Param = MemParam VName Space
| ScalarParam VName PrimType
deriving (Int -> Param -> ShowS
[Param] -> ShowS
Param -> String
(Int -> Param -> ShowS)
-> (Param -> String) -> ([Param] -> ShowS) -> Show Param
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Param] -> ShowS
$cshowList :: [Param] -> ShowS
show :: Param -> String
$cshow :: Param -> String
showsPrec :: Int -> Param -> ShowS
$cshowsPrec :: Int -> Param -> ShowS
Show)
paramName :: Param -> VName
paramName :: Param -> VName
paramName (MemParam VName
name Space
_) = VName
name
paramName (ScalarParam VName
name PrimType
_) = VName
name
data Definitions a = Definitions (Constants a) (Functions a)
newtype Functions a = Functions [(Name, Function a)]
instance Semigroup (Functions a) where
Functions [(Name, Function a)]
x <> :: Functions a -> Functions a -> Functions a
<> Functions [(Name, Function a)]
y = [(Name, Function a)] -> Functions a
forall a. [(Name, Function a)] -> Functions a
Functions ([(Name, Function a)] -> Functions a)
-> [(Name, Function a)] -> Functions a
forall a b. (a -> b) -> a -> b
$ [(Name, Function a)]
x [(Name, Function a)]
-> [(Name, Function a)] -> [(Name, Function a)]
forall a. [a] -> [a] -> [a]
++ [(Name, Function a)]
y
instance Monoid (Functions a) where
mempty :: Functions a
mempty = [(Name, Function a)] -> Functions a
forall a. [(Name, Function a)] -> Functions a
Functions []
data Constants a = Constants
{ Constants a -> [Param]
constsDecl :: [Param]
, Constants a -> Code a
constsInit :: Code a
}
data Signedness = TypeUnsigned
| TypeDirect
deriving (Signedness -> Signedness -> Bool
(Signedness -> Signedness -> Bool)
-> (Signedness -> Signedness -> Bool) -> Eq Signedness
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Signedness -> Signedness -> Bool
$c/= :: Signedness -> Signedness -> Bool
== :: Signedness -> Signedness -> Bool
$c== :: Signedness -> Signedness -> Bool
Eq, Int -> Signedness -> ShowS
[Signedness] -> ShowS
Signedness -> String
(Int -> Signedness -> ShowS)
-> (Signedness -> String)
-> ([Signedness] -> ShowS)
-> Show Signedness
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Signedness] -> ShowS
$cshowList :: [Signedness] -> ShowS
show :: Signedness -> String
$cshow :: Signedness -> String
showsPrec :: Int -> Signedness -> ShowS
$cshowsPrec :: Int -> Signedness -> ShowS
Show)
data ValueDesc = ArrayValue VName Space PrimType Signedness [DimSize]
| ScalarValue PrimType Signedness VName
deriving (ValueDesc -> ValueDesc -> Bool
(ValueDesc -> ValueDesc -> Bool)
-> (ValueDesc -> ValueDesc -> Bool) -> Eq ValueDesc
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ValueDesc -> ValueDesc -> Bool
$c/= :: ValueDesc -> ValueDesc -> Bool
== :: ValueDesc -> ValueDesc -> Bool
$c== :: ValueDesc -> ValueDesc -> Bool
Eq, Int -> ValueDesc -> ShowS
[ValueDesc] -> ShowS
ValueDesc -> String
(Int -> ValueDesc -> ShowS)
-> (ValueDesc -> String)
-> ([ValueDesc] -> ShowS)
-> Show ValueDesc
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValueDesc] -> ShowS
$cshowList :: [ValueDesc] -> ShowS
show :: ValueDesc -> String
$cshow :: ValueDesc -> String
showsPrec :: Int -> ValueDesc -> ShowS
$cshowsPrec :: Int -> ValueDesc -> ShowS
Show)
data ExternalValue = OpaqueValue String [ValueDesc]
| TransparentValue ValueDesc
deriving (Int -> ExternalValue -> ShowS
[ExternalValue] -> ShowS
ExternalValue -> String
(Int -> ExternalValue -> ShowS)
-> (ExternalValue -> String)
-> ([ExternalValue] -> ShowS)
-> Show ExternalValue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExternalValue] -> ShowS
$cshowList :: [ExternalValue] -> ShowS
show :: ExternalValue -> String
$cshow :: ExternalValue -> String
showsPrec :: Int -> ExternalValue -> ShowS
$cshowsPrec :: Int -> ExternalValue -> ShowS
Show)
data FunctionT a = Function { FunctionT a -> Bool
functionEntry :: Bool
, FunctionT a -> [Param]
functionOutput :: [Param]
, FunctionT a -> [Param]
functionInput :: [Param]
, FunctionT a -> Code a
functionBody :: Code a
, FunctionT a -> [ExternalValue]
functionResult :: [ExternalValue]
, FunctionT a -> [ExternalValue]
functionArgs :: [ExternalValue]
}
deriving (Int -> FunctionT a -> ShowS
[FunctionT a] -> ShowS
FunctionT a -> String
(Int -> FunctionT a -> ShowS)
-> (FunctionT a -> String)
-> ([FunctionT a] -> ShowS)
-> Show (FunctionT a)
forall a. Show a => Int -> FunctionT a -> ShowS
forall a. Show a => [FunctionT a] -> ShowS
forall a. Show a => FunctionT a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FunctionT a] -> ShowS
$cshowList :: forall a. Show a => [FunctionT a] -> ShowS
show :: FunctionT a -> String
$cshow :: forall a. Show a => FunctionT a -> String
showsPrec :: Int -> FunctionT a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> FunctionT a -> ShowS
Show)
type Function = FunctionT
data ArrayContents = ArrayValues [PrimValue]
| ArrayZeros Int
deriving (Int -> ArrayContents -> ShowS
[ArrayContents] -> ShowS
ArrayContents -> String
(Int -> ArrayContents -> ShowS)
-> (ArrayContents -> String)
-> ([ArrayContents] -> ShowS)
-> Show ArrayContents
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ArrayContents] -> ShowS
$cshowList :: [ArrayContents] -> ShowS
show :: ArrayContents -> String
$cshow :: ArrayContents -> String
showsPrec :: Int -> ArrayContents -> ShowS
$cshowsPrec :: Int -> ArrayContents -> ShowS
Show)
data Code a = Skip
| Code a :>>: Code a
| For VName IntType Exp (Code a)
| While Exp (Code a)
| DeclareMem VName Space
| DeclareScalar VName Volatility PrimType
| DeclareArray VName Space PrimType ArrayContents
| Allocate VName (Count Bytes Exp) Space
| Free VName Space
| Copy VName (Count Bytes Exp) Space VName (Count Bytes Exp) Space (Count Bytes Exp)
| Write VName (Count Elements Exp) PrimType Space Volatility Exp
| SetScalar VName Exp
| SetMem VName VName Space
| Call [VName] Name [Arg]
| If Exp (Code a) (Code a)
| Assert Exp (ErrorMsg Exp) (SrcLoc, [SrcLoc])
| String (Code a)
| DebugPrint String (Maybe Exp)
| Op a
deriving (Int -> Code a -> ShowS
[Code a] -> ShowS
Code a -> String
(Int -> Code a -> ShowS)
-> (Code a -> String) -> ([Code a] -> ShowS) -> Show (Code a)
forall a. Show a => Int -> Code a -> ShowS
forall a. Show a => [Code a] -> ShowS
forall a. Show a => Code a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Code a] -> ShowS
$cshowList :: forall a. Show a => [Code a] -> ShowS
show :: Code a -> String
$cshow :: forall a. Show a => Code a -> String
showsPrec :: Int -> Code a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Code a -> ShowS
Show)
data Volatility = Volatile | Nonvolatile
deriving (Volatility -> Volatility -> Bool
(Volatility -> Volatility -> Bool)
-> (Volatility -> Volatility -> Bool) -> Eq Volatility
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Volatility -> Volatility -> Bool
$c/= :: Volatility -> Volatility -> Bool
== :: Volatility -> Volatility -> Bool
$c== :: Volatility -> Volatility -> Bool
Eq, Eq Volatility
Eq Volatility
-> (Volatility -> Volatility -> Ordering)
-> (Volatility -> Volatility -> Bool)
-> (Volatility -> Volatility -> Bool)
-> (Volatility -> Volatility -> Bool)
-> (Volatility -> Volatility -> Bool)
-> (Volatility -> Volatility -> Volatility)
-> (Volatility -> Volatility -> Volatility)
-> Ord Volatility
Volatility -> Volatility -> Bool
Volatility -> Volatility -> Ordering
Volatility -> Volatility -> Volatility
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Volatility -> Volatility -> Volatility
$cmin :: Volatility -> Volatility -> Volatility
max :: Volatility -> Volatility -> Volatility
$cmax :: Volatility -> Volatility -> Volatility
>= :: Volatility -> Volatility -> Bool
$c>= :: Volatility -> Volatility -> Bool
> :: Volatility -> Volatility -> Bool
$c> :: Volatility -> Volatility -> Bool
<= :: Volatility -> Volatility -> Bool
$c<= :: Volatility -> Volatility -> Bool
< :: Volatility -> Volatility -> Bool
$c< :: Volatility -> Volatility -> Bool
compare :: Volatility -> Volatility -> Ordering
$ccompare :: Volatility -> Volatility -> Ordering
$cp1Ord :: Eq Volatility
Ord, Int -> Volatility -> ShowS
[Volatility] -> ShowS
Volatility -> String
(Int -> Volatility -> ShowS)
-> (Volatility -> String)
-> ([Volatility] -> ShowS)
-> Show Volatility
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Volatility] -> ShowS
$cshowList :: [Volatility] -> ShowS
show :: Volatility -> String
$cshow :: Volatility -> String
showsPrec :: Int -> Volatility -> ShowS
$cshowsPrec :: Int -> Volatility -> ShowS
Show)
instance Semigroup (Code a) where
Code a
Skip <> :: Code a -> Code a -> Code a
<> Code a
y = Code a
y
Code a
x <> Code a
Skip = Code a
x
Code a
x <> Code a
y = Code a
x Code a -> Code a -> Code a
forall a. Code a -> Code a -> Code a
:>>: Code a
y
instance Monoid (Code a) where
mempty :: Code a
mempty = Code a
forall a. Code a
Skip
data ExpLeaf = ScalarVar VName
| SizeOf PrimType
| Index VName (Count Elements Exp) PrimType Space Volatility
deriving (ExpLeaf -> ExpLeaf -> Bool
(ExpLeaf -> ExpLeaf -> Bool)
-> (ExpLeaf -> ExpLeaf -> Bool) -> Eq ExpLeaf
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExpLeaf -> ExpLeaf -> Bool
$c/= :: ExpLeaf -> ExpLeaf -> Bool
== :: ExpLeaf -> ExpLeaf -> Bool
$c== :: ExpLeaf -> ExpLeaf -> Bool
Eq, Int -> ExpLeaf -> ShowS
[ExpLeaf] -> ShowS
ExpLeaf -> String
(Int -> ExpLeaf -> ShowS)
-> (ExpLeaf -> String) -> ([ExpLeaf] -> ShowS) -> Show ExpLeaf
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExpLeaf] -> ShowS
$cshowList :: [ExpLeaf] -> ShowS
show :: ExpLeaf -> String
$cshow :: ExpLeaf -> String
showsPrec :: Int -> ExpLeaf -> ShowS
$cshowsPrec :: Int -> ExpLeaf -> ShowS
Show)
type Exp = PrimExp ExpLeaf
data Arg = ExpArg Exp
| MemArg VName
deriving (Int -> Arg -> ShowS
[Arg] -> ShowS
Arg -> String
(Int -> Arg -> ShowS)
-> (Arg -> String) -> ([Arg] -> ShowS) -> Show Arg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Arg] -> ShowS
$cshowList :: [Arg] -> ShowS
show :: Arg -> String
$cshow :: Arg -> String
showsPrec :: Int -> Arg -> ShowS
$cshowsPrec :: Int -> Arg -> ShowS
Show)
data Elements
data Bytes
elements :: Exp -> Count Elements Exp
elements :: Exp -> Count Elements Exp
elements = Exp -> Count Elements Exp
forall u e. e -> Count u e
Count
bytes :: Exp -> Count Bytes Exp
bytes :: Exp -> Count Bytes Exp
bytes = Exp -> Count Bytes Exp
forall u e. e -> Count u e
Count
withElemType :: Count Elements Exp -> PrimType -> Count Bytes Exp
withElemType :: Count Elements Exp -> PrimType -> Count Bytes Exp
withElemType (Count Exp
e) PrimType
t =
Exp -> Count Bytes Exp
bytes (Exp -> Count Bytes Exp) -> Exp -> Count Bytes Exp
forall a b. (a -> b) -> a -> b
$ ConvOp -> Exp -> Exp
forall v. ConvOp -> PrimExp v -> PrimExp v
ConvOpExp (IntType -> IntType -> ConvOp
SExt IntType
Int32 IntType
Int64) Exp
e Exp -> Exp -> Exp
forall a. Num a => a -> a -> a
* ExpLeaf -> PrimType -> Exp
forall v. v -> PrimType -> PrimExp v
LeafExp (PrimType -> ExpLeaf
SizeOf PrimType
t) (IntType -> PrimType
IntType IntType
Int64)
var :: VName -> PrimType -> Exp
var :: VName -> PrimType -> Exp
var = ExpLeaf -> PrimType -> Exp
forall v. v -> PrimType -> PrimExp v
LeafExp (ExpLeaf -> PrimType -> Exp)
-> (VName -> ExpLeaf) -> VName -> PrimType -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VName -> ExpLeaf
ScalarVar
vi32 :: VName -> Exp
vi32 :: VName -> Exp
vi32 = (VName -> PrimType -> Exp) -> PrimType -> VName -> Exp
forall a b c. (a -> b -> c) -> b -> a -> c
flip VName -> PrimType -> Exp
var (PrimType -> VName -> Exp) -> PrimType -> VName -> Exp
forall a b. (a -> b) -> a -> b
$ IntType -> PrimType
IntType IntType
Int32
index :: VName -> Count Elements Exp -> PrimType -> Space -> Volatility -> Exp
index :: VName
-> Count Elements Exp -> PrimType -> Space -> Volatility -> Exp
index VName
arr Count Elements Exp
i PrimType
t Space
s Volatility
vol = ExpLeaf -> PrimType -> Exp
forall v. v -> PrimType -> PrimExp v
LeafExp (VName
-> Count Elements Exp -> PrimType -> Space -> Volatility -> ExpLeaf
Index VName
arr Count Elements Exp
i PrimType
t Space
s Volatility
vol) PrimType
t
instance Pretty op => Pretty (Definitions op) where
ppr :: Definitions op -> Doc
ppr (Definitions Constants op
consts Functions op
funs) =
Constants op -> Doc
forall a. Pretty a => a -> Doc
ppr Constants op
consts Doc -> Doc -> Doc
</> Functions op -> Doc
forall a. Pretty a => a -> Doc
ppr Functions op
funs
instance Pretty op => Pretty (Functions op) where
ppr :: Functions op -> Doc
ppr (Functions [(Name, Function op)]
funs) = [Doc] -> Doc
stack ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse Doc
forall a. Monoid a => a
mempty ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ ((Name, Function op) -> Doc) -> [(Name, Function op)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Function op) -> Doc
forall a a. (Pretty a, Pretty a) => (a, a) -> Doc
ppFun [(Name, Function op)]
funs
where ppFun :: (a, a) -> Doc
ppFun (a
name, a
fun) =
String -> Doc
text String
"Function " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> a -> Doc
forall a. Pretty a => a -> Doc
ppr a
name Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
colon Doc -> Doc -> Doc
</> Int -> Doc -> Doc
indent Int
2 (a -> Doc
forall a. Pretty a => a -> Doc
ppr a
fun)
instance Pretty op => Pretty (Constants op) where
ppr :: Constants op -> Doc
ppr (Constants [Param]
decls Code op
code) =
String -> Doc
text String
"Constants:" Doc -> Doc -> Doc
</> Int -> Doc -> Doc
indent Int
2 ([Doc] -> Doc
stack ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Param -> Doc) -> [Param] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Param -> Doc
forall a. Pretty a => a -> Doc
ppr [Param]
decls) Doc -> Doc -> Doc
</>
Doc
forall a. Monoid a => a
mempty Doc -> Doc -> Doc
</>
String -> Doc
text String
"Initialisation:" Doc -> Doc -> Doc
</>
Int -> Doc -> Doc
indent Int
2 (Code op -> Doc
forall a. Pretty a => a -> Doc
ppr Code op
code)
instance Pretty op => Pretty (FunctionT op) where
ppr :: FunctionT op -> Doc
ppr (Function Bool
_ [Param]
outs [Param]
ins Code op
body [ExternalValue]
results [ExternalValue]
args) =
String -> Doc
text String
"Inputs:" Doc -> Doc -> Doc
</> [Param] -> Doc
forall a. Pretty a => [a] -> Doc
block [Param]
ins Doc -> Doc -> Doc
</>
String -> Doc
text String
"Outputs:" Doc -> Doc -> Doc
</> [Param] -> Doc
forall a. Pretty a => [a] -> Doc
block [Param]
outs Doc -> Doc -> Doc
</>
String -> Doc
text String
"Arguments:" Doc -> Doc -> Doc
</> [ExternalValue] -> Doc
forall a. Pretty a => [a] -> Doc
block [ExternalValue]
args Doc -> Doc -> Doc
</>
String -> Doc
text String
"Result:" Doc -> Doc -> Doc
</> [ExternalValue] -> Doc
forall a. Pretty a => [a] -> Doc
block [ExternalValue]
results Doc -> Doc -> Doc
</>
String -> Doc
text String
"Body:" Doc -> Doc -> Doc
</> Int -> Doc -> Doc
indent Int
2 (Code op -> Doc
forall a. Pretty a => a -> Doc
ppr Code op
body)
where block :: Pretty a => [a] -> Doc
block :: [a] -> Doc
block = Int -> Doc -> Doc
indent Int
2 (Doc -> Doc) -> ([a] -> Doc) -> [a] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
stack ([Doc] -> Doc) -> ([a] -> [Doc]) -> [a] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
forall a. Pretty a => a -> Doc
ppr
instance Pretty Param where
ppr :: Param -> Doc
ppr (ScalarParam VName
name PrimType
ptype) = PrimType -> Doc
forall a. Pretty a => a -> Doc
ppr PrimType
ptype Doc -> Doc -> Doc
<+> VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
name
ppr (MemParam VName
name Space
space) = String -> Doc
text String
"mem" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Space -> Doc
forall a. Pretty a => a -> Doc
ppr Space
space Doc -> Doc -> Doc
<+> VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
name
instance Pretty ValueDesc where
ppr :: ValueDesc -> Doc
ppr (ScalarValue PrimType
t Signedness
ept VName
name) =
PrimType -> Doc
forall a. Pretty a => a -> Doc
ppr PrimType
t Doc -> Doc -> Doc
<+> VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
name Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
ept'
where ept' :: Doc
ept' = case Signedness
ept of Signedness
TypeUnsigned -> String -> Doc
text String
" (unsigned)"
Signedness
TypeDirect -> Doc
forall a. Monoid a => a
mempty
ppr (ArrayValue VName
mem Space
space PrimType
et Signedness
ept [DimSize]
shape) =
(DimSize -> Doc -> Doc) -> Doc -> [DimSize] -> Doc
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr DimSize -> Doc -> Doc
forall a. Pretty a => a -> Doc -> Doc
f (PrimType -> Doc
forall a. Pretty a => a -> Doc
ppr PrimType
et) [DimSize]
shape Doc -> Doc -> Doc
<+> String -> Doc
text String
"at" Doc -> Doc -> Doc
<+> VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
mem Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Space -> Doc
forall a. Pretty a => a -> Doc
ppr Space
space Doc -> Doc -> Doc
<+> Doc
ept'
where f :: a -> Doc -> Doc
f a
e Doc
s = Doc -> Doc
brackets (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
s Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
comma Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> a -> Doc
forall a. Pretty a => a -> Doc
ppr a
e
ept' :: Doc
ept' = case Signedness
ept of Signedness
TypeUnsigned -> String -> Doc
text String
" (unsigned)"
Signedness
TypeDirect -> Doc
forall a. Monoid a => a
mempty
instance Pretty ExternalValue where
ppr :: ExternalValue -> Doc
ppr (TransparentValue ValueDesc
v) = ValueDesc -> Doc
forall a. Pretty a => a -> Doc
ppr ValueDesc
v
ppr (OpaqueValue String
desc [ValueDesc]
vs) =
String -> Doc
text String
"opaque" Doc -> Doc -> Doc
<+> String -> Doc
text String
desc Doc -> Doc -> Doc
<+>
String -> String -> Doc -> Doc
nestedBlock String
"{" String
"}" ([Doc] -> Doc
stack ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (ValueDesc -> Doc) -> [ValueDesc] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ValueDesc -> Doc
forall a. Pretty a => a -> Doc
ppr [ValueDesc]
vs)
instance Pretty ArrayContents where
ppr :: ArrayContents -> Doc
ppr (ArrayValues [PrimValue]
vs) = Doc -> Doc
braces ([Doc] -> Doc
commasep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (PrimValue -> Doc) -> [PrimValue] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map PrimValue -> Doc
forall a. Pretty a => a -> Doc
ppr [PrimValue]
vs)
ppr (ArrayZeros Int
n) = Doc -> Doc
braces (String -> Doc
text String
"0") Doc -> Doc -> Doc
<+> String -> Doc
text String
"*" Doc -> Doc -> Doc
<+> Int -> Doc
forall a. Pretty a => a -> Doc
ppr Int
n
instance Pretty op => Pretty (Code op) where
ppr :: Code op -> Doc
ppr (Op op
op) = op -> Doc
forall a. Pretty a => a -> Doc
ppr op
op
ppr Code op
Skip = String -> Doc
text String
"skip"
ppr (Code op
c1 :>>: Code op
c2) = Code op -> Doc
forall a. Pretty a => a -> Doc
ppr Code op
c1 Doc -> Doc -> Doc
</> Code op -> Doc
forall a. Pretty a => a -> Doc
ppr Code op
c2
ppr (For VName
i IntType
it Exp
limit Code op
body) =
String -> Doc
text String
"for" Doc -> Doc -> Doc
<+> VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
i Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
":" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> IntType -> Doc
forall a. Pretty a => a -> Doc
ppr IntType
it Doc -> Doc -> Doc
<+> Doc
langle Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Pretty a => a -> Doc
ppr Exp
limit Doc -> Doc -> Doc
<+> String -> Doc
text String
"{" Doc -> Doc -> Doc
</>
Int -> Doc -> Doc
indent Int
2 (Code op -> Doc
forall a. Pretty a => a -> Doc
ppr Code op
body) Doc -> Doc -> Doc
</>
String -> Doc
text String
"}"
ppr (While Exp
cond Code op
body) =
String -> Doc
text String
"while" Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Pretty a => a -> Doc
ppr Exp
cond Doc -> Doc -> Doc
<+> String -> Doc
text String
"{" Doc -> Doc -> Doc
</>
Int -> Doc -> Doc
indent Int
2 (Code op -> Doc
forall a. Pretty a => a -> Doc
ppr Code op
body) Doc -> Doc -> Doc
</>
String -> Doc
text String
"}"
ppr (DeclareMem VName
name Space
space) =
String -> Doc
text String
"var" Doc -> Doc -> Doc
<+> VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
name Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
": mem" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Space -> Doc
forall a. Pretty a => a -> Doc
ppr Space
space
ppr (DeclareScalar VName
name Volatility
vol PrimType
t) =
String -> Doc
text String
"var" Doc -> Doc -> Doc
<+> VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
name Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
":" Doc -> Doc -> Doc
<+> Doc
vol' Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> PrimType -> Doc
forall a. Pretty a => a -> Doc
ppr PrimType
t
where vol' :: Doc
vol' = case Volatility
vol of Volatility
Volatile -> String -> Doc
text String
"volatile "
Volatility
Nonvolatile -> Doc
forall a. Monoid a => a
mempty
ppr (DeclareArray VName
name Space
space PrimType
t ArrayContents
vs) =
String -> Doc
text String
"array" Doc -> Doc -> Doc
<+> VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
name Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
"@" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Space -> Doc
forall a. Pretty a => a -> Doc
ppr Space
space Doc -> Doc -> Doc
<+> String -> Doc
text String
":" Doc -> Doc -> Doc
<+> PrimType -> Doc
forall a. Pretty a => a -> Doc
ppr PrimType
t Doc -> Doc -> Doc
<+>
Doc
equals Doc -> Doc -> Doc
<+> ArrayContents -> Doc
forall a. Pretty a => a -> Doc
ppr ArrayContents
vs
ppr (Allocate VName
name Count Bytes Exp
e Space
space) =
VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
name Doc -> Doc -> Doc
<+> String -> Doc
text String
"<-" Doc -> Doc -> Doc
<+> String -> Doc
text String
"malloc" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens (Count Bytes Exp -> Doc
forall a. Pretty a => a -> Doc
ppr Count Bytes Exp
e) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Space -> Doc
forall a. Pretty a => a -> Doc
ppr Space
space
ppr (Free VName
name Space
space) =
String -> Doc
text String
"free" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens (VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
name) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Space -> Doc
forall a. Pretty a => a -> Doc
ppr Space
space
ppr (Write VName
name Count Elements Exp
i PrimType
bt Space
space Volatility
vol Exp
val) =
VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
name Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
langle Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
vol' Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> PrimType -> Doc
forall a. Pretty a => a -> Doc
ppr PrimType
bt Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Space -> Doc
forall a. Pretty a => a -> Doc
ppr Space
space Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
rangle Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
brackets (Count Elements Exp -> Doc
forall a. Pretty a => a -> Doc
ppr Count Elements Exp
i) Doc -> Doc -> Doc
<+>
String -> Doc
text String
"<-" Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Pretty a => a -> Doc
ppr Exp
val
where vol' :: Doc
vol' = case Volatility
vol of Volatility
Volatile -> String -> Doc
text String
"volatile "
Volatility
Nonvolatile -> Doc
forall a. Monoid a => a
mempty
ppr (SetScalar VName
name Exp
val) =
VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
name Doc -> Doc -> Doc
<+> String -> Doc
text String
"<-" Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Pretty a => a -> Doc
ppr Exp
val
ppr (SetMem VName
dest VName
from Space
space) =
VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
dest Doc -> Doc -> Doc
<+> String -> Doc
text String
"<-" Doc -> Doc -> Doc
<+> VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
from Doc -> Doc -> Doc
<+> String -> Doc
text String
"@" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Space -> Doc
forall a. Pretty a => a -> Doc
ppr Space
space
ppr (Assert Exp
e ErrorMsg Exp
msg (SrcLoc, [SrcLoc])
_) =
String -> Doc
text String
"assert" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens ([Doc] -> Doc
commasep [ErrorMsg Exp -> Doc
forall a. Pretty a => a -> Doc
ppr ErrorMsg Exp
msg, Exp -> Doc
forall a. Pretty a => a -> Doc
ppr Exp
e])
ppr (Copy VName
dest Count Bytes Exp
destoffset Space
destspace VName
src Count Bytes Exp
srcoffset Space
srcspace Count Bytes Exp
size) =
String -> Doc
text String
"memcpy" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>
Doc -> Doc
parens (VName -> Count Bytes Exp -> Doc
forall a a. (Pretty a, Pretty a) => a -> a -> Doc
ppMemLoc VName
dest Count Bytes Exp
destoffset Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Space -> Doc
forall a. Pretty a => a -> Doc
ppr Space
destspace Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
comma Doc -> Doc -> Doc
</>
VName -> Count Bytes Exp -> Doc
forall a a. (Pretty a, Pretty a) => a -> a -> Doc
ppMemLoc VName
src Count Bytes Exp
srcoffset Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Space -> Doc
forall a. Pretty a => a -> Doc
ppr Space
srcspace Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
comma Doc -> Doc -> Doc
</>
Count Bytes Exp -> Doc
forall a. Pretty a => a -> Doc
ppr Count Bytes Exp
size)
where ppMemLoc :: a -> a -> Doc
ppMemLoc a
base a
offset =
a -> Doc
forall a. Pretty a => a -> Doc
ppr a
base Doc -> Doc -> Doc
<+> String -> Doc
text String
"+" Doc -> Doc -> Doc
<+> a -> Doc
forall a. Pretty a => a -> Doc
ppr a
offset
ppr (If Exp
cond Code op
tbranch Code op
fbranch) =
String -> Doc
text String
"if" Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Pretty a => a -> Doc
ppr Exp
cond Doc -> Doc -> Doc
<+> String -> Doc
text String
"then {" Doc -> Doc -> Doc
</>
Int -> Doc -> Doc
indent Int
2 (Code op -> Doc
forall a. Pretty a => a -> Doc
ppr Code op
tbranch) Doc -> Doc -> Doc
</>
String -> Doc
text String
"} else {" Doc -> Doc -> Doc
</>
Int -> Doc -> Doc
indent Int
2 (Code op -> Doc
forall a. Pretty a => a -> Doc
ppr Code op
fbranch) Doc -> Doc -> Doc
</>
String -> Doc
text String
"}"
ppr (Call [VName]
dests Name
fname [Arg]
args) =
[Doc] -> Doc
commasep ((VName -> Doc) -> [VName] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map VName -> Doc
forall a. Pretty a => a -> Doc
ppr [VName]
dests) Doc -> Doc -> Doc
<+> String -> Doc
text String
"<-" Doc -> Doc -> Doc
<+>
Name -> Doc
forall a. Pretty a => a -> Doc
ppr Name
fname Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens ([Doc] -> Doc
commasep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Arg -> Doc) -> [Arg] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Arg -> Doc
forall a. Pretty a => a -> Doc
ppr [Arg]
args)
ppr (Comment String
s Code op
code) =
String -> Doc
text String
"--" Doc -> Doc -> Doc
<+> String -> Doc
text String
s Doc -> Doc -> Doc
</> Code op -> Doc
forall a. Pretty a => a -> Doc
ppr Code op
code
ppr (DebugPrint String
desc (Just Exp
e)) =
String -> Doc
text String
"debug" Doc -> Doc -> Doc
<+> Doc -> Doc
parens ([Doc] -> Doc
commasep [String -> Doc
text (ShowS
forall a. Show a => a -> String
show String
desc), Exp -> Doc
forall a. Pretty a => a -> Doc
ppr Exp
e])
ppr (DebugPrint String
desc Maybe Exp
Nothing) =
String -> Doc
text String
"debug" Doc -> Doc -> Doc
<+> Doc -> Doc
parens (String -> Doc
text (ShowS
forall a. Show a => a -> String
show String
desc))
instance Pretty Arg where
ppr :: Arg -> Doc
ppr (MemArg VName
m) = VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
m
ppr (ExpArg Exp
e) = Exp -> Doc
forall a. Pretty a => a -> Doc
ppr Exp
e
instance Pretty ExpLeaf where
ppr :: ExpLeaf -> Doc
ppr (ScalarVar VName
v) =
VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
v
ppr (Index VName
v Count Elements Exp
is PrimType
bt Space
space Volatility
vol) =
VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
v Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
langle Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
vol' Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> PrimType -> Doc
forall a. Pretty a => a -> Doc
ppr PrimType
bt Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Space -> Doc
forall a. Pretty a => a -> Doc
ppr Space
space Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
rangle Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
brackets (Count Elements Exp -> Doc
forall a. Pretty a => a -> Doc
ppr Count Elements Exp
is)
where vol' :: Doc
vol' = case Volatility
vol of Volatility
Volatile -> String -> Doc
text String
"volatile "
Volatility
Nonvolatile -> Doc
forall a. Monoid a => a
mempty
ppr (SizeOf PrimType
t) =
String -> Doc
text String
"sizeof" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens (PrimType -> Doc
forall a. Pretty a => a -> Doc
ppr PrimType
t)
instance Functor Functions where
fmap :: (a -> b) -> Functions a -> Functions b
fmap = (a -> b) -> Functions a -> Functions b
forall (t :: * -> *) a b. Traversable t => (a -> b) -> t a -> t b
fmapDefault
instance Foldable Functions where
foldMap :: (a -> m) -> Functions a -> m
foldMap = (a -> m) -> Functions a -> m
forall (t :: * -> *) m a.
(Traversable t, Monoid m) =>
(a -> m) -> t a -> m
foldMapDefault
instance Traversable Functions where
traverse :: (a -> f b) -> Functions a -> f (Functions b)
traverse a -> f b
f (Functions [(Name, Function a)]
funs) =
[(Name, Function b)] -> Functions b
forall a. [(Name, Function a)] -> Functions a
Functions ([(Name, Function b)] -> Functions b)
-> f [(Name, Function b)] -> f (Functions b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Name, Function a) -> f (Name, Function b))
-> [(Name, Function a)] -> f [(Name, Function b)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Name, Function a) -> f (Name, Function b)
forall (t :: * -> *) t. Traversable t => (t, t a) -> f (t, t b)
f' [(Name, Function a)]
funs
where f' :: (t, t a) -> f (t, t b)
f' (t
name, t a
fun) = (t
name,) (t b -> (t, t b)) -> f (t b) -> f (t, t b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> t a -> f (t b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f t a
fun
instance Functor FunctionT where
fmap :: (a -> b) -> FunctionT a -> FunctionT b
fmap = (a -> b) -> FunctionT a -> FunctionT b
forall (t :: * -> *) a b. Traversable t => (a -> b) -> t a -> t b
fmapDefault
instance Foldable FunctionT where
foldMap :: (a -> m) -> FunctionT a -> m
foldMap = (a -> m) -> FunctionT a -> m
forall (t :: * -> *) m a.
(Traversable t, Monoid m) =>
(a -> m) -> t a -> m
foldMapDefault
instance Traversable FunctionT where
traverse :: (a -> f b) -> FunctionT a -> f (FunctionT b)
traverse a -> f b
f (Function Bool
entry [Param]
outs [Param]
ins Code a
body [ExternalValue]
results [ExternalValue]
args) =
Bool
-> [Param]
-> [Param]
-> Code b
-> [ExternalValue]
-> [ExternalValue]
-> FunctionT b
forall a.
Bool
-> [Param]
-> [Param]
-> Code a
-> [ExternalValue]
-> [ExternalValue]
-> FunctionT a
Function Bool
entry [Param]
outs [Param]
ins (Code b -> [ExternalValue] -> [ExternalValue] -> FunctionT b)
-> f (Code b)
-> f ([ExternalValue] -> [ExternalValue] -> FunctionT b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> Code a -> f (Code b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f Code a
body f ([ExternalValue] -> [ExternalValue] -> FunctionT b)
-> f [ExternalValue] -> f ([ExternalValue] -> FunctionT b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [ExternalValue] -> f [ExternalValue]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ExternalValue]
results f ([ExternalValue] -> FunctionT b)
-> f [ExternalValue] -> f (FunctionT b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [ExternalValue] -> f [ExternalValue]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ExternalValue]
args
instance Functor Code where
fmap :: (a -> b) -> Code a -> Code b
fmap = (a -> b) -> Code a -> Code b
forall (t :: * -> *) a b. Traversable t => (a -> b) -> t a -> t b
fmapDefault
instance Foldable Code where
foldMap :: (a -> m) -> Code a -> m
foldMap = (a -> m) -> Code a -> m
forall (t :: * -> *) m a.
(Traversable t, Monoid m) =>
(a -> m) -> t a -> m
foldMapDefault
instance Traversable Code where
traverse :: (a -> f b) -> Code a -> f (Code b)
traverse a -> f b
f (Code a
x :>>: Code a
y) =
Code b -> Code b -> Code b
forall a. Code a -> Code a -> Code a
(:>>:) (Code b -> Code b -> Code b) -> f (Code b) -> f (Code b -> Code b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> Code a -> f (Code b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f Code a
x f (Code b -> Code b) -> f (Code b) -> f (Code b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (a -> f b) -> Code a -> f (Code b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f Code a
y
traverse a -> f b
f (For VName
i IntType
it Exp
bound Code a
code) =
VName -> IntType -> Exp -> Code b -> Code b
forall a. VName -> IntType -> Exp -> Code a -> Code a
For VName
i IntType
it Exp
bound (Code b -> Code b) -> f (Code b) -> f (Code b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> Code a -> f (Code b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f Code a
code
traverse a -> f b
f (While Exp
cond Code a
code) =
Exp -> Code b -> Code b
forall a. Exp -> Code a -> Code a
While Exp
cond (Code b -> Code b) -> f (Code b) -> f (Code b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> Code a -> f (Code b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f Code a
code
traverse a -> f b
f (If Exp
cond Code a
x Code a
y) =
Exp -> Code b -> Code b -> Code b
forall a. Exp -> Code a -> Code a -> Code a
If Exp
cond (Code b -> Code b -> Code b) -> f (Code b) -> f (Code b -> Code b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> Code a -> f (Code b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f Code a
x f (Code b -> Code b) -> f (Code b) -> f (Code b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (a -> f b) -> Code a -> f (Code b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f Code a
y
traverse a -> f b
f (Op a
kernel) =
b -> Code b
forall a. a -> Code a
Op (b -> Code b) -> f b -> f (Code b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
kernel
traverse a -> f b
_ Code a
Skip =
Code b -> f (Code b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Code b
forall a. Code a
Skip
traverse a -> f b
_ (DeclareMem VName
name Space
space) =
Code b -> f (Code b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Code b -> f (Code b)) -> Code b -> f (Code b)
forall a b. (a -> b) -> a -> b
$ VName -> Space -> Code b
forall a. VName -> Space -> Code a
DeclareMem VName
name Space
space
traverse a -> f b
_ (DeclareScalar VName
name Volatility
vol PrimType
bt) =
Code b -> f (Code b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Code b -> f (Code b)) -> Code b -> f (Code b)
forall a b. (a -> b) -> a -> b
$ VName -> Volatility -> PrimType -> Code b
forall a. VName -> Volatility -> PrimType -> Code a
DeclareScalar VName
name Volatility
vol PrimType
bt
traverse a -> f b
_ (DeclareArray VName
name Space
space PrimType
t ArrayContents
vs) =
Code b -> f (Code b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Code b -> f (Code b)) -> Code b -> f (Code b)
forall a b. (a -> b) -> a -> b
$ VName -> Space -> PrimType -> ArrayContents -> Code b
forall a. VName -> Space -> PrimType -> ArrayContents -> Code a
DeclareArray VName
name Space
space PrimType
t ArrayContents
vs
traverse a -> f b
_ (Allocate VName
name Count Bytes Exp
size Space
s) =
Code b -> f (Code b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Code b -> f (Code b)) -> Code b -> f (Code b)
forall a b. (a -> b) -> a -> b
$ VName -> Count Bytes Exp -> Space -> Code b
forall a. VName -> Count Bytes Exp -> Space -> Code a
Allocate VName
name Count Bytes Exp
size Space
s
traverse a -> f b
_ (Free VName
name Space
space) =
Code b -> f (Code b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Code b -> f (Code b)) -> Code b -> f (Code b)
forall a b. (a -> b) -> a -> b
$ VName -> Space -> Code b
forall a. VName -> Space -> Code a
Free VName
name Space
space
traverse a -> f b
_ (Copy VName
dest Count Bytes Exp
destoffset Space
destspace VName
src Count Bytes Exp
srcoffset Space
srcspace Count Bytes Exp
size) =
Code b -> f (Code b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Code b -> f (Code b)) -> Code b -> f (Code b)
forall a b. (a -> b) -> a -> b
$ VName
-> Count Bytes Exp
-> Space
-> VName
-> Count Bytes Exp
-> Space
-> Count Bytes Exp
-> Code b
forall a.
VName
-> Count Bytes Exp
-> Space
-> VName
-> Count Bytes Exp
-> Space
-> Count Bytes Exp
-> Code a
Copy VName
dest Count Bytes Exp
destoffset Space
destspace VName
src Count Bytes Exp
srcoffset Space
srcspace Count Bytes Exp
size
traverse a -> f b
_ (Write VName
name Count Elements Exp
i PrimType
bt Space
val Volatility
space Exp
vol) =
Code b -> f (Code b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Code b -> f (Code b)) -> Code b -> f (Code b)
forall a b. (a -> b) -> a -> b
$ VName
-> Count Elements Exp
-> PrimType
-> Space
-> Volatility
-> Exp
-> Code b
forall a.
VName
-> Count Elements Exp
-> PrimType
-> Space
-> Volatility
-> Exp
-> Code a
Write VName
name Count Elements Exp
i PrimType
bt Space
val Volatility
space Exp
vol
traverse a -> f b
_ (SetScalar VName
name Exp
val) =
Code b -> f (Code b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Code b -> f (Code b)) -> Code b -> f (Code b)
forall a b. (a -> b) -> a -> b
$ VName -> Exp -> Code b
forall a. VName -> Exp -> Code a
SetScalar VName
name Exp
val
traverse a -> f b
_ (SetMem VName
dest VName
from Space
space) =
Code b -> f (Code b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Code b -> f (Code b)) -> Code b -> f (Code b)
forall a b. (a -> b) -> a -> b
$ VName -> VName -> Space -> Code b
forall a. VName -> VName -> Space -> Code a
SetMem VName
dest VName
from Space
space
traverse a -> f b
_ (Assert Exp
e ErrorMsg Exp
msg (SrcLoc, [SrcLoc])
loc) =
Code b -> f (Code b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Code b -> f (Code b)) -> Code b -> f (Code b)
forall a b. (a -> b) -> a -> b
$ Exp -> ErrorMsg Exp -> (SrcLoc, [SrcLoc]) -> Code b
forall a. Exp -> ErrorMsg Exp -> (SrcLoc, [SrcLoc]) -> Code a
Assert Exp
e ErrorMsg Exp
msg (SrcLoc, [SrcLoc])
loc
traverse a -> f b
_ (Call [VName]
dests Name
fname [Arg]
args) =
Code b -> f (Code b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Code b -> f (Code b)) -> Code b -> f (Code b)
forall a b. (a -> b) -> a -> b
$ [VName] -> Name -> [Arg] -> Code b
forall a. [VName] -> Name -> [Arg] -> Code a
Call [VName]
dests Name
fname [Arg]
args
traverse a -> f b
f (Comment String
s Code a
code) =
String -> Code b -> Code b
forall a. String -> Code a -> Code a
Comment String
s (Code b -> Code b) -> f (Code b) -> f (Code b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> Code a -> f (Code b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f Code a
code
traverse a -> f b
_ (DebugPrint String
s Maybe Exp
v) =
Code b -> f (Code b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Code b -> f (Code b)) -> Code b -> f (Code b)
forall a b. (a -> b) -> a -> b
$ String -> Maybe Exp -> Code b
forall a. String -> Maybe Exp -> Code a
DebugPrint String
s Maybe Exp
v
declaredIn :: Code a -> Names
declaredIn :: Code a -> Names
declaredIn (DeclareMem VName
name Space
_) = VName -> Names
oneName VName
name
declaredIn (DeclareScalar VName
name Volatility
_ PrimType
_) = VName -> Names
oneName VName
name
declaredIn (DeclareArray VName
name Space
_ PrimType
_ ArrayContents
_) = VName -> Names
oneName VName
name
declaredIn (If Exp
_ Code a
t Code a
f) = Code a -> Names
forall a. Code a -> Names
declaredIn Code a
t Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
<> Code a -> Names
forall a. Code a -> Names
declaredIn Code a
f
declaredIn (Code a
x :>>: Code a
y) = Code a -> Names
forall a. Code a -> Names
declaredIn Code a
x Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
<> Code a -> Names
forall a. Code a -> Names
declaredIn Code a
y
declaredIn (For VName
i IntType
_ Exp
_ Code a
body) = VName -> Names
oneName VName
i Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
<> Code a -> Names
forall a. Code a -> Names
declaredIn Code a
body
declaredIn (While Exp
_ Code a
body) = Code a -> Names
forall a. Code a -> Names
declaredIn Code a
body
declaredIn (Comment String
_ Code a
body) = Code a -> Names
forall a. Code a -> Names
declaredIn Code a
body
declaredIn Code a
_ = Names
forall a. Monoid a => a
mempty
instance FreeIn a => FreeIn (Functions a) where
freeIn' :: Functions a -> FV
freeIn' (Functions [(Name, Function a)]
fs) =
((Name, Function a) -> FV) -> [(Name, Function a)] -> FV
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Code a -> FV
forall a. FreeIn a => a -> FV
freeIn' (Code a -> FV)
-> ((Name, Function a) -> Code a) -> (Name, Function a) -> FV
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function a -> Code a
forall a. FunctionT a -> Code a
functionBody (Function a -> Code a)
-> ((Name, Function a) -> Function a)
-> (Name, Function a)
-> Code a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Function a) -> Function a
forall a b. (a, b) -> b
snd) [(Name, Function a)]
fs
instance FreeIn a => FreeIn (Code a) where
freeIn' :: Code a -> FV
freeIn' (Code a
x :>>: Code a
y) =
Names -> FV -> FV
fvBind (Code a -> Names
forall a. Code a -> Names
declaredIn Code a
x) (FV -> FV) -> FV -> FV
forall a b. (a -> b) -> a -> b
$ Code a -> FV
forall a. FreeIn a => a -> FV
freeIn' Code a
x FV -> FV -> FV
forall a. Semigroup a => a -> a -> a
<> Code a -> FV
forall a. FreeIn a => a -> FV
freeIn' Code a
y
freeIn' Code a
Skip =
FV
forall a. Monoid a => a
mempty
freeIn' (For VName
i IntType
_ Exp
bound Code a
body) =
Names -> FV -> FV
fvBind (VName -> Names
oneName VName
i) (FV -> FV) -> FV -> FV
forall a b. (a -> b) -> a -> b
$ Exp -> FV
forall a. FreeIn a => a -> FV
freeIn' Exp
bound FV -> FV -> FV
forall a. Semigroup a => a -> a -> a
<> Code a -> FV
forall a. FreeIn a => a -> FV
freeIn' Code a
body
freeIn' (While Exp
cond Code a
body) =
Exp -> FV
forall a. FreeIn a => a -> FV
freeIn' Exp
cond FV -> FV -> FV
forall a. Semigroup a => a -> a -> a
<> Code a -> FV
forall a. FreeIn a => a -> FV
freeIn' Code a
body
freeIn' (DeclareMem VName
_ Space
space) =
Space -> FV
forall a. FreeIn a => a -> FV
freeIn' Space
space
freeIn' DeclareScalar{} =
FV
forall a. Monoid a => a
mempty
freeIn' DeclareArray{} =
FV
forall a. Monoid a => a
mempty
freeIn' (Allocate VName
name Count Bytes Exp
size Space
space) =
VName -> FV
forall a. FreeIn a => a -> FV
freeIn' VName
name FV -> FV -> FV
forall a. Semigroup a => a -> a -> a
<> Count Bytes Exp -> FV
forall a. FreeIn a => a -> FV
freeIn' Count Bytes Exp
size FV -> FV -> FV
forall a. Semigroup a => a -> a -> a
<> Space -> FV
forall a. FreeIn a => a -> FV
freeIn' Space
space
freeIn' (Free VName
name Space
_) =
VName -> FV
forall a. FreeIn a => a -> FV
freeIn' VName
name
freeIn' (Copy VName
dest Count Bytes Exp
x Space
_ VName
src Count Bytes Exp
y Space
_ Count Bytes Exp
n) =
VName -> FV
forall a. FreeIn a => a -> FV
freeIn' VName
dest FV -> FV -> FV
forall a. Semigroup a => a -> a -> a
<> Count Bytes Exp -> FV
forall a. FreeIn a => a -> FV
freeIn' Count Bytes Exp
x FV -> FV -> FV
forall a. Semigroup a => a -> a -> a
<> VName -> FV
forall a. FreeIn a => a -> FV
freeIn' VName
src FV -> FV -> FV
forall a. Semigroup a => a -> a -> a
<> Count Bytes Exp -> FV
forall a. FreeIn a => a -> FV
freeIn' Count Bytes Exp
y FV -> FV -> FV
forall a. Semigroup a => a -> a -> a
<> Count Bytes Exp -> FV
forall a. FreeIn a => a -> FV
freeIn' Count Bytes Exp
n
freeIn' (SetMem VName
x VName
y Space
_) =
VName -> FV
forall a. FreeIn a => a -> FV
freeIn' VName
x FV -> FV -> FV
forall a. Semigroup a => a -> a -> a
<> VName -> FV
forall a. FreeIn a => a -> FV
freeIn' VName
y
freeIn' (Write VName
v Count Elements Exp
i PrimType
_ Space
_ Volatility
_ Exp
e) =
VName -> FV
forall a. FreeIn a => a -> FV
freeIn' VName
v FV -> FV -> FV
forall a. Semigroup a => a -> a -> a
<> Count Elements Exp -> FV
forall a. FreeIn a => a -> FV
freeIn' Count Elements Exp
i FV -> FV -> FV
forall a. Semigroup a => a -> a -> a
<> Exp -> FV
forall a. FreeIn a => a -> FV
freeIn' Exp
e
freeIn' (SetScalar VName
x Exp
y) =
VName -> FV
forall a. FreeIn a => a -> FV
freeIn' VName
x FV -> FV -> FV
forall a. Semigroup a => a -> a -> a
<> Exp -> FV
forall a. FreeIn a => a -> FV
freeIn' Exp
y
freeIn' (Call [VName]
dests Name
_ [Arg]
args) =
[VName] -> FV
forall a. FreeIn a => a -> FV
freeIn' [VName]
dests FV -> FV -> FV
forall a. Semigroup a => a -> a -> a
<> [Arg] -> FV
forall a. FreeIn a => a -> FV
freeIn' [Arg]
args
freeIn' (If Exp
cond Code a
t Code a
f) =
Exp -> FV
forall a. FreeIn a => a -> FV
freeIn' Exp
cond FV -> FV -> FV
forall a. Semigroup a => a -> a -> a
<> Code a -> FV
forall a. FreeIn a => a -> FV
freeIn' Code a
t FV -> FV -> FV
forall a. Semigroup a => a -> a -> a
<> Code a -> FV
forall a. FreeIn a => a -> FV
freeIn' Code a
f
freeIn' (Assert Exp
e ErrorMsg Exp
msg (SrcLoc, [SrcLoc])
_) =
Exp -> FV
forall a. FreeIn a => a -> FV
freeIn' Exp
e FV -> FV -> FV
forall a. Semigroup a => a -> a -> a
<> (Exp -> FV) -> ErrorMsg Exp -> FV
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Exp -> FV
forall a. FreeIn a => a -> FV
freeIn' ErrorMsg Exp
msg
freeIn' (Op a
op) =
a -> FV
forall a. FreeIn a => a -> FV
freeIn' a
op
freeIn' (Comment String
_ Code a
code) =
Code a -> FV
forall a. FreeIn a => a -> FV
freeIn' Code a
code
freeIn' (DebugPrint String
_ Maybe Exp
v) =
FV -> (Exp -> FV) -> Maybe Exp -> FV
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FV
forall a. Monoid a => a
mempty Exp -> FV
forall a. FreeIn a => a -> FV
freeIn' Maybe Exp
v
instance FreeIn ExpLeaf where
freeIn' :: ExpLeaf -> FV
freeIn' (Index VName
v Count Elements Exp
e PrimType
_ Space
_ Volatility
_) = VName -> FV
forall a. FreeIn a => a -> FV
freeIn' VName
v FV -> FV -> FV
forall a. Semigroup a => a -> a -> a
<> Count Elements Exp -> FV
forall a. FreeIn a => a -> FV
freeIn' Count Elements Exp
e
freeIn' (ScalarVar VName
v) = VName -> FV
forall a. FreeIn a => a -> FV
freeIn' VName
v
freeIn' (SizeOf PrimType
_) = FV
forall a. Monoid a => a
mempty
instance FreeIn Arg where
freeIn' :: Arg -> FV
freeIn' (MemArg VName
m) = VName -> FV
forall a. FreeIn a => a -> FV
freeIn' VName
m
freeIn' (ExpArg Exp
e) = Exp -> FV
forall a. FreeIn a => a -> FV
freeIn' Exp
e