[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Only test T16190 with the NCG
Marge Bot
gitlab at gitlab.haskell.org
Thu Jun 11 16:41:56 UTC 2020
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
8f4da7bd by Sylvain Henry at 2020-06-11T12:41:36-04:00
Only test T16190 with the NCG
T16190 is meant to test a NCG feature. It has already caused spurious
failures in other MRs (e.g. !2165) when LLVM is used.
- - - - -
e0c54c21 by Sylvain Henry at 2020-06-11T12:41:36-04:00
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`)
- - - - -
185016de by Oleg Grenrus at 2020-06-11T12:41:41-04:00
Fix #12073: Add MonadFix Q instance
- - - - -
afe64084 by Ben Gamari at 2020-06-11T12:41:42-04:00
testsuite: Increase size of T12150
As noted in #18319, this test was previously very fragile. Increase its
size to make it more likely that its fails with its newly-increased
acceptance threshold.
Metric Increase:
T12150
- - - - -
18 changed files:
- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/CmmToLlvm.hs
- compiler/GHC/CmmToLlvm/Base.hs
- compiler/GHC/CmmToLlvm/CodeGen.hs
- compiler/GHC/CmmToLlvm/Data.hs
- compiler/GHC/CmmToLlvm/Ppr.hs
- compiler/GHC/Llvm.hs
- compiler/GHC/Llvm/MetaData.hs
- compiler/GHC/Llvm/Ppr.hs
- compiler/GHC/Llvm/Types.hs
- libraries/base/System/IO.hs
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- libraries/template-haskell/changelog.md
- testsuite/tests/perf/compiler/T12150.hs
- testsuite/tests/perf/compiler/all.T
- + testsuite/tests/th/T12073.hs
- + testsuite/tests/th/T12073.stdout
- testsuite/tests/th/all.T
Changes:
=====================================
compiler/GHC/Cmm/CLabel.hs
=====================================
@@ -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 '_'
=====================================
compiler/GHC/CmmToLlvm.hs
=====================================
@@ -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 at 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], [])
=====================================
compiler/GHC/CmmToLlvm/Base.hs
=====================================
@@ -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
=====================================
compiler/GHC/CmmToLlvm/CodeGen.hs
=====================================
@@ -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
=====================================
compiler/GHC/CmmToLlvm/Data.hs
=====================================
@@ -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
=====================================
compiler/GHC/CmmToLlvm/Ppr.hs
=====================================
@@ -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
=====================================
compiler/GHC/Llvm.hs
=====================================
@@ -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,
=====================================
compiler/GHC/Llvm/MetaData.hs
=====================================
@@ -1,4 +1,5 @@
{-# 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
=====================================
compiler/GHC/Llvm/Ppr.hs
=====================================
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
--------------------------------------------------------------------------------
-- | Pretty print LLVM IR Code.
@@ -21,6 +22,12 @@ module GHC.Llvm.Ppr (
ppLlvmFunctions,
ppLlvmFunction,
+ ppVar,
+ ppLit,
+ ppTypeLit,
+ ppName,
+ ppPlainName
+
) where
#include "HsVersions.h"
@@ -30,26 +37,26 @@ import GHC.Prelude
import GHC.Llvm.Syntax
import GHC.Llvm.MetaData
import GHC.Llvm.Types
-import GHC.Platform
+import Data.Int
import Data.List ( intersperse )
import GHC.Utils.Outputable
import GHC.Types.Unique
-import GHC.Data.FastString ( sLit )
+import GHC.Data.FastString
--------------------------------------------------------------------------------
-- * Top Level Print functions
--------------------------------------------------------------------------------
-- | Print out a whole LLVM module.
-ppLlvmModule :: Platform -> LlvmModule -> SDoc
-ppLlvmModule platform (LlvmModule comments aliases meta globals decls funcs)
+ppLlvmModule :: LlvmOpts -> LlvmModule -> SDoc
+ppLlvmModule opts (LlvmModule comments aliases meta globals decls funcs)
= ppLlvmComments comments $+$ newLine
$+$ ppLlvmAliases aliases $+$ newLine
- $+$ ppLlvmMetas meta $+$ newLine
- $+$ ppLlvmGlobals globals $+$ newLine
+ $+$ ppLlvmMetas opts meta $+$ newLine
+ $+$ ppLlvmGlobals opts globals $+$ newLine
$+$ ppLlvmFunctionDecls decls $+$ newLine
- $+$ ppLlvmFunctions platform funcs
+ $+$ ppLlvmFunctions opts funcs
-- | Print out a multi-line comment, can be inside a function or on its own
ppLlvmComments :: [LMString] -> SDoc
@@ -61,12 +68,12 @@ ppLlvmComment com = semi <+> ftext com
-- | Print out a list of global mutable variable definitions
-ppLlvmGlobals :: [LMGlobal] -> SDoc
-ppLlvmGlobals ls = vcat $ map ppLlvmGlobal ls
+ppLlvmGlobals :: LlvmOpts -> [LMGlobal] -> SDoc
+ppLlvmGlobals opts ls = vcat $ map (ppLlvmGlobal opts) ls
-- | Print out a global mutable variable definition
-ppLlvmGlobal :: LMGlobal -> SDoc
-ppLlvmGlobal (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) =
+ppLlvmGlobal :: LlvmOpts -> LMGlobal -> SDoc
+ppLlvmGlobal opts (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) =
let sect = case x of
Just x' -> text ", section" <+> doubleQuotes (ftext x')
Nothing -> empty
@@ -76,7 +83,7 @@ ppLlvmGlobal (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) =
Nothing -> empty
rhs = case dat of
- Just stat -> pprSpecialStatic stat
+ Just stat -> pprSpecialStatic opts stat
Nothing -> ppr (pLower $ getVarType var)
-- Position of linkage is different for aliases.
@@ -85,11 +92,11 @@ ppLlvmGlobal (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) =
Constant -> "constant"
Alias -> "alias"
- in ppAssignment var $ ppr link <+> text const <+> rhs <> sect <> align
+ in ppAssignment opts var $ ppr link <+> text const <+> rhs <> sect <> align
$+$ newLine
-ppLlvmGlobal (LMGlobal var val) = pprPanic "ppLlvmGlobal" $
- text "Non Global var ppr as global! " <> ppr var <> text "=" <> ppr val
+ppLlvmGlobal opts (LMGlobal var val) = pprPanic "ppLlvmGlobal" $
+ text "Non Global var ppr as global! " <> ppVar opts var <> text "=" <> ppr (fmap (ppStatic opts) val)
-- | Print out a list of LLVM type aliases.
@@ -103,38 +110,38 @@ ppLlvmAlias (name, ty)
-- | Print out a list of LLVM metadata.
-ppLlvmMetas :: [MetaDecl] -> SDoc
-ppLlvmMetas metas = vcat $ map ppLlvmMeta metas
+ppLlvmMetas :: LlvmOpts -> [MetaDecl] -> SDoc
+ppLlvmMetas opts metas = vcat $ map (ppLlvmMeta opts) metas
-- | Print out an LLVM metadata definition.
-ppLlvmMeta :: MetaDecl -> SDoc
-ppLlvmMeta (MetaUnnamed n m)
- = ppr n <+> equals <+> ppr m
+ppLlvmMeta :: LlvmOpts -> MetaDecl -> SDoc
+ppLlvmMeta opts (MetaUnnamed n m)
+ = ppr n <+> equals <+> ppMetaExpr opts m
-ppLlvmMeta (MetaNamed n m)
+ppLlvmMeta _opts (MetaNamed n m)
= exclamation <> ftext n <+> equals <+> exclamation <> braces nodes
where
nodes = hcat $ intersperse comma $ map ppr m
-- | Print out a list of function definitions.
-ppLlvmFunctions :: Platform -> LlvmFunctions -> SDoc
-ppLlvmFunctions platform funcs = vcat $ map (ppLlvmFunction platform) funcs
+ppLlvmFunctions :: LlvmOpts -> LlvmFunctions -> SDoc
+ppLlvmFunctions opts funcs = vcat $ map (ppLlvmFunction opts) funcs
-- | Print out a function definition.
-ppLlvmFunction :: Platform -> LlvmFunction -> SDoc
-ppLlvmFunction platform fun =
+ppLlvmFunction :: LlvmOpts -> LlvmFunction -> SDoc
+ppLlvmFunction opts fun =
let attrDoc = ppSpaceJoin (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" <+> ppr v
+ Just v -> text "prefix" <+> ppStatic opts v
Nothing -> empty
in text "define" <+> ppLlvmFunctionHeader (funcDecl fun) (funcArgs fun)
<+> attrDoc <+> secDoc <+> prefixDoc
$+$ lbrace
- $+$ ppLlvmBlocks platform (funcBody fun)
+ $+$ ppLlvmBlocks opts (funcBody fun)
$+$ rbrace
$+$ newLine
$+$ newLine
@@ -178,21 +185,21 @@ ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a)
-- | Print out a list of LLVM blocks.
-ppLlvmBlocks :: Platform -> LlvmBlocks -> SDoc
-ppLlvmBlocks platform blocks = vcat $ map (ppLlvmBlock platform) blocks
+ppLlvmBlocks :: LlvmOpts -> LlvmBlocks -> SDoc
+ppLlvmBlocks opts blocks = vcat $ map (ppLlvmBlock opts) blocks
-- | Print out an LLVM block.
-- It must be part of a function definition.
-ppLlvmBlock :: Platform -> LlvmBlock -> SDoc
-ppLlvmBlock platform (LlvmBlock blockId stmts) =
+ppLlvmBlock :: LlvmOpts -> LlvmBlock -> SDoc
+ppLlvmBlock opts (LlvmBlock blockId stmts) =
let isLabel (MkLabel _) = True
isLabel _ = False
(block, rest) = break isLabel stmts
ppRest = case rest of
- MkLabel id:xs -> ppLlvmBlock platform (LlvmBlock id xs)
+ MkLabel id:xs -> ppLlvmBlock opts (LlvmBlock id xs)
_ -> empty
in ppLlvmBlockLabel blockId
- $+$ (vcat $ map (ppLlvmStatement platform) block)
+ $+$ (vcat $ map (ppLlvmStatement opts) block)
$+$ newLine
$+$ ppRest
@@ -202,47 +209,55 @@ ppLlvmBlockLabel id = pprUniqueAlways id <> colon
-- | Print out an LLVM statement.
-ppLlvmStatement :: Platform -> LlvmStatement -> SDoc
-ppLlvmStatement platform stmt =
+ppLlvmStatement :: LlvmOpts -> LlvmStatement -> SDoc
+ppLlvmStatement opts stmt =
let ind = (text " " <>)
in case stmt of
- Assignment dst expr -> ind $ ppAssignment dst (ppLlvmExpression platform expr)
+ Assignment dst expr -> ind $ ppAssignment opts dst (ppLlvmExpression opts expr)
Fence st ord -> ind $ ppFence st ord
- Branch target -> ind $ ppBranch target
- BranchIf cond ifT ifF -> ind $ ppBranchIf cond ifT ifF
+ 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 -> ind $ ppStore value ptr
- Switch scrut def tgs -> ind $ ppSwitch scrut def tgs
- Return result -> ind $ ppReturn result
- Expr expr -> ind $ ppLlvmExpression platform expr
+ Store value ptr -> ind $ ppStore opts value ptr
+ Switch scrut def tgs -> ind $ 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 platform meta s
+ MetaStmt meta s -> ppMetaStatement opts meta s
-- | Print out an LLVM expression.
-ppLlvmExpression :: Platform -> LlvmExpression -> SDoc
-ppLlvmExpression platform expr
+ppLlvmExpression :: LlvmOpts -> LlvmExpression -> SDoc
+ppLlvmExpression opts expr
= case expr of
- Alloca tp amount -> ppAlloca tp amount
- LlvmOp op left right -> ppMachOp op left right
- Call tp fp args attrs -> ppCall tp fp (map MetaVar args) attrs
- CallM tp fp args attrs -> ppCall tp fp args attrs
- Cast op from to -> ppCast op from to
- Compare op left right -> ppCmpOp op left right
- Extract vec idx -> ppExtract vec idx
- ExtractV struct idx -> ppExtractV struct idx
- Insert vec elt idx -> ppInsert vec elt idx
- GetElemPtr inb ptr indexes -> ppGetElementPtr inb ptr indexes
- Load ptr -> ppLoad ptr
- ALoad ord st ptr -> ppALoad platform ord st ptr
- Malloc tp amount -> ppMalloc tp amount
- AtomicRMW aop tgt src ordering -> ppAtomicRMW aop tgt src ordering
- CmpXChg addr old new s_ord f_ord -> ppCmpXChg addr old new s_ord f_ord
- Phi tp predecessors -> ppPhi tp predecessors
- Asm asm c ty v se sk -> ppAsm asm c ty v se sk
- MExpr meta expr -> ppMetaExpr platform meta expr
+ Alloca tp amount -> ppAlloca opts tp amount
+ LlvmOp op left right -> ppMachOp opts op left right
+ Call tp fp args attrs -> ppCall opts tp fp (map MetaVar args) attrs
+ CallM tp fp args attrs -> ppCall opts tp fp args attrs
+ Cast op from to -> ppCast opts op from to
+ Compare op left right -> ppCmpOp opts op left right
+ Extract vec idx -> ppExtract opts vec idx
+ ExtractV struct idx -> ppExtractV opts struct idx
+ Insert vec elt idx -> ppInsert opts vec elt idx
+ GetElemPtr inb ptr indexes -> ppGetElementPtr opts inb ptr indexes
+ Load ptr -> ppLoad opts ptr
+ ALoad ord st ptr -> ppALoad opts ord st ptr
+ Malloc tp amount -> ppMalloc opts tp amount
+ AtomicRMW aop tgt src ordering -> ppAtomicRMW opts aop tgt src ordering
+ CmpXChg addr old new s_ord f_ord -> ppCmpXChg opts addr old new s_ord f_ord
+ 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
+
+ppMetaExpr :: LlvmOpts -> MetaExpr -> SDoc
+ppMetaExpr opts = \case
+ MetaVar (LMLitVar (LMNullLit _)) -> text "null"
+ MetaStr s -> char '!' <> doubleQuotes (ftext s)
+ MetaNode n -> ppr n
+ MetaVar v -> ppVar opts v
+ MetaStruct es -> char '!' <> braces (ppCommaJoin (map (ppMetaExpr opts) es))
--------------------------------------------------------------------------------
@@ -251,8 +266,8 @@ ppLlvmExpression platform expr
-- | 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 :: LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc
-ppCall ct fptr args attrs = case fptr of
+ppCall :: LlvmOpts -> LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc
+ppCall opts ct fptr args attrs = case fptr of
--
-- if local var function pointer, unwrap
LMLocalVar _ (LMPointer (LMFunction d)) -> ppCall' d
@@ -269,29 +284,29 @@ ppCall ct fptr args attrs = case fptr of
ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) =
let tc = if ct == TailCall then text "tail " else empty
ppValues = hsep $ punctuate comma $ map ppCallMetaExpr args
- ppArgTy = (ppCommaJoin $ map fst params) <>
+ ppArgTy = (ppCommaJoin $ map (ppr . 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
- <> fnty <+> ppName fptr <> lparen <+> ppValues
+ <> fnty <+> ppName opts fptr <> lparen <+> ppValues
<+> rparen <+> attrDoc
-- Metadata needs to be marked as having the `metadata` type when used
-- in a call argument
- ppCallMetaExpr (MetaVar v) = ppr v
- ppCallMetaExpr v = text "metadata" <+> ppr v
+ ppCallMetaExpr (MetaVar v) = ppVar opts v
+ ppCallMetaExpr v = text "metadata" <+> ppMetaExpr opts v
-ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc
-ppMachOp op left right =
- (ppr op) <+> (ppr (getVarType left)) <+> ppName left
- <> comma <+> ppName right
+ppMachOp :: LlvmOpts -> LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc
+ppMachOp opts op left right =
+ (ppr op) <+> (ppr (getVarType left)) <+> ppName opts left
+ <> comma <+> ppName opts right
-ppCmpOp :: LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc
-ppCmpOp op left right =
+ppCmpOp :: LlvmOpts -> LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc
+ppCmpOp opts op left right =
let cmpOp
| isInt (getVarType left) && isInt (getVarType right) = text "icmp"
| isFloat (getVarType left) && isFloat (getVarType right) = text "fcmp"
@@ -302,11 +317,11 @@ ppCmpOp op left right =
++ (show $ getVarType right))
-}
in cmpOp <+> ppr op <+> ppr (getVarType left)
- <+> ppName left <> comma <+> ppName right
+ <+> ppName opts left <> comma <+> ppName opts right
-ppAssignment :: LlvmVar -> SDoc -> SDoc
-ppAssignment var expr = ppName var <+> equals <+> expr
+ppAssignment :: LlvmOpts -> LlvmVar -> SDoc -> SDoc
+ppAssignment opts var expr = ppName opts var <+> equals <+> expr
ppFence :: Bool -> LlvmSyncOrdering -> SDoc
ppFence st ord =
@@ -335,15 +350,15 @@ ppAtomicOp LAO_Min = text "min"
ppAtomicOp LAO_Umax = text "umax"
ppAtomicOp LAO_Umin = text "umin"
-ppAtomicRMW :: LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc
-ppAtomicRMW aop tgt src ordering =
- text "atomicrmw" <+> ppAtomicOp aop <+> ppr tgt <> comma
- <+> ppr src <+> ppSyncOrdering ordering
+ppAtomicRMW :: LlvmOpts -> LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc
+ppAtomicRMW opts aop tgt src ordering =
+ text "atomicrmw" <+> ppAtomicOp aop <+> ppVar opts tgt <> comma
+ <+> ppVar opts src <+> ppSyncOrdering ordering
-ppCmpXChg :: LlvmVar -> LlvmVar -> LlvmVar
+ppCmpXChg :: LlvmOpts -> LlvmVar -> LlvmVar -> LlvmVar
-> LlvmSyncOrdering -> LlvmSyncOrdering -> SDoc
-ppCmpXChg addr old new s_ord f_ord =
- text "cmpxchg" <+> ppr addr <> comma <+> ppr old <> comma <+> ppr new
+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
-- XXX: On x86, vector types need to be 16-byte aligned for aligned access, but
@@ -354,138 +369,228 @@ ppCmpXChg addr old new s_ord f_ord =
-- access patterns are aligned, in which case we will need a more granular way
-- of specifying alignment.
-ppLoad :: LlvmVar -> SDoc
-ppLoad var = text "load" <+> ppr derefType <> comma <+> ppr var <> align
+ppLoad :: LlvmOpts -> LlvmVar -> SDoc
+ppLoad opts var = text "load" <+> ppr derefType <> comma <+> ppVar opts var <> align
where
derefType = pLower $ getVarType var
align | isVector . pLower . getVarType $ var = text ", align 1"
| otherwise = empty
-ppALoad :: Platform -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc
-ppALoad platform ord st var =
- let alignment = (llvmWidthInBits platform $ getVarType var) `quot` 8
+ppALoad :: LlvmOpts -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc
+ppALoad opts ord st var =
+ let alignment = (llvmWidthInBits (llvmOptsPlatform opts) $ getVarType var) `quot` 8
align = text ", align" <+> ppr alignment
sThreaded | st = text " singlethread"
| otherwise = empty
derefType = pLower $ getVarType var
- in text "load atomic" <+> ppr derefType <> comma <+> ppr var <> sThreaded
+ in text "load atomic" <+> ppr derefType <> comma <+> ppVar opts var <> sThreaded
<+> ppSyncOrdering ord <> align
-ppStore :: LlvmVar -> LlvmVar -> SDoc
-ppStore val dst
- | isVecPtrVar dst = text "store" <+> ppr val <> comma <+> ppr dst <>
+ppStore :: LlvmOpts -> LlvmVar -> LlvmVar -> SDoc
+ppStore opts val dst
+ | isVecPtrVar dst = text "store" <+> ppVar opts val <> comma <+> ppVar opts dst <>
comma <+> text "align 1"
- | otherwise = text "store" <+> ppr val <> comma <+> ppr dst
+ | otherwise = text "store" <+> ppVar opts val <> comma <+> ppVar opts dst
where
isVecPtrVar :: LlvmVar -> Bool
isVecPtrVar = isVector . pLower . getVarType
-ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> SDoc
-ppCast op from to
+ppCast :: LlvmOpts -> LlvmCastOp -> LlvmVar -> LlvmType -> SDoc
+ppCast opts op from to
= ppr op
- <+> ppr (getVarType from) <+> ppName from
+ <+> ppr (getVarType from) <+> ppName opts from
<+> text "to"
<+> ppr to
-ppMalloc :: LlvmType -> Int -> SDoc
-ppMalloc tp amount =
+ppMalloc :: LlvmOpts -> LlvmType -> Int -> SDoc
+ppMalloc opts tp amount =
let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
- in text "malloc" <+> ppr tp <> comma <+> ppr amount'
+ in text "malloc" <+> ppr tp <> comma <+> ppVar opts amount'
-ppAlloca :: LlvmType -> Int -> SDoc
-ppAlloca tp amount =
+ppAlloca :: LlvmOpts -> LlvmType -> Int -> SDoc
+ppAlloca opts tp amount =
let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
- in text "alloca" <+> ppr tp <> comma <+> ppr amount'
+ in text "alloca" <+> ppr tp <> comma <+> ppVar opts amount'
-ppGetElementPtr :: Bool -> LlvmVar -> [LlvmVar] -> SDoc
-ppGetElementPtr inb ptr idx =
- let indexes = comma <+> ppCommaJoin idx
+ppGetElementPtr :: LlvmOpts -> Bool -> LlvmVar -> [LlvmVar] -> SDoc
+ppGetElementPtr opts inb ptr idx =
+ let indexes = comma <+> ppCommaJoin (map (ppVar opts) idx)
inbound = if inb then text "inbounds" else empty
derefType = pLower $ getVarType ptr
- in text "getelementptr" <+> inbound <+> ppr derefType <> comma <+> ppr ptr
+ in text "getelementptr" <+> inbound <+> ppr derefType <> comma <+> ppVar opts ptr
<> indexes
-ppReturn :: Maybe LlvmVar -> SDoc
-ppReturn (Just var) = text "ret" <+> ppr var
-ppReturn Nothing = text "ret" <+> ppr LMVoid
+ppReturn :: LlvmOpts -> Maybe LlvmVar -> SDoc
+ppReturn opts (Just var) = text "ret" <+> ppVar opts var
+ppReturn _ Nothing = text "ret" <+> ppr LMVoid
-ppBranch :: LlvmVar -> SDoc
-ppBranch var = text "br" <+> ppr var
+ppBranch :: LlvmOpts -> LlvmVar -> SDoc
+ppBranch opts var = text "br" <+> ppVar opts var
-ppBranchIf :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc
-ppBranchIf cond trueT falseT
- = text "br" <+> ppr cond <> comma <+> ppr trueT <> comma <+> ppr falseT
+ppBranchIf :: LlvmOpts -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc
+ppBranchIf opts cond trueT falseT
+ = text "br" <+> ppVar opts cond <> comma <+> ppVar opts trueT <> comma <+> ppVar opts falseT
-ppPhi :: LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc
-ppPhi tp preds =
- let ppPreds (val, label) = brackets $ ppName val <> comma <+> ppName label
+ppPhi :: LlvmOpts -> LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc
+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)
-ppSwitch :: LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc
-ppSwitch scrut dflt targets =
- let ppTarget (val, lab) = ppr val <> comma <+> ppr lab
+ppSwitch :: LlvmOpts -> LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc
+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" <+> ppr scrut <> comma <+> ppr dflt
+ in text "switch" <+> ppVar opts scrut <> comma <+> ppVar opts dflt
<+> ppTargets targets
-ppAsm :: LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc
-ppAsm asm constraints rty vars sideeffect alignstack =
+ppAsm :: LlvmOpts -> LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc
+ppAsm opts asm constraints rty vars sideeffect alignstack =
let asm' = doubleQuotes $ ftext asm
cons = doubleQuotes $ ftext constraints
rty' = ppr rty
- vars' = lparen <+> ppCommaJoin vars <+> rparen
+ vars' = lparen <+> ppCommaJoin (map (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'
-ppExtract :: LlvmVar -> LlvmVar -> SDoc
-ppExtract vec idx =
+ppExtract :: LlvmOpts -> LlvmVar -> LlvmVar -> SDoc
+ppExtract opts vec idx =
text "extractelement"
- <+> ppr (getVarType vec) <+> ppName vec <> comma
- <+> ppr idx
+ <+> ppr (getVarType vec) <+> ppName opts vec <> comma
+ <+> ppVar opts idx
-ppExtractV :: LlvmVar -> Int -> SDoc
-ppExtractV struct idx =
+ppExtractV :: LlvmOpts -> LlvmVar -> Int -> SDoc
+ppExtractV opts struct idx =
text "extractvalue"
- <+> ppr (getVarType struct) <+> ppName struct <> comma
+ <+> ppr (getVarType struct) <+> ppName opts struct <> comma
<+> ppr idx
-ppInsert :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc
-ppInsert vec elt idx =
+ppInsert :: LlvmOpts -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc
+ppInsert opts vec elt idx =
text "insertelement"
- <+> ppr (getVarType vec) <+> ppName vec <> comma
- <+> ppr (getVarType elt) <+> ppName elt <> comma
- <+> ppr idx
+ <+> ppr (getVarType vec) <+> ppName opts vec <> comma
+ <+> ppr (getVarType elt) <+> ppName opts elt <> comma
+ <+> ppVar opts idx
-ppMetaStatement :: Platform -> [MetaAnnot] -> LlvmStatement -> SDoc
-ppMetaStatement platform meta stmt =
- ppLlvmStatement platform stmt <> ppMetaAnnots meta
+ppMetaStatement :: LlvmOpts -> [MetaAnnot] -> LlvmStatement -> SDoc
+ppMetaStatement opts meta stmt =
+ ppLlvmStatement opts stmt <> ppMetaAnnots opts meta
-ppMetaExpr :: Platform -> [MetaAnnot] -> LlvmExpression -> SDoc
-ppMetaExpr platform meta expr =
- ppLlvmExpression platform expr <> ppMetaAnnots meta
+ppMetaAnnotExpr :: LlvmOpts -> [MetaAnnot] -> LlvmExpression -> SDoc
+ppMetaAnnotExpr opts meta expr =
+ ppLlvmExpression opts expr <> ppMetaAnnots opts meta
-ppMetaAnnots :: [MetaAnnot] -> SDoc
-ppMetaAnnots meta = hcat $ map ppMeta meta
+ppMetaAnnots :: LlvmOpts -> [MetaAnnot] -> SDoc
+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 ms)
- other -> exclamation <> braces (ppr other) -- possible?
+ MetaStruct ms -> exclamation <> braces (ppCommaJoin (map (ppMetaExpr opts) ms))
+ other -> exclamation <> braces (ppMetaExpr opts other) -- possible?
+
+-- | Return the variable name or value of the 'LlvmVar'
+-- in Llvm IR textual representation (e.g. @\@x@, @%y@ or @42@).
+ppName :: LlvmOpts -> LlvmVar -> SDoc
+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
+
+-- | Return the variable name or value of the 'LlvmVar'
+-- in a plain textual representation (e.g. @x@, @y@ or @42@).
+ppPlainName :: LlvmOpts -> LlvmVar -> SDoc
+ppPlainName opts v = case v of
+ (LMGlobalVar x _ _ _ _ _) -> ftext x
+ (LMLocalVar x LMLabel ) -> text (show x)
+ (LMLocalVar x _ ) -> text ('l' : show x)
+ (LMNLocalVar x _ ) -> ftext x
+ (LMLitVar x ) -> ppLit opts x
+
+-- | Print a literal value. No type.
+ppLit :: LlvmOpts -> LlvmLit -> SDoc
+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)
+ (LMFloatLit r LMFloat ) -> ppFloat (llvmOptsPlatform opts) $ narrowFp r
+ (LMFloatLit r LMDouble) -> ppDouble (llvmOptsPlatform 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 '>'
+ (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 )
+ | llvmOptsFillUndefWithGarbage opts
+ , Just lit <- garbageLit t -> ppLit opts lit
+ | otherwise -> text "undef"
+
+ppVar :: LlvmOpts -> LlvmVar -> SDoc
+ppVar opts v = case v of
+ LMLitVar x -> ppTypeLit opts x
+ x -> ppr (getVarType x) <+> ppName opts x
+
+ppTypeLit :: LlvmOpts -> LlvmLit -> SDoc
+ppTypeLit opts l = case l of
+ LMVectorLit {} -> ppLit opts l
+ _ -> ppr (getLitType l) <+> ppLit opts l
+
+ppStatic :: LlvmOpts -> LlvmStatic -> SDoc
+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 "}>"
+ 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 ')'
+ LMAdd s1 s2 -> pprStaticArith opts s1 s2 (sLit "add") (sLit "fadd") "LMAdd"
+ LMSub s1 s2 -> pprStaticArith opts s1 s2 (sLit "sub") (sLit "fsub") "LMSub"
+
+
+pprSpecialStatic :: LlvmOpts -> LlvmStatic -> SDoc
+pprSpecialStatic opts stat = case stat of
+ LMBitc v t -> ppr (pLower t)
+ <> text ", bitcast ("
+ <> ppStatic opts v <> text " to " <> ppr t
+ <> char ')'
+ LMStaticPointer x -> ppr (pLower $ getVarType x)
+ <> comma <+> ppStatic opts stat
+ _ -> ppStatic opts stat
+
+
+pprStaticArith :: LlvmOpts -> LlvmStatic -> LlvmStatic -> PtrString -> PtrString
+ -> String -> SDoc
+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 <+> ptext op <+> lparen <> ppStatic opts s1 <> comma <> ppStatic opts s2 <> rparen
+ else pprPanic "pprStaticArith" $
+ text op_name <> text " with different types! s1: " <> ppStatic opts s1
+ <> text", s2: " <> ppStatic opts s2
--------------------------------------------------------------------------------
=====================================
compiler/GHC/Llvm/Types.hs
=====================================
@@ -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)
=====================================
libraries/base/System/IO.hs
=====================================
@@ -440,7 +440,10 @@ fixIO k = do
putMVar m result
return result
--- NOTE: we do our own explicit black holing here, because GHC's lazy
+-- Note [Blackholing in fixIO]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- We do our own explicit black holing here, because GHC's lazy
-- blackholing isn't enough. In an infinite loop, GHC may run the IO
-- computation a few times before it notices the loop, which is wrong.
--
=====================================
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
=====================================
@@ -31,9 +31,14 @@ module Language.Haskell.TH.Syntax
import Data.Data hiding (Fixity(..))
import Data.IORef
import System.IO.Unsafe ( unsafePerformIO )
+import GHC.IO.Unsafe ( unsafeDupableInterleaveIO )
import Control.Monad (liftM)
import Control.Monad.IO.Class (MonadIO (..))
+import Control.Monad.Fix (MonadFix (..))
import Control.Applicative (liftA2)
+import Control.Exception (BlockedIndefinitelyOnMVar (..), catch, throwIO)
+import Control.Exception.Base (FixIOException (..))
+import Control.Concurrent.MVar (newEmptyMVar, readMVar, putMVar)
import System.IO ( hPutStrLn, stderr )
import Data.Char ( isAlpha, isAlphaNum, isUpper, ord )
import Data.Int
@@ -215,6 +220,23 @@ instance Semigroup a => Semigroup (Q a) where
instance Monoid a => Monoid (Q a) where
mempty = pure mempty
+-- | If the function passed to 'mfix' inspects its argument,
+-- the resulting action will throw a 'FixIOException'.
+--
+-- @since 2.17.0.0
+instance MonadFix Q where
+ -- We use the same blackholing approach as in fixIO.
+ -- See Note [Blackholing in fixIO] in System.IO in base.
+ mfix k = do
+ m <- runIO newEmptyMVar
+ ans <- runIO (unsafeDupableInterleaveIO
+ (readMVar m `catch` \BlockedIndefinitelyOnMVar ->
+ throwIO FixIOException))
+ result <- k ans
+ runIO (putMVar m result)
+ return result
+
+
-----------------------------------------------------
--
-- The Quote class
=====================================
libraries/template-haskell/changelog.md
=====================================
@@ -24,6 +24,8 @@
* Add `Semigroup` and `Monoid` instances for `Q` (#18123).
+ * Add `MonadFix` instance for `Q` (#12073).
+
## 2.16.0.0 *TBA*
* Add support for tuple sections. (#15843) The type signatures of `TupE` and
=====================================
testsuite/tests/perf/compiler/T12150.hs
=====================================
@@ -8,6 +8,9 @@ data Result a = Success a | Error String
ghc-7.10.3 -O : 0.3s
ghc-8.0.1 -O : 1.8s
+
+ Increased to 450 guards in June 2020, along with increasing size of
+ acceptance threshold. 0.4s compile time
-}
instance Functor Result where
@@ -100,6 +103,413 @@ instance Functor Result where
| bool = f
| bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+ | bool = f
+
where
bool = undefined
f = undefined
=====================================
testsuite/tests/perf/compiler/all.T
=====================================
@@ -350,7 +350,10 @@ test ('WWRec',
['-v0 -O'])
test('T16190',
- [req_th, collect_compiler_stats()],
+ [ req_th,
+ unless(have_ncg(), skip), # T16190 tests a NCG feature
+ collect_compiler_stats()
+ ],
multimod_compile,
['T16190.hs', '-v0'])
=====================================
testsuite/tests/th/T12073.hs
=====================================
@@ -0,0 +1,33 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Main where
+
+import Control.Monad.Fix
+import Language.Haskell.TH
+import Control.Monad.State
+
+-- Direct variant
+$([d|
+ f1, f2 :: Integer -> [Integer]
+ f1 = \z -> z : f2 (succ z)
+ f2 = \z -> z : f1 (z * z)
+ |])
+
+-- Using mfix.
+-- This is a contrived example, but it fits into a single splice
+$(fmap (\(x,x',y,y') ->
+ [ ValD (VarP x') (NormalB x) []
+ , ValD (VarP y') (NormalB y) []
+ ]) $
+ mfix $ \ ~(_,x',_,y') -> do
+ x <- [| \z -> z : $(return $ VarE y') (succ z) |]
+ y <- [| \z -> z : $(return $ VarE x') (z * z) |]
+ x'' <- newName "g1"
+ y'' <- newName "g2"
+ return (x, x'', y, y'')
+ )
+
+
+main :: IO ()
+main = do
+ print $ take 11 $ f1 0
+ print $ take 11 $ g1 0
=====================================
testsuite/tests/th/T12073.stdout
=====================================
@@ -0,0 +1,2 @@
+[0,1,1,2,4,5,25,26,676,677,458329]
+[0,1,1,2,4,5,25,26,676,677,458329]
=====================================
testsuite/tests/th/all.T
=====================================
@@ -364,6 +364,7 @@ test('T11629', normal, compile, ['-v0'])
test('T8761', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
test('T12045TH1', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
test('T12045TH2', normal, compile, ['-v0'])
+test('T12073', normal, compile_and_run, [''])
test('T12130', [], multimod_compile,
['T12130', '-v0 ' + config.ghc_th_way_flags])
test('T12387', normal, compile_fail, ['-v0'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f8fdece08332c8744fa85cdbddf8b2ae06ada4e9...afe64084109ea50ff3d893c84327bc5c60e10866
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f8fdece08332c8744fa85cdbddf8b2ae06ada4e9...afe64084109ea50ff3d893c84327bc5c60e10866
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200611/93b2b020/attachment-0001.html>
More information about the ghc-commits
mailing list