summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorAlex Mason <Axman6@gmail.com>2023-01-13 22:38:13 +1100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2023-03-21 18:11:04 -0400
commite8b4aac437b2620d93546a57eb5818f317a4549e (patch)
treea7987467436407b25e5fd169b86390e664a4b7cf /compiler
parentbe1d4be8d09072091b77cb68ccf234434754af00 (diff)
downloadhaskell-e8b4aac437b2620d93546a57eb5818f317a4549e.tar.gz
Allow LLVM backend to use HDoc for faster file generation.
Also remove the MetaStmt constructor from LlvmStatement and places the annotations into the Store statement. Includes “Implement a workaround for -no-asm-shortcutting bug“ (https://gitlab.haskell.org/ghc/ghc/-/commit/2fda9e0df886cc551e2cd6b9c2a384192bdc3045)
Diffstat (limited to 'compiler')
-rw-r--r--compiler/GHC/CmmToLlvm.hs48
-rw-r--r--compiler/GHC/CmmToLlvm/Base.hs8
-rw-r--r--compiler/GHC/CmmToLlvm/CodeGen.hs60
-rw-r--r--compiler/GHC/CmmToLlvm/Ppr.hs19
-rw-r--r--compiler/GHC/Llvm/MetaData.hs7
-rw-r--r--compiler/GHC/Llvm/Ppr.hs457
-rw-r--r--compiler/GHC/Llvm/Syntax.hs7
-rw-r--r--compiler/GHC/Llvm/Types.hs266
8 files changed, 524 insertions, 348 deletions
diff --git a/compiler/GHC/CmmToLlvm.hs b/compiler/GHC/CmmToLlvm.hs
index ea5884405e..cce31e630e 100644
--- a/compiler/GHC/CmmToLlvm.hs
+++ b/compiler/GHC/CmmToLlvm.hs
@@ -91,7 +91,7 @@ llvmCodeGen logger cfg h cmm_stream
llvmCodeGen' :: LlvmCgConfig -> Stream.Stream IO RawCmmGroup a -> LlvmM a
llvmCodeGen' cfg cmm_stream
= do -- Preamble
- renderLlvm header
+ renderLlvm (llvmHeader cfg) (llvmHeader cfg)
ghcInternalFunctions
cmmMetaLlvmPrelude
@@ -99,20 +99,23 @@ llvmCodeGen' cfg cmm_stream
a <- Stream.consume cmm_stream liftIO llvmGroupLlvmGens
-- Declare aliases for forward references
- renderLlvm . pprLlvmData cfg =<< generateExternDecls
+ decls <- generateExternDecls
+ renderLlvm (pprLlvmData cfg decls)
+ (pprLlvmData cfg decls)
-- Postamble
cmmUsedLlvmGens
return a
- where
- header :: SDoc
- header =
- let target = llvmCgLlvmTarget cfg
- llvmCfg = llvmCgLlvmConfig cfg
- in (text "target datalayout = \"" <> text (getDataLayout llvmCfg target) <> text "\"")
- $+$ (text "target triple = \"" <> text target <> text "\"")
+llvmHeader :: IsDoc doc => LlvmCgConfig -> doc
+llvmHeader cfg =
+ let target = llvmCgLlvmTarget cfg
+ llvmCfg = llvmCgLlvmConfig cfg
+ in lines_
+ [ text "target datalayout = \"" <> text (getDataLayout llvmCfg target) <> text "\""
+ , text "target triple = \"" <> text target <> text "\"" ]
+ where
getDataLayout :: LlvmConfig -> String -> String
getDataLayout config target =
case lookup target (llvmTargets config) of
@@ -121,6 +124,8 @@ llvmCodeGen' cfg cmm_stream
text "Target:" <+> text target $$
hang (text "Available targets:") 4
(vcat $ map (text . fst) $ llvmTargets config)
+{-# SPECIALIZE llvmHeader :: LlvmCgConfig -> SDoc #-}
+{-# SPECIALIZE llvmHeader :: LlvmCgConfig -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
llvmGroupLlvmGens :: RawCmmGroup -> LlvmM ()
llvmGroupLlvmGens cmm = do
@@ -156,10 +161,11 @@ cmmDataLlvmGens statics
= funInsert l ty
regGlobal _ = pure ()
mapM_ regGlobal gs
- gss' <- mapM aliasify $ gs
+ gss' <- mapM aliasify gs
cfg <- getConfig
- renderLlvm $ pprLlvmData cfg (concat gss', concat tss)
+ renderLlvm (pprLlvmData cfg (concat gss', concat tss))
+ (pprLlvmData cfg (concat gss', concat tss))
-- | Complete LLVM code generation phase for a single top-level chunk of Cmm.
cmmLlvmGen ::RawCmmDecl -> LlvmM ()
@@ -175,12 +181,12 @@ cmmLlvmGen cmm@CmmProc{} = do
-- generate llvm code from cmm
llvmBC <- withClearVars $ genLlvmProc fixed_cmm
- -- pretty print
- (docs, ivars) <- fmap unzip $ mapM pprLlvmCmmDecl llvmBC
-
- -- Output, note down used variables
- renderLlvm (vcat docs)
- mapM_ markUsedVar $ concat ivars
+ -- pretty print - print as we go, since we produce HDocs, we know
+ -- no nesting state needs to be maintained for the SDocs.
+ forM_ llvmBC (\decl -> do
+ (hdoc, sdoc) <- pprLlvmCmmDecl decl
+ renderLlvm (hdoc $$ empty) (sdoc $$ empty)
+ )
cmmLlvmGen _ = return ()
@@ -204,7 +210,8 @@ cmmMetaLlvmPrelude = do
-- name.
Nothing -> [ MetaStr name ]
cfg <- getConfig
- renderLlvm $ ppLlvmMetas cfg metas
+ renderLlvm (ppLlvmMetas cfg metas)
+ (ppLlvmMetas cfg metas)
-- -----------------------------------------------------------------------------
-- | Marks variables as used where necessary
@@ -229,4 +236,7 @@ cmmUsedLlvmGens = do
lmUsed = LMGlobal lmUsedVar (Just usedArray)
if null ivars
then return ()
- else getConfig >>= renderLlvm . flip pprLlvmData ([lmUsed], [])
+ else do
+ cfg <- getConfig
+ renderLlvm (pprLlvmData cfg ([lmUsed], []))
+ (pprLlvmData cfg ([lmUsed], []))
diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs
index d625ae341e..0c9605cd3b 100644
--- a/compiler/GHC/CmmToLlvm/Base.hs
+++ b/compiler/GHC/CmmToLlvm/Base.hs
@@ -371,13 +371,13 @@ dumpIfSetLlvm flag hdr fmt doc = do
liftIO $ putDumpFileMaybe logger flag hdr fmt doc
-- | Prints the given contents to the output handle
-renderLlvm :: Outp.SDoc -> LlvmM ()
-renderLlvm sdoc = do
+renderLlvm :: Outp.HDoc -> Outp.SDoc -> LlvmM ()
+renderLlvm hdoc sdoc = do
-- Write to output
ctx <- llvmCgContext <$> getConfig
out <- getEnv envOutput
- liftIO $ Outp.bufLeftRenderSDoc ctx out sdoc
+ liftIO $ Outp.bPutHDoc out ctx hdoc
-- Dump, if requested
dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" FormatLLVM sdoc
@@ -428,7 +428,7 @@ ghcInternalFunctions = do
let n' = fsLit n
decl = LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret
FixedArgs (tysToParams args) Nothing
- renderLlvm $ ppLlvmFunctionDecl decl
+ renderLlvm (ppLlvmFunctionDecl decl) (ppLlvmFunctionDecl decl)
funInsert n' (LMFunction decl)
-- ----------------------------------------------------------------------------
diff --git a/compiler/GHC/CmmToLlvm/CodeGen.hs b/compiler/GHC/CmmToLlvm/CodeGen.hs
index 60eb1624b2..1d658b359e 100644
--- a/compiler/GHC/CmmToLlvm/CodeGen.hs
+++ b/compiler/GHC/CmmToLlvm/CodeGen.hs
@@ -207,7 +207,7 @@ genCall (PrimTarget (MO_UF_Conv w)) [dst] [e] = runStmtsDecls $ do
castV <- lift $ mkLocalVar ty
ve <- exprToVarW e
statement $ Assignment castV $ Cast LM_Uitofp ve width
- statement $ Store castV dstV Nothing
+ statement $ Store castV dstV Nothing []
genCall (PrimTarget (MO_UF_Conv _)) [_] args =
panic $ "genCall: Too many arguments to MO_UF_Conv. " ++
@@ -263,12 +263,12 @@ genCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = runStmtsDecls $
AMO_Or -> LAO_Or
AMO_Xor -> LAO_Xor
retVar <- doExprW targetTy $ AtomicRMW op ptrVar nVar SyncSeqCst
- statement $ Store retVar dstVar Nothing
+ statement $ Store retVar dstVar Nothing []
genCall (PrimTarget (MO_AtomicRead _ mem_ord)) [dst] [addr] = runStmtsDecls $ do
dstV <- getCmmRegW (CmmLocal dst)
v1 <- genLoadW (Just mem_ord) addr (localRegType dst) NaturallyAligned
- statement $ Store v1 dstV Nothing
+ statement $ Store v1 dstV Nothing []
genCall (PrimTarget (MO_Cmpxchg _width))
[dst] [addr, old, new] = runStmtsDecls $ do
@@ -282,7 +282,7 @@ genCall (PrimTarget (MO_Cmpxchg _width))
retVar <- doExprW (LMStructU [targetTy,i1])
$ CmpXChg ptrVar oldVar newVar SyncSeqCst SyncSeqCst
retVar' <- doExprW targetTy $ ExtractV retVar 0
- statement $ Store retVar' dstVar Nothing
+ statement $ Store retVar' dstVar Nothing []
genCall (PrimTarget (MO_Xchg _width)) [dst] [addr, val] = runStmtsDecls $ do
dstV <- getCmmRegW (CmmLocal dst) :: WriterT LlvmAccum LlvmM LlvmVar
@@ -292,7 +292,7 @@ genCall (PrimTarget (MO_Xchg _width)) [dst] [addr, val] = runStmtsDecls $ do
ptrExpr = Cast LM_Inttoptr addrVar ptrTy
ptrVar <- doExprW ptrTy ptrExpr
resVar <- doExprW (getVarType valVar) (AtomicRMW LAO_Xchg ptrVar valVar SyncSeqCst)
- statement $ Store resVar dstV Nothing
+ statement $ Store resVar dstV Nothing []
genCall (PrimTarget (MO_AtomicWrite _width mem_ord)) [] [addr, val] = runStmtsDecls $ do
addrVar <- exprToVarW addr
@@ -353,8 +353,8 @@ genCall (PrimTarget (MO_U_Mul2 w)) [dstH, dstL] [lhs, rhs] = runStmtsDecls $ do
retH <- doExprW width $ Cast LM_Trunc retShifted width
dstRegL <- getCmmRegW (CmmLocal dstL)
dstRegH <- getCmmRegW (CmmLocal dstH)
- statement $ Store retL dstRegL Nothing
- statement $ Store retH dstRegH Nothing
+ statement $ Store retL dstRegL Nothing []
+ statement $ Store retH dstRegH Nothing []
genCall (PrimTarget (MO_S_Mul2 w)) [dstC, dstH, dstL] [lhs, rhs] = runStmtsDecls $ do
let width = widthToLlvmInt w
@@ -385,9 +385,9 @@ genCall (PrimTarget (MO_S_Mul2 w)) [dstC, dstH, dstL] [lhs, rhs] = runStmtsDecls
dstRegL <- getCmmRegW (CmmLocal dstL)
dstRegH <- getCmmRegW (CmmLocal dstH)
dstRegC <- getCmmRegW (CmmLocal dstC)
- statement $ Store retL dstRegL Nothing
- statement $ Store retH dstRegH Nothing
- statement $ Store retC dstRegC Nothing
+ statement $ Store retL dstRegL Nothing []
+ statement $ Store retH dstRegH Nothing []
+ statement $ Store retC dstRegC Nothing []
-- MO_U_QuotRem2 is another case we handle by widening the registers to double
-- the width and use normal LLVM instructions (similarly to the MO_U_Mul2). The
@@ -421,8 +421,8 @@ genCall (PrimTarget (MO_U_QuotRem2 w))
retRem <- narrow retExtRem
dstRegQ <- lift $ getCmmReg (CmmLocal dstQ)
dstRegR <- lift $ getCmmReg (CmmLocal dstR)
- statement $ Store retDiv dstRegQ Nothing
- statement $ Store retRem dstRegR Nothing
+ statement $ Store retDiv dstRegQ Nothing []
+ statement $ Store retRem dstRegR Nothing []
-- Handle the MO_{Add,Sub}IntC separately. LLVM versions return a record from
-- which we need to extract the actual values.
@@ -529,7 +529,7 @@ genCall target res args = do
vreg <- getCmmRegW (CmmLocal creg)
if retTy == pLower (getVarType vreg)
then do
- statement $ Store v1 vreg Nothing
+ statement $ Store v1 vreg Nothing []
doReturn
else do
let ty = pLower $ getVarType vreg
@@ -541,7 +541,7 @@ genCall target res args = do
++ " returned type!"
v2 <- doExprW ty $ Cast op v1 ty
- statement $ Store v2 vreg Nothing
+ statement $ Store v2 vreg Nothing []
doReturn
-- | Generate a call to an LLVM intrinsic that performs arithmetic operation
@@ -570,8 +570,8 @@ genCallWithOverflow t@(PrimTarget op) w [dstV, dstO] [lhs, rhs] = do
(overflow, zext) <- doExpr width $ Cast LM_Zext overflowBit width
dstRegV <- getCmmReg (CmmLocal dstV)
dstRegO <- getCmmReg (CmmLocal dstO)
- let storeV = Store value dstRegV Nothing
- storeO = Store overflow dstRegO Nothing
+ let storeV = Store value dstRegV Nothing []
+ storeO = Store overflow dstRegO Nothing []
return (stmts `snocOL` zext `snocOL` storeV `snocOL` storeO, top)
genCallWithOverflow _ _ _ _ =
panic "genCallExtract: wrong ForeignTarget or number of arguments"
@@ -636,7 +636,7 @@ genCallSimpleCast w t@(PrimTarget op) [dst] args = do
(retV, s1) <- doExpr width $ Call StdCall fptr argsV' []
(retVs', stmts5) <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)]
let retV' = singletonPanic "genCallSimpleCast" retVs'
- let s2 = Store retV' dstV Nothing
+ let s2 = Store retV' dstV Nothing []
let stmts = stmts2 `appOL` stmts4 `snocOL`
s1 `appOL` stmts5 `snocOL` s2
@@ -668,7 +668,7 @@ genCallSimpleCast2 w t@(PrimTarget op) [dst] args = do
(retV, s1) <- doExpr width $ Call StdCall fptr argsV' []
(retVs', stmts5) <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)]
let retV' = singletonPanic "genCallSimpleCast2" retVs'
- let s2 = Store retV' dstV Nothing
+ let s2 = Store retV' dstV Nothing []
let stmts = stmts2 `appOL` stmts4 `snocOL`
s1 `appOL` stmts5 `snocOL` s2
@@ -1098,16 +1098,16 @@ genAssign reg val = do
-- Some registers are pointer types, so need to cast value to pointer
LMPointer _ | getVarType vval == llvmWord platform -> do
(v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
- let s2 = Store v vreg Nothing
+ let s2 = Store v vreg Nothing []
return (stmts `snocOL` s1 `snocOL` s2, top2)
LMVector _ _ -> do
(v, s1) <- doExpr ty $ Cast LM_Bitcast vval ty
- let s2 = mkStore v vreg NaturallyAligned
+ let s2 = mkStore v vreg NaturallyAligned []
return (stmts `snocOL` s1 `snocOL` s2, top2)
_ -> do
- let s1 = Store vval vreg Nothing
+ let s1 = Store vval vreg Nothing []
return (stmts `snocOL` s1, top2)
@@ -1158,7 +1158,7 @@ genStore_fast addr r n val alignment
case pLower grt == getVarType vval of
-- were fine
True -> do
- let s3 = MetaStmt meta $ mkStore vval ptr alignment
+ let s3 = mkStore vval ptr alignment meta
return (stmts `appOL` s1 `snocOL` s2
`snocOL` s3, top)
@@ -1166,7 +1166,7 @@ genStore_fast addr r n val alignment
False -> do
let ty = (pLift . getVarType) vval
(ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty
- let s4 = MetaStmt meta $ mkStore vval ptr' alignment
+ let s4 = mkStore vval ptr' alignment meta
return (stmts `appOL` s1 `snocOL` s2
`snocOL` s3 `snocOL` s4, top)
@@ -1189,17 +1189,17 @@ genStore_slow addr val alignment meta = do
-- sometimes we need to cast an int to a pointer before storing
LMPointer ty@(LMPointer _) | getVarType vval == llvmWord platform -> do
(v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
- let s2 = MetaStmt meta $ mkStore v vaddr alignment
+ let s2 = mkStore v vaddr alignment meta
return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
LMPointer _ -> do
- let s1 = MetaStmt meta $ mkStore vval vaddr alignment
+ let s1 = mkStore vval vaddr alignment meta
return (stmts `snocOL` s1, top1 ++ top2)
i@(LMInt _) | i == llvmWord platform -> do
let vty = pLift $ getVarType vval
(vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty
- let s2 = MetaStmt meta $ mkStore vval vptr alignment
+ let s2 = mkStore vval vptr alignment meta
return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
other ->
@@ -1209,9 +1209,9 @@ genStore_slow addr val alignment meta = do
text "Size of var:" <+> ppr (llvmWidthInBits platform other) $$
text "Var:" <+> ppVar cfg vaddr)
-mkStore :: LlvmVar -> LlvmVar -> AlignmentSpec -> LlvmStatement
-mkStore vval vptr alignment =
- Store vval vptr align
+mkStore :: LlvmVar -> LlvmVar -> AlignmentSpec -> [MetaAnnot] -> LlvmStatement
+mkStore vval vptr alignment metas =
+ Store vval vptr align metas
where
ty = pLower (getVarType vptr)
align = case alignment of
@@ -2072,7 +2072,7 @@ funPrologue live cmmBlocks = do
rval = if isLive r then arg else trash
alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1
markStackReg r
- return $ toOL [alloc, Store rval reg Nothing]
+ return $ toOL [alloc, Store rval reg Nothing []]
return (concatOL stmtss `snocOL` jumpToEntry, [])
where
diff --git a/compiler/GHC/CmmToLlvm/Ppr.hs b/compiler/GHC/CmmToLlvm/Ppr.hs
index 8b0577bad7..5838233f3b 100644
--- a/compiler/GHC/CmmToLlvm/Ppr.hs
+++ b/compiler/GHC/CmmToLlvm/Ppr.hs
@@ -26,22 +26,28 @@ import GHC.Types.Unique
--
-- | Pretty print LLVM data code
-pprLlvmData :: LlvmCgConfig -> LlvmData -> SDoc
+pprLlvmData :: IsDoc doc => LlvmCgConfig -> LlvmData -> doc
pprLlvmData cfg (globals, types) =
- let ppLlvmTys (LMAlias a) = ppLlvmAlias a
+ let ppLlvmTys (LMAlias a) = line $ ppLlvmAlias a
ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f
ppLlvmTys _other = empty
types' = vcat $ map ppLlvmTys types
globals' = ppLlvmGlobals cfg globals
- in types' $+$ globals'
+ in types' $$ globals'
+{-# SPECIALIZE pprLlvmData :: LlvmCgConfig -> LlvmData -> SDoc #-}
+{-# SPECIALIZE pprLlvmData :: LlvmCgConfig -> LlvmData -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Pretty print LLVM code
-pprLlvmCmmDecl :: LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar])
+-- The HDoc we return is used to produce the final LLVM file, with the
+-- SDoc being returned alongside for use when @Opt_D_dump_llvm@ is set
+-- as we can't (currently) dump HDocs.
+pprLlvmCmmDecl :: LlvmCmmDecl -> LlvmM (HDoc, SDoc)
pprLlvmCmmDecl (CmmData _ lmdata) = do
opts <- getConfig
- return (vcat $ map (pprLlvmData opts) lmdata, [])
+ return ( vcat $ map (pprLlvmData opts) lmdata
+ , vcat $ map (pprLlvmData opts) lmdata)
pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))
= do let lbl = case mb_info of
@@ -92,7 +98,8 @@ pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))
(Just $ LMBitc (LMStaticPointer defVar)
i8Ptr)
- return (ppLlvmGlobal cfg alias $+$ ppLlvmFunction cfg fun', [])
+ return ( vcat [line $ ppLlvmGlobal cfg alias, ppLlvmFunction cfg fun']
+ , vcat [line $ ppLlvmGlobal cfg alias, ppLlvmFunction cfg fun'])
-- | The section we are putting info tables and their entry code into, should
diff --git a/compiler/GHC/Llvm/MetaData.hs b/compiler/GHC/Llvm/MetaData.hs
index f46ae0a101..3f8818ee45 100644
--- a/compiler/GHC/Llvm/MetaData.hs
+++ b/compiler/GHC/Llvm/MetaData.hs
@@ -64,7 +64,12 @@ newtype MetaId = MetaId Int
deriving (Eq, Ord, Enum)
instance Outputable MetaId where
- ppr (MetaId n) = char '!' <> int n
+ ppr = ppMetaId
+
+ppMetaId :: IsLine doc => MetaId -> doc
+ppMetaId (MetaId n) = char '!' <> int n
+{-# SPECIALIZE ppMetaId :: MetaId -> SDoc #-}
+{-# SPECIALIZE ppMetaId :: MetaId -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | LLVM metadata expressions
data MetaExpr = MetaStr !LMString
diff --git a/compiler/GHC/Llvm/Ppr.hs b/compiler/GHC/Llvm/Ppr.hs
index 787b6efcf7..36bfdf3405 100644
--- a/compiler/GHC/Llvm/Ppr.hs
+++ b/compiler/GHC/Llvm/Ppr.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeApplications #-}
--------------------------------------------------------------------------------
-- | Pretty print LLVM IR Code.
@@ -36,7 +37,6 @@ import GHC.Llvm.Syntax
import GHC.Llvm.MetaData
import GHC.Llvm.Types
-import Data.Int
import Data.List ( intersperse )
import GHC.Utils.Outputable
@@ -49,30 +49,39 @@ import GHC.Types.Unique
--------------------------------------------------------------------------------
-- | Print out a whole LLVM module.
-ppLlvmModule :: LlvmCgConfig -> LlvmModule -> SDoc
+ppLlvmModule :: IsDoc doc => LlvmCgConfig -> LlvmModule -> doc
ppLlvmModule opts (LlvmModule comments aliases meta globals decls funcs)
- = ppLlvmComments comments $+$ newLine
- $+$ ppLlvmAliases aliases $+$ newLine
- $+$ ppLlvmMetas opts meta $+$ newLine
- $+$ ppLlvmGlobals opts globals $+$ newLine
- $+$ ppLlvmFunctionDecls decls $+$ newLine
- $+$ ppLlvmFunctions opts funcs
+ = ppLlvmComments comments $$ newLine
+ $$ ppLlvmAliases aliases $$ newLine
+ $$ ppLlvmMetas opts meta $$ newLine
+ $$ ppLlvmGlobals opts globals $$ newLine
+ $$ ppLlvmFunctionDecls decls $$ newLine
+ $$ ppLlvmFunctions opts funcs
+{-# SPECIALIZE ppLlvmModule :: LlvmCgConfig -> LlvmModule -> SDoc #-}
+{-# SPECIALIZE ppLlvmModule :: LlvmCgConfig -> LlvmModule -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
+
-- | Print out a multi-line comment, can be inside a function or on its own
-ppLlvmComments :: [LMString] -> SDoc
-ppLlvmComments comments = vcat $ map ppLlvmComment comments
+ppLlvmComments :: IsDoc doc => [LMString] -> doc
+ppLlvmComments comments = lines_ $ map ppLlvmComment comments
+{-# SPECIALIZE ppLlvmComments :: [LMString] -> SDoc #-}
+{-# SPECIALIZE ppLlvmComments :: [LMString] -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Print out a comment, can be inside a function or on its own
-ppLlvmComment :: LMString -> SDoc
+ppLlvmComment :: IsLine doc => LMString -> doc
ppLlvmComment com = semi <+> ftext com
+{-# SPECIALIZE ppLlvmComment :: LMString -> SDoc #-}
+{-# SPECIALIZE ppLlvmComment :: LMString -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Print out a list of global mutable variable definitions
-ppLlvmGlobals :: LlvmCgConfig -> [LMGlobal] -> SDoc
-ppLlvmGlobals opts ls = vcat $ map (ppLlvmGlobal opts) ls
+ppLlvmGlobals :: IsDoc doc => LlvmCgConfig -> [LMGlobal] -> doc
+ppLlvmGlobals opts ls = lines_ $ map (ppLlvmGlobal opts) ls
+{-# SPECIALIZE ppLlvmGlobals :: LlvmCgConfig -> [LMGlobal] -> SDoc #-}
+{-# SPECIALIZE ppLlvmGlobals :: LlvmCgConfig -> [LMGlobal] -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Print out a global mutable variable definition
-ppLlvmGlobal :: LlvmCgConfig -> LMGlobal -> SDoc
+ppLlvmGlobal :: IsLine doc => LlvmCgConfig -> LMGlobal -> doc
ppLlvmGlobal opts (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) =
let sect = case x of
Just x' -> text ", section" <+> doubleQuotes (ftext x')
@@ -84,7 +93,7 @@ ppLlvmGlobal opts (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) =
rhs = case dat of
Just stat -> pprSpecialStatic opts stat
- Nothing -> ppr (pLower $ getVarType var)
+ Nothing -> ppLlvmType (pLower $ getVarType var)
-- Position of linkage is different for aliases.
const = case c of
@@ -92,105 +101,130 @@ ppLlvmGlobal opts (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) =
Constant -> "constant"
Alias -> "alias"
- in ppAssignment opts var $ ppr link <+> text const <+> rhs <> sect <> align
- $+$ newLine
+ in ppAssignment opts var $ ppLlvmLinkageType link <+> text const <+> rhs <> sect <> align
ppLlvmGlobal opts (LMGlobal var val) = pprPanic "ppLlvmGlobal" $
- text "Non Global var ppr as global! " <> ppVar opts var <> text "=" <> ppr (fmap (ppStatic opts) val)
+ text "Non Global var ppr as global! " <> ppVar opts var <> text "=" <> ppr (fmap (ppStatic @SDoc opts) val)
+{-# SPECIALIZE ppLlvmGlobal :: LlvmCgConfig -> LMGlobal -> SDoc #-}
+{-# SPECIALIZE ppLlvmGlobal :: LlvmCgConfig -> LMGlobal -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Print out a list of LLVM type aliases.
-ppLlvmAliases :: [LlvmAlias] -> SDoc
-ppLlvmAliases tys = vcat $ map ppLlvmAlias tys
+ppLlvmAliases :: IsDoc doc => [LlvmAlias] -> doc
+ppLlvmAliases tys = lines_ $ map ppLlvmAlias tys
+{-# SPECIALIZE ppLlvmAliases :: [LlvmAlias] -> SDoc #-}
+{-# SPECIALIZE ppLlvmAliases :: [LlvmAlias] -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Print out an LLVM type alias.
-ppLlvmAlias :: LlvmAlias -> SDoc
+ppLlvmAlias :: IsLine doc => LlvmAlias -> doc
ppLlvmAlias (name, ty)
- = char '%' <> ftext name <+> equals <+> text "type" <+> ppr ty
+ = char '%' <> ftext name <+> equals <+> text "type" <+> ppLlvmType ty
+{-# SPECIALIZE ppLlvmAlias :: LlvmAlias -> SDoc #-}
+{-# SPECIALIZE ppLlvmAlias :: LlvmAlias -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Print out a list of LLVM metadata.
-ppLlvmMetas :: LlvmCgConfig -> [MetaDecl] -> SDoc
-ppLlvmMetas opts metas = vcat $ map (ppLlvmMeta opts) metas
+ppLlvmMetas :: IsDoc doc => LlvmCgConfig -> [MetaDecl] -> doc
+ppLlvmMetas opts metas = lines_ $ map (ppLlvmMeta opts) metas
+{-# SPECIALIZE ppLlvmMetas :: LlvmCgConfig -> [MetaDecl] -> SDoc #-}
+{-# SPECIALIZE ppLlvmMetas :: LlvmCgConfig -> [MetaDecl] -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Print out an LLVM metadata definition.
-ppLlvmMeta :: LlvmCgConfig -> MetaDecl -> SDoc
+ppLlvmMeta :: IsLine doc => LlvmCgConfig -> MetaDecl -> doc
ppLlvmMeta opts (MetaUnnamed n m)
- = ppr n <+> equals <+> ppMetaExpr opts m
+ = ppMetaId n <+> equals <+> ppMetaExpr opts m
ppLlvmMeta _opts (MetaNamed n m)
= exclamation <> ftext n <+> equals <+> exclamation <> braces nodes
where
- nodes = hcat $ intersperse comma $ map ppr m
+ nodes = hcat $ intersperse comma $ map ppMetaId m
+{-# SPECIALIZE ppLlvmMeta :: LlvmCgConfig -> MetaDecl -> SDoc #-}
+{-# SPECIALIZE ppLlvmMeta :: LlvmCgConfig -> MetaDecl -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Print out a list of function definitions.
-ppLlvmFunctions :: LlvmCgConfig -> LlvmFunctions -> SDoc
+ppLlvmFunctions :: IsDoc doc => LlvmCgConfig -> LlvmFunctions -> doc
ppLlvmFunctions opts funcs = vcat $ map (ppLlvmFunction opts) funcs
+{-# SPECIALIZE ppLlvmFunctions :: LlvmCgConfig -> LlvmFunctions -> SDoc #-}
+{-# SPECIALIZE ppLlvmFunctions :: LlvmCgConfig -> LlvmFunctions -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Print out a function definition.
-ppLlvmFunction :: LlvmCgConfig -> LlvmFunction -> SDoc
+ppLlvmFunction :: IsDoc doc => LlvmCgConfig -> LlvmFunction -> doc
ppLlvmFunction opts fun =
- let attrDoc = ppSpaceJoin (funcAttrs fun)
+ let attrDoc = ppSpaceJoin ppLlvmFuncAttr (funcAttrs fun)
secDoc = case funcSect fun of
Just s' -> text "section" <+> (doubleQuotes $ ftext s')
Nothing -> empty
prefixDoc = case funcPrefix fun of
Just v -> text "prefix" <+> ppStatic opts v
Nothing -> empty
- in text "define" <+> ppLlvmFunctionHeader (funcDecl fun) (funcArgs fun)
- <+> attrDoc <+> secDoc <+> prefixDoc
- $+$ lbrace
- $+$ ppLlvmBlocks opts (funcBody fun)
- $+$ rbrace
- $+$ newLine
- $+$ newLine
+ in vcat
+ [line $ text "define" <+> ppLlvmFunctionHeader (funcDecl fun) (funcArgs fun)
+ <+> attrDoc <+> secDoc <+> prefixDoc
+ , line lbrace
+ , ppLlvmBlocks opts (funcBody fun)
+ , line rbrace
+ , newLine
+ , newLine]
+{-# SPECIALIZE ppLlvmFunction :: LlvmCgConfig -> LlvmFunction -> SDoc #-}
+{-# SPECIALIZE ppLlvmFunction :: LlvmCgConfig -> LlvmFunction -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Print out a function definition header.
-ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> SDoc
+ppLlvmFunctionHeader :: IsLine doc => LlvmFunctionDecl -> [LMString] -> doc
ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args
= let varg' = case varg of
VarArgs | null p -> text "..."
| otherwise -> text ", ..."
_otherwise -> text ""
align = case a of
- Just a' -> text " align " <> ppr a'
+ Just a' -> text " align " <> int a'
Nothing -> empty
- args' = map (\((ty,p),n) -> ppr ty <+> ppSpaceJoin p <+> char '%'
+ args' = zipWith (\(ty,p) n -> ppLlvmType ty <+> ppSpaceJoin ppLlvmParamAttr p <+> char '%'
<> ftext n)
- (zip p args)
- in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <> lparen <>
- (hsep $ punctuate comma args') <> varg' <> rparen <> align
+ p
+ args
+ in ppLlvmLinkageType l <+> ppLlvmCallConvention c <+> ppLlvmType r <+> char '@' <> ftext n <> lparen <>
+ hsep (punctuate comma args') <> varg' <> rparen <> align
+{-# SPECIALIZE ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> SDoc #-}
+{-# SPECIALIZE ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Print out a list of function declaration.
-ppLlvmFunctionDecls :: LlvmFunctionDecls -> SDoc
+ppLlvmFunctionDecls :: IsDoc doc => LlvmFunctionDecls -> doc
ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs
+{-# SPECIALIZE ppLlvmFunctionDecls :: LlvmFunctionDecls -> SDoc #-}
+{-# SPECIALIZE ppLlvmFunctionDecls :: LlvmFunctionDecls -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Print out a function declaration.
-- Declarations define the function type but don't define the actual body of
-- the function.
-ppLlvmFunctionDecl :: LlvmFunctionDecl -> SDoc
+ppLlvmFunctionDecl :: IsDoc doc => LlvmFunctionDecl -> doc
ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a)
= let varg' = case varg of
VarArgs | null p -> text "..."
| otherwise -> text ", ..."
_otherwise -> text ""
align = case a of
- Just a' -> text " align" <+> ppr a'
+ Just a' -> text " align" <+> int a'
Nothing -> empty
args = hcat $ intersperse (comma <> space) $
- map (\(t,a) -> ppr t <+> ppSpaceJoin a) p
- in text "declare" <+> ppr l <+> ppr c <+> ppr r <+> char '@' <>
- ftext n <> lparen <> args <> varg' <> rparen <> align $+$ newLine
+ map (\(t,a) -> ppLlvmType t <+> ppSpaceJoin ppLlvmParamAttr a) p
+ in lines_
+ [ text "declare" <+> ppLlvmLinkageType l <+> ppLlvmCallConvention c
+ <+> ppLlvmType r <+> char '@' <> ftext n <> lparen <> args <> varg' <> rparen <> align
+ , empty]
+{-# SPECIALIZE ppLlvmFunctionDecl :: LlvmFunctionDecl -> SDoc #-}
+{-# SPECIALIZE ppLlvmFunctionDecl :: LlvmFunctionDecl -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Print out a list of LLVM blocks.
-ppLlvmBlocks :: LlvmCgConfig -> LlvmBlocks -> SDoc
+ppLlvmBlocks :: IsDoc doc => LlvmCgConfig -> LlvmBlocks -> doc
ppLlvmBlocks opts blocks = vcat $ map (ppLlvmBlock opts) blocks
+{-# SPECIALIZE ppLlvmBlocks :: LlvmCgConfig -> LlvmBlocks -> SDoc #-}
+{-# SPECIALIZE ppLlvmBlocks :: LlvmCgConfig -> LlvmBlocks -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Print out an LLVM block.
-- It must be part of a function definition.
-ppLlvmBlock :: LlvmCgConfig -> LlvmBlock -> SDoc
+ppLlvmBlock :: IsDoc doc => LlvmCgConfig -> LlvmBlock -> doc
ppLlvmBlock opts (LlvmBlock blockId stmts) =
let isLabel (MkLabel _) = True
isLabel _ = False
@@ -198,39 +232,44 @@ ppLlvmBlock opts (LlvmBlock blockId stmts) =
ppRest = case rest of
MkLabel id:xs -> ppLlvmBlock opts (LlvmBlock id xs)
_ -> empty
- in ppLlvmBlockLabel blockId
- $+$ (vcat $ map (ppLlvmStatement opts) block)
- $+$ newLine
- $+$ ppRest
+ in vcat $
+ line (ppLlvmBlockLabel blockId)
+ : map (ppLlvmStatement opts) block
+ ++ [ empty , ppRest ]
+{-# SPECIALIZE ppLlvmBlock :: LlvmCgConfig -> LlvmBlock -> SDoc #-}
+{-# SPECIALIZE ppLlvmBlock :: LlvmCgConfig -> LlvmBlock -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Print out an LLVM block label.
-ppLlvmBlockLabel :: LlvmBlockId -> SDoc
+ppLlvmBlockLabel :: IsLine doc => LlvmBlockId -> doc
ppLlvmBlockLabel id = pprUniqueAlways id <> colon
+{-# SPECIALIZE ppLlvmBlockLabel :: LlvmBlockId -> SDoc #-}
+{-# SPECIALIZE ppLlvmBlockLabel :: LlvmBlockId -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
--- | Print out an LLVM statement.
-ppLlvmStatement :: LlvmCgConfig -> LlvmStatement -> SDoc
+-- | Print out an LLVM statement, with any metadata to append to the statement.
+ppLlvmStatement :: IsDoc doc => LlvmCgConfig -> LlvmStatement -> doc
ppLlvmStatement opts stmt =
- let ind = (text " " <>)
+ let ind = line . (text " " <>)
in case stmt of
Assignment dst expr -> ind $ ppAssignment opts dst (ppLlvmExpression opts expr)
Fence st ord -> ind $ ppFence st ord
Branch target -> ind $ ppBranch opts target
BranchIf cond ifT ifF -> ind $ ppBranchIf opts cond ifT ifF
- Comment comments -> ind $ ppLlvmComments comments
- MkLabel label -> ppLlvmBlockLabel label
- Store value ptr align
- -> ind $ ppStore opts value ptr align
- Switch scrut def tgs -> ind $ ppSwitch opts scrut def tgs
+ Comment comments -> ppLlvmComments comments
+ MkLabel label -> line $ ppLlvmBlockLabel label
+ Store value ptr align metas
+ -> ind $ ppStore opts value ptr align metas
+ Switch scrut def tgs -> ppSwitch opts scrut def tgs
Return result -> ind $ ppReturn opts result
Expr expr -> ind $ ppLlvmExpression opts expr
Unreachable -> ind $ text "unreachable"
- Nop -> empty
- MetaStmt meta s -> ppMetaStatement opts meta s
+ Nop -> line empty
+{-# SPECIALIZE ppLlvmStatement :: LlvmCgConfig -> LlvmStatement -> SDoc #-}
+{-# SPECIALIZE ppLlvmStatement :: LlvmCgConfig -> LlvmStatement -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Print out an LLVM expression.
-ppLlvmExpression :: LlvmCgConfig -> LlvmExpression -> SDoc
+ppLlvmExpression :: IsLine doc => LlvmCgConfig -> LlvmExpression -> doc
ppLlvmExpression opts expr
= case expr of
Alloca tp amount -> ppAlloca opts tp amount
@@ -251,14 +290,18 @@ ppLlvmExpression opts expr
Phi tp predecessors -> ppPhi opts tp predecessors
Asm asm c ty v se sk -> ppAsm opts asm c ty v se sk
MExpr meta expr -> ppMetaAnnotExpr opts meta expr
+{-# SPECIALIZE ppLlvmExpression :: LlvmCgConfig -> LlvmExpression -> SDoc #-}
+{-# SPECIALIZE ppLlvmExpression :: LlvmCgConfig -> LlvmExpression -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-ppMetaExpr :: LlvmCgConfig -> MetaExpr -> SDoc
+ppMetaExpr :: IsLine doc => LlvmCgConfig -> MetaExpr -> doc
ppMetaExpr opts = \case
MetaVar (LMLitVar (LMNullLit _)) -> text "null"
MetaStr s -> char '!' <> doubleQuotes (ftext s)
- MetaNode n -> ppr n
+ MetaNode n -> ppMetaId n
MetaVar v -> ppVar opts v
- MetaStruct es -> char '!' <> braces (ppCommaJoin (map (ppMetaExpr opts) es))
+ MetaStruct es -> char '!' <> braces (ppCommaJoin (ppMetaExpr opts) es)
+{-# SPECIALIZE ppMetaExpr :: LlvmCgConfig -> MetaExpr -> SDoc #-}
+{-# SPECIALIZE ppMetaExpr :: LlvmCgConfig -> MetaExpr -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
--------------------------------------------------------------------------------
@@ -267,7 +310,8 @@ ppMetaExpr opts = \case
-- | Should always be a function pointer. So a global var of function type
-- (since globals are always pointers) or a local var of pointer function type.
-ppCall :: LlvmCgConfig -> LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc
+ppCall :: forall doc. IsLine doc => LlvmCgConfig -> LlvmCallType -> LlvmVar -> [MetaExpr]
+ -> [LlvmFuncAttr] -> doc
ppCall opts ct fptr args attrs = case fptr of
--
-- if local var function pointer, unwrap
@@ -285,32 +329,36 @@ ppCall opts ct fptr args attrs = case fptr of
ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) =
let tc = if ct == TailCall then text "tail " else empty
ppValues = ppCallParams opts (map snd params) args
- ppArgTy = (ppCommaJoin $ map (ppr . fst) params) <>
+ ppArgTy = ppCommaJoin (ppLlvmType . fst) params <>
(case argTy of
VarArgs -> text ", ..."
FixedArgs -> empty)
fnty = space <> lparen <> ppArgTy <> rparen
- attrDoc = ppSpaceJoin attrs
- in tc <> text "call" <+> ppr cc <+> ppr ret
+ attrDoc = ppSpaceJoin ppLlvmFuncAttr attrs
+ in tc <> text "call" <+> ppLlvmCallConvention cc <+> ppLlvmType ret
<> fnty <+> ppName opts fptr <> lparen <+> ppValues
<+> rparen <+> attrDoc
- ppCallParams :: LlvmCgConfig -> [[LlvmParamAttr]] -> [MetaExpr] -> SDoc
+ ppCallParams :: LlvmCgConfig -> [[LlvmParamAttr]] -> [MetaExpr] -> doc
ppCallParams opts attrs args = hsep $ punctuate comma $ zipWith ppCallMetaExpr attrs args
where
-- Metadata needs to be marked as having the `metadata` type when used
-- in a call argument
ppCallMetaExpr attrs (MetaVar v) = ppVar' attrs opts v
ppCallMetaExpr _ v = text "metadata" <+> ppMetaExpr opts v
+{-# SPECIALIZE ppCall :: LlvmCgConfig -> LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc #-}
+{-# SPECIALIZE ppCall :: LlvmCgConfig -> LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-ppMachOp :: LlvmCgConfig -> LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc
+ppMachOp :: IsLine doc => LlvmCgConfig -> LlvmMachOp -> LlvmVar -> LlvmVar -> doc
ppMachOp opts op left right =
- (ppr op) <+> (ppr (getVarType left)) <+> ppName opts left
+ ppLlvmMachOp op <+> ppLlvmType (getVarType left) <+> ppName opts left
<> comma <+> ppName opts right
+{-# SPECIALIZE ppMachOp :: LlvmCgConfig -> LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc #-}
+{-# SPECIALIZE ppMachOp :: LlvmCgConfig -> LlvmMachOp -> LlvmVar -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-ppCmpOp :: LlvmCgConfig -> LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc
+ppCmpOp :: IsLine doc => LlvmCgConfig -> LlvmCmpOp -> LlvmVar -> LlvmVar -> doc
ppCmpOp opts op left right =
let cmpOp
| isInt (getVarType left) && isInt (getVarType right) = text "icmp"
@@ -321,28 +369,36 @@ ppCmpOp opts op left right =
++ (show $ getVarType left) ++ ", right = "
++ (show $ getVarType right))
-}
- in cmpOp <+> ppr op <+> ppr (getVarType left)
+ in cmpOp <+> ppLlvmCmpOp op <+> ppLlvmType (getVarType left)
<+> ppName opts left <> comma <+> ppName opts right
+{-# SPECIALIZE ppCmpOp :: LlvmCgConfig -> LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc #-}
+{-# SPECIALIZE ppCmpOp :: LlvmCgConfig -> LlvmCmpOp -> LlvmVar -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-ppAssignment :: LlvmCgConfig -> LlvmVar -> SDoc -> SDoc
+ppAssignment :: IsLine doc => LlvmCgConfig -> LlvmVar -> doc -> doc
ppAssignment opts var expr = ppName opts var <+> equals <+> expr
+{-# SPECIALIZE ppAssignment :: LlvmCgConfig -> LlvmVar -> SDoc -> SDoc #-}
+{-# SPECIALIZE ppAssignment :: LlvmCgConfig -> LlvmVar -> HLine -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-ppFence :: Bool -> LlvmSyncOrdering -> SDoc
+ppFence :: IsLine doc => Bool -> LlvmSyncOrdering -> doc
ppFence st ord =
let singleThread = case st of True -> text "singlethread"
False -> empty
in text "fence" <+> singleThread <+> ppSyncOrdering ord
+{-# SPECIALIZE ppFence :: Bool -> LlvmSyncOrdering -> SDoc #-}
+{-# SPECIALIZE ppFence :: Bool -> LlvmSyncOrdering -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-ppSyncOrdering :: LlvmSyncOrdering -> SDoc
+ppSyncOrdering :: IsLine doc => LlvmSyncOrdering -> doc
ppSyncOrdering SyncUnord = text "unordered"
ppSyncOrdering SyncMonotonic = text "monotonic"
ppSyncOrdering SyncAcquire = text "acquire"
ppSyncOrdering SyncRelease = text "release"
ppSyncOrdering SyncAcqRel = text "acq_rel"
ppSyncOrdering SyncSeqCst = text "seq_cst"
+{-# SPECIALIZE ppSyncOrdering :: LlvmSyncOrdering -> SDoc #-}
+{-# SPECIALIZE ppSyncOrdering :: LlvmSyncOrdering -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-ppAtomicOp :: LlvmAtomicOp -> SDoc
+ppAtomicOp :: IsLine doc => LlvmAtomicOp -> doc
ppAtomicOp LAO_Xchg = text "xchg"
ppAtomicOp LAO_Add = text "add"
ppAtomicOp LAO_Sub = text "sub"
@@ -354,184 +410,222 @@ ppAtomicOp LAO_Max = text "max"
ppAtomicOp LAO_Min = text "min"
ppAtomicOp LAO_Umax = text "umax"
ppAtomicOp LAO_Umin = text "umin"
+{-# SPECIALIZE ppAtomicOp :: LlvmAtomicOp -> SDoc #-}
+{-# SPECIALIZE ppAtomicOp :: LlvmAtomicOp -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-ppAtomicRMW :: LlvmCgConfig -> LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc
+ppAtomicRMW :: IsLine doc => LlvmCgConfig -> LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> doc
ppAtomicRMW opts aop tgt src ordering =
text "atomicrmw" <+> ppAtomicOp aop <+> ppVar opts tgt <> comma
<+> ppVar opts src <+> ppSyncOrdering ordering
+{-# SPECIALIZE ppAtomicRMW :: LlvmCgConfig -> LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc #-}
+{-# SPECIALIZE ppAtomicRMW :: LlvmCgConfig -> LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-ppCmpXChg :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar
- -> LlvmSyncOrdering -> LlvmSyncOrdering -> SDoc
+ppCmpXChg :: IsLine doc => LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar
+ -> LlvmSyncOrdering -> LlvmSyncOrdering -> doc
ppCmpXChg opts addr old new s_ord f_ord =
text "cmpxchg" <+> ppVar opts addr <> comma <+> ppVar opts old <> comma <+> ppVar opts new
<+> ppSyncOrdering s_ord <+> ppSyncOrdering f_ord
+{-# SPECIALIZE ppCmpXChg :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> LlvmSyncOrdering -> SDoc #-}
+{-# SPECIALIZE ppCmpXChg :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> LlvmSyncOrdering -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-ppLoad :: LlvmCgConfig -> LlvmVar -> LMAlign -> SDoc
+ppLoad :: IsLine doc => LlvmCgConfig -> LlvmVar -> LMAlign -> doc
ppLoad opts var alignment =
- text "load" <+> ppr derefType <> comma <+> ppVar opts var <> align
+ text "load" <+> ppLlvmType derefType <> comma <+> ppVar opts var <> align
where
derefType = pLower $ getVarType var
align =
case alignment of
- Just n -> text ", align" <+> ppr n
+ Just n -> text ", align" <+> int n
Nothing -> empty
+{-# SPECIALIZE ppLoad :: LlvmCgConfig -> LlvmVar -> LMAlign -> SDoc #-}
+{-# SPECIALIZE ppLoad :: LlvmCgConfig -> LlvmVar -> LMAlign -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-ppALoad :: LlvmCgConfig -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc
+ppALoad :: IsLine doc => LlvmCgConfig -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> doc
ppALoad opts ord st var =
let alignment = llvmWidthInBits (llvmCgPlatform opts) (getVarType var) `quot` 8
- align = text ", align" <+> ppr alignment
+ align = text ", align" <+> int alignment
sThreaded | st = text " singlethread"
| otherwise = empty
derefType = pLower $ getVarType var
- in text "load atomic" <+> ppr derefType <> comma <+> ppVar opts var <> sThreaded
+ in text "load atomic" <+> ppLlvmType derefType <> comma <+> ppVar opts var <> sThreaded
<+> ppSyncOrdering ord <> align
+{-# SPECIALIZE ppALoad :: LlvmCgConfig -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc #-}
+{-# SPECIALIZE ppALoad :: LlvmCgConfig -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-ppStore :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LMAlign -> SDoc
-ppStore opts val dst alignment =
- text "store" <+> ppVar opts val <> comma <+> ppVar opts dst <> align
+ppStore :: IsLine doc => LlvmCgConfig -> LlvmVar -> LlvmVar -> LMAlign -> [MetaAnnot] -> doc
+ppStore opts val dst alignment metas =
+ text "store" <+> ppVar opts val <> comma <+> ppVar opts dst <> align <+> ppMetaAnnots opts metas
where
align =
case alignment of
- Just n -> text ", align" <+> ppr n
+ Just n -> text ", align" <+> int n
Nothing -> empty
+{-# SPECIALIZE ppStore :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LMAlign -> [MetaAnnot] -> SDoc #-}
+{-# SPECIALIZE ppStore :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LMAlign -> [MetaAnnot] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-ppCast :: LlvmCgConfig -> LlvmCastOp -> LlvmVar -> LlvmType -> SDoc
+ppCast :: IsLine doc => LlvmCgConfig -> LlvmCastOp -> LlvmVar -> LlvmType -> doc
ppCast opts op from to
- = ppr op
- <+> ppr (getVarType from) <+> ppName opts from
+ = ppLlvmCastOp op
+ <+> ppLlvmType (getVarType from) <+> ppName opts from
<+> text "to"
- <+> ppr to
+ <+> ppLlvmType to
+{-# SPECIALIZE ppCast :: LlvmCgConfig -> LlvmCastOp -> LlvmVar -> LlvmType -> SDoc #-}
+{-# SPECIALIZE ppCast :: LlvmCgConfig -> LlvmCastOp -> LlvmVar -> LlvmType -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-ppMalloc :: LlvmCgConfig -> LlvmType -> Int -> SDoc
+ppMalloc :: IsLine doc => LlvmCgConfig -> LlvmType -> Int -> doc
ppMalloc opts tp amount =
let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
- in text "malloc" <+> ppr tp <> comma <+> ppVar opts amount'
-
+ in text "malloc" <+> ppLlvmType tp <> comma <+> ppVar opts amount'
+{-# SPECIALIZE ppMalloc :: LlvmCgConfig -> LlvmType -> Int -> SDoc #-}
+{-# SPECIALIZE ppMalloc :: LlvmCgConfig -> LlvmType -> Int -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-ppAlloca :: LlvmCgConfig -> LlvmType -> Int -> SDoc
+ppAlloca :: IsLine doc => LlvmCgConfig -> LlvmType -> Int -> doc
ppAlloca opts tp amount =
let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
- in text "alloca" <+> ppr tp <> comma <+> ppVar opts amount'
-
+ in text "alloca" <+> ppLlvmType tp <> comma <+> ppVar opts amount'
+{-# SPECIALIZE ppAlloca :: LlvmCgConfig -> LlvmType -> Int -> SDoc #-}
+{-# SPECIALIZE ppAlloca :: LlvmCgConfig -> LlvmType -> Int -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-ppGetElementPtr :: LlvmCgConfig -> Bool -> LlvmVar -> [LlvmVar] -> SDoc
+ppGetElementPtr :: IsLine doc => LlvmCgConfig -> Bool -> LlvmVar -> [LlvmVar] -> doc
ppGetElementPtr opts inb ptr idx =
- let indexes = comma <+> ppCommaJoin (map (ppVar opts) idx)
+ let indexes = comma <+> ppCommaJoin (ppVar opts) idx
inbound = if inb then text "inbounds" else empty
derefType = pLower $ getVarType ptr
- in text "getelementptr" <+> inbound <+> ppr derefType <> comma <+> ppVar opts ptr
+ in text "getelementptr" <+> inbound <+> ppLlvmType derefType <> comma <+> ppVar opts ptr
<> indexes
+{-# SPECIALIZE ppGetElementPtr :: LlvmCgConfig -> Bool -> LlvmVar -> [LlvmVar] -> SDoc #-}
+{-# SPECIALIZE ppGetElementPtr :: LlvmCgConfig -> Bool -> LlvmVar -> [LlvmVar] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-ppReturn :: LlvmCgConfig -> Maybe LlvmVar -> SDoc
+ppReturn :: IsLine doc => LlvmCgConfig -> Maybe LlvmVar -> doc
ppReturn opts (Just var) = text "ret" <+> ppVar opts var
-ppReturn _ Nothing = text "ret" <+> ppr LMVoid
+ppReturn _ Nothing = text "ret" <+> ppLlvmType LMVoid
+{-# SPECIALIZE ppReturn :: LlvmCgConfig -> Maybe LlvmVar -> SDoc #-}
+{-# SPECIALIZE ppReturn :: LlvmCgConfig -> Maybe LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-
-ppBranch :: LlvmCgConfig -> LlvmVar -> SDoc
+ppBranch :: IsLine doc => LlvmCgConfig -> LlvmVar -> doc
ppBranch opts var = text "br" <+> ppVar opts var
+{-# SPECIALIZE ppBranch :: LlvmCgConfig -> LlvmVar -> SDoc #-}
+{-# SPECIALIZE ppBranch :: LlvmCgConfig -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-ppBranchIf :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc
+ppBranchIf :: IsLine doc => LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> doc
ppBranchIf opts cond trueT falseT
= text "br" <+> ppVar opts cond <> comma <+> ppVar opts trueT <> comma <+> ppVar opts falseT
+{-# SPECIALIZE ppBranchIf :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc #-}
+{-# SPECIALIZE ppBranchIf :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-ppPhi :: LlvmCgConfig -> LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc
+ppPhi :: IsLine doc => LlvmCgConfig -> LlvmType -> [(LlvmVar,LlvmVar)] -> doc
ppPhi opts tp preds =
let ppPreds (val, label) = brackets $ ppName opts val <> comma <+> ppName opts label
- in text "phi" <+> ppr tp <+> hsep (punctuate comma $ map ppPreds preds)
+ in text "phi" <+> ppLlvmType tp <+> hsep (punctuate comma $ map ppPreds preds)
+{-# SPECIALIZE ppPhi :: LlvmCgConfig -> LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc #-}
+{-# SPECIALIZE ppPhi :: LlvmCgConfig -> LlvmType -> [(LlvmVar,LlvmVar)] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-ppSwitch :: LlvmCgConfig -> LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc
+ppSwitch :: IsDoc doc => LlvmCgConfig -> LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> doc
ppSwitch opts scrut dflt targets =
- let ppTarget (val, lab) = ppVar opts val <> comma <+> ppVar opts lab
- ppTargets xs = brackets $ vcat (map ppTarget xs)
- in text "switch" <+> ppVar opts scrut <> comma <+> ppVar opts dflt
- <+> ppTargets targets
+ let ppTarget (val, lab) = text " " <> ppVar opts val <> comma <+> ppVar opts lab
+ in lines_ $ concat
+ [ [text "switch" <+> ppVar opts scrut <> comma <+> ppVar opts dflt <+> char '[']
+ , map ppTarget targets
+ , [char ']']
+ ]
+{-# SPECIALIZE ppSwitch :: LlvmCgConfig -> LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc #-}
+{-# SPECIALIZE ppSwitch :: LlvmCgConfig -> LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-ppAsm :: LlvmCgConfig -> LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc
+ppAsm :: IsLine doc => LlvmCgConfig -> LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> doc
ppAsm opts asm constraints rty vars sideeffect alignstack =
let asm' = doubleQuotes $ ftext asm
cons = doubleQuotes $ ftext constraints
- rty' = ppr rty
- vars' = lparen <+> ppCommaJoin (map (ppVar opts) vars) <+> rparen
+ rty' = ppLlvmType rty
+ vars' = lparen <+> ppCommaJoin (ppVar opts) vars <+> rparen
side = if sideeffect then text "sideeffect" else empty
align = if alignstack then text "alignstack" else empty
in text "call" <+> rty' <+> text "asm" <+> side <+> align <+> asm' <> comma
<+> cons <> vars'
+{-# SPECIALIZE ppAsm :: LlvmCgConfig -> LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc #-}
+{-# SPECIALIZE ppAsm :: LlvmCgConfig -> LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-ppExtract :: LlvmCgConfig -> LlvmVar -> LlvmVar -> SDoc
+ppExtract :: IsLine doc => LlvmCgConfig -> LlvmVar -> LlvmVar -> doc
ppExtract opts vec idx =
text "extractelement"
- <+> ppr (getVarType vec) <+> ppName opts vec <> comma
+ <+> ppLlvmType (getVarType vec) <+> ppName opts vec <> comma
<+> ppVar opts idx
+{-# SPECIALIZE ppExtract :: LlvmCgConfig -> LlvmVar -> LlvmVar -> SDoc #-}
+{-# SPECIALIZE ppExtract :: LlvmCgConfig -> LlvmVar -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-ppExtractV :: LlvmCgConfig -> LlvmVar -> Int -> SDoc
+ppExtractV :: IsLine doc => LlvmCgConfig -> LlvmVar -> Int -> doc
ppExtractV opts struct idx =
text "extractvalue"
- <+> ppr (getVarType struct) <+> ppName opts struct <> comma
- <+> ppr idx
+ <+> ppLlvmType (getVarType struct) <+> ppName opts struct <> comma
+ <+> int idx
+{-# SPECIALIZE ppExtractV :: LlvmCgConfig -> LlvmVar -> Int -> SDoc #-}
+{-# SPECIALIZE ppExtractV :: LlvmCgConfig -> LlvmVar -> Int -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-ppInsert :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc
+ppInsert :: IsLine doc => LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> doc
ppInsert opts vec elt idx =
text "insertelement"
- <+> ppr (getVarType vec) <+> ppName opts vec <> comma
- <+> ppr (getVarType elt) <+> ppName opts elt <> comma
+ <+> ppLlvmType (getVarType vec) <+> ppName opts vec <> comma
+ <+> ppLlvmType (getVarType elt) <+> ppName opts elt <> comma
<+> ppVar opts idx
+{-# SPECIALIZE ppInsert :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc #-}
+{-# SPECIALIZE ppInsert :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-
-ppMetaStatement :: LlvmCgConfig -> [MetaAnnot] -> LlvmStatement -> SDoc
-ppMetaStatement opts meta stmt =
- ppLlvmStatement opts stmt <> ppMetaAnnots opts meta
-
-ppMetaAnnotExpr :: LlvmCgConfig -> [MetaAnnot] -> LlvmExpression -> SDoc
+ppMetaAnnotExpr :: IsLine doc => LlvmCgConfig -> [MetaAnnot] -> LlvmExpression -> doc
ppMetaAnnotExpr opts meta expr =
ppLlvmExpression opts expr <> ppMetaAnnots opts meta
+{-# SPECIALIZE ppMetaAnnotExpr :: LlvmCgConfig -> [MetaAnnot] -> LlvmExpression -> SDoc #-}
+{-# SPECIALIZE ppMetaAnnotExpr :: LlvmCgConfig -> [MetaAnnot] -> LlvmExpression -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-ppMetaAnnots :: LlvmCgConfig -> [MetaAnnot] -> SDoc
+ppMetaAnnots :: IsLine doc => LlvmCgConfig -> [MetaAnnot] -> doc
ppMetaAnnots opts meta = hcat $ map ppMeta meta
where
ppMeta (MetaAnnot name e)
= comma <+> exclamation <> ftext name <+>
case e of
- MetaNode n -> ppr n
- MetaStruct ms -> exclamation <> braces (ppCommaJoin (map (ppMetaExpr opts) ms))
+ MetaNode n -> ppMetaId n
+ MetaStruct ms -> exclamation <> braces (ppCommaJoin (ppMetaExpr opts) ms)
other -> exclamation <> braces (ppMetaExpr opts other) -- possible?
+{-# SPECIALIZE ppMetaAnnots :: LlvmCgConfig -> [MetaAnnot] -> SDoc #-}
+{-# SPECIALIZE ppMetaAnnots :: LlvmCgConfig -> [MetaAnnot] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Return the variable name or value of the 'LlvmVar'
-- in Llvm IR textual representation (e.g. @\@x@, @%y@ or @42@).
-ppName :: LlvmCgConfig -> LlvmVar -> SDoc
+ppName :: IsLine doc => LlvmCgConfig -> LlvmVar -> doc
ppName opts v = case v of
LMGlobalVar {} -> char '@' <> ppPlainName opts v
LMLocalVar {} -> char '%' <> ppPlainName opts v
LMNLocalVar {} -> char '%' <> ppPlainName opts v
LMLitVar {} -> ppPlainName opts v
+{-# SPECIALIZE ppName :: LlvmCgConfig -> LlvmVar -> SDoc #-}
+{-# SPECIALIZE ppName :: LlvmCgConfig -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Return the variable name or value of the 'LlvmVar'
-- in a plain textual representation (e.g. @x@, @y@ or @42@).
-ppPlainName :: LlvmCgConfig -> LlvmVar -> SDoc
+ppPlainName :: IsLine doc => LlvmCgConfig -> LlvmVar -> doc
ppPlainName opts v = case v of
(LMGlobalVar x _ _ _ _ _) -> ftext x
(LMLocalVar x LMLabel ) -> pprUniqueAlways x
(LMLocalVar x _ ) -> char 'l' <> pprUniqueAlways x
(LMNLocalVar x _ ) -> ftext x
(LMLitVar x ) -> ppLit opts x
+{-# SPECIALIZE ppPlainName :: LlvmCgConfig -> LlvmVar -> SDoc #-}
+{-# SPECIALIZE ppPlainName :: LlvmCgConfig -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Print a literal value. No type.
-ppLit :: LlvmCgConfig -> LlvmLit -> SDoc
+ppLit :: IsLine doc => LlvmCgConfig -> LlvmLit -> doc
ppLit opts l = 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)
+ (LMIntLit i _ ) -> integer i
(LMFloatLit r LMFloat ) -> ppFloat (llvmCgPlatform opts) $ narrowFp r
(LMFloatLit r LMDouble) -> ppDouble (llvmCgPlatform opts) r
f@(LMFloatLit _ _) -> pprPanic "ppLit" (text "Can't print this float literal: " <> ppTypeLit opts f)
- (LMVectorLit ls ) -> char '<' <+> ppCommaJoin (map (ppTypeLit opts) ls) <+> char '>'
+ (LMVectorLit ls ) -> char '<' <+> ppCommaJoin (ppTypeLit opts) 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
@@ -544,61 +638,76 @@ ppLit opts l = case l of
| llvmCgFillUndefWithGarbage opts
, Just lit <- garbageLit t -> ppLit opts lit
| otherwise -> text "undef"
+{-# SPECIALIZE ppLit :: LlvmCgConfig -> LlvmLit -> SDoc #-}
+{-# SPECIALIZE ppLit :: LlvmCgConfig -> LlvmLit -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-ppVar :: LlvmCgConfig -> LlvmVar -> SDoc
+ppVar :: IsLine doc => LlvmCgConfig -> LlvmVar -> doc
ppVar = ppVar' []
+{-# SPECIALIZE ppVar :: LlvmCgConfig -> LlvmVar -> SDoc #-}
+{-# SPECIALIZE ppVar :: LlvmCgConfig -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-ppVar' :: [LlvmParamAttr] -> LlvmCgConfig -> LlvmVar -> SDoc
+ppVar' :: IsLine doc => [LlvmParamAttr] -> LlvmCgConfig -> LlvmVar -> doc
ppVar' attrs opts v = case v of
LMLitVar x -> ppTypeLit' attrs opts x
- x -> ppr (getVarType x) <+> ppSpaceJoin attrs <+> ppName opts x
+ x -> ppLlvmType (getVarType x) <+> ppSpaceJoin ppLlvmParamAttr attrs <+> ppName opts x
+{-# SPECIALIZE ppVar' :: [LlvmParamAttr] -> LlvmCgConfig -> LlvmVar -> SDoc #-}
+{-# SPECIALIZE ppVar' :: [LlvmParamAttr] -> LlvmCgConfig -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-ppTypeLit :: LlvmCgConfig -> LlvmLit -> SDoc
+ppTypeLit :: IsLine doc => LlvmCgConfig -> LlvmLit -> doc
ppTypeLit = ppTypeLit' []
+{-# SPECIALIZE ppTypeLit :: LlvmCgConfig -> LlvmLit -> SDoc #-}
+{-# SPECIALIZE ppTypeLit :: LlvmCgConfig -> LlvmLit -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-ppTypeLit' :: [LlvmParamAttr] -> LlvmCgConfig -> LlvmLit -> SDoc
+ppTypeLit' :: IsLine doc => [LlvmParamAttr] -> LlvmCgConfig -> LlvmLit -> doc
ppTypeLit' attrs opts l = case l of
LMVectorLit {} -> ppLit opts l
- _ -> ppr (getLitType l) <+> ppSpaceJoin attrs <+> ppLit opts l
+ _ -> ppLlvmType (getLitType l) <+> ppSpaceJoin ppLlvmParamAttr attrs <+> ppLit opts l
+{-# SPECIALIZE ppTypeLit' :: [LlvmParamAttr] -> LlvmCgConfig -> LlvmLit -> SDoc #-}
+{-# SPECIALIZE ppTypeLit' :: [LlvmParamAttr] -> LlvmCgConfig -> LlvmLit -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-ppStatic :: LlvmCgConfig -> LlvmStatic -> SDoc
+ppStatic :: IsLine doc => LlvmCgConfig -> LlvmStatic -> doc
ppStatic opts st = case st of
LMComment s -> text "; " <> ftext s
LMStaticLit l -> ppTypeLit opts l
- LMUninitType t -> ppr t <> text " undef"
- LMStaticStr s t -> ppr t <> text " c\"" <> ftext s <> text "\\00\""
- LMStaticArray d t -> ppr t <> text " [" <> ppCommaJoin (map (ppStatic opts) d) <> char ']'
- LMStaticStruc d t -> ppr t <> text "<{" <> ppCommaJoin (map (ppStatic opts) d) <> text "}>"
- LMStaticStrucU d t -> ppr t <> text "{" <> ppCommaJoin (map (ppStatic opts) d) <> text "}"
+ LMUninitType t -> ppLlvmType t <> text " undef"
+ LMStaticStr s t -> ppLlvmType t <> text " c\"" <> ftext s <> text "\\00\""
+ LMStaticArray d t -> ppLlvmType t <> text " [" <> ppCommaJoin (ppStatic opts) d <> char ']'
+ LMStaticStruc d t -> ppLlvmType t <> text "<{" <> ppCommaJoin (ppStatic opts) d <> text "}>"
+ LMStaticStrucU d t -> ppLlvmType t <> text "{" <> ppCommaJoin (ppStatic opts) d <> text "}"
LMStaticPointer v -> ppVar opts v
- LMTrunc v t -> ppr t <> text " trunc (" <> ppStatic opts v <> text " to " <> ppr t <> char ')'
- LMBitc v t -> ppr t <> text " bitcast (" <> ppStatic opts v <> text " to " <> ppr t <> char ')'
- LMPtoI v t -> ppr t <> text " ptrtoint (" <> ppStatic opts v <> text " to " <> ppr t <> char ')'
+ LMTrunc v t -> ppLlvmType t <> text " trunc (" <> ppStatic opts v <> text " to " <> ppLlvmType t <> char ')'
+ LMBitc v t -> ppLlvmType t <> text " bitcast (" <> ppStatic opts v <> text " to " <> ppLlvmType t <> char ')'
+ LMPtoI v t -> ppLlvmType t <> text " ptrtoint (" <> ppStatic opts v <> text " to " <> ppLlvmType t <> char ')'
LMAdd s1 s2 -> pprStaticArith opts s1 s2 (text "add") (text "fadd") (text "LMAdd")
LMSub s1 s2 -> pprStaticArith opts s1 s2 (text "sub") (text "fsub") (text "LMSub")
+{-# SPECIALIZE ppStatic :: LlvmCgConfig -> LlvmStatic -> SDoc #-}
+{-# SPECIALIZE ppStatic :: LlvmCgConfig -> LlvmStatic -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-pprSpecialStatic :: LlvmCgConfig -> LlvmStatic -> SDoc
+pprSpecialStatic :: IsLine doc => LlvmCgConfig -> LlvmStatic -> doc
pprSpecialStatic opts stat = case stat of
- LMBitc v t -> ppr (pLower t)
+ LMBitc v t -> ppLlvmType (pLower t)
<> text ", bitcast ("
- <> ppStatic opts v <> text " to " <> ppr t
+ <> ppStatic opts v <> text " to " <> ppLlvmType t
<> char ')'
- LMStaticPointer x -> ppr (pLower $ getVarType x)
+ LMStaticPointer x -> ppLlvmType (pLower $ getVarType x)
<> comma <+> ppStatic opts stat
_ -> ppStatic opts stat
+{-# SPECIALIZE pprSpecialStatic :: LlvmCgConfig -> LlvmStatic -> SDoc #-}
+{-# SPECIALIZE pprSpecialStatic :: LlvmCgConfig -> LlvmStatic -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-pprStaticArith :: LlvmCgConfig -> LlvmStatic -> LlvmStatic -> SDoc -> SDoc
- -> SDoc -> SDoc
+pprStaticArith :: IsLine doc => LlvmCgConfig -> LlvmStatic -> LlvmStatic -> doc -> doc -> SDoc -> doc
pprStaticArith opts 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 <+> op <+> lparen <> ppStatic opts s1 <> comma <> ppStatic opts s2 <> rparen
+ then ppLlvmType ty1 <+> op <+> lparen <> ppStatic opts s1 <> comma <> ppStatic opts s2 <> rparen
else pprPanic "pprStaticArith" $
op_name <> text " with different types! s1: " <> ppStatic opts s1
<> text", s2: " <> ppStatic opts s2
+{-# SPECIALIZE pprStaticArith :: LlvmCgConfig -> LlvmStatic -> LlvmStatic -> SDoc -> SDoc -> SDoc -> SDoc #-}
+{-# SPECIALIZE pprStaticArith :: LlvmCgConfig -> LlvmStatic -> LlvmStatic -> HLine -> HLine -> SDoc -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
--------------------------------------------------------------------------------
@@ -606,9 +715,13 @@ pprStaticArith opts s1 s2 int_op float_op op_name =
--------------------------------------------------------------------------------
-- | Blank line.
-newLine :: SDoc
+newLine :: IsDoc doc => doc
newLine = empty
+{-# SPECIALIZE newLine :: SDoc #-}
+{-# SPECIALIZE newLine :: HDoc #-}
-- | Exclamation point.
-exclamation :: SDoc
+exclamation :: IsLine doc => doc
exclamation = char '!'
+{-# SPECIALIZE exclamation :: SDoc #-}
+{-# SPECIALIZE exclamation :: HLine #-}
diff --git a/compiler/GHC/Llvm/Syntax.hs b/compiler/GHC/Llvm/Syntax.hs
index 115f5b58c3..882cb0660b 100644
--- a/compiler/GHC/Llvm/Syntax.hs
+++ b/compiler/GHC/Llvm/Syntax.hs
@@ -150,7 +150,7 @@ data LlvmStatement
* value: Variable/Constant to store.
* ptr: Location to store the value in
-}
- | Store LlvmVar LlvmVar LMAlign
+ | Store LlvmVar LlvmVar LMAlign [MetaAnnot]
{- |
Multiway branch
@@ -186,11 +186,6 @@ data LlvmStatement
-}
| Nop
- {- |
- A LLVM statement with metadata attached to it.
- -}
- | MetaStmt [MetaAnnot] LlvmStatement
-
deriving (Eq)
diff --git a/compiler/GHC/Llvm/Types.hs b/compiler/GHC/Llvm/Types.hs
index 77e2ffd10d..f80b261584 100644
--- a/compiler/GHC/Llvm/Types.hs
+++ b/compiler/GHC/Llvm/Types.hs
@@ -1,6 +1,13 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
+-- Workaround for #21972. It can be removed once the minimal bootstrapping
+-- compiler has a fix for this bug.
+#if defined(darwin_HOST_OS)
+{-# OPTIONS_GHC -fno-asm-shortcutting #-}
+#endif
+
--------------------------------------------------------------------------------
-- | The LLVM Type System.
--
@@ -61,28 +68,30 @@ data LlvmType
deriving (Eq)
instance Outputable LlvmType where
- ppr = ppType
+ ppr = ppLlvmType
-ppType :: LlvmType -> SDoc
-ppType t = case t of
- LMInt size -> char 'i' <> ppr size
+ppLlvmType :: IsLine doc => LlvmType -> doc
+ppLlvmType t = case t of
+ LMInt size -> char 'i' <> int 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 '>'
+ LMPointer x -> ppLlvmType x <> char '*'
+ LMArray nr tp -> char '[' <> int nr <> text " x " <> ppLlvmType tp <> char ']'
+ LMVector nr tp -> char '<' <> int nr <> text " x " <> ppLlvmType tp <> char '>'
LMLabel -> text "label"
LMVoid -> text "void"
- LMStruct tys -> text "<{" <> ppCommaJoin tys <> text "}>"
- LMStructU tys -> text "{" <> ppCommaJoin tys <> text "}"
+ LMStruct tys -> text "<{" <> ppCommaJoin ppLlvmType tys <> text "}>"
+ LMStructU tys -> text "{" <> ppCommaJoin ppLlvmType tys <> text "}"
LMMetadata -> text "metadata"
LMAlias (s,_) -> char '%' <> ftext s
LMFunction (LlvmFunctionDecl _ _ _ r varg p _)
- -> ppr r <+> lparen <> ppParams varg p <> rparen
+ -> ppLlvmType r <+> lparen <> ppParams varg p <> rparen
+{-# SPECIALIZE ppLlvmType :: LlvmType -> SDoc #-}
+{-# SPECIALIZE ppLlvmType :: LlvmType -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-ppParams :: LlvmParameterListType -> [LlvmParameter] -> SDoc
+ppParams :: IsLine doc => LlvmParameterListType -> [LlvmParameter] -> doc
ppParams varg p
= let varg' = case varg of
VarArgs | null args -> text "..."
@@ -90,7 +99,9 @@ ppParams varg p
_otherwise -> text ""
-- by default we don't print param attributes
args = map fst p
- in ppCommaJoin args <> varg'
+ in ppCommaJoin ppLlvmType args <> varg'
+{-# SPECIALIZE ppParams :: LlvmParameterListType -> [LlvmParameter] -> SDoc #-}
+{-# SPECIALIZE ppParams :: LlvmParameterListType -> [LlvmParameter] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | An LLVM section definition. If Nothing then let LLVM decide the section
type LMSection = Maybe LMString
@@ -337,14 +348,6 @@ data LlvmFunctionDecl = LlvmFunctionDecl {
}
deriving (Eq)
-instance Outputable LlvmFunctionDecl where
- ppr (LlvmFunctionDecl n l c r varg p a)
- = let align = case a of
- Just a' -> text " align " <> ppr a'
- Nothing -> empty
- in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <>
- lparen <> ppParams varg p <> rparen <> align
-
type LlvmFunctionDecls = [LlvmFunctionDecl]
type LlvmParameter = (LlvmType, [LlvmParamAttr])
@@ -385,14 +388,19 @@ data LlvmParamAttr
deriving (Eq)
instance Outputable LlvmParamAttr where
- ppr ZeroExt = text "zeroext"
- ppr SignExt = text "signext"
- ppr InReg = text "inreg"
- ppr ByVal = text "byval"
- ppr SRet = text "sret"
- ppr NoAlias = text "noalias"
- ppr NoCapture = text "nocapture"
- ppr Nest = text "nest"
+ ppr = ppLlvmParamAttr
+
+ppLlvmParamAttr :: IsLine doc => LlvmParamAttr -> doc
+ppLlvmParamAttr ZeroExt = text "zeroext"
+ppLlvmParamAttr SignExt = text "signext"
+ppLlvmParamAttr InReg = text "inreg"
+ppLlvmParamAttr ByVal = text "byval"
+ppLlvmParamAttr SRet = text "sret"
+ppLlvmParamAttr NoAlias = text "noalias"
+ppLlvmParamAttr NoCapture = text "nocapture"
+ppLlvmParamAttr Nest = text "nest"
+{-# SPECIALIZE ppLlvmParamAttr :: LlvmParamAttr -> SDoc #-}
+{-# SPECIALIZE ppLlvmParamAttr :: LlvmParamAttr -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Llvm Function Attributes.
--
@@ -473,19 +481,24 @@ data LlvmFuncAttr
deriving (Eq)
instance Outputable LlvmFuncAttr where
- ppr AlwaysInline = text "alwaysinline"
- ppr InlineHint = text "inlinehint"
- ppr NoInline = text "noinline"
- ppr OptSize = text "optsize"
- ppr NoReturn = text "noreturn"
- ppr NoUnwind = text "nounwind"
- ppr ReadNone = text "readnone"
- ppr ReadOnly = text "readonly"
- ppr Ssp = text "ssp"
- ppr SspReq = text "ssqreq"
- ppr NoRedZone = text "noredzone"
- ppr NoImplicitFloat = text "noimplicitfloat"
- ppr Naked = text "naked"
+ ppr = ppLlvmFuncAttr
+
+ppLlvmFuncAttr :: IsLine doc => LlvmFuncAttr -> doc
+ppLlvmFuncAttr AlwaysInline = text "alwaysinline"
+ppLlvmFuncAttr InlineHint = text "inlinehint"
+ppLlvmFuncAttr NoInline = text "noinline"
+ppLlvmFuncAttr OptSize = text "optsize"
+ppLlvmFuncAttr NoReturn = text "noreturn"
+ppLlvmFuncAttr NoUnwind = text "nounwind"
+ppLlvmFuncAttr ReadNone = text "readnone"
+ppLlvmFuncAttr ReadOnly = text "readonly"
+ppLlvmFuncAttr Ssp = text "ssp"
+ppLlvmFuncAttr SspReq = text "ssqreq"
+ppLlvmFuncAttr NoRedZone = text "noredzone"
+ppLlvmFuncAttr NoImplicitFloat = text "noimplicitfloat"
+ppLlvmFuncAttr Naked = text "naked"
+{-# SPECIALIZE ppLlvmFuncAttr :: LlvmFuncAttr -> SDoc #-}
+{-# SPECIALIZE ppLlvmFuncAttr :: LlvmFuncAttr -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Different types to call a function.
@@ -533,12 +546,17 @@ data LlvmCallConvention
deriving (Eq)
instance Outputable LlvmCallConvention where
- ppr CC_Ccc = text "ccc"
- ppr CC_Fastcc = text "fastcc"
- ppr CC_Coldcc = text "coldcc"
- ppr CC_Ghc = text "ghccc"
- ppr (CC_Ncc i) = text "cc " <> ppr i
- ppr CC_X86_Stdcc = text "x86_stdcallcc"
+ ppr = ppLlvmCallConvention
+
+ppLlvmCallConvention :: IsLine doc => LlvmCallConvention -> doc
+ppLlvmCallConvention CC_Ccc = text "ccc"
+ppLlvmCallConvention CC_Fastcc = text "fastcc"
+ppLlvmCallConvention CC_Coldcc = text "coldcc"
+ppLlvmCallConvention CC_Ghc = text "ghccc"
+ppLlvmCallConvention (CC_Ncc i) = text "cc " <> int i
+ppLlvmCallConvention CC_X86_Stdcc = text "x86_stdcallcc"
+{-# SPECIALIZE ppLlvmCallConvention :: LlvmCallConvention -> SDoc #-}
+{-# SPECIALIZE ppLlvmCallConvention :: LlvmCallConvention -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Functions can have a fixed amount of parameters, or a variable amount.
@@ -597,17 +615,22 @@ data LlvmLinkageType
deriving (Eq)
instance Outputable LlvmLinkageType where
- ppr Internal = text "internal"
- ppr LinkOnce = text "linkonce"
- ppr Weak = text "weak"
- ppr Appending = text "appending"
- ppr ExternWeak = text "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 ExternallyVisible = empty
- ppr External = text "external"
- ppr Private = text "private"
+ ppr = ppLlvmLinkageType
+
+ppLlvmLinkageType :: IsLine doc => LlvmLinkageType -> doc
+ppLlvmLinkageType Internal = text "internal"
+ppLlvmLinkageType LinkOnce = text "linkonce"
+ppLlvmLinkageType Weak = text "weak"
+ppLlvmLinkageType Appending = text "appending"
+ppLlvmLinkageType ExternWeak = text "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.
+ppLlvmLinkageType ExternallyVisible = empty
+ppLlvmLinkageType External = text "external"
+ppLlvmLinkageType Private = text "private"
+{-# SPECIALIZE ppLlvmLinkageType :: LlvmLinkageType -> SDoc #-}
+{-# SPECIALIZE ppLlvmLinkageType :: LlvmLinkageType -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- -----------------------------------------------------------------------------
-- * LLVM Operations
@@ -645,24 +668,29 @@ data LlvmMachOp
deriving (Eq)
instance Outputable LlvmMachOp where
- ppr LM_MO_Add = text "add"
- ppr LM_MO_Sub = text "sub"
- ppr LM_MO_Mul = text "mul"
- ppr LM_MO_UDiv = text "udiv"
- ppr LM_MO_SDiv = text "sdiv"
- ppr LM_MO_URem = text "urem"
- ppr LM_MO_SRem = text "srem"
- ppr LM_MO_FAdd = text "fadd"
- ppr LM_MO_FSub = text "fsub"
- ppr LM_MO_FMul = text "fmul"
- ppr LM_MO_FDiv = text "fdiv"
- ppr LM_MO_FRem = text "frem"
- ppr LM_MO_Shl = text "shl"
- ppr LM_MO_LShr = text "lshr"
- ppr LM_MO_AShr = text "ashr"
- ppr LM_MO_And = text "and"
- ppr LM_MO_Or = text "or"
- ppr LM_MO_Xor = text "xor"
+ ppr = ppLlvmMachOp
+
+ppLlvmMachOp :: IsLine doc => LlvmMachOp -> doc
+ppLlvmMachOp LM_MO_Add = text "add"
+ppLlvmMachOp LM_MO_Sub = text "sub"
+ppLlvmMachOp LM_MO_Mul = text "mul"
+ppLlvmMachOp LM_MO_UDiv = text "udiv"
+ppLlvmMachOp LM_MO_SDiv = text "sdiv"
+ppLlvmMachOp LM_MO_URem = text "urem"
+ppLlvmMachOp LM_MO_SRem = text "srem"
+ppLlvmMachOp LM_MO_FAdd = text "fadd"
+ppLlvmMachOp LM_MO_FSub = text "fsub"
+ppLlvmMachOp LM_MO_FMul = text "fmul"
+ppLlvmMachOp LM_MO_FDiv = text "fdiv"
+ppLlvmMachOp LM_MO_FRem = text "frem"
+ppLlvmMachOp LM_MO_Shl = text "shl"
+ppLlvmMachOp LM_MO_LShr = text "lshr"
+ppLlvmMachOp LM_MO_AShr = text "ashr"
+ppLlvmMachOp LM_MO_And = text "and"
+ppLlvmMachOp LM_MO_Or = text "or"
+ppLlvmMachOp LM_MO_Xor = text "xor"
+{-# SPECIALIZE ppLlvmMachOp :: LlvmMachOp -> SDoc #-}
+{-# SPECIALIZE ppLlvmMachOp :: LlvmMachOp -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Llvm compare operations.
@@ -689,22 +717,27 @@ data LlvmCmpOp
deriving (Eq)
instance Outputable LlvmCmpOp where
- ppr LM_CMP_Eq = text "eq"
- ppr LM_CMP_Ne = text "ne"
- ppr LM_CMP_Ugt = text "ugt"
- ppr LM_CMP_Uge = text "uge"
- ppr LM_CMP_Ult = text "ult"
- ppr LM_CMP_Ule = text "ule"
- ppr LM_CMP_Sgt = text "sgt"
- ppr LM_CMP_Sge = text "sge"
- ppr LM_CMP_Slt = text "slt"
- ppr LM_CMP_Sle = text "sle"
- ppr LM_CMP_Feq = text "oeq"
- ppr LM_CMP_Fne = text "une"
- ppr LM_CMP_Fgt = text "ogt"
- ppr LM_CMP_Fge = text "oge"
- ppr LM_CMP_Flt = text "olt"
- ppr LM_CMP_Fle = text "ole"
+ ppr = ppLlvmCmpOp
+
+ppLlvmCmpOp :: IsLine doc => LlvmCmpOp -> doc
+ppLlvmCmpOp LM_CMP_Eq = text "eq"
+ppLlvmCmpOp LM_CMP_Ne = text "ne"
+ppLlvmCmpOp LM_CMP_Ugt = text "ugt"
+ppLlvmCmpOp LM_CMP_Uge = text "uge"
+ppLlvmCmpOp LM_CMP_Ult = text "ult"
+ppLlvmCmpOp LM_CMP_Ule = text "ule"
+ppLlvmCmpOp LM_CMP_Sgt = text "sgt"
+ppLlvmCmpOp LM_CMP_Sge = text "sge"
+ppLlvmCmpOp LM_CMP_Slt = text "slt"
+ppLlvmCmpOp LM_CMP_Sle = text "sle"
+ppLlvmCmpOp LM_CMP_Feq = text "oeq"
+ppLlvmCmpOp LM_CMP_Fne = text "une"
+ppLlvmCmpOp LM_CMP_Fgt = text "ogt"
+ppLlvmCmpOp LM_CMP_Fge = text "oge"
+ppLlvmCmpOp LM_CMP_Flt = text "olt"
+ppLlvmCmpOp LM_CMP_Fle = text "ole"
+{-# SPECIALIZE ppLlvmCmpOp :: LlvmCmpOp -> SDoc #-}
+{-# SPECIALIZE ppLlvmCmpOp :: LlvmCmpOp -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- | Llvm cast operations.
@@ -724,18 +757,23 @@ data LlvmCastOp
deriving (Eq)
instance Outputable LlvmCastOp where
- ppr LM_Trunc = text "trunc"
- ppr LM_Zext = text "zext"
- ppr LM_Sext = text "sext"
- ppr LM_Fptrunc = text "fptrunc"
- ppr LM_Fpext = text "fpext"
- ppr LM_Fptoui = text "fptoui"
- ppr LM_Fptosi = text "fptosi"
- ppr LM_Uitofp = text "uitofp"
- ppr LM_Sitofp = text "sitofp"
- ppr LM_Ptrtoint = text "ptrtoint"
- ppr LM_Inttoptr = text "inttoptr"
- ppr LM_Bitcast = text "bitcast"
+ ppr = ppLlvmCastOp
+
+ppLlvmCastOp :: IsLine doc => LlvmCastOp -> doc
+ppLlvmCastOp LM_Trunc = text "trunc"
+ppLlvmCastOp LM_Zext = text "zext"
+ppLlvmCastOp LM_Sext = text "sext"
+ppLlvmCastOp LM_Fptrunc = text "fptrunc"
+ppLlvmCastOp LM_Fpext = text "fpext"
+ppLlvmCastOp LM_Fptoui = text "fptoui"
+ppLlvmCastOp LM_Fptosi = text "fptosi"
+ppLlvmCastOp LM_Uitofp = text "uitofp"
+ppLlvmCastOp LM_Sitofp = text "sitofp"
+ppLlvmCastOp LM_Ptrtoint = text "ptrtoint"
+ppLlvmCastOp LM_Inttoptr = text "inttoptr"
+ppLlvmCastOp LM_Bitcast = text "bitcast"
+{-# SPECIALIZE ppLlvmCastOp :: LlvmCastOp -> SDoc #-}
+{-# SPECIALIZE ppLlvmCastOp :: LlvmCastOp -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- -----------------------------------------------------------------------------
@@ -747,7 +785,7 @@ instance Outputable LlvmCastOp where
-- regardless of underlying architecture.
--
-- See Note [LLVM Float Types].
-ppDouble :: Platform -> Double -> SDoc
+ppDouble :: IsLine doc => Platform -> Double -> doc
ppDouble platform d
= let bs = doubleToBytes d
hex d' = case showHex d' "" of
@@ -761,6 +799,8 @@ ppDouble platform d
LittleEndian -> reverse
str = map toUpper $ concat $ fixEndian $ map hex bs
in text "0x" <> text str
+{-# SPECIALIZE ppDouble :: Platform -> Double -> SDoc #-}
+{-# SPECIALIZE ppDouble :: Platform -> Double -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-- Note [LLVM Float Types]
-- ~~~~~~~~~~~~~~~~~~~~~~~
@@ -787,16 +827,22 @@ widenFp :: Float -> Double
{-# NOINLINE widenFp #-}
widenFp = float2Double
-ppFloat :: Platform -> Float -> SDoc
+ppFloat :: IsLine doc => Platform -> Float -> doc
ppFloat platform = ppDouble platform . widenFp
+{-# SPECIALIZE ppFloat :: Platform -> Float -> SDoc #-}
+{-# SPECIALIZE ppFloat :: Platform -> Float -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
--------------------------------------------------------------------------------
-- * Misc functions
--------------------------------------------------------------------------------
-ppCommaJoin :: (Outputable a) => [a] -> SDoc
-ppCommaJoin strs = hsep $ punctuate comma (map ppr strs)
+ppCommaJoin :: IsLine doc => (a -> doc) -> [a] -> doc
+ppCommaJoin ppr strs = hsep $ punctuate comma (map ppr strs)
+{-# SPECIALIZE ppCommaJoin :: (a -> SDoc) -> [a] -> SDoc #-}
+{-# SPECIALIZE ppCommaJoin :: (a -> HLine) -> [a] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-ppSpaceJoin :: (Outputable a) => [a] -> SDoc
-ppSpaceJoin strs = hsep (map ppr strs)
+ppSpaceJoin :: IsLine doc => (a -> doc) -> [a] -> doc
+ppSpaceJoin ppr strs = hsep (map ppr strs)
+{-# SPECIALIZE ppSpaceJoin :: (a -> SDoc) -> [a] -> SDoc #-}
+{-# SPECIALIZE ppSpaceJoin :: (a -> HLine) -> [a] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
View Lorry Controller Status