accelerate-llvm-1.4.0.0: src/LLVM/AST/Type/Representation.hs

{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# 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(..),
  defaultAddrSpace,

) where

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

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

-- import qualified LLVM.AST.Type                                      as LLVM
import qualified Data.Array.Accelerate.LLVM.Internal.LLVMPretty     as LLVM
import Data.Array.Accelerate.LLVM.Internal.LLVMPretty               ( AddrSpace(..), defaultAddrSpace )

import Data.List
import Data.Text.Lazy.Builder
import Foreign.Ptr
import Formatting
import Text.Printf
import qualified Data.ByteString.Short.Char8                        as S8


-- 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 LLArray 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?)
  ArrayPrimType   :: Word64 -> ScalarType a  -> PrimType (LLArray a) -- static arrays (TODO: type-level array length)
  StructPrimType  :: Bool -> TupR PrimType l -> PrimType l          -- aggregate structures
  NamedPrimType   :: Label                   -> PrimType a          -- typedef (TODO: add a type witness)


-- | All types
--

class IsType a where
  type' :: Type a

instance IsType () where
  type' = VoidType

instance IsType Int where
  type' = PrimType primType

instance IsType Int8 where
  type' = PrimType primType

instance IsType Int16 where
  type' = PrimType primType

instance IsType Int32 where
  type' = PrimType primType

instance IsType Int64 where
  type' = PrimType primType

instance IsType Word where
  type' = PrimType primType

instance IsType Word8 where
  type' = PrimType primType

instance IsType Word16 where
  type' = PrimType primType

instance IsType Word32 where
  type' = PrimType primType

instance IsType Word64 where
  type' = PrimType primType

instance IsType Half where
  type' = PrimType primType

instance IsType Float where
  type' = PrimType primType

instance IsType Double where
  type' = PrimType primType

instance IsType (Ptr Int) where
  type' = PrimType primType

instance IsType (Ptr Int8) where
  type' = PrimType primType

instance IsType (Ptr Int16) where
  type' = PrimType primType

instance IsType (Ptr Int32) where
  type' = PrimType primType

instance IsType (Ptr Int64) where
  type' = PrimType primType

instance IsType (Ptr Word) where
  type' = PrimType primType

instance IsType (Ptr Word8) where
  type' = PrimType primType

instance IsType (Ptr Word16) where
  type' = PrimType primType

instance IsType (Ptr Word32) where
  type' = PrimType primType

instance IsType (Ptr Word64) where
  type' = PrimType primType

instance IsType (Ptr Float) where
  type' = PrimType primType

instance IsType (Ptr Double) where
  type' = PrimType primType

instance IsType Bool where
  type' = PrimType BoolPrimType


-- | All primitive types
--

class IsPrim a where
  primType :: PrimType a

instance IsPrim Int where
  primType = ScalarPrimType scalarType

instance IsPrim Int8 where
  primType = ScalarPrimType scalarType

instance IsPrim Int16 where
  primType = ScalarPrimType scalarType

instance IsPrim Int32 where
  primType = ScalarPrimType scalarType

instance IsPrim Int64 where
  primType = ScalarPrimType scalarType

instance IsPrim Word where
  primType = ScalarPrimType scalarType

instance IsPrim Word8 where
  primType = ScalarPrimType scalarType

instance IsPrim Word16 where
  primType = ScalarPrimType scalarType

instance IsPrim Word32 where
  primType = ScalarPrimType scalarType

instance IsPrim Word64 where
  primType = ScalarPrimType scalarType

instance IsPrim Half where
  primType = ScalarPrimType scalarType

instance IsPrim Float where
  primType = ScalarPrimType scalarType

instance IsPrim Double where
  primType = ScalarPrimType scalarType

instance IsPrim (Ptr Int) where
  primType = PtrPrimType primType defaultAddrSpace

instance IsPrim (Ptr Int8) where
  primType = PtrPrimType primType defaultAddrSpace

instance IsPrim (Ptr Int16) where
  primType = PtrPrimType primType defaultAddrSpace

instance IsPrim (Ptr Int32) where
  primType = PtrPrimType primType defaultAddrSpace

instance IsPrim (Ptr Int64) where
  primType = PtrPrimType primType defaultAddrSpace

instance IsPrim (Ptr Word) where
  primType = PtrPrimType primType defaultAddrSpace

instance IsPrim (Ptr Word8) where
  primType = PtrPrimType primType defaultAddrSpace

