diff options
| author | Sylvain Henry <sylvain@haskus.fr> | 2020-03-01 16:37:59 +0100 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-03-15 10:57:10 -0400 |
| commit | 2e82465fff5851f00449131fdc8bacd3ca95f90f (patch) | |
| tree | cb8c8f57b1c1bf9950c514d91286b3a5463778f4 | |
| parent | dd6ffe6be742cf3ec98406704fef53ad86cc1560 (diff) | |
| download | haskell-2e82465fff5851f00449131fdc8bacd3ca95f90f.tar.gz | |
Refactor CmmToAsm (disentangle DynFlags)
This patch disentangles a bit more DynFlags from the native code
generator (CmmToAsm).
In more details:
- add a new NCGConfig datatype in GHC.CmmToAsm.Config which contains the
configuration of a native code generation session
- explicitly pass NCGConfig/Platform arguments when necessary
- as a consequence `sdocWithPlatform` is gone and there are only a few
`sdocWithDynFlags` left
- remove the use of `unsafeGlobalDynFlags` from GHC.CmmToAsm.CFG
- remove `sdocDebugLevel` (now we pass the debug level via NCGConfig)
There are still some places where DynFlags is used, especially because
of pretty-printing (CLabel), because of Cmm helpers (such as
`cmmExprType`) and because of `Outputable` instance for the
instructions. These are left for future refactoring as this patch is
already big.
42 files changed, 2001 insertions, 1738 deletions
diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs index 34217d317f..eea71d0ce9 100644 --- a/compiler/GHC/Cmm/CLabel.hs +++ b/compiler/GHC/Cmm/CLabel.hs @@ -1355,18 +1355,18 @@ instance Outputable ForeignLabelSource where internalNamePrefix :: Name -> SDoc internalNamePrefix name = getPprStyle $ \ sty -> if asmStyle sty && isRandomGenerated then - sdocWithPlatform $ \platform -> - ptext (asmTempLabelPrefix platform) + sdocWithDynFlags $ \dflags -> + ptext (asmTempLabelPrefix (targetPlatform dflags)) else empty where isRandomGenerated = not $ isExternalName name tempLabelPrefixOrUnderscore :: SDoc -tempLabelPrefixOrUnderscore = sdocWithPlatform $ \platform -> +tempLabelPrefixOrUnderscore = sdocWithDynFlags $ \dflags -> getPprStyle $ \ sty -> if asmStyle sty then - ptext (asmTempLabelPrefix platform) + ptext (asmTempLabelPrefix (targetPlatform dflags)) else char '_' diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs index 8dc9b61198..82519db084 100644 --- a/compiler/GHC/CmmToAsm.hs +++ b/compiler/GHC/CmmToAsm.hs @@ -69,6 +69,7 @@ import GHC.Platform.Reg import GHC.CmmToAsm.Monad import GHC.CmmToAsm.CFG import GHC.CmmToAsm.Dwarf +import GHC.CmmToAsm.Config import GHC.Cmm.DebugBlock import GHC.Cmm.BlockId @@ -191,14 +192,15 @@ x86_64NcgImpl :: DynFlags -> NcgImpl (Alignment, RawCmmStatics) X86.Instr.Instr X86.Instr.JumpDest x86_64NcgImpl dflags = NcgImpl { - cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen - ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr dflags + ncgConfig = config + ,cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen + ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr config ,getJumpDestBlockId = X86.Instr.getJumpDestBlockId ,canShortcut = X86.Instr.canShortcut ,shortcutStatics = X86.Instr.shortcutStatics ,shortcutJump = X86.Instr.shortcutJump - ,pprNatCmmDecl = X86.Ppr.pprNatCmmDecl - ,maxSpillSlots = X86.Instr.maxSpillSlots dflags + ,pprNatCmmDecl = X86.Ppr.pprNatCmmDecl config + ,maxSpillSlots = X86.Instr.maxSpillSlots config ,allocatableRegs = X86.Regs.allocatableRegs platform ,ncgAllocMoreStack = X86.Instr.allocMoreStack platform ,ncgExpandTop = id @@ -206,19 +208,22 @@ x86_64NcgImpl dflags ,extractUnwindPoints = X86.CodeGen.extractUnwindPoints ,invertCondBranches = X86.CodeGen.invertCondBranches } - where platform = targetPlatform dflags + where + config = initConfig dflags + platform = ncgPlatform config ppcNcgImpl :: DynFlags -> NcgImpl RawCmmStatics PPC.Instr.Instr PPC.RegInfo.JumpDest ppcNcgImpl dflags = NcgImpl { - cmmTopCodeGen = PPC.CodeGen.cmmTopCodeGen - ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr dflags + ncgConfig = config + ,cmmTopCodeGen = PPC.CodeGen.cmmTopCodeGen + ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr config ,getJumpDestBlockId = PPC.RegInfo.getJumpDestBlockId ,canShortcut = PPC.RegInfo.canShortcut ,shortcutStatics = PPC.RegInfo.shortcutStatics ,shortcutJump = PPC.RegInfo.shortcutJump - ,pprNatCmmDecl = PPC.Ppr.pprNatCmmDecl - ,maxSpillSlots = PPC.Instr.maxSpillSlots dflags + ,pprNatCmmDecl = PPC.Ppr.pprNatCmmDecl config + ,maxSpillSlots = PPC.Instr.maxSpillSlots config ,allocatableRegs = PPC.Regs.allocatableRegs platform ,ncgAllocMoreStack = PPC.Instr.allocMoreStack platform ,ncgExpandTop = id @@ -226,19 +231,22 @@ ppcNcgImpl dflags ,extractUnwindPoints = const [] ,invertCondBranches = \_ _ -> id } - where platform = targetPlatform dflags + where + config = initConfig dflags + platform = ncgPlatform config sparcNcgImpl :: DynFlags -> NcgImpl RawCmmStatics SPARC.Instr.Instr SPARC.ShortcutJump.JumpDest sparcNcgImpl dflags = NcgImpl { - cmmTopCodeGen = SPARC.CodeGen.cmmTopCodeGen + ncgConfig = config + ,cmmTopCodeGen = SPARC.CodeGen.cmmTopCodeGen ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr dflags ,getJumpDestBlockId = SPARC.ShortcutJump.getJumpDestBlockId ,canShortcut = SPARC.ShortcutJump.canShortcut ,shortcutStatics = SPARC.ShortcutJump.shortcutStatics ,shortcutJump = SPARC.ShortcutJump.shortcutJump - ,pprNatCmmDecl = SPARC.Ppr.pprNatCmmDecl - ,maxSpillSlots = SPARC.Instr.maxSpillSlots dflags + ,pprNatCmmDecl = SPARC.Ppr.pprNatCmmDecl config + ,maxSpillSlots = SPARC.Instr.maxSpillSlots config ,allocatableRegs = SPARC.Regs.allocatableRegs ,ncgAllocMoreStack = noAllocMoreStack ,ncgExpandTop = map SPARC.CodeGen.Expand.expandTop @@ -246,6 +254,8 @@ sparcNcgImpl dflags ,extractUnwindPoints = const [] ,invertCondBranches = \_ _ -> id } + where + config = initConfig dflags -- -- Allocating more stack space for spilling is currently only @@ -538,7 +548,8 @@ cmmNativeGen cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count = do - let platform = targetPlatform dflags + let config = ncgConfig ncgImpl + let platform = ncgPlatform config let proc_name = case cmm of (CmmProc _ entry_label _ _) -> ppr entry_label @@ -577,7 +588,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count -- tag instructions with register liveness information -- also drops dead code. We don't keep the cfg in sync on -- some backends, so don't use it there. - let livenessCfg = if (backendMaintainsCfg dflags) + let livenessCfg = if backendMaintainsCfg platform then Just nativeCfgWeights else Nothing let (withLiveness, usLive) = @@ -607,7 +618,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count = {-# SCC "RegAlloc-color" #-} initUs usLive $ Color.regAlloc - dflags + config alloc_regs (mkUniqSet [0 .. maxSpillSlots ncgImpl]) (maxSpillSlots ncgImpl) @@ -655,7 +666,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count -- do linear register allocation let reg_alloc proc = do (alloced, maybe_more_stack, ra_stats) <- - Linear.regAlloc dflags proc + Linear.regAlloc config proc case maybe_more_stack of Nothing -> return ( alloced, ra_stats, [] ) Just amount -> do @@ -691,11 +702,11 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count cfgRegAllocUpdates = (concatMap Linear.ra_fixupList raStats) let cfgWithFixupBlks = - (\cfg -> addNodesBetween cfg cfgRegAllocUpdates) <$> livenessCfg + (\cfg -> addNodesBetween dflags cfg cfgRegAllocUpdates) <$> livenessCfg -- Insert stack update blocks let postRegCFG = - pure (foldl' (\m (from,to) -> addImmediateSuccessor from to m )) + pure (foldl' (\m (from,to) -> addImmediateSuccessor dflags from to m )) <*> cfgWithFixupBlks <*> pure stack_updt_blks @@ -725,7 +736,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count let getBlks (CmmProc _info _lbl _live (ListGraph blocks)) = blocks getBlks _ = [] - when ( backendMaintainsCfg dflags && + when ( backendMaintainsCfg platform && (gopt Opt_DoAsmLinting dflags || debugIsOn )) $ do let blocks = concatMap getBlks shorted let labels = setFromList $ fmap blockId blocks :: LabelSet @@ -854,7 +865,7 @@ makeImportsDoc dflags imports -- security. GHC generated code does not need an executable -- stack so add the note in: (if platformHasGnuNonexecStack platform - then text ".section .note.GNU-stack,\"\"," <> sectionType "progbits" + then text ".section .note.GNU-stack,\"\"," <> sectionType platform "progbits" else Outputable.empty) $$ -- And just because every other compiler does, let's stick in @@ -865,9 +876,8 @@ makeImportsDoc dflags imports else Outputable.empty) where - platform = targetPlatform dflags - arch = platformArch platform - os = platformOS platform + config = initConfig dflags + platform = ncgPlatform config -- Generate "symbol stubs" for all external symbols that might -- come from a dynamic library. @@ -877,10 +887,10 @@ makeImportsDoc dflags imports -- (Hack) sometimes two Labels pretty-print the same, but have -- different uniques; so we compare their text versions... dyld_stubs imps - | needImportedSymbols dflags arch os + | needImportedSymbols config = vcat $ - (pprGotDeclaration dflags arch os :) $ - map ( pprImportedSymbol dflags platform . fst . head) $ + (pprGotDeclaration config :) $ + map ( pprImportedSymbol dflags config . fst . head) $ groupBy (\(_,a) (_,b) -> a == b) $ sortBy (\(_,a) (_,b) -> compare a b) $ map doPpr $ diff --git a/compiler/GHC/CmmToAsm/BlockLayout.hs b/compiler/GHC/CmmToAsm/BlockLayout.hs index 01a1388b5f..0665e71433 100644 --- a/compiler/GHC/CmmToAsm/BlockLayout.hs +++ b/compiler/GHC/CmmToAsm/BlockLayout.hs @@ -10,7 +10,7 @@ {-# LANGUAGE FlexibleContexts #-} module GHC.CmmToAsm.BlockLayout - ( sequenceTop ) + ( sequenceTop, backendMaintainsCfg) where #include "HsVersions.h" @@ -25,7 +25,8 @@ import GHC.Cmm import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label -import GHC.Driver.Session (gopt, GeneralFlag(..), DynFlags, backendMaintainsCfg) +import GHC.Platform +import GHC.Driver.Session (gopt, GeneralFlag(..), DynFlags, targetPlatform) import UniqFM import Util import Unique @@ -785,7 +786,7 @@ sequenceTop sequenceTop _ _ _ top@(CmmData _ _) = top sequenceTop dflags ncgImpl edgeWeights (CmmProc info lbl live (ListGraph blocks)) - | (gopt Opt_CfgBlocklayout dflags) && backendMaintainsCfg dflags + | (gopt Opt_CfgBlocklayout dflags) && backendMaintainsCfg (targetPlatform dflags) --Use chain based algorithm , Just cfg <- edgeWeights = CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $ @@ -799,7 +800,7 @@ sequenceTop dflags ncgImpl edgeWeights sequenceBlocks cfg info blocks) where dontUseCfg = gopt Opt_WeightlessBlocklayout dflags || - (not $ backendMaintainsCfg dflags) + (not $ backendMaintainsCfg (targetPlatform dflags)) -- The old algorithm: -- It is very simple (and stupid): We make a graph out of @@ -893,3 +894,10 @@ lookupDeleteUFM :: Uniquable key => UniqFM elt -> key lookupDeleteUFM m k = do -- Maybe monad v <- lookupUFM m k return (v, delFromUFM m k) + +backendMaintainsCfg :: Platform -> Bool +backendMaintainsCfg platform = case platformArch platform of + -- ArchX86 -- Should work but not tested so disabled currently. + ArchX86_64 -> True + _otherwise -> False + diff --git a/compiler/GHC/CmmToAsm/CFG.hs b/compiler/GHC/CmmToAsm/CFG.hs index f52ff514b1..0995ecab61 100644 --- a/compiler/GHC/CmmToAsm/CFG.hs +++ b/compiler/GHC/CmmToAsm/CFG.hs @@ -328,12 +328,12 @@ shortcutWeightMap cuts cfg = -- \ \ -- -> C => -> C -- -addImmediateSuccessor :: BlockId -> BlockId -> CFG -> CFG -addImmediateSuccessor node follower cfg +addImmediateSuccessor :: D.DynFlags -> BlockId -> BlockId -> CFG -> CFG +addImmediateSuccessor dflags node follower cfg = updateEdges . addWeightEdge node follower uncondWeight $ cfg where uncondWeight = fromIntegral . D.uncondWeight . - D.cfgWeightInfo $ D.unsafeGlobalDynFlags + D.cfgWeightInfo $ dflags targets = getSuccessorEdges cfg node successors = map fst targets :: [BlockId] updateEdges = addNewSuccs . remOldSuccs @@ -508,13 +508,13 @@ mapWeights f cfg = -- these cases. -- We assign the old edge info to the edge A -> B and assign B -> C the -- weight of an unconditional jump. -addNodesBetween :: CFG -> [(BlockId,BlockId,BlockId)] -> CFG -addNodesBetween m updates = +addNodesBetween :: D.DynFlags -> CFG -> [(BlockId,BlockId,BlockId)] -> CFG +addNodesBetween dflags m updates = foldl' updateWeight m . weightUpdates $ updates where weight = fromIntegral . D.uncondWeight . - D.cfgWeightInfo $ D.unsafeGlobalDynFlags + D.cfgWeightInfo $ dflags -- We might add two blocks for different jumps along a single -- edge. So we end up with edges: A -> B -> C , A -> D -> C -- in this case after applying the first update the weight for A -> C diff --git a/compiler/GHC/CmmToAsm/Config.hs b/compiler/GHC/CmmToAsm/Config.hs new file mode 100644 index 0000000000..2df3655948 --- /dev/null +++ b/compiler/GHC/CmmToAsm/Config.hs @@ -0,0 +1,32 @@ +-- | Native code generator configuration +module GHC.CmmToAsm.Config + ( NCGConfig(..) + , ncgWordWidth + ) +where + +import GhcPrelude +import GHC.Platform +import GHC.Cmm.Type (Width(..)) + +-- | 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 + } + +-- | Return Word size +ncgWordWidth :: NCGConfig -> Width +ncgWordWidth config = case platformWordSize (ncgPlatform config) of + PW4 -> W32 + PW8 -> W64 diff --git a/compiler/GHC/CmmToAsm/Dwarf.hs b/compiler/GHC/CmmToAsm/Dwarf.hs index cdbbb9885a..9270a308a8 100644 --- a/compiler/GHC/CmmToAsm/Dwarf.hs +++ b/compiler/GHC/CmmToAsm/Dwarf.hs @@ -36,6 +36,7 @@ dwarfGen :: DynFlags -> ModLocation -> UniqSupply -> [DebugBlock] -> IO (SDoc, UniqSupply) dwarfGen _ _ us [] = return (empty, us) dwarfGen df modLoc us blocks = do + let platform = targetPlatform df -- Convert debug data structures to DWARF info records -- We strip out block information when running with -g0 or -g1. @@ -64,33 +65,33 @@ dwarfGen df modLoc us blocks = do haveSrc = any haveSrcIn procs -- .debug_abbrev section: Declare the format we're using - let abbrevSct = pprAbbrevDecls haveSrc + let abbrevSct = pprAbbrevDecls platform haveSrc -- .debug_info section: Information records on procedures and blocks let -- unique to identify start and end compilation unit .debug_inf (unitU, us') = takeUniqFromSupply us infoSct = vcat [ ptext dwarfInfoLabel <> colon - , dwarfInfoSection - , compileUnitHeader unitU - , pprDwarfInfo haveSrc dwarfUnit + , dwarfInfoSection platform + , compileUnitHeader platform unitU + , pprDwarfInfo platform haveSrc dwarfUnit , compileUnitFooter unitU ] -- .debug_line section: Generated mainly by the assembler, but we -- need to label it - let lineSct = dwarfLineSection $$ + let lineSct = dwarfLineSection platform $$ ptext dwarfLineLabel <> colon -- .debug_frame section: Information about the layout of the GHC stack let (framesU, us'') = takeUniqFromSupply us' - frameSct = dwarfFrameSection $$ + frameSct = dwarfFrameSection platform $$ ptext dwarfFrameLabel <> colon $$ - pprDwarfFrame (debugFrame framesU procs) + pprDwarfFrame platform (debugFrame framesU procs) -- .aranges section: Information about the bounds of compilation units let aranges' | gopt Opt_SplitSections df = map mkDwarfARange procs | otherwise = [DwarfARange lowLabel highLabel] - let aranges = dwarfARangesSection $$ pprDwarfARanges aranges' unitU + let aranges = dwarfARangesSection platform $$ pprDwarfARanges platform aranges' unitU return (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'') @@ -106,17 +107,17 @@ mkDwarfARange proc = DwarfARange start end -- | Header for a compilation unit, establishing global format -- parameters -compileUnitHeader :: Unique -> SDoc -compileUnitHeader unitU = sdocWithPlatform $ \plat -> +compileUnitHeader :: Platform -> Unique -> SDoc +compileUnitHeader platform unitU = let cuLabel = mkAsmTempLabel unitU -- sits right before initialLength field length = ppr (mkAsmTempEndLabel cuLabel) <> char '-' <> ppr cuLabel <> text "-4" -- length of initialLength field in vcat [ ppr cuLabel <> colon , text "\t.long " <> length -- compilation unit size , pprHalf 3 -- DWARF version - , sectionOffset (ptext dwarfAbbrevLabel) (ptext dwarfAbbrevLabel) + , sectionOffset platform (ptext dwarfAbbrevLabel) (ptext dwarfAbbrevLabel) -- abbrevs offset - , text "\t.byte " <> ppr (platformWordSizeInBytes plat) -- word size + , text "\t.byte " <> ppr (platformWordSizeInBytes platform) -- word size ] -- | Compilation unit footer, mainly establishing size of debug sections @@ -176,7 +177,7 @@ parent, B. -- | Generate DWARF info for a procedure debug block procToDwarf :: DynFlags -> DebugBlock -> DwarfInfo procToDwarf df prc - = DwarfSubprogram { dwChildren = map (blockToDwarf df) (dblBlocks prc) + = DwarfSubprogram { dwChildren = map blockToDwarf (dblBlocks prc) , dwName = case dblSourceTick prc of Just s@SourceNote{} -> sourceName s _otherwise -> showSDocDump df $ ppr $ dblLabel prc @@ -195,10 +196,10 @@ procToDwarf df prc goodParent _ = True -- | Generate DWARF info for a block -blockToDwarf :: DynFlags -> DebugBlock -> DwarfInfo -blockToDwarf df blk - = DwarfBlock { dwChildren = concatMap (tickToDwarf df) (dblTicks blk) - ++ map (blockToDwarf df) (dblBlocks blk) +blockToDwarf :: DebugBlock -> DwarfInfo +blockToDwarf blk + = DwarfBlock { dwChildren = concatMap tickToDwarf (dblTicks blk) + ++ map blockToDwarf (dblBlocks blk) , dwLabel = dblCLabel blk , dwMarker = marker } @@ -207,9 +208,9 @@ blockToDwarf df blk | Just _ <- dblPosition blk = Just $ mkAsmTempLabel $ dblLabel blk | otherwise = Nothing -- block was optimized out -tickToDwarf :: DynFlags -> Tickish () -> [DwarfInfo] -tickToDwarf _ (SourceNote ss _) = [DwarfSrcNote ss] -tickToDwarf _ _ = [] +tickToDwarf :: Tickish () -> [DwarfInfo] +tickToDwarf (SourceNote ss _) = [DwarfSrcNote ss] +tickToDwarf _ = [] -- | Generates the data for the debug frame section, which encodes the -- desired stack unwind behaviour for the debugger diff --git a/compiler/GHC/CmmToAsm/Dwarf/Constants.hs b/compiler/GHC/CmmToAsm/Dwarf/Constants.hs index 4ab54b6629..16bdded699 100644 --- a/compiler/GHC/CmmToAsm/Dwarf/Constants.hs +++ b/compiler/GHC/CmmToAsm/Dwarf/Constants.hs @@ -144,20 +144,20 @@ dW_OP_call_frame_cfa = 0x9c -- * Dwarf section declarations dwarfInfoSection, dwarfAbbrevSection, dwarfLineSection, - dwarfFrameSection, dwarfGhcSection, dwarfARangesSection :: SDoc -dwarfInfoSection = dwarfSection "info" -dwarfAbbrevSection = dwarfSection "abbrev" -dwarfLineSection = dwarfSection "line" -dwarfFrameSection = dwarfSection "frame" -dwarfGhcSection = dwarfSection "ghc" -dwarfARangesSection = dwarfSection "aranges" - -dwarfSection :: String -> SDoc -dwarfSection name = sdocWithPlatform $ \plat -> - case platformOS plat of + dwarfFrameSection, dwarfGhcSection, dwarfARangesSection :: Platform -> SDoc +dwarfInfoSection platform = dwarfSection platform "info" +dwarfAbbrevSection platform = dwarfSection platform "abbrev" +dwarfLineSection platform = dwarfSection platform "line" +dwarfFrameSection platform = dwarfSection platform "frame" +dwarfGhcSection platform = dwarfSection platform "ghc" +dwarfARangesSection platform = dwarfSection platform "aranges" + +dwarfSection :: Platform -> String -> SDoc +dwarfSection platform name = + case platformOS platform of os | osElfTarget os -> text "\t.section .debug_" <> text name <> text ",\"\"," - <> sectionType "progbits" + <> sectionType platform "progbits" | osMachOTarget os -> text "\t.section __DWARF,__debug_" <> text name <> text ",regular,debug" | otherwise diff --git a/compiler/GHC/CmmToAsm/Dwarf/Types.hs b/compiler/GHC/CmmToAsm/Dwarf/Types.hs index 5eda37a653..c54815aff7 100644 --- a/compiler/GHC/CmmToAsm/Dwarf/Types.hs +++ b/compiler/GHC/CmmToAsm/Dwarf/Types.hs @@ -90,8 +90,8 @@ pprAbbrev = pprLEBWord . fromIntegral . fromEnum -- | Abbreviation declaration. This explains the binary encoding we -- use for representing 'DwarfInfo'. Be aware that this must be updated -- along with 'pprDwarfInfo'. -pprAbbrevDecls :: Bool -> SDoc -pprAbbrevDecls haveDebugLine = +pprAbbrevDecls :: Platform -> Bool -> SDoc +pprAbbrevDecls platform haveDebugLine = let mkAbbrev abbr tag chld flds = let fld (tag, form) = pprLEBWord tag $$ pprLEBWord form in pprAbbrev abbr $$ pprLEBWord tag $$ pprByte chld $$ @@ -106,7 +106,7 @@ pprAbbrevDecls haveDebugLine = , (dW_AT_high_pc, dW_FORM_addr) , (dW_AT_frame_base, dW_FORM_block1) ] - in dwarfAbbrevSection $$ + in dwarfAbbrevSection platform $$ ptext dwarfAbbrevLabel <> colon $$ mkAbbrev DwAbbrCompileUnit dW_TAG_compile_unit dW_CHILDREN_yes ([(dW_AT_name, dW_FORM_string) @@ -142,8 +142,8 @@ pprAbbrevDecls haveDebugLine = pprByte 0 -- | Generate assembly for DWARF data -pprDwarfInfo :: Bool -> DwarfInfo -> SDoc -pprDwarfInfo haveSrc d +pprDwarfInfo :: Platform -> Bool -> DwarfInfo -> SDoc +pprDwarfInfo platform haveSrc d = case d of DwarfCompileUnit {} -> hasChildren DwarfSubprogram {} -> hasChildren @@ -151,36 +151,36 @@ pprDwarfInfo haveSrc d DwarfSrcNote {} -> noChildren where hasChildren = - pprDwarfInfoOpen haveSrc d $$ - vcat (map (pprDwarfInfo haveSrc) (dwChildren d)) $$ + pprDwarfInfoOpen platform haveSrc d $$ + vcat (map (pprDwarfInfo platform haveSrc) (dwChildren d)) $$ pprDwarfInfoClose - noChildren = pprDwarfInfoOpen haveSrc d + noChildren = pprDwarfInfoOpen platform haveSrc d -- | Prints assembler data corresponding to DWARF info records. Note -- that the binary format of this is parameterized in @abbrevDecls@ and -- has to be kept in synch. -pprDwarfInfoOpen :: Bool -> DwarfInfo -> SDoc -pprDwarfInfoOpen haveSrc (DwarfCompileUnit _ name producer compDir lowLabel +pprDwarfInfoOpen :: Platform -> Bool -> DwarfInfo -> SDoc +pprDwarfInfoOpen platform haveSrc (DwarfCompileUnit _ name producer compDir lowLabel highLabel lineLbl) = pprAbbrev DwAbbrCompileUnit $$ pprString name $$ pprString producer $$ pprData4 dW_LANG_Haskell $$ pprString compDir - $$ pprWord (ppr lowLabel) - $$ pprWord (ppr highLabel) + $$ pprWord platform (ppr lowLabel) + $$ pprWord platform (ppr highLabel) $$ if haveSrc - then sectionOffset (ptext lineLbl) (ptext dwarfLineLabel) + then sectionOffset platform (ptext lineLbl) (ptext dwarfLineLabel) else empty -pprDwarfInfoOpen _ (DwarfSubprogram _ name label +pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label parent) = sdocWithDynFlags $ \df -> ppr (mkAsmTempDieLabel label) <> colon $$ pprAbbrev abbrev $$ pprString name $$ pprString (renderWithStyle (initSDocContext df (mkCodeStyle CStyle)) (ppr label)) $$ pprFlag (externallyVisibleCLabel label) - $$ pprWord (ppr label) - $$ pprWord (ppr $ mkAsmTempEndLabel label) + $$ pprWord platform (ppr label) + $$ pprWord platform (ppr $ mkAsmTempEndLabel label) $$ pprByte 1 $$ pprByte dW_OP_call_frame_cfa $$ parentValue @@ -188,18 +188,18 @@ pprDwarfInfoOpen _ (DwarfSubprogram _ name label abbrev = case parent of Nothing -> DwAbbrSubprogram Just _ -> DwAbbrSubprogramWithParent parentValue = maybe empty pprParentDie parent - pprParentDie sym = sectionOffset (ppr sym) (ptext dwarfInfoLabel) -pprDwarfInfoOpen _ (DwarfBlock _ label Nothing) = sdocWithDynFlags $ \df -> + pprParentDie sym = sectionOffset platform (ppr sym) (ptext dwarfInfoLabel) +pprDwarfInfoOpen _ _ (DwarfBlock _ label Nothing) = sdocWithDynFlags $ \df -> ppr (mkAsmTempDieLabel label) <> colon $$ pprAbbrev DwAbbrBlockWithoutCode $$ pprString (renderWithStyle (initSDocContext df (mkCodeStyle CStyle)) (ppr label)) -pprDwarfInfoOpen _ (DwarfBlock _ label (Just marker)) = sdocWithDynFlags $ \df -> +pprDwarfInfoOpen platform _ (DwarfBlock _ label (Just marker)) = sdocWithDynFlags $ \df -> ppr (mkAsmTempDieLabel label) <> colon $$ pprAbbrev DwAbbrBlock $$ pprString (renderWithStyle (initSDocContext df (mkCodeStyle CStyle)) (ppr label)) - $$ pprWord (ppr marker) - $$ pprWord (ppr $ mkAsmTempEndLabel marker) -pprDwarfInfoOpen _ (DwarfSrcNote ss) = + $$ pprWord platform (ppr marker) + $$ pprWord platform (ppr $ mkAsmTempEndLabel marker) +pprDwarfInfoOpen _ _ (DwarfSrcNote ss) = pprAbbrev DwAbbrGhcSrcNote $$ pprString' (ftext $ srcSpanFile ss) $$ pprData4 (fromIntegral $ srcSpanStartLine ss) @@ -222,9 +222,9 @@ data DwarfARange -- | Print assembler directives corresponding to a DWARF @.debug_aranges@ -- address table entry. -pprDwarfARanges :: [DwarfARange] -> Unique -> SDoc -pprDwarfARanges arngs unitU = sdocWithPlatform $ \plat -> - let wordSize = platformWordSizeInBytes plat +pprDwarfARanges :: Platform -> [DwarfARange] -> Unique -> SDoc +pprDwarfARanges platform arngs unitU = + let wordSize = platformWordSizeInBytes platform paddingSize = 4 :: Int -- header is 12 bytes long. -- entry is 8 bytes (32-bit platform) or 16 bytes (64-bit platform). @@ -234,19 +234,19 @@ pprDwarfARanges arngs unitU = sdocWithPlatform $ \plat -> initialLength = 8 + paddingSize + (1 + length arngs) * 2 * wordSize in pprDwWord (ppr initialLength) $$ pprHalf 2 - $$ sectionOffset (ppr $ mkAsmTempLabel $ unitU) - (ptext dwarfInfoLabel) + $$ sectionOffset platform (ppr $ mkAsmTempLabel $ unitU) + (ptext dwarfInfoLabel) $$ pprByte (fromIntegral wordSize) $$ pprByte 0 $$ pad paddingSize -- body - $$ vcat (map pprDwarfARange arngs) + $$ vcat (map (pprDwarfARange platform) arngs) -- terminus - $$ pprWord (char '0') - $$ pprWord (char '0') + $$ pprWord platform (char '0') + $$ pprWord platform (char '0') -pprDwarfARange :: DwarfARange -> SDoc -pprDwarfARange arng = pprWord (ppr $ dwArngStartLabel arng) $$ pprWord length +pprDwarfARange :: Platform -> DwarfARange -> SDoc +pprDwarfARange platform arng = pprWord platform (ppr $ dwArngStartLabel arng) $$ pprWord platform length where length = ppr (dwArngEndLabel arng) <> char '-' <> ppr (dwArngStartLabel arng) @@ -286,21 +286,20 @@ instance Outputable DwarfFrameBlock where -- | Header for the @.debug_frame@ section. Here we emit the "Common -- Information Entry" record that establishes general call frame -- parameters and the default stack layout. -pprDwarfFrame :: DwarfFrame -> SDoc -pprDwarfFrame DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs} - = sdocWithPlatform $ \plat -> - let cieStartLabel= mkAsmTempDerivedLabel cieLabel (fsLit "_start") +pprDwarfFrame :: Platform -> DwarfFrame -> SDoc +pprDwarfFrame platform DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs} + = let cieStartLabel= mkAsmTempDerivedLabel cieLabel (fsLit "_start") cieEndLabel = mkAsmTempEndLabel cieLabel length = ppr cieEndLabel <> char '-' <> ppr cieStartLabel - spReg = dwarfGlobalRegNo plat Sp - retReg = dwarfReturnRegNo plat - wordSize = platformWordSizeInBytes plat + spReg = dwarfGlobalRegNo platform Sp + retReg = dwarfReturnRegNo platform + wordSize = platformWordSizeInBytes platform pprInit :: (GlobalReg, Maybe UnwindExpr) -> SDoc - pprInit (g, uw) = pprSetUnwind plat g (Nothing, uw) + pprInit (g, uw) = pprSetUnwind platform g (Nothing, uw) -- Preserve C stack pointer: This necessary to override that default -- unwinding behavior of setting $sp = CFA. - preserveSp = case platformArch plat of + preserveSp = case platformArch platform of ArchX86 -> pprByte dW_CFA_same_value $$ pprLEBWord 4 ArchX86_64 -> pprByte dW_CFA_same_value $$ pprLEBWord 7 _ -> empty @@ -333,16 +332,16 @@ pprDwarfFrame DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs} , pprLEBWord (fromIntegral spReg) , pprLEBWord 0 ] $$ - wordAlign $$ + wordAlign platform $$ ppr cieEndLabel <> colon $$ -- Procedure unwind tables - vcat (map (pprFrameProc cieLabel cieInit) procs) + vcat (map (pprFrameProc platform cieLabel cieInit) procs) -- | Writes a "Frame Description Entry" for a procedure. This consists -- mainly of referencing the CIE and writing state machine -- instructions to describe how the frame base (CFA) changes. -pprFrameProc :: CLabel -> UnwindTable -> DwarfFrameProc -> SDoc -pprFrameProc frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks) +pprFrameProc :: Platform -> CLabel -> UnwindTable -> DwarfFrameProc -> SDoc +pprFrameProc platform frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks) = let fdeLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde") fdeEndLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde_end") procEnd = mkAsmTempEndLabel procLbl @@ -353,20 +352,20 @@ pprFrameProc frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks) , ppr fdeLabel <> colon , pprData4' (ppr frameLbl <> char '-' <> ptext dwarfFrameLabel) -- Reference to CIE - , pprWord (ppr procLbl <> ifInfo "-1") -- Code pointer - , pprWord (ppr procEnd <> char '-' <> - ppr procLbl <> ifInfo "+1") -- Block byte length + , pprWord platform (ppr procLbl <> ifInfo "-1") -- Code pointer + , pprWord platform (ppr procEnd <> char '-' <> + ppr procLbl <> ifInfo "+1") -- Block byte length ] $$ - vcat (S.evalState (mapM pprFrameBlock blocks) initUw) $$ - wordAlign $$ + vcat (S.evalState (mapM (pprFrameBlock platform) blocks) initUw) $$ + wordAlign platform $$ ppr fdeEndLabel <> colon -- | Generates unwind information for a block. We only generate -- instructions where unwind information actually changes. This small -- optimisations saves a lot of space, as subsequent blocks often have -- the same unwind information. -pprFrameBlock :: DwarfFrameBlock -> S.State UnwindTable SDoc -pprFrameBlock (DwarfFrameBlock hasInfo uws0) = +pprFrameBlock :: Platform -> DwarfFrameBlock -> S.State UnwindTable SDoc +pprFrameBlock platform (DwarfFrameBlock hasInfo uws0) = vcat <$> zipWithM pprFrameDecl (True : repeat False) uws0 where pprFrameDecl :: Bool -> UnwindPoint -> S.State UnwindTable SDoc @@ -393,9 +392,8 @@ pprFrameBlock (DwarfFrameBlock hasInfo uws0) = needsOffset = firstDecl && hasInfo lblDoc = ppr lbl <> if needsOffset then text "-1" else empty - doc = sdocWithPlatform $ \plat -> - pprByte dW_CFA_set_loc $$ pprWord lblDoc $$ - vcat (map (uncurry $ pprSetUnwind plat) changed) + doc = pprByte dW_CFA_set_loc $$ pprWord platform lblDoc $$ + vcat (map (uncurry $ pprSetUnwind platform) changed) in (doc, uws) -- Note [Info Offset] @@ -452,8 +450,8 @@ pprSetUnwind plat Sp (_, Just (UwReg s' o')) else pprByte dW_CFA_def_cfa_sf $$ pprLEBRegNo plat s' $$ pprLEBInt o' -pprSetUnwind _ Sp (_, Just uw) - = pprByte dW_CFA_def_cfa_expression $$ pprUnwindExpr False uw +pprSetUnwind plat Sp (_, Just uw) + = pprByte dW_CFA_def_cfa_expression $$ pprUnwindExpr plat False uw pprSetUnwind plat g (_, Just (UwDeref (UwReg Sp o))) | o < 0 && ((-o) `mod` platformWordSizeInBytes plat) == 0 -- expected case = pprByte (dW_CFA_offset + dwarfGlobalRegNo plat g) $$ @@ -465,7 +463,7 @@ pprSetUnwind plat g (_, Just (UwDeref (UwReg Sp o))) pprSetUnwind plat g (_, Just (UwDeref uw)) = pprByte dW_CFA_expression $$ pprLEBRegNo plat g $$ - pprUnwindExpr True uw + pprUnwindExpr plat True uw pprSetUnwind plat g (_, Just (UwReg g' 0)) | g == g' = pprByte dW_CFA_same_value $$ @@ -473,7 +471,7 @@ pprSetUnwind plat g (_, Just (UwReg g' 0)) pprSetUnwind plat g (_, Just uw) = pprByte dW_CFA_val_expression $$ pprLEBRegNo plat g $$ - pprUnwindExpr True uw + pprUnwindExpr plat True uw -- | Print the register number of the given 'GlobalReg' as an unsigned LEB128 -- encoded number. @@ -483,20 +481,19 @@ pprLEBRegNo plat = pprLEBWord . fromIntegral . dwarfGlobalRegNo plat -- | Generates a DWARF expression for the given unwind expression. If -- @spIsCFA@ is true, we see @Sp@ as the frame base CFA where it gets -- mentioned. -pprUnwindExpr :: Bool -> UnwindExpr -> SDoc -pprUnwindExpr spIsCFA expr - = sdocWithPlatform $ \plat -> - let pprE (UwConst i) +pprUnwindExpr :: Platform -> Bool -> UnwindExpr -> SDoc +pprUnwindExpr platform spIsCFA expr + = let pprE (UwConst i) | i >= 0 && i < 32 = pprByte (dW_OP_lit0 + fromIntegral i) | otherwise = pprByte dW_OP_consts $$ pprLEBInt i -- lazy... pprE (UwReg Sp i) | spIsCFA = if i == 0 then pprByte dW_OP_call_frame_cfa else pprE (UwPlus (UwReg Sp 0) (UwConst i)) - pprE (UwReg g i) = pprByte (dW_OP_breg0+dwarfGlobalRegNo plat g) $$ + pprE (UwReg g i) = pprByte (dW_OP_breg0+dwarfGlobalRegNo platform g) $$ pprLEBInt i pprE (UwDeref u) = pprE u $$ pprByte dW_OP_deref - pprE (UwLabel l) = pprByte dW_OP_addr $$ pprWord (ppr l) + pprE (UwLabel l) = pprByte dW_OP_addr $$ pprWord platform (ppr l) pprE (UwPlus u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_plus pprE (UwMinus u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_minus pprE (UwTimes u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_mul @@ -514,8 +511,8 @@ pprUndefUnwind plat g = pprByte dW_CFA_undefined $$ -- | Align assembly at (machine) word boundary -wordAlign :: SDoc -wordAlign = sdocWithPlatform $ \plat -> +wordAlign :: Platform -> SDoc +wordAlign plat = text "\t.align " <> case platformOS plat of OSDarwin -> case platformWordSize plat of PW8 -> char '3' @@ -549,11 +546,11 @@ pprDwWord = pprData4' -- | Assembly for a machine word of dynamic data. Depends on the -- architecture we are currently generating code for. -pprWord :: SDoc -> SDoc -pprWord s = (<> s) . sdocWithPlatform $ \plat -> +pprWord :: Platform -> SDoc -> SDoc +pprWord plat s = case platformWordSize plat of - PW4 -> text "\t.long " - PW8 -> text "\t.quad " + PW4 -> text "\t.long " <> s + PW8 -> text "\t.quad " <> s -- | Prints a number in "little endian base 128" format. The idea is -- to optimize for small numbers by stopping once all further bytes @@ -604,8 +601,8 @@ escapeChar c -- us to just reference the target directly, and will figure out on -- their own that we actually need an offset. Finally, Windows has -- a special directive to refer to relative offsets. Fun. -sectionOffset :: SDoc -> SDoc -> SDoc -sectionOffset target section = sdocWithPlatform $ \plat -> +sectionOffset :: Platform -> SDoc -> SDoc -> SDoc +sectionOffset plat target section = case platformOS plat of OSDarwin -> pprDwWord (target <> char '-' <> section) OSMinGW32 -> text "\t.secrel32 " <> target diff --git a/compiler/GHC/CmmToAsm/Instr.hs b/compiler/GHC/CmmToAsm/Instr.hs index 44fa9b7cc9..01f703340b 100644 --- a/compiler/GHC/CmmToAsm/Instr.hs +++ b/compiler/GHC/CmmToAsm/Instr.hs @@ -16,14 +16,15 @@ where import GhcPrelude +import GHC.Platform import GHC.Platform.Reg import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label -import GHC.Driver.Session import GHC.Cmm hiding (topInfoTable) -import GHC.Platform + +import GHC.CmmToAsm.Config -- | Holds a list of source and destination registers used by a -- particular instruction. @@ -132,7 +133,7 @@ class Instruction instr where -- | An instruction to spill a register into a spill slot. mkSpillInstr - :: DynFlags + :: NCGConfig -> Reg -- ^ the reg to spill -> Int -- ^ the current stack delta -> Int -- ^ spill slot to use @@ -141,7 +142,7 @@ class Instruction instr where -- | An instruction to reload a register from a spill slot. mkLoadInstr - :: DynFlags + :: NCGConfig -> Reg -- ^ the reg to reload. -> Int -- ^ the current stack delta -> Int -- ^ the spill slot to use diff --git a/compiler/GHC/CmmToAsm/Monad.hs b/compiler/GHC/CmmToAsm/Monad.hs index c9414a2eee..89e64d5e79 100644 --- a/compiler/GHC/CmmToAsm/Monad.hs +++ b/compiler/GHC/CmmToAsm/Monad.hs @@ -16,6 +16,7 @@ module GHC.CmmToAsm.Monad ( NatM, -- instance Monad initNat, + initConfig, addImportNat, addNodeBetweenNat, addImmediateSuccessorNat, @@ -23,6 +24,8 @@ module GHC.CmmToAsm.Monad ( getUniqueNat, mapAccumLNat, setDeltaNat, + getConfig, + getPlatform, getDeltaNat, getThisModuleNat, getBlockIdNat, @@ -45,9 +48,11 @@ where import GhcPrelude +import GHC.Platform import GHC.Platform.Reg import GHC.CmmToAsm.Format import GHC.CmmToAsm.Reg.Target +import GHC.CmmToAsm.Config import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Collections @@ -69,6 +74,7 @@ import GHC.Cmm (RawCmmDecl, RawCmmStatics) import GHC.CmmToAsm.CFG data NcgImpl statics instr jumpDest = NcgImpl { + ncgConfig :: !NCGConfig, cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl statics instr], generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr), getJumpDestBlockId :: jumpDest -> Maybe BlockId, @@ -102,6 +108,7 @@ data NatM_State natm_imports :: [(CLabel)], natm_pic :: Maybe Reg, natm_dflags :: DynFlags, + natm_config :: NCGConfig, natm_this_module :: Module, natm_modloc :: ModLocation, natm_fileid :: DwarfFiles, @@ -130,6 +137,7 @@ mkNatM_State us delta dflags this_mod , natm_imports = [] , natm_pic = Nothing , natm_dflags = dflags + , natm_config = initConfig dflags , natm_this_module = this_mod , natm_modloc = loc , natm_fileid = dwf @@ -137,6 +145,24 @@ mkNatM_State us delta dflags this_mod , natm_cfg = cfg } +-- | 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 + } + + initNat :: NatM_State -> NatM a -> (a, NatM_State) initNat init_st m = case unNat m init_st of { (r,st) -> (r,st) } @@ -232,8 +258,9 @@ addNodeBetweenNat from between to -- | Place `succ` after `block` and change any edges -- block -> X to `succ` -> X addImmediateSuccessorNat :: BlockId -> BlockId -> NatM () -addImmediateSuccessorNat block succ - = updateCfgNat (addImmediateSuccessor block succ) +addImmediateSuccessorNat block succ = do + dflags <- getDynFlags + updateCfgNat (addImmediateSuccessor dflags block succ) getBlockIdNat :: NatM BlockId getBlockIdNat @@ -249,16 +276,16 @@ getNewLabelNat getNewRegNat :: Format -> NatM Reg getNewRegNat rep = do u <- getUniqueNat - dflags <- getDynFlags - return (RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep) + platform <- getPlatform + return (RegVirtual $ targetMkVirtualReg platform u rep) getNewRegPairNat :: Format -> NatM (Reg,Reg) getNewRegPairNat rep = do u <- getUniqueNat - dflags <- getDynFlags - let vLo = targetMkVirtualReg (targetPlatform dflags) u rep - let lo = RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep + platform <- getPlatform + let vLo = targetMkVirtualReg platform u rep + let lo = RegVirtual $ targetMkVirtualReg platform u rep let hi = RegVirtual $ getHiVirtualRegFromLo vLo return (lo, hi) @@ -282,6 +309,14 @@ getModLoc :: NatM ModLocation getModLoc = NatM $ \ st -> (natm_modloc st, st) +-- | Get native code generator configuration +getConfig :: NatM NCGConfig +getConfig = NatM $ \st -> (natm_config st, st) + +-- | Get target platform from native code generator configuration +getPlatform :: NatM Platform +getPlatform = ncgPlatform <$> getConfig + getFileId :: FastString -> NatM Int getFileId f = NatM $ \st -> case lookupUFM (natm_fileid st) f of diff --git a/compiler/GHC/CmmToAsm/PIC.hs b/compiler/GHC/CmmToAsm/PIC.hs index 323d93d173..d4d8b55e7e 100644 --- a/compiler/GHC/CmmToAsm/PIC.hs +++ b/compiler/GHC/CmmToAsm/PIC.hs @@ -57,6 +57,7 @@ import GHC.Platform import GHC.CmmToAsm.Instr import GHC.Platform.Reg import GHC.CmmToAsm.Monad +import GHC.CmmToAsm.Config import GHC.Cmm.Dataflow.Collections @@ -163,7 +164,7 @@ cmmMakePicReference dflags lbl | OSAIX <- platformOS $ targetPlatform dflags = CmmMachOp (MO_Add W32) [ CmmReg (CmmGlobal PicBaseReg) - , CmmLit $ picRelative dflags + , CmmLit $ picRelative (wordWidth dflags) (platformArch $ targetPlatform dflags) (platformOS $ targetPlatform dflags) lbl ] @@ -172,7 +173,7 @@ cmmMakePicReference dflags lbl | ArchPPC_64 _ <- platformArch $ targetPlatform dflags = CmmMachOp (MO_Add W32) -- code model medium [ CmmReg (CmmGlobal PicBaseReg) - , CmmLit $ picRelative dflags + , CmmLit $ picRelative (wordWidth dflags) (platformArch $ targetPlatform dflags) (platformOS $ targetPlatform dflags) lbl ] @@ -181,7 +182,7 @@ cmmMakePicReference dflags lbl && absoluteLabel lbl = CmmMachOp (MO_Add (wordWidth dflags)) [ CmmReg (CmmGlobal PicBaseReg) - , CmmLit $ picRelative dflags + , CmmLit $ picRelative (wordWidth dflags) (platformArch $ targetPlatform dflags) (platformOS $ targetPlatform dflags) lbl ] @@ -404,7 +405,7 @@ howToAccessLabel dflags _ _ _ _ _ -- | Says what we have to add to our 'PIC base register' in order to -- get the address of a label. -picRelative :: DynFlags -> Arch -> OS -> CLabel -> CmmLit +picRelative :: Width -> Arch -> OS -> CLabel -> CmmLit -- Darwin, but not x86_64: -- The PIC base register points to the PIC base label at the beginning @@ -413,15 +414,15 @@ picRelative :: DynFlags -> Arch -> OS -> CLabel -> CmmLit -- We have already made sure that all labels that are not from the current -- module are accessed indirectly ('as' can't calculate differences between -- undefined labels). -picRelative dflags arch OSDarwin lbl +picRelative width arch OSDarwin lbl | arch /= ArchX86_64 - = CmmLabelDiffOff lbl mkPicBaseLabel 0 (wordWidth dflags) + = CmmLabelDiffOff lbl mkPicBaseLabel 0 width -- On AIX we use an indirect local TOC anchored by 'gotLabel'. -- This way we use up only one global TOC entry per compilation-unit -- (this is quite similar to GCC's @-mminimal-toc@ compilation mode) -picRelative dflags _ OSAIX lbl - = CmmLabelDiffOff lbl gotLabel 0 (wordWidth dflags) +picRelative width _ OSAIX lbl + = CmmLabelDiffOff lbl gotLabel 0 width -- PowerPC Linux: -- The PIC base register points to our fake GOT. Use a label difference @@ -429,9 +430,9 @@ picRelative dflags _ OSAIX lbl -- We have made sure that *everything* is accessed indirectly, so this -- is only used for offsets from the GOT to symbol pointers inside the -- GOT. -picRelative dflags ArchPPC os lbl +picRelative width ArchPPC os lbl | osElfTarget os - = CmmLabelDiffOff lbl gotLabel 0 (wordWidth dflags) + = CmmLabelDiffOff lbl gotLabel 0 width -- Most Linux versions: @@ -453,14 +454,14 @@ picRelative _ arch os lbl in result picRelative _ _ _ _ - = panic "PositionIndependentCode.picRelative undefined for this platform" + = panic "GHC.CmmToAsm.PIC.picRelative undefined for this platform" -------------------------------------------------------------------------------- -needImportedSymbols :: DynFlags -> Arch -> OS -> Bool -needImportedSymbols dflags arch os +needImportedSymbols :: NCGConfig -> Bool +needImportedSymbols config | os == OSDarwin , arch /= ArchX86_64 = True @@ -471,7 +472,7 @@ needImportedSymbols dflags arch os -- PowerPC Linux: -fPIC or -dynamic | osElfTarget os , arch == ArchPPC - = positionIndependent dflags || gopt Opt_ExternalDynamicRefs dflags + = ncgPIC config || ncgExternalDynamicRefs config -- PowerPC 64 Linux: always | osElfTarget os @@ -481,11 +482,15 @@ needImportedSymbols dflags arch os -- i386 (and others?): -dynamic but not -fPIC | osElfTarget os , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2 - = gopt Opt_ExternalDynamicRefs dflags && - not (positionIndependent dflags) + = ncgExternalDynamicRefs config && + not (ncgPIC config) | otherwise = False + where + platform = ncgPlatform config + arch = platformArch platform + os = platformOS platform -- gotLabel -- The label used to refer to our "fake GOT" from @@ -499,13 +504,16 @@ gotLabel --------------------------------------------------------------------------------- +-- Emit GOT declaration +-- Output whatever needs to be output once per .s file. +-- -- We don't need to declare any offset tables. -- However, for PIC on x86, we need a small helper function. -pprGotDeclaration :: DynFlags -> Arch -> OS -> SDoc -pprGotDeclaration dflags ArchX86 OSDarwin - | positionIndependent dflags - = vcat [ +pprGotDeclaration :: NCGConfig -> SDoc +pprGotDeclaration config = case (arch,os) of + (ArchX86, OSDarwin) + | ncgPIC config + -> vcat [ text ".section __TEXT,__textcoal_nt,coalesced,no_toc", text ".weak_definition ___i686.get_pc_thunk.ax", text ".private_extern ___i686.get_pc_thunk.ax", @@ -513,48 +521,49 @@ pprGotDeclaration dflags ArchX86 OSDarwin text "\tmovl (%esp), %eax", text "\tret" ] -pprGotDeclaration _ _ OSDarwin - = empty - --- Emit XCOFF TOC section -pprGotDeclaration _ _ OSAIX - = vcat $ [ text ".toc" - , text ".tc ghc_toc_table[TC],.LCTOC1" - , text ".csect ghc_toc_table[RW]" - -- See Note [.LCTOC1 in PPC PIC code] - , text ".set .LCTOC1,$+0x8000" - ] - - --- PPC 64 ELF v1 needs a Table Of Contents (TOC) -pprGotDeclaration _ (ArchPPC_64 ELF_V1) _ - = text ".section \".toc\",\"aw\"" --- In ELF v2 we also need to tell the assembler that we want ABI --- version 2. This would normally be done at the top of the file --- right after a file directive, but I could not figure out how --- to do that. -pprGotDeclaration _ (ArchPPC_64 ELF_V2) _ - = vcat [ text ".abiversion 2", - text ".section \".toc\",\"aw\"" - ] + (_, OSDarwin) -> empty --- Emit GOT declaration --- Output whatever needs to be output once per .s file. -pprGotDeclaration dflags arch os + -- Emit XCOFF TOC section + (_, OSAIX) + -> vcat $ [ text ".toc" + , text ".tc ghc_toc_table[TC],.LCTOC1" + , text ".csect ghc_toc_table[RW]" + -- See Note [.LCTOC1 in PPC PIC code] + , text ".set .LCTOC1,$+0x8000" + ] + + + -- PPC 64 ELF v1 needs a Table Of Contents (TOC) + (ArchPPC_64 ELF_V1, _) + -> text ".section \".toc\",\"aw\"" + + -- In ELF v2 we also need to tell the assembler that we want ABI + -- version 2. This would normally be done at the top of the file + -- right after a file directive, but I could not figure out how + -- to do that. + (ArchPPC_64 ELF_V2, _) + -> vcat [ text ".abiversion 2", + text ".section \".toc\",\"aw\"" + ] + + (arch, os) | osElfTarget os , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2 - , not (positionIndependent dflags) - = empty + , not (ncgPIC config) + -> empty | osElfTarget os , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2 - = vcat [ + -> vcat [ -- See Note [.LCTOC1 in PPC PIC code] text ".section \".got2\",\"aw\"", text ".LCTOC1 = .+32768" ] -pprGotDeclaration _ _ _ - = panic "pprGotDeclaration: no match" + _ -> panic "pprGotDeclaration: no match" + where + platform = ncgPlatform config + arch = platformArch platform + os = platformOS platform -------------------------------------------------------------------------------- @@ -563,43 +572,44 @@ pprGotDeclaration _ _ _ -- and one for non-PIC. -- -pprImportedSymbol :: DynFlags -> Platform -> CLabel -> SDoc -pprImportedSymbol dflags (Platform { platformMini = PlatformMini { platformMini_arch = ArchX86, platformMini_os = OSDarwin } }) importedLbl +pprImportedSymbol :: DynFlags -> NCGConfig -> CLabel -> SDoc +pprImportedSymbol dflags config importedLbl = case (arch,os) of + (ArchX86, OSDarwin) | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl - = case positionIndependent dflags of - False -> - vcat [ - text ".symbol_stub", - text "L" <> pprCLabel dflags lbl <> ptext (sLit "$stub:"), - text "\t.indirect_symbol" <+> pprCLabel dflags lbl, - text "\tjmp *L" <> pprCLabel dflags lbl - <> text "$lazy_ptr", - text "L" <> pprCLabel dflags lbl - <> text "$stub_binder:", - text "\tpushl $L" <> pprCLabel dflags lbl - <> text "$lazy_ptr", - text "\tjmp dyld_stub_binding_helper" - ] - True -> - vcat [ - text ".section __TEXT,__picsymbolstub2," - <> text "symbol_stubs,pure_instructions,25", - text "L" <> pprCLabel dflags lbl <> ptext (sLit "$stub:"), - text "\t.indirect_symbol" <+> pprCLabel dflags lbl, - text "\tcall ___i686.get_pc_thunk.ax", - text "1:", - text "\tmovl L" <> pprCLabel dflags lbl - <> text "$lazy_ptr-1b(%eax),%edx", - text "\tjmp *%edx", - text "L" <> pprCLabel dflags lbl - <> text "$stub_binder:", - text "\tlea L" <> pprCLabel dflags lbl - <> text "$lazy_ptr-1b(%eax),%eax", - text "\tpushl %eax", - text "\tjmp dyld_stub_binding_helper" - ] - $+$ vcat [ text ".section __DATA, __la_sym_ptr" - <> (if positionIndependent dflags then int 2 else int 3) + -> if not pic + then + vcat [ + text ".symbol_stub", + text "L" <> pprCLabel dflags lbl <> ptext (sLit "$stub:"), + text "\t.indirect_symbol" <+> pprCLabel dflags lbl, + text "\tjmp *L" <> pprCLabel dflags lbl + <> text "$lazy_ptr", + text "L" <> pprCLabel dflags lbl + <> text "$stub_binder:", + text "\tpushl $L" <> pprCLabel dflags lbl + <> text "$lazy_ptr", + text "\tjmp dyld_stub_binding_helper" + ] + else + vcat [ + text ".section __TEXT,__picsymbolstub2," + <> text "symbol_stubs,pure_instructions,25", + text "L" <> pprCLabel dflags lbl <> ptext (sLit "$stub:"), + text "\t.indirect_symbol" <+> pprCLabel dflags lbl, + text "\tcall ___i686.get_pc_thunk.ax", + text "1:", + text "\tmovl L" <> pprCLabel dflags lbl + <> text "$lazy_ptr-1b(%eax),%edx", + text "\tjmp *%edx", + text "L" <> pprCLabel dflags lbl + <> text "$stub_binder:", + text "\tlea L" <> pprCLabel dflags lbl + <> text "$lazy_ptr-1b(%eax),%eax", + text "\tpushl %eax", + text "\tjmp dyld_stub_binding_helper" + ] + $+$ vcat [ text ".section __DATA, __la_sym_ptr" + <> (if pic then int 2 else int 3) <> text ",lazy_symbol_pointers", text "L" <> pprCLabel dflags lbl <> ptext (sLit "$lazy_ptr:"), text "\t.indirect_symbol" <+> pprCLabel dflags lbl, @@ -607,71 +617,68 @@ pprImportedSymbol dflags (Platform { platformMini = PlatformMini { platformMini_ <> text "$stub_binder"] | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl - = vcat [ + -> vcat [ text ".non_lazy_symbol_pointer", char 'L' <> pprCLabel dflags lbl <> text "$non_lazy_ptr:", text "\t.indirect_symbol" <+> pprCLabel dflags lbl, text "\t.long\t0"] | otherwise - = empty + -> empty + (_, OSDarwin) -> empty -pprImportedSymbol _ (Platform { platformMini = PlatformMini { platformMini_os = OSDarwin } }) _ - = empty --- XCOFF / AIX --- --- Similar to PPC64 ELF v1, there's dedicated TOC register (r2). To --- workaround the limitation of a global TOC we use an indirect TOC --- with the label `ghc_toc_table`. --- --- See also GCC's `-mminimal-toc` compilation mode or --- http://www.ibm.com/developerworks/rational/library/overview-toc-aix/ --- --- NB: No DSO-support yet + -- XCOFF / AIX + -- + -- Similar to PPC64 ELF v1, there's dedicated TOC register (r2). To + -- workaround the limitation of a global TOC we use an indirect TOC + -- with the label `ghc_toc_table`. + -- + -- See also GCC's `-mminimal-toc` compilation mode or + -- http://www.ibm.com/developerworks/rational/library/overview-toc-aix/ + -- + -- NB: No DSO-support yet -pprImportedSymbol dflags (Platform { platformMini = PlatformMini { platformMini_os = OSAIX } }) importedLbl - = case dynamicLinkerLabelInfo importedLbl of + (_, OSAIX) -> case dynamicLinkerLabelInfo importedLbl of Just (SymbolPtr, lbl) -> vcat [ text "LC.." <> pprCLabel dflags lbl <> char ':', text "\t.long" <+> pprCLabel dflags lbl ] _ -> empty --- ELF / Linux --- --- In theory, we don't need to generate any stubs or symbol pointers --- by hand for Linux. --- --- Reality differs from this in two areas. --- --- 1) If we just use a dynamically imported symbol directly in a read-only --- section of the main executable (as GCC does), ld generates R_*_COPY --- relocations, which are fundamentally incompatible with reversed info --- tables. Therefore, we need a table of imported addresses in a writable --- section. --- The "official" GOT mechanism (label@got) isn't intended to be used --- in position dependent code, so we have to create our own "fake GOT" --- when not Opt_PIC && WayDyn `elem` ways dflags. --- --- 2) PowerPC Linux is just plain broken. --- While it's theoretically possible to use GOT offsets larger --- than 16 bit, the standard crt*.o files don't, which leads to --- linker errors as soon as the GOT size exceeds 16 bit. --- Also, the assembler doesn't support @gotoff labels. --- In order to be able to use a larger GOT, we have to circumvent the --- entire GOT mechanism and do it ourselves (this is also what GCC does). - - --- When needImportedSymbols is defined, --- the NCG will keep track of all DynamicLinkerLabels it uses --- and output each of them using pprImportedSymbol. - -pprImportedSymbol dflags platform@(Platform { platformMini = PlatformMini { platformMini_arch = ArchPPC_64 _ } }) - importedLbl - | osElfTarget (platformOS platform) - = case dynamicLinkerLabelInfo importedLbl of + -- ELF / Linux + -- + -- In theory, we don't need to generate any stubs or symbol pointers + -- by hand for Linux. + -- + -- Reality differs from this in two areas. + -- + -- 1) If we just use a dynamically imported symbol directly in a read-only + -- section of the main executable (as GCC does), ld generates R_*_COPY + -- relocations, which are fundamentally incompatible with reversed info + -- tables. Therefore, we need a table of imported addresses in a writable + -- section. + -- The "official" GOT mechanism (label@got) isn't intended to be used + -- in position dependent code, so we have to create our own "fake GOT" + -- when not Opt_PIC && WayDyn `elem` ways dflags. + -- + -- 2) PowerPC Linux is just plain broken. + -- While it's theoretically possible to use GOT offsets larger + -- than 16 bit, the standard crt*.o files don't, which leads to + -- linker errors as soon as the GOT size exceeds 16 bit. + -- Also, the assembler doesn't support @gotoff labels. + -- In order to be able to use a larger GOT, we have to circumvent the + -- entire GOT mechanism and do it ourselves (this is also what GCC does). + + + -- When needImportedSymbols is defined, + -- the NCG will keep track of all DynamicLinkerLabels it uses + -- and output each of them using pprImportedSymbol. + + (ArchPPC_64 _, _) + | osElfTarget os + -> case dynamicLinkerLabelInfo importedLbl of Just (SymbolPtr, lbl) -> vcat [ text ".section \".toc\", \"aw\"", @@ -679,11 +686,10 @@ pprImportedSymbol dflags platform@(Platform { platformMini = PlatformMini { plat text "\t.quad" <+> pprCLabel dflags lbl ] _ -> empty -pprImportedSymbol dflags platform importedLbl - | osElfTarget (platformOS platform) - = case dynamicLinkerLabelInfo importedLbl of + _ | osElfTarget os + -> case dynamicLinkerLabelInfo importedLbl of Just (SymbolPtr, lbl) - -> let symbolSize = case wordWidth dflags of + -> let symbolSize = case ncgWordWidth config of W32 -> sLit "\t.long" W64 -> sLit "\t.quad" _ -> panic "Unknown wordRep in pprImportedSymbol" @@ -696,8 +702,12 @@ pprImportedSymbol dflags platform importedLbl -- PLT code stubs are generated automatically by the dynamic linker. _ -> empty -pprImportedSymbol _ _ _ - = panic "PIC.pprImportedSymbol: no match" + _ -> panic "PIC.pprImportedSymbol: no match" + where + platform = ncgPlatform config + arch = platformArch platform + os = platformOS platform + pic = ncgPIC config -------------------------------------------------------------------------------- -- Generate code to calculate the address that should be put in the diff --git a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs index 02319171dc..531efdde68 100644 --- a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs @@ -33,11 +33,12 @@ import GHC.CmmToAsm.CPrim import GHC.CmmToAsm.Monad ( NatM, getNewRegNat, getNewLabelNat , getBlockIdNat, getPicBaseNat, getNewRegPairNat - , getPicBaseMaybeNat + , getPicBaseMaybeNat, getPlatform ) import GHC.CmmToAsm.Instr import GHC.CmmToAsm.PIC import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Config import GHC.Platform.Reg.Class import GHC.Platform.Reg import GHC.CmmToAsm.Reg.Target @@ -81,11 +82,11 @@ cmmTopCodeGen cmmTopCodeGen (CmmProc info lab live graph) = do let blocks = toBlockListEntryFirst graph (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks - dflags <- getDynFlags + platform <- getPlatform let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) tops = proc : concat statics - os = platformOS $ targetPlatform dflags - arch = platformArch $ targetPlatform dflags + os = platformOS platform + arch = platformArch platform case arch of ArchPPC | os == OSAIX -> return tops | otherwise -> do @@ -149,6 +150,7 @@ stmtsToInstrs stmts stmtToInstrs :: CmmNode e x -> NatM InstrBlock stmtToInstrs stmt = do dflags <- getDynFlags + platform <- getPlatform case stmt of CmmComment s -> return (unitOL (COMMENT s)) CmmTick {} -> return nilOL @@ -156,7 +158,7 @@ stmtToInstrs stmt = do CmmAssign reg src | isFloatType ty -> assignReg_FltCode format reg src - | target32Bit (targetPlatform dflags) && + | target32Bit platform && isWord64 ty -> assignReg_I64Code reg src | otherwise -> assignReg_IntCode format reg src where ty = cmmRegType dflags reg @@ -164,7 +166,7 @@ stmtToInstrs stmt = do CmmStore addr src | isFloatType ty -> assignMem_FltCode format addr src - | target32Bit (targetPlatform dflags) && + | target32Bit platform && isWord64 ty -> assignMem_I64Code addr src | otherwise -> assignMem_IntCode format addr src where ty = cmmExprType dflags src @@ -178,18 +180,14 @@ stmtToInstrs stmt = do b1 <- genCondJump true arg prediction b2 <- genBranch false return (b1 `appOL` b2) - CmmSwitch arg ids -> do dflags <- getDynFlags - genSwitch dflags arg ids + CmmSwitch arg ids -> genSwitch dflags arg ids CmmCall { cml_target = arg - , cml_args_regs = gregs } -> do - dflags <- getDynFlags - genJump arg (jumpRegs dflags gregs) + , cml_args_regs = gregs } -> genJump arg (jumpRegs platform gregs) _ -> panic "stmtToInstrs: statement should have been cps'd away" -jumpRegs :: DynFlags -> [GlobalReg] -> [Reg] -jumpRegs dflags gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ] - where platform = targetPlatform dflags +jumpRegs :: Platform -> [GlobalReg] -> [Reg] +jumpRegs platform gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ] -------------------------------------------------------------------------------- -- | 'InstrBlock's are the insn sequences generated by the insn selectors. @@ -230,8 +228,8 @@ getRegisterReg platform (CmmGlobal mid) -- platform. Hence ... -- | Convert a BlockId to some CmmStatic data -jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic -jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags)) +jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic +jumpTableEntry config Nothing = CmmStaticLit (CmmInt 0 (ncgWordWidth config)) jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel) where blockLabel = blockLbl blockid @@ -801,11 +799,11 @@ getAmode DS (CmmMachOp (MO_Add W64) [x, CmmLit (CmmInt i _)]) -- (needed for PIC) getAmode _ (CmmMachOp (MO_Add W32) [x, CmmLit lit]) = do - dflags <- getDynFlags + platform <- getPlatform (src, srcCode) <- getSomeReg x let imm = litToImm lit case () of - _ | OSAIX <- platformOS (targetPlatform dflags) + _ | OSAIX <- platformOS platform , isCmmLabelType lit -> -- HA16/LO16 relocations on labels not supported on AIX return (Amode (AddrRegImm src imm) srcCode) @@ -821,8 +819,8 @@ getAmode _ (CmmMachOp (MO_Add W32) [x, CmmLit lit]) getAmode _ (CmmLit lit) = do - dflags <- getDynFlags - case platformArch $ targetPlatform dflags of + platform <- getPlatform + case platformArch platform of ArchPPC -> do tmp <- getNewRegNat II32 let imm = litToImm lit @@ -911,8 +909,8 @@ getCondCode _ = panic "getCondCode(2)(powerpc)" condIntCode :: Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode condIntCode cond width x y = do - dflags <- getDynFlags - condIntCode' (target32Bit (targetPlatform dflags)) cond width x y + platform <- getPlatform + condIntCode' (target32Bit platform) cond width x y condIntCode' :: Bool -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode @@ -1749,13 +1747,13 @@ genCCall' dflags gcp target dest_regs args -- TODO: Do not create a new stack frame if delta is too large. move_sp_down finalStack - | delta > stackFrameHeaderSize dflags = + | delta > stackFrameHeaderSize platform = toOL [STU spFormat sp (AddrRegImm sp (ImmInt (-delta))), DELTA (-delta)] | otherwise = nilOL where delta = stackDelta finalStack move_sp_up finalStack - | delta > stackFrameHeaderSize dflags = + | delta > stackFrameHeaderSize platform = toOL [ADD sp sp (RIImm (ImmInt delta)), DELTA 0] | otherwise = nilOL @@ -2096,19 +2094,18 @@ genSwitch dflags expr targets return code where (offset, ids) = switchTargetsToTable targets -generateJumpTableForInstr :: DynFlags -> Instr +generateJumpTableForInstr :: NCGConfig -> Instr -> Maybe (NatCmmDecl RawCmmStatics Instr) -generateJumpTableForInstr dflags (BCTR ids (Just lbl) _) = +generateJumpTableForInstr config (BCTR ids (Just lbl) _) = let jumpTable - | (positionIndependent dflags) - || (not $ target32Bit $ targetPlatform dflags) + | (ncgPIC config) || (not $ target32Bit $ ncgPlatform config) = map jumpTableEntryRel ids - | otherwise = map (jumpTableEntry dflags) ids + | otherwise = map (jumpTableEntry config) ids where jumpTableEntryRel Nothing - = CmmStaticLit (CmmInt 0 (wordWidth dflags)) + = CmmStaticLit (CmmInt 0 (ncgWordWidth config)) jumpTableEntryRel (Just blockid) = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0 - (wordWidth dflags)) + (ncgWordWidth config)) where blockLabel = blockLbl blockid in Just (CmmData (Section ReadOnlyData lbl) (RawCmmStatics lbl jumpTable)) generateJumpTableForInstr _ _ = Nothing @@ -2124,7 +2121,7 @@ generateJumpTableForInstr _ _ = Nothing condReg :: NatM CondCode -> NatM Register condReg getCond = do CondCode _ cond cond_code <- getCond - dflags <- getDynFlags + platform <- getPlatform let code dst = cond_code `appOL` negate_code @@ -2151,7 +2148,7 @@ condReg getCond = do GU -> (1, False) _ -> panic "PPC.CodeGen.codeReg: no match" - format = archWordFormat $ target32Bit $ targetPlatform dflags + format = archWordFormat $ target32Bit platform return (Any format code) condIntReg :: Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register @@ -2324,8 +2321,8 @@ remainderCode rep sgn reg_q arg_x arg_y = do coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register coerceInt2FP fromRep toRep x = do - dflags <- getDynFlags - let arch = platformArch $ targetPlatform dflags + platform <- getPlatform + let arch = platformArch platform coerceInt2FP' arch fromRep toRep x coerceInt2FP' :: Arch -> Width -> Width -> CmmExpr -> NatM Register @@ -2335,6 +2332,7 @@ coerceInt2FP' ArchPPC fromRep toRep x = do itmp <- getNewRegNat II32 ftmp <- getNewRegNat FF64 dflags <- getDynFlags + platform <- getPlatform dynRef <- cmmMakeDynamicReference dflags DataReference lbl Amode addr addr_code <- getAmode D dynRef let @@ -2343,10 +2341,10 @@ coerceInt2FP' ArchPPC fromRep toRep x = do [CmmStaticLit (CmmInt 0x43300000 W32), CmmStaticLit (CmmInt 0x80000000 W32)], XORIS itmp src (ImmInt 0x8000), - ST II32 itmp (spRel dflags 3), + ST II32 itmp (spRel platform 3), LIS itmp (ImmInt 0x4330), - ST II32 itmp (spRel dflags 2), - LD FF64 ftmp (spRel dflags 2) + ST II32 itmp (spRel platform 2), + LD FF64 ftmp (spRel platform 2) ] `appOL` addr_code `appOL` toOL [ LD FF64 dst addr, FSUB FF64 dst ftmp dst @@ -2372,11 +2370,11 @@ coerceInt2FP' ArchPPC fromRep toRep x = do -- So it is fine. coerceInt2FP' (ArchPPC_64 _) fromRep toRep x = do (src, code) <- getSomeReg x - dflags <- getDynFlags + platform <- getPlatform let code' dst = code `appOL` maybe_exts `appOL` toOL [ - ST II64 src (spRel dflags 3), - LD FF64 dst (spRel dflags 3), + ST II64 src (spRel platform 3), + LD FF64 dst (spRel platform 3), FCFID dst dst ] `appOL` maybe_frsp dst @@ -2400,13 +2398,13 @@ coerceInt2FP' _ _ _ _ = panic "PPC.CodeGen.coerceInt2FP: unknown arch" coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register coerceFP2Int fromRep toRep x = do - dflags <- getDynFlags - let arch = platformArch $ targetPlatform dflags + platform <- getPlatform + let arch = platformArch platform coerceFP2Int' arch fromRep toRep x coerceFP2Int' :: Arch -> Width -> Width -> CmmExpr -> NatM Register coerceFP2Int' ArchPPC _ toRep x = do - dflags <- getDynFlags + platform <- getPlatform -- the reps don't really matter: F*->FF64 and II32->I* are no-ops (src, code) <- getSomeReg x tmp <- getNewRegNat FF64 @@ -2415,13 +2413,13 @@ coerceFP2Int' ArchPPC _ toRep x = do -- convert to int in FP reg FCTIWZ tmp src, -- store value (64bit) from FP to stack - ST FF64 tmp (spRel dflags 2), + ST FF64 tmp (spRel platform 2), -- read low word of value (high word is undefined) - LD II32 dst (spRel dflags 3)] + LD II32 dst (spRel platform 3)] return (Any (intFormat toRep) code') coerceFP2Int' (ArchPPC_64 _) _ toRep x = do - dflags <- getDynFlags + platform <- getPlatform -- the reps don't really matter: F*->FF64 and II64->I* are no-ops (src, code) <- getSomeReg x tmp <- getNewRegNat FF64 @@ -2430,8 +2428,8 @@ coerceFP2Int' (ArchPPC_64 _) _ toRep x = do -- convert to int in FP reg FCTIDZ tmp src, -- store value (64bit) from FP to compiler word on stack - ST FF64 tmp (spRel dflags 3), - LD II64 dst (spRel dflags 3)] + ST FF64 tmp (spRel platform 3), + LD II64 dst (spRel platform 3)] return (Any (intFormat toRep) code') coerceFP2Int' _ _ _ _ = panic "PPC.CodeGen.coerceFP2Int: unknown arch" diff --git a/compiler/GHC/CmmToAsm/PPC/Instr.hs b/compiler/GHC/CmmToAsm/PPC/Instr.hs index b92a952340..26742b5a17 100644 --- a/compiler/GHC/CmmToAsm/PPC/Instr.hs +++ b/compiler/GHC/CmmToAsm/PPC/Instr.hs @@ -31,6 +31,7 @@ import GHC.CmmToAsm.PPC.Cond import GHC.CmmToAsm.Instr import GHC.CmmToAsm.Format import GHC.CmmToAsm.Reg.Target +import GHC.CmmToAsm.Config import GHC.Platform.Reg.Class import GHC.Platform.Reg @@ -38,7 +39,6 @@ import GHC.Platform.Regs import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label -import GHC.Driver.Session import GHC.Cmm import GHC.Cmm.Info import FastString @@ -534,15 +534,15 @@ ppc_patchJumpInstr insn patchF -- | An instruction to spill a register into a spill slot. ppc_mkSpillInstr - :: DynFlags + :: NCGConfig -> Reg -- register to spill -> Int -- current stack delta -> Int -- spill slot to use -> Instr -ppc_mkSpillInstr dflags reg delta slot - = let platform = targetPlatform dflags - off = spillSlotToOffset dflags slot +ppc_mkSpillInstr config reg delta slot + = let platform = ncgPlatform config + off = spillSlotToOffset platform slot arch = platformArch platform in let fmt = case targetClassOfReg platform reg of @@ -559,15 +559,15 @@ ppc_mkSpillInstr dflags reg delta slot ppc_mkLoadInstr - :: DynFlags + :: NCGConfig -> Reg -- register to load -> Int -- current stack delta -> Int -- spill slot to use -> Instr -ppc_mkLoadInstr dflags reg delta slot - = let platform = targetPlatform dflags - off = spillSlotToOffset dflags slot +ppc_mkLoadInstr config reg delta slot + = let platform = ncgPlatform config + off = spillSlotToOffset platform slot arch = platformArch platform in let fmt = case targetClassOfReg platform reg of @@ -585,8 +585,8 @@ ppc_mkLoadInstr dflags reg delta slot -- | The size of a minimal stackframe header including minimal -- parameter save area. -stackFrameHeaderSize :: DynFlags -> Int -stackFrameHeaderSize dflags +stackFrameHeaderSize :: Platform -> Int +stackFrameHeaderSize platform = case platformOS platform of OSAIX -> 24 + 8 * 4 _ -> case platformArch platform of @@ -595,7 +595,6 @@ stackFrameHeaderSize dflags ArchPPC_64 ELF_V1 -> 48 + 8 * 8 ArchPPC_64 ELF_V2 -> 32 + 8 * 8 _ -> panic "PPC.stackFrameHeaderSize: not defined for this OS" - where platform = targetPlatform dflags -- | The maximum number of bytes required to spill a register. PPC32 -- has 32-bit GPRs and 64-bit FPRs, while PPC64 has 64-bit GPRs and @@ -606,11 +605,12 @@ spillSlotSize :: Int spillSlotSize = 8 -- | The number of spill slots available without allocating more. -maxSpillSlots :: DynFlags -> Int -maxSpillSlots dflags - = ((rESERVED_C_STACK_BYTES dflags - stackFrameHeaderSize dflags) - `div` spillSlotSize) - 1 --- = 0 -- useful for testing allocMoreStack +maxSpillSlots :: NCGConfig -> Int +maxSpillSlots config +-- = 0 -- useful for testing allocMoreStack + = let platform = ncgPlatform config + in ((ncgSpillPreallocSize config - stackFrameHeaderSize platform) + `div` spillSlotSize) - 1 -- | The number of bytes that the stack pointer should be aligned -- to. This is 16 both on PPC32 and PPC64 ELF (see ELF processor @@ -619,9 +619,9 @@ stackAlign :: Int stackAlign = 16 -- | Convert a spill slot number to a *byte* offset, with no sign. -spillSlotToOffset :: DynFlags -> Int -> Int -spillSlotToOffset dflags slot - = stackFrameHeaderSize dflags + spillSlotSize * slot +spillSlotToOffset :: Platform -> Int -> Int +spillSlotToOffset platform slot + = stackFrameHeaderSize platform + spillSlotSize * slot -------------------------------------------------------------------------------- diff --git a/compiler/GHC/CmmToAsm/PPC/Ppr.hs b/compiler/GHC/CmmToAsm/PPC/Ppr.hs index 550bd618ef..09f390163f 100644 --- a/compiler/GHC/CmmToAsm/PPC/Ppr.hs +++ b/compiler/GHC/CmmToAsm/PPC/Ppr.hs @@ -20,6 +20,7 @@ import GHC.CmmToAsm.Format import GHC.Platform.Reg import GHC.Platform.Reg.Class import GHC.CmmToAsm.Reg.Target +import GHC.CmmToAsm.Config import GHC.Cmm hiding (topInfoTable) import GHC.Cmm.Dataflow.Collections @@ -33,7 +34,7 @@ import Unique ( pprUniqueAlways, getUnique ) import GHC.Platform import FastString import Outputable -import GHC.Driver.Session +import GHC.Driver.Session (targetPlatform) import Data.Word import Data.Int @@ -42,30 +43,30 @@ import Data.Bits -- ----------------------------------------------------------------------------- -- Printing this stuff out -pprNatCmmDecl :: NatCmmDecl RawCmmStatics Instr -> SDoc -pprNatCmmDecl (CmmData section dats) = - pprSectionAlign section $$ pprDatas dats +pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc +pprNatCmmDecl config (CmmData section dats) = + pprSectionAlign config section + $$ pprDatas (ncgPlatform config) dats -pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = +pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = + let platform = ncgPlatform config in case topInfoTable proc of Nothing -> - sdocWithPlatform $ \platform -> -- special case for code without info table: - pprSectionAlign (Section Text lbl) $$ + pprSectionAlign config (Section Text lbl) $$ (case platformArch platform of ArchPPC_64 ELF_V1 -> pprFunctionDescriptor lbl ArchPPC_64 ELF_V2 -> pprFunctionPrologue lbl - _ -> pprLabel lbl) $$ -- blocks guaranteed not null, - -- so label needed - vcat (map (pprBasicBlock top_info) blocks) + _ -> pprLabel platform lbl) $$ -- blocks guaranteed not null, + -- so label needed + vcat (map (pprBasicBlock platform top_info) blocks) Just (RawCmmStatics info_lbl _) -> - sdocWithPlatform $ \platform -> - pprSectionAlign (Section Text info_lbl) $$ + pprSectionAlign config (Section Text info_lbl) $$ (if platformHasSubsectionsViaSymbols platform then ppr (mkDeadStripPreventer info_lbl) <> char ':' else empty) $$ - vcat (map (pprBasicBlock top_info) blocks) $$ + vcat (map (pprBasicBlock platform top_info) blocks) $$ -- above: Even the first block gets a label, because with branch-chain -- elimination, it might be the target of a goto. (if platformHasSubsectionsViaSymbols platform @@ -104,24 +105,24 @@ pprFunctionPrologue lab = pprGloblDecl lab $$ text "\t.localentry\t" <> ppr lab <> text ",.-" <> ppr lab -pprBasicBlock :: LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc -pprBasicBlock info_env (BasicBlock blockid instrs) +pprBasicBlock :: Platform -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc +pprBasicBlock platform info_env (BasicBlock blockid instrs) = maybe_infotable $$ - pprLabel (blockLbl blockid) $$ - vcat (map pprInstr instrs) + pprLabel platform (blockLbl blockid) $$ + vcat (map (pprInstr platform) instrs) where maybe_infotable = case mapLookup blockid info_env of Nothing -> empty Just (RawCmmStatics info_lbl info) -> - pprAlignForSection Text $$ - vcat (map pprData info) $$ - pprLabel info_lbl + pprAlignForSection platform Text $$ + vcat (map (pprData platform) info) $$ + pprLabel platform info_lbl -pprDatas :: RawCmmStatics -> SDoc +pprDatas :: Platform -> RawCmmStatics -> SDoc -- See note [emit-time elimination of static indirections] in CLabel. -pprDatas (RawCmmStatics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) +pprDatas _platform (RawCmmStatics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) | lbl == mkIndStaticInfoLabel , let labelInd (CmmLabelOff l _) = Just l labelInd (CmmLabel l) = Just l @@ -130,36 +131,38 @@ pprDatas (RawCmmStatics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, , alias `mayRedirectTo` ind' = pprGloblDecl alias $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind') -pprDatas (RawCmmStatics lbl dats) = vcat (pprLabel lbl : map pprData dats) +pprDatas platform (RawCmmStatics lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats) -pprData :: CmmStatic -> SDoc -pprData (CmmString str) = pprBytes str -pprData (CmmUninitialised bytes) = text ".space " <> int bytes -pprData (CmmStaticLit lit) = pprDataItem lit +pprData :: Platform -> CmmStatic -> SDoc +pprData platform d = case d of + CmmString str -> pprBytes str + CmmUninitialised bytes -> text ".space " <> int bytes + CmmStaticLit lit -> pprDataItem platform lit pprGloblDecl :: CLabel -> SDoc pprGloblDecl lbl | not (externallyVisibleCLabel lbl) = empty | otherwise = text ".globl " <> ppr lbl -pprTypeAndSizeDecl :: CLabel -> SDoc -pprTypeAndSizeDecl lbl - = sdocWithPlatform $ \platform -> - if platformOS platform == OSLinux && externallyVisibleCLabel lbl +pprTypeAndSizeDecl :: Platform -> CLabel -> SDoc +pprTypeAndSizeDecl platform lbl + = if platformOS platform == OSLinux && externallyVisibleCLabel lbl then text ".type " <> ppr lbl <> text ", @object" else empty -pprLabel :: CLabel -> SDoc -pprLabel lbl = pprGloblDecl lbl - $$ pprTypeAndSizeDecl lbl - $$ (ppr lbl <> char ':') +pprLabel :: Platform -> CLabel -> SDoc +pprLabel platform lbl = + pprGloblDecl lbl + $$ pprTypeAndSizeDecl platform lbl + $$ (ppr lbl <> char ':') -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' instance Outputable Instr where - ppr instr = pprInstr instr + ppr instr = sdocWithDynFlags $ \dflags -> + pprInstr (targetPlatform dflags) instr pprReg :: Reg -> SDoc @@ -258,16 +261,14 @@ pprAddr (AddrRegImm r1 imm) = hcat [ pprImm imm, char '(', pprReg r1, char ')' ] -pprSectionAlign :: Section -> SDoc -pprSectionAlign sec@(Section seg _) = - sdocWithPlatform $ \platform -> - pprSectionHeader platform sec $$ - pprAlignForSection seg +pprSectionAlign :: NCGConfig -> Section -> SDoc +pprSectionAlign config sec@(Section seg _) = + pprSectionHeader config sec $$ + pprAlignForSection (ncgPlatform config) seg -- | Print appropriate alignment for the given section type. -pprAlignForSection :: SectionType -> SDoc -pprAlignForSection seg = - sdocWithPlatform $ \platform -> +pprAlignForSection :: Platform -> SectionType -> SDoc +pprAlignForSection platform seg = let ppc64 = not $ target32Bit platform in ptext $ case seg of Text -> sLit ".align 2" @@ -291,199 +292,213 @@ pprAlignForSection seg = | otherwise -> sLit ".align 2" OtherSection _ -> panic "PprMach.pprSectionAlign: unknown section" -pprDataItem :: CmmLit -> SDoc -pprDataItem lit +pprDataItem :: Platform -> CmmLit -> SDoc +pprDataItem platform lit = sdocWithDynFlags $ \dflags -> - vcat (ppr_item (cmmTypeFormat $ cmmLitType dflags lit) lit dflags) + vcat (ppr_item (cmmTypeFormat $ cmmLitType dflags lit) lit) where imm = litToImm lit - archPPC_64 dflags = not $ target32Bit $ targetPlatform dflags + archPPC_64 = not $ target32Bit platform - ppr_item II8 _ _ = [text "\t.byte\t" <> pprImm imm] + ppr_item II8 _ = [text "\t.byte\t" <> pprImm imm] + ppr_item II16 _ = [text "\t.short\t" <> pprImm imm] + ppr_item II32 _ = [text "\t.long\t" <> pprImm imm] + ppr_item II64 _ + | archPPC_64 = [text "\t.quad\t" <> pprImm imm] - ppr_item II32 _ _ = [text "\t.long\t" <> pprImm imm] - - ppr_item II64 _ dflags - | archPPC_64 dflags = [text "\t.quad\t" <> pprImm imm] + ppr_item II64 (CmmInt x _) + | not archPPC_64 = + [text "\t.long\t" + <> int (fromIntegral + (fromIntegral (x `shiftR` 32) :: Word32)), + text "\t.long\t" + <> int (fromIntegral (fromIntegral x :: Word32))] - ppr_item FF32 (CmmFloat r _) _ + ppr_item FF32 (CmmFloat r _) = let bs = floatToBytes (fromRational r) in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs - ppr_item FF64 (CmmFloat r _) _ + ppr_item FF64 (CmmFloat r _) = let bs = doubleToBytes (fromRational r) in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs - ppr_item II16 _ _ = [text "\t.short\t" <> pprImm imm] + ppr_item _ _ + = panic "PPC.Ppr.pprDataItem: no match" - ppr_item II64 (CmmInt x _) dflags - | not(archPPC_64 dflags) = - [text "\t.long\t" - <> int (fromIntegral - (fromIntegral (x `shiftR` 32) :: Word32)), - text "\t.long\t" - <> int (fromIntegral (fromIntegral x :: Word32))] - ppr_item _ _ _ - = panic "PPC.Ppr.pprDataItem: no match" +pprInstr :: Platform -> Instr -> SDoc +pprInstr platform instr = case instr of + COMMENT _ + -> empty -- nuke 'em -pprInstr :: Instr -> SDoc + -- COMMENT s + -- -> if platformOS platform == OSLinux + -- then text "# " <> ftext s + -- else text "; " <> ftext s -pprInstr (COMMENT _) = empty -- nuke 'em -{- -pprInstr (COMMENT s) = - if platformOS platform == OSLinux - then text "# " <> ftext s - else text "; " <> ftext s --} -pprInstr (DELTA d) - = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d))) + DELTA d + -> pprInstr platform (COMMENT (mkFastString ("\tdelta = " ++ show d))) -pprInstr (NEWBLOCK _) - = panic "PprMach.pprInstr: NEWBLOCK" + NEWBLOCK _ + -> panic "PprMach.pprInstr: NEWBLOCK" -pprInstr (LDATA _ _) - = panic "PprMach.pprInstr: LDATA" + LDATA _ _ + -> panic "PprMach.pprInstr: LDATA" {- -pprInstr (SPILL reg slot) - = hcat [ - text "\tSPILL", - char '\t', - pprReg reg, - comma, - text "SLOT" <> parens (int slot)] - -pprInstr (RELOAD slot reg) - = hcat [ - text "\tRELOAD", - char '\t', - text "SLOT" <> parens (int slot), - comma, - pprReg reg] + SPILL reg slot + -> hcat [ + text "\tSPILL", + char '\t', + pprReg reg, + comma, + text "SLOT" <> parens (int slot)] + + RELOAD slot reg + -> hcat [ + text "\tRELOAD", + char '\t', + text "SLOT" <> parens (int slot), + comma, + pprReg reg] -} -pprInstr (LD fmt reg addr) = hcat [ - char '\t', - text "l", - ptext (case fmt of - II8 -> sLit "bz" - II16 -> sLit "hz" - II32 -> sLit "wz" - II64 -> sLit "d" - FF32 -> sLit "fs" - FF64 -> sLit "fd" - ), - case addr of AddrRegImm _ _ -> empty - AddrRegReg _ _ -> char 'x', - char '\t', - pprReg reg, - text ", ", - pprAddr addr - ] + LD fmt reg addr + -> hcat [ + char '\t', + text "l", + ptext (case fmt of + II8 -> sLit "bz" + II16 -> sLit "hz" + II32 -> sLit "wz" + II64 -> sLit "d" + FF32 -> sLit "fs" + FF64 -> sLit "fd" + ), + case addr of AddrRegImm _ _ -> empty + AddrRegReg _ _ -> char 'x', + char '\t', + pprReg reg, + text ", ", + pprAddr addr + ] + + LDFAR fmt reg (AddrRegImm source off) + -> vcat + [ pprInstr platform (ADDIS (tmpReg platform) source (HA off)) + , pprInstr platform (LD fmt reg (AddrRegImm (tmpReg platform) (LO off))) + ] -pprInstr (LDFAR fmt reg (AddrRegImm source off)) = - sdocWithPlatform $ \platform -> vcat [ - pprInstr (ADDIS (tmpReg platform) source (HA off)), - pprInstr (LD fmt reg (AddrRegImm (tmpReg platform) (LO off))) - ] -pprInstr (LDFAR _ _ _) = - panic "PPC.Ppr.pprInstr LDFAR: no match" - -pprInstr (LDR fmt reg1 addr) = hcat [ - text "\tl", - case fmt of - II32 -> char 'w' - II64 -> char 'd' - _ -> panic "PPC.Ppr.Instr LDR: no match", - text "arx\t", - pprReg reg1, - text ", ", - pprAddr addr - ] - -pprInstr (LA fmt reg addr) = hcat [ - char '\t', - text "l", - ptext (case fmt of - II8 -> sLit "ba" - II16 -> sLit "ha" - II32 -> sLit "wa" - II64 -> sLit "d" - FF32 -> sLit "fs" - FF64 -> sLit "fd" - ), - case addr of AddrRegImm _ _ -> empty - AddrRegReg _ _ -> char 'x', - char '\t', - pprReg reg, - text ", ", - pprAddr addr - ] -pprInstr (ST fmt reg addr) = hcat [ - char '\t', - text "st", - pprFormat fmt, - case addr of AddrRegImm _ _ -> empty - AddrRegReg _ _ -> char 'x', + LDFAR _ _ _ + -> panic "PPC.Ppr.pprInstr LDFAR: no match" + + LDR fmt reg1 addr + -> hcat [ + text "\tl", + case fmt of + II32 -> char 'w' + II64 -> char 'd' + _ -> panic "PPC.Ppr.Instr LDR: no match", + text "arx\t", + pprReg reg1, + text ", ", + pprAddr addr + ] + + LA fmt reg addr + -> hcat [ + char '\t', + text "l", + ptext (case fmt of + II8 -> sLit "ba" + II16 -> sLit "ha" + II32 -> sLit "wa" + II64 -> sLit "d" + FF32 -> sLit "fs" + FF64 -> sLit "fd" + ), + case addr of AddrRegImm _ _ -> empty + AddrRegReg _ _ -> char 'x', + char '\t', + pprReg reg, + text ", ", + pprAddr addr + ] + + ST fmt reg addr + -> hcat [ + char '\t', + text "st", + pprFormat fmt, + case addr of AddrRegImm _ _ -> empty + AddrRegReg _ _ -> char 'x', + char '\t', + pprReg reg, + text ", ", + pprAddr addr + ] + + STFAR fmt reg (AddrRegImm source off) + -> vcat [ pprInstr platform (ADDIS (tmpReg platform) source (HA off)) + , pprInstr platform (ST fmt reg (AddrRegImm (tmpReg platform) (LO off))) + ] + + STFAR _ _ _ + -> panic "PPC.Ppr.pprInstr STFAR: no match" + + STU fmt reg addr + -> hcat [ + char '\t', + text "st", + pprFormat fmt, + char 'u', + case addr of AddrRegImm _ _ -> empty + AddrRegReg _ _ -> char 'x', + char '\t', + pprReg reg, + text ", ", + pprAddr addr + ] + + STC fmt reg1 addr + -> hcat [ + text "\tst", + case fmt of + II32 -> char 'w' + II64 -> char 'd' + _ -> panic "PPC.Ppr.Instr STC: no match", + text "cx.\t", + pprReg reg1, + text ", ", + pprAddr addr + ] + + LIS reg imm + -> hcat [ + char '\t', + text "lis", + char '\t', + pprReg reg, + text ", ", + pprImm imm + ] + + LI reg imm + -> hcat [ + char '\t', + text "li", + char '\t', + pprReg reg, + text ", ", + pprImm imm + ] + + MR reg1 reg2 + | reg1 == reg2 -> empty + | otherwise -> hcat [ char '\t', - pprReg reg, - text ", ", - pprAddr addr - ] -pprInstr (STFAR fmt reg (AddrRegImm source off)) = - sdocWithPlatform $ \platform -> vcat [ - pprInstr (ADDIS (tmpReg platform) source (HA off)), - pprInstr (ST fmt reg (AddrRegImm (tmpReg platform) (LO off))) - ] -pprInstr (STFAR _ _ _) = - panic "PPC.Ppr.pprInstr STFAR: no match" -pprInstr (STU fmt reg addr) = hcat [ - char '\t', - text "st", - pprFormat fmt, - char 'u', - case addr of AddrRegImm _ _ -> empty - AddrRegReg _ _ -> char 'x', - char '\t', - pprReg reg, - text ", ", - pprAddr addr - ] -pprInstr (STC fmt reg1 addr) = hcat [ - text "\tst", - case fmt of - II32 -> char 'w' - II64 -> char 'd' - _ -> panic "PPC.Ppr.Instr STC: no match", - text "cx.\t", - pprReg reg1, - text ", ", - pprAddr addr - ] -pprInstr (LIS reg imm) = hcat [ - char '\t', - text "lis", - char '\t', - pprReg reg, - text ", ", - pprImm imm - ] -pprInstr (LI reg imm) = hcat [ - char '\t', - text "li", - char '\t', - pprReg reg, - text ", ", - pprImm imm - ] -pprInstr (MR reg1 reg2) - | reg1 == reg2 = empty - | otherwise = hcat [ - char '\t', - sdocWithPlatform $ \platform -> case targetClassOfReg platform reg1 of RcInteger -> text "mr" _ -> text "fmr", @@ -491,411 +506,499 @@ pprInstr (MR reg1 reg2) pprReg reg1, text ", ", pprReg reg2 - ] -pprInstr (CMP fmt reg ri) = hcat [ - char '\t', - op, - char '\t', - pprReg reg, - text ", ", - pprRI ri - ] - where - op = hcat [ - text "cmp", - pprFormat fmt, - case ri of - RIReg _ -> empty - RIImm _ -> char 'i' - ] -pprInstr (CMPL fmt reg ri) = hcat [ - char '\t', - op, - char '\t', - pprReg reg, - text ", ", - pprRI ri - ] - where - op = hcat [ - text "cmpl", - pprFormat fmt, - case ri of - RIReg _ -> empty - RIImm _ -> char 'i' - ] -pprInstr (BCC cond blockid prediction) = hcat [ - char '\t', - text "b", - pprCond cond, - pprPrediction prediction, - char '\t', - ppr lbl - ] - where lbl = mkLocalBlockLabel (getUnique blockid) - pprPrediction p = case p of - Nothing -> empty - Just True -> char '+' - Just False -> char '-' - -pprInstr (BCCFAR cond blockid prediction) = vcat [ - hcat [ - text "\tb", - pprCond (condNegate cond), - neg_prediction, - text "\t$+8" - ], - hcat [ - text "\tb\t", - ppr lbl ] - ] - where lbl = mkLocalBlockLabel (getUnique blockid) - neg_prediction = case prediction of - Nothing -> empty - Just True -> char '-' - Just False -> char '+' - -pprInstr (JMP lbl _) - -- We never jump to ForeignLabels; if we ever do, c.f. handling for "BL" - | isForeignLabel lbl = panic "PPC.Ppr.pprInstr: JMP to ForeignLabel" - | otherwise = - hcat [ -- an alias for b that takes a CLabel - char '\t', - text "b", - char '\t', - ppr lbl - ] -pprInstr (MTCTR reg) = hcat [ - char '\t', - text "mtctr", - char '\t', - pprReg reg - ] -pprInstr (BCTR _ _ _) = hcat [ - char '\t', - text "bctr" - ] -pprInstr (BL lbl _) = do - sdocWithPlatform $ \platform -> case platformOS platform of - OSAIX -> - -- On AIX, "printf" denotes a function-descriptor (for use - -- by function pointers), whereas the actual entry-code - -- address is denoted by the dot-prefixed ".printf" label. - -- Moreover, the PPC NCG only ever emits a BL instruction - -- for calling C ABI functions. Most of the time these calls - -- originate from FFI imports and have a 'ForeignLabel', - -- but when profiling the codegen inserts calls via - -- 'emitRtsCallGen' which are 'CmmLabel's even though - -- they'd technically be more like 'ForeignLabel's. - hcat [ - text "\tbl\t.", - ppr lbl - ] - _ -> - hcat [ - text "\tbl\t", - ppr lbl + CMP fmt reg ri + -> hcat [ + char '\t', + op, + char '\t', + pprReg reg, + text ", ", + pprRI ri + ] + where + op = hcat [ + text "cmp", + pprFormat fmt, + case ri of + RIReg _ -> empty + RIImm _ -> char 'i' + ] + + CMPL fmt reg ri + -> hcat [ + char '\t', + op, + char '\t', + pprReg reg, + text ", ", + pprRI ri + ] + where + op = hcat [ + text "cmpl", + pprFormat fmt, + case ri of + RIReg _ -> empty + RIImm _ -> char 'i' + ] + + BCC cond blockid prediction + -> hcat [ + char '\t', + text "b", + pprCond cond, + pprPrediction prediction, + char '\t', + ppr lbl + ] + where lbl = mkLocalBlockLabel (getUnique blockid) + pprPrediction p = case p of + Nothing -> empty + Just True -> char '+' + Just False -> char '-' + + BCCFAR cond blockid prediction + -> vcat [ + hcat [ + text "\tb", + pprCond (condNegate cond), + neg_prediction, + text "\t$+8" + ], + hcat [ + text "\tb\t", + ppr lbl + ] ] -pprInstr (BCTRL _) = hcat [ - char '\t', - text "bctrl" - ] -pprInstr (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri -pprInstr (ADDIS reg1 reg2 imm) = hcat [ - char '\t', - text "addis", - char '\t', - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - pprImm imm - ] + where lbl = mkLocalBlockLabel (getUnique blockid) + neg_prediction = case prediction of + Nothing -> empty + Just True -> char '-' + Just False -> char '+' + + JMP lbl _ + -- We never jump to ForeignLabels; if we ever do, c.f. handling for "BL" + | isForeignLabel lbl -> panic "PPC.Ppr.pprInstr: JMP to ForeignLabel" + | otherwise -> + hcat [ -- an alias for b that takes a CLabel + char '\t', + text "b", + char '\t', + ppr lbl + ] + + MTCTR reg + -> hcat [ + char '\t', + text "mtctr", + char '\t', + pprReg reg + ] -pprInstr (ADDO reg1 reg2 reg3) = pprLogic (sLit "addo") reg1 reg2 (RIReg reg3) -pprInstr (ADDC reg1 reg2 reg3) = pprLogic (sLit "addc") reg1 reg2 (RIReg reg3) -pprInstr (ADDE reg1 reg2 reg3) = pprLogic (sLit "adde") reg1 reg2 (RIReg reg3) -pprInstr (ADDZE reg1 reg2) = pprUnary (sLit "addze") reg1 reg2 -pprInstr (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3) -pprInstr (SUBFO reg1 reg2 reg3) = pprLogic (sLit "subfo") reg1 reg2 (RIReg reg3) -pprInstr (SUBFC reg1 reg2 ri) = hcat [ - char '\t', - text "subf", - case ri of - RIReg _ -> empty - RIImm _ -> char 'i', - text "c\t", - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - pprRI ri - ] -pprInstr (SUBFE reg1 reg2 reg3) = pprLogic (sLit "subfe") reg1 reg2 (RIReg reg3) -pprInstr (MULL fmt reg1 reg2 ri) = pprMul fmt reg1 reg2 ri -pprInstr (MULLO fmt reg1 reg2 reg3) = hcat [ - char '\t', - text "mull", - case fmt of - II32 -> char 'w' - II64 -> char 'd' - _ -> panic "PPC: illegal format", - text "o\t", - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - pprReg reg3 - ] -pprInstr (MFOV fmt reg) = vcat [ - hcat [ - char '\t', - text "mfxer", + BCTR _ _ _ + -> hcat [ + char '\t', + text "bctr" + ] + + BL lbl _ + -> case platformOS platform of + OSAIX -> + -- On AIX, "printf" denotes a function-descriptor (for use + -- by function pointers), whereas the actual entry-code + -- address is denoted by the dot-prefixed ".printf" label. + -- Moreover, the PPC NCG only ever emits a BL instruction + -- for calling C ABI functions. Most of the time these calls + -- originate from FFI imports and have a 'ForeignLabel', + -- but when profiling the codegen inserts calls via + -- 'emitRtsCallGen' which are 'CmmLabel's even though + -- they'd technically be more like 'ForeignLabel's. + hcat [ + text "\tbl\t.", + ppr lbl + ] + _ -> + hcat [ + text "\tbl\t", + ppr lbl + ] + + BCTRL _ + -> hcat [ + char '\t', + text "bctrl" + ] + + ADD reg1 reg2 ri + -> pprLogic (sLit "add") reg1 reg2 ri + + ADDIS reg1 reg2 imm + -> hcat [ + char '\t', + text "addis", + char '\t', + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + pprImm imm + ] + + ADDO reg1 reg2 reg3 + -> pprLogic (sLit "addo") reg1 reg2 (RIReg reg3) + + ADDC reg1 reg2 reg3 + -> pprLogic (sLit "addc") reg1 reg2 (RIReg reg3) + + ADDE reg1 reg2 reg3 + -> pprLogic (sLit "adde") reg1 reg2 (RIReg reg3) + + ADDZE reg1 reg2 + -> pprUnary (sLit "addze") reg1 reg2 + + SUBF reg1 reg2 reg3 + -> pprLogic (sLit "subf") reg1 reg2 (RIReg reg3) + + SUBFO reg1 reg2 reg3 + -> pprLogic (sLit "subfo") reg1 reg2 (RIReg reg3) + + SUBFC reg1 reg2 ri + -> hcat [ + char '\t', + text "subf", + case ri of + RIReg _ -> empty + RIImm _ -> char 'i', + text "c\t", + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + pprRI ri + ] + + SUBFE reg1 reg2 reg3 + -> pprLogic (sLit "subfe") reg1 reg2 (RIReg reg3) + + MULL fmt reg1 reg2 ri + -> pprMul fmt reg1 reg2 ri + + MULLO fmt reg1 reg2 reg3 + -> hcat [ + char '\t', + text "mull", + case fmt of + II32 -> char 'w' + II64 -> char 'd' + _ -> panic "PPC: illegal format", + text "o\t", + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + pprReg reg3 + ] + + MFOV fmt reg + -> vcat [ + hcat [ + char '\t', + text "mfxer", + char '\t', + pprReg reg + ], + hcat [ + char '\t', + text "extr", + case fmt of + II32 -> char 'w' + II64 -> char 'd' + _ -> panic "PPC: illegal format", + text "i\t", + pprReg reg, + text ", ", + pprReg reg, + text ", 1, ", + case fmt of + II32 -> text "1" + II64 -> text "33" + _ -> panic "PPC: illegal format" + ] + ] + + MULHU fmt reg1 reg2 reg3 + -> hcat [ char '\t', - pprReg reg - ], - hcat [ - char '\t', - text "extr", + text "mulh", case fmt of II32 -> char 'w' II64 -> char 'd' _ -> panic "PPC: illegal format", - text "i\t", - pprReg reg, + text "u\t", + pprReg reg1, text ", ", - pprReg reg, - text ", 1, ", - case fmt of - II32 -> text "1" - II64 -> text "33" - _ -> panic "PPC: illegal format" - ] + pprReg reg2, + text ", ", + pprReg reg3 ] -pprInstr (MULHU fmt reg1 reg2 reg3) = hcat [ - char '\t', - text "mulh", - case fmt of - II32 -> char 'w' - II64 -> char 'd' - _ -> panic "PPC: illegal format", - text "u\t", - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - pprReg reg3 - ] - -pprInstr (DIV fmt sgn reg1 reg2 reg3) = pprDiv fmt sgn reg1 reg2 reg3 + DIV fmt sgn reg1 reg2 reg3 + -> pprDiv fmt sgn reg1 reg2 reg3 -- for some reason, "andi" doesn't exist. -- we'll use "andi." instead. -pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [ - char '\t', - text "andi.", - char '\t', - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - pprImm imm - ] -pprInstr (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri -pprInstr (ANDC reg1 reg2 reg3) = pprLogic (sLit "andc") reg1 reg2 (RIReg reg3) -pprInstr (NAND reg1 reg2 reg3) = pprLogic (sLit "nand") reg1 reg2 (RIReg reg3) + AND reg1 reg2 (RIImm imm) + -> hcat [ + char '\t', + text "andi.", + char '\t', + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + pprImm imm + ] -pprInstr (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri -pprInstr (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri + AND reg1 reg2 ri + -> pprLogic (sLit "and") reg1 reg2 ri -pprInstr (ORIS reg1 reg2 imm) = hcat [ - char '\t', - text "oris", - char '\t', - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - pprImm imm - ] + ANDC reg1 reg2 reg3 + -> pprLogic (sLit "andc") reg1 reg2 (RIReg reg3) -pprInstr (XORIS reg1 reg2 imm) = hcat [ - char '\t', - text "xoris", - char '\t', - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - pprImm imm - ] + NAND reg1 reg2 reg3 + -> pprLogic (sLit "nand") reg1 reg2 (RIReg reg3) -pprInstr (EXTS fmt reg1 reg2) = hcat [ - char '\t', - text "exts", - pprFormat fmt, - char '\t', - pprReg reg1, - text ", ", - pprReg reg2 - ] -pprInstr (CNTLZ fmt reg1 reg2) = hcat [ - char '\t', - text "cntlz", - case fmt of - II32 -> char 'w' - II64 -> char 'd' - _ -> panic "PPC: illegal format", - char '\t', - pprReg reg1, - text ", ", - pprReg reg2 - ] + OR reg1 reg2 ri + -> pprLogic (sLit "or") reg1 reg2 ri -pprInstr (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2 -pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2 + XOR reg1 reg2 ri + -> pprLogic (sLit "xor") reg1 reg2 ri -pprInstr (SR II32 reg1 reg2 (RIImm (ImmInt i))) | i < 0 || i > 31 = + ORIS reg1 reg2 imm + -> hcat [ + char '\t', + text "oris", + char '\t', + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + pprImm imm + ] + + XORIS reg1 reg2 imm + -> hcat [ + char '\t', + text "xoris", + char '\t', + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + pprImm imm + ] + + EXTS fmt reg1 reg2 + -> hcat [ + char '\t', + text "exts", + pprFormat fmt, + char '\t', + pprReg reg1, + text ", ", + pprReg reg2 + ] + + CNTLZ fmt reg1 reg2 + -> hcat [ + char '\t', + text "cntlz", + case fmt of + II32 -> char 'w' + II64 -> char 'd' + _ -> panic "PPC: illegal format", + char '\t', + pprReg reg1, + text ", ", + pprReg reg2 + ] + + NEG reg1 reg2 + -> pprUnary (sLit "neg") reg1 reg2 + + NOT reg1 reg2 + -> pprUnary (sLit "not") reg1 reg2 + + SR II32 reg1 reg2 (RIImm (ImmInt i)) -- Handle the case where we are asked to shift a 32 bit register by -- less than zero or more than 31 bits. We convert this into a clear -- of the destination register. -- Fixes ticket https://gitlab.haskell.org/ghc/ghc/issues/5900 - pprInstr (XOR reg1 reg2 (RIReg reg2)) + | i < 0 || i > 31 -> pprInstr platform (XOR reg1 reg2 (RIReg reg2)) -pprInstr (SL II32 reg1 reg2 (RIImm (ImmInt i))) | i < 0 || i > 31 = + SL II32 reg1 reg2 (RIImm (ImmInt i)) -- As above for SR, but for left shifts. -- Fixes ticket https://gitlab.haskell.org/ghc/ghc/issues/10870 - pprInstr (XOR reg1 reg2 (RIReg reg2)) + | i < 0 || i > 31 -> pprInstr platform (XOR reg1 reg2 (RIReg reg2)) -pprInstr (SRA II32 reg1 reg2 (RIImm (ImmInt i))) | i > 31 = + SRA II32 reg1 reg2 (RIImm (ImmInt i)) -- PT: I don't know what to do for negative shift amounts: -- For now just panic. -- -- For shift amounts greater than 31 set all bit to the -- value of the sign bit, this also what sraw does. - pprInstr (SRA II32 reg1 reg2 (RIImm (ImmInt 31))) + | i > 31 -> pprInstr platform (SRA II32 reg1 reg2 (RIImm (ImmInt 31))) -pprInstr (SL fmt reg1 reg2 ri) = - let op = case fmt of + SL fmt reg1 reg2 ri + -> let op = case fmt of II32 -> "slw" II64 -> "sld" _ -> panic "PPC.Ppr.pprInstr: shift illegal size" in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri) -pprInstr (SR fmt reg1 reg2 ri) = - let op = case fmt of + SR fmt reg1 reg2 ri + -> let op = case fmt of II32 -> "srw" II64 -> "srd" _ -> panic "PPC.Ppr.pprInstr: shift illegal size" in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri) -pprInstr (SRA fmt reg1 reg2 ri) = - let op = case fmt of + SRA fmt reg1 reg2 ri + -> let op = case fmt of II32 -> "sraw" II64 -> "srad" _ -> panic "PPC.Ppr.pprInstr: shift illegal size" in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri) -pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [ - text "\trlwinm\t", - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - int sh, - text ", ", - int mb, - text ", ", - int me - ] - -pprInstr (CLRLI fmt reg1 reg2 n) = hcat [ - text "\tclrl", - pprFormat fmt, - text "i ", - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - int n - ] -pprInstr (CLRRI fmt reg1 reg2 n) = hcat [ - text "\tclrr", - pprFormat fmt, - text "i ", - pprReg reg1, - text ", ", - pprReg reg2, - text ", ", - int n - ] - -pprInstr (FADD fmt reg1 reg2 reg3) = pprBinaryF (sLit "fadd") fmt reg1 reg2 reg3 -pprInstr (FSUB fmt reg1 reg2 reg3) = pprBinaryF (sLit "fsub") fmt reg1 reg2 reg3 -pprInstr (FMUL fmt reg1 reg2 reg3) = pprBinaryF (sLit "fmul") fmt reg1 reg2 reg3 -pprInstr (FDIV fmt reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") fmt reg1 reg2 reg3 -pprInstr (FABS reg1 reg2) = pprUnary (sLit "fabs") reg1 reg2 -pprInstr (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2 - -pprInstr (FCMP reg1 reg2) = hcat [ - char '\t', - text "fcmpu\t0, ", - -- Note: we're using fcmpu, not fcmpo - -- The difference is with fcmpo, compare with NaN is an invalid operation. - -- We don't handle invalid fp ops, so we don't care. - -- Moreover, we use `fcmpu 0, ...` rather than `fcmpu cr0, ...` for - -- better portability since some non-GNU assembler (such as - -- IBM's `as`) tend not to support the symbolic register name cr0. - -- This matches the syntax that GCC seems to emit for PPC targets. - pprReg reg1, - text ", ", - pprReg reg2 - ] - -pprInstr (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2 -pprInstr (FCTIDZ reg1 reg2) = pprUnary (sLit "fctidz") reg1 reg2 -pprInstr (FCFID reg1 reg2) = pprUnary (sLit "fcfid") reg1 reg2 -pprInstr (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2 - -pprInstr (CRNOR dst src1 src2) = hcat [ - text "\tcrnor\t", - int dst, - text ", ", - int src1, - text ", ", - int src2 - ] - -pprInstr (MFCR reg) = hcat [ - char '\t', - text "mfcr", - char '\t', - pprReg reg - ] - -pprInstr (MFLR reg) = hcat [ - char '\t', - text "mflr", - char '\t', - pprReg reg - ] - -pprInstr (FETCHPC reg) = vcat [ - text "\tbcl\t20,31,1f", - hcat [ text "1:\tmflr\t", pprReg reg ] - ] - -pprInstr HWSYNC = text "\tsync" - -pprInstr ISYNC = text "\tisync" - -pprInstr LWSYNC = text "\tlwsync" + RLWINM reg1 reg2 sh mb me + -> hcat [ + text "\trlwinm\t", + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + int sh, + text ", ", + int mb, + text ", ", + int me + ] + + CLRLI fmt reg1 reg2 n + -> hcat [ + text "\tclrl", + pprFormat fmt, + text "i ", + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + int n + ] -pprInstr NOP = text "\tnop" + CLRRI fmt reg1 reg2 n + -> hcat [ + text "\tclrr", + pprFormat fmt, + text "i ", + pprReg reg1, + text ", ", + pprReg reg2, + text ", ", + int n + ] + FADD fmt reg1 reg2 reg3 + -> pprBinaryF (sLit "fadd") fmt reg1 reg2 reg3 + + FSUB fmt reg1 reg2 reg3 + -> pprBinaryF (sLit "fsub") fmt reg1 reg2 reg3 + + FMUL fmt reg1 reg2 reg3 + -> pprBinaryF (sLit "fmul") fmt reg1 reg2 reg3 + + FDIV fmt reg1 reg2 reg3 + -> pprBinaryF (sLit "fdiv") fmt reg1 reg2 reg3 + + FABS reg1 reg2 + -> pprUnary (sLit "fabs") reg1 reg2 + + FNEG reg1 reg2 + -> pprUnary (sLit "fneg") reg1 reg2 + + FCMP reg1 reg2 + -> hcat [ + char '\t', + text "fcmpu\t0, ", + -- Note: we're using fcmpu, not fcmpo + -- The difference is with fcmpo, compare with NaN is an invalid operation. + -- We don't handle invalid fp ops, so we don't care. + -- Moreover, we use `fcmpu 0, ...` rather than `fcmpu cr0, ...` for + -- better portability since some non-GNU assembler (such as + -- IBM's `as`) tend not to support the symbolic register name cr0. + -- This matches the syntax that GCC seems to emit for PPC targets. + pprReg reg1, + text ", ", + pprReg reg2 + ] + + FCTIWZ reg1 reg2 + -> pprUnary (sLit "fctiwz") reg1 reg2 + + FCTIDZ reg1 reg2 + -> pprUnary (sLit "fctidz") reg1 reg2 + + FCFID reg1 reg2 + -> pprUnary (sLit "fcfid") reg1 reg2 + + FRSP reg1 reg2 + -> pprUnary (sLit "frsp") reg1 reg2 + + CRNOR dst src1 src2 + -> hcat [ + text "\tcrnor\t", + int dst, + text ", ", + int src1, + text ", ", + int src2 + ] + + MFCR reg + -> hcat [ + char '\t', + text "mfcr", + char '\t', + pprReg reg + ] + + MFLR reg + -> hcat [ + char '\t', + text "mflr", + char '\t', + pprReg reg + ] + + FETCHPC reg + -> vcat [ + text "\tbcl\t20,31,1f", + hcat [ text "1:\tmflr\t", pprReg reg ] + ] + + HWSYNC + -> text "\tsync" + + ISYNC + -> text "\tisync" + + LWSYNC + -> text "\tlwsync" + + NOP + -> text "\tnop" pprLogic :: PtrString -> Reg -> Reg -> RI -> SDoc pprLogic op reg1 reg2 ri = hcat [ diff --git a/compiler/GHC/CmmToAsm/PPC/Regs.hs b/compiler/GHC/CmmToAsm/PPC/Regs.hs index 8a9a859665..90f8a62ab7 100644 --- a/compiler/GHC/CmmToAsm/PPC/Regs.hs +++ b/compiler/GHC/CmmToAsm/PPC/Regs.hs @@ -60,7 +60,6 @@ import GHC.Cmm.CLabel ( CLabel ) import Unique import GHC.Platform.Regs -import GHC.Driver.Session import Outputable import GHC.Platform @@ -199,11 +198,11 @@ addrOffset addr off -- temporaries and for excess call arguments. @fpRel@, where -- applicable, is the same but for the frame pointer. -spRel :: DynFlags +spRel :: Platform -> Int -- desired stack offset in words, positive or negative -> AddrMode -spRel dflags n = AddrRegImm sp (ImmInt (n * wORD_SIZE dflags)) +spRel platform n = AddrRegImm sp (ImmInt (n * platformWordSizeInBytes platform)) -- argRegs is the set of regs which are read for an n-argument call to C. diff --git a/compiler/GHC/CmmToAsm/Ppr.hs b/compiler/GHC/CmmToAsm/Ppr.hs index 636d2e4e3a..324bad63c4 100644 --- a/compiler/GHC/CmmToAsm/Ppr.hs +++ b/compiler/GHC/CmmToAsm/Ppr.hs @@ -25,6 +25,7 @@ import GhcPrelude import AsmUtils import GHC.Cmm.CLabel import GHC.Cmm +import GHC.CmmToAsm.Config import GHC.Driver.Session import FastString import Outputable @@ -203,48 +204,49 @@ string in source code. See #14741 for profiling results. -- identical strings in the linker. With -split-sections each string also gets -- a unique section to allow strings from unused code to be GC'd. -pprSectionHeader :: Platform -> Section -> SDoc -pprSectionHeader platform (Section t suffix) = - case platformOS platform of +pprSectionHeader :: NCGConfig -> Section -> SDoc +pprSectionHeader config (Section t suffix) = + case platformOS (ncgPlatform config) of OSAIX -> pprXcoffSectionHeader t OSDarwin -> pprDarwinSectionHeader t - OSMinGW32 -> pprGNUSectionHeader (char '$') t suffix - _ -> pprGNUSectionHeader (char '.') t suffix - -pprGNUSectionHeader :: SDoc -> SectionType -> CLabel -> SDoc -pprGNUSectionHeader sep t suffix = sdocWithDynFlags $ \dflags -> - let splitSections = gopt Opt_SplitSections dflags - subsection | splitSections = sep <> ppr suffix - | otherwise = empty - in text ".section " <> ptext (header dflags) <> subsection <> - flags dflags + OSMinGW32 -> pprGNUSectionHeader config (char '$') t suffix + _ -> pprGNUSectionHeader config (char '.') t suffix + +pprGNUSectionHeader :: NCGConfig -> SDoc -> SectionType -> CLabel -> SDoc +pprGNUSectionHeader config sep t suffix = + text ".section " <> ptext header <> subsection <> flags where - header dflags = case t of + platform = ncgPlatform config + splitSections = ncgSplitSections config + subsection + | splitSections = sep <> ppr suffix + | otherwise = empty + header = case t of Text -> sLit ".text" Data -> sLit ".data" - ReadOnlyData | OSMinGW32 <- platformOS (targetPlatform dflags) + ReadOnlyData | OSMinGW32 <- platformOS platform -> sLit ".rdata" | otherwise -> sLit ".rodata" - RelocatableReadOnlyData | OSMinGW32 <- platformOS (targetPlatform dflags) + RelocatableReadOnlyData | OSMinGW32 <- platformOS platform -- Concept does not exist on Windows, -- So map these to R/O data. -> sLit ".rdata$rel.ro" | otherwise -> sLit ".data.rel.ro" UninitialisedData -> sLit ".bss" - ReadOnlyData16 | OSMinGW32 <- platformOS (targetPlatform dflags) + ReadOnlyData16 | OSMinGW32 <- platformOS platform -> sLit ".rdata$cst16" | otherwise -> sLit ".rodata.cst16" CString - | OSMinGW32 <- platformOS (targetPlatform dflags) + | OSMinGW32 <- platformOS platform -> sLit ".rdata" | otherwise -> sLit ".rodata.str" OtherSection _ -> panic "PprBase.pprGNUSectionHeader: unknown section type" - flags dflags = case t of + flags = case t of CString - | OSMinGW32 <- platformOS (targetPlatform dflags) + | OSMinGW32 <- platformOS platform -> empty - | otherwise -> text ",\"aMS\"," <> sectionType "progbits" <> text ",1" + | otherwise -> text ",\"aMS\"," <> sectionType platform "progbits" <> text ",1" _ -> empty -- XCOFF doesn't support relocating label-differences, so we place all diff --git a/compiler/GHC/CmmToAsm/Reg/Graph.hs b/compiler/GHC/CmmToAsm/Reg/Graph.hs index 6dfe84cf95..7f0cacfcb4 100644 --- a/compiler/GHC/CmmToAsm/Reg/Graph.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph.hs @@ -16,11 +16,11 @@ import GHC.CmmToAsm.Reg.Graph.Stats import GHC.CmmToAsm.Reg.Graph.TrivColorable import GHC.CmmToAsm.Instr import GHC.CmmToAsm.Reg.Target +import GHC.CmmToAsm.Config import GHC.Platform.Reg.Class import GHC.Platform.Reg import Bag -import GHC.Driver.Session import Outputable import GHC.Platform import UniqFM @@ -45,7 +45,7 @@ maxSpinCount = 10 -- | The top level of the graph coloring register allocator. regAlloc :: (Outputable statics, Outputable instr, Instruction instr) - => DynFlags + => NCGConfig -> UniqFM (UniqSet RealReg) -- ^ registers we can use for allocation -> UniqSet Int -- ^ set of available spill slots. -> Int -- ^ current number of spill slots @@ -56,18 +56,15 @@ regAlloc -- ^ code with registers allocated, additional stacks required -- and stats for each stage of allocation -regAlloc dflags regsFree slotsFree slotsCount code cfg +regAlloc config regsFree slotsFree slotsCount code cfg = do - -- TODO: the regClass function is currently hard coded to the default - -- target architecture. Would prefer to determine this from dflags. - -- There are other uses of targetRegClass later in this module. - let platform = targetPlatform dflags + let platform = ncgPlatform config triv = trivColorable platform (targetVirtualRegSqueeze platform) (targetRealRegSqueeze platform) (code_final, debug_codeGraphs, slotsCount', _) - <- regAlloc_spin dflags 0 + <- regAlloc_spin config 0 triv regsFree slotsFree slotsCount [] code cfg @@ -94,7 +91,7 @@ regAlloc_spin (Instruction instr, Outputable instr, Outputable statics) - => DynFlags + => NCGConfig -> Int -- ^ Number of solver iterations we've already performed. -> Color.Triv VirtualReg RegClass RealReg -- ^ Function for calculating whether a register is trivially @@ -110,17 +107,18 @@ regAlloc_spin , Int -- Slots in use , Color.Graph VirtualReg RegClass RealReg) -regAlloc_spin dflags spinCount triv regsFree slotsFree slotsCount debug_codeGraphs code cfg +regAlloc_spin config spinCount triv regsFree slotsFree slotsCount debug_codeGraphs code cfg = do - let platform = targetPlatform dflags + let platform = ncgPlatform config -- If any of these dump flags are turned on we want to hang on to -- intermediate structures in the allocator - otherwise tell the -- allocator to ditch them early so we don't end up creating space leaks. let dump = or - [ dopt Opt_D_dump_asm_regalloc_stages dflags - , dopt Opt_D_dump_asm_stats dflags - , dopt Opt_D_dump_asm_conflicts dflags ] + [ ncgDumpRegAllocStages config + , ncgDumpAsmStats config + , ncgDumpAsmConflicts config + ] -- Check that we're not running off down the garden path. when (spinCount > maxSpinCount) @@ -161,14 +159,16 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree slotsCount debug_codeGrap then Just $ RegAllocStatsStart { raLiveCmm = code , raGraph = graph - , raSpillCosts = spillCosts } + , raSpillCosts = spillCosts + , raPlatform = platform + } else Nothing -- Try and color the graph. let (graph_colored, rsSpill, rmCoalesce) = {-# SCC "ColorGraph" #-} Color.colorGraph - (gopt Opt_RegsIterative dflags) + (ncgRegsIterative config) spinCount regsFree triv spill graph @@ -193,7 +193,7 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree slotsCount debug_codeGrap -- if -fasm-lint is turned on then validate the graph. -- This checks for bugs in the graph allocator itself. let graph_colored_lint = - if gopt Opt_DoAsmLinting dflags + if ncgAsmLinting config then Color.validateGraph (text "") True -- Require all nodes to be colored. graph_colored @@ -215,7 +215,7 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree slotsCount debug_codeGrap -- Also rewrite SPILL/RELOAD meta instructions into real machine -- instructions along the way let code_final - = map (stripLive dflags) code_spillclean + = map (stripLive config) code_spillclean -- Record what happened in this stage for debugging let stat @@ -229,7 +229,9 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree slotsCount debug_codeGrap , raSpillClean = code_spillclean , raFinal = code_final , raSRMs = foldl' addSRM (0, 0, 0) - $ map countSRMs code_spillclean } + $ map countSRMs code_spillclean + , raPlatform = platform + } -- Bundle up all the register allocator statistics. -- .. but make sure to drop them on the floor if they're not @@ -251,7 +253,7 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree slotsCount debug_codeGrap else do -- if -fasm-lint is turned on then validate the graph let graph_colored_lint = - if gopt Opt_DoAsmLinting dflags + if ncgAsmLinting config then Color.validateGraph (text "") False -- don't require nodes to be colored graph_colored @@ -289,7 +291,7 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree slotsCount debug_codeGrap -- Ensure all the statistics are evaluated, to avoid space leaks. seqList statList (return ()) - regAlloc_spin dflags (spinCount + 1) triv regsFree slotsFree' + regAlloc_spin config (spinCount + 1) triv regsFree slotsFree' slotsCount' statList code_relive cfg diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs index 05d2e814af..2285d3e908 100644 --- a/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs @@ -27,6 +27,7 @@ import GHC.CmmToAsm.Instr import GHC.Platform.Reg.Class import GHC.Platform.Reg import GHC.CmmToAsm.Reg.Target +import GHC.Platform import Outputable import UniqFM @@ -45,7 +46,11 @@ data RegAllocStats statics instr , raGraph :: Color.Graph VirtualReg RegClass RealReg -- | Information to help choose which regs to spill. - , raSpillCosts :: SpillCostInfo } + , raSpillCosts :: SpillCostInfo + + -- | Target platform + , raPlatform :: !Platform + } -- Information about an intermediate graph. @@ -98,23 +103,27 @@ data RegAllocStats statics instr , raFinal :: [NatCmmDecl statics instr] -- | Spill\/reload\/reg-reg moves present in this code. - , raSRMs :: (Int, Int, Int) } + , raSRMs :: (Int, Int, Int) + + -- | Target platform + , raPlatform :: !Platform + } instance (Outputable statics, Outputable instr) => Outputable (RegAllocStats statics instr) where - ppr (s@RegAllocStatsStart{}) = sdocWithPlatform $ \platform -> - text "# Start" + ppr (s@RegAllocStatsStart{}) + = text "# Start" $$ text "# Native code with liveness information." $$ ppr (raLiveCmm s) $$ text "" $$ text "# Initial register conflict graph." $$ Color.dotGraph - (targetRegDotColor platform) - (trivColorable platform - (targetVirtualRegSqueeze platform) - (targetRealRegSqueeze platform)) + (targetRegDotColor (raPlatform s)) + (trivColorable (raPlatform s) + (targetVirtualRegSqueeze (raPlatform s)) + (targetRealRegSqueeze (raPlatform s))) (raGraph s) @@ -140,8 +149,7 @@ instance (Outputable statics, Outputable instr) ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) }) - = sdocWithPlatform $ \platform -> - text "# Colored" + = text "# Colored" $$ text "# Code with liveness information." $$ ppr (raCode s) @@ -149,10 +157,10 @@ instance (Outputable statics, Outputable instr) $$ text "# Register conflict graph (colored)." $$ Color.dotGraph - (targetRegDotColor platform) - (trivColorable platform - (targetVirtualRegSqueeze platform) - (targetRealRegSqueeze platform)) + (targetRegDotColor (raPlatform s)) + (trivColorable (raPlatform s) + (targetVirtualRegSqueeze (raPlatform s)) + (targetRealRegSqueeze (raPlatform s))) (raGraphColored s) $$ text "" diff --git a/compiler/GHC/CmmToAsm/Reg/Linear.hs b/compiler/GHC/CmmToAsm/Reg/Linear.hs index 9b263889d8..155d67c2c2 100644 --- a/compiler/GHC/CmmToAsm/Reg/Linear.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear.hs @@ -119,6 +119,7 @@ import qualified GHC.CmmToAsm.Reg.Linear.X86_64 as X86_64 import GHC.CmmToAsm.Reg.Target import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.Config import GHC.Platform.Reg import GHC.Cmm.BlockId @@ -126,7 +127,6 @@ import GHC.Cmm.Dataflow.Collections import GHC.Cmm hiding (RegSet) import Digraph -import GHC.Driver.Session import Unique import UniqSet import UniqFM @@ -144,7 +144,7 @@ import Control.Monad -- Allocate registers regAlloc :: (Outputable instr, Instruction instr) - => DynFlags + => NCGConfig -> LiveCmmDecl statics instr -> UniqSM ( NatCmmDecl statics instr , Maybe Int -- number of extra stack slots required, @@ -163,19 +163,19 @@ regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl live []) , Nothing , Nothing ) -regAlloc dflags (CmmProc static lbl live sccs) +regAlloc config (CmmProc static lbl live sccs) | LiveInfo info entry_ids@(first_id:_) block_live _ <- static = do -- do register allocation on each component. (final_blocks, stats, stack_use) - <- linearRegAlloc dflags entry_ids block_live sccs + <- linearRegAlloc config entry_ids block_live sccs -- make sure the block that was first in the input list -- stays at the front of the output let ((first':_), rest') = partition ((== first_id) . blockId) final_blocks - let max_spill_slots = maxSpillSlots dflags + let max_spill_slots = maxSpillSlots config extra_stack | stack_use > max_spill_slots = Just (stack_use - max_spill_slots) @@ -201,7 +201,7 @@ regAlloc _ (CmmProc _ _ _ _) -- linearRegAlloc :: (Outputable instr, Instruction instr) - => DynFlags + => NCGConfig -> [BlockId] -- ^ entry points -> BlockMap RegSet -- ^ live regs on entry to each basic block @@ -209,7 +209,7 @@ linearRegAlloc -- ^ instructions annotated with "deaths" -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int) -linearRegAlloc dflags entry_ids block_live sccs +linearRegAlloc config entry_ids block_live sccs = case platformArch platform of ArchX86 -> go $ (frInitFreeRegs platform :: X86.FreeRegs) ArchX86_64 -> go $ (frInitFreeRegs platform :: X86_64.FreeRegs) @@ -226,22 +226,22 @@ linearRegAlloc dflags entry_ids block_live sccs ArchJavaScript -> panic "linearRegAlloc ArchJavaScript" ArchUnknown -> panic "linearRegAlloc ArchUnknown" where - go f = linearRegAlloc' dflags f entry_ids block_live sccs - platform = targetPlatform dflags + go f = linearRegAlloc' config f entry_ids block_live sccs + platform = ncgPlatform config linearRegAlloc' :: (FR freeRegs, Outputable instr, Instruction instr) - => DynFlags + => NCGConfig -> freeRegs -> [BlockId] -- ^ entry points -> BlockMap RegSet -- ^ live regs on entry to each basic block -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths" -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int) -linearRegAlloc' dflags initFreeRegs entry_ids block_live sccs +linearRegAlloc' config initFreeRegs entry_ids block_live sccs = do us <- getUniqueSupplyM let (_, stack, stats, blocks) = - runR dflags mapEmpty initFreeRegs emptyRegMap (emptyStackMap dflags) us + runR config mapEmpty initFreeRegs emptyRegMap emptyStackMap us $ linearRA_SCCs entry_ids block_live [] sccs return (blocks, stats, getStackUse stack) @@ -342,9 +342,8 @@ processBlock block_live (BasicBlock id instrs) initBlock :: FR freeRegs => BlockId -> BlockMap RegSet -> RegM freeRegs () initBlock id block_live - = do dflags <- getDynFlags - let platform = targetPlatform dflags - block_assig <- getBlockAssigR + = do platform <- getPlatform + block_assig <- getBlockAssigR case mapLookup id block_assig of -- no prior info about this block: we must consider -- any fixed regs to be allocated, but we can ignore @@ -487,8 +486,7 @@ genRaInsn :: (FR freeRegs, Instruction instr, Outputable instr) -> RegM freeRegs ([instr], [NatBasicBlock instr]) genRaInsn block_live new_instrs block_id instr r_dying w_dying = do - dflags <- getDynFlags - let platform = targetPlatform dflags + platform <- getPlatform case regUsageOfInstr platform instr of { RU read written -> do let real_written = [ rr | (RegReal rr) <- written ] @@ -590,8 +588,7 @@ genRaInsn block_live new_instrs block_id instr r_dying w_dying = do releaseRegs :: FR freeRegs => [Reg] -> RegM freeRegs () releaseRegs regs = do - dflags <- getDynFlags - let platform = targetPlatform dflags + platform <- getPlatform assig <- getAssigR free <- getFreeRegsR let loop assig !free [] = do setAssigR assig; setFreeRegsR free; return () @@ -651,8 +648,7 @@ saveClobberedTemps clobbered dying = return (instrs, assig) clobber assig instrs ((temp, reg) : rest) - = do dflags <- getDynFlags - let platform = targetPlatform dflags + = do platform <- getPlatform freeRegs <- getFreeRegsR let regclass = targetClassOfRealReg platform reg @@ -693,10 +689,8 @@ clobberRegs [] = return () clobberRegs clobbered - = do dflags <- getDynFlags - let platform = targetPlatform dflags - - freeregs <- getFreeRegsR + = do platform <- getPlatform + freeregs <- getFreeRegsR setFreeRegsR $! foldl' (flip $ frAllocateReg platform) freeregs clobbered assig <- getAssigR @@ -799,9 +793,8 @@ allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr) -> SpillLoc -> RegM freeRegs ([instr], [RealReg]) allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc - = do dflags <- getDynFlags - let platform = targetPlatform dflags - freeRegs <- getFreeRegsR + = do platform <- getPlatform + freeRegs <- getFreeRegsR let freeRegs_thisClass = frGetFreeRegs platform (classOfVirtualReg r) freeRegs case freeRegs_thisClass of diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs b/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs index 43dbab843b..92b3ee19a3 100644 --- a/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs @@ -21,9 +21,9 @@ import GhcPrelude import GHC.CmmToAsm.Reg.Linear.StackMap import GHC.CmmToAsm.Reg.Liveness +import GHC.CmmToAsm.Config import GHC.Platform.Reg -import GHC.Driver.Session import Outputable import Unique import UniqFM @@ -133,7 +133,9 @@ data RA_State freeRegs -- Just keep a list here instead of a map of regs -> reasons. -- We don't want to slow down the allocator if we're not going to emit the stats. , ra_spills :: [SpillReason] - , ra_DynFlags :: DynFlags + + -- | Native code generator configuration + , ra_config :: !NCGConfig -- | (from,fixup,to) : We inserted fixup code between from and to , ra_fixups :: [(BlockId,BlockId,BlockId)] } diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs b/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs index 0d72d8b6e9..e340dcf5c6 100644 --- a/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs @@ -14,7 +14,7 @@ import GhcPrelude import GHC.Platform.Reg import GHC.Platform.Reg.Class -import GHC.Driver.Session +import GHC.CmmToAsm.Config import Panic import GHC.Platform @@ -69,21 +69,19 @@ instance FR SPARC.FreeRegs where frInitFreeRegs = SPARC.initFreeRegs frReleaseReg = SPARC.releaseReg -maxSpillSlots :: DynFlags -> Int -maxSpillSlots dflags - = case platformArch (targetPlatform dflags) of - ArchX86 -> X86.Instr.maxSpillSlots dflags - ArchX86_64 -> X86.Instr.maxSpillSlots dflags - ArchPPC -> PPC.Instr.maxSpillSlots dflags - ArchS390X -> panic "maxSpillSlots ArchS390X" - ArchSPARC -> SPARC.Instr.maxSpillSlots dflags - ArchSPARC64 -> panic "maxSpillSlots ArchSPARC64" - ArchARM _ _ _ -> panic "maxSpillSlots ArchARM" - ArchARM64 -> panic "maxSpillSlots ArchARM64" - ArchPPC_64 _ -> PPC.Instr.maxSpillSlots dflags - ArchAlpha -> panic "maxSpillSlots ArchAlpha" - ArchMipseb -> panic "maxSpillSlots ArchMipseb" - ArchMipsel -> panic "maxSpillSlots ArchMipsel" - ArchJavaScript-> panic "maxSpillSlots ArchJavaScript" - ArchUnknown -> panic "maxSpillSlots ArchUnknown" - +maxSpillSlots :: NCGConfig -> Int +maxSpillSlots config = case platformArch (ncgPlatform config) of + ArchX86 -> X86.Instr.maxSpillSlots config + ArchX86_64 -> X86.Instr.maxSpillSlots config + ArchPPC -> PPC.Instr.maxSpillSlots config + ArchS390X -> panic "maxSpillSlots ArchS390X" + ArchSPARC -> SPARC.Instr.maxSpillSlots config + ArchSPARC64 -> panic "maxSpillSlots ArchSPARC64" + ArchARM _ _ _ -> panic "maxSpillSlots ArchARM" + ArchARM64 -> panic "maxSpillSlots ArchARM64" + ArchPPC_64 _ -> PPC.Instr.maxSpillSlots config + ArchAlpha -> panic "maxSpillSlots ArchAlpha" + ArchMipseb -> panic "maxSpillSlots ArchMipseb" + ArchMipsel -> panic "maxSpillSlots ArchMipsel" + ArchJavaScript-> panic "maxSpillSlots ArchJavaScript" + ArchUnknown -> panic "maxSpillSlots ArchUnknown" diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs b/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs index b4ad1b948c..0874cd0dbf 100644 --- a/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs @@ -17,12 +17,12 @@ import GHC.CmmToAsm.Reg.Linear.Base import GHC.CmmToAsm.Reg.Linear.FreeRegs import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.Config import GHC.Platform.Reg import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Collections import Digraph -import GHC.Driver.Session import Outputable import Unique import UniqFM @@ -125,8 +125,8 @@ joinToTargets_first block_live new_blocks block_id instr dest dests block_assig src_assig to_free - = do dflags <- getDynFlags - let platform = targetPlatform dflags + = do config <- getConfig + let platform = ncgPlatform config -- free up the regs that are not live on entry to this block. freeregs <- getFreeRegsR @@ -355,8 +355,8 @@ makeMove -> RegM freeRegs instr -- ^ move instruction. makeMove delta vreg src dst - = do dflags <- getDynFlags - let platform = targetPlatform dflags + = do config <- getConfig + let platform = ncgPlatform config case (src, dst) of (InReg s, InReg d) -> @@ -364,10 +364,10 @@ makeMove delta vreg src dst return $ mkRegRegMoveInstr platform (RegReal s) (RegReal d) (InMem s, InReg d) -> do recordSpill (SpillJoinRM vreg) - return $ mkLoadInstr dflags (RegReal d) delta s + return $ mkLoadInstr config (RegReal d) delta s (InReg s, InMem d) -> do recordSpill (SpillJoinRM vreg) - return $ mkSpillInstr dflags (RegReal s) delta d + return $ mkSpillInstr config (RegReal s) delta d _ -> -- we don't handle memory to memory moves. -- they shouldn't happen because we don't share diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs b/compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs index 630b101fc7..00fcfd91c8 100644 --- a/compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs @@ -22,7 +22,6 @@ where import GhcPrelude -import GHC.Driver.Session import UniqFM import Unique @@ -40,8 +39,8 @@ data StackMap -- | An empty stack map, with all slots available. -emptyStackMap :: DynFlags -> StackMap -emptyStackMap _ = StackMap 0 emptyUFM +emptyStackMap :: StackMap +emptyStackMap = StackMap 0 emptyUFM -- | If this vreg unique already has a stack assignment then return the slot number, diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/State.hs b/compiler/GHC/CmmToAsm/Reg/Linear/State.hs index a167cc7e00..5a1e3a4c3f 100644 --- a/compiler/GHC/CmmToAsm/Reg/Linear/State.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/State.hs @@ -30,6 +30,8 @@ module GHC.CmmToAsm.Reg.Linear.State ( getDeltaR, getUniqueR, + getConfig, + getPlatform, recordSpill, recordFixupBlock @@ -43,10 +45,11 @@ import GHC.CmmToAsm.Reg.Linear.StackMap import GHC.CmmToAsm.Reg.Linear.Base import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.Config import GHC.Platform.Reg import GHC.Cmm.BlockId -import GHC.Driver.Session +import GHC.Platform import Unique import UniqSupply @@ -79,12 +82,16 @@ instance Applicative (RegM freeRegs) where instance Monad (RegM freeRegs) where m >>= k = RegM $ \s -> case unReg m s of { RA_Result s a -> unReg (k a) s } -instance HasDynFlags (RegM a) where - getDynFlags = RegM $ \s -> RA_Result s (ra_DynFlags s) +-- | Get native code generator configuration +getConfig :: RegM a NCGConfig +getConfig = RegM $ \s -> RA_Result s (ra_config s) +-- | Get target platform from native code generator configuration +getPlatform :: RegM a Platform +getPlatform = ncgPlatform <$> getConfig -- | Run a computation in the RegM register allocator monad. -runR :: DynFlags +runR :: NCGConfig -> BlockAssignment freeRegs -> freeRegs -> RegMap Loc @@ -93,7 +100,7 @@ runR :: DynFlags -> RegM freeRegs a -> (BlockAssignment freeRegs, StackMap, RegAllocStats, a) -runR dflags block_assig freeregs assig stack us thing = +runR config block_assig freeregs assig stack us thing = case unReg thing (RA_State { ra_blockassig = block_assig @@ -103,7 +110,7 @@ runR dflags block_assig freeregs assig stack us thing = , ra_stack = stack , ra_us = us , ra_spills = [] - , ra_DynFlags = dflags + , ra_config = config , ra_fixups = [] }) of RA_Result state returned_thing @@ -121,10 +128,9 @@ makeRAStats state spillR :: Instruction instr => Reg -> Unique -> RegM freeRegs (instr, Int) -spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack0} -> - let dflags = ra_DynFlags s - (stack1,slot) = getStackSlotFor stack0 temp - instr = mkSpillInstr dflags reg delta slot +spillR reg temp = RegM $ \s -> + let (stack1,slot) = getStackSlotFor (ra_stack s) temp + instr = mkSpillInstr (ra_config s) reg (ra_delta s) slot in RA_Result s{ra_stack=stack1} (instr,slot) @@ -132,9 +138,8 @@ spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack0} -> loadR :: Instruction instr => Reg -> Int -> RegM freeRegs instr -loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} -> - let dflags = ra_DynFlags s - in RA_Result s (mkLoadInstr dflags reg delta slot) +loadR reg slot = RegM $ \s -> + RA_Result s (mkLoadInstr (ra_config s) reg (ra_delta s) slot) getFreeRegsR :: RegM freeRegs freeRegs getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} -> diff --git a/compiler/GHC/CmmToAsm/Reg/Liveness.hs b/compiler/GHC/CmmToAsm/Reg/Liveness.hs index 03b8123f93..d1c4c8f498 100644 --- a/compiler/GHC/CmmToAsm/Reg/Liveness.hs +++ b/compiler/GHC/CmmToAsm/Reg/Liveness.hs @@ -41,15 +41,15 @@ import GhcPrelude import GHC.Platform.Reg import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.CFG +import GHC.CmmToAsm.Config import GHC.Cmm.BlockId -import GHC.CmmToAsm.CFG import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import GHC.Cmm hiding (RegSet, emptyRegSet) import Digraph -import GHC.Driver.Session import MonadUtils import Outputable import GHC.Platform @@ -483,11 +483,11 @@ slurpReloadCoalesce live -- | Strip away liveness information, yielding NatCmmDecl stripLive :: (Outputable statics, Outputable instr, Instruction instr) - => DynFlags + => NCGConfig -> LiveCmmDecl statics instr -> NatCmmDecl statics instr -stripLive dflags live +stripLive config live = stripCmm live where stripCmm :: (Outputable statics, Outputable instr, Instruction instr) @@ -503,7 +503,7 @@ stripLive dflags live = partition ((== first_id) . blockId) final_blocks in CmmProc info label live - (ListGraph $ map (stripLiveBlock dflags) $ first' : rest') + (ListGraph $ map (stripLiveBlock config) $ first' : rest') -- If the proc has blocks but we don't know what the first one was, then we're dead. stripCmm proc @@ -514,11 +514,11 @@ stripLive dflags live stripLiveBlock :: Instruction instr - => DynFlags + => NCGConfig -> LiveBasicBlock instr -> NatBasicBlock instr -stripLiveBlock dflags (BasicBlock i lis) +stripLiveBlock config (BasicBlock i lis) = BasicBlock i instrs' where (instrs', _) @@ -529,11 +529,11 @@ stripLiveBlock dflags (BasicBlock i lis) spillNat acc (LiveInstr (SPILL reg slot) _ : instrs) = do delta <- get - spillNat (mkSpillInstr dflags reg delta slot : acc) instrs + spillNat (mkSpillInstr config reg delta slot : acc) instrs spillNat acc (LiveInstr (RELOAD slot reg) _ : instrs) = do delta <- get - spillNat (mkLoadInstr dflags reg delta slot : acc) instrs + spillNat (mkLoadInstr config reg delta slot : acc) instrs spillNat acc (LiveInstr (Instr instr) _ : instrs) | Just i <- takeDeltaInstr instr diff --git a/compiler/GHC/CmmToAsm/SPARC/Base.hs b/compiler/GHC/CmmToAsm/SPARC/Base.hs index 86a897dacb..85b1de9ef3 100644 --- a/compiler/GHC/CmmToAsm/SPARC/Base.hs +++ b/compiler/GHC/CmmToAsm/SPARC/Base.hs @@ -8,7 +8,6 @@ module GHC.CmmToAsm.SPARC.Base ( wordLength, wordLengthInBits, - spillAreaLength, spillSlotSize, extraStackArgsHere, fits13Bits, @@ -20,7 +19,6 @@ where import GhcPrelude -import GHC.Driver.Session import Panic import Data.Int @@ -34,11 +32,6 @@ wordLengthInBits :: Int wordLengthInBits = wordLength * 8 --- Size of the available spill area -spillAreaLength :: DynFlags -> Int -spillAreaLength - = rESERVED_C_STACK_BYTES - -- | We need 8 bytes because our largest registers are 64 bit. spillSlotSize :: Int spillSlotSize = 8 diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs index 43807ec027..18b22b2a1e 100644 --- a/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs +++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs @@ -24,7 +24,6 @@ import GHC.Platform.Reg import GHC.Cmm -import GHC.Driver.Session import OrdList import Outputable @@ -184,9 +183,8 @@ iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) -- compute expr and load it into r_dst_lo (a_reg, a_code) <- getSomeReg expr - dflags <- getDynFlags - let platform = targetPlatform dflags - code = a_code + platform <- getPlatform + let code = a_code `appOL` toOL [ mkRegRegMoveInstr platform g0 r_dst_hi -- clear high 32 bits , mkRegRegMoveInstr platform a_reg r_dst_lo ] @@ -202,9 +200,8 @@ iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) -- compute expr and load it into r_dst_lo (a_reg, a_code) <- getSomeReg expr - dflags <- getDynFlags - let platform = targetPlatform dflags - code = a_code + platform <- getPlatform + let code = a_code `appOL` toOL [ SRA a_reg (RIImm (ImmInt 31)) r_dst_hi , mkRegRegMoveInstr platform a_reg r_dst_lo ] diff --git a/compiler/GHC/CmmToAsm/SPARC/Instr.hs b/compiler/GHC/CmmToAsm/SPARC/Instr.hs index ec74d3723b..a1f890bc6d 100644 --- a/compiler/GHC/CmmToAsm/SPARC/Instr.hs +++ b/compiler/GHC/CmmToAsm/SPARC/Instr.hs @@ -37,11 +37,11 @@ import GHC.CmmToAsm.Instr import GHC.Platform.Reg.Class import GHC.Platform.Reg import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Config import GHC.Cmm.CLabel import GHC.Platform.Regs import GHC.Cmm.BlockId -import GHC.Driver.Session import GHC.Cmm import FastString import Outputable @@ -369,15 +369,15 @@ sparc_patchJumpInstr insn patchF -- | Make a spill instruction. -- On SPARC we spill below frame pointer leaving 2 words/spill sparc_mkSpillInstr - :: DynFlags + :: NCGConfig -> Reg -- ^ register to spill -> Int -- ^ current stack delta -> Int -- ^ spill slot to use -> Instr -sparc_mkSpillInstr dflags reg _ slot - = let platform = targetPlatform dflags - off = spillSlotToOffset dflags slot +sparc_mkSpillInstr config reg _ slot + = let platform = ncgPlatform config + off = spillSlotToOffset config slot off_w = 1 + (off `div` 4) fmt = case targetClassOfReg platform reg of RcInteger -> II32 @@ -389,15 +389,15 @@ sparc_mkSpillInstr dflags reg _ slot -- | Make a spill reload instruction. sparc_mkLoadInstr - :: DynFlags + :: NCGConfig -> Reg -- ^ register to load into -> Int -- ^ current stack delta -> Int -- ^ spill slot to use -> Instr -sparc_mkLoadInstr dflags reg _ slot - = let platform = targetPlatform dflags - off = spillSlotToOffset dflags slot +sparc_mkLoadInstr config reg _ slot + = let platform = ncgPlatform config + off = spillSlotToOffset config slot off_w = 1 + (off `div` 4) fmt = case targetClassOfReg platform reg of RcInteger -> II32 diff --git a/compiler/GHC/CmmToAsm/SPARC/Ppr.hs b/compiler/GHC/CmmToAsm/SPARC/Ppr.hs index 2f3ea778f7..fc382a5c10 100644 --- a/compiler/GHC/CmmToAsm/SPARC/Ppr.hs +++ b/compiler/GHC/CmmToAsm/SPARC/Ppr.hs @@ -36,6 +36,7 @@ import GHC.CmmToAsm.Instr import GHC.Platform.Reg import GHC.CmmToAsm.Format import GHC.CmmToAsm.Ppr +import GHC.CmmToAsm.Config import GHC.Cmm hiding (topInfoTable) import GHC.Cmm.Ppr() -- For Outputable instances @@ -52,25 +53,26 @@ import FastString -- ----------------------------------------------------------------------------- -- Printing this stuff out -pprNatCmmDecl :: NatCmmDecl RawCmmStatics Instr -> SDoc -pprNatCmmDecl (CmmData section dats) = - pprSectionAlign section $$ pprDatas dats +pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc +pprNatCmmDecl config (CmmData section dats) = + pprSectionAlign config section + $$ pprDatas (ncgPlatform config) dats -pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = +pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = + let platform = ncgPlatform config in case topInfoTable proc of Nothing -> -- special case for code without info table: - pprSectionAlign (Section Text lbl) $$ - pprLabel lbl $$ -- blocks guaranteed not null, so label needed - vcat (map (pprBasicBlock top_info) blocks) + pprSectionAlign config (Section Text lbl) $$ + pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed + vcat (map (pprBasicBlock platform top_info) blocks) Just (RawCmmStatics info_lbl _) -> - sdocWithPlatform $ \platform -> (if platformHasSubsectionsViaSymbols platform - then pprSectionAlign dspSection $$ + then pprSectionAlign config dspSection $$ ppr (mkDeadStripPreventer info_lbl) <> char ':' else empty) $$ - vcat (map (pprBasicBlock top_info) blocks) $$ + vcat (map (pprBasicBlock platform top_info) blocks) $$ -- above: Even the first block gets a label, because with branch-chain -- elimination, it might be the target of a goto. (if platformHasSubsectionsViaSymbols platform @@ -86,10 +88,10 @@ dspSection :: Section dspSection = Section Text $ panic "subsections-via-symbols doesn't combine with split-sections" -pprBasicBlock :: LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc -pprBasicBlock info_env (BasicBlock blockid instrs) +pprBasicBlock :: Platform -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc +pprBasicBlock platform info_env (BasicBlock blockid instrs) = maybe_infotable $$ - pprLabel (blockLbl blockid) $$ + pprLabel platform (blockLbl blockid) $$ vcat (map pprInstr instrs) where maybe_infotable = case mapLookup blockid info_env of @@ -97,12 +99,12 @@ pprBasicBlock info_env (BasicBlock blockid instrs) Just (RawCmmStatics info_lbl info) -> pprAlignForSection Text $$ vcat (map pprData info) $$ - pprLabel info_lbl + pprLabel platform info_lbl -pprDatas :: RawCmmStatics -> SDoc +pprDatas :: Platform -> RawCmmStatics -> SDoc -- See note [emit-time elimination of static indirections] in CLabel. -pprDatas (RawCmmStatics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) +pprDatas _platform (RawCmmStatics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) | lbl == mkIndStaticInfoLabel , let labelInd (CmmLabelOff l _) = Just l labelInd (CmmLabel l) = Just l @@ -111,7 +113,7 @@ pprDatas (RawCmmStatics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, , alias `mayRedirectTo` ind' = pprGloblDecl alias $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind') -pprDatas (RawCmmStatics lbl dats) = vcat (pprLabel lbl : map pprData dats) +pprDatas platform (RawCmmStatics lbl dats) = vcat (pprLabel platform lbl : map pprData dats) pprData :: CmmStatic -> SDoc pprData (CmmString str) = pprBytes str @@ -123,17 +125,17 @@ pprGloblDecl lbl | not (externallyVisibleCLabel lbl) = empty | otherwise = text ".global " <> ppr lbl -pprTypeAndSizeDecl :: CLabel -> SDoc -pprTypeAndSizeDecl lbl - = sdocWithPlatform $ \platform -> - if platformOS platform == OSLinux && externallyVisibleCLabel lbl +pprTypeAndSizeDecl :: Platform -> CLabel -> SDoc +pprTypeAndSizeDecl platform lbl + = if platformOS platform == OSLinux && externallyVisibleCLabel lbl then text ".type " <> ppr lbl <> ptext (sLit ", @object") else empty -pprLabel :: CLabel -> SDoc -pprLabel lbl = pprGloblDecl lbl - $$ pprTypeAndSizeDecl lbl - $$ (ppr lbl <> char ':') +pprLabel :: Platform -> CLabel -> SDoc +pprLabel platform lbl = + pprGloblDecl lbl + $$ pprTypeAndSizeDecl platform lbl + $$ (ppr lbl <> char ':') -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' @@ -321,10 +323,9 @@ pprImm imm -- On SPARC all the data sections must be at least 8 byte aligned -- incase we store doubles in them. -- -pprSectionAlign :: Section -> SDoc -pprSectionAlign sec@(Section seg _) = - sdocWithPlatform $ \platform -> - pprSectionHeader platform sec $$ +pprSectionAlign :: NCGConfig -> Section -> SDoc +pprSectionAlign config sec@(Section seg _) = + pprSectionHeader config sec $$ pprAlignForSection seg -- | Print appropriate alignment for the given section type. diff --git a/compiler/GHC/CmmToAsm/SPARC/Stack.hs b/compiler/GHC/CmmToAsm/SPARC/Stack.hs index d9a0ffd7cf..861d1ad691 100644 --- a/compiler/GHC/CmmToAsm/SPARC/Stack.hs +++ b/compiler/GHC/CmmToAsm/SPARC/Stack.hs @@ -13,8 +13,8 @@ import GHC.CmmToAsm.SPARC.AddrMode import GHC.CmmToAsm.SPARC.Regs import GHC.CmmToAsm.SPARC.Base import GHC.CmmToAsm.SPARC.Imm +import GHC.CmmToAsm.Config -import GHC.Driver.Session import Outputable -- | Get an AddrMode relative to the address in sp. @@ -37,15 +37,15 @@ fpRel n -- | Convert a spill slot number to a *byte* offset, with no sign. -- -spillSlotToOffset :: DynFlags -> Int -> Int -spillSlotToOffset dflags slot - | slot >= 0 && slot < maxSpillSlots dflags +spillSlotToOffset :: NCGConfig -> Int -> Int +spillSlotToOffset config slot + | slot >= 0 && slot < maxSpillSlots config = 64 + spillSlotSize * slot | otherwise = pprPanic "spillSlotToOffset:" ( text "invalid spill location: " <> int slot - $$ text "maxSpillSlots: " <> int (maxSpillSlots dflags)) + $$ text "maxSpillSlots: " <> int (maxSpillSlots config)) -- | The maximum number of spill slots available on the C stack. @@ -54,6 +54,6 @@ spillSlotToOffset dflags slot -- Why do we reserve 64 bytes, instead of using the whole thing?? -- -- BL 2009/02/15 -- -maxSpillSlots :: DynFlags -> Int -maxSpillSlots dflags - = ((spillAreaLength dflags - 64) `div` spillSlotSize) - 1 +maxSpillSlots :: NCGConfig -> Int +maxSpillSlots config + = ((ncgSpillPreallocSize config - 64) `div` spillSlotSize) - 1 diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs index 4b1dd31cf1..17e246366b 100644 --- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs @@ -41,7 +41,7 @@ import GhcPrelude import GHC.CmmToAsm.X86.Instr import GHC.CmmToAsm.X86.Cond import GHC.CmmToAsm.X86.Regs -import GHC.CmmToAsm.X86.Ppr ( ) +import GHC.CmmToAsm.X86.Ppr import GHC.CmmToAsm.X86.RegInfo import GHC.Platform.Regs @@ -56,10 +56,11 @@ import GHC.CmmToAsm.Monad ( NatM, getNewRegNat, getNewLabelNat, setDeltaNat , getDeltaNat, getBlockIdNat, getPicBaseNat, getNewRegPairNat , getPicBaseMaybeNat, getDebugBlock, getFileId - , addImmediateSuccessorNat, updateCfgNat + , addImmediateSuccessorNat, updateCfgNat, getConfig, getPlatform ) import GHC.CmmToAsm.CFG import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Config import GHC.Platform.Reg import GHC.Platform @@ -98,13 +99,13 @@ import qualified Data.Map as M is32BitPlatform :: NatM Bool is32BitPlatform = do - dflags <- getDynFlags - return $ target32Bit (targetPlatform dflags) + platform <- getPlatform + return $ target32Bit platform sse2Enabled :: NatM Bool sse2Enabled = do - dflags <- getDynFlags - case platformArch (targetPlatform dflags) of + 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 @@ -132,10 +133,10 @@ cmmTopCodeGen (CmmProc info lab live graph) = do let blocks = toBlockListEntryFirst graph (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks picBaseMb <- getPicBaseMaybeNat - dflags <- getDynFlags + platform <- getPlatform let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) tops = proc : concat statics - os = platformOS $ targetPlatform dflags + os = platformOS platform case picBaseMb of Just picBase -> initializePicBase_x86 ArchX86 os picBase tops @@ -172,8 +173,8 @@ cmmTopCodeGen (CmmData sec dat) = do -} -- Verifying basic blocks is cheap, but not cheap enough to enable it unconditionally. -verifyBasicBlock :: [Instr] -> () -verifyBasicBlock instrs +verifyBasicBlock :: Platform -> [Instr] -> () +verifyBasicBlock platform instrs | debugIsOn = go False instrs | otherwise = () where @@ -193,7 +194,7 @@ verifyBasicBlock instrs else faultyBlockWith i faultyBlockWith i = pprPanic "Non control flow instructions after end of basic block." - (ppr i <+> text "in:" $$ vcat (map ppr instrs)) + (pprInstr platform i <+> text "in:" $$ vcat (map (pprInstr platform) instrs)) basicBlockCodeGen :: CmmBlock @@ -215,7 +216,8 @@ basicBlockCodeGen block = do (mid_instrs,mid_bid) <- stmtsToInstrs id stmts (!tail_instrs,_) <- stmtToInstrs mid_bid tail let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs - return $! verifyBasicBlock (fromOL instrs) + platform <- getPlatform + return $! verifyBasicBlock platform (fromOL instrs) instrs' <- fold <$> traverse addSpUnwindings instrs -- code generation may introduce new basic block boundaries, which -- are indicated by the NEWBLOCK instruction. We must split up the @@ -237,8 +239,8 @@ basicBlockCodeGen block = do -- for details. addSpUnwindings :: Instr -> NatM (OrdList Instr) addSpUnwindings instr@(DELTA d) = do - dflags <- getDynFlags - if debugLevel dflags >= 1 + config <- getConfig + if ncgDebugLevel config >= 1 then do lbl <- mkAsmTempLabel <$> getUniqueM let unwind = M.singleton MachSp (Just $ UwReg MachSp $ negate d) return $ toOL [ instr, UNWIND lbl unwind ] @@ -332,9 +334,10 @@ stmtToInstrs :: BlockId -- ^ Basic block this statement will start to be placed stmtToInstrs bid stmt = do dflags <- getDynFlags is32Bit <- is32BitPlatform + platform <- getPlatform case stmt of CmmUnsafeForeignCall target result_regs args - -> genCCall dflags is32Bit target result_regs args bid + -> genCCall is32Bit target result_regs args bid _ -> (,Nothing) <$> case stmt of CmmComment s -> return (unitOL (COMMENT s)) @@ -368,19 +371,15 @@ stmtToInstrs bid stmt = do --We try to arrange blocks such that the likely branch is the fallthrough --in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here. CmmCondBranch arg true false _ -> genCondBranch bid true false arg - CmmSwitch arg ids -> do dflags <- getDynFlags - genSwitch dflags arg ids + CmmSwitch arg ids -> genSwitch arg ids CmmCall { cml_target = arg - , cml_args_regs = gregs } -> do - dflags <- getDynFlags - genJump arg (jumpRegs dflags gregs) + , cml_args_regs = gregs } -> genJump arg (jumpRegs platform gregs) _ -> panic "stmtToInstrs: statement should have been cps'd away" -jumpRegs :: DynFlags -> [GlobalReg] -> [Reg] -jumpRegs dflags gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ] - where platform = targetPlatform dflags +jumpRegs :: Platform -> [GlobalReg] -> [Reg] +jumpRegs platform gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ] -------------------------------------------------------------------------------- -- | 'InstrBlock's are the insn sequences generated by the insn selectors. @@ -477,8 +476,8 @@ is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000 -- | Convert a BlockId to some CmmStatic data -jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic -jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags)) +jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic +jumpTableEntry config Nothing = CmmStaticLit (CmmInt 0 (ncgWordWidth config)) jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel) where blockLabel = blockLbl blockid @@ -659,9 +658,9 @@ getRegister' dflags is32Bit (CmmReg reg) fmt = cmmTypeFormat (cmmRegType dflags reg) format = fmt -- - let platform = targetPlatform dflags + platform <- ncgPlatform <$> getConfig return (Fixed format - (getRegisterReg platform reg) + (getRegisterReg platform reg) nilOL) @@ -1236,15 +1235,15 @@ getByteReg expr = do -- be modified by code to evaluate an arbitrary expression. getNonClobberedReg :: CmmExpr -> NatM (Reg, InstrBlock) getNonClobberedReg expr = do - dflags <- getDynFlags r <- getRegister expr + platform <- ncgPlatform <$> getConfig case r of Any rep code -> do tmp <- getNewRegNat rep return (tmp, code tmp) Fixed rep reg code -- only certain regs can be clobbered - | reg `elem` instrClobberedRegs (targetPlatform dflags) + | reg `elem` instrClobberedRegs platform -> do tmp <- getNewRegNat rep return (tmp, code `snocOL` reg2reg rep reg tmp) @@ -1326,11 +1325,12 @@ getAmode' _ expr = do -- (i.e. no index register). This stops us from running out of -- registers on x86 when using instructions such as cmpxchg, which can -- use up to three virtual registers and one fixed register. -getSimpleAmode :: DynFlags -> Bool -> CmmExpr -> NatM Amode -getSimpleAmode dflags is32Bit addr +getSimpleAmode :: Bool -> CmmExpr -> NatM Amode +getSimpleAmode is32Bit addr | is32Bit = do addr_code <- getAnyReg addr - addr_r <- getNewRegNat (intFormat (wordWidth dflags)) + config <- getConfig + addr_r <- getNewRegNat (intFormat (ncgWordWidth config)) let amode = AddrBaseIndex (EABaseReg addr_r) EAIndexNone (ImmInt 0) return $! Amode amode (addr_code addr_r) | otherwise = getAmode addr @@ -1383,8 +1383,7 @@ getNonClobberedOperand (CmmLoad mem pk) = do -- or if 64bit -- this could use some eyeballs or i'll need to stare at it more later then do - dflags <- getDynFlags - let platform = targetPlatform dflags + platform <- ncgPlatform <$> getConfig Amode src mem_code <- getAmode mem (src',save_code) <- if (amodeCouldBeClobbered platform src) @@ -1477,7 +1476,8 @@ memConstant align lit = do lbl <- getNewLabelNat let rosection = Section ReadOnlyData lbl dflags <- getDynFlags - (addr, addr_code) <- if target32Bit (targetPlatform dflags) + platform <- getPlatform + (addr, addr_code) <- if target32Bit platform then do dynRef <- cmmMakeDynamicReference dflags DataReference @@ -1742,14 +1742,12 @@ assignMem_IntCode pk addr src = do -- Assign; dst is a reg, rhs is mem assignReg_IntCode pk reg (CmmLoad src _) = do load_code <- intLoadCode (MOV pk) src - dflags <- getDynFlags - let platform = targetPlatform dflags + platform <- ncgPlatform <$> getConfig return (load_code (getRegisterReg platform reg)) -- dst is a reg, but src could be anything assignReg_IntCode _ reg src = do - dflags <- getDynFlags - let platform = targetPlatform dflags + platform <- ncgPlatform <$> getConfig code <- getAnyReg src return (code (getRegisterReg platform reg)) @@ -1768,9 +1766,8 @@ assignMem_FltCode pk addr src = do -- Floating point assignment to a register/temporary assignReg_FltCode _ reg src = do src_code <- getAnyReg src - dflags <- getDynFlags - let platform = targetPlatform dflags - return (src_code (getRegisterReg platform reg)) + platform <- ncgPlatform <$> getConfig + return (src_code (getRegisterReg platform reg)) genJump :: CmmExpr{-the branch target-} -> [Reg] -> NatM InstrBlock @@ -1997,8 +1994,7 @@ genCondBranch' _ bid id false bool = do -- to take/return a block id. genCCall - :: DynFlags - -> Bool -- 32 bit platform? + :: Bool -- 32 bit platform? -> ForeignTarget -- function to call -> [CmmFormal] -- where to put the result -> [CmmActual] -- arguments (of mixed type) @@ -2007,16 +2003,16 @@ genCCall -- First we deal with cases which might introduce new blocks in the stream. -genCCall dflags is32Bit (PrimTarget (MO_AtomicRMW width amop)) +genCCall is32Bit (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] bid = do Amode amode addr_code <- if amop `elem` [AMO_Add, AMO_Sub] then getAmode addr - else getSimpleAmode dflags is32Bit addr -- See genCCall for MO_Cmpxchg + else getSimpleAmode is32Bit addr -- See genCCall for MO_Cmpxchg arg <- getNewRegNat format arg_code <- getAnyReg n - let platform = targetPlatform dflags - dst_r = getRegisterReg platform (CmmLocal dst) + platform <- ncgPlatform <$> getConfig + let dst_r = getRegisterReg platform (CmmLocal dst) (code, lbl) <- op_code dst_r arg amode return (addr_code `appOL` arg_code arg `appOL` code, Just lbl) where @@ -2080,9 +2076,10 @@ genCCall dflags is32Bit (PrimTarget (MO_AtomicRMW width amop)) lbl2) format = intFormat width -genCCall dflags is32Bit (PrimTarget (MO_Ctz width)) [dst] [src] bid +genCCall is32Bit (PrimTarget (MO_Ctz width)) [dst] [src] bid | is32Bit, width == W64 = do ChildCode64 vcode rlo <- iselExpr64 src + platform <- ncgPlatform <$> getConfig let rhi = getHiVRegFromLo rlo dst_r = getRegisterReg platform (CmmLocal dst) lbl1 <- getBlockIdNat @@ -2094,9 +2091,10 @@ genCCall dflags is32Bit (PrimTarget (MO_Ctz width)) [dst] [src] bid -- bid -> lbl2 -- bid -> lbl1 -> lbl2 -- We also changes edges originating at bid to start at lbl2 instead. + dflags <- getDynFlags updateCfgNat (addWeightEdge bid lbl1 110 . addWeightEdge lbl1 lbl2 110 . - addImmediateSuccessor bid lbl2) + addImmediateSuccessor dflags bid lbl2) -- The following instruction sequence corresponds to the pseudo-code -- @@ -2125,8 +2123,9 @@ genCCall dflags is32Bit (PrimTarget (MO_Ctz width)) [dst] [src] bid | otherwise = do code_src <- getAnyReg src + platform <- ncgPlatform <$> getConfig let dst_r = getRegisterReg platform (CmmLocal dst) - + dflags <- getDynFlags if isBmi2Enabled dflags then do src_r <- getNewRegNat (intFormat width) @@ -2158,9 +2157,9 @@ genCCall dflags is32Bit (PrimTarget (MO_Ctz width)) [dst] [src] bid return (instrs, Nothing) where bw = widthInBits width - platform = targetPlatform dflags -genCCall dflags bits mop dst args bid = do +genCCall bits mop dst args bid = do + dflags <- getDynFlags instr <- genCCall' dflags bits mop dst args bid return (instr, Nothing) @@ -2326,8 +2325,8 @@ genCCall' _ is32bit (PrimTarget (MO_Prefetch_Data n )) _ [src] _ = ((AddrBaseIndex (EABaseReg src_r ) EAIndexNone (ImmInt 0)))) )) -- prefetch always takes an address -genCCall' dflags is32Bit (PrimTarget (MO_BSwap width)) [dst] [src] _ = do - let platform = targetPlatform dflags +genCCall' _ is32Bit (PrimTarget (MO_BSwap width)) [dst] [src] _ = do + platform <- ncgPlatform <$> getConfig let dst_r = getRegisterReg platform (CmmLocal dst) case width of W64 | is32Bit -> do @@ -2351,7 +2350,7 @@ genCCall' dflags is32Bit (PrimTarget (MO_BSwap width)) [dst] [src] _ = do genCCall' dflags is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst] args@[src] bid = do sse4_2 <- sse4_2Enabled - let platform = targetPlatform dflags + platform <- ncgPlatform <$> getConfig if sse4_2 then do code_src <- getAnyReg src src_r <- getNewRegNat format @@ -2381,7 +2380,7 @@ genCCall' dflags is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst] genCCall' dflags is32Bit (PrimTarget (MO_Pdep width)) dest_regs@[dst] args@[src, mask] bid = do - let platform = targetPlatform dflags + platform <- ncgPlatform <$> getConfig if isBmi2Enabled dflags then do code_src <- getAnyReg src code_mask <- getAnyReg mask @@ -2414,7 +2413,7 @@ genCCall' dflags is32Bit (PrimTarget (MO_Pdep width)) dest_regs@[dst] genCCall' dflags is32Bit (PrimTarget (MO_Pext width)) dest_regs@[dst] args@[src, mask] bid = do - let platform = targetPlatform dflags + platform <- ncgPlatform <$> getConfig if isBmi2Enabled dflags then do code_src <- getAnyReg src code_mask <- getAnyReg mask @@ -2456,6 +2455,7 @@ genCCall' dflags is32Bit (PrimTarget (MO_Clz width)) dest_regs@[dst] args@[src] | otherwise = do code_src <- getAnyReg src + platform <- ncgPlatform <$> getConfig let dst_r = getRegisterReg platform (CmmLocal dst) if isBmi2Enabled dflags then do @@ -2486,7 +2486,6 @@ genCCall' dflags is32Bit (PrimTarget (MO_Clz width)) dest_regs@[dst] args@[src] -- took care of implicitly clearing the upper bits where bw = widthInBits width - platform = targetPlatform dflags lbl = mkCmmCodeLabel primUnitId (fsLit (clzLabel width)) genCCall' dflags is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args bid = do @@ -2499,9 +2498,9 @@ genCCall' dflags is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args bid = do where lbl = mkCmmCodeLabel primUnitId (fsLit (word2FloatLabel width)) -genCCall' dflags _ (PrimTarget (MO_AtomicRead width)) [dst] [addr] _ = do +genCCall' _ _ (PrimTarget (MO_AtomicRead width)) [dst] [addr] _ = do load_code <- intLoadCode (MOV (intFormat width)) addr - let platform = targetPlatform dflags + platform <- ncgPlatform <$> getConfig return (load_code (getRegisterReg platform (CmmLocal dst))) @@ -2509,17 +2508,17 @@ genCCall' _ _ (PrimTarget (MO_AtomicWrite width)) [] [addr, val] _ = do code <- assignMem_IntCode (intFormat width) addr val return $ code `snocOL` MFENCE -genCCall' dflags is32Bit (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] _ = do +genCCall' _ is32Bit (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] _ = do -- On x86 we don't have enough registers to use cmpxchg with a -- complicated addressing mode, so on that architecture we -- pre-compute the address first. - Amode amode addr_code <- getSimpleAmode dflags is32Bit addr + Amode amode addr_code <- getSimpleAmode is32Bit addr newval <- getNewRegNat format newval_code <- getAnyReg new oldval <- getNewRegNat format oldval_code <- getAnyReg old - let platform = targetPlatform dflags - dst_r = getRegisterReg platform (CmmLocal dst) + platform <- getPlatform + let dst_r = getRegisterReg platform (CmmLocal dst) code = toOL [ MOV format (OpReg oldval) (OpReg eax) , LOCK (CMPXCHG format (OpReg newval) (OpAddr amode)) @@ -2530,9 +2529,8 @@ genCCall' dflags is32Bit (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] where format = intFormat width -genCCall' _ is32Bit target dest_regs args bid = do - dflags <- getDynFlags - let platform = targetPlatform dflags +genCCall' dflags is32Bit target dest_regs args bid = do + platform <- ncgPlatform <$> getConfig case (target, dest_regs) of -- void return type prim op (PrimTarget op, []) -> @@ -2785,8 +2783,7 @@ genCCall32' dflags target dest_regs args = do ) setDeltaNat delta0 - dflags <- getDynFlags - let platform = targetPlatform dflags + platform <- getPlatform let -- assign the results, if necessary @@ -2889,6 +2886,8 @@ genCCall64' :: DynFlags -> [CmmActual] -- arguments (of mixed type) -> NatM InstrBlock genCCall64' dflags target dest_regs args = do + config <- getConfig + let platform = ncgPlatform config -- load up the register arguments let prom_args = map (maybePromoteCArg dflags W32) args @@ -2921,15 +2920,16 @@ genCCall64' dflags target dest_regs args = do -- Align stack to 16n for calls, assuming a starting stack -- alignment of 16n - word_size on procedure entry. Which we -- maintain. See Note [rts/StgCRun.c : Stack Alignment on X86] + let word_size = platformWordSizeInBytes platform (real_size, adjust_rsp) <- - if (tot_arg_size + wORD_SIZE dflags) `rem` 16 == 0 + if (tot_arg_size + word_size) `rem` 16 == 0 then return (tot_arg_size, nilOL) else do -- we need to adjust... delta <- getDeltaNat - setDeltaNat (delta - wORD_SIZE dflags) - return (tot_arg_size + wORD_SIZE dflags, toOL [ - SUB II64 (OpImm (ImmInt (wORD_SIZE dflags))) (OpReg rsp), - DELTA (delta - wORD_SIZE dflags) ]) + setDeltaNat (delta - word_size) + return (tot_arg_size + word_size, toOL [ + SUB II64 (OpImm (ImmInt word_size)) (OpReg rsp), + DELTA (delta - word_size) ]) -- push the stack args, right to left push_code <- push_args (reverse stack_args) nilOL @@ -2971,7 +2971,7 @@ genCCall64' dflags target dest_regs args = do -- stdcall has callee do it, but is not supported on -- x86_64 target (see #3336) (if real_size==0 then [] else - [ADD (intFormat (wordWidth dflags)) (OpImm (ImmInt real_size)) (OpReg esp)]) + [ADD (intFormat (ncgWordWidth config)) (OpImm (ImmInt real_size)) (OpReg esp)]) ++ [DELTA (delta + real_size)] ) @@ -3003,8 +3003,7 @@ genCCall64' dflags target dest_regs args = do call `appOL` assign_code dest_regs) - where platform = targetPlatform dflags - arg_size = 8 -- always, at the mo + where arg_size = 8 -- always, at the mo load_args :: [CmmExpr] @@ -3107,7 +3106,7 @@ genCCall64' dflags target dest_regs args = do let code' = code `appOL` arg_code `appOL` toOL [ SUB (intFormat (wordWidth dflags)) (OpImm (ImmInt arg_size)) (OpReg rsp), DELTA (delta-arg_size), - MOV (floatFormat width) (OpReg arg_reg) (OpAddr (spRel dflags 0))] + MOV (floatFormat width) (OpReg arg_reg) (OpAddr (spRel (targetPlatform dflags) 0))] push_args rest code' | otherwise = do @@ -3250,17 +3249,19 @@ outOfLineCmmOp bid mop res args -- ----------------------------------------------------------------------------- -- Generating a table-branch -genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock +genSwitch :: CmmExpr -> SwitchTargets -> NatM InstrBlock -genSwitch dflags expr targets - | positionIndependent dflags - = do +genSwitch expr targets = do + config <- getConfig + dflags <- getDynFlags + let platform = ncgPlatform config + if ncgPIC config + then do (reg,e_code) <- getNonClobberedReg (cmmOffset dflags expr offset) -- getNonClobberedReg because it needs to survive across t_code lbl <- getNewLabelNat - dflags <- getDynFlags - let is32bit = target32Bit (targetPlatform dflags) - os = platformOS (targetPlatform dflags) + let is32bit = target32Bit platform + os = platformOS platform -- Might want to use .rodata.<function we're in> instead, but as -- long as it's something unique it'll work out since the -- references to the jump table are in the appropriate section. @@ -3275,12 +3276,12 @@ genSwitch dflags expr targets dynRef <- cmmMakeDynamicReference dflags DataReference lbl (tableReg,t_code) <- getSomeReg $ dynRef let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) - (EAIndex reg (wORD_SIZE dflags)) (ImmInt 0)) + (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0)) - offsetReg <- getNewRegNat (intFormat (wordWidth dflags)) + offsetReg <- getNewRegNat (intFormat (ncgWordWidth config)) return $ if is32bit || os == OSDarwin then e_code `appOL` t_code `appOL` toOL [ - ADD (intFormat (wordWidth dflags)) op (OpReg tableReg), + ADD (intFormat (ncgWordWidth config)) op (OpReg tableReg), JMP_TBL (OpReg tableReg) ids rosection lbl ] else -- HACK: On x86_64 binutils<2.17 is only able to generate @@ -3291,16 +3292,15 @@ genSwitch dflags expr targets -- PprMach.hs/pprDataItem once binutils 2.17 is standard. e_code `appOL` t_code `appOL` toOL [ MOVSxL II32 op (OpReg offsetReg), - ADD (intFormat (wordWidth dflags)) + ADD (intFormat (ncgWordWidth config)) (OpReg offsetReg) (OpReg tableReg), JMP_TBL (OpReg tableReg) ids rosection lbl ] - | otherwise - = do + else do (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset) lbl <- getNewLabelNat - let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (wORD_SIZE dflags)) (ImmCLbl lbl)) + let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (platformWordSizeInBytes platform)) (ImmCLbl lbl)) code = e_code `appOL` toOL [ JMP_TBL op ids (Section ReadOnlyData lbl) lbl ] @@ -3309,27 +3309,27 @@ genSwitch dflags expr targets (offset, blockIds) = switchTargetsToTable targets ids = map (fmap DestBlockId) blockIds -generateJumpTableForInstr :: DynFlags -> Instr -> Maybe (NatCmmDecl (Alignment, RawCmmStatics) Instr) -generateJumpTableForInstr dflags (JMP_TBL _ ids section lbl) +generateJumpTableForInstr :: NCGConfig -> Instr -> Maybe (NatCmmDecl (Alignment, RawCmmStatics) Instr) +generateJumpTableForInstr config (JMP_TBL _ ids section lbl) = let getBlockId (DestBlockId id) = id getBlockId _ = panic "Non-Label target in Jump Table" blockIds = map (fmap getBlockId) ids - in Just (createJumpTable dflags blockIds section lbl) + in Just (createJumpTable config blockIds section lbl) generateJumpTableForInstr _ _ = Nothing -createJumpTable :: DynFlags -> [Maybe BlockId] -> Section -> CLabel +createJumpTable :: NCGConfig -> [Maybe BlockId] -> Section -> CLabel -> GenCmmDecl (Alignment, RawCmmStatics) h g -createJumpTable dflags ids section lbl +createJumpTable config ids section lbl = let jumpTable - | positionIndependent dflags = - let ww = wordWidth dflags + | ncgPIC config = + let ww = ncgWordWidth config jumpTableEntryRel Nothing = CmmStaticLit (CmmInt 0 ww) jumpTableEntryRel (Just blockid) = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0 ww) where blockLabel = blockLbl blockid in map jumpTableEntryRel ids - | otherwise = map (jumpTableEntry dflags) ids + | otherwise = map (jumpTableEntry config) ids in CmmData section (mkAlignment 1, RawCmmStatics lbl jumpTable) extractUnwindPoints :: [Instr] -> [UnwindPoint] diff --git a/compiler/GHC/CmmToAsm/X86/Instr.hs b/compiler/GHC/CmmToAsm/X86/Instr.hs index 4171806695..71ee322516 100644 --- a/compiler/GHC/CmmToAsm/X86/Instr.hs +++ b/compiler/GHC/CmmToAsm/X86/Instr.hs @@ -27,6 +27,7 @@ import GHC.CmmToAsm.Format import GHC.Platform.Reg.Class import GHC.Platform.Reg import GHC.CmmToAsm.Reg.Target +import GHC.CmmToAsm.Config import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Collections @@ -39,7 +40,6 @@ import GHC.Platform import BasicTypes (Alignment) import GHC.Cmm.CLabel -import GHC.Driver.Session import UniqSet import Unique import UniqSupply @@ -660,50 +660,51 @@ x86_patchJumpInstr insn patchF -- ----------------------------------------------------------------------------- -- | Make a spill instruction. x86_mkSpillInstr - :: DynFlags + :: NCGConfig -> Reg -- register to spill -> Int -- current stack delta -> Int -- spill slot to use -> Instr -x86_mkSpillInstr dflags reg delta slot +x86_mkSpillInstr config reg delta slot = let off = spillSlotToOffset platform slot - delta in case targetClassOfReg platform reg of RcInteger -> MOV (archWordFormat is32Bit) - (OpReg reg) (OpAddr (spRel dflags off)) - RcDouble -> MOV FF64 (OpReg reg) (OpAddr (spRel dflags off)) + (OpReg reg) (OpAddr (spRel platform off)) + RcDouble -> MOV FF64 (OpReg reg) (OpAddr (spRel platform off)) _ -> panic "X86.mkSpillInstr: no match" - where platform = targetPlatform dflags + where platform = ncgPlatform config is32Bit = target32Bit platform -- | Make a spill reload instruction. x86_mkLoadInstr - :: DynFlags + :: NCGConfig -> Reg -- register to load -> Int -- current stack delta -> Int -- spill slot to use -> Instr -x86_mkLoadInstr dflags reg delta slot +x86_mkLoadInstr config reg delta slot = let off = spillSlotToOffset platform slot - delta in case targetClassOfReg platform reg of RcInteger -> MOV (archWordFormat is32Bit) - (OpAddr (spRel dflags off)) (OpReg reg) - RcDouble -> MOV FF64 (OpAddr (spRel dflags off)) (OpReg reg) + (OpAddr (spRel platform off)) (OpReg reg) + RcDouble -> MOV FF64 (OpAddr (spRel platform off)) (OpReg reg) _ -> panic "X86.x86_mkLoadInstr" - where platform = targetPlatform dflags + where platform = ncgPlatform config is32Bit = target32Bit platform spillSlotSize :: Platform -> Int -spillSlotSize dflags = if is32Bit then 12 else 8 - where is32Bit = target32Bit dflags - -maxSpillSlots :: DynFlags -> Int -maxSpillSlots dflags - = ((rESERVED_C_STACK_BYTES dflags - 64) `div` spillSlotSize (targetPlatform dflags)) - 1 --- = 0 -- useful for testing allocMoreStack +spillSlotSize platform + | target32Bit platform = 12 + | otherwise = 8 + +maxSpillSlots :: NCGConfig -> Int +maxSpillSlots config + = ((ncgSpillPreallocSize config - 64) `div` spillSlotSize (ncgPlatform config)) - 1 +-- = 0 -- useful for testing allocMoreStack -- number of bytes that the stack pointer should be aligned to stackAlign :: Int diff --git a/compiler/GHC/CmmToAsm/X86/Ppr.hs b/compiler/GHC/CmmToAsm/X86/Ppr.hs index a5b9041974..5aa216f6ba 100644 --- a/compiler/GHC/CmmToAsm/X86/Ppr.hs +++ b/compiler/GHC/CmmToAsm/X86/Ppr.hs @@ -28,6 +28,7 @@ import GHC.CmmToAsm.X86.Regs import GHC.CmmToAsm.X86.Instr import GHC.CmmToAsm.X86.Cond import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.Config import GHC.CmmToAsm.Format import GHC.Platform.Reg import GHC.CmmToAsm.Ppr @@ -69,36 +70,36 @@ import Data.Bits -- .subsections_via_symbols and -dead_strip can be found at -- <https://developer.apple.com/library/mac/documentation/DeveloperTools/Reference/Assembler/040-Assembler_Directives/asm_directives.html#//apple_ref/doc/uid/TP30000823-TPXREF101> -pprProcAlignment :: SDoc -pprProcAlignment = sdocWithDynFlags $ \dflags -> - (maybe empty (pprAlign . mkAlignment) (cmmProcAlignment dflags)) +pprProcAlignment :: NCGConfig -> SDoc +pprProcAlignment config = maybe empty (pprAlign platform . mkAlignment) (ncgProcAlignment config) + where + platform = ncgPlatform config -pprNatCmmDecl :: NatCmmDecl (Alignment, RawCmmStatics) Instr -> SDoc -pprNatCmmDecl (CmmData section dats) = - pprSectionAlign section $$ pprDatas dats +pprNatCmmDecl :: NCGConfig -> NatCmmDecl (Alignment, RawCmmStatics) Instr -> SDoc +pprNatCmmDecl config (CmmData section dats) = + pprSectionAlign config section $$ pprDatas config dats -pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = - sdocWithDynFlags $ \dflags -> - pprProcAlignment $$ +pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = + let platform = ncgPlatform config in + pprProcAlignment config $$ case topInfoTable proc of Nothing -> -- special case for code without info table: - pprSectionAlign (Section Text lbl) $$ - pprProcAlignment $$ - pprLabel lbl $$ -- blocks guaranteed not null, so label needed - vcat (map (pprBasicBlock top_info) blocks) $$ - (if debugLevel dflags > 0 + pprSectionAlign config (Section Text lbl) $$ + pprProcAlignment config $$ + pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed + vcat (map (pprBasicBlock config top_info) blocks) $$ + (if ncgDebugLevel config > 0 then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$ - pprSizeDecl lbl + pprSizeDecl platform lbl Just (RawCmmStatics info_lbl _) -> - sdocWithPlatform $ \platform -> - pprSectionAlign (Section Text info_lbl) $$ - pprProcAlignment $$ + pprSectionAlign config (Section Text info_lbl) $$ + pprProcAlignment config $$ (if platformHasSubsectionsViaSymbols platform then ppr (mkDeadStripPreventer info_lbl) <> char ':' else empty) $$ - vcat (map (pprBasicBlock top_info) blocks) $$ + vcat (map (pprBasicBlock config top_info) blocks) $$ -- above: Even the first block gets a label, because with branch-chain -- elimination, it might be the target of a goto. (if platformHasSubsectionsViaSymbols platform @@ -108,51 +109,49 @@ pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = <+> char '-' <+> ppr (mkDeadStripPreventer info_lbl) else empty) $$ - pprSizeDecl info_lbl + pprSizeDecl platform info_lbl -- | Output the ELF .size directive. -pprSizeDecl :: CLabel -> SDoc -pprSizeDecl lbl - = sdocWithPlatform $ \platform -> - if osElfTarget (platformOS platform) +pprSizeDecl :: Platform -> CLabel -> SDoc +pprSizeDecl platform lbl + = if osElfTarget (platformOS platform) then text "\t.size" <+> ppr lbl <> ptext (sLit ", .-") <> ppr lbl else empty -pprBasicBlock :: LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc -pprBasicBlock info_env (BasicBlock blockid instrs) +pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc +pprBasicBlock config info_env (BasicBlock blockid instrs) = maybe_infotable $ - pprLabel asmLbl $$ - vcat (map pprInstr instrs) $$ - (sdocOption sdocDebugLevel $ \level -> - if level > 0 - then ppr (mkAsmTempEndLabel asmLbl) <> char ':' - else empty + pprLabel platform asmLbl $$ + vcat (map (pprInstr platform) instrs) $$ + (if ncgDebugLevel config > 0 + then ppr (mkAsmTempEndLabel asmLbl) <> char ':' + else empty ) where asmLbl = blockLbl blockid + platform = ncgPlatform config maybe_infotable c = case mapLookup blockid info_env of Nothing -> c Just (RawCmmStatics infoLbl info) -> - pprAlignForSection Text $$ + pprAlignForSection platform Text $$ infoTableLoc $$ - vcat (map pprData info) $$ - pprLabel infoLbl $$ + vcat (map (pprData config) info) $$ + pprLabel platform infoLbl $$ c $$ - (sdocOption sdocDebugLevel $ \level -> - if level > 0 - then ppr (mkAsmTempEndLabel infoLbl) <> char ':' - else empty + (if ncgDebugLevel config > 0 + then ppr (mkAsmTempEndLabel infoLbl) <> char ':' + else empty ) -- Make sure the info table has the right .loc for the block -- coming right after it. See [Note: Info Offset] infoTableLoc = case instrs of - (l@LOCATION{} : _) -> pprInstr l + (l@LOCATION{} : _) -> pprInstr platform l _other -> empty -pprDatas :: (Alignment, RawCmmStatics) -> SDoc +pprDatas :: NCGConfig -> (Alignment, RawCmmStatics) -> SDoc -- See note [emit-time elimination of static indirections] in CLabel. -pprDatas (_, RawCmmStatics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) +pprDatas _config (_, RawCmmStatics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) | lbl == mkIndStaticInfoLabel , let labelInd (CmmLabelOff l _) = Just l labelInd (CmmLabel l) = Just l @@ -162,18 +161,21 @@ pprDatas (_, RawCmmStatics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, = pprGloblDecl alias $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind') -pprDatas (align, (RawCmmStatics lbl dats)) - = vcat (pprAlign align : pprLabel lbl : map pprData dats) +pprDatas config (align, (RawCmmStatics lbl dats)) + = vcat (pprAlign platform align : pprLabel platform lbl : map (pprData config) dats) + where + platform = ncgPlatform config -pprData :: CmmStatic -> SDoc -pprData (CmmString str) = pprBytes str +pprData :: NCGConfig -> CmmStatic -> SDoc +pprData _config (CmmString str) = pprBytes str -pprData (CmmUninitialised bytes) - = sdocWithPlatform $ \platform -> - if platformOS platform == OSDarwin then text ".space " <> int bytes - else text ".skip " <> int bytes +pprData config (CmmUninitialised bytes) + = let platform = ncgPlatform config + in if platformOS platform == OSDarwin + then text ".space " <> int bytes + else text ".skip " <> int bytes -pprData (CmmStaticLit lit) = pprDataItem lit +pprData config (CmmStaticLit lit) = pprDataItem config lit pprGloblDecl :: CLabel -> SDoc pprGloblDecl lbl @@ -238,24 +240,23 @@ pprLabelType' dflags lbl = isInfoTableLabel lbl && not (isConInfoTableLabel lbl) -pprTypeDecl :: CLabel -> SDoc -pprTypeDecl lbl - = sdocWithPlatform $ \platform -> - if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl +pprTypeDecl :: Platform -> CLabel -> SDoc +pprTypeDecl platform lbl + = if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl then sdocWithDynFlags $ \df -> text ".type " <> ppr lbl <> ptext (sLit ", ") <> pprLabelType' df lbl else empty -pprLabel :: CLabel -> SDoc -pprLabel lbl = pprGloblDecl lbl - $$ pprTypeDecl lbl - $$ (ppr lbl <> char ':') +pprLabel :: Platform -> CLabel -> SDoc +pprLabel platform lbl = + pprGloblDecl lbl + $$ pprTypeDecl platform lbl + $$ (ppr lbl <> char ':') -pprAlign :: Alignment -> SDoc -pprAlign alignment - = sdocWithPlatform $ \platform -> - text ".align " <> int (alignmentOn platform) +pprAlign :: Platform -> Alignment -> SDoc +pprAlign platform alignment + = text ".align " <> int (alignmentOn platform) where bytes = alignmentBytes alignment alignmentOn platform = if platformOS platform == OSDarwin @@ -269,18 +270,15 @@ pprAlign alignment log2 8 = 3 log2 n = 1 + log2 (n `quot` 2) --- ----------------------------------------------------------------------------- --- pprInstr: print an 'Instr' - instance Outputable Instr where - ppr instr = pprInstr instr + ppr instr = sdocWithDynFlags $ \dflags -> + pprInstr (targetPlatform dflags) instr -pprReg :: Format -> Reg -> SDoc -pprReg f r +pprReg :: Platform -> Format -> Reg -> SDoc +pprReg platform f r = case r of RegReal (RealRegSingle i) -> - sdocWithPlatform $ \platform -> if target32Bit platform then ppr32_reg_no f i else ppr64_reg_no f i RegReal (RealRegPair _ _) -> panic "X86.Ppr: no reg pairs on this arch" @@ -439,8 +437,8 @@ pprImm (ImmConstantDiff a b) = pprImm a <> char '-' -pprAddr :: AddrMode -> SDoc -pprAddr (ImmAddr imm off) +pprAddr :: Platform -> AddrMode -> SDoc +pprAddr _platform (ImmAddr imm off) = let pp_imm = pprImm imm in if (off == 0) then @@ -450,12 +448,11 @@ pprAddr (ImmAddr imm off) else pp_imm <> char '+' <> int off -pprAddr (AddrBaseIndex base index displacement) - = sdocWithPlatform $ \platform -> - let +pprAddr platform (AddrBaseIndex base index displacement) + = let pp_disp = ppr_disp displacement pp_off p = pp_disp <> char '(' <> p <> char ')' - pp_reg r = pprReg (archWordFormat (target32Bit platform)) r + pp_reg r = pprReg platform (archWordFormat (target32Bit platform)) r in case (base, index) of (EABaseNone, EAIndexNone) -> pp_disp @@ -471,18 +468,16 @@ pprAddr (AddrBaseIndex base index displacement) ppr_disp imm = pprImm imm -- | Print section header and appropriate alignment for that section. -pprSectionAlign :: Section -> SDoc -pprSectionAlign (Section (OtherSection _) _) = +pprSectionAlign :: NCGConfig -> Section -> SDoc +pprSectionAlign _config (Section (OtherSection _) _) = panic "X86.Ppr.pprSectionAlign: unknown section" -pprSectionAlign sec@(Section seg _) = - sdocWithPlatform $ \platform -> - pprSectionHeader platform sec $$ - pprAlignForSection seg +pprSectionAlign config sec@(Section seg _) = + pprSectionHeader config sec $$ + pprAlignForSection (ncgPlatform config) seg -- | Print appropriate alignment for the given section type. -pprAlignForSection :: SectionType -> SDoc -pprAlignForSection seg = - sdocWithPlatform $ \platform -> +pprAlignForSection :: Platform -> SectionType -> SDoc +pprAlignForSection platform seg = text ".align " <> case platformOS platform of -- Darwin: alignments are given as shifts. @@ -511,14 +506,14 @@ pprAlignForSection seg = CString -> int 1 _ -> int 8 -pprDataItem :: CmmLit -> SDoc -pprDataItem lit = sdocWithDynFlags $ \dflags -> pprDataItem' dflags lit +pprDataItem :: NCGConfig -> CmmLit -> SDoc +pprDataItem config lit = sdocWithDynFlags $ \dflags -> pprDataItem' dflags config lit -pprDataItem' :: DynFlags -> CmmLit -> SDoc -pprDataItem' dflags lit +pprDataItem' :: DynFlags -> NCGConfig -> CmmLit -> SDoc +pprDataItem' dflags config lit = vcat (ppr_item (cmmTypeFormat $ cmmLitType dflags lit) lit) where - platform = targetPlatform dflags + platform = ncgPlatform config imm = litToImm lit -- These seem to be common: @@ -577,38 +572,38 @@ pprDataItem' dflags lit asmComment :: SDoc -> SDoc asmComment c = whenPprDebug $ text "# " <> c -pprInstr :: Instr -> SDoc +pprInstr :: Platform -> Instr -> SDoc +pprInstr platform i = case i of + COMMENT s + -> asmComment (ftext s) -pprInstr (COMMENT s) - = asmComment (ftext s) + LOCATION file line col _name + -> text "\t.loc " <> ppr file <+> ppr line <+> ppr col -pprInstr (LOCATION file line col _name) - = text "\t.loc " <> ppr file <+> ppr line <+> ppr col + DELTA d + -> asmComment $ text ("\tdelta = " ++ show d) -pprInstr (DELTA d) - = asmComment $ text ("\tdelta = " ++ show d) + NEWBLOCK _ + -> panic "pprInstr: NEWBLOCK" -pprInstr (NEWBLOCK _) - = panic "PprMach.pprInstr: NEWBLOCK" + UNWIND lbl d + -> asmComment (text "\tunwind = " <> ppr d) + $$ ppr lbl <> colon -pprInstr (UNWIND lbl d) - = asmComment (text "\tunwind = " <> ppr d) - $$ ppr lbl <> colon - -pprInstr (LDATA _ _) - = panic "PprMach.pprInstr: LDATA" + LDATA _ _ + -> panic "pprInstr: LDATA" {- -pprInstr (SPILL reg slot) - = hcat [ - text "\tSPILL", - char ' ', - pprUserReg reg, - comma, - text "SLOT" <> parens (int slot)] - -pprInstr (RELOAD slot reg) - = hcat [ + SPILL reg slot + -> hcat [ + text "\tSPILL", + char ' ', + pprUserReg reg, + comma, + text "SLOT" <> parens (int slot)] + + RELOAD slot reg + -> hcat [ text "\tRELOAD", char ' ', text "SLOT" <> parens (int slot), @@ -616,120 +611,170 @@ pprInstr (RELOAD slot reg) pprUserReg reg] -} --- Replace 'mov $0x0,%reg' by 'xor %reg,%reg', which is smaller and cheaper. --- The code generator catches most of these already, but not all. -pprInstr (MOV format (OpImm (ImmInt 0)) dst@(OpReg _)) - = pprInstr (XOR format' dst dst) - where format' = case format of - II64 -> II32 -- 32-bit version is equivalent, and smaller - _ -> format -pprInstr (MOV format src dst) - = pprFormatOpOp (sLit "mov") format src dst + -- Replace 'mov $0x0,%reg' by 'xor %reg,%reg', which is smaller and cheaper. + -- The code generator catches most of these already, but not all. + MOV format (OpImm (ImmInt 0)) dst@(OpReg _) + -> pprInstr platform (XOR format' dst dst) + where format' = case format of + II64 -> II32 -- 32-bit version is equivalent, and smaller + _ -> format + + MOV format src dst + -> pprFormatOpOp (sLit "mov") format src dst -pprInstr (CMOV cc format src dst) - = pprCondOpReg (sLit "cmov") format cc src dst + CMOV cc format src dst + -> pprCondOpReg (sLit "cmov") format cc src dst -pprInstr (MOVZxL II32 src dst) = pprFormatOpOp (sLit "mov") II32 src dst + MOVZxL II32 src dst + -> pprFormatOpOp (sLit "mov") II32 src dst -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple -- movl. But we represent it as a MOVZxL instruction, because -- the reg alloc would tend to throw away a plain reg-to-reg -- move, and we still want it to do that. -pprInstr (MOVZxL formats src dst) - = pprFormatOpOpCoerce (sLit "movz") formats II32 src dst + MOVZxL formats src dst + -> pprFormatOpOpCoerce (sLit "movz") formats II32 src dst -- zero-extension only needs to extend to 32 bits: on x86_64, -- the remaining zero-extension to 64 bits is automatic, and the 32-bit -- instruction is shorter. -pprInstr (MOVSxL formats src dst) - = sdocWithPlatform $ \platform -> - pprFormatOpOpCoerce (sLit "movs") formats (archWordFormat (target32Bit platform)) src dst - --- here we do some patching, since the physical registers are only set late --- in the code generation. -pprInstr (LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3)) - | reg1 == reg3 - = pprFormatOpOp (sLit "add") format (OpReg reg2) dst - -pprInstr (LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3)) - | reg2 == reg3 - = pprFormatOpOp (sLit "add") format (OpReg reg1) dst - -pprInstr (LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3)) - | reg1 == reg3 - = pprInstr (ADD format (OpImm displ) dst) - -pprInstr (LEA format src dst) = pprFormatOpOp (sLit "lea") format src dst - -pprInstr (ADD format (OpImm (ImmInt (-1))) dst) - = pprFormatOp (sLit "dec") format dst -pprInstr (ADD format (OpImm (ImmInt 1)) dst) - = pprFormatOp (sLit "inc") format dst -pprInstr (ADD format src dst) = pprFormatOpOp (sLit "add") format src dst -pprInstr (ADC format src dst) = pprFormatOpOp (sLit "adc") format src dst -pprInstr (SUB format src dst) = pprFormatOpOp (sLit "sub") format src dst -pprInstr (SBB format src dst) = pprFormatOpOp (sLit "sbb") format src dst -pprInstr (IMUL format op1 op2) = pprFormatOpOp (sLit "imul") format op1 op2 - -pprInstr (ADD_CC format src dst) - = pprFormatOpOp (sLit "add") format src dst -pprInstr (SUB_CC format src dst) - = pprFormatOpOp (sLit "sub") format src dst - -{- A hack. The Intel documentation says that "The two and three - operand forms [of IMUL] may also be used with unsigned operands - because the lower half of the product is the same regardless if - (sic) the operands are signed or unsigned. The CF and OF flags, - however, cannot be used to determine if the upper half of the - result is non-zero." So there. --} + MOVSxL formats src dst + -> pprFormatOpOpCoerce (sLit "movs") formats (archWordFormat (target32Bit platform)) src dst + + -- here we do some patching, since the physical registers are only set late + -- in the code generation. + LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3) + | reg1 == reg3 + -> pprFormatOpOp (sLit "add") format (OpReg reg2) dst + + LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3) + | reg2 == reg3 + -> pprFormatOpOp (sLit "add") format (OpReg reg1) dst + + LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3) + | reg1 == reg3 + -> pprInstr platform (ADD format (OpImm displ) dst) + + LEA format src dst + -> pprFormatOpOp (sLit "lea") format src dst + + ADD format (OpImm (ImmInt (-1))) dst + -> pprFormatOp (sLit "dec") format dst + + ADD format (OpImm (ImmInt 1)) dst + -> pprFormatOp (sLit "inc") format dst + + ADD format src dst + -> pprFormatOpOp (sLit "add") format src dst + + ADC format src dst + -> pprFormatOpOp (sLit "adc") format src dst + + SUB format src dst + -> pprFormatOpOp (sLit "sub") format src dst + + SBB format src dst + -> pprFormatOpOp (sLit "sbb") format src dst + + IMUL format op1 op2 + -> pprFormatOpOp (sLit "imul") format op1 op2 + + ADD_CC format src dst + -> pprFormatOpOp (sLit "add") format src dst + + SUB_CC format src dst + -> pprFormatOpOp (sLit "sub") format src dst + + -- Use a 32-bit instruction when possible as it saves a byte. + -- Notably, extracting the tag bits of a pointer has this form. + -- TODO: we could save a byte in a subsequent CMP instruction too, + -- but need something like a peephole pass for this + AND II64 src@(OpImm (ImmInteger mask)) dst + | 0 <= mask && mask < 0xffffffff + -> pprInstr platform (AND II32 src dst) + + AND FF32 src dst + -> pprOpOp (sLit "andps") FF32 src dst + + AND FF64 src dst + -> pprOpOp (sLit "andpd") FF64 src dst + + AND format src dst + -> pprFormatOpOp (sLit "and") format src dst + + OR format src dst + -> pprFormatOpOp (sLit "or") format src dst + + XOR FF32 src dst + -> pprOpOp (sLit "xorps") FF32 src dst + + XOR FF64 src dst + -> pprOpOp (sLit "xorpd") FF64 src dst + + XOR format src dst + -> pprFormatOpOp (sLit "xor") format src dst + + POPCNT format src dst + -> pprOpOp (sLit "popcnt") format src (OpReg dst) + + LZCNT format src dst + -> pprOpOp (sLit "lzcnt") format src (OpReg dst) + + TZCNT format src dst + -> pprOpOp (sLit "tzcnt") format src (OpReg dst) + + BSF format src dst + -> pprOpOp (sLit "bsf") format src (OpReg dst) + + BSR format src dst + -> pprOpOp (sLit "bsr") format src (OpReg dst) + + PDEP format src mask dst + -> pprFormatOpOpReg (sLit "pdep") format src mask dst + + PEXT format src mask dst + -> pprFormatOpOpReg (sLit "pext") format src mask dst + + PREFETCH NTA format src + -> pprFormatOp_ (sLit "prefetchnta") format src + + PREFETCH Lvl0 format src + -> pprFormatOp_ (sLit "prefetcht0") format src --- Use a 32-bit instruction when possible as it saves a byte. --- Notably, extracting the tag bits of a pointer has this form. --- TODO: we could save a byte in a subsequent CMP instruction too, --- but need something like a peephole pass for this -pprInstr (AND II64 src@(OpImm (ImmInteger mask)) dst) - | 0 <= mask && mask < 0xffffffff - = pprInstr (AND II32 src dst) -pprInstr (AND FF32 src dst) = pprOpOp (sLit "andps") FF32 src dst -pprInstr (AND FF64 src dst) = pprOpOp (sLit "andpd") FF64 src dst -pprInstr (AND format src dst) = pprFormatOpOp (sLit "and") format src dst -pprInstr (OR format src dst) = pprFormatOpOp (sLit "or") format src dst - -pprInstr (XOR FF32 src dst) = pprOpOp (sLit "xorps") FF32 src dst -pprInstr (XOR FF64 src dst) = pprOpOp (sLit "xorpd") FF64 src dst -pprInstr (XOR format src dst) = pprFormatOpOp (sLit "xor") format src dst - -pprInstr (POPCNT format src dst) = pprOpOp (sLit "popcnt") format src (OpReg dst) -pprInstr (LZCNT format src dst) = pprOpOp (sLit "lzcnt") format src (OpReg dst) -pprInstr (TZCNT format src dst) = pprOpOp (sLit "tzcnt") format src (OpReg dst) -pprInstr (BSF format src dst) = pprOpOp (sLit "bsf") format src (OpReg dst) -pprInstr (BSR format src dst) = pprOpOp (sLit "bsr") format src (OpReg dst) - -pprInstr (PDEP format src mask dst) = pprFormatOpOpReg (sLit "pdep") format src mask dst -pprInstr (PEXT format src mask dst) = pprFormatOpOpReg (sLit "pext") format src mask dst - -pprInstr (PREFETCH NTA format src ) = pprFormatOp_ (sLit "prefetchnta") format src -pprInstr (PREFETCH Lvl0 format src) = pprFormatOp_ (sLit "prefetcht0") format src -pprInstr (PREFETCH Lvl1 format src) = pprFormatOp_ (sLit "prefetcht1") format src -pprInstr (PREFETCH Lvl2 format src) = pprFormatOp_ (sLit "prefetcht2") format src - -pprInstr (NOT format op) = pprFormatOp (sLit "not") format op -pprInstr (BSWAP format op) = pprFormatOp (sLit "bswap") format (OpReg op) -pprInstr (NEGI format op) = pprFormatOp (sLit "neg") format op - -pprInstr (SHL format src dst) = pprShift (sLit "shl") format src dst -pprInstr (SAR format src dst) = pprShift (sLit "sar") format src dst -pprInstr (SHR format src dst) = pprShift (sLit "shr") format src dst - -pprInstr (BT format imm src) = pprFormatImmOp (sLit "bt") format imm src - -pprInstr (CMP format src dst) - | isFloatFormat format = pprFormatOpOp (sLit "ucomi") format src dst -- SSE2 - | otherwise = pprFormatOpOp (sLit "cmp") format src dst - -pprInstr (TEST format src dst) = sdocWithPlatform $ \platform -> - let format' = case (src,dst) of + PREFETCH Lvl1 format src + -> pprFormatOp_ (sLit "prefetcht1") format src + + PREFETCH Lvl2 format src + -> pprFormatOp_ (sLit "prefetcht2") format src + + NOT format op + -> pprFormatOp (sLit "not") format op + + BSWAP format op + -> pprFormatOp (sLit "bswap") format (OpReg op) + + NEGI format op + -> pprFormatOp (sLit "neg") format op + + SHL format src dst + -> pprShift (sLit "shl") format src dst + + SAR format src dst + -> pprShift (sLit "sar") format src dst + + SHR format src dst + -> pprShift (sLit "shr") format src dst + + BT format imm src + -> pprFormatImmOp (sLit "bt") format imm src + + CMP format src dst + | isFloatFormat format -> pprFormatOpOp (sLit "ucomi") format src dst -- SSE2 + | otherwise -> pprFormatOpOp (sLit "cmp") format src dst + + TEST format src dst + -> pprFormatOpOp (sLit "test") format' src dst + where -- Match instructions like 'test $0x3,%esi' or 'test $0x7,%rbx'. -- We can replace them by equivalent, but smaller instructions -- by reducing the size of the immediate operand as far as possible. @@ -740,275 +785,308 @@ pprInstr (TEST format src dst) = sdocWithPlatform $ \platform -> -- to be completely equivalent to the original; in particular so -- that the signed comparison condition bits are the same as they -- would be if doing a full word comparison. See #13425. - (OpImm (ImmInteger mask), OpReg dstReg) - | 0 <= mask && mask < 128 -> minSizeOfReg platform dstReg - _ -> format - in pprFormatOpOp (sLit "test") format' src dst - where - minSizeOfReg platform (RegReal (RealRegSingle i)) - | target32Bit platform && i <= 3 = II8 -- al, bl, cl, dl - | target32Bit platform && i <= 7 = II16 -- si, di, bp, sp - | not (target32Bit platform) && i <= 15 = II8 -- al .. r15b - minSizeOfReg _ _ = format -- other - -pprInstr (PUSH format op) = pprFormatOp (sLit "push") format op -pprInstr (POP format op) = pprFormatOp (sLit "pop") format op + format' = case (src,dst) of + (OpImm (ImmInteger mask), OpReg dstReg) + | 0 <= mask && mask < 128 -> minSizeOfReg platform dstReg + _ -> format + minSizeOfReg platform (RegReal (RealRegSingle i)) + | target32Bit platform && i <= 3 = II8 -- al, bl, cl, dl + | target32Bit platform && i <= 7 = II16 -- si, di, bp, sp + | not (target32Bit platform) && i <= 15 = II8 -- al .. r15b + minSizeOfReg _ _ = format -- other + + PUSH format op + -> pprFormatOp (sLit "push") format op + + POP format op + -> pprFormatOp (sLit "pop") format op -- both unused (SDM): --- pprInstr PUSHA = text "\tpushal" --- pprInstr POPA = text "\tpopal" - -pprInstr NOP = text "\tnop" -pprInstr (CLTD II8) = text "\tcbtw" -pprInstr (CLTD II16) = text "\tcwtd" -pprInstr (CLTD II32) = text "\tcltd" -pprInstr (CLTD II64) = text "\tcqto" -pprInstr (CLTD x) = panic $ "pprInstr: " ++ show x - -pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand II8 op) - -pprInstr (JXX cond blockid) - = pprCondInstr (sLit "j") cond (ppr lab) - where lab = blockLbl blockid - -pprInstr (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm) - -pprInstr (JMP (OpImm imm) _) = text "\tjmp " <> pprImm imm -pprInstr (JMP op _) = sdocWithPlatform $ \platform -> - text "\tjmp *" - <> pprOperand (archWordFormat (target32Bit platform)) op -pprInstr (JMP_TBL op _ _ _) = pprInstr (JMP op []) -pprInstr (CALL (Left imm) _) = text "\tcall " <> pprImm imm -pprInstr (CALL (Right reg) _) = sdocWithPlatform $ \platform -> - text "\tcall *" - <> pprReg (archWordFormat (target32Bit platform)) reg - -pprInstr (IDIV fmt op) = pprFormatOp (sLit "idiv") fmt op -pprInstr (DIV fmt op) = pprFormatOp (sLit "div") fmt op -pprInstr (IMUL2 fmt op) = pprFormatOp (sLit "imul") fmt op - --- x86_64 only -pprInstr (MUL format op1 op2) = pprFormatOpOp (sLit "mul") format op1 op2 -pprInstr (MUL2 format op) = pprFormatOp (sLit "mul") format op - -pprInstr (FDIV format op1 op2) = pprFormatOpOp (sLit "div") format op1 op2 -pprInstr (SQRT format op1 op2) = pprFormatOpReg (sLit "sqrt") format op1 op2 - -pprInstr (CVTSS2SD from to) = pprRegReg (sLit "cvtss2sd") from to -pprInstr (CVTSD2SS from to) = pprRegReg (sLit "cvtsd2ss") from to -pprInstr (CVTTSS2SIQ fmt from to) = pprFormatFormatOpReg (sLit "cvttss2si") FF32 fmt from to -pprInstr (CVTTSD2SIQ fmt from to) = pprFormatFormatOpReg (sLit "cvttsd2si") FF64 fmt from to -pprInstr (CVTSI2SS fmt from to) = pprFormatOpReg (sLit "cvtsi2ss") fmt from to -pprInstr (CVTSI2SD fmt from to) = pprFormatOpReg (sLit "cvtsi2sd") fmt from to - - -- FETCHGOT for PIC on ELF platforms -pprInstr (FETCHGOT reg) - = vcat [ text "\tcall 1f", - hcat [ text "1:\tpopl\t", pprReg II32 reg ], - hcat [ text "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), ", - pprReg II32 reg ] - ] - - -- FETCHPC for PIC on Darwin/x86 - -- get the instruction pointer into a register - -- (Terminology note: the IP is called Program Counter on PPC, - -- and it's a good thing to use the same name on both platforms) -pprInstr (FETCHPC reg) - = vcat [ text "\tcall 1f", - hcat [ text "1:\tpopl\t", pprReg II32 reg ] - ] - +-- PUSHA -> text "\tpushal" +-- POPA -> text "\tpopal" --- the --- GST fmt src addr ==> FLD dst ; FSTPsz addr -pprInstr g@(X87Store fmt addr) - = pprX87 g (hcat [gtab, - text "fstp", pprFormat_x87 fmt, gsp, pprAddr addr]) + NOP + -> text "\tnop" + CLTD II8 + -> text "\tcbtw" --- Atomics + CLTD II16 + -> text "\tcwtd" -pprInstr (LOCK i) = text "\tlock" $$ pprInstr i + CLTD II32 + -> text "\tcltd" -pprInstr MFENCE = text "\tmfence" + CLTD II64 + -> text "\tcqto" -pprInstr (XADD format src dst) = pprFormatOpOp (sLit "xadd") format src dst + CLTD x + -> panic $ "pprInstr: CLTD " ++ show x -pprInstr (CMPXCHG format src dst) - = pprFormatOpOp (sLit "cmpxchg") format src dst + SETCC cond op + -> pprCondInstr (sLit "set") cond (pprOperand platform II8 op) + JXX cond blockid + -> pprCondInstr (sLit "j") cond (ppr lab) + where lab = blockLbl blockid + JXX_GBL cond imm + -> pprCondInstr (sLit "j") cond (pprImm imm) --------------------------- --- some left over + JMP (OpImm imm) _ + -> text "\tjmp " <> pprImm imm + JMP op _ + -> text "\tjmp *" <> pprOperand platform (archWordFormat (target32Bit platform)) op + JMP_TBL op _ _ _ + -> pprInstr platform (JMP op []) -gtab :: SDoc -gtab = char '\t' + CALL (Left imm) _ + -> text "\tcall " <> pprImm imm -gsp :: SDoc -gsp = char ' ' + CALL (Right reg) _ + -> text "\tcall *" <> pprReg platform (archWordFormat (target32Bit platform)) reg + IDIV fmt op + -> pprFormatOp (sLit "idiv") fmt op + DIV fmt op + -> pprFormatOp (sLit "div") fmt op -pprX87 :: Instr -> SDoc -> SDoc -pprX87 fake actual - = (char '#' <> pprX87Instr fake) $$ actual + IMUL2 fmt op + -> pprFormatOp (sLit "imul") fmt op -pprX87Instr :: Instr -> SDoc -pprX87Instr (X87Store fmt dst) = pprFormatAddr (sLit "gst") fmt dst -pprX87Instr _ = panic "X86.Ppr.pprX87Instr: no match" + -- x86_64 only + MUL format op1 op2 + -> pprFormatOpOp (sLit "mul") format op1 op2 -pprDollImm :: Imm -> SDoc -pprDollImm i = text "$" <> pprImm i + MUL2 format op + -> pprFormatOp (sLit "mul") format op + FDIV format op1 op2 + -> pprFormatOpOp (sLit "div") format op1 op2 -pprOperand :: Format -> Operand -> SDoc -pprOperand f (OpReg r) = pprReg f r -pprOperand _ (OpImm i) = pprDollImm i -pprOperand _ (OpAddr ea) = pprAddr ea + SQRT format op1 op2 + -> pprFormatOpReg (sLit "sqrt") format op1 op2 + CVTSS2SD from to + -> pprRegReg (sLit "cvtss2sd") from to -pprMnemonic_ :: PtrString -> SDoc -pprMnemonic_ name = - char '\t' <> ptext name <> space + CVTSD2SS from to + -> pprRegReg (sLit "cvtsd2ss") from to + CVTTSS2SIQ fmt from to + -> pprFormatFormatOpReg (sLit "cvttss2si") FF32 fmt from to -pprMnemonic :: PtrString -> Format -> SDoc -pprMnemonic name format = - char '\t' <> ptext name <> pprFormat format <> space + CVTTSD2SIQ fmt from to + -> pprFormatFormatOpReg (sLit "cvttsd2si") FF64 fmt from to + CVTSI2SS fmt from to + -> pprFormatOpReg (sLit "cvtsi2ss") fmt from to -pprFormatImmOp :: PtrString -> Format -> Imm -> Operand -> SDoc -pprFormatImmOp name format imm op1 - = hcat [ - pprMnemonic name format, - char '$', - pprImm imm, - comma, - pprOperand format op1 - ] - - -pprFormatOp_ :: PtrString -> Format -> Operand -> SDoc -pprFormatOp_ name format op1 - = hcat [ - pprMnemonic_ name , - pprOperand format op1 - ] - -pprFormatOp :: PtrString -> Format -> Operand -> SDoc -pprFormatOp name format op1 - = hcat [ - pprMnemonic name format, - pprOperand format op1 - ] - - -pprFormatOpOp :: PtrString -> Format -> Operand -> Operand -> SDoc -pprFormatOpOp name format op1 op2 - = hcat [ - pprMnemonic name format, - pprOperand format op1, - comma, - pprOperand format op2 - ] + CVTSI2SD fmt from to + -> pprFormatOpReg (sLit "cvtsi2sd") fmt from to + -- FETCHGOT for PIC on ELF platforms + FETCHGOT reg + -> vcat [ text "\tcall 1f", + hcat [ text "1:\tpopl\t", pprReg platform II32 reg ], + hcat [ text "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), ", + pprReg platform II32 reg ] + ] -pprOpOp :: PtrString -> Format -> Operand -> Operand -> SDoc -pprOpOp name format op1 op2 - = hcat [ - pprMnemonic_ name, - pprOperand format op1, - comma, - pprOperand format op2 - ] + -- FETCHPC for PIC on Darwin/x86 + -- get the instruction pointer into a register + -- (Terminology note: the IP is called Program Counter on PPC, + -- and it's a good thing to use the same name on both platforms) + FETCHPC reg + -> vcat [ text "\tcall 1f", + hcat [ text "1:\tpopl\t", pprReg platform II32 reg ] + ] + -- the + -- GST fmt src addr ==> FLD dst ; FSTPsz addr + g@(X87Store fmt addr) + -> pprX87 g (hcat [gtab, text "fstp", pprFormat_x87 fmt, gsp, pprAddr platform addr]) + -- Atomics + LOCK i + -> text "\tlock" $$ pprInstr platform i -pprRegReg :: PtrString -> Reg -> Reg -> SDoc -pprRegReg name reg1 reg2 - = sdocWithPlatform $ \platform -> - hcat [ - pprMnemonic_ name, - pprReg (archWordFormat (target32Bit platform)) reg1, - comma, - pprReg (archWordFormat (target32Bit platform)) reg2 - ] - - -pprFormatOpReg :: PtrString -> Format -> Operand -> Reg -> SDoc -pprFormatOpReg name format op1 reg2 - = sdocWithPlatform $ \platform -> - hcat [ - pprMnemonic name format, - pprOperand format op1, - comma, - pprReg (archWordFormat (target32Bit platform)) reg2 - ] - -pprCondOpReg :: PtrString -> Format -> Cond -> Operand -> Reg -> SDoc -pprCondOpReg name format cond op1 reg2 - = hcat [ - char '\t', - ptext name, - pprCond cond, - space, - pprOperand format op1, - comma, - pprReg format reg2 - ] - -pprFormatFormatOpReg :: PtrString -> Format -> Format -> Operand -> Reg -> SDoc -pprFormatFormatOpReg name format1 format2 op1 reg2 - = hcat [ - pprMnemonic name format2, - pprOperand format1 op1, - comma, - pprReg format2 reg2 - ] - -pprFormatOpOpReg :: PtrString -> Format -> Operand -> Operand -> Reg -> SDoc -pprFormatOpOpReg name format op1 op2 reg3 - = hcat [ - pprMnemonic name format, - pprOperand format op1, - comma, - pprOperand format op2, - comma, - pprReg format reg3 - ] + MFENCE + -> text "\tmfence" + XADD format src dst + -> pprFormatOpOp (sLit "xadd") format src dst + CMPXCHG format src dst + -> pprFormatOpOp (sLit "cmpxchg") format src dst -pprFormatAddr :: PtrString -> Format -> AddrMode -> SDoc -pprFormatAddr name format op - = hcat [ - pprMnemonic name format, - comma, - pprAddr op - ] - -pprShift :: PtrString -> Format -> Operand -> Operand -> SDoc -pprShift name format src dest - = hcat [ - pprMnemonic name format, - pprOperand II8 src, -- src is 8-bit sized - comma, - pprOperand format dest - ] - - -pprFormatOpOpCoerce :: PtrString -> Format -> Format -> Operand -> Operand -> SDoc -pprFormatOpOpCoerce name format1 format2 op1 op2 - = hcat [ char '\t', ptext name, pprFormat format1, pprFormat format2, space, - pprOperand format1 op1, - comma, - pprOperand format2 op2 - ] + where + gtab :: SDoc + gtab = char '\t' -pprCondInstr :: PtrString -> Cond -> SDoc -> SDoc -pprCondInstr name cond arg - = hcat [ char '\t', ptext name, pprCond cond, space, arg] + gsp :: SDoc + gsp = char ' ' + + + + pprX87 :: Instr -> SDoc -> SDoc + pprX87 fake actual + = (char '#' <> pprX87Instr fake) $$ actual + + pprX87Instr :: Instr -> SDoc + pprX87Instr (X87Store fmt dst) = pprFormatAddr (sLit "gst") fmt dst + pprX87Instr _ = panic "X86.Ppr.pprX87Instr: no match" + + pprDollImm :: Imm -> SDoc + pprDollImm i = text "$" <> pprImm i + + + pprOperand :: Platform -> Format -> Operand -> SDoc + pprOperand platform f op = case op of + OpReg r -> pprReg platform f r + OpImm i -> pprDollImm i + OpAddr ea -> pprAddr platform ea + + + pprMnemonic_ :: PtrString -> SDoc + pprMnemonic_ name = + char '\t' <> ptext name <> space + + + pprMnemonic :: PtrString -> Format -> SDoc + pprMnemonic name format = + char '\t' <> ptext name <> pprFormat format <> space + + + pprFormatImmOp :: PtrString -> Format -> Imm -> Operand -> SDoc + pprFormatImmOp name format imm op1 + = hcat [ + pprMnemonic name format, + char '$', + pprImm imm, + comma, + pprOperand platform format op1 + ] + + + pprFormatOp_ :: PtrString -> Format -> Operand -> SDoc + pprFormatOp_ name format op1 + = hcat [ + pprMnemonic_ name , + pprOperand platform format op1 + ] + + pprFormatOp :: PtrString -> Format -> Operand -> SDoc + pprFormatOp name format op1 + = hcat [ + pprMnemonic name format, + pprOperand platform format op1 + ] + + + pprFormatOpOp :: PtrString -> Format -> Operand -> Operand -> SDoc + pprFormatOpOp name format op1 op2 + = hcat [ + pprMnemonic name format, + pprOperand platform format op1, + comma, + pprOperand platform format op2 + ] + + + pprOpOp :: PtrString -> Format -> Operand -> Operand -> SDoc + pprOpOp name format op1 op2 + = hcat [ + pprMnemonic_ name, + pprOperand platform format op1, + comma, + pprOperand platform format op2 + ] + + pprRegReg :: PtrString -> Reg -> Reg -> SDoc + pprRegReg name reg1 reg2 + = hcat [ + pprMnemonic_ name, + pprReg platform (archWordFormat (target32Bit platform)) reg1, + comma, + pprReg platform (archWordFormat (target32Bit platform)) reg2 + ] + + + pprFormatOpReg :: PtrString -> Format -> Operand -> Reg -> SDoc + pprFormatOpReg name format op1 reg2 + = hcat [ + pprMnemonic name format, + pprOperand platform format op1, + comma, + pprReg platform (archWordFormat (target32Bit platform)) reg2 + ] + + pprCondOpReg :: PtrString -> Format -> Cond -> Operand -> Reg -> SDoc + pprCondOpReg name format cond op1 reg2 + = hcat [ + char '\t', + ptext name, + pprCond cond, + space, + pprOperand platform format op1, + comma, + pprReg platform format reg2 + ] + + pprFormatFormatOpReg :: PtrString -> Format -> Format -> Operand -> Reg -> SDoc + pprFormatFormatOpReg name format1 format2 op1 reg2 + = hcat [ + pprMnemonic name format2, + pprOperand platform format1 op1, + comma, + pprReg platform format2 reg2 + ] + + pprFormatOpOpReg :: PtrString -> Format -> Operand -> Operand -> Reg -> SDoc + pprFormatOpOpReg name format op1 op2 reg3 + = hcat [ + pprMnemonic name format, + pprOperand platform format op1, + comma, + pprOperand platform format op2, + comma, + pprReg platform format reg3 + ] + + + + pprFormatAddr :: PtrString -> Format -> AddrMode -> SDoc + pprFormatAddr name format op + = hcat [ + pprMnemonic name format, + comma, + pprAddr platform op + ] + + pprShift :: PtrString -> Format -> Operand -> Operand -> SDoc + pprShift name format src dest + = hcat [ + pprMnemonic name format, + pprOperand platform II8 src, -- src is 8-bit sized + comma, + pprOperand platform format dest + ] + + + pprFormatOpOpCoerce :: PtrString -> Format -> Format -> Operand -> Operand -> SDoc + pprFormatOpOpCoerce name format1 format2 op1 op2 + = hcat [ char '\t', ptext name, pprFormat format1, pprFormat format2, space, + pprOperand platform format1 op1, + comma, + pprOperand platform format2 op2 + ] + + + pprCondInstr :: PtrString -> Cond -> SDoc -> SDoc + pprCondInstr name cond arg + = hcat [ char '\t', ptext name, pprCond cond, space, arg] diff --git a/compiler/GHC/CmmToAsm/X86/Regs.hs b/compiler/GHC/CmmToAsm/X86/Regs.hs index 87e31a1428..ab8e6d3b4f 100644 --- a/compiler/GHC/CmmToAsm/X86/Regs.hs +++ b/compiler/GHC/CmmToAsm/X86/Regs.hs @@ -57,7 +57,6 @@ import GHC.Platform.Reg.Class import GHC.Cmm import GHC.Cmm.CLabel ( CLabel ) -import GHC.Driver.Session import Outputable import GHC.Platform @@ -188,11 +187,11 @@ addrModeRegs _ = [] -- applicable, is the same but for the frame pointer. -spRel :: DynFlags +spRel :: Platform -> Int -- ^ desired stack offset in bytes, positive or negative -> AddrMode -spRel dflags n - | target32Bit (targetPlatform dflags) +spRel platform n + | target32Bit platform = AddrBaseIndex (EABaseReg esp) EAIndexNone (ImmInt n) | otherwise = AddrBaseIndex (EABaseReg rsp) EAIndexNone (ImmInt n) diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs index 6e6f58ba7d..7944f6a0fc 100644 --- a/compiler/GHC/CmmToC.hs +++ b/compiler/GHC/CmmToC.hs @@ -406,7 +406,7 @@ pprLoad dflags e ty -- (For tagging to work, I had to avoid unaligned loads. --ARY) -> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift dflags)) - _other -> cLoad e ty + _other -> cLoad (targetPlatform dflags) e ty where width = typeWidth ty @@ -1145,10 +1145,9 @@ te_Reg _ = return () cCast :: SDoc -> CmmExpr -> SDoc cCast ty expr = parens ty <> pprExpr1 expr -cLoad :: CmmExpr -> CmmType -> SDoc -cLoad expr rep - = sdocWithPlatform $ \platform -> - if bewareLoadStoreAlignment (platformArch platform) +cLoad :: Platform -> CmmExpr -> CmmType -> SDoc +cLoad platform expr rep + = if bewareLoadStoreAlignment (platformArch platform) then let decl = machRepCType rep <+> text "x" <> semi struct = text "struct" <+> braces (decl) packed_attr = text "__attribute__((packed))" diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 97dd1a6f07..ac0bbbd286 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -235,7 +235,7 @@ module GHC.Driver.Session ( initSDocContext, -- * Make use of the Cmm CFG - CfgWeights(..), backendMaintainsCfg + CfgWeights(..) ) where #include "HsVersions.h" @@ -852,12 +852,6 @@ parseCfgWeights s oldWeights = ",likelyCondWeight=900,unlikelyCondWeight=300" ++ ",infoTablePenalty=300,backEdgeBonus=400" -backendMaintainsCfg :: DynFlags -> Bool -backendMaintainsCfg dflags = case (platformArch $ targetPlatform dflags) of - -- ArchX86 -- Should work but not tested so disabled currently. - ArchX86_64 -> True - _otherwise -> False - class HasDynFlags m where getDynFlags :: m DynFlags @@ -5226,7 +5220,6 @@ initSDocContext dflags style = SDC , sdocLineLength = pprCols dflags , sdocCanUseUnicode = useUnicode dflags , sdocHexWordLiterals = gopt Opt_HexWordLiterals dflags - , sdocDebugLevel = debugLevel dflags , sdocPprDebug = dopt Opt_D_ppr_debug dflags , sdocPrintUnicodeSyntax = gopt Opt_PrintUnicodeSyntax dflags , sdocPrintCaseAsLet = gopt Opt_PprCaseAsLet dflags diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 0cc41b65c0..7a2fd82342 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -269,6 +269,7 @@ Library FileSettings GHC.Cmm.Graph GHC.CmmToAsm.Ppr + GHC.CmmToAsm.Config GHC.CmmToC GHC.Cmm.Ppr GHC.Cmm.Ppr.Decl diff --git a/compiler/main/Elf.hs b/compiler/main/Elf.hs index e9c80d7d81..4d3b06e731 100644 --- a/compiler/main/Elf.hs +++ b/compiler/main/Elf.hs @@ -19,6 +19,7 @@ import GhcPrelude import AsmUtils import Exception import GHC.Driver.Session +import GHC.Platform import ErrUtils import Maybes (MaybeT(..),runMaybeT) import Util (charToC) @@ -408,12 +409,12 @@ readElfNoteAsString dflags path sectionName noteId = action `catchIO` \_ -> do -- | Generate the GAS code to create a Note section -- -- Header fields for notes are 32-bit long (see Note [ELF specification]). -makeElfNote :: String -> String -> Word32 -> String -> SDoc -makeElfNote sectionName noteName typ contents = hcat [ +makeElfNote :: Platform -> String -> String -> Word32 -> String -> SDoc +makeElfNote platform sectionName noteName typ contents = hcat [ text "\t.section ", text sectionName, text ",\"\",", - sectionType "note", + sectionType platform "note", text "\n", text "\t.balign 4\n", diff --git a/compiler/main/SysTools/ExtraObj.hs b/compiler/main/SysTools/ExtraObj.hs index 9ff428f9ca..73b28a368f 100644 --- a/compiler/main/SysTools/ExtraObj.hs +++ b/compiler/main/SysTools/ExtraObj.hs @@ -143,22 +143,23 @@ mkNoteObjsToLinkIntoBinary :: DynFlags -> [InstalledUnitId] -> IO [FilePath] mkNoteObjsToLinkIntoBinary dflags dep_packages = do link_info <- getLinkInfo dflags dep_packages - if (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags))) + if (platformSupportsSavingLinkOpts (platformOS platform )) then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc dflags (link_opts link_info)) else return [] where + platform = targetPlatform dflags link_opts info = hcat [ -- "link info" section (see Note [LinkInfo section]) - makeElfNote ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info, + makeElfNote platform ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info, -- ALL generated assembly must have this section to disable -- executable stacks. See also -- compiler/nativeGen/AsmCodeGen.hs for another instance -- where we need to do this. - if platformHasGnuNonexecStack (targetPlatform dflags) + if platformHasGnuNonexecStack platform then text ".section .note.GNU-stack,\"\"," - <> sectionType "progbits" <> char '\n' + <> sectionType platform "progbits" <> char '\n' else Outputable.empty ] diff --git a/compiler/utils/AsmUtils.hs b/compiler/utils/AsmUtils.hs index 591b53dc31..d3393d71e2 100644 --- a/compiler/utils/AsmUtils.hs +++ b/compiler/utils/AsmUtils.hs @@ -12,9 +12,10 @@ import GHC.Platform import Outputable -- | Generate a section type (e.g. @\@progbits@). See #13937. -sectionType :: String -- ^ section type - -> SDoc -- ^ pretty assembler fragment -sectionType ty = sdocWithPlatform $ \platform -> +sectionType :: Platform -- ^ Target platform + -> String -- ^ section type + -> SDoc -- ^ pretty assembler fragment +sectionType platform ty = case platformArch platform of ArchARM{} -> char '%' <> text ty _ -> char '@' <> text ty diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs index 7133951d67..6f6a335ed7 100644 --- a/compiler/utils/Outputable.hs +++ b/compiler/utils/Outputable.hs @@ -71,7 +71,7 @@ module Outputable ( neverQualify, neverQualifyNames, neverQualifyModules, alwaysQualifyPackages, neverQualifyPackages, QualifyName(..), queryQual, - sdocWithDynFlags, sdocWithPlatform, sdocOption, + sdocWithDynFlags, sdocOption, updSDocContext, SDocContext (..), sdocWithContext, getPprStyle, withPprStyle, setStyleColoured, @@ -96,7 +96,7 @@ import GhcPrelude import {-# SOURCE #-} GHC.Driver.Session ( DynFlags, hasPprDebug, hasNoDebugOutput - , targetPlatform, pprUserLength, pprCols + , pprUserLength, pprCols , unsafeGlobalDynFlags, initSDocContext ) import {-# SOURCE #-} Module( UnitId, Module, ModuleName, moduleName ) @@ -106,7 +106,6 @@ import BufWrite (BufHandle) import FastString import qualified Pretty import Util -import GHC.Platform import qualified PprColour as Col import Pretty ( Doc, Mode(..) ) import Panic @@ -346,7 +345,6 @@ data SDocContext = SDC -- ^ True if Unicode encoding is supported -- and not disable by GHC_NO_UNICODE environment variable , sdocHexWordLiterals :: !Bool - , sdocDebugLevel :: !Int , sdocPprDebug :: !Bool , sdocPrintUnicodeSyntax :: !Bool , sdocPrintCaseAsLet :: !Bool @@ -422,9 +420,6 @@ getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx sdocWithDynFlags :: (DynFlags -> SDoc) -> SDoc sdocWithDynFlags f = SDoc $ \ctx -> runSDoc (f (sdocDynFlags ctx)) ctx -sdocWithPlatform :: (Platform -> SDoc) -> SDoc -sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform) - sdocWithContext :: (SDocContext -> SDoc) -> SDoc sdocWithContext f = SDoc $ \ctx -> runSDoc (f ctx) ctx diff --git a/testsuite/tests/regalloc/regalloc_unit_tests.hs b/testsuite/tests/regalloc/regalloc_unit_tests.hs index f9ccd1f703..2b018fc0e1 100644 --- a/testsuite/tests/regalloc/regalloc_unit_tests.hs +++ b/testsuite/tests/regalloc/regalloc_unit_tests.hs @@ -200,7 +200,7 @@ testGraphNoSpills dflags' path us = do -- discard irrelevant stats extractSRMs x = case x of Color.RegAllocStatsColored _ _ _ _ _ _ _ _ - rSrms -> Just rSrms + rSrms _ -> Just rSrms _ -> Nothing matchesExpected (a, b, c) = a == 0 && b == 0 |