{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Variation of "Futhark.CodeGen.ImpCode" that contains the notion
-- of a kernel invocation.
module Futhark.CodeGen.ImpCode.Kernels
  ( Program
  , Function
  , FunctionT (Function)
  , Code
  , KernelCode
  , KernelConst (..)
  , KernelConstExp
  , HostOp (..)
  , KernelOp (..)
  , Fence (..)
  , AtomicOp (..)
  , Kernel (..)
  , KernelUse (..)
  , module Futhark.CodeGen.ImpCode
  , module Futhark.IR.Kernels.Sizes
  )
  where

import Futhark.CodeGen.ImpCode hiding (Function, Code)
import qualified Futhark.CodeGen.ImpCode as Imp
import Futhark.IR.Kernels.Sizes
import Futhark.IR.Pretty ()
import Futhark.Util.Pretty

-- | A program that calls kernels.
type Program = Imp.Definitions HostOp

-- | A function that calls kernels.
type Function = Imp.Function HostOp

-- | Host-level code that can call kernels.
type Code = Imp.Code HostOp

-- | Code inside a kernel.
type KernelCode = Imp.Code KernelOp

-- | A run-time constant related to kernels.
newtype KernelConst = SizeConst Name
                    deriving (KernelConst -> KernelConst -> Bool
(KernelConst -> KernelConst -> Bool)
-> (KernelConst -> KernelConst -> Bool) -> Eq KernelConst
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KernelConst -> KernelConst -> Bool
$c/= :: KernelConst -> KernelConst -> Bool
== :: KernelConst -> KernelConst -> Bool
$c== :: KernelConst -> KernelConst -> Bool
Eq, Eq KernelConst
Eq KernelConst
-> (KernelConst -> KernelConst -> Ordering)
-> (KernelConst -> KernelConst -> Bool)
-> (KernelConst -> KernelConst -> Bool)
-> (KernelConst -> KernelConst -> Bool)
-> (KernelConst -> KernelConst -> Bool)
-> (KernelConst -> KernelConst -> KernelConst)
-> (KernelConst -> KernelConst -> KernelConst)
-> Ord KernelConst
KernelConst -> KernelConst -> Bool
KernelConst -> KernelConst -> Ordering
KernelConst -> KernelConst -> KernelConst
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 :: KernelConst -> KernelConst -> KernelConst
$cmin :: KernelConst -> KernelConst -> KernelConst
max :: KernelConst -> KernelConst -> KernelConst
$cmax :: KernelConst -> KernelConst -> KernelConst
>= :: KernelConst -> KernelConst -> Bool
$c>= :: KernelConst -> KernelConst -> Bool
> :: KernelConst -> KernelConst -> Bool
$c> :: KernelConst -> KernelConst -> Bool
<= :: KernelConst -> KernelConst -> Bool
$c<= :: KernelConst -> KernelConst -> Bool
< :: KernelConst -> KernelConst -> Bool
$c< :: KernelConst -> KernelConst -> Bool
compare :: KernelConst -> KernelConst -> Ordering
$ccompare :: KernelConst -> KernelConst -> Ordering
$cp1Ord :: Eq KernelConst
Ord, Int -> KernelConst -> ShowS
[KernelConst] -> ShowS
KernelConst -> String
(Int -> KernelConst -> ShowS)
-> (KernelConst -> String)
-> ([KernelConst] -> ShowS)
-> Show KernelConst
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KernelConst] -> ShowS
$cshowList :: [KernelConst] -> ShowS
show :: KernelConst -> String
$cshow :: KernelConst -> String
showsPrec :: Int -> KernelConst -> ShowS
$cshowsPrec :: Int -> KernelConst -> ShowS
Show)

-- | An expression whose variables are kernel constants.
type KernelConstExp = PrimExp KernelConst

-- | An operation that runs on the host (CPU).
data HostOp = CallKernel Kernel
            | GetSize VName Name SizeClass
            | CmpSizeLe VName Name SizeClass Imp.Exp
            | GetSizeMax VName SizeClass
            deriving (Int -> HostOp -> ShowS
[HostOp] -> ShowS
HostOp -> String
(Int -> HostOp -> ShowS)
-> (HostOp -> String) -> ([HostOp] -> ShowS) -> Show HostOp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HostOp] -> ShowS
$cshowList :: [HostOp] -> ShowS
show :: HostOp -> String
$cshow :: HostOp -> String
showsPrec :: Int -> HostOp -> ShowS
$cshowsPrec :: Int -> HostOp -> ShowS
Show)

-- | A generic kernel containing arbitrary kernel code.
data Kernel = Kernel
              { Kernel -> Code KernelOp
kernelBody :: Imp.Code KernelOp

              , Kernel -> [KernelUse]
kernelUses :: [KernelUse]
                -- ^ The host variables referenced by the kernel.

              , Kernel -> [Exp]
kernelNumGroups :: [Imp.Exp]
              , Kernel -> [Exp]
kernelGroupSize :: [Imp.Exp]
              , Kernel -> Name
kernelName :: Name
               -- ^ A short descriptive and _unique_ name - should be
               -- alphanumeric and without spaces.

              , Kernel -> Bool
kernelFailureTolerant :: Bool
                -- ^ If true, this kernel does not need to check
                -- whether we are in a failing state, as it can cope.
                -- Intuitively, it means that the kernel does not
                -- depend on any non-scalar parameters to make control
                -- flow decisions.  Replication, transpose, and copy
                -- kernels are examples of this.
              }
            deriving (Int -> Kernel -> ShowS
[Kernel] -> ShowS
Kernel -> String
(Int -> Kernel -> ShowS)
-> (Kernel -> String) -> ([Kernel] -> ShowS) -> Show Kernel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Kernel] -> ShowS
$cshowList :: [Kernel] -> ShowS
show :: Kernel -> String
$cshow :: Kernel -> String
showsPrec :: Int -> Kernel -> ShowS
$cshowsPrec :: Int -> Kernel -> ShowS
Show)

-- | Information about a host-level variable that is used inside this
-- kernel.  When generating the actual kernel code, this is used to
-- deduce which parameters are needed.
data KernelUse = ScalarUse VName PrimType
               | MemoryUse VName
               | ConstUse VName KernelConstExp
                 deriving (KernelUse -> KernelUse -> Bool
(KernelUse -> KernelUse -> Bool)
-> (KernelUse -> KernelUse -> Bool) -> Eq KernelUse
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KernelUse -> KernelUse -> Bool
$c/= :: KernelUse -> KernelUse -> Bool
== :: KernelUse -> KernelUse -> Bool
$c== :: KernelUse -> KernelUse -> Bool
Eq, Int -> KernelUse -> ShowS
[KernelUse] -> ShowS
KernelUse -> String
(Int -> KernelUse -> ShowS)
-> (KernelUse -> String)
-> ([KernelUse] -> ShowS)
-> Show KernelUse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KernelUse] -> ShowS
$cshowList :: [KernelUse] -> ShowS
show :: KernelUse -> String
$cshow :: KernelUse -> String
showsPrec :: Int -> KernelUse -> ShowS
$cshowsPrec :: Int -> KernelUse -> ShowS
Show)

instance Pretty KernelConst where
  ppr :: KernelConst -> Doc
ppr (SizeConst Name
key) = String -> Doc
text String
"get_size" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens (Name -> Doc
forall a. Pretty a => a -> Doc
ppr Name
key)

instance Pretty KernelUse where
  ppr :: KernelUse -> Doc
ppr (ScalarUse VName
name PrimType
t) =
    Doc -> Doc
