{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}

--------------------------------------------------------------------------------
-- | The LLVM Type System.
--

module Llvm.Types where

#include "HsVersions.h"

import GhcPrelude

import Data.Char
import Data.Int
import Numeric

import DynFlags
import FastString
import Outputable
import Unique

-- from NCG
import PprBase

import GHC.Float

-- -----------------------------------------------------------------------------
-- * LLVM Basic Types and Variables
--

-- | A global mutable variable. Maybe defined or external
data LMGlobal = LMGlobal {
  LMGlobal -> LlvmVar
getGlobalVar :: LlvmVar,          -- ^ Returns the variable of the 'LMGlobal'
  LMGlobal -> Maybe LlvmStatic
getGlobalValue :: Maybe LlvmStatic -- ^ Return the value of the 'LMGlobal'
  }

-- | A String in LLVM
type LMString = FastString

-- | A type alias
type LlvmAlias = (LMString, LlvmType)

-- | Llvm Types
data LlvmType
  = LMInt Int             -- ^ An integer with a given width in bits.
  | LMFloat               -- ^ 32 bit floating point
  | LMDouble              -- ^ 64 bit floating point
  | LMFloat80             -- ^ 80 bit (x86 only) floating point
  | LMFloat128            -- ^ 128 bit floating point
  | LMPointer LlvmType    -- ^ A pointer to a 'LlvmType'
  | LMArray Int LlvmType  -- ^ An array of 'LlvmType'
  | LMVector Int LlvmType -- ^ A vector of 'LlvmType'
  | LMLabel               -- ^ A 'LlvmVar' can represent a label (address)
  | LMVoid                -- ^ Void type
  | LMStruct [LlvmType]   -- ^ Packed structure type
  | LMStructU [LlvmType]  -- ^ Unpacked structure type
  | LMAlias LlvmAlias     -- ^ A type alias
  | LMMetadata            -- ^ LLVM Metadata

  -- | Function type, used to create pointers to functions
  | LMFunction LlvmFunctionDecl
  deriving (LlvmType -> LlvmType -> Bool
(LlvmType -> LlvmType -> Bool)
-> (LlvmType -> LlvmType -> Bool) -> Eq LlvmType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LlvmType -> LlvmType -> Bool
$c/= :: LlvmType -> LlvmType -> Bool
== :: LlvmType -> LlvmType -> Bool
$c== :: LlvmType -> LlvmType -> Bool
Eq)

instance Outputable LlvmType where
  ppr :: LlvmType -> SDoc
ppr (LMInt Int
size     ) = Char -> SDoc
char Char
'i' SDoc -> SDoc -> SDoc
<> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
size
  ppr (LlvmType
LMFloat        ) = String -> SDoc
text String
"float"
  ppr (LlvmType
LMDouble       ) = String -> SDoc
text String
"double"
  ppr (LlvmType
LMFloat80      ) = String -> SDoc
text String
"x86_fp80"
  ppr (LlvmType
LMFloat128     ) = String -> SDoc
text String
"fp128"
  ppr (LMPointer LlvmType
x    ) = LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
x SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'*'
  ppr (LMArray Int
nr LlvmType
tp  ) = Char -> SDoc
char Char
'[' SDoc -> SDoc -> SDoc
<> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
nr SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" x " SDoc -> SDoc -> SDoc
<> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
tp SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
']'
  ppr (LMVector Int
nr LlvmType
tp ) = Char -> SDoc
char Char
'<' SDoc -> SDoc -> SDoc
<> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
nr SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" x " SDoc -> SDoc -> SDoc
<> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
tp SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'>'
  ppr (LlvmType
LMLabel        ) = String -> SDoc
text String
"label"
  ppr (LlvmType
LMVoid         ) = String -> SDoc
text String
"void"
  ppr (LMStruct [LlvmType]
tys   ) = String -> SDoc
text String
"<{" SDoc -> SDoc -> SDoc
<> [LlvmType] -> SDoc
forall a. Outputable a => [a] -> SDoc
ppCommaJoin [LlvmType]
tys SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"}>"
  ppr (LMStructU [LlvmType]
tys  ) = String -> SDoc
text String
"{" SDoc -> SDoc -> SDoc
<> [LlvmType] -> SDoc
forall a. Outputable a => [a] -> SDoc
ppCommaJoin [LlvmType]
tys SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"}"
  ppr (LlvmType
LMMetadata     ) = String -> SDoc
text String
"metadata"

  ppr (LMFunction (LlvmFunctionDecl LMString
_ LlvmLinkageType
_ LlvmCallConvention
_ LlvmType
r LlvmParameterListType
varg [LlvmParameter]
p LMAlign
_))
    = LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
r SDoc -> SDoc -> SDoc
<+> SDoc
lparen SDoc -> SDoc -> SDoc
<> LlvmParameterListType -> [LlvmParameter] -> SDoc
ppParams LlvmParameterListType
varg [LlvmParameter]
p SDoc -> SDoc -> SDoc
<> SDoc
rparen

  ppr (LMAlias (LMString
s,LlvmType
_)) = Char -> SDoc
char Char
'%' SDoc -> SDoc -> SDoc
<> LMString -> SDoc
ftext LMString
s

ppParams :: LlvmParameterListType -> [LlvmParameter] -> SDoc
ppParams :: LlvmParameterListType -> [LlvmParameter] -> SDoc
ppParams LlvmParameterListType
varg [LlvmParameter]
p
  = let varg' :: PtrString
varg' = case LlvmParameterListType
varg of
          LlvmParameterListType
VarArgs | [LlvmType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LlvmType]
args -> String -> PtrString
sLit String
"..."
                  | Bool
otherwise -> String -> PtrString
sLit String
", ..."
          LlvmParameterListType
_otherwise          -> String -> PtrString
sLit String
""
        -- by default we don't print param attributes
        args :: [LlvmType]
args = (LlvmParameter -> LlvmType) -> [LlvmParameter] -> [LlvmType]
forall a b. (a -> b) -> [a] -> [b]
map LlvmParameter -> LlvmType
forall a b. (a, b) -> a
fst [LlvmParameter]
p
    in [LlvmType] -> SDoc
forall a. Outputable a => [a] -> SDoc
ppCommaJoin [LlvmType]
args SDoc -> SDoc -> SDoc
<> PtrString -> SDoc
ptext PtrString
varg'

-- | An LLVM section definition. If Nothing then let LLVM decide the section
type LMSection = Maybe LMString
type LMAlign = Maybe Int

data LMConst = Global      -- ^ Mutable global variable
             | Constant    -- ^ Constant global variable
             | Alias       -- ^ Alias of another variable
             deriving (LMConst -> LMConst -> Bool
(LMConst -> LMConst -> Bool)
-> (LMConst -> LMConst -> Bool) -> Eq LMConst
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LMConst -> LMConst -> Bool
$c/= :: LMConst -> LMConst -> Bool
== :: LMConst -> LMConst -> Bool
$c== :: LMConst -> LMConst -> Bool
Eq)

-- | LLVM Variables
data LlvmVar
  -- | Variables with a global scope.
  = LMGlobalVar LMString LlvmType LlvmLinkageType LMSection LMAlign LMConst
  -- | Variables local to a function or parameters.
  | LMLocalVar Unique LlvmType
  -- | Named local variables. Sometimes we need to be able to explicitly name
  -- variables (e.g for function arguments).
  | LMNLocalVar LMString LlvmType
  -- | A constant variable
  | LMLitVar LlvmLit
  deriving (LlvmVar -> LlvmVar -> Bool
(LlvmVar -> LlvmVar -> Bool)
-> (LlvmVar -> LlvmVar -> Bool) -> Eq LlvmVar
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LlvmVar -> LlvmVar -> Bool
$c/= :: LlvmVar -> LlvmVar -> Bool
== :: LlvmVar -> LlvmVar -> Bool
$c== :: LlvmVar -> LlvmVar -> Bool
Eq)

instance Outputable LlvmVar where
  ppr :: LlvmVar -> SDoc
ppr (LMLitVar LlvmLit
x)  = LlvmLit -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmLit
x
  ppr (LlvmVar
x         )  = LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LlvmVar -> LlvmType
getVarType LlvmVar
x) SDoc -> SDoc -> SDoc
<+> LlvmVar -> SDoc
ppName LlvmVar
x


