[Git][ghc/ghc][master] 6 commits: Use ParserFlags in GHC.Runtime.Eval (#17957)
Marge Bot
gitlab at gitlab.haskell.org
Tue Apr 21 10:39:54 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
6655f933 by Sylvain Henry at 2020-04-21T06:39:32-04:00
Use ParserFlags in GHC.Runtime.Eval (#17957)
Instead of passing `DynFlags` to functions such as `isStmt` and
`hasImport` in `GHC.Runtime.Eval` we pass `ParserFlags`. It's a much
simpler structure that can be created purely with `mkParserFlags'`.
- - - - -
70be0fbc by Sylvain Henry at 2020-04-21T06:39:32-04:00
GHC.Runtime: avoid DynFlags (#17957)
* add `getPlatform :: TcM Platform` helper
* remove unused `DynFlags` parameter from `emptyPLS`
- - - - -
35e43d48 by Sylvain Henry at 2020-04-21T06:39:32-04:00
Avoid DynFlags in Ppr code (#17957)
* replace `DynFlags` parameters with `SDocContext` parameters for a few
Ppr related functions: `bufLeftRenderSDoc`, `printSDoc`,
`printSDocLn`, `showSDocOneLine`.
* remove the use of `pprCols :: DynFlags -> Int` in Outputable. We
already have the information via `sdocLineLength :: SDocContext ->
Int`
- - - - -
ce5c2999 by Sylvain Henry at 2020-04-21T06:39:32-04:00
Avoid using sdocWithDynFlags (#17957)
Remove one use of `sdocWithDynFlags` from `GHC.CmmToLlvm.llvmCodeGen'`
and from `GHC.Driver.CodeOutput.profilingInitCode`
- - - - -
f2a98996 by Sylvain Henry at 2020-04-21T06:39:32-04:00
Avoid `sdocWithDynFlags` in `pprCLbl` (#17957)
* add a `DynFlags` parameter to `pprCLbl`
* put `maybe_underscore` and `pprAsmCLbl` in a `where` clause to avoid
`DynFlags` parameters
- - - - -
747093b7 by Sylvain Henry at 2020-04-21T06:39:32-04:00
CmmToAsm DynFlags refactoring (#17957)
* Remove `DynFlags` parameter from `isDynLinkName`: `isDynLinkName` used
to test the global `ExternalDynamicRefs` flag. Now we test it outside of
`isDynLinkName`
* Add new fields into `NCGConfig`: current unit id, sse/bmi versions,
externalDynamicRefs, etc.
* Replace many uses of `DynFlags` by `NCGConfig`
* Moved `BMI/SSE` datatypes into `GHC.Platform`
- - - - -
28 changed files:
- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/Cmm/Info/Build.hs
- compiler/GHC/CmmToAsm.hs
- compiler/GHC/CmmToAsm/Config.hs
- compiler/GHC/CmmToAsm/Monad.hs
- compiler/GHC/CmmToAsm/PIC.hs
- compiler/GHC/CmmToAsm/PPC/CodeGen.hs
- compiler/GHC/CmmToAsm/SPARC/CodeGen.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/CmmToLlvm.hs
- compiler/GHC/CmmToLlvm/Base.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Packages.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Driver/Session.hs-boot
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Runtime/Heap/Inspect.hs
- compiler/GHC/Runtime/Linker.hs
- compiler/GHC/Stg/Syntax.hs
- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/Tc/Types.hs
- compiler/main/ErrUtils.hs
- compiler/utils/Outputable.hs
- ghc/GHCi/UI.hs
- libraries/ghc-boot/GHC/Platform.hs
- testsuite/tests/ghc-api/T9015.hs
- testsuite/tests/regalloc/regalloc_unit_tests.hs
Changes:
=====================================
compiler/GHC/Cmm/CLabel.hs
=====================================
@@ -8,6 +8,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
module GHC.Cmm.CLabel (
CLabel, -- abstract type
@@ -131,6 +132,7 @@ import GHC.Platform
import GHC.Types.Unique.Set
import Util
import GHC.Core.Ppr ( {- instances -} )
+import GHC.CmmToAsm.Config
-- -----------------------------------------------------------------------------
-- The CLabel type
@@ -1026,23 +1028,21 @@ isLocalCLabel this_mod lbl =
-- that data resides in a DLL or not. [Win32 only.]
-- @labelDynamic@ returns @True@ if the label is located
-- in a DLL, be it a data reference or not.
-labelDynamic :: DynFlags -> Module -> CLabel -> Bool
-labelDynamic dflags this_mod lbl =
+labelDynamic :: NCGConfig -> Module -> CLabel -> Bool
+labelDynamic config this_mod lbl =
case lbl of
-- is the RTS in a DLL or not?
RtsLabel _ ->
externalDynamicRefs && (this_pkg /= rtsUnitId)
IdLabel n _ _ ->
- isDynLinkName dflags this_mod n
+ externalDynamicRefs && isDynLinkName platform this_mod n
-- When compiling in the "dyn" way, each package is to be linked into
-- its own shared library.
CmmLabel pkg _ _
- | os == OSMinGW32 ->
- externalDynamicRefs && (this_pkg /= pkg)
- | otherwise ->
- gopt Opt_ExternalDynamicRefs dflags
+ | os == OSMinGW32 -> externalDynamicRefs && (this_pkg /= pkg)
+ | otherwise -> externalDynamicRefs
LocalBlockLabel _ -> False
@@ -1079,8 +1079,9 @@ labelDynamic dflags this_mod lbl =
-- Note that DynamicLinkerLabels do NOT require dynamic linking themselves.
_ -> False
where
- externalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags
- os = platformOS (targetPlatform dflags)
+ externalDynamicRefs = ncgExternalDynamicRefs config
+ platform = ncgPlatform config
+ os = platformOS platform
this_pkg = moduleUnitId this_mod
@@ -1168,93 +1169,85 @@ instance Outputable CLabel where
ppr c = sdocWithDynFlags $ \dynFlags -> pprCLabel dynFlags c
pprCLabel :: DynFlags -> CLabel -> SDoc
+pprCLabel dflags = \case
+ (LocalBlockLabel u) -> tempLabelPrefixOrUnderscore <> pprUniqueAlways u
+
+ (AsmTempLabel u)
+ | not (platformUnregisterised platform)
+ -> tempLabelPrefixOrUnderscore <> pprUniqueAlways u
+
+ (AsmTempDerivedLabel l suf)
+ | useNCG
+ -> ptext (asmTempLabelPrefix platform)
+ <> case l of AsmTempLabel u -> pprUniqueAlways u
+ LocalBlockLabel u -> pprUniqueAlways u
+ _other -> pprCLabel dflags l
+ <> ftext suf
+
+ (DynamicLinkerLabel info lbl)
+ | useNCG
+ -> pprDynamicLinkerAsmLabel platform info lbl
+
+ PicBaseLabel
+ | useNCG
+ -> text "1b"
+
+ (DeadStripPreventer lbl)
+ | useNCG
+ ->
+ {-
+ `lbl` can be temp one but we need to ensure that dsp label will stay
+ in the final binary so we prepend non-temp prefix ("dsp_") and
+ optional `_` (underscore) because this is how you mark non-temp symbols
+ on some platforms (Darwin)
+ -}
+ maybe_underscore $ text "dsp_" <> pprCLabel dflags lbl <> text "_dsp"
+
+ (StringLitLabel u)
+ | useNCG
+ -> pprUniqueAlways u <> ptext (sLit "_str")
+
+ lbl -> getPprStyle $ \sty ->
+ if useNCG && asmStyle sty
+ then maybe_underscore $ pprAsmCLbl lbl
+ else pprCLbl dflags lbl
-pprCLabel _ (LocalBlockLabel u)
- = tempLabelPrefixOrUnderscore <> pprUniqueAlways u
-
-pprCLabel dynFlags (AsmTempLabel u)
- | not (platformUnregisterised $ targetPlatform dynFlags)
- = tempLabelPrefixOrUnderscore <> pprUniqueAlways u
-
-pprCLabel dynFlags (AsmTempDerivedLabel l suf)
- | platformMisc_ghcWithNativeCodeGen $ platformMisc dynFlags
- = ptext (asmTempLabelPrefix $ targetPlatform dynFlags)
- <> case l of AsmTempLabel u -> pprUniqueAlways u
- LocalBlockLabel u -> pprUniqueAlways u
- _other -> pprCLabel dynFlags l
- <> ftext suf
-
-pprCLabel dynFlags (DynamicLinkerLabel info lbl)
- | platformMisc_ghcWithNativeCodeGen $ platformMisc dynFlags
- = pprDynamicLinkerAsmLabel (targetPlatform dynFlags) info lbl
-
-pprCLabel dynFlags PicBaseLabel
- | platformMisc_ghcWithNativeCodeGen $ platformMisc dynFlags
- = text "1b"
-
-pprCLabel dynFlags (DeadStripPreventer lbl)
- | platformMisc_ghcWithNativeCodeGen $ platformMisc dynFlags
- =
- {-
- `lbl` can be temp one but we need to ensure that dsp label will stay
- in the final binary so we prepend non-temp prefix ("dsp_") and
- optional `_` (underscore) because this is how you mark non-temp symbols
- on some platforms (Darwin)
- -}
- maybe_underscore dynFlags $ text "dsp_"
- <> pprCLabel dynFlags lbl <> text "_dsp"
-
-pprCLabel dynFlags (StringLitLabel u)
- | platformMisc_ghcWithNativeCodeGen $ platformMisc dynFlags
- = pprUniqueAlways u <> ptext (sLit "_str")
-
-pprCLabel dynFlags lbl
- = getPprStyle $ \ sty ->
- if platformMisc_ghcWithNativeCodeGen (platformMisc dynFlags) && asmStyle sty
- then maybe_underscore dynFlags $ pprAsmCLbl (targetPlatform dynFlags) lbl
- else pprCLbl lbl
-
-maybe_underscore :: DynFlags -> SDoc -> SDoc
-maybe_underscore dynFlags doc =
- if platformMisc_leadingUnderscore $ platformMisc dynFlags
- then pp_cSEP <> doc
- else doc
-
-pprAsmCLbl :: Platform -> CLabel -> SDoc
-pprAsmCLbl platform (ForeignLabel fs (Just sz) _ _)
- | platformOS platform == OSMinGW32
- -- In asm mode, we need to put the suffix on a stdcall ForeignLabel.
- -- (The C compiler does this itself).
- = ftext fs <> char '@' <> int sz
-pprAsmCLbl _ lbl
- = pprCLbl lbl
-
-pprCLbl :: CLabel -> SDoc
-pprCLbl (StringLitLabel u)
- = pprUniqueAlways u <> text "_str"
-
-pprCLbl (SRTLabel u)
- = tempLabelPrefixOrUnderscore <> pprUniqueAlways u <> pp_cSEP <> text "srt"
-
-pprCLbl (LargeBitmapLabel u) =
- tempLabelPrefixOrUnderscore
- <> char 'b' <> pprUniqueAlways u <> pp_cSEP <> text "btm"
--- Some bitsmaps for tuple constructors have a numeric tag (e.g. '7')
--- until that gets resolved we'll just force them to start
--- with a letter so the label will be legal assembly code.
-
-
-pprCLbl (CmmLabel _ str CmmCode) = ftext str
-pprCLbl (CmmLabel _ str CmmData) = ftext str
-pprCLbl (CmmLabel _ str CmmPrimCall) = ftext str
-
-pprCLbl (LocalBlockLabel u) =
- tempLabelPrefixOrUnderscore <> text "blk_" <> pprUniqueAlways u
-
-pprCLbl (RtsLabel (RtsApFast str)) = ftext str <> text "_fast"
-
-pprCLbl (RtsLabel (RtsSelectorInfoTable upd_reqd offset))
- = sdocWithDynFlags $ \dflags ->
+ where
+ platform = targetPlatform dflags
+ useNCG = platformMisc_ghcWithNativeCodeGen (platformMisc dflags)
+
+ maybe_underscore :: SDoc -> SDoc
+ maybe_underscore doc =
+ if platformMisc_leadingUnderscore $ platformMisc dflags
+ then pp_cSEP <> doc
+ else doc
+
+ pprAsmCLbl (ForeignLabel fs (Just sz) _ _)
+ | platformOS platform == OSMinGW32
+ -- In asm mode, we need to put the suffix on a stdcall ForeignLabel.
+ -- (The C compiler does this itself).
+ = ftext fs <> char '@' <> int sz
+ pprAsmCLbl lbl = pprCLbl dflags lbl
+
+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
+ <> 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
+ -- with a letter so the label will be legal assembly code.
+
+ (CmmLabel _ str CmmCode) -> ftext str
+ (CmmLabel _ str CmmData) -> ftext str
+ (CmmLabel _ str CmmPrimCall) -> ftext str
+
+ (LocalBlockLabel u) -> tempLabelPrefixOrUnderscore <> text "blk_" <> pprUniqueAlways u
+
+ (RtsLabel (RtsApFast str)) -> ftext str <> text "_fast"
+
+ (RtsLabel (RtsSelectorInfoTable upd_reqd offset)) ->
ASSERT(offset >= 0 && offset <= mAX_SPEC_SELECTEE_SIZE dflags)
hcat [text "stg_sel_", text (show offset),
ptext (if upd_reqd
@@ -1262,8 +1255,7 @@ pprCLbl (RtsLabel (RtsSelectorInfoTable upd_reqd offset))
else (sLit "_noupd_info"))
]
-pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset))
- = sdocWithDynFlags $ \dflags ->
+ (RtsLabel (RtsSelectorEntry upd_reqd offset)) ->
ASSERT(offset >= 0 && offset <= mAX_SPEC_SELECTEE_SIZE dflags)
hcat [text "stg_sel_", text (show offset),
ptext (if upd_reqd
@@ -1271,8 +1263,7 @@ pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset))
else (sLit "_noupd_entry"))
]
-pprCLbl (RtsLabel (RtsApInfoTable upd_reqd arity))
- = sdocWithDynFlags $ \dflags ->
+ (RtsLabel (RtsApInfoTable upd_reqd arity)) ->
ASSERT(arity > 0 && arity <= mAX_SPEC_AP_SIZE dflags)
hcat [text "stg_ap_", text (show arity),
ptext (if upd_reqd
@@ -1280,8 +1271,7 @@ pprCLbl (RtsLabel (RtsApInfoTable upd_reqd arity))
else (sLit "_noupd_info"))
]
-pprCLbl (RtsLabel (RtsApEntry upd_reqd arity))
- = sdocWithDynFlags $ \dflags ->
+ (RtsLabel (RtsApEntry upd_reqd arity)) ->
ASSERT(arity > 0 && arity <= mAX_SPEC_AP_SIZE dflags)
hcat [text "stg_ap_", text (show arity),
ptext (if upd_reqd
@@ -1289,44 +1279,29 @@ pprCLbl (RtsLabel (RtsApEntry upd_reqd arity))
else (sLit "_noupd_entry"))
]
-pprCLbl (CmmLabel _ fs CmmInfo)
- = ftext fs <> text "_info"
-
-pprCLbl (CmmLabel _ fs CmmEntry)
- = ftext fs <> text "_entry"
-
-pprCLbl (CmmLabel _ fs CmmRetInfo)
- = ftext fs <> text "_info"
-
-pprCLbl (CmmLabel _ fs CmmRet)
- = ftext fs <> text "_ret"
-
-pprCLbl (CmmLabel _ fs CmmClosure)
- = ftext fs <> text "_closure"
-
-pprCLbl (RtsLabel (RtsPrimOp primop))
- = text "stg_" <> ppr primop
-
-pprCLbl (RtsLabel (RtsSlowFastTickyCtr pat))
- = text "SLOW_CALL_fast_" <> text pat <> ptext (sLit "_ctr")
+ (CmmLabel _ fs CmmInfo) -> ftext fs <> text "_info"
+ (CmmLabel _ fs CmmEntry) -> ftext fs <> text "_entry"
+ (CmmLabel _ fs CmmRetInfo) -> ftext fs <> text "_info"
+ (CmmLabel _ fs CmmRet) -> ftext fs <> text "_ret"
+ (CmmLabel _ fs CmmClosure) -> ftext fs <> text "_closure"
-pprCLbl (ForeignLabel str _ _ _)
- = ftext str
+ (RtsLabel (RtsPrimOp primop)) -> text "stg_" <> ppr primop
+ (RtsLabel (RtsSlowFastTickyCtr pat)) ->
+ text "SLOW_CALL_fast_" <> text pat <> ptext (sLit "_ctr")
-pprCLbl (IdLabel name _cafs flavor) =
- internalNamePrefix name <> ppr name <> ppIdFlavor flavor
+ (ForeignLabel str _ _ _) -> ftext str
-pprCLbl (CC_Label cc) = ppr cc
-pprCLbl (CCS_Label ccs) = ppr ccs
+ (IdLabel name _cafs flavor) -> internalNamePrefix name <> ppr name <> ppIdFlavor flavor
-pprCLbl (HpcTicksLabel mod)
- = text "_hpc_tickboxes_" <> ppr mod <> ptext (sLit "_hpc")
+ (CC_Label cc) -> ppr cc
+ (CCS_Label ccs) -> ppr ccs
+ (HpcTicksLabel mod) -> text "_hpc_tickboxes_" <> ppr mod <> ptext (sLit "_hpc")
-pprCLbl (AsmTempLabel {}) = panic "pprCLbl AsmTempLabel"
-pprCLbl (AsmTempDerivedLabel {})= panic "pprCLbl AsmTempDerivedLabel"
-pprCLbl (DynamicLinkerLabel {}) = panic "pprCLbl DynamicLinkerLabel"
-pprCLbl (PicBaseLabel {}) = panic "pprCLbl PicBaseLabel"
-pprCLbl (DeadStripPreventer {}) = panic "pprCLbl DeadStripPreventer"
+ (AsmTempLabel {}) -> panic "pprCLbl AsmTempLabel"
+ (AsmTempDerivedLabel {}) -> panic "pprCLbl AsmTempDerivedLabel"
+ (DynamicLinkerLabel {}) -> panic "pprCLbl DynamicLinkerLabel"
+ (PicBaseLabel {}) -> panic "pprCLbl PicBaseLabel"
+ (DeadStripPreventer {}) -> panic "pprCLbl DeadStripPreventer"
ppIdFlavor :: IdLabelInfo -> SDoc
ppIdFlavor x = pp_cSEP <> text
=====================================
compiler/GHC/Cmm/Info/Build.hs
=====================================
@@ -31,6 +31,8 @@ import GHC.Runtime.Heap.Layout
import GHC.Types.Unique.Supply
import GHC.Types.CostCentre
import GHC.StgToCmm.Heap
+import GHC.CmmToAsm.Monad
+import GHC.CmmToAsm.Config
import Control.Monad
import Data.Map.Strict (Map)
@@ -925,6 +927,7 @@ oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data = do
topSRT <- get
let
+ config = initConfig dflags
srtMap = moduleSRTMap topSRT
blockids = getBlockLabels lbls
@@ -1024,11 +1027,11 @@ oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data = do
-- when dynamic linking is used we cannot guarantee that the offset
-- between the SRT and the info table will fit in the offset field.
-- Consequently we build a singleton SRT in in this case.
- not (labelDynamic dflags this_mod lbl)
+ not (labelDynamic config this_mod lbl)
-- MachO relocations can't express offsets between compilation units at
-- all, so we are always forced to build a singleton SRT in this case.
- && (not (osMachOTarget $ platformOS $ targetPlatform dflags)
+ && (not (osMachOTarget $ platformOS $ ncgPlatform config)
|| isLocalCLabel this_mod lbl) -> do
-- If we have a static function closure, then it becomes the
=====================================
compiler/GHC/CmmToAsm.hs
=====================================
@@ -162,35 +162,36 @@ nativeCodeGen :: forall a . DynFlags -> Module -> ModLocation -> Handle -> UniqS
-> Stream IO RawCmmGroup a
-> IO a
nativeCodeGen dflags this_mod modLoc h us cmms
- = let platform = targetPlatform dflags
+ = let config = initConfig dflags
+ platform = ncgPlatform config
nCG' :: ( Outputable statics, Outputable instr
, Outputable jumpDest, Instruction instr)
=> NcgImpl statics instr jumpDest -> IO a
nCG' ncgImpl = nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms
in case platformArch platform of
- ArchX86 -> nCG' (x86NcgImpl dflags)
- ArchX86_64 -> nCG' (x86_64NcgImpl dflags)
- ArchPPC -> nCG' (ppcNcgImpl dflags)
+ ArchX86 -> nCG' (x86NcgImpl config)
+ ArchX86_64 -> nCG' (x86_64NcgImpl config)
+ ArchPPC -> nCG' (ppcNcgImpl config)
ArchS390X -> panic "nativeCodeGen: No NCG for S390X"
- ArchSPARC -> nCG' (sparcNcgImpl dflags)
+ ArchSPARC -> nCG' (sparcNcgImpl config)
ArchSPARC64 -> panic "nativeCodeGen: No NCG for SPARC64"
ArchARM {} -> panic "nativeCodeGen: No NCG for ARM"
ArchARM64 -> panic "nativeCodeGen: No NCG for ARM64"
- ArchPPC_64 _ -> nCG' (ppcNcgImpl dflags)
+ ArchPPC_64 _ -> nCG' (ppcNcgImpl config)
ArchAlpha -> panic "nativeCodeGen: No NCG for Alpha"
ArchMipseb -> panic "nativeCodeGen: No NCG for mipseb"
ArchMipsel -> panic "nativeCodeGen: No NCG for mipsel"
ArchUnknown -> panic "nativeCodeGen: No NCG for unknown arch"
ArchJavaScript-> panic "nativeCodeGen: No NCG for JavaScript"
-x86NcgImpl :: DynFlags -> NcgImpl (Alignment, RawCmmStatics)
+x86NcgImpl :: NCGConfig -> NcgImpl (Alignment, RawCmmStatics)
X86.Instr.Instr X86.Instr.JumpDest
-x86NcgImpl dflags
- = (x86_64NcgImpl dflags)
+x86NcgImpl config
+ = (x86_64NcgImpl config)
-x86_64NcgImpl :: DynFlags -> NcgImpl (Alignment, RawCmmStatics)
+x86_64NcgImpl :: NCGConfig -> NcgImpl (Alignment, RawCmmStatics)
X86.Instr.Instr X86.Instr.JumpDest
-x86_64NcgImpl dflags
+x86_64NcgImpl config
= NcgImpl {
ncgConfig = config
,cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen
@@ -209,11 +210,10 @@ x86_64NcgImpl dflags
,invertCondBranches = X86.CodeGen.invertCondBranches
}
where
- config = initConfig dflags
platform = ncgPlatform config
-ppcNcgImpl :: DynFlags -> NcgImpl RawCmmStatics PPC.Instr.Instr PPC.RegInfo.JumpDest
-ppcNcgImpl dflags
+ppcNcgImpl :: NCGConfig -> NcgImpl RawCmmStatics PPC.Instr.Instr PPC.RegInfo.JumpDest
+ppcNcgImpl config
= NcgImpl {
ncgConfig = config
,cmmTopCodeGen = PPC.CodeGen.cmmTopCodeGen
@@ -232,11 +232,10 @@ ppcNcgImpl dflags
,invertCondBranches = \_ _ -> id
}
where
- config = initConfig dflags
platform = ncgPlatform config
-sparcNcgImpl :: DynFlags -> NcgImpl RawCmmStatics SPARC.Instr.Instr SPARC.ShortcutJump.JumpDest
-sparcNcgImpl dflags
+sparcNcgImpl :: NCGConfig -> NcgImpl RawCmmStatics SPARC.Instr.Instr SPARC.ShortcutJump.JumpDest
+sparcNcgImpl config
= NcgImpl {
ncgConfig = config
,cmmTopCodeGen = SPARC.CodeGen.cmmTopCodeGen
@@ -255,7 +254,6 @@ sparcNcgImpl dflags
,invertCondBranches = \_ _ -> id
}
where
- config = initConfig dflags
platform = ncgPlatform config
--
@@ -387,7 +385,8 @@ finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs
dump_stats (Linear.pprStats (concat (ngs_natives ngs)) linearStats)
-- write out the imports
- printSDocLn Pretty.LeftMode dflags h (mkCodeStyle AsmStyle)
+ let ctx = initSDocContext dflags (mkCodeStyle AsmStyle)
+ printSDocLn ctx Pretty.LeftMode h
$ makeImportsDoc dflags (concat (ngs_imports ngs))
return us'
where
@@ -516,8 +515,8 @@ cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap = go
emitNativeCode :: DynFlags -> BufHandle -> SDoc -> IO ()
emitNativeCode dflags h sdoc = do
- {-# SCC "pprNativeCode" #-} bufLeftRenderSDoc dflags h
- (mkCodeStyle AsmStyle) sdoc
+ let ctx = initSDocContext dflags (mkCodeStyle AsmStyle)
+ {-# SCC "pprNativeCode" #-} bufLeftRenderSDoc ctx h sdoc
-- dump native code
dumpIfSet_dyn dflags
@@ -564,7 +563,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
-- cmm to cmm optimisations
let (opt_cmm, imports) =
{-# SCC "cmmToCmm" #-}
- cmmToCmm dflags this_mod fixed_cmm
+ cmmToCmm config this_mod fixed_cmm
dumpIfSet_dyn dflags
Opt_D_dump_opt_cmm "Optimised Cmm" FormatCMM
@@ -1066,10 +1065,10 @@ Ideas for other things we could do (put these in Hoopl please!):
temp assignments, and certain assigns to mem...)
-}
-cmmToCmm :: DynFlags -> Module -> RawCmmDecl -> (RawCmmDecl, [CLabel])
+cmmToCmm :: NCGConfig -> Module -> RawCmmDecl -> (RawCmmDecl, [CLabel])
cmmToCmm _ _ top@(CmmData _ _) = (top, [])
-cmmToCmm dflags this_mod (CmmProc info lbl live graph)
- = runCmmOpt dflags this_mod $
+cmmToCmm config this_mod (CmmProc info lbl live graph)
+ = runCmmOpt config this_mod $
do blocks' <- mapM cmmBlockConFold (toBlockList graph)
return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks')
@@ -1086,7 +1085,7 @@ pattern OptMResult x y = (# x, y #)
data OptMResult a = OptMResult !a ![CLabel] deriving (Functor)
#endif
-newtype CmmOptM a = CmmOptM (DynFlags -> Module -> [CLabel] -> OptMResult a)
+newtype CmmOptM a = CmmOptM (NCGConfig -> Module -> [CLabel] -> OptMResult a)
deriving (Functor)
instance Applicative CmmOptM where
@@ -1095,11 +1094,11 @@ instance Applicative CmmOptM where
instance Monad CmmOptM where
(CmmOptM f) >>= g =
- CmmOptM $ \dflags this_mod imports0 ->
- case f dflags this_mod imports0 of
+ CmmOptM $ \config this_mod imports0 ->
+ case f config this_mod imports0 of
OptMResult x imports1 ->
case g x of
- CmmOptM g' -> g' dflags this_mod imports1
+ CmmOptM g' -> g' config this_mod imports1
instance CmmMakeDynamicReferenceM CmmOptM where
addImport = addImportCmmOpt
@@ -1108,12 +1107,12 @@ instance CmmMakeDynamicReferenceM CmmOptM where
addImportCmmOpt :: CLabel -> CmmOptM ()
addImportCmmOpt lbl = CmmOptM $ \_ _ imports -> OptMResult () (lbl:imports)
-instance HasDynFlags CmmOptM where
- getDynFlags = CmmOptM $ \dflags _ imports -> OptMResult dflags imports
+getCmmOptConfig :: CmmOptM NCGConfig
+getCmmOptConfig = CmmOptM $ \config _ imports -> OptMResult config imports
-runCmmOpt :: DynFlags -> Module -> CmmOptM a -> (a, [CLabel])
-runCmmOpt dflags this_mod (CmmOptM f) =
- case f dflags this_mod [] of
+runCmmOpt :: NCGConfig -> Module -> CmmOptM a -> (a, [CLabel])
+runCmmOpt config this_mod (CmmOptM f) =
+ case f config this_mod [] of
OptMResult result imports -> (result, imports)
cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock
@@ -1177,29 +1176,26 @@ cmmStmtConFold stmt
cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold referenceKind expr = do
- dflags <- getDynFlags
+ config <- getCmmOptConfig
- -- With -O1 and greater, the cmmSink pass does constant-folding, so
- -- we don't need to do it again here.
- let expr' = if optLevel dflags >= 1
+ let expr' = if not (ncgDoConstantFolding config)
then expr
- else cmmExprCon dflags expr
+ else cmmExprCon config expr
cmmExprNative referenceKind expr'
-cmmExprCon :: DynFlags -> CmmExpr -> CmmExpr
-cmmExprCon dflags (CmmLoad addr rep) = CmmLoad (cmmExprCon dflags addr) rep
-cmmExprCon dflags (CmmMachOp mop args)
- = cmmMachOpFold platform mop (map (cmmExprCon dflags) args)
- where platform = targetPlatform dflags
+cmmExprCon :: NCGConfig -> CmmExpr -> CmmExpr
+cmmExprCon config (CmmLoad addr rep) = CmmLoad (cmmExprCon config addr) rep
+cmmExprCon config (CmmMachOp mop args)
+ = cmmMachOpFold (ncgPlatform config) mop (map (cmmExprCon config) args)
cmmExprCon _ other = other
-- handles both PIC and non-PIC cases... a very strange mixture
-- of things to do.
cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprNative referenceKind expr = do
- dflags <- getDynFlags
- let platform = targetPlatform dflags
+ config <- getCmmOptConfig
+ let platform = ncgPlatform config
arch = platformArch platform
case expr of
CmmLoad addr rep
@@ -1218,10 +1214,10 @@ cmmExprNative referenceKind expr = do
CmmLit (CmmLabel lbl)
-> do
- cmmMakeDynamicReference dflags referenceKind lbl
+ cmmMakeDynamicReference config referenceKind lbl
CmmLit (CmmLabelOff lbl off)
-> do
- dynRef <- cmmMakeDynamicReference dflags referenceKind lbl
+ dynRef <- cmmMakeDynamicReference config referenceKind lbl
-- need to optimize here, since it's late
return $ cmmMachOpFold platform (MO_Add (wordWidth platform)) [
dynRef,
@@ -1232,15 +1228,15 @@ cmmExprNative referenceKind expr = do
-- to use the register table, so we replace these registers
-- with the corresponding labels:
CmmReg (CmmGlobal EagerBlackholeInfo)
- | arch == ArchPPC && not (positionIndependent dflags)
+ | arch == ArchPPC && not (ncgPIC config)
-> cmmExprNative referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_EAGER_BLACKHOLE_info")))
CmmReg (CmmGlobal GCEnter1)
- | arch == ArchPPC && not (positionIndependent dflags)
+ | arch == ArchPPC && not (ncgPIC config)
-> cmmExprNative referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_enter_1")))
CmmReg (CmmGlobal GCFun)
- | arch == ArchPPC && not (positionIndependent dflags)
+ | arch == ArchPPC && not (ncgPIC config)
-> cmmExprNative referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_fun")))
=====================================
compiler/GHC/CmmToAsm/Config.hs
=====================================
@@ -9,21 +9,28 @@ where
import GhcPrelude
import GHC.Platform
import GHC.Cmm.Type (Width(..))
+import GHC.Types.Module
-- | Native code generator configuration
data NCGConfig = NCGConfig
- { ncgPlatform :: !Platform -- ^ Target platform
- , ncgProcAlignment :: !(Maybe Int) -- ^ Mandatory proc alignment
- , ncgDebugLevel :: !Int -- ^ Debug level
- , ncgExternalDynamicRefs :: !Bool -- ^ Generate code to link against dynamic libraries
- , ncgPIC :: !Bool -- ^ Enable Position-Independent Code
- , ncgSplitSections :: !Bool -- ^ Split sections
- , ncgSpillPreallocSize :: !Int -- ^ Size in bytes of the pre-allocated spill space on the C stack
- , ncgRegsIterative :: !Bool
- , ncgAsmLinting :: !Bool -- ^ Perform ASM linting pass
- , ncgDumpRegAllocStages :: !Bool
- , ncgDumpAsmStats :: !Bool
- , ncgDumpAsmConflicts :: !Bool
+ { ncgPlatform :: !Platform -- ^ Target platform
+ , ncgUnitId :: UnitId -- ^ Target unit ID
+ , ncgProcAlignment :: !(Maybe Int) -- ^ Mandatory proc alignment
+ , ncgDebugLevel :: !Int -- ^ Debug level
+ , ncgExternalDynamicRefs :: !Bool -- ^ Generate code to link against dynamic libraries
+ , ncgPIC :: !Bool -- ^ Enable Position-Independent Code
+ , ncgInlineThresholdMemcpy :: !Word -- ^ If inlining `memcpy` produces less than this threshold (in pseudo-instruction unit), do it
+ , ncgInlineThresholdMemset :: !Word -- ^ Ditto for `memset`
+ , ncgSplitSections :: !Bool -- ^ Split sections
+ , ncgSpillPreallocSize :: !Int -- ^ Size in bytes of the pre-allocated spill space on the C stack
+ , ncgRegsIterative :: !Bool
+ , ncgAsmLinting :: !Bool -- ^ Perform ASM linting pass
+ , ncgDoConstantFolding :: !Bool -- ^ Perform CMM constant folding
+ , ncgSseVersion :: Maybe SseVersion -- ^ (x86) SSE instructions
+ , ncgBmiVersion :: Maybe BmiVersion -- ^ (x86) BMI instructions
+ , ncgDumpRegAllocStages :: !Bool
+ , ncgDumpAsmStats :: !Bool
+ , ncgDumpAsmConflicts :: !Bool
}
-- | Return Word size
=====================================
compiler/GHC/CmmToAsm/Monad.hs
=====================================
@@ -148,18 +148,46 @@ mkNatM_State us delta dflags this_mod
-- | Initialize the native code generator configuration from the DynFlags
initConfig :: DynFlags -> NCGConfig
initConfig dflags = NCGConfig
- { ncgPlatform = targetPlatform dflags
- , ncgProcAlignment = cmmProcAlignment dflags
- , ncgDebugLevel = debugLevel dflags
- , ncgExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags
- , ncgPIC = positionIndependent dflags
- , ncgSplitSections = gopt Opt_SplitSections dflags
- , ncgSpillPreallocSize = rESERVED_C_STACK_BYTES dflags
- , ncgRegsIterative = gopt Opt_RegsIterative dflags
- , ncgAsmLinting = gopt Opt_DoAsmLinting dflags
- , ncgDumpRegAllocStages = dopt Opt_D_dump_asm_regalloc_stages dflags
- , ncgDumpAsmStats = dopt Opt_D_dump_asm_stats dflags
- , ncgDumpAsmConflicts = dopt Opt_D_dump_asm_conflicts dflags
+ { ncgPlatform = targetPlatform dflags
+ , ncgUnitId = thisPackage dflags
+ , ncgProcAlignment = cmmProcAlignment dflags
+ , ncgDebugLevel = debugLevel dflags
+ , ncgExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags
+ , ncgPIC = positionIndependent dflags
+ , ncgInlineThresholdMemcpy = fromIntegral $ maxInlineMemcpyInsns dflags
+ , ncgInlineThresholdMemset = fromIntegral $ maxInlineMemsetInsns dflags
+ , ncgSplitSections = gopt Opt_SplitSections dflags
+ , ncgSpillPreallocSize = rESERVED_C_STACK_BYTES dflags
+ , ncgRegsIterative = gopt Opt_RegsIterative dflags
+ , ncgAsmLinting = gopt Opt_DoAsmLinting dflags
+
+ -- With -O1 and greater, the cmmSink pass does constant-folding, so
+ -- we don't need to do it again in the native code generator.
+ , ncgDoConstantFolding = optLevel dflags < 1
+
+ , ncgDumpRegAllocStages = dopt Opt_D_dump_asm_regalloc_stages dflags
+ , ncgDumpAsmStats = dopt Opt_D_dump_asm_stats dflags
+ , ncgDumpAsmConflicts = dopt Opt_D_dump_asm_conflicts dflags
+ , ncgBmiVersion = case platformArch (targetPlatform dflags) of
+ ArchX86_64 -> bmiVersion dflags
+ ArchX86 -> bmiVersion dflags
+ _ -> Nothing
+
+ -- We Assume SSE1 and SSE2 operations are available on both
+ -- x86 and x86_64. Historically we didn't default to SSE2 and
+ -- SSE1 on x86, which results in defacto nondeterminism for how
+ -- rounding behaves in the associated x87 floating point instructions
+ -- because variations in the spill/fpu stack placement of arguments for
+ -- operations would change the precision and final result of what
+ -- would otherwise be the same expressions with respect to single or
+ -- double precision IEEE floating point computations.
+ , ncgSseVersion =
+ let v | sseVersion dflags < Just SSE2 = Just SSE2
+ | otherwise = sseVersion dflags
+ in case platformArch (targetPlatform dflags) of
+ ArchX86_64 -> v
+ ArchX86 -> v
+ _ -> Nothing
}
=====================================
compiler/GHC/CmmToAsm/PIC.hs
=====================================
@@ -109,21 +109,20 @@ instance CmmMakeDynamicReferenceM NatM where
cmmMakeDynamicReference
:: CmmMakeDynamicReferenceM m
- => DynFlags
+ => NCGConfig
-> ReferenceKind -- whether this is the target of a jump
-> CLabel -- the label
-> m CmmExpr
-cmmMakeDynamicReference dflags referenceKind lbl
+cmmMakeDynamicReference config referenceKind lbl
| Just _ <- dynamicLinkerLabelInfo lbl
= return $ CmmLit $ CmmLabel lbl -- already processed it, pass through
| otherwise
= do this_mod <- getThisModule
- let config = initConfig dflags
- platform = ncgPlatform config
+ let platform = ncgPlatform config
case howToAccessLabel
- dflags
+ config
(platformArch platform)
(platformOS platform)
this_mod
@@ -215,9 +214,7 @@ data LabelAccessStyle
| AccessViaSymbolPtr
| AccessDirectly
-howToAccessLabel
- :: DynFlags -> Arch -> OS -> Module -> ReferenceKind -> CLabel -> LabelAccessStyle
-
+howToAccessLabel :: NCGConfig -> Arch -> OS -> Module -> ReferenceKind -> CLabel -> LabelAccessStyle
-- Windows
-- In Windows speak, a "module" is a set of objects linked into the
@@ -240,15 +237,15 @@ howToAccessLabel
-- into the same .exe file. In this case we always access symbols directly,
-- and never use __imp_SYMBOL.
--
-howToAccessLabel dflags _ OSMinGW32 this_mod _ lbl
+howToAccessLabel config _ OSMinGW32 this_mod _ lbl
-- Assume all symbols will be in the same PE, so just access them directly.
- | not (gopt Opt_ExternalDynamicRefs dflags)
+ | not (ncgExternalDynamicRefs config)
= AccessDirectly
-- If the target symbol is in another PE we need to access it via the
-- appropriate __imp_SYMBOL pointer.
- | labelDynamic dflags this_mod lbl
+ | labelDynamic config this_mod lbl
= AccessViaSymbolPtr
-- Target symbol is in the same PE as the caller, so just access it directly.
@@ -264,9 +261,9 @@ howToAccessLabel dflags _ OSMinGW32 this_mod _ lbl
-- It is always possible to access something indirectly,
-- even when it's not necessary.
--
-howToAccessLabel dflags arch OSDarwin this_mod DataReference lbl
+howToAccessLabel config arch OSDarwin this_mod DataReference lbl
-- data access to a dynamic library goes via a symbol pointer
- | labelDynamic dflags this_mod lbl
+ | labelDynamic config this_mod lbl
= AccessViaSymbolPtr
-- when generating PIC code, all cross-module data references must
@@ -279,27 +276,27 @@ howToAccessLabel dflags arch OSDarwin this_mod DataReference lbl
-- we'd need to pass the current Module all the way in to
-- this function.
| arch /= ArchX86_64
- , positionIndependent dflags && externallyVisibleCLabel lbl
+ , ncgPIC config && externallyVisibleCLabel lbl
= AccessViaSymbolPtr
| otherwise
= AccessDirectly
-howToAccessLabel dflags arch OSDarwin this_mod JumpReference lbl
+howToAccessLabel config arch OSDarwin this_mod JumpReference lbl
-- dyld code stubs don't work for tailcalls because the
-- stack alignment is only right for regular calls.
-- Therefore, we have to go via a symbol pointer:
| arch == ArchX86 || arch == ArchX86_64
- , labelDynamic dflags this_mod lbl
+ , labelDynamic config this_mod lbl
= AccessViaSymbolPtr
-howToAccessLabel dflags arch OSDarwin this_mod _ lbl
+howToAccessLabel config arch OSDarwin this_mod _ lbl
-- Code stubs are the usual method of choice for imported code;
-- not needed on x86_64 because Apple's new linker, ld64, generates
-- them automatically.
| arch /= ArchX86_64
- , labelDynamic dflags this_mod lbl
+ , labelDynamic config this_mod lbl
= AccessViaStub
| otherwise
@@ -310,7 +307,7 @@ howToAccessLabel dflags arch OSDarwin this_mod _ lbl
-- AIX
-- quite simple (for now)
-howToAccessLabel _dflags _arch OSAIX _this_mod kind _lbl
+howToAccessLabel _config _arch OSAIX _this_mod kind _lbl
= case kind of
DataReference -> AccessViaSymbolPtr
CallReference -> AccessDirectly
@@ -339,27 +336,27 @@ howToAccessLabel _ (ArchPPC_64 _) os _ kind _
-- regular calls are handled by the runtime linker
_ -> AccessDirectly
-howToAccessLabel dflags _ os _ _ _
+howToAccessLabel config _ os _ _ _
-- no PIC -> the dynamic linker does everything for us;
-- if we don't dynamically link to Haskell code,
-- it actually manages to do so without messing things up.
| osElfTarget os
- , not (positionIndependent dflags) &&
- not (gopt Opt_ExternalDynamicRefs dflags)
+ , not (ncgPIC config) &&
+ not (ncgExternalDynamicRefs config)
= AccessDirectly
-howToAccessLabel dflags arch os this_mod DataReference lbl
+howToAccessLabel config arch os this_mod DataReference lbl
| osElfTarget os
= case () of
-- A dynamic label needs to be accessed via a symbol pointer.
- _ | labelDynamic dflags this_mod lbl
+ _ | labelDynamic config this_mod lbl
-> AccessViaSymbolPtr
-- For PowerPC32 -fPIC, we have to access even static data
-- via a symbol pointer (see below for an explanation why
-- PowerPC32 Linux is especially broken).
| arch == ArchPPC
- , positionIndependent dflags
+ , ncgPIC config
-> AccessViaSymbolPtr
| otherwise
@@ -378,26 +375,26 @@ howToAccessLabel dflags arch os this_mod DataReference lbl
-- (AccessDirectly, because we get an implicit symbol stub)
-- and calling functions from PIC code on non-i386 platforms (via a symbol stub)
-howToAccessLabel dflags arch os this_mod CallReference lbl
+howToAccessLabel config arch os this_mod CallReference lbl
| osElfTarget os
- , labelDynamic dflags this_mod lbl && not (positionIndependent dflags)
+ , labelDynamic config this_mod lbl && not (ncgPIC config)
= AccessDirectly
| osElfTarget os
, arch /= ArchX86
- , labelDynamic dflags this_mod lbl
- , positionIndependent dflags
+ , labelDynamic config this_mod lbl
+ , ncgPIC config
= AccessViaStub
-howToAccessLabel dflags _ os this_mod _ lbl
+howToAccessLabel config _ os this_mod _ lbl
| osElfTarget os
- = if labelDynamic dflags this_mod lbl
+ = if labelDynamic config this_mod lbl
then AccessViaSymbolPtr
else AccessDirectly
-- all other platforms
-howToAccessLabel dflags _ _ _ _ _
- | not (positionIndependent dflags)
+howToAccessLabel config _ _ _ _ _
+ | not (ncgPIC config)
= AccessDirectly
| otherwise
=====================================
compiler/GHC/CmmToAsm/PPC/CodeGen.hs
=====================================
@@ -33,7 +33,7 @@ import GHC.CmmToAsm.CPrim
import GHC.CmmToAsm.Monad
( NatM, getNewRegNat, getNewLabelNat
, getBlockIdNat, getPicBaseNat, getNewRegPairNat
- , getPicBaseMaybeNat, getPlatform, initConfig
+ , getPicBaseMaybeNat, getPlatform, getConfig
)
import GHC.CmmToAsm.Instr
import GHC.CmmToAsm.PIC
@@ -57,7 +57,6 @@ import GHC.Cmm.Dataflow.Graph
-- The rest:
import OrdList
import Outputable
-import GHC.Driver.Session
import Control.Monad ( mapAndUnzipM, when )
import Data.Bits
@@ -149,7 +148,7 @@ stmtsToInstrs stmts
stmtToInstrs :: CmmNode e x -> NatM InstrBlock
stmtToInstrs stmt = do
- dflags <- getDynFlags
+ config <- getConfig
platform <- getPlatform
case stmt of
CmmComment s -> return (unitOL (COMMENT s))
@@ -180,7 +179,7 @@ stmtToInstrs stmt = do
b1 <- genCondJump true arg prediction
b2 <- genBranch false
return (b1 `appOL` b2)
- CmmSwitch arg ids -> genSwitch dflags arg ids
+ CmmSwitch arg ids -> genSwitch config arg ids
CmmCall { cml_target = arg
, cml_args_regs = gregs } -> genJump arg (jumpRegs platform gregs)
_ ->
@@ -404,10 +403,10 @@ iselExpr64 expr
getRegister :: CmmExpr -> NatM Register
-getRegister e = do dflags <- getDynFlags
- getRegister' dflags (targetPlatform dflags) e
+getRegister e = do config <- getConfig
+ getRegister' config (ncgPlatform config) e
-getRegister' :: DynFlags -> Platform -> CmmExpr -> NatM Register
+getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' _ platform (CmmReg (CmmGlobal PicBaseReg))
| OSAIX <- platformOS platform = do
@@ -424,8 +423,8 @@ getRegister' _ platform (CmmReg reg)
= return (Fixed (cmmTypeFormat (cmmRegType platform reg))
(getRegisterReg platform reg) nilOL)
-getRegister' dflags platform tree@(CmmRegOff _ _)
- = getRegister' dflags platform (mangleIndexTree platform tree)
+getRegister' config platform tree@(CmmRegOff _ _)
+ = getRegister' config platform (mangleIndexTree platform tree)
-- for 32-bit architectures, support some 64 -> 32 bit conversions:
-- TO_W_(x), TO_W_(x >> 32)
@@ -509,7 +508,7 @@ getRegister' _ _ (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad mem _]) = do
Amode addr addr_code <- getAmode DS mem
return (Any II64 (\dst -> addr_code `snocOL` LA II32 dst addr))
-getRegister' dflags platform (CmmMachOp mop [x]) -- unary MachOps
+getRegister' config platform (CmmMachOp mop [x]) -- unary MachOps
= case mop of
MO_Not rep -> triv_ucode_int rep NOT
@@ -539,7 +538,7 @@ getRegister' dflags platform (CmmMachOp mop [x]) -- unary MachOps
triv_ucode_float width instr = trivialUCode (floatFormat width) instr x
conversionNop new_format expr
- = do e_code <- getRegister' dflags platform expr
+ = do e_code <- getRegister' config platform expr
return (swizzleRegisterRep e_code new_format)
clearLeft from to
@@ -662,9 +661,9 @@ getRegister' _ _ (CmmLit (CmmInt i rep))
in
return (Any (intFormat rep) code)
-getRegister' dflags _ (CmmLit (CmmFloat f frep)) = do
+getRegister' config _ (CmmLit (CmmFloat f frep)) = do
lbl <- getNewLabelNat
- dynRef <- cmmMakeDynamicReference dflags DataReference lbl
+ dynRef <- cmmMakeDynamicReference config DataReference lbl
Amode addr addr_code <- getAmode D dynRef
let format = floatFormat frep
code dst =
@@ -673,7 +672,7 @@ getRegister' dflags _ (CmmLit (CmmFloat f frep)) = do
`consOL` (addr_code `snocOL` LD format dst addr)
return (Any format code)
-getRegister' dflags platform (CmmLit lit)
+getRegister' config platform (CmmLit lit)
| target32Bit platform
= let rep = cmmLitType platform lit
imm = litToImm lit
@@ -684,7 +683,7 @@ getRegister' dflags platform (CmmLit lit)
in return (Any (cmmTypeFormat rep) code)
| otherwise
= do lbl <- getNewLabelNat
- dynRef <- cmmMakeDynamicReference dflags DataReference lbl
+ dynRef <- cmmMakeDynamicReference config DataReference lbl
Amode addr addr_code <- getAmode D dynRef
let rep = cmmLitType platform lit
format = cmmTypeFormat rep
@@ -1031,8 +1030,8 @@ assignMem_IntCode pk addr src = do
-- dst is a reg, but src could be anything
assignReg_IntCode _ reg src
= do
- dflags <- getDynFlags
- let dst = getRegisterReg (targetPlatform dflags) reg
+ platform <- getPlatform
+ let dst = getRegisterReg platform reg
r <- getRegister src
return $ case r of
Any _ code -> code dst
@@ -1053,8 +1052,8 @@ genJump (CmmLit (CmmLabel lbl)) regs
genJump tree gregs
= do
- dflags <- getDynFlags
- genJump' tree (platformToGCP (targetPlatform dflags)) gregs
+ platform <- getPlatform
+ genJump' tree (platformToGCP platform) gregs
genJump' :: CmmExpr -> GenCCallPlatform -> [Reg] -> NatM InstrBlock
@@ -1132,9 +1131,8 @@ genCCall (PrimTarget (MO_Prefetch_Data _)) _ _
= return $ nilOL
genCCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n]
- = do dflags <- getDynFlags
- let platform = targetPlatform dflags
- fmt = intFormat width
+ = do platform <- getPlatform
+ let fmt = intFormat width
reg_dst = getRegisterReg platform (CmmLocal dst)
(instr, n_code) <- case amop of
AMO_Add -> getSomeRegOrImm ADD True reg_dst
@@ -1184,9 +1182,8 @@ genCCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n]
return (op dst dst (RIReg n_reg), n_code)
genCCall (PrimTarget (MO_AtomicRead width)) [dst] [addr]
- = do dflags <- getDynFlags
- let platform = targetPlatform dflags
- fmt = intFormat width
+ = do platform <- getPlatform
+ let fmt = intFormat width
reg_dst = getRegisterReg platform (CmmLocal dst)
form = if widthInBits width == 64 then DS else D
Amode addr_reg addr_code <- getAmode form addr
@@ -1216,9 +1213,8 @@ genCCall (PrimTarget (MO_AtomicWrite width)) [] [addr, val] = do
return $ unitOL(HWSYNC) `appOL` code
genCCall (PrimTarget (MO_Clz width)) [dst] [src]
- = do dflags <- getDynFlags
- let platform = targetPlatform dflags
- reg_dst = getRegisterReg platform (CmmLocal dst)
+ = do platform <- getPlatform
+ let reg_dst = getRegisterReg platform (CmmLocal dst)
if target32Bit platform && width == W64
then do
ChildCode64 code vr_lo <- iselExpr64 src
@@ -1268,9 +1264,8 @@ genCCall (PrimTarget (MO_Clz width)) [dst] [src]
return $ s_code `appOL` pre `appOL` cntlz `appOL` post
genCCall (PrimTarget (MO_Ctz width)) [dst] [src]
- = do dflags <- getDynFlags
- let platform = targetPlatform dflags
- reg_dst = getRegisterReg platform (CmmLocal dst)
+ = do platform <- getPlatform
+ let reg_dst = getRegisterReg platform (CmmLocal dst)
if target32Bit platform && width == W64
then do
let format = II32
@@ -1334,8 +1329,7 @@ genCCall (PrimTarget (MO_Ctz width)) [dst] [src]
]
genCCall target dest_regs argsAndHints
- = do dflags <- getDynFlags
- let platform = targetPlatform dflags
+ = do platform <- getPlatform
case target of
PrimTarget (MO_S_QuotRem width) -> divOp1 platform True width
dest_regs argsAndHints
@@ -1354,7 +1348,8 @@ genCCall target dest_regs argsAndHints
dest_regs argsAndHints
PrimTarget MO_F64_Fabs -> fabs platform dest_regs argsAndHints
PrimTarget MO_F32_Fabs -> fabs platform dest_regs argsAndHints
- _ -> genCCall' dflags (platformToGCP platform)
+ _ -> do config <- getConfig
+ genCCall' config (platformToGCP platform)
target dest_regs argsAndHints
where divOp1 platform signed width [res_q, res_r] [arg_x, arg_y]
= do let reg_q = getRegisterReg platform (CmmLocal res_q)
@@ -1586,7 +1581,7 @@ platformToGCP platform
genCCall'
- :: DynFlags
+ :: NCGConfig
-> GenCCallPlatform
-> ForeignTarget -- function to call
-> [CmmFormal] -- where to put the result
@@ -1639,7 +1634,7 @@ genCCall'
-}
-genCCall' dflags gcp target dest_regs args
+genCCall' config gcp target dest_regs args
= do
(finalStack,passArgumentsCode,usedRegs) <- passArguments
(zip3 args argReps argHints)
@@ -1705,7 +1700,6 @@ genCCall' dflags gcp target dest_regs args
`snocOL` BCTRL usedRegs
`appOL` codeAfter)
where
- config = initConfig dflags
platform = ncgPlatform config
uses_pic_base_implicitly = do
@@ -1777,7 +1771,7 @@ genCCall' dflags gcp target dest_regs args
passArguments [] _ _ stackOffset accumCode accumUsed = return (stackOffset, accumCode, accumUsed)
passArguments ((arg,arg_ty,_):args) gprs fprs stackOffset
accumCode accumUsed | isWord64 arg_ty
- && target32Bit (targetPlatform dflags) =
+ && target32Bit (ncgPlatform config) =
do
ChildCode64 code vr_lo <- iselExpr64 arg
let vr_hi = getHiVRegFromLo vr_lo
@@ -1945,8 +1939,7 @@ genCCall' dflags gcp target dest_regs args
outOfLineMachOp mop =
do
- dflags <- getDynFlags
- mopExpr <- cmmMakeDynamicReference dflags CallReference $
+ mopExpr <- cmmMakeDynamicReference config CallReference $
mkForeignLabel functionName Nothing ForeignLabelInThisPackage IsFunction
let mopLabelOrExpr = case mopExpr of
CmmLit (CmmLabel lbl) -> Left lbl
@@ -2041,8 +2034,8 @@ genCCall' dflags gcp target dest_regs args
-- -----------------------------------------------------------------------------
-- Generating a table-branch
-genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock
-genSwitch dflags expr targets
+genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock
+genSwitch config expr targets
| OSAIX <- platformOS platform
= do
(reg,e_code) <- getSomeReg (cmmOffset platform expr offset)
@@ -2050,7 +2043,7 @@ genSwitch dflags expr targets
sha = if target32Bit platform then 2 else 3
tmp <- getNewRegNat fmt
lbl <- getNewLabelNat
- dynRef <- cmmMakeDynamicReference dflags DataReference lbl
+ dynRef <- cmmMakeDynamicReference config DataReference lbl
(tableReg,t_code) <- getSomeReg $ dynRef
let code = e_code `appOL` t_code `appOL` toOL [
SL fmt tmp reg (RIImm (ImmInt sha)),
@@ -2067,7 +2060,7 @@ genSwitch dflags expr targets
sha = if target32Bit platform then 2 else 3
tmp <- getNewRegNat fmt
lbl <- getNewLabelNat
- dynRef <- cmmMakeDynamicReference dflags DataReference lbl
+ dynRef <- cmmMakeDynamicReference config DataReference lbl
(tableReg,t_code) <- getSomeReg $ dynRef
let code = e_code `appOL` t_code `appOL` toOL [
SL fmt tmp reg (RIImm (ImmInt sha)),
@@ -2095,7 +2088,6 @@ genSwitch dflags expr targets
where
(offset, ids) = switchTargetsToTable targets
platform = ncgPlatform config
- config = initConfig dflags
generateJumpTableForInstr :: NCGConfig -> Instr
-> Maybe (NatCmmDecl RawCmmStatics Instr)
@@ -2334,9 +2326,9 @@ coerceInt2FP' ArchPPC fromRep toRep x = do
lbl <- getNewLabelNat
itmp <- getNewRegNat II32
ftmp <- getNewRegNat FF64
- dflags <- getDynFlags
+ config <- getConfig
platform <- getPlatform
- dynRef <- cmmMakeDynamicReference dflags DataReference lbl
+ dynRef <- cmmMakeDynamicReference config DataReference lbl
Amode addr addr_code <- getAmode D dynRef
let
code' dst = code `appOL` maybe_exts `appOL` toOL [
=====================================
compiler/GHC/CmmToAsm/SPARC/CodeGen.hs
=====================================
@@ -53,7 +53,6 @@ import GHC.CmmToAsm.CPrim
-- The rest:
import GHC.Types.Basic
-import GHC.Driver.Session
import FastString
import OrdList
import Outputable
@@ -455,7 +454,7 @@ genCCall target dest_regs args
let transfer_code
= toOL (move_final vregs allArgRegs extraStackArgsHere)
- dflags <- getDynFlags
+ platform <- getPlatform
return
$ argcode `appOL`
move_sp_down `appOL`
@@ -463,7 +462,7 @@ genCCall target dest_regs args
callinsns `appOL`
unitOL NOP `appOL`
move_sp_up `appOL`
- assign_code (targetPlatform dflags) dest_regs
+ assign_code platform dest_regs
-- | Generate code to calculate an argument, and move it into one
@@ -594,8 +593,8 @@ outOfLineMachOp mop
= do let functionName
= outOfLineMachOp_table mop
- dflags <- getDynFlags
- mopExpr <- cmmMakeDynamicReference dflags CallReference
+ config <- getConfig
+ mopExpr <- cmmMakeDynamicReference config CallReference
$ mkForeignLabel functionName Nothing ForeignLabelInExternalPackage IsFunction
let mopLabelOrExpr
=====================================
compiler/GHC/CmmToAsm/X86/CodeGen.hs
=====================================
@@ -104,26 +104,13 @@ is32BitPlatform = do
sse2Enabled :: NatM Bool
sse2Enabled = do
- platform <- getPlatform
- case platformArch platform of
- -- We Assume SSE1 and SSE2 operations are available on both
- -- x86 and x86_64. Historically we didn't default to SSE2 and
- -- SSE1 on x86, which results in defacto nondeterminism for how
- -- rounding behaves in the associated x87 floating point instructions
- -- because variations in the spill/fpu stack placement of arguments for
- -- operations would change the precision and final result of what
- -- would otherwise be the same expressions with respect to single or
- -- double precision IEEE floating point computations.
- ArchX86_64 -> return True
- ArchX86 -> return True
- _ -> panic "trying to generate x86/x86_64 on the wrong platform"
-
+ config <- getConfig
+ return (ncgSseVersion config >= Just SSE2)
sse4_2Enabled :: NatM Bool
sse4_2Enabled = do
- dflags <- getDynFlags
- return (isSse4_2Enabled dflags)
-
+ config <- getConfig
+ return (ncgSseVersion config >= Just SSE42)
cmmTopCodeGen
:: RawCmmDecl
@@ -1474,11 +1461,11 @@ memConstant :: Alignment -> CmmLit -> NatM Amode
memConstant align lit = do
lbl <- getNewLabelNat
let rosection = Section ReadOnlyData lbl
- dflags <- getDynFlags
+ config <- getConfig
platform <- getPlatform
(addr, addr_code) <- if target32Bit platform
then do dynRef <- cmmMakeDynamicReference
- dflags
+ config
DataReference
lbl
Amode addr addr_code <- getAmode dynRef
@@ -2122,10 +2109,10 @@ genCCall is32Bit (PrimTarget (MO_Ctz width)) [dst] [src] bid
| otherwise = do
code_src <- getAnyReg src
- platform <- ncgPlatform <$> getConfig
+ config <- getConfig
+ let platform = ncgPlatform config
let dst_r = getRegisterReg platform (CmmLocal dst)
- dflags <- getDynFlags
- if isBmi2Enabled dflags
+ if ncgBmiVersion config >= Just BMI2
then do
src_r <- getNewRegNat (intFormat width)
let instrs = appOL (code_src src_r) $ case width of
@@ -2158,13 +2145,13 @@ genCCall is32Bit (PrimTarget (MO_Ctz width)) [dst] [src] bid
bw = widthInBits width
genCCall bits mop dst args bid = do
- dflags <- getDynFlags
- instr <- genCCall' dflags bits mop dst args bid
+ config <- getConfig
+ instr <- genCCall' config bits mop dst args bid
return (instr, Nothing)
-- genCCall' handles cases not introducing new code blocks.
genCCall'
- :: DynFlags
+ :: NCGConfig
-> Bool -- 32 bit platform?
-> ForeignTarget -- function to call
-> [CmmFormal] -- where to put the result
@@ -2174,9 +2161,9 @@ genCCall'
-- Unroll memcpy calls if the number of bytes to copy isn't too
-- large. Otherwise, call C's memcpy.
-genCCall' dflags _ (PrimTarget (MO_Memcpy align)) _
+genCCall' config _ (PrimTarget (MO_Memcpy align)) _
[dst, src, CmmLit (CmmInt n _)] _
- | fromInteger insns <= maxInlineMemcpyInsns dflags = do
+ | fromInteger insns <= ncgInlineThresholdMemcpy config = do
code_dst <- getAnyReg dst
dst_r <- getNewRegNat format
code_src <- getAnyReg src
@@ -2185,7 +2172,7 @@ genCCall' dflags _ (PrimTarget (MO_Memcpy align)) _
return $ code_dst dst_r `appOL` code_src src_r `appOL`
go dst_r src_r tmp_r (fromInteger n)
where
- platform = targetPlatform dflags
+ platform = ncgPlatform config
-- The number of instructions we will generate (approx). We need 2
-- instructions per move.
insns = 2 * ((n + sizeBytes - 1) `div` sizeBytes)
@@ -2224,12 +2211,12 @@ genCCall' dflags _ (PrimTarget (MO_Memcpy align)) _
dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone
(ImmInteger (n - i))
-genCCall' dflags _ (PrimTarget (MO_Memset align)) _
+genCCall' config _ (PrimTarget (MO_Memset align)) _
[dst,
CmmLit (CmmInt c _),
CmmLit (CmmInt n _)]
_
- | fromInteger insns <= maxInlineMemsetInsns dflags = do
+ | fromInteger insns <= ncgInlineThresholdMemset config = do
code_dst <- getAnyReg dst
dst_r <- getNewRegNat format
if format == II64 && n >= 8 then do
@@ -2242,7 +2229,7 @@ genCCall' dflags _ (PrimTarget (MO_Memset align)) _
return $ code_dst dst_r `appOL`
go4 dst_r (fromInteger n)
where
- platform = targetPlatform dflags
+ platform = ncgPlatform config
maxAlignment = wordAlignment platform -- only machine word wide MOVs are supported
effectiveAlignment = min (alignmentOf align) maxAlignment
format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment
@@ -2348,10 +2335,10 @@ genCCall' _ is32Bit (PrimTarget (MO_BSwap width)) [dst] [src] _ = do
where
format = intFormat width
-genCCall' dflags is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst]
+genCCall' config is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst]
args@[src] bid = do
sse4_2 <- sse4_2Enabled
- platform <- ncgPlatform <$> getConfig
+ let platform = ncgPlatform config
if sse4_2
then do code_src <- getAnyReg src
src_r <- getNewRegNat format
@@ -2369,20 +2356,20 @@ genCCall' dflags is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst]
unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r))
else nilOL)
else do
- targetExpr <- cmmMakeDynamicReference dflags
+ targetExpr <- cmmMakeDynamicReference config
CallReference lbl
let target = ForeignTarget targetExpr (ForeignConvention CCallConv
[NoHint] [NoHint]
CmmMayReturn)
- genCCall' dflags is32Bit target dest_regs args bid
+ genCCall' config is32Bit target dest_regs args bid
where
format = intFormat width
lbl = mkCmmCodeLabel primUnitId (fsLit (popCntLabel width))
-genCCall' dflags is32Bit (PrimTarget (MO_Pdep width)) dest_regs@[dst]
+genCCall' config is32Bit (PrimTarget (MO_Pdep width)) dest_regs@[dst]
args@[src, mask] bid = do
- platform <- ncgPlatform <$> getConfig
- if isBmi2Enabled dflags
+ let platform = ncgPlatform config
+ if ncgBmiVersion config >= Just BMI2
then do code_src <- getAnyReg src
code_mask <- getAnyReg mask
src_r <- getNewRegNat format
@@ -2402,20 +2389,20 @@ genCCall' dflags is32Bit (PrimTarget (MO_Pdep width)) dest_regs@[dst]
unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r))
else nilOL)
else do
- targetExpr <- cmmMakeDynamicReference dflags
+ targetExpr <- cmmMakeDynamicReference config
CallReference lbl
let target = ForeignTarget targetExpr (ForeignConvention CCallConv
[NoHint] [NoHint]
CmmMayReturn)
- genCCall' dflags is32Bit target dest_regs args bid
+ genCCall' config is32Bit target dest_regs args bid
where
format = intFormat width
lbl = mkCmmCodeLabel primUnitId (fsLit (pdepLabel width))
-genCCall' dflags is32Bit (PrimTarget (MO_Pext width)) dest_regs@[dst]
+genCCall' config is32Bit (PrimTarget (MO_Pext width)) dest_regs@[dst]
args@[src, mask] bid = do
- platform <- ncgPlatform <$> getConfig
- if isBmi2Enabled dflags
+ let platform = ncgPlatform config
+ if ncgBmiVersion config >= Just BMI2
then do code_src <- getAnyReg src
code_mask <- getAnyReg mask
src_r <- getNewRegNat format
@@ -2435,30 +2422,31 @@ genCCall' dflags is32Bit (PrimTarget (MO_Pext width)) dest_regs@[dst]
unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r))
else nilOL)
else do
- targetExpr <- cmmMakeDynamicReference dflags
+ targetExpr <- cmmMakeDynamicReference config
CallReference lbl
let target = ForeignTarget targetExpr (ForeignConvention CCallConv
[NoHint] [NoHint]
CmmMayReturn)
- genCCall' dflags is32Bit target dest_regs args bid
+ genCCall' config is32Bit target dest_regs args bid
where
format = intFormat width
lbl = mkCmmCodeLabel primUnitId (fsLit (pextLabel width))
-genCCall' dflags is32Bit (PrimTarget (MO_Clz width)) dest_regs@[dst] args@[src] bid
+genCCall' config is32Bit (PrimTarget (MO_Clz width)) dest_regs@[dst] args@[src] bid
| is32Bit && width == W64 = do
-- Fallback to `hs_clz64` on i386
- targetExpr <- cmmMakeDynamicReference dflags CallReference lbl
+ targetExpr <- cmmMakeDynamicReference config CallReference lbl
let target = ForeignTarget targetExpr (ForeignConvention CCallConv
[NoHint] [NoHint]
CmmMayReturn)
- genCCall' dflags is32Bit target dest_regs args bid
+ genCCall' config is32Bit target dest_regs args bid
| otherwise = do
code_src <- getAnyReg src
- platform <- ncgPlatform <$> getConfig
+ config <- getConfig
+ let platform = ncgPlatform config
let dst_r = getRegisterReg platform (CmmLocal dst)
- if isBmi2Enabled dflags
+ if ncgBmiVersion config >= Just BMI2
then do
src_r <- getNewRegNat (intFormat width)
return $ appOL (code_src src_r) $ case width of
@@ -2489,13 +2477,13 @@ genCCall' dflags is32Bit (PrimTarget (MO_Clz width)) dest_regs@[dst] args@[src]
bw = widthInBits width
lbl = mkCmmCodeLabel primUnitId (fsLit (clzLabel width))
-genCCall' dflags is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args bid = do
- targetExpr <- cmmMakeDynamicReference dflags
+genCCall' config is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args bid = do
+ targetExpr <- cmmMakeDynamicReference config
CallReference lbl
let target = ForeignTarget targetExpr (ForeignConvention CCallConv
[NoHint] [NoHint]
CmmMayReturn)
- genCCall' dflags is32Bit target dest_regs args bid
+ genCCall' config is32Bit target dest_regs args bid
where
lbl = mkCmmCodeLabel primUnitId (fsLit (word2FloatLabel width))
@@ -3142,8 +3130,8 @@ outOfLineCmmOp :: BlockId -> CallishMachOp -> Maybe CmmFormal -> [CmmActual]
-> NatM InstrBlock
outOfLineCmmOp bid mop res args
= do
- dflags <- getDynFlags
- targetExpr <- cmmMakeDynamicReference dflags CallReference lbl
+ config <- getConfig
+ targetExpr <- cmmMakeDynamicReference config CallReference lbl
let target = ForeignTarget targetExpr
(ForeignConvention CCallConv [] [] CmmMayReturn)
@@ -3252,7 +3240,6 @@ genSwitch :: CmmExpr -> SwitchTargets -> NatM InstrBlock
genSwitch expr targets = do
config <- getConfig
- dflags <- getDynFlags
let platform = ncgPlatform config
if ncgPIC config
then do
@@ -3272,7 +3259,7 @@ genSwitch expr targets = do
-- if L0 is not preceded by a non-anonymous label in its section.
OSDarwin | not is32bit -> Section Text lbl
_ -> Section ReadOnlyData lbl
- dynRef <- cmmMakeDynamicReference dflags DataReference lbl
+ dynRef <- cmmMakeDynamicReference config DataReference lbl
(tableReg,t_code) <- getSomeReg $ dynRef
let op = OpAddr (AddrBaseIndex (EABaseReg tableReg)
(EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0))
=====================================
compiler/GHC/CmmToLlvm.hs
=====================================
@@ -75,14 +75,14 @@ llvmCodeGen dflags h cmm_stream
-- run code generation
a <- runLlvm dflags (fromMaybe supportedLlvmVersion mb_ver) bufh $
- llvmCodeGen' (liftStream cmm_stream)
+ llvmCodeGen' dflags (liftStream cmm_stream)
bFlush bufh
return a
-llvmCodeGen' :: Stream.Stream LlvmM RawCmmGroup a -> LlvmM a
-llvmCodeGen' cmm_stream
+llvmCodeGen' :: DynFlags -> Stream.Stream LlvmM RawCmmGroup a -> LlvmM a
+llvmCodeGen' dflags cmm_stream
= do -- Preamble
renderLlvm header
ghcInternalFunctions
@@ -100,19 +100,19 @@ llvmCodeGen' cmm_stream
return a
where
header :: SDoc
- header = sdocWithDynFlags $ \dflags ->
+ header =
let target = platformMisc_llvmTarget $ platformMisc dflags
- in text ("target datalayout = \"" ++ getDataLayout dflags target ++ "\"")
+ in text ("target datalayout = \"" ++ getDataLayout (llvmConfig dflags) target ++ "\"")
$+$ text ("target triple = \"" ++ target ++ "\"")
- getDataLayout :: DynFlags -> String -> String
- getDataLayout dflags target =
- case lookup target (llvmTargets $ llvmConfig dflags) of
+ getDataLayout :: LlvmConfig -> String -> String
+ getDataLayout config target =
+ case lookup target (llvmTargets config) of
Just (LlvmTarget {lDataLayout=dl}) -> dl
Nothing -> pprPanic "Failed to lookup LLVM data layout" $
text "Target:" <+> text target $$
hang (text "Available targets:") 4
- (vcat $ map (text . fst) $ llvmTargets $ llvmConfig dflags)
+ (vcat $ map (text . fst) $ llvmTargets config)
llvmGroupLlvmGens :: RawCmmGroup -> LlvmM ()
llvmGroupLlvmGens cmm = do
=====================================
compiler/GHC/CmmToLlvm/Base.hs
=====================================
@@ -447,8 +447,8 @@ renderLlvm sdoc = do
-- Write to output
dflags <- getDynFlags
out <- getEnv envOutput
- liftIO $ Outp.bufLeftRenderSDoc dflags out
- (Outp.mkCodeStyle Outp.CStyle) sdoc
+ let ctx = initSDocContext dflags (Outp.mkCodeStyle Outp.CStyle)
+ liftIO $ Outp.bufLeftRenderSDoc ctx out sdoc
-- Dump, if requested
dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" FormatLLVM sdoc
=====================================
compiler/GHC/Driver/CodeOutput.hs
=====================================
@@ -277,10 +277,9 @@ outputForeignStubs_help fname doc_str header footer
-- module;
-- | Generate code to initialise cost centres
-profilingInitCode :: Module -> CollectedCCs -> SDoc
-profilingInitCode this_mod (local_CCs, singleton_CCSs)
- = sdocWithDynFlags $ \dflags ->
- if not (gopt Opt_SccProfilingOn dflags)
+profilingInitCode :: DynFlags -> Module -> CollectedCCs -> SDoc
+profilingInitCode dflags this_mod (local_CCs, singleton_CCSs)
+ = if not (gopt Opt_SccProfilingOn dflags)
then empty
else vcat
$ map emit_cc_decl local_CCs
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -1420,7 +1420,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do
let cost_centre_info =
(S.toList local_ccs ++ caf_ccs, caf_cc_stacks)
- prof_init = profilingInitCode this_mod cost_centre_info
+ prof_init = profilingInitCode dflags this_mod cost_centre_info
foreign_stubs = foreign_stubs0 `appendStubC` prof_init
------------------ Code generation ------------------
=====================================
compiler/GHC/Driver/Packages.hs
=====================================
@@ -2155,9 +2155,8 @@ displayInstalledUnitId pkgstate uid =
fmap sourcePackageIdString (lookupInstalledPackage pkgstate uid)
-- | Will the 'Name' come from a dynamically linked package?
-isDynLinkName :: DynFlags -> Module -> Name -> Bool
-isDynLinkName dflags this_mod name
- | not (gopt Opt_ExternalDynamicRefs dflags) = False
+isDynLinkName :: Platform -> Module -> Name -> Bool
+isDynLinkName platform this_mod name
| Just mod <- nameModule_maybe name
-- Issue #8696 - when GHC is dynamically linked, it will attempt
-- to load the dynamic dependencies of object files at compile
@@ -2171,7 +2170,7 @@ isDynLinkName dflags this_mod name
-- In the mean time, always force dynamic indirections to be
-- generated: when the module name isn't the module being
-- compiled, references are dynamic.
- = case platformOS $ targetPlatform dflags of
+ = case platformOS platform of
-- On Windows the hack for #8696 makes it unlinkable.
-- As the entire setup of the code from Cmm down to the RTS expects
-- the use of trampolines for the imported functions only when
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -230,7 +230,7 @@ module GHC.Driver.Session (
IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes,
-- * SDoc
- initSDocContext,
+ initSDocContext, initDefaultSDocContext,
-- * Make use of the Cmm CFG
CfgWeights(..)
@@ -1588,7 +1588,8 @@ defaultLogActionHPutStrDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO ()
defaultLogActionHPutStrDoc dflags h d sty
-- Don't add a newline at the end, so that successive
-- calls to this log-action can output all on the same line
- = printSDoc Pretty.PageMode dflags h sty d
+ = printSDoc ctx Pretty.PageMode h d
+ where ctx = initSDocContext dflags sty
newtype FlushOut = FlushOut (IO ())
@@ -5053,13 +5054,6 @@ setUnsafeGlobalDynFlags = writeIORef v_unsafeGlobalDynFlags
-- check if SSE is enabled, we might have x86-64 imply the -msse2
-- flag.
-data SseVersion = SSE1
- | SSE2
- | SSE3
- | SSE4
- | SSE42
- deriving (Eq, Ord)
-
isSseEnabled :: DynFlags -> Bool
isSseEnabled dflags = case platformArch (targetPlatform dflags) of
ArchX86_64 -> True
@@ -5105,10 +5099,6 @@ isAvx512pfEnabled dflags = avx512pf dflags
-- -----------------------------------------------------------------------------
-- BMI2
-data BmiVersion = BMI1
- | BMI2
- deriving (Eq, Ord)
-
isBmiEnabled :: DynFlags -> Bool
isBmiEnabled dflags = case platformArch (targetPlatform dflags) of
ArchX86_64 -> bmiVersion dflags >= Just BMI1
@@ -5184,7 +5174,7 @@ emptyFilesToClean :: FilesToClean
emptyFilesToClean = FilesToClean Set.empty Set.empty
-
+-- | Initialize the pretty-printing options
initSDocContext :: DynFlags -> PprStyle -> SDocContext
initSDocContext dflags style = SDC
{ sdocStyle = style
@@ -5220,3 +5210,7 @@ initSDocContext dflags style = SDC
, sdocImpredicativeTypes = xopt LangExt.ImpredicativeTypes dflags
, sdocDynFlags = dflags
}
+
+-- | Initialize the pretty-printing options using the default user style
+initDefaultSDocContext :: DynFlags -> SDocContext
+initDefaultSDocContext dflags = initSDocContext dflags (defaultUserStyle dflags)
=====================================
compiler/GHC/Driver/Session.hs-boot
=====================================
@@ -8,7 +8,6 @@ data DynFlags
targetPlatform :: DynFlags -> Platform
pprUserLength :: DynFlags -> Int
-pprCols :: DynFlags -> Int
unsafeGlobalDynFlags :: DynFlags
hasPprDebug :: DynFlags -> Bool
hasNoDebugOutput :: DynFlags -> Bool
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -95,7 +95,8 @@ import Outputable
import FastString
import Bag
import Util
-import qualified GHC.Parser.Lexer as Lexer (P (..), ParseResult(..), unP, mkPState)
+import qualified GHC.Parser.Lexer as Lexer (P (..), ParseResult(..), unP, mkPStatePure)
+import GHC.Parser.Lexer (ParserFlags)
import qualified GHC.Parser as Parser (parseStmt, parseModule, parseDeclaration, parseImport)
import System.Directory
@@ -879,44 +880,44 @@ parseName str = withSession $ \hsc_env -> liftIO $
; hscTcRnLookupRdrName hsc_env lrdr_name }
-- | Returns @True@ if passed string is a statement.
-isStmt :: DynFlags -> String -> Bool
-isStmt dflags stmt =
- case parseThing Parser.parseStmt dflags stmt of
+isStmt :: ParserFlags -> String -> Bool
+isStmt pflags stmt =
+ case parseThing Parser.parseStmt pflags stmt of
Lexer.POk _ _ -> True
Lexer.PFailed _ -> False
-- | Returns @True@ if passed string has an import declaration.
-hasImport :: DynFlags -> String -> Bool
-hasImport dflags stmt =
- case parseThing Parser.parseModule dflags stmt of
+hasImport :: ParserFlags -> String -> Bool
+hasImport pflags stmt =
+ case parseThing Parser.parseModule pflags stmt of
Lexer.POk _ thing -> hasImports thing
Lexer.PFailed _ -> False
where
hasImports = not . null . hsmodImports . unLoc
-- | Returns @True@ if passed string is an import declaration.
-isImport :: DynFlags -> String -> Bool
-isImport dflags stmt =
- case parseThing Parser.parseImport dflags stmt of
+isImport :: ParserFlags -> String -> Bool
+isImport pflags stmt =
+ case parseThing Parser.parseImport pflags stmt of
Lexer.POk _ _ -> True
Lexer.PFailed _ -> False
-- | Returns @True@ if passed string is a declaration but __/not a splice/__.
-isDecl :: DynFlags -> String -> Bool
-isDecl dflags stmt = do
- case parseThing Parser.parseDeclaration dflags stmt of
+isDecl :: ParserFlags -> String -> Bool
+isDecl pflags stmt = do
+ case parseThing Parser.parseDeclaration pflags stmt of
Lexer.POk _ thing ->
case unLoc thing of
SpliceD _ _ -> False
_ -> True
Lexer.PFailed _ -> False
-parseThing :: Lexer.P thing -> DynFlags -> String -> Lexer.ParseResult thing
-parseThing parser dflags stmt = do
+parseThing :: Lexer.P thing -> ParserFlags -> String -> Lexer.ParseResult thing
+parseThing parser pflags stmt = do
let buf = stringToStringBuffer stmt
loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
- Lexer.unP parser (Lexer.mkPState dflags buf loc)
+ Lexer.unP parser (Lexer.mkPStatePure pflags buf loc)
getDocs :: GhcMonad m
=> Name
=====================================
compiler/GHC/Runtime/Heap/Inspect.hs
=====================================
@@ -865,7 +865,7 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 0
-- This is a bit involved since we allow packing multiple fields
-- within a single word. See also
-- GHC.StgToCmm.Layout.mkVirtHeapOffsetsWithPadding
- platform <- targetPlatform <$> getDynFlags
+ platform <- getPlatform
let word_size = platformWordSizeInBytes platform
endian = platformByteOrder platform
size_b = primRepSizeB platform rep
=====================================
compiler/GHC/Runtime/Linker.hs
=====================================
@@ -127,15 +127,15 @@ modifyMbPLS_
:: DynLinker -> (Maybe PersistentLinkerState -> IO (Maybe PersistentLinkerState)) -> IO ()
modifyMbPLS_ dl f = modifyMVar_ (dl_mpls dl) f
-emptyPLS :: DynFlags -> PersistentLinkerState
-emptyPLS _ = PersistentLinkerState {
- closure_env = emptyNameEnv,
- itbl_env = emptyNameEnv,
- pkgs_loaded = init_pkgs,
- bcos_loaded = [],
- objs_loaded = [],
- temp_sos = [] }
-
+emptyPLS :: PersistentLinkerState
+emptyPLS = PersistentLinkerState
+ { closure_env = emptyNameEnv
+ , itbl_env = emptyNameEnv
+ , pkgs_loaded = init_pkgs
+ , bcos_loaded = []
+ , objs_loaded = []
+ , temp_sos = []
+ }
-- Packages that don't need loading, because the compiler
-- shares them with the interpreted program.
--
@@ -280,7 +280,7 @@ reallyInitDynLinker :: HscEnv -> IO PersistentLinkerState
reallyInitDynLinker hsc_env = do
-- Initialise the linker state
let dflags = hsc_dflags hsc_env
- pls0 = emptyPLS dflags
+ pls0 = emptyPLS
-- (a) initialise the C dynamic linker
initObjLinker hsc_env
=====================================
compiler/GHC/Stg/Syntax.hs
=====================================
@@ -126,15 +126,17 @@ data StgArg
-- If so, we can't allocate it statically
isDllConApp :: DynFlags -> Module -> DataCon -> [StgArg] -> Bool
isDllConApp dflags this_mod con args
- | platformOS (targetPlatform dflags) == OSMinGW32
- = isDynLinkName dflags this_mod (dataConName con) || any is_dll_arg args
+ | not (gopt Opt_ExternalDynamicRefs dflags) = False
+ | platformOS platform == OSMinGW32
+ = isDynLinkName platform this_mod (dataConName con) || any is_dll_arg args
| otherwise = False
where
+ platform = targetPlatform dflags
-- NB: typePrimRep1 is legit because any free variables won't have
-- unlifted type (there are no unlifted things at top level)
is_dll_arg :: StgArg -> Bool
is_dll_arg (StgVarArg v) = isAddrRep (typePrimRep1 (idType v))
- && isDynLinkName dflags this_mod (idName v)
+ && isDynLinkName platform this_mod (idName v)
is_dll_arg _ = False
-- True of machine addresses; these are the things that don't work across DLLs.
=====================================
compiler/GHC/Tc/Deriv/Generate.hs
=====================================
@@ -1342,8 +1342,9 @@ gen_data dflags data_type_name constr_names loc rep_tc
L loc (TypeSig noExtField [L loc data_type_name] sig_ty))
sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR)
+ ctx = initDefaultSDocContext dflags
rhs = nlHsVar mkDataType_RDR
- `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc)))
+ `nlHsApp` nlHsLit (mkHsString (showSDocOneLine ctx (ppr rep_tc)))
`nlHsApp` nlList (map nlHsVar constr_names)
genDataDataCon :: DataCon -> RdrName -> DerivStuff
=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -70,6 +70,7 @@ module GHC.Tc.Types(
TcId, TcIdSet,
NameShape(..),
removeBindingShadowing,
+ getPlatform,
-- Constraint solver plugins
TcPlugin(..), TcPluginResult(..), TcPluginSolver,
@@ -84,6 +85,7 @@ module GHC.Tc.Types(
#include "HsVersions.h"
import GhcPrelude
+import GHC.Platform
import GHC.Hs
import GHC.Driver.Types
@@ -902,6 +904,11 @@ removeBindingShadowing bindings = reverse $ fst $ foldl
else (binding:bindingAcc, extendOccSet seenNames (occName binding)))
([], emptyOccSet) bindings
+
+-- | Get target platform
+getPlatform :: TcM Platform
+getPlatform = targetPlatform <$> getDynFlags
+
---------------------------
-- Template Haskell stages and levels
---------------------------
=====================================
compiler/main/ErrUtils.hs
=====================================
@@ -729,12 +729,13 @@ withTiming' dflags what force_result prtimings action
then do whenPrintTimings $
logInfo dflags (defaultUserStyle dflags) $
text "***" <+> what <> colon
- eventBegins dflags what
+ let ctx = initDefaultSDocContext dflags
+ eventBegins ctx what
alloc0 <- liftIO getAllocationCounter
start <- liftIO getCPUTime
!r <- action
() <- pure $ force_result r
- eventEnds dflags what
+ eventEnds ctx what
end <- liftIO getCPUTime
alloc1 <- liftIO getAllocationCounter
-- recall that allocation counter counts down
@@ -753,7 +754,7 @@ withTiming' dflags what force_result prtimings action
whenPrintTimings $
dumpIfSet_dyn dflags Opt_D_dump_timings "" FormatText
- $ text $ showSDocOneLine dflags
+ $ text $ showSDocOneLine ctx
$ hsep [ what <> colon
, text "alloc=" <> ppr alloc
, text "time=" <> doublePrec 3 time
@@ -762,15 +763,15 @@ withTiming' dflags what force_result prtimings action
else action
where whenPrintTimings = liftIO . when (prtimings == PrintTimings)
- eventBegins dflags w = do
- whenPrintTimings $ traceMarkerIO (eventBeginsDoc dflags w)
- liftIO $ traceEventIO (eventBeginsDoc dflags w)
- eventEnds dflags w = do
- whenPrintTimings $ traceMarkerIO (eventEndsDoc dflags w)
- liftIO $ traceEventIO (eventEndsDoc dflags w)
-
- eventBeginsDoc dflags w = showSDocOneLine dflags $ text "GHC:started:" <+> w
- eventEndsDoc dflags w = showSDocOneLine dflags $ text "GHC:finished:" <+> w
+ eventBegins ctx w = do
+ whenPrintTimings $ traceMarkerIO (eventBeginsDoc ctx w)
+ liftIO $ traceEventIO (eventBeginsDoc ctx w)
+ eventEnds ctx w = do
+ whenPrintTimings $ traceMarkerIO (eventEndsDoc ctx w)
+ liftIO $ traceEventIO (eventEndsDoc ctx w)
+
+ eventBeginsDoc ctx w = showSDocOneLine ctx $ text "GHC:started:" <+> w
+ eventEndsDoc ctx w = showSDocOneLine ctx $ text "GHC:finished:" <+> w
debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
debugTraceMsg dflags val msg = ifVerbose dflags val $
=====================================
compiler/utils/Outputable.hs
=====================================
@@ -96,7 +96,7 @@ import GhcPrelude
import {-# SOURCE #-} GHC.Driver.Session
( DynFlags, hasPprDebug, hasNoDebugOutput
- , pprUserLength, pprCols
+ , pprUserLength
, unsafeGlobalDynFlags, initSDocContext
)
import {-# SOURCE #-} GHC.Types.Module( UnitId, Module, ModuleName, moduleName )
@@ -484,43 +484,43 @@ whenPprDebug d = ifPprDebug d empty
-- | The analog of 'Pretty.printDoc_' for 'SDoc', which tries to make sure the
-- terminal doesn't get screwed up by the ANSI color codes if an exception
-- is thrown during pretty-printing.
-printSDoc :: Mode -> DynFlags -> Handle -> PprStyle -> SDoc -> IO ()
-printSDoc mode dflags handle sty doc =
+printSDoc :: SDocContext -> Mode -> Handle -> SDoc -> IO ()
+printSDoc ctx mode handle doc =
Pretty.printDoc_ mode cols handle (runSDoc doc ctx)
`finally`
Pretty.printDoc_ mode cols handle
(runSDoc (coloured Col.colReset empty) ctx)
where
- cols = pprCols dflags
- ctx = initSDocContext dflags sty
+ cols = sdocLineLength ctx
-- | Like 'printSDoc' but appends an extra newline.
-printSDocLn :: Mode -> DynFlags -> Handle -> PprStyle -> SDoc -> IO ()
-printSDocLn mode dflags handle sty doc =
- printSDoc mode dflags handle sty (doc $$ text "")
+printSDocLn :: SDocContext -> Mode -> Handle -> SDoc -> IO ()
+printSDocLn ctx mode handle doc =
+ printSDoc ctx mode handle (doc $$ text "")
printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO ()
printForUser dflags handle unqual doc
- = printSDocLn PageMode dflags handle
- (mkUserStyle dflags unqual AllTheWay) doc
+ = printSDocLn ctx PageMode handle doc
+ where ctx = initSDocContext dflags (mkUserStyle dflags unqual AllTheWay)
printForUserPartWay :: DynFlags -> Handle -> Int -> PrintUnqualified -> SDoc
-> IO ()
printForUserPartWay dflags handle d unqual doc
- = printSDocLn PageMode dflags handle
- (mkUserStyle dflags unqual (PartWay d)) doc
+ = printSDocLn ctx PageMode handle doc
+ where ctx = initSDocContext dflags (mkUserStyle dflags unqual (PartWay d))
-- | Like 'printSDocLn' but specialized with 'LeftMode' and
-- @'PprCode' 'CStyle'@. This is typically used to output C-- code.
printForC :: DynFlags -> Handle -> SDoc -> IO ()
printForC dflags handle doc =
- printSDocLn LeftMode dflags handle (PprCode CStyle) doc
+ printSDocLn ctx LeftMode handle doc
+ where ctx = initSDocContext dflags (PprCode CStyle)
-- | An efficient variant of 'printSDoc' specialized for 'LeftMode' that
-- outputs to a 'BufHandle'.
-bufLeftRenderSDoc :: DynFlags -> BufHandle -> PprStyle -> SDoc -> IO ()
-bufLeftRenderSDoc dflags bufHandle sty doc =
- Pretty.bufLeftRender bufHandle (runSDoc doc (initSDocContext dflags sty))
+bufLeftRenderSDoc :: SDocContext -> BufHandle -> SDoc -> IO ()
+bufLeftRenderSDoc ctx bufHandle doc =
+ Pretty.bufLeftRender bufHandle (runSDoc doc ctx)
pprCode :: CodeStyle -> SDoc -> SDoc
pprCode cs d = withPprStyle (PprCode cs) d
@@ -566,12 +566,12 @@ renderWithStyle ctx sdoc
-- This shows an SDoc, but on one line only. It's cheaper than a full
-- showSDoc, designed for when we're getting results like "Foo.bar"
-- and "foo{uniq strictness}" so we don't want fancy layout anyway.
-showSDocOneLine :: DynFlags -> SDoc -> String
-showSDocOneLine dflags d
+showSDocOneLine :: SDocContext -> SDoc -> String
+showSDocOneLine ctx d
= let s = Pretty.style{ Pretty.mode = OneLineMode,
- Pretty.lineLength = pprCols dflags } in
+ Pretty.lineLength = sdocLineLength ctx } in
Pretty.renderStyle s $
- runSDoc d (initSDocContext dflags (defaultUserStyle dflags))
+ runSDoc d ctx
showSDocDumpOneLine :: DynFlags -> SDoc -> String
showSDocDumpOneLine dflags d
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -1168,7 +1168,7 @@ enqueueCommands cmds = do
-- The return value True indicates success, as in `runOneCommand`.
runStmt :: GhciMonad m => String -> SingleStep -> m (Maybe GHC.ExecResult)
runStmt input step = do
- dflags <- GHC.getInteractiveDynFlags
+ pflags <- Lexer.mkParserFlags <$> GHC.getInteractiveDynFlags
-- In GHCi, we disable `-fdefer-type-errors`, as well as `-fdefer-type-holes`
-- and `-fdefer-out-of-scope-variables` for **naked expressions**. The
-- declarations and statements are not affected.
@@ -1177,7 +1177,7 @@ runStmt input step = do
let source = progname st
let line = line_number st
- if | GHC.isStmt dflags input -> do
+ if | GHC.isStmt pflags input -> do
hsc_env <- GHC.getSession
mb_stmt <- liftIO (runInteractiveHsc hsc_env (hscParseStmtWithLocation source line input))
case mb_stmt of
@@ -1187,13 +1187,13 @@ runStmt input step = do
Just stmt ->
run_stmt stmt
- | GHC.isImport dflags input -> run_import
+ | GHC.isImport pflags input -> run_import
-- Every import declaration should be handled by `run_import`. As GHCi
-- in general only accepts one command at a time, we simply throw an
-- exception when the input contains multiple commands of which at least
-- one is an import command (see #10663).
- | GHC.hasImport dflags input -> throwGhcException
+ | GHC.hasImport pflags input -> throwGhcException
(CmdLineError "error: expecting a single import declaration")
-- Otherwise assume a declaration (or a list of declarations)
=====================================
libraries/ghc-boot/GHC/Platform.hs
=====================================
@@ -2,37 +2,38 @@
-- | A description of the platform we're compiling for.
--
-module GHC.Platform (
- PlatformMini(..),
- PlatformWordSize(..),
- Platform(..), platformArch, platformOS,
- Arch(..),
- OS(..),
- ArmISA(..),
- ArmISAExt(..),
- ArmABI(..),
- PPC_64ABI(..),
- ByteOrder(..),
-
- target32Bit,
- isARM,
- osElfTarget,
- osMachOTarget,
- osSubsectionsViaSymbols,
- platformUsesFrameworks,
- platformWordSizeInBytes,
- platformWordSizeInBits,
- platformMinInt,
- platformMaxInt,
- platformMaxWord,
- platformInIntRange,
- platformInWordRange,
-
- PlatformMisc(..),
- IntegerLibrary(..),
-
- stringEncodeArch,
- stringEncodeOS,
+module GHC.Platform
+ ( PlatformMini(..)
+ , PlatformWordSize(..)
+ , Platform(..)
+ , platformArch
+ , platformOS
+ , Arch(..)
+ , OS(..)
+ , ArmISA(..)
+ , ArmISAExt(..)
+ , ArmABI(..)
+ , PPC_64ABI(..)
+ , ByteOrder(..)
+ , target32Bit
+ , isARM
+ , osElfTarget
+ , osMachOTarget
+ , osSubsectionsViaSymbols
+ , platformUsesFrameworks
+ , platformWordSizeInBytes
+ , platformWordSizeInBits
+ , platformMinInt
+ , platformMaxInt
+ , platformMaxWord
+ , platformInIntRange
+ , platformInWordRange
+ , PlatformMisc(..)
+ , IntegerLibrary(..)
+ , stringEncodeArch
+ , stringEncodeOS
+ , SseVersion (..)
+ , BmiVersion (..)
)
where
@@ -338,3 +339,24 @@ platformInIntRange platform x = x >= platformMinInt platform && x <= platformMax
-- | Test if the given Integer is representable with a platform Word
platformInWordRange :: Platform -> Integer -> Bool
platformInWordRange platform x = x >= 0 && x <= platformMaxWord platform
+
+
+--------------------------------------------------
+-- Instruction sets
+--------------------------------------------------
+
+-- | x86 SSE instructions
+data SseVersion
+ = SSE1
+ | SSE2
+ | SSE3
+ | SSE4
+ | SSE42
+ deriving (Eq, Ord)
+
+-- | x86 BMI (bit manipulation) instructions
+data BmiVersion
+ = BMI1
+ | BMI2
+ deriving (Eq, Ord)
+
=====================================
testsuite/tests/ghc-api/T9015.hs
=====================================
@@ -2,8 +2,9 @@ module Main where
import GHC
import GHC.Driver.Session
-import System.Environment
import GHC.Driver.Monad
+import GHC.Parser.Lexer (mkParserFlags)
+import System.Environment
testStrings = [
"import Data.Maybe"
@@ -52,7 +53,8 @@ main = do
where
testWithParser parser = do
dflags <- getSessionDynFlags
- liftIO . putStrLn . unlines $ map (testExpr (parser dflags)) testStrings
+ let pflags = mkParserFlags dflags
+ liftIO . putStrLn . unlines $ map (testExpr (parser pflags)) testStrings
testExpr parser expr = do
expr ++ ": " ++ show (parser expr)
=====================================
testsuite/tests/regalloc/regalloc_unit_tests.hs
=====================================
@@ -26,6 +26,8 @@ import qualified GHC.CmmToAsm.X86.Instr as X86.Instr
import GHC.Driver.Main
import GHC.StgToCmm.CgUtils
import GHC.CmmToAsm
+import GHC.CmmToAsm.Config
+import GHC.CmmToAsm.Monad as NCGConfig
import GHC.Cmm.Info.Build
import GHC.Cmm.Pipeline
import GHC.Cmm.Parser
@@ -97,13 +99,13 @@ assertIO = assertOr $ \msg -> void (throwIO . RegAllocTestException $ msg)
compileCmmForRegAllocStats ::
DynFlags ->
FilePath ->
- (DynFlags ->
+ (NCGConfig ->
NcgImpl (Alignment, RawCmmStatics) X86.Instr.Instr X86.Instr.JumpDest) ->
UniqSupply ->
IO [( Maybe [Color.RegAllocStats (Alignment, RawCmmStatics) X86.Instr.Instr]
, Maybe [Linear.RegAllocStats])]
compileCmmForRegAllocStats dflags' cmmFile ncgImplF us = do
- let ncgImpl = ncgImplF dflags
+ let ncgImpl = ncgImplF (NCGConfig.initConfig dflags)
hscEnv <- newHscEnv dflags
-- parse the cmm file and output any warnings or errors
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bca02fca0119354a6201fd5d019a553015ba2dd8...747093b7c23a1cf92b564eb3d9efe2adc15330df
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bca02fca0119354a6201fd5d019a553015ba2dd8...747093b7c23a1cf92b564eb3d9efe2adc15330df
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/20200421/d9c11c88/attachment-0001.html>
More information about the ghc-commits
mailing list