oneLine (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"scalar_copy" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens ([Doc] -> Doc
commasep [VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
name, PrimType -> Doc
forall a. Pretty a => a -> Doc
ppr PrimType
t])
  ppr (MemoryUse VName
name) =
    Doc -> Doc
oneLine (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"mem_copy" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens ([Doc] -> Doc
commasep [VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
name])
  ppr (ConstUse VName
name KernelConstExp
e) =
    Doc -> Doc
oneLine (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"const" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens ([Doc] -> Doc
commasep [VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
name, KernelConstExp -> Doc
forall a. Pretty a => a -> Doc
ppr KernelConstExp
e])

instance Pretty HostOp where
  ppr :: HostOp -> Doc
ppr (GetSize VName
dest Name
key SizeClass
size_class) =
    VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
dest Doc -> Doc -> Doc
<+> String -> Doc
text String
"<-" Doc -> Doc -> Doc
<+>
    String -> Doc
text String
"get_size" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens ([Doc] -> Doc
commasep [Name -> Doc
forall a. Pretty a => a -> Doc
ppr Name
key, SizeClass -> Doc
forall a. Pretty a => a -> Doc
ppr SizeClass
size_class])
  ppr (GetSizeMax VName
dest SizeClass
size_class) =
    VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
dest Doc -> Doc -> Doc
<+> String -> Doc
text String
"<-" Doc -> Doc -> Doc
<+> String -> Doc
text String
"get_size_max" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens (SizeClass -> Doc
forall a. Pretty a => a -> Doc
ppr SizeClass
size_class)
  ppr (CmpSizeLe VName
dest Name
name SizeClass
size_class Exp
x) =
    VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
dest Doc -> Doc -> Doc
<+> String -> Doc
text String
"<-" Doc -> Doc -> Doc
<+>
    String -> Doc
text String
"get_size" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens ([Doc] -> Doc
commasep [Name -> Doc
forall a. Pretty a => a -> Doc
ppr Name
name, SizeClass -> Doc
forall a. Pretty a => a -> Doc
ppr SizeClass
size_class]) Doc -> Doc -> Doc
<+>
    String -> Doc
text String
"<" Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Pretty a => a -> Doc
ppr Exp
x
  ppr (CallKernel Kernel
c) =
    Kernel -> Doc
forall a. Pretty a => a -> Doc
ppr Kernel
c

instance FreeIn HostOp where
  freeIn' :: HostOp -> FV
freeIn' (CallKernel Kernel
c) =
    Kernel -> FV
forall a. FreeIn a => a -> FV
freeIn' Kernel
c
  freeIn' (CmpSizeLe VName
dest Name
_ SizeClass
_ Exp
x) =
    VName -> FV
forall a. FreeIn a => a -> FV
freeIn' VName
dest FV -> FV -> FV
forall a. Semigroup a => a -> a -> a
<> Exp -> FV
forall a. FreeIn a => a -> FV
freeIn' Exp
x
  freeIn' (GetSizeMax VName
dest SizeClass
_) =
    VName -> FV
forall a. FreeIn a => a -> FV
freeIn' VName
dest
  freeIn' (GetSize VName
dest Name
_ SizeClass
_) =
    VName -> FV
forall a. FreeIn a => a -> FV
freeIn' VName
dest

instance FreeIn Kernel where
  freeIn' :: Kernel -> FV
freeIn' Kernel
kernel = Code KernelOp -> FV
forall a. FreeIn a => a -> FV
freeIn' (Kernel -> Code KernelOp
kernelBody Kernel
kernel) FV -> FV -> FV
forall a. Semigroup a => a -> a -> a
<>
                   [[Exp]] -> FV
forall a. FreeIn a => a -> FV
freeIn' [Kernel -> [Exp]
kernelNumGroups Kernel
kernel, Kernel -> [Exp]
kernelGroupSize Kernel
kernel]

instance Pretty Kernel where
  ppr :: Kernel -> Doc
ppr Kernel
kernel =
    String -> Doc
text String
"kernel" Doc -> Doc -> Doc
<+> Doc -> Doc
brace
    (String -> Doc
text String
"groups" Doc -> Doc -> Doc
<+> Doc -> Doc
brace ([Exp] -> Doc
forall a. Pretty a => a -> Doc
ppr ([Exp] -> Doc) -> [Exp] -> Doc
forall a b. (a -> b) -> a -> b
$ Kernel -> [Exp]
kernelNumGroups Kernel
kernel) Doc -> Doc -> Doc
</>
     String -> Doc
text String
"group_size" Doc -> Doc -> Doc
<+> Doc -> Doc
brace ([Exp] -> Doc
forall a. Pretty a => a -> Doc
ppr ([Exp] -> Doc) -> [Exp] -> Doc
forall a b. (a -> b) -> a -> b
$ Kernel -> [Exp]
kernelGroupSize Kernel
kernel) Doc -> Doc -> Doc
</>
     String -> Doc
text String
"uses" Doc -> Doc -> Doc
<+> Doc -> Doc
brace ([Doc] -> Doc
commasep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (KernelUse -> Doc) -> [KernelUse] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map KernelUse -> Doc
forall a. Pretty a => a -> Doc
ppr ([KernelUse] -> [Doc]) -> [KernelUse] -> [Doc]
forall a b. (a -> b) -> a -> b
$ Kernel -> [KernelUse]
kernelUses Kernel
kernel) Doc -> Doc -> Doc
</>
     String -> Doc
text String
"failure_tolerant" Doc -> Doc -> Doc
<+> Doc -> Doc
brace (Bool -> Doc
forall a. Pretty a => a -> Doc
ppr (Bool -> Doc) -> Bool -> Doc
forall a b. (a -> b) -> a -> b
$ Kernel -> Bool
kernelFailureTolerant Kernel
kernel) Doc -> Doc -> Doc
</>
     String -> Doc
text String
"body" Doc -> Doc -> Doc
<+> Doc -> Doc
brace (Code KernelOp -> Doc
forall a. Pretty a => a -> Doc
ppr (Code KernelOp -> Doc) -> Code KernelOp -> Doc
forall a b. (a -> b) -> a -> b
$ Kernel -> Code KernelOp
kernelBody Kernel
kernel))

