Commit 2517a51c authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot

DynFlags refactoring VIII (#17957)

* Remove several uses of `sdocWithDynFlags`, especially in GHC.Llvm.*

* Add LlvmOpts datatype to store Llvm backend options

* Remove Outputable instances (for LlvmVar, LlvmLit, LlvmStatic and
  Llvm.MetaExpr) which require LlvmOpts.

* Rename ppMetaExpr into ppMetaAnnotExpr (pprMetaExpr is now used in place of `ppr :: MetaExpr -> SDoc`)
parent 3445b965
......@@ -1169,11 +1169,11 @@ instance Outputable CLabel where
pprCLabel :: DynFlags -> CLabel -> SDoc
pprCLabel dflags = \case
(LocalBlockLabel u) -> tempLabelPrefixOrUnderscore <> pprUniqueAlways u
(LocalBlockLabel u) -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u
(AsmTempLabel u)
| not (platformUnregisterised platform)
-> tempLabelPrefixOrUnderscore <> pprUniqueAlways u
-> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u
(AsmTempDerivedLabel l suf)
| useNCG
......@@ -1231,8 +1231,8 @@ pprCLabel dflags = \case
pprCLbl :: DynFlags -> CLabel -> SDoc
pprCLbl dflags = \case
(StringLitLabel u) -> pprUniqueAlways u <> text "_str"
(SRTLabel u) -> tempLabelPrefixOrUnderscore <> pprUniqueAlways u <> pp_cSEP <> text "srt"
(LargeBitmapLabel u) -> tempLabelPrefixOrUnderscore
(SRTLabel u) -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u <> pp_cSEP <> text "srt"
(LargeBitmapLabel u) -> tempLabelPrefixOrUnderscore platform
<> char 'b' <> pprUniqueAlways u <> pp_cSEP <> text "btm"
-- Some bitmaps for tuple constructors have a numeric tag (e.g. '7')
-- until that gets resolved we'll just force them to start
......@@ -1242,7 +1242,7 @@ pprCLbl dflags = \case
(CmmLabel _ str CmmData) -> ftext str
(CmmLabel _ str CmmPrimCall) -> ftext str
(LocalBlockLabel u) -> tempLabelPrefixOrUnderscore <> text "blk_" <> pprUniqueAlways u
(LocalBlockLabel u) -> tempLabelPrefixOrUnderscore platform <> text "blk_" <> pprUniqueAlways u
(RtsLabel (RtsApFast str)) -> ftext str <> text "_fast"
......@@ -1290,7 +1290,7 @@ pprCLbl dflags = \case
(ForeignLabel str _ _ _) -> ftext str
(IdLabel name _cafs flavor) -> internalNamePrefix name <> ppr name <> ppIdFlavor flavor
(IdLabel name _cafs flavor) -> internalNamePrefix platform name <> ppr name <> ppIdFlavor flavor
(CC_Label cc) -> ppr cc
(CCS_Label ccs) -> ppr ccs
......@@ -1301,6 +1301,8 @@ pprCLbl dflags = \case
(DynamicLinkerLabel {}) -> panic "pprCLbl DynamicLinkerLabel"
(PicBaseLabel {}) -> panic "pprCLbl PicBaseLabel"
(DeadStripPreventer {}) -> panic "pprCLbl DeadStripPreventer"
where
platform = targetPlatform dflags
ppIdFlavor :: IdLabelInfo -> SDoc
ppIdFlavor x = pp_cSEP <> text
......@@ -1331,21 +1333,20 @@ instance Outputable ForeignLabelSource where
ForeignLabelInThisPackage -> parens $ text "this package"
ForeignLabelInExternalPackage -> parens $ text "external package"
internalNamePrefix :: Name -> SDoc
internalNamePrefix name = getPprStyle $ \ sty ->
internalNamePrefix :: Platform -> Name -> SDoc
internalNamePrefix platform name = getPprStyle $ \ sty ->
if asmStyle sty && isRandomGenerated then
sdocWithDynFlags $ \dflags ->
ptext (asmTempLabelPrefix (targetPlatform dflags))
ptext (asmTempLabelPrefix platform)
else
empty
where
isRandomGenerated = not $ isExternalName name
tempLabelPrefixOrUnderscore :: SDoc
tempLabelPrefixOrUnderscore = sdocWithDynFlags $ \dflags ->
tempLabelPrefixOrUnderscore :: Platform -> SDoc
tempLabelPrefixOrUnderscore platform =
getPprStyle $ \ sty ->
if asmStyle sty then
ptext (asmTempLabelPrefix (targetPlatform dflags))
ptext (asmTempLabelPrefix platform)
else
char '_'
......
......@@ -92,7 +92,8 @@ llvmCodeGen' dflags cmm_stream
a <- Stream.consume cmm_stream llvmGroupLlvmGens
-- Declare aliases for forward references
renderLlvm . pprLlvmData =<< generateExternDecls
opts <- getLlvmOpts
renderLlvm . pprLlvmData opts =<< generateExternDecls
-- Postamble
cmmUsedLlvmGens
......@@ -150,14 +151,15 @@ cmmDataLlvmGens statics
mapM_ regGlobal gs
gss' <- mapM aliasify $ gs
renderLlvm $ pprLlvmData (concat gss', concat tss)
opts <- getLlvmOpts
renderLlvm $ pprLlvmData opts (concat gss', concat tss)
-- | Complete LLVM code generation phase for a single top-level chunk of Cmm.
cmmLlvmGen ::RawCmmDecl -> LlvmM ()
cmmLlvmGen cmm@CmmProc{} = do
-- rewrite assignments to global regs
dflags <- getDynFlag id
dflags <- getDynFlags
let fixed_cmm = {-# SCC "llvm_fix_regs" #-} fixStgRegisters dflags cmm
dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm"
......@@ -194,7 +196,8 @@ cmmMetaLlvmPrelude = do
-- just a name on its own. Previously `null` was accepted as the
-- name.
Nothing -> [ MetaStr name ]
renderLlvm $ ppLlvmMetas metas
opts <- getLlvmOpts
renderLlvm $ ppLlvmMetas opts metas
-- -----------------------------------------------------------------------------
-- | Marks variables as used where necessary
......@@ -217,6 +220,7 @@ cmmUsedLlvmGens = do
sectName = Just $ fsLit "llvm.metadata"
lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending sectName Nothing Constant
lmUsed = LMGlobal lmUsedVar (Just usedArray)
opts <- getLlvmOpts
if null ivars
then return ()
else renderLlvm $ pprLlvmData ([lmUsed], [])
else renderLlvm $ pprLlvmData opts ([lmUsed], [])
......@@ -21,9 +21,9 @@ module GHC.CmmToLlvm.Base (
LlvmM,
runLlvm, liftStream, withClearVars, varLookup, varInsert,
markStackReg, checkStackReg,
funLookup, funInsert, getLlvmVer, getDynFlags, getDynFlag, getLlvmPlatform,
funLookup, funInsert, getLlvmVer, getDynFlags,
dumpIfSetLlvm, renderLlvm, markUsedVar, getUsedVars,
ghcInternalFunctions, getPlatform,
ghcInternalFunctions, getPlatform, getLlvmOpts,
getMetaUniqueId,
setUniqMeta, getUniqMeta,
......@@ -114,10 +114,10 @@ widthToLlvmInt :: Width -> LlvmType
widthToLlvmInt w = LMInt $ widthInBits w
-- | GHC Call Convention for LLVM
llvmGhcCC :: DynFlags -> LlvmCallConvention
llvmGhcCC dflags
| platformUnregisterised (targetPlatform dflags) = CC_Ccc
| otherwise = CC_Ghc
llvmGhcCC :: Platform -> LlvmCallConvention
llvmGhcCC platform
| platformUnregisterised platform = CC_Ccc
| otherwise = CC_Ghc
-- | Llvm Function type for Cmm function
llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType
......@@ -133,9 +133,8 @@ llvmFunSig' :: LiveGlobalRegs -> LMString -> LlvmLinkageType -> LlvmM LlvmFuncti
llvmFunSig' live lbl link
= do let toParams x | isPointer x = (x, [NoAlias, NoCapture])
| otherwise = (x, [])
dflags <- getDynFlags
platform <- getPlatform
return $ LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs
return $ LlvmFunctionDecl lbl link (llvmGhcCC platform) LMVoid FixedArgs
(map (toParams . getVarType) (llvmFunArgs platform live))
(llvmFunAlign platform)
......@@ -148,10 +147,10 @@ llvmInfAlign :: Platform -> LMAlign
llvmInfAlign platform = Just (platformWordSizeInBytes platform)
-- | Section to use for a function
llvmFunSection :: DynFlags -> LMString -> LMSection
llvmFunSection dflags lbl
| gopt Opt_SplitSections dflags = Just (concatFS [fsLit ".text.", lbl])
| otherwise = Nothing
llvmFunSection :: LlvmOpts -> LMString -> LMSection
llvmFunSection opts lbl
| llvmOptsSplitSections opts = Just (concatFS [fsLit ".text.", lbl])
| otherwise = Nothing
-- | A Function's arguments
llvmFunArgs :: Platform -> LiveGlobalRegs -> [LlvmVar]
......@@ -311,6 +310,7 @@ llvmVersionList = NE.toList . llvmVersionNE
data LlvmEnv = LlvmEnv
{ envVersion :: LlvmVersion -- ^ LLVM version
, envOpts :: LlvmOpts -- ^ LLVM backend options
, envDynFlags :: DynFlags -- ^ Dynamic flags
, envOutput :: BufHandle -- ^ Output buffer
, envMask :: !Char -- ^ Mask for creating unique values
......@@ -342,8 +342,13 @@ instance Monad LlvmM where
instance HasDynFlags LlvmM where
getDynFlags = LlvmM $ \env -> return (envDynFlags env, env)
-- | Get target platform
getPlatform :: LlvmM Platform
getPlatform = targetPlatform <$> getDynFlags
getPlatform = llvmOptsPlatform <$> getLlvmOpts
-- | Get LLVM options
getLlvmOpts :: LlvmM LlvmOpts
getLlvmOpts = LlvmM $ \env -> return (envOpts env, env)
instance MonadUnique LlvmM where
getUniqueSupplyM = do
......@@ -370,6 +375,7 @@ runLlvm dflags ver out m = do
, envUsedVars = []
, envAliases = emptyUniqSet
, envVersion = ver
, envOpts = initLlvmOpts dflags
, envDynFlags = dflags
, envOutput = out
, envMask = 'n'
......@@ -426,14 +432,6 @@ getMetaUniqueId = LlvmM $ \env ->
getLlvmVer :: LlvmM LlvmVersion
getLlvmVer = getEnv envVersion
-- | Get the platform we are generating code for
getDynFlag :: (DynFlags -> a) -> LlvmM a
getDynFlag f = getEnv (f . envDynFlags)
-- | Get the platform we are generating code for
getLlvmPlatform :: LlvmM Platform
getLlvmPlatform = getDynFlag targetPlatform
-- | Dumps the document if the corresponding flag has been set by the user
dumpIfSetLlvm :: DumpFlag -> String -> DumpFormat -> Outp.SDoc -> LlvmM ()
dumpIfSetLlvm flag hdr fmt doc = do
......
......@@ -178,7 +178,7 @@ barrier = do
-- exceptions (where no code will be emitted instead).
barrierUnless :: [Arch] -> LlvmM StmtData
barrierUnless exs = do
platform <- getLlvmPlatform
platform <- getPlatform
if platformArch platform `elem` exs
then return (nilOL, [])
else barrier
......@@ -415,7 +415,7 @@ genCall target res args = do
++ " 0 or 1, given " ++ show (length t) ++ "."
-- extract Cmm call convention, and translate to LLVM call convention
platform <- lift $ getLlvmPlatform
platform <- lift $ getPlatform
let lmconv = case target of
ForeignTarget _ (ForeignConvention conv _ _ _) ->
case conv of
......@@ -993,6 +993,7 @@ genStore_slow addr val meta = do
let stmts = stmts1 `appOL` stmts2
dflags <- getDynFlags
platform <- getPlatform
opts <- getLlvmOpts
case getVarType vaddr of
-- sometimes we need to cast an int to a pointer before storing
LMPointer ty@(LMPointer _) | getVarType vval == llvmWord platform -> do
......@@ -1015,7 +1016,7 @@ genStore_slow addr val meta = do
(PprCmm.pprExpr platform addr <+> text (
"Size of Ptr: " ++ show (llvmPtrBits platform) ++
", Size of var: " ++ show (llvmWidthInBits platform other) ++
", Var: " ++ showSDoc dflags (ppr vaddr)))
", Var: " ++ showSDoc dflags (ppVar opts vaddr)))
-- | Unconditional branch
......@@ -1041,7 +1042,8 @@ genCondBranch cond idT idF likely = do
return (stmts1 `appOL` stmts2 `snocOL` s1, top1 ++ top2)
else do
dflags <- getDynFlags
panic $ "genCondBranch: Cond expr not bool! (" ++ showSDoc dflags (ppr vc) ++ ")"
opts <- getLlvmOpts
panic $ "genCondBranch: Cond expr not bool! (" ++ showSDoc dflags (ppVar opts vc) ++ ")"
-- | Generate call to llvm.expect.x intrinsic. Assigning result to a new var.
......@@ -1663,6 +1665,7 @@ genLoad_slow :: Atomic -> CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData
genLoad_slow atomic e ty meta = do
platform <- getPlatform
dflags <- getDynFlags
opts <- getLlvmOpts
runExprData $ do
iptr <- exprToVarW e
case getVarType iptr of
......@@ -1678,7 +1681,7 @@ genLoad_slow atomic e ty meta = do
(PprCmm.pprExpr platform e <+> text (
"Size of Ptr: " ++ show (llvmPtrBits platform) ++
", Size of var: " ++ show (llvmWidthInBits platform other) ++
", Var: " ++ showSDoc dflags (ppr iptr)))
", Var: " ++ showSDoc dflags (ppVar opts iptr)))
where
loadInstr ptr | atomic = ALoad SyncSeqCst False ptr
| otherwise = Load ptr
......@@ -1873,7 +1876,7 @@ funEpilogue live = do
loadUndef r = do
let ty = (pLower . getVarType $ lmGlobalRegVar platform r)
return (Just $ LMLitVar $ LMUndefLit ty, nilOL)
platform <- getDynFlag targetPlatform
platform <- getPlatform
let allRegs = activeStgRegs platform
loads <- flip mapM allRegs $ \r -> case () of
_ | (False, r) `elem` livePadded
......
......@@ -17,7 +17,6 @@ import GHC.CmmToLlvm.Base
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
import GHC.Cmm
import GHC.Driver.Session
import GHC.Platform
import GHC.Data.FastString
......@@ -71,7 +70,7 @@ genLlvmData (sec, CmmStaticsRaw lbl xs) = do
label <- strCLabel_llvm lbl
static <- mapM genData xs
lmsec <- llvmSection sec
platform <- getLlvmPlatform
platform <- getPlatform
let types = map getStatType static
strucTy = LMStruct types
......@@ -113,9 +112,9 @@ llvmSectionType p t = case t of
-- | Format a Cmm Section into a LLVM section name
llvmSection :: Section -> LlvmM LMSection
llvmSection (Section t suffix) = do
dflags <- getDynFlags
let splitSect = gopt Opt_SplitSections dflags
platform = targetPlatform dflags
opts <- getLlvmOpts
let splitSect = llvmOptsSplitSections opts
platform = llvmOptsPlatform opts
if not splitSect
then return Nothing
else do
......
......@@ -27,21 +27,22 @@ import GHC.Types.Unique
--
-- | Pretty print LLVM data code
pprLlvmData :: LlvmData -> SDoc
pprLlvmData (globals, types) =
pprLlvmData :: LlvmOpts -> LlvmData -> SDoc
pprLlvmData opts (globals, types) =
let ppLlvmTys (LMAlias a) = ppLlvmAlias a
ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f
ppLlvmTys _other = empty
types' = vcat $ map ppLlvmTys types
globals' = ppLlvmGlobals globals
globals' = ppLlvmGlobals opts globals
in types' $+$ globals'
-- | Pretty print LLVM code
pprLlvmCmmDecl :: LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar])
pprLlvmCmmDecl (CmmData _ lmdata)
= return (vcat $ map pprLlvmData lmdata, [])
pprLlvmCmmDecl (CmmData _ lmdata) = do
opts <- getLlvmOpts
return (vcat $ map (pprLlvmData opts) lmdata, [])
pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))
= do let lbl = case mb_info of
......@@ -55,10 +56,11 @@ pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))
funDec <- llvmFunSig live lbl link
dflags <- getDynFlags
opts <- getLlvmOpts
platform <- getPlatform
let buildArg = fsLit . showSDoc dflags . ppPlainName
let buildArg = fsLit . showSDoc dflags . ppPlainName opts
funArgs = map buildArg (llvmFunArgs platform live)
funSect = llvmFunSection dflags (decName funDec)
funSect = llvmFunSection opts (decName funDec)
-- generate the info table
prefix <- case mb_info of
......@@ -92,7 +94,7 @@ pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))
(Just $ LMBitc (LMStaticPointer defVar)
i8Ptr)
return (ppLlvmGlobal alias $+$ ppLlvmFunction platform fun', [])
return (ppLlvmGlobal opts alias $+$ ppLlvmFunction opts fun', [])
-- | The section we are putting info tables and their entry code into, should
......
......@@ -10,6 +10,8 @@
--
module GHC.Llvm (
LlvmOpts (..),
initLlvmOpts,
-- * Modules, Functions and Blocks
LlvmModule(..),
......@@ -50,7 +52,7 @@ module GHC.Llvm (
pLift, pLower, isInt, isFloat, isPointer, isVector, llvmWidthInBits,
-- * Pretty Printing
ppLit, ppName, ppPlainName,
ppVar, ppLit, ppTypeLit, ppName, ppPlainName,
ppLlvmModule, ppLlvmComments, ppLlvmComment, ppLlvmGlobals,
ppLlvmGlobal, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions,
ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, ppLlvmMetas, ppLlvmMeta,
......
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
module GHC.Llvm.MetaData where
......@@ -73,13 +74,6 @@ data MetaExpr = MetaStr !LMString
| MetaStruct [MetaExpr]
deriving (Eq)
instance Outputable MetaExpr where
ppr (MetaVar (LMLitVar (LMNullLit _))) = text "null"
ppr (MetaStr s ) = char '!' <> doubleQuotes (ftext s)
ppr (MetaNode n ) = ppr n
ppr (MetaVar v ) = ppr v
ppr (MetaStruct es) = char '!' <> braces (ppCommaJoin es)
-- | Associates some metadata with a specific label for attaching to an
-- instruction.
data MetaAnnot = MetaAnnot LMString MetaExpr
......
This diff is collapsed.
......@@ -12,7 +12,6 @@ module GHC.Llvm.Types where
import GHC.Prelude
import Data.Char
import Data.Int
import Numeric
import GHC.Platform
......@@ -64,24 +63,26 @@ data LlvmType
deriving (Eq)
instance Outputable LlvmType where
ppr (LMInt size ) = char 'i' <> ppr size
ppr (LMFloat ) = text "float"
ppr (LMDouble ) = text "double"
ppr (LMFloat80 ) = text "x86_fp80"
ppr (LMFloat128 ) = text "fp128"
ppr (LMPointer x ) = ppr x <> char '*'
ppr (LMArray nr tp ) = char '[' <> ppr nr <> text " x " <> ppr tp <> char ']'
ppr (LMVector nr tp ) = char '<' <> ppr nr <> text " x " <> ppr tp <> char '>'
ppr (LMLabel ) = text "label"
ppr (LMVoid ) = text "void"
ppr (LMStruct tys ) = text "<{" <> ppCommaJoin tys <> text "}>"
ppr (LMStructU tys ) = text "{" <> ppCommaJoin tys <> text "}"
ppr (LMMetadata ) = text "metadata"
ppr (LMFunction (LlvmFunctionDecl _ _ _ r varg p _))
= ppr r <+> lparen <> ppParams varg p <> rparen
ppr (LMAlias (s,_)) = char '%' <> ftext s
ppr = ppType
ppType :: LlvmType -> SDoc
ppType t = case t of
LMInt size -> char 'i' <> ppr size
LMFloat -> text "float"
LMDouble -> text "double"
LMFloat80 -> text "x86_fp80"
LMFloat128 -> text "fp128"
LMPointer x -> ppr x <> char '*'
LMArray nr tp -> char '[' <> ppr nr <> text " x " <> ppr tp <> char ']'
LMVector nr tp -> char '<' <> ppr nr <> text " x " <> ppr tp <> char '>'
LMLabel -> text "label"
LMVoid -> text "void"
LMStruct tys -> text "<{" <> ppCommaJoin tys <> text "}>"
LMStructU tys -> text "{" <> ppCommaJoin tys <> text "}"
LMMetadata -> text "metadata"
LMAlias (s,_) -> char '%' <> ftext s
LMFunction (LlvmFunctionDecl _ _ _ r varg p _)
-> ppr r <+> lparen <> ppParams varg p <> rparen
ppParams :: LlvmParameterListType -> [LlvmParameter] -> SDoc
ppParams varg p
......@@ -115,11 +116,6 @@ data LlvmVar
| LMLitVar LlvmLit
deriving (Eq)
instance Outputable LlvmVar where
ppr (LMLitVar x) = ppr x
ppr (x ) = ppr (getVarType x) <+> ppName x
-- | Llvm Literal Data.
--
-- These can be used inline in expressions.
......@@ -136,11 +132,6 @@ data LlvmLit
| LMUndefLit LlvmType
deriving (Eq)
instance Outputable LlvmLit where
ppr l@(LMVectorLit {}) = ppLit l
ppr l = ppr (getLitType l) <+> ppLit l
-- | Llvm Static Data.
--
-- These represent the possible global level variables and constants.
......@@ -162,89 +153,24 @@ data LlvmStatic
| LMAdd LlvmStatic LlvmStatic -- ^ Constant addition operation
| LMSub LlvmStatic LlvmStatic -- ^ Constant subtraction operation
instance Outputable LlvmStatic where
ppr (LMComment s) = text "; " <> ftext s
ppr (LMStaticLit l ) = ppr l
ppr (LMUninitType t) = ppr t <> text " undef"
ppr (LMStaticStr s t) = ppr t <> text " c\"" <> ftext s <> text "\\00\""
ppr (LMStaticArray d t) = ppr t <> text " [" <> ppCommaJoin d <> char ']'
ppr (LMStaticStruc d t) = ppr t <> text "<{" <> ppCommaJoin d <> text "}>"
ppr (LMStaticPointer v) = ppr v
ppr (LMTrunc v t)
= ppr t <> text " trunc (" <> ppr v <> text " to " <> ppr t <> char ')'
ppr (LMBitc v t)
= ppr t <> text " bitcast (" <> ppr v <> text " to " <> ppr t <> char ')'
ppr (LMPtoI v t)
= ppr t <> text " ptrtoint (" <> ppr v <> text " to " <> ppr t <> char ')'
ppr (LMAdd s1 s2)
= pprStaticArith s1 s2 (sLit "add") (sLit "fadd") "LMAdd"
ppr (LMSub s1 s2)
= pprStaticArith s1 s2 (sLit "sub") (sLit "fsub") "LMSub"
pprSpecialStatic :: LlvmStatic -> SDoc
pprSpecialStatic (LMBitc v t) =
ppr (pLower t) <> text ", bitcast (" <> ppr v <> text " to " <> ppr t
<> char ')'
pprSpecialStatic v@(LMStaticPointer x) = ppr (pLower $ getVarType x) <> comma <+> ppr v
pprSpecialStatic stat = ppr stat
pprStaticArith :: LlvmStatic -> LlvmStatic -> PtrString -> PtrString
-> String -> SDoc
pprStaticArith s1 s2 int_op float_op op_name =
let ty1 = getStatType s1
op = if isFloat ty1 then float_op else int_op
in if ty1 == getStatType s2
then ppr ty1 <+> ptext op <+> lparen <> ppr s1 <> comma <> ppr s2 <> rparen
else pprPanic "pprStaticArith" $
text op_name <> text " with different types! s1: " <> ppr s1
<> text", s2: " <> ppr 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 v@(LMGlobalVar {}) = char '@' <> ppPlainName v
ppName v@(LMLocalVar {}) = char '%' <> ppPlainName v
ppName v@(LMNLocalVar {}) = char '%' <> ppPlainName v
ppName v@(LMLitVar {}) = ppPlainName 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 (LMGlobalVar x _ _ _ _ _) = ftext x
ppPlainName (LMLocalVar x LMLabel ) = text (show x)
ppPlainName (LMLocalVar x _ ) = text ('l' : show x)
ppPlainName (LMNLocalVar x _ ) = ftext x
ppPlainName (LMLitVar x ) = ppLit x
-- | Print a literal value. No type.
ppLit :: LlvmLit -> SDoc
ppLit l = sdocWithDynFlags $ \dflags -> case l of
(LMIntLit i (LMInt 32)) -> ppr (fromInteger i :: Int32)
(LMIntLit i (LMInt 64)) -> ppr (fromInteger i :: Int64)
(LMIntLit i _ ) -> ppr ((fromInteger i)::Int)
(LMFloatLit r LMFloat ) -> ppFloat (targetPlatform dflags) $ narrowFp r
(LMFloatLit r LMDouble) -> ppDouble (targetPlatform dflags) r
f@(LMFloatLit _ _) -> pprPanic "ppLit" (text "Can't print this float literal: " <> ppr f)
(LMVectorLit ls ) -> char '<' <+> ppCommaJoin ls <+> char '>'
(LMNullLit _ ) -> text "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.
(LMUndefLit t )
| gopt Opt_LlvmFillUndefWithGarbage dflags
, Just lit <- garbageLit t -> ppLit lit
| otherwise -> text "undef"
-- | LLVM code generator options
data LlvmOpts = LlvmOpts
{ llvmOptsPlatform :: !Platform -- ^ Target platform
, llvmOptsFillUndefWithGarbage :: !Bool -- ^ Fill undefined literals with garbage values
, llvmOptsSplitSections :: !Bool -- ^ Split sections
}
-- | Get LlvmOptions from DynFlags
initLlvmOpts :: DynFlags -> LlvmOpts
initLlvmOpts dflags = LlvmOpts
{ llvmOptsPlatform = targetPlatform dflags
, llvmOptsFillUndefWithGarbage = gopt Opt_LlvmFillUndefWithGarbage dflags
, llvmOptsSplitSections = gopt Opt_SplitSections dflags
}
garbageLit :: LlvmType -> Maybe LlvmLit
garbageLit t@(LMInt w) = Just (LMIntLit (0xbbbbbbbbbbbbbbb0 `mod` (2^w)) t)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment