{-# LANGUAGE QuasiQuotes #-}
module Futhark.CodeGen.Backends.GenericC.Code
( compilePrimExp,
compileExp,
compileExpToName,
compileCode,
errorMsgString,
linearCode,
)
where
import Control.Monad.Reader
import Data.Loc
import Data.Maybe
import Data.Text qualified as T
import Futhark.CodeGen.Backends.GenericC.Monad
import Futhark.CodeGen.ImpCode
import Futhark.IR.Prop (isBuiltInFunction)
import Futhark.MonadFreshNames
import Language.C.Quote.OpenCL qualified as C
import Language.C.Syntax qualified as C
errorMsgString :: ErrorMsg Exp -> CompilerM op s (String, [C.Exp])
errorMsgString :: forall op s. ErrorMsg Exp -> CompilerM op s (String, [Exp])
errorMsgString (ErrorMsg [ErrorMsgPart Exp]
parts) = do
let boolStr :: a -> Exp
boolStr a
e = [C.cexp|($exp:e) ? "true" : "false"|]
asLongLong :: a -> Exp
asLongLong a
e = [C.cexp|(long long int)$exp:e|]
asDouble :: a -> Exp
asDouble a
e = [C.cexp|(double)$exp:e|]
onPart :: ErrorMsgPart Exp -> CompilerM op s (a, Exp)
onPart (ErrorString Text
s) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
"%s", [C.cexp|$string:(T.unpack s)|])
onPart (ErrorVal PrimType
Bool Exp
x) = (a
"%s",) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. ToExp a => a -> Exp
boolStr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall op s. Exp -> CompilerM op s Exp
compileExp Exp
x
onPart (ErrorVal PrimType
Unit Exp
_) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
"%s", [C.cexp|"()"|])
onPart (ErrorVal (IntType IntType
Int8) Exp
x) = (a
"%hhd",) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall op s. Exp -> CompilerM op s Exp
compileExp Exp
x
onPart (ErrorVal (IntType IntType
Int16) Exp
x) = (a
"%hd",) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall op s. Exp -> CompilerM op s Exp
compileExp Exp
x
onPart (ErrorVal (IntType IntType
Int32) Exp
x) = (a
"%d",) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall op s. Exp -> CompilerM op s Exp
compileExp Exp
x
onPart (ErrorVal (IntType IntType
Int64) Exp
x) = (a
"%lld",) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. ToExp a => a -> Exp
asLongLong forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall op s. Exp -> CompilerM op s Exp
compileExp Exp
x
onPart (ErrorVal (FloatType FloatType
Float16) Exp
x) = (a
"%f",) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. ToExp a => a -> Exp
asDouble forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall op s. Exp -> CompilerM op s Exp
compileExp Exp
x
onPart (ErrorVal (FloatType FloatType
Float32) Exp
x) = (a
"%f",) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. ToExp a => a -> Exp
asDouble forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall op s. Exp -> CompilerM op s Exp
compileExp Exp
x
onPart (ErrorVal (FloatType FloatType
Float64) Exp
x) = (a
"%f",) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall op s. Exp -> CompilerM op s Exp
compileExp Exp
x
([String]
formatstrs, [Exp]
formatargs) <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {a} {op} {s}.
IsString a =>
ErrorMsgPart Exp -> CompilerM op s (a, Exp)
onPart [ErrorMsgPart Exp]
parts
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Monoid a => [a] -> a
mconcat [String]
formatstrs, [Exp]
formatargs)
compileExpToName :: String -> PrimType -> Exp -> CompilerM op s VName
compileExpToName :: forall op s. String -> PrimType -> Exp -> CompilerM op s VName
compileExpToName String
_ PrimType
_ (LeafExp VName
v PrimType
_) =
forall (f :: * -> *) a. Applicative f => a -> f a
pure VName
v
compileExpToName String
desc PrimType
t Exp
e = do
VName
desc' <- forall (m :: * -> *). MonadFreshNames m => String -> m VName
newVName String
desc
Exp
e' <- forall op s. Exp -> CompilerM op s Exp
compileExp Exp
e
forall op s. InitGroup -> CompilerM op s ()
decl [C.cdecl|$ty:(primTypeToCType t) $id:desc' = $e';|]
forall (f :: * -> *) a. Applicative f => a -> f a
pure VName
desc'
compileExp :: Exp -> CompilerM op s C.Exp
compileExp :: forall op s. Exp -> CompilerM op s Exp
compileExp = forall (m :: * -> *) v.
Monad m =>
(v -> m Exp) -> PrimExp v -> m Exp
compilePrimExp forall a b. (a -> b) -> a -> b
$ \VName
v -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cexp|$id:v|]
compilePrimExp :: Monad m => (v -> m C.Exp) -> PrimExp v -> m C.Exp
compilePrimExp :: forall (m :: * -> *) v.
Monad m =>
(v -> m Exp) -> PrimExp v -> m Exp
compilePrimExp v -> m Exp
_ (ValueExp PrimValue
val) =
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. ToExp a => a -> SrcLoc -> Exp
C.toExp PrimValue
val forall a. Monoid a => a
mempty
compilePrimExp v -> m Exp
f (LeafExp v
v PrimType
_) =
v -> m Exp
f v
v
compilePrimExp v -> m Exp
f (UnOpExp Complement {} PrimExp v
x) = do
Exp
x' <- forall (m :: * -> *) v.
Monad m =>
(v -> m Exp) -> PrimExp v -> m Exp
compilePrimExp v -> m Exp
f PrimExp v
x
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cexp|~$exp:x'|]
compilePrimExp v -> m Exp
f (UnOpExp Not {} PrimExp v
x) = do
Exp
x' <- forall (m :: * -> *) v.
Monad m =>
(v -> m Exp) -> PrimExp v -> m Exp
compilePrimExp v -> m Exp
f PrimExp v
x
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cexp|!$exp:x'|]
compilePrimExp v -> m Exp
f (UnOpExp (FAbs FloatType
Float32) PrimExp v
x) = do
Exp
x' <- forall (m :: * -> *) v.
Monad m =>
(v -> m Exp) -> PrimExp v -> m Exp
compilePrimExp v -> m Exp
f PrimExp v
x
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cexp|(float)fabs($exp:x')|]
compilePrimExp v -> m Exp
f (UnOpExp (FAbs FloatType
Float64) PrimExp v
x) = do
Exp
x' <- forall (m :: * -> *) v.
Monad m =>
(v -> m Exp) -> PrimExp v -> m Exp
compilePrimExp v -> m Exp
f PrimExp v
x
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cexp|fabs($exp:x')|]
compilePrimExp v -> m Exp
f (UnOpExp SSignum {} PrimExp v
x) = do
Exp
x' <- forall (m :: * -> *) v.
Monad m =>
(v -> m Exp) -> PrimExp v -> m Exp
compilePrimExp v -> m Exp
f PrimExp v
x
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cexp|($exp:x' > 0 ? 1 : 0) - ($exp:x' < 0 ? 1 : 0)|]
compilePrimExp v -> m Exp
f (UnOpExp USignum {} PrimExp v
x) = do
Exp
x' <- forall (m :: * -> *) v.
Monad m =>
(v -> m Exp) -> PrimExp v -> m Exp
compilePrimExp v -> m Exp
f PrimExp v
x
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cexp|($exp:x' > 0 ? 1 : 0) - ($exp:x' < 0 ? 1 : 0) != 0|]
compilePrimExp v -> m Exp
f (UnOpExp UnOp
op PrimExp v
x) = do
Exp
x' <- forall (m :: * -> *) v.
Monad m =>
(v -> m Exp) -> PrimExp v -> m Exp
compilePrimExp v -> m Exp
f PrimExp v
x
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cexp|$id:(prettyString op)($exp:x')|]
compilePrimExp v -> m Exp
f (CmpOpExp CmpOp
cmp PrimExp v
x PrimExp v
y) = do
Exp
x' <- forall (m :: * -> *) v.
Monad m =>
(v -> m Exp) -> PrimExp v -> m Exp
compilePrimExp v -> m Exp
f PrimExp v
x
Exp
y' <- forall (m :: * -> *) v.
Monad m =>
(v -> m Exp) -> PrimExp v -> m Exp
compilePrimExp v -> m Exp
f PrimExp v
y
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case CmpOp
cmp of
CmpEq {} -> [C.cexp|$exp:x' == $exp:y'|]
FCmpLt {} -> [C.cexp|$exp:x' < $exp:y'|]
FCmpLe {} -> [C.cexp|$exp:x' <= $exp:y'|]
CmpLlt {} -> [C.cexp|$exp:x' < $exp:y'|]
CmpLle {} -> [C.cexp|$exp:x' <= $exp:y'|]
CmpOp
_ -> [C.cexp|$id:(prettyString cmp)($exp:x', $exp:y')|]
compilePrimExp v -> m Exp
f (ConvOpExp ConvOp
conv PrimExp v
x) = do
Exp
x' <- forall (m :: * -> *) v.
Monad m =>
(v -> m Exp) -> PrimExp v -> m Exp
compilePrimExp v -> m Exp
f PrimExp v
x
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cexp|$id:(prettyString conv)($exp:x')|]
compilePrimExp v -> m Exp
f (BinOpExp BinOp
bop PrimExp v
x PrimExp v
y) = do
Exp
x' <- forall (m :: * -> *) v.
Monad m =>
(v -> m Exp) -> PrimExp v -> m Exp
compilePrimExp v -> m Exp
f PrimExp v
x
Exp
y' <- forall (m :: * -> *) v.
Monad m =>
(v -> m Exp) -> PrimExp v -> m Exp
compilePrimExp v -> m Exp
f PrimExp v
y
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case BinOp
bop of
Add IntType
_ Overflow
OverflowUndef -> [C.cexp|$exp:x' + $exp:y'|]
Sub IntType
_ Overflow
OverflowUndef -> [C.cexp|$exp:x' - $exp:y'|]
Mul IntType
_ Overflow
OverflowUndef -> [C.cexp|$exp:x' * $exp:y'|]
FAdd {} -> [C.cexp|$exp:x' + $exp:y'|]
FSub {} -> [C.cexp|$exp:x' - $exp:y'|]
FMul {} -> [C.cexp|$exp:x' * $exp:y'|]
FDiv {} -> [C.cexp|$exp:x' / $exp:y'|]
Xor {} -> [C.cexp|$exp:x' ^ $exp:y'|]
And {} -> [C.cexp|$exp:x' & $exp:y'|]
Or {} -> [C.cexp|$exp:x' | $exp:y'|]
LogAnd {} -> [C.cexp|$exp:x' && $exp:y'|]
LogOr {} -> [C.cexp|$exp:x' || $exp:y'|]
BinOp
_ -> [C.cexp|$id:(prettyString bop)($exp:x', $exp:y')|]
compilePrimExp v -> m Exp
f (FunExp String
h [PrimExp v]
args PrimType
_) = do
[Exp]
args' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) v.
Monad m =>
(v -> m Exp) -> PrimExp v -> m Exp
compilePrimExp v -> m Exp
f) [PrimExp v]
args
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cexp|$id:(funName (nameFromString h))($args:args')|]
linearCode :: Code op -> [Code op]
linearCode :: forall op. Code op -> [Code op]
linearCode = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. [Code a] -> Code a -> [Code a]
go []
where
go :: [Code a] -> Code a -> [Code a]
go [Code a]
acc (Code a
x :>>: Code a
y) =
[Code a] -> Code a -> [Code a]
go ([Code a] -> Code a -> [Code a]
go [Code a]
acc Code a
x) Code a
y
go [Code a]
acc Code a
x = Code a
x forall a. a -> [a] -> [a]
: [Code a]
acc
assignmentOperator :: BinOp -> Maybe (VName -> C.Exp -> C.Exp)
assignmentOperator :: BinOp -> Maybe (VName -> Exp -> Exp)
assignmentOperator Add {} = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ \VName
d Exp
e -> [C.cexp|$id:d += $exp:e|]
assignmentOperator Sub {} = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ \VName
d Exp
e -> [C.cexp|$id:d -= $exp:e|]
assignmentOperator Mul {} = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ \VName
d Exp
e -> [C.cexp|$id:d *= $exp:e|]
assignmentOperator BinOp
_ = forall a. Maybe a
Nothing
compileRead ::
VName ->
Count u (TPrimExp t VName) ->
PrimType ->
Space ->
Volatility ->
CompilerM op s C.Exp
compileRead :: forall {k} {k} (u :: k) (t :: k) op s.
VName
-> Count u (TPrimExp t VName)
-> PrimType
-> Space
-> Volatility
-> CompilerM op s Exp
compileRead VName
_ Count u (TPrimExp t VName)
_ PrimType
Unit Space
_ Volatility
_ =
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cexp|$exp:(UnitValue)|]
compileRead VName
src (Count TPrimExp t VName
iexp) PrimType
restype Space
DefaultSpace Volatility
vol = do
Exp
src' <- forall op s. VName -> CompilerM op s Exp
rawMem VName
src
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PrimType -> Exp -> Exp
fromStorage PrimType
restype) forall a b. (a -> b) -> a -> b
$
Exp -> Exp -> Type -> Exp
derefPointer Exp
src'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall op s. Exp -> CompilerM op s Exp
compileExp (forall {k} (t :: k) v. TPrimExp t v -> PrimExp v
untyped TPrimExp t VName
iexp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cty|$tyquals:(volQuals vol) $ty:(primStorageType restype)*|]
compileRead VName
src (Count TPrimExp t VName
iexp) PrimType
restype (Space String
space) Volatility
vol =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PrimType -> Exp -> Exp
fromStorage PrimType
restype) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall op s. Operations op s -> ReadScalar op s
opsReadScalar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall op s. CompilerEnv op s -> Operations op s
envOperations)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall op s. VName -> CompilerM op s Exp
rawMem VName
src
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall op s. Exp -> CompilerM op s Exp
compileExp (forall {k} (t :: k) v. TPrimExp t v -> PrimExp v
untyped TPrimExp t VName
iexp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (PrimType -> Type
primStorageType PrimType
restype)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure String
space
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Volatility
vol
compileRead VName
src (Count TPrimExp t VName
iexp) PrimType
_ ScalarSpace {} Volatility
_ = do
Exp
iexp' <- forall op s. Exp -> CompilerM op s Exp
compileExp forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k) v. TPrimExp t v -> PrimExp v
untyped TPrimExp t VName
iexp
forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cexp|$id:src[$exp:iexp']|]
compileArg :: Arg -> CompilerM op s C.Exp
compileArg :: forall op s. Arg -> CompilerM op s Exp
compileArg (MemArg VName
m) = forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cexp|$exp:m|]
compileArg (ExpArg Exp
e) = forall op s. Exp -> CompilerM op s Exp
compileExp Exp
e
compileCode :: Code op -> CompilerM op s ()
compileCode :: forall op s. Code op -> CompilerM op s ()
compileCode (Op op
op) =
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall op s. Operations op s -> OpCompiler op s
opsCompiler forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall op s. CompilerEnv op s -> Operations op s
envOperations) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure op
op
compileCode Code op
Skip = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
compileCode (Comment Text
s Code op
code) = do
[BlockItem]
xs <- forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
collect forall a b. (a -> b) -> a -> b
$ forall op s. Code op -> CompilerM op s ()
compileCode Code op
code
let comment :: String
comment = String
"// " forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
s
forall op s. Stm -> CompilerM op s ()
stm
[C.cstm|$comment:comment
{ $items:xs }
|]
compileCode (TracePrint ErrorMsg Exp
msg) = do
(String
formatstr, [Exp]
formatargs) <- forall op s. ErrorMsg Exp -> CompilerM op s (String, [Exp])
errorMsgString ErrorMsg Exp
msg
forall op s. Stm -> CompilerM op s ()
stm [C.cstm|fprintf(ctx->log, $string:formatstr, $args:formatargs);|]
compileCode (DebugPrint String
s (Just Exp
e)) = do
Exp
e' <- forall op s. Exp -> CompilerM op s Exp
compileExp Exp
e
forall op s. Stm -> CompilerM op s ()
stm
[C.cstm|if (ctx->debugging) {
fprintf(ctx->log, $string:fmtstr, $exp:s, ($ty:ety)$exp:e', '\n');
}|]
where
(String
fmt, Type
ety) = case forall v. PrimExp v -> PrimType
primExpType Exp
e of
IntType IntType
_ -> (String
"llu", [C.cty|long long int|])
FloatType FloatType
_ -> (String
"f", [C.cty|double|])
PrimType
_ -> (String
"d", [C.cty|int|])
fmtstr :: String
fmtstr = String
"%s: %" forall a. [a] -> [a] -> [a]
++ String
fmt forall a. [a] -> [a] -> [a]
++ String
"%c"
compileCode (DebugPrint String
s Maybe Exp
Nothing) =
forall op s. Stm -> CompilerM op s ()
stm
[C.cstm|if (ctx->debugging) {
fprintf(ctx->log, "%s\n", $exp:s);
}|]
compileCode (Code op
c1 :>>: Code op
c2) = forall {op} {s}. [Code op] -> CompilerM op s ()
go (forall op. Code op -> [Code op]
linearCode (Code op
c1 forall a. Code a -> Code a -> Code a
:>>: Code op
c2))
where
go :: [Code op] -> CompilerM op s ()
go (DeclareScalar VName
name Volatility
vol PrimType
t : SetScalar VName
dest Exp
e : [Code op]
code)
| VName
name forall a. Eq a => a -> a -> Bool
== VName
dest = do
let ct :: Type
ct = PrimType -> Type
primTypeToCType PrimType
t
Exp
e' <- forall op s. Exp -> CompilerM op s Exp
compileExp Exp
e
forall op s. BlockItem -> CompilerM op s ()
item [C.citem|$tyquals:(volQuals vol) $ty:ct $id:name = $exp:e';|]
[Code op] -> CompilerM op s ()
go [Code op]
code
go (DeclareScalar VName
name Volatility
vol PrimType
t : Read VName
dest VName
src Count Elements (TExp Int64)
i PrimType
restype Space
space Volatility
read_vol : [Code op]
code)
| VName
name forall a. Eq a => a -> a -> Bool
== VName
dest = do
let ct :: Type
ct = PrimType -> Type
primTypeToCType PrimType
t
Exp
e <- forall {k} {k} (u :: k) (t :: k) op s.
VName
-> Count u (TPrimExp t VName)
-> PrimType
-> Space
-> Volatility
-> CompilerM op s Exp
compileRead VName
src Count Elements (TExp Int64)
i PrimType
restype Space
space Volatility
read_vol
forall op s. BlockItem -> CompilerM op s ()
item [C.citem|$tyquals:(volQuals vol) $ty:ct $id:name = $exp:e;|]
[Code op] -> CompilerM op s ()
go [Code op]
code
go (DeclareScalar VName
name Volatility
vol PrimType
t : Call [VName
dest] Name
fname [Arg]
args : [Code op]
code)
| VName
name forall a. Eq a => a -> a -> Bool
== VName
dest,
Name -> Bool
isBuiltInFunction Name
fname = do
let ct :: Type
ct = PrimType -> Type
primTypeToCType PrimType
t
[Exp]
args' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall op s. Arg -> CompilerM op s Exp
compileArg [Arg]
args
forall op s. BlockItem -> CompilerM op s ()
item [C.citem|$tyquals:(volQuals vol) $ty:ct $id:name = $id:(funName fname)($args:args');|]
[Code op] -> CompilerM op s ()
go [Code op]
code
go (Code op
x : [Code op]
xs) = forall op s. Code op -> CompilerM op s ()
compileCode Code op
x forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Code op] -> CompilerM op s ()
go [Code op]
xs
go [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
compileCode (Assert Exp
e ErrorMsg Exp
msg (SrcLoc
loc, [SrcLoc]
locs)) = do
Exp
e' <- forall op s. Exp -> CompilerM op s Exp
compileExp Exp
e
[BlockItem]
err <-
forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
collect forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall op s. Operations op s -> ErrorCompiler op s
opsError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall op s. CompilerEnv op s -> Operations op s
envOperations) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorMsg Exp
msg forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure String
stacktrace
forall op s. Stm -> CompilerM op s ()
stm [C.cstm|if (!$exp:e') { $items:err }|]
where
stacktrace :: String
stacktrace = Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Int -> [Text] -> Text
prettyStacktrace Int
0 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Located a => a -> Text
locText forall a b. (a -> b) -> a -> b
$ SrcLoc
loc forall a. a -> [a] -> [a]
: [SrcLoc]
locs
compileCode (Allocate VName
_ Count Bytes (TExp Int64)
_ ScalarSpace {}) =
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
compileCode (Allocate VName
name (Count (TPrimExp Exp
e)) Space
space) = do
Exp
size <- forall op s. Exp -> CompilerM op s Exp
compileExp Exp
e
Maybe VName
cached <- forall a op s. ToExp a => a -> CompilerM op s (Maybe VName)
cacheMem VName
name
case Maybe VName
cached of
Just VName
cur_size ->
forall op s. Stm -> CompilerM op s ()
stm
[C.cstm|if ($exp:cur_size < $exp:size) {
err = lexical_realloc(ctx, &$exp:name, &$exp:cur_size, $exp:size);
if (err != FUTHARK_SUCCESS) {
goto cleanup;
}
}|]
Maybe VName
_ ->
forall a b op s.
(ToExp a, ToExp b) =>
a -> b -> Space -> Stm -> CompilerM op s ()
allocMem VName
name Exp
size Space
space [C.cstm|{err = 1; goto cleanup;}|]
compileCode (Free VName
name Space
space) = do
Bool
cached <- forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a op s. ToExp a => a -> CompilerM op s (Maybe VName)
cacheMem VName
name
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
cached forall a b. (a -> b) -> a -> b
$ forall a op s. ToExp a => a -> Space -> CompilerM op s ()
unRefMem VName
name Space
space
compileCode (For VName
i Exp
bound Code op
body) = do
let i' :: SrcLoc -> Id
i' = forall a. ToIdent a => a -> SrcLoc -> Id
C.toIdent VName
i
t :: Type
t = PrimType -> Type
primTypeToCType forall a b. (a -> b) -> a -> b
$ forall v. PrimExp v -> PrimType
primExpType Exp
bound
Exp
bound' <- forall op s. Exp -> CompilerM op s Exp
compileExp Exp
bound
[BlockItem]
body' <- forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
collect forall a b. (a -> b) -> a -> b
$ forall op s. Code op -> CompilerM op s ()
compileCode Code op
body
forall op s. Stm -> CompilerM op s ()
stm
[C.cstm|for ($ty:t $id:i' = 0; $id:i' < $exp:bound'; $id:i'++) {
$items:body'
}|]
compileCode (While TExp Bool
cond Code op
body) = do
Exp
cond' <- forall op s. Exp -> CompilerM op s Exp
compileExp forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k) v. TPrimExp t v -> PrimExp v
untyped TExp Bool
cond
[BlockItem]
body' <- forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
collect forall a b. (a -> b) -> a -> b
$ forall op s. Code op -> CompilerM op s ()
compileCode Code op
body
forall op s. Stm -> CompilerM op s ()
stm
[C.cstm|while ($exp:cond') {
$items:body'
}|]
compileCode (If TExp Bool
cond Code op
tbranch Code op
fbranch) = do
Exp
cond' <- forall op s. Exp -> CompilerM op s Exp
compileExp forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k) v. TPrimExp t v -> PrimExp v
untyped TExp Bool
cond
[BlockItem]
tbranch' <- forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
collect forall a b. (a -> b) -> a -> b
$ forall op s. Code op -> CompilerM op s ()
compileCode Code op
tbranch
[BlockItem]
fbranch' <- forall op s. CompilerM op s () -> CompilerM op s [BlockItem]
collect forall a b. (a -> b) -> a -> b
$ forall op s. Code op -> CompilerM op s ()
compileCode Code op
fbranch
forall op s. Stm -> CompilerM op s ()
stm forall a b. (a -> b) -> a -> b
$ case ([BlockItem]
tbranch', [BlockItem]
fbranch') of
([BlockItem]
_, []) ->
[C.cstm|if ($exp:cond') { $items:tbranch' }|]
([], [BlockItem]
_) ->
[C.cstm|if (!($exp:cond')) { $items:fbranch' }|]
([BlockItem]
_, [C.BlockStm x :: Stm
x@C.If {}]) ->
[C.cstm|if ($exp:cond') { $items:tbranch' } else $stm:x|]
([BlockItem], [BlockItem])
_ ->
[C.cstm|if ($exp:cond') { $items:tbranch' } else { $items:fbranch' }|]
compileCode (Copy PrimType
_ VName
dest (Count TExp Int64
destoffset) Space
DefaultSpace VName
src (Count TExp Int64
srcoffset) Space
DefaultSpace (Count TExp Int64
size)) =
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$
forall op s. Exp -> Exp -> Exp -> Exp -> Exp -> CompilerM op s ()
copyMemoryDefaultSpace
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall op s. VName -> CompilerM op s Exp
rawMem VName
dest
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall op s. Exp -> CompilerM op s Exp
compileExp (forall {k} (t :: k) v. TPrimExp t v -> PrimExp v
untyped TExp Int64
destoffset)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall op s. VName -> CompilerM op s Exp
rawMem VName
src
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall op s. Exp -> CompilerM op s Exp
compileExp (forall {k} (t :: k) v. TPrimExp t v -> PrimExp v
untyped TExp Int64
srcoffset)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall op s. Exp -> CompilerM op s Exp
compileExp (forall {k} (t :: k) v. TPrimExp t v -> PrimExp v
untyped TExp Int64
size)
compileCode (Copy PrimType
_ VName
dest (Count TExp Int64
destoffset) Space
destspace VName
src (Count TExp Int64
srcoffset) Space
srcspace (Count TExp Int64
size)) = do
Copy op s
copy <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a b. (a -> b) -> a -> b
$ forall op s. Operations op s -> Copy op s
opsCopy forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall op s. CompilerEnv op s -> Operations op s
envOperations
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$
Copy op s
copy CopyBarrier
CopyBarrier
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall op s. VName -> CompilerM op s Exp
rawMem VName
dest
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall op s. Exp -> CompilerM op s Exp
compileExp (forall {k} (t :: k) v. TPrimExp t v -> PrimExp v
untyped TExp Int64
destoffset)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Space
destspace
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall op s. VName -> CompilerM op s Exp
rawMem VName
src
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall op s. Exp -> CompilerM op s Exp
compileExp (forall {k} (t :: k) v. TPrimExp t v -> PrimExp v
untyped TExp Int64
srcoffset)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Space
srcspace
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall op s. Exp -> CompilerM op s Exp
compileExp (forall {k} (t :: k) v. TPrimExp t v -> PrimExp v
untyped TExp Int64
size)
compileCode (Write VName
_ Count Elements (TExp Int64)
_ PrimType
Unit Space
_ Volatility
_ Exp
_) = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
compileCode (Write VName
dest (Count TExp Int64
idx) PrimType
elemtype Space
DefaultSpace Volatility
vol Exp
elemexp) = do
Exp
dest' <- forall op s. VName -> CompilerM op s Exp
rawMem VName
dest
Exp
deref <-
Exp -> Exp -> Type -> Exp
derefPointer Exp
dest'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall op s. Exp -> CompilerM op s Exp
compileExp (forall {k} (t :: k) v. TPrimExp t v -> PrimExp v
untyped TExp Int64
idx)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure [C.cty|$tyquals:(volQuals vol) $ty:(primStorageType elemtype)*|]
Exp
elemexp' <- PrimType -> Exp -> Exp
toStorage PrimType
elemtype forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall op s. Exp -> CompilerM op s Exp
compileExp Exp
elemexp
forall op s. Stm -> CompilerM op s ()
stm [C.cstm|$exp:deref = $exp:elemexp';|]
compileCode (Write VName
dest (Count TExp Int64
idx) PrimType
_ ScalarSpace {} Volatility
_ Exp
elemexp) = do
Exp
idx' <- forall op s. Exp -> CompilerM op s Exp
compileExp (forall {k} (t :: k) v. TPrimExp t v -> PrimExp v
untyped TExp Int64
idx)
Exp
elemexp' <- forall op s. Exp -> CompilerM op s Exp
compileExp Exp
elemexp
forall op s. Stm -> CompilerM op s ()
stm [C.cstm|$id:dest[$exp:idx'] = $exp:elemexp';|]
compileCode (Write VName
dest (Count TExp Int64
idx) PrimType
elemtype (Space String
space) Volatility
vol Exp
elemexp) =
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall op s. Operations op s -> WriteScalar op s
opsWriteScalar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall op s. CompilerEnv op s -> Operations op s
envOperations)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall op s. VName -> CompilerM op s Exp
rawMem VName
dest
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall op s. Exp -> CompilerM op s Exp
compileExp (forall {k} (t :: k) v. TPrimExp t v -> PrimExp v
untyped TExp Int64
idx)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (PrimType -> Type
primStorageType PrimType
elemtype)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure String
space
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Volatility
vol
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (PrimType -> Exp -> Exp
toStorage PrimType
elemtype forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall op s. Exp -> CompilerM op s Exp
compileExp Exp
elemexp)
compileCode (Read VName
x VName
src Count Elements (TExp Int64)
i PrimType
restype Space
space Volatility
vol) = do
Exp
e <- forall {k} {k} (u :: k) (t :: k) op s.
VName
-> Count u (TPrimExp t VName)
-> PrimType
-> Space
-> Volatility
-> CompilerM op s Exp
compileRead VName
src Count Elements (TExp Int64)
i PrimType
restype Space
space Volatility
vol
forall op s. Stm -> CompilerM op s ()
stm [C.cstm|$id:x = $exp:e;|]
compileCode (DeclareMem VName
name Space
space) =
forall op s. VName -> Space -> CompilerM op s ()
declMem VName
name Space
space
compileCode (DeclareScalar VName
name Volatility
vol PrimType
t) = do
let ct :: Type
ct = PrimType -> Type
primTypeToCType PrimType
t
forall op s. InitGroup -> CompilerM op s ()
decl [C.cdecl|$tyquals:(volQuals vol) $ty:ct $id:name;|]
compileCode (DeclareArray VName
name ScalarSpace {} PrimType
_ ArrayContents
_) =
forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Cannot declare array " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
prettyString VName
name forall a. [a] -> [a] -> [a]
++ String
" in scalar space."
compileCode (DeclareArray VName
name Space
DefaultSpace PrimType
t ArrayContents
vs) = do
VName
name_realtype <- forall (m :: * -> *). MonadFreshNames m => String -> m VName
newVName forall a b. (a -> b) -> a -> b
$ VName -> String
baseString VName
name forall a. [a] -> [a] -> [a]
++ String
"_realtype"
let ct :: Type
ct = PrimType -> Type
primTypeToCType PrimType
t
case ArrayContents
vs of
ArrayValues [PrimValue]
vs' -> do
let vs'' :: [Initializer]
vs'' = [[C.cinit|$exp:v|] | PrimValue
v <- [PrimValue]
vs']
forall op s. Definition -> CompilerM op s ()
earlyDecl [C.cedecl|static $ty:ct $id:name_realtype[$int:(length vs')] = {$inits:vs''};|]
ArrayZeros Int
n ->
forall op s. Definition -> CompilerM op s ()
earlyDecl [C.cedecl|static $ty:ct $id:name_realtype[$int:n];|]
forall op s. Id -> Type -> Maybe Exp -> CompilerM op s ()
contextField
(forall a. ToIdent a => a -> SrcLoc -> Id
C.toIdent VName
name forall a. IsLocation a => a
noLoc)
[C.cty|struct memblock|]
forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just
[C.cexp|(struct memblock){NULL,
(unsigned char*)$id:name_realtype,
0,
$string:(prettyString name)}|]
forall op s. BlockItem -> CompilerM op s ()
item [C.citem|struct memblock $id:name = ctx->$id:name;|]
compileCode (DeclareArray VName
name (Space String
space) PrimType
t ArrayContents
vs) =
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall op s. Operations op s -> StaticArray op s
opsStaticArray forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall op s. CompilerEnv op s -> Operations op s
envOperations)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure VName
name
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure String
space
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure PrimType
t
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure ArrayContents
vs
compileCode (SetScalar VName
dest (BinOpExp BinOp
op (LeafExp VName
x PrimType
_) Exp
y))
| VName
dest forall a. Eq a => a -> a -> Bool
== VName
x,
Just VName -> Exp -> Exp
f <- BinOp -> Maybe (VName -> Exp -> Exp)
assignmentOperator BinOp
op = do
Exp
y' <- forall op s. Exp -> CompilerM op s Exp
compileExp Exp
y
forall op s. Stm -> CompilerM op s ()
stm [C.cstm|$exp:(f dest y');|]
compileCode (SetScalar VName
dest Exp
src) = do
Exp
src' <- forall op s. Exp -> CompilerM op s Exp
compileExp Exp
src
forall op s. Stm -> CompilerM op s ()
stm [C.cstm|$id:dest = $exp:src';|]
compileCode (SetMem VName
dest VName
src Space
space) =
forall a b op s.
(ToExp a, ToExp b) =>
a -> b -> Space -> CompilerM op s ()
setMem VName
dest VName
src Space
space
compileCode (Call [VName
dest] Name
fname [Arg]
args)
| Name -> Bool
isBuiltInFunction Name
fname = do
[Exp]
args' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall op s. Arg -> CompilerM op s Exp
compileArg [Arg]
args
forall op s. Stm -> CompilerM op s ()
stm [C.cstm|$id:dest = $id:(funName fname)($args:args');|]
compileCode (Call [VName]
dests Name
fname [Arg]
args) =
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall op s. Operations op s -> CallCompiler op s
opsCall forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall op s. CompilerEnv op s -> Operations op s
envOperations)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure [VName]
dests
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
fname
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall op s. Arg -> CompilerM op s Exp
compileArg [Arg]
args