instance IsPrim (Ptr Word16) where
  primType = PtrPrimType primType defaultAddrSpace

instance IsPrim (Ptr Word32) where
  primType = PtrPrimType primType defaultAddrSpace

instance IsPrim (Ptr Word64) where
  primType = PtrPrimType primType defaultAddrSpace

instance IsPrim (Ptr Half) where
  primType = PtrPrimType primType defaultAddrSpace

instance IsPrim (Ptr Float) where
  primType = PtrPrimType primType defaultAddrSpace

instance IsPrim (Ptr Double) where
  primType = PtrPrimType primType defaultAddrSpace

instance IsPrim Bool where
  primType = BoolPrimType

instance Show (Type a) where
  show VoidType     = "()"
  show (PrimType t) = show t

instance Show (PrimType a) where
  show BoolPrimType              = "Bool"
  show (ScalarPrimType t)        = show t
  show (NamedPrimType (Label l)) = S8.unpack l
  show (ArrayPrimType n t)       = printf "[%d x %s]" n (show t)
  show (StructPrimType _ t)      = printf "{ %s }" (intercalate ", " (go t))
    where
      go :: TupR PrimType t -> [String]
      go TupRunit         = []
      go (TupRsingle s)   = [show s]
      go (TupRpair ta tb) = go ta ++ go tb

  show (PtrPrimType t (AddrSpace n)) = printf "Ptr%s %s" a p
    where
      p             = show t
      a | n == 0    = ""
        | otherwise = printf "[addrspace %d]" n :: String
      -- p | PtrPrimType{} <- t  = printf "(%s)" (show t)
      --   | otherwise           = show t

formatType :: Format r (Type a -> r)
formatType = later $ \case
  VoidType   -> "()"
  PrimType t -> bformat formatPrimType t

formatPrimType :: Format r (PrimType a -> r)
formatPrimType = later $ \case
  BoolPrimType            -> "Bool"
  ScalarPrimType t        -> bformat formatScalarType t
  NamedPrimType (Label t) -> bformat string (S8.unpack t)
  ArrayPrimType n t       -> bformat (squared (int % " x " % formatScalarType)) n t
  StructPrimType _ t      -> bformat (braced (commaSpaceSep builder)) (go t)
    where
      go :: TupR PrimType t -> [Builder]
      go TupRunit         = []
      go (TupRsingle s)   = [bformat formatPrimType s]
      go (TupRpair ta tb) = go ta ++ go tb

  PtrPrimType t (AddrSpace 0) -> bformat ("Ptr "                        % formatPrimType) t
  PtrPrimType t (AddrSpace n) -> bformat ("Ptr[addrspace " % int % "] " % formatPrimType) n t


-- | Does the concrete type represent signed or unsigned values?
--
class IsSigned dict where
  signed   :: dict a -> Bool
  signed   = not . unsigned
  --
  unsigned :: dict a -> Bool
  unsigned = not . signed

instance IsSigned ScalarType where
  signed (SingleScalarType t) = signed t
  signed (VectorScalarType t) = signed t

instance IsSigned SingleType where
  signed (NumSingleType t)    = signed t

instance IsSigned VectorType where
  signed (VectorType _ t) = signed t

instance IsSigned BoundedType where
  signed (IntegralBoundedType t) = signed t

instance IsSigned NumType where
  signed (IntegralNumType t) = signed t
  signed (FloatingNumType t) = signed t

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

instance IsSigned FloatingType where
  signed _ = True


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


-- | Convert to llvm-pretty
--
instance Downcast (Type a) LLVM.Type where
  downcast VoidType     = LLVM.PrimType LLVM.Void
  downcast (PrimType t) = downcast t

instance Downcast (PrimType a) LLVM.Type where
  downcast BoolPrimType         = LLVM.PrimType (LLVM.Integer 1)
  downcast (NamedPrimType lab)  = LLVM.Alias (labelToPrettyI lab)
  downcast (ScalarPrimType t)   = downcast t
  downcast (PtrPrimType t a)    = LLVM.PtrTo (downcast t) a
  downcast (ArrayPrimType n t)  = LLVM.Array n (downcast t)
  downcast (StructPrimType p t) = (if p then LLVM.PackedStruct else LLVM.Struct) (go t)
    where
      go :: TupR PrimType t -> [LLVM.Type]
      go TupRunit         = []
      go (TupRsingle s)   = [downcast s]
      go (TupRpair ta tb) = go ta ++ go tb