accelerate-llvm-1.3.0.0: src/Data/Array/Accelerate/LLVM/CodeGen/Arithmetic.hs
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_HADDOCK hide #-}
-- |
-- Module : Data.Array.Accelerate.LLVM.CodeGen.Arithmetic
-- Copyright : [2015..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.Arithmetic
where
import Data.Array.Accelerate.AST ( PrimMaybe )
import Data.Array.Accelerate.Analysis.Match
import Data.Array.Accelerate.Representation.Tag
import Data.Array.Accelerate.Representation.Type
import LLVM.AST.Type.Constant
import LLVM.AST.Type.Function
import LLVM.AST.Type.Instruction
import LLVM.AST.Type.Instruction.Compare
import LLVM.AST.Type.Name
import LLVM.AST.Type.Operand
import LLVM.AST.Type.Representation
import Data.Array.Accelerate.LLVM.CodeGen.Base
import Data.Array.Accelerate.LLVM.CodeGen.Constant
import Data.Array.Accelerate.LLVM.CodeGen.IR
import Data.Array.Accelerate.LLVM.CodeGen.Monad
import Data.Array.Accelerate.LLVM.CodeGen.Type
import Control.Applicative
import Control.Monad
import Data.Bits ( finiteBitSize )
import Data.Bool ( Bool(..), otherwise )
import Data.ByteString.Short ( ShortByteString )
import Data.Constraint ( Dict(..) )
import Data.Monoid
import Data.String
import Foreign.Storable ( sizeOf )
import Prelude ( Eq, Num, Maybe(..), ($), (==), (/), undefined, flip, fromInteger )
import Text.Printf
import qualified Data.Ord as Ord
import qualified Prelude as P
-- Operations from Num
-- -------------------
add :: NumType a -> Operands a -> Operands a -> CodeGen arch (Operands a)
add = binop Add
sub :: NumType a -> Operands a -> Operands a -> CodeGen arch (Operands a)
sub = binop Sub
mul :: NumType a -> Operands a -> Operands a -> CodeGen arch (Operands a)
mul = binop Mul
negate :: NumType a -> Operands a -> CodeGen arch (Operands a)
negate t x =
case t of
IntegralNumType i | IntegralDict <- integralDict i -> mul t x (ir t (num t (P.negate 1)))
FloatingNumType f | FloatingDict <- floatingDict f -> mul t x (ir t (num t (P.negate 1)))
abs :: forall arch a. NumType a -> Operands a -> CodeGen arch (Operands a)
abs n x =
case n of
FloatingNumType f -> mathf "fabs" f x
IntegralNumType i
| unsigned i -> return x
| IntegralDict <- integralDict i ->
let p = ScalarPrimType (SingleScalarType (NumSingleType n))
t = PrimType p
in
case finiteBitSize (undefined :: a) of
64 -> call (Lam p (op n x) (Body t Nothing "llabs")) [NoUnwind, ReadNone]
_ -> call (Lam p (op n x) (Body t Nothing "abs")) [NoUnwind, ReadNone]
signum :: forall arch a. NumType a -> Operands a -> CodeGen arch (Operands a)
signum t x =
case t of
IntegralNumType i
| IntegralDict <- integralDict i
, unsigned i
-> do z <- neq (NumSingleType t) x (ir t (num t 0))
s <- instr (BoolToInt i (unbool z))
return s
--
-- http://graphics.stanford.edu/~seander/bithacks.html#CopyIntegerSign
| IntegralDict <- integralDict i
-> do let wsib = finiteBitSize (undefined::a)
z <- neq (NumSingleType t) x (ir t (num t 0))
l <- instr (BoolToInt i (unbool z))
r <- shiftRA i x (ir integralType (integral integralType (wsib P.- 1)))
s <- bor i l r
return s
--
-- http://graphics.stanford.edu/~seander/bithacks.html#CopyIntegerSign
FloatingNumType f
| FloatingDict <- floatingDict f
-> do
l <- gt (NumSingleType t) x (ir f (floating f 0))
r <- lt (NumSingleType t) x (ir f (floating f 0))
u <- instr (BoolToFP f (unbool l))
v <- instr (BoolToFP f (unbool r))
s <- sub t u v
return s
-- Operations from Integral and Bits
-- ---------------------------------
quot :: IntegralType a -> Operands a -> Operands a -> CodeGen arch (Operands a)
quot = binop Quot
rem :: IntegralType a -> Operands a -> Operands a -> CodeGen arch (Operands a)
rem = binop Rem
quotRem :: IntegralType a -> Operands a -> Operands a -> CodeGen arch (Operands (a,a))
quotRem t x y = do
q <- quot t x y
r <- rem t x y
-- TLM: On x86 we can compute quotRem with a single [i]divq instruction. This
-- is not evident from the generated LLVM IR, which will still list both
-- div/rem operations. Note that this may not be true for other instruction
-- sets, for example the NVPTX assembly contains both operations. It might be
-- worthwhile to allow backends to specialise Exp code generation in the same
-- way the other phases of compilation are handled.
--
-- The following can be used to compute the remainder, and _may_ be better for
-- architectures without a combined quotRem instruction.
--
-- z <- mul (IntegralNumType t) y q
-- r <- sub (IntegralNumType t) x z
return $ pair q r
idiv :: IntegralType a -> Operands a -> Operands a -> CodeGen arch (Operands a)
idiv i x y
| unsigned i
= quot i x y
--
| IntegralDict <- integralDict i
, Dict <- integralElt i
, zero <- ir i (integral i 0)
, one <- ir i (integral i 1)
, n <- IntegralNumType i
, s <- NumSingleType n
= if (tp, gt s x zero `land'` lt s y zero)
then do
a <- sub n x one
b <- quot i a y
c <- sub n b one
return c
else
if (tp, lt s x zero `land'` gt s y zero)
then do
a <- add n x one
b <- quot i a y
c <- sub n b one
return c
else
quot i x y
where
tp = TupRsingle $ SingleScalarType $ NumSingleType $ IntegralNumType i
mod :: IntegralType a -> Operands a -> Operands a -> CodeGen arch (Operands a)
mod i x y
| unsigned i
= rem i x y
--
| IntegralDict <- integralDict i
, Dict <- integralElt i
, zero <- ir i (integral i 0)
, n <- IntegralNumType i
, s <- NumSingleType n
= do r <- rem i x y
if (tp, (gt s x zero `land'` lt s y zero) `lor'` (lt s x zero `land'` gt s y zero))
then if (tp, neq s r zero)
then add n r y
else return zero
else return r
where
tp = TupRsingle $ SingleScalarType $ NumSingleType $ IntegralNumType i
divMod :: IntegralType a -> Operands a -> Operands a -> CodeGen arch (Operands (a,a))
divMod i x y
| unsigned i
= quotRem i x y
--
| IntegralDict <- integralDict i
, Dict <- integralElt i
, zero <- ir i (integral i 0)
, one <- ir i (integral i 1)
, n <- IntegralNumType i
, s <- NumSingleType n
= if (TupRpair tp tp, gt s x zero `land'` lt s y zero)
then do
a <- sub n x one
b <- quotRem i a y
c <- sub n (fst b) one
d <- add n (snd b) y
e <- add n d one
return $ pair c e
else
if (TupRpair tp tp, lt s x zero `land'` gt s y zero)
then do
a <- add n x one
b <- quotRem i a y
c <- sub n (fst b) one
d <- add n (snd b) y
e <- sub n d one
return $ pair c e
else
quotRem i x y
where
tp = TupRsingle $ SingleScalarType $ NumSingleType $ IntegralNumType i
band :: IntegralType a -> Operands a -> Operands a -> CodeGen arch (Operands a)
band = binop BAnd
bor :: IntegralType a -> Operands a -> Operands a -> CodeGen arch (Operands a)
bor = binop BOr
xor :: IntegralType a -> Operands a -> Operands a -> CodeGen arch (Operands a)
xor = binop BXor
complement :: IntegralType a -> Operands a -> CodeGen arch (Operands a)
complement t x | IntegralDict <- integralDict t = xor t x (ir t (integral t (P.negate 1)))
shiftL :: IntegralType a -> Operands a -> Operands Int -> CodeGen arch (Operands a)
shiftL t x i = do
i' <- fromIntegral integralType (IntegralNumType t) i
binop ShiftL t x i'
shiftR :: IntegralType a -> Operands a -> Operands Int -> CodeGen arch (Operands a)
shiftR t
| signed t = shiftRA t
| otherwise = shiftRL t
shiftRL :: IntegralType a -> Operands a -> Operands Int -> CodeGen arch (Operands a)
shiftRL t x i = do
i' <- fromIntegral integralType (IntegralNumType t) i
r <- binop ShiftRL t x i'
return r
shiftRA :: IntegralType a -> Operands a -> Operands Int -> CodeGen arch (Operands a)
shiftRA t x i = do
i' <- fromIntegral integralType (IntegralNumType t) i
r <- binop ShiftRA t x i'
return r
rotateL :: forall arch a. IntegralType a -> Operands a -> Operands Int -> CodeGen arch (Operands a)
rotateL t x i
| IntegralDict <- integralDict t
= do let wsib = finiteBitSize (undefined::a)
i1 <- band integralType i (ir integralType (integral integralType (wsib P.- 1)))
i2 <- sub numType (ir numType (integral integralType wsib)) i1
--
a <- shiftL t x i1
b <- shiftRL t x i2
c <- bor t a b
return c
rotateR :: IntegralType a -> Operands a -> Operands Int -> CodeGen arch (Operands a)
rotateR t x i = do
i' <- negate numType i
r <- rotateL t x i'
return r
popCount :: forall arch a. IntegralType a -> Operands a -> CodeGen arch (Operands Int)
popCount i x
| IntegralDict <- integralDict i
= do let ctpop = fromString $ printf "llvm.ctpop.i%d" (finiteBitSize (undefined::a))
p = ScalarPrimType (SingleScalarType (NumSingleType (IntegralNumType i)))
t = PrimType p
--
c <- call (Lam p (op i x) (Body t Nothing ctpop)) [NoUnwind, ReadNone]
r <- fromIntegral i numType c
return r
countLeadingZeros :: forall arch a. IntegralType a -> Operands a -> CodeGen arch (Operands Int)
countLeadingZeros i x
| IntegralDict <- integralDict i
= do let clz = fromString $ printf "llvm.ctlz.i%d" (finiteBitSize (undefined::a))
p = ScalarPrimType (SingleScalarType (NumSingleType (IntegralNumType i)))
t = PrimType p
--
c <- call (Lam p (op i x) (Lam primType (boolean False) (Body t Nothing clz))) [NoUnwind, ReadNone]
r <- fromIntegral i numType c
return r
countTrailingZeros :: forall arch a. IntegralType a -> Operands a -> CodeGen arch (Operands Int)
countTrailingZeros i x
| IntegralDict <- integralDict i
= do let clz = fromString $ printf "llvm.cttz.i%d" (finiteBitSize (undefined::a))
p = ScalarPrimType (SingleScalarType (NumSingleType (IntegralNumType i)))
t = PrimType p
--
c <- call (Lam p (op i x) (Lam primType (boolean False) (Body t Nothing clz))) [NoUnwind, ReadNone]
r <- fromIntegral i numType c
return r
-- Operators from Fractional and Floating
-- --------------------------------------
fdiv :: FloatingType a -> Operands a -> Operands a -> CodeGen arch (Operands a)
fdiv = binop Div
recip :: FloatingType a -> Operands a -> CodeGen arch (Operands a)
recip t x | FloatingDict <- floatingDict t = fdiv t (ir t (floating t 1)) x
sin :: FloatingType a -> Operands a -> CodeGen arch (Operands a)
sin = mathf "sin"
cos :: FloatingType a -> Operands a -> CodeGen arch (Operands a)
cos = mathf "cos"
tan :: FloatingType a -> Operands a -> CodeGen arch (Operands a)
tan = mathf "tan"
sinh :: FloatingType a -> Operands a -> CodeGen arch (Operands a)
sinh = mathf "sinh"
cosh :: FloatingType a -> Operands a -> CodeGen arch (Operands a)
cosh = mathf "cosh"
tanh :: FloatingType a -> Operands a -> CodeGen arch (Operands a)
tanh = mathf "tanh"
asin :: FloatingType a -> Operands a -> CodeGen arch (Operands a)
asin = mathf "asin"
acos :: FloatingType a -> Operands a -> CodeGen arch (Operands a)
acos = mathf "acos"
atan :: FloatingType a -> Operands a -> CodeGen arch (Operands a)
atan = mathf "atan"
asinh :: FloatingType a -> Operands a -> CodeGen arch (Operands a)
asinh = mathf "asinh"
acosh :: FloatingType a -> Operands a -> CodeGen arch (Operands a)
acosh = mathf "acosh"
atanh :: FloatingType a -> Operands a -> CodeGen arch (Operands a)
atanh = mathf "atanh"
atan2 :: FloatingType a -> Operands a -> Operands a -> CodeGen arch (Operands a)
atan2 = mathf2 "atan2"
exp :: FloatingType a -> Operands a -> CodeGen arch (Operands a)
exp = mathf "exp"
fpow :: FloatingType a -> Operands a -> Operands a -> CodeGen arch (Operands a)
fpow = mathf2 "pow"
sqrt :: FloatingType a -> Operands a -> CodeGen arch (Operands a)
sqrt = mathf "sqrt"
log :: FloatingType a -> Operands a -> CodeGen arch (Operands a)
log = mathf "log"
logBase :: forall arch a. FloatingType a -> Operands a -> Operands a -> CodeGen arch (Operands a)
logBase t x@(op t -> base) y | FloatingDict <- floatingDict t = logBase'
where
match :: Eq t => Operand t -> Operand t -> Bool
match (ConstantOperand (ScalarConstant _ u))
(ConstantOperand (ScalarConstant _ v)) = u == v
match _ _ = False
logBase' :: (Num a, Eq a) => CodeGen arch (Operands a)
logBase' | match base (floating t 2) = mathf "log2" t y
| match base (floating t 10) = mathf "log10" t y
| otherwise
= do x' <- log t x
y' <- log t y
fdiv t y' x'
-- Operators from RealFloat
-- ------------------------
isNaN :: FloatingType a -> Operands a -> CodeGen arch (Operands Bool)
isNaN f (op f -> x) = instr (IsNaN f x)
isInfinite :: forall arch a. FloatingType a -> Operands a -> CodeGen arch (Operands Bool)
isInfinite f x = do
x' <- abs n x
eq (NumSingleType n) infinity x'
where
n :: NumType a
n = FloatingNumType f
infinity :: Operands a
infinity | FloatingDict <- floatingDict f = ir f (floating f (1/0))
-- Operators from RealFrac
-- -----------------------
truncate :: FloatingType a -> IntegralType b -> Operands a -> CodeGen arch (Operands b)
truncate tf ti (op tf -> x) = instr (FPToInt tf ti x)
round :: FloatingType a -> IntegralType b -> Operands a -> CodeGen arch (Operands b)
round tf ti x = do
i <- mathf "round" tf x
truncate tf ti i
floor :: FloatingType a -> IntegralType b -> Operands a -> CodeGen arch (Operands b)
floor tf ti x = do
i <- mathf "floor" tf x
truncate tf ti i
ceiling :: FloatingType a -> IntegralType b -> Operands a -> CodeGen arch (Operands b)
ceiling tf ti x = do
i <- mathf "ceil" tf x
truncate tf ti i
-- Relational and Equality operators
-- ---------------------------------
cmp :: Ordering -> SingleType a -> Operands a -> Operands a -> CodeGen arch (Operands Bool)
cmp p dict (op dict -> x) (op dict -> y) = instr (Cmp dict p x y)
lt :: SingleType a -> Operands a -> Operands a -> CodeGen arch (Operands Bool)
lt = cmp LT
gt :: SingleType a -> Operands a -> Operands a -> CodeGen arch (Operands Bool)
gt = cmp GT
lte :: SingleType a -> Operands a -> Operands a -> CodeGen arch (Operands Bool)
lte = cmp LE
gte :: SingleType a -> Operands a -> Operands a -> CodeGen arch (Operands Bool)
gte = cmp GE
eq :: SingleType a -> Operands a -> Operands a -> CodeGen arch (Operands Bool)
eq = cmp EQ
neq :: SingleType a -> Operands a -> Operands a -> CodeGen arch (Operands Bool)
neq = cmp NE
max :: SingleType a -> Operands a -> Operands a -> CodeGen arch (Operands a)
max ty x y
| NumSingleType (FloatingNumType f) <- ty = mathf2 "fmax" f x y
| otherwise = do c <- unbool <$> gte ty x y
binop (flip Select c) ty x y
min :: SingleType a -> Operands a -> Operands a -> CodeGen arch (Operands a)
min ty x y
| NumSingleType (FloatingNumType f) <- ty = mathf2 "fmin" f x y
| otherwise = do c <- unbool <$> lte ty x y
binop (flip Select c) ty x y
-- Logical operators
-- -----------------
--
-- Note that these implementations are strict in both arguments. The short
-- circuiting (&&) and (||) operators in the language are not evaluated
-- using these functions, but defined in terms of if-then-else.
--
land :: Operands Bool -> Operands Bool -> CodeGen arch (Operands Bool)
land (OP_Bool x) (OP_Bool y) = instr (LAnd x y)
lor :: Operands Bool -> Operands Bool -> CodeGen arch (Operands Bool)
lor (OP_Bool x) (OP_Bool y) = instr (LOr x y)
lnot :: Operands Bool -> CodeGen arch (Operands Bool)
lnot (OP_Bool x) = instr (LNot x)
-- Utilities for implementing bounds checks
land' :: CodeGen arch (Operands Bool) -> CodeGen arch (Operands Bool) -> CodeGen arch (Operands Bool)
land' x y = do
a <- x
b <- y
land a b
lor' :: CodeGen arch (Operands Bool) -> CodeGen arch (Operands Bool) -> CodeGen arch (Operands Bool)
lor' x y = do
a <- x
b <- y
lor a b
-- Type conversions
-- ----------------
fromIntegral :: forall arch a b. IntegralType a -> NumType b -> Operands a -> CodeGen arch (Operands b)
fromIntegral i1 n (op i1 -> x) =
case n of
FloatingNumType f
-> instr (IntToFP i1 f x)
IntegralNumType (i2 :: IntegralType b)
| IntegralDict <- integralDict i1
, IntegralDict <- integralDict i2
-> let
bits_a = finiteBitSize (undefined::a)
bits_b = finiteBitSize (undefined::b)
in
case Ord.compare bits_a bits_b of
Ord.EQ -> instr (BitCast (SingleScalarType (NumSingleType n)) x)
Ord.GT -> instr (Trunc (IntegralBoundedType i1) (IntegralBoundedType i2) x)
Ord.LT -> instr (Ext (IntegralBoundedType i1) (IntegralBoundedType i2) x)
toFloating :: forall arch a b. NumType a -> FloatingType b -> Operands a -> CodeGen arch (Operands b)
toFloating n1 f2 (op n1 -> x) =
case n1 of
IntegralNumType i1
-> instr (IntToFP i1 f2 x)
FloatingNumType (f1 :: FloatingType a)
| FloatingDict <- floatingDict f1
, FloatingDict <- floatingDict f2
-> let
bytes_a = sizeOf (undefined::a)
bytes_b = sizeOf (undefined::b)
in
case Ord.compare bytes_a bytes_b of
Ord.EQ -> instr (BitCast (SingleScalarType (NumSingleType (FloatingNumType f2))) x)
Ord.GT -> instr (FTrunc f1 f2 x)
Ord.LT -> instr (FExt f1 f2 x)
bitcast :: ScalarType a -> ScalarType b -> Operands a -> CodeGen arch (Operands b)
bitcast ta tb x
| Just Refl <- matchScalarType ta tb = return x
| otherwise = instr (BitCast tb (op ta x))
-- Utility functions
-- -----------------
fst :: Operands (a, b) -> Operands a
fst (OP_Pair x _) = x
snd :: Operands (a, b) -> Operands b
snd (OP_Pair _ y) = y
pair :: Operands a -> Operands b -> Operands (a, b)
pair x y = OP_Pair x y
unpair :: Operands (a, b) -> (Operands a, Operands b)
unpair (OP_Pair x y) = (x, y)
uncurry :: (Operands a -> Operands b -> c) -> Operands (a, b) -> c
uncurry f (OP_Pair x y) = f x y
unbool :: Operands Bool -> Operand Bool
unbool (OP_Bool x) = x
binop :: IROP dict => (dict a -> Operand a -> Operand a -> Instruction a) -> dict a -> Operands a -> Operands a -> CodeGen arch (Operands a)
binop f dict (op dict -> x) (op dict -> y) = instr (f dict x y)
fst3 :: Operands (Tup3 a b c) -> Operands a
fst3 (OP_Pair (OP_Pair (OP_Pair OP_Unit x) _) _) = x
snd3 :: Operands (Tup3 a b c) -> Operands b
snd3 (OP_Pair (OP_Pair _ y) _) = y
thd3 :: Operands (Tup3 a b c) -> Operands c
thd3 (OP_Pair _ z) = z
trip :: Operands a -> Operands b -> Operands c -> Operands (Tup3 a b c)
trip x y z = OP_Pair (OP_Pair (OP_Pair OP_Unit x) y) z
untrip :: Operands (Tup3 a b c) -> (Operands a, Operands b, Operands c)
untrip t = (fst3 t, snd3 t, thd3 t)
-- | Lift a constant value into an constant in the intermediate representation.
--
{-# INLINABLE lift #-}
lift :: TypeR a -> a -> Operands a
lift tp v = constant tp v
{-# INLINE liftInt #-}
liftInt :: Int -> Operands Int
liftInt = lift $ TupRsingle scalarTypeInt
{-# INLINE liftInt32 #-}
liftInt32 :: Int32 -> Operands Int32
liftInt32 = lift $ TupRsingle scalarTypeInt32
{-# INLINE liftWord32 #-}
liftWord32 :: Word32 -> Operands Word32
liftWord32 = lift $ TupRsingle scalarTypeWord32
{-# INLINE liftBool #-}
liftBool :: Bool -> Operands Bool
liftBool x = OP_Bool (boolean x)
-- | Standard if-then-else expression
--
ifThenElse
:: (TypeR a, CodeGen arch (Operands Bool))
-> CodeGen arch (Operands a)
-> CodeGen arch (Operands a)
-> CodeGen arch (Operands a)
ifThenElse (tp, test) yes no = do
ifThen <- newBlock "if.then"
ifElse <- newBlock "if.else"
ifExit <- newBlock "if.exit"
_ <- beginBlock "if.entry"
p <- test
_ <- cbr p ifThen ifElse
setBlock ifThen
tv <- yes
tb <- br ifExit
setBlock ifElse
fv <- no
fb <- br ifExit
setBlock ifExit
phi tp [(tv, tb), (fv, fb)]
caseof
:: TypeR a
-> CodeGen arch (Operands TAG)
-> [(TAG, CodeGen arch (Operands a))]
-> Maybe (CodeGen arch (Operands a))
-> CodeGen arch (Operands a)
caseof tR tag xs x = do
exit <- newBlock "switch.exit"
def <- newBlock "switch.default"
cases <- forM xs (\(t,e) -> (t,e,) <$> newBlock (printf "switch.l%d" t))
_ <- beginBlock "switch.entry"
p <- tag
_ <- switch p def [(t,b) | (t,_,b) <- cases]
-- Generate basic blocks for each equation
vs <- forM cases $ \(_,body,label) -> do
setBlock label
r <- body
b <- br exit
return (r,b)
-- Basic block for the default case
v <- do
setBlock def
r <- case x of
Nothing ->
let go :: TypeR a -> Operands a
go TupRunit = OP_Unit
go (TupRsingle t) = ir t (undef t)
go (TupRpair a b) = OP_Pair (go a) (go b)
in return (go tR)
Just default_ -> default_
b <- br exit
return (r,b)
setBlock exit
phi tR (v:vs)
-- Execute the body only if the first argument evaluates to True
--
when :: CodeGen arch (Operands Bool) -> CodeGen arch () -> CodeGen arch ()
when test doit = do
body <- newBlock "when.body"
exit <- newBlock "when.exit"
p <- test
_ <- cbr p body exit
setBlock body
doit
_ <- br exit
setBlock exit
-- Execute the body only if the first argument evaluates to False
--
unless :: CodeGen arch (Operands Bool) -> CodeGen arch () -> CodeGen arch ()
unless test doit = do
body <- newBlock "unless.body"
exit <- newBlock "unless.exit"
p <- test
_ <- cbr p exit body
setBlock body
doit
_ <- br exit
setBlock exit
-- Call a function from the standard C math library. This is a wrapper around
-- the 'call' function from CodeGen.Base since:
--
-- (1) The parameter and return types are all the same; and
-- (2) We check if there is an intrinsic implementation of this function
--
-- TLM: We should really be able to construct functions of any arity.
--
mathf :: ShortByteString -> FloatingType t -> Operands t -> CodeGen arch (Operands t)
mathf n f (op f -> x) = do
let s = ScalarPrimType (SingleScalarType (NumSingleType (FloatingNumType f)))
t = PrimType s
--
name <- lm f n
r <- call (Lam s x (Body t Nothing name)) [NoUnwind, ReadOnly]
return r
mathf2 :: ShortByteString -> FloatingType t -> Operands t -> Operands t -> CodeGen arch (Operands t)
mathf2 n f (op f -> x) (op f -> y) = do
let s = ScalarPrimType (SingleScalarType (NumSingleType (FloatingNumType f)))
t = PrimType s
--
name <- lm f n
r <- call (Lam s x (Lam s y (Body t Nothing name))) [NoUnwind, ReadOnly]
return r
lm :: FloatingType t -> ShortByteString -> CodeGen arch Label
lm t n
= intrinsic
$ case t of
TypeHalf{} -> n<>"f" -- XXX: check
TypeFloat{} -> n<>"f"
TypeDouble{} -> n
isJust :: Operands (PrimMaybe a) -> CodeGen arch (Operands Bool)
isJust (OP_Pair l _) = instr (IntToBool integralType (op integralType l))
fromJust :: Operands (PrimMaybe a) -> CodeGen arch (Operands a)
fromJust (OP_Pair _ (OP_Pair OP_Unit r)) = return r