{-# LANGUAGE GADTs               #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeOperators       #-}
{-# OPTIONS_HADDOCK hide #-}
-- |
-- Module      : Data.Array.Accelerate.LLVM.CodeGen.Permute
-- Copyright   : [2016..2020] The Accelerate Team
-- License     : BSD3
--
-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--

module Data.Array.Accelerate.LLVM.CodeGen.Permute (

  IRPermuteFun(..),
  llvmOfPermuteFun,

  atomicCAS_rmw,
  atomicCAS_cmp,

) where

import Data.Array.Accelerate.AST
import Data.Array.Accelerate.AST.Idx
import Data.Array.Accelerate.AST.LeftHandSide
import Data.Array.Accelerate.AST.Var
import Data.Array.Accelerate.Debug
import Data.Array.Accelerate.Error
import Data.Array.Accelerate.Representation.Type
import Data.Array.Accelerate.Trafo.Substitution
import Data.Array.Accelerate.Type

import Data.Array.Accelerate.LLVM.CodeGen.Environment
import Data.Array.Accelerate.LLVM.CodeGen.Exp
import Data.Array.Accelerate.LLVM.CodeGen.IR
import Data.Array.Accelerate.LLVM.CodeGen.Monad
import Data.Array.Accelerate.LLVM.CodeGen.Sugar
import Data.Array.Accelerate.LLVM.CodeGen.Type
import Data.Array.Accelerate.LLVM.Foreign

import LLVM.AST.Type.AddrSpace
import LLVM.AST.Type.Instruction
import LLVM.AST.Type.Instruction.Atomic
import LLVM.AST.Type.Instruction.RMW                                as RMW
import LLVM.AST.Type.Instruction.Volatile
import LLVM.AST.Type.Name
import LLVM.AST.Type.Operand
import LLVM.AST.Type.Representation

import Control.Applicative
import Data.Constraint                                              ( withDict )
import System.IO.Unsafe
import Prelude


-- | A forward permutation might be specialised to use atomic instructions to
-- perform the read-modify-write of the output array directly, rather than
-- separately acquiring a lock. The basic operation is always provided in case
-- a backend does not support the atomic operation at that type, or if it is
-- executing sequentially.
--
-- For the atomicRMW case, the function is applied to the new value before
-- feeding to the atomic instruction to combine with the old.
--
data IRPermuteFun arch aenv t where
  IRPermuteFun :: { IRPermuteFun arch aenv (e -> e -> e)
-> IRFun2 arch aenv (e -> e -> e)
combine   :: IRFun2 arch aenv (e -> e -> e)
                  , IRPermuteFun arch aenv (e -> e -> e)
-> Maybe (RMWOperation, IRFun1 arch aenv (e -> e))
atomicRMW :: Maybe
                      ( RMWOperation
                      , IRFun1 arch aenv (e -> e)
                      )
                  }
               -> IRPermuteFun arch aenv (e -> e -> e)


-- | Analysis and code generation for forward permutation combination function.
--
-- Specialisation for atomic operations is currently limited to direct
-- applications of the function; that is, we don't dig down underneath
-- let-bindings.
--
llvmOfPermuteFun
    :: forall arch aenv e. Foreign arch
    => Fun aenv (e -> e -> e)
    -> Gamma aenv
    -> IRPermuteFun arch aenv (e -> e -> e)
llvmOfPermuteFun :: Fun aenv (e -> e -> e)
-> Gamma aenv -> IRPermuteFun arch aenv (e -> e -> e)
llvmOfPermuteFun Fun aenv (e -> e -> e)
fun Gamma aenv
aenv = IRPermuteFun :: forall arch aenv e.
IRFun2 arch aenv (e -> e -> e)
-> Maybe (RMWOperation, IRFun1 arch aenv (e -> e))
-> IRPermuteFun arch aenv (e -> e -> e)
IRPermuteFun{Maybe (RMWOperation, IRFun1 arch aenv (e -> e))
IRFun2 arch aenv (e -> e -> e)
atomicRMW :: Maybe (RMWOperation, IRFun1 arch aenv (e -> e))
combine :: IRFun2 arch aenv (e -> e -> e)
atomicRMW :: Maybe (RMWOperation, IRFun1 arch aenv (e -> e))
combine :: IRFun2 arch aenv (e -> e -> e)
..}
  where
    combine :: IRFun2 arch aenv (e -> e -> e)
combine   = Fun aenv (e -> e -> e)
-> Gamma aenv -> IRFun2 arch aenv (e -> e -> e)
forall arch aenv a b c.
(HasCallStack, Foreign arch) =>
Fun aenv (a -> b -> c)
-> Gamma aenv -> IRFun2 arch aenv (a -> b -> c)
llvmOfFun2 Fun aenv (e -> e -> e)
fun Gamma aenv
aenv
    atomicRMW :: Maybe (RMWOperation, IRFun1 arch aenv (e -> e))
atomicRMW
      -- If the old value is not used (i.e. permute const) then we can just
      -- store the new value directly. Since we do not require the return value
      -- we can do this for any scalar value with a regular Store. However,
      -- as we use an unzipped struct-of-array representation for product
      -- types, the multiple store instructions for the different fields
      -- could come from different threads, so we only allow the non-atomic
      -- version if the flag @-ffast-permute-const@ is set.
      --
      | Lam ELeftHandSide a () env'
lhs (Lam (LeftHandSideWildcard TupR ScalarType a
tp) (Body OpenExp env' aenv t1
body)) <- Fun aenv (e -> e -> e)
fun
      , Bool
True                  <- TypeR e -> Bool
fast TypeR e
TupR ScalarType a
tp
      , IRFun1 arch aenv (a -> t1)
fun'                  <- Fun aenv (a -> t1) -> Gamma aenv -> IRFun1 arch aenv (a -> t1)
forall arch aenv a b.
(HasCallStack, Foreign arch) =>
Fun aenv (a -> b) -> Gamma aenv -> IRFun1 arch aenv (a -> b)
llvmOfFun1 (ELeftHandSide a () env'
-> OpenFun env' aenv t1 -> Fun aenv (a -> t1)
forall a env env' aenv t1.
ELeftHandSide a env env'
-> OpenFun env' aenv t1 -> OpenFun env aenv (a -> t1)
Lam ELeftHandSide a () env'
lhs (OpenExp env' aenv t1 -> OpenFun env' aenv t1
forall env aenv t. OpenExp env aenv t -> OpenFun env aenv t
Body OpenExp env' aenv t1
body)) Gamma aenv
aenv
      = (RMWOperation, IRFun1 arch aenv (a -> t1))
-> Maybe (RMWOperation, IRFun1 arch aenv (a -> t1))
forall a. a -> Maybe a
Just (RMWOperation
Exchange, IRFun1 arch aenv (a -> t1)
fun')

      -- LLVM natively supports atomic operations on integral types only.
      -- However different targets may support atomic instructions on other
      -- scalar types (for example the NVPTX target supports atomic add and
      -- subtract on floating point values).
      --
      -- Additionally it is possible to implement atomic instructions using
      -- atomic compare-and-swap, which is likely to be more performant than the
      -- generic spin-lock based approach.
      --
      | Lam lhs :: ELeftHandSide a () env'
lhs@(LeftHandSideSingle ScalarType a
_) (Lam (LeftHandSideSingle ScalarType a
_) (Body OpenExp env' aenv t1
body)) <- Fun aenv (e -> e -> e)
fun
      , Just (RMWOperation
rmw, OpenExp (((), e), e) aenv e
x)         <- OpenExp (((), e), e) aenv e
-> Maybe (RMWOperation, OpenExp (((), e), e) aenv e)
rmwOp OpenExp env' aenv t1
OpenExp (((), e), e) aenv e
body
      , Just OpenExp env' aenv e
x'               <- ((((), e), e) :?> env')
-> OpenExp (((), e), e) aenv e -> Maybe (OpenExp env' aenv e)
forall (f :: * -> * -> * -> *) env env' aenv t.
RebuildableExp f =>
(env :?> env') -> f env aenv t -> Maybe (f env' aenv t)
strengthenE (((), e), e) :?> env'
(((), e), e) :?> ((), e)
latest OpenExp (((), e), e) aenv e
x
      , IRFun1 arch aenv (a -> e)
fun'                  <- Fun aenv (a -> e) -> Gamma aenv -> IRFun1 arch aenv (a -> e)
forall arch aenv a b.
(HasCallStack, Foreign arch) =>
Fun aenv (a -> b) -> Gamma aenv -> IRFun1 arch aenv (a -> b)
llvmOfFun1 (ELeftHandSide a () env' -> OpenFun env' aenv e -> Fun aenv (a -> e)
forall a env env' aenv t1.
ELeftHandSide a env env'
-> OpenFun env' aenv t1 -> OpenFun env aenv (a -> t1)
Lam ELeftHandSide a () env'
lhs (OpenExp env' aenv e -> OpenFun env' aenv e
forall env aenv t. OpenExp env aenv t -> OpenFun env aenv t
Body OpenExp env' aenv e
x')) Gamma aenv
aenv
      = (RMWOperation, IRFun1 arch aenv (a -> e))
-> Maybe (RMWOperation, IRFun1 arch aenv (a -> e))
forall a. a -> Maybe a
Just (RMWOperation
rmw, IRFun1 arch aenv (a -> e)
fun')

      | Bool
otherwise
      = Maybe (RMWOperation, IRFun1 arch aenv (e -> e))
forall a. Maybe a
Nothing

    fast :: TypeR e -> Bool
    fast :: TypeR e -> Bool
fast TypeR e
tp
      | TupRsingle{} <- TypeR e
tp = Bool
True
      | Bool
otherwise          = IO Bool -> Bool
forall a. IO a -> a
unsafePerformIO (Flag -> IO Bool
getFlag Flag
fast_permute_const)

    -- XXX: This doesn't work for newtypes because the coercion gets in the
    -- way. This should be generalised to work for product types (e.g.
    -- complex numbers) and take this factor into account as well.
    --    TLM-2019-09-27
    --
    rmwOp :: OpenExp (((),e),e) aenv e -> Maybe (RMWOperation, OpenExp (((),e),e) aenv e)
    rmwOp :: OpenExp (((), e), e) aenv e
-> Maybe (RMWOperation, OpenExp (((), e), e) aenv e)
rmwOp (PrimApp PrimFun (a -> e)
f OpenExp (((), e), e) aenv a
xs)
      | PrimAdd{}  <- PrimFun (a -> e)
f = (RMWOperation
RMW.Add,) (OpenExp (((), e), e) aenv e
 -> (RMWOperation, OpenExp (((), e), e) aenv e))
-> Maybe (OpenExp (((), e), e) aenv e)
-> Maybe (RMWOperation, OpenExp (((), e), e) aenv e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OpenExp (((), e), e) aenv (e, e)
-> Maybe (OpenExp (((), e), e) aenv e)
extract OpenExp (((), e), e) aenv a
OpenExp (((), e), e) aenv (e, e)
xs
      | PrimSub{}  <- PrimFun (a -> e)
f = (RMWOperation
RMW.Sub,) (OpenExp (((), e), e) aenv e
 -> (RMWOperation, OpenExp (((), e), e) aenv e))
-> Maybe (OpenExp (((), e), e) aenv e)
-> Maybe (RMWOperation, OpenExp (((), e), e) aenv e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OpenExp (((), e), e) aenv (e, e)
-> Maybe (OpenExp (((), e), e) aenv e)
extract OpenExp (((), e), e) aenv a
OpenExp (((), e), e) aenv (e, e)
xs
      | PrimMin{}  <- PrimFun (a -> e)
f = (RMWOperation
RMW.Min,) (OpenExp (((), e), e) aenv e
 -> (RMWOperation, OpenExp (((), e), e) aenv e))
-> Maybe (OpenExp (((), e), e) aenv e)
-> Maybe (RMWOperation, OpenExp (((), e), e) aenv e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OpenExp (((), e), e) aenv (e, e)
-> Maybe (OpenExp (((), e), e) aenv e)
extract OpenExp (((), e), e) aenv a
OpenExp (((), e), e) aenv (e, e)
xs
      | PrimMax{}  <- PrimFun (a -> e)
f = (RMWOperation
RMW.Max,) (OpenExp (((), e), e) aenv e
 -> (RMWOperation, OpenExp (((), e), e) aenv e))
-> Maybe (OpenExp (((), e), e) aenv e)
-> Maybe (RMWOperation, OpenExp (((), e), e) aenv e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OpenExp (((), e), e) aenv (e, e)
-> Maybe (OpenExp (((), e), e) aenv e)
extract OpenExp (((), e), e) aenv a
OpenExp (((), e), e) aenv (e, e)
xs
      | PrimBOr{}  <- PrimFun (a -> e)
f = (RMWOperation
RMW.Or,)  (OpenExp (((), e), e) aenv e
 -> (RMWOperation, OpenExp (((), e), e) aenv e))
-> Maybe (OpenExp (((), e), e) aenv e)
-> Maybe (RMWOperation, OpenExp (((), e), e) aenv e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OpenExp (((), e), e) aenv (e, e)
-> Maybe (OpenExp (((), e), e) aenv e)
extract OpenExp (((), e), e) aenv a
OpenExp (((), e), e) aenv (e, e)
xs
      | PrimBAnd{} <- PrimFun (a -> e)
f = (RMWOperation
RMW.And,) (OpenExp (((), e), e) aenv e
 -> (RMWOperation, OpenExp (((), e), e) aenv e))
-> Maybe (OpenExp (((), e), e) aenv e)
-> Maybe (RMWOperation, OpenExp (((), e), e) aenv e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OpenExp (((), e), e) aenv (e, e)
-> Maybe (OpenExp (((), e), e) aenv e)
extract OpenExp (((), e), e) aenv a
OpenExp (((), e), e) aenv (e, e)
xs
      | PrimBXor{} <- PrimFun (a -> e)
f = (RMWOperation
RMW.Xor,) (OpenExp (((), e), e) aenv e
 -> (RMWOperation, OpenExp (((), e), e) aenv e))
-> Maybe (OpenExp (((), e), e) aenv e)
-> Maybe (RMWOperation, OpenExp (((), e), e) aenv e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OpenExp (((), e), e) aenv (e, e)
-> Maybe (OpenExp (((), e), e) aenv e)
extract OpenExp (((), e), e) aenv a
OpenExp (((), e), e) aenv (e, e)
xs
    rmwOp OpenExp (((), e), e) aenv e
_             = Maybe (RMWOperation, OpenExp (((), e), e) aenv e)
forall a. Maybe a
Nothing

    -- Determine which argument to a binary function was the new value being
    -- combined. This only works when the old value is used unmodified, but that
    -- is sufficient for us because otherwise it would not be suitable for the
    -- atomic update operation.
    --
    -- In the permutation function, the old value is given as the second
    -- argument, corresponding to ZeroIdx.
    --
    extract :: OpenExp (((),e),e) aenv (e,e) -> Maybe (OpenExp (((),e),e) aenv e)
    extract :: OpenExp (((), e), e) aenv (e, e)
-> Maybe (OpenExp (((), e), e) aenv e)
extract (Pair OpenExp (((), e), e) aenv t1
x OpenExp (((), e), e) aenv t2
y)
      | Evar (Var ScalarType t1
_ Idx (((), e), e) t1
ZeroIdx) <- OpenExp (((), e), e) aenv t1
x = OpenExp (((), e), e) aenv t2
-> Maybe (OpenExp (((), e), e) aenv t2)
forall a. a -> Maybe a
Just OpenExp (((), e), e) aenv t2
y
      | Evar (Var ScalarType t2
_ Idx (((), e), e) t2
ZeroIdx) <- OpenExp (((), e), e) aenv t2
y = OpenExp (((), e), e) aenv t1
-> Maybe (OpenExp (((), e), e) aenv t1)
forall a. a -> Maybe a
Just OpenExp (((), e), e) aenv t1
x
    extract OpenExp (((), e), e) aenv (e, e)
_
      = Maybe (OpenExp (((), e), e) aenv e)
forall a. Maybe a
Nothing

    -- Used with 'strengthenE' to ensure that the expression does not make use
    -- of the old value except in the combination function.
    latest :: (((),e),e) :?> ((),e)
    latest :: Idx (((), e), e) t' -> Maybe (Idx ((), e) t')
latest Idx (((), e), e) t'
ZeroIdx      = Maybe (Idx ((), e) t')
forall a. Maybe a
Nothing
    latest (SuccIdx Idx env1 t'
ix) = Idx env1 t' -> Maybe (Idx env1 t')
forall a. a -> Maybe a
Just Idx env1 t'
ix


-- Implementation of atomic RMW operation (e.g. (+), (-)) using atomic
-- compare-and-swap instructions, for targets which do not support the native
-- instruction at this type but do support CAS at this bit width.
--
-- > void casAdd(double *addr, double val)
-- > {
-- >     uint64_t* addr_i = reinterpret_cast<uint64_t*> addr;
-- >     uint64_t old     = *addr_i;
-- >
-- >     do {
-- >       uint64_t expected = old;
-- >       uint64_t new      = reinterpret_cast<uint64_t>(val + reinterpret_cast<double>(expected));
-- >
-- >       uint64_t old      = atomicCAS(addr_i, expected, new);
-- >     }
-- >     while (old != expected);
-- > }
--
atomicCAS_rmw
    :: forall arch e. HasCallStack
    => SingleType e
    -> (Operands e -> CodeGen arch (Operands e))
    -> Operand (Ptr e)
    -> CodeGen arch ()
atomicCAS_rmw :: SingleType e
-> (Operands e -> CodeGen arch (Operands e))
-> Operand (Ptr e)
-> CodeGen arch ()
atomicCAS_rmw SingleType e
t Operands e -> CodeGen arch (Operands e)
update Operand (Ptr e)
addr =
  case SingleType e
t of
    NumSingleType (FloatingNumType FloatingType e
f) -> FloatingType e -> CodeGen arch ()
forall t. FloatingType t -> CodeGen arch ()
floating FloatingType e
f
    NumSingleType (IntegralNumType IntegralType e
i) -> IntegralType e -> CodeGen arch ()
forall t. IntegralType t -> CodeGen arch ()
integral IntegralType e
i

  where
    floating :: FloatingType t -> CodeGen arch ()
    floating :: FloatingType t -> CodeGen arch ()
floating TypeHalf{}   = SingleType e
-> IntegralType Word16
-> (Operands e -> CodeGen arch (Operands e))
-> Operand (Ptr e)
-> CodeGen arch ()
forall t i arch.
HasCallStack =>
SingleType t
-> IntegralType i
-> (Operands t -> CodeGen arch (Operands t))
-> Operand (Ptr t)
-> CodeGen arch ()
atomicCAS_rmw' SingleType e
t (IntegralType Word16
forall a. IsIntegral a => IntegralType a
integralType :: IntegralType Word16) Operands e -> CodeGen arch (Operands e)
update Operand (Ptr e)
addr
    floating TypeFloat{}  = SingleType e
-> IntegralType Word32
-> (Operands e -> CodeGen arch (Operands e))
-> Operand (Ptr e)
-> CodeGen arch ()
forall t i arch.
HasCallStack =>
SingleType t
-> IntegralType i
-> (Operands t -> CodeGen arch (Operands t))
-> Operand (Ptr t)
-> CodeGen arch ()
atomicCAS_rmw' SingleType e
t (IntegralType Word32
forall a. IsIntegral a => IntegralType a
integralType :: IntegralType Word32) Operands e -> CodeGen arch (Operands e)
update Operand (Ptr e)
addr
    floating TypeDouble{} = SingleType e
-> IntegralType Word64
-> (Operands e -> CodeGen arch (Operands e))
-> Operand (Ptr e)
-> CodeGen arch ()
forall t i arch.
HasCallStack =>
SingleType t
-> IntegralType i
-> (Operands t -> CodeGen arch (Operands t))
-> Operand (Ptr t)
-> CodeGen arch ()
atomicCAS_rmw' SingleType e
t (IntegralType Word64
forall a. IsIntegral a => IntegralType a
integralType :: IntegralType Word64) Operands e -> CodeGen arch (Operands e)
update Operand (Ptr e)
addr

    integral :: IntegralType t -> CodeGen arch ()
    integral :: IntegralType t -> CodeGen arch ()
integral IntegralType t
i            = SingleType e
-> IntegralType t
-> (Operands e -> CodeGen arch (Operands e))
-> Operand (Ptr e)
-> CodeGen arch ()
forall t i arch.
HasCallStack =>
SingleType t
-> IntegralType i
-> (Operands t -> CodeGen arch (Operands t))
-> Operand (Ptr t)
-> CodeGen arch ()
atomicCAS_rmw' SingleType e
t IntegralType t
i Operands e -> CodeGen arch (Operands e)
update Operand (Ptr e)
addr


atomicCAS_rmw'
    :: HasCallStack
    => SingleType t
    -> IntegralType i
    -> (Operands t -> CodeGen arch (Operands t))
    -> Operand (Ptr t)
    -> CodeGen arch ()
atomicCAS_rmw' :: SingleType t
-> IntegralType i
-> (Operands t -> CodeGen arch (Operands t))
-> Operand (Ptr t)
-> CodeGen arch ()
atomicCAS_rmw' SingleType t
t IntegralType i
i Operands t -> CodeGen arch (Operands t)
update Operand (Ptr t)
addr = Dict (Elt i) -> (Elt i => CodeGen arch ()) -> CodeGen arch ()
forall (c :: Constraint) e r. HasDict c e => e -> (c => r) -> r
withDict (IntegralType i -> Dict (Elt i)
forall a. IntegralType a -> Dict (Elt a)
integralElt IntegralType i
i) ((Elt i => CodeGen arch ()) -> CodeGen arch ())
-> (Elt i => CodeGen arch ()) -> CodeGen arch ()
forall a b. (a -> b) -> a -> b
$ do
  let si :: ScalarType i
si = SingleType i -> ScalarType i
forall a. SingleType a -> ScalarType a
SingleScalarType (NumType i -> SingleType i
forall a. NumType a -> SingleType a
NumSingleType (IntegralType i -> NumType i
forall a. IntegralType a -> NumType a
IntegralNumType IntegralType i
i))
  --
  Block
spin  <- String -> CodeGen arch Block
forall arch. HasCallStack => String -> CodeGen arch Block
newBlock String
"rmw.spin"
  Block
exit  <- String -> CodeGen arch Block
forall arch. HasCallStack => String -> CodeGen arch Block
newBlock String
"rmw.exit"

  Operand (Ptr i)
addr' <- Instruction (Ptr i) -> CodeGen arch (Operand (Ptr i))
forall a arch.
HasCallStack =>
Instruction a -> CodeGen arch (Operand a)
instr' (Instruction (Ptr i) -> CodeGen arch (Operand (Ptr i)))
-> Instruction (Ptr i) -> CodeGen arch (Operand (Ptr i))
forall a b. (a -> b) -> a -> b
$ PrimType (Ptr i) -> Operand (Ptr t) -> Instruction (Ptr i)
forall b a.
PrimType (Ptr b) -> Operand (Ptr a) -> Instruction (Ptr b)
PtrCast (PrimType i -> AddrSpace -> PrimType (Ptr i)
forall a. PrimType a -> AddrSpace -> PrimType (Ptr a)
PtrPrimType (ScalarType i -> PrimType i
forall a. ScalarType a -> PrimType a
ScalarPrimType ScalarType i
si) AddrSpace
defaultAddrSpace) Operand (Ptr t)
addr
  Operand i
init' <- Instruction i -> CodeGen arch (Operand i)
forall a arch.
HasCallStack =>
Instruction a -> CodeGen arch (Operand a)
instr' (Instruction i -> CodeGen arch (Operand i))
-> Instruction i -> CodeGen arch (Operand i)
forall a b. (a -> b) -> a -> b
$ ScalarType i -> Volatility -> Operand (Ptr i) -> Instruction i
forall a.
ScalarType a -> Volatility -> Operand (Ptr a) -> Instruction a
Load ScalarType i
si Volatility
NonVolatile Operand (Ptr i)
addr'
  Operands i
old'  <- TypeR i -> CodeGen arch (Operands i)
forall a arch. TypeR a -> CodeGen arch (Operands a)
fresh  (TypeR i -> CodeGen arch (Operands i))
-> TypeR i -> CodeGen arch (Operands i)
forall a b. (a -> b) -> a -> b
$ ScalarType i -> TypeR i
forall (s :: * -> *) a. s a -> TupR s a
TupRsingle ScalarType i
si
  Block
top   <- Block -> CodeGen arch Block
forall arch. HasCallStack => Block -> CodeGen arch Block
br Block
spin

  Block -> CodeGen arch ()
forall arch. Block -> CodeGen arch ()
setBlock Block
spin
  Operand t
old   <- Instruction t -> CodeGen arch (Operand t)
forall a arch.
HasCallStack =>
Instruction a -> CodeGen arch (Operand a)
instr' (Instruction t -> CodeGen arch (Operand t))
-> Instruction t -> CodeGen arch (Operand t)
forall a b. (a -> b) -> a -> b
$ ScalarType t -> Operand i -> Instruction t
forall b a. ScalarType b -> Operand a -> Instruction b
BitCast (SingleType t -> ScalarType t
forall a. SingleType a -> ScalarType a
SingleScalarType SingleType t
t) (IntegralType i -> Operands i -> Operand i
forall (dict :: * -> *) a.
(IROP dict, HasCallStack) =>
dict a -> Operands a -> Operand a
op IntegralType i
i Operands i
old')
  Operands t
val   <- Operands t -> CodeGen arch (Operands t)
update (Operands t -> CodeGen arch (Operands t))
-> Operands t -> CodeGen arch (Operands t)
forall a b. (a -> b) -> a -> b
$ SingleType t -> Operand t -> Operands t
forall (dict :: * -> *) a.
(IROP dict, HasCallStack) =>
dict a -> Operand a -> Operands a
ir SingleType t
t Operand t
old
  Operand i
val'  <- Instruction i -> CodeGen arch (Operand i)
forall a arch.
HasCallStack =>
Instruction a -> CodeGen arch (Operand a)
instr' (Instruction i -> CodeGen arch (Operand i))
-> Instruction i -> CodeGen arch (Operand i)
forall a b. (a -> b) -> a -> b
$ ScalarType i -> Operand t -> Instruction i
forall b a. ScalarType b -> Operand a -> Instruction b
BitCast ScalarType i
si (SingleType t -> Operands t -> Operand t
forall (dict :: * -> *) a.
(IROP dict, HasCallStack) =>
dict a -> Operands a -> Operand a
op SingleType t
t Operands t
val)
  Operand (i, PrimBool)
r     <- Instruction (i, PrimBool) -> CodeGen arch (Operand (i, PrimBool))
forall a arch.
HasCallStack =>
Instruction a -> CodeGen arch (Operand a)
instr' (Instruction (i, PrimBool) -> CodeGen arch (Operand (i, PrimBool)))
-> Instruction (i, PrimBool)
-> CodeGen arch (Operand (i, PrimBool))
forall a b. (a -> b) -> a -> b
$ IntegralType i
-> Volatility
-> Operand (Ptr i)
-> Operand i
-> Operand i
-> Atomicity
-> MemoryOrdering
-> Instruction (i, PrimBool)
forall a.
IntegralType a
-> Volatility
-> Operand (Ptr a)
-> Operand a
-> Operand a
-> Atomicity
-> MemoryOrdering
-> Instruction (a, PrimBool)
CmpXchg IntegralType i
i Volatility
NonVolatile Operand (Ptr i)
addr' (IntegralType i -> Operands i -> Operand i
forall (dict :: * -> *) a.
(IROP dict, HasCallStack) =>
dict a -> Operands a -> Operand a
op IntegralType i
i Operands i
old') Operand i
val' (Synchronisation
CrossThread, MemoryOrdering
AcquireRelease) MemoryOrdering
Monotonic
  Operand PrimBool
done  <- Instruction PrimBool -> CodeGen arch (Operand PrimBool)
forall a arch.
HasCallStack =>
Instruction a -> CodeGen arch (Operand a)
instr' (Instruction PrimBool -> CodeGen arch (Operand PrimBool))
-> Instruction PrimBool -> CodeGen arch (Operand PrimBool)
forall a b. (a -> b) -> a -> b
$ ScalarType PrimBool
-> PairIdx (i, PrimBool) PrimBool
-> Operand (i, PrimBool)
-> Instruction PrimBool
forall t tup.
ScalarType t -> PairIdx tup t -> Operand tup -> Instruction t
ExtractValue ScalarType PrimBool
forall a. IsScalar a => ScalarType a
scalarType PairIdx (i, PrimBool) PrimBool
forall a1 a. PairIdx (a1, a) a
PairIdxRight Operand (i, PrimBool)
r
  Operand i
next' <- Instruction i -> CodeGen arch (Operand i)
forall a arch.
HasCallStack =>
Instruction a -> CodeGen arch (Operand a)
instr' (Instruction i -> CodeGen arch (Operand i))
-> Instruction i -> CodeGen arch (Operand i)
forall a b. (a -> b) -> a -> b
$ ScalarType i
-> PairIdx (i, PrimBool) i
-> Operand (i, PrimBool)
-> Instruction i
forall t tup.
ScalarType t -> PairIdx tup t -> Operand tup -> Instruction t
ExtractValue ScalarType i
si         PairIdx (i, PrimBool) i
forall a b. PairIdx (a, b) a
PairIdxLeft  Operand (i, PrimBool)
r

  -- Since we removed Bool from the set of primitive types Accelerate
  -- supports, we have to do a small hack to have LLVM consider this as its
  -- correct type of a 1-bit integer (rather than the 8-bits it is actually
  -- stored as)
  Operands Bool
done' <- case Operand PrimBool
done of
             LocalReference Type PrimBool
_ (UnName Word
n) -> Operands Bool -> CodeGen arch (Operands Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Operands Bool -> CodeGen arch (Operands Bool))
-> Operands Bool -> CodeGen arch (Operands Bool)
forall a b. (a -> b) -> a -> b
$ Operand Bool -> Operands Bool
OP_Bool (Type Bool -> Name Bool -> Operand Bool
forall a. Type a -> Name a -> Operand a
LocalReference Type Bool
forall a. IsType a => Type a
type' (Word -> Name Bool
forall a. Word -> Name a
UnName Word
n))
             Operand PrimBool
_                           -> String -> CodeGen arch (Operands Bool)
forall a. HasCallStack => String -> a
internalError String
"expected unnamed local reference"

  Block
bot   <- Operands Bool -> Block -> Block -> CodeGen arch Block
forall arch.
HasCallStack =>
Operands Bool -> Block -> Block -> CodeGen arch Block
cbr Operands Bool
done' Block
exit Block
spin
  Operands i
_     <- TypeR i
-> Block
-> Operands i
-> [(Operands i, Block)]
-> CodeGen arch (Operands i)
forall a arch.
HasCallStack =>
TypeR a
-> Block
-> Operands a
-> [(Operands a, Block)]
-> CodeGen arch (Operands a)
phi' (ScalarType i -> TypeR i
forall (s :: * -> *) a. s a -> TupR s a
TupRsingle ScalarType i
si) Block
spin Operands i
old' [(IntegralType i -> Operand i -> Operands i
forall (dict :: * -> *) a.
(IROP dict, HasCallStack) =>
dict a -> Operand a -> Operands a
ir IntegralType i
i Operand i
init',Block
top), (IntegralType i -> Operand i -> Operands i
forall (dict :: * -> *) a.
(IROP dict, HasCallStack) =>
dict a -> Operand a -> Operands a
ir IntegralType i
i Operand i
next',Block
bot)]

  Block -> CodeGen arch ()
forall arch. Block -> CodeGen arch ()
setBlock Block
exit


-- Implementation of atomic comparison operators (i.e. min, max) using
-- compare-and-swap, for targets which do not support the native instruction at
-- this type but do support CAS at this bit width. The old value is discarded.
--
-- For example, atomicMin is implemented similarly to the following (however the
-- loop condition is more complex):
--
-- > void casMin(double *addr, double val)
-- > {
-- >     double old      = *addr;
-- >     uint64_t val_i  = reinterpret_cast<uint64_t>(val);
-- >     uint64_t addr_i = reinterpret_cast<uint64_t*>(addr);
-- >
-- >     while (val < old) {
-- >         uint64_t assumed_i = reinterpret_cast<uint64_t>(old);
-- >         uint64_t old_i     = atomicCAS(addr_i, assumed_i, val_i);
-- >         old                = reinterpret_cast<double>(old_i);
-- >     }
-- > }
--
-- If the function returns 'True', then the given value should be written to the
-- address.
--
atomicCAS_cmp
    :: forall arch e. HasCallStack
    => SingleType e
    -> (SingleType e -> Operands e -> Operands e -> CodeGen arch (Operands Bool))
    -> Operand (Ptr e)
    -> Operand e
    -> CodeGen arch ()
atomicCAS_cmp :: SingleType e
-> (SingleType e
    -> Operands e -> Operands e -> CodeGen arch (Operands Bool))
-> Operand (Ptr e)
-> Operand e
-> CodeGen arch ()
atomicCAS_cmp SingleType e
t SingleType e
-> Operands e -> Operands e -> CodeGen arch (Operands Bool)
cmp Operand (Ptr e)
addr Operand e
val =
  case SingleType e
t of
    NumSingleType (FloatingNumType FloatingType e
f) -> FloatingType e -> CodeGen arch ()
forall t. FloatingType t -> CodeGen arch ()
floating FloatingType e
f
    NumSingleType (IntegralNumType IntegralType e
i) -> IntegralType e -> CodeGen arch ()
forall t. IntegralType t -> CodeGen arch ()
integral IntegralType e
i

  where
    floating :: FloatingType t -> CodeGen arch ()
    floating :: FloatingType t -> CodeGen arch ()
floating TypeHalf{}   = SingleType e
-> IntegralType Word16
-> (SingleType e
    -> Operands e -> Operands e -> CodeGen arch (Operands Bool))
-> Operand (Ptr e)
-> Operand e
-> CodeGen arch ()
forall t i arch.
HasCallStack =>
SingleType t
-> IntegralType i
-> (SingleType t
    -> Operands t -> Operands t -> CodeGen arch (Operands Bool))
-> Operand (Ptr t)
-> Operand t
-> CodeGen arch ()
atomicCAS_cmp' SingleType e
t (IntegralType Word16
forall a. IsIntegral a => IntegralType a
integralType :: IntegralType Word16) SingleType e
-> Operands e -> Operands e -> CodeGen arch (Operands Bool)
cmp Operand (Ptr e)
addr Operand e
val
    floating TypeFloat{}  = SingleType e
-> IntegralType Word32
-> (SingleType e
    -> Operands e -> Operands e -> CodeGen arch (Operands Bool))
-> Operand (Ptr e)
-> Operand e
-> CodeGen arch ()
forall t i arch.
HasCallStack =>
SingleType t
-> IntegralType i
-> (SingleType t
    -> Operands t -> Operands t -> CodeGen arch (Operands Bool))
-> Operand (Ptr t)
-> Operand t
-> CodeGen arch ()
atomicCAS_cmp' SingleType e
t (IntegralType Word32
forall a. IsIntegral a => IntegralType a
integralType :: IntegralType Word32) SingleType e
-> Operands e -> Operands e -> CodeGen arch (Operands Bool)
cmp Operand (Ptr e)
addr Operand e
val
    floating TypeDouble{} = SingleType e
-> IntegralType Word64
-> (SingleType e
    -> Operands e -> Operands e -> CodeGen arch (Operands Bool))
-> Operand (Ptr e)
-> Operand e
-> CodeGen arch ()
forall t i arch.
HasCallStack =>
SingleType t
-> IntegralType i
-> (SingleType t
    -> Operands t -> Operands t -> CodeGen arch (Operands Bool))
-> Operand (Ptr t)
-> Operand t
-> CodeGen arch ()
atomicCAS_cmp' SingleType e
t (IntegralType Word64
forall a. IsIntegral a => IntegralType a
integralType :: IntegralType Word64) SingleType e
-> Operands e -> Operands e -> CodeGen arch (Operands Bool)
cmp Operand (Ptr e)
addr Operand e
val

    integral :: IntegralType t -> CodeGen arch ()
    integral :: IntegralType t -> CodeGen arch ()
integral IntegralType t
i            = SingleType e
-> IntegralType t
-> (SingleType e
    -> Operands e -> Operands e -> CodeGen arch (Operands Bool))
-> Operand (Ptr e)
-> Operand e
-> CodeGen arch ()
forall t i arch.
HasCallStack =>
SingleType t
-> IntegralType i
-> (SingleType t
    -> Operands t -> Operands t -> CodeGen arch (Operands Bool))
-> Operand (Ptr t)
-> Operand t
-> CodeGen arch ()
atomicCAS_cmp' SingleType e
t IntegralType t
i SingleType e
-> Operands e -> Operands e -> CodeGen arch (Operands Bool)
cmp Operand (Ptr e)
addr Operand e
val


atomicCAS_cmp'
    :: HasCallStack
    => SingleType t       -- actual type of elements
    -> IntegralType i     -- unsigned integral type of same bit size as 't'
    -> (SingleType t -> Operands t -> Operands t -> CodeGen arch (Operands Bool))
    -> Operand (Ptr t)
    -> Operand t
    -> CodeGen arch ()
atomicCAS_cmp' :: SingleType t
-> IntegralType i
-> (SingleType t
    -> Operands t -> Operands t -> CodeGen arch (Operands Bool))
-> Operand (Ptr t)
-> Operand t
-> CodeGen arch ()
atomicCAS_cmp' SingleType t
t IntegralType i
i SingleType t
-> Operands t -> Operands t -> CodeGen arch (Operands Bool)
cmp Operand (Ptr t)
addr Operand t
val = Dict (Elt t) -> (Elt t => CodeGen arch ()) -> CodeGen arch ()
forall (c :: Constraint) e r. HasDict c e => e -> (c => r) -> r
withDict (SingleType t -> Dict (Elt t)
forall a. SingleType a -> Dict (Elt a)
singleElt SingleType t
t) ((Elt t => CodeGen arch ()) -> CodeGen arch ())
-> (Elt t => CodeGen arch ()) -> CodeGen arch ()
forall a b. (a -> b) -> a -> b
$ do
  let si :: ScalarType i
si = SingleType i -> ScalarType i
forall a. SingleType a -> ScalarType a
SingleScalarType (NumType i -> SingleType i
forall a. NumType a -> SingleType a
NumSingleType (IntegralType i -> NumType i
forall a. IntegralType a -> NumType a
IntegralNumType IntegralType i
i))
  --
  Block
test  <- String -> CodeGen arch Block
forall arch. HasCallStack => String -> CodeGen arch Block
newBlock String
"cas.cmp"
  Block
spin  <- String -> CodeGen arch Block
forall arch. HasCallStack => String -> CodeGen arch Block
newBlock String
"cas.retry"
  Block
exit  <- String -> CodeGen arch Block
forall arch. HasCallStack => String -> CodeGen arch Block
newBlock String
"cas.exit"

  -- The new value and address to swap cast to integral type
  Operand (Ptr i)
addr' <- Instruction (Ptr i) -> CodeGen arch (Operand (Ptr i))
forall a arch.
HasCallStack =>
Instruction a -> CodeGen arch (Operand a)
instr' (Instruction (Ptr i) -> CodeGen arch (Operand (Ptr i)))
-> Instruction (Ptr i) -> CodeGen arch (Operand (Ptr i))
forall a b. (a -> b) -> a -> b
$ PrimType (Ptr i) -> Operand (Ptr t) -> Instruction (Ptr i)
forall b a.
PrimType (Ptr b) -> Operand (Ptr a) -> Instruction (Ptr b)
PtrCast (PrimType i -> AddrSpace -> PrimType (Ptr i)
forall a. PrimType a -> AddrSpace -> PrimType (Ptr a)
PtrPrimType (ScalarType i -> PrimType i
forall a. ScalarType a -> PrimType a
ScalarPrimType ScalarType i
si) AddrSpace
defaultAddrSpace) Operand (Ptr t)
addr
  Operand i
val'  <- Instruction i -> CodeGen arch (Operand i)
forall a arch.
HasCallStack =>
Instruction a -> CodeGen arch (Operand a)
instr' (Instruction i -> CodeGen arch (Operand i))
-> Instruction i -> CodeGen arch (Operand i)
forall a b. (a -> b) -> a -> b
$ ScalarType i -> Operand t -> Instruction i
forall b a. ScalarType b -> Operand a -> Instruction b
BitCast ScalarType i
si Operand t
val
  Operands t
old   <- TypeR t -> CodeGen arch (Operands t)
forall a arch. TypeR a -> CodeGen arch (Operands a)
fresh  (TypeR t -> CodeGen arch (Operands t))
-> TypeR t -> CodeGen arch (Operands t)
forall a b. (a -> b) -> a -> b
$ ScalarType t -> TypeR t
forall (s :: * -> *) a. s a -> TupR s a
TupRsingle (ScalarType t -> TypeR t) -> ScalarType t -> TypeR t
forall a b. (a -> b) -> a -> b
$ SingleType t -> ScalarType t
forall a. SingleType a -> ScalarType a
SingleScalarType SingleType t
t

  -- Read the current value at the address
  Operand t
start <- Instruction t -> CodeGen arch (Operand t)
forall a arch.
HasCallStack =>
Instruction a -> CodeGen arch (Operand a)
instr' (Instruction t -> CodeGen arch (Operand t))
-> Instruction t -> CodeGen arch (Operand t)
forall a b. (a -> b) -> a -> b
$ ScalarType t -> Volatility -> Operand (Ptr t) -> Instruction t
forall a.
ScalarType a -> Volatility -> Operand (Ptr a) -> Instruction a
Load (SingleType t -> ScalarType t
forall a. SingleType a -> ScalarType a
SingleScalarType SingleType t
t) Volatility
NonVolatile Operand (Ptr t)
addr
  Block
top   <- Block -> CodeGen arch Block
forall arch. HasCallStack => Block -> CodeGen arch Block
br Block
test

  -- Compare the new value with the current contents at that memory slot. If the
  -- comparison fails (e.g. we are computing atomicMin but the new value is
  -- already larger than the current value) then exit.
  Block -> CodeGen arch ()
forall arch. Block -> CodeGen arch ()
setBlock Block
test
  Operands Bool
yes   <- SingleType t
-> Operands t -> Operands t -> CodeGen arch (Operands Bool)
cmp SingleType t
t (SingleType t -> Operand t -> Operands t
forall (dict :: * -> *) a.
(IROP dict, HasCallStack) =>
dict a -> Operand a -> Operands a
ir SingleType t
t Operand t
val) Operands t
old
  Block
_     <- Operands Bool -> Block -> Block -> CodeGen arch Block
forall arch.
HasCallStack =>
Operands Bool -> Block -> Block -> CodeGen arch Block
cbr Operands Bool
yes Block
spin Block
exit

  -- Attempt to exchange the memory at this location with the new value. The
  -- CmpXchg instruction returns the old value together with a flag indicating
  -- whether or not the swap occurred. If the swap is successful we are done,
  -- otherwise reapply the comparison value with the newly acquired value.
  Block -> CodeGen arch ()
forall arch. Block -> CodeGen arch ()
setBlock Block
spin
  Operand i
old'  <- Instruction i -> CodeGen arch (Operand i)
forall a arch.
HasCallStack =>
Instruction a -> CodeGen arch (Operand a)
instr' (Instruction i -> CodeGen arch (Operand i))
-> Instruction i -> CodeGen arch (Operand i)
forall a b. (a -> b) -> a -> b
$ ScalarType i -> Operand t -> Instruction i
forall b a. ScalarType b -> Operand a -> Instruction b
BitCast ScalarType i
si (SingleType t -> Operands t -> Operand t
forall (dict :: * -> *) a.
(IROP dict, HasCallStack) =>
dict a -> Operands a -> Operand a
op SingleType t
t Operands t
old)
  Operand (i, PrimBool)
r     <- Instruction (i, PrimBool) -> CodeGen arch (Operand (i, PrimBool))
forall a arch.
HasCallStack =>
Instruction a -> CodeGen arch (Operand a)
instr' (Instruction (i, PrimBool) -> CodeGen arch (Operand (i, PrimBool)))
-> Instruction (i, PrimBool)
-> CodeGen arch (Operand (i, PrimBool))
forall a b. (a -> b) -> a -> b
$ IntegralType i
-> Volatility
-> Operand (Ptr i)
-> Operand i
-> Operand i
-> Atomicity
-> MemoryOrdering
-> Instruction (i, PrimBool)
forall a.
IntegralType a
-> Volatility
-> Operand (Ptr a)
-> Operand a
-> Operand a
-> Atomicity
-> MemoryOrdering
-> Instruction (a, PrimBool)
CmpXchg IntegralType i
i Volatility
NonVolatile Operand (Ptr i)
addr' Operand i
old' Operand i
val' (Synchronisation
CrossThread, MemoryOrdering
AcquireRelease) MemoryOrdering
Monotonic
  Operand PrimBool
done  <- Instruction PrimBool -> CodeGen arch (Operand PrimBool)
forall a arch.
HasCallStack =>
Instruction a -> CodeGen arch (Operand a)
instr' (Instruction PrimBool -> CodeGen arch (Operand PrimBool))
-> Instruction PrimBool -> CodeGen arch (Operand PrimBool)
forall a b. (a -> b) -> a -> b
$ ScalarType PrimBool
-> PairIdx (i, PrimBool) PrimBool
-> Operand (i, PrimBool)
-> Instruction PrimBool
forall t tup.
ScalarType t -> PairIdx tup t -> Operand tup -> Instruction t
ExtractValue ScalarType PrimBool
forall a. IsScalar a => ScalarType a
scalarType PairIdx (i, PrimBool) PrimBool
forall a1 a. PairIdx (a1, a) a
PairIdxRight Operand (i, PrimBool)
r
  Operand i
next  <- Instruction i -> CodeGen arch (Operand i)
forall a arch.
HasCallStack =>
Instruction a -> CodeGen arch (Operand a)
instr' (Instruction i -> CodeGen arch (Operand i))
-> Instruction i -> CodeGen arch (Operand i)
forall a b. (a -> b) -> a -> b
$ ScalarType i
-> PairIdx (i, PrimBool) i
-> Operand (i, PrimBool)
-> Instruction i
forall t tup.
ScalarType t -> PairIdx tup t -> Operand tup -> Instruction t
ExtractValue ScalarType i
si         PairIdx (i, PrimBool) i
forall a b. PairIdx (a, b) a
PairIdxLeft  Operand (i, PrimBool)
r
  Operand t
next' <- Instruction t -> CodeGen arch (Operand t)
forall a arch.
HasCallStack =>
Instruction a -> CodeGen arch (Operand a)
instr' (Instruction t -> CodeGen arch (Operand t))
-> Instruction t -> CodeGen arch (Operand t)
forall a b. (a -> b) -> a -> b
$ ScalarType t -> Operand i -> Instruction t
forall b a. ScalarType b -> Operand a -> Instruction b
BitCast (SingleType t -> ScalarType t
forall a. SingleType a -> ScalarType a
SingleScalarType SingleType t
t) Operand i
next

  Operands Bool
done' <- case Operand PrimBool
done of
             LocalReference Type PrimBool
_ (UnName Word
n) -> Operands Bool -> CodeGen arch (Operands Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Operands Bool -> CodeGen arch (Operands Bool))
-> Operands Bool -> CodeGen arch (Operands Bool)
forall a b. (a -> b) -> a -> b
$ Operand Bool -> Operands Bool
OP_Bool (Type Bool -> Name Bool -> Operand Bool
forall a. Type a -> Name a -> Operand a
LocalReference Type Bool
forall a. IsType a => Type a
type' (Word -> Name Bool
forall a. Word -> Name a
UnName Word
n))
             Operand PrimBool
_                           -> String -> CodeGen arch (Operands Bool)
forall a. HasCallStack => String -> a
internalError String
"expected unnamed local reference"

  Block
bot   <- Operands Bool -> Block -> Block -> CodeGen arch Block
forall arch.
HasCallStack =>
Operands Bool -> Block -> Block -> CodeGen arch Block
cbr Operands Bool
done' Block
exit Block
test
  Operands t
_     <- TypeR t
-> Block
-> Operands t
-> [(Operands t, Block)]
-> CodeGen arch (Operands t)
forall a arch.
HasCallStack =>
TypeR a
-> Block
-> Operands a
-> [(Operands a, Block)]
-> CodeGen arch (Operands a)
phi' (ScalarType t -> TypeR t
forall (s :: * -> *) a. s a -> TupR s a
TupRsingle (ScalarType t -> TypeR t) -> ScalarType t -> TypeR t
forall a b. (a -> b) -> a -> b
$ SingleType t -> ScalarType t
forall a. SingleType a -> ScalarType a
SingleScalarType SingleType t
t) Block
test Operands t
old [(SingleType t -> Operand t -> Operands t
forall (dict :: * -> *) a.
(IROP dict, HasCallStack) =>
dict a -> Operand a -> Operands a
ir SingleType t
t Operand t
start,Block
top), (SingleType t -> Operand t -> Operands t
forall (dict :: * -> *) a.
(IROP dict, HasCallStack) =>
dict a -> Operand a -> Operands a
ir SingleType t
t Operand t
next',Block
bot)]

  Block -> CodeGen arch ()
forall arch. Block -> CodeGen arch ()
setBlock Block
exit