{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# OPTIONS_HADDOCK hide #-}
-- |
-- Module      : LLVM.AST.Type.Representation
-- 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.Representation (

  module LLVM.AST.Type.Representation,
  module Data.Array.Accelerate.Type,
  Ptr,
  AddrSpace(..),

) where

import Data.Array.Accelerate.Type
import Data.Array.Accelerate.Representation.Type

import LLVM.AST.Type.AddrSpace
import LLVM.AST.Type.Downcast

import qualified LLVM.AST.Type                                      as LLVM

import Foreign.Ptr
import Text.Printf


-- Witnesses to observe the LLVM type hierarchy:
--
-- <http://llvm.org/docs/LangRef.html#type-system>
--
-- Type
--   * void
--   * labels & metadata
--   * function types
--   * first class types (basic types)
--      * primitive types (single value types, things that go in registers)
--          * multi (SIMD vectors of primitive types: pointer and single values)
--          * single value types
--              * int
--              * float
--              * ptr (any first-class or function type)
--      * aggregate types
--          * (static) array
--          * [opaque] structure
--
-- We actually don't want to encode this hierarchy as shown above, since it is
-- not precise enough for our purposes. For example, the `Add` instruction
-- operates on operands of integer type or vector (multi) of integer types, so
-- we would probably prefer to add multi-types as a sub-type of IntegralType,
-- FloatingType, etc.
--
-- We minimally extend Accelerate's existing type hierarchy to support the
-- features we require for code generation: void types, pointer types, and
-- simple aggregate structures (for CmpXchg).
--

data Type a where
  VoidType  :: Type ()
  PrimType  :: PrimType a -> Type a

data PrimType a where
  BoolPrimType    ::                            PrimType Bool
  ScalarPrimType  :: ScalarType a            -> PrimType a          -- scalar value types (things in registers)
  PtrPrimType     :: PrimType a -> AddrSpace -> PrimType (Ptr a)    -- pointers (XXX: volatility?)
  StructPrimType  :: TypeR a                 -> PrimType a          -- opaque structures (required for CmpXchg)
  ArrayPrimType   :: Word64 -> ScalarType a  -> PrimType a          -- static arrays

-- | All types
--

class IsType a where
  type' :: Type a

instance IsType () where
  type' :: Type ()
type' = Type ()
VoidType

instance IsType Int where
  type' :: Type Int
type' = PrimType Int -> Type Int
forall a. PrimType a -> Type a
PrimType PrimType Int
forall a. IsPrim a => PrimType a
primType

instance IsType Int8 where
  type' :: Type Int8
type' = PrimType Int8 -> Type Int8
forall a. PrimType a -> Type a
PrimType PrimType Int8
forall a. IsPrim a => PrimType a
primType

instance IsType Int16 where
  type' :: Type Int16
type' = PrimType Int16 -> Type Int16
forall a. PrimType a -> Type a
PrimType PrimType Int16
forall a. IsPrim a => PrimType a
primType

instance IsType Int32 where
  type' :: Type Int32
type' = PrimType Int32 -> Type Int32
forall a. PrimType a -> Type a
PrimType PrimType Int32
forall a. IsPrim a => PrimType a
primType

instance IsType Int64 where
  type' :: Type Int64
type' = PrimType Int64 -> Type Int64
forall a. PrimType a -> Type a
PrimType PrimType Int64
forall a. IsPrim a => PrimType a
primType

instance IsType Word where
  type' :: Type Word
type' = PrimType Word -> Type Word
forall a. PrimType a -> Type a
PrimType PrimType Word
forall a. IsPrim a => PrimType a
primType

instance IsType Word8 where
  type' :: Type Word8
type' = PrimType Word8 -> Type Word8
forall a. PrimType a -> Type a
PrimType PrimType Word8
forall a. IsPrim a => PrimType a
primType

instance IsType Word16 where
  type' :: Type Word16
type' = PrimType Word16 -> Type Word16
forall a. PrimType a -> Type a
PrimType PrimType Word16
forall a. IsPrim a => PrimType a
primType

instance IsType Word32 where
  type' :: Type Word32
type' = PrimType Word32 -> Type Word32
forall a. PrimType a -> Type a
PrimType PrimType Word32
forall a. IsPrim a => PrimType a
primType

instance IsType Word64 where
  type' :: Type Word64
type' = PrimType Word64 -> Type Word64
forall a. PrimType a -> Type a
PrimType PrimType Word64
forall a. IsPrim a => PrimType a
primType

instance IsType Half where
  type' :: Type Half
type' = PrimType Half -> Type Half
forall a. PrimType a -> Type a
PrimType PrimType Half
forall a. IsPrim a => PrimType a
primType

instance IsType Float where
  type' :: Type Float
type' = PrimType Float -> Type Float
forall a. PrimType a -> Type a
PrimType PrimType Float
forall a. IsPrim a => PrimType a
primType

instance IsType Double where
  type' :: Type Double
type' = PrimType Double -> Type Double
forall a. PrimType a -> Type a
PrimType PrimType Double
forall a. IsPrim a => PrimType a
primType

instance IsType (Ptr Int) where
  type' :: Type (Ptr Int)
type' = PrimType (Ptr Int) -> Type (Ptr Int)
forall a. PrimType a -> Type a
PrimType PrimType (Ptr Int)
forall a. IsPrim a => PrimType a
primType

instance IsType (Ptr Int8) where
  type' :: Type (Ptr Int8)
type' = PrimType (Ptr Int8) -> Type (Ptr Int8)
forall a. PrimType a -> Type a
PrimType PrimType (Ptr Int8)
forall a. IsPrim a => PrimType a
primType

instance IsType (Ptr Int16) where
  type' :: Type (Ptr Int16)
type' = PrimType (Ptr Int16) -> Type (Ptr Int16)
forall a. PrimType a -> Type a
PrimType PrimType (Ptr Int16)
forall a. IsPrim a => PrimType a
primType

instance IsType (Ptr Int32) where
  type' :: Type (Ptr Int32)
type' = PrimType (Ptr Int32) -> Type (Ptr Int32)
forall a. PrimType a -> Type a
PrimType PrimType (Ptr Int32)
forall a. IsPrim a => PrimType a
primType

instance IsType (Ptr Int64) where
  type' :: Type (Ptr Int64)
type' = PrimType (Ptr Int64) -> Type (Ptr Int64)
forall a. PrimType a -> Type a
PrimType PrimType (Ptr Int64)
forall a. IsPrim a => PrimType a
primType

instance IsType (Ptr Word) where
  type' :: Type (Ptr Word)
type' = PrimType (Ptr Word) -> Type (Ptr Word)
forall a. PrimType a -> Type a
PrimType PrimType (Ptr Word)
forall a. IsPrim a => PrimType a
primType

instance IsType (Ptr Word8) where
  type' :: Type (Ptr Word8)
type' = PrimType (Ptr Word8) -> Type (Ptr Word8)
forall a. PrimType a -> Type a
PrimType PrimType (Ptr Word8)
forall a. IsPrim a => PrimType a
primType

instance IsType (Ptr Word16) where
  type' :: Type (Ptr Word16)
type' = PrimType (Ptr Word16) -> Type (Ptr Word16)
forall a. PrimType a -> Type a
PrimType PrimType (Ptr Word16)
forall a. IsPrim a => PrimType a
primType

instance IsType (Ptr Word32) where
  type' :: Type (Ptr Word32)
type' = PrimType (Ptr Word32) -> Type (Ptr Word32)
forall a. PrimType a -> Type a
PrimType PrimType (Ptr Word32)
forall a. IsPrim a => PrimType a
primType

instance IsType (Ptr Word64) where
  type' :: Type (Ptr Word64)
type' = PrimType (Ptr Word64) -> Type (Ptr Word64)
forall a. PrimType a -> Type a
PrimType PrimType (Ptr Word64)
forall a. IsPrim a => PrimType a
primType

instance IsType (Ptr Float) where
  type' :: Type (Ptr Float)
type' = PrimType (Ptr Float) -> Type (Ptr Float)
forall a. PrimType a -> Type a
PrimType PrimType (Ptr Float)
forall a. IsPrim a => PrimType a
primType

instance IsType (Ptr Double) where
  type' :: Type (Ptr Double)
type' = PrimType (Ptr Double) -> Type (Ptr Double)
forall a. PrimType a -> Type a
PrimType PrimType (Ptr Double)
forall a. IsPrim a => PrimType a
primType

instance IsType Bool where
  type' :: Type Bool
type' = PrimType Bool -> Type Bool
forall a. PrimType a -> Type a
PrimType PrimType Bool
BoolPrimType


-- | All primitive types
--

class IsPrim a where
  primType :: PrimType a

instance IsPrim Int where
  primType :: PrimType Int
primType = ScalarType Int -> PrimType Int
forall a. ScalarType a -> PrimType a
ScalarPrimType ScalarType Int
forall a. IsScalar a => ScalarType a
scalarType

instance IsPrim Int8 where
  primType :: PrimType Int8
primType = ScalarType Int8 -> PrimType Int8
forall a. ScalarType a -> PrimType a
ScalarPrimType ScalarType Int8
forall a. IsScalar a => ScalarType a
scalarType

instance IsPrim Int16 where
  primType :: PrimType Int16
primType = ScalarType Int16 -> PrimType Int16
forall a. ScalarType a -> PrimType a
ScalarPrimType ScalarType Int16
forall a. IsScalar a => ScalarType a
scalarType

instance IsPrim Int32 where
  primType :: PrimType Int32
primType = ScalarType Int32 -> PrimType Int32
forall a. ScalarType a -> PrimType a
ScalarPrimType ScalarType Int32
forall a. IsScalar a => ScalarType a
scalarType

instance IsPrim Int64 where
  primType :: PrimType Int64
primType = ScalarType Int64 -> PrimType Int64
forall a. ScalarType a -> PrimType a
ScalarPrimType ScalarType Int64
forall a. IsScalar a => ScalarType a
scalarType

instance IsPrim Word where
  primType :: PrimType Word
primType = ScalarType Word -> PrimType Word
forall a. ScalarType a -> PrimType a
ScalarPrimType ScalarType Word
forall a. IsScalar a => ScalarType a
scalarType

instance IsPrim Word8 where
  primType :: PrimType Word8
primType = ScalarType Word8 -> PrimType Word8
forall a. ScalarType a -> PrimType a
ScalarPrimType ScalarType Word8
forall a. IsScalar a => ScalarType a
scalarType

instance IsPrim Word16 where
  primType :: PrimType Word16
primType = ScalarType Word16 -> PrimType Word16
forall a. ScalarType a -> PrimType a
ScalarPrimType ScalarType Word16
forall a. IsScalar a => ScalarType a
scalarType

instance IsPrim Word32 where
  primType :: PrimType Word32
primType = ScalarType Word32 -> PrimType Word32
forall a. ScalarType a -> PrimType a
ScalarPrimType ScalarType Word32
forall a. IsScalar a => ScalarType a
scalarType

instance IsPrim Word64 where
  primType :: PrimType Word64
primType = ScalarType Word64 -> PrimType Word64
forall a. ScalarType a -> PrimType a
ScalarPrimType ScalarType Word64
forall a. IsScalar a => ScalarType a
scalarType

instance IsPrim Half where
  primType :: PrimType Half
primType = ScalarType Half -> PrimType Half
forall a. ScalarType a -> PrimType a
ScalarPrimType ScalarType Half
forall a. IsScalar a => ScalarType a
scalarType

instance IsPrim Float where
  primType :: PrimType Float
primType = ScalarType Float -> PrimType Float
forall a. ScalarType a -> PrimType a
ScalarPrimType ScalarType Float
forall a. IsScalar a => ScalarType a
scalarType

instance IsPrim Double where
  primType :: PrimType Double
primType = ScalarType Double -> PrimType Double
forall a. ScalarType a -> PrimType a
ScalarPrimType ScalarType Double
forall a. IsScalar a => ScalarType a
scalarType

instance IsPrim (Ptr Int) where
  primType :: PrimType (Ptr Int)
primType = PrimType Int -> AddrSpace -> PrimType (Ptr Int)
forall a. PrimType a -> AddrSpace -> PrimType (Ptr a)
PtrPrimType PrimType Int
forall a. IsPrim a => PrimType a
primType AddrSpace
defaultAddrSpace

instance IsPrim (Ptr Int8) where
  primType :: PrimType (Ptr Int8)
primType = PrimType Int8 -> AddrSpace -> PrimType (Ptr Int8)
forall a. PrimType a -> AddrSpace -> PrimType (Ptr a)
PtrPrimType PrimType Int8
forall a. IsPrim a => PrimType a
primType AddrSpace
defaultAddrSpace

instance IsPrim (Ptr Int16) where
  primType :: PrimType (Ptr Int16)
primType = PrimType Int16 -> AddrSpace -> PrimType (Ptr Int16)
forall a. PrimType a -> AddrSpace -> PrimType (Ptr a)
PtrPrimType PrimType Int16
forall a. IsPrim a => PrimType a
primType AddrSpace
defaultAddrSpace

instance IsPrim (Ptr Int32) where
  primType :: PrimType (Ptr Int32)
primType = PrimType Int32 -> AddrSpace -> PrimType (Ptr Int32)
forall a. PrimType a -> AddrSpace -> PrimType (Ptr a)
PtrPrimType PrimType Int32
forall a. IsPrim a => PrimType a
primType AddrSpace
defaultAddrSpace

instance IsPrim (Ptr Int64) where
  primType :: PrimType (Ptr Int64)
primType = PrimType Int64 -> AddrSpace -> PrimType (Ptr Int64)
forall a. PrimType a -> AddrSpace -> PrimType (Ptr a)
PtrPrimType PrimType Int64
forall a. IsPrim a => PrimType a
primType AddrSpace
defaultAddrSpace

instance IsPrim (Ptr Word) where
  primType :: PrimType (Ptr Word)
primType = PrimType Word -> AddrSpace -> PrimType (Ptr Word)
forall a. PrimType a -> AddrSpace -> PrimType (Ptr a)
PtrPrimType PrimType Word
forall a. IsPrim a => PrimType a
primType AddrSpace
defaultAddrSpace

instance IsPrim (Ptr Word8) where
  primType :: PrimType (Ptr Word8)
primType = PrimType Word8 -> AddrSpace -> PrimType (Ptr Word8)
forall a. PrimType a -> AddrSpace -> PrimType (Ptr a)
PtrPrimType PrimType Word8
forall a. IsPrim a => PrimType a
primType AddrSpace
defaultAddrSpace

instance IsPrim (Ptr Word16) where
  primType :: PrimType (Ptr Word16)
primType = PrimType Word16 -> AddrSpace -> PrimType (Ptr Word16)
forall a. PrimType a -> AddrSpace -> PrimType (Ptr a)
PtrPrimType PrimType Word16
forall a. IsPrim a => PrimType a
primType AddrSpace
defaultAddrSpace

instance IsPrim (Ptr Word32) where
  primType :: PrimType (Ptr Word32)
primType = PrimType Word32 -> AddrSpace -> PrimType (Ptr Word32)
forall a. PrimType a -> AddrSpace -> PrimType (Ptr a)
PtrPrimType PrimType Word32
forall a. IsPrim a => PrimType a
primType AddrSpace
defaultAddrSpace

instance IsPrim (Ptr Word64) where
  primType :: PrimType (Ptr Word64)
primType = PrimType Word64 -> AddrSpace -> PrimType (Ptr Word64)
forall a. PrimType a -> AddrSpace -> PrimType (Ptr a)
PtrPrimType PrimType Word64
forall a. IsPrim a => PrimType a
primType AddrSpace
defaultAddrSpace

instance IsPrim (Ptr Half) where
  primType :: PrimType (Ptr Half)
primType = PrimType Half -> AddrSpace -> PrimType (Ptr Half)
forall a. PrimType a -> AddrSpace -> PrimType (Ptr a)
PtrPrimType PrimType Half
forall a. IsPrim a => PrimType a
primType AddrSpace
defaultAddrSpace

instance IsPrim (Ptr Float) where
  primType :: PrimType (Ptr Float)
primType = PrimType Float -> AddrSpace -> PrimType (Ptr Float)
forall a. PrimType a -> AddrSpace -> PrimType (Ptr a)
PtrPrimType PrimType Float
forall a. IsPrim a => PrimType a
primType AddrSpace
defaultAddrSpace

instance IsPrim (Ptr Double) where
  primType :: PrimType (Ptr Double)
primType = PrimType Double -> AddrSpace -> PrimType (Ptr Double)
forall a. PrimType a -> AddrSpace -> PrimType (Ptr a)
PtrPrimType PrimType Double
forall a. IsPrim a => PrimType a
primType AddrSpace
defaultAddrSpace

instance IsPrim Bool where
  primType :: PrimType Bool
primType = PrimType Bool
BoolPrimType

instance Show (Type a) where
  show :: Type a -> String
show Type a
VoidType        = String
"()"
  show (PrimType PrimType a
t)    = PrimType a -> String
forall a. Show a => a -> String
show PrimType a
t

instance Show (PrimType a) where
  show :: PrimType a -> String
show PrimType a
BoolPrimType                   = String
"Bool"
  show (ScalarPrimType ScalarType a
t)             = ScalarType a -> String
forall a. Show a => a -> String
show ScalarType a
t
  show (StructPrimType TypeR a
t)             = TypeR a -> String
forall a. Show a => a -> String
show TypeR a
t
  show (ArrayPrimType Word64
n ScalarType a
t)            = String -> Word64 -> ShowS
forall r. PrintfType r => String -> r
printf String
"[%d x %s]" Word64
n (ScalarType a -> String
forall a. Show a => a -> String
show ScalarType a
t)
  show (PtrPrimType PrimType a
t (AddrSpace Word32
n))  = String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Ptr%s %s" String
a String
p
    where
      p :: String
p             = PrimType a -> String
forall a. Show a => a -> String
show PrimType a
t
      a :: String
a | Word32
n Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0    = String
""
        | Bool
otherwise = String -> Word32 -> String
forall r. PrintfType r => String -> r
printf String
"[addrspace %d]" Word32
n
      -- p | PtrPrimType{} <- t  = printf "(%s)" (show t)
      --   | otherwise           = show t


-- | Does the concrete type represent signed or unsigned values?
--
class IsSigned dict where
  signed   :: dict a -> Bool
  signed   = Bool -> Bool
not (Bool -> Bool) -> (dict a -> Bool) -> dict a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. dict a -> Bool
forall (dict :: * -> *) a. IsSigned dict => dict a -> Bool
unsigned
  --
  unsigned :: dict a -> Bool
  unsigned = Bool -> Bool
not (Bool -> Bool) -> (dict a -> Bool) -> dict a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. dict a -> Bool
forall (dict :: * -> *) a. IsSigned dict => dict a -> Bool
signed

instance IsSigned ScalarType where
  signed :: ScalarType a -> Bool
signed (SingleScalarType SingleType a
t) = SingleType a -> Bool
forall (dict :: * -> *) a. IsSigned dict => dict a -> Bool
signed SingleType a
t
  signed (VectorScalarType VectorType (Vec n a1)
t) = VectorType (Vec n a1) -> Bool
forall (dict :: * -> *) a. IsSigned dict => dict a -> Bool
signed VectorType (Vec n a1)
t

instance IsSigned SingleType where
  signed :: SingleType a -> Bool
signed (NumSingleType NumType a
t)    = NumType a -> Bool
forall (dict :: * -> *) a. IsSigned dict => dict a -> Bool
signed NumType a
t

instance IsSigned VectorType where
  signed :: VectorType a -> Bool
signed (VectorType Int
_ SingleType a1
t) = SingleType a1 -> Bool
forall (dict :: * -> *) a. IsSigned dict => dict a -> Bool
signed SingleType a1
t

instance IsSigned BoundedType where
  signed :: BoundedType a -> Bool
signed (IntegralBoundedType IntegralType a
t) = IntegralType a -> Bool
forall (dict :: * -> *) a. IsSigned dict => dict a -> Bool
signed IntegralType a
t

instance IsSigned NumType where
  signed :: NumType a -> Bool
signed (IntegralNumType IntegralType a
t) = IntegralType a -> Bool
forall (dict :: * -> *) a. IsSigned dict => dict a -> Bool
signed IntegralType a
t
  signed (FloatingNumType FloatingType a
t) = FloatingType a -> Bool
forall (dict :: * -> *) a. IsSigned dict => dict a -> Bool
signed FloatingType a
t

instance IsSigned IntegralType where
  signed :: IntegralType a -> Bool
signed = \case
    TypeInt{}     -> Bool
True
    TypeInt8{}    -> Bool
True
    TypeInt16{}   -> Bool
True
    TypeInt32{}   -> Bool
True
    TypeInt64{}   -> Bool
True
    IntegralType a
_             -> Bool
False

instance IsSigned FloatingType where
  signed :: FloatingType a -> Bool
signed FloatingType a
_ = Bool
True


-- | Recover the type of a container
--
class TypeOf f where
  typeOf :: f a -> Type a


-- | Convert to llvm-hs
--
instance Downcast (Type a) LLVM.Type where
  downcast :: Type a -> Type
downcast Type a
VoidType     = Type
LLVM.VoidType
  downcast (PrimType PrimType a
t) = PrimType a -> Type
forall typed untyped.
(Downcast typed untyped, HasCallStack) =>
typed -> untyped
downcast PrimType a
t

instance Downcast (PrimType a) LLVM.Type where
  downcast :: PrimType a -> Type
downcast PrimType a
BoolPrimType         = Word32 -> Type
LLVM.IntegerType Word32
1
  downcast (ScalarPrimType ScalarType a
t)   = ScalarType a -> Type
forall typed untyped.
(Downcast typed untyped, HasCallStack) =>
typed -> untyped
downcast ScalarType a
t
  downcast (PtrPrimType PrimType a
t AddrSpace
a)    = Type -> AddrSpace -> Type
LLVM.PointerType (PrimType a -> Type
forall typed untyped.
(Downcast typed untyped, HasCallStack) =>
typed -> untyped
downcast PrimType a
t) AddrSpace
a
  downcast (ArrayPrimType Word64
n ScalarType a
t)  = Word64 -> Type -> Type
LLVM.ArrayType Word64
n (ScalarType a -> Type
forall typed untyped.
(Downcast typed untyped, HasCallStack) =>
typed -> untyped
downcast ScalarType a
t)
  downcast (StructPrimType TypeR a
t)   = Bool -> [Type] -> Type
LLVM.StructureType Bool
False (TypeR a -> [Type]
forall t. TypeR t -> [Type]
go TypeR a
t)
    where
      go :: TypeR t -> [LLVM.Type]
      go :: TypeR t -> [Type]
go TypeR t
TupRunit         = []
      go (TupRsingle ScalarType t
s)   = [ScalarType t -> Type
forall typed untyped.
(Downcast typed untyped, HasCallStack) =>
typed -> untyped
downcast ScalarType t
s]
      go (TupRpair TupR ScalarType a1
ta TupR ScalarType b
tb) = TupR ScalarType a1 -> [Type]
forall t. TypeR t -> [Type]
go TupR ScalarType a1
ta [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ TupR ScalarType b -> [Type]
forall t. TypeR t -> [Type]
go TupR ScalarType b
tb