{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, LambdaCase #-}
{-# LANGUAGE TupleSections #-}
module Futhark.CodeGen.Backends.GenericCSharp
( compileProg
, Constructor (..)
, emptyConstructor
, assignScalarPointer
, toIntPtr
, compileName
, compileVar
, compileDim
, compileExp
, compileCode
, compilePrimValue
, compilePrimType
, compilePrimTypeExt
, compilePrimTypeToAST
, compilePrimTypeToASText
, contextFinalInits
, debugReport
, Operations (..)
, defaultOperations
, unpackDim
, CompilerM (..)
, OpCompiler
, WriteScalar
, ReadScalar
, Allocate
, Copy
, StaticArray
, EntryOutput
, EntryInput
, CompilerEnv(..)
, CompilerState(..)
, CompilerAcc
, stm
, stms
, atInit
, staticMemDecl
, staticMemAlloc
, addMemberDecl
, beforeParse
, collect'
, collect
, simpleCall
, callMethod
, simpleInitClass
, copyMemoryDefaultSpace
, consoleErrorWrite
, consoleErrorWriteLine
, publicName
, sizeOf
, privateFunDef
, getDefaultDecl
) where
import Control.Monad.Identity
import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.RWS
import Control.Arrow((&&&))
import Data.Maybe
import qualified Data.Map as M
import Futhark.IR.Primitive hiding (Bool)
import Futhark.MonadFreshNames
import Futhark.IR.Syntax (Space(..))
import qualified Futhark.CodeGen.ImpCode as Imp
import Futhark.CodeGen.Backends.GenericCSharp.AST
import Futhark.CodeGen.Backends.GenericCSharp.Options
import Futhark.CodeGen.Backends.GenericCSharp.Definitions
import Futhark.Util (zEncodeString)
type OpCompiler op s = op -> CompilerM op s ()
type WriteScalar op s = CSExp -> CSExp -> PrimType -> Imp.SpaceId -> CSExp
-> CompilerM op s ()
type ReadScalar op s = CSExp -> CSExp -> PrimType -> Imp.SpaceId
-> CompilerM op s CSExp
type Allocate op s = CSExp -> CSExp -> Imp.SpaceId
-> CompilerM op s ()
type Copy op s = CSExp -> CSExp -> Imp.Space ->
CSExp -> CSExp -> Imp.Space ->
CSExp -> PrimType ->
CompilerM op s ()
type StaticArray op s = VName -> Imp.SpaceId -> PrimType -> Imp.ArrayContents -> CompilerM op s ()
type EntryOutput op s = CSExp -> Imp.SpaceId ->
PrimType -> Imp.Signedness ->
[Imp.DimSize] ->
CompilerM op s CSExp
type EntryInput op s = VName -> Imp.SpaceId ->
PrimType -> Imp.Signedness ->
[Imp.DimSize] ->
CSExp ->
CompilerM op s ()
data Operations op s = Operations { Operations op s -> WriteScalar op s
opsWriteScalar :: WriteScalar op s
, Operations op s -> ReadScalar op s
opsReadScalar :: ReadScalar op s
, Operations op s -> Allocate op s
opsAllocate :: Allocate op s
, Operations op s -> Copy op s
opsCopy :: Copy op s
, Operations op s -> StaticArray op s
opsStaticArray :: StaticArray op s
, Operations op s -> OpCompiler op s
opsCompiler :: OpCompiler op s
, Operations op s -> EntryOutput op s
opsEntryOutput :: EntryOutput op s
, Operations op s -> EntryInput op s
opsEntryInput :: EntryInput op s
, Operations op s -> CSStmt
opsSyncRun :: CSStmt
}
defaultOperations :: Operations op s
defaultOperations :: Operations op s
defaultOperations = Operations :: forall op s.
WriteScalar op s
-> ReadScalar op s
-> Allocate op s
-> Copy op s
-> StaticArray op s
-> OpCompiler op s
-> EntryOutput op s
-> EntryInput op s
-> CSStmt
-> Operations op s
Operations { opsWriteScalar :: WriteScalar op s
opsWriteScalar = WriteScalar op s
forall p p p p p a. p -> p -> p -> p -> p -> a
defWriteScalar
, opsReadScalar :: ReadScalar op s
opsReadScalar = ReadScalar op s
forall p p p p a. p -> p -> p -> p -> a
defReadScalar
, opsAllocate :: Allocate op s
opsAllocate = Allocate op s
forall p p p a. p -> p -> p -> a
defAllocate
, opsCopy :: Copy op s
opsCopy = Copy op s
forall p p p p p p p p a. p -> p -> p -> p -> p -> p -> p -> p -> a
defCopy
, opsStaticArray :: StaticArray op s
opsStaticArray = StaticArray op s
forall p p p p a. p -> p -> p -> p -> a
defStaticArray
, opsCompiler :: OpCompiler op s
opsCompiler = OpCompiler op s
forall p a. p -> a
defCompiler
, opsEntryOutput :: EntryOutput op s
opsEntryOutput = EntryOutput op s
forall p p p p a. p -> p -> p -> p -> a
defEntryOutput
, opsEntryInput :: EntryInput op s
opsEntryInput = EntryInput op s
forall p p p p a. p -> p -> p -> p -> a
defEntryInput
, opsSyncRun :: CSStmt
opsSyncRun = CSStmt
defSyncRun
}
where defWriteScalar :: p -> p -> p -> p -> p -> a
defWriteScalar p
_ p
_ p
_ p
_ p
_ =
[Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot write to non-default memory space because I am dumb"
defReadScalar :: p -> p -> p -> p -> a
defReadScalar p
_ p
_ p
_ p
_ =
[Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot read from non-default memory space"
defAllocate :: p -> p -> p -> a
defAllocate p
_ p
_ p
_ =
[Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot allocate in non-default memory space"
defCopy :: p -> p -> p -> p -> p -> p -> p -> p -> a
defCopy p
_ p
_ p
_ p
_ p
_ p
_ p
_ p
_ =
[Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot copy to or from non-default memory space"
defStaticArray :: p -> p -> p -> p -> a
defStaticArray p
_ p
_ p
_ p
_ =
[Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot create static array in non-default memory space"
defCompiler :: p -> a
defCompiler p
_ =
[Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"The default compiler cannot compile extended operations"
defEntryOutput :: p -> p -> p -> p -> a
defEntryOutput p
_ p
_ p
_ p
_ =
[Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot return array not in default memory space"
defEntryInput :: p -> p -> p -> p -> a
defEntryInput p
_ p
_ p
_ p
_ =
[Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot accept array not in default memory space"
defSyncRun :: CSStmt
defSyncRun =
CSStmt
Pass
data CompilerEnv op s = CompilerEnv
{ CompilerEnv op s -> Operations op s
envOperations :: Operations op s
, CompilerEnv op s -> Map VName CSExp
envVarExp :: M.Map VName CSExp
}
data CompilerAcc op s = CompilerAcc {
CompilerAcc op s -> [CSStmt]
accItems :: [CSStmt]
, CompilerAcc op s -> [VName]
accFreedMem :: [VName]
}
instance Semigroup (CompilerAcc op s) where
CompilerAcc [CSStmt]
items1 [VName]
freed1 <> :: CompilerAcc op s -> CompilerAcc op s -> CompilerAcc op s
<> CompilerAcc [CSStmt]
items2 [VName]
freed2 =
[CSStmt] -> [VName] -> CompilerAcc op s
forall op s. [CSStmt] -> [VName] -> CompilerAcc op s
CompilerAcc ([CSStmt]
items1[CSStmt] -> [CSStmt] -> [CSStmt]
forall a. Semigroup a => a -> a -> a
<>[CSStmt]
items2) ([VName]
freed1[VName] -> [VName] -> [VName]
forall a. Semigroup a => a -> a -> a
<>[VName]
freed2)
instance Monoid (CompilerAcc op s) where
mempty :: CompilerAcc op s
mempty = [CSStmt] -> [VName] -> CompilerAcc op s
forall op s. [CSStmt] -> [VName] -> CompilerAcc op s
CompilerAcc [CSStmt]
forall a. Monoid a => a
mempty [VName]
forall a. Monoid a => a
mempty
envOpCompiler :: CompilerEnv op s -> OpCompiler op s
envOpCompiler :: CompilerEnv op s -> OpCompiler op s
envOpCompiler = Operations op s -> OpCompiler op s
forall op s. Operations op s -> OpCompiler op s
opsCompiler (Operations op s -> OpCompiler op s)
-> (CompilerEnv op s -> Operations op s)
-> CompilerEnv op s
-> OpCompiler 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
envReadScalar :: CompilerEnv op s -> ReadScalar op s
envReadScalar :: CompilerEnv op s -> ReadScalar op s
envReadScalar = Operations op s -> ReadScalar op s
forall op s. Operations op s -> ReadScalar op s
opsReadScalar (Operations op s -> ReadScalar op s)
-> (CompilerEnv op s -> Operations op s)
-> CompilerEnv op s
-> ReadScalar 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
envWriteScalar :: CompilerEnv op s -> WriteScalar op s
envWriteScalar :: CompilerEnv op s -> WriteScalar op s
envWriteScalar = Operations op s -> WriteScalar op s
forall op s. Operations op s -> WriteScalar op s
opsWriteScalar (Operations op s -> WriteScalar op s)
-> (CompilerEnv op s -> Operations op s)
-> CompilerEnv op s
-> WriteScalar 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
envAllocate :: CompilerEnv op s -> Allocate op s
envAllocate :: CompilerEnv op s -> Allocate op s
envAllocate = 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
envCopy :: CompilerEnv op s -> Copy op s
envCopy :: CompilerEnv op s -> Copy op s
envCopy = Operations op s -> Copy op s
forall op s. Operations op s -> Copy op s
opsCopy (Operations op s -> Copy op s)
-> (CompilerEnv op s -> Operations op s)
-> CompilerEnv op s
-> Copy 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
envStaticArray :: CompilerEnv op s -> StaticArray op s
envStaticArray :: CompilerEnv op s -> StaticArray op s
envStaticArray = Operations op s -> StaticArray op s
forall op s. Operations op s -> StaticArray op s
opsStaticArray (Operations op s -> StaticArray op s)
-> (CompilerEnv op s -> Operations op s)
-> CompilerEnv op s
-> StaticArray 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
envEntryOutput :: CompilerEnv op s -> EntryOutput op s
envEntryOutput :: CompilerEnv op s -> EntryOutput op s
envEntryOutput = Operations op s -> EntryOutput op s
forall op s. Operations op s -> EntryOutput op s
opsEntryOutput (Operations op s -> EntryOutput op s)
-> (CompilerEnv op s -> Operations op s)
-> CompilerEnv op s
-> EntryOutput 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
envEntryInput :: CompilerEnv op s -> EntryInput op s
envEntryInput :: CompilerEnv op s -> EntryInput op s
envEntryInput = Operations op s -> EntryInput op s
forall op s. Operations op s -> EntryInput op s
opsEntryInput (Operations op s -> EntryInput op s)
-> (CompilerEnv op s -> Operations op s)
-> CompilerEnv op s
-> EntryInput 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
envSyncFun :: CompilerEnv op s -> CSStmt
envSyncFun :: CompilerEnv op s -> CSStmt
envSyncFun = Operations op s -> CSStmt
forall op s. Operations op s -> CSStmt
opsSyncRun (Operations op s -> CSStmt)
-> (CompilerEnv op s -> Operations op s)
-> CompilerEnv op s
-> CSStmt
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
newCompilerEnv :: Operations op s -> CompilerEnv op s
newCompilerEnv :: Operations op s -> CompilerEnv op s
newCompilerEnv Operations op s
ops =
CompilerEnv :: forall op s. Operations op s -> Map VName CSExp -> CompilerEnv op s
CompilerEnv { envOperations :: Operations op s
envOperations = Operations op s
ops
, envVarExp :: Map VName CSExp
envVarExp = Map VName CSExp
forall a. Monoid a => a
mempty }
data CompilerState s = CompilerState {
CompilerState s -> VNameSource
compNameSrc :: VNameSource
, CompilerState s -> [CSStmt]
compBeforeParse :: [CSStmt]
, CompilerState s -> [CSStmt]
compInit :: [CSStmt]
, CompilerState s -> [CSStmt]
compStaticMemDecls :: [CSStmt]
, CompilerState s -> [CSStmt]
compStaticMemAllocs :: [CSStmt]
, CompilerState s -> [CSStmt]
compDebugItems :: [CSStmt]
, CompilerState s -> s
compUserState :: s
, CompilerState s -> [CSStmt]
compMemberDecls :: [CSStmt]
, CompilerState s -> [VName]
compAssignedVars :: [VName]
, CompilerState s -> [(CSExp, Space)]
compDeclaredMem :: [(CSExp, Space)]
}
newCompilerState :: VNameSource -> s -> CompilerState s
newCompilerState :: VNameSource -> s -> CompilerState s
newCompilerState VNameSource
src s
s = CompilerState :: forall s.
VNameSource
-> [CSStmt]
-> [CSStmt]
-> [CSStmt]
-> [CSStmt]
-> [CSStmt]
-> s
-> [CSStmt]
-> [VName]
-> [(CSExp, Space)]
-> CompilerState s
CompilerState { compNameSrc :: VNameSource
compNameSrc = VNameSource
src
, compBeforeParse :: [CSStmt]
compBeforeParse = []
, compInit :: [CSStmt]
compInit = []
, compStaticMemDecls :: [CSStmt]
compStaticMemDecls = []
, compStaticMemAllocs :: [CSStmt]
compStaticMemAllocs = []
, compDebugItems :: [CSStmt]
compDebugItems = []
, compMemberDecls :: [CSStmt]
compMemberDecls = []
, compUserState :: s
compUserState = s
s
, compAssignedVars :: [VName]
compAssignedVars = []
, compDeclaredMem :: [(CSExp, Space)]
compDeclaredMem = []
}
newtype CompilerM op s a = CompilerM (RWS (CompilerEnv op s) (CompilerAcc op s) (CompilerState s) a)
deriving (a -> CompilerM op s b -> CompilerM op s a
(a -> b) -> CompilerM op s a -> CompilerM op s b
(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
<$ :: 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 :: (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)
a -> CompilerM op s a
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)
CompilerM op s a -> CompilerM op s b -> CompilerM op s b
CompilerM op s a -> CompilerM op s b -> CompilerM op s a
CompilerM op s (a -> b) -> CompilerM op s a -> CompilerM op s b
(a -> b -> c)
-> CompilerM op s a -> CompilerM op s b -> CompilerM op s c
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
<* :: 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
*> :: 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 :: (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
<*> :: 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 :: a -> CompilerM op s a
$cpure :: forall op s a. a -> CompilerM op s a
$cp1Applicative :: forall op s. Functor (CompilerM op s)
Applicative, Applicative (CompilerM op s)
a -> CompilerM op s a
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)
CompilerM op s a -> (a -> CompilerM op s b) -> CompilerM op s b
CompilerM op s a -> CompilerM op s b -> CompilerM op s b
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 :: a -> CompilerM op s a
$creturn :: forall op s a. a -> CompilerM op s a
>> :: 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
>>= :: 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
$cp1Monad :: forall op s. Applicative (CompilerM op s)
Monad,
MonadState (CompilerState s),
MonadReader (CompilerEnv op s),
MonadWriter (CompilerAcc 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 }
collect :: CompilerM op s () -> CompilerM op s [CSStmt]
collect :: CompilerM op s () -> CompilerM op s [CSStmt]
collect CompilerM op s ()
m = CompilerM op s ([CSStmt], CompilerAcc op s -> CompilerAcc op s)
-> CompilerM op s [CSStmt]
forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass (CompilerM op s ([CSStmt], CompilerAcc op s -> CompilerAcc op s)
-> CompilerM op s [CSStmt])
-> CompilerM op s ([CSStmt], CompilerAcc op s -> CompilerAcc op s)
-> CompilerM op s [CSStmt]
forall a b. (a -> b) -> a -> b
$ do
((), CompilerAcc op s
w) <- CompilerM op s () -> CompilerM op s ((), CompilerAcc op s)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen CompilerM op s ()
m
([CSStmt], CompilerAcc op s -> CompilerAcc op s)
-> CompilerM op s ([CSStmt], CompilerAcc op s -> CompilerAcc op s)
forall (m :: * -> *) a. Monad m => a -> m a
return (CompilerAcc op s -> [CSStmt]
forall op s. CompilerAcc op s -> [CSStmt]
accItems CompilerAcc op s
w,
CompilerAcc op s -> CompilerAcc op s -> CompilerAcc op s
forall a b. a -> b -> a
const CompilerAcc op s
w { accItems :: [CSStmt]
accItems = [CSStmt]
forall a. Monoid a => a
mempty} )
collect' :: CompilerM op s a -> CompilerM op s (a, [CSStmt])
collect' :: CompilerM op s a -> CompilerM op s (a, [CSStmt])
collect' CompilerM op s a
m = CompilerM
op s ((a, [CSStmt]), CompilerAcc op s -> CompilerAcc op s)
-> CompilerM op s (a, [CSStmt])
forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass (CompilerM
op s ((a, [CSStmt]), CompilerAcc op s -> CompilerAcc op s)
-> CompilerM op s (a, [CSStmt]))
-> CompilerM
op s ((a, [CSStmt]), CompilerAcc op s -> CompilerAcc op s)
-> CompilerM op s (a, [CSStmt])
forall a b. (a -> b) -> a -> b
$ do
(a
x, CompilerAcc op s
w) <- CompilerM op s a -> CompilerM op s (a, CompilerAcc op s)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen CompilerM op s a
m
((a, [CSStmt]), CompilerAcc op s -> CompilerAcc op s)
-> CompilerM
op s ((a, [CSStmt]), CompilerAcc op s -> CompilerAcc op s)
forall (m :: * -> *) a. Monad m => a -> m a
return ((a
x, CompilerAcc op s -> [CSStmt]
forall op s. CompilerAcc op s -> [CSStmt]
accItems CompilerAcc op s
w),
CompilerAcc op s -> CompilerAcc op s -> CompilerAcc op s
forall a b. a -> b -> a
const CompilerAcc op s
w { accItems :: [CSStmt]
accItems = [CSStmt]
forall a. Monoid a => a
mempty})
beforeParse :: CSStmt -> CompilerM op s ()
beforeParse :: CSStmt -> CompilerM op s ()
beforeParse CSStmt
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 { compBeforeParse :: [CSStmt]
compBeforeParse = CompilerState s -> [CSStmt]
forall s. CompilerState s -> [CSStmt]
compBeforeParse CompilerState s
s [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt
x] }
atInit :: CSStmt -> CompilerM op s ()
atInit :: CSStmt -> CompilerM op s ()
atInit CSStmt
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 :: [CSStmt]
compInit = CompilerState s -> [CSStmt]
forall s. CompilerState s -> [CSStmt]
compInit CompilerState s
s [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt
x] }
staticMemDecl :: CSStmt -> CompilerM op s ()
staticMemDecl :: CSStmt -> CompilerM op s ()
staticMemDecl CSStmt
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 { compStaticMemDecls :: [CSStmt]
compStaticMemDecls = CompilerState s -> [CSStmt]
forall s. CompilerState s -> [CSStmt]
compStaticMemDecls CompilerState s
s [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt
x] }
staticMemAlloc :: CSStmt -> CompilerM op s ()
staticMemAlloc :: CSStmt -> CompilerM op s ()
staticMemAlloc CSStmt
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 { compStaticMemAllocs :: [CSStmt]
compStaticMemAllocs = CompilerState s -> [CSStmt]
forall s. CompilerState s -> [CSStmt]
compStaticMemAllocs CompilerState s
s [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt
x] }
addMemberDecl :: CSStmt -> CompilerM op s ()
addMemberDecl :: CSStmt -> CompilerM op s ()
addMemberDecl CSStmt
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 { compMemberDecls :: [CSStmt]
compMemberDecls = CompilerState s -> [CSStmt]
forall s. CompilerState s -> [CSStmt]
compMemberDecls CompilerState s
s [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt
x] }
contextFinalInits :: CompilerM op s [CSStmt]
contextFinalInits :: CompilerM op s [CSStmt]
contextFinalInits = (CompilerState s -> [CSStmt]) -> CompilerM op s [CSStmt]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompilerState s -> [CSStmt]
forall s. CompilerState s -> [CSStmt]
compInit
item :: CSStmt -> CompilerM op s ()
item :: CSStmt -> CompilerM op s ()
item CSStmt
x = CompilerAcc op s -> CompilerM op s ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (CompilerAcc op s -> CompilerM op s ())
-> CompilerAcc op s -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ CompilerAcc Any Any
forall a. Monoid a => a
mempty { accItems :: [CSStmt]
accItems = [CSStmt
x] }
stm :: CSStmt -> CompilerM op s ()
stm :: CSStmt -> CompilerM op s ()
stm = CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
item
stms :: [CSStmt] -> CompilerM op s ()
stms :: [CSStmt] -> CompilerM op s ()
stms = (CSStmt -> CompilerM op s ()) -> [CSStmt] -> CompilerM op s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
stm
debugReport :: CSStmt -> CompilerM op s ()
debugReport :: CSStmt -> CompilerM op s ()
debugReport CSStmt
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 { compDebugItems :: [CSStmt]
compDebugItems = CompilerState s -> [CSStmt]
forall s. CompilerState s -> [CSStmt]
compDebugItems CompilerState s
s [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt
x] }
getVarAssigned :: VName -> CompilerM op s Bool
getVarAssigned :: VName -> CompilerM op s Bool
getVarAssigned VName
vname =
(CompilerState s -> Bool) -> CompilerM op s Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((CompilerState s -> Bool) -> CompilerM op s Bool)
-> (CompilerState s -> Bool) -> CompilerM op s Bool
forall a b. (a -> b) -> a -> b
$ VName -> [VName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem VName
vname ([VName] -> Bool)
-> (CompilerState s -> [VName]) -> CompilerState s -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerState s -> [VName]
forall s. CompilerState s -> [VName]
compAssignedVars
setVarAssigned :: VName -> CompilerM op s ()
setVarAssigned :: VName -> CompilerM op s ()
setVarAssigned VName
vname = (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 { compAssignedVars :: [VName]
compAssignedVars = VName
vname VName -> [VName] -> [VName]
forall a. a -> [a] -> [a]
: CompilerState s -> [VName]
forall s. CompilerState s -> [VName]
compAssignedVars CompilerState s
s}
futharkFun :: String -> String
futharkFun :: [Char] -> [Char]
futharkFun [Char]
s = [Char]
"futhark_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
zEncodeString [Char]
s
paramType :: Imp.Param -> Imp.Type
paramType :: Param -> Type
paramType (Imp.MemParam VName
_ Space
space) = Space -> Type
Imp.Mem Space
space
paramType (Imp.ScalarParam VName
_ PrimType
t) = PrimType -> Type
Imp.Scalar PrimType
t
compileOutput :: Imp.Param -> (CSExp, CSType)
compileOutput :: Param -> (CSExp, CSType)
compileOutput = Param -> CSExp
nameFun (Param -> CSExp) -> (Param -> CSType) -> Param -> (CSExp, CSType)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Param -> CSType
typeFun
where nameFun :: Param -> CSExp
nameFun = [Char] -> CSExp
Var ([Char] -> CSExp) -> (Param -> [Char]) -> Param -> CSExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VName -> [Char]
compileName (VName -> [Char]) -> (Param -> VName) -> Param -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Param -> VName
Imp.paramName
typeFun :: Param -> CSType
typeFun = Type -> CSType
compileType (Type -> CSType) -> (Param -> Type) -> Param -> CSType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Param -> Type
paramType
getDefaultDecl :: Imp.Param -> CSStmt
getDefaultDecl :: Param -> CSStmt
getDefaultDecl (Imp.MemParam VName
v Space
DefaultSpace) =
CSExp -> CSExp -> CSStmt
Assign ([Char] -> CSExp
Var ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ VName -> [Char]
compileName VName
v) (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"allocateMem" [Integer -> CSExp
Integer Integer
0]
getDefaultDecl (Imp.MemParam VName
v Space
_) =
CSType -> CSExp -> Maybe CSExp -> CSStmt
AssignTyped ([Char] -> CSType
CustomT [Char]
"OpenCLMemblock") ([Char] -> CSExp
Var ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ VName -> [Char]
compileName VName
v) (CSExp -> Maybe CSExp
forall a. a -> Maybe a
Just (CSExp -> Maybe CSExp) -> CSExp -> Maybe CSExp
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"EmptyMemblock" [[Char] -> CSExp
Var [Char]
"Ctx.EMPTY_MEM_HANDLE"])
getDefaultDecl (Imp.ScalarParam VName
v PrimType
Cert) =
CSExp -> CSExp -> CSStmt
Assign ([Char] -> CSExp
Var ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ VName -> [Char]
compileName VName
v) (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ Bool -> CSExp
Bool Bool
True
getDefaultDecl (Imp.ScalarParam VName
v PrimType
t) =
CSExp -> CSExp -> CSStmt
Assign ([Char] -> CSExp
Var ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ VName -> [Char]
compileName VName
v) (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleInitClass (PrimType -> [Char]
compilePrimType PrimType
t) []
runCompilerM :: Operations op s
-> VNameSource
-> s
-> CompilerM op s a
-> a
runCompilerM :: Operations op s -> VNameSource -> s -> CompilerM op s a -> a
runCompilerM Operations op s
ops VNameSource
src s
userstate (CompilerM RWS (CompilerEnv op s) (CompilerAcc op s) (CompilerState s) a
m) =
(a, CompilerAcc op s) -> a
forall a b. (a, b) -> a
fst ((a, CompilerAcc op s) -> a) -> (a, CompilerAcc op s) -> a
forall a b. (a -> b) -> a -> b
$ RWS (CompilerEnv op s) (CompilerAcc op s) (CompilerState s) a
-> CompilerEnv op s -> CompilerState s -> (a, CompilerAcc op s)
forall r w s a. RWS r w s a -> r -> s -> (a, w)
evalRWS RWS (CompilerEnv op s) (CompilerAcc op s) (CompilerState s) a
m (Operations op s -> CompilerEnv op s
forall op s. Operations op s -> CompilerEnv op s
newCompilerEnv Operations op s
ops) (VNameSource -> s -> CompilerState s
forall s. VNameSource -> s -> CompilerState s
newCompilerState VNameSource
src s
userstate)
standardOptions :: [Option]
standardOptions :: [Option]
standardOptions = [
Option :: [Char] -> Maybe Char -> OptionArgument -> [CSStmt] -> Option
Option { optionLongName :: [Char]
optionLongName = [Char]
"write-runtime-to"
, optionShortName :: Maybe Char
optionShortName = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
't'
, optionArgument :: OptionArgument
optionArgument = OptionArgument
RequiredArgument
, optionAction :: [CSStmt]
optionAction =
[
CSExp -> [CSStmt] -> [CSStmt] -> CSStmt
If ([Char] -> CSExp -> CSExp -> CSExp
BinOp [Char]
"!=" ([Char] -> CSExp
Var [Char]
"RuntimeFile") CSExp
Null)
[CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"RuntimeFile.Close" []] []
, CSExp -> CSExp -> CSStmt
Reassign ([Char] -> CSExp
Var [Char]
"RuntimeFile") (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$
[Char] -> [CSExp] -> CSExp
simpleInitClass [Char]
"FileStream" [[Char] -> CSExp
Var [Char]
"optarg", [Char] -> CSExp
Var [Char]
"FileMode.Create"]
, CSExp -> CSExp -> CSStmt
Reassign ([Char] -> CSExp
Var [Char]
"RuntimeFileWriter") (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$
[Char] -> [CSExp] -> CSExp
simpleInitClass [Char]
"StreamWriter" [[Char] -> CSExp
Var [Char]
"RuntimeFile"]
]
},
Option :: [Char] -> Maybe Char -> OptionArgument -> [CSStmt] -> Option
Option { optionLongName :: [Char]
optionLongName = [Char]
"runs"
, optionShortName :: Maybe Char
optionShortName = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'r'
, optionArgument :: OptionArgument
optionArgument = OptionArgument
RequiredArgument
, optionAction :: [CSStmt]
optionAction =
[ CSExp -> CSExp -> CSStmt
Reassign ([Char] -> CSExp
Var [Char]
"NumRuns") (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"Convert.ToInt32" [[Char] -> CSExp
Var [Char]
"optarg"]
, CSExp -> CSExp -> CSStmt
Reassign ([Char] -> CSExp
Var [Char]
"DoWarmupRun") (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ Bool -> CSExp
Bool Bool
True
]
},
Option :: [Char] -> Maybe Char -> OptionArgument -> [CSStmt] -> Option
Option { optionLongName :: [Char]
optionLongName = [Char]
"entry-point"
, optionShortName :: Maybe Char
optionShortName = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'e'
, optionArgument :: OptionArgument
optionArgument = OptionArgument
RequiredArgument
, optionAction :: [CSStmt]
optionAction =
[ CSExp -> CSExp -> CSStmt
Reassign ([Char] -> CSExp
Var [Char]
"EntryPoint") (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> CSExp
Var [Char]
"optarg" ]
}
]
data Constructor = Constructor [CSFunDefArg] [CSStmt]
emptyConstructor :: Constructor
emptyConstructor :: Constructor
emptyConstructor = [CSFunDefArg] -> [CSStmt] -> Constructor
Constructor [(CSComp -> CSType
Composite (CSComp -> CSType) -> CSComp -> CSType
forall a b. (a -> b) -> a -> b
$ CSType -> CSComp
ArrayT (CSType -> CSComp) -> CSType -> CSComp
forall a b. (a -> b) -> a -> b
$ CSPrim -> CSType
Primitive CSPrim
StringT, [Char]
"args")] []
constructorToConstructorDef :: Constructor -> String -> [CSStmt] -> CSStmt
constructorToConstructorDef :: Constructor -> [Char] -> [CSStmt] -> CSStmt
constructorToConstructorDef (Constructor [CSFunDefArg]
params [CSStmt]
body) [Char]
name [CSStmt]
at_init =
CSConstructorDef -> CSStmt
ConstructorDef (CSConstructorDef -> CSStmt) -> CSConstructorDef -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSFunDefArg] -> [CSStmt] -> CSConstructorDef
ClassConstructor [Char]
name [CSFunDefArg]
params ([CSStmt] -> CSConstructorDef) -> [CSStmt] -> CSConstructorDef
forall a b. (a -> b) -> a -> b
$ [CSStmt]
body [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. Semigroup a => a -> a -> a
<> [CSStmt]
at_init
compileProg :: MonadFreshNames m =>
Maybe String
-> Constructor
-> [CSStmt]
-> [CSStmt]
-> Operations op s
-> s
-> CompilerM op s ()
-> [CSStmt]
-> [Space]
-> [Option]
-> Imp.Definitions op
-> m String
compileProg :: Maybe [Char]
-> Constructor
-> [CSStmt]
-> [CSStmt]
-> Operations op s
-> s
-> CompilerM op s ()
-> [CSStmt]
-> [Space]
-> [Option]
-> Definitions op
-> m [Char]
compileProg Maybe [Char]
module_name Constructor
constructor [CSStmt]
imports [CSStmt]
defines Operations op s
ops s
userstate CompilerM op s ()
boilerplate [CSStmt]
pre_timing [Space]
_ [Option]
options Definitions op
prog = do
VNameSource
src <- m VNameSource
forall (m :: * -> *). MonadFreshNames m => m VNameSource
getNameSource
let prog' :: [CSStmt]
prog' = Operations op s
-> VNameSource -> s -> CompilerM op s [CSStmt] -> [CSStmt]
forall op s a.
Operations op s -> VNameSource -> s -> CompilerM op s a -> a
runCompilerM Operations op s
ops VNameSource
src s
userstate CompilerM op s [CSStmt]
compileProg'
let imports' :: [CSStmt]
imports' = [ Maybe [Char] -> [Char] -> CSStmt
Using Maybe [Char]
forall a. Maybe a
Nothing [Char]
"System"
, Maybe [Char] -> [Char] -> CSStmt
Using Maybe [Char]
forall a. Maybe a
Nothing [Char]
"System.Diagnostics"
, Maybe [Char] -> [Char] -> CSStmt
Using Maybe [Char]
forall a. Maybe a
Nothing [Char]
"System.Collections"
, Maybe [Char] -> [Char] -> CSStmt
Using Maybe [Char]
forall a. Maybe a
Nothing [Char]
"System.Collections.Generic"
, Maybe [Char] -> [Char] -> CSStmt
Using Maybe [Char]
forall a. Maybe a
Nothing [Char]
"System.IO"
, Maybe [Char] -> [Char] -> CSStmt
Using Maybe [Char]
forall a. Maybe a
Nothing [Char]
"System.Linq"
, Maybe [Char] -> [Char] -> CSStmt
Using Maybe [Char]
forall a. Maybe a
Nothing [Char]
"System.Runtime.InteropServices"
, Maybe [Char] -> [Char] -> CSStmt
Using Maybe [Char]
forall a. Maybe a
Nothing [Char]
"static System.ValueTuple"
, Maybe [Char] -> [Char] -> CSStmt
Using Maybe [Char]
forall a. Maybe a
Nothing [Char]
"static System.Convert"
, Maybe [Char] -> [Char] -> CSStmt
Using Maybe [Char]
forall a. Maybe a
Nothing [Char]
"static System.Math"
, Maybe [Char] -> [Char] -> CSStmt
Using Maybe [Char]
forall a. Maybe a
Nothing [Char]
"System.Numerics"
, Maybe [Char] -> [Char] -> CSStmt
Using Maybe [Char]
forall a. Maybe a
Nothing [Char]
"Mono.Options" ] [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt]
imports
[Char] -> m [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> m [Char]) -> [Char] -> m [Char]
forall a b. (a -> b) -> a -> b
$ CSProg -> [Char]
forall a. Pretty a => a -> [Char]
pretty ([CSStmt] -> CSProg
CSProg ([CSStmt] -> CSProg) -> [CSStmt] -> CSProg
forall a b. (a -> b) -> a -> b
$ [CSStmt]
imports' [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt]
prog')
where Imp.Definitions Constants op
consts (Imp.Functions [(Name, Function op)]
funs) = Definitions op
prog
compileProg' :: CompilerM op s [CSStmt]
compileProg' = do
Constants op -> CompilerM op s ()
forall op s. Constants op -> CompilerM op s ()
compileConstants Constants op
consts
[CSFunDef]
definitions <- ((Name, Function op) -> CompilerM op s CSFunDef)
-> [(Name, Function op)] -> CompilerM op s [CSFunDef]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name, Function op) -> CompilerM op s CSFunDef
forall op s. (Name, Function op) -> CompilerM op s CSFunDef
compileFunc [(Name, Function op)]
funs
[CSStmt]
opencl_boilerplate <- CompilerM op s () -> CompilerM op s [CSStmt]
forall op s. CompilerM op s () -> CompilerM op s [CSStmt]
collect CompilerM op s ()
boilerplate
[CSStmt]
compBeforeParses <- (CompilerState s -> [CSStmt]) -> CompilerM op s [CSStmt]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompilerState s -> [CSStmt]
forall s. CompilerState s -> [CSStmt]
compBeforeParse
[CSStmt]
compInits <- (CompilerState s -> [CSStmt]) -> CompilerM op s [CSStmt]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompilerState s -> [CSStmt]
forall s. CompilerState s -> [CSStmt]
compInit
[CSStmt]
staticDecls <- (CompilerState s -> [CSStmt]) -> CompilerM op s [CSStmt]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompilerState s -> [CSStmt]
forall s. CompilerState s -> [CSStmt]
compStaticMemDecls
[CSStmt]
staticAllocs <- (CompilerState s -> [CSStmt]) -> CompilerM op s [CSStmt]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompilerState s -> [CSStmt]
forall s. CompilerState s -> [CSStmt]
compStaticMemAllocs
[CSStmt]
extraMemberDecls <- (CompilerState s -> [CSStmt]) -> CompilerM op s [CSStmt]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompilerState s -> [CSStmt]
forall s. CompilerState s -> [CSStmt]
compMemberDecls
let member_decls' :: [CSStmt]
member_decls' = [CSStmt]
member_decls [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt]
extraMemberDecls [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt]
staticDecls
let at_inits' :: [CSStmt]
at_inits' = [CSStmt]
at_inits [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt]
compBeforeParses [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt]
parse_options [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt]
compInits [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt]
staticAllocs
case Maybe [Char]
module_name of
Just [Char]
name -> do
[CSFunDef]
entry_points <- ((Name, Function op) -> CompilerM op s CSFunDef)
-> [(Name, Function op)] -> CompilerM op s [CSFunDef]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([CSStmt] -> (Name, Function op) -> CompilerM op s CSFunDef
forall op s.
[CSStmt] -> (Name, Function op) -> CompilerM op s CSFunDef
compileEntryFun [CSStmt]
pre_timing) ([(Name, Function op)] -> CompilerM op s [CSFunDef])
-> [(Name, Function op)] -> CompilerM op s [CSFunDef]
forall a b. (a -> b) -> a -> b
$ ((Name, Function op) -> Bool)
-> [(Name, Function op)] -> [(Name, Function op)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Function op -> Bool
forall a. FunctionT a -> Bool
Imp.functionEntry (Function op -> Bool)
-> ((Name, Function op) -> Function op)
-> (Name, Function op)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Function op) -> Function op
forall a b. (a, b) -> b
snd) [(Name, Function op)]
funs
let constructor' :: CSStmt
constructor' = Constructor -> [Char] -> [CSStmt] -> CSStmt
constructorToConstructorDef Constructor
constructor [Char]
name [CSStmt]
at_inits'
[CSStmt] -> CompilerM op s [CSStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [ [Char] -> [CSStmt] -> CSStmt
Namespace [Char]
name [CSClassDef -> CSStmt
ClassDef (CSClassDef -> CSStmt) -> CSClassDef -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSStmt] -> CSClassDef
PublicClass [Char]
name ([CSStmt] -> CSClassDef) -> [CSStmt] -> CSClassDef
forall a b. (a -> b) -> a -> b
$ [CSStmt]
member_decls' [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++
CSStmt
constructor' CSStmt -> [CSStmt] -> [CSStmt]
forall a. a -> [a] -> [a]
: [CSStmt]
defines' [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt]
opencl_boilerplate [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++
(CSFunDef -> CSStmt) -> [CSFunDef] -> [CSStmt]
forall a b. (a -> b) -> [a] -> [b]
map CSFunDef -> CSStmt
PrivateFunDef [CSFunDef]
definitions [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++
(CSFunDef -> CSStmt) -> [CSFunDef] -> [CSStmt]
forall a b. (a -> b) -> [a] -> [b]
map CSFunDef -> CSStmt
PublicFunDef [CSFunDef]
entry_points ]]
Maybe [Char]
Nothing -> do
let name :: [Char]
name = [Char]
"FutharkInternal"
let constructor' :: CSStmt
constructor' = Constructor -> [Char] -> [CSStmt] -> CSStmt
constructorToConstructorDef Constructor
constructor [Char]
name [CSStmt]
at_inits'
([CSFunDef]
entry_point_defs, [[Char]]
entry_point_names, [CSExp]
entry_points) <-
[(CSFunDef, [Char], CSExp)] -> ([CSFunDef], [[Char]], [CSExp])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(CSFunDef, [Char], CSExp)] -> ([CSFunDef], [[Char]], [CSExp]))
-> CompilerM op s [(CSFunDef, [Char], CSExp)]
-> CompilerM op s ([CSFunDef], [[Char]], [CSExp])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Name, Function op) -> CompilerM op s (CSFunDef, [Char], CSExp))
-> [(Name, Function op)]
-> CompilerM op s [(CSFunDef, [Char], CSExp)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([CSStmt]
-> (Name, Function op) -> CompilerM op s (CSFunDef, [Char], CSExp)
forall op s.
[CSStmt]
-> (Name, Function op) -> CompilerM op s (CSFunDef, [Char], CSExp)
callEntryFun [CSStmt]
pre_timing)
(((Name, Function op) -> Bool)
-> [(Name, Function op)] -> [(Name, Function op)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Function op -> Bool
forall a. FunctionT a -> Bool
Imp.functionEntry (Function op -> Bool)
-> ((Name, Function op) -> Function op)
-> (Name, Function op)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Function op) -> Function op
forall a b. (a, b) -> b
snd) [(Name, Function op)]
funs)
[CSStmt]
debug_ending <- (CompilerState s -> [CSStmt]) -> CompilerM op s [CSStmt]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompilerState s -> [CSStmt]
forall s. CompilerState s -> [CSStmt]
compDebugItems
[CSStmt] -> CompilerM op s [CSStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [[Char] -> [CSStmt] -> CSStmt
Namespace [Char]
name (CSClassDef -> CSStmt
ClassDef
([Char] -> [CSStmt] -> CSClassDef
PublicClass [Char]
name ([CSStmt] -> CSClassDef) -> [CSStmt] -> CSClassDef
forall a b. (a -> b) -> a -> b
$
[CSStmt]
member_decls' [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++
CSStmt
constructor' CSStmt -> [CSStmt] -> [CSStmt]
forall a. a -> [a] -> [a]
: [CSStmt]
defines' [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++
[CSStmt]
opencl_boilerplate [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++
(CSFunDef -> CSStmt) -> [CSFunDef] -> [CSStmt]
forall a b. (a -> b) -> [a] -> [b]
map CSFunDef -> CSStmt
PrivateFunDef ([CSFunDef]
definitions [CSFunDef] -> [CSFunDef] -> [CSFunDef]
forall a. [a] -> [a] -> [a]
++ [CSFunDef]
entry_point_defs) [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++
[CSFunDef -> CSStmt
PublicFunDef (CSFunDef -> CSStmt) -> CSFunDef -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> CSType -> [CSFunDefArg] -> [CSStmt] -> CSFunDef
Def [Char]
"InternalEntry" CSType
VoidT [] ([CSStmt] -> CSFunDef) -> [CSStmt] -> CSFunDef
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [CSExp] -> [CSStmt]
selectEntryPoint [[Char]]
entry_point_names [CSExp]
entry_points [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt]
debug_ending
]
) CSStmt -> [CSStmt] -> [CSStmt]
forall a. a -> [a] -> [a]
:
[CSClassDef -> CSStmt
ClassDef (CSClassDef -> CSStmt) -> CSClassDef -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSStmt] -> CSClassDef
PublicClass [Char]
"Program"
[CSFunDef -> CSStmt
StaticFunDef (CSFunDef -> CSStmt) -> CSFunDef -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> CSType -> [CSFunDefArg] -> [CSStmt] -> CSFunDef
Def [Char]
"Main" CSType
VoidT [(CSType
string_arrayT,[Char]
"args")] [CSStmt]
main_entry]])
]
string_arrayT :: CSType
string_arrayT = CSComp -> CSType
Composite (CSComp -> CSType) -> CSComp -> CSType
forall a b. (a -> b) -> a -> b
$ CSType -> CSComp
ArrayT (CSType -> CSComp) -> CSType -> CSComp
forall a b. (a -> b) -> a -> b
$ CSPrim -> CSType
Primitive CSPrim
StringT
main_entry :: [CSStmt]
main_entry :: [CSStmt]
main_entry = [ CSExp -> CSExp -> CSStmt
Assign ([Char] -> CSExp
Var [Char]
"internalInstance") ([Char] -> [CSExp] -> CSExp
simpleInitClass [Char]
"FutharkInternal" [[Char] -> CSExp
Var [Char]
"args"])
, CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"internalInstance.InternalEntry" []
]
member_decls :: [CSStmt]
member_decls =
[ CSType -> CSExp -> Maybe CSExp -> CSStmt
AssignTyped ([Char] -> CSType
CustomT [Char]
"FileStream") ([Char] -> CSExp
Var [Char]
"RuntimeFile") Maybe CSExp
forall a. Maybe a
Nothing
, CSType -> CSExp -> Maybe CSExp -> CSStmt
AssignTyped ([Char] -> CSType
CustomT [Char]
"StreamWriter") ([Char] -> CSExp
Var [Char]
"RuntimeFileWriter") Maybe CSExp
forall a. Maybe a
Nothing
, CSType -> CSExp -> Maybe CSExp -> CSStmt
AssignTyped (CSPrim -> CSType
Primitive CSPrim
BoolT) ([Char] -> CSExp
Var [Char]
"DoWarmupRun") Maybe CSExp
forall a. Maybe a
Nothing
, CSType -> CSExp -> Maybe CSExp -> CSStmt
AssignTyped (CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int32T) ([Char] -> CSExp
Var [Char]
"NumRuns") Maybe CSExp
forall a. Maybe a
Nothing
, CSType -> CSExp -> Maybe CSExp -> CSStmt
AssignTyped (CSPrim -> CSType
Primitive CSPrim
StringT) ([Char] -> CSExp
Var [Char]
"EntryPoint") Maybe CSExp
forall a. Maybe a
Nothing
]
at_inits :: [CSStmt]
at_inits = [ CSExp -> CSExp -> CSStmt
Reassign ([Char] -> CSExp
Var [Char]
"DoWarmupRun") (Bool -> CSExp
Bool Bool
False)
, CSExp -> CSExp -> CSStmt
Reassign ([Char] -> CSExp
Var [Char]
"NumRuns") (Integer -> CSExp
Integer Integer
1)
, CSExp -> CSExp -> CSStmt
Reassign ([Char] -> CSExp
Var [Char]
"EntryPoint") ([Char] -> CSExp
String [Char]
"main")
, CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"ValueReader" []
]
defines' :: [CSStmt]
defines' = [ [Char] -> CSStmt
Escape [Char]
csScalar
, [Char] -> CSStmt
Escape [Char]
csMemory
, [Char] -> CSStmt
Escape [Char]
csPanic
, [Char] -> CSStmt
Escape [Char]
csExceptions
, [Char] -> CSStmt
Escape [Char]
csReader] [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt]
defines
parse_options :: [CSStmt]
parse_options =
[Option] -> [CSStmt]
generateOptionParser ([Option]
standardOptions [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ [Option]
options)
selectEntryPoint :: [[Char]] -> [CSExp] -> [CSStmt]
selectEntryPoint [[Char]]
entry_point_names [CSExp]
entry_points =
[ CSExp -> CSExp -> CSStmt
Assign ([Char] -> CSExp
Var [Char]
"EntryPoints") (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$
[Char] -> [CSExp] -> CSExp
Collection [Char]
"Dictionary<string, Action>" ([CSExp] -> CSExp) -> [CSExp] -> CSExp
forall a b. (a -> b) -> a -> b
$ (CSExp -> CSExp -> CSExp) -> [CSExp] -> [CSExp] -> [CSExp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith CSExp -> CSExp -> CSExp
Pair (([Char] -> CSExp) -> [[Char]] -> [CSExp]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> CSExp
String [[Char]]
entry_point_names) [CSExp]
entry_points,
CSExp -> [CSStmt] -> [CSStmt] -> CSStmt
If ([Char] -> [CSExp] -> CSExp
simpleCall [Char]
"!EntryPoints.ContainsKey" [[Char] -> CSExp
Var [Char]
"EntryPoint"])
[ CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"Console.Error.WriteLine"
[[Char] -> [CSExp] -> CSExp
simpleCall [Char]
"string.Format"
[ [Char] -> CSExp
String [Char]
"No entry point '{0}'. Select another with --entry point. Options are:\n{1}"
, [Char] -> CSExp
Var [Char]
"EntryPoint"
, [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"string.Join"
[ [Char] -> CSExp
String [Char]
"\n"
, CSExp -> [Char] -> CSExp
Field ([Char] -> CSExp
Var [Char]
"EntryPoints") [Char]
"Keys" ]]]
, CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"Environment.Exit" [Integer -> CSExp
Integer Integer
1]]
[ CSExp -> CSExp -> CSStmt
Assign ([Char] -> CSExp
Var [Char]
"entryPointFun") (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$
CSExp -> CSIdx -> CSExp
Index ([Char] -> CSExp
Var [Char]
"EntryPoints") (CSExp -> CSIdx
IdxExp (CSExp -> CSIdx) -> CSExp -> CSIdx
forall a b. (a -> b) -> a -> b
$ [Char] -> CSExp
Var [Char]
"EntryPoint")
, CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"entryPointFun.Invoke" []]
]
compileConstants :: Imp.Constants op -> CompilerM op s ()
compileConstants :: Constants op -> CompilerM op s ()
compileConstants (Imp.Constants [Param]
ps Code op
init_consts) = do
(Param -> CompilerM op s ()) -> [Param] -> CompilerM op s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Param -> CompilerM op s ()
forall op s. Param -> CompilerM op s ()
addConstDecl [Param]
ps
(CSStmt -> CompilerM op s ()) -> [CSStmt] -> CompilerM op s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
staticMemAlloc ([CSStmt] -> CompilerM op s ())
-> CompilerM op s [CSStmt] -> CompilerM op s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CompilerM op s () -> CompilerM op s [CSStmt]
forall op s. CompilerM op s () -> CompilerM op s [CSStmt]
collect (Code op -> CompilerM op s ()
forall op s. Code op -> CompilerM op s ()
compileCode Code op
init_consts)
where addConstDecl :: Param -> CompilerM op s ()
addConstDecl (Imp.ScalarParam VName
p PrimType
bt) = do
let t :: CSType
t = Type -> CSType
compileType (Type -> CSType) -> Type -> CSType
forall a b. (a -> b) -> a -> b
$ PrimType -> Type
Imp.Scalar PrimType
bt
CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
addMemberDecl (CSStmt -> CompilerM op s ()) -> CSStmt -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ CSType -> CSExp -> Maybe CSExp -> CSStmt
AssignTyped CSType
t ([Char] -> CSExp
Var (VName -> [Char]
compileName VName
p)) Maybe CSExp
forall a. Maybe a
Nothing
addConstDecl (Imp.MemParam VName
p Space
space) = do
let t :: CSType
t = Type -> CSType
compileType (Type -> CSType) -> Type -> CSType
forall a b. (a -> b) -> a -> b
$ Space -> Type
Imp.Mem Space
space
CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
addMemberDecl (CSStmt -> CompilerM op s ()) -> CSStmt -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ CSType -> CSExp -> Maybe CSExp -> CSStmt
AssignTyped CSType
t ([Char] -> CSExp
Var (VName -> [Char]
compileName VName
p)) Maybe CSExp
forall a. Maybe a
Nothing
case Space -> Maybe CSExp
memInitExp Space
space of
Maybe CSExp
Nothing -> () -> CompilerM op s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just CSExp
e -> CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
atInit (CSStmt -> CompilerM op s ()) -> CSStmt -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ CSExp -> CSExp -> CSStmt
Reassign ([Char] -> CSExp
Var (VName -> [Char]
compileName VName
p)) CSExp
e
compileFunc :: (Name, Imp.Function op) -> CompilerM op s CSFunDef
compileFunc :: (Name, Function op) -> CompilerM op s CSFunDef
compileFunc (Name
fname, Imp.Function Bool
_ [Param]
outputs [Param]
inputs Code op
body [ExternalValue]
_ [ExternalValue]
_) = do
[CSStmt]
body' <- CompilerM op s () -> CompilerM op s [CSStmt]
forall op s. CompilerM op s () -> CompilerM op s [CSStmt]
blockScope (CompilerM op s () -> CompilerM op s [CSStmt])
-> CompilerM op s () -> CompilerM op s [CSStmt]
forall a b. (a -> b) -> a -> b
$ Code op -> CompilerM op s ()
forall op s. Code op -> CompilerM op s ()
compileCode Code op
body
let inputs' :: [CSFunDefArg]
inputs' = (Param -> CSFunDefArg) -> [Param] -> [CSFunDefArg]
forall a b. (a -> b) -> [a] -> [b]
map Param -> CSFunDefArg
compileTypedInput [Param]
inputs
let outputs' :: [(CSExp, CSType)]
outputs' = (Param -> (CSExp, CSType)) -> [Param] -> [(CSExp, CSType)]
forall a b. (a -> b) -> [a] -> [b]
map Param -> (CSExp, CSType)
compileOutput [Param]
outputs
let outputDecls :: [CSStmt]
outputDecls = (Param -> CSStmt) -> [Param] -> [CSStmt]
forall a b. (a -> b) -> [a] -> [b]
map Param -> CSStmt
getDefaultDecl [Param]
outputs
let ([CSExp]
ret, [CSType]
retType) = [(CSExp, CSType)] -> ([CSExp], [CSType])
forall a b. [(a, b)] -> ([a], [b])
unzip [(CSExp, CSType)]
outputs'
let retType' :: CSType
retType' = [CSType] -> CSType
tupleOrSingleT [CSType]
retType
let ret' :: [CSStmt]
ret' = [CSExp -> CSStmt
Return (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [CSExp] -> CSExp
tupleOrSingle [CSExp]
ret]
case [Param]
outputs of
[] -> CSFunDef -> CompilerM op s CSFunDef
forall (m :: * -> *) a. Monad m => a -> m a
return (CSFunDef -> CompilerM op s CSFunDef)
-> CSFunDef -> CompilerM op s CSFunDef
forall a b. (a -> b) -> a -> b
$ [Char] -> CSType -> [CSFunDefArg] -> [CSStmt] -> CSFunDef
Def ([Char] -> [Char]
futharkFun ([Char] -> [Char]) -> (Name -> [Char]) -> Name -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Char]
nameToString (Name -> [Char]) -> Name -> [Char]
forall a b. (a -> b) -> a -> b
$ Name
fname) CSType
VoidT [CSFunDefArg]
inputs' ([CSStmt]
outputDecls[CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++[CSStmt]
body')
[Param]
_ -> CSFunDef -> CompilerM op s CSFunDef
forall (m :: * -> *) a. Monad m => a -> m a
return (CSFunDef -> CompilerM op s CSFunDef)
-> CSFunDef -> CompilerM op s CSFunDef
forall a b. (a -> b) -> a -> b
$ [Char] -> CSType -> [CSFunDefArg] -> [CSStmt] -> CSFunDef
Def ([Char] -> [Char]
futharkFun ([Char] -> [Char]) -> (Name -> [Char]) -> Name -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Char]
nameToString (Name -> [Char]) -> Name -> [Char]
forall a b. (a -> b) -> a -> b
$ Name
fname) CSType
retType' [CSFunDefArg]
inputs' ([CSStmt]
outputDecls[CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++[CSStmt]
body'[CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++[CSStmt]
ret')
compileTypedInput :: Imp.Param -> (CSType, String)
compileTypedInput :: Param -> CSFunDefArg
compileTypedInput Param
input = (Param -> CSType
typeFun Param
input, Param -> [Char]
nameFun Param
input)
where nameFun :: Param -> [Char]
nameFun = VName -> [Char]
compileName (VName -> [Char]) -> (Param -> VName) -> Param -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Param -> VName
Imp.paramName
typeFun :: Param -> CSType
typeFun = Type -> CSType
compileType (Type -> CSType) -> (Param -> Type) -> Param -> CSType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Param -> Type
paramType
tupleOrSingleEntryT :: [CSType] -> CSType
tupleOrSingleEntryT :: [CSType] -> CSType
tupleOrSingleEntryT [CSType
e] = CSType
e
tupleOrSingleEntryT [CSType]
es = CSComp -> CSType
Composite (CSComp -> CSType) -> CSComp -> CSType
forall a b. (a -> b) -> a -> b
$ [CSType] -> CSComp
SystemTupleT [CSType]
es
tupleOrSingleEntry :: [CSExp] -> CSExp
tupleOrSingleEntry :: [CSExp] -> CSExp
tupleOrSingleEntry [CSExp
e] = CSExp
e
tupleOrSingleEntry [CSExp]
es = [CSExp] -> CSExp
CreateSystemTuple [CSExp]
es
tupleOrSingleT :: [CSType] -> CSType
tupleOrSingleT :: [CSType] -> CSType
tupleOrSingleT [CSType
e] = CSType
e
tupleOrSingleT [CSType]
es = CSComp -> CSType
Composite (CSComp -> CSType) -> CSComp -> CSType
forall a b. (a -> b) -> a -> b
$ [CSType] -> CSComp
TupleT [CSType]
es
tupleOrSingle :: [CSExp] -> CSExp
tupleOrSingle :: [CSExp] -> CSExp
tupleOrSingle [CSExp
e] = CSExp
e
tupleOrSingle [CSExp]
es = [CSExp] -> CSExp
Tuple [CSExp]
es
assignScalarPointer :: CSExp -> CSExp -> CSStmt
assignScalarPointer :: CSExp -> CSExp -> CSStmt
assignScalarPointer CSExp
e CSExp
ptr =
CSType -> CSExp -> Maybe CSExp -> CSStmt
AssignTyped (CSType -> CSType
PointerT CSType
VoidT) CSExp
ptr (CSExp -> Maybe CSExp
forall a. a -> Maybe a
Just (CSExp -> Maybe CSExp) -> CSExp -> Maybe CSExp
forall a b. (a -> b) -> a -> b
$ CSExp -> CSExp
Addr CSExp
e)
simpleCall :: String -> [CSExp] -> CSExp
simpleCall :: [Char] -> [CSExp] -> CSExp
simpleCall [Char]
fname = CSExp -> [CSArg] -> CSExp
Call ([Char] -> CSExp
Var [Char]
fname) ([CSArg] -> CSExp) -> ([CSExp] -> [CSArg]) -> [CSExp] -> CSExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CSExp -> CSArg) -> [CSExp] -> [CSArg]
forall a b. (a -> b) -> [a] -> [b]
map CSExp -> CSArg
simpleArg
simpleArg :: CSExp -> CSArg
simpleArg :: CSExp -> CSArg
simpleArg = Maybe ArgMemType -> CSExp -> CSArg
Arg Maybe ArgMemType
forall a. Maybe a
Nothing
callMethod :: CSExp -> String -> [CSExp] -> CSExp
callMethod :: CSExp -> [Char] -> [CSExp] -> CSExp
callMethod CSExp
object [Char]
method = CSExp -> CSExp -> [CSArg] -> CSExp
CallMethod CSExp
object ([Char] -> CSExp
Var [Char]
method) ([CSArg] -> CSExp) -> ([CSExp] -> [CSArg]) -> [CSExp] -> CSExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CSExp -> CSArg) -> [CSExp] -> [CSArg]
forall a b. (a -> b) -> [a] -> [b]
map CSExp -> CSArg
simpleArg
simpleInitClass :: String -> [CSExp] -> CSExp
simpleInitClass :: [Char] -> [CSExp] -> CSExp
simpleInitClass [Char]
fname =CSExp -> [CSArg] -> CSExp
CreateObject ([Char] -> CSExp
Var [Char]
fname) ([CSArg] -> CSExp) -> ([CSExp] -> [CSArg]) -> [CSExp] -> CSExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CSExp -> CSArg) -> [CSExp] -> [CSArg]
forall a b. (a -> b) -> [a] -> [b]
map CSExp -> CSArg
simpleArg
compileName :: VName -> String
compileName :: VName -> [Char]
compileName = [Char] -> [Char]
zEncodeString ([Char] -> [Char]) -> (VName -> [Char]) -> VName -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VName -> [Char]
forall a. Pretty a => a -> [Char]
pretty
compileVar :: VName -> CompilerM op s CSExp
compileVar :: VName -> CompilerM op s CSExp
compileVar VName
v =
(CompilerEnv op s -> CSExp) -> CompilerM op s CSExp
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((CompilerEnv op s -> CSExp) -> CompilerM op s CSExp)
-> (CompilerEnv op s -> CSExp) -> CompilerM op s CSExp
forall a b. (a -> b) -> a -> b
$ CSExp -> Maybe CSExp -> CSExp
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> CSExp
Var ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ VName -> [Char]
compileName VName
v) (Maybe CSExp -> CSExp)
-> (CompilerEnv op s -> Maybe CSExp) -> CompilerEnv op s -> CSExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VName -> Map VName CSExp -> Maybe CSExp
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup VName
v (Map VName CSExp -> Maybe CSExp)
-> (CompilerEnv op s -> Map VName CSExp)
-> CompilerEnv op s
-> Maybe CSExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerEnv op s -> Map VName CSExp
forall op s. CompilerEnv op s -> Map VName CSExp
envVarExp
compileType :: Imp.Type -> CSType
compileType :: Type -> CSType
compileType (Imp.Scalar PrimType
p) = PrimType -> CSType
compilePrimTypeToAST PrimType
p
compileType (Imp.Mem Space
space) = Space -> CSType
rawMemCSType Space
space
compilePrimTypeToAST :: PrimType -> CSType
compilePrimTypeToAST :: PrimType -> CSType
compilePrimTypeToAST (IntType IntType
Int8) = CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int8T
compilePrimTypeToAST (IntType IntType
Int16) = CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int16T
compilePrimTypeToAST (IntType IntType
Int32) = CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int32T
compilePrimTypeToAST (IntType IntType
Int64) = CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int64T
compilePrimTypeToAST (FloatType FloatType
Float32) = CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSFloat -> CSPrim
CSFloat CSFloat
FloatT
compilePrimTypeToAST (FloatType FloatType
Float64) = CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSFloat -> CSPrim
CSFloat CSFloat
DoubleT
compilePrimTypeToAST PrimType
Imp.Bool = CSPrim -> CSType
Primitive CSPrim
BoolT
compilePrimTypeToAST PrimType
Imp.Cert = CSPrim -> CSType
Primitive CSPrim
BoolT
compilePrimTypeToASText :: PrimType -> Imp.Signedness -> CSType
compilePrimTypeToASText :: PrimType -> Signedness -> CSType
compilePrimTypeToASText (IntType IntType
Int8) Signedness
Imp.TypeUnsigned = CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSUInt -> CSPrim
CSUInt CSUInt
UInt8T
compilePrimTypeToASText (IntType IntType
Int16) Signedness
Imp.TypeUnsigned = CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSUInt -> CSPrim
CSUInt CSUInt
UInt16T
compilePrimTypeToASText (IntType IntType
Int32) Signedness
Imp.TypeUnsigned = CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSUInt -> CSPrim
CSUInt CSUInt
UInt32T
compilePrimTypeToASText (IntType IntType
Int64) Signedness
Imp.TypeUnsigned = CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSUInt -> CSPrim
CSUInt CSUInt
UInt64T
compilePrimTypeToASText (IntType IntType
Int8) Signedness
_ = CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int8T
compilePrimTypeToASText (IntType IntType
Int16) Signedness
_ = CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int16T
compilePrimTypeToASText (IntType IntType
Int32) Signedness
_ = CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int32T
compilePrimTypeToASText (IntType IntType
Int64) Signedness
_ = CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int64T
compilePrimTypeToASText (FloatType FloatType
Float32) Signedness
_ = CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSFloat -> CSPrim
CSFloat CSFloat
FloatT
compilePrimTypeToASText (FloatType FloatType
Float64) Signedness
_ = CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSFloat -> CSPrim
CSFloat CSFloat
DoubleT
compilePrimTypeToASText PrimType
Imp.Bool Signedness
_ = CSPrim -> CSType
Primitive CSPrim
BoolT
compilePrimTypeToASText PrimType
Imp.Cert Signedness
_ = CSPrim -> CSType
Primitive CSPrim
BoolT
compileDim :: Imp.DimSize -> CSExp
compileDim :: DimSize -> CSExp
compileDim (Imp.Constant PrimValue
v) = PrimValue -> CSExp
compilePrimValue PrimValue
v
compileDim (Imp.Var VName
v) = [Char] -> CSExp
Var ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ VName -> [Char]
compileName VName
v
unpackDim :: CSExp -> Imp.DimSize -> Int32 -> CompilerM op s ()
unpackDim :: CSExp -> DimSize -> Int32 -> CompilerM op s ()
unpackDim CSExp
arr_name (Imp.Constant PrimValue
c) Int32
i = do
let shape_name :: CSExp
shape_name = CSExp -> [Char] -> CSExp
Field CSExp
arr_name [Char]
"Item2"
let constant_c :: CSExp
constant_c = PrimValue -> CSExp
compilePrimValue PrimValue
c
let constant_i :: CSExp
constant_i = Integer -> CSExp
Integer (Integer -> CSExp) -> Integer -> CSExp
forall a b. (a -> b) -> a -> b
$ Int32 -> Integer
forall a. Integral a => a -> Integer
toInteger Int32
i
CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
stm (CSStmt -> CompilerM op s ()) -> CSStmt -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ CSExp -> [CSExp] -> CSStmt
Assert ([Char] -> CSExp -> CSExp -> CSExp
BinOp [Char]
"==" CSExp
constant_c (CSExp -> CSIdx -> CSExp
Index CSExp
shape_name (CSIdx -> CSExp) -> CSIdx -> CSExp
forall a b. (a -> b) -> a -> b
$ CSExp -> CSIdx
IdxExp CSExp
constant_i)) [[Char] -> CSExp
String [Char]
"constant dimension wrong"]
unpackDim CSExp
arr_name (Imp.Var VName
var) Int32
i = do
let shape_name :: CSExp
shape_name = CSExp -> [Char] -> CSExp
Field CSExp
arr_name [Char]
"Item2"
let src :: CSExp
src = CSExp -> CSIdx -> CSExp
Index CSExp
shape_name (CSIdx -> CSExp) -> CSIdx -> CSExp
forall a b. (a -> b) -> a -> b
$ CSExp -> CSIdx
IdxExp (CSExp -> CSIdx) -> CSExp -> CSIdx
forall a b. (a -> b) -> a -> b
$ Integer -> CSExp
Integer (Integer -> CSExp) -> Integer -> CSExp
forall a b. (a -> b) -> a -> b
$ Int32 -> Integer
forall a. Integral a => a -> Integer
toInteger Int32
i
CSExp
dest <- VName -> CompilerM op s CSExp
forall op s. VName -> CompilerM op s CSExp
compileVar VName
var
Bool
isAssigned <- VName -> CompilerM op s Bool
forall op s. VName -> CompilerM op s Bool
getVarAssigned VName
var
if Bool
isAssigned
then
CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
stm (CSStmt -> CompilerM op s ()) -> CSStmt -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ CSExp -> CSExp -> CSStmt
Reassign CSExp
dest (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ CSType -> CSExp -> CSExp
Cast (CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int32T) CSExp
src
else do
CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
stm (CSStmt -> CompilerM op s ()) -> CSStmt -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ CSExp -> CSExp -> CSStmt
Assign CSExp
dest (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ CSType -> CSExp -> CSExp
Cast (CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int32T) CSExp
src
VName -> CompilerM op s ()
forall op s. VName -> CompilerM op s ()
setVarAssigned VName
var
entryPointOutput :: Imp.ExternalValue -> CompilerM op s CSExp
entryPointOutput :: ExternalValue -> CompilerM op s CSExp
entryPointOutput (Imp.OpaqueValue [Char]
_ [ValueDesc]
vs) =
[CSExp] -> CSExp
CreateSystemTuple ([CSExp] -> CSExp)
-> CompilerM op s [CSExp] -> CompilerM op s CSExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ValueDesc -> CompilerM op s CSExp)
-> [ValueDesc] -> CompilerM op s [CSExp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ExternalValue -> CompilerM op s CSExp
forall op s. ExternalValue -> CompilerM op s CSExp
entryPointOutput (ExternalValue -> CompilerM op s CSExp)
-> (ValueDesc -> ExternalValue)
-> ValueDesc
-> CompilerM op s CSExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValueDesc -> ExternalValue
Imp.TransparentValue) [ValueDesc]
vs
entryPointOutput (Imp.TransparentValue (Imp.ScalarValue PrimType
bt Signedness
ept VName
name)) =
CSExp -> CSExp
cast (CSExp -> CSExp) -> CompilerM op s CSExp -> CompilerM op s CSExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VName -> CompilerM op s CSExp
forall op s. VName -> CompilerM op s CSExp
compileVar VName
name
where cast :: CSExp -> CSExp
cast = PrimType -> Signedness -> CSExp -> CSExp
compileTypecastExt PrimType
bt Signedness
ept
entryPointOutput (Imp.TransparentValue (Imp.ArrayValue VName
mem (Imp.Space [Char]
sid) PrimType
bt Signedness
ept [DimSize]
dims)) = do
CSExp
mem' <- VName -> CompilerM op s CSExp
forall op s. VName -> CompilerM op s CSExp
compileVar VName
mem
CSExp -> Space -> CompilerM op s ()
forall op s. CSExp -> Space -> CompilerM op s ()
unRefMem CSExp
mem' ([Char] -> Space
Imp.Space [Char]
sid)
EntryOutput op s
pack_output <- (CompilerEnv op s -> EntryOutput op s)
-> CompilerM op s (EntryOutput op s)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks CompilerEnv op s -> EntryOutput op s
forall op s. CompilerEnv op s -> EntryOutput op s
envEntryOutput
EntryOutput op s
pack_output CSExp
mem' [Char]
sid PrimType
bt Signedness
ept [DimSize]
dims
entryPointOutput (Imp.TransparentValue (Imp.ArrayValue VName
mem Space
_ PrimType
bt Signedness
ept [DimSize]
dims)) = do
CSExp
src <- VName -> CompilerM op s CSExp
forall op s. VName -> CompilerM op s CSExp
compileVar VName
mem
let createTuple :: [Char]
createTuple = [Char]
"createTuple_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PrimType -> Signedness -> [Char]
compilePrimTypeExt PrimType
bt Signedness
ept
CSExp -> CompilerM op s CSExp
forall (m :: * -> *) a. Monad m => a -> m a
return (CSExp -> CompilerM op s CSExp) -> CSExp -> CompilerM op s CSExp
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall [Char]
createTuple [CSExp
src, CSType -> Either Int [CSExp] -> CSExp
CreateArray (CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int64T) (Either Int [CSExp] -> CSExp) -> Either Int [CSExp] -> CSExp
forall a b. (a -> b) -> a -> b
$ [CSExp] -> Either Int [CSExp]
forall a b. b -> Either a b
Right ([CSExp] -> Either Int [CSExp]) -> [CSExp] -> Either Int [CSExp]
forall a b. (a -> b) -> a -> b
$ (DimSize -> CSExp) -> [DimSize] -> [CSExp]
forall a b. (a -> b) -> [a] -> [b]
map DimSize -> CSExp
compileDim [DimSize]
dims]
entryPointInput :: (Int, Imp.ExternalValue, CSExp) -> CompilerM op s ()
entryPointInput :: (Int, ExternalValue, CSExp) -> CompilerM op s ()
entryPointInput (Int
i, Imp.OpaqueValue [Char]
_ [ValueDesc]
vs, CSExp
e) =
((Int, ExternalValue, CSExp) -> CompilerM op s ())
-> [(Int, ExternalValue, CSExp)] -> CompilerM op s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Int, ExternalValue, CSExp) -> CompilerM op s ()
forall op s. (Int, ExternalValue, CSExp) -> CompilerM op s ()
entryPointInput ([(Int, ExternalValue, CSExp)] -> CompilerM op s ())
-> [(Int, ExternalValue, CSExp)] -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ [Int]
-> [ExternalValue] -> [CSExp] -> [(Int, ExternalValue, CSExp)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 (Int -> [Int]
forall a. a -> [a]
repeat Int
i) ((ValueDesc -> ExternalValue) -> [ValueDesc] -> [ExternalValue]
forall a b. (a -> b) -> [a] -> [b]
map ValueDesc -> ExternalValue
Imp.TransparentValue [ValueDesc]
vs) ([CSExp] -> [(Int, ExternalValue, CSExp)])
-> [CSExp] -> [(Int, ExternalValue, CSExp)]
forall a b. (a -> b) -> a -> b
$
(Int -> CSExp) -> [Int] -> [CSExp]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
idx -> CSExp -> [Char] -> CSExp
Field CSExp
e ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ [Char]
"Item" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Int
idx :: Int)) [Int
1..]
entryPointInput (Int
_, Imp.TransparentValue (Imp.ScalarValue PrimType
bt Signedness
_ VName
name), CSExp
e) = do
CSExp
vname' <- VName -> CompilerM op s CSExp
forall op s. VName -> CompilerM op s CSExp
compileVar VName
name
let cast :: CSExp -> CSExp
cast = PrimType -> CSExp -> CSExp
compileTypecast PrimType
bt
CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
stm (CSStmt -> CompilerM op s ()) -> CSStmt -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ CSExp -> CSExp -> CSStmt
Assign CSExp
vname' (CSExp -> CSExp
cast CSExp
e)
entryPointInput (Int
_, Imp.TransparentValue (Imp.ArrayValue VName
mem (Imp.Space [Char]
sid) PrimType
bt Signedness
ept [DimSize]
dims), CSExp
e) = do
EntryInput op s
unpack_input <- (CompilerEnv op s -> EntryInput op s)
-> CompilerM op s (EntryInput op s)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks CompilerEnv op s -> EntryInput op s
forall op s. CompilerEnv op s -> EntryInput op s
envEntryInput
[CSStmt]
unpack <- CompilerM op s () -> CompilerM op s [CSStmt]
forall op s. CompilerM op s () -> CompilerM op s [CSStmt]
collect (CompilerM op s () -> CompilerM op s [CSStmt])
-> CompilerM op s () -> CompilerM op s [CSStmt]
forall a b. (a -> b) -> a -> b
$ EntryInput op s
unpack_input VName
mem [Char]
sid PrimType
bt Signedness
ept [DimSize]
dims CSExp
e
[CSStmt] -> CompilerM op s ()
forall op s. [CSStmt] -> CompilerM op s ()
stms [CSStmt]
unpack
entryPointInput (Int
_, Imp.TransparentValue (Imp.ArrayValue VName
mem Space
_ PrimType
bt Signedness
_ [DimSize]
dims), CSExp
e) = do
(DimSize -> Int32 -> CompilerM op s ())
-> [DimSize] -> [Int32] -> CompilerM op s ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (CSExp -> DimSize -> Int32 -> CompilerM op s ()
forall op s. CSExp -> DimSize -> Int32 -> CompilerM op s ()
unpackDim CSExp
e) [DimSize]
dims [Int32
0..]
let arrayData :: CSExp
arrayData = CSExp -> [Char] -> CSExp
Field CSExp
e [Char]
"Item1"
CSExp
dest <- VName -> CompilerM op s CSExp
forall op s. VName -> CompilerM op s CSExp
compileVar VName
mem
let unwrap_call :: CSExp
unwrap_call = [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"unwrapArray" [CSExp
arrayData, CSType -> CSExp
sizeOf (CSType -> CSExp) -> CSType -> CSExp
forall a b. (a -> b) -> a -> b
$ PrimType -> CSType
compilePrimTypeToAST PrimType
bt]
CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
stm (CSStmt -> CompilerM op s ()) -> CSStmt -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ CSExp -> CSExp -> CSStmt
Assign CSExp
dest CSExp
unwrap_call
extValueDescName :: Imp.ExternalValue -> String
extValueDescName :: ExternalValue -> [Char]
extValueDescName (Imp.TransparentValue ValueDesc
v) = [Char] -> [Char]
extName ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ ValueDesc -> [Char]
valueDescName ValueDesc
v
extValueDescName (Imp.OpaqueValue [Char]
desc []) = [Char] -> [Char]
extName ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
zEncodeString [Char]
desc
extValueDescName (Imp.OpaqueValue [Char]
desc (ValueDesc
v:[ValueDesc]
_)) =
[Char] -> [Char]
extName ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
zEncodeString [Char]
desc [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Pretty a => a -> [Char]
pretty (VName -> Int
baseTag (ValueDesc -> VName
valueDescVName ValueDesc
v))
extName :: String -> String
extName :: [Char] -> [Char]
extName = ([Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"_ext")
sizeOf :: CSType -> CSExp
sizeOf :: CSType -> CSExp
sizeOf CSType
t = [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"sizeof" [([Char] -> CSExp
Var ([Char] -> CSExp) -> (CSType -> [Char]) -> CSType -> CSExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CSType -> [Char]
forall a. Pretty a => a -> [Char]
pretty) CSType
t]
privateFunDef :: String -> CSType -> [(CSType, String)] -> [CSStmt] -> CSStmt
privateFunDef :: [Char] -> CSType -> [CSFunDefArg] -> [CSStmt] -> CSStmt
privateFunDef [Char]
s CSType
t [CSFunDefArg]
args [CSStmt]
stmts = CSFunDef -> CSStmt
PrivateFunDef (CSFunDef -> CSStmt) -> CSFunDef -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> CSType -> [CSFunDefArg] -> [CSStmt] -> CSFunDef
Def [Char]
s CSType
t [CSFunDefArg]
args [CSStmt]
stmts
valueDescName :: Imp.ValueDesc -> String
valueDescName :: ValueDesc -> [Char]
valueDescName = VName -> [Char]
compileName (VName -> [Char]) -> (ValueDesc -> VName) -> ValueDesc -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValueDesc -> VName
valueDescVName
valueDescVName :: Imp.ValueDesc -> VName
valueDescVName :: ValueDesc -> VName
valueDescVName (Imp.ScalarValue PrimType
_ Signedness
_ VName
vname) = VName
vname
valueDescVName (Imp.ArrayValue VName
vname Space
_ PrimType
_ Signedness
_ [DimSize]
_) = VName
vname
consoleErrorWrite :: String -> [CSExp] -> CSExp
consoleErrorWrite :: [Char] -> [CSExp] -> CSExp
consoleErrorWrite [Char]
str [CSExp]
exps = [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"Console.Error.Write" ([CSExp] -> CSExp) -> [CSExp] -> CSExp
forall a b. (a -> b) -> a -> b
$ [Char] -> CSExp
String [Char]
strCSExp -> [CSExp] -> [CSExp]
forall a. a -> [a] -> [a]
:[CSExp]
exps
consoleErrorWriteLine :: String -> [CSExp] -> CSExp
consoleErrorWriteLine :: [Char] -> [CSExp] -> CSExp
consoleErrorWriteLine [Char]
str [CSExp]
exps = [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"Console.Error.WriteLine" ([CSExp] -> CSExp) -> [CSExp] -> CSExp
forall a b. (a -> b) -> a -> b
$ [Char] -> CSExp
String [Char]
strCSExp -> [CSExp] -> [CSExp]
forall a. a -> [a] -> [a]
:[CSExp]
exps
readFun :: PrimType -> Imp.Signedness -> String
readFun :: PrimType -> Signedness -> [Char]
readFun (FloatType FloatType
Float32) Signedness
_ = [Char]
"ReadF32"
readFun (FloatType FloatType
Float64) Signedness
_ = [Char]
"ReadF64"
readFun (IntType IntType
Int8) Signedness
Imp.TypeUnsigned = [Char]
"ReadU8"
readFun (IntType IntType
Int16) Signedness
Imp.TypeUnsigned = [Char]
"ReadU16"
readFun (IntType IntType
Int32) Signedness
Imp.TypeUnsigned = [Char]
"ReadU32"
readFun (IntType IntType
Int64) Signedness
Imp.TypeUnsigned = [Char]
"ReadU64"
readFun (IntType IntType
Int8) Signedness
Imp.TypeDirect = [Char]
"ReadI8"
readFun (IntType IntType
Int16) Signedness
Imp.TypeDirect = [Char]
"ReadI16"
readFun (IntType IntType
Int32) Signedness
Imp.TypeDirect = [Char]
"ReadI32"
readFun (IntType IntType
Int64) Signedness
Imp.TypeDirect = [Char]
"ReadI64"
readFun PrimType
Imp.Bool Signedness
_ = [Char]
"ReadBool"
readFun PrimType
Cert Signedness
_ = [Char] -> [Char]
forall a. HasCallStack => [Char] -> a
error [Char]
"readFun: cert"
readBinFun :: PrimType -> Imp.Signedness -> String
readBinFun :: PrimType -> Signedness -> [Char]
readBinFun (FloatType FloatType
Float32) Signedness
_bin_ = [Char]
"ReadBinF32"
readBinFun (FloatType FloatType
Float64) Signedness
_bin_ = [Char]
"ReadBinF64"
readBinFun (IntType IntType
Int8) Signedness
Imp.TypeUnsigned = [Char]
"ReadBinU8"
readBinFun (IntType IntType
Int16) Signedness
Imp.TypeUnsigned = [Char]
"ReadBinU16"
readBinFun (IntType IntType
Int32) Signedness
Imp.TypeUnsigned = [Char]
"ReadBinU32"
readBinFun (IntType IntType
Int64) Signedness
Imp.TypeUnsigned = [Char]
"ReadBinU64"
readBinFun (IntType IntType
Int8) Signedness
Imp.TypeDirect = [Char]
"ReadBinI8"
readBinFun (IntType IntType
Int16) Signedness
Imp.TypeDirect = [Char]
"ReadBinI16"
readBinFun (IntType IntType
Int32) Signedness
Imp.TypeDirect = [Char]
"ReadBinI32"
readBinFun (IntType IntType
Int64) Signedness
Imp.TypeDirect = [Char]
"ReadBinI64"
readBinFun PrimType
Imp.Bool Signedness
_ = [Char]
"ReadBinBool"
readBinFun PrimType
Cert Signedness
_ = [Char] -> [Char]
forall a. HasCallStack => [Char] -> a
error [Char]
"readFun: cert"
readTypeEnum :: PrimType -> Imp.Signedness -> String
readTypeEnum :: PrimType -> Signedness -> [Char]
readTypeEnum (IntType IntType
Int8) Signedness
Imp.TypeUnsigned = [Char]
"u8"
readTypeEnum (IntType IntType
Int16) Signedness
Imp.TypeUnsigned = [Char]
"u16"
readTypeEnum (IntType IntType
Int32) Signedness
Imp.TypeUnsigned = [Char]
"u32"
readTypeEnum (IntType IntType
Int64) Signedness
Imp.TypeUnsigned = [Char]
"u64"
readTypeEnum (IntType IntType
Int8) Signedness
Imp.TypeDirect = [Char]
"i8"
readTypeEnum (IntType IntType
Int16) Signedness
Imp.TypeDirect = [Char]
"i16"
readTypeEnum (IntType IntType
Int32) Signedness
Imp.TypeDirect = [Char]
"i32"
readTypeEnum (IntType IntType
Int64) Signedness
Imp.TypeDirect = [Char]
"i64"
readTypeEnum (FloatType FloatType
Float32) Signedness
_ = [Char]
"f32"
readTypeEnum (FloatType FloatType
Float64) Signedness
_ = [Char]
"f64"
readTypeEnum PrimType
Imp.Bool Signedness
_ = [Char]
"bool"
readTypeEnum PrimType
Cert Signedness
_ = [Char] -> [Char]
forall a. HasCallStack => [Char] -> a
error [Char]
"readTypeEnum: cert"
readInput :: Imp.ExternalValue -> CSStmt
readInput :: ExternalValue -> CSStmt
readInput (Imp.OpaqueValue [Char]
desc [ValueDesc]
_) =
CSExp -> CSStmt
Throw (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleInitClass [Char]
"Exception" [[Char] -> CSExp
String ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot read argument of type " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
desc [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"."]
readInput decl :: ExternalValue
decl@(Imp.TransparentValue (Imp.ScalarValue PrimType
bt Signedness
ept VName
_)) =
let read_func :: CSExp
read_func = [Char] -> CSExp
Var ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ PrimType -> Signedness -> [Char]
readFun PrimType
bt Signedness
ept
read_bin_func :: CSExp
read_bin_func = [Char] -> CSExp
Var ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ PrimType -> Signedness -> [Char]
readBinFun PrimType
bt Signedness
ept
type_enum :: CSExp
type_enum = [Char] -> CSExp
String ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ PrimType -> Signedness -> [Char]
readTypeEnum PrimType
bt Signedness
ept
bt' :: [Char]
bt' = PrimType -> Signedness -> [Char]
compilePrimTypeExt PrimType
bt Signedness
ept
readScalar :: [Char]
readScalar = [Char] -> [Char] -> [Char]
initializeGenericFunction [Char]
"ReadScalar" [Char]
bt'
in CSExp -> CSExp -> CSStmt
Assign ([Char] -> CSExp
Var ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ ExternalValue -> [Char]
extValueDescName ExternalValue
decl) (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall [Char]
readScalar [CSExp
type_enum, CSExp
read_func, CSExp
read_bin_func]
readInput decl :: ExternalValue
decl@(Imp.TransparentValue (Imp.ArrayValue VName
_ Space
_ PrimType
bt Signedness
ept [DimSize]
dims)) =
let rank' :: CSExp
rank' = [Char] -> CSExp
Var ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> [Char]) -> Int -> [Char]
forall a b. (a -> b) -> a -> b
$ [DimSize] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DimSize]
dims
type_enum :: CSExp
type_enum = [Char] -> CSExp
String ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ PrimType -> Signedness -> [Char]
readTypeEnum PrimType
bt Signedness
ept
bt' :: [Char]
bt' = PrimType -> Signedness -> [Char]
compilePrimTypeExt PrimType
bt Signedness
ept
read_func :: CSExp
read_func = [Char] -> CSExp
Var ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ PrimType -> Signedness -> [Char]
readFun PrimType
bt Signedness
ept
readArray :: [Char]
readArray = [Char] -> [Char] -> [Char]
initializeGenericFunction [Char]
"ReadArray" [Char]
bt'
in CSExp -> CSExp -> CSStmt
Assign ([Char] -> CSExp
Var ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ ExternalValue -> [Char]
extValueDescName ExternalValue
decl) (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall [Char]
readArray [CSExp
rank', CSExp
type_enum, CSExp
read_func]
initializeGenericFunction :: String -> String -> String
initializeGenericFunction :: [Char] -> [Char] -> [Char]
initializeGenericFunction [Char]
fun [Char]
tp = [Char]
fun [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"<" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
tp [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
">"
printPrimStm :: CSExp -> CSStmt
printPrimStm :: CSExp -> CSStmt
printPrimStm CSExp
val = CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"WriteValue" [CSExp
val]
formatString :: String -> [CSExp] -> CSExp
formatString :: [Char] -> [CSExp] -> CSExp
formatString [Char]
fmt [CSExp]
contents =
[Char] -> [CSExp] -> CSExp
simpleCall [Char]
"String.Format" ([CSExp] -> CSExp) -> [CSExp] -> CSExp
forall a b. (a -> b) -> a -> b
$ [Char] -> CSExp
String [Char]
fmt CSExp -> [CSExp] -> [CSExp]
forall a. a -> [a] -> [a]
: [CSExp]
contents
printStm :: Imp.ValueDesc -> CSExp -> CSExp -> CompilerM op s CSStmt
printStm :: ValueDesc -> CSExp -> CSExp -> CompilerM op s CSStmt
printStm Imp.ScalarValue{} CSExp
_ CSExp
e =
CSStmt -> CompilerM op s CSStmt
forall (m :: * -> *) a. Monad m => a -> m a
return (CSStmt -> CompilerM op s CSStmt)
-> CSStmt -> CompilerM op s CSStmt
forall a b. (a -> b) -> a -> b
$ CSExp -> CSStmt
printPrimStm CSExp
e
printStm (Imp.ArrayValue VName
_ Space
_ PrimType
_ Signedness
_ []) CSExp
ind CSExp
e = do
let e' :: CSExp
e' = CSExp -> CSIdx -> CSExp
Index CSExp
e (CSExp -> CSIdx
IdxExp ([Char] -> CSExp -> CSExp
PostUnOp [Char]
"++" CSExp
ind))
CSStmt -> CompilerM op s CSStmt
forall (m :: * -> *) a. Monad m => a -> m a
return (CSStmt -> CompilerM op s CSStmt)
-> CSStmt -> CompilerM op s CSStmt
forall a b. (a -> b) -> a -> b
$ CSExp -> CSStmt
printPrimStm CSExp
e'
printStm (Imp.ArrayValue VName
mem Space
space PrimType
bt Signedness
ept (DimSize
outer:[DimSize]
shape)) CSExp
ind CSExp
e = do
VName
ptr <- [Char] -> CompilerM op s VName
forall (m :: * -> *). MonadFreshNames m => [Char] -> m VName
newVName [Char]
"shapePtr"
VName
first <- [Char] -> CompilerM op s VName
forall (m :: * -> *). MonadFreshNames m => [Char] -> m VName
newVName [Char]
"printFirst"
let dims :: [CSExp]
dims = (DimSize -> CSExp) -> [DimSize] -> [CSExp]
forall a b. (a -> b) -> [a] -> [b]
map DimSize -> CSExp
compileDim ([DimSize] -> [CSExp]) -> [DimSize] -> [CSExp]
forall a b. (a -> b) -> a -> b
$ DimSize
outerDimSize -> [DimSize] -> [DimSize]
forall a. a -> [a] -> [a]
:[DimSize]
shape
size :: CSExp
size = CSExp -> [Char] -> [CSExp] -> CSExp
callMethod (CSType -> Either Int [CSExp] -> CSExp
CreateArray (CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int32T) (Either Int [CSExp] -> CSExp) -> Either Int [CSExp] -> CSExp
forall a b. (a -> b) -> a -> b
$ [CSExp] -> Either Int [CSExp]
forall a b. b -> Either a b
Right [CSExp]
dims)
[Char]
"Aggregate" [ Integer -> CSExp
Integer Integer
1
, CSExp -> [CSStmt] -> CSExp
Lambda ([CSExp] -> CSExp
Tuple [[Char] -> CSExp
Var [Char]
"acc", [Char] -> CSExp
Var [Char]
"val"])
[CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> CSExp -> CSExp -> CSExp
BinOp [Char]
"*" ([Char] -> CSExp
Var [Char]
"acc") ([Char] -> CSExp
Var [Char]
"val")]
]
emptystr :: [Char]
emptystr = [Char]
"empty(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PrimType -> [Int] -> [Char]
forall a. Show a => PrimType -> [a] -> [Char]
ppArrayType PrimType
bt [Int
0..[CSExp] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CSExp]
dimsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
CSStmt
printelem <- ValueDesc -> CSExp -> CSExp -> CompilerM op s CSStmt
forall op s. ValueDesc -> CSExp -> CSExp -> CompilerM op s CSStmt
printStm (VName -> Space -> PrimType -> Signedness -> [DimSize] -> ValueDesc
Imp.ArrayValue VName
mem Space
space PrimType
bt Signedness
ept [DimSize]
shape) CSExp
ind CSExp
e
CSStmt -> CompilerM op s CSStmt
forall (m :: * -> *) a. Monad m => a -> m a
return (CSStmt -> CompilerM op s CSStmt)
-> CSStmt -> CompilerM op s CSStmt
forall a b. (a -> b) -> a -> b
$
CSExp -> [CSStmt] -> [CSStmt] -> CSStmt
If ([Char] -> CSExp -> CSExp -> CSExp
BinOp [Char]
"==" CSExp
size (Integer -> CSExp
Integer Integer
0))
[CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"Console.Write" [[Char] -> [CSExp] -> CSExp
formatString [Char]
emptystr [CSExp]
dims]]
[ CSExp -> CSExp -> CSStmt
Assign ([Char] -> CSExp
Var ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ VName -> [Char]
forall a. Pretty a => a -> [Char]
pretty VName
first) (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> CSExp
Var [Char]
"true"
, [Char] -> CSStmt
puts [Char]
"["
, [Char] -> CSExp -> [CSStmt] -> CSStmt
For (VName -> [Char]
forall a. Pretty a => a -> [Char]
pretty VName
ptr) (DimSize -> CSExp
compileDim DimSize
outer)
[ CSExp -> [CSStmt] -> [CSStmt] -> CSStmt
If ([Char] -> [CSExp] -> CSExp
simpleCall [Char]
"!" [[Char] -> CSExp
Var ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ VName -> [Char]
forall a. Pretty a => a -> [Char]
pretty VName
first]) [[Char] -> CSStmt
puts [Char]
", "] []
, CSStmt
printelem
, CSExp -> CSExp -> CSStmt
Reassign ([Char] -> CSExp
Var ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ VName -> [Char]
forall a. Pretty a => a -> [Char]
pretty VName
first) (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> CSExp
Var [Char]
"false"
]
, [Char] -> CSStmt
puts [Char]
"]"
]
where ppArrayType :: PrimType -> [a] -> [Char]
ppArrayType PrimType
t [] = Signedness -> PrimType -> [Char]
prettyPrimType Signedness
ept PrimType
t
ppArrayType PrimType
t (a
i:[a]
is) = [Char]
"[{" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
i [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"}]" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PrimType -> [a] -> [Char]
ppArrayType PrimType
t [a]
is
prettyPrimType :: Signedness -> PrimType -> [Char]
prettyPrimType Signedness
Imp.TypeUnsigned (IntType IntType
Int8) = [Char]
"u8"
prettyPrimType Signedness
Imp.TypeUnsigned (IntType IntType
Int16) = [Char]
"u16"
prettyPrimType Signedness
Imp.TypeUnsigned (IntType IntType
Int32) = [Char]
"u32"
prettyPrimType Signedness
Imp.TypeUnsigned (IntType IntType
Int64) = [Char]
"u64"
prettyPrimType Signedness
_ PrimType
t = PrimType -> [Char]
forall a. Pretty a => a -> [Char]
pretty PrimType
t
puts :: [Char] -> CSStmt
puts [Char]
s = CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"Console.Write" [[Char] -> CSExp
String [Char]
s]
printValue :: [(Imp.ExternalValue, CSExp)] -> CompilerM op s [CSStmt]
printValue :: [(ExternalValue, CSExp)] -> CompilerM op s [CSStmt]
printValue = ([[CSStmt]] -> [CSStmt])
-> CompilerM op s [[CSStmt]] -> CompilerM op s [CSStmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[CSStmt]] -> [CSStmt]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (CompilerM op s [[CSStmt]] -> CompilerM op s [CSStmt])
-> ([(ExternalValue, CSExp)] -> CompilerM op s [[CSStmt]])
-> [(ExternalValue, CSExp)]
-> CompilerM op s [CSStmt]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ExternalValue, CSExp) -> CompilerM op s [CSStmt])
-> [(ExternalValue, CSExp)] -> CompilerM op s [[CSStmt]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((ExternalValue -> CSExp -> CompilerM op s [CSStmt])
-> (ExternalValue, CSExp) -> CompilerM op s [CSStmt]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ExternalValue -> CSExp -> CompilerM op s [CSStmt]
forall op s. ExternalValue -> CSExp -> CompilerM op s [CSStmt]
printValue')
where printValue' :: ExternalValue -> CSExp -> CompilerM op s [CSStmt]
printValue' (Imp.OpaqueValue [Char]
desc [ValueDesc]
_) CSExp
_ =
[CSStmt] -> CompilerM op s [CSStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"Console.Write"
[[Char] -> CSExp
String ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ [Char]
"#<opaque " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
desc [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
">"]]
printValue' (Imp.TransparentValue r :: ValueDesc
r@Imp.ScalarValue{}) CSExp
e = do
CSStmt
p <- ValueDesc -> CSExp -> CSExp -> CompilerM op s CSStmt
forall op s. ValueDesc -> CSExp -> CSExp -> CompilerM op s CSStmt
printStm ValueDesc
r (Integer -> CSExp
Integer Integer
0) CSExp
e
[CSStmt] -> CompilerM op s [CSStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [CSStmt
p, CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"Console.Write" [[Char] -> CSExp
String [Char]
"\n"]]
printValue' (Imp.TransparentValue r :: ValueDesc
r@Imp.ArrayValue{}) CSExp
e = do
VName
tuple <- [Char] -> CompilerM op s VName
forall (m :: * -> *). MonadFreshNames m => [Char] -> m VName
newVName [Char]
"resultArr"
VName
i <- [Char] -> CompilerM op s VName
forall (m :: * -> *). MonadFreshNames m => [Char] -> m VName
newVName [Char]
"arrInd"
let i' :: CSExp
i' = [Char] -> CSExp
Var ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ VName -> [Char]
compileName VName
i
CSStmt
p <- ValueDesc -> CSExp -> CSExp -> CompilerM op s CSStmt
forall op s. ValueDesc -> CSExp -> CSExp -> CompilerM op s CSStmt
printStm ValueDesc
r CSExp
i' ([Char] -> CSExp
Var ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ VName -> [Char]
compileName VName
tuple)
let e' :: CSExp
e' = [Char] -> CSExp
Var ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ CSExp -> [Char]
forall a. Pretty a => a -> [Char]
pretty CSExp
e
[CSStmt] -> CompilerM op s [CSStmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [ CSExp -> CSExp -> CSStmt
Assign ([Char] -> CSExp
Var ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ VName -> [Char]
compileName VName
tuple) (CSExp -> [Char] -> CSExp
Field CSExp
e' [Char]
"Item1")
, CSExp -> CSExp -> CSStmt
Assign CSExp
i' (Integer -> CSExp
Integer Integer
0)
, CSStmt
p
, CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"Console.Write" [[Char] -> CSExp
String [Char]
"\n"]]
prepareEntry :: (Name, Imp.Function op) -> CompilerM op s
(String, [(CSType, String)], CSType, [CSStmt], [CSStmt], [CSStmt], [CSStmt],
[(Imp.ExternalValue, CSExp)], [CSStmt])
prepareEntry :: (Name, Function op)
-> CompilerM
op
s
([Char], [CSFunDefArg], CSType, [CSStmt], [CSStmt], [CSStmt],
[CSStmt], [(ExternalValue, CSExp)], [CSStmt])
prepareEntry (Name
fname, Imp.Function Bool
_ [Param]
outputs [Param]
inputs Code op
_ [ExternalValue]
results [ExternalValue]
args) = do
let ([CSType]
output_types, [[Char]]
output_paramNames) = [CSFunDefArg] -> ([CSType], [[Char]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([CSFunDefArg] -> ([CSType], [[Char]]))
-> [CSFunDefArg] -> ([CSType], [[Char]])
forall a b. (a -> b) -> a -> b
$ (Param -> CSFunDefArg) -> [Param] -> [CSFunDefArg]
forall a b. (a -> b) -> [a] -> [b]
map Param -> CSFunDefArg
compileTypedInput [Param]
outputs
funTuple :: CSExp
funTuple = [CSExp] -> CSExp
tupleOrSingle ([CSExp] -> CSExp) -> [CSExp] -> CSExp
forall a b. (a -> b) -> a -> b
$ ([Char] -> CSExp) -> [[Char]] -> [CSExp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> CSExp
Var [[Char]]
output_paramNames
([()]
_, [CSStmt]
sizeDecls) <- CompilerM op s [()] -> CompilerM op s ([()], [CSStmt])
forall op s a. CompilerM op s a -> CompilerM op s (a, [CSStmt])
collect' (CompilerM op s [()] -> CompilerM op s ([()], [CSStmt]))
-> CompilerM op s [()] -> CompilerM op s ([()], [CSStmt])
forall a b. (a -> b) -> a -> b
$ [ExternalValue]
-> (ExternalValue -> CompilerM op s ()) -> CompilerM op s [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ExternalValue]
args ExternalValue -> CompilerM op s ()
forall op s. ExternalValue -> CompilerM op s ()
declsfunction
([Maybe CSExp]
argexps_mem_copies, [CSStmt]
prepare_run) <- CompilerM op s [Maybe CSExp]
-> CompilerM op s ([Maybe CSExp], [CSStmt])
forall op s a. CompilerM op s a -> CompilerM op s (a, [CSStmt])
collect' (CompilerM op s [Maybe CSExp]
-> CompilerM op s ([Maybe CSExp], [CSStmt]))
-> CompilerM op s [Maybe CSExp]
-> CompilerM op s ([Maybe CSExp], [CSStmt])
forall a b. (a -> b) -> a -> b
$ [Param]
-> (Param -> CompilerM op s (Maybe CSExp))
-> CompilerM op s [Maybe CSExp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Param]
inputs ((Param -> CompilerM op s (Maybe CSExp))
-> CompilerM op s [Maybe CSExp])
-> (Param -> CompilerM op s (Maybe CSExp))
-> CompilerM op s [Maybe CSExp]
forall a b. (a -> b) -> a -> b
$ \case
Imp.MemParam VName
name Space
space -> do
VName
name' <- [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]
baseString VName
name [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"_copy"
Copy op s
copy <- (CompilerEnv op s -> Copy op s) -> CompilerM op s (Copy op s)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks CompilerEnv op s -> Copy op s
forall op s. CompilerEnv op s -> Copy op s
envCopy
Allocate op s
allocate <- (CompilerEnv op s -> Allocate op s)
-> CompilerM op s (Allocate op s)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks CompilerEnv op s -> Allocate op s
forall op s. CompilerEnv op s -> Allocate op s
envAllocate
let size :: CSExp
size = [Char] -> CSExp
Var (VName -> [Char]
compileName VName
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_nbytes")
dest :: CSExp
dest = [Char] -> CSExp
Var ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ VName -> [Char]
compileName VName
name'
src :: CSExp
src = [Char] -> CSExp
Var ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ VName -> [Char]
compileName VName
name
offset :: CSExp
offset = Integer -> CSExp
Integer Integer
0
case Space
space of
Space [Char]
sid ->
Allocate op s
allocate CSExp
dest CSExp
size [Char]
sid
Space
_ ->
CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
stm (CSStmt -> CompilerM op s ()) -> CSStmt -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ CSExp -> CSExp -> CSStmt
Reassign CSExp
dest ([Char] -> [CSExp] -> CSExp
simpleCall [Char]
"allocateMem" [CSExp
size])
Copy op s
copy CSExp
dest CSExp
offset Space
space CSExp
src CSExp
offset Space
space CSExp
size (IntType -> PrimType
IntType IntType
Int64)
Maybe CSExp -> CompilerM op s (Maybe CSExp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe CSExp -> CompilerM op s (Maybe CSExp))
-> Maybe CSExp -> CompilerM op s (Maybe CSExp)
forall a b. (a -> b) -> a -> b
$ CSExp -> Maybe CSExp
forall a. a -> Maybe a
Just CSExp
dest
Param
_ -> Maybe CSExp -> CompilerM op s (Maybe CSExp)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe CSExp
forall a. Maybe a
Nothing
[CSStmt]
prepareIn <- CompilerM op s () -> CompilerM op s [CSStmt]
forall op s. CompilerM op s () -> CompilerM op s [CSStmt]
collect (CompilerM op s () -> CompilerM op s [CSStmt])
-> CompilerM op s () -> CompilerM op s [CSStmt]
forall a b. (a -> b) -> a -> b
$ ((Int, ExternalValue, CSExp) -> CompilerM op s ())
-> [(Int, ExternalValue, CSExp)] -> CompilerM op s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Int, ExternalValue, CSExp) -> CompilerM op s ()
forall op s. (Int, ExternalValue, CSExp) -> CompilerM op s ()
entryPointInput ([(Int, ExternalValue, CSExp)] -> CompilerM op s ())
-> [(Int, ExternalValue, CSExp)] -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ [Int]
-> [ExternalValue] -> [CSExp] -> [(Int, ExternalValue, CSExp)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Int
0..] [ExternalValue]
args ([CSExp] -> [(Int, ExternalValue, CSExp)])
-> [CSExp] -> [(Int, ExternalValue, CSExp)]
forall a b. (a -> b) -> a -> b
$
(ExternalValue -> CSExp) -> [ExternalValue] -> [CSExp]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> CSExp
Var ([Char] -> CSExp)
-> (ExternalValue -> [Char]) -> ExternalValue -> CSExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExternalValue -> [Char]
extValueDescName) [ExternalValue]
args
([CSExp]
res, [CSStmt]
prepareOut) <- CompilerM op s [CSExp] -> CompilerM op s ([CSExp], [CSStmt])
forall op s a. CompilerM op s a -> CompilerM op s (a, [CSStmt])
collect' (CompilerM op s [CSExp] -> CompilerM op s ([CSExp], [CSStmt]))
-> CompilerM op s [CSExp] -> CompilerM op s ([CSExp], [CSStmt])
forall a b. (a -> b) -> a -> b
$ (ExternalValue -> CompilerM op s CSExp)
-> [ExternalValue] -> CompilerM op s [CSExp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ExternalValue -> CompilerM op s CSExp
forall op s. ExternalValue -> CompilerM op s CSExp
entryPointOutput [ExternalValue]
results
let mem_copies :: [(CSExp, Param)]
mem_copies = ((Maybe CSExp, Param) -> Maybe (CSExp, Param))
-> [(Maybe CSExp, Param)] -> [(CSExp, Param)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Maybe CSExp, Param) -> Maybe (CSExp, Param)
forall a b. (Maybe a, b) -> Maybe (a, b)
liftMaybe ([(Maybe CSExp, Param)] -> [(CSExp, Param)])
-> [(Maybe CSExp, Param)] -> [(CSExp, Param)]
forall a b. (a -> b) -> a -> b
$ [Maybe CSExp] -> [Param] -> [(Maybe CSExp, Param)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Maybe CSExp]
argexps_mem_copies [Param]
inputs
mem_copy_inits :: [CSStmt]
mem_copy_inits = ((CSExp, Param) -> CSStmt) -> [(CSExp, Param)] -> [CSStmt]
forall a b. (a -> b) -> [a] -> [b]
map (CSExp, Param) -> CSStmt
initCopy [(CSExp, Param)]
mem_copies
argexps_lib :: [CSExp]
argexps_lib = (Param -> CSExp) -> [Param] -> [CSExp]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> CSExp
Var ([Char] -> CSExp) -> (Param -> [Char]) -> Param -> CSExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VName -> [Char]
compileName (VName -> [Char]) -> (Param -> VName) -> Param -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Param -> VName
Imp.paramName) [Param]
inputs
argexps_bin :: [CSExp]
argexps_bin = (CSExp -> Maybe CSExp -> CSExp)
-> [CSExp] -> [Maybe CSExp] -> [CSExp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith CSExp -> Maybe CSExp -> CSExp
forall a. a -> Maybe a -> a
fromMaybe [CSExp]
argexps_lib [Maybe CSExp]
argexps_mem_copies
fname' :: [Char]
fname' = [Char] -> [Char]
futharkFun (Name -> [Char]
nameToString Name
fname)
arg_types :: [CSType]
arg_types = (Param -> CSType) -> [Param] -> [CSType]
forall a b. (a -> b) -> [a] -> [b]
map (CSFunDefArg -> CSType
forall a b. (a, b) -> a
fst (CSFunDefArg -> CSType)
-> (Param -> CSFunDefArg) -> Param -> CSType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Param -> CSFunDefArg
compileTypedInput) [Param]
inputs
inputs' :: [CSFunDefArg]
inputs' = [CSType] -> [[Char]] -> [CSFunDefArg]
forall a b. [a] -> [b] -> [(a, b)]
zip [CSType]
arg_types ((ExternalValue -> [Char]) -> [ExternalValue] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ExternalValue -> [Char]
extValueDescName [ExternalValue]
args)
output_type :: CSType
output_type = [CSType] -> CSType
tupleOrSingleEntryT [CSType]
output_types
call_lib :: [CSStmt]
call_lib = [CSExp -> CSExp -> CSStmt
Reassign CSExp
funTuple (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall [Char]
fname' [CSExp]
argexps_lib]
call_bin :: [CSStmt]
call_bin = [CSExp -> CSExp -> CSStmt
Reassign CSExp
funTuple (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall [Char]
fname' [CSExp]
argexps_bin]
prepareIn' :: [CSStmt]
prepareIn' = [CSStmt]
prepareIn [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt]
mem_copy_inits [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt]
sizeDecls
([Char], [CSFunDefArg], CSType, [CSStmt], [CSStmt], [CSStmt],
[CSStmt], [(ExternalValue, CSExp)], [CSStmt])
-> CompilerM
op
s
([Char], [CSFunDefArg], CSType, [CSStmt], [CSStmt], [CSStmt],
[CSStmt], [(ExternalValue, CSExp)], [CSStmt])
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> [Char]
nameToString Name
fname, [CSFunDefArg]
inputs', CSType
output_type,
[CSStmt]
prepareIn', [CSStmt]
call_lib, [CSStmt]
call_bin, [CSStmt]
prepareOut,
[ExternalValue] -> [CSExp] -> [(ExternalValue, CSExp)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ExternalValue]
results [CSExp]
res, [CSStmt]
prepare_run)
where liftMaybe :: (Maybe a, b) -> Maybe (a, b)
liftMaybe (Just a
a, b
b) = (a, b) -> Maybe (a, b)
forall a. a -> Maybe a
Just (a
a,b
b)
liftMaybe (Maybe a, b)
_ = Maybe (a, b)
forall a. Maybe a
Nothing
initCopy :: (CSExp, Param) -> CSStmt
initCopy (CSExp
varName, Imp.MemParam VName
_ Space
space) = CSExp -> Space -> CSStmt
declMem' CSExp
varName Space
space
initCopy (CSExp, Param)
_ = CSStmt
Pass
valueDescFun :: ValueDesc -> CompilerM op s ()
valueDescFun (Imp.ArrayValue VName
mem Space
Imp.DefaultSpace PrimType
_ Signedness
_ [DimSize]
_) =
CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
stm (CSStmt -> CompilerM op s ()) -> CSStmt -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ CSExp -> CSExp -> CSStmt
Assign ([Char] -> CSExp
Var ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ VName -> [Char]
compileName VName
mem [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_nbytes") ([Char] -> CSExp
Var ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ VName -> [Char]
compileName VName
mem [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".Length")
valueDescFun (Imp.ArrayValue VName
mem (Imp.Space [Char]
_) PrimType
bt Signedness
_ [DimSize]
dims) =
CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
stm (CSStmt -> CompilerM op s ()) -> CSStmt -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ CSExp -> CSExp -> CSStmt
Assign ([Char] -> CSExp
Var ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ VName -> [Char]
compileName VName
mem [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_nbytes") (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ (DimSize -> CSExp -> CSExp) -> CSExp -> [DimSize] -> CSExp
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ([Char] -> CSExp -> CSExp -> CSExp
BinOp [Char]
"*" (CSExp -> CSExp -> CSExp)
-> (DimSize -> CSExp) -> DimSize -> CSExp -> CSExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DimSize -> CSExp
compileDim) (CSType -> CSExp
sizeOf (CSType -> CSExp) -> CSType -> CSExp
forall a b. (a -> b) -> a -> b
$ PrimType -> CSType
compilePrimTypeToAST PrimType
bt) [DimSize]
dims
valueDescFun ValueDesc
_ = CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
stm CSStmt
Pass
declsfunction :: ExternalValue -> CompilerM op s ()
declsfunction (Imp.TransparentValue ValueDesc
v) = ValueDesc -> CompilerM op s ()
forall op s. ValueDesc -> CompilerM op s ()
valueDescFun ValueDesc
v
declsfunction (Imp.OpaqueValue [Char]
_ [ValueDesc]
vs) = (ValueDesc -> CompilerM op s ())
-> [ValueDesc] -> CompilerM op s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ValueDesc -> CompilerM op s ()
forall op s. ValueDesc -> CompilerM op s ()
valueDescFun [ValueDesc]
vs
copyMemoryDefaultSpace :: CSExp -> CSExp -> CSExp -> CSExp -> CSExp ->
CompilerM op s ()
copyMemoryDefaultSpace :: CSExp -> CSExp -> CSExp -> CSExp -> CSExp -> CompilerM op s ()
copyMemoryDefaultSpace CSExp
destmem CSExp
destidx CSExp
srcmem CSExp
srcidx CSExp
nbytes =
CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
stm (CSStmt -> CompilerM op s ()) -> CSStmt -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"Buffer.BlockCopy" [ CSExp
srcmem, CSExp
srcidx
, CSExp
destmem, CSExp
destidx
, CSExp
nbytes]
compileEntryFun :: [CSStmt] -> (Name, Imp.Function op)
-> CompilerM op s CSFunDef
compileEntryFun :: [CSStmt] -> (Name, Function op) -> CompilerM op s CSFunDef
compileEntryFun [CSStmt]
pre_timing entry :: (Name, Function op)
entry@(Name
_,Imp.Function Bool
_ [Param]
outputs [Param]
_ Code op
_ [ExternalValue]
results [ExternalValue]
args) = do
let params :: [CSFunDefArg]
params = (ExternalValue -> CSFunDefArg) -> [ExternalValue] -> [CSFunDefArg]
forall a b. (a -> b) -> [a] -> [b]
map (ExternalValue -> CSType
getType (ExternalValue -> CSType)
-> (ExternalValue -> [Char]) -> ExternalValue -> CSFunDefArg
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ExternalValue -> [Char]
extValueDescName) [ExternalValue]
args
let outputType :: CSType
outputType = [CSType] -> CSType
tupleOrSingleEntryT ([CSType] -> CSType) -> [CSType] -> CSType
forall a b. (a -> b) -> a -> b
$ (ExternalValue -> CSType) -> [ExternalValue] -> [CSType]
forall a b. (a -> b) -> [a] -> [b]
map ExternalValue -> CSType
getType [ExternalValue]
results
([Char]
fname', [CSFunDefArg]
_, CSType
_, [CSStmt]
prepareIn, [CSStmt]
body_lib, [CSStmt]
_, [CSStmt]
prepareOut, [(ExternalValue, CSExp)]
res, [CSStmt]
_) <- (Name, Function op)
-> CompilerM
op
s
([Char], [CSFunDefArg], CSType, [CSStmt], [CSStmt], [CSStmt],
[CSStmt], [(ExternalValue, CSExp)], [CSStmt])
forall op s.
(Name, Function op)
-> CompilerM
op
s
([Char], [CSFunDefArg], CSType, [CSStmt], [CSStmt], [CSStmt],
[CSStmt], [(ExternalValue, CSExp)], [CSStmt])
prepareEntry (Name, Function op)
entry
let ret :: CSStmt
ret = CSExp -> CSStmt
Return (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [CSExp] -> CSExp
tupleOrSingleEntry ([CSExp] -> CSExp) -> [CSExp] -> CSExp
forall a b. (a -> b) -> a -> b
$ ((ExternalValue, CSExp) -> CSExp)
-> [(ExternalValue, CSExp)] -> [CSExp]
forall a b. (a -> b) -> [a] -> [b]
map (ExternalValue, CSExp) -> CSExp
forall a b. (a, b) -> b
snd [(ExternalValue, CSExp)]
res
let outputDecls :: [CSStmt]
outputDecls = (Param -> CSStmt) -> [Param] -> [CSStmt]
forall a b. (a -> b) -> [a] -> [b]
map Param -> CSStmt
getDefaultDecl [Param]
outputs
do_run :: [CSStmt]
do_run = [CSStmt]
body_lib [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt]
pre_timing
([CSStmt]
do_run_with_timing, CSStmt
close_runtime_file) <- [CSStmt] -> CompilerM op s ([CSStmt], CSStmt)
forall s op. [CSStmt] -> CompilerM s op ([CSStmt], CSStmt)
addTiming [CSStmt]
do_run
let do_warmup_run :: CSStmt
do_warmup_run = CSExp -> [CSStmt] -> [CSStmt] -> CSStmt
If ([Char] -> CSExp
Var [Char]
"DoWarmupRun") [CSStmt]
do_run []
do_num_runs :: CSStmt
do_num_runs = [Char] -> CSExp -> [CSStmt] -> CSStmt
For [Char]
"i" ([Char] -> CSExp
Var [Char]
"NumRuns") [CSStmt]
do_run_with_timing
CSFunDef -> CompilerM op s CSFunDef
forall (m :: * -> *) a. Monad m => a -> m a
return (CSFunDef -> CompilerM op s CSFunDef)
-> CSFunDef -> CompilerM op s CSFunDef
forall a b. (a -> b) -> a -> b
$ [Char] -> CSType -> [CSFunDefArg] -> [CSStmt] -> CSFunDef
Def [Char]
fname' CSType
outputType [CSFunDefArg]
params ([CSStmt] -> CSFunDef) -> [CSStmt] -> CSFunDef
forall a b. (a -> b) -> a -> b
$
[CSStmt]
prepareIn [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt]
outputDecls [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt
do_warmup_run, CSStmt
do_num_runs, CSStmt
close_runtime_file] [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt]
prepareOut [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt
ret]
where getType :: Imp.ExternalValue -> CSType
getType :: ExternalValue -> CSType
getType (Imp.OpaqueValue [Char]
_ [ValueDesc]
valueDescs) =
let valueDescs' :: [CSType]
valueDescs' = (ValueDesc -> CSType) -> [ValueDesc] -> [CSType]
forall a b. (a -> b) -> [a] -> [b]
map ValueDesc -> CSType
getType' [ValueDesc]
valueDescs
in CSComp -> CSType
Composite (CSComp -> CSType) -> CSComp -> CSType
forall a b. (a -> b) -> a -> b
$ [CSType] -> CSComp
SystemTupleT [CSType]
valueDescs'
getType (Imp.TransparentValue ValueDesc
valueDesc) =
ValueDesc -> CSType
getType' ValueDesc
valueDesc
getType' :: Imp.ValueDesc -> CSType
getType' :: ValueDesc -> CSType
getType' (Imp.ScalarValue PrimType
primtype Signedness
signedness VName
_) =
PrimType -> Signedness -> CSType
compilePrimTypeToASText PrimType
primtype Signedness
signedness
getType' (Imp.ArrayValue VName
_ Space
_ PrimType
primtype Signedness
signedness [DimSize]
_) =
let t :: CSType
t = PrimType -> Signedness -> CSType
compilePrimTypeToASText PrimType
primtype Signedness
signedness
in CSComp -> CSType
Composite (CSComp -> CSType) -> CSComp -> CSType
forall a b. (a -> b) -> a -> b
$ [CSType] -> CSComp
SystemTupleT [CSComp -> CSType
Composite (CSComp -> CSType) -> CSComp -> CSType
forall a b. (a -> b) -> a -> b
$ CSType -> CSComp
ArrayT CSType
t, CSComp -> CSType
Composite (CSComp -> CSType) -> CSComp -> CSType
forall a b. (a -> b) -> a -> b
$ CSType -> CSComp
ArrayT (CSType -> CSComp) -> CSType -> CSComp
forall a b. (a -> b) -> a -> b
$ CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int64T]
callEntryFun :: [CSStmt] -> (Name, Imp.Function op)
-> CompilerM op s (CSFunDef, String, CSExp)
callEntryFun :: [CSStmt]
-> (Name, Function op) -> CompilerM op s (CSFunDef, [Char], CSExp)
callEntryFun [CSStmt]
pre_timing entry :: (Name, Function op)
entry@(Name
fname, Imp.Function Bool
_ [Param]
outputs [Param]
_ Code op
_ [ExternalValue]
_ [ExternalValue]
decl_args) =
if (ExternalValue -> Bool) -> [ExternalValue] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ExternalValue -> Bool
isOpaque [ExternalValue]
decl_args then
(CSFunDef, [Char], CSExp)
-> CompilerM op s (CSFunDef, [Char], CSExp)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> CSType -> [CSFunDefArg] -> [CSStmt] -> CSFunDef
Def [Char]
fname' CSType
VoidT [] [CSStmt
exitException], Name -> [Char]
nameToString Name
fname, [Char] -> CSExp
Var [Char]
fname')
else do
([Char]
_, [CSFunDefArg]
_, CSType
_, [CSStmt]
prepare_in, [CSStmt]
_, [CSStmt]
body_bin, [CSStmt]
prepare_out, [(ExternalValue, CSExp)]
res, [CSStmt]
prepare_run) <- (Name, Function op)
-> CompilerM
op
s
([Char], [CSFunDefArg], CSType, [CSStmt], [CSStmt], [CSStmt],
[CSStmt], [(ExternalValue, CSExp)], [CSStmt])
forall op s.
(Name, Function op)
-> CompilerM
op
s
([Char], [CSFunDefArg], CSType, [CSStmt], [CSStmt], [CSStmt],
[CSStmt], [(ExternalValue, CSExp)], [CSStmt])
prepareEntry (Name, Function op)
entry
let str_input :: [CSStmt]
str_input = (ExternalValue -> CSStmt) -> [ExternalValue] -> [CSStmt]
forall a b. (a -> b) -> [a] -> [b]
map ExternalValue -> CSStmt
readInput [ExternalValue]
decl_args
end_of_input :: [CSStmt]
end_of_input = [CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"EndOfInput" [[Char] -> CSExp
String ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
forall a. Pretty a => a -> [Char]
pretty Name
fname]]
let outputDecls :: [CSStmt]
outputDecls = (Param -> CSStmt) -> [Param] -> [CSStmt]
forall a b. (a -> b) -> [a] -> [b]
map Param -> CSStmt
getDefaultDecl [Param]
outputs
exitcall :: [CSStmt]
exitcall = [
CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"Console.Error.WriteLine" [[Char] -> [CSExp] -> CSExp
formatString [Char]
"Assertion.{0} failed" [[Char] -> CSExp
Var [Char]
"e"]]
, CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"Environment.Exit" [Integer -> CSExp
Integer Integer
1]
]
except' :: CSExcept
except' = CSExp -> [CSStmt] -> CSExcept
Catch ([Char] -> CSExp
Var [Char]
"Exception") [CSStmt]
exitcall
do_run :: [CSStmt]
do_run = [CSStmt]
body_bin [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt]
pre_timing
([CSStmt]
do_run_with_timing, CSStmt
close_runtime_file) <- [CSStmt] -> CompilerM op s ([CSStmt], CSStmt)
forall s op. [CSStmt] -> CompilerM s op ([CSStmt], CSStmt)
addTiming [CSStmt]
do_run
let maybe_free :: [CSStmt]
maybe_free =
[CSExp -> [CSStmt] -> [CSStmt] -> CSStmt
If ([Char] -> CSExp -> CSExp -> CSExp
BinOp [Char]
"<" ([Char] -> CSExp
Var [Char]
"i") ([Char] -> CSExp -> CSExp -> CSExp
BinOp [Char]
"-" ([Char] -> CSExp
Var [Char]
"NumRuns") (Integer -> CSExp
Integer Integer
1)))
[CSStmt]
prepare_out []]
do_warmup_run :: CSStmt
do_warmup_run =
CSExp -> [CSStmt] -> [CSStmt] -> CSStmt
If ([Char] -> CSExp
Var [Char]
"DoWarmupRun") ([CSStmt]
prepare_run [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt]
do_run [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt]
prepare_out) []
do_num_runs :: CSStmt
do_num_runs =
[Char] -> CSExp -> [CSStmt] -> CSStmt
For [Char]
"i" ([Char] -> CSExp
Var [Char]
"NumRuns") ([CSStmt]
prepare_run [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt]
do_run_with_timing [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt]
maybe_free)
[CSStmt]
str_output <- [(ExternalValue, CSExp)] -> CompilerM op s [CSStmt]
forall op s. [(ExternalValue, CSExp)] -> CompilerM op s [CSStmt]
printValue [(ExternalValue, CSExp)]
res
(CSFunDef, [Char], CSExp)
-> CompilerM op s (CSFunDef, [Char], CSExp)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> CSType -> [CSFunDefArg] -> [CSStmt] -> CSFunDef
Def [Char]
fname' CSType
VoidT [] ([CSStmt] -> CSFunDef) -> [CSStmt] -> CSFunDef
forall a b. (a -> b) -> a -> b
$
[CSStmt]
str_input [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt]
end_of_input [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt]
prepare_in [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++ [CSStmt]
outputDecls [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++
[[CSStmt] -> [CSExcept] -> CSStmt
Try [CSStmt
do_warmup_run, CSStmt
do_num_runs] [CSExcept
except']] [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++
[CSStmt
close_runtime_file] [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++
[CSStmt]
str_output,
Name -> [Char]
nameToString Name
fname,
[Char] -> CSExp
Var [Char]
fname')
where fname' :: [Char]
fname' = [Char]
"entry_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
nameToString Name
fname
isOpaque :: ExternalValue -> Bool
isOpaque Imp.TransparentValue{} = Bool
False
isOpaque ExternalValue
_ = Bool
True
exitException :: CSStmt
exitException = CSExp -> CSStmt
Throw (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleInitClass [Char]
"Exception" [[Char] -> CSExp
String ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ [Char]
"The function " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
nameToString Name
fname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is not available as an entry function."]
addTiming :: [CSStmt] -> CompilerM s op ([CSStmt], CSStmt)
addTiming :: [CSStmt] -> CompilerM s op ([CSStmt], CSStmt)
addTiming [CSStmt]
statements = do
CSStmt
syncFun <- (CompilerEnv s op -> CSStmt) -> CompilerM s op CSStmt
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks CompilerEnv s op -> CSStmt
forall op s. CompilerEnv op s -> CSStmt
envSyncFun
([CSStmt], CSStmt) -> CompilerM s op ([CSStmt], CSStmt)
forall (m :: * -> *) a. Monad m => a -> m a
return ([ CSExp -> CSExp -> CSStmt
Assign ([Char] -> CSExp
Var [Char]
"StopWatch") (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleInitClass [Char]
"Stopwatch" []
, CSStmt
syncFun
, CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"StopWatch.Start" [] ] [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++
[CSStmt]
statements [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++
[ CSStmt
syncFun
, CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"StopWatch.Stop" []
, CSExp -> CSExp -> CSStmt
Assign ([Char] -> CSExp
Var [Char]
"timeElapsed") (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ CSExp -> CSExp
asMicroseconds ([Char] -> CSExp
Var [Char]
"StopWatch")
, CSExp -> [CSStmt] -> [CSStmt] -> CSStmt
If (CSExp -> CSExp
not_null ([Char] -> CSExp
Var [Char]
"RuntimeFile")) [CSStmt
print_runtime] []
]
, CSExp -> [CSStmt] -> [CSStmt] -> CSStmt
If (CSExp -> CSExp
not_null ([Char] -> CSExp
Var [Char]
"RuntimeFile")) [
CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"RuntimeFileWriter.Close" [] ,
CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"RuntimeFile.Close" []
] []
)
where print_runtime :: CSStmt
print_runtime = CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"RuntimeFileWriter.WriteLine" [ CSExp -> [Char] -> [CSExp] -> CSExp
callMethod ([Char] -> CSExp
Var [Char]
"timeElapsed") [Char]
"ToString" [] ]
not_null :: CSExp -> CSExp
not_null CSExp
var = [Char] -> CSExp -> CSExp -> CSExp
BinOp [Char]
"!=" CSExp
var CSExp
Null
asMicroseconds :: CSExp -> CSExp
asMicroseconds CSExp
watch =
[Char] -> CSExp -> CSExp -> CSExp
BinOp [Char]
"/" (CSExp -> [Char] -> CSExp
Field CSExp
watch [Char]
"ElapsedTicks")
([Char] -> CSExp -> CSExp -> CSExp
BinOp [Char]
"/" (CSExp -> [Char] -> CSExp
Field ([Char] -> CSExp
Var [Char]
"TimeSpan") [Char]
"TicksPerMillisecond") (Integer -> CSExp
Integer Integer
1000))
compileUnOp :: Imp.UnOp -> String
compileUnOp :: UnOp -> [Char]
compileUnOp UnOp
op =
case UnOp
op of
UnOp
Not -> [Char]
"!"
Complement{} -> [Char]
"~"
Abs{} -> [Char]
"Math.Abs"
FAbs{} -> [Char]
"Math.Abs"
SSignum{} -> [Char]
"ssignum"
USignum{} -> [Char]
"usignum"
compileBinOpLike :: Monad m =>
Imp.Exp -> Imp.Exp
-> CompilerM op s (CSExp, CSExp, String -> m CSExp)
compileBinOpLike :: Exp -> Exp -> CompilerM op s (CSExp, CSExp, [Char] -> m CSExp)
compileBinOpLike Exp
x Exp
y = do
CSExp
x' <- Exp -> CompilerM op s CSExp
forall op s. Exp -> CompilerM op s CSExp
compileExp Exp
x
CSExp
y' <- Exp -> CompilerM op s CSExp
forall op s. Exp -> CompilerM op s CSExp
compileExp Exp
y
let simple :: [Char] -> m CSExp
simple [Char]
s = CSExp -> m CSExp
forall (m :: * -> *) a. Monad m => a -> m a
return (CSExp -> m CSExp) -> CSExp -> m CSExp
forall a b. (a -> b) -> a -> b
$ [Char] -> CSExp -> CSExp -> CSExp
BinOp [Char]
s CSExp
x' CSExp
y'
(CSExp, CSExp, [Char] -> m CSExp)
-> CompilerM op s (CSExp, CSExp, [Char] -> m CSExp)
forall (m :: * -> *) a. Monad m => a -> m a
return (CSExp
x', CSExp
y', [Char] -> m CSExp
forall (m :: * -> *). Monad m => [Char] -> m CSExp
simple)
compilePrimType :: PrimType -> String
compilePrimType :: PrimType -> [Char]
compilePrimType PrimType
t =
case PrimType
t of
IntType IntType
Int8 -> [Char]
"sbyte"
IntType IntType
Int16 -> [Char]
"short"
IntType IntType
Int32 -> [Char]
"int"
IntType IntType
Int64 -> [Char]
"long"
FloatType FloatType
Float32 -> [Char]
"float"
FloatType FloatType
Float64 -> [Char]
"double"
PrimType
Imp.Bool -> [Char]
"bool"
PrimType
Cert -> [Char]
"bool"
compilePrimTypeExt :: PrimType -> Imp.Signedness -> String
compilePrimTypeExt :: PrimType -> Signedness -> [Char]
compilePrimTypeExt PrimType
t Signedness
ept =
case (PrimType
t, Signedness
ept) of
(IntType IntType
Int8, Signedness
Imp.TypeUnsigned) -> [Char]
"byte"
(IntType IntType
Int16, Signedness
Imp.TypeUnsigned) -> [Char]
"ushort"
(IntType IntType
Int32, Signedness
Imp.TypeUnsigned) -> [Char]
"uint"
(IntType IntType
Int64, Signedness
Imp.TypeUnsigned) -> [Char]
"ulong"
(IntType IntType
Int8, Signedness
_) -> [Char]
"sbyte"
(IntType IntType
Int16, Signedness
_) -> [Char]
"short"
(IntType IntType
Int32, Signedness
_) -> [Char]
"int"
(IntType IntType
Int64, Signedness
_) -> [Char]
"long"
(FloatType FloatType
Float32, Signedness
_) -> [Char]
"float"
(FloatType FloatType
Float64, Signedness
_) -> [Char]
"double"
(PrimType
Imp.Bool, Signedness
_) -> [Char]
"bool"
(PrimType
Cert, Signedness
_) -> [Char]
"byte"
compileTypecastExt :: PrimType -> Imp.Signedness -> (CSExp -> CSExp)
compileTypecastExt :: PrimType -> Signedness -> CSExp -> CSExp
compileTypecastExt PrimType
t Signedness
ept =
let t' :: CSType
t' = case (PrimType
t, Signedness
ept) of
(IntType IntType
Int8 , Signedness
Imp.TypeUnsigned)-> CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSUInt -> CSPrim
CSUInt CSUInt
UInt8T
(IntType IntType
Int16 , Signedness
Imp.TypeUnsigned)-> CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSUInt -> CSPrim
CSUInt CSUInt
UInt16T
(IntType IntType
Int32 , Signedness
Imp.TypeUnsigned)-> CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSUInt -> CSPrim
CSUInt CSUInt
UInt32T
(IntType IntType
Int64 , Signedness
Imp.TypeUnsigned)-> CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSUInt -> CSPrim
CSUInt CSUInt
UInt64T
(IntType IntType
Int8 , Signedness
_)-> CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int8T
(IntType IntType
Int16 , Signedness
_)-> CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int16T
(IntType IntType
Int32 , Signedness
_)-> CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int32T
(IntType IntType
Int64 , Signedness
_)-> CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int64T
(FloatType FloatType
Float32, Signedness
_)-> CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSFloat -> CSPrim
CSFloat CSFloat
FloatT
(FloatType FloatType
Float64, Signedness
_)-> CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSFloat -> CSPrim
CSFloat CSFloat
DoubleT
(PrimType
Imp.Bool , Signedness
_)-> CSPrim -> CSType
Primitive CSPrim
BoolT
(PrimType
Cert, Signedness
_)-> CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int8T
in CSType -> CSExp -> CSExp
Cast CSType
t'
compileTypecast :: PrimType -> (CSExp -> CSExp)
compileTypecast :: PrimType -> CSExp -> CSExp
compileTypecast PrimType
t =
let t' :: CSType
t' = case PrimType
t of
IntType IntType
Int8 -> CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int8T
IntType IntType
Int16 -> CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int16T
IntType IntType
Int32 -> CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int32T
IntType IntType
Int64 -> CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int64T
FloatType FloatType
Float32 -> CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSFloat -> CSPrim
CSFloat CSFloat
FloatT
FloatType FloatType
Float64 -> CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSFloat -> CSPrim
CSFloat CSFloat
DoubleT
PrimType
Imp.Bool -> CSPrim -> CSType
Primitive CSPrim
BoolT
PrimType
Cert -> CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int8T
in CSType -> CSExp -> CSExp
Cast CSType
t'
compilePrimValue :: Imp.PrimValue -> CSExp
compilePrimValue :: PrimValue -> CSExp
compilePrimValue (IntValue (Int8Value Int8
v)) =
CSType -> CSExp -> CSExp
Cast (CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int8T) (CSExp -> CSExp) -> CSExp -> CSExp
forall a b. (a -> b) -> a -> b
$ Integer -> CSExp
Integer (Integer -> CSExp) -> Integer -> CSExp
forall a b. (a -> b) -> a -> b
$ Int8 -> Integer
forall a. Integral a => a -> Integer
toInteger Int8
v
compilePrimValue (IntValue (Int16Value Int16
v)) =
CSType -> CSExp -> CSExp
Cast (CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int16T) (CSExp -> CSExp) -> CSExp -> CSExp
forall a b. (a -> b) -> a -> b
$ Integer -> CSExp
Integer (Integer -> CSExp) -> Integer -> CSExp
forall a b. (a -> b) -> a -> b
$ Int16 -> Integer
forall a. Integral a => a -> Integer
toInteger Int16
v
compilePrimValue (IntValue (Int32Value Int32
v)) =
CSType -> CSExp -> CSExp
Cast (CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int32T) (CSExp -> CSExp) -> CSExp -> CSExp
forall a b. (a -> b) -> a -> b
$ Integer -> CSExp
Integer (Integer -> CSExp) -> Integer -> CSExp
forall a b. (a -> b) -> a -> b
$ Int32 -> Integer
forall a. Integral a => a -> Integer
toInteger Int32
v
compilePrimValue (IntValue (Int64Value Int64
v)) =
CSType -> CSExp -> CSExp
Cast (CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int64T) (CSExp -> CSExp) -> CSExp -> CSExp
forall a b. (a -> b) -> a -> b
$ Integer -> CSExp
Integer (Integer -> CSExp) -> Integer -> CSExp
forall a b. (a -> b) -> a -> b
$ Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger Int64
v
compilePrimValue (FloatValue (Float32Value Float
v))
| Float -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Float
v =
if Float
v Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0 then [Char] -> CSExp
Var [Char]
"Single.PositiveInfinity" else [Char] -> CSExp
Var [Char]
"Single.NegativeInfinity"
| Float -> Bool
forall a. RealFloat a => a -> Bool
isNaN Float
v =
[Char] -> CSExp
Var [Char]
"Single.NaN"
| Bool
otherwise = CSType -> CSExp -> CSExp
Cast (CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSFloat -> CSPrim
CSFloat CSFloat
FloatT) (Double -> CSExp
Float (Double -> CSExp) -> Double -> CSExp
forall a b. (a -> b) -> a -> b
$ Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (Rational -> Double) -> Rational -> Double
forall a b. (a -> b) -> a -> b
$ Float -> Rational
forall a. Real a => a -> Rational
toRational Float
v)
compilePrimValue (FloatValue (Float64Value Double
v))
| Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
v =
if Double
v Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 then [Char] -> CSExp
Var [Char]
"Double.PositiveInfinity" else [Char] -> CSExp
Var [Char]
"Double.NegativeInfinity"
| Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
v =
[Char] -> CSExp
Var [Char]
"Double.NaN"
| Bool
otherwise = CSType -> CSExp -> CSExp
Cast (CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSFloat -> CSPrim
CSFloat CSFloat
DoubleT) (Double -> CSExp
Float (Double -> CSExp) -> Double -> CSExp
forall a b. (a -> b) -> a -> b
$ Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (Rational -> Double) -> Rational -> Double
forall a b. (a -> b) -> a -> b
$ Double -> Rational
forall a. Real a => a -> Rational
toRational Double
v)
compilePrimValue (BoolValue Bool
v) = Bool -> CSExp
Bool Bool
v
compilePrimValue PrimValue
Checked = Bool -> CSExp
Bool Bool
True
compileExp :: Imp.Exp -> CompilerM op s CSExp
compileExp :: Exp -> CompilerM op s CSExp
compileExp (Imp.ValueExp PrimValue
v) = CSExp -> CompilerM op s CSExp
forall (m :: * -> *) a. Monad m => a -> m a
return (CSExp -> CompilerM op s CSExp) -> CSExp -> CompilerM op s CSExp
forall a b. (a -> b) -> a -> b
$ PrimValue -> CSExp
compilePrimValue PrimValue
v
compileExp (Imp.LeafExp (Imp.ScalarVar VName
vname) PrimType
_) =
VName -> CompilerM op s CSExp
forall op s. VName -> CompilerM op s CSExp
compileVar VName
vname
compileExp (Imp.LeafExp (Imp.SizeOf PrimType
t) PrimType
_) =
CSExp -> CompilerM op s CSExp
forall (m :: * -> *) a. Monad m => a -> m a
return (CSExp -> CompilerM op s CSExp) -> CSExp -> CompilerM op s CSExp
forall a b. (a -> b) -> a -> b
$ (PrimType -> CSExp -> CSExp
compileTypecast (PrimType -> CSExp -> CSExp) -> PrimType -> CSExp -> CSExp
forall a b. (a -> b) -> a -> b
$ IntType -> PrimType
IntType IntType
Int32) (Integer -> CSExp
Integer (Integer -> CSExp) -> Integer -> CSExp
forall a b. (a -> b) -> a -> b
$ PrimType -> Integer
forall a. Num a => PrimType -> a
primByteSize PrimType
t)
compileExp (Imp.LeafExp (Imp.Index VName
src (Imp.Count Exp
iexp) PrimType
restype (Imp.Space [Char]
space) Volatility
_) PrimType
_) =
CompilerM op s (CompilerM op s CSExp) -> CompilerM op s CSExp
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (CompilerM op s (CompilerM op s CSExp) -> CompilerM op s CSExp)
-> CompilerM op s (CompilerM op s CSExp) -> CompilerM op s CSExp
forall a b. (a -> b) -> a -> b
$ (CompilerEnv op s -> ReadScalar op s)
-> CompilerM op s (ReadScalar op s)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks CompilerEnv op s -> ReadScalar op s
forall op s. CompilerEnv op s -> ReadScalar op s
envReadScalar
CompilerM op s (ReadScalar op s)
-> CompilerM op s CSExp
-> CompilerM
op s (CSExp -> PrimType -> [Char] -> CompilerM op s CSExp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> VName -> CompilerM op s CSExp
forall op s. VName -> CompilerM op s CSExp
compileVar VName
src CompilerM
op s (CSExp -> PrimType -> [Char] -> CompilerM op s CSExp)
-> CompilerM op s CSExp
-> CompilerM op s (PrimType -> [Char] -> CompilerM op s CSExp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> CompilerM op s CSExp
forall op s. Exp -> CompilerM op s CSExp
compileExp Exp
iexp
CompilerM op s (PrimType -> [Char] -> CompilerM op s CSExp)
-> CompilerM op s PrimType
-> CompilerM op s ([Char] -> CompilerM op s CSExp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PrimType -> CompilerM op s PrimType
forall (f :: * -> *) a. Applicative f => a -> f a
pure PrimType
restype CompilerM op s ([Char] -> CompilerM op s CSExp)
-> CompilerM op s [Char] -> CompilerM op s (CompilerM op s CSExp)
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]
space
compileExp (Imp.LeafExp (Imp.Index VName
src (Imp.Count Exp
iexp) (IntType IntType
Int8) Space
_ Volatility
_) PrimType
_) = do
CSExp
src' <- VName -> CompilerM op s CSExp
forall op s. VName -> CompilerM op s CSExp
compileVar VName
src
CSExp
iexp' <- Exp -> CompilerM op s CSExp
forall op s. Exp -> CompilerM op s CSExp
compileExp Exp
iexp
CSExp -> CompilerM op s CSExp
forall (m :: * -> *) a. Monad m => a -> m a
return (CSExp -> CompilerM op s CSExp) -> CSExp -> CompilerM op s CSExp
forall a b. (a -> b) -> a -> b
$ CSType -> CSExp -> CSExp
Cast (CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int8T) (CSExp -> CSIdx -> CSExp
Index CSExp
src' (CSExp -> CSIdx
IdxExp CSExp
iexp'))
compileExp (Imp.LeafExp (Imp.Index VName
src (Imp.Count Exp
iexp) PrimType
bt Space
_ Volatility
_) PrimType
_) = do
CSExp
iexp' <- Exp -> CompilerM op s CSExp
forall op s. Exp -> CompilerM op s CSExp
compileExp Exp
iexp
let bt' :: [Char]
bt' = PrimType -> [Char]
compilePrimType PrimType
bt
iexp'' :: CSExp
iexp'' = [Char] -> CSExp -> CSExp -> CSExp
BinOp [Char]
"*" CSExp
iexp' (CSType -> CSExp
sizeOf (PrimType -> CSType
compilePrimTypeToAST PrimType
bt))
CSExp
src' <- VName -> CompilerM op s CSExp
forall op s. VName -> CompilerM op s CSExp
compileVar VName
src
CSExp -> CompilerM op s CSExp
forall (m :: * -> *) a. Monad m => a -> m a
return (CSExp -> CompilerM op s CSExp) -> CSExp -> CompilerM op s CSExp
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall ([Char]
"indexArray_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
bt') [CSExp
src', CSExp
iexp'']
compileExp (Imp.BinOpExp BinOp
op Exp
x Exp
y) = do
(CSExp
x', CSExp
y', [Char] -> CompilerM op s CSExp
simple) <- Exp
-> Exp
-> CompilerM op s (CSExp, CSExp, [Char] -> CompilerM op s CSExp)
forall (m :: * -> *) op s.
Monad m =>
Exp -> Exp -> CompilerM op s (CSExp, CSExp, [Char] -> m CSExp)
compileBinOpLike Exp
x Exp
y
case BinOp
op of
FAdd{} -> [Char] -> CompilerM op s CSExp
simple [Char]
"+"
FSub{} -> [Char] -> CompilerM op s CSExp
simple [Char]
"-"
FMul{} -> [Char] -> CompilerM op s CSExp
simple [Char]
"*"
FDiv{} -> [Char] -> CompilerM op s CSExp
simple [Char]
"/"
FMod{} -> [Char] -> CompilerM op s CSExp
simple [Char]
"%"
LogAnd{} -> [Char] -> CompilerM op s CSExp
simple [Char]
"&&"
LogOr{} -> [Char] -> CompilerM op s CSExp
simple [Char]
"||"
BinOp
_ -> CSExp -> CompilerM op s CSExp
forall (m :: * -> *) a. Monad m => a -> m a
return (CSExp -> CompilerM op s CSExp) -> CSExp -> CompilerM op s CSExp
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall (BinOp -> [Char]
forall a. Pretty a => a -> [Char]
pretty BinOp
op) [CSExp
x', CSExp
y']
compileExp (Imp.ConvOpExp ConvOp
conv Exp
x) = do
CSExp
x' <- Exp -> CompilerM op s CSExp
forall op s. Exp -> CompilerM op s CSExp
compileExp Exp
x
CSExp -> CompilerM op s CSExp
forall (m :: * -> *) a. Monad m => a -> m a
return (CSExp -> CompilerM op s CSExp) -> CSExp -> CompilerM op s CSExp
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall (ConvOp -> [Char]
forall a. Pretty a => a -> [Char]
pretty ConvOp
conv) [CSExp
x']
compileExp (Imp.CmpOpExp CmpOp
cmp Exp
x Exp
y) = do
(CSExp
x', CSExp
y', [Char] -> CompilerM op s CSExp
simple) <- Exp
-> Exp
-> CompilerM op s (CSExp, CSExp, [Char] -> CompilerM op s CSExp)
forall (m :: * -> *) op s.
Monad m =>
Exp -> Exp -> CompilerM op s (CSExp, CSExp, [Char] -> m CSExp)
compileBinOpLike Exp
x Exp
y
case CmpOp
cmp of
CmpEq{} -> [Char] -> CompilerM op s CSExp
simple [Char]
"=="
FCmpLt{} -> [Char] -> CompilerM op s CSExp
simple [Char]
"<"
FCmpLe{} -> [Char] -> CompilerM op s CSExp
simple [Char]
"<="
CmpOp
_ -> CSExp -> CompilerM op s CSExp
forall (m :: * -> *) a. Monad m => a -> m a
return (CSExp -> CompilerM op s CSExp) -> CSExp -> CompilerM op s CSExp
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall (CmpOp -> [Char]
forall a. Pretty a => a -> [Char]
pretty CmpOp
cmp) [CSExp
x', CSExp
y']
compileExp (Imp.UnOpExp UnOp
op Exp
exp1) =
[Char] -> CSExp -> CSExp
PreUnOp (UnOp -> [Char]
compileUnOp UnOp
op) (CSExp -> CSExp) -> CompilerM op s CSExp -> CompilerM op s CSExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> CompilerM op s CSExp
forall op s. Exp -> CompilerM op s CSExp
compileExp Exp
exp1
compileExp (Imp.FunExp [Char]
h [Exp]
args PrimType
_) =
[Char] -> [CSExp] -> CSExp
simpleCall ([Char] -> [Char]
futharkFun ([Char] -> [Char]
forall a. Pretty a => a -> [Char]
pretty [Char]
h)) ([CSExp] -> CSExp)
-> CompilerM op s [CSExp] -> CompilerM op s CSExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> CompilerM op s CSExp) -> [Exp] -> CompilerM op s [CSExp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Exp -> CompilerM op s CSExp
forall op s. Exp -> CompilerM op s CSExp
compileExp [Exp]
args
compileCode :: Imp.Code op -> CompilerM op s ()
compileCode :: Code op -> CompilerM op s ()
compileCode Imp.DebugPrint{} =
() -> CompilerM op s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
compileCode (Imp.Op op
op) =
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 -> OpCompiler op s)
-> CompilerM op s (OpCompiler op s)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks CompilerEnv op s -> OpCompiler op s
forall op s. CompilerEnv op s -> OpCompiler op s
envOpCompiler CompilerM op s (OpCompiler op s)
-> CompilerM op s op -> CompilerM op s (CompilerM op s ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> op -> CompilerM op s op
forall (f :: * -> *) a. Applicative f => a -> f a
pure op
op
compileCode (Imp.If Exp
cond Code op
tb Code op
fb) = do
CSExp
cond' <- Exp -> CompilerM op s CSExp
forall op s. Exp -> CompilerM op s CSExp
compileExp Exp
cond
[CSStmt]
tb' <- CompilerM op s () -> CompilerM op s [CSStmt]
forall op s. CompilerM op s () -> CompilerM op s [CSStmt]
blockScope (CompilerM op s () -> CompilerM op s [CSStmt])
-> CompilerM op s () -> CompilerM op s [CSStmt]
forall a b. (a -> b) -> a -> b
$ Code op -> CompilerM op s ()
forall op s. Code op -> CompilerM op s ()
compileCode Code op
tb
[CSStmt]
fb' <- CompilerM op s () -> CompilerM op s [CSStmt]
forall op s. CompilerM op s () -> CompilerM op s [CSStmt]
blockScope (CompilerM op s () -> CompilerM op s [CSStmt])
-> CompilerM op s () -> CompilerM op s [CSStmt]
forall a b. (a -> b) -> a -> b
$ Code op -> CompilerM op s ()
forall op s. Code op -> CompilerM op s ()
compileCode Code op
fb
CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
stm (CSStmt -> CompilerM op s ()) -> CSStmt -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ CSExp -> [CSStmt] -> [CSStmt] -> CSStmt
If CSExp
cond' [CSStmt]
tb' [CSStmt]
fb'
compileCode (Code op
c1 Imp.:>>: Code op
c2) = do
Code op -> CompilerM op s ()
forall op s. Code op -> CompilerM op s ()
compileCode Code op
c1
Code op -> CompilerM op s ()
forall op s. Code op -> CompilerM op s ()
compileCode Code op
c2
compileCode (Imp.While Exp
cond Code op
body) = do
CSExp
cond' <- Exp -> CompilerM op s CSExp
forall op s. Exp -> CompilerM op s CSExp
compileExp Exp
cond
[CSStmt]
body' <- CompilerM op s () -> CompilerM op s [CSStmt]
forall op s. CompilerM op s () -> CompilerM op s [CSStmt]
blockScope (CompilerM op s () -> CompilerM op s [CSStmt])
-> CompilerM op s () -> CompilerM op s [CSStmt]
forall a b. (a -> b) -> a -> b
$ Code op -> CompilerM op s ()
forall op s. Code op -> CompilerM op s ()
compileCode Code op
body
CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
stm (CSStmt -> CompilerM op s ()) -> CSStmt -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ CSExp -> [CSStmt] -> CSStmt
While CSExp
cond' [CSStmt]
body'
compileCode (Imp.For VName
i IntType
it Exp
bound Code op
body) = do
CSExp
bound' <- Exp -> CompilerM op s CSExp
forall op s. Exp -> CompilerM op s CSExp
compileExp Exp
bound
let i' :: [Char]
i' = VName -> [Char]
compileName VName
i
[CSStmt]
body' <- CompilerM op s () -> CompilerM op s [CSStmt]
forall op s. CompilerM op s () -> CompilerM op s [CSStmt]
blockScope (CompilerM op s () -> CompilerM op s [CSStmt])
-> CompilerM op s () -> CompilerM op s [CSStmt]
forall a b. (a -> b) -> a -> b
$ Code op -> CompilerM op s ()
forall op s. Code op -> CompilerM op s ()
compileCode Code op
body
[Char]
counter <- VName -> [Char]
forall a. Pretty a => a -> [Char]
pretty (VName -> [Char]) -> CompilerM op s VName -> CompilerM op s [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> CompilerM op s VName
forall (m :: * -> *). MonadFreshNames m => [Char] -> m VName
newVName [Char]
"counter"
[Char]
one <- VName -> [Char]
forall a. Pretty a => a -> [Char]
pretty (VName -> [Char]) -> CompilerM op s VName -> CompilerM op s [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> CompilerM op s VName
forall (m :: * -> *). MonadFreshNames m => [Char] -> m VName
newVName [Char]
"one"
CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
stm (CSStmt -> CompilerM op s ()) -> CSStmt -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ CSExp -> CSExp -> CSStmt
Assign ([Char] -> CSExp
Var [Char]
i') (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ PrimType -> CSExp -> CSExp
compileTypecast (IntType -> PrimType
IntType IntType
it) (Integer -> CSExp
Integer Integer
0)
CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
stm (CSStmt -> CompilerM op s ()) -> CSStmt -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ CSExp -> CSExp -> CSStmt
Assign ([Char] -> CSExp
Var [Char]
one) (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ PrimType -> CSExp -> CSExp
compileTypecast (IntType -> PrimType
IntType IntType
it) (Integer -> CSExp
Integer Integer
1)
CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
stm (CSStmt -> CompilerM op s ()) -> CSStmt -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ [Char] -> CSExp -> [CSStmt] -> CSStmt
For [Char]
counter CSExp
bound' ([CSStmt] -> CSStmt) -> [CSStmt] -> CSStmt
forall a b. (a -> b) -> a -> b
$ [CSStmt]
body' [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. [a] -> [a] -> [a]
++
[[Char] -> CSExp -> CSExp -> CSStmt
AssignOp [Char]
"+" ([Char] -> CSExp
Var [Char]
i') ([Char] -> CSExp
Var [Char]
one)]
compileCode (Imp.SetScalar VName
vname Exp
exp1) =
CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
stm (CSStmt -> CompilerM op s ())
-> CompilerM op s CSStmt -> CompilerM op s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CSExp -> CSExp -> CSStmt
Reassign (CSExp -> CSExp -> CSStmt)
-> CompilerM op s CSExp -> CompilerM op s (CSExp -> CSStmt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VName -> CompilerM op s CSExp
forall op s. VName -> CompilerM op s CSExp
compileVar VName
vname CompilerM op s (CSExp -> CSStmt)
-> CompilerM op s CSExp -> CompilerM op s CSStmt
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> CompilerM op s CSExp
forall op s. Exp -> CompilerM op s CSExp
compileExp Exp
exp1
compileCode (Imp.DeclareMem VName
v Space
space) = VName -> Space -> CompilerM op s ()
forall op s. VName -> Space -> CompilerM op s ()
declMem VName
v Space
space
compileCode (Imp.DeclareScalar VName
v Volatility
_ PrimType
Cert) =
CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
stm (CSStmt -> CompilerM op s ())
-> CompilerM op s CSStmt -> CompilerM op s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CSExp -> CSExp -> CSStmt
Assign (CSExp -> CSExp -> CSStmt)
-> CompilerM op s CSExp -> CompilerM op s (CSExp -> CSStmt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VName -> CompilerM op s CSExp
forall op s. VName -> CompilerM op s CSExp
compileVar VName
v CompilerM op s (CSExp -> CSStmt)
-> CompilerM op s CSExp -> CompilerM op s CSStmt
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CSExp -> CompilerM op s CSExp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> CSExp
Bool Bool
True)
compileCode (Imp.DeclareScalar VName
v Volatility
_ PrimType
t) =
CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
stm (CSStmt -> CompilerM op s ())
-> CompilerM op s CSStmt -> CompilerM op s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CSType -> CSExp -> Maybe CSExp -> CSStmt
AssignTyped CSType
t' (CSExp -> Maybe CSExp -> CSStmt)
-> CompilerM op s CSExp -> CompilerM op s (Maybe CSExp -> CSStmt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VName -> CompilerM op s CSExp
forall op s. VName -> CompilerM op s CSExp
compileVar VName
v CompilerM op s (Maybe CSExp -> CSStmt)
-> CompilerM op s (Maybe CSExp) -> CompilerM op s CSStmt
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe CSExp -> CompilerM op s (Maybe CSExp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CSExp
forall a. Maybe a
Nothing
where t' :: CSType
t' = PrimType -> CSType
compilePrimTypeToAST PrimType
t
compileCode (Imp.DeclareArray VName
name (Space [Char]
space) PrimType
t ArrayContents
vs) =
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 -> StaticArray op s)
-> CompilerM op s (StaticArray op s)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks CompilerEnv op s -> StaticArray op s
forall op s. CompilerEnv op s -> StaticArray op s
envStaticArray CompilerM op s (StaticArray op s)
-> CompilerM op s VName
-> CompilerM
op s ([Char] -> PrimType -> ArrayContents -> CompilerM op s ())
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
name CompilerM
op s ([Char] -> PrimType -> ArrayContents -> CompilerM op s ())
-> CompilerM op s [Char]
-> CompilerM op s (PrimType -> ArrayContents -> 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]
space CompilerM op s (PrimType -> ArrayContents -> CompilerM op s ())
-> CompilerM op s PrimType
-> CompilerM op s (ArrayContents -> CompilerM op s ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PrimType -> CompilerM op s PrimType
forall (f :: * -> *) a. Applicative f => a -> f a
pure PrimType
t CompilerM op s (ArrayContents -> CompilerM op s ())
-> CompilerM op s ArrayContents
-> CompilerM op s (CompilerM op s ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ArrayContents -> CompilerM op s ArrayContents
forall (f :: * -> *) a. Applicative f => a -> f a
pure ArrayContents
vs
compileCode (Imp.DeclareArray VName
name Space
_ PrimType
t ArrayContents
vs) = do
CSExp
name' <- VName -> CompilerM op s CSExp
forall op s. VName -> CompilerM op s CSExp
compileVar VName
name
[CSStmt] -> CompilerM op s ()
forall op s. [CSStmt] -> CompilerM op s ()
stms [CSExp -> CSExp -> CSStmt
Assign ([Char] -> CSExp
Var ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ [Char]
"init_"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++VName -> [Char]
compileName VName
name) (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$
[Char] -> [CSExp] -> CSExp
simpleCall [Char]
"unwrapArray"
[
case ArrayContents
vs of Imp.ArrayValues [PrimValue]
vs' ->
CSType -> Either Int [CSExp] -> CSExp
CreateArray (PrimType -> CSType
compilePrimTypeToAST PrimType
t) (Either Int [CSExp] -> CSExp) -> Either Int [CSExp] -> CSExp
forall a b. (a -> b) -> a -> b
$ [CSExp] -> Either Int [CSExp]
forall a b. b -> Either a b
Right ([CSExp] -> Either Int [CSExp]) -> [CSExp] -> Either Int [CSExp]
forall a b. (a -> b) -> a -> b
$ (PrimValue -> CSExp) -> [PrimValue] -> [CSExp]
forall a b. (a -> b) -> [a] -> [b]
map PrimValue -> CSExp
compilePrimValue [PrimValue]
vs'
Imp.ArrayZeros Int
n ->
CSType -> Either Int [CSExp] -> CSExp
CreateArray (PrimType -> CSType
compilePrimTypeToAST PrimType
t) (Either Int [CSExp] -> CSExp) -> Either Int [CSExp] -> CSExp
forall a b. (a -> b) -> a -> b
$ Int -> Either Int [CSExp]
forall a b. a -> Either a b
Left Int
n
, [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"sizeof" [[Char] -> CSExp
Var ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ PrimType -> [Char]
compilePrimType PrimType
t]
]
, CSExp -> CSExp -> CSStmt
Assign CSExp
name' (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> CSExp
Var ([Char]
"init_"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++VName -> [Char]
compileName VName
name)
]
compileCode (Imp.Comment [Char]
s Code op
code) = do
[CSStmt]
code' <- CompilerM op s () -> CompilerM op s [CSStmt]
forall op s. CompilerM op s () -> CompilerM op s [CSStmt]
blockScope (CompilerM op s () -> CompilerM op s [CSStmt])
-> CompilerM op s () -> CompilerM op s [CSStmt]
forall a b. (a -> b) -> a -> b
$ Code op -> CompilerM op s ()
forall op s. Code op -> CompilerM op s ()
compileCode Code op
code
CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
stm (CSStmt -> CompilerM op s ()) -> CSStmt -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSStmt] -> CSStmt
Comment [Char]
s [CSStmt]
code'
compileCode (Imp.Assert Exp
e (Imp.ErrorMsg [ErrorMsgPart Exp]
parts) (SrcLoc
loc,[SrcLoc]
locs)) = do
CSExp
e' <- Exp -> CompilerM op s CSExp
forall op s. Exp -> CompilerM op s CSExp
compileExp Exp
e
let onPart :: (a, ErrorMsgPart Exp) -> CompilerM op s ([Char], CSExp)
onPart (a
i, Imp.ErrorString [Char]
s) = ([Char], CSExp) -> CompilerM op s ([Char], CSExp)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> [Char]
forall a. Show a => a -> [Char]
printFormatArg a
i, [Char] -> CSExp
String [Char]
s)
onPart (a
i, Imp.ErrorInt32 Exp
x) = (a -> [Char]
forall a. Show a => a -> [Char]
printFormatArg a
i,) (CSExp -> ([Char], CSExp))
-> CompilerM op s CSExp -> CompilerM op s ([Char], CSExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> CompilerM op s CSExp
forall op s. Exp -> CompilerM op s CSExp
compileExp Exp
x
([[Char]]
formatstrs, [CSExp]
formatargs) <- [([Char], CSExp)] -> ([[Char]], [CSExp])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([Char], CSExp)] -> ([[Char]], [CSExp]))
-> CompilerM op s [([Char], CSExp)]
-> CompilerM op s ([[Char]], [CSExp])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Integer, ErrorMsgPart Exp) -> CompilerM op s ([Char], CSExp))
-> [(Integer, ErrorMsgPart Exp)]
-> CompilerM op s [([Char], CSExp)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Integer, ErrorMsgPart Exp) -> CompilerM op s ([Char], CSExp)
forall a op s.
Show a =>
(a, ErrorMsgPart Exp) -> CompilerM op s ([Char], CSExp)
onPart ([Integer] -> [ErrorMsgPart Exp] -> [(Integer, ErrorMsgPart Exp)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Integer
0..] :: [Integer]) [ErrorMsgPart Exp]
parts)
CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
stm (CSStmt -> CompilerM op s ()) -> CSStmt -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ CSExp -> [CSExp] -> CSStmt
Assert CSExp
e' ([CSExp] -> CSStmt) -> [CSExp] -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> CSExp
String ([Char]
"Error: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Char]]
formatstrs [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
[Char]
"\n\nBacktrace:\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"{" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([CSExp] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CSExp]
formatargs) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"}") CSExp -> [CSExp] -> [CSExp]
forall a. a -> [a] -> [a]
:
([CSExp]
formatargs [CSExp] -> [CSExp] -> [CSExp]
forall a. [a] -> [a] -> [a]
++ [[Char] -> CSExp
String [Char]
stacktrace])
where stacktrace :: [Char]
stacktrace = Int -> [[Char]] -> [Char]
prettyStacktrace Int
0 ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ (SrcLoc -> [Char]) -> [SrcLoc] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map SrcLoc -> [Char]
forall a. Located a => a -> [Char]
locStr ([SrcLoc] -> [[Char]]) -> [SrcLoc] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ SrcLoc
locSrcLoc -> [SrcLoc] -> [SrcLoc]
forall a. a -> [a] -> [a]
:[SrcLoc]
locs
printFormatArg :: a -> [Char]
printFormatArg a
i = [Char]
"{" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
i [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"}"
compileCode (Imp.Call [VName]
dests Name
fname [Arg]
args) = do
[CSExp]
args' <- (Arg -> CompilerM op s CSExp) -> [Arg] -> CompilerM op s [CSExp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Arg -> CompilerM op s CSExp
forall op s. Arg -> CompilerM op s CSExp
compileArg [Arg]
args
CSExp
dests' <- [CSExp] -> CSExp
tupleOrSingle ([CSExp] -> CSExp)
-> CompilerM op s [CSExp] -> CompilerM op s CSExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (VName -> CompilerM op s CSExp)
-> [VName] -> CompilerM op s [CSExp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM VName -> CompilerM op s CSExp
forall op s. VName -> CompilerM op s CSExp
compileVar [VName]
dests
let fname' :: [Char]
fname' = [Char] -> [Char]
futharkFun (Name -> [Char]
forall a. Pretty a => a -> [Char]
pretty Name
fname)
call' :: CSExp
call' = [Char] -> [CSExp] -> CSExp
simpleCall [Char]
fname' [CSExp]
args'
CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
stm (CSStmt -> CompilerM op s ()) -> CSStmt -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ if [VName] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [VName]
dests
then CSExp -> CSStmt
Exp CSExp
call'
else CSExp -> CSExp -> CSStmt
Reassign CSExp
dests' CSExp
call'
where compileArg :: Arg -> CompilerM op s CSExp
compileArg (Imp.MemArg VName
m) = VName -> CompilerM op s CSExp
forall op s. VName -> CompilerM op s CSExp
compileVar VName
m
compileArg (Imp.ExpArg Exp
e) = Exp -> CompilerM op s CSExp
forall op s. Exp -> CompilerM op s CSExp
compileExp Exp
e
compileCode (Imp.SetMem VName
dest VName
src Space
DefaultSpace) =
CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
stm (CSStmt -> CompilerM op s ())
-> CompilerM op s CSStmt -> CompilerM op s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CSExp -> CSExp -> CSStmt
Reassign (CSExp -> CSExp -> CSStmt)
-> CompilerM op s CSExp -> CompilerM op s (CSExp -> CSStmt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VName -> CompilerM op s CSExp
forall op s. VName -> CompilerM op s CSExp
compileVar VName
dest CompilerM op s (CSExp -> CSStmt)
-> CompilerM op s CSExp -> CompilerM op s CSStmt
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> VName -> CompilerM op s CSExp
forall op s. VName -> CompilerM op s CSExp
compileVar VName
src
compileCode (Imp.SetMem VName
dest VName
src Space
_) = do
CSExp
src' <- VName -> CompilerM op s CSExp
forall op s. VName -> CompilerM op s CSExp
compileVar VName
src
CSExp
dest' <- VName -> CompilerM op s CSExp
forall op s. VName -> CompilerM op s CSExp
compileVar VName
dest
CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
stm (CSStmt -> CompilerM op s ()) -> CSStmt -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"MemblockSetDevice" [CSExp -> CSExp
Ref (CSExp -> CSExp) -> CSExp -> CSExp
forall a b. (a -> b) -> a -> b
$ [Char] -> CSExp
Var [Char]
"Ctx", CSExp -> CSExp
Ref CSExp
dest', CSExp -> CSExp
Ref CSExp
src', [Char] -> CSExp
String ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ CSExp -> [Char]
forall a. Pretty a => a -> [Char]
pretty CSExp
src']
compileCode (Imp.Allocate VName
name (Imp.Count Exp
e) (Imp.Space [Char]
space)) =
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 CompilerEnv op s -> Allocate op s
forall op s. CompilerEnv op s -> Allocate op s
envAllocate
CompilerM op s (Allocate op s)
-> CompilerM op s CSExp
-> CompilerM op s (CSExp -> [Char] -> CompilerM op s ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> VName -> CompilerM op s CSExp
forall op s. VName -> CompilerM op s CSExp
compileVar VName
name
CompilerM op s (CSExp -> [Char] -> CompilerM op s ())
-> CompilerM op s CSExp
-> CompilerM op s ([Char] -> CompilerM op s ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> CompilerM op s CSExp
forall op s. Exp -> CompilerM op s CSExp
compileExp Exp
e
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]
space
compileCode (Imp.Allocate VName
name (Imp.Count Exp
e) Space
_) = do
CSExp
e' <- Exp -> CompilerM op s CSExp
forall op s. Exp -> CompilerM op s CSExp
compileExp Exp
e
let allocate' :: CSExp
allocate' = [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"allocateMem" [CSExp
e']
CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
stm (CSStmt -> CompilerM op s ())
-> CompilerM op s CSStmt -> CompilerM op s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CSExp -> CSExp -> CSStmt
Reassign (CSExp -> CSExp -> CSStmt)
-> CompilerM op s CSExp -> CompilerM op s (CSExp -> CSStmt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VName -> CompilerM op s CSExp
forall op s. VName -> CompilerM op s CSExp
compileVar VName
name CompilerM op s (CSExp -> CSStmt)
-> CompilerM op s CSExp -> CompilerM op s CSStmt
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CSExp -> CompilerM op s CSExp
forall (f :: * -> *) a. Applicative f => a -> f a
pure CSExp
allocate'
compileCode (Imp.Free VName
name Space
space) = do
CSExp
name' <- VName -> CompilerM op s CSExp
forall op s. VName -> CompilerM op s CSExp
compileVar VName
name
CSExp -> Space -> CompilerM op s ()
forall op s. CSExp -> Space -> CompilerM op s ()
unRefMem CSExp
name' Space
space
CompilerAcc op s -> CompilerM op s ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (CompilerAcc op s -> CompilerM op s ())
-> CompilerAcc op s -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ CompilerAcc Any Any
forall a. Monoid a => a
mempty { accFreedMem :: [VName]
accFreedMem = [VName
name] }
compileCode (Imp.Copy VName
dest (Imp.Count Exp
destoffset) Space
DefaultSpace VName
src (Imp.Count Exp
srcoffset) Space
DefaultSpace (Imp.Count Exp
size)) = do
CSExp
destoffset' <- Exp -> CompilerM op s CSExp
forall op s. Exp -> CompilerM op s CSExp
compileExp Exp
destoffset
CSExp
srcoffset' <- Exp -> CompilerM op s CSExp
forall op s. Exp -> CompilerM op s CSExp
compileExp Exp
srcoffset
CSExp
dest' <- VName -> CompilerM op s CSExp
forall op s. VName -> CompilerM op s CSExp
compileVar VName
dest
CSExp
src' <- VName -> CompilerM op s CSExp
forall op s. VName -> CompilerM op s CSExp
compileVar VName
src
CSExp
size' <- Exp -> CompilerM op s CSExp
forall op s. Exp -> CompilerM op s CSExp
compileExp Exp
size
CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
stm (CSStmt -> CompilerM op s ()) -> CSStmt -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"Buffer.BlockCopy"
[CSExp
src', CSExp
srcoffset', CSExp
dest', CSExp
destoffset',
CSType -> CSExp -> CSExp
Cast (CSPrim -> CSType
Primitive (CSPrim -> CSType) -> CSPrim -> CSType
forall a b. (a -> b) -> a -> b
$ CSInt -> CSPrim
CSInt CSInt
Int32T) CSExp
size']
compileCode (Imp.Copy VName
dest (Imp.Count Exp
destoffset) Space
destspace VName
src (Imp.Count Exp
srcoffset) Space
srcspace (Imp.Count Exp
size)) = do
Copy op s
copy <- (CompilerEnv op s -> Copy op s) -> CompilerM op s (Copy op s)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks CompilerEnv op s -> Copy op s
forall op s. CompilerEnv op s -> Copy op s
envCopy
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
$ Copy op s
copy
Copy op s
-> CompilerM op s CSExp
-> CompilerM
op
s
(CSExp
-> Space
-> CSExp
-> CSExp
-> Space
-> CSExp
-> PrimType
-> CompilerM op s ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VName -> CompilerM op s CSExp
forall op s. VName -> CompilerM op s CSExp
compileVar VName
dest CompilerM
op
s
(CSExp
-> Space
-> CSExp
-> CSExp
-> Space
-> CSExp
-> PrimType
-> CompilerM op s ())
-> CompilerM op s CSExp
-> CompilerM
op
s
(Space
-> CSExp
-> CSExp
-> Space
-> CSExp
-> PrimType
-> CompilerM op s ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> CompilerM op s CSExp
forall op s. Exp -> CompilerM op s CSExp
compileExp Exp
destoffset CompilerM
op
s
(Space
-> CSExp
-> CSExp
-> Space
-> CSExp
-> PrimType
-> CompilerM op s ())
-> CompilerM op s Space
-> CompilerM
op
s
(CSExp -> CSExp -> Space -> CSExp -> PrimType -> CompilerM op s ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Space -> CompilerM op s Space
forall (f :: * -> *) a. Applicative f => a -> f a
pure Space
destspace
CompilerM
op
s
(CSExp -> CSExp -> Space -> CSExp -> PrimType -> CompilerM op s ())
-> CompilerM op s CSExp
-> CompilerM
op s (CSExp -> Space -> CSExp -> PrimType -> CompilerM op s ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> VName -> CompilerM op s CSExp
forall op s. VName -> CompilerM op s CSExp
compileVar VName
src CompilerM
op s (CSExp -> Space -> CSExp -> PrimType -> CompilerM op s ())
-> CompilerM op s CSExp
-> CompilerM op s (Space -> CSExp -> PrimType -> CompilerM op s ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> CompilerM op s CSExp
forall op s. Exp -> CompilerM op s CSExp
compileExp Exp
srcoffset CompilerM op s (Space -> CSExp -> PrimType -> CompilerM op s ())
-> CompilerM op s Space
-> CompilerM op s (CSExp -> PrimType -> CompilerM op s ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Space -> CompilerM op s Space
forall (f :: * -> *) a. Applicative f => a -> f a
pure Space
srcspace
CompilerM op s (CSExp -> PrimType -> CompilerM op s ())
-> CompilerM op s CSExp
-> CompilerM op s (PrimType -> CompilerM op s ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> CompilerM op s CSExp
forall op s. Exp -> CompilerM op s CSExp
compileExp Exp
size CompilerM op s (PrimType -> CompilerM op s ())
-> CompilerM op s PrimType -> CompilerM op s (CompilerM op s ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PrimType -> CompilerM op s PrimType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IntType -> PrimType
IntType IntType
Int64)
compileCode (Imp.Write VName
dest (Imp.Count Exp
idx) PrimType
elemtype (Imp.Space [Char]
space) Volatility
_ Exp
elemexp) =
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 -> WriteScalar op s)
-> CompilerM op s (WriteScalar op s)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks CompilerEnv op s -> WriteScalar op s
forall op s. CompilerEnv op s -> WriteScalar op s
envWriteScalar
CompilerM op s (WriteScalar op s)
-> CompilerM op s CSExp
-> CompilerM
op s (CSExp -> PrimType -> [Char] -> CSExp -> CompilerM op s ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> VName -> CompilerM op s CSExp
forall op s. VName -> CompilerM op s CSExp
compileVar VName
dest
CompilerM
op s (CSExp -> PrimType -> [Char] -> CSExp -> CompilerM op s ())
-> CompilerM op s CSExp
-> CompilerM
op s (PrimType -> [Char] -> CSExp -> CompilerM op s ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> CompilerM op s CSExp
forall op s. Exp -> CompilerM op s CSExp
compileExp Exp
idx
CompilerM op s (PrimType -> [Char] -> CSExp -> CompilerM op s ())
-> CompilerM op s PrimType
-> CompilerM op s ([Char] -> CSExp -> CompilerM op s ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PrimType -> CompilerM op s PrimType
forall (f :: * -> *) a. Applicative f => a -> f a
pure PrimType
elemtype
CompilerM op s ([Char] -> CSExp -> CompilerM op s ())
-> CompilerM op s [Char]
-> CompilerM op s (CSExp -> 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]
space
CompilerM op s (CSExp -> CompilerM op s ())
-> CompilerM op s CSExp -> CompilerM op s (CompilerM op s ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> CompilerM op s CSExp
forall op s. Exp -> CompilerM op s CSExp
compileExp Exp
elemexp
compileCode (Imp.Write VName
dest (Imp.Count Exp
idx) PrimType
elemtype Space
_ Volatility
_ Exp
elemexp) = do
CSExp
idx' <- Exp -> CompilerM op s CSExp
forall op s. Exp -> CompilerM op s CSExp
compileExp Exp
idx
CSExp
elemexp' <- Exp -> CompilerM op s CSExp
forall op s. Exp -> CompilerM op s CSExp
compileExp Exp
elemexp
CSExp
dest' <- VName -> CompilerM op s CSExp
forall op s. VName -> CompilerM op s CSExp
compileVar VName
dest
let elemtype' :: CSExp -> CSExp
elemtype' = PrimType -> CSExp -> CSExp
compileTypecast PrimType
elemtype
ctype :: CSExp
ctype = CSExp -> CSExp
elemtype' CSExp
elemexp'
idx'' :: CSExp
idx'' = [Char] -> CSExp -> CSExp -> CSExp
BinOp [Char]
"*" CSExp
idx' (CSType -> CSExp
sizeOf (PrimType -> CSType
compilePrimTypeToAST PrimType
elemtype))
CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
stm (CSStmt -> CompilerM op s ()) -> CSStmt -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"writeScalarArray" [CSExp
dest', CSExp
idx'', CSExp
ctype]
compileCode Code op
Imp.Skip = () -> CompilerM op s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
blockScope :: CompilerM op s () -> CompilerM op s [CSStmt]
blockScope :: CompilerM op s () -> CompilerM op s [CSStmt]
blockScope = (((), [CSStmt]) -> [CSStmt])
-> CompilerM op s ((), [CSStmt]) -> CompilerM op s [CSStmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((), [CSStmt]) -> [CSStmt]
forall a b. (a, b) -> b
snd (CompilerM op s ((), [CSStmt]) -> CompilerM op s [CSStmt])
-> (CompilerM op s () -> CompilerM op s ((), [CSStmt]))
-> CompilerM op s ()
-> CompilerM op s [CSStmt]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerM op s () -> CompilerM op s ((), [CSStmt])
forall op s a. CompilerM op s a -> CompilerM op s (a, [CSStmt])
blockScope'
blockScope' :: CompilerM op s a -> CompilerM op s (a, [CSStmt])
blockScope' :: CompilerM op s a -> CompilerM op s (a, [CSStmt])
blockScope' CompilerM op s a
m = do
[(CSExp, Space)]
old_allocs <- (CompilerState s -> [(CSExp, Space)])
-> CompilerM op s [(CSExp, Space)]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets CompilerState s -> [(CSExp, Space)]
forall s. CompilerState s -> [(CSExp, Space)]
compDeclaredMem
(a
x, [CSStmt]
items) <- CompilerM
op s ((a, [CSStmt]), CompilerAcc op s -> CompilerAcc op s)
-> CompilerM op s (a, [CSStmt])
forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass (CompilerM
op s ((a, [CSStmt]), CompilerAcc op s -> CompilerAcc op s)
-> CompilerM op s (a, [CSStmt]))
-> CompilerM
op s ((a, [CSStmt]), CompilerAcc op s -> CompilerAcc op s)
-> CompilerM op s (a, [CSStmt])
forall a b. (a -> b) -> a -> b
$ do
(a
x, CompilerAcc op s
w) <- CompilerM op s a -> CompilerM op s (a, CompilerAcc op s)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen CompilerM op s a
m
let items :: [CSStmt]
items = CompilerAcc op s -> [CSStmt]
forall op s. CompilerAcc op s -> [CSStmt]
accItems CompilerAcc op s
w
((a, [CSStmt]), CompilerAcc op s -> CompilerAcc op s)
-> CompilerM
op s ((a, [CSStmt]), CompilerAcc op s -> CompilerAcc op s)
forall (m :: * -> *) a. Monad m => a -> m a
return ((a
x, [CSStmt]
items), CompilerAcc op s -> CompilerAcc op s -> CompilerAcc op s
forall a b. a -> b -> a
const CompilerAcc op s
forall a. Monoid a => a
mempty)
[(CSExp, Space)]
new_allocs <- (CompilerState s -> [(CSExp, Space)])
-> CompilerM op s [(CSExp, Space)]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((CompilerState s -> [(CSExp, Space)])
-> CompilerM op s [(CSExp, Space)])
-> (CompilerState s -> [(CSExp, Space)])
-> CompilerM op s [(CSExp, Space)]
forall a b. (a -> b) -> a -> b
$ ((CSExp, Space) -> Bool) -> [(CSExp, Space)] -> [(CSExp, Space)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((CSExp, Space) -> [(CSExp, Space)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [(CSExp, Space)]
old_allocs) ([(CSExp, Space)] -> [(CSExp, Space)])
-> (CompilerState s -> [(CSExp, Space)])
-> CompilerState s
-> [(CSExp, Space)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerState s -> [(CSExp, Space)]
forall s. CompilerState s -> [(CSExp, 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 :: [(CSExp, Space)]
compDeclaredMem = [(CSExp, Space)]
old_allocs }
[CSStmt]
releases <- CompilerM op s () -> CompilerM op s [CSStmt]
forall op s. CompilerM op s () -> CompilerM op s [CSStmt]
collect (CompilerM op s () -> CompilerM op s [CSStmt])
-> CompilerM op s () -> CompilerM op s [CSStmt]
forall a b. (a -> b) -> a -> b
$ ((CSExp, Space) -> CompilerM op s ())
-> [(CSExp, Space)] -> CompilerM op s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((CSExp -> Space -> CompilerM op s ())
-> (CSExp, Space) -> CompilerM op s ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry CSExp -> Space -> CompilerM op s ()
forall op s. CSExp -> Space -> CompilerM op s ()
unRefMem) [(CSExp, Space)]
new_allocs
(a, [CSStmt]) -> CompilerM op s (a, [CSStmt])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x, [CSStmt]
items [CSStmt] -> [CSStmt] -> [CSStmt]
forall a. Semigroup a => a -> a -> a
<> [CSStmt]
releases)
unRefMem :: CSExp -> Space -> CompilerM op s ()
unRefMem :: CSExp -> Space -> CompilerM op s ()
unRefMem CSExp
mem (Space [Char]
"device") =
CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
stm (CSStmt -> CompilerM op s ()) -> CSStmt -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ CSExp -> CSStmt
Exp (CSExp -> CSStmt) -> CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$
[Char] -> [CSExp] -> CSExp
simpleCall [Char]
"MemblockUnrefDevice" [ CSExp -> CSExp
Ref (CSExp -> CSExp) -> CSExp -> CSExp
forall a b. (a -> b) -> a -> b
$ [Char] -> CSExp
Var [Char]
"Ctx"
, CSExp -> CSExp
Ref CSExp
mem
, [Char] -> CSExp
String ([Char] -> CSExp) -> [Char] -> CSExp
forall a b. (a -> b) -> a -> b
$ CSExp -> [Char]
forall a. Pretty a => a -> [Char]
pretty CSExp
mem]
unRefMem CSExp
_ Space
DefaultSpace = CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
stm CSStmt
Pass
unRefMem CSExp
_ (Space [Char]
"local") = CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
stm CSStmt
Pass
unRefMem CSExp
_ Space
_ = [Char] -> CompilerM op s ()
forall a. HasCallStack => [Char] -> a
error [Char]
"The default compiler cannot compile unRefMem for other spaces"
publicName :: String -> String
publicName :: [Char] -> [Char]
publicName [Char]
s = [Char]
"Futhark" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s
declMem :: VName -> Space -> CompilerM op s ()
declMem :: VName -> Space -> CompilerM op s ()
declMem VName
name Space
space = do
CSExp
name' <- VName -> CompilerM op s CSExp
forall op s. VName -> CompilerM op s CSExp
compileVar VName
name
(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 :: [(CSExp, Space)]
compDeclaredMem = (CSExp
name', Space
space) (CSExp, Space) -> [(CSExp, Space)] -> [(CSExp, Space)]
forall a. a -> [a] -> [a]
: CompilerState s -> [(CSExp, Space)]
forall s. CompilerState s -> [(CSExp, Space)]
compDeclaredMem CompilerState s
s}
CSStmt -> CompilerM op s ()
forall op s. CSStmt -> CompilerM op s ()
stm (CSStmt -> CompilerM op s ()) -> CSStmt -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ CSExp -> Space -> CSStmt
declMem' CSExp
name' Space
space
memInitExp :: Space -> Maybe CSExp
memInitExp :: Space -> Maybe CSExp
memInitExp (Space [Char]
_) =
CSExp -> Maybe CSExp
forall a. a -> Maybe a
Just (CSExp -> Maybe CSExp) -> CSExp -> Maybe CSExp
forall a b. (a -> b) -> a -> b
$ [Char] -> [CSExp] -> CSExp
simpleCall [Char]
"EmptyMemblock" [[Char] -> CSExp
Var [Char]
"Ctx.EMPTY_MEM_HANDLE"]
memInitExp Space
_ =
Maybe CSExp
forall a. Maybe a
Nothing
declMem' :: CSExp -> Space -> CSStmt
declMem' :: CSExp -> Space -> CSStmt
declMem' CSExp
name space :: Space
space@(Space [Char]
_) =
CSType -> CSExp -> Maybe CSExp -> CSStmt
AssignTyped ([Char] -> CSType
CustomT [Char]
"OpenCLMemblock") CSExp
name (Maybe CSExp -> CSStmt) -> Maybe CSExp -> CSStmt
forall a b. (a -> b) -> a -> b
$ Space -> Maybe CSExp
memInitExp Space
space
declMem' CSExp
name Space
_ =
CSType -> CSExp -> Maybe CSExp -> CSStmt
AssignTyped (CSComp -> CSType
Composite (CSComp -> CSType) -> CSComp -> CSType
forall a b. (a -> b) -> a -> b
$ CSType -> CSComp
ArrayT (CSType -> CSComp) -> CSType -> CSComp
forall a b. (a -> b) -> a -> b
$ CSPrim -> CSType
Primitive CSPrim
ByteT) CSExp
name Maybe CSExp
forall a. Maybe a
Nothing
rawMemCSType :: Space -> CSType
rawMemCSType :: Space -> CSType
rawMemCSType (Space [Char]
_) = [Char] -> CSType
CustomT [Char]
"OpenCLMemblock"
rawMemCSType Space
_ = CSComp -> CSType
Composite (CSComp -> CSType) -> CSComp -> CSType
forall a b. (a -> b) -> a -> b
$ CSType -> CSComp
ArrayT (CSType -> CSComp) -> CSType -> CSComp
forall a b. (a -> b) -> a -> b
$ CSPrim -> CSType
Primitive CSPrim
ByteT
toIntPtr :: CSExp -> CSExp
toIntPtr :: CSExp -> CSExp
toIntPtr CSExp
e = [Char] -> [CSExp] -> CSExp
simpleInitClass [Char]
"IntPtr" [CSExp
e]