-- | Llvm Literal Data.
--
-- These can be used inline in expressions.
data LlvmLit
  -- | Refers to an integer constant (i64 42).
  = LMIntLit Integer LlvmType
  -- | Floating point literal
  | LMFloatLit Double LlvmType
  -- | Literal NULL, only applicable to pointer types
  | LMNullLit LlvmType
  -- | Vector literal
  | LMVectorLit [LlvmLit]
  -- | Undefined value, random bit pattern. Useful for optimisations.
  | LMUndefLit LlvmType
  deriving (LlvmLit -> LlvmLit -> Bool
(LlvmLit -> LlvmLit -> Bool)
-> (LlvmLit -> LlvmLit -> Bool) -> Eq LlvmLit
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LlvmLit -> LlvmLit -> Bool
$c/= :: LlvmLit -> LlvmLit -> Bool
== :: LlvmLit -> LlvmLit -> Bool
$c== :: LlvmLit -> LlvmLit -> Bool
Eq)

instance Outputable LlvmLit where
  ppr :: LlvmLit -> SDoc
ppr l :: LlvmLit
l@(LMVectorLit {}) = LlvmLit -> SDoc
ppLit LlvmLit
l
  ppr LlvmLit
l                  = LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LlvmLit -> LlvmType
getLitType LlvmLit
l) SDoc -> SDoc -> SDoc
<+> LlvmLit -> SDoc
ppLit LlvmLit
l


-- | Llvm Static Data.
--
-- These represent the possible global level variables and constants.
data LlvmStatic
  = LMComment LMString                  -- ^ A comment in a static section
  | LMStaticLit LlvmLit                 -- ^ A static variant of a literal value
  | LMUninitType LlvmType               -- ^ For uninitialised data
  | LMStaticStr LMString LlvmType       -- ^ Defines a static 'LMString'
  | LMStaticArray [LlvmStatic] LlvmType -- ^ A static array
  | LMStaticStruc [LlvmStatic] LlvmType -- ^ A static structure type
  | LMStaticPointer LlvmVar             -- ^ A pointer to other data

  -- static expressions, could split out but leave
  -- for moment for ease of use. Not many of them.

  | LMTrunc LlvmStatic LlvmType        -- ^ Truncate
  | LMBitc LlvmStatic LlvmType         -- ^ Pointer to Pointer conversion
  | LMPtoI LlvmStatic LlvmType         -- ^ Pointer to Integer conversion
  | LMAdd LlvmStatic LlvmStatic        -- ^ Constant addition operation
  | LMSub LlvmStatic LlvmStatic        -- ^ Constant subtraction operation

instance Outputable LlvmStatic where
  ppr :: LlvmStatic -> SDoc
ppr (LMComment       LMString
s) = String -> SDoc
text String
"; " SDoc -> SDoc -> SDoc
<> LMString -> SDoc
ftext LMString
s
  ppr (LMStaticLit   LlvmLit
l  ) = LlvmLit -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmLit
l
  ppr (LMUninitType    LlvmType
t) = LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
t SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" undef"
  ppr (LMStaticStr   LMString
s LlvmType
t) = LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
t SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" c\"" SDoc -> SDoc -> SDoc
<> LMString -> SDoc
ftext LMString
s SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"\\00\""
  ppr (LMStaticArray [LlvmStatic]
d LlvmType
t) = LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
t SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" [" SDoc -> SDoc -> SDoc
<> [LlvmStatic] -> SDoc
forall a. Outputable a => [a] -> SDoc
ppCommaJoin [LlvmStatic]
d SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
']'
  ppr (LMStaticStruc [LlvmStatic]
d LlvmType
t) = LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
t SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"<{" SDoc -> SDoc -> SDoc
<> [LlvmStatic] -> SDoc
forall a. Outputable a => [a] -> SDoc
ppCommaJoin [LlvmStatic]
d SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"}>"
  ppr (LMStaticPointer LlvmVar
v) = LlvmVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmVar
v
  ppr (LMTrunc LlvmStatic
v LlvmType
t)
      = LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
t SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" trunc (" SDoc -> SDoc -> SDoc
<> LlvmStatic -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmStatic
v SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" to " SDoc -> SDoc -> SDoc
<> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
t SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
')'
  ppr (LMBitc LlvmStatic
v LlvmType
t)
      = LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
t SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" bitcast (" SDoc -> SDoc -> SDoc
<> LlvmStatic -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmStatic
v SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" to " SDoc -> SDoc -> SDoc
<> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
t SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
')'
  ppr (LMPtoI LlvmStatic
v LlvmType
t)
      = LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
t SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" ptrtoint (" SDoc -> SDoc -> SDoc
<> LlvmStatic -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmStatic
v SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" to " SDoc -> SDoc -> SDoc
<> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
t SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
')'

  ppr (LMAdd LlvmStatic
s1 LlvmStatic
s2)
      = LlvmStatic
-> LlvmStatic -> PtrString -> PtrString -> String -> SDoc
pprStaticArith LlvmStatic
s1 LlvmStatic
s2 (String -> PtrString
sLit String
"add") (String -> PtrString
sLit String
"fadd") String
"LMAdd"
  ppr (LMSub LlvmStatic
s1 LlvmStatic
s2)
      = LlvmStatic
-> LlvmStatic -> PtrString -> PtrString -> String -> SDoc
pprStaticArith LlvmStatic
s1 LlvmStatic
s2 (String -> PtrString
sLit String
"sub") (String -> PtrString
sLit String
"fsub") String
"LMSub"


pprSpecialStatic :: LlvmStatic -> SDoc
pprSpecialStatic :: LlvmStatic -> SDoc
pprSpecialStatic (LMBitc LlvmStatic
v LlvmType
t) =
    LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LlvmType -> LlvmType
pLower LlvmType
t) SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
", bitcast (" SDoc -> SDoc -> SDoc
<> LlvmStatic -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmStatic
v SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" to " SDoc -> SDoc -> SDoc
<> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
t
        SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
')'
pprSpecialStatic v :: LlvmStatic
v@(LMStaticPointer LlvmVar
x) = LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LlvmType -> LlvmType
pLower (LlvmType -> LlvmType) -> LlvmType -> LlvmType
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmType
getVarType LlvmVar
x) SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+> LlvmStatic -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmStatic
v
pprSpecialStatic LlvmStatic
stat = LlvmStatic -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmStatic
stat


pprStaticArith :: LlvmStatic -> LlvmStatic -> PtrString -> PtrString
                  -> String -> SDoc
pprStaticArith :: LlvmStatic
-> LlvmStatic -> PtrString -> PtrString -> String -> SDoc
pprStaticArith LlvmStatic
s1 LlvmStatic
s2 PtrString
int_op PtrString
float_op String
op_name =
  let ty1 :: LlvmType
ty1 = LlvmStatic -> LlvmType
getStatType LlvmStatic
s1
      op :: PtrString
op  = if LlvmType -> Bool
isFloat LlvmType
ty1 then PtrString
float_op else PtrString
int_op
  in if LlvmType
ty1 LlvmType -> LlvmType -> Bool
forall a. Eq a => a -> a -> Bool
== LlvmStatic -> LlvmType
getStatType LlvmStatic
s2
     then LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