-- | When we do a barrier or fence, is it at the local or global
-- level?
data Fence = FenceLocal | FenceGlobal
           deriving (Int -> Fence -> ShowS
[Fence] -> ShowS
Fence -> String
(Int -> Fence -> ShowS)
-> (Fence -> String) -> ([Fence] -> ShowS) -> Show Fence
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Fence] -> ShowS
$cshowList :: [Fence] -> ShowS
show :: Fence -> String
$cshow :: Fence -> String
showsPrec :: Int -> Fence -> ShowS
$cshowsPrec :: Int -> Fence -> ShowS
Show)

-- | An operation that occurs within a kernel body.
data KernelOp = GetGroupId VName Int
              | GetLocalId VName Int
              | GetLocalSize VName Int
              | GetGlobalSize VName Int
              | GetGlobalId VName Int
              | GetLockstepWidth VName
              | Atomic Space AtomicOp
              | Barrier Fence
              | MemFence Fence
              | LocalAlloc VName (Count Bytes Imp.Exp)
              | ErrorSync Fence
                -- ^ Perform a barrier and also check whether any
                -- threads have failed an assertion.  Make sure all
                -- threads would reach all 'ErrorSync's if any of them
                -- do.  A failing assertion will jump to the next
                -- following 'ErrorSync', so make sure it's not inside
                -- control flow or similar.
              deriving (Int -> KernelOp -> ShowS
[KernelOp] -> ShowS
KernelOp -> String
(Int -> KernelOp -> ShowS)
-> (KernelOp -> String) -> ([KernelOp] -> ShowS) -> Show KernelOp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KernelOp] -> ShowS
$cshowList :: [KernelOp] -> ShowS
show :: KernelOp -> String
$cshow :: KernelOp -> String
showsPrec :: Int -> KernelOp -> ShowS
$cshowsPrec :: Int -> KernelOp -> ShowS
Show)

-- | Atomic operations return the value stored before the update.
-- This old value is stored in the first 'VName'.  The second 'VName'
-- is the memory block to update.  The 'Exp' is the new value.
data AtomicOp = AtomicAdd IntType VName VName (Count Elements Imp.Exp) Exp
              | AtomicFAdd FloatType VName VName (Count Elements Imp.Exp) Exp
              | AtomicSMax IntType VName VName (Count Elements Imp.Exp) Exp
              | AtomicSMin IntType VName VName (Count Elements Imp.Exp) Exp
              | AtomicUMax IntType VName VName (Count Elements Imp.Exp) Exp
              | AtomicUMin IntType VName VName (Count Elements Imp.Exp) Exp
              | AtomicAnd IntType VName VName (Count Elements Imp.Exp) Exp
              | AtomicOr IntType VName VName (Count Elements Imp.Exp) Exp
              | AtomicXor IntType VName VName (Count Elements Imp.Exp) Exp
              | AtomicCmpXchg PrimType VName VName (Count Elements Imp.Exp) Exp Exp
              | AtomicXchg PrimType VName VName (Count Elements Imp.Exp) Exp
              deriving (Int -> AtomicOp -> ShowS
[AtomicOp] -> ShowS
AtomicOp -> String
(Int -> AtomicOp -> ShowS)
-> (AtomicOp -> String) -> ([AtomicOp] -> ShowS) -> Show AtomicOp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AtomicOp] -> ShowS
$cshowList :: [AtomicOp] -> ShowS
show :: AtomicOp -> String
$cshow :: AtomicOp -> String
showsPrec :: Int -> AtomicOp -> ShowS
$cshowsPrec :: Int -> AtomicOp -> ShowS
Show)

