{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, LambdaCase #-}
{-# LANGUAGE TupleSections #-}
-- | A generic C# code generator which is polymorphic in the type
-- of the operations.  Concretely, we use this to handle both
-- sequential and OpenCL C# code.
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.Representation.Primitive hiding (Bool)
import Futhark.MonadFreshNames
import Futhark.Representation.AST.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)

-- | A substitute expression compiler, tried before the main
-- compilation function.
type OpCompiler op s = op -> CompilerM op s ()

-- | Write a scalar to the given memory block with the given index and
-- in the given memory space.
type WriteScalar op s = CSExp -> CSExp -> PrimType -> Imp.SpaceId -> CSExp
                        -> CompilerM op s ()

-- | Read a scalar from the given memory block with the given index and
-- in the given memory space.
type ReadScalar op s = CSExp -> CSExp -> PrimType -> Imp.SpaceId
                       -> CompilerM op s CSExp

-- | Allocate a memory block of the given size in the given memory
-- space, saving a reference in the given variable name.
type Allocate op s = CSExp -> CSExp -> Imp.SpaceId
                     -> CompilerM op s ()

-- | Copy from one memory block to another.
type Copy op s = CSExp -> CSExp -> Imp.Space ->
                 CSExp -> CSExp -> Imp.Space ->
                 CSExp -> PrimType ->
                 CompilerM op s ()

-- | Create a static array of values - initialised at load time.
type StaticArray op s = VName -> Imp.SpaceId -> PrimType -> Imp.ArrayContents -> CompilerM op s ()

-- | Construct the C# array being returned from an entry point.
type EntryOutput op s = CSExp -> Imp.SpaceId ->
                        PrimType -> Imp.Signedness ->
                        [Imp.DimSize] ->
                        CompilerM op s CSExp

-- | Unpack the array being passed to an entry point.
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
                                  }

-- | A set of operations that fail for every operation involving
-- non-default memory spaces.  Uses plain pointers and @malloc@ for
-- memory management.
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 =
  VName -> [VName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem VName
vname ([VName] -> Bool) -> CompilerM op s [VName] -> CompilerM op s Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CompilerState s -> [VName]) -> CompilerM op s [VName]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets 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" ]
         }
  ]

-- | The class generated by the code generator must have a
-- constructor, although it can be vacuous.
data Constructor = Constructor [CSFunDefArg] [CSStmt]

-- | A constructor that takes no arguments and does nothing.
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)

-- | A 'Call' where the function is a variable and every argument is a
-- simple 'Arg'.
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

-- | A CallMethod
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" -- array tuples are currently (data array * dimension array) currently
  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"

-- The value returned will be used when reading binary arrays, to indicate what
-- the expected type is
-- Key into the FUTHARK_PRIMTYPES dict.
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]

-- TODO: If the type identifier of 'Float32' is changed, currently the error
-- messages for reading binary input will not use this new name. This is also a
-- problem for the C runtime system.
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')
  -- We copy non-host arrays to the host before printing.  This is
  -- done in a hacky way - we assume the value has a .get()-method
  -- that returns an equivalent Numpy array.  This works for CSOpenCL,
  -- but we will probably need yet another plugin mechanism here in
  -- the future.
  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
      -- A program might write to its input parameters, so create a new memory
      -- block and copy the source there.  This way the program can be run more
      -- than once.
      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]) -- FIXME
      Copy op s
copy CSExp
dest CSExp
offset Space
space CSExp
src CSExp
offset Space
space CSExp
size (IntType -> PrimType
IntType IntType
Int64) -- FIXME
      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

        -- We ignore overflow errors and the like for executable entry
        -- points.  These are (somewhat) well-defined in Futhark.

    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" -- actually write these helpers
    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)

-- | The ctypes type corresponding to a 'PrimType'.
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"

-- | The ctypes type corresponding to a 'PrimType', taking sign into account.
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"

-- | Select function to retrieve bytes from byte array as specific data type
-- | The ctypes type corresponding to a 'PrimType'.
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'

-- | The ctypes type corresponding to a 'PrimType'.
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'

-- | The ctypes type corresponding to a 'PrimType'.
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'
  -- If the function returns nothing (is called only for side
  -- effects), take care not to assign to an empty tuple.
  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) -- FIXME

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"


-- | Public names must have a consistent prefix.
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]