{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MagicHash             #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# OPTIONS_HADDOCK hide #-}
-- |
-- Module      : LLVM.AST.Type.Constant
-- Copyright   : [2015..2020] The Accelerate Team
-- License     : BSD3
--
-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--

module LLVM.AST.Type.Constant
  where

import LLVM.AST.Type.Downcast
import LLVM.AST.Type.Name
import LLVM.AST.Type.Representation

import qualified LLVM.AST.Constant                                  as LLVM
import qualified LLVM.AST.Float                                     as LLVM
import qualified LLVM.AST.Type                                      as LLVM

import Data.Constraint
import Data.Primitive.ByteArray
import Data.Primitive.Types
import Data.Primitive.Vec


-- | Although constant expressions and instructions have many similarities,
-- there are important differences - so they're represented using different
-- types in this AST. At the cost of making it harder to move an code back and
-- forth between being constant and not, this approach embeds more of the rules
-- of what IR is legal into the Haskell types.
--
-- <http://llvm.org/docs/LangRef.html#constants>
--
-- <http://llvm.org/docs/LangRef.html#constant-expressions>
--
data Constant a where
  ScalarConstant        :: ScalarType a
                        -> a
                        -> Constant a

  BooleanConstant       :: Bool
                        -> Constant Bool

  UndefConstant         :: Type a
                        -> Constant a

  GlobalReference       :: Type a
                        -> Name a
                        -> Constant a


-- | Convert to llvm-hs
--
instance Downcast (Constant a) LLVM.Constant where
  downcast :: Constant a -> Constant
downcast = \case
    UndefConstant Type a
t       -> Type -> Constant
LLVM.Undef (Type a -> Type
forall typed untyped.
(Downcast typed untyped, HasCallStack) =>
typed -> untyped
downcast Type a
t)
    GlobalReference Type a
t Name a
n   -> Type -> Name -> Constant
LLVM.GlobalReference (Type a -> Type
forall typed untyped.
(Downcast typed untyped, HasCallStack) =>
typed -> untyped
downcast Type a
t) (Name a -> Name
forall typed untyped.
(Downcast typed untyped, HasCallStack) =>
typed -> untyped
downcast Name a
n)
    BooleanConstant Bool
x     -> Word32 -> Integer -> Constant
LLVM.Int Word32
1 (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Bool -> Int
forall a. Enum a => a -> Int
fromEnum Bool
x))
    ScalarConstant ScalarType a
t a
x    -> ScalarType a -> a -> Constant
forall s. ScalarType s -> s -> Constant
scalar ScalarType a
t a
x
    where
      scalar :: ScalarType s -> s -> LLVM.Constant
      scalar :: ScalarType s -> s -> Constant
scalar (SingleScalarType SingleType s
s) = SingleType s -> s -> Constant
forall s. SingleType s -> s -> Constant
single SingleType s
s
      scalar (VectorScalarType VectorType (Vec n a1)
s) = VectorType (Vec n a1) -> Vec n a1 -> Constant
forall s. VectorType s -> s -> Constant
vector VectorType (Vec n a1)
s

      single :: SingleType s -> s -> LLVM.Constant
      single :: SingleType s -> s -> Constant
single (NumSingleType NumType s
s) = NumType s -> s -> Constant
forall s. NumType s -> s -> Constant
num NumType s
s

      vector :: VectorType s -> s -> LLVM.Constant
      vector :: VectorType s -> s -> Constant