instance FreeIn AtomicOp where
  freeIn' :: AtomicOp -> FV
freeIn' (AtomicAdd IntType
_ VName
_ VName
arr Count Elements Exp
i Exp
x) = VName -> FV
forall a. FreeIn a => a -> FV
freeIn' VName
arr 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
x
  freeIn' (AtomicFAdd FloatType
_ VName
_ VName
arr Count Elements Exp
i Exp
x) = VName -> FV
forall a. FreeIn a => a -> FV
freeIn' VName
arr 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
x
  freeIn' (AtomicSMax IntType
_ VName
_ VName
arr Count Elements Exp
i Exp
x) = VName -> FV
forall a. FreeIn a => a -> FV
freeIn' VName
arr 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
x
  freeIn' (AtomicSMin IntType
_ VName
_ VName
arr Count Elements Exp
i Exp
x) = VName -> FV
forall a. FreeIn a => a -> FV
freeIn' VName
arr 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
x
  freeIn' (AtomicUMax IntType
_ VName
_ VName
arr Count Elements Exp
i Exp
x) = VName -> FV
forall a. FreeIn a => a -> FV
freeIn' VName
arr 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
x
  freeIn' (AtomicUMin IntType
_ VName
_ VName
arr Count Elements Exp
i Exp
x) = VName -> FV
forall a. FreeIn a => a -> FV
freeIn' VName
arr 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
x
  freeIn' (AtomicAnd IntType
_ VName
_ VName
arr Count Elements Exp
i Exp
x) = VName -> FV
forall a. FreeIn a => a -> FV
freeIn' VName
arr 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
x
  freeIn' (AtomicOr IntType
_ VName
_ VName
arr Count Elements Exp
i Exp
x) = VName -> FV
forall a. FreeIn a => a -> FV
freeIn' VName
arr 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
x
  freeIn' (AtomicXor IntType
_ VName
_ VName
arr Count Elements Exp
i Exp
x) = VName -> FV
forall a. FreeIn a => a -> FV
freeIn' VName
arr 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
x
  freeIn' (AtomicCmpXchg PrimType
_ VName
_ VName
arr Count Elements Exp
i Exp
x Exp
y) = VName -> FV
forall a. FreeIn a => a -> FV
freeIn' VName
arr 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
x FV -> FV -> FV
forall a. Semigroup a => a -> a -> a
<> Exp -> FV
forall a. FreeIn a => a -> FV
freeIn' Exp
y
  freeIn' (AtomicXchg PrimType
_ VName
_ VName
arr Count Elements Exp
i Exp
x) = VName -> FV
forall a. FreeIn a => a -> FV
freeIn' VName
arr 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
x

instance Pretty KernelOp where
  ppr :: KernelOp -> Doc
ppr (GetGroupId VName
dest Int
i) =
    VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
dest Doc -> Doc -> Doc
<+>  Doc
"<-" Doc -> Doc -> Doc
<+>
     Doc
"get_group_id" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens (Int -> Doc
forall a. Pretty a => a -> Doc
ppr Int
i)
  ppr (GetLocalId VName
dest Int
i) =
    VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
dest Doc -> Doc -> Doc
<+>  Doc
"<-" Doc -> Doc -> Doc
<+>
     Doc
"get_local_id" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens (Int -> Doc
forall a. Pretty a => a -> Doc
ppr Int
i)
  ppr (GetLocalSize VName
dest Int
i) =
    VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
dest Doc -> Doc -> Doc
<+>  Doc
"<-" Doc -> Doc -> Doc
<+>
     Doc
"get_local_size" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens (Int -> Doc
forall a. Pretty a => a -> Doc
ppr Int
i)
  ppr (GetGlobalSize VName
dest Int
i) =
    VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
dest Doc -> Doc -> Doc
<+>  Doc
"<-" Doc -> Doc -> Doc
<+>
     Doc
