content: {-# 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
                fn = fromString $ printf "llvm.abs.i%d" (finiteBitSize (undefined::a))
            in
            call (Lam p (op n x) (Lam primType (boolean False) (Body t Nothing fn))) [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 fshl = fromString $ printf "llvm.fshl.i%d" (finiteBitSize (undefined::a))
             p    = ScalarPrimType (SingleScalarType (NumSingleType (IntegralNumType t)))
             x'   = op t x
         i' <- fromIntegral integralType (IntegralNumType t) i
         r  <- call (Lam p x' (Lam p x' (Lam p (op t i') (Body (PrimType p) Nothing fshl)))) [NoUnwind, ReadNone]
         return r
  
  rotateR :: forall arch a. IntegralType a -> Operands a -> Operands Int -> CodeGen arch (Operands a)
  rotateR t x i
    | IntegralDict <- integralDict t
    = do let fshr = fromString $ printf "llvm.fshr.i%d" (finiteBitSize (undefined::a))
             p    = ScalarPrimType (SingleScalarType (NumSingleType (IntegralNumType t)))
             x'   = op t x
         i' <- fromIntegral integralType (IntegralNumType t) i
         r  <- call (Lam p x' (Lam p x' (Lam p (op t i') (Body (PrimType p) Nothing fshr)))) [NoUnwind, ReadNone]
         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
  
  