vector (VectorType Int
_ SingleType a1
s) (Vec ba#)
        = [Constant] -> Constant
LLVM.Vector
        ([Constant] -> Constant) -> [Constant] -> Constant
forall a b. (a -> b) -> a -> b
$ (a1 -> Constant) -> [a1] -> [Constant]
forall a b. (a -> b) -> [a] -> [b]
map (SingleType a1 -> a1 -> Constant
forall s. SingleType s -> s -> Constant
single SingleType a1
s)
        ([a1] -> [Constant]) -> [a1] -> [Constant]
forall a b. (a -> b) -> a -> b
$ SingleType a1 -> Dict (Prim a1)
forall s. SingleType s -> Dict (Prim s)
singlePrim SingleType a1
s Dict (Prim a1) -> (Prim a1 => [a1]) -> [a1]
forall (c :: Constraint) e r. HasDict c e => e -> (c => r) -> r
`withDict` (a1 -> [a1] -> [a1]) -> [a1] -> ByteArray -> [a1]
forall a b. Prim a => (a -> b -> b) -> b -> ByteArray -> b
foldrByteArray (:) [] (ByteArray# -> ByteArray
ByteArray ByteArray#
ba#)

      num :: NumType s -> s -> LLVM.Constant
      num :: NumType s -> s -> Constant
num (IntegralNumType IntegralType s
s) s
v
        | IntegralDict s
IntegralDict <- IntegralType s -> IntegralDict s
forall a. IntegralType a -> IntegralDict a
integralDict IntegralType s
s
        = Word32 -> Integer -> Constant
LLVM.Int (Type -> Word32
LLVM.typeBits (IntegralType s -> Type
forall typed untyped.
(Downcast typed untyped, HasCallStack) =>
typed -> untyped
downcast IntegralType s
s)) (s -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral s
v)

      num (FloatingNumType FloatingType s
s) s
v
        = SomeFloat -> Constant
LLVM.Float
        (SomeFloat -> Constant) -> SomeFloat -> Constant
forall a b. (a -> b) -> a -> b
$ case FloatingType s
s of
            FloatingType s
TypeFloat                        -> Float -> SomeFloat
LLVM.Single s
Float
v
            FloatingType s
TypeDouble                       -> Double -> SomeFloat
LLVM.Double s
Double
v
            FloatingType s
TypeHalf | Half (CUShort u) <- s
v -> Word16 -> SomeFloat
LLVM.Half Word16
u

      singlePrim :: SingleType s -> Dict (Prim s)
      singlePrim :: SingleType s -> Dict (Prim s)
singlePrim (NumSingleType NumType s
s) = NumType s -> Dict (Prim s)
forall s. NumType s -> Dict (Prim s)
numPrim NumType s
s

      numPrim :: NumType s -> Dict (Prim s)
      numPrim :: NumType s -> Dict (Prim s)
numPrim (IntegralNumType IntegralType s
s) = IntegralType s -> Dict (Prim s)
forall s. IntegralType s -> Dict (Prim s)
integralPrim IntegralType s
s
      numPrim (FloatingNumType FloatingType s
s) = FloatingType s -> Dict (Prim s)
forall s. FloatingType s -> Dict (Prim s)
floatingPrim FloatingType s
s

      integralPrim :: IntegralType s -> Dict (Prim s)
      integralPrim :: IntegralType s -> Dict (Prim s)
integralPrim IntegralType s
TypeInt    = Dict (Prim s)
forall (a :: Constraint). a => Dict a
Dict
      integralPrim IntegralType s
TypeInt8   = Dict (Prim s)
forall (a :: Constraint). a => Dict a
Dict
      integralPrim IntegralType s
TypeInt16  = Dict (Prim s)
forall (a :: Constraint). a => Dict a
Dict
      integralPrim IntegralType s
TypeInt32  = Dict (Prim s)
forall (a :: Constraint). a => Dict a
Dict
      integralPrim IntegralType s
TypeInt64  = Dict (Prim s)
forall (a :: Constraint). a => Dict a
Dict
      integralPrim IntegralType s
TypeWord   = Dict (Prim s)
forall (a :: Constraint). a => Dict a
Dict
      integralPrim IntegralType s
TypeWord8  = Dict (Prim s)
forall (a :: Constraint). a => Dict a
Dict
      integralPrim IntegralType s
TypeWord16 = Dict (Prim s)
forall (a :: Constraint). a => Dict a
Dict
      integralPrim IntegralType s
TypeWord32 = Dict (Prim s)
forall (a :: Constraint). a => Dict a
Dict
      integralPrim IntegralType s
TypeWord64 = Dict (Prim s)
forall (a :: Constraint). a => Dict a
Dict

      floatingPrim :: FloatingType s -> Dict (Prim s)
      floatingPrim :: FloatingType s -> Dict (Prim s)
floatingPrim FloatingType s
TypeHalf   = Dict (Prim s)
forall (a :: Constraint). a => Dict a
Dict
      floatingPrim FloatingType s
TypeFloat  = Dict (Prim s)
forall (a :: Constraint). a => Dict a
Dict
      floatingPrim FloatingType s
TypeDouble = Dict (Prim s)
forall (a :: Constraint). a => Dict a
Dict

instance TypeOf Constant where
  typeOf :: Constant a -> Type a
typeOf (BooleanConstant Bool
_)   = Type a
forall a. IsType a => Type a
type'
  typeOf (ScalarConstant ScalarType a
t a
_)  = PrimType a -> Type a
forall a. PrimType a -> Type a
PrimType (ScalarType a -> PrimType a
forall a. ScalarType a -> PrimType a
ScalarPrimType ScalarType a
t)
  typeOf (UndefConstant Type a
t)     = Type a
t
  typeOf (GlobalReference Type a
t Name a
_) = Type a
t