"get_global_size" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens (Int -> Doc
forall a. Pretty a => a -> Doc
ppr Int
i)
  ppr (GetGlobalId VName
dest Int
i) =
    VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
dest Doc -> Doc -> Doc
<+>  Doc
"<-" Doc -> Doc -> Doc
<+>
     Doc
"get_global_id" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens (Int -> Doc
forall a. Pretty a => a -> Doc
ppr Int
i)
  ppr (GetLockstepWidth VName
dest) =
    VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
dest Doc -> Doc -> Doc
<+>  Doc
"<-" Doc -> Doc -> Doc
<+>
     Doc
"get_lockstep_width()"
  ppr (Barrier Fence
FenceLocal) =
     Doc
"local_barrier()"
  ppr (Barrier Fence
FenceGlobal) =
     Doc
"global_barrier()"
  ppr (MemFence Fence
FenceLocal) =
     Doc
"mem_fence_local()"
  ppr (MemFence Fence
FenceGlobal) =
     Doc
"mem_fence_global()"
  ppr (LocalAlloc VName
name Count Bytes Exp
size) =
    VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
name Doc -> Doc -> Doc
<+> Doc
equals Doc -> Doc -> Doc
<+>  Doc
"local_alloc" 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
size)
  ppr (ErrorSync Fence
FenceLocal) =
     Doc
"error_sync_local()"
  ppr (ErrorSync Fence
FenceGlobal) =
     Doc
"error_sync_global()"
  ppr (Atomic Space
_ (AtomicAdd IntType
t VName
old VName
arr Count Elements Exp
ind Exp
x)) =
    VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
old Doc -> Doc -> Doc
<+>  Doc
"<-" Doc -> Doc -> Doc
<+>  Doc
"atomic_add_" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> IntType -> Doc
forall a. Pretty a => a -> Doc
ppr IntType
t Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>
    Doc -> Doc
parens ([Doc] -> Doc
commasep [VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
arr 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
ind), Exp -> Doc
forall a. Pretty a => a -> Doc
ppr Exp
x])
  ppr (Atomic Space
_ (AtomicFAdd FloatType
t VName
old VName
arr Count Elements Exp
ind Exp
x)) =
    VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
old Doc -> Doc -> Doc
<+>  Doc
"<-" Doc -> Doc -> Doc
<+>  Doc
"atomic_fadd_" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> FloatType -> Doc
forall a. Pretty a => a -> Doc
ppr FloatType
t Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>
    Doc -> Doc
parens ([Doc] -> Doc
commasep [VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
arr 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
ind), Exp -> Doc
forall a. Pretty a => a -> Doc
ppr Exp
x])
  ppr (Atomic Space
_ (AtomicSMax IntType
t VName
old VName
arr Count Elements Exp
ind Exp
x)) =
    VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
old Doc -> Doc -> Doc
<+>  Doc
"<-" Doc -> Doc -> Doc
<+>  Doc
"atomic_smax" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> IntType -> Doc
forall a. Pretty a => a -> Doc
ppr IntType
t Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>
    Doc -> Doc
parens ([Doc] -> Doc
commasep [VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
arr 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
ind), Exp -> Doc
forall a. Pretty a => a -> Doc
ppr Exp
x])
  ppr (Atomic Space
_ (AtomicSMin IntType
t VName
old VName
arr Count Elements Exp
ind Exp
x)) =
    VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
old Doc -> Doc -> Doc
<+>  Doc
"<-" Doc -> Doc -> Doc
<+>  Doc
"atomic_smin" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> IntType -> Doc
forall a. Pretty a => a -> Doc
ppr IntType
t Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>
    Doc -> Doc
parens ([Doc] -> Doc
commasep [VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
arr 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
ind), Exp -> Doc
forall a. Pretty a => a -> Doc
ppr Exp
x])
  ppr (Atomic Space
_ (AtomicUMax IntType
t VName
old VName
arr Count Elements Exp
ind Exp
x)) =
    VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
old Doc -> Doc -> Doc
<+>  Doc
"<-" Doc -> Doc -> Doc
<+>  Doc
"atomic_umax" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> IntType -> Doc
forall a. Pretty a => a -> Doc
ppr IntType
t Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>
    Doc -> Doc
parens ([Doc] -> Doc
commasep [VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
arr 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
ind), Exp -> Doc
forall a. Pretty a => a -> Doc
ppr Exp
x])
  ppr (Atomic Space
_ (AtomicUMin IntType
t VName
old VName
arr Count Elements Exp
ind Exp
x)) =
    VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
old Doc -> Doc -> Doc
<+>  Doc
"<-" Doc -> Doc -> Doc
<+>  Doc
"atomic_umin" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> IntType -> Doc
forall a. Pretty a => a -> Doc
ppr IntType
t Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>
    Doc -> Doc
parens ([Doc] -> Doc
commasep [VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
arr 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
ind), Exp -> Doc
forall a. Pretty a => a -> Doc
ppr Exp
x])
  ppr (Atomic Space
_ (AtomicAnd IntType
t VName
old VName
arr Count Elements Exp
ind Exp
x)) =
    VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
old Doc -> Doc -> Doc
<+>  Doc
"<-" Doc -> Doc -> Doc
<+>  Doc
"atomic_and" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> IntType -> Doc
forall a. Pretty a => a -> Doc
ppr IntType
t Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>
    Doc -> Doc
parens ([Doc] -> Doc
commasep [VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
arr 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
ind), Exp -> Doc
forall a. Pretty a => a -> Doc
ppr Exp
x])
  ppr (Atomic Space
_ (AtomicOr IntType
t VName
old VName
arr Count Elements Exp
ind Exp
x)) =
    VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
old Doc -> Doc -> Doc
<+>  Doc
"<-" Doc -> Doc -> Doc
<+>  Doc
"atomic_or" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> IntType -> Doc
forall a. Pretty a => a -> Doc
ppr IntType
t Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>
    Doc -> Doc
parens ([Doc] -> Doc
commasep [VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
arr 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
ind), Exp -> Doc
forall a. Pretty a => a -> Doc
ppr Exp
x])
  ppr (Atomic Space
_ (AtomicXor IntType
t VName
old VName
arr Count Elements Exp
ind Exp
x)) =
    VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
old Doc -> Doc -> Doc
<+>  Doc
"<-" Doc -> Doc -> Doc
<+>  Doc
"atomic_xor" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> IntType -> Doc
forall a. Pretty a => a -> Doc
ppr IntType
t Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>
    Doc -> Doc
parens ([Doc] -> Doc
commasep [VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
arr 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
ind), Exp -> Doc
forall a. Pretty a => a -> Doc
ppr Exp
x])
  ppr (Atomic Space
_ (AtomicCmpXchg PrimType
t VName
old VName
arr Count Elements Exp
ind Exp
x Exp
y)) =
    VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
old Doc -> Doc -> Doc
<+>  Doc
"<-" Doc -> Doc -> Doc
<+>  Doc
"atomic_cmp_xchg" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> PrimType -> Doc
forall a. Pretty a => a -> Doc
ppr PrimType
t Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>
    Doc -> Doc
parens ([Doc] -> Doc
commasep [VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
arr 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
ind), Exp -> Doc
forall a. Pretty a => a -> Doc
ppr Exp
x, Exp -> Doc
forall a. Pretty a => a -> Doc
ppr Exp
y])
  ppr (Atomic Space
_ (AtomicXchg PrimType
t VName
old VName
arr Count Elements Exp
ind Exp
x)) =
    VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
old Doc -> Doc -> Doc
<+>  Doc
"<-" Doc -> Doc -> Doc
<+>  Doc
"atomic_xchg" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> PrimType -> Doc
forall a. Pretty a => a -> Doc
ppr PrimType
t Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>
    Doc -> Doc
parens ([Doc] -> Doc
commasep [VName -> Doc
forall a. Pretty a => a -> Doc
ppr VName
arr 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
ind), Exp -> Doc
forall a. Pretty a => a -> Doc
ppr Exp
x])

instance FreeIn KernelOp where
  freeIn' :: KernelOp -> FV
freeIn' (Atomic Space
_ AtomicOp
op) = AtomicOp -> FV
forall a. FreeIn a => a -> FV
freeIn' AtomicOp
op
  freeIn' KernelOp
_ = FV
forall a. Monoid a => a
mempty

brace :: Doc -> Doc
brace :: Doc -> Doc
brace Doc
body =  Doc
" {" Doc -> Doc -> Doc
</> Int -> Doc -> Doc
indent Int
2 Doc
body Doc -> Doc -> Doc
</>  Doc
"}"