{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TupleSections #-}
module Futhark.CodeGen.Backends.GenericC.Monad
(
Operations (..),
Publicness (..),
OpCompiler,
ErrorCompiler,
CallCompiler,
PointerQuals,
MemoryType,
WriteScalar,
writeScalarPointerWithQuals,
ReadScalar,
readScalarPointerWithQuals,
Allocate,
Deallocate,
CopyBarrier (..),
Copy,
StaticArray,
CompilerM,
CompilerState (..),
CompilerEnv (..),
getUserState,
modifyUserState,
contextContents,
contextFinalInits,
runCompilerM,
inNewFunction,
cachingMemory,
volQuals,
rawMem,
item,
items,
stm,
stms,
decl,
atInit,
headerDecl,
publicDef,
publicDef_,
profileReport,
onClear,
HeaderSection (..),
libDecl,
earlyDecl,
publicName,
contextField,
contextFieldDyn,
memToCType,
cacheMem,
fatMemory,
rawMemCType,
freeRawMem,
allocRawMem,
fatMemType,
declAllocatedMem,
freeAllocatedMem,
collect,
collect',
contextType,
configType,
copyMemoryDefaultSpace,
derefPointer,
setMem,
allocMem,
unRefMem,
declMem,
resetMem,
fatMemAlloc,
fatMemSet,
fatMemUnRef,
criticalSection,
module Futhark.CodeGen.Backends.SimpleRep,
)
where
import Control.Monad.Identity
import Control.Monad.Reader
import Control.Monad.State
import Data.Bifunctor (first)
import qualified Data.DList as DL
import Data.List (unzip4)
import Data.Loc
import qualified Data.Map.Strict as M
import Data.Maybe
import Futhark.CodeGen.Backends.SimpleRep
import Futhark.CodeGen.ImpCode
import Futhark.MonadFreshNames
import qualified Language.C.Quote.OpenCL as C
import qualified Language.C.Syntax as C
data Publicness = Private | Public
deriving (Publicness -> Publicness -> Bool
(Publicness -> Publicness -> Bool)
-> (Publicness -> Publicness -> Bool) -> Eq Publicness
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Publicness -> Publicness -> Bool
$c/= :: Publicness -> Publicness -> Bool
== :: Publicness -> Publicness -> Bool
$c== :: Publicness -> Publicness -> Bool
Eq, Eq Publicness
Eq Publicness
-> (Publicness -> Publicness -> Ordering)
-> (Publicness -> Publicness -> Bool)
-> (Publicness -> Publicness -> Bool)
-> (Publicness -> Publicness -> Bool)
-> (Publicness -> Publicness -> Bool)
-> (Publicness -> Publicness -> Publicness)
-> (Publicness -> Publicness -> Publicness)
-> Ord Publicness
Publicness -> Publicness -> Bool
Publicness -> Publicness -> Ordering
Publicness -> Publicness -> Publicness
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 :: Publicness -> Publicness -> Publicness
$cmin :: Publicness -> Publicness -> Publicness
max :: Publicness -> Publicness -> Publicness
$cmax :: Publicness -> Publicness -> Publicness
>= :: Publicness -> Publicness -> Bool
$c>= :: Publicness -> Publicness -> Bool
> :: Publicness -> Publicness -> Bool
$c> :: Publicness -> Publicness -> Bool
<= :: Publicness -> Publicness -> Bool
$c<= :: Publicness -> Publicness -> Bool
< :: Publicness -> Publicness -> Bool
$c< :: Publicness -> Publicness -> Bool
compare :: Publicness -> Publicness -> Ordering
$ccompare :: Publicness -> Publicness -> Ordering
Ord, Int -> Publicness -> ShowS
[Publicness] -> ShowS
Publicness -> [Char]
(Int -> Publicness -> ShowS)
-> (Publicness -> [Char])
-> ([Publicness] -> ShowS)
-> Show Publicness
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Publicness] -> ShowS
$cshowList :: [Publicness] -> ShowS
show :: Publicness -> [Char]
$cshow :: Publicness -> [Char]
showsPrec :: Int -> Publicness -> ShowS
$cshowsPrec :: Int -> Publicness -> ShowS
Show)
type ArrayType = (Signedness, PrimType, Int)
data CompilerState s = CompilerState
{ forall s. CompilerState s -> Map ArrayType Publicness
compArrayTypes :: M.Map ArrayType Publicness,
forall s. CompilerState s -> DList Definition
compEarlyDecls :: DL.DList C.Definition,
forall s. CompilerState s -> [Stm]
compInit :: [C.Stm],
forall s. CompilerState s -> VNameSource
compNameSrc :: VNameSource,
forall s. CompilerState s -> s
compUserState :: s,
:: M.Map HeaderSection (DL.DList C.Definition),
forall s. CompilerState s -> DList Definition
compLibDecls :: DL.DList C.Definition,
forall s. CompilerState s -> DList (Id, Type, Maybe Exp, Maybe Stm)
compCtxFields :: DL.DList (C.Id, C.Type, Maybe C.Exp, Maybe C.Stm),
forall s. CompilerState s -> DList BlockItem
compProfileItems :: DL.DList C.BlockItem,
forall s. CompilerState s -> DList BlockItem
compClearItems :: DL.DList C.BlockItem,
forall s. CompilerState s -> [(VName, Space)]
compDeclaredMem :: [(VName, Space)],
forall s. CompilerState s -> DList BlockItem
compItems :: DL.DList C.BlockItem
}
newCompilerState :: VNameSource -> s -> CompilerState s
newCompilerState :: forall s. VNameSource -> s -> CompilerState s
newCompilerState VNameSource
src s
s =
CompilerState :: forall s.
Map ArrayType Publicness
-> DList Definition
-> [Stm]
-> VNameSource
-> s
-> Map HeaderSection (DList Definition)
-> DList Definition
-> DList (Id, Type, Maybe Exp, Maybe Stm)
-> DList BlockItem
-> DList BlockItem
-> [(VName, Space)]
-> DList BlockItem
-> CompilerState s
CompilerState
{ compArrayTypes :: Map ArrayType Publicness
compArrayTypes = Map ArrayType Publicness
forall a. Monoid a => a
mempty,
compEarlyDecls :: DList Definition
compEarlyDecls = DList Definition
forall a. Monoid a => a
mempty,
compInit :: [Stm]
compInit = [],
compNameSrc :: VNameSource
compNameSrc = VNameSource
src,
compUserState :: s
compUserState = s
s,
compHeaderDecls :: Map HeaderSection (DList Definition)
compHeaderDecls = Map HeaderSection (DList Definition)
forall a. Monoid a => a
mempty,
compLibDecls :: DList Definition
compLibDecls = DList Definition
forall a. Monoid a => a
mempty,
compCtxFields :: DList (Id, Type, Maybe Exp, Maybe Stm)
compCtxFields = DList (Id, Type, Maybe Exp, Maybe Stm)
forall a. Monoid a => a
mempty,
compProfileItems :: DList BlockItem
compProfileItems = DList BlockItem
forall a. Monoid a => a
mempty,
compClearItems :: DList BlockItem
compClearItems = DList BlockItem
forall a. Monoid a => a
mempty,
compDeclaredMem :: [(VName, Space)]
compDeclaredMem = [(VName, Space)]
forall a. Monoid a => a
mempty,
compItems :: DList BlockItem
compItems = DList BlockItem
forall a. Monoid a => a
mempty
}
data
= ArrayDecl String
| OpaqueTypeDecl String
| OpaqueDecl String
| EntryDecl
| MiscDecl
| InitDecl
deriving (HeaderSection -> HeaderSection -> Bool
(HeaderSection -> HeaderSection -> Bool)
-> (HeaderSection -> HeaderSection -> Bool) -> Eq HeaderSection
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HeaderSection -> HeaderSection -> Bool
$c/= :: HeaderSection -> HeaderSection -> Bool
== :: HeaderSection -> HeaderSection -> Bool
$c== :: HeaderSection -> HeaderSection -> Bool
Eq, Eq HeaderSection
Eq HeaderSection
-> (HeaderSection -> HeaderSection -> Ordering)
-> (HeaderSection -> HeaderSection -> Bool)
-> (HeaderSection -> HeaderSection -> Bool)
-> (HeaderSection -> HeaderSection -> Bool)
-> (HeaderSection -> HeaderSection -> Bool)
-> (HeaderSection -> HeaderSection -> HeaderSection)
-> (HeaderSection -> HeaderSection -> HeaderSection)
-> Ord HeaderSection
HeaderSection -> HeaderSection -> Bool
HeaderSection -> HeaderSection -> Ordering
HeaderSection -> HeaderSection -> HeaderSection
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 :: HeaderSection -> HeaderSection -> HeaderSection
$cmin :: HeaderSection -> HeaderSection -> HeaderSection
max :: HeaderSection -> HeaderSection -> HeaderSection
$cmax :: HeaderSection -> HeaderSection -> HeaderSection
>= :: HeaderSection -> HeaderSection -> Bool
$c>= :: HeaderSection -> HeaderSection -> Bool
> :: HeaderSection -> HeaderSection -> Bool
$c> :: HeaderSection -> HeaderSection -> Bool
<= :: HeaderSection -> HeaderSection -> Bool
$c<= :: HeaderSection -> HeaderSection -> Bool
< :: HeaderSection -> HeaderSection -> Bool
$c< :: HeaderSection -> HeaderSection -> Bool
compare :: HeaderSection -> HeaderSection -> Ordering
$ccompare :: HeaderSection -> HeaderSection -> Ordering
Ord)
type OpCompiler op s = op -> CompilerM op s ()
type ErrorCompiler op s = ErrorMsg Exp -> String -> CompilerM op s ()
type PointerQuals op s = String -> CompilerM op s [C.TypeQual]
type MemoryType op s = SpaceId -> CompilerM op s C.Type
type WriteScalar op s =
C.Exp -> C.Exp -> C.Type -> SpaceId -> Volatility -> C.Exp -> CompilerM op s ()
type ReadScalar op s =
C.Exp -> C.Exp -> C.Type -> SpaceId -> Volatility -> CompilerM op s C.Exp
type Allocate op s =
C.Exp ->
C.Exp ->
C.Exp ->
SpaceId ->
CompilerM op s ()
type Deallocate op s = C.Exp -> C.Exp -> SpaceId -> CompilerM op s ()
type StaticArray op s = VName -> SpaceId -> PrimType -> ArrayContents -> CompilerM op s ()
data CopyBarrier
= CopyBarrier
|
CopyNoBarrier
deriving (CopyBarrier -> CopyBarrier -> Bool
(CopyBarrier -> CopyBarrier -> Bool)
-> (CopyBarrier -> CopyBarrier -> Bool) -> Eq CopyBarrier
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CopyBarrier -> CopyBarrier -> Bool
$c/= :: CopyBarrier -> CopyBarrier -> Bool
== :: CopyBarrier -> CopyBarrier -> Bool
$c== :: CopyBarrier -> CopyBarrier -> Bool
Eq, Int -> CopyBarrier -> ShowS
[CopyBarrier] -> ShowS
CopyBarrier -> [Char]
(Int -> CopyBarrier -> ShowS)
-> (CopyBarrier -> [Char])
-> ([CopyBarrier] -> ShowS)
-> Show CopyBarrier
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [CopyBarrier] -> ShowS
$cshowList :: [CopyBarrier] -> ShowS
show :: CopyBarrier -> [Char]
$cshow :: CopyBarrier -> [Char]
showsPrec :: Int -> CopyBarrier -> ShowS
$cshowsPrec :: Int -> CopyBarrier -> ShowS
Show)
type Copy op s =
CopyBarrier ->
C.Exp ->
C.Exp ->
Space ->
C.Exp ->
C.Exp ->
Space ->
C.Exp ->
CompilerM op s ()
type CallCompiler op s = [VName] -> Name -> [C.Exp] -> CompilerM op s ()
data Operations op s = Operations
{ forall op s. Operations op s -> WriteScalar op s
opsWriteScalar :: WriteScalar op s,
forall op s. Operations op s -> ReadScalar op s
opsReadScalar :: ReadScalar op s,
forall op s. Operations op s -> Allocate op s
opsAllocate :: Allocate op s,
forall op s. Operations op s -> Deallocate op s
opsDeallocate :: Deallocate op s,
forall op s. Operations op s -> Copy op s
opsCopy :: Copy op s,
forall op s. Operations op s -> StaticArray op s
opsStaticArray :: StaticArray op s,
forall op s. Operations op s -> MemoryType op s
opsMemoryType :: MemoryType op s,
forall op s. Operations op s -> OpCompiler op s
opsCompiler :: OpCompiler op s,
forall op s. Operations op s -> ErrorCompiler op s
opsError :: ErrorCompiler op s,
forall op s. Operations op s -> CallCompiler op s
opsCall :: CallCompiler op s,
forall op s. Operations op s -> Bool
opsFatMemory :: Bool,
forall op s. Operations op s -> ([BlockItem], [BlockItem])
opsCritical :: ([C.BlockItem], [C.BlockItem])
}
freeAllocatedMem :: CompilerM op s [C.BlockItem]
freeAllocatedMem :: forall op s. CompilerM op s [BlockItem]
freeAllocatedMem = CompilerM op s () -> CompilerM op s [BlockItem]
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
collect (CompilerM op s () -> CompilerM op s [BlockItem])
-> CompilerM op s () -> CompilerM op s [BlockItem]
forall a b. (a -> b) -> a -> b
$ ((VName, Space) -> CompilerM op s ())
-> [(VName, Space)] -> CompilerM op s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((VName -> Space -> CompilerM op s ())
-> (VName, Space) -> CompilerM op s ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry VName -> Space -> CompilerM op s ()
forall a op s. ToExp a => a -> Space -> CompilerM op s ()
unRefMem) ([(VName, Space)] -> CompilerM op s ())
-> CompilerM op s [(VName, Space)] -> CompilerM op s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (CompilerState s -> [(VName, Space)])
-> CompilerM op s [(VName, Space)]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompilerState s -> [(VName, Space)]
forall s. CompilerState s -> [(VName, Space)]
compDeclaredMem
declAllocatedMem :: CompilerM op s [C.BlockItem]
declAllocatedMem :: forall op s. CompilerM op s [BlockItem]
declAllocatedMem = CompilerM op s () -> CompilerM op s [BlockItem]
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
collect (CompilerM op s () -> CompilerM op s [BlockItem])
-> CompilerM op s () -> CompilerM op s [BlockItem]
forall a b. (a -> b) -> a -> b
$ ((VName, Space) -> CompilerM op s ())
-> [(VName, Space)] -> CompilerM op s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (VName, Space) -> CompilerM op s ()
forall {op} {s}. (VName, Space) -> CompilerM op s ()
f ([(VName, Space)] -> CompilerM op s ())
-> CompilerM op s [(VName, Space)] -> CompilerM op s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (CompilerState s -> [(VName, Space)])
-> CompilerM op s [(VName, Space)]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompilerState s -> [(VName, Space)]
forall s. CompilerState s -> [(VName, Space)]
compDeclaredMem
where
f :: (VName, Space) -> CompilerM op s ()
f (VName
name, Space
space) = do
Type
ty <- VName -> Space -> CompilerM op s Type
forall op s. VName -> Space -> CompilerM op s Type
memToCType VName
name Space
space
InitGroup -> CompilerM op s ()
forall op s. InitGroup -> CompilerM op s ()
decl [C.cdecl|$ty:ty $id:name;|]
VName -> Space -> CompilerM op s ()
forall a op s. ToExp a => a -> Space -> CompilerM op s ()
resetMem VName
name Space
space
data CompilerEnv op s = CompilerEnv
{ forall op s. CompilerEnv op s -> Operations op s
envOperations :: Operations op s,
forall op s. CompilerEnv op s -> Map Exp VName
envCachedMem :: M.Map C.Exp VName
}
contextContents :: CompilerM op s ([C.FieldGroup], [C.Stm], [C.Stm])
contextContents :: forall op s. CompilerM op s ([FieldGroup], [Stm], [Stm])
contextContents = do
([Id]
field_names, [Type]
field_types, [Maybe Exp]
field_values, [Maybe Stm]
field_frees) <-
(CompilerState s -> ([Id], [Type], [Maybe Exp], [Maybe Stm]))
-> CompilerM op s ([Id], [Type], [Maybe Exp], [Maybe Stm])
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((CompilerState s -> ([Id], [Type], [Maybe Exp], [Maybe Stm]))
-> CompilerM op s ([Id], [Type], [Maybe Exp], [Maybe Stm]))
-> (CompilerState s -> ([Id], [Type], [Maybe Exp], [Maybe Stm]))
-> CompilerM op s ([Id], [Type], [Maybe Exp], [Maybe Stm])
forall a b. (a -> b) -> a -> b
$ [(Id, Type, Maybe Exp, Maybe Stm)]
-> ([Id], [Type], [Maybe Exp], [Maybe Stm])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 ([(Id, Type, Maybe Exp, Maybe Stm)]
-> ([Id], [Type], [Maybe Exp], [Maybe Stm]))
-> (CompilerState s -> [(Id, Type, Maybe Exp, Maybe Stm)])
-> CompilerState s
-> ([Id], [Type], [Maybe Exp], [Maybe Stm])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DList (Id, Type, Maybe Exp, Maybe Stm)
-> [(Id, Type, Maybe Exp, Maybe Stm)]
forall a. DList a -> [a]
DL.toList (DList (Id, Type, Maybe Exp, Maybe Stm)
-> [(Id, Type, Maybe Exp, Maybe Stm)])
-> (CompilerState s -> DList (Id, Type, Maybe Exp, Maybe Stm))
-> CompilerState s
-> [(Id, Type, Maybe Exp, Maybe Stm)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerState s -> DList (Id, Type, Maybe Exp, Maybe Stm)
forall s. CompilerState s -> DList (Id, Type, Maybe Exp, Maybe Stm)
compCtxFields
let fields :: [FieldGroup]
fields =
[ [C.csdecl|$ty:ty $id:name;|]
| (Id
name, Type
ty) <- [Id] -> [Type] -> [(Id, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
field_names [Type]
field_types
]
init_fields :: [Stm]
init_fields =
[ [C.cstm|ctx->$id:name = $exp:e;|]
| (Id
name, Just Exp
e) <- [Id] -> [Maybe Exp] -> [(Id, Maybe Exp)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
field_names [Maybe Exp]
field_values
]
([FieldGroup], [Stm], [Stm])
-> CompilerM op s ([FieldGroup], [Stm], [Stm])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FieldGroup]
fields, [Stm]
init_fields, [Maybe Stm] -> [Stm]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Stm]
field_frees)
contextFinalInits :: CompilerM op s [C.Stm]
contextFinalInits :: forall op s. CompilerM op s [Stm]
contextFinalInits = (CompilerState s -> [Stm]) -> CompilerM op s [Stm]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompilerState s -> [Stm]
forall s. CompilerState s -> [Stm]
compInit
newtype CompilerM op s a
= CompilerM (ReaderT (CompilerEnv op s) (State (CompilerState s)) a)
deriving
( (forall a b. (a -> b) -> CompilerM op s a -> CompilerM op s b)
-> (forall a b. a -> CompilerM op s b -> CompilerM op s a)
-> Functor (CompilerM op s)
forall a b. a -> CompilerM op s b -> CompilerM op s a
forall a b. (a -> b) -> CompilerM op s a -> CompilerM op s b
forall op s a b. a -> CompilerM op s b -> CompilerM op s a
forall op s a b. (a -> b) -> CompilerM op s a -> CompilerM op s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> CompilerM op s b -> CompilerM op s a
$c<$ :: forall op s a b. a -> CompilerM op s b -> CompilerM op s a
fmap :: forall a b. (a -> b) -> CompilerM op s a -> CompilerM op s b
$cfmap :: forall op s a b. (a -> b) -> CompilerM op s a -> CompilerM op s b
Functor,
Functor (CompilerM op s)
Functor (CompilerM op s)
-> (forall a. a -> CompilerM op s a)
-> (forall a b.
CompilerM op s (a -> b) -> CompilerM op s a -> CompilerM op s b)
-> (forall a b c.
(a -> b -> c)
-> CompilerM op s a -> CompilerM op s b -> CompilerM op s c)
-> (forall a b.
CompilerM op s a -> CompilerM op s b -> CompilerM op s b)
-> (forall a b.
CompilerM op s a -> CompilerM op s b -> CompilerM op s a)
-> Applicative (CompilerM op s)
forall a. a -> CompilerM op s a
forall op s. Functor (CompilerM op s)
forall a b.
CompilerM op s a -> CompilerM op s b -> CompilerM op s a
forall a b.
CompilerM op s a -> CompilerM op s b -> CompilerM op s b
forall a b.
CompilerM op s (a -> b) -> CompilerM op s a -> CompilerM op s b
forall op s a. a -> CompilerM op s a
forall a b c.
(a -> b -> c)
-> CompilerM op s a -> CompilerM op s b -> CompilerM op s c
forall op s a b.
CompilerM op s a -> CompilerM op s b -> CompilerM op s a
forall op s a b.
CompilerM op s a -> CompilerM op s b -> CompilerM op s b
forall op s a b.
CompilerM op s (a -> b) -> CompilerM op s a -> CompilerM op s b
forall op s a b c.
(a -> b -> c)
-> CompilerM op s a -> CompilerM op s b -> CompilerM op s c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b.
CompilerM op s a -> CompilerM op s b -> CompilerM op s a
$c<* :: forall op s a b.
CompilerM op s a -> CompilerM op s b -> CompilerM op s a
*> :: forall a b.
CompilerM op s a -> CompilerM op s b -> CompilerM op s b
$c*> :: forall op s a b.
CompilerM op s a -> CompilerM op s b -> CompilerM op s b
liftA2 :: forall a b c.
(a -> b -> c)
-> CompilerM op s a -> CompilerM op s b -> CompilerM op s c
$cliftA2 :: forall op s a b c.
(a -> b -> c)
-> CompilerM op s a -> CompilerM op s b -> CompilerM op s c
<*> :: forall a b.
CompilerM op s (a -> b) -> CompilerM op s a -> CompilerM op s b
$c<*> :: forall op s a b.
CompilerM op s (a -> b) -> CompilerM op s a -> CompilerM op s b
pure :: forall a. a -> CompilerM op s a
$cpure :: forall op s a. a -> CompilerM op s a
Applicative,
Applicative (CompilerM op s)
Applicative (CompilerM op s)
-> (forall a b.
CompilerM op s a -> (a -> CompilerM op s b) -> CompilerM op s b)
-> (forall a b.
CompilerM op s a -> CompilerM op s b -> CompilerM op s b)
-> (forall a. a -> CompilerM op s a)
-> Monad (CompilerM op s)
forall a. a -> CompilerM op s a
forall op s. Applicative (CompilerM op s)
forall a b.
CompilerM op s a -> CompilerM op s b -> CompilerM op s b
forall a b.
CompilerM op s a -> (a -> CompilerM op s b) -> CompilerM op s b
forall op s a. a -> CompilerM op s a
forall op s a b.
CompilerM op s a -> CompilerM op s b -> CompilerM op s b
forall op s a b.
CompilerM op s a -> (a -> CompilerM op s b) -> CompilerM op s b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> CompilerM op s a
$creturn :: forall op s a. a -> CompilerM op s a
>> :: forall a b.
CompilerM op s a -> CompilerM op s b -> CompilerM op s b
$c>> :: forall op s a b.
CompilerM op s a -> CompilerM op s b -> CompilerM op s b
>>= :: forall a b.
CompilerM op s a -> (a -> CompilerM op s b) -> CompilerM op s b
$c>>= :: forall op s a b.
CompilerM op s a -> (a -> CompilerM op s b) -> CompilerM op s b
Monad,
MonadState (CompilerState s),
MonadReader (CompilerEnv op s)
)
instance MonadFreshNames (CompilerM op s) where
getNameSource :: CompilerM op s VNameSource
getNameSource = (CompilerState s -> VNameSource) -> CompilerM op s VNameSource
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompilerState s -> VNameSource
forall s. CompilerState s -> VNameSource
compNameSrc
putNameSource :: VNameSource -> CompilerM op s ()
putNameSource VNameSource
src = (CompilerState s -> CompilerState s) -> CompilerM op s ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CompilerState s -> CompilerState s) -> CompilerM op s ())
-> (CompilerState s -> CompilerState s) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \CompilerState s
s -> CompilerState s
s {compNameSrc :: VNameSource
compNameSrc = VNameSource
src}
runCompilerM ::
Operations op s ->
VNameSource ->
s ->
CompilerM op s a ->
(a, CompilerState s)
runCompilerM :: forall op s a.
Operations op s
-> VNameSource -> s -> CompilerM op s a -> (a, CompilerState s)
runCompilerM Operations op s
ops VNameSource
src s
userstate (CompilerM ReaderT (CompilerEnv op s) (State (CompilerState s)) a
m) =
State (CompilerState s) a
-> CompilerState s -> (a, CompilerState s)
forall s a. State s a -> s -> (a, s)
runState
(ReaderT (CompilerEnv op s) (State (CompilerState s)) a
-> CompilerEnv op s -> State (CompilerState s) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (CompilerEnv op s) (State (CompilerState s)) a
m (Operations op s -> Map Exp VName -> CompilerEnv op s
forall op s. Operations op s -> Map Exp VName -> CompilerEnv op s
CompilerEnv Operations op s
ops Map Exp VName
forall a. Monoid a => a
mempty))
(VNameSource -> s -> CompilerState s
forall s. VNameSource -> s -> CompilerState s
newCompilerState VNameSource
src s
userstate)
getUserState :: CompilerM op s s
getUserState :: forall op s. CompilerM op s s
getUserState = (CompilerState s -> s) -> CompilerM op s s
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompilerState s -> s
forall s. CompilerState s -> s
compUserState
modifyUserState :: (s -> s) -> CompilerM op s ()
modifyUserState :: forall s op. (s -> s) -> CompilerM op s ()
modifyUserState s -> s
f = (CompilerState s -> CompilerState s) -> CompilerM op s ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CompilerState s -> CompilerState s) -> CompilerM op s ())
-> (CompilerState s -> CompilerState s) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \CompilerState s
compstate ->
CompilerState s
compstate {compUserState :: s
compUserState = s -> s
f (s -> s) -> s -> s
forall a b. (a -> b) -> a -> b
$ CompilerState s -> s
forall s. CompilerState s -> s
compUserState CompilerState s
compstate}
atInit :: C.Stm -> CompilerM op s ()
atInit :: forall op s. Stm -> CompilerM op s ()
atInit Stm
x = (CompilerState s -> CompilerState s) -> CompilerM op s ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CompilerState s -> CompilerState s) -> CompilerM op s ())
-> (CompilerState s -> CompilerState s) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \CompilerState s
s ->
CompilerState s
s {compInit :: [Stm]
compInit = CompilerState s -> [Stm]
forall s. CompilerState s -> [Stm]
compInit CompilerState s
s [Stm] -> [Stm] -> [Stm]
forall a. [a] -> [a] -> [a]
++ [Stm
x]}
collect :: CompilerM op s () -> CompilerM op s [C.BlockItem]
collect :: forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
collect CompilerM op s ()
m = ((), [BlockItem]) -> [BlockItem]
forall a b. (a, b) -> b
snd (((), [BlockItem]) -> [BlockItem])
-> CompilerM op s ((), [BlockItem]) -> CompilerM op s [BlockItem]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CompilerM op s () -> CompilerM op s ((), [BlockItem])
forall op s a. CompilerM op s a -> CompilerM op s (a, [BlockItem])
collect' CompilerM op s ()
m
collect' :: CompilerM op s a -> CompilerM op s (a, [C.BlockItem])
collect' :: forall op s a. CompilerM op s a -> CompilerM op s (a, [BlockItem])
collect' CompilerM op s a
m = do
DList BlockItem
old <- (CompilerState s -> DList BlockItem)
-> CompilerM op s (DList BlockItem)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompilerState s -> DList BlockItem
forall s. CompilerState s -> DList BlockItem
compItems
(CompilerState s -> CompilerState s) -> CompilerM op s ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CompilerState s -> CompilerState s) -> CompilerM op s ())
-> (CompilerState s -> CompilerState s) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \CompilerState s
s -> CompilerState s
s {compItems :: DList BlockItem
compItems = DList BlockItem
forall a. Monoid a => a
mempty}
a
x <- CompilerM op s a
m
DList BlockItem
new <- (CompilerState s -> DList BlockItem)
-> CompilerM op s (DList BlockItem)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompilerState s -> DList BlockItem
forall s. CompilerState s -> DList BlockItem
compItems
(CompilerState s -> CompilerState s) -> CompilerM op s ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CompilerState s -> CompilerState s) -> CompilerM op s ())
-> (CompilerState s -> CompilerState s) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \CompilerState s
s -> CompilerState s
s {compItems :: DList BlockItem
compItems = DList BlockItem
old}
(a, [BlockItem]) -> CompilerM op s (a, [BlockItem])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
x, DList BlockItem -> [BlockItem]
forall a. DList a -> [a]
DL.toList DList BlockItem
new)
inNewFunction :: CompilerM op s a -> CompilerM op s a
inNewFunction :: forall op s a. CompilerM op s a -> CompilerM op s a
inNewFunction CompilerM op s a
m = do
[(VName, Space)]
old_mem <- (CompilerState s -> [(VName, Space)])
-> CompilerM op s [(VName, Space)]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompilerState s -> [(VName, Space)]
forall s. CompilerState s -> [(VName, Space)]
compDeclaredMem
(CompilerState s -> CompilerState s) -> CompilerM op s ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CompilerState s -> CompilerState s) -> CompilerM op s ())
-> (CompilerState s -> CompilerState s) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \CompilerState s
s -> CompilerState s
s {compDeclaredMem :: [(VName, Space)]
compDeclaredMem = [(VName, Space)]
forall a. Monoid a => a
mempty}
a
x <- (CompilerEnv op s -> CompilerEnv op s)
-> CompilerM op s a -> CompilerM op s a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local CompilerEnv op s -> CompilerEnv op s
forall {op} {s}. CompilerEnv op s -> CompilerEnv op s
noCached CompilerM op s a
m
(CompilerState s -> CompilerState s) -> CompilerM op s ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CompilerState s -> CompilerState s) -> CompilerM op s ())
-> (CompilerState s -> CompilerState s) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \CompilerState s
s -> CompilerState s
s {compDeclaredMem :: [(VName, Space)]
compDeclaredMem = [(VName, Space)]
old_mem}
a -> CompilerM op s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
where
noCached :: CompilerEnv op s -> CompilerEnv op s
noCached CompilerEnv op s
env = CompilerEnv op s
env {envCachedMem :: Map Exp VName
envCachedMem = Map Exp VName
forall a. Monoid a => a
mempty}
item :: C.BlockItem -> CompilerM op s ()
item :: forall op s. BlockItem -> CompilerM op s ()
item BlockItem
x = (CompilerState s -> CompilerState s) -> CompilerM op s ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CompilerState s -> CompilerState s) -> CompilerM op s ())
-> (CompilerState s -> CompilerState s) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \CompilerState s
s -> CompilerState s
s {compItems :: DList BlockItem
compItems = DList BlockItem -> BlockItem -> DList BlockItem
forall a. DList a -> a -> DList a
DL.snoc (CompilerState s -> DList BlockItem
forall s. CompilerState s -> DList BlockItem
compItems CompilerState s
s) BlockItem
x}
items :: [C.BlockItem] -> CompilerM op s ()
items :: forall op s. [BlockItem] -> CompilerM op s ()
items [BlockItem]
xs = (CompilerState s -> CompilerState s) -> CompilerM op s ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CompilerState s -> CompilerState s) -> CompilerM op s ())
-> (CompilerState s -> CompilerState s) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \CompilerState s
s -> CompilerState s
s {compItems :: DList BlockItem
compItems = DList BlockItem -> DList BlockItem -> DList BlockItem
forall a. DList a -> DList a -> DList a
DL.append (CompilerState s -> DList BlockItem
forall s. CompilerState s -> DList BlockItem
compItems CompilerState s
s) ([BlockItem] -> DList BlockItem
forall a. [a] -> DList a
DL.fromList [BlockItem]
xs)}
fatMemory :: Space -> CompilerM op s Bool
fatMemory :: forall op s. Space -> CompilerM op s Bool
fatMemory ScalarSpace {} = Bool -> CompilerM op s Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
fatMemory Space
_ = (CompilerEnv op s -> Bool) -> CompilerM op s Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((CompilerEnv op s -> Bool) -> CompilerM op s Bool)
-> (CompilerEnv op s -> Bool) -> CompilerM op s Bool
forall a b. (a -> b) -> a -> b
$ Operations op s -> Bool
forall op s. Operations op s -> Bool
opsFatMemory (Operations op s -> Bool)
-> (CompilerEnv op s -> Operations op s)
-> CompilerEnv op s
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerEnv op s -> Operations op s
forall op s. CompilerEnv op s -> Operations op s
envOperations
cacheMem :: C.ToExp a => a -> CompilerM op s (Maybe VName)
cacheMem :: forall a op s. ToExp a => a -> CompilerM op s (Maybe VName)
cacheMem a
a = (CompilerEnv op s -> Maybe VName) -> CompilerM op s (Maybe VName)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((CompilerEnv op s -> Maybe VName) -> CompilerM op s (Maybe VName))
-> (CompilerEnv op s -> Maybe VName)
-> CompilerM op s (Maybe VName)
forall a b. (a -> b) -> a -> b
$ Exp -> Map Exp VName -> Maybe VName
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (a -> SrcLoc -> Exp
forall a. ToExp a => a -> SrcLoc -> Exp
C.toExp a
a SrcLoc
forall a. IsLocation a => a
noLoc) (Map Exp VName -> Maybe VName)
-> (CompilerEnv op s -> Map Exp VName)
-> CompilerEnv op s
-> Maybe VName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerEnv op s -> Map Exp VName
forall op s. CompilerEnv op s -> Map Exp VName
envCachedMem
publicDef ::
String ->
HeaderSection ->
(String -> (C.Definition, C.Definition)) ->
CompilerM op s String
publicDef :: forall op s.
[Char]
-> HeaderSection
-> ([Char] -> (Definition, Definition))
-> CompilerM op s [Char]
publicDef [Char]
s HeaderSection
h [Char] -> (Definition, Definition)
f = do
[Char]
s' <- [Char] -> CompilerM op s [Char]
forall op s. [Char] -> CompilerM op s [Char]
publicName [Char]
s
let (Definition
pub, Definition
priv) = [Char] -> (Definition, Definition)
f [Char]
s'
HeaderSection -> Definition -> CompilerM op s ()
forall op s. HeaderSection -> Definition -> CompilerM op s ()
headerDecl HeaderSection
h Definition
pub
Definition -> CompilerM op s ()
forall op s. Definition -> CompilerM op s ()
earlyDecl Definition
priv
[Char] -> CompilerM op s [Char]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
s'
publicDef_ ::
String ->
HeaderSection ->
(String -> (C.Definition, C.Definition)) ->
CompilerM op s ()
publicDef_ :: forall op s.
[Char]
-> HeaderSection
-> ([Char] -> (Definition, Definition))
-> CompilerM op s ()
publicDef_ [Char]
s HeaderSection
h [Char] -> (Definition, Definition)
f = CompilerM op s [Char] -> CompilerM op s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (CompilerM op s [Char] -> CompilerM op s ())
-> CompilerM op s [Char] -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ [Char]
-> HeaderSection
-> ([Char] -> (Definition, Definition))
-> CompilerM op s [Char]
forall op s.
[Char]
-> HeaderSection
-> ([Char] -> (Definition, Definition))
-> CompilerM op s [Char]
publicDef [Char]
s HeaderSection
h [Char] -> (Definition, Definition)
f
headerDecl :: HeaderSection -> C.Definition -> CompilerM op s ()
HeaderSection
sec Definition
def = (CompilerState s -> CompilerState s) -> CompilerM op s ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CompilerState s -> CompilerState s) -> CompilerM op s ())
-> (CompilerState s -> CompilerState s) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \CompilerState s
s ->
CompilerState s
s
{ compHeaderDecls :: Map HeaderSection (DList Definition)
compHeaderDecls =
(DList Definition -> DList Definition -> DList Definition)
-> Map HeaderSection (DList Definition)
-> Map HeaderSection (DList Definition)
-> Map HeaderSection (DList Definition)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith
DList Definition -> DList Definition -> DList Definition
forall a. Semigroup a => a -> a -> a
(<>)
(CompilerState s -> Map HeaderSection (DList Definition)
forall s. CompilerState s -> Map HeaderSection (DList Definition)
compHeaderDecls CompilerState s
s)
(HeaderSection
-> DList Definition -> Map HeaderSection (DList Definition)
forall k a. k -> a -> Map k a
M.singleton HeaderSection
sec (Definition -> DList Definition
forall a. a -> DList a
DL.singleton Definition
def))
}
libDecl :: C.Definition -> CompilerM op s ()
libDecl :: forall op s. Definition -> CompilerM op s ()
libDecl Definition
def = (CompilerState s -> CompilerState s) -> CompilerM op s ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CompilerState s -> CompilerState s) -> CompilerM op s ())
-> (CompilerState s -> CompilerState s) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \CompilerState s
s ->
CompilerState s
s {compLibDecls :: DList Definition
compLibDecls = CompilerState s -> DList Definition
forall s. CompilerState s -> DList Definition
compLibDecls CompilerState s
s DList Definition -> DList Definition -> DList Definition
forall a. Semigroup a => a -> a -> a
<> Definition -> DList Definition
forall a. a -> DList a
DL.singleton Definition
def}
earlyDecl :: C.Definition -> CompilerM op s ()
earlyDecl :: forall op s. Definition -> CompilerM op s ()
earlyDecl Definition
def = (CompilerState s -> CompilerState s) -> CompilerM op s ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CompilerState s -> CompilerState s) -> CompilerM op s ())
-> (CompilerState s -> CompilerState s) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \CompilerState s
s ->
CompilerState s
s {compEarlyDecls :: DList Definition
compEarlyDecls = CompilerState s -> DList Definition
forall s. CompilerState s -> DList Definition
compEarlyDecls CompilerState s
s DList Definition -> DList Definition -> DList Definition
forall a. Semigroup a => a -> a -> a
<> Definition -> DList Definition
forall a. a -> DList a
DL.singleton Definition
def}
contextField :: C.Id -> C.Type -> Maybe C.Exp -> CompilerM op s ()
contextField :: forall op s. Id -> Type -> Maybe Exp -> CompilerM op s ()
contextField Id
name Type
ty Maybe Exp
initial = (CompilerState s -> CompilerState s) -> CompilerM op s ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CompilerState s -> CompilerState s) -> CompilerM op s ())
-> (CompilerState s -> CompilerState s) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \CompilerState s
s ->
CompilerState s
s {compCtxFields :: DList (Id, Type, Maybe Exp, Maybe Stm)
compCtxFields = CompilerState s -> DList (Id, Type, Maybe Exp, Maybe Stm)
forall s. CompilerState s -> DList (Id, Type, Maybe Exp, Maybe Stm)
compCtxFields CompilerState s
s DList (Id, Type, Maybe Exp, Maybe Stm)
-> DList (Id, Type, Maybe Exp, Maybe Stm)
-> DList (Id, Type, Maybe Exp, Maybe Stm)
forall a. Semigroup a => a -> a -> a
<> (Id, Type, Maybe Exp, Maybe Stm)
-> DList (Id, Type, Maybe Exp, Maybe Stm)
forall a. a -> DList a
DL.singleton (Id
name, Type
ty, Maybe Exp
initial, Maybe Stm
forall a. Maybe a
Nothing)}
contextFieldDyn :: C.Id -> C.Type -> Maybe C.Exp -> C.Stm -> CompilerM op s ()
contextFieldDyn :: forall op s. Id -> Type -> Maybe Exp -> Stm -> CompilerM op s ()
contextFieldDyn Id
name Type
ty Maybe Exp
initial Stm
free = (CompilerState s -> CompilerState s) -> CompilerM op s ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CompilerState s -> CompilerState s) -> CompilerM op s ())
-> (CompilerState s -> CompilerState s) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \CompilerState s
s ->
CompilerState s
s {compCtxFields :: DList (Id, Type, Maybe Exp, Maybe Stm)
compCtxFields = CompilerState s -> DList (Id, Type, Maybe Exp, Maybe Stm)
forall s. CompilerState s -> DList (Id, Type, Maybe Exp, Maybe Stm)
compCtxFields CompilerState s
s DList (Id, Type, Maybe Exp, Maybe Stm)
-> DList (Id, Type, Maybe Exp, Maybe Stm)
-> DList (Id, Type, Maybe Exp, Maybe Stm)
forall a. Semigroup a => a -> a -> a
<> (Id, Type, Maybe Exp, Maybe Stm)
-> DList (Id, Type, Maybe Exp, Maybe Stm)
forall a. a -> DList a
DL.singleton (Id
name, Type
ty, Maybe Exp
initial, Stm -> Maybe Stm
forall a. a -> Maybe a
Just Stm
free)}
profileReport :: C.BlockItem -> CompilerM op s ()
profileReport :: forall op s. BlockItem -> CompilerM op s ()
profileReport BlockItem
x = (CompilerState s -> CompilerState s) -> CompilerM op s ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CompilerState s -> CompilerState s) -> CompilerM op s ())
-> (CompilerState s -> CompilerState s) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \CompilerState s
s ->
CompilerState s
s {compProfileItems :: DList BlockItem
compProfileItems = CompilerState s -> DList BlockItem
forall s. CompilerState s -> DList BlockItem
compProfileItems CompilerState s
s DList BlockItem -> DList BlockItem -> DList BlockItem
forall a. Semigroup a => a -> a -> a
<> BlockItem -> DList BlockItem
forall a. a -> DList a
DL.singleton BlockItem
x}
onClear :: C.BlockItem -> CompilerM op s ()
onClear :: forall op s. BlockItem -> CompilerM op s ()
onClear BlockItem
x = (CompilerState s -> CompilerState s) -> CompilerM op s ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CompilerState s -> CompilerState s) -> CompilerM op s ())
-> (CompilerState s -> CompilerState s) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \CompilerState s
s ->
CompilerState s
s {compClearItems :: DList BlockItem
compClearItems = CompilerState s -> DList BlockItem
forall s. CompilerState s -> DList BlockItem
compClearItems CompilerState s
s DList BlockItem -> DList BlockItem -> DList BlockItem
forall a. Semigroup a => a -> a -> a
<> BlockItem -> DList BlockItem
forall a. a -> DList a
DL.singleton BlockItem
x}
stm :: C.Stm -> CompilerM op s ()
stm :: forall op s. Stm -> CompilerM op s ()
stm Stm
s = BlockItem -> CompilerM op s ()
forall op s. BlockItem -> CompilerM op s ()
item [C.citem|$stm:s|]
stms :: [C.Stm] -> CompilerM op s ()
stms :: forall op s. [Stm] -> CompilerM op s ()
stms = (Stm -> CompilerM op s ()) -> [Stm] -> CompilerM op s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Stm -> CompilerM op s ()
forall op s. Stm -> CompilerM op s ()
stm
decl :: C.InitGroup -> CompilerM op s ()
decl :: forall op s. InitGroup -> CompilerM op s ()
decl InitGroup
x = BlockItem -> CompilerM op s ()
forall op s. BlockItem -> CompilerM op s ()
item [C.citem|$decl:x;|]
publicName :: String -> CompilerM op s String
publicName :: forall op s. [Char] -> CompilerM op s [Char]
publicName [Char]
s = [Char] -> CompilerM op s [Char]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> CompilerM op s [Char])
-> [Char] -> CompilerM op s [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"futhark_" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
s
memToCType :: VName -> Space -> CompilerM op s C.Type
memToCType :: forall op s. VName -> Space -> CompilerM op s Type
memToCType VName
v Space
space = do
Bool
refcount <- Space -> CompilerM op s Bool
forall op s. Space -> CompilerM op s Bool
fatMemory Space
space
Bool
cached <- Maybe VName -> Bool
forall a. Maybe a -> Bool
isJust (Maybe VName -> Bool)
-> CompilerM op s (Maybe VName) -> CompilerM op s Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VName -> CompilerM op s (Maybe VName)
forall a op s. ToExp a => a -> CompilerM op s (Maybe VName)
cacheMem VName
v
if Bool
refcount Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
cached
then Type -> CompilerM op s Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> CompilerM op s Type) -> Type -> CompilerM op s Type
forall a b. (a -> b) -> a -> b
$ Space -> Type
fatMemType Space
space
else Space -> CompilerM op s Type
forall op s. Space -> CompilerM op s Type
rawMemCType Space
space
rawMemCType :: Space -> CompilerM op s C.Type
rawMemCType :: forall op s. Space -> CompilerM op s Type
rawMemCType Space
DefaultSpace = Type -> CompilerM op s Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
defaultMemBlockType
rawMemCType (Space [Char]
sid) = CompilerM op s (CompilerM op s Type) -> CompilerM op s Type
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (CompilerM op s (CompilerM op s Type) -> CompilerM op s Type)
-> CompilerM op s (CompilerM op s Type) -> CompilerM op s Type
forall a b. (a -> b) -> a -> b
$ (CompilerEnv op s -> MemoryType op s)
-> CompilerM op s (MemoryType op s)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Operations op s -> MemoryType op s
forall op s. Operations op s -> MemoryType op s
opsMemoryType (Operations op s -> MemoryType op s)
-> (CompilerEnv op s -> Operations op s)
-> CompilerEnv op s
-> MemoryType op s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerEnv op s -> Operations op s
forall op s. CompilerEnv op s -> Operations op s
envOperations) CompilerM op s (MemoryType op s)
-> CompilerM op s [Char] -> CompilerM op s (CompilerM op s Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> CompilerM op s [Char]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
sid
rawMemCType (ScalarSpace [] PrimType
t) =
Type -> CompilerM op s Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cty|$ty:(primTypeToCType t)[1]|]
rawMemCType (ScalarSpace [SubExp]
ds PrimType
t) =
Type -> CompilerM op s Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cty|$ty:(primTypeToCType t)[$exp:(cproduct ds')]|]
where
ds' :: [Exp]
ds' = (SubExp -> Exp) -> [SubExp] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (SubExp -> SrcLoc -> Exp
forall a. ToExp a => a -> SrcLoc -> Exp
`C.toExp` SrcLoc
forall a. IsLocation a => a
noLoc) [SubExp]
ds
fatMemType :: Space -> C.Type
fatMemType :: Space -> Type
fatMemType Space
space =
[C.cty|struct $id:name|]
where
name :: [Char]
name = case Space
space of
Space [Char]
sid -> [Char]
"memblock_" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
sid
Space
_ -> [Char]
"memblock"
fatMemSet :: Space -> String
fatMemSet :: Space -> [Char]
fatMemSet (Space [Char]
sid) = [Char]
"memblock_set_" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
sid
fatMemSet Space
_ = [Char]
"memblock_set"
fatMemAlloc :: Space -> String
fatMemAlloc :: Space -> [Char]
fatMemAlloc (Space [Char]
sid) = [Char]
"memblock_alloc_" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
sid
fatMemAlloc Space
_ = [Char]
"memblock_alloc"
fatMemUnRef :: Space -> String
fatMemUnRef :: Space -> [Char]
fatMemUnRef (Space [Char]
sid) = [Char]
"memblock_unref_" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
sid
fatMemUnRef Space
_ = [Char]
"memblock_unref"
rawMem :: VName -> CompilerM op s C.Exp
rawMem :: forall op s. VName -> CompilerM op s Exp
rawMem VName
v = Bool -> VName -> Exp
forall a. ToExp a => Bool -> a -> Exp
rawMem' (Bool -> VName -> Exp)
-> CompilerM op s Bool -> CompilerM op s (VName -> Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CompilerM op s Bool
forall {op} {s}. CompilerM op s Bool
fat CompilerM op s (VName -> Exp)
-> CompilerM op s VName -> CompilerM op s Exp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> VName -> CompilerM op s VName
forall (f :: * -> *) a. Applicative f => a -> f a
pure VName
v
where
fat :: CompilerM op s Bool
fat = (CompilerEnv op s -> Bool -> Bool) -> CompilerM op s (Bool -> Bool)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> (CompilerEnv op s -> Bool) -> CompilerEnv op s -> Bool -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Operations op s -> Bool
forall op s. Operations op s -> Bool
opsFatMemory (Operations op s -> Bool)
-> (CompilerEnv op s -> Operations op s)
-> CompilerEnv op s
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerEnv op s -> Operations op s
forall op s. CompilerEnv op s -> Operations op s
envOperations) CompilerM op s (Bool -> Bool)
-> CompilerM op s Bool -> CompilerM op s Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Maybe VName -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe VName -> Bool)
-> CompilerM op s (Maybe VName) -> CompilerM op s Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VName -> CompilerM op s (Maybe VName)
forall a op s. ToExp a => a -> CompilerM op s (Maybe VName)
cacheMem VName
v)
rawMem' :: C.ToExp a => Bool -> a -> C.Exp
rawMem' :: forall a. ToExp a => Bool -> a -> Exp
rawMem' Bool
True a
e = [C.cexp|$exp:e.mem|]
rawMem' Bool
False a
e = [C.cexp|$exp:e|]
allocRawMem ::
(C.ToExp a, C.ToExp b, C.ToExp c) =>
a ->
b ->
Space ->
c ->
CompilerM op s ()
allocRawMem :: forall a b c op s.
(ToExp a, ToExp b, ToExp c) =>
a -> b -> Space -> c -> CompilerM op s ()
allocRawMem a
dest b
size Space
space c
desc = case Space
space of
Space [Char]
sid ->
CompilerM op s (CompilerM op s ()) -> CompilerM op s ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (CompilerM op s (CompilerM op s ()) -> CompilerM op s ())
-> CompilerM op s (CompilerM op s ()) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$
(CompilerEnv op s -> Allocate op s)
-> CompilerM op s (Allocate op s)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Operations op s -> Allocate op s
forall op s. Operations op s -> Allocate op s
opsAllocate (Operations op s -> Allocate op s)
-> (CompilerEnv op s -> Operations op s)
-> CompilerEnv op s
-> Allocate op s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerEnv op s -> Operations op s
forall op s. CompilerEnv op s -> Operations op s
envOperations)
CompilerM op s (Allocate op s)
-> CompilerM op s Exp
-> CompilerM op s (Exp -> Exp -> [Char] -> CompilerM op s ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> CompilerM op s Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cexp|$exp:dest|]
CompilerM op s (Exp -> Exp -> [Char] -> CompilerM op s ())
-> CompilerM op s Exp
-> CompilerM op s (Exp -> [Char] -> CompilerM op s ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> CompilerM op s Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cexp|$exp:size|]
CompilerM op s (Exp -> [Char] -> CompilerM op s ())
-> CompilerM op s Exp
-> CompilerM op s ([Char] -> CompilerM op s ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> CompilerM op s Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cexp|$exp:desc|]
CompilerM op s ([Char] -> CompilerM op s ())
-> CompilerM op s [Char] -> CompilerM op s (CompilerM op s ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> CompilerM op s [Char]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
sid
Space
_ ->
Stm -> CompilerM op s ()
forall op s. Stm -> CompilerM op s ()
stm [C.cstm|$exp:dest = (unsigned char*) malloc((size_t)$exp:size);|]
freeRawMem ::
(C.ToExp a, C.ToExp b) =>
a ->
Space ->
b ->
CompilerM op s ()
freeRawMem :: forall a b op s.
(ToExp a, ToExp b) =>
a -> Space -> b -> CompilerM op s ()
freeRawMem a
mem Space
space b
desc =
case Space
space of
Space [Char]
sid -> do
Deallocate op s
free_mem <- (CompilerEnv op s -> Deallocate op s)
-> CompilerM op s (Deallocate op s)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Operations op s -> Deallocate op s
forall op s. Operations op s -> Deallocate op s
opsDeallocate (Operations op s -> Deallocate op s)
-> (CompilerEnv op s -> Operations op s)
-> CompilerEnv op s
-> Deallocate op s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerEnv op s -> Operations op s
forall op s. CompilerEnv op s -> Operations op s
envOperations)
Deallocate op s
free_mem [C.cexp|$exp:mem|] [C.cexp|$exp:desc|] [Char]
sid
Space
_ -> BlockItem -> CompilerM op s ()
forall op s. BlockItem -> CompilerM op s ()
item [C.citem|free($exp:mem);|]
declMem :: VName -> Space -> CompilerM op s ()
declMem :: forall op s. VName -> Space -> CompilerM op s ()
declMem VName
name Space
space = do
Bool
cached <- Maybe VName -> Bool
forall a. Maybe a -> Bool
isJust (Maybe VName -> Bool)
-> CompilerM op s (Maybe VName) -> CompilerM op s Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VName -> CompilerM op s (Maybe VName)
forall a op s. ToExp a => a -> CompilerM op s (Maybe VName)
cacheMem VName
name
Bool
fat <- Space -> CompilerM op s Bool
forall op s. Space -> CompilerM op s Bool
fatMemory Space
space
Bool -> CompilerM op s () -> CompilerM op s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
cached (CompilerM op s () -> CompilerM op s ())
-> CompilerM op s () -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$
if Bool
fat
then (CompilerState s -> CompilerState s) -> CompilerM op s ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CompilerState s -> CompilerState s) -> CompilerM op s ())
-> (CompilerState s -> CompilerState s) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \CompilerState s
s -> CompilerState s
s {compDeclaredMem :: [(VName, Space)]
compDeclaredMem = (VName
name, Space
space) (VName, Space) -> [(VName, Space)] -> [(VName, Space)]
forall a. a -> [a] -> [a]
: CompilerState s -> [(VName, Space)]
forall s. CompilerState s -> [(VName, Space)]
compDeclaredMem CompilerState s
s}
else do
Type
ty <- VName -> Space -> CompilerM op s Type
forall op s. VName -> Space -> CompilerM op s Type
memToCType VName
name Space
space
InitGroup -> CompilerM op s ()
forall op s. InitGroup -> CompilerM op s ()
decl [C.cdecl|$ty:ty $id:name;|]
resetMem :: C.ToExp a => a -> Space -> CompilerM op s ()
resetMem :: forall a op s. ToExp a => a -> Space -> CompilerM op s ()
resetMem a
mem Space
space = do
Bool
refcount <- Space -> CompilerM op s Bool
forall op s. Space -> CompilerM op s Bool
fatMemory Space
space
Bool
cached <- Maybe VName -> Bool
forall a. Maybe a -> Bool
isJust (Maybe VName -> Bool)
-> CompilerM op s (Maybe VName) -> CompilerM op s Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> CompilerM op s (Maybe VName)
forall a op s. ToExp a => a -> CompilerM op s (Maybe VName)
cacheMem a
mem
if Bool
cached
then Stm -> CompilerM op s ()
forall op s. Stm -> CompilerM op s ()
stm [C.cstm|$exp:mem = NULL;|]
else
Bool -> CompilerM op s () -> CompilerM op s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
refcount (CompilerM op s () -> CompilerM op s ())
-> CompilerM op s () -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$
Stm -> CompilerM op s ()
forall op s. Stm -> CompilerM op s ()
stm [C.cstm|$exp:mem.references = NULL;|]
setMem :: (C.ToExp a, C.ToExp b) => a -> b -> Space -> CompilerM op s ()
setMem :: forall a b op s.
(ToExp a, ToExp b) =>
a -> b -> Space -> CompilerM op s ()
setMem a
dest b
src Space
space = do
Bool
refcount <- Space -> CompilerM op s Bool
forall op s. Space -> CompilerM op s Bool
fatMemory Space
space
let src_s :: [Char]
src_s = Exp -> [Char]
forall a. Pretty a => a -> [Char]
pretty (Exp -> [Char]) -> Exp -> [Char]
forall a b. (a -> b) -> a -> b
$ b -> SrcLoc -> Exp
forall a. ToExp a => a -> SrcLoc -> Exp
C.toExp b
src SrcLoc
forall a. IsLocation a => a
noLoc
if Bool
refcount
then
Stm -> CompilerM op s ()
forall op s. Stm -> CompilerM op s ()
stm
[C.cstm|if ($id:(fatMemSet space)(ctx, &$exp:dest, &$exp:src,
$string:src_s) != 0) {
return 1;
}|]
else case Space
space of
ScalarSpace [SubExp]
ds PrimType
_ -> do
VName
i' <- [Char] -> CompilerM op s VName
forall (m :: * -> *). MonadFreshNames m => [Char] -> m VName
newVName [Char]
"i"
let i :: SrcLoc -> Id
i = VName -> SrcLoc -> Id
forall a. ToIdent a => a -> SrcLoc -> Id
C.toIdent VName
i'
it :: Type
it = PrimType -> Type
primTypeToCType (PrimType -> Type) -> PrimType -> Type
forall a b. (a -> b) -> a -> b
$ IntType -> PrimType
IntType IntType
Int32
ds' :: [Exp]
ds' = (SubExp -> Exp) -> [SubExp] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (SubExp -> SrcLoc -> Exp
forall a. ToExp a => a -> SrcLoc -> Exp
`C.toExp` SrcLoc
forall a. IsLocation a => a
noLoc) [SubExp]
ds
bound :: Exp
bound = [Exp] -> Exp
cproduct [Exp]
ds'
Stm -> CompilerM op s ()
forall op s. Stm -> CompilerM op s ()
stm
[C.cstm|for ($ty:it $id:i = 0; $id:i < $exp:bound; $id:i++) {
$exp:dest[$id:i] = $exp:src[$id:i];
}|]
Space
_ -> Stm -> CompilerM op s ()
forall op s. Stm -> CompilerM op s ()
stm [C.cstm|$exp:dest = $exp:src;|]
unRefMem :: C.ToExp a => a -> Space -> CompilerM op s ()
unRefMem :: forall a op s. ToExp a => a -> Space -> CompilerM op s ()
unRefMem a
mem Space
space = do
Bool
refcount <- Space -> CompilerM op s Bool
forall op s. Space -> CompilerM op s Bool
fatMemory Space
space
Bool
cached <- Maybe VName -> Bool
forall a. Maybe a -> Bool
isJust (Maybe VName -> Bool)
-> CompilerM op s (Maybe VName) -> CompilerM op s Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> CompilerM op s (Maybe VName)
forall a op s. ToExp a => a -> CompilerM op s (Maybe VName)
cacheMem a
mem
let mem_s :: [Char]
mem_s = Exp -> [Char]
forall a. Pretty a => a -> [Char]
pretty (Exp -> [Char]) -> Exp -> [Char]
forall a b. (a -> b) -> a -> b
$ a -> SrcLoc -> Exp
forall a. ToExp a => a -> SrcLoc -> Exp
C.toExp a
mem SrcLoc
forall a. IsLocation a => a
noLoc
Bool -> CompilerM op s () -> CompilerM op s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
refcount Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
cached) (CompilerM op s () -> CompilerM op s ())
-> CompilerM op s () -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$
Stm -> CompilerM op s ()
forall op s. Stm -> CompilerM op s ()
stm
[C.cstm|if ($id:(fatMemUnRef space)(ctx, &$exp:mem, $string:mem_s) != 0) {
return 1;
}|]
allocMem ::
(C.ToExp a, C.ToExp b) =>
a ->
b ->
Space ->
C.Stm ->
CompilerM op s ()
allocMem :: forall a b op s.
(ToExp a, ToExp b) =>
a -> b -> Space -> Stm -> CompilerM op s ()
allocMem a
mem b
size Space
space Stm
on_failure = do
Bool
refcount <- Space -> CompilerM op s Bool
forall op s. Space -> CompilerM op s Bool
fatMemory Space
space
let mem_s :: [Char]
mem_s = Exp -> [Char]
forall a. Pretty a => a -> [Char]
pretty (Exp -> [Char]) -> Exp -> [Char]
forall a b. (a -> b) -> a -> b
$ a -> SrcLoc -> Exp
forall a. ToExp a => a -> SrcLoc -> Exp
C.toExp a
mem SrcLoc
forall a. IsLocation a => a
noLoc
if Bool
refcount
then
Stm -> CompilerM op s ()
forall op s. Stm -> CompilerM op s ()
stm
[C.cstm|if ($id:(fatMemAlloc space)(ctx, &$exp:mem, $exp:size,
$string:mem_s)) {
$stm:on_failure
}|]
else do
a -> Space -> [Char] -> CompilerM op s ()
forall a b op s.
(ToExp a, ToExp b) =>
a -> Space -> b -> CompilerM op s ()
freeRawMem a
mem Space
space [Char]
mem_s
a -> b -> Space -> Exp -> CompilerM op s ()
forall a b c op s.
(ToExp a, ToExp b, ToExp c) =>
a -> b -> Space -> c -> CompilerM op s ()
allocRawMem a
mem b
size Space
space [C.cexp|desc|]
copyMemoryDefaultSpace ::
C.Exp ->
C.Exp ->
C.Exp ->
C.Exp ->
C.Exp ->
CompilerM op s ()
copyMemoryDefaultSpace :: forall op s. Exp -> Exp -> Exp -> Exp -> Exp -> CompilerM op s ()
copyMemoryDefaultSpace Exp
destmem Exp
destidx Exp
srcmem Exp
srcidx Exp
nbytes =
Stm -> CompilerM op s ()
forall op s. Stm -> CompilerM op s ()
stm
[C.cstm|if ($exp:nbytes > 0) {
memmove($exp:destmem + $exp:destidx,
$exp:srcmem + $exp:srcidx,
$exp:nbytes);
}|]
cachingMemory ::
M.Map VName Space ->
([C.BlockItem] -> [C.Stm] -> CompilerM op s a) ->
CompilerM op s a
cachingMemory :: forall op s a.
Map VName Space
-> ([BlockItem] -> [Stm] -> CompilerM op s a) -> CompilerM op s a
cachingMemory Map VName Space
lexical [BlockItem] -> [Stm] -> CompilerM op s a
f = do
let cached :: [VName]
cached = Map VName Space -> [VName]
forall k a. Map k a -> [k]
M.keys (Map VName Space -> [VName]) -> Map VName Space -> [VName]
forall a b. (a -> b) -> a -> b
$ (Space -> Bool) -> Map VName Space -> Map VName Space
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Space -> Space -> Bool
forall a. Eq a => a -> a -> Bool
== Space
DefaultSpace) Map VName Space
lexical
[(VName, VName)]
cached' <- [VName]
-> (VName -> CompilerM op s (VName, VName))
-> CompilerM op s [(VName, VName)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [VName]
cached ((VName -> CompilerM op s (VName, VName))
-> CompilerM op s [(VName, VName)])
-> (VName -> CompilerM op s (VName, VName))
-> CompilerM op s [(VName, VName)]
forall a b. (a -> b) -> a -> b
$ \VName
mem -> do
VName
size <- [Char] -> CompilerM op s VName
forall (m :: * -> *). MonadFreshNames m => [Char] -> m VName
newVName ([Char] -> CompilerM op s VName) -> [Char] -> CompilerM op s VName
forall a b. (a -> b) -> a -> b
$ VName -> [Char]
forall a. Pretty a => a -> [Char]
pretty VName
mem [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"_cached_size"
(VName, VName) -> CompilerM op s (VName, VName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VName
mem, VName
size)
let lexMem :: CompilerEnv op s -> CompilerEnv op s
lexMem CompilerEnv op s
env =
CompilerEnv op s
env
{ envCachedMem :: Map Exp VName
envCachedMem =
[(Exp, VName)] -> Map Exp VName
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (((VName, VName) -> (Exp, VName))
-> [(VName, VName)] -> [(Exp, VName)]
forall a b. (a -> b) -> [a] -> [b]
map ((VName -> Exp) -> (VName, VName) -> (Exp, VName)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (VName -> SrcLoc -> Exp
forall a. ToExp a => a -> SrcLoc -> Exp
`C.toExp` SrcLoc
forall a. IsLocation a => a
noLoc)) [(VName, VName)]
cached')
Map Exp VName -> Map Exp VName -> Map Exp VName
forall a. Semigroup a => a -> a -> a
<> CompilerEnv op s -> Map Exp VName
forall op s. CompilerEnv op s -> Map Exp VName
envCachedMem CompilerEnv op s
env
}
declCached :: (a, a) -> [BlockItem]
declCached (a
mem, a
size) =
[ [C.citem|typename int64_t $id:size = 0;|],
[C.citem|$ty:defaultMemBlockType $id:mem = NULL;|]
]
freeCached :: (a, b) -> Stm
freeCached (a
mem, b
_) =
[C.cstm|free($id:mem);|]
(CompilerEnv op s -> CompilerEnv op s)
-> CompilerM op s a -> CompilerM op s a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local CompilerEnv op s -> CompilerEnv op s
forall {op} {s}. CompilerEnv op s -> CompilerEnv op s
lexMem (CompilerM op s a -> CompilerM op s a)
-> CompilerM op s a -> CompilerM op s a
forall a b. (a -> b) -> a -> b
$ [BlockItem] -> [Stm] -> CompilerM op s a
f (((VName, VName) -> [BlockItem]) -> [(VName, VName)] -> [BlockItem]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (VName, VName) -> [BlockItem]
forall {a} {a}. (ToIdent a, ToIdent a) => (a, a) -> [BlockItem]
declCached [(VName, VName)]
cached') (((VName, VName) -> Stm) -> [(VName, VName)] -> [Stm]
forall a b. (a -> b) -> [a] -> [b]
map (VName, VName) -> Stm
forall {a} {b}. ToIdent a => (a, b) -> Stm
freeCached [(VName, VName)]
cached')
derefPointer :: C.Exp -> C.Exp -> C.Type -> C.Exp
derefPointer :: Exp -> Exp -> Type -> Exp
derefPointer Exp
ptr Exp
i Type
res_t =
[C.cexp|(($ty:res_t)$exp:ptr)[$exp:i]|]
volQuals :: Volatility -> [C.TypeQual]
volQuals :: Volatility -> [TypeQual]
volQuals Volatility
Volatile = [C.ctyquals|volatile|]
volQuals Volatility
Nonvolatile = []
writeScalarPointerWithQuals :: PointerQuals op s -> WriteScalar op s
writeScalarPointerWithQuals :: forall op s. PointerQuals op s -> WriteScalar op s
writeScalarPointerWithQuals PointerQuals op s
quals_f Exp
dest Exp
i Type
elemtype [Char]
space Volatility
vol Exp
v = do
[TypeQual]
quals <- PointerQuals op s
quals_f [Char]
space
let quals' :: [TypeQual]
quals' = Volatility -> [TypeQual]
volQuals Volatility
vol [TypeQual] -> [TypeQual] -> [TypeQual]
forall a. [a] -> [a] -> [a]
++ [TypeQual]
quals
deref :: Exp
deref =
Exp -> Exp -> Type -> Exp
derefPointer
Exp
dest
Exp
i
[C.cty|$tyquals:quals' $ty:elemtype*|]
Stm -> CompilerM op s ()
forall op s. Stm -> CompilerM op s ()
stm [C.cstm|$exp:deref = $exp:v;|]
readScalarPointerWithQuals :: PointerQuals op s -> ReadScalar op s
readScalarPointerWithQuals :: forall op s. PointerQuals op s -> ReadScalar op s
readScalarPointerWithQuals PointerQuals op s
quals_f Exp
dest Exp
i Type
elemtype [Char]
space Volatility
vol = do
[TypeQual]
quals <- PointerQuals op s
quals_f [Char]
space
let quals' :: [TypeQual]
quals' = Volatility -> [TypeQual]
volQuals Volatility
vol [TypeQual] -> [TypeQual] -> [TypeQual]
forall a. [a] -> [a] -> [a]
++ [TypeQual]
quals
Exp -> CompilerM op s Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> CompilerM op s Exp) -> Exp -> CompilerM op s Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Type -> Exp
derefPointer Exp
dest Exp
i [C.cty|$tyquals:quals' $ty:elemtype*|]
criticalSection :: Operations op s -> [C.BlockItem] -> [C.BlockItem]
criticalSection :: forall op s. Operations op s -> [BlockItem] -> [BlockItem]
criticalSection Operations op s
ops [BlockItem]
x =
[C.citems|lock_lock(&ctx->lock);
$items:(fst (opsCritical ops))
$items:x
$items:(snd (opsCritical ops))
lock_unlock(&ctx->lock);
|]
contextType :: CompilerM op s C.Type
contextType :: forall op s. CompilerM op s Type
contextType = do
[Char]
name <- [Char] -> CompilerM op s [Char]
forall op s. [Char] -> CompilerM op s [Char]
publicName [Char]
"context"
Type -> CompilerM op s Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cty|struct $id:name|]
configType :: CompilerM op s C.Type
configType :: forall op s. CompilerM op s Type
configType = do
[Char]
name <- [Char] -> CompilerM op s [Char]
forall op s. [Char] -> CompilerM op s [Char]
publicName [Char]
"context_config"
Type -> CompilerM op s Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cty|struct $id:name|]