{-# LANGUAGE QuasiQuotes #-}

-- | Translation of ImpCode Exp and Code to C.
module Futhark.CodeGen.Backends.GenericC.Code
  ( compilePrimExp,
    compileExp,
    compileExpToName,
    compileCode,
    errorMsgString,
    linearCode,
  )
where

import Control.Monad.Reader
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|]

-- | Tell me how to compile a @v@, and I'll Compile any @PrimExp v@ for you.
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
  -- Note that integer addition, subtraction, and multiplication with
  -- OverflowWrap are not handled by explicit operators, but rather by
  -- functions.  This is because we want to implicitly convert them to
  -- unsigned numbers, so we can do overflow without invoking
  -- undefined behaviour.
  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);
       }|]
-- :>>: is treated in a special way to detect declare-set pairs in
-- order to generate prettier code.
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 {}) =
  -- Handled by the declaration of the memory block, which is
  -- translated to an actual array.
  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 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];|]
  -- Fake a memory block.
  forall op s. BlockItem -> CompilerM op s ()
item
    [C.citem|struct memblock $id:name =
               (struct memblock){NULL,
                                 (unsigned char*)$id:name_realtype,
                                 0,
                                 $string:(prettyString name)};|]
-- For assignments of the form 'x = x OP e', we generate C assignment
-- operators to make the resulting code slightly nicer.  This has no
-- effect on performance.
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