ty1 SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext PtrString
op SDoc -> SDoc -> SDoc
<+> SDoc
lparen SDoc -> SDoc -> SDoc
<> LlvmStatic -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmStatic
s1 SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<> LlvmStatic -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmStatic
s2 SDoc -> SDoc -> SDoc
<> SDoc
rparen
     else (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
            String -> SDoc
forall a. HasCallStack => String -> a
error (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
op_name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" with different types! s1: "
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (LlvmStatic -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmStatic
s1) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", s2: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (LlvmStatic -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmStatic
s2)

-- -----------------------------------------------------------------------------
-- ** Operations on LLVM Basic Types and Variables
--

-- | Return the variable name or value of the 'LlvmVar'
-- in Llvm IR textual representation (e.g. @\@x@, @%y@ or @42@).
ppName :: LlvmVar -> SDoc
ppName :: LlvmVar -> SDoc
ppName v :: LlvmVar
v@(LMGlobalVar {}) = Char -> SDoc
char Char
'@' SDoc -> SDoc -> SDoc
<> LlvmVar -> SDoc
ppPlainName LlvmVar
v
ppName v :: LlvmVar
v@(LMLocalVar  {}) = Char -> SDoc
char Char
'%' SDoc -> SDoc -> SDoc
<> LlvmVar -> SDoc
ppPlainName LlvmVar
v
ppName v :: LlvmVar
v@(LMNLocalVar {}) = Char -> SDoc
char Char
'%' SDoc -> SDoc -> SDoc
<> LlvmVar -> SDoc
ppPlainName LlvmVar
v
ppName v :: LlvmVar
v@(LMLitVar    {}) =             LlvmVar -> SDoc
ppPlainName LlvmVar
v

-- | Return the variable name or value of the 'LlvmVar'
-- in a plain textual representation (e.g. @x@, @y@ or @42@).
ppPlainName :: LlvmVar -> SDoc
ppPlainName :: LlvmVar -> SDoc
ppPlainName (LMGlobalVar LMString
x LlvmType
_ LlvmLinkageType
_ LMSection
_ LMAlign
_ LMConst
_) = LMString -> SDoc
ftext LMString
x
ppPlainName (LMLocalVar  Unique
x LlvmType
LMLabel  ) = String -> SDoc
text (Unique -> String
forall a. Show a => a -> String
show Unique
x)
ppPlainName (LMLocalVar  Unique
x LlvmType
_        ) = String -> SDoc
text (Char
'l' Char -> String -> String
forall a. a -> [a] -> [a]
: Unique -> String
forall a. Show a => a -> String
show Unique
x)
ppPlainName (LMNLocalVar LMString
x LlvmType
_        ) = LMString -> SDoc
ftext LMString
x
ppPlainName (LMLitVar    LlvmLit
x          ) = LlvmLit -> SDoc
ppLit LlvmLit
x

-- | Print a literal value. No type.
ppLit :: LlvmLit -> SDoc
ppLit :: LlvmLit -> SDoc
ppLit (LMIntLit Integer
i (LMInt Int
32))  = Int32 -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Integer -> Int32
forall a. Num a => Integer -> a
fromInteger Integer
i :: Int32)
ppLit (LMIntLit Integer
i (LMInt Int
64))  = Int64 -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Integer -> Int64
forall a. Num a => Integer -> a
fromInteger Integer
i :: Int64)
ppLit (LMIntLit   Integer
i LlvmType
_       )  = Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
i)::Int)
ppLit (LMFloatLit Double
r LlvmType
LMFloat )  = Float -> SDoc
ppFloat (Float -> SDoc) -> Float -> SDoc
forall a b. (a -> b) -> a -> b
$ Double -> Float
narrowFp Double
r
ppLit (LMFloatLit Double
r LlvmType
LMDouble)  = Double -> SDoc
ppDouble Double
r
ppLit f :: LlvmLit
f@(LMFloatLit Double
_ LlvmType
_)       = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags (\DynFlags
dflags ->
                                   String -> SDoc
forall a. HasCallStack => String -> a
error (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"Can't print this float literal!" String -> String -> String
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (LlvmLit -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmLit
f))
ppLit (LMVectorLit [LlvmLit]
ls  )       = Char -> SDoc
char Char
'<' SDoc -> SDoc -> SDoc
<+> [LlvmLit] -> SDoc
forall a. Outputable a => [a] -> SDoc
ppCommaJoin [LlvmLit]
ls SDoc -> SDoc -> SDoc
<+> Char -> SDoc
char Char
'>'
ppLit (LMNullLit LlvmType
_     )       = String -> SDoc
text String
"null"
-- #11487 was an issue where we passed undef for some arguments
-- that were actually live. By chance the registers holding those
-- arguments usually happened to have the right values anyways, but
-- that was not guaranteed. To find such bugs reliably, we set the
-- flag below when validating, which replaces undef literals (at
-- common types) with values that are likely to cause a crash or test
-- failure.
ppLit (LMUndefLit LlvmType
t    )       = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags DynFlags -> SDoc
f
  where f :: DynFlags -> SDoc
f DynFlags
dflags
          | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_LlvmFillUndefWithGarbage DynFlags
dflags,
            Just LlvmLit
lit <- LlvmType -> Maybe LlvmLit
garbageLit LlvmType
t   = LlvmLit -> SDoc
ppLit LlvmLit
lit
          | Bool
otherwise                  = String -> SDoc
text String
"undef"

garbageLit :: LlvmType -> Maybe LlvmLit
garbageLit :: LlvmType -> Maybe LlvmLit
garbageLit t :: LlvmType
t@(LMInt Int
w)     = LlvmLit -> Maybe LlvmLit
forall a. a -> Maybe a
Just (Integer -> LlvmType -> LlvmLit
LMIntLit (Integer
0xbbbbbbbbbbbbbbb0 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` (Integer
2Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^Int
w)) LlvmType
t)
  -- Use a value that looks like an untagged pointer, so we are more
  -- likely to try to enter it
garbageLit LlvmType
t
  | LlvmType -> Bool
isFloat LlvmType
t              = LlvmLit -> Maybe LlvmLit
forall a. a -> Maybe a
Just (Double -> LlvmType -> LlvmLit
LMFloatLit Double
12345678.9 LlvmType
t)
garbageLit t :: LlvmType
t@(LMPointer LlvmType
_) = LlvmLit -> Maybe LlvmLit
forall a. a -> Maybe a
Just (LlvmType -> LlvmLit
LMNullLit LlvmType
t)
  -- Using null isn't totally ideal, since some functions may check for null.
  -- But producing another value is inconvenient since it needs a cast,
  -- and the knowledge for how to format casts is in PpLlvm.
garbageLit LlvmType
_               = Maybe LlvmLit
forall a. Maybe a
Nothing
  -- More cases could be added, but this should do for now.

-- | Return the 'LlvmType' of the 'LlvmVar'
getVarType :: LlvmVar -> LlvmType
getVarType :: LlvmVar -> LlvmType
getVarType (LMGlobalVar LMString
_ LlvmType
y LlvmLinkageType
_ LMSection
_ LMAlign
_ LMConst
_) = LlvmType
y
getVarType (LMLocalVar  Unique
_ LlvmType
y        ) = LlvmType
y
getVarType (LMNLocalVar LMString
_ LlvmType
y        ) = LlvmType
y
getVarType (LMLitVar    LlvmLit
l          ) = LlvmLit -> LlvmType
getLitType LlvmLit
l

-- | Return the 'LlvmType' of a 'LlvmLit'
getLitType :: LlvmLit -> LlvmType
getLitType :: LlvmLit -> LlvmType
getLitType (LMIntLit   Integer
_ LlvmType
t) = LlvmType
t
getLitType (LMFloatLit Double
_ LlvmType
t) = LlvmType
t
getLitType (LMVectorLit [])  = String -> LlvmType
forall a. String -> a
panic String
"getLitType"
getLitType (LMVectorLit [LlvmLit]
ls)  = Int -> LlvmType -> LlvmType
LMVector ([LlvmLit] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LlvmLit]
ls) (LlvmLit -> LlvmType
getLitType ([LlvmLit] -> LlvmLit
forall a. [a] -> a
head [LlvmLit]
ls))
getLitType (LMNullLit    LlvmType
t) = LlvmType
t
getLitType (LMUndefLit   LlvmType
t) = LlvmType
t

-- | Return the 'LlvmType' of the 'LlvmStatic'
getStatType :: LlvmStatic -> LlvmType
getStatType :: LlvmStatic -> LlvmType
getStatType (LMStaticLit   LlvmLit
l  ) = LlvmLit -> LlvmType
getLitType LlvmLit
l
getStatType (LMUninitType    LlvmType
t) = LlvmType
t
getStatType (LMStaticStr   LMString
_ LlvmType
t) = LlvmType
t
getStatType (LMStaticArray [LlvmStatic]
_ LlvmType
t) = LlvmType
t
getStatType (LMStaticStruc [LlvmStatic]
_ LlvmType
t) = LlvmType
t
getStatType (LMStaticPointer LlvmVar
v) = LlvmVar -> LlvmType
getVarType LlvmVar
v
getStatType (LMTrunc       LlvmStatic
_ LlvmType
t) = LlvmType
t
getStatType (LMBitc        LlvmStatic
_ LlvmType
t) = LlvmType
t
getStatType (LMPtoI        LlvmStatic
_ LlvmType
t) = LlvmType
t
getStatType (LMAdd         LlvmStatic
t LlvmStatic
_) = LlvmStatic -> LlvmType
getStatType LlvmStatic
t
getStatType (LMSub         LlvmStatic
t LlvmStatic
_) = LlvmStatic -> LlvmType
getStatType LlvmStatic
t
getStatType (LMComment       LMString
_) = String -> LlvmType
forall a. HasCallStack => String -> a
error String
"Can't call getStatType on LMComment!"

-- | Return the 'LlvmLinkageType' for a 'LlvmVar'
getLink :: LlvmVar -> LlvmLinkageType
getLink :: LlvmVar -> LlvmLinkageType
getLink (LMGlobalVar LMString
_ LlvmType
_ LlvmLinkageType
l LMSection
_ LMAlign
_ LMConst
_) = LlvmLinkageType
l
getLink LlvmVar
_                         = LlvmLinkageType
Internal

-- | Add a pointer indirection to the supplied type. 'LMLabel' and 'LMVoid'
-- cannot be lifted.
pLift :: LlvmType -> LlvmType
pLift :: LlvmType -> LlvmType
pLift LlvmType
LMLabel    = String -> LlvmType
forall a. HasCallStack => String -> a
error String
"Labels are unliftable"
pLift LlvmType
LMVoid     = String -> LlvmType
forall a. HasCallStack => String -> a
error String
"Voids are unliftable"
pLift LlvmType
LMMetadata = String -> LlvmType
forall a. HasCallStack => String -> a
error String
"Metadatas are unliftable"
pLift LlvmType
x          = LlvmType -> LlvmType
LMPointer LlvmType
x

-- | Lift a variable to 'LMPointer' type.
pVarLift :: LlvmVar -> LlvmVar
pVarLift :: LlvmVar -> LlvmVar
pVarLift (LMGlobalVar LMString
s LlvmType
t LlvmLinkageType
l LMSection
x LMAlign
a LMConst
c) = LMString
-> LlvmType
-> LlvmLinkageType
-> LMSection
-> LMAlign
-> LMConst
-> LlvmVar
LMGlobalVar LMString
s (LlvmType -> LlvmType
pLift LlvmType
t) LlvmLinkageType
l LMSection
x LMAlign
a LMConst
c
pVarLift (LMLocalVar  Unique
s LlvmType
t        ) = Unique -> LlvmType -> LlvmVar
LMLocalVar  Unique
s (LlvmType -> LlvmType
pLift LlvmType
t)
pVarLift (LMNLocalVar LMString
s LlvmType
t        ) = LMString -> LlvmType -> LlvmVar
LMNLocalVar LMString
s (LlvmType -> LlvmType
pLift LlvmType
t)
pVarLift (LMLitVar    LlvmLit
_          ) = String -> LlvmVar
forall a. HasCallStack => String -> a
error (String -> LlvmVar) -> String -> LlvmVar
forall a b. (a -> b) -> a -> b
$ String
"Can't lower a literal type!"

-- | Remove the pointer indirection of the supplied type. Only 'LMPointer'
-- constructors can be lowered.
pLower :: LlvmType -> LlvmType
pLower :: LlvmType -> LlvmType
pLower (LMPointer LlvmType
x) = LlvmType
x
pLower LlvmType
x  = String -> SDoc -> LlvmType
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"llvmGen(pLower)"
            (SDoc -> LlvmType) -> SDoc -> LlvmType
forall a b. (a -> b) -> a -> b
$ LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
x SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
" is a unlowerable type, need a pointer"

-- | Lower a variable of 'LMPointer' type.
pVarLower :: LlvmVar -> LlvmVar
pVarLower :: LlvmVar -> LlvmVar
pVarLower (LMGlobalVar LMString
s LlvmType
t LlvmLinkageType
l LMSection
x LMAlign
a LMConst
c) = LMString
-> LlvmType
-> LlvmLinkageType
-> LMSection
-> LMAlign
-> LMConst
-> LlvmVar
LMGlobalVar LMString
s (LlvmType -> LlvmType
pLower LlvmType
t) LlvmLinkageType
l LMSection
x LMAlign
a LMConst
c
pVarLower (LMLocalVar  Unique
s LlvmType
t        ) = Unique -> LlvmType -> LlvmVar
LMLocalVar  Unique
s (LlvmType -> LlvmType
pLower LlvmType
t)
pVarLower (LMNLocalVar LMString
s LlvmType
t        ) = LMString -> LlvmType -> LlvmVar
LMNLocalVar LMString
s (LlvmType -> LlvmType
pLower LlvmType
t)
pVarLower (LMLitVar    LlvmLit
_          ) = String -> LlvmVar
forall a. HasCallStack => String -> a
error (String -> LlvmVar) -> String -> LlvmVar
forall a b. (a -> b) -> a -> b
$ String
"Can't lower a literal type!"

-- | Test if the given 'LlvmType' is an integer
isInt :: LlvmType -> Bool
isInt :: LlvmType -> Bool
isInt (LMInt Int
_) = Bool
True
isInt LlvmType
_         = Bool
False

-- | Test if the given 'LlvmType' is a floating point type
isFloat :: LlvmType -> Bool
isFloat :: LlvmType -> Bool
isFloat LlvmType
LMFloat    = Bool
True
isFloat LlvmType
LMDouble   = Bool
True
isFloat LlvmType
LMFloat80  = Bool
True
isFloat LlvmType
LMFloat128 = Bool
True
isFloat LlvmType
_          = Bool
False

-- | Test if the given 'LlvmType' is an 'LMPointer' construct
isPointer :: LlvmType -> Bool
isPointer :: LlvmType -> Bool
isPointer (LMPointer LlvmType
_) = Bool
True
isPointer LlvmType
_             = Bool
False

-- | Test if the given 'LlvmType' is an 'LMVector' construct
isVector :: LlvmType -> Bool
isVector :: LlvmType -> Bool
isVector (LMVector {}) = Bool
True
isVector LlvmType
_             = Bool
False

-- | Test if a 'LlvmVar' is global.
isGlobal :: LlvmVar -> Bool
isGlobal :: LlvmVar -> Bool
isGlobal (LMGlobalVar LMString
_ LlvmType
_ LlvmLinkageType
_ LMSection
_ LMAlign
_ LMConst
_) = Bool
True
isGlobal LlvmVar
_                         = Bool
False

-- | Width in bits of an 'LlvmType', returns 0 if not applicable
llvmWidthInBits :: DynFlags -> LlvmType -> Int
llvmWidthInBits :: DynFlags -> LlvmType -> Int
llvmWidthInBits DynFlags
_      (LMInt Int
n)       = Int
n
llvmWidthInBits DynFlags
_      (LlvmType
LMFloat)       = Int
32
llvmWidthInBits DynFlags
_      (LlvmType
LMDouble)      = Int
64
llvmWidthInBits DynFlags
_      (LlvmType
LMFloat80)     = Int
80
llvmWidthInBits DynFlags
_      (LlvmType
LMFloat128)    = Int
128
-- Could return either a pointer width here or the width of what
-- it points to. We will go with the former for now.
-- PMW: At least judging by the way LLVM outputs constants, pointers
--      should use the former, but arrays the latter.
llvmWidthInBits DynFlags
dflags (LMPointer LlvmType
_)   = DynFlags -> LlvmType -> Int
llvmWidthInBits DynFlags
dflags (DynFlags -> LlvmType
llvmWord DynFlags
dflags)
llvmWidthInBits DynFlags
dflags (LMArray Int
n LlvmType
t)   = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* DynFlags -> LlvmType -> Int
llvmWidthInBits DynFlags
dflags LlvmType
t
llvmWidthInBits DynFlags
dflags (LMVector Int
n LlvmType
ty) = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* DynFlags -> LlvmType -> Int
llvmWidthInBits DynFlags
dflags LlvmType
ty
llvmWidthInBits DynFlags
_      LlvmType
LMLabel         = Int
0
llvmWidthInBits DynFlags
_      LlvmType
LMVoid          = Int
0
llvmWidthInBits DynFlags
dflags (LMStruct [LlvmType]
tys)  = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (LlvmType -> Int) -> [LlvmType] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> LlvmType -> Int
llvmWidthInBits DynFlags
dflags) [LlvmType]
tys
llvmWidthInBits DynFlags
_      (LMStructU [LlvmType]
_)   =
    -- It's not trivial to calculate the bit width of the unpacked structs,
    -- since they will be aligned depending on the specified datalayout (
    -- http://llvm.org/docs/LangRef.html#data-layout ). One way we could support
    -- this could be to make the LlvmCodeGen.Ppr.moduleLayout be a data type
    -- that exposes the alignment information. However, currently the only place
    -- we use unpacked structs is LLVM intrinsics that return them (e.g.,
    -- llvm.sadd.with.overflow.*), so we don't actually need to compute their
    -- bit width.
    String -> Int
forall a. String -> a
panic String
"llvmWidthInBits: not implemented for LMStructU"
llvmWidthInBits DynFlags
_      (LMFunction  LlvmFunctionDecl
_) = Int
0
llvmWidthInBits DynFlags
dflags (LMAlias (LMString
_,LlvmType
t)) = DynFlags -> LlvmType -> Int
llvmWidthInBits DynFlags
dflags LlvmType
t
llvmWidthInBits DynFlags
_      LlvmType
LMMetadata      = String -> Int
forall a. String -> a
panic String
"llvmWidthInBits: Meta-data has no runtime representation!"


-- -----------------------------------------------------------------------------
-- ** Shortcut for Common Types
--

i128, i64, i32, i16, i8, i1, i8Ptr :: LlvmType
i128 :: LlvmType
i128  = Int -> LlvmType
LMInt Int
128
i64 :: LlvmType
i64   = Int -> LlvmType
LMInt  Int
64
i32 :: LlvmType
i32   = Int -> LlvmType
LMInt  Int
32
i16 :: LlvmType
i16   = Int -> LlvmType
LMInt  Int
16
i8 :: LlvmType
i8    = Int -> LlvmType
LMInt   Int
8
i1 :: LlvmType
i1    = Int -> LlvmType
LMInt   Int
1
i8Ptr :: LlvmType
i8Ptr = LlvmType -> LlvmType
pLift LlvmType
i8

-- | The target architectures word size
llvmWord, llvmWordPtr :: DynFlags -> LlvmType
llvmWord :: DynFlags -> LlvmType
llvmWord    DynFlags
dflags = Int -> LlvmType
LMInt (DynFlags -> Int
wORD_SIZE DynFlags
dflags Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8)
llvmWordPtr :: DynFlags -> LlvmType
llvmWordPtr DynFlags
dflags = LlvmType -> LlvmType
pLift (DynFlags -> LlvmType
llvmWord DynFlags
dflags)

-- -----------------------------------------------------------------------------
-- * LLVM Function Types
--

-- | An LLVM Function
data LlvmFunctionDecl = LlvmFunctionDecl {
        -- | Unique identifier of the function
        LlvmFunctionDecl -> LMString
decName       :: LMString,
        -- | LinkageType of the function
        LlvmFunctionDecl -> LlvmLinkageType
funcLinkage   :: LlvmLinkageType,
        -- | The calling convention of the function
        LlvmFunctionDecl -> LlvmCallConvention
funcCc        :: LlvmCallConvention,
        -- | Type of the returned value
        LlvmFunctionDecl -> LlvmType
decReturnType :: LlvmType,
        -- | Indicates if this function uses varargs
        LlvmFunctionDecl -> LlvmParameterListType
decVarargs    :: LlvmParameterListType,
        -- | Parameter types and attributes
        LlvmFunctionDecl -> [LlvmParameter]
decParams     :: [LlvmParameter],
        -- | Function align value, must be power of 2
        LlvmFunctionDecl -> LMAlign
funcAlign     :: LMAlign
  }
  deriving (LlvmFunctionDecl -> LlvmFunctionDecl -> Bool
(LlvmFunctionDecl -> LlvmFunctionDecl -> Bool)
-> (LlvmFunctionDecl -> LlvmFunctionDecl -> Bool)
-> Eq LlvmFunctionDecl
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LlvmFunctionDecl -> LlvmFunctionDecl -> Bool
$c/= :: LlvmFunctionDecl -> LlvmFunctionDecl -> Bool
== :: LlvmFunctionDecl -> LlvmFunctionDecl -> Bool
$c== :: LlvmFunctionDecl -> LlvmFunctionDecl -> Bool
Eq)

instance Outputable LlvmFunctionDecl where
  ppr :: LlvmFunctionDecl -> SDoc
ppr (LlvmFunctionDecl LMString
n LlvmLinkageType
l LlvmCallConvention
c LlvmType
r LlvmParameterListType
varg [LlvmParameter]
p LMAlign
a)
    = let align :: SDoc
align = case LMAlign
a of
                       Just Int
a' -> String -> SDoc
text String
" align " SDoc -> SDoc -> SDoc
<> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
a'
                       LMAlign
Nothing -> SDoc
empty
      in LlvmLinkageType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmLinkageType
l SDoc -> SDoc -> SDoc
<+> LlvmCallConvention -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmCallConvention
c SDoc -> SDoc -> SDoc
<+> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
r SDoc -> SDoc -> SDoc
<+> Char -> SDoc
char Char
'@' SDoc -> SDoc -> SDoc
<> LMString -> SDoc
ftext LMString
n SDoc -> SDoc -> SDoc
<>
             SDoc
lparen SDoc -> SDoc -> SDoc
<> LlvmParameterListType -> [LlvmParameter] -> SDoc
ppParams LlvmParameterListType
varg [LlvmParameter]
p SDoc -> SDoc -> SDoc
<> SDoc
rparen SDoc -> SDoc -> SDoc
<> SDoc
align

type LlvmFunctionDecls = [LlvmFunctionDecl]

type LlvmParameter = (LlvmType, [LlvmParamAttr])

-- | LLVM Parameter Attributes.
--
-- Parameter attributes are used to communicate additional information about
-- the result or parameters of a function
data LlvmParamAttr
  -- | This indicates to the code generator that the parameter or return value
  -- should be zero-extended to a 32-bit value by the caller (for a parameter)
  -- or the callee (for a return value).
  = ZeroExt
  -- | This indicates to the code generator that the parameter or return value
  -- should be sign-extended to a 32-bit value by the caller (for a parameter)
  -- or the callee (for a return value).
  | SignExt
  -- | This indicates that this parameter or return value should be treated in
  -- a special target-dependent fashion during while emitting code for a
  -- function call or return (usually, by putting it in a register as opposed
  -- to memory).
  | InReg
  -- | This indicates that the pointer parameter should really be passed by
  -- value to the function.
  | ByVal
  -- | This indicates that the pointer parameter specifies the address of a
  -- structure that is the return value of the function in the source program.
  | SRet
  -- | This indicates that the pointer does not alias any global or any other
  -- parameter.
  | NoAlias
  -- | This indicates that the callee does not make any copies of the pointer
  -- that outlive the callee itself
  | NoCapture
  -- | This indicates that the pointer parameter can be excised using the
  -- trampoline intrinsics.
  | Nest
  deriving (LlvmParamAttr -> LlvmParamAttr -> Bool
(LlvmParamAttr -> LlvmParamAttr -> Bool)
-> (LlvmParamAttr -> LlvmParamAttr -> Bool) -> Eq LlvmParamAttr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LlvmParamAttr -> LlvmParamAttr -> Bool
$c/= :: LlvmParamAttr -> LlvmParamAttr -> Bool
== :: LlvmParamAttr -> LlvmParamAttr -> Bool
$c== :: LlvmParamAttr -> LlvmParamAttr -> Bool
Eq)

instance Outputable LlvmParamAttr where
  ppr :: LlvmParamAttr -> SDoc
ppr LlvmParamAttr
ZeroExt   = String -> SDoc
text String
"zeroext"
  ppr LlvmParamAttr
SignExt   = String -> SDoc
text String
"signext"
  ppr LlvmParamAttr
InReg     = String -> SDoc
text String
"inreg"
  ppr LlvmParamAttr
ByVal     = String -> SDoc
text String
"byval"
  ppr LlvmParamAttr
SRet      = String -> SDoc
text String
"sret"
  ppr LlvmParamAttr
NoAlias   = String -> SDoc
text String
"noalias"
  ppr LlvmParamAttr
NoCapture = String -> SDoc
text String
"nocapture"
  ppr LlvmParamAttr
Nest      = String -> SDoc
text String
"nest"

-- | Llvm Function Attributes.
--
-- Function attributes are set to communicate additional information about a
-- function. Function attributes are considered to be part of the function,
-- not of the function type, so functions with different parameter attributes
-- can have the same function type. Functions can have multiple attributes.
--
-- Descriptions taken from <http://llvm.org/docs/LangRef.html#fnattrs>
data LlvmFuncAttr
  -- | This attribute indicates that the inliner should attempt to inline this
  -- function into callers whenever possible, ignoring any active inlining
  -- size threshold for this caller.
  = AlwaysInline
  -- | This attribute indicates that the source code contained a hint that
  -- inlining this function is desirable (such as the \"inline\" keyword in
  -- C/C++). It is just a hint; it imposes no requirements on the inliner.
  | InlineHint
  -- | This attribute indicates that the inliner should never inline this
  -- function in any situation. This attribute may not be used together
  -- with the alwaysinline attribute.
  | NoInline
  -- | This attribute suggests that optimization passes and code generator
  -- passes make choices that keep the code size of this function low, and
  -- otherwise do optimizations specifically to reduce code size.
  | OptSize
  -- | This function attribute indicates that the function never returns
  -- normally. This produces undefined behavior at runtime if the function
  -- ever does dynamically return.
  | NoReturn
  -- | This function attribute indicates that the function never returns with
  -- an unwind or exceptional control flow. If the function does unwind, its
  -- runtime behavior is undefined.
  | NoUnwind
  -- | This attribute indicates that the function computes its result (or
  -- decides to unwind an exception) based strictly on its arguments, without
  -- dereferencing any pointer arguments or otherwise accessing any mutable
  -- state (e.g. memory, control registers, etc) visible to caller functions.
  -- It does not write through any pointer arguments (including byval
  -- arguments) and never changes any state visible to callers. This means
  -- that it cannot unwind exceptions by calling the C++ exception throwing
  -- methods, but could use the unwind instruction.
  | ReadNone
  -- | This attribute indicates that the function does not write through any
  -- pointer arguments (including byval arguments) or otherwise modify any
  -- state (e.g. memory, control registers, etc) visible to caller functions.
  -- It may dereference pointer arguments and read state that may be set in
  -- the caller. A readonly function always returns the same value (or unwinds
  -- an exception identically) when called with the same set of arguments and
  -- global state. It cannot unwind an exception by calling the C++ exception
  -- throwing methods, but may use the unwind instruction.
  | ReadOnly
  -- | This attribute indicates that the function should emit a stack smashing
  -- protector. It is in the form of a \"canary\"—a random value placed on the
  -- stack before the local variables that's checked upon return from the
  -- function to see if it has been overwritten. A heuristic is used to
  -- determine if a function needs stack protectors or not.
  --
  -- If a function that has an ssp attribute is inlined into a function that
  -- doesn't have an ssp attribute, then the resulting function will have an
  -- ssp attribute.
  | Ssp
  -- | This attribute indicates that the function should always emit a stack
  -- smashing protector. This overrides the ssp function attribute.
  --
  -- If a function that has an sspreq attribute is inlined into a function
  -- that doesn't have an sspreq attribute or which has an ssp attribute,
  -- then the resulting function will have an sspreq attribute.
  | SspReq
  -- | This attribute indicates that the code generator should not use a red
  -- zone, even if the target-specific ABI normally permits it.
  | NoRedZone
  -- | This attributes disables implicit floating point instructions.
  | NoImplicitFloat
  -- | This attribute disables prologue / epilogue emission for the function.
  -- This can have very system-specific consequences.
  | Naked
  deriving (LlvmFuncAttr -> LlvmFuncAttr -> Bool
(LlvmFuncAttr -> LlvmFuncAttr -> Bool)
-> (LlvmFuncAttr -> LlvmFuncAttr -> Bool) -> Eq LlvmFuncAttr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LlvmFuncAttr -> LlvmFuncAttr -> Bool
$c/= :: LlvmFuncAttr -> LlvmFuncAttr -> Bool
== :: LlvmFuncAttr -> LlvmFuncAttr -> Bool
$c== :: LlvmFuncAttr -> LlvmFuncAttr -> Bool
Eq)

instance Outputable LlvmFuncAttr where
  ppr :: LlvmFuncAttr -> SDoc
ppr LlvmFuncAttr
AlwaysInline       = String -> SDoc
text String
"alwaysinline"
  ppr LlvmFuncAttr
InlineHint         = String -> SDoc
text String
"inlinehint"
  ppr LlvmFuncAttr
NoInline           = String -> SDoc
text String
"noinline"
  ppr LlvmFuncAttr
OptSize            = String -> SDoc
text String
"optsize"
  ppr LlvmFuncAttr
NoReturn           = String -> SDoc
text String
"noreturn"
  ppr LlvmFuncAttr
NoUnwind           = String -> SDoc
text String
"nounwind"
  ppr LlvmFuncAttr
ReadNone           = String -> SDoc
text String
"readnon"
  ppr LlvmFuncAttr
ReadOnly           = String -> SDoc
text String
"readonly"
  ppr LlvmFuncAttr
Ssp                = String -> SDoc
text String
"ssp"
  ppr LlvmFuncAttr
SspReq             = String -> SDoc
text String
"ssqreq"
  ppr LlvmFuncAttr
NoRedZone          = String -> SDoc
text String
"noredzone"
  ppr LlvmFuncAttr
NoImplicitFloat    = String -> SDoc
text String
"noimplicitfloat"
  ppr LlvmFuncAttr
Naked              = String -> SDoc
text String
"naked"


-- | Different types to call a function.
data LlvmCallType
  -- | Normal call, allocate a new stack frame.
  = StdCall
  -- | Tail call, perform the call in the current stack frame.
  | TailCall
  deriving (LlvmCallType -> LlvmCallType -> Bool
(LlvmCallType -> LlvmCallType -> Bool)
-> (LlvmCallType -> LlvmCallType -> Bool) -> Eq LlvmCallType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LlvmCallType -> LlvmCallType -> Bool
$c/= :: LlvmCallType -> LlvmCallType -> Bool
== :: LlvmCallType -> LlvmCallType -> Bool
$c== :: LlvmCallType -> LlvmCallType -> Bool
Eq,Int -> LlvmCallType -> String -> String
[LlvmCallType] -> String -> String
LlvmCallType -> String
(Int -> LlvmCallType -> String -> String)
-> (LlvmCallType -> String)
-> ([LlvmCallType] -> String -> String)
-> Show LlvmCallType
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [LlvmCallType] -> String -> String
$cshowList :: [LlvmCallType] -> String -> String
show :: LlvmCallType -> String
$cshow :: LlvmCallType -> String
showsPrec :: Int -> LlvmCallType -> String -> String
$cshowsPrec :: Int -> LlvmCallType -> String -> String
Show)

-- | Different calling conventions a function can use.
data LlvmCallConvention
  -- | The C calling convention.
  -- This calling convention (the default if no other calling convention is
  -- specified) matches the target C calling conventions. This calling
  -- convention supports varargs function calls and tolerates some mismatch in
  -- the declared prototype and implemented declaration of the function (as
  -- does normal C).
  = CC_Ccc
  -- | This calling convention attempts to make calls as fast as possible
  -- (e.g. by passing things in registers). This calling convention allows
  -- the target to use whatever tricks it wants to produce fast code for the
  -- target, without having to conform to an externally specified ABI
  -- (Application Binary Interface). Implementations of this convention should
  -- allow arbitrary tail call optimization to be supported. This calling
  -- convention does not support varargs and requires the prototype of al
  -- callees to exactly match the prototype of the function definition.
  | CC_Fastcc
  -- | This calling convention attempts to make code in the caller as efficient
  -- as possible under the assumption that the call is not commonly executed.
  -- As such, these calls often preserve all registers so that the call does
  -- not break any live ranges in the caller side. This calling convention
  -- does not support varargs and requires the prototype of all callees to
  -- exactly match the prototype of the function definition.
  | CC_Coldcc
  -- | The GHC-specific 'registerised' calling convention.
  | CC_Ghc
  -- | Any calling convention may be specified by number, allowing
  -- target-specific calling conventions to be used. Target specific calling
  -- conventions start at 64.
  | CC_Ncc Int
  -- | X86 Specific 'StdCall' convention. LLVM includes a specific alias for it
  -- rather than just using CC_Ncc.
  | CC_X86_Stdcc
  deriving (LlvmCallConvention -> LlvmCallConvention -> Bool
(LlvmCallConvention -> LlvmCallConvention -> Bool)
-> (LlvmCallConvention -> LlvmCallConvention -> Bool)
-> Eq LlvmCallConvention
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LlvmCallConvention -> LlvmCallConvention -> Bool
$c/= :: LlvmCallConvention -> LlvmCallConvention -> Bool
== :: LlvmCallConvention -> LlvmCallConvention -> Bool
$c== :: LlvmCallConvention -> LlvmCallConvention -> Bool
Eq)

instance Outputable LlvmCallConvention where
  ppr :: LlvmCallConvention -> SDoc
ppr LlvmCallConvention
CC_Ccc       = String -> SDoc
text String
"ccc"
  ppr LlvmCallConvention
CC_Fastcc    = String -> SDoc
text String
"fastcc"
  ppr LlvmCallConvention
CC_Coldcc    = String -> SDoc
text String
"coldcc"
  ppr LlvmCallConvention
CC_Ghc       = String -> SDoc
text String
"ghccc"
  ppr (CC_Ncc Int
i)   = String -> SDoc
text String
"cc " SDoc -> SDoc -> SDoc
<> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
i
  ppr LlvmCallConvention
CC_X86_Stdcc = String -> SDoc
text String
"x86_stdcallcc"


-- | Functions can have a fixed amount of parameters, or a variable amount.
data LlvmParameterListType
  -- Fixed amount of arguments.
  = FixedArgs
  -- Variable amount of arguments.
  | VarArgs
  deriving (LlvmParameterListType -> LlvmParameterListType -> Bool
(LlvmParameterListType -> LlvmParameterListType -> Bool)
-> (LlvmParameterListType -> LlvmParameterListType -> Bool)
-> Eq LlvmParameterListType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LlvmParameterListType -> LlvmParameterListType -> Bool
$c/= :: LlvmParameterListType -> LlvmParameterListType -> Bool
== :: LlvmParameterListType -> LlvmParameterListType -> Bool
$c== :: LlvmParameterListType -> LlvmParameterListType -> Bool
Eq,Int -> LlvmParameterListType -> String -> String
[LlvmParameterListType] -> String -> String
LlvmParameterListType -> String
(Int -> LlvmParameterListType -> String -> String)
-> (LlvmParameterListType -> String)
-> ([LlvmParameterListType] -> String -> String)
-> Show LlvmParameterListType
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [LlvmParameterListType] -> String -> String
$cshowList :: [LlvmParameterListType] -> String -> String
show :: LlvmParameterListType -> String
$cshow :: LlvmParameterListType -> String
showsPrec :: Int -> LlvmParameterListType -> String -> String
$cshowsPrec :: Int -> LlvmParameterListType -> String -> String
Show)


-- | Linkage type of a symbol.
--
-- The description of the constructors is copied from the Llvm Assembly Language
-- Reference Manual <http://www.llvm.org/docs/LangRef.html#linkage>, because
-- they correspond to the Llvm linkage types.
data LlvmLinkageType
  -- | Global values with internal linkage are only directly accessible by
  -- objects in the current module. In particular, linking code into a module
  -- with an internal global value may cause the internal to be renamed as
  -- necessary to avoid collisions. Because the symbol is internal to the
  -- module, all references can be updated. This corresponds to the notion
  -- of the @static@ keyword in C.
  = Internal
  -- | Globals with @linkonce@ linkage are merged with other globals of the
  -- same name when linkage occurs. This is typically used to implement
  -- inline functions, templates, or other code which must be generated
  -- in each translation unit that uses it. Unreferenced linkonce globals are
  -- allowed to be discarded.
  | LinkOnce
  -- | @weak@ linkage is exactly the same as linkonce linkage, except that
  -- unreferenced weak globals may not be discarded. This is used for globals
  -- that may be emitted in multiple translation units, but that are not
  -- guaranteed to be emitted into every translation unit that uses them. One
  -- example of this are common globals in C, such as @int X;@ at global
  -- scope.
  | Weak
  -- | @appending@ linkage may only be applied to global variables of pointer
  -- to array type. When two global variables with appending linkage are
  -- linked together, the two global arrays are appended together. This is
  -- the Llvm, typesafe, equivalent of having the system linker append
  -- together @sections@ with identical names when .o files are linked.
  | Appending
  -- | The semantics of this linkage follow the ELF model: the symbol is weak
  -- until linked, if not linked, the symbol becomes null instead of being an
  -- undefined reference.
  | ExternWeak
  -- | The symbol participates in linkage and can be used to resolve external
  --  symbol references.
  | ExternallyVisible
  -- | Alias for 'ExternallyVisible' but with explicit textual form in LLVM
  --  assembly.
  | External
  -- | Symbol is private to the module and should not appear in the symbol table
  | Private
  deriving (LlvmLinkageType -> LlvmLinkageType -> Bool
(LlvmLinkageType -> LlvmLinkageType -> Bool)
-> (LlvmLinkageType -> LlvmLinkageType -> Bool)
-> Eq LlvmLinkageType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LlvmLinkageType -> LlvmLinkageType -> Bool
$c/= :: LlvmLinkageType -> LlvmLinkageType -> Bool
== :: LlvmLinkageType -> LlvmLinkageType -> Bool
$c== :: LlvmLinkageType -> LlvmLinkageType -> Bool
Eq)

instance Outputable LlvmLinkageType where
  ppr :: LlvmLinkageType -> SDoc
ppr LlvmLinkageType
Internal          = String -> SDoc
text String
"internal"
  ppr LlvmLinkageType
LinkOnce          = String -> SDoc
text String
"linkonce"
  ppr LlvmLinkageType
Weak              = String -> SDoc
text String
"weak"
  ppr LlvmLinkageType
Appending         = String -> SDoc
text String
"appending"
  ppr LlvmLinkageType
ExternWeak        = String -> SDoc
text String
"extern_weak"
  -- ExternallyVisible does not have a textual representation, it is
  -- the linkage type a function resolves to if no other is specified
  -- in Llvm.
  ppr LlvmLinkageType
ExternallyVisible = SDoc
empty
  ppr LlvmLinkageType
External          = String -> SDoc
text String
"external"
  ppr LlvmLinkageType
Private           = String -> SDoc
text String
"private"

-- -----------------------------------------------------------------------------
-- * LLVM Operations
--

-- | Llvm binary operators machine operations.
data LlvmMachOp
  = LM_MO_Add  -- ^ add two integer, floating point or vector values.
  | LM_MO_Sub  -- ^ subtract two ...
  | LM_MO_Mul  -- ^ multiply ..
  | LM_MO_UDiv -- ^ unsigned integer or vector division.
  | LM_MO_SDiv -- ^ signed integer ..
  | LM_MO_URem -- ^ unsigned integer or vector remainder (mod)
  | LM_MO_SRem -- ^ signed ...

  | LM_MO_FAdd -- ^ add two floating point or vector values.
  | LM_MO_FSub -- ^ subtract two ...
  | LM_MO_FMul -- ^ multiply ...
  | LM_MO_FDiv -- ^ divide ...
  | LM_MO_FRem -- ^ remainder ...

  -- | Left shift
  | LM_MO_Shl
  -- | Logical shift right
  -- Shift right, filling with zero
  | LM_MO_LShr
  -- | Arithmetic shift right
  -- The most significant bits of the result will be equal to the sign bit of
  -- the left operand.
  | LM_MO_AShr

  | LM_MO_And -- ^ AND bitwise logical operation.
  | LM_MO_Or  -- ^ OR bitwise logical operation.
  | LM_MO_Xor -- ^ XOR bitwise logical operation.
  deriving (LlvmMachOp -> LlvmMachOp -> Bool
(LlvmMachOp -> LlvmMachOp -> Bool)
-> (LlvmMachOp -> LlvmMachOp -> Bool) -> Eq LlvmMachOp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LlvmMachOp -> LlvmMachOp -> Bool
$c/= :: LlvmMachOp -> LlvmMachOp -> Bool
== :: LlvmMachOp -> LlvmMachOp -> Bool
$c== :: LlvmMachOp -> LlvmMachOp -> Bool
Eq)

instance Outputable LlvmMachOp where
  ppr :: LlvmMachOp -> SDoc
ppr LlvmMachOp
LM_MO_Add  = String -> SDoc
text String
"add"
  ppr LlvmMachOp
LM_MO_Sub  = String -> SDoc
text String
"sub"
  ppr LlvmMachOp
LM_MO_Mul  = String -> SDoc
text String
"mul"
  ppr LlvmMachOp
LM_MO_UDiv = String -> SDoc
text String
"udiv"
  ppr LlvmMachOp
LM_MO_SDiv = String -> SDoc
text String
"sdiv"
  ppr LlvmMachOp
LM_MO_URem = String -> SDoc
text String
"urem"
  ppr LlvmMachOp
LM_MO_SRem = String -> SDoc
text String
"srem"
  ppr LlvmMachOp
LM_MO_FAdd = String -> SDoc
text String
"fadd"
  ppr LlvmMachOp
LM_MO_FSub = String -> SDoc
text String
"fsub"
  ppr LlvmMachOp
LM_MO_FMul = String -> SDoc
text String
"fmul"
  ppr LlvmMachOp
LM_MO_FDiv = String -> SDoc
text String
"fdiv"
  ppr LlvmMachOp
LM_MO_FRem = String -> SDoc
text String
"frem"
  ppr LlvmMachOp
LM_MO_Shl  = String -> SDoc
text String
"shl"
  ppr LlvmMachOp
LM_MO_LShr = String -> SDoc
text String
"lshr"
  ppr LlvmMachOp
LM_MO_AShr = String -> SDoc
text String
"ashr"
  ppr LlvmMachOp
LM_MO_And  = String -> SDoc
text String
"and"
  ppr LlvmMachOp
LM_MO_Or   = String -> SDoc
text String
"or"
  ppr LlvmMachOp
LM_MO_Xor  = String -> SDoc
text String
"xor"


-- | Llvm compare operations.
data LlvmCmpOp
  = LM_CMP_Eq  -- ^ Equal (Signed and Unsigned)
  | LM_CMP_Ne  -- ^ Not equal (Signed and Unsigned)
  | LM_CMP_Ugt -- ^ Unsigned greater than
  | LM_CMP_Uge -- ^ Unsigned greater than or equal
  | LM_CMP_Ult -- ^ Unsigned less than
  | LM_CMP_Ule -- ^ Unsigned less than or equal
  | LM_CMP_Sgt -- ^ Signed greater than
  | LM_CMP_Sge -- ^ Signed greater than or equal
  | LM_CMP_Slt -- ^ Signed less than
  | LM_CMP_Sle -- ^ Signed less than or equal

  -- Float comparisons. GHC uses a mix of ordered and unordered float
  -- comparisons.
  | LM_CMP_Feq -- ^ Float equal
  | LM_CMP_Fne -- ^ Float not equal
  | LM_CMP_Fgt -- ^ Float greater than
  | LM_CMP_Fge -- ^ Float greater than or equal
  | LM_CMP_Flt -- ^ Float less than
  | LM_CMP_Fle -- ^ Float less than or equal
  deriving (LlvmCmpOp -> LlvmCmpOp -> Bool
(LlvmCmpOp -> LlvmCmpOp -> Bool)
-> (LlvmCmpOp -> LlvmCmpOp -> Bool) -> Eq LlvmCmpOp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LlvmCmpOp -> LlvmCmpOp -> Bool
$c/= :: LlvmCmpOp -> LlvmCmpOp -> Bool
== :: LlvmCmpOp -> LlvmCmpOp -> Bool
$c== :: LlvmCmpOp -> LlvmCmpOp -> Bool
Eq)

instance Outputable LlvmCmpOp where
  ppr :: LlvmCmpOp -> SDoc
ppr LlvmCmpOp
LM_CMP_Eq  = String -> SDoc
text String
"eq"
  ppr LlvmCmpOp
LM_CMP_Ne  = String -> SDoc
text String
"ne"
  ppr LlvmCmpOp
LM_CMP_Ugt = String -> SDoc
text String
"ugt"
  ppr LlvmCmpOp
LM_CMP_Uge = String -> SDoc
text String
"uge"
  ppr LlvmCmpOp
LM_CMP_Ult = String -> SDoc
text String
"ult"
  ppr LlvmCmpOp
LM_CMP_Ule = String -> SDoc
text String
"ule"
  ppr LlvmCmpOp
LM_CMP_Sgt = String -> SDoc
text String
"sgt"
  ppr LlvmCmpOp
LM_CMP_Sge = String -> SDoc
text String
"sge"
  ppr LlvmCmpOp
LM_CMP_Slt = String -> SDoc
text String
"slt"
  ppr LlvmCmpOp
LM_CMP_Sle = String -> SDoc
text String
"sle"
  ppr LlvmCmpOp
LM_CMP_Feq = String -> SDoc
text String
"oeq"
  ppr LlvmCmpOp
LM_CMP_Fne = String -> SDoc
text String
"une"
  ppr LlvmCmpOp
LM_CMP_Fgt = String -> SDoc
text String
"ogt"
  ppr LlvmCmpOp
LM_CMP_Fge = String -> SDoc
text String
"oge"
  ppr LlvmCmpOp
LM_CMP_Flt = String -> SDoc
text String
"olt"
  ppr LlvmCmpOp
LM_CMP_Fle = String -> SDoc
text String
"ole"


-- | Llvm cast operations.
data LlvmCastOp
  = LM_Trunc    -- ^ Integer truncate
  | LM_Zext     -- ^ Integer extend (zero fill)
  | LM_Sext     -- ^ Integer extend (sign fill)
  | LM_Fptrunc  -- ^ Float truncate
  | LM_Fpext    -- ^ Float extend
  | LM_Fptoui   -- ^ Float to unsigned Integer
  | LM_Fptosi   -- ^ Float to signed Integer
  | LM_Uitofp   -- ^ Unsigned Integer to Float
  | LM_Sitofp   -- ^ Signed Int to Float
  | LM_Ptrtoint -- ^ Pointer to Integer
  | LM_Inttoptr -- ^ Integer to Pointer
  | LM_Bitcast  -- ^ Cast between types where no bit manipulation is needed
  deriving (LlvmCastOp -> LlvmCastOp -> Bool
(LlvmCastOp -> LlvmCastOp -> Bool)
-> (LlvmCastOp -> LlvmCastOp -> Bool) -> Eq LlvmCastOp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LlvmCastOp -> LlvmCastOp -> Bool
$c/= :: LlvmCastOp -> LlvmCastOp -> Bool
== :: LlvmCastOp -> LlvmCastOp -> Bool
$c== :: LlvmCastOp -> LlvmCastOp -> Bool
Eq)

instance Outputable LlvmCastOp where
  ppr :: LlvmCastOp -> SDoc
ppr LlvmCastOp
LM_Trunc    = String -> SDoc
text String
"trunc"
  ppr LlvmCastOp
LM_Zext     = String -> SDoc
text String
"zext"
  ppr LlvmCastOp
LM_Sext     = String -> SDoc
text String
"sext"
  ppr LlvmCastOp
LM_Fptrunc  = String -> SDoc
text String
"fptrunc"
  ppr LlvmCastOp
LM_Fpext    = String -> SDoc
text String
"fpext"
  ppr LlvmCastOp
LM_Fptoui   = String -> SDoc
text String
"fptoui"
  ppr LlvmCastOp
LM_Fptosi   = String -> SDoc
text String
"fptosi"
  ppr LlvmCastOp
LM_Uitofp   = String -> SDoc
text String
"uitofp"
  ppr LlvmCastOp
LM_Sitofp   = String -> SDoc
text String
"sitofp"
  ppr LlvmCastOp
LM_Ptrtoint = String -> SDoc
text String
"ptrtoint"
  ppr LlvmCastOp
LM_Inttoptr = String -> SDoc
text String
"inttoptr"
  ppr LlvmCastOp
LM_Bitcast  = String -> SDoc
text String
"bitcast"


-- -----------------------------------------------------------------------------
-- * Floating point conversion
--

-- | Convert a Haskell Double to an LLVM hex encoded floating point form. In
-- Llvm float literals can be printed in a big-endian hexadecimal format,
-- regardless of underlying architecture.
--
-- See Note [LLVM Float Types].
ppDouble :: Double -> SDoc
ppDouble :: Double -> SDoc
ppDouble Double
d
  = let bs :: [Int]
bs     = Double -> [Int]
doubleToBytes Double
d
        hex :: a -> String
hex a
d' = case a -> String -> String
forall a. (Integral a, Show a) => a -> String -> String
showHex a
d' String
"" of
                     []    -> String -> String
forall a. HasCallStack => String -> a
error String
"dToStr: too few hex digits for float"
                     [Char
x]   -> [Char
'0',Char
x]
                     [Char
x,Char
y] -> [Char
x,Char
y]
                     String
_     -> String -> String
forall a. HasCallStack => String -> a
error String
"dToStr: too many hex digits for float"

    in (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags (\DynFlags
dflags ->
         let fixEndian :: [a] -> [a]
fixEndian = if DynFlags -> Bool
wORDS_BIGENDIAN DynFlags
dflags then [a] -> [a]
forall a. a -> a
id else [a] -> [a]
forall a. [a] -> [a]
reverse
             str :: String
str       = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. [a] -> [a]
fixEndian ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
forall a. (Integral a, Show a) => a -> String
hex [Int]
bs
         in String -> SDoc
text String
"0x" SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
str)

-- Note [LLVM Float Types]
-- ~~~~~~~~~~~~~~~~~~~~~~~
-- We use 'ppDouble' for both printing Float and Double floating point types. This is
-- as LLVM expects all floating point constants (single & double) to be in IEEE
-- 754 Double precision format. However, for single precision numbers (Float)
-- they should be *representable* in IEEE 754 Single precision format. So the
-- easiest way to do this is to narrow and widen again.
-- (i.e., Double -> Float -> Double). We must be careful doing this that GHC
-- doesn't optimize that away.

-- Note [narrowFp & widenFp]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~
-- NOTE: we use float2Double & co directly as GHC likes to optimize away
-- successive calls of 'realToFrac', defeating the narrowing. (Bug #7600).
-- 'realToFrac' has inconsistent behaviour with optimisation as well that can
-- also cause issues, these methods don't.

narrowFp :: Double -> Float
{-# NOINLINE narrowFp #-}
narrowFp :: Double -> Float
narrowFp = Double -> Float
double2Float

widenFp :: Float -> Double
{-# NOINLINE widenFp #-}
widenFp :: Float -> Double
widenFp = Float -> Double
float2Double

ppFloat :: Float -> SDoc
ppFloat :: Float -> SDoc
ppFloat = Double -> SDoc
ppDouble (Double -> SDoc) -> (Float -> Double) -> Float -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Double
widenFp


--------------------------------------------------------------------------------
-- * Misc functions
--------------------------------------------------------------------------------

ppCommaJoin :: (Outputable a) => [a] -> SDoc
ppCommaJoin :: [a] -> SDoc
ppCommaJoin [a]
strs = [SDoc] -> SDoc
hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma ((a -> SDoc) -> [a] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map a -> SDoc
forall a. Outputable a => a -> SDoc
ppr [a]
strs)

ppSpaceJoin :: (Outputable a) => [a] -> SDoc
ppSpaceJoin :: [a] -> SDoc
ppSpaceJoin [a]
strs = [SDoc] -> SDoc
hsep ((a -> SDoc) -> [a] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map a -> SDoc
forall a. Outputable a => a -> SDoc
ppr [a]
strs)