diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2011-07-27 11:05:30 +0100 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2011-07-27 11:05:30 +0100 |
| commit | 64a27638cd3260e0487dd43147d55436735763e7 (patch) | |
| tree | 214c0974205faa88fba7e850c062117e80b5ae6c /compiler/nativeGen | |
| parent | 3fdd294af643a86162e544f442b0e36c57e1db36 (diff) | |
| parent | 7639e7518b8430b3f2eff2b847c3283e0f00e8ec (diff) | |
| download | haskell-64a27638cd3260e0487dd43147d55436735763e7.tar.gz | |
Merge branch 'master' of http://darcs.haskell.org/ghc
Conflicts:
compiler/coreSyn/CoreSubst.lhs
compiler/rename/RnNames.lhs
Diffstat (limited to 'compiler/nativeGen')
37 files changed, 2130 insertions, 2059 deletions
diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index ff18615b1a..94b0258f57 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -62,6 +62,7 @@ import DynFlags import StaticFlags import Util +import BasicTypes ( Alignment ) import Digraph import Pretty (Doc) import qualified Pretty @@ -131,31 +132,32 @@ The machine-dependent bits break down as follows: -- ----------------------------------------------------------------------------- -- Top-level of the native codegen -data NcgImpl instr jumpDest = NcgImpl { - cmmTopCodeGen :: RawCmmTop -> NatM [NatCmmTop instr], - generateJumpTableForInstr :: instr -> Maybe (NatCmmTop instr), +data NcgImpl statics instr jumpDest = NcgImpl { + cmmTopCodeGen :: RawCmmTop -> NatM [NatCmmTop statics instr], + generateJumpTableForInstr :: instr -> Maybe (NatCmmTop statics instr), getJumpDestBlockId :: jumpDest -> Maybe BlockId, canShortcut :: instr -> Maybe jumpDest, - shortcutStatic :: (BlockId -> Maybe jumpDest) -> CmmStatic -> CmmStatic, + shortcutStatics :: (BlockId -> Maybe jumpDest) -> statics -> statics, shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr, - pprNatCmmTop :: NatCmmTop instr -> Doc, + pprNatCmmTop :: Platform -> NatCmmTop statics instr -> Doc, maxSpillSlots :: Int, allocatableRegs :: [RealReg], - ncg_x86fp_kludge :: [NatCmmTop instr] -> [NatCmmTop instr], - ncgExpandTop :: [NatCmmTop instr] -> [NatCmmTop instr], + ncg_x86fp_kludge :: [NatCmmTop statics instr] -> [NatCmmTop statics instr], + ncgExpandTop :: [NatCmmTop statics instr] -> [NatCmmTop statics instr], ncgMakeFarBranches :: [NatBasicBlock instr] -> [NatBasicBlock instr] } -------------------- nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmm] -> IO () nativeCodeGen dflags h us cmms - = let nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms + = let nCG' :: (Outputable statics, PlatformOutputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO () + nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms x86NcgImpl = NcgImpl { cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr ,getJumpDestBlockId = X86.Instr.getJumpDestBlockId ,canShortcut = X86.Instr.canShortcut - ,shortcutStatic = X86.Instr.shortcutStatic + ,shortcutStatics = X86.Instr.shortcutStatics ,shortcutJump = X86.Instr.shortcutJump ,pprNatCmmTop = X86.Ppr.pprNatCmmTop ,maxSpillSlots = X86.Instr.maxSpillSlots @@ -173,7 +175,7 @@ nativeCodeGen dflags h us cmms ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr ,getJumpDestBlockId = PPC.RegInfo.getJumpDestBlockId ,canShortcut = PPC.RegInfo.canShortcut - ,shortcutStatic = PPC.RegInfo.shortcutStatic + ,shortcutStatics = PPC.RegInfo.shortcutStatics ,shortcutJump = PPC.RegInfo.shortcutJump ,pprNatCmmTop = PPC.Ppr.pprNatCmmTop ,maxSpillSlots = PPC.Instr.maxSpillSlots @@ -188,7 +190,7 @@ nativeCodeGen dflags h us cmms ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr ,getJumpDestBlockId = SPARC.ShortcutJump.getJumpDestBlockId ,canShortcut = SPARC.ShortcutJump.canShortcut - ,shortcutStatic = SPARC.ShortcutJump.shortcutStatic + ,shortcutStatics = SPARC.ShortcutJump.shortcutStatics ,shortcutJump = SPARC.ShortcutJump.shortcutJump ,pprNatCmmTop = SPARC.Ppr.pprNatCmmTop ,maxSpillSlots = SPARC.Instr.maxSpillSlots @@ -204,13 +206,14 @@ nativeCodeGen dflags h us cmms ArchUnknown -> panic "nativeCodeGen: No NCG for unknown arch" -nativeCodeGen' :: (Instruction instr, Outputable instr) +nativeCodeGen' :: (Outputable statics, PlatformOutputable instr, Instruction instr) => DynFlags - -> NcgImpl instr jumpDest + -> NcgImpl statics instr jumpDest -> Handle -> UniqSupply -> [RawCmm] -> IO () nativeCodeGen' dflags ncgImpl h us cmms = do - let split_cmms = concat $ map add_split cmms + let platform = targetPlatform dflags + split_cmms = concat $ map add_split cmms -- BufHandle is a performance hack. We could hide it inside -- Pretty if it weren't for the fact that we do lots of little -- printDocs here (in order to do codegen in constant space). @@ -224,7 +227,7 @@ nativeCodeGen' dflags ncgImpl h us cmms -- dump native code dumpIfSet_dyn dflags Opt_D_dump_asm "Asm code" - (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) $ concat native) + (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl platform) $ concat native) -- dump global NCG stats for graph coloring allocator (case concat $ catMaybes colorStats of @@ -242,10 +245,10 @@ nativeCodeGen' dflags ncgImpl h us cmms dumpIfSet_dyn dflags Opt_D_dump_asm_conflicts "Register conflict graph" $ Color.dotGraph - targetRegDotColor - (Color.trivColorable - targetVirtualRegSqueeze - targetRealRegSqueeze) + (targetRegDotColor platform) + (Color.trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform)) $ graphGlobal) @@ -265,25 +268,25 @@ nativeCodeGen' dflags ncgImpl h us cmms | dopt Opt_SplitObjs dflags = split_marker : tops | otherwise = tops - split_marker = CmmProc [] mkSplitMarkerLabel (ListGraph []) + split_marker = CmmProc Nothing mkSplitMarkerLabel (ListGraph []) -- | Do native code generation on all these cmms. -- -cmmNativeGens :: (Instruction instr, Outputable instr) +cmmNativeGens :: (Outputable statics, PlatformOutputable instr, Instruction instr) => DynFlags - -> NcgImpl instr jumpDest + -> NcgImpl statics instr jumpDest -> BufHandle -> UniqSupply -> [RawCmmTop] -> [[CLabel]] - -> [ ([NatCmmTop instr], - Maybe [Color.RegAllocStats instr], + -> [ ([NatCmmTop statics instr], + Maybe [Color.RegAllocStats statics instr], Maybe [Linear.RegAllocStats]) ] -> Int -> IO ( [[CLabel]], - [([NatCmmTop instr], - Maybe [Color.RegAllocStats instr], + [([NatCmmTop statics instr], + Maybe [Color.RegAllocStats statics instr], Maybe [Linear.RegAllocStats])] ) cmmNativeGens _ _ _ _ [] impAcc profAcc _ @@ -295,7 +298,7 @@ cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count <- cmmNativeGen dflags ncgImpl us cmm count Pretty.bufLeftRender h - $ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map (pprNatCmmTop ncgImpl) native + $ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map (pprNatCmmTop ncgImpl (targetPlatform dflags)) native -- carefully evaluate this strictly. Binding it with 'let' -- and then using 'seq' doesn't work, because the let @@ -325,20 +328,21 @@ cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count -- Dumping the output of each stage along the way. -- Global conflict graph and NGC stats cmmNativeGen - :: (Instruction instr, Outputable instr) + :: (Outputable statics, PlatformOutputable instr, Instruction instr) => DynFlags - -> NcgImpl instr jumpDest + -> NcgImpl statics instr jumpDest -> UniqSupply -> RawCmmTop -- ^ the cmm to generate code for -> Int -- ^ sequence number of this top thing -> IO ( UniqSupply - , [NatCmmTop instr] -- native code - , [CLabel] -- things imported by this cmm - , Maybe [Color.RegAllocStats instr] -- stats for the coloring register allocator - , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators + , [NatCmmTop statics instr] -- native code + , [CLabel] -- things imported by this cmm + , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator + , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators cmmNativeGen dflags ncgImpl us cmm count = do + let platform = targetPlatform dflags -- rewrite assignments to global regs let fixed_cmm = @@ -352,7 +356,7 @@ cmmNativeGen dflags ncgImpl us cmm count dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm" - (pprCmm $ Cmm [opt_cmm]) + (pprCmm platform $ Cmm [opt_cmm]) -- generate native code from cmm let ((native, lastMinuteImports), usGen) = @@ -361,18 +365,18 @@ cmmNativeGen dflags ncgImpl us cmm count dumpIfSet_dyn dflags Opt_D_dump_asm_native "Native code" - (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) native) + (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl platform) native) -- tag instructions with register liveness information let (withLiveness, usLive) = {-# SCC "regLiveness" #-} initUs usGen - $ mapUs regLiveness + $ mapUs (regLiveness platform) $ map natCmmTopToLive native dumpIfSet_dyn dflags Opt_D_dump_asm_liveness "Liveness annotations added" - (vcat $ map ppr withLiveness) + (vcat $ map (pprPlatform platform) withLiveness) -- allocate registers (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <- @@ -382,7 +386,7 @@ cmmNativeGen dflags ncgImpl us cmm count -- the regs usable for allocation let (alloc_regs :: UniqFM (UniqSet RealReg)) = foldr (\r -> plusUFM_C unionUniqSets - $ unitUFM (targetClassOfRealReg r) (unitUniqSet r)) + $ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r)) emptyUFM $ allocatableRegs ncgImpl @@ -399,14 +403,14 @@ cmmNativeGen dflags ncgImpl us cmm count -- dump out what happened during register allocation dumpIfSet_dyn dflags Opt_D_dump_asm_regalloc "Registers allocated" - (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) alloced) + (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl platform) alloced) dumpIfSet_dyn dflags Opt_D_dump_asm_regalloc_stages "Build/spill stages" (vcat $ map (\(stage, stats) -> text "# --------------------------" $$ text "# cmm " <> int count <> text " Stage " <> int stage - $$ ppr stats) + $$ pprPlatform platform stats) $ zip [0..] regAllocStats) let mPprStats = @@ -430,7 +434,7 @@ cmmNativeGen dflags ncgImpl us cmm count dumpIfSet_dyn dflags Opt_D_dump_asm_regalloc "Registers allocated" - (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) alloced) + (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl platform) alloced) let mPprStats = if dopt Opt_D_dump_asm_stats dflags @@ -474,7 +478,7 @@ cmmNativeGen dflags ncgImpl us cmm count dumpIfSet_dyn dflags Opt_D_dump_asm_expanded "Synthetic instructions expanded" - (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) expanded) + (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl platform) expanded) return ( usAlloc , expanded @@ -483,7 +487,7 @@ cmmNativeGen dflags ncgImpl us cmm count , ppr_raStatsLinear) -x86fp_kludge :: NatCmmTop X86.Instr.Instr -> NatCmmTop X86.Instr.Instr +x86fp_kludge :: NatCmmTop (Alignment, CmmStatics) X86.Instr.Instr -> NatCmmTop (Alignment, CmmStatics) X86.Instr.Instr x86fp_kludge top@(CmmData _ _) = top x86fp_kludge (CmmProc info lbl (ListGraph code)) = CmmProc info lbl (ListGraph $ X86.Instr.i386_insert_ffrees code) @@ -556,7 +560,7 @@ makeImportsDoc dflags imports sequenceTop :: Instruction instr - => NcgImpl instr jumpDest -> NatCmmTop instr -> NatCmmTop instr + => NcgImpl statics instr jumpDest -> NatCmmTop statics instr -> NatCmmTop statics instr sequenceTop _ top@(CmmData _ _) = top sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) = @@ -670,8 +674,8 @@ makeFarBranches blocks -- Analyzes all native code and generates data sections for all jump -- table instructions. generateJumpTables - :: NcgImpl instr jumpDest - -> [NatCmmTop instr] -> [NatCmmTop instr] + :: NcgImpl statics instr jumpDest + -> [NatCmmTop statics instr] -> [NatCmmTop statics instr] generateJumpTables ncgImpl xs = concatMap f xs where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs f p = [p] @@ -682,9 +686,9 @@ generateJumpTables ncgImpl xs = concatMap f xs shortcutBranches :: DynFlags - -> NcgImpl instr jumpDest - -> [NatCmmTop instr] - -> [NatCmmTop instr] + -> NcgImpl statics instr jumpDest + -> [NatCmmTop statics instr] + -> [NatCmmTop statics instr] shortcutBranches dflags ncgImpl tops | optLevel dflags < 1 = tops -- only with -O or higher @@ -693,7 +697,7 @@ shortcutBranches dflags ncgImpl tops (tops', mappings) = mapAndUnzip (build_mapping ncgImpl) tops mapping = foldr plusUFM emptyUFM mappings -build_mapping :: NcgImpl instr jumpDest +build_mapping :: NcgImpl statics instr jumpDest -> GenCmmTop d t (ListGraph instr) -> (GenCmmTop d t (ListGraph instr), UniqFM jumpDest) build_mapping _ top@(CmmData _ _) = (top, emptyUFM) @@ -723,14 +727,12 @@ build_mapping ncgImpl (CmmProc info lbl (ListGraph (head:blocks))) mapping = foldl add emptyUFM shortcut_blocks add ufm (id,dest) = addToUFM ufm id dest -apply_mapping :: NcgImpl instr jumpDest +apply_mapping :: NcgImpl statics instr jumpDest -> UniqFM jumpDest - -> GenCmmTop CmmStatic h (ListGraph instr) - -> GenCmmTop CmmStatic h (ListGraph instr) + -> GenCmmTop statics h (ListGraph instr) + -> GenCmmTop statics h (ListGraph instr) apply_mapping ncgImpl ufm (CmmData sec statics) - = CmmData sec (map (shortcutStatic ncgImpl (lookupUFM ufm)) statics) - -- we need to get the jump tables, so apply the mapping to the entries - -- of a CmmData too. + = CmmData sec (shortcutStatics ncgImpl (lookupUFM ufm) statics) apply_mapping ncgImpl ufm (CmmProc info lbl (ListGraph blocks)) = CmmProc info lbl (ListGraph $ map short_bb blocks) where @@ -761,10 +763,10 @@ apply_mapping ncgImpl ufm (CmmProc info lbl (ListGraph blocks)) genMachCode :: DynFlags - -> (RawCmmTop -> NatM [NatCmmTop instr]) + -> (RawCmmTop -> NatM [NatCmmTop statics instr]) -> RawCmmTop -> UniqSM - ( [NatCmmTop instr] + ( [NatCmmTop statics instr] , [CLabel]) genMachCode dflags cmmTopCodeGen cmm_top diff --git a/compiler/nativeGen/Instruction.hs b/compiler/nativeGen/Instruction.hs index 918198cb9c..b2db2ef206 100644 --- a/compiler/nativeGen/Instruction.hs +++ b/compiler/nativeGen/Instruction.hs @@ -1,11 +1,11 @@ module Instruction ( - RegUsage(..), - noUsage, - NatCmm, - NatCmmTop, - NatBasicBlock, - Instruction(..) + RegUsage(..), + noUsage, + NatCmm, + NatCmmTop, + NatBasicBlock, + Instruction(..) ) where @@ -14,19 +14,20 @@ import Reg import BlockId import OldCmm +import Platform -- | Holds a list of source and destination registers used by a --- particular instruction. +-- particular instruction. -- -- Machine registers that are pre-allocated to stgRegs are filtered --- out, because they are uninteresting from a register allocation --- standpoint. (We wouldn't want them to end up on the free list!) +-- out, because they are uninteresting from a register allocation +-- standpoint. (We wouldn't want them to end up on the free list!) -- -- As far as we are concerned, the fixed registers simply don't exist --- (for allocation purposes, anyway). +-- (for allocation purposes, anyway). -- -data RegUsage - = RU [Reg] [Reg] +data RegUsage + = RU [Reg] [Reg] -- | No regs read or written to. noUsage :: RegUsage @@ -36,124 +37,127 @@ noUsage = RU [] [] -- Our flavours of the Cmm types -- Type synonyms for Cmm populated with native code type NatCmm instr - = GenCmm - CmmStatic - [CmmStatic] - (ListGraph instr) + = GenCmm + CmmStatics + (Maybe CmmStatics) + (ListGraph instr) -type NatCmmTop instr - = GenCmmTop - CmmStatic - [CmmStatic] - (ListGraph instr) +type NatCmmTop statics instr + = GenCmmTop + statics + (Maybe CmmStatics) + (ListGraph instr) type NatBasicBlock instr - = GenBasicBlock instr + = GenBasicBlock instr -- | Common things that we can do with instructions, on all architectures. --- These are used by the shared parts of the native code generator, --- specifically the register allocators. +-- These are used by the shared parts of the native code generator, +-- specifically the register allocators. -- -class Instruction instr where - - -- | Get the registers that are being used by this instruction. - -- regUsage doesn't need to do any trickery for jumps and such. - -- Just state precisely the regs read and written by that insn. - -- The consequences of control flow transfers, as far as register - -- allocation goes, are taken care of by the register allocator. - -- - regUsageOfInstr - :: instr - -> RegUsage - - - -- | Apply a given mapping to all the register references in this - -- instruction. - patchRegsOfInstr - :: instr - -> (Reg -> Reg) - -> instr - - - -- | Checks whether this instruction is a jump/branch instruction. - -- One that can change the flow of control in a way that the - -- register allocator needs to worry about. - isJumpishInstr - :: instr -> Bool - - - -- | Give the possible destinations of this jump instruction. - -- Must be defined for all jumpish instructions. - jumpDestsOfInstr - :: instr -> [BlockId] - - - -- | Change the destination of this jump instruction. - -- Used in the linear allocator when adding fixup blocks for join - -- points. - patchJumpInstr - :: instr - -> (BlockId -> BlockId) - -> instr - - - -- | An instruction to spill a register into a spill slot. - mkSpillInstr - :: Reg -- ^ the reg to spill - -> Int -- ^ the current stack delta - -> Int -- ^ spill slot to use - -> instr - - - -- | An instruction to reload a register from a spill slot. - mkLoadInstr - :: Reg -- ^ the reg to reload. - -> Int -- ^ the current stack delta - -> Int -- ^ the spill slot to use - -> instr - - -- | See if this instruction is telling us the current C stack delta - takeDeltaInstr - :: instr - -> Maybe Int - - -- | Check whether this instruction is some meta thing inserted into - -- the instruction stream for other purposes. - -- - -- Not something that has to be treated as a real machine instruction - -- and have its registers allocated. - -- - -- eg, comments, delta, ldata, etc. - isMetaInstr - :: instr - -> Bool - - - - -- | Copy the value in a register to another one. - -- Must work for all register classes. - mkRegRegMoveInstr - :: Reg -- ^ source register - -> Reg -- ^ destination register - -> instr - - -- | Take the source and destination from this reg -> reg move instruction - -- or Nothing if it's not one - takeRegRegMoveInstr - :: instr - -> Maybe (Reg, Reg) - - -- | Make an unconditional jump instruction. - -- For architectures with branch delay slots, its ok to put - -- a NOP after the jump. Don't fill the delay slot with an - -- instruction that references regs or you'll confuse the - -- linear allocator. - mkJumpInstr - :: BlockId - -> [instr] - - +class Instruction instr where + + -- | Get the registers that are being used by this instruction. + -- regUsage doesn't need to do any trickery for jumps and such. + -- Just state precisely the regs read and written by that insn. + -- The consequences of control flow transfers, as far as register + -- allocation goes, are taken care of by the register allocator. + -- + regUsageOfInstr + :: instr + -> RegUsage + + + -- | Apply a given mapping to all the register references in this + -- instruction. + patchRegsOfInstr + :: instr + -> (Reg -> Reg) + -> instr + + + -- | Checks whether this instruction is a jump/branch instruction. + -- One that can change the flow of control in a way that the + -- register allocator needs to worry about. + isJumpishInstr + :: instr -> Bool + + + -- | Give the possible destinations of this jump instruction. + -- Must be defined for all jumpish instructions. + jumpDestsOfInstr + :: instr -> [BlockId] + + + -- | Change the destination of this jump instruction. + -- Used in the linear allocator when adding fixup blocks for join + -- points. + patchJumpInstr + :: instr + -> (BlockId -> BlockId) + -> instr + + + -- | An instruction to spill a register into a spill slot. + mkSpillInstr + :: Platform + -> Reg -- ^ the reg to spill + -> Int -- ^ the current stack delta + -> Int -- ^ spill slot to use + -> instr + + + -- | An instruction to reload a register from a spill slot. + mkLoadInstr + :: Platform + -> Reg -- ^ the reg to reload. + -> Int -- ^ the current stack delta + -> Int -- ^ the spill slot to use + -> instr + + -- | See if this instruction is telling us the current C stack delta + takeDeltaInstr + :: instr + -> Maybe Int + + -- | Check whether this instruction is some meta thing inserted into + -- the instruction stream for other purposes. + -- + -- Not something that has to be treated as a real machine instruction + -- and have its registers allocated. + -- + -- eg, comments, delta, ldata, etc. + isMetaInstr + :: instr + -> Bool + + + + -- | Copy the value in a register to another one. + -- Must work for all register classes. + mkRegRegMoveInstr + :: Platform + -> Reg -- ^ source register + -> Reg -- ^ destination register + -> instr + + -- | Take the source and destination from this reg -> reg move instruction + -- or Nothing if it's not one + takeRegRegMoveInstr + :: instr + -> Maybe (Reg, Reg) + + -- | Make an unconditional jump instruction. + -- For architectures with branch delay slots, its ok to put + -- a NOP after the jump. Don't fill the delay slot with an + -- instruction that references regs or you'll confuse the + -- linear allocator. + mkJumpInstr + :: BlockId + -> [instr] + + diff --git a/compiler/nativeGen/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs index 2a7376838a..57d2adf9b8 100644 --- a/compiler/nativeGen/NCGMonad.hs +++ b/compiler/nativeGen/NCGMonad.hs @@ -130,18 +130,20 @@ getNewLabelNat getNewRegNat :: Size -> NatM Reg -getNewRegNat rep - = do u <- getUniqueNat - return (RegVirtual $ targetMkVirtualReg u rep) +getNewRegNat rep + = do u <- getUniqueNat + dflags <- getDynFlagsNat + return (RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep) getNewRegPairNat :: Size -> NatM (Reg,Reg) -getNewRegPairNat rep - = do u <- getUniqueNat - let vLo = targetMkVirtualReg u rep - let lo = RegVirtual $ targetMkVirtualReg u rep - let hi = RegVirtual $ getHiVirtualRegFromLo vLo - return (lo, hi) +getNewRegPairNat rep + = do u <- getUniqueNat + dflags <- getDynFlagsNat + let vLo = targetMkVirtualReg (targetPlatform dflags) u rep + let lo = RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep + let hi = RegVirtual $ getHiVirtualRegFromLo vLo + return (lo, hi) getPicBaseMaybeNat :: NatM (Maybe Reg) diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs index c375ab4707..7f59fd6fc9 100644 --- a/compiler/nativeGen/PIC.hs +++ b/compiler/nativeGen/PIC.hs @@ -709,8 +709,8 @@ pprImportedSymbol _ _ _ initializePicBase_ppc :: Arch -> OS -> Reg - -> [NatCmmTop PPC.Instr] - -> NatM [NatCmmTop PPC.Instr] + -> [NatCmmTop CmmStatics PPC.Instr] + -> NatM [NatCmmTop CmmStatics PPC.Instr] initializePicBase_ppc ArchPPC os picReg (CmmProc info lab (ListGraph blocks) : statics) @@ -719,8 +719,7 @@ initializePicBase_ppc ArchPPC os picReg gotOffLabel <- getNewLabelNat tmp <- getNewRegNat $ intSize wordWidth let - gotOffset = CmmData Text [ - CmmDataLabel gotOffLabel, + gotOffset = CmmData Text $ Statics gotOffLabel [ CmmStaticLit (CmmLabelDiffOff gotLabel mkPicBaseLabel 0) @@ -762,8 +761,8 @@ initializePicBase_ppc _ _ _ _ initializePicBase_x86 :: Arch -> OS -> Reg - -> [NatCmmTop X86.Instr] - -> NatM [NatCmmTop X86.Instr] + -> [NatCmmTop (Alignment, CmmStatics) X86.Instr] + -> NatM [NatCmmTop (Alignment, CmmStatics) X86.Instr] initializePicBase_x86 ArchX86 os picReg (CmmProc info lab (ListGraph blocks) : statics) diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index f4c972e4b0..a0e3ae92b5 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -67,7 +67,7 @@ import FastString cmmTopCodeGen :: RawCmmTop - -> NatM [NatCmmTop Instr] + -> NatM [NatCmmTop CmmStatics Instr] cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks @@ -86,7 +86,7 @@ cmmTopCodeGen (CmmData sec dat) = do basicBlockCodeGen :: CmmBasicBlock -> NatM ( [NatBasicBlock Instr] - , [NatCmmTop Instr]) + , [NatCmmTop CmmStatics Instr]) basicBlockCodeGen (BasicBlock id stmts) = do instrs <- stmtsToInstrs stmts @@ -403,11 +403,12 @@ getRegister' dflags (CmmMachOp (MO_SS_Conv W64 W32) [x]) ChildCode64 code rlo <- iselExpr64 x return $ Fixed II32 rlo code -getRegister' _ (CmmLoad mem pk) +getRegister' dflags (CmmLoad mem pk) | not (isWord64 pk) = do + let platform = targetPlatform dflags Amode addr addr_code <- getAmode mem - let code dst = ASSERT((targetClassOfReg dst == RcDouble) == isFloatType pk) + let code dst = ASSERT((targetClassOfReg platform dst == RcDouble) == isFloatType pk) addr_code `snocOL` LD size dst addr return (Any size code) where size = cmmTypeSize pk @@ -557,8 +558,8 @@ getRegister' _ (CmmLit (CmmFloat f frep)) = do Amode addr addr_code <- getAmode dynRef let size = floatSize frep code dst = - LDATA ReadOnlyData [CmmDataLabel lbl, - CmmStaticLit (CmmFloat f frep)] + LDATA ReadOnlyData (Statics lbl + [CmmStaticLit (CmmFloat f frep)]) `consOL` (addr_code `snocOL` LD size dst addr) return (Any size code) @@ -903,7 +904,7 @@ genCCall' _ (CmmPrim MO_WriteBarrier) _ _ = return $ unitOL LWSYNC genCCall' gcp target dest_regs argsAndHints - = ASSERT (not $ any (`elem` [II8,II16]) $ map cmmTypeSize argReps) + = ASSERT (not $ any (`elem` [II16]) $ map cmmTypeSize argReps) -- we rely on argument promotion in the codeGen do (finalStack,passArgumentsCode,usedRegs) <- passArguments @@ -1058,23 +1059,23 @@ genCCall' gcp target dest_regs argsAndHints = case gcp of GCPDarwin -> case cmmTypeSize rep of + II8 -> (1, 0, 4, gprs) II32 -> (1, 0, 4, gprs) -- The Darwin ABI requires that we skip a -- corresponding number of GPRs when we use -- the FPRs. FF32 -> (1, 1, 4, fprs) FF64 -> (2, 1, 8, fprs) - II8 -> panic "genCCall' passArguments II8" II16 -> panic "genCCall' passArguments II16" II64 -> panic "genCCall' passArguments II64" FF80 -> panic "genCCall' passArguments FF80" GCPLinux -> case cmmTypeSize rep of + II8 -> (1, 0, 4, gprs) II32 -> (1, 0, 4, gprs) -- ... the SysV ABI doesn't. FF32 -> (0, 1, 4, fprs) FF64 -> (0, 1, 8, fprs) - II8 -> panic "genCCall' passArguments II8" II16 -> panic "genCCall' passArguments II16" II64 -> panic "genCCall' passArguments II64" FF80 -> panic "genCCall' passArguments FF80" @@ -1180,7 +1181,7 @@ genSwitch expr ids ] return code -generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr) +generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop CmmStatics Instr) generateJumpTableForInstr (BCTR ids (Just lbl)) = let jumpTable | opt_PIC = map jumpTableEntryRel ids @@ -1190,7 +1191,7 @@ generateJumpTableForInstr (BCTR ids (Just lbl)) = jumpTableEntryRel (Just blockid) = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0) where blockLabel = mkAsmTempLabel (getUnique blockid) - in Just (CmmData ReadOnlyData (CmmDataLabel lbl : jumpTable)) + in Just (CmmData ReadOnlyData (Statics lbl jumpTable)) generateJumpTableForInstr _ = Nothing -- ----------------------------------------------------------------------------- @@ -1362,10 +1363,9 @@ coerceInt2FP fromRep toRep x = do Amode addr addr_code <- getAmode dynRef let code' dst = code `appOL` maybe_exts `appOL` toOL [ - LDATA ReadOnlyData - [CmmDataLabel lbl, - CmmStaticLit (CmmInt 0x43300000 W32), - CmmStaticLit (CmmInt 0x80000000 W32)], + LDATA ReadOnlyData $ Statics lbl + [CmmStaticLit (CmmInt 0x43300000 W32), + CmmStaticLit (CmmInt 0x80000000 W32)], XORIS itmp src (ImmInt 0x8000), ST II32 itmp (spRel 3), LIS itmp (ImmInt 0x4330), diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs index 0288f1bf02..ffe5408033 100644 --- a/compiler/nativeGen/PPC/Instr.hs +++ b/compiler/nativeGen/PPC/Instr.hs @@ -32,6 +32,7 @@ import OldCmm import FastString import CLabel import Outputable +import Platform import FastBool -------------------------------------------------------------------------------- @@ -43,18 +44,18 @@ archWordSize = II32 -- | Instruction instance for powerpc instance Instruction Instr where - regUsageOfInstr = ppc_regUsageOfInstr - patchRegsOfInstr = ppc_patchRegsOfInstr - isJumpishInstr = ppc_isJumpishInstr - jumpDestsOfInstr = ppc_jumpDestsOfInstr - patchJumpInstr = ppc_patchJumpInstr - mkSpillInstr = ppc_mkSpillInstr - mkLoadInstr = ppc_mkLoadInstr - takeDeltaInstr = ppc_takeDeltaInstr - isMetaInstr = ppc_isMetaInstr - mkRegRegMoveInstr = ppc_mkRegRegMoveInstr - takeRegRegMoveInstr = ppc_takeRegRegMoveInstr - mkJumpInstr = ppc_mkJumpInstr + regUsageOfInstr = ppc_regUsageOfInstr + patchRegsOfInstr = ppc_patchRegsOfInstr + isJumpishInstr = ppc_isJumpishInstr + jumpDestsOfInstr = ppc_jumpDestsOfInstr + patchJumpInstr = ppc_patchJumpInstr + mkSpillInstr = ppc_mkSpillInstr + mkLoadInstr = ppc_mkLoadInstr + takeDeltaInstr = ppc_takeDeltaInstr + isMetaInstr = ppc_isMetaInstr + mkRegRegMoveInstr _ = ppc_mkRegRegMoveInstr + takeRegRegMoveInstr = ppc_takeRegRegMoveInstr + mkJumpInstr = ppc_mkJumpInstr -- ----------------------------------------------------------------------------- @@ -75,7 +76,7 @@ data Instr -- some static data spat out during code -- generation. Will be extracted before -- pretty-printing. - | LDATA Section [CmmStatic] + | LDATA Section CmmStatics -- start a new basic block. Useful during -- codegen, removed later. Preceding @@ -346,15 +347,16 @@ ppc_patchJumpInstr insn patchF -- | An instruction to spill a register into a spill slot. ppc_mkSpillInstr - :: Reg -- register to spill - -> Int -- current stack delta - -> Int -- spill slot to use + :: Platform + -> Reg -- register to spill + -> Int -- current stack delta + -> Int -- spill slot to use -> Instr -ppc_mkSpillInstr reg delta slot +ppc_mkSpillInstr platform reg delta slot = let off = spillSlotToOffset slot in - let sz = case targetClassOfReg reg of + let sz = case targetClassOfReg platform reg of RcInteger -> II32 RcDouble -> FF64 _ -> panic "PPC.Instr.mkSpillInstr: no match" @@ -362,15 +364,16 @@ ppc_mkSpillInstr reg delta slot ppc_mkLoadInstr - :: Reg -- register to load - -> Int -- current stack delta - -> Int -- spill slot to use + :: Platform + -> Reg -- register to load + -> Int -- current stack delta + -> Int -- spill slot to use -> Instr -ppc_mkLoadInstr reg delta slot +ppc_mkLoadInstr platform reg delta slot = let off = spillSlotToOffset slot in - let sz = case targetClassOfReg reg of + let sz = case targetClassOfReg platform reg of RcInteger -> II32 RcDouble -> FF64 _ -> panic "PPC.Instr.mkLoadInstr: no match" diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs index bd12a8188c..54056c9e4d 100644 --- a/compiler/nativeGen/PPC/Ppr.hs +++ b/compiler/nativeGen/PPC/Ppr.hs @@ -37,10 +37,11 @@ import OldCmm import CLabel import Unique ( pprUnique, Uniquable(..) ) +import Platform import Pretty import FastString import qualified Outputable -import Outputable ( Outputable, panic ) +import Outputable ( PlatformOutputable, panic ) import Data.Word import Data.Bits @@ -49,26 +50,30 @@ import Data.Bits -- ----------------------------------------------------------------------------- -- Printing this stuff out -pprNatCmmTop :: NatCmmTop Instr -> Doc -pprNatCmmTop (CmmData section dats) = - pprSectionHeader section $$ vcat (map pprData dats) +pprNatCmmTop :: Platform -> NatCmmTop CmmStatics Instr -> Doc +pprNatCmmTop _ (CmmData section dats) = + pprSectionHeader section $$ pprDatas dats -- special case for split markers: -pprNatCmmTop (CmmProc [] lbl (ListGraph [])) = pprLabel lbl +pprNatCmmTop _ (CmmProc Nothing lbl (ListGraph [])) = pprLabel lbl -pprNatCmmTop (CmmProc info lbl (ListGraph blocks)) = + -- special case for code without an info table: +pprNatCmmTop platform (CmmProc Nothing lbl (ListGraph blocks)) = pprSectionHeader Text $$ - (if null info then -- blocks guaranteed not null, so label needed - pprLabel lbl - else + pprLabel lbl $$ -- blocks guaranteed not null, so label needed + vcat (map (pprBasicBlock platform) blocks) + +pprNatCmmTop platform (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blocks)) = + pprSectionHeader Text $$ + ( #if HAVE_SUBSECTIONS_VIA_SYMBOLS - pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl) - <> char ':' $$ + pprCLabel_asm (mkDeadStripPreventer info_lbl) + <> char ':' $$ #endif vcat (map pprData info) $$ - pprLabel (entryLblToInfoLbl lbl) + pprLabel info_lbl ) $$ - vcat (map pprBasicBlock blocks) + vcat (map (pprBasicBlock platform) blocks) -- above: Even the first block gets a label, because with branch-chain -- elimination, it might be the target of a goto. #if HAVE_SUBSECTIONS_VIA_SYMBOLS @@ -78,24 +83,24 @@ pprNatCmmTop (CmmProc info lbl (ListGraph blocks)) = -- from the entry code to a label on the _top_ of of the info table, -- so that the linker will not think it is unreferenced and dead-strip -- it. That's why the label is called a DeadStripPreventer (_dsp). - $$ if not (null info) - then text "\t.long " - <+> pprCLabel_asm (entryLblToInfoLbl lbl) - <+> char '-' - <+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl) - else empty + $$ text "\t.long " + <+> pprCLabel_asm info_lbl + <+> char '-' + <+> pprCLabel_asm (mkDeadStripPreventer info_lbl) #endif -pprBasicBlock :: NatBasicBlock Instr -> Doc -pprBasicBlock (BasicBlock blockid instrs) = +pprBasicBlock :: Platform -> NatBasicBlock Instr -> Doc +pprBasicBlock platform (BasicBlock blockid instrs) = pprLabel (mkAsmTempLabel (getUnique blockid)) $$ - vcat (map pprInstr instrs) + vcat (map (pprInstr platform) instrs) + +pprDatas :: CmmStatics -> Doc +pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats) + pprData :: CmmStatic -> Doc -pprData (CmmAlign bytes) = pprAlign bytes -pprData (CmmDataLabel lbl) = pprLabel lbl pprData (CmmString str) = pprASCII str #if darwin_TARGET_OS @@ -133,25 +138,12 @@ pprASCII str do1 :: Word8 -> Doc do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w) -pprAlign :: Int -> Doc -pprAlign bytes = - ptext (sLit ".align ") <> int pow2 - where - pow2 = log2 bytes - - log2 :: Int -> Int -- cache the common ones - log2 1 = 0 - log2 2 = 1 - log2 4 = 2 - log2 8 = 3 - log2 n = 1 + log2 (n `quot` 2) - -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' -instance Outputable Instr where - ppr instr = Outputable.docToSDoc $ pprInstr instr +instance PlatformOutputable Instr where + pprPlatform platform instr = Outputable.docToSDoc $ pprInstr platform instr pprReg :: Reg -> Doc @@ -345,26 +337,26 @@ pprDataItem lit = panic "PPC.Ppr.pprDataItem: no match" -pprInstr :: Instr -> Doc +pprInstr :: Platform -> Instr -> Doc -pprInstr (COMMENT _) = empty -- nuke 'em +pprInstr _ (COMMENT _) = empty -- nuke 'em {- -pprInstr (COMMENT s) +pprInstr _ (COMMENT s) IF_OS_linux( ((<>) (ptext (sLit "# ")) (ftext s)), ((<>) (ptext (sLit "; ")) (ftext s))) -} -pprInstr (DELTA d) - = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d))) +pprInstr platform (DELTA d) + = pprInstr platform (COMMENT (mkFastString ("\tdelta = " ++ show d))) -pprInstr (NEWBLOCK _) +pprInstr _ (NEWBLOCK _) = panic "PprMach.pprInstr: NEWBLOCK" -pprInstr (LDATA _ _) +pprInstr _ (LDATA _ _) = panic "PprMach.pprInstr: LDATA" {- -pprInstr (SPILL reg slot) +pprInstr _ (SPILL reg slot) = hcat [ ptext (sLit "\tSPILL"), char '\t', @@ -372,7 +364,7 @@ pprInstr (SPILL reg slot) comma, ptext (sLit "SLOT") <> parens (int slot)] -pprInstr (RELOAD slot reg) +pprInstr _ (RELOAD slot reg) = hcat [ ptext (sLit "\tRELOAD"), char '\t', @@ -381,7 +373,7 @@ pprInstr (RELOAD slot reg) pprReg reg] -} -pprInstr (LD sz reg addr) = hcat [ +pprInstr _ (LD sz reg addr) = hcat [ char '\t', ptext (sLit "l"), ptext (case sz of @@ -399,7 +391,7 @@ pprInstr (LD sz reg addr) = hcat [ ptext (sLit ", "), pprAddr addr ] -pprInstr (LA sz reg addr) = hcat [ +pprInstr _ (LA sz reg addr) = hcat [ char '\t', ptext (sLit "l"), ptext (case sz of @@ -417,7 +409,7 @@ pprInstr (LA sz reg addr) = hcat [ ptext (sLit ", "), pprAddr addr ] -pprInstr (ST sz reg addr) = hcat [ +pprInstr _ (ST sz reg addr) = hcat [ char '\t', ptext (sLit "st"), pprSize sz, @@ -428,7 +420,7 @@ pprInstr (ST sz reg addr) = hcat [ ptext (sLit ", "), pprAddr addr ] -pprInstr (STU sz reg addr) = hcat [ +pprInstr _ (STU sz reg addr) = hcat [ char '\t', ptext (sLit "st"), pprSize sz, @@ -439,7 +431,7 @@ pprInstr (STU sz reg addr) = hcat [ ptext (sLit ", "), pprAddr addr ] -pprInstr (LIS reg imm) = hcat [ +pprInstr _ (LIS reg imm) = hcat [ char '\t', ptext (sLit "lis"), char '\t', @@ -447,7 +439,7 @@ pprInstr (LIS reg imm) = hcat [ ptext (sLit ", "), pprImm imm ] -pprInstr (LI reg imm) = hcat [ +pprInstr _ (LI reg imm) = hcat [ char '\t', ptext (sLit "li"), char '\t', @@ -455,11 +447,11 @@ pprInstr (LI reg imm) = hcat [ ptext (sLit ", "), pprImm imm ] -pprInstr (MR reg1 reg2) +pprInstr platform (MR reg1 reg2) | reg1 == reg2 = empty | otherwise = hcat [ char '\t', - case targetClassOfReg reg1 of + case targetClassOfReg platform reg1 of RcInteger -> ptext (sLit "mr") _ -> ptext (sLit "fmr"), char '\t', @@ -467,7 +459,7 @@ pprInstr (MR reg1 reg2) ptext (sLit ", "), pprReg reg2 ] -pprInstr (CMP sz reg ri) = hcat [ +pprInstr _ (CMP sz reg ri) = hcat [ char '\t', op, char '\t', @@ -483,7 +475,7 @@ pprInstr (CMP sz reg ri) = hcat [ RIReg _ -> empty RIImm _ -> char 'i' ] -pprInstr (CMPL sz reg ri) = hcat [ +pprInstr _ (CMPL sz reg ri) = hcat [ char '\t', op, char '\t', @@ -499,7 +491,7 @@ pprInstr (CMPL sz reg ri) = hcat [ RIReg _ -> empty RIImm _ -> char 'i' ] -pprInstr (BCC cond blockid) = hcat [ +pprInstr _ (BCC cond blockid) = hcat [ char '\t', ptext (sLit "b"), pprCond cond, @@ -508,7 +500,7 @@ pprInstr (BCC cond blockid) = hcat [ ] where lbl = mkAsmTempLabel (getUnique blockid) -pprInstr (BCCFAR cond blockid) = vcat [ +pprInstr _ (BCCFAR cond blockid) = vcat [ hcat [ ptext (sLit "\tb"), pprCond (condNegate cond), @@ -521,33 +513,33 @@ pprInstr (BCCFAR cond blockid) = vcat [ ] where lbl = mkAsmTempLabel (getUnique blockid) -pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel +pprInstr _ (JMP lbl) = hcat [ -- an alias for b that takes a CLabel char '\t', ptext (sLit "b"), char '\t', pprCLabel_asm lbl ] -pprInstr (MTCTR reg) = hcat [ +pprInstr _ (MTCTR reg) = hcat [ char '\t', ptext (sLit "mtctr"), char '\t', pprReg reg ] -pprInstr (BCTR _ _) = hcat [ +pprInstr _ (BCTR _ _) = hcat [ char '\t', ptext (sLit "bctr") ] -pprInstr (BL lbl _) = hcat [ +pprInstr _ (BL lbl _) = hcat [ ptext (sLit "\tbl\t"), pprCLabel_asm lbl ] -pprInstr (BCTRL _) = hcat [ +pprInstr _ (BCTRL _) = hcat [ char '\t', ptext (sLit "bctrl") ] -pprInstr (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri -pprInstr (ADDIS reg1 reg2 imm) = hcat [ +pprInstr _ (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri +pprInstr _ (ADDIS reg1 reg2 imm) = hcat [ char '\t', ptext (sLit "addis"), char '\t', @@ -558,15 +550,15 @@ pprInstr (ADDIS reg1 reg2 imm) = hcat [ pprImm imm ] -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 (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3) -pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic (sLit "mullw") reg1 reg2 ri -pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic (sLit "mull") reg1 reg2 ri -pprInstr (DIVW reg1 reg2 reg3) = pprLogic (sLit "divw") reg1 reg2 (RIReg reg3) -pprInstr (DIVWU reg1 reg2 reg3) = pprLogic (sLit "divwu") 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 _ (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3) +pprInstr _ (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic (sLit "mullw") reg1 reg2 ri +pprInstr _ (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic (sLit "mull") reg1 reg2 ri +pprInstr _ (DIVW reg1 reg2 reg3) = pprLogic (sLit "divw") reg1 reg2 (RIReg reg3) +pprInstr _ (DIVWU reg1 reg2 reg3) = pprLogic (sLit "divwu") reg1 reg2 (RIReg reg3) -pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [ +pprInstr _ (MULLW_MayOflo reg1 reg2 reg3) = vcat [ hcat [ ptext (sLit "\tmullwo\t"), pprReg reg1, ptext (sLit ", "), pprReg reg2, ptext (sLit ", "), pprReg reg3 ], @@ -578,7 +570,7 @@ pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [ -- for some reason, "andi" doesn't exist. -- we'll use "andi." instead. -pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [ +pprInstr _ (AND reg1 reg2 (RIImm imm)) = hcat [ char '\t', ptext (sLit "andi."), char '\t', @@ -588,12 +580,12 @@ pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [ ptext (sLit ", "), pprImm imm ] -pprInstr (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri +pprInstr _ (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri -pprInstr (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri -pprInstr (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri +pprInstr _ (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri +pprInstr _ (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri -pprInstr (XORIS reg1 reg2 imm) = hcat [ +pprInstr _ (XORIS reg1 reg2 imm) = hcat [ char '\t', ptext (sLit "xoris"), char '\t', @@ -604,7 +596,7 @@ pprInstr (XORIS reg1 reg2 imm) = hcat [ pprImm imm ] -pprInstr (EXTS sz reg1 reg2) = hcat [ +pprInstr _ (EXTS sz reg1 reg2) = hcat [ char '\t', ptext (sLit "exts"), pprSize sz, @@ -614,13 +606,13 @@ pprInstr (EXTS sz reg1 reg2) = hcat [ pprReg reg2 ] -pprInstr (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2 -pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2 +pprInstr _ (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2 +pprInstr _ (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2 -pprInstr (SLW reg1 reg2 ri) = pprLogic (sLit "slw") reg1 reg2 (limitShiftRI ri) -pprInstr (SRW reg1 reg2 ri) = pprLogic (sLit "srw") reg1 reg2 (limitShiftRI ri) -pprInstr (SRAW reg1 reg2 ri) = pprLogic (sLit "sraw") reg1 reg2 (limitShiftRI ri) -pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [ +pprInstr _ (SLW reg1 reg2 ri) = pprLogic (sLit "slw") reg1 reg2 (limitShiftRI ri) +pprInstr _ (SRW reg1 reg2 ri) = pprLogic (sLit "srw") reg1 reg2 (limitShiftRI ri) +pprInstr _ (SRAW reg1 reg2 ri) = pprLogic (sLit "sraw") reg1 reg2 (limitShiftRI ri) +pprInstr _ (RLWINM reg1 reg2 sh mb me) = hcat [ ptext (sLit "\trlwinm\t"), pprReg reg1, ptext (sLit ", "), @@ -633,13 +625,13 @@ pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [ int me ] -pprInstr (FADD sz reg1 reg2 reg3) = pprBinaryF (sLit "fadd") sz reg1 reg2 reg3 -pprInstr (FSUB sz reg1 reg2 reg3) = pprBinaryF (sLit "fsub") sz reg1 reg2 reg3 -pprInstr (FMUL sz reg1 reg2 reg3) = pprBinaryF (sLit "fmul") sz reg1 reg2 reg3 -pprInstr (FDIV sz reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") sz reg1 reg2 reg3 -pprInstr (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2 +pprInstr _ (FADD sz reg1 reg2 reg3) = pprBinaryF (sLit "fadd") sz reg1 reg2 reg3 +pprInstr _ (FSUB sz reg1 reg2 reg3) = pprBinaryF (sLit "fsub") sz reg1 reg2 reg3 +pprInstr _ (FMUL sz reg1 reg2 reg3) = pprBinaryF (sLit "fmul") sz reg1 reg2 reg3 +pprInstr _ (FDIV sz reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") sz reg1 reg2 reg3 +pprInstr _ (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2 -pprInstr (FCMP reg1 reg2) = hcat [ +pprInstr _ (FCMP reg1 reg2) = hcat [ char '\t', ptext (sLit "fcmpu\tcr0, "), -- Note: we're using fcmpu, not fcmpo @@ -650,10 +642,10 @@ pprInstr (FCMP reg1 reg2) = hcat [ pprReg reg2 ] -pprInstr (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2 -pprInstr (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2 +pprInstr _ (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2 +pprInstr _ (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2 -pprInstr (CRNOR dst src1 src2) = hcat [ +pprInstr _ (CRNOR dst src1 src2) = hcat [ ptext (sLit "\tcrnor\t"), int dst, ptext (sLit ", "), @@ -662,28 +654,28 @@ pprInstr (CRNOR dst src1 src2) = hcat [ int src2 ] -pprInstr (MFCR reg) = hcat [ +pprInstr _ (MFCR reg) = hcat [ char '\t', ptext (sLit "mfcr"), char '\t', pprReg reg ] -pprInstr (MFLR reg) = hcat [ +pprInstr _ (MFLR reg) = hcat [ char '\t', ptext (sLit "mflr"), char '\t', pprReg reg ] -pprInstr (FETCHPC reg) = vcat [ +pprInstr _ (FETCHPC reg) = vcat [ ptext (sLit "\tbcl\t20,31,1f"), hcat [ ptext (sLit "1:\tmflr\t"), pprReg reg ] ] -pprInstr LWSYNC = ptext (sLit "\tlwsync") +pprInstr _ LWSYNC = ptext (sLit "\tlwsync") --- pprInstr _ = panic "pprInstr (ppc)" +-- pprInstr _ _ = panic "pprInstr (ppc)" pprLogic :: LitString -> Reg -> Reg -> RI -> Doc diff --git a/compiler/nativeGen/PPC/RegInfo.hs b/compiler/nativeGen/PPC/RegInfo.hs index bfc712af86..2a30087ab7 100644 --- a/compiler/nativeGen/PPC/RegInfo.hs +++ b/compiler/nativeGen/PPC/RegInfo.hs @@ -11,7 +11,7 @@ module PPC.RegInfo ( canShortcut, shortcutJump, - shortcutStatic + shortcutStatics ) where @@ -43,18 +43,24 @@ shortcutJump _ other = other -- Here because it knows about JumpDest -shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic +shortcutStatics :: (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics +shortcutStatics fn (Statics lbl statics) + = Statics lbl $ map (shortcutStatic fn) statics + -- we need to get the jump tables, so apply the mapping to the entries + -- of a CmmData too. -shortcutStatic fn (CmmStaticLit (CmmLabel lab)) - | Just uq <- maybeAsmTemp lab - = CmmStaticLit (CmmLabel (shortBlockId fn (mkBlockId uq))) +shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel +shortcutLabel fn lab + | Just uq <- maybeAsmTemp lab = shortBlockId fn (mkBlockId uq) + | otherwise = lab +shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic +shortcutStatic fn (CmmStaticLit (CmmLabel lab)) + = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) - | Just uq <- maybeAsmTemp lbl1 - = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn (mkBlockId uq)) lbl2 off) + = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off) -- slightly dodgy, we're ignoring the second label, but this -- works with the way we use CmmLabelDiffOff for jump tables now. - shortcutStatic _ other_static = other_static diff --git a/compiler/nativeGen/PprInstruction.hs b/compiler/nativeGen/PprInstruction.hs new file mode 100644 index 0000000000..6c19160e35 --- /dev/null +++ b/compiler/nativeGen/PprInstruction.hs @@ -0,0 +1,2 @@ + + pprInstruction :: Platform -> instr -> SDoc diff --git a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs index 1eaf00f3a2..a499e1d562 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs @@ -27,8 +27,8 @@ import Data.List -- the same and the move instruction safely erased. regCoalesce :: Instruction instr - => [LiveCmmTop instr] - -> UniqSM [LiveCmmTop instr] + => [LiveCmmTop statics instr] + -> UniqSM [LiveCmmTop statics instr] regCoalesce code = do @@ -61,7 +61,7 @@ sinkReg fm r -- then we can rename the two regs to the same thing and eliminate the move. slurpJoinMovs :: Instruction instr - => LiveCmmTop instr + => LiveCmmTop statics instr -> Bag (Reg, Reg) slurpJoinMovs live diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs index cdbe98755a..5321a34695 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Main.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs @@ -28,6 +28,7 @@ import UniqSet import UniqFM import Bag import Outputable +import Platform import DynFlags import Data.List @@ -44,12 +45,12 @@ maxSpinCount = 10 -- | The top level of the graph coloring register allocator. regAlloc - :: (Outputable instr, Instruction instr) + :: (Outputable statics, PlatformOutputable instr, Instruction instr) => DynFlags -> UniqFM (UniqSet RealReg) -- ^ the registers we can use for allocation -> UniqSet Int -- ^ the set of available spill slots. - -> [LiveCmmTop instr] -- ^ code annotated with liveness information. - -> UniqSM ( [NatCmmTop instr], [RegAllocStats instr] ) + -> [LiveCmmTop statics instr] -- ^ code annotated with liveness information. + -> UniqSM ( [NatCmmTop statics instr], [RegAllocStats statics instr] ) -- ^ code with registers allocated and stats for each stage of -- allocation @@ -58,9 +59,10 @@ regAlloc dflags regsFree slotsFree code -- 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 triv = trivColorable - targetVirtualRegSqueeze - targetRealRegSqueeze + let platform = targetPlatform dflags + triv = trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform) (code_final, debug_codeGraphs, _) <- regAlloc_spin dflags 0 @@ -79,6 +81,7 @@ regAlloc_spin debug_codeGraphs code = do + let platform = targetPlatform dflags -- 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. @@ -111,7 +114,7 @@ regAlloc_spin -- build a map of the cost of spilling each instruction -- this will only actually be computed if we have to spill something. let spillCosts = foldl' plusSpillCostInfo zeroSpillCostInfo - $ map slurpSpillCostInfo code + $ map (slurpSpillCostInfo platform) code -- the function to choose regs to leave uncolored let spill = chooseSpill spillCosts @@ -159,14 +162,14 @@ regAlloc_spin else graph_colored -- patch the registers using the info in the graph - let code_patched = map (patchRegsFromGraph graph_colored_lint) code_coalesced + let code_patched = map (patchRegsFromGraph platform graph_colored_lint) code_coalesced -- clean out unneeded SPILL/RELOADs - let code_spillclean = map cleanSpills code_patched + let code_spillclean = map (cleanSpills platform) code_patched -- strip off liveness information, -- and rewrite SPILL/RELOAD pseudos into real instructions along the way - let code_final = map stripLive code_spillclean + let code_final = map (stripLive platform) code_spillclean -- record what happened in this stage for debugging let stat = @@ -211,7 +214,7 @@ regAlloc_spin -- NOTE: we have to reverse the SCCs here to get them back into the reverse-dependency -- order required by computeLiveness. If they're not in the correct order -- that function will panic. - code_relive <- mapM (regLiveness . reverseBlocksInTops) code_spilled + code_relive <- mapM (regLiveness platform . reverseBlocksInTops) code_spilled -- record what happened in this stage for debugging let stat = @@ -239,7 +242,7 @@ regAlloc_spin -- | Build a graph from the liveness and coalesce information in this code. buildGraph :: Instruction instr - => [LiveCmmTop instr] + => [LiveCmmTop statics instr] -> UniqSM (Color.Graph VirtualReg RegClass RealReg) buildGraph code @@ -320,11 +323,11 @@ graphAddCoalesce _ _ -- | Patch registers in code using the reg -> reg mapping in this graph. patchRegsFromGraph - :: (Outputable instr, Instruction instr) - => Color.Graph VirtualReg RegClass RealReg - -> LiveCmmTop instr -> LiveCmmTop instr + :: (Outputable statics, PlatformOutputable instr, Instruction instr) + => Platform -> Color.Graph VirtualReg RegClass RealReg + -> LiveCmmTop statics instr -> LiveCmmTop statics instr -patchRegsFromGraph graph code +patchRegsFromGraph platform graph code = let -- a function to lookup the hardreg for a virtual reg from the graph. patchF reg @@ -343,12 +346,12 @@ patchRegsFromGraph graph code | otherwise = pprPanic "patchRegsFromGraph: register mapping failed." ( text "There is no node in the graph for register " <> ppr reg - $$ ppr code + $$ pprPlatform platform code $$ Color.dotGraph (\_ -> text "white") - (trivColorable - targetVirtualRegSqueeze - targetRealRegSqueeze) + (trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform)) graph) in patchEraseLive patchF code diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs index 4eabb3b0b4..c4fb783688 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Spill.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs @@ -41,13 +41,13 @@ import qualified Data.Set as Set -- regSpill :: Instruction instr - => [LiveCmmTop instr] -- ^ the code + => [LiveCmmTop statics instr] -- ^ the code -> UniqSet Int -- ^ available stack slots -> UniqSet VirtualReg -- ^ the regs to spill -> UniqSM - ([LiveCmmTop instr] -- code with SPILL and RELOAD meta instructions added. - , UniqSet Int -- left over slots - , SpillStats ) -- stats about what happened during spilling + ([LiveCmmTop statics instr] -- code with SPILL and RELOAD meta instructions added. + , UniqSet Int -- left over slots + , SpillStats ) -- stats about what happened during spilling regSpill code slotsFree regs @@ -81,8 +81,8 @@ regSpill code slotsFree regs regSpill_top :: Instruction instr => RegMap Int -- ^ map of vregs to slots they're being spilled to. - -> LiveCmmTop instr -- ^ the top level thing. - -> SpillM (LiveCmmTop instr) + -> LiveCmmTop statics instr -- ^ the top level thing. + -> SpillM (LiveCmmTop statics instr) regSpill_top regSlotMap cmm = case cmm of diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs index 38c33b708a..da13eab045 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs @@ -39,6 +39,7 @@ import UniqFM import Unique import State import Outputable +import Platform import Data.List import Data.Maybe @@ -52,22 +53,23 @@ type Slot = Int -- | Clean out unneeded spill\/reloads from this top level thing. -cleanSpills - :: Instruction instr - => LiveCmmTop instr -> LiveCmmTop instr +cleanSpills + :: Instruction instr + => Platform -> LiveCmmTop statics instr -> LiveCmmTop statics instr -cleanSpills cmm - = evalState (cleanSpin 0 cmm) initCleanS +cleanSpills platform cmm + = evalState (cleanSpin platform 0 cmm) initCleanS -- | do one pass of cleaning -cleanSpin - :: Instruction instr - => Int - -> LiveCmmTop instr - -> CleanM (LiveCmmTop instr) +cleanSpin + :: Instruction instr + => Platform + -> Int + -> LiveCmmTop statics instr + -> CleanM (LiveCmmTop statics instr) {- -cleanSpin spinCount code +cleanSpin _ spinCount code = do jumpValid <- gets sJumpValid pprTrace "cleanSpin" ( int spinCount @@ -78,7 +80,7 @@ cleanSpin spinCount code $ cleanSpin' spinCount code -} -cleanSpin spinCount code +cleanSpin platform spinCount code = do -- init count of cleaned spills\/reloads modify $ \s -> s @@ -86,7 +88,7 @@ cleanSpin spinCount code , sCleanedReloadsAcc = 0 , sReloadedBy = emptyUFM } - code_forward <- mapBlockTopM cleanBlockForward code + code_forward <- mapBlockTopM (cleanBlockForward platform) code code_backward <- cleanTopBackward code_forward -- During the cleaning of each block we collected information about what regs @@ -107,16 +109,17 @@ cleanSpin spinCount code then return code -- otherwise go around again - else cleanSpin (spinCount + 1) code_backward + else cleanSpin platform (spinCount + 1) code_backward -- | Clean one basic block -cleanBlockForward - :: Instruction instr - => LiveBasicBlock instr - -> CleanM (LiveBasicBlock instr) +cleanBlockForward + :: Instruction instr + => Platform + -> LiveBasicBlock instr + -> CleanM (LiveBasicBlock instr) -cleanBlockForward (BasicBlock blockId instrs) +cleanBlockForward platform (BasicBlock blockId instrs) = do -- see if we have a valid association for the entry to this block jumpValid <- gets sJumpValid @@ -124,7 +127,7 @@ cleanBlockForward (BasicBlock blockId instrs) Just assoc -> assoc Nothing -> emptyAssoc - instrs_reload <- cleanForward blockId assoc [] instrs + instrs_reload <- cleanForward platform blockId assoc [] instrs return $ BasicBlock blockId instrs_reload @@ -135,37 +138,38 @@ cleanBlockForward (BasicBlock blockId instrs) -- then we don't need to do the reload. -- cleanForward - :: Instruction instr - => BlockId -- ^ the block that we're currently in - -> Assoc Store -- ^ two store locations are associated if they have the same value - -> [LiveInstr instr] -- ^ acc - -> [LiveInstr instr] -- ^ instrs to clean (in backwards order) - -> CleanM [LiveInstr instr] -- ^ cleaned instrs (in forward order) - -cleanForward _ _ acc [] + :: Instruction instr + => Platform + -> BlockId -- ^ the block that we're currently in + -> Assoc Store -- ^ two store locations are associated if they have the same value + -> [LiveInstr instr] -- ^ acc + -> [LiveInstr instr] -- ^ instrs to clean (in backwards order) + -> CleanM [LiveInstr instr] -- ^ cleaned instrs (in forward order) + +cleanForward _ _ _ acc [] = return acc -- write out live range joins via spill slots to just a spill and a reg-reg move -- hopefully the spill will be also be cleaned in the next pass -- -cleanForward blockId assoc acc (li1 : li2 : instrs) +cleanForward platform blockId assoc acc (li1 : li2 : instrs) | LiveInstr (SPILL reg1 slot1) _ <- li1 , LiveInstr (RELOAD slot2 reg2) _ <- li2 , slot1 == slot2 = do modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 } - cleanForward blockId assoc acc - (li1 : LiveInstr (mkRegRegMoveInstr reg1 reg2) Nothing : instrs) + cleanForward platform blockId assoc acc + (li1 : LiveInstr (mkRegRegMoveInstr platform reg1 reg2) Nothing : instrs) -cleanForward blockId assoc acc (li@(LiveInstr i1 _) : instrs) +cleanForward platform blockId assoc acc (li@(LiveInstr i1 _) : instrs) | Just (r1, r2) <- takeRegRegMoveInstr i1 = if r1 == r2 -- erase any left over nop reg reg moves while we're here -- this will also catch any nop moves that the "write out live range joins" case above -- happens to add - then cleanForward blockId assoc acc instrs + then cleanForward platform blockId assoc acc instrs -- if r1 has the same value as some slots and we copy r1 to r2, -- then r2 is now associated with those slots instead @@ -173,50 +177,51 @@ cleanForward blockId assoc acc (li@(LiveInstr i1 _) : instrs) $ delAssoc (SReg r2) $ assoc - cleanForward blockId assoc' (li : acc) instrs + cleanForward platform blockId assoc' (li : acc) instrs -cleanForward blockId assoc acc (li : instrs) +cleanForward platform blockId assoc acc (li : instrs) -- update association due to the spill | LiveInstr (SPILL reg slot) _ <- li = let assoc' = addAssoc (SReg reg) (SSlot slot) $ delAssoc (SSlot slot) $ assoc - in cleanForward blockId assoc' (li : acc) instrs + in cleanForward platform blockId assoc' (li : acc) instrs -- clean a reload instr | LiveInstr (RELOAD{}) _ <- li - = do (assoc', mli) <- cleanReload blockId assoc li + = do (assoc', mli) <- cleanReload platform blockId assoc li case mli of - Nothing -> cleanForward blockId assoc' acc instrs - Just li' -> cleanForward blockId assoc' (li' : acc) instrs + Nothing -> cleanForward platform blockId assoc' acc instrs + Just li' -> cleanForward platform blockId assoc' (li' : acc) instrs -- remember the association over a jump | LiveInstr instr _ <- li , targets <- jumpDestsOfInstr instr , not $ null targets = do mapM_ (accJumpValid assoc) targets - cleanForward blockId assoc (li : acc) instrs + cleanForward platform blockId assoc (li : acc) instrs -- writing to a reg changes its value. | LiveInstr instr _ <- li , RU _ written <- regUsageOfInstr instr = let assoc' = foldr delAssoc assoc (map SReg $ nub written) - in cleanForward blockId assoc' (li : acc) instrs + in cleanForward platform blockId assoc' (li : acc) instrs -- | Try and rewrite a reload instruction to something more pleasing -- -cleanReload - :: Instruction instr - => BlockId - -> Assoc Store - -> LiveInstr instr - -> CleanM (Assoc Store, Maybe (LiveInstr instr)) +cleanReload + :: Instruction instr + => Platform + -> BlockId + -> Assoc Store + -> LiveInstr instr + -> CleanM (Assoc Store, Maybe (LiveInstr instr)) -cleanReload blockId assoc li@(LiveInstr (RELOAD slot reg) _) +cleanReload platform blockId assoc li@(LiveInstr (RELOAD slot reg) _) -- if the reg we're reloading already has the same value as the slot -- then we can erase the instruction outright @@ -233,7 +238,7 @@ cleanReload blockId assoc li@(LiveInstr (RELOAD slot reg) _) $ delAssoc (SReg reg) $ assoc - return (assoc', Just $ LiveInstr (mkRegRegMoveInstr reg2 reg) Nothing) + return (assoc', Just $ LiveInstr (mkRegRegMoveInstr platform reg2 reg) Nothing) -- gotta keep this instr | otherwise @@ -247,7 +252,7 @@ cleanReload blockId assoc li@(LiveInstr (RELOAD slot reg) _) return (assoc', Just li) -cleanReload _ _ _ +cleanReload _ _ _ _ = panic "RegSpillClean.cleanReload: unhandled instr" @@ -282,8 +287,8 @@ cleanReload _ _ _ -- cleanTopBackward :: Instruction instr - => LiveCmmTop instr - -> CleanM (LiveCmmTop instr) + => LiveCmmTop statics instr + -> CleanM (LiveCmmTop statics instr) cleanTopBackward cmm = case cmm of diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs index 330a410312..3ea150a3df 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs @@ -29,6 +29,7 @@ import UniqFM import UniqSet import Digraph (flattenSCCs) import Outputable +import Platform import State import Data.List (nub, minimumBy) @@ -62,12 +63,12 @@ plusSpillCostRecord (r1, a1, b1, c1) (r2, a2, b2, c2) -- for each vreg, the number of times it was written to, read from, -- and the number of instructions it was live on entry to (lifetime) -- -slurpSpillCostInfo - :: (Outputable instr, Instruction instr) - => LiveCmmTop instr - -> SpillCostInfo +slurpSpillCostInfo :: (PlatformOutputable instr, Instruction instr) + => Platform + -> LiveCmmTop statics instr + -> SpillCostInfo -slurpSpillCostInfo cmm +slurpSpillCostInfo platform cmm = execState (countCmm cmm) zeroSpillCostInfo where countCmm CmmData{} = return () @@ -96,7 +97,7 @@ slurpSpillCostInfo cmm | otherwise = pprPanic "RegSpillCost.slurpSpillCostInfo" - (text "no liveness information on instruction " <> ppr instr) + (text "no liveness information on instruction " <> pprPlatform platform instr) countLIs rsLiveEntry (LiveInstr instr (Just live) : lis) = do diff --git a/compiler/nativeGen/RegAlloc/Graph/Stats.hs b/compiler/nativeGen/RegAlloc/Graph/Stats.hs index 5ff7bff91a..15ec6e7f87 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Stats.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Stats.hs @@ -36,56 +36,56 @@ import State import Data.List -data RegAllocStats instr +data RegAllocStats statics instr -- initial graph = RegAllocStatsStart - { raLiveCmm :: [LiveCmmTop instr] -- ^ initial code, with liveness + { raLiveCmm :: [LiveCmmTop statics instr] -- ^ initial code, with liveness , raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the initial, uncolored graph , raSpillCosts :: SpillCostInfo } -- ^ information to help choose which regs to spill -- a spill stage | RegAllocStatsSpill - { raCode :: [LiveCmmTop instr] -- ^ the code we tried to allocate registers for + { raCode :: [LiveCmmTop statics instr] -- ^ the code we tried to allocate registers for , raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the partially colored graph , raCoalesced :: UniqFM VirtualReg -- ^ the regs that were coaleced , raSpillStats :: SpillStats -- ^ spiller stats , raSpillCosts :: SpillCostInfo -- ^ number of instrs each reg lives for - , raSpilled :: [LiveCmmTop instr] } -- ^ code with spill instructions added + , raSpilled :: [LiveCmmTop statics instr] } -- ^ code with spill instructions added -- a successful coloring | RegAllocStatsColored - { raCode :: [LiveCmmTop instr] -- ^ the code we tried to allocate registers for + { raCode :: [LiveCmmTop statics instr] -- ^ the code we tried to allocate registers for , raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the uncolored graph , raGraphColored :: Color.Graph VirtualReg RegClass RealReg -- ^ the coalesced and colored graph , raCoalesced :: UniqFM VirtualReg -- ^ the regs that were coaleced - , raCodeCoalesced :: [LiveCmmTop instr] -- ^ code with coalescings applied - , raPatched :: [LiveCmmTop instr] -- ^ code with vregs replaced by hregs - , raSpillClean :: [LiveCmmTop instr] -- ^ code with unneeded spill\/reloads cleaned out - , raFinal :: [NatCmmTop instr] -- ^ final code + , raCodeCoalesced :: [LiveCmmTop statics instr] -- ^ code with coalescings applied + , raPatched :: [LiveCmmTop statics instr] -- ^ code with vregs replaced by hregs + , raSpillClean :: [LiveCmmTop statics instr] -- ^ code with unneeded spill\/reloads cleaned out + , raFinal :: [NatCmmTop statics instr] -- ^ final code , raSRMs :: (Int, Int, Int) } -- ^ spill\/reload\/reg-reg moves present in this code -instance Outputable instr => Outputable (RegAllocStats instr) where +instance (Outputable statics, PlatformOutputable instr) => PlatformOutputable (RegAllocStats statics instr) where - ppr (s@RegAllocStatsStart{}) + pprPlatform platform (s@RegAllocStatsStart{}) = text "# Start" $$ text "# Native code with liveness information." - $$ ppr (raLiveCmm s) + $$ pprPlatform platform (raLiveCmm s) $$ text "" $$ text "# Initial register conflict graph." $$ Color.dotGraph - targetRegDotColor - (trivColorable - targetVirtualRegSqueeze - targetRealRegSqueeze) + (targetRegDotColor platform) + (trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform)) (raGraph s) - ppr (s@RegAllocStatsSpill{}) + pprPlatform platform (s@RegAllocStatsSpill{}) = text "# Spill" $$ text "# Code with liveness information." - $$ (ppr (raCode s)) + $$ pprPlatform platform (raCode s) $$ text "" $$ (if (not $ isNullUFM $ raCoalesced s) @@ -99,22 +99,22 @@ instance Outputable instr => Outputable (RegAllocStats instr) where $$ text "" $$ text "# Code with spills inserted." - $$ (ppr (raSpilled s)) + $$ pprPlatform platform (raSpilled s) - ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) }) + pprPlatform platform (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) }) = text "# Colored" $$ text "# Code with liveness information." - $$ (ppr (raCode s)) + $$ pprPlatform platform (raCode s) $$ text "" $$ text "# Register conflict graph (colored)." $$ Color.dotGraph - targetRegDotColor - (trivColorable - targetVirtualRegSqueeze - targetRealRegSqueeze) + (targetRegDotColor platform) + (trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform)) (raGraphColored s) $$ text "" @@ -125,19 +125,19 @@ instance Outputable instr => Outputable (RegAllocStats instr) where else empty) $$ text "# Native code after coalescings applied." - $$ ppr (raCodeCoalesced s) + $$ pprPlatform platform (raCodeCoalesced s) $$ text "" $$ text "# Native code after register allocation." - $$ ppr (raPatched s) + $$ pprPlatform platform (raPatched s) $$ text "" $$ text "# Clean out unneeded spill/reloads." - $$ ppr (raSpillClean s) + $$ pprPlatform platform (raSpillClean s) $$ text "" $$ text "# Final code, after rewriting spill/rewrite pseudo instrs." - $$ ppr (raFinal s) + $$ pprPlatform platform (raFinal s) $$ text "" $$ text "# Score:" $$ (text "# spills inserted: " <> int spills) @@ -147,7 +147,7 @@ instance Outputable instr => Outputable (RegAllocStats instr) where -- | Do all the different analysis on this list of RegAllocStats pprStats - :: [RegAllocStats instr] + :: [RegAllocStats statics instr] -> Color.Graph VirtualReg RegClass RealReg -> SDoc @@ -162,7 +162,7 @@ pprStats stats graph -- | Dump a table of how many spill loads \/ stores were inserted for each vreg. pprStatsSpills - :: [RegAllocStats instr] -> SDoc + :: [RegAllocStats statics instr] -> SDoc pprStatsSpills stats = let @@ -180,7 +180,7 @@ pprStatsSpills stats -- | Dump a table of how long vregs tend to live for in the initial code. pprStatsLifetimes - :: [RegAllocStats instr] -> SDoc + :: [RegAllocStats statics instr] -> SDoc pprStatsLifetimes stats = let info = foldl' plusSpillCostInfo zeroSpillCostInfo @@ -208,7 +208,7 @@ binLifetimeCount fm -- | Dump a table of how many conflicts vregs tend to have in the initial code. pprStatsConflict - :: [RegAllocStats instr] -> SDoc + :: [RegAllocStats statics instr] -> SDoc pprStatsConflict stats = let confMap = foldl' (plusUFM_C (\(c1, n1) (_, n2) -> (c1, n1 + n2))) @@ -225,7 +225,7 @@ pprStatsConflict stats -- | For every vreg, dump it's how many conflicts it has and its lifetime -- good for making a scatter plot. pprStatsLifeConflict - :: [RegAllocStats instr] + :: [RegAllocStats statics instr] -> Color.Graph VirtualReg RegClass RealReg -- ^ global register conflict graph -> SDoc @@ -256,7 +256,7 @@ pprStatsLifeConflict stats graph -- Lets us see how well the register allocator has done. countSRMs :: Instruction instr - => LiveCmmTop instr -> (Int, Int, Int) + => LiveCmmTop statics instr -> (Int, Int, Int) countSRMs cmm = execState (mapBlockTopM countSRM_block cmm) (0, 0, 0) diff --git a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs index 802f847f11..e62b4a9abb 100644 --- a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs +++ b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs @@ -98,18 +98,15 @@ the most efficient variant tried. Benchmark compiling 10-times SHA1.lhs follows. 100.00% 166.23% 94.18% 100.95% -} --- TODO: We shouldn't be using defaultTargetPlatform here. --- We should be passing DynFlags in instead, and looking at --- its targetPlatform. - trivColorable - :: (RegClass -> VirtualReg -> FastInt) + :: Platform + -> (RegClass -> VirtualReg -> FastInt) -> (RegClass -> RealReg -> FastInt) -> Triv VirtualReg RegClass RealReg -trivColorable virtualRegSqueeze realRegSqueeze RcInteger conflicts exclusions +trivColorable platform virtualRegSqueeze realRegSqueeze RcInteger conflicts exclusions | let !cALLOCATABLE_REGS_INTEGER - = iUnbox (case platformArch defaultTargetPlatform of + = iUnbox (case platformArch platform of ArchX86 -> 3 ArchX86_64 -> 5 ArchPPC -> 16 @@ -127,9 +124,9 @@ trivColorable virtualRegSqueeze realRegSqueeze RcInteger conflicts exclusions = count3 <# cALLOCATABLE_REGS_INTEGER -trivColorable virtualRegSqueeze realRegSqueeze RcFloat conflicts exclusions +trivColorable platform virtualRegSqueeze realRegSqueeze RcFloat conflicts exclusions | let !cALLOCATABLE_REGS_FLOAT - = iUnbox (case platformArch defaultTargetPlatform of + = iUnbox (case platformArch platform of ArchX86 -> 0 ArchX86_64 -> 0 ArchPPC -> 0 @@ -147,9 +144,9 @@ trivColorable virtualRegSqueeze realRegSqueeze RcFloat conflicts exclusions = count3 <# cALLOCATABLE_REGS_FLOAT -trivColorable virtualRegSqueeze realRegSqueeze RcDouble conflicts exclusions +trivColorable platform virtualRegSqueeze realRegSqueeze RcDouble conflicts exclusions | let !cALLOCATABLE_REGS_DOUBLE - = iUnbox (case platformArch defaultTargetPlatform of + = iUnbox (case platformArch platform of ArchX86 -> 6 ArchX86_64 -> 0 ArchPPC -> 26 @@ -167,9 +164,9 @@ trivColorable virtualRegSqueeze realRegSqueeze RcDouble conflicts exclusions = count3 <# cALLOCATABLE_REGS_DOUBLE -trivColorable virtualRegSqueeze realRegSqueeze RcDoubleSSE conflicts exclusions +trivColorable platform virtualRegSqueeze realRegSqueeze RcDoubleSSE conflicts exclusions | let !cALLOCATABLE_REGS_SSE - = iUnbox (case platformArch defaultTargetPlatform of + = iUnbox (case platformArch platform of ArchX86 -> 8 ArchX86_64 -> 10 ArchPPC -> 0 diff --git a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs index 07cfc0f825..5a413d341e 100644 --- a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs +++ b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs @@ -58,12 +58,9 @@ instance FR SPARC.FreeRegs where frInitFreeRegs = SPARC.initFreeRegs frReleaseReg = SPARC.releaseReg --- TODO: We shouldn't be using defaultTargetPlatform here. --- We should be passing DynFlags in instead, and looking at --- its targetPlatform. - -maxSpillSlots :: Int -maxSpillSlots = case platformArch defaultTargetPlatform of +maxSpillSlots :: Platform -> Int +maxSpillSlots platform + = case platformArch platform of ArchX86 -> X86.Instr.maxSpillSlots ArchX86_64 -> X86.Instr.maxSpillSlots ArchPPC -> PPC.Instr.maxSpillSlots diff --git a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs index e6a078a05e..ba07e61871 100644 --- a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs +++ b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs @@ -24,6 +24,7 @@ import BlockId import OldCmm hiding (RegSet) import Digraph import Outputable +import Platform import Unique import UniqFM import UniqSet @@ -34,7 +35,8 @@ import UniqSet -- joinToTargets :: (FR freeRegs, Instruction instr) - => BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs + => Platform + -> BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs -- that are known to be live on the entry to each block. -> BlockId -- ^ id of the current block @@ -44,19 +46,20 @@ joinToTargets , instr) -- the original branch instruction, but maybe patched to jump -- to a fixup block first. -joinToTargets block_live id instr +joinToTargets platform block_live id instr -- we only need to worry about jump instructions. | not $ isJumpishInstr instr = return ([], instr) | otherwise - = joinToTargets' block_live [] id instr (jumpDestsOfInstr instr) + = joinToTargets' platform block_live [] id instr (jumpDestsOfInstr instr) ----- joinToTargets' :: (FR freeRegs, Instruction instr) - => BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs + => Platform + -> BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs -- that are known to be live on the entry to each block. -> [NatBasicBlock instr] -- ^ acc blocks of fixup code. @@ -70,11 +73,11 @@ joinToTargets' , instr) -- no more targets to consider. all done. -joinToTargets' _ new_blocks _ instr [] +joinToTargets' _ _ new_blocks _ instr [] = return (new_blocks, instr) -- handle a branch target. -joinToTargets' block_live new_blocks block_id instr (dest:dests) +joinToTargets' platform block_live new_blocks block_id instr (dest:dests) = do -- get the map of where the vregs are stored on entry to each basic block. block_assig <- getBlockAssigR @@ -97,18 +100,19 @@ joinToTargets' block_live new_blocks block_id instr (dest:dests) case mapLookup dest block_assig of Nothing -> joinToTargets_first - block_live new_blocks block_id instr dest dests + platform block_live new_blocks block_id instr dest dests block_assig adjusted_assig to_free Just (_, dest_assig) -> joinToTargets_again - block_live new_blocks block_id instr dest dests + platform block_live new_blocks block_id instr dest dests adjusted_assig dest_assig -- this is the first time we jumped to this block. joinToTargets_first :: (FR freeRegs, Instruction instr) - => BlockMap RegSet + => Platform + -> BlockMap RegSet -> [NatBasicBlock instr] -> BlockId -> instr @@ -118,7 +122,7 @@ joinToTargets_first :: (FR freeRegs, Instruction instr) -> RegMap Loc -> [RealReg] -> RegM freeRegs ([NatBasicBlock instr], instr) -joinToTargets_first block_live new_blocks block_id instr dest dests +joinToTargets_first platform block_live new_blocks block_id instr dest dests block_assig src_assig to_free @@ -129,12 +133,13 @@ joinToTargets_first block_live new_blocks block_id instr dest dests -- remember the current assignment on entry to this block. setBlockAssigR (mapInsert dest (freeregs', src_assig) block_assig) - joinToTargets' block_live new_blocks block_id instr dests + joinToTargets' platform block_live new_blocks block_id instr dests -- we've jumped to this block before joinToTargets_again :: (Instruction instr, FR freeRegs) - => BlockMap RegSet + => Platform + -> BlockMap RegSet -> [NatBasicBlock instr] -> BlockId -> instr @@ -143,13 +148,13 @@ joinToTargets_again :: (Instruction instr, FR freeRegs) -> UniqFM Loc -> UniqFM Loc -> RegM freeRegs ([NatBasicBlock instr], instr) -joinToTargets_again - block_live new_blocks block_id instr dest dests - src_assig dest_assig +joinToTargets_again + platform block_live new_blocks block_id instr dest dests + src_assig dest_assig -- the assignments already match, no problem. | ufmToList dest_assig == ufmToList src_assig - = joinToTargets' block_live new_blocks block_id instr dests + = joinToTargets' platform block_live new_blocks block_id instr dests -- assignments don't match, need fixup code | otherwise @@ -184,7 +189,7 @@ joinToTargets_again (return ()) -} delta <- getDeltaR - fixUpInstrs_ <- mapM (handleComponent delta instr) sccs + fixUpInstrs_ <- mapM (handleComponent platform delta instr) sccs let fixUpInstrs = concat fixUpInstrs_ -- make a new basic block containing the fixup code. @@ -202,7 +207,7 @@ joinToTargets_again -} -- if we didn't need any fixups, then don't include the block case fixUpInstrs of - [] -> joinToTargets' block_live new_blocks block_id instr dests + [] -> joinToTargets' platform block_live new_blocks block_id instr dests -- patch the original branch instruction so it goes to our -- fixup block instead. @@ -211,7 +216,7 @@ joinToTargets_again then mkBlockId fixup_block_id else bid) -- no change! - in joinToTargets' block_live (block : new_blocks) block_id instr' dests + in joinToTargets' platform block_live (block : new_blocks) block_id instr' dests -- | Construct a graph of register\/spill movements. @@ -281,14 +286,14 @@ expandNode vreg src dst -- handleComponent :: Instruction instr - => Int -> instr -> SCC (Unique, Loc, [Loc]) -> RegM freeRegs [instr] + => Platform -> Int -> instr -> SCC (Unique, Loc, [Loc]) -> RegM freeRegs [instr] -- If the graph is acyclic then we won't get the swapping problem below. -- In this case we can just do the moves directly, and avoid having to -- go via a spill slot. -- -handleComponent delta _ (AcyclicSCC (vreg, src, dsts)) - = mapM (makeMove delta vreg src) dsts +handleComponent platform delta _ (AcyclicSCC (vreg, src, dsts)) + = mapM (makeMove platform delta vreg src) dsts -- Handle some cyclic moves. @@ -306,53 +311,54 @@ handleComponent delta _ (AcyclicSCC (vreg, src, dsts)) -- are allocated exclusively for a virtual register and therefore can not -- require a fixup. -- -handleComponent delta instr +handleComponent platform delta instr (CyclicSCC ( (vreg, InReg sreg, (InReg dreg: _)) : rest)) -- dest list may have more than one element, if the reg is also InMem. = do -- spill the source into its slot (instrSpill, slot) - <- spillR (RegReal sreg) vreg + <- spillR platform (RegReal sreg) vreg -- reload into destination reg - instrLoad <- loadR (RegReal dreg) slot + instrLoad <- loadR platform (RegReal dreg) slot - remainingFixUps <- mapM (handleComponent delta instr) + remainingFixUps <- mapM (handleComponent platform delta instr) (stronglyConnCompFromEdgedVerticesR rest) -- make sure to do all the reloads after all the spills, -- so we don't end up clobbering the source values. return ([instrSpill] ++ concat remainingFixUps ++ [instrLoad]) -handleComponent _ _ (CyclicSCC _) +handleComponent _ _ _ (CyclicSCC _) = panic "Register Allocator: handleComponent cyclic" -- | Move a vreg between these two locations. -- -makeMove - :: Instruction instr - => Int -- ^ current C stack delta. - -> Unique -- ^ unique of the vreg that we're moving. - -> Loc -- ^ source location. - -> Loc -- ^ destination location. - -> RegM freeRegs instr -- ^ move instruction. - -makeMove _ vreg (InReg src) (InReg dst) - = do recordSpill (SpillJoinRR vreg) - return $ mkRegRegMoveInstr (RegReal src) (RegReal dst) - -makeMove delta vreg (InMem src) (InReg dst) - = do recordSpill (SpillJoinRM vreg) - return $ mkLoadInstr (RegReal dst) delta src - -makeMove delta vreg (InReg src) (InMem dst) - = do recordSpill (SpillJoinRM vreg) - return $ mkSpillInstr (RegReal src) delta dst +makeMove + :: Instruction instr + => Platform + -> Int -- ^ current C stack delta. + -> Unique -- ^ unique of the vreg that we're moving. + -> Loc -- ^ source location. + -> Loc -- ^ destination location. + -> RegM freeRegs instr -- ^ move instruction. + +makeMove platform _ vreg (InReg src) (InReg dst) + = do recordSpill (SpillJoinRR vreg) + return $ mkRegRegMoveInstr platform (RegReal src) (RegReal dst) + +makeMove platform delta vreg (InMem src) (InReg dst) + = do recordSpill (SpillJoinRM vreg) + return $ mkLoadInstr platform (RegReal dst) delta src + +makeMove platform delta vreg (InReg src) (InMem dst) + = do recordSpill (SpillJoinRM vreg) + return $ mkSpillInstr platform (RegReal src) delta dst -- we don't handle memory to memory moves. -- they shouldn't happen because we don't share stack slots between vregs. -makeMove _ vreg src dst +makeMove _ _ vreg src dst = panic $ "makeMove " ++ show vreg ++ " (" ++ show src ++ ") (" ++ show dst ++ ")" ++ " we don't handle mem->mem moves." diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index 3682ffbe1d..8fa758d063 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -127,10 +127,10 @@ import Control.Monad -- Allocate registers regAlloc - :: (Outputable instr, Instruction instr) + :: (PlatformOutputable instr, Instruction instr) => DynFlags - -> LiveCmmTop instr - -> UniqSM (NatCmmTop instr, Maybe RegAllocStats) + -> LiveCmmTop statics instr + -> UniqSM (NatCmmTop statics instr, Maybe RegAllocStats) regAlloc _ (CmmData sec d) = return @@ -170,7 +170,7 @@ regAlloc _ (CmmProc _ _ _) -- an entry in the block map or it is the first block. -- linearRegAlloc - :: (Outputable instr, Instruction instr) + :: (PlatformOutputable instr, Instruction instr) => DynFlags -> BlockId -- ^ the first block -> BlockMap RegSet -- ^ live regs on entry to each basic block @@ -178,51 +178,54 @@ linearRegAlloc -> UniqSM ([NatBasicBlock instr], RegAllocStats) linearRegAlloc dflags first_id block_live sccs - = case platformArch $ targetPlatform dflags of - ArchX86 -> linearRegAlloc' (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs - ArchX86_64 -> linearRegAlloc' (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs - ArchSPARC -> linearRegAlloc' (frInitFreeRegs :: SPARC.FreeRegs) first_id block_live sccs - ArchPPC -> linearRegAlloc' (frInitFreeRegs :: PPC.FreeRegs) first_id block_live sccs - ArchARM -> panic "linearRegAlloc ArchARM" - ArchPPC_64 -> panic "linearRegAlloc ArchPPC_64" - ArchUnknown -> panic "linearRegAlloc ArchUnknown" + = let platform = targetPlatform dflags + in case platformArch platform of + ArchX86 -> linearRegAlloc' platform (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs + ArchX86_64 -> linearRegAlloc' platform (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs + ArchSPARC -> linearRegAlloc' platform (frInitFreeRegs :: SPARC.FreeRegs) first_id block_live sccs + ArchPPC -> linearRegAlloc' platform (frInitFreeRegs :: PPC.FreeRegs) first_id block_live sccs + ArchARM -> panic "linearRegAlloc ArchARM" + ArchPPC_64 -> panic "linearRegAlloc ArchPPC_64" + ArchUnknown -> panic "linearRegAlloc ArchUnknown" linearRegAlloc' - :: (FR freeRegs, Outputable instr, Instruction instr) - => freeRegs + :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + => Platform + -> freeRegs -> BlockId -- ^ the first block -> BlockMap RegSet -- ^ live regs on entry to each basic block -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths" -> UniqSM ([NatBasicBlock instr], RegAllocStats) -linearRegAlloc' initFreeRegs first_id block_live sccs +linearRegAlloc' platform initFreeRegs first_id block_live sccs = do us <- getUs let (_, _, stats, blocks) = - runR emptyBlockMap initFreeRegs emptyRegMap emptyStackMap us - $ linearRA_SCCs first_id block_live [] sccs + runR emptyBlockMap initFreeRegs emptyRegMap (emptyStackMap platform) us + $ linearRA_SCCs platform first_id block_live [] sccs return (blocks, stats) -linearRA_SCCs :: (FR freeRegs, Instruction instr, Outputable instr) - => BlockId +linearRA_SCCs :: (FR freeRegs, Instruction instr, PlatformOutputable instr) + => Platform + -> BlockId -> BlockMap RegSet -> [NatBasicBlock instr] -> [SCC (LiveBasicBlock instr)] -> RegM freeRegs [NatBasicBlock instr] -linearRA_SCCs _ _ blocksAcc [] +linearRA_SCCs _ _ _ blocksAcc [] = return $ reverse blocksAcc -linearRA_SCCs first_id block_live blocksAcc (AcyclicSCC block : sccs) - = do blocks' <- processBlock block_live block - linearRA_SCCs first_id block_live +linearRA_SCCs platform first_id block_live blocksAcc (AcyclicSCC block : sccs) + = do blocks' <- processBlock platform block_live block + linearRA_SCCs platform first_id block_live ((reverse blocks') ++ blocksAcc) sccs -linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs) +linearRA_SCCs platform first_id block_live blocksAcc (CyclicSCC blocks : sccs) = do - blockss' <- process first_id block_live blocks [] (return []) False - linearRA_SCCs first_id block_live + blockss' <- process platform first_id block_live blocks [] (return []) False + linearRA_SCCs platform first_id block_live (reverse (concat blockss') ++ blocksAcc) sccs @@ -238,8 +241,9 @@ linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs) more sanity checking to guard against this eventuality. -} -process :: (FR freeRegs, Instruction instr, Outputable instr) - => BlockId +process :: (FR freeRegs, Instruction instr, PlatformOutputable instr) + => Platform + -> BlockId -> BlockMap RegSet -> [GenBasicBlock (LiveInstr instr)] -> [GenBasicBlock (LiveInstr instr)] @@ -247,10 +251,10 @@ process :: (FR freeRegs, Instruction instr, Outputable instr) -> Bool -> RegM freeRegs [[NatBasicBlock instr]] -process _ _ [] [] accum _ +process _ _ _ [] [] accum _ = return $ reverse accum -process first_id block_live [] next_round accum madeProgress +process platform first_id block_live [] next_round accum madeProgress | not madeProgress {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming. @@ -260,10 +264,10 @@ process first_id block_live [] next_round accum madeProgress = return $ reverse accum | otherwise - = process first_id block_live + = process platform first_id block_live next_round [] accum False -process first_id block_live (b@(BasicBlock id _) : blocks) +process platform first_id block_live (b@(BasicBlock id _) : blocks) next_round accum madeProgress = do block_assig <- getBlockAssigR @@ -271,26 +275,27 @@ process first_id block_live (b@(BasicBlock id _) : blocks) if isJust (mapLookup id block_assig) || id == first_id then do - b' <- processBlock block_live b - process first_id block_live blocks + b' <- processBlock platform block_live b + process platform first_id block_live blocks next_round (b' : accum) True - else process first_id block_live blocks + else process platform first_id block_live blocks (b : next_round) accum madeProgress -- | Do register allocation on this basic block -- processBlock - :: (FR freeRegs, Outputable instr, Instruction instr) - => BlockMap RegSet -- ^ live regs on entry to each basic block + :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + => Platform + -> BlockMap RegSet -- ^ live regs on entry to each basic block -> LiveBasicBlock instr -- ^ block to do register allocation on -> RegM freeRegs [NatBasicBlock instr] -- ^ block with registers allocated -processBlock block_live (BasicBlock id instrs) +processBlock platform block_live (BasicBlock id instrs) = do initBlock id (instrs', fixups) - <- linearRA block_live [] [] id instrs + <- linearRA platform block_live [] [] id instrs return $ BasicBlock id instrs' : fixups @@ -316,8 +321,9 @@ initBlock id -- | Do allocation for a sequence of instructions. linearRA - :: (FR freeRegs, Outputable instr, Instruction instr) - => BlockMap RegSet -- ^ map of what vregs are live on entry to each block. + :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + => Platform + -> BlockMap RegSet -- ^ map of what vregs are live on entry to each block. -> [instr] -- ^ accumulator for instructions already processed. -> [NatBasicBlock instr] -- ^ accumulator for blocks of fixup code. -> BlockId -- ^ id of the current block, for debugging. @@ -328,24 +334,25 @@ linearRA , [NatBasicBlock instr]) -- fresh blocks of fixup code. -linearRA _ accInstr accFixup _ [] +linearRA _ _ accInstr accFixup _ [] = return ( reverse accInstr -- instrs need to be returned in the correct order. , accFixup) -- it doesn't matter what order the fixup blocks are returned in. -linearRA block_live accInstr accFixups id (instr:instrs) +linearRA platform block_live accInstr accFixups id (instr:instrs) = do (accInstr', new_fixups) - <- raInsn block_live accInstr id instr + <- raInsn platform block_live accInstr id instr - linearRA block_live accInstr' (new_fixups ++ accFixups) id instrs + linearRA platform block_live accInstr' (new_fixups ++ accFixups) id instrs -- | Do allocation for a single instruction. raInsn - :: (FR freeRegs, Outputable instr, Instruction instr) - => BlockMap RegSet -- ^ map of what vregs are love on entry to each block. + :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + => Platform + -> BlockMap RegSet -- ^ map of what vregs are love on entry to each block. -> [instr] -- ^ accumulator for instructions already processed. -> BlockId -- ^ the id of the current block, for debugging -> LiveInstr instr -- ^ the instr to have its regs allocated, with liveness info. @@ -353,17 +360,17 @@ raInsn ( [instr] -- new instructions , [NatBasicBlock instr]) -- extra fixup blocks -raInsn _ new_instrs _ (LiveInstr ii Nothing) +raInsn _ _ new_instrs _ (LiveInstr ii Nothing) | Just n <- takeDeltaInstr ii = do setDeltaR n return (new_instrs, []) -raInsn _ new_instrs _ (LiveInstr ii Nothing) +raInsn _ _ new_instrs _ (LiveInstr ii Nothing) | isMetaInstr ii = return (new_instrs, []) -raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live)) +raInsn platform block_live new_instrs id (LiveInstr (Instr instr) (Just live)) = do assig <- getAssigR @@ -398,17 +405,18 @@ raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live)) -} return (new_instrs, []) - _ -> genRaInsn block_live new_instrs id instr + _ -> genRaInsn platform block_live new_instrs id instr (uniqSetToList $ liveDieRead live) (uniqSetToList $ liveDieWrite live) -raInsn _ _ _ instr - = pprPanic "raInsn" (text "no match for:" <> ppr instr) +raInsn platform _ _ _ instr + = pprPanic "raInsn" (text "no match for:" <> pprPlatform platform instr) -genRaInsn :: (FR freeRegs, Instruction instr, Outputable instr) - => BlockMap RegSet +genRaInsn :: (FR freeRegs, Instruction instr, PlatformOutputable instr) + => Platform + -> BlockMap RegSet -> [instr] -> BlockId -> instr @@ -416,7 +424,7 @@ genRaInsn :: (FR freeRegs, Instruction instr, Outputable instr) -> [Reg] -> RegM freeRegs ([instr], [NatBasicBlock instr]) -genRaInsn block_live new_instrs block_id instr r_dying w_dying = +genRaInsn platform block_live new_instrs block_id instr r_dying w_dying = case regUsageOfInstr instr of { RU read written -> do let real_written = [ rr | (RegReal rr) <- written ] @@ -428,7 +436,7 @@ genRaInsn block_live new_instrs block_id instr r_dying w_dying = let virt_read = nub [ vr | (RegVirtual vr) <- read ] -- (a) save any temporaries which will be clobbered by this instruction - clobber_saves <- saveClobberedTemps real_written r_dying + clobber_saves <- saveClobberedTemps platform real_written r_dying -- debugging {- freeregs <- getFreeRegsR @@ -446,14 +454,14 @@ genRaInsn block_live new_instrs block_id instr r_dying w_dying = -- (b), (c) allocate real regs for all regs read by this instruction. (r_spills, r_allocd) <- - allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read + allocateRegsAndSpill platform True{-reading-} virt_read [] [] virt_read -- (d) Update block map for new destinations -- NB. do this before removing dead regs from the assignment, because -- these dead regs might in fact be live in the jump targets (they're -- only dead in the code that follows in the current basic block). (fixup_blocks, adjusted_instr) - <- joinToTargets block_live block_id instr + <- joinToTargets platform block_live block_id instr -- (e) Delete all register assignments for temps which are read -- (only) and die here. Update the free register list. @@ -464,7 +472,7 @@ genRaInsn block_live new_instrs block_id instr r_dying w_dying = -- (g) Allocate registers for temporaries *written* (only) (w_spills, w_allocd) <- - allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written + allocateRegsAndSpill platform False{-writing-} virt_written [] [] virt_written -- (h) Release registers for temps which are written here and not -- used again. @@ -546,16 +554,17 @@ releaseRegs regs = do saveClobberedTemps - :: (Outputable instr, Instruction instr) - => [RealReg] -- real registers clobbered by this instruction + :: (PlatformOutputable instr, Instruction instr) + => Platform + -> [RealReg] -- real registers clobbered by this instruction -> [Reg] -- registers which are no longer live after this insn -> RegM freeRegs [instr] -- return: instructions to spill any temps that will -- be clobbered. -saveClobberedTemps [] _ +saveClobberedTemps _ [] _ = return [] -saveClobberedTemps clobbered dying +saveClobberedTemps platform clobbered dying = do assig <- getAssigR let to_spill @@ -574,7 +583,7 @@ saveClobberedTemps clobbered dying clobber assig instrs ((temp, reg) : rest) = do - (spill, slot) <- spillR (RegReal reg) temp + (spill, slot) <- spillR platform (RegReal reg) temp -- record why this reg was spilled for profiling recordSpill (SpillClobber temp) @@ -638,24 +647,25 @@ data SpillLoc = ReadMem StackSlot -- reading from register only in memory -- the list of free registers and free stack slots. allocateRegsAndSpill - :: (FR freeRegs, Outputable instr, Instruction instr) - => Bool -- True <=> reading (load up spilled regs) + :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + => Platform + -> Bool -- True <=> reading (load up spilled regs) -> [VirtualReg] -- don't push these out -> [instr] -- spill insns -> [RealReg] -- real registers allocated (accum.) -> [VirtualReg] -- temps to allocate -> RegM freeRegs ( [instr] , [RealReg]) -allocateRegsAndSpill _ _ spills alloc [] +allocateRegsAndSpill _ _ _ spills alloc [] = return (spills, reverse alloc) -allocateRegsAndSpill reading keep spills alloc (r:rs) +allocateRegsAndSpill platform reading keep spills alloc (r:rs) = do assig <- getAssigR - let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig + let doSpill = allocRegsAndSpill_spill platform reading keep spills alloc r rs assig case lookupUFM assig r of -- case (1a): already in a register Just (InReg my_reg) -> - allocateRegsAndSpill reading keep spills (my_reg:alloc) rs + allocateRegsAndSpill platform reading keep spills (my_reg:alloc) rs -- case (1b): already in a register (and memory) -- NB1. if we're writing this register, update its assignment to be @@ -664,7 +674,7 @@ allocateRegsAndSpill reading keep spills alloc (r:rs) -- are also read by the same instruction. Just (InBoth my_reg _) -> do when (not reading) (setAssigR (addToUFM assig r (InReg my_reg))) - allocateRegsAndSpill reading keep spills (my_reg:alloc) rs + allocateRegsAndSpill platform reading keep spills (my_reg:alloc) rs -- Not already in a register, so we need to find a free one... Just (InMem slot) | reading -> doSpill (ReadMem slot) @@ -682,8 +692,9 @@ allocateRegsAndSpill reading keep spills alloc (r:rs) -- reading is redundant with reason, but we keep it around because it's -- convenient and it maintains the recursive structure of the allocator. -- EZY -allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr) - => Bool +allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, PlatformOutputable instr) + => Platform + -> Bool -> [VirtualReg] -> [instr] -> [RealReg] @@ -692,7 +703,7 @@ allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr) -> UniqFM Loc -> SpillLoc -> RegM freeRegs ([instr], [RealReg]) -allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc +allocRegsAndSpill_spill platform reading keep spills alloc r rs assig spill_loc = do freeRegs <- getFreeRegsR let freeRegs_thisClass = frGetFreeRegs (classOfVirtualReg r) freeRegs @@ -701,12 +712,12 @@ allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc -- case (2): we have a free register (my_reg : _) -> - do spills' <- loadTemp r spill_loc my_reg spills + do spills' <- loadTemp platform r spill_loc my_reg spills setAssigR (addToUFM assig r $! newLocation spill_loc my_reg) setFreeRegsR $ frAllocateReg my_reg freeRegs - allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs + allocateRegsAndSpill platform reading keep spills' (my_reg : alloc) rs -- case (3): we need to push something out to free up a register @@ -718,7 +729,7 @@ allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc = [ (temp, reg, mem) | (temp, InBoth reg mem) <- ufmToList assig , temp `notElem` keep' - , targetClassOfRealReg reg == classOfVirtualReg r ] + , targetClassOfRealReg platform reg == classOfVirtualReg r ] -- the vregs we could kick out that are only in a reg -- this would require writing the reg to a new slot before using it. @@ -726,26 +737,26 @@ allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc = [ (temp, reg) | (temp, InReg reg) <- ufmToList assig , temp `notElem` keep' - , targetClassOfRealReg reg == classOfVirtualReg r ] + , targetClassOfRealReg platform reg == classOfVirtualReg r ] let result -- we have a temporary that is in both register and mem, -- just free up its register for use. | (temp, my_reg, slot) : _ <- candidates_inBoth - = do spills' <- loadTemp r spill_loc my_reg spills + = do spills' <- loadTemp platform r spill_loc my_reg spills let assig1 = addToUFM assig temp (InMem slot) let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg setAssigR assig2 - allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs + allocateRegsAndSpill platform reading keep spills' (my_reg:alloc) rs -- otherwise, we need to spill a temporary that currently -- resides in a register. | (temp_to_push_out, (my_reg :: RealReg)) : _ <- candidates_inReg = do - (spill_insn, slot) <- spillR (RegReal my_reg) temp_to_push_out + (spill_insn, slot) <- spillR platform (RegReal my_reg) temp_to_push_out let spill_store = (if reading then id else reverse) [ -- COMMENT (fsLit "spill alloc") spill_insn ] @@ -759,9 +770,9 @@ allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc setAssigR assig2 -- if need be, load up a spilled temp into the reg we've just freed up. - spills' <- loadTemp r spill_loc my_reg spills + spills' <- loadTemp platform r spill_loc my_reg spills - allocateRegsAndSpill reading keep + allocateRegsAndSpill platform reading keep (spill_store ++ spills') (my_reg:alloc) rs @@ -787,19 +798,20 @@ newLocation _ my_reg = InReg my_reg -- | Load up a spilled temporary if we need to (read from memory). loadTemp - :: (Outputable instr, Instruction instr) - => VirtualReg -- the temp being loaded + :: (PlatformOutputable instr, Instruction instr) + => Platform + -> VirtualReg -- the temp being loaded -> SpillLoc -- the current location of this temp -> RealReg -- the hreg to load the temp into -> [instr] -> RegM freeRegs [instr] -loadTemp vreg (ReadMem slot) hreg spills +loadTemp platform vreg (ReadMem slot) hreg spills = do - insn <- loadR (RegReal hreg) slot + insn <- loadR platform (RegReal hreg) slot recordSpill (SpillLoad $ getUnique vreg) return $ {- COMMENT (fsLit "spill load") : -} insn : spills -loadTemp _ _ _ spills = +loadTemp _ _ _ _ spills = return spills diff --git a/compiler/nativeGen/RegAlloc/Linear/StackMap.hs b/compiler/nativeGen/RegAlloc/Linear/StackMap.hs index 62bf6adb2a..1dd410aa46 100644 --- a/compiler/nativeGen/RegAlloc/Linear/StackMap.hs +++ b/compiler/nativeGen/RegAlloc/Linear/StackMap.hs @@ -22,6 +22,7 @@ where import RegAlloc.Linear.FreeRegs import Outputable +import Platform import UniqFM import Unique @@ -39,8 +40,8 @@ data StackMap -- | An empty stack map, with all slots available. -emptyStackMap :: StackMap -emptyStackMap = StackMap [0..maxSpillSlots] emptyUFM +emptyStackMap :: Platform -> StackMap +emptyStackMap platform = StackMap [0 .. maxSpillSlots platform] emptyUFM -- | If this vreg unique already has a stack assignment then return the slot number, diff --git a/compiler/nativeGen/RegAlloc/Linear/State.hs b/compiler/nativeGen/RegAlloc/Linear/State.hs index 05db9de350..9999a1e2e4 100644 --- a/compiler/nativeGen/RegAlloc/Linear/State.hs +++ b/compiler/nativeGen/RegAlloc/Linear/State.hs @@ -36,6 +36,7 @@ import RegAlloc.Liveness import Instruction import Reg +import Platform import Unique import UniqSupply @@ -81,21 +82,21 @@ makeRAStats state { ra_spillInstrs = binSpillReasons (ra_spills state) } -spillR :: Instruction instr - => Reg -> Unique -> RegM freeRegs (instr, Int) +spillR :: Instruction instr + => Platform -> Reg -> Unique -> RegM freeRegs (instr, Int) -spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} -> +spillR platform reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} -> let (stack',slot) = getStackSlotFor stack temp - instr = mkSpillInstr reg delta slot + instr = mkSpillInstr platform reg delta slot in (# s{ra_stack=stack'}, (instr,slot) #) -loadR :: Instruction instr - => Reg -> Int -> RegM freeRegs instr +loadR :: Instruction instr + => Platform -> Reg -> Int -> RegM freeRegs instr -loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} -> - (# s, mkLoadInstr reg delta slot #) +loadR platform reg slot = RegM $ \ s@RA_State{ra_delta=delta} -> + (# s, mkLoadInstr platform reg delta slot #) getFreeRegsR :: RegM freeRegs freeRegs getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} -> diff --git a/compiler/nativeGen/RegAlloc/Linear/Stats.hs b/compiler/nativeGen/RegAlloc/Linear/Stats.hs index c80f77f893..0c059eac27 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Stats.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Stats.hs @@ -37,7 +37,7 @@ binSpillReasons reasons -- | Count reg-reg moves remaining in this code. countRegRegMovesNat :: Instruction instr - => NatCmmTop instr -> Int + => NatCmmTop statics instr -> Int countRegRegMovesNat cmm = execState (mapGenBlockTopM countBlock cmm) 0 @@ -58,7 +58,7 @@ countRegRegMovesNat cmm -- | Pretty print some RegAllocStats pprStats :: Instruction instr - => [NatCmmTop instr] -> [RegAllocStats] -> SDoc + => [NatCmmTop statics instr] -> [RegAllocStats] -> SDoc pprStats code statss = let -- sum up all the instrs inserted by the spiller diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs index a2030fafa9..2b7975dcb4 100644 --- a/compiler/nativeGen/RegAlloc/Liveness.hs +++ b/compiler/nativeGen/RegAlloc/Liveness.hs @@ -8,28 +8,28 @@ {-# OPTIONS -Wall -fno-warn-name-shadowing #-} module RegAlloc.Liveness ( - RegSet, - RegMap, emptyRegMap, - BlockMap, emptyBlockMap, - LiveCmmTop, - InstrSR (..), - LiveInstr (..), - Liveness (..), - LiveInfo (..), - LiveBasicBlock, - - mapBlockTop, mapBlockTopM, mapSCCM, - mapGenBlockTop, mapGenBlockTopM, - stripLive, - stripLiveBlock, - slurpConflicts, - slurpReloadCoalesce, - eraseDeltasLive, - patchEraseLive, - patchRegsLiveInstr, - reverseBlocksInTops, - regLiveness, - natCmmTopToLive + RegSet, + RegMap, emptyRegMap, + BlockMap, emptyBlockMap, + LiveCmmTop, + InstrSR (..), + LiveInstr (..), + Liveness (..), + LiveInfo (..), + LiveBasicBlock, + + mapBlockTop, mapBlockTopM, mapSCCM, + mapGenBlockTop, mapGenBlockTopM, + stripLive, + stripLiveBlock, + slurpConflicts, + slurpReloadCoalesce, + eraseDeltasLive, + patchEraseLive, + patchRegsLiveInstr, + reverseBlocksInTops, + regLiveness, + natCmmTopToLive ) where import Reg import Instruction @@ -40,6 +40,7 @@ import OldPprCmm() import Digraph import Outputable +import Platform import Unique import UniqSet import UniqFM @@ -50,9 +51,9 @@ import FastString import Data.List import Data.Maybe -import Data.Map (Map) -import Data.Set (Set) -import qualified Data.Map as Map +import Data.Map (Map) +import Data.Set (Set) +import qualified Data.Map as Map ----------------------------------------------------------------------------- type RegSet = UniqSet Reg @@ -66,869 +67,873 @@ type BlockMap a = BlockEnv a -- | A top level thing which carries liveness information. -type LiveCmmTop instr - = GenCmmTop - CmmStatic - LiveInfo - [SCC (LiveBasicBlock instr)] +type LiveCmmTop statics instr + = GenCmmTop + statics + LiveInfo + [SCC (LiveBasicBlock instr)] -- | The register allocator also wants to use SPILL/RELOAD meta instructions, --- so we'll keep those here. +-- so we'll keep those here. data InstrSR instr - -- | A real machine instruction - = Instr instr + -- | A real machine instruction + = Instr instr - -- | spill this reg to a stack slot - | SPILL Reg Int + -- | spill this reg to a stack slot + | SPILL Reg Int - -- | reload this reg from a stack slot - | RELOAD Int Reg + -- | reload this reg from a stack slot + | RELOAD Int Reg instance Instruction instr => Instruction (InstrSR instr) where - regUsageOfInstr i - = case i of - Instr instr -> regUsageOfInstr instr - SPILL reg _ -> RU [reg] [] - RELOAD _ reg -> RU [] [reg] + regUsageOfInstr i + = case i of + Instr instr -> regUsageOfInstr instr + SPILL reg _ -> RU [reg] [] + RELOAD _ reg -> RU [] [reg] - patchRegsOfInstr i f - = case i of - Instr instr -> Instr (patchRegsOfInstr instr f) - SPILL reg slot -> SPILL (f reg) slot - RELOAD slot reg -> RELOAD slot (f reg) + patchRegsOfInstr i f + = case i of + Instr instr -> Instr (patchRegsOfInstr instr f) + SPILL reg slot -> SPILL (f reg) slot + RELOAD slot reg -> RELOAD slot (f reg) - isJumpishInstr i - = case i of - Instr instr -> isJumpishInstr instr - _ -> False + isJumpishInstr i + = case i of + Instr instr -> isJumpishInstr instr + _ -> False - jumpDestsOfInstr i - = case i of - Instr instr -> jumpDestsOfInstr instr - _ -> [] + jumpDestsOfInstr i + = case i of + Instr instr -> jumpDestsOfInstr instr + _ -> [] - patchJumpInstr i f - = case i of - Instr instr -> Instr (patchJumpInstr instr f) - _ -> i + patchJumpInstr i f + = case i of + Instr instr -> Instr (patchJumpInstr instr f) + _ -> i - mkSpillInstr = error "mkSpillInstr[InstrSR]: Not making SPILL meta-instr" - mkLoadInstr = error "mkLoadInstr[InstrSR]: Not making LOAD meta-instr" + mkSpillInstr = error "mkSpillInstr[InstrSR]: Not making SPILL meta-instr" + mkLoadInstr = error "mkLoadInstr[InstrSR]: Not making LOAD meta-instr" - takeDeltaInstr i - = case i of - Instr instr -> takeDeltaInstr instr - _ -> Nothing + takeDeltaInstr i + = case i of + Instr instr -> takeDeltaInstr instr + _ -> Nothing - isMetaInstr i - = case i of - Instr instr -> isMetaInstr instr - _ -> False + isMetaInstr i + = case i of + Instr instr -> isMetaInstr instr + _ -> False - mkRegRegMoveInstr r1 r2 = Instr (mkRegRegMoveInstr r1 r2) + mkRegRegMoveInstr platform r1 r2 + = Instr (mkRegRegMoveInstr platform r1 r2) - takeRegRegMoveInstr i - = case i of - Instr instr -> takeRegRegMoveInstr instr - _ -> Nothing + takeRegRegMoveInstr i + = case i of + Instr instr -> takeRegRegMoveInstr instr + _ -> Nothing + + mkJumpInstr target = map Instr (mkJumpInstr target) - mkJumpInstr target = map Instr (mkJumpInstr target) - -- | An instruction with liveness information. data LiveInstr instr - = LiveInstr (InstrSR instr) (Maybe Liveness) + = LiveInstr (InstrSR instr) (Maybe Liveness) -- | Liveness information. --- The regs which die are ones which are no longer live in the *next* instruction --- in this sequence. --- (NB. if the instruction is a jump, these registers might still be live --- at the jump target(s) - you have to check the liveness at the destination --- block to find out). +-- The regs which die are ones which are no longer live in the *next* instruction +-- in this sequence. +-- (NB. if the instruction is a jump, these registers might still be live +-- at the jump target(s) - you have to check the liveness at the destination +-- block to find out). data Liveness - = Liveness - { liveBorn :: RegSet -- ^ registers born in this instruction (written to for first time). - , liveDieRead :: RegSet -- ^ registers that died because they were read for the last time. - , liveDieWrite :: RegSet } -- ^ registers that died because they were clobbered by something. + = Liveness + { liveBorn :: RegSet -- ^ registers born in this instruction (written to for first time). + , liveDieRead :: RegSet -- ^ registers that died because they were read for the last time. + , liveDieWrite :: RegSet } -- ^ registers that died because they were clobbered by something. -- | Stash regs live on entry to each basic block in the info part of the cmm code. data LiveInfo - = LiveInfo - [CmmStatic] -- cmm static stuff - (Maybe BlockId) -- id of the first block - (Maybe (BlockMap RegSet)) -- argument locals live on entry to this block - (Map BlockId (Set Int)) -- stack slots live on entry to this block + = LiveInfo + (Maybe CmmStatics) -- cmm info table static stuff + (Maybe BlockId) -- id of the first block + (Maybe (BlockMap RegSet)) -- argument locals live on entry to this block + (Map BlockId (Set Int)) -- stack slots live on entry to this block -- | A basic block with liveness information. type LiveBasicBlock instr - = GenBasicBlock (LiveInstr instr) - - -instance Outputable instr - => Outputable (InstrSR instr) where - - ppr (Instr realInstr) - = ppr realInstr - - ppr (SPILL reg slot) - = hcat [ - ptext (sLit "\tSPILL"), - char ' ', - ppr reg, - comma, - ptext (sLit "SLOT") <> parens (int slot)] - - ppr (RELOAD slot reg) - = hcat [ - ptext (sLit "\tRELOAD"), - char ' ', - ptext (sLit "SLOT") <> parens (int slot), - comma, - ppr reg] - -instance Outputable instr - => Outputable (LiveInstr instr) where - - ppr (LiveInstr instr Nothing) - = ppr instr - - ppr (LiveInstr instr (Just live)) - = ppr instr - $$ (nest 8 - $ vcat - [ pprRegs (ptext (sLit "# born: ")) (liveBorn live) - , pprRegs (ptext (sLit "# r_dying: ")) (liveDieRead live) - , pprRegs (ptext (sLit "# w_dying: ")) (liveDieWrite live) ] - $+$ space) - - where pprRegs :: SDoc -> RegSet -> SDoc - pprRegs name regs - | isEmptyUniqSet regs = empty - | otherwise = name <> (hcat $ punctuate space $ map ppr $ uniqSetToList regs) + = GenBasicBlock (LiveInstr instr) + + +instance PlatformOutputable instr + => PlatformOutputable (InstrSR instr) where + + pprPlatform platform (Instr realInstr) + = pprPlatform platform realInstr + + pprPlatform _ (SPILL reg slot) + = hcat [ + ptext (sLit "\tSPILL"), + char ' ', + ppr reg, + comma, + ptext (sLit "SLOT") <> parens (int slot)] + + pprPlatform _ (RELOAD slot reg) + = hcat [ + ptext (sLit "\tRELOAD"), + char ' ', + ptext (sLit "SLOT") <> parens (int slot), + comma, + ppr reg] + +instance PlatformOutputable instr + => PlatformOutputable (LiveInstr instr) where + + pprPlatform platform (LiveInstr instr Nothing) + = pprPlatform platform instr + + pprPlatform platform (LiveInstr instr (Just live)) + = pprPlatform platform instr + $$ (nest 8 + $ vcat + [ pprRegs (ptext (sLit "# born: ")) (liveBorn live) + , pprRegs (ptext (sLit "# r_dying: ")) (liveDieRead live) + , pprRegs (ptext (sLit "# w_dying: ")) (liveDieWrite live) ] + $+$ space) + + where pprRegs :: SDoc -> RegSet -> SDoc + pprRegs name regs + | isEmptyUniqSet regs = empty + | otherwise = name <> (hcat $ punctuate space $ map ppr $ uniqSetToList regs) instance Outputable LiveInfo where - ppr (LiveInfo static firstId liveVRegsOnEntry liveSlotsOnEntry) - = (vcat $ map ppr static) - $$ text "# firstId = " <> ppr firstId - $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry - $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry) + ppr (LiveInfo mb_static firstId liveVRegsOnEntry liveSlotsOnEntry) + = (maybe empty ppr mb_static) + $$ text "# firstId = " <> ppr firstId + $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry + $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry) -- | map a function across all the basic blocks in this code -- mapBlockTop - :: (LiveBasicBlock instr -> LiveBasicBlock instr) - -> LiveCmmTop instr -> LiveCmmTop instr + :: (LiveBasicBlock instr -> LiveBasicBlock instr) + -> LiveCmmTop statics instr -> LiveCmmTop statics instr mapBlockTop f cmm - = evalState (mapBlockTopM (\x -> return $ f x) cmm) () + = evalState (mapBlockTopM (\x -> return $ f x) cmm) () -- | map a function across all the basic blocks in this code (monadic version) -- mapBlockTopM - :: Monad m - => (LiveBasicBlock instr -> m (LiveBasicBlock instr)) - -> LiveCmmTop instr -> m (LiveCmmTop instr) + :: Monad m + => (LiveBasicBlock instr -> m (LiveBasicBlock instr)) + -> LiveCmmTop statics instr -> m (LiveCmmTop statics instr) mapBlockTopM _ cmm@(CmmData{}) - = return cmm + = return cmm mapBlockTopM f (CmmProc header label sccs) - = do sccs' <- mapM (mapSCCM f) sccs - return $ CmmProc header label sccs' + = do sccs' <- mapM (mapSCCM f) sccs + return $ CmmProc header label sccs' mapSCCM :: Monad m => (a -> m b) -> SCC a -> m (SCC b) -mapSCCM f (AcyclicSCC x) - = do x' <- f x - return $ AcyclicSCC x' +mapSCCM f (AcyclicSCC x) + = do x' <- f x + return $ AcyclicSCC x' mapSCCM f (CyclicSCC xs) - = do xs' <- mapM f xs - return $ CyclicSCC xs' + = do xs' <- mapM f xs + return $ CyclicSCC xs' -- map a function across all the basic blocks in this code mapGenBlockTop - :: (GenBasicBlock i -> GenBasicBlock i) - -> (GenCmmTop d h (ListGraph i) -> GenCmmTop d h (ListGraph i)) + :: (GenBasicBlock i -> GenBasicBlock i) + -> (GenCmmTop d h (ListGraph i) -> GenCmmTop d h (ListGraph i)) mapGenBlockTop f cmm - = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) () + = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) () -- | map a function across all the basic blocks in this code (monadic version) mapGenBlockTopM - :: Monad m - => (GenBasicBlock i -> m (GenBasicBlock i)) - -> (GenCmmTop d h (ListGraph i) -> m (GenCmmTop d h (ListGraph i))) + :: Monad m + => (GenBasicBlock i -> m (GenBasicBlock i)) + -> (GenCmmTop d h (ListGraph i) -> m (GenCmmTop d h (ListGraph i))) mapGenBlockTopM _ cmm@(CmmData{}) - = return cmm + = return cmm mapGenBlockTopM f (CmmProc header label (ListGraph blocks)) - = do blocks' <- mapM f blocks - return $ CmmProc header label (ListGraph blocks') + = do blocks' <- mapM f blocks + return $ CmmProc header label (ListGraph blocks') -- | Slurp out the list of register conflicts and reg-reg moves from this top level thing. --- Slurping of conflicts and moves is wrapped up together so we don't have --- to make two passes over the same code when we want to build the graph. +-- Slurping of conflicts and moves is wrapped up together so we don't have +-- to make two passes over the same code when we want to build the graph. -- -slurpConflicts - :: Instruction instr - => LiveCmmTop instr - -> (Bag (UniqSet Reg), Bag (Reg, Reg)) +slurpConflicts + :: Instruction instr + => LiveCmmTop statics instr + -> (Bag (UniqSet Reg), Bag (Reg, Reg)) slurpConflicts live - = slurpCmm (emptyBag, emptyBag) live + = slurpCmm (emptyBag, emptyBag) live + + where slurpCmm rs CmmData{} = rs + slurpCmm rs (CmmProc info _ sccs) + = foldl' (slurpSCC info) rs sccs - where slurpCmm rs CmmData{} = rs - slurpCmm rs (CmmProc info _ sccs) - = foldl' (slurpSCC info) rs sccs + slurpSCC info rs (AcyclicSCC b) + = slurpBlock info rs b - slurpSCC info rs (AcyclicSCC b) - = slurpBlock info rs b + slurpSCC info rs (CyclicSCC bs) + = foldl' (slurpBlock info) rs bs - slurpSCC info rs (CyclicSCC bs) - = foldl' (slurpBlock info) rs bs + slurpBlock info rs (BasicBlock blockId instrs) + | LiveInfo _ _ (Just blockLive) _ <- info + , Just rsLiveEntry <- mapLookup blockId blockLive + , (conflicts, moves) <- slurpLIs rsLiveEntry rs instrs + = (consBag rsLiveEntry conflicts, moves) - slurpBlock info rs (BasicBlock blockId instrs) - | LiveInfo _ _ (Just blockLive) _ <- info - , Just rsLiveEntry <- mapLookup blockId blockLive - , (conflicts, moves) <- slurpLIs rsLiveEntry rs instrs - = (consBag rsLiveEntry conflicts, moves) + | otherwise + = panic "Liveness.slurpConflicts: bad block" - | otherwise - = panic "Liveness.slurpConflicts: bad block" + slurpLIs rsLive (conflicts, moves) [] + = (consBag rsLive conflicts, moves) - slurpLIs rsLive (conflicts, moves) [] - = (consBag rsLive conflicts, moves) + slurpLIs rsLive rs (LiveInstr _ Nothing : lis) + = slurpLIs rsLive rs lis - slurpLIs rsLive rs (LiveInstr _ Nothing : lis) - = slurpLIs rsLive rs lis - - slurpLIs rsLiveEntry (conflicts, moves) (LiveInstr instr (Just live) : lis) - = let - -- regs that die because they are read for the last time at the start of an instruction - -- are not live across it. - rsLiveAcross = rsLiveEntry `minusUniqSet` (liveDieRead live) + slurpLIs rsLiveEntry (conflicts, moves) (LiveInstr instr (Just live) : lis) + = let + -- regs that die because they are read for the last time at the start of an instruction + -- are not live across it. + rsLiveAcross = rsLiveEntry `minusUniqSet` (liveDieRead live) - -- regs live on entry to the next instruction. - -- be careful of orphans, make sure to delete dying regs _after_ unioning - -- in the ones that are born here. - rsLiveNext = (rsLiveAcross `unionUniqSets` (liveBorn live)) - `minusUniqSet` (liveDieWrite live) + -- regs live on entry to the next instruction. + -- be careful of orphans, make sure to delete dying regs _after_ unioning + -- in the ones that are born here. + rsLiveNext = (rsLiveAcross `unionUniqSets` (liveBorn live)) + `minusUniqSet` (liveDieWrite live) - -- orphan vregs are the ones that die in the same instruction they are born in. - -- these are likely to be results that are never used, but we still - -- need to assign a hreg to them.. - rsOrphans = intersectUniqSets - (liveBorn live) - (unionUniqSets (liveDieWrite live) (liveDieRead live)) + -- orphan vregs are the ones that die in the same instruction they are born in. + -- these are likely to be results that are never used, but we still + -- need to assign a hreg to them.. + rsOrphans = intersectUniqSets + (liveBorn live) + (unionUniqSets (liveDieWrite live) (liveDieRead live)) - -- - rsConflicts = unionUniqSets rsLiveNext rsOrphans + -- + rsConflicts = unionUniqSets rsLiveNext rsOrphans - in case takeRegRegMoveInstr instr of - Just rr -> slurpLIs rsLiveNext - ( consBag rsConflicts conflicts - , consBag rr moves) lis + in case takeRegRegMoveInstr instr of + Just rr -> slurpLIs rsLiveNext + ( consBag rsConflicts conflicts + , consBag rr moves) lis - Nothing -> slurpLIs rsLiveNext - ( consBag rsConflicts conflicts - , moves) lis + Nothing -> slurpLIs rsLiveNext + ( consBag rsConflicts conflicts + , moves) lis -- | For spill\/reloads -- --- SPILL v1, slot1 --- ... --- RELOAD slot1, v2 +-- SPILL v1, slot1 +-- ... +-- RELOAD slot1, v2 -- --- If we can arrange that v1 and v2 are allocated to the same hreg it's more likely --- the spill\/reload instrs can be cleaned and replaced by a nop reg-reg move. +-- If we can arrange that v1 and v2 are allocated to the same hreg it's more likely +-- the spill\/reload instrs can be cleaned and replaced by a nop reg-reg move. -- -- -slurpReloadCoalesce - :: forall instr. Instruction instr - => LiveCmmTop instr - -> Bag (Reg, Reg) +slurpReloadCoalesce + :: forall statics instr. Instruction instr + => LiveCmmTop statics instr + -> Bag (Reg, Reg) slurpReloadCoalesce live - = slurpCmm emptyBag live + = slurpCmm emptyBag live - where + where slurpCmm :: Bag (Reg, Reg) -> GenCmmTop t t1 [SCC (LiveBasicBlock instr)] -> Bag (Reg, Reg) - slurpCmm cs CmmData{} = cs - slurpCmm cs (CmmProc _ _ sccs) - = slurpComp cs (flattenSCCs sccs) + slurpCmm cs CmmData{} = cs + slurpCmm cs (CmmProc _ _ sccs) + = slurpComp cs (flattenSCCs sccs) slurpComp :: Bag (Reg, Reg) -> [LiveBasicBlock instr] -> Bag (Reg, Reg) - slurpComp cs blocks - = let (moveBags, _) = runState (slurpCompM blocks) emptyUFM - in unionManyBags (cs : moveBags) + slurpComp cs blocks + = let (moveBags, _) = runState (slurpCompM blocks) emptyUFM + in unionManyBags (cs : moveBags) slurpCompM :: [LiveBasicBlock instr] -> State (UniqFM [UniqFM Reg]) [Bag (Reg, Reg)] - slurpCompM blocks - = do -- run the analysis once to record the mapping across jumps. - mapM_ (slurpBlock False) blocks + slurpCompM blocks + = do -- run the analysis once to record the mapping across jumps. + mapM_ (slurpBlock False) blocks - -- run it a second time while using the information from the last pass. - -- We /could/ run this many more times to deal with graphical control - -- flow and propagating info across multiple jumps, but it's probably - -- not worth the trouble. - mapM (slurpBlock True) blocks + -- run it a second time while using the information from the last pass. + -- We /could/ run this many more times to deal with graphical control + -- flow and propagating info across multiple jumps, but it's probably + -- not worth the trouble. + mapM (slurpBlock True) blocks slurpBlock :: Bool -> LiveBasicBlock instr -> State (UniqFM [UniqFM Reg]) (Bag (Reg, Reg)) - slurpBlock propagate (BasicBlock blockId instrs) - = do -- grab the slot map for entry to this block - slotMap <- if propagate - then getSlotMap blockId - else return emptyUFM - - (_, mMoves) <- mapAccumLM slurpLI slotMap instrs - return $ listToBag $ catMaybes mMoves - - slurpLI :: UniqFM Reg -- current slotMap - -> LiveInstr instr - -> State (UniqFM [UniqFM Reg]) -- blockId -> [slot -> reg] - -- for tracking slotMaps across jumps - - ( UniqFM Reg -- new slotMap - , Maybe (Reg, Reg)) -- maybe a new coalesce edge - - slurpLI slotMap li - - -- remember what reg was stored into the slot - | LiveInstr (SPILL reg slot) _ <- li - , slotMap' <- addToUFM slotMap slot reg - = return (slotMap', Nothing) - - -- add an edge betwen the this reg and the last one stored into the slot - | LiveInstr (RELOAD slot reg) _ <- li - = case lookupUFM slotMap slot of - Just reg2 - | reg /= reg2 -> return (slotMap, Just (reg, reg2)) - | otherwise -> return (slotMap, Nothing) - - Nothing -> return (slotMap, Nothing) - - -- if we hit a jump, remember the current slotMap - | LiveInstr (Instr instr) _ <- li - , targets <- jumpDestsOfInstr instr - , not $ null targets - = do mapM_ (accSlotMap slotMap) targets - return (slotMap, Nothing) - - | otherwise - = return (slotMap, Nothing) - - -- record a slotmap for an in edge to this block - accSlotMap slotMap blockId - = modify (\s -> addToUFM_C (++) s blockId [slotMap]) - - -- work out the slot map on entry to this block - -- if we have slot maps for multiple in-edges then we need to merge them. - getSlotMap blockId - = do map <- get - let slotMaps = fromMaybe [] (lookupUFM map blockId) - return $ foldr mergeSlotMaps emptyUFM slotMaps - - mergeSlotMaps :: UniqFM Reg -> UniqFM Reg -> UniqFM Reg - mergeSlotMaps map1 map2 - = listToUFM - $ [ (k, r1) | (k, r1) <- ufmToList map1 - , case lookupUFM map2 k of - Nothing -> False - Just r2 -> r1 == r2 ] + slurpBlock propagate (BasicBlock blockId instrs) + = do -- grab the slot map for entry to this block + slotMap <- if propagate + then getSlotMap blockId + else return emptyUFM + + (_, mMoves) <- mapAccumLM slurpLI slotMap instrs + return $ listToBag $ catMaybes mMoves + + slurpLI :: UniqFM Reg -- current slotMap + -> LiveInstr instr + -> State (UniqFM [UniqFM Reg]) -- blockId -> [slot -> reg] + -- for tracking slotMaps across jumps + + ( UniqFM Reg -- new slotMap + , Maybe (Reg, Reg)) -- maybe a new coalesce edge + + slurpLI slotMap li + + -- remember what reg was stored into the slot + | LiveInstr (SPILL reg slot) _ <- li + , slotMap' <- addToUFM slotMap slot reg + = return (slotMap', Nothing) + + -- add an edge betwen the this reg and the last one stored into the slot + | LiveInstr (RELOAD slot reg) _ <- li + = case lookupUFM slotMap slot of + Just reg2 + | reg /= reg2 -> return (slotMap, Just (reg, reg2)) + | otherwise -> return (slotMap, Nothing) + + Nothing -> return (slotMap, Nothing) + + -- if we hit a jump, remember the current slotMap + | LiveInstr (Instr instr) _ <- li + , targets <- jumpDestsOfInstr instr + , not $ null targets + = do mapM_ (accSlotMap slotMap) targets + return (slotMap, Nothing) + + | otherwise + = return (slotMap, Nothing) + + -- record a slotmap for an in edge to this block + accSlotMap slotMap blockId + = modify (\s -> addToUFM_C (++) s blockId [slotMap]) + + -- work out the slot map on entry to this block + -- if we have slot maps for multiple in-edges then we need to merge them. + getSlotMap blockId + = do map <- get + let slotMaps = fromMaybe [] (lookupUFM map blockId) + return $ foldr mergeSlotMaps emptyUFM slotMaps + + mergeSlotMaps :: UniqFM Reg -> UniqFM Reg -> UniqFM Reg + mergeSlotMaps map1 map2 + = listToUFM + $ [ (k, r1) | (k, r1) <- ufmToList map1 + , case lookupUFM map2 k of + Nothing -> False + Just r2 -> r1 == r2 ] -- | Strip away liveness information, yielding NatCmmTop -stripLive - :: (Outputable instr, Instruction instr) - => LiveCmmTop instr - -> NatCmmTop instr +stripLive + :: (Outputable statics, PlatformOutputable instr, Instruction instr) + => Platform + -> LiveCmmTop statics instr + -> NatCmmTop statics instr -stripLive live - = stripCmm live +stripLive platform live + = stripCmm live - where stripCmm (CmmData sec ds) = CmmData sec ds - stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label sccs) - = let final_blocks = flattenSCCs sccs - - -- make sure the block that was first in the input list - -- stays at the front of the output. This is the entry point - -- of the proc, and it needs to come first. - ((first':_), rest') - = partition ((== first_id) . blockId) final_blocks + where stripCmm (CmmData sec ds) = CmmData sec ds + stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label sccs) + = let final_blocks = flattenSCCs sccs - in CmmProc info label - (ListGraph $ map stripLiveBlock $ first' : rest') + -- make sure the block that was first in the input list + -- stays at the front of the output. This is the entry point + -- of the proc, and it needs to come first. + ((first':_), rest') + = partition ((== first_id) . blockId) final_blocks - -- procs used for stg_split_markers don't contain any blocks, and have no first_id. - stripCmm (CmmProc (LiveInfo info Nothing _ _) label []) - = CmmProc info label (ListGraph []) + in CmmProc info label + (ListGraph $ map (stripLiveBlock platform) $ first' : rest') - -- If the proc has blocks but we don't know what the first one was, then we're dead. - stripCmm proc - = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (ppr proc) + -- procs used for stg_split_markers don't contain any blocks, and have no first_id. + stripCmm (CmmProc (LiveInfo info Nothing _ _) label []) + = CmmProc info label (ListGraph []) + -- If the proc has blocks but we don't know what the first one was, then we're dead. + stripCmm proc + = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (pprPlatform platform proc) -- | Strip away liveness information from a basic block, --- and make real spill instructions out of SPILL, RELOAD pseudos along the way. +-- and make real spill instructions out of SPILL, RELOAD pseudos along the way. stripLiveBlock - :: Instruction instr - => LiveBasicBlock instr - -> NatBasicBlock instr + :: Instruction instr + => Platform + -> LiveBasicBlock instr + -> NatBasicBlock instr -stripLiveBlock (BasicBlock i lis) - = BasicBlock i instrs' +stripLiveBlock platform (BasicBlock i lis) + = BasicBlock i instrs' - where (instrs', _) - = runState (spillNat [] lis) 0 + where (instrs', _) + = runState (spillNat [] lis) 0 - spillNat acc [] - = return (reverse acc) + spillNat acc [] + = return (reverse acc) - spillNat acc (LiveInstr (SPILL reg slot) _ : instrs) - = do delta <- get - spillNat (mkSpillInstr reg delta slot : acc) instrs + spillNat acc (LiveInstr (SPILL reg slot) _ : instrs) + = do delta <- get + spillNat (mkSpillInstr platform reg delta slot : acc) instrs - spillNat acc (LiveInstr (RELOAD slot reg) _ : instrs) - = do delta <- get - spillNat (mkLoadInstr reg delta slot : acc) instrs + spillNat acc (LiveInstr (RELOAD slot reg) _ : instrs) + = do delta <- get + spillNat (mkLoadInstr platform reg delta slot : acc) instrs - spillNat acc (LiveInstr (Instr instr) _ : instrs) - | Just i <- takeDeltaInstr instr - = do put i - spillNat acc instrs + spillNat acc (LiveInstr (Instr instr) _ : instrs) + | Just i <- takeDeltaInstr instr + = do put i + spillNat acc instrs - spillNat acc (LiveInstr (Instr instr) _ : instrs) - = spillNat (instr : acc) instrs + spillNat acc (LiveInstr (Instr instr) _ : instrs) + = spillNat (instr : acc) instrs -- | Erase Delta instructions. -eraseDeltasLive - :: Instruction instr - => LiveCmmTop instr - -> LiveCmmTop instr +eraseDeltasLive + :: Instruction instr + => LiveCmmTop statics instr + -> LiveCmmTop statics instr eraseDeltasLive cmm - = mapBlockTop eraseBlock cmm + = mapBlockTop eraseBlock cmm where - eraseBlock (BasicBlock id lis) - = BasicBlock id - $ filter (\(LiveInstr i _) -> not $ isJust $ takeDeltaInstr i) - $ lis + eraseBlock (BasicBlock id lis) + = BasicBlock id + $ filter (\(LiveInstr i _) -> not $ isJust $ takeDeltaInstr i) + $ lis -- | Patch the registers in this code according to this register mapping. --- also erase reg -> reg moves when the reg is the same. --- also erase reg -> reg moves when the destination dies in this instr. +-- also erase reg -> reg moves when the reg is the same. +-- also erase reg -> reg moves when the destination dies in this instr. patchEraseLive - :: Instruction instr - => (Reg -> Reg) - -> LiveCmmTop instr -> LiveCmmTop instr + :: Instruction instr + => (Reg -> Reg) + -> LiveCmmTop statics instr -> LiveCmmTop statics instr patchEraseLive patchF cmm - = patchCmm cmm + = patchCmm cmm where - patchCmm cmm@CmmData{} = cmm + patchCmm cmm@CmmData{} = cmm - patchCmm (CmmProc info label sccs) - | LiveInfo static id (Just blockMap) mLiveSlots <- info - = let - patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set - blockMap' = mapMap patchRegSet blockMap + patchCmm (CmmProc info label sccs) + | LiveInfo static id (Just blockMap) mLiveSlots <- info + = let + patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set + blockMap' = mapMap patchRegSet blockMap - info' = LiveInfo static id (Just blockMap') mLiveSlots - in CmmProc info' label $ map patchSCC sccs + info' = LiveInfo static id (Just blockMap') mLiveSlots + in CmmProc info' label $ map patchSCC sccs - | otherwise - = panic "RegAlloc.Liveness.patchEraseLive: no blockMap" + | otherwise + = panic "RegAlloc.Liveness.patchEraseLive: no blockMap" - patchSCC (AcyclicSCC b) = AcyclicSCC (patchBlock b) - patchSCC (CyclicSCC bs) = CyclicSCC (map patchBlock bs) + patchSCC (AcyclicSCC b) = AcyclicSCC (patchBlock b) + patchSCC (CyclicSCC bs) = CyclicSCC (map patchBlock bs) - patchBlock (BasicBlock id lis) - = BasicBlock id $ patchInstrs lis + patchBlock (BasicBlock id lis) + = BasicBlock id $ patchInstrs lis - patchInstrs [] = [] - patchInstrs (li : lis) + patchInstrs [] = [] + patchInstrs (li : lis) - | LiveInstr i (Just live) <- li' - , Just (r1, r2) <- takeRegRegMoveInstr i - , eatMe r1 r2 live - = patchInstrs lis + | LiveInstr i (Just live) <- li' + , Just (r1, r2) <- takeRegRegMoveInstr i + , eatMe r1 r2 live + = patchInstrs lis - | otherwise - = li' : patchInstrs lis + | otherwise + = li' : patchInstrs lis - where li' = patchRegsLiveInstr patchF li + where li' = patchRegsLiveInstr patchF li - eatMe r1 r2 live - -- source and destination regs are the same - | r1 == r2 = True + eatMe r1 r2 live + -- source and destination regs are the same + | r1 == r2 = True - -- desination reg is never used - | elementOfUniqSet r2 (liveBorn live) - , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live) - = True + -- desination reg is never used + | elementOfUniqSet r2 (liveBorn live) + , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live) + = True - | otherwise = False + | otherwise = False -- | Patch registers in this LiveInstr, including the liveness information. -- patchRegsLiveInstr - :: Instruction instr - => (Reg -> Reg) - -> LiveInstr instr -> LiveInstr instr + :: Instruction instr + => (Reg -> Reg) + -> LiveInstr instr -> LiveInstr instr patchRegsLiveInstr patchF li = case li of - LiveInstr instr Nothing - -> LiveInstr (patchRegsOfInstr instr patchF) Nothing + LiveInstr instr Nothing + -> LiveInstr (patchRegsOfInstr instr patchF) Nothing - LiveInstr instr (Just live) - -> LiveInstr - (patchRegsOfInstr instr patchF) - (Just live - { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg - liveBorn = mkUniqSet $ map patchF $ uniqSetToList $ liveBorn live - , liveDieRead = mkUniqSet $ map patchF $ uniqSetToList $ liveDieRead live - , liveDieWrite = mkUniqSet $ map patchF $ uniqSetToList $ liveDieWrite live }) + LiveInstr instr (Just live) + -> LiveInstr + (patchRegsOfInstr instr patchF) + (Just live + { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg + liveBorn = mkUniqSet $ map patchF $ uniqSetToList $ liveBorn live + , liveDieRead = mkUniqSet $ map patchF $ uniqSetToList $ liveDieRead live + , liveDieWrite = mkUniqSet $ map patchF $ uniqSetToList $ liveDieWrite live }) -------------------------------------------------------------------------------- -- | Convert a NatCmmTop to a LiveCmmTop, with empty liveness information -natCmmTopToLive - :: Instruction instr - => NatCmmTop instr - -> LiveCmmTop instr +natCmmTopToLive + :: Instruction instr + => NatCmmTop statics instr + -> LiveCmmTop statics instr natCmmTopToLive (CmmData i d) - = CmmData i d + = CmmData i d natCmmTopToLive (CmmProc info lbl (ListGraph [])) - = CmmProc (LiveInfo info Nothing Nothing Map.empty) lbl [] + = CmmProc (LiveInfo info Nothing Nothing Map.empty) lbl [] natCmmTopToLive (CmmProc info lbl (ListGraph blocks@(first : _))) - = let first_id = blockId first - sccs = sccBlocks blocks - sccsLive = map (fmap (\(BasicBlock l instrs) -> - BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs))) - $ sccs - - in CmmProc (LiveInfo info (Just first_id) Nothing Map.empty) lbl sccsLive + = let first_id = blockId first + sccs = sccBlocks blocks + sccsLive = map (fmap (\(BasicBlock l instrs) -> + BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs))) + $ sccs + in CmmProc (LiveInfo info (Just first_id) Nothing Map.empty) lbl sccsLive -sccBlocks - :: Instruction instr - => [NatBasicBlock instr] - -> [SCC (NatBasicBlock instr)] + +sccBlocks + :: Instruction instr + => [NatBasicBlock instr] + -> [SCC (NatBasicBlock instr)] sccBlocks blocks = stronglyConnCompFromEdgedVertices graph where - getOutEdges :: Instruction instr => [instr] -> [BlockId] - getOutEdges instrs = concat $ map jumpDestsOfInstr instrs + getOutEdges :: Instruction instr => [instr] -> [BlockId] + getOutEdges instrs = concat $ map jumpDestsOfInstr instrs - graph = [ (block, getUnique id, map getUnique (getOutEdges instrs)) - | block@(BasicBlock id instrs) <- blocks ] + graph = [ (block, getUnique id, map getUnique (getOutEdges instrs)) + | block@(BasicBlock id instrs) <- blocks ] --------------------------------------------------------------------------------- -- Annotate code with register liveness information -- regLiveness - :: (Outputable instr, Instruction instr) - => LiveCmmTop instr - -> UniqSM (LiveCmmTop instr) + :: (PlatformOutputable instr, Instruction instr) + => Platform + -> LiveCmmTop statics instr + -> UniqSM (LiveCmmTop statics instr) -regLiveness (CmmData i d) - = returnUs $ CmmData i d +regLiveness _ (CmmData i d) + = returnUs $ CmmData i d -regLiveness (CmmProc info lbl []) - | LiveInfo static mFirst _ _ <- info - = returnUs $ CmmProc - (LiveInfo static mFirst (Just mapEmpty) Map.empty) - lbl [] +regLiveness _ (CmmProc info lbl []) + | LiveInfo static mFirst _ _ <- info + = returnUs $ CmmProc + (LiveInfo static mFirst (Just mapEmpty) Map.empty) + lbl [] -regLiveness (CmmProc info lbl sccs) - | LiveInfo static mFirst _ liveSlotsOnEntry <- info - = let (ann_sccs, block_live) = computeLiveness sccs +regLiveness platform (CmmProc info lbl sccs) + | LiveInfo static mFirst _ liveSlotsOnEntry <- info + = let (ann_sccs, block_live) = computeLiveness platform sccs - in returnUs $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry) - lbl ann_sccs + in returnUs $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry) + lbl ann_sccs -- ----------------------------------------------------------------------------- -- | Check ordering of Blocks --- The computeLiveness function requires SCCs to be in reverse dependent order. --- If they're not the liveness information will be wrong, and we'll get a bad allocation. --- Better to check for this precondition explicitly or some other poor sucker will --- waste a day staring at bad assembly code.. --- +-- The computeLiveness function requires SCCs to be in reverse dependent order. +-- If they're not the liveness information will be wrong, and we'll get a bad allocation. +-- Better to check for this precondition explicitly or some other poor sucker will +-- waste a day staring at bad assembly code.. +-- checkIsReverseDependent - :: Instruction instr - => [SCC (LiveBasicBlock instr)] -- ^ SCCs of blocks that we're about to run the liveness determinator on. - -> Maybe BlockId -- ^ BlockIds that fail the test (if any) - + :: Instruction instr + => [SCC (LiveBasicBlock instr)] -- ^ SCCs of blocks that we're about to run the liveness determinator on. + -> Maybe BlockId -- ^ BlockIds that fail the test (if any) + checkIsReverseDependent sccs' = go emptyUniqSet sccs' - where go _ [] - = Nothing - - go blocksSeen (AcyclicSCC block : sccs) - = let dests = slurpJumpDestsOfBlock block - blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet [blockId block] - badDests = dests `minusUniqSet` blocksSeen' - in case uniqSetToList badDests of - [] -> go blocksSeen' sccs - bad : _ -> Just bad - - go blocksSeen (CyclicSCC blocks : sccs) - = let dests = unionManyUniqSets $ map slurpJumpDestsOfBlock blocks - blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet $ map blockId blocks - badDests = dests `minusUniqSet` blocksSeen' - in case uniqSetToList badDests of - [] -> go blocksSeen' sccs - bad : _ -> Just bad - - slurpJumpDestsOfBlock (BasicBlock _ instrs) - = unionManyUniqSets - $ map (mkUniqSet . jumpDestsOfInstr) - [ i | LiveInstr i _ <- instrs] + where go _ [] + = Nothing + + go blocksSeen (AcyclicSCC block : sccs) + = let dests = slurpJumpDestsOfBlock block + blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet [blockId block] + badDests = dests `minusUniqSet` blocksSeen' + in case uniqSetToList badDests of + [] -> go blocksSeen' sccs + bad : _ -> Just bad + + go blocksSeen (CyclicSCC blocks : sccs) + = let dests = unionManyUniqSets $ map slurpJumpDestsOfBlock blocks + blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet $ map blockId blocks + badDests = dests `minusUniqSet` blocksSeen' + in case uniqSetToList badDests of + [] -> go blocksSeen' sccs + bad : _ -> Just bad + + slurpJumpDestsOfBlock (BasicBlock _ instrs) + = unionManyUniqSets + $ map (mkUniqSet . jumpDestsOfInstr) + [ i | LiveInstr i _ <- instrs] -- | If we've compute liveness info for this code already we have to reverse -- the SCCs in each top to get them back to the right order so we can do it again. -reverseBlocksInTops :: LiveCmmTop instr -> LiveCmmTop instr +reverseBlocksInTops :: LiveCmmTop statics instr -> LiveCmmTop statics instr reverseBlocksInTops top = case top of - CmmData{} -> top - CmmProc info lbl sccs -> CmmProc info lbl (reverse sccs) + CmmData{} -> top + CmmProc info lbl sccs -> CmmProc info lbl (reverse sccs) + - -- | Computing liveness --- +-- -- On entry, the SCCs must be in "reverse" order: later blocks may transfer -- control to earlier ones only, else `panic`. --- +-- -- The SCCs returned are in the *opposite* order, which is exactly what we -- want for the next pass. -- computeLiveness - :: (Outputable instr, Instruction instr) - => [SCC (LiveBasicBlock instr)] - -> ([SCC (LiveBasicBlock instr)], -- instructions annotated with list of registers - -- which are "dead after this instruction". - BlockMap RegSet) -- blocks annontated with set of live registers - -- on entry to the block. - -computeLiveness sccs + :: (PlatformOutputable instr, Instruction instr) + => Platform + -> [SCC (LiveBasicBlock instr)] + -> ([SCC (LiveBasicBlock instr)], -- instructions annotated with list of registers + -- which are "dead after this instruction". + BlockMap RegSet) -- blocks annontated with set of live registers + -- on entry to the block. + +computeLiveness platform sccs = case checkIsReverseDependent sccs of - Nothing -> livenessSCCs emptyBlockMap [] sccs - Just bad -> pprPanic "RegAlloc.Liveness.computeLivenss" - (vcat [ text "SCCs aren't in reverse dependent order" - , text "bad blockId" <+> ppr bad - , ppr sccs]) + Nothing -> livenessSCCs emptyBlockMap [] sccs + Just bad -> pprPanic "RegAlloc.Liveness.computeLivenss" + (vcat [ text "SCCs aren't in reverse dependent order" + , text "bad blockId" <+> ppr bad + , pprPlatform platform sccs]) livenessSCCs :: Instruction instr => BlockMap RegSet - -> [SCC (LiveBasicBlock instr)] -- accum + -> [SCC (LiveBasicBlock instr)] -- accum -> [SCC (LiveBasicBlock instr)] -> ( [SCC (LiveBasicBlock instr)] - , BlockMap RegSet) + , BlockMap RegSet) -livenessSCCs blockmap done [] - = (done, blockmap) +livenessSCCs blockmap done [] + = (done, blockmap) livenessSCCs blockmap done (AcyclicSCC block : sccs) - = let (blockmap', block') = livenessBlock blockmap block - in livenessSCCs blockmap' (AcyclicSCC block' : done) sccs + = let (blockmap', block') = livenessBlock blockmap block + in livenessSCCs blockmap' (AcyclicSCC block' : done) sccs livenessSCCs blockmap done - (CyclicSCC blocks : sccs) = - livenessSCCs blockmap' (CyclicSCC blocks':done) sccs + (CyclicSCC blocks : sccs) = + livenessSCCs blockmap' (CyclicSCC blocks':done) sccs where (blockmap', blocks') - = iterateUntilUnchanged linearLiveness equalBlockMaps - blockmap blocks + = iterateUntilUnchanged linearLiveness equalBlockMaps + blockmap blocks iterateUntilUnchanged :: (a -> b -> (a,c)) -> (a -> a -> Bool) -> a -> b -> (a,c) - iterateUntilUnchanged f eq a b - = head $ - concatMap tail $ - groupBy (\(a1, _) (a2, _) -> eq a1 a2) $ - iterate (\(a, _) -> f a b) $ - (a, panic "RegLiveness.livenessSCCs") + iterateUntilUnchanged f eq a b + = head $ + concatMap tail $ + groupBy (\(a1, _) (a2, _) -> eq a1 a2) $ + iterate (\(a, _) -> f a b) $ + (a, panic "RegLiveness.livenessSCCs") - linearLiveness - :: Instruction instr - => BlockMap RegSet -> [LiveBasicBlock instr] - -> (BlockMap RegSet, [LiveBasicBlock instr]) + linearLiveness + :: Instruction instr + => BlockMap RegSet -> [LiveBasicBlock instr] + -> (BlockMap RegSet, [LiveBasicBlock instr]) linearLiveness = mapAccumL livenessBlock -- probably the least efficient way to compare two -- BlockMaps for equality. - equalBlockMaps a b - = a' == b' - where a' = map f $ mapToList a - b' = map f $ mapToList b - f (key,elt) = (key, uniqSetToList elt) + equalBlockMaps a b + = a' == b' + where a' = map f $ mapToList a + b' = map f $ mapToList b + f (key,elt) = (key, uniqSetToList elt) -- | Annotate a basic block with register liveness information. -- livenessBlock - :: Instruction instr - => BlockMap RegSet - -> LiveBasicBlock instr - -> (BlockMap RegSet, LiveBasicBlock instr) + :: Instruction instr + => BlockMap RegSet + -> LiveBasicBlock instr + -> (BlockMap RegSet, LiveBasicBlock instr) livenessBlock blockmap (BasicBlock block_id instrs) = let - (regsLiveOnEntry, instrs1) - = livenessBack emptyUniqSet blockmap [] (reverse instrs) - blockmap' = mapInsert block_id regsLiveOnEntry blockmap + (regsLiveOnEntry, instrs1) + = livenessBack emptyUniqSet blockmap [] (reverse instrs) + blockmap' = mapInsert block_id regsLiveOnEntry blockmap - instrs2 = livenessForward regsLiveOnEntry instrs1 + instrs2 = livenessForward regsLiveOnEntry instrs1 - output = BasicBlock block_id instrs2 + output = BasicBlock block_id instrs2 - in ( blockmap', output) + in ( blockmap', output) -- | Calculate liveness going forwards, --- filling in when regs are born +-- filling in when regs are born livenessForward - :: Instruction instr - => RegSet -- regs live on this instr - -> [LiveInstr instr] -> [LiveInstr instr] + :: Instruction instr + => RegSet -- regs live on this instr + -> [LiveInstr instr] -> [LiveInstr instr] -livenessForward _ [] = [] +livenessForward _ [] = [] livenessForward rsLiveEntry (li@(LiveInstr instr mLive) : lis) - | Nothing <- mLive - = li : livenessForward rsLiveEntry lis + | Nothing <- mLive + = li : livenessForward rsLiveEntry lis - | Just live <- mLive - , RU _ written <- regUsageOfInstr instr - = let - -- Regs that are written to but weren't live on entry to this instruction - -- are recorded as being born here. - rsBorn = mkUniqSet - $ filter (\r -> not $ elementOfUniqSet r rsLiveEntry) written + | Just live <- mLive + , RU _ written <- regUsageOfInstr instr + = let + -- Regs that are written to but weren't live on entry to this instruction + -- are recorded as being born here. + rsBorn = mkUniqSet + $ filter (\r -> not $ elementOfUniqSet r rsLiveEntry) written - rsLiveNext = (rsLiveEntry `unionUniqSets` rsBorn) - `minusUniqSet` (liveDieRead live) - `minusUniqSet` (liveDieWrite live) + rsLiveNext = (rsLiveEntry `unionUniqSets` rsBorn) + `minusUniqSet` (liveDieRead live) + `minusUniqSet` (liveDieWrite live) - in LiveInstr instr (Just live { liveBorn = rsBorn }) - : livenessForward rsLiveNext lis + in LiveInstr instr (Just live { liveBorn = rsBorn }) + : livenessForward rsLiveNext lis -livenessForward _ _ = panic "RegLiveness.livenessForward: no match" +livenessForward _ _ = panic "RegLiveness.livenessForward: no match" -- | Calculate liveness going backwards, --- filling in when regs die, and what regs are live across each instruction +-- filling in when regs die, and what regs are live across each instruction livenessBack - :: Instruction instr - => RegSet -- regs live on this instr - -> BlockMap RegSet -- regs live on entry to other BBs - -> [LiveInstr instr] -- instructions (accum) - -> [LiveInstr instr] -- instructions - -> (RegSet, [LiveInstr instr]) + :: Instruction instr + => RegSet -- regs live on this instr + -> BlockMap RegSet -- regs live on entry to other BBs + -> [LiveInstr instr] -- instructions (accum) + -> [LiveInstr instr] -- instructions + -> (RegSet, [LiveInstr instr]) livenessBack liveregs _ done [] = (liveregs, done) livenessBack liveregs blockmap acc (instr : instrs) - = let (liveregs', instr') = liveness1 liveregs blockmap instr - in livenessBack liveregs' blockmap (instr' : acc) instrs + = let (liveregs', instr') = liveness1 liveregs blockmap instr + in livenessBack liveregs' blockmap (instr' : acc) instrs -- don't bother tagging comments or deltas with liveness -liveness1 - :: Instruction instr - => RegSet - -> BlockMap RegSet - -> LiveInstr instr - -> (RegSet, LiveInstr instr) +liveness1 + :: Instruction instr + => RegSet + -> BlockMap RegSet + -> LiveInstr instr + -> (RegSet, LiveInstr instr) liveness1 liveregs _ (LiveInstr instr _) - | isMetaInstr instr - = (liveregs, LiveInstr instr Nothing) + | isMetaInstr instr + = (liveregs, LiveInstr instr Nothing) liveness1 liveregs blockmap (LiveInstr instr _) - | not_a_branch - = (liveregs1, LiveInstr instr - (Just $ Liveness - { liveBorn = emptyUniqSet - , liveDieRead = mkUniqSet r_dying - , liveDieWrite = mkUniqSet w_dying })) - - | otherwise - = (liveregs_br, LiveInstr instr - (Just $ Liveness - { liveBorn = emptyUniqSet - , liveDieRead = mkUniqSet r_dying_br - , liveDieWrite = mkUniqSet w_dying })) - - where - RU read written = regUsageOfInstr instr - - -- registers that were written here are dead going backwards. - -- registers that were read here are live going backwards. - liveregs1 = (liveregs `delListFromUniqSet` written) - `addListToUniqSet` read - - -- registers that are not live beyond this point, are recorded - -- as dying here. - r_dying = [ reg | reg <- read, reg `notElem` written, - not (elementOfUniqSet reg liveregs) ] - - w_dying = [ reg | reg <- written, - not (elementOfUniqSet reg liveregs) ] - - -- union in the live regs from all the jump destinations of this - -- instruction. - targets = jumpDestsOfInstr instr -- where we go from here - not_a_branch = null targets - - targetLiveRegs target + | not_a_branch + = (liveregs1, LiveInstr instr + (Just $ Liveness + { liveBorn = emptyUniqSet + , liveDieRead = mkUniqSet r_dying + , liveDieWrite = mkUniqSet w_dying })) + + | otherwise + = (liveregs_br, LiveInstr instr + (Just $ Liveness + { liveBorn = emptyUniqSet + , liveDieRead = mkUniqSet r_dying_br + , liveDieWrite = mkUniqSet w_dying })) + + where + RU read written = regUsageOfInstr instr + + -- registers that were written here are dead going backwards. + -- registers that were read here are live going backwards. + liveregs1 = (liveregs `delListFromUniqSet` written) + `addListToUniqSet` read + + -- registers that are not live beyond this point, are recorded + -- as dying here. + r_dying = [ reg | reg <- read, reg `notElem` written, + not (elementOfUniqSet reg liveregs) ] + + w_dying = [ reg | reg <- written, + not (elementOfUniqSet reg liveregs) ] + + -- union in the live regs from all the jump destinations of this + -- instruction. + targets = jumpDestsOfInstr instr -- where we go from here + not_a_branch = null targets + + targetLiveRegs target = case mapLookup target blockmap of Just ra -> ra Nothing -> emptyRegMap live_from_branch = unionManyUniqSets (map targetLiveRegs targets) - liveregs_br = liveregs1 `unionUniqSets` live_from_branch + liveregs_br = liveregs1 `unionUniqSets` live_from_branch -- registers that are live only in the branch targets should -- be listed as dying here. diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index a4dbbe8771..6f454a3733 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -41,28 +41,30 @@ import OldCmm import CLabel -- The rest: +import DynFlags import StaticFlags ( opt_PIC ) import OrdList import Outputable +import Platform import Unique import Control.Monad ( mapAndUnzipM ) -- | Top level code generation -cmmTopCodeGen - :: RawCmmTop - -> NatM [NatCmmTop Instr] +cmmTopCodeGen :: RawCmmTop + -> NatM [NatCmmTop CmmStatics Instr] -cmmTopCodeGen - (CmmProc info lab (ListGraph blocks)) - = do - (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks +cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) + = do + dflags <- getDynFlagsNat + let platform = targetPlatform dflags + (nat_blocks,statics) <- mapAndUnzipM (basicBlockCodeGen platform) blocks - let proc = CmmProc info lab (ListGraph $ concat nat_blocks) - let tops = proc : concat statics + let proc = CmmProc info lab (ListGraph $ concat nat_blocks) + let tops = proc : concat statics + + return tops - return tops - cmmTopCodeGen (CmmData sec dat) = do return [CmmData sec dat] -- no translation, we just use CmmStatic @@ -72,12 +74,12 @@ cmmTopCodeGen (CmmData sec dat) = do -- are indicated by the NEWBLOCK instruction. We must split up the -- instruction stream into basic blocks again. Also, we extract -- LDATAs here too. -basicBlockCodeGen - :: CmmBasicBlock - -> NatM ( [NatBasicBlock Instr] - , [NatCmmTop Instr]) +basicBlockCodeGen :: Platform + -> CmmBasicBlock + -> NatM ( [NatBasicBlock Instr] + , [NatCmmTop CmmStatics Instr]) -basicBlockCodeGen cmm@(BasicBlock id stmts) = do +basicBlockCodeGen platform cmm@(BasicBlock id stmts) = do instrs <- stmtsToInstrs stmts let (top,other_blocks,statics) @@ -94,7 +96,7 @@ basicBlockCodeGen cmm@(BasicBlock id stmts) = do -- do intra-block sanity checking blocksChecked - = map (checkBlock cmm) + = map (checkBlock platform cmm) $ BasicBlock id top : other_blocks return (blocksChecked, statics) @@ -313,8 +315,8 @@ genSwitch expr ids , JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label , NOP ] -generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr) +generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop CmmStatics Instr) generateJumpTableForInstr (JMP_TBL _ ids label) = let jumpTable = map jumpTableEntry ids - in Just (CmmData ReadOnlyData (CmmDataLabel label : jumpTable)) + in Just (CmmData ReadOnlyData (Statics label jumpTable)) generateJumpTableForInstr _ = Nothing diff --git a/compiler/nativeGen/SPARC/CodeGen/CCall.hs b/compiler/nativeGen/SPARC/CodeGen/CCall.hs index 7445f7168e..3e629c47f5 100644 --- a/compiler/nativeGen/SPARC/CodeGen/CCall.hs +++ b/compiler/nativeGen/SPARC/CodeGen/CCall.hs @@ -24,8 +24,10 @@ import CLabel import BasicTypes import OrdList +import DynFlags import FastString import Outputable +import Platform {- Now the biggest nightmare---calls. Most of the nastiness is buried in @@ -137,6 +139,7 @@ genCCall target dest_regs argsAndHints let transfer_code = toOL (move_final vregs allArgRegs extraStackArgsHere) + dflags <- getDynFlagsNat return $ argcode `appOL` move_sp_down `appOL` @@ -144,7 +147,7 @@ genCCall target dest_regs argsAndHints callinsns `appOL` unitOL NOP `appOL` move_sp_up `appOL` - assign_code dest_regs + assign_code (targetPlatform dflags) dest_regs -- | Generate code to calculate an argument, and move it into one @@ -224,11 +227,11 @@ move_final (v:vs) (a:az) offset -- | Assign results returned from the call into their -- desination regs. -- -assign_code :: [CmmHinted LocalReg] -> OrdList Instr +assign_code :: Platform -> [CmmHinted LocalReg] -> OrdList Instr -assign_code [] = nilOL +assign_code _ [] = nilOL -assign_code [CmmHinted dest _hint] +assign_code platform [CmmHinted dest _hint] = let rep = localRegType dest width = typeWidth rep r_dest = getRegisterReg (CmmLocal dest) @@ -244,20 +247,20 @@ assign_code [CmmHinted dest _hint] | not $ isFloatType rep , W32 <- width - = unitOL $ mkRegRegMoveInstr (regSingle $ oReg 0) r_dest + = unitOL $ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest | not $ isFloatType rep , W64 <- width , r_dest_hi <- getHiVRegFromLo r_dest - = toOL [ mkRegRegMoveInstr (regSingle $ oReg 0) r_dest_hi - , mkRegRegMoveInstr (regSingle $ oReg 1) r_dest] + = toOL [ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest_hi + , mkRegRegMoveInstr platform (regSingle $ oReg 1) r_dest] | otherwise = panic "SPARC.CodeGen.GenCCall: no match" in result -assign_code _ +assign_code _ _ = panic "SPARC.CodeGen.GenCCall: no match" diff --git a/compiler/nativeGen/SPARC/CodeGen/Expand.hs b/compiler/nativeGen/SPARC/CodeGen/Expand.hs index d4500e8a8e..3e49f5c025 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Expand.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Expand.hs @@ -21,7 +21,7 @@ import Outputable import OrdList -- | Expand out synthetic instructions in this top level thing -expandTop :: NatCmmTop Instr -> NatCmmTop Instr +expandTop :: NatCmmTop CmmStatics Instr -> NatCmmTop CmmStatics Instr expandTop top@(CmmData{}) = top diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs index 9d6aa5e646..ddeed0508b 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs @@ -83,9 +83,8 @@ getRegister (CmmLit (CmmFloat f W32)) = do let code dst = toOL [ -- the data area - LDATA ReadOnlyData - [CmmDataLabel lbl, - CmmStaticLit (CmmFloat f W32)], + LDATA ReadOnlyData $ Statics lbl + [CmmStaticLit (CmmFloat f W32)], -- load the literal SETHI (HI (ImmCLbl lbl)) tmp, @@ -97,9 +96,8 @@ getRegister (CmmLit (CmmFloat d W64)) = do lbl <- getNewLabelNat tmp <- getNewRegNat II32 let code dst = toOL [ - LDATA ReadOnlyData - [CmmDataLabel lbl, - CmmStaticLit (CmmFloat d W64)], + LDATA ReadOnlyData $ Statics lbl + [CmmStaticLit (CmmFloat d W64)], SETHI (HI (ImmCLbl lbl)) tmp, LD II64 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] return (Any FF64 code) diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs index 180ec315ee..6bf2a8f32d 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs @@ -23,6 +23,7 @@ import Reg import OldCmm +import DynFlags import OrdList import Outputable @@ -182,10 +183,12 @@ iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) -- compute expr and load it into r_dst_lo (a_reg, a_code) <- getSomeReg expr - let code = a_code + dflags <- getDynFlagsNat + let platform = targetPlatform dflags + code = a_code `appOL` toOL - [ mkRegRegMoveInstr g0 r_dst_hi -- clear high 32 bits - , mkRegRegMoveInstr a_reg r_dst_lo ] + [ mkRegRegMoveInstr platform g0 r_dst_hi -- clear high 32 bits + , mkRegRegMoveInstr platform a_reg r_dst_lo ] return $ ChildCode64 code r_dst_lo diff --git a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs index ca4c8e4994..a3053cbae8 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs @@ -15,15 +15,17 @@ import Instruction import OldCmm import Outputable +import Platform -- | Enforce intra-block invariants. -- -checkBlock - :: CmmBasicBlock - -> NatBasicBlock Instr -> NatBasicBlock Instr +checkBlock :: Platform + -> CmmBasicBlock + -> NatBasicBlock Instr + -> NatBasicBlock Instr -checkBlock cmm block@(BasicBlock _ instrs) +checkBlock platform cmm block@(BasicBlock _ instrs) | checkBlockInstrs instrs = block @@ -31,9 +33,9 @@ checkBlock cmm block@(BasicBlock _ instrs) = pprPanic ("SPARC.CodeGen: bad block\n") ( vcat [ text " -- cmm -----------------\n" - , ppr cmm + , pprPlatform platform cmm , text " -- native code ---------\n" - , ppr block ]) + , pprPlatform platform block ]) checkBlockInstrs :: [Instr] -> Bool diff --git a/compiler/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs index 93f4d27444..61090e05c8 100644 --- a/compiler/nativeGen/SPARC/Instr.hs +++ b/compiler/nativeGen/SPARC/Instr.hs @@ -43,6 +43,7 @@ import OldCmm import FastString import FastBool import Outputable +import Platform -- | Register or immediate @@ -112,7 +113,7 @@ data Instr -- some static data spat out during code generation. -- Will be extracted before pretty-printing. - | LDATA Section [CmmStatic] + | LDATA Section CmmStatics -- Start a new basic block. Useful during codegen, removed later. -- Preceding instruction should be a jump, as per the invariants @@ -363,15 +364,16 @@ sparc_patchJumpInstr insn patchF -- | Make a spill instruction. -- On SPARC we spill below frame pointer leaving 2 words/spill sparc_mkSpillInstr - :: Reg -- ^ register to spill - -> Int -- ^ current stack delta - -> Int -- ^ spill slot to use - -> Instr + :: Platform + -> Reg -- ^ register to spill + -> Int -- ^ current stack delta + -> Int -- ^ spill slot to use + -> Instr -sparc_mkSpillInstr reg _ slot +sparc_mkSpillInstr platform reg _ slot = let off = spillSlotToOffset slot off_w = 1 + (off `div` 4) - sz = case targetClassOfReg reg of + sz = case targetClassOfReg platform reg of RcInteger -> II32 RcFloat -> FF32 RcDouble -> FF64 @@ -382,15 +384,16 @@ sparc_mkSpillInstr reg _ slot -- | Make a spill reload instruction. sparc_mkLoadInstr - :: Reg -- ^ register to load into - -> Int -- ^ current stack delta - -> Int -- ^ spill slot to use - -> Instr + :: Platform + -> Reg -- ^ register to load into + -> Int -- ^ current stack delta + -> Int -- ^ spill slot to use + -> Instr -sparc_mkLoadInstr reg _ slot +sparc_mkLoadInstr platform reg _ slot = let off = spillSlotToOffset slot off_w = 1 + (off `div` 4) - sz = case targetClassOfReg reg of + sz = case targetClassOfReg platform reg of RcInteger -> II32 RcFloat -> FF32 RcDouble -> FF64 @@ -430,13 +433,14 @@ sparc_isMetaInstr instr -- have to go via memory. -- sparc_mkRegRegMoveInstr - :: Reg - -> Reg - -> Instr - -sparc_mkRegRegMoveInstr src dst - | srcClass <- targetClassOfReg src - , dstClass <- targetClassOfReg dst + :: Platform + -> Reg + -> Reg + -> Instr + +sparc_mkRegRegMoveInstr platform src dst + | srcClass <- targetClassOfReg platform src + , dstClass <- targetClassOfReg platform dst , srcClass == dstClass = case srcClass of RcInteger -> ADD False False src (RIReg g0) dst diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs index d78d1a760e..bf3fd3c303 100644 --- a/compiler/nativeGen/SPARC/Ppr.hs +++ b/compiler/nativeGen/SPARC/Ppr.hs @@ -39,7 +39,8 @@ import CLabel import Unique ( Uniquable(..), pprUnique ) import qualified Outputable -import Outputable (Outputable, panic) +import Outputable (PlatformOutputable, panic) +import Platform import Pretty import FastString import Data.Word @@ -47,24 +48,28 @@ import Data.Word -- ----------------------------------------------------------------------------- -- Printing this stuff out -pprNatCmmTop :: NatCmmTop Instr -> Doc -pprNatCmmTop (CmmData section dats) = - pprSectionHeader section $$ vcat (map pprData dats) +pprNatCmmTop :: Platform -> NatCmmTop CmmStatics Instr -> Doc +pprNatCmmTop _ (CmmData section dats) = + pprSectionHeader section $$ pprDatas dats -- special case for split markers: -pprNatCmmTop (CmmProc [] lbl (ListGraph [])) = pprLabel lbl +pprNatCmmTop _ (CmmProc Nothing lbl (ListGraph [])) = pprLabel lbl -pprNatCmmTop (CmmProc info lbl (ListGraph blocks)) = + -- special case for code without info table: +pprNatCmmTop _ (CmmProc Nothing lbl (ListGraph blocks)) = pprSectionHeader Text $$ - (if null info then -- blocks guaranteed not null, so label needed - pprLabel lbl - else + pprLabel lbl $$ -- blocks guaranteed not null, so label needed + vcat (map pprBasicBlock blocks) + +pprNatCmmTop _ (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blocks)) = + pprSectionHeader Text $$ + ( #if HAVE_SUBSECTIONS_VIA_SYMBOLS - pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl) - <> char ':' $$ + pprCLabel_asm (mkDeadStripPreventer info_lbl) + <> char ':' $$ #endif vcat (map pprData info) $$ - pprLabel (entryLblToInfoLbl lbl) + pprLabel info_lbl ) $$ vcat (map pprBasicBlock blocks) -- above: Even the first block gets a label, because with branch-chain @@ -76,12 +81,10 @@ pprNatCmmTop (CmmProc info lbl (ListGraph blocks)) = -- from the entry code to a label on the _top_ of of the info table, -- so that the linker will not think it is unreferenced and dead-strip -- it. That's why the label is called a DeadStripPreventer (_dsp). - $$ if not (null info) - then text "\t.long " - <+> pprCLabel_asm (entryLblToInfoLbl lbl) - <+> char '-' - <+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl) - else empty + $$ text "\t.long " + <+> pprCLabel_asm info_lbl + <+> char '-' + <+> pprCLabel_asm (mkDeadStripPreventer info_lbl) #endif @@ -91,9 +94,10 @@ pprBasicBlock (BasicBlock blockid instrs) = vcat (map pprInstr instrs) +pprDatas :: CmmStatics -> Doc +pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats) + pprData :: CmmStatic -> Doc -pprData (CmmAlign bytes) = pprAlign bytes -pprData (CmmDataLabel lbl) = pprLabel lbl pprData (CmmString str) = pprASCII str pprData (CmmUninitialised bytes) = ptext (sLit ".skip ") <> int bytes pprData (CmmStaticLit lit) = pprDataItem lit @@ -125,16 +129,12 @@ pprASCII str do1 :: Word8 -> Doc do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w) -pprAlign :: Int -> Doc -pprAlign bytes = - ptext (sLit ".align ") <> int bytes - -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' -instance Outputable Instr where - ppr instr = Outputable.docToSDoc $ pprInstr instr +instance PlatformOutputable Instr where + pprPlatform _ instr = Outputable.docToSDoc $ pprInstr instr -- | Pretty print a register. diff --git a/compiler/nativeGen/SPARC/ShortcutJump.hs b/compiler/nativeGen/SPARC/ShortcutJump.hs index 30e48bb377..10e2e9fbaa 100644 --- a/compiler/nativeGen/SPARC/ShortcutJump.hs +++ b/compiler/nativeGen/SPARC/ShortcutJump.hs @@ -3,7 +3,7 @@ module SPARC.ShortcutJump ( JumpDest(..), getJumpDestBlockId, canShortcut, shortcutJump, - shortcutStatic, + shortcutStatics, shortBlockId ) @@ -38,16 +38,23 @@ shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr shortcutJump _ other = other -shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic -shortcutStatic fn (CmmStaticLit (CmmLabel lab)) - | Just uq <- maybeAsmTemp lab - = CmmStaticLit (CmmLabel (shortBlockId fn (mkBlockId uq))) +shortcutStatics :: (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics +shortcutStatics fn (Statics lbl statics) + = Statics lbl $ map (shortcutStatic fn) statics + -- we need to get the jump tables, so apply the mapping to the entries + -- of a CmmData too. -shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) - | Just uq <- maybeAsmTemp lbl1 - = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn (mkBlockId uq)) lbl2 off) +shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel +shortcutLabel fn lab + | Just uq <- maybeAsmTemp lab = shortBlockId fn (mkBlockId uq) + | otherwise = lab +shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic +shortcutStatic fn (CmmStaticLit (CmmLabel lab)) + = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) +shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) + = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off) -- slightly dodgy, we're ignoring the second label, but this -- works with the way we use CmmLabelDiffOff for jump tables now. shortcutStatic _ other_static diff --git a/compiler/nativeGen/TargetReg.hs b/compiler/nativeGen/TargetReg.hs index e6427ed499..089269785c 100644 --- a/compiler/nativeGen/TargetReg.hs +++ b/compiler/nativeGen/TargetReg.hs @@ -40,13 +40,9 @@ import qualified PPC.Regs as PPC import qualified SPARC.Regs as SPARC --- TODO: We shouldn't be using defaultTargetPlatform here. --- We should be passing DynFlags in instead, and looking at --- its targetPlatform. - -targetVirtualRegSqueeze :: RegClass -> VirtualReg -> FastInt -targetVirtualRegSqueeze - = case platformArch defaultTargetPlatform of +targetVirtualRegSqueeze :: Platform -> RegClass -> VirtualReg -> FastInt +targetVirtualRegSqueeze platform + = case platformArch platform of ArchX86 -> X86.virtualRegSqueeze ArchX86_64 -> X86.virtualRegSqueeze ArchPPC -> PPC.virtualRegSqueeze @@ -55,9 +51,9 @@ targetVirtualRegSqueeze ArchARM -> panic "targetVirtualRegSqueeze ArchARM" ArchUnknown -> panic "targetVirtualRegSqueeze ArchUnknown" -targetRealRegSqueeze :: RegClass -> RealReg -> FastInt -targetRealRegSqueeze - = case platformArch defaultTargetPlatform of +targetRealRegSqueeze :: Platform -> RegClass -> RealReg -> FastInt +targetRealRegSqueeze platform + = case platformArch platform of ArchX86 -> X86.realRegSqueeze ArchX86_64 -> X86.realRegSqueeze ArchPPC -> PPC.realRegSqueeze @@ -66,9 +62,9 @@ targetRealRegSqueeze ArchARM -> panic "targetRealRegSqueeze ArchARM" ArchUnknown -> panic "targetRealRegSqueeze ArchUnknown" -targetClassOfRealReg :: RealReg -> RegClass -targetClassOfRealReg - = case platformArch defaultTargetPlatform of +targetClassOfRealReg :: Platform -> RealReg -> RegClass +targetClassOfRealReg platform + = case platformArch platform of ArchX86 -> X86.classOfRealReg ArchX86_64 -> X86.classOfRealReg ArchPPC -> PPC.classOfRealReg @@ -81,9 +77,9 @@ targetClassOfRealReg targetWordSize :: Size targetWordSize = intSize wordWidth -targetMkVirtualReg :: Unique -> Size -> VirtualReg -targetMkVirtualReg - = case platformArch defaultTargetPlatform of +targetMkVirtualReg :: Platform -> Unique -> Size -> VirtualReg +targetMkVirtualReg platform + = case platformArch platform of ArchX86 -> X86.mkVirtualReg ArchX86_64 -> X86.mkVirtualReg ArchPPC -> PPC.mkVirtualReg @@ -92,11 +88,11 @@ targetMkVirtualReg ArchARM -> panic "targetMkVirtualReg ArchARM" ArchUnknown -> panic "targetMkVirtualReg ArchUnknown" -targetRegDotColor :: RealReg -> SDoc -targetRegDotColor - = case platformArch defaultTargetPlatform of - ArchX86 -> X86.regDotColor - ArchX86_64 -> X86.regDotColor +targetRegDotColor :: Platform -> RealReg -> SDoc +targetRegDotColor platform + = case platformArch platform of + ArchX86 -> X86.regDotColor platform + ArchX86_64 -> X86.regDotColor platform ArchPPC -> PPC.regDotColor ArchSPARC -> SPARC.regDotColor ArchPPC_64 -> panic "targetRegDotColor ArchPPC_64" @@ -104,10 +100,10 @@ targetRegDotColor ArchUnknown -> panic "targetRegDotColor ArchUnknown" -targetClassOfReg :: Reg -> RegClass -targetClassOfReg reg +targetClassOfReg :: Platform -> Reg -> RegClass +targetClassOfReg platform reg = case reg of - RegVirtual vr -> classOfVirtualReg vr - RegReal rr -> targetClassOfRealReg rr + RegVirtual vr -> classOfVirtualReg vr + RegReal rr -> targetClassOfRealReg platform rr diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index d191733af1..6ab7cff93b 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -80,7 +80,7 @@ if_sse2 sse2 x87 = do cmmTopCodeGen :: RawCmmTop - -> NatM [NatCmmTop Instr] + -> NatM [NatCmmTop (Alignment, CmmStatics) Instr] cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks @@ -95,13 +95,13 @@ cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do Nothing -> return tops cmmTopCodeGen (CmmData sec dat) = do - return [CmmData sec dat] -- no translation, we just use CmmStatic + return [CmmData sec (1, dat)] -- no translation, we just use CmmStatic basicBlockCodeGen :: CmmBasicBlock -> NatM ( [NatBasicBlock Instr] - , [NatCmmTop Instr]) + , [NatCmmTop (Alignment, CmmStatics) Instr]) basicBlockCodeGen (BasicBlock id stmts) = do instrs <- stmtsToInstrs stmts @@ -323,7 +323,7 @@ iselExpr64 (CmmLit (CmmInt i _)) = do (rlo,rhi) <- getNewRegPairNat II32 let r = fromIntegral (fromIntegral i :: Word32) - q = fromIntegral ((fromIntegral i `shiftR` 32) :: Word32) + q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32) code = toOL [ MOV II32 (OpImm (ImmInteger r)) (OpReg rlo), MOV II32 (OpImm (ImmInteger q)) (OpReg rhi) @@ -352,7 +352,7 @@ iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do (rlo,rhi) <- getNewRegPairNat II32 let r = fromIntegral (fromIntegral i :: Word32) - q = fromIntegral ((fromIntegral i `shiftR` 32) :: Word32) + q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32) r1hi = getHiVRegFromLo r1lo code = code1 `appOL` toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), @@ -1123,10 +1123,7 @@ memConstant align lit = do return (addr, addr_code) else return (ripRel (ImmCLbl lbl), nilOL) let code = - LDATA ReadOnlyData - [CmmAlign align, - CmmDataLabel lbl, - CmmStaticLit lit] + LDATA ReadOnlyData (align, Statics lbl [CmmStaticLit lit]) `consOL` addr_code return (Amode addr code) @@ -1580,341 +1577,355 @@ genCCall (CmmPrim MO_WriteBarrier) _ _ = return nilOL genCCall target dest_regs args = do dflags <- getDynFlagsNat if target32Bit (targetPlatform dflags) - then case (target, dest_regs) of - -- void return type prim op - (CmmPrim op, []) -> - outOfLineCmmOp op Nothing args - -- we only cope with a single result for foreign calls - (CmmPrim op, [r_hinted@(CmmHinted r _)]) -> do - l1 <- getNewLabelNat - l2 <- getNewLabelNat - sse2 <- sse2Enabled - if sse2 - then - outOfLineCmmOp op (Just r_hinted) args - else case op of - MO_F32_Sqrt -> actuallyInlineFloatOp GSQRT FF32 args - MO_F64_Sqrt -> actuallyInlineFloatOp GSQRT FF64 args - - MO_F32_Sin -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF32 args - MO_F64_Sin -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF64 args - - MO_F32_Cos -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF32 args - MO_F64_Cos -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF64 args - - MO_F32_Tan -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF32 args - MO_F64_Tan -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF64 args - - _other_op -> outOfLineCmmOp op (Just r_hinted) args - - where - actuallyInlineFloatOp instr size [CmmHinted x _] - = do res <- trivialUFCode size (instr size) x - any <- anyReg res - return (any (getRegisterReg False (CmmLocal r))) - - actuallyInlineFloatOp _ _ args - = panic $ "genCCall.actuallyInlineFloatOp: bad number of arguments! (" - ++ show (length args) ++ ")" - _ -> do - let - sizes = map (arg_size . cmmExprType . hintlessCmm) (reverse args) - raw_arg_size = sum sizes - tot_arg_size = roundTo 16 raw_arg_size - arg_pad_size = tot_arg_size - raw_arg_size - delta0 <- getDeltaNat - setDeltaNat (delta0 - arg_pad_size) - - use_sse2 <- sse2Enabled - push_codes <- mapM (push_arg use_sse2) (reverse args) - delta <- getDeltaNat + then genCCall32 target dest_regs args + else genCCall64 target dest_regs args + +genCCall32 :: CmmCallTarget -- function to call + -> [HintedCmmFormal] -- where to put the result + -> [HintedCmmActual] -- arguments (of mixed type) + -> NatM InstrBlock +genCCall32 target dest_regs args = + case (target, dest_regs) of + -- void return type prim op + (CmmPrim op, []) -> + outOfLineCmmOp op Nothing args + -- we only cope with a single result for foreign calls + (CmmPrim op, [r_hinted@(CmmHinted r _)]) -> do + l1 <- getNewLabelNat + l2 <- getNewLabelNat + sse2 <- sse2Enabled + if sse2 + then + outOfLineCmmOp op (Just r_hinted) args + else case op of + MO_F32_Sqrt -> actuallyInlineFloatOp GSQRT FF32 args + MO_F64_Sqrt -> actuallyInlineFloatOp GSQRT FF64 args + + MO_F32_Sin -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF32 args + MO_F64_Sin -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF64 args + + MO_F32_Cos -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF32 args + MO_F64_Cos -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF64 args + + MO_F32_Tan -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF32 args + MO_F64_Tan -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF64 args + + _other_op -> outOfLineCmmOp op (Just r_hinted) args + + where + actuallyInlineFloatOp instr size [CmmHinted x _] + = do res <- trivialUFCode size (instr size) x + any <- anyReg res + return (any (getRegisterReg False (CmmLocal r))) + + actuallyInlineFloatOp _ _ args + = panic $ "genCCall.actuallyInlineFloatOp: bad number of arguments! (" + ++ show (length args) ++ ")" + _ -> do + let + sizes = map (arg_size . cmmExprType . hintlessCmm) (reverse args) + raw_arg_size = sum sizes + tot_arg_size = roundTo 16 raw_arg_size + arg_pad_size = tot_arg_size - raw_arg_size + delta0 <- getDeltaNat + setDeltaNat (delta0 - arg_pad_size) + + use_sse2 <- sse2Enabled + push_codes <- mapM (push_arg use_sse2) (reverse args) + delta <- getDeltaNat + + -- in + -- deal with static vs dynamic call targets + (callinsns,cconv) <- + case target of + CmmCallee (CmmLit (CmmLabel lbl)) conv + -> -- ToDo: stdcall arg sizes + return (unitOL (CALL (Left fn_imm) []), conv) + where fn_imm = ImmCLbl lbl + CmmCallee expr conv + -> do { (dyn_r, dyn_c) <- getSomeReg expr + ; ASSERT( isWord32 (cmmExprType expr) ) + return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) } + CmmPrim _ + -> panic $ "genCCall: Can't handle CmmPrim call type here, error " + ++ "probably because too many return values." + + let push_code + | arg_pad_size /= 0 + = toOL [SUB II32 (OpImm (ImmInt arg_pad_size)) (OpReg esp), + DELTA (delta0 - arg_pad_size)] + `appOL` concatOL push_codes + | otherwise + = concatOL push_codes + + -- Deallocate parameters after call for ccall; + -- but not for stdcall (callee does it) + -- + -- We have to pop any stack padding we added + -- even if we are doing stdcall, though (#5052) + pop_size | cconv /= StdCallConv = tot_arg_size + | otherwise = arg_pad_size + + call = callinsns `appOL` + toOL ( + (if pop_size==0 then [] else + [ADD II32 (OpImm (ImmInt pop_size)) (OpReg esp)]) + ++ + [DELTA (delta + tot_arg_size)] + ) + -- in + setDeltaNat (delta + tot_arg_size) + + let + -- assign the results, if necessary + assign_code [] = nilOL + assign_code [CmmHinted dest _hint] + | isFloatType ty = + if use_sse2 + then let tmp_amode = AddrBaseIndex (EABaseReg esp) + EAIndexNone + (ImmInt 0) + sz = floatSize w + in toOL [ SUB II32 (OpImm (ImmInt b)) (OpReg esp), + GST sz fake0 tmp_amode, + MOV sz (OpAddr tmp_amode) (OpReg r_dest), + ADD II32 (OpImm (ImmInt b)) (OpReg esp)] + else unitOL (GMOV fake0 r_dest) + | isWord64 ty = toOL [MOV II32 (OpReg eax) (OpReg r_dest), + MOV II32 (OpReg edx) (OpReg r_dest_hi)] + | otherwise = unitOL (MOV (intSize w) (OpReg eax) (OpReg r_dest)) + where + ty = localRegType dest + w = typeWidth ty + b = widthInBytes w + r_dest_hi = getHiVRegFromLo r_dest + r_dest = getRegisterReg use_sse2 (CmmLocal dest) + assign_code many = pprPanic "genCCall.assign_code - too many return values:" (ppr many) + + return (push_code `appOL` + call `appOL` + assign_code dest_regs) + + where + arg_size :: CmmType -> Int -- Width in bytes + arg_size ty = widthInBytes (typeWidth ty) + + roundTo a x | x `mod` a == 0 = x + | otherwise = x + a - (x `mod` a) - -- in - -- deal with static vs dynamic call targets - (callinsns,cconv) <- - case target of - CmmCallee (CmmLit (CmmLabel lbl)) conv - -> -- ToDo: stdcall arg sizes - return (unitOL (CALL (Left fn_imm) []), conv) - where fn_imm = ImmCLbl lbl - CmmCallee expr conv - -> do { (dyn_r, dyn_c) <- getSomeReg expr - ; ASSERT( isWord32 (cmmExprType expr) ) - return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) } - CmmPrim _ - -> panic $ "genCCall: Can't handle CmmPrim call type here, error " - ++ "probably because too many return values." - - let push_code - | arg_pad_size /= 0 - = toOL [SUB II32 (OpImm (ImmInt arg_pad_size)) (OpReg esp), - DELTA (delta0 - arg_pad_size)] - `appOL` concatOL push_codes - | otherwise - = concatOL push_codes - - -- Deallocate parameters after call for ccall; - -- but not for stdcall (callee does it) - -- - -- We have to pop any stack padding we added - -- even if we are doing stdcall, though (#5052) - pop_size | cconv /= StdCallConv = tot_arg_size - | otherwise = arg_pad_size - - call = callinsns `appOL` - toOL ( - (if pop_size==0 then [] else - [ADD II32 (OpImm (ImmInt pop_size)) (OpReg esp)]) - ++ - [DELTA (delta + tot_arg_size)] - ) - -- in - setDeltaNat (delta + tot_arg_size) - - let - -- assign the results, if necessary - assign_code [] = nilOL - assign_code [CmmHinted dest _hint] - | isFloatType ty = - if use_sse2 - then let tmp_amode = AddrBaseIndex (EABaseReg esp) - EAIndexNone - (ImmInt 0) - sz = floatSize w - in toOL [ SUB II32 (OpImm (ImmInt b)) (OpReg esp), - GST sz fake0 tmp_amode, - MOV sz (OpAddr tmp_amode) (OpReg r_dest), - ADD II32 (OpImm (ImmInt b)) (OpReg esp)] - else unitOL (GMOV fake0 r_dest) - | isWord64 ty = toOL [MOV II32 (OpReg eax) (OpReg r_dest), - MOV II32 (OpReg edx) (OpReg r_dest_hi)] - | otherwise = unitOL (MOV (intSize w) (OpReg eax) (OpReg r_dest)) - where - ty = localRegType dest - w = typeWidth ty - b = widthInBytes w - r_dest_hi = getHiVRegFromLo r_dest - r_dest = getRegisterReg use_sse2 (CmmLocal dest) - assign_code many = pprPanic "genCCall.assign_code - too many return values:" (ppr many) - - return (push_code `appOL` - call `appOL` - assign_code dest_regs) - - where - arg_size :: CmmType -> Int -- Width in bytes - arg_size ty = widthInBytes (typeWidth ty) - - roundTo a x | x `mod` a == 0 = x - | otherwise = x + a - (x `mod` a) - - push_arg :: Bool -> HintedCmmActual {-current argument-} - -> NatM InstrBlock -- code - - push_arg use_sse2 (CmmHinted arg _hint) -- we don't need the hints on x86 - | isWord64 arg_ty = do - ChildCode64 code r_lo <- iselExpr64 arg - delta <- getDeltaNat - setDeltaNat (delta - 8) - let - r_hi = getHiVRegFromLo r_lo - -- in - return ( code `appOL` - toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4), - PUSH II32 (OpReg r_lo), DELTA (delta - 8), - DELTA (delta-8)] - ) - - | isFloatType arg_ty = do - (reg, code) <- getSomeReg arg - delta <- getDeltaNat - setDeltaNat (delta-size) - return (code `appOL` - toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp), - DELTA (delta-size), - let addr = AddrBaseIndex (EABaseReg esp) - EAIndexNone - (ImmInt 0) - size = floatSize (typeWidth arg_ty) - in - if use_sse2 - then MOV size (OpReg reg) (OpAddr addr) - else GST size reg addr - ] - ) - - | otherwise = do - (operand, code) <- getOperand arg - delta <- getDeltaNat - setDeltaNat (delta-size) - return (code `snocOL` - PUSH II32 operand `snocOL` - DELTA (delta-size)) - - where - arg_ty = cmmExprType arg - size = arg_size arg_ty -- Byte size - else case (target, dest_regs) of - (CmmPrim op, []) -> - -- void return type prim op - outOfLineCmmOp op Nothing args - (CmmPrim op, [res]) -> - -- we only cope with a single result for foreign calls - outOfLineCmmOp op (Just res) args - _ -> do - -- load up the register arguments - (stack_args, aregs, fregs, load_args_code) - <- load_args args allArgRegs allFPArgRegs nilOL - - let - fp_regs_used = reverse (drop (length fregs) (reverse allFPArgRegs)) - int_regs_used = reverse (drop (length aregs) (reverse allArgRegs)) - arg_regs = [eax] ++ int_regs_used ++ fp_regs_used - -- for annotating the call instruction with - - sse_regs = length fp_regs_used - - tot_arg_size = arg_size * length stack_args - - -- On entry to the called function, %rsp should be aligned - -- on a 16-byte boundary +8 (i.e. the first stack arg after - -- the return address is 16-byte aligned). In STG land - -- %rsp is kept 16-byte aligned (see StgCRun.c), so we just - -- need to make sure we push a multiple of 16-bytes of args, - -- plus the return address, to get the correct alignment. - -- Urg, this is hard. We need to feed the delta back into - -- the arg pushing code. - (real_size, adjust_rsp) <- - if tot_arg_size `rem` 16 == 0 - then return (tot_arg_size, nilOL) - else do -- we need to adjust... - delta <- getDeltaNat - setDeltaNat (delta-8) - return (tot_arg_size+8, toOL [ - SUB II64 (OpImm (ImmInt 8)) (OpReg rsp), - DELTA (delta-8) - ]) - - -- push the stack args, right to left - push_code <- push_args (reverse stack_args) nilOL + push_arg :: Bool -> HintedCmmActual {-current argument-} + -> NatM InstrBlock -- code + + push_arg use_sse2 (CmmHinted arg _hint) -- we don't need the hints on x86 + | isWord64 arg_ty = do + ChildCode64 code r_lo <- iselExpr64 arg + delta <- getDeltaNat + setDeltaNat (delta - 8) + let + r_hi = getHiVRegFromLo r_lo + -- in + return ( code `appOL` + toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4), + PUSH II32 (OpReg r_lo), DELTA (delta - 8), + DELTA (delta-8)] + ) + + | isFloatType arg_ty = do + (reg, code) <- getSomeReg arg + delta <- getDeltaNat + setDeltaNat (delta-size) + return (code `appOL` + toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp), + DELTA (delta-size), + let addr = AddrBaseIndex (EABaseReg esp) + EAIndexNone + (ImmInt 0) + size = floatSize (typeWidth arg_ty) + in + if use_sse2 + then MOV size (OpReg reg) (OpAddr addr) + else GST size reg addr + ] + ) + + | otherwise = do + (operand, code) <- getOperand arg + delta <- getDeltaNat + setDeltaNat (delta-size) + return (code `snocOL` + PUSH II32 operand `snocOL` + DELTA (delta-size)) + + where + arg_ty = cmmExprType arg + size = arg_size arg_ty -- Byte size + +genCCall64 :: CmmCallTarget -- function to call + -> [HintedCmmFormal] -- where to put the result + -> [HintedCmmActual] -- arguments (of mixed type) + -> NatM InstrBlock +genCCall64 target dest_regs args = + case (target, dest_regs) of + (CmmPrim op, []) -> + -- void return type prim op + outOfLineCmmOp op Nothing args + (CmmPrim op, [res]) -> + -- we only cope with a single result for foreign calls + outOfLineCmmOp op (Just res) args + _ -> do + -- load up the register arguments + (stack_args, aregs, fregs, load_args_code) + <- load_args args allArgRegs allFPArgRegs nilOL + + let + fp_regs_used = reverse (drop (length fregs) (reverse allFPArgRegs)) + int_regs_used = reverse (drop (length aregs) (reverse allArgRegs)) + arg_regs = [eax] ++ int_regs_used ++ fp_regs_used + -- for annotating the call instruction with + + sse_regs = length fp_regs_used + + tot_arg_size = arg_size * length stack_args + + -- On entry to the called function, %rsp should be aligned + -- on a 16-byte boundary +8 (i.e. the first stack arg after + -- the return address is 16-byte aligned). In STG land + -- %rsp is kept 16-byte aligned (see StgCRun.c), so we just + -- need to make sure we push a multiple of 16-bytes of args, + -- plus the return address, to get the correct alignment. + -- Urg, this is hard. We need to feed the delta back into + -- the arg pushing code. + (real_size, adjust_rsp) <- + if tot_arg_size `rem` 16 == 0 + then return (tot_arg_size, nilOL) + else do -- we need to adjust... delta <- getDeltaNat + setDeltaNat (delta-8) + return (tot_arg_size+8, toOL [ + SUB II64 (OpImm (ImmInt 8)) (OpReg rsp), + DELTA (delta-8) + ]) + + -- push the stack args, right to left + push_code <- push_args (reverse stack_args) nilOL + delta <- getDeltaNat + + -- deal with static vs dynamic call targets + (callinsns,cconv) <- + case target of + CmmCallee (CmmLit (CmmLabel lbl)) conv + -> -- ToDo: stdcall arg sizes + return (unitOL (CALL (Left fn_imm) arg_regs), conv) + where fn_imm = ImmCLbl lbl + CmmCallee expr conv + -> do (dyn_r, dyn_c) <- getSomeReg expr + return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv) + CmmPrim _ + -> panic $ "genCCall: Can't handle CmmPrim call type here, error " + ++ "probably because too many return values." - -- deal with static vs dynamic call targets - (callinsns,cconv) <- - case target of - CmmCallee (CmmLit (CmmLabel lbl)) conv - -> -- ToDo: stdcall arg sizes - return (unitOL (CALL (Left fn_imm) arg_regs), conv) - where fn_imm = ImmCLbl lbl - CmmCallee expr conv - -> do (dyn_r, dyn_c) <- getSomeReg expr - return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv) - CmmPrim _ - -> panic $ "genCCall: Can't handle CmmPrim call type here, error " - ++ "probably because too many return values." - - let - -- The x86_64 ABI requires us to set %al to the number of SSE2 - -- registers that contain arguments, if the called routine - -- is a varargs function. We don't know whether it's a - -- varargs function or not, so we have to assume it is. - -- - -- It's not safe to omit this assignment, even if the number - -- of SSE2 regs in use is zero. If %al is larger than 8 - -- on entry to a varargs function, seg faults ensue. - assign_eax n = unitOL (MOV II32 (OpImm (ImmInt n)) (OpReg eax)) - - let call = callinsns `appOL` - toOL ( - -- Deallocate parameters after call for ccall; - -- but not for stdcall (callee does it) - (if cconv == StdCallConv || real_size==0 then [] else - [ADD (intSize wordWidth) (OpImm (ImmInt real_size)) (OpReg esp)]) - ++ - [DELTA (delta + real_size)] - ) - -- in - setDeltaNat (delta + real_size) - - let - -- assign the results, if necessary - assign_code [] = nilOL - assign_code [CmmHinted dest _hint] = - case typeWidth rep of - W32 | isFloatType rep -> unitOL (MOV (floatSize W32) (OpReg xmm0) (OpReg r_dest)) - W64 | isFloatType rep -> unitOL (MOV (floatSize W64) (OpReg xmm0) (OpReg r_dest)) - _ -> unitOL (MOV (cmmTypeSize rep) (OpReg rax) (OpReg r_dest)) - where - rep = localRegType dest - r_dest = getRegisterReg True (CmmLocal dest) - assign_code _many = panic "genCCall.assign_code many" - - return (load_args_code `appOL` - adjust_rsp `appOL` - push_code `appOL` - assign_eax sse_regs `appOL` - call `appOL` - assign_code dest_regs) - - where - arg_size = 8 -- always, at the mo - - load_args :: [CmmHinted CmmExpr] - -> [Reg] -- int regs avail for args - -> [Reg] -- FP regs avail for args - -> InstrBlock - -> NatM ([CmmHinted CmmExpr],[Reg],[Reg],InstrBlock) - load_args args [] [] code = return (args, [], [], code) - -- no more regs to use - load_args [] aregs fregs code = return ([], aregs, fregs, code) - -- no more args to push - load_args ((CmmHinted arg hint) : rest) aregs fregs code - | isFloatType arg_rep = - case fregs of - [] -> push_this_arg - (r:rs) -> do - arg_code <- getAnyReg arg - load_args rest aregs rs (code `appOL` arg_code r) - | otherwise = - case aregs of - [] -> push_this_arg - (r:rs) -> do - arg_code <- getAnyReg arg - load_args rest rs fregs (code `appOL` arg_code r) - where - arg_rep = cmmExprType arg - - push_this_arg = do - (args',ars,frs,code') <- load_args rest aregs fregs code - return ((CmmHinted arg hint):args', ars, frs, code') - - push_args [] code = return code - push_args ((CmmHinted arg _):rest) code - | isFloatType arg_rep = do - (arg_reg, arg_code) <- getSomeReg arg - delta <- getDeltaNat - setDeltaNat (delta-arg_size) - let code' = code `appOL` arg_code `appOL` toOL [ - SUB (intSize wordWidth) (OpImm (ImmInt arg_size)) (OpReg rsp) , - DELTA (delta-arg_size), - MOV (floatSize width) (OpReg arg_reg) (OpAddr (spRel 0))] - push_args rest code' - - | otherwise = do - -- we only ever generate word-sized function arguments. Promotion - -- has already happened: our Int8# type is kept sign-extended - -- in an Int#, for example. - ASSERT(width == W64) return () - (arg_op, arg_code) <- getOperand arg - delta <- getDeltaNat - setDeltaNat (delta-arg_size) - let code' = code `appOL` arg_code `appOL` toOL [ - PUSH II64 arg_op, - DELTA (delta-arg_size)] - push_args rest code' - where - arg_rep = cmmExprType arg - width = typeWidth arg_rep + let + -- The x86_64 ABI requires us to set %al to the number of SSE2 + -- registers that contain arguments, if the called routine + -- is a varargs function. We don't know whether it's a + -- varargs function or not, so we have to assume it is. + -- + -- It's not safe to omit this assignment, even if the number + -- of SSE2 regs in use is zero. If %al is larger than 8 + -- on entry to a varargs function, seg faults ensue. + assign_eax n = unitOL (MOV II32 (OpImm (ImmInt n)) (OpReg eax)) + + let call = callinsns `appOL` + toOL ( + -- Deallocate parameters after call for ccall; + -- but not for stdcall (callee does it) + (if cconv == StdCallConv || real_size==0 then [] else + [ADD (intSize wordWidth) (OpImm (ImmInt real_size)) (OpReg esp)]) + ++ + [DELTA (delta + real_size)] + ) + -- in + setDeltaNat (delta + real_size) + + let + -- assign the results, if necessary + assign_code [] = nilOL + assign_code [CmmHinted dest _hint] = + case typeWidth rep of + W32 | isFloatType rep -> unitOL (MOV (floatSize W32) (OpReg xmm0) (OpReg r_dest)) + W64 | isFloatType rep -> unitOL (MOV (floatSize W64) (OpReg xmm0) (OpReg r_dest)) + _ -> unitOL (MOV (cmmTypeSize rep) (OpReg rax) (OpReg r_dest)) + where + rep = localRegType dest + r_dest = getRegisterReg True (CmmLocal dest) + assign_code _many = panic "genCCall.assign_code many" + + return (load_args_code `appOL` + adjust_rsp `appOL` + push_code `appOL` + assign_eax sse_regs `appOL` + call `appOL` + assign_code dest_regs) + + where + arg_size = 8 -- always, at the mo + + load_args :: [CmmHinted CmmExpr] + -> [Reg] -- int regs avail for args + -> [Reg] -- FP regs avail for args + -> InstrBlock + -> NatM ([CmmHinted CmmExpr],[Reg],[Reg],InstrBlock) + load_args args [] [] code = return (args, [], [], code) + -- no more regs to use + load_args [] aregs fregs code = return ([], aregs, fregs, code) + -- no more args to push + load_args ((CmmHinted arg hint) : rest) aregs fregs code + | isFloatType arg_rep = + case fregs of + [] -> push_this_arg + (r:rs) -> do + arg_code <- getAnyReg arg + load_args rest aregs rs (code `appOL` arg_code r) + | otherwise = + case aregs of + [] -> push_this_arg + (r:rs) -> do + arg_code <- getAnyReg arg + load_args rest rs fregs (code `appOL` arg_code r) + where + arg_rep = cmmExprType arg + + push_this_arg = do + (args',ars,frs,code') <- load_args rest aregs fregs code + return ((CmmHinted arg hint):args', ars, frs, code') + + push_args [] code = return code + push_args ((CmmHinted arg _):rest) code + | isFloatType arg_rep = do + (arg_reg, arg_code) <- getSomeReg arg + delta <- getDeltaNat + setDeltaNat (delta-arg_size) + let code' = code `appOL` arg_code `appOL` toOL [ + SUB (intSize wordWidth) (OpImm (ImmInt arg_size)) (OpReg rsp) , + DELTA (delta-arg_size), + MOV (floatSize width) (OpReg arg_reg) (OpAddr (spRel 0))] + push_args rest code' + + | otherwise = do + -- we only ever generate word-sized function arguments. Promotion + -- has already happened: our Int8# type is kept sign-extended + -- in an Int#, for example. + ASSERT(width == W64) return () + (arg_op, arg_code) <- getOperand arg + delta <- getDeltaNat + setDeltaNat (delta-arg_size) + let code' = code `appOL` arg_code `appOL` toOL [ + PUSH II64 arg_op, + DELTA (delta-arg_size)] + push_args rest code' + where + arg_rep = cmmExprType arg + width = typeWidth arg_rep -- | We're willing to inline and unroll memcpy/memset calls that touch -- at most these many bytes. This threshold is the same as the one @@ -2041,11 +2052,11 @@ genSwitch expr ids -- in return code -generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr) +generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop (Alignment, CmmStatics) Instr) generateJumpTableForInstr (JMP_TBL _ ids section lbl) = Just (createJumpTable ids section lbl) generateJumpTableForInstr _ = Nothing -createJumpTable :: [Maybe BlockId] -> Section -> CLabel -> GenCmmTop CmmStatic h g +createJumpTable :: [Maybe BlockId] -> Section -> CLabel -> GenCmmTop (Alignment, CmmStatics) h g createJumpTable ids section lbl = let jumpTable | opt_PIC = @@ -2056,7 +2067,7 @@ createJumpTable ids section lbl where blockLabel = mkAsmTempLabel (getUnique blockid) in map jumpTableEntryRel ids | otherwise = map jumpTableEntry ids - in CmmData section (CmmDataLabel lbl : jumpTable) + in CmmData section (1, Statics lbl jumpTable) -- ----------------------------------------------------------------------------- -- 'condIntReg' and 'condFltReg': condition codes into registers diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index b9c851a859..0e292ac21f 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -25,8 +25,10 @@ import OldCmm import FastString import FastBool import Outputable +import Platform import Constants (rESERVED_C_STACK_BYTES) +import BasicTypes (Alignment) import CLabel import UniqSet import Unique @@ -151,7 +153,6 @@ bit precision. --SDM 1/2003 -} - data Instr -- comment pseudo-op = COMMENT FastString @@ -159,7 +160,7 @@ data Instr -- some static data spat out during code -- generation. Will be extracted before -- pretty-printing. - | LDATA Section [CmmStatic] + | LDATA Section (Alignment, CmmStatics) -- start a new basic block. Useful during -- codegen, removed later. Preceding @@ -603,16 +604,17 @@ x86_patchJumpInstr insn patchF -- ----------------------------------------------------------------------------- -- | Make a spill instruction. x86_mkSpillInstr - :: Reg -- register to spill - -> Int -- current stack delta - -> Int -- spill slot to use - -> Instr + :: Platform + -> Reg -- register to spill + -> Int -- current stack delta + -> Int -- spill slot to use + -> Instr -x86_mkSpillInstr reg delta slot +x86_mkSpillInstr platform reg delta slot = let off = spillSlotToOffset slot in let off_w = (off-delta) `div` IF_ARCH_i386(4,8) - in case targetClassOfReg reg of + in case targetClassOfReg platform reg of RcInteger -> MOV IF_ARCH_i386(II32,II64) (OpReg reg) (OpAddr (spRel off_w)) RcDouble -> GST FF80 reg (spRel off_w) {- RcFloat/RcDouble -} @@ -622,16 +624,17 @@ x86_mkSpillInstr reg delta slot -- | Make a spill reload instruction. x86_mkLoadInstr - :: Reg -- register to load - -> Int -- current stack delta - -> Int -- spill slot to use - -> Instr + :: Platform + -> Reg -- register to load + -> Int -- current stack delta + -> Int -- spill slot to use + -> Instr -x86_mkLoadInstr reg delta slot +x86_mkLoadInstr platform reg delta slot = let off = spillSlotToOffset slot in let off_w = (off-delta) `div` IF_ARCH_i386(4,8) - in case targetClassOfReg reg of + in case targetClassOfReg platform reg of RcInteger -> MOV IF_ARCH_i386(II32,II64) (OpAddr (spRel off_w)) (OpReg reg) RcDouble -> GLD FF80 (spRel off_w) reg {- RcFloat/RcDouble -} @@ -689,12 +692,13 @@ x86_isMetaInstr instr -- have to go via memory. -- x86_mkRegRegMoveInstr - :: Reg - -> Reg - -> Instr + :: Platform + -> Reg + -> Reg + -> Instr -x86_mkRegRegMoveInstr src dst - = case targetClassOfReg src of +x86_mkRegRegMoveInstr platform src dst + = case targetClassOfReg platform src of #if i386_TARGET_ARCH RcInteger -> MOV II32 (OpReg src) (OpReg dst) #else @@ -805,16 +809,24 @@ shortcutJump fn insn = shortcutJump' fn (setEmpty :: BlockSet) insn shortcutJump' _ _ other = other -- Here because it knows about JumpDest +shortcutStatics :: (BlockId -> Maybe JumpDest) -> (Alignment, CmmStatics) -> (Alignment, CmmStatics) +shortcutStatics fn (align, Statics lbl statics) + = (align, Statics lbl $ map (shortcutStatic fn) statics) + -- we need to get the jump tables, so apply the mapping to the entries + -- of a CmmData too. + +shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel +shortcutLabel fn lab + | Just uq <- maybeAsmTemp lab = shortBlockId fn emptyUniqSet (mkBlockId uq) + | otherwise = lab + shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic shortcutStatic fn (CmmStaticLit (CmmLabel lab)) - | Just uq <- maybeAsmTemp lab - = CmmStaticLit (CmmLabel (shortBlockId fn emptyUniqSet (mkBlockId uq))) + = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) - | Just uq <- maybeAsmTemp lbl1 - = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn emptyUniqSet (mkBlockId uq)) lbl2 off) + = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off) -- slightly dodgy, we're ignoring the second label, but this -- works with the way we use CmmLabelDiffOff for jump tables now. - shortcutStatic _ other_static = other_static diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index 769057ae02..a755d839fb 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -31,13 +31,15 @@ import Reg import PprBase +import BasicTypes (Alignment) import OldCmm import CLabel import Unique ( pprUnique, Uniquable(..) ) +import Platform import Pretty import FastString import qualified Outputable -import Outputable (panic, Outputable) +import Outputable (panic, PlatformOutputable) import Data.Word @@ -48,26 +50,31 @@ import Data.Bits -- ----------------------------------------------------------------------------- -- Printing this stuff out -pprNatCmmTop :: NatCmmTop Instr -> Doc -pprNatCmmTop (CmmData section dats) = - pprSectionHeader section $$ vcat (map pprData dats) +pprNatCmmTop :: Platform -> NatCmmTop (Alignment, CmmStatics) Instr -> Doc +pprNatCmmTop platform (CmmData section dats) = + pprSectionHeader section $$ pprDatas platform dats -- special case for split markers: -pprNatCmmTop (CmmProc [] lbl (ListGraph [])) = pprLabel lbl +pprNatCmmTop platform (CmmProc Nothing lbl (ListGraph [])) = pprLabel platform lbl -pprNatCmmTop (CmmProc info lbl (ListGraph blocks)) = + -- special case for code without info table: +pprNatCmmTop platform (CmmProc Nothing lbl (ListGraph blocks)) = pprSectionHeader Text $$ - (if null info then -- blocks guaranteed not null, so label needed - pprLabel lbl - else + pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed + vcat (map (pprBasicBlock platform) blocks) $$ + pprSizeDecl platform lbl + +pprNatCmmTop platform (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blocks)) = + pprSectionHeader Text $$ + ( #if HAVE_SUBSECTIONS_VIA_SYMBOLS - pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl) - <> char ':' $$ + pprCLabel_asm (mkDeadStripPreventer info_lbl) + <> char ':' $$ #endif - vcat (map pprData info) $$ - pprLabel (entryLblToInfoLbl lbl) + vcat (map (pprData platform) info) $$ + pprLabel platform info_lbl ) $$ - vcat (map pprBasicBlock blocks) + vcat (map (pprBasicBlock platform) blocks) -- above: Even the first block gets a label, because with branch-chain -- elimination, it might be the target of a goto. #if HAVE_SUBSECTIONS_VIA_SYMBOLS @@ -77,62 +84,57 @@ pprNatCmmTop (CmmProc info lbl (ListGraph blocks)) = -- from the entry code to a label on the _top_ of of the info table, -- so that the linker will not think it is unreferenced and dead-strip -- it. That's why the label is called a DeadStripPreventer (_dsp). - $$ if not (null info) - then text "\t.long " - <+> pprCLabel_asm (entryLblToInfoLbl lbl) - <+> char '-' - <+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl) - else empty + $$ text "\t.long " + <+> pprCLabel_asm info_lbl + <+> char '-' + <+> pprCLabel_asm (mkDeadStripPreventer info_lbl) #endif - $$ pprSizeDecl (if null info then lbl else entryLblToInfoLbl lbl) + $$ pprSizeDecl platform info_lbl -- | Output the ELF .size directive. -pprSizeDecl :: CLabel -> Doc -#if elf_OBJ_FORMAT -pprSizeDecl lbl = +pprSizeDecl :: Platform -> CLabel -> Doc +pprSizeDecl platform lbl + | osElfTarget (platformOS platform) = ptext (sLit "\t.size") <+> pprCLabel_asm lbl <> ptext (sLit ", .-") <> pprCLabel_asm lbl -#else -pprSizeDecl _ = empty -#endif + | otherwise = empty -pprBasicBlock :: NatBasicBlock Instr -> Doc -pprBasicBlock (BasicBlock blockid instrs) = - pprLabel (mkAsmTempLabel (getUnique blockid)) $$ - vcat (map pprInstr instrs) +pprBasicBlock :: Platform -> NatBasicBlock Instr -> Doc +pprBasicBlock platform (BasicBlock blockid instrs) = + pprLabel platform (mkAsmTempLabel (getUnique blockid)) $$ + vcat (map (pprInstr platform) instrs) -pprData :: CmmStatic -> Doc -pprData (CmmAlign bytes) = pprAlign bytes -pprData (CmmDataLabel lbl) = pprLabel lbl -pprData (CmmString str) = pprASCII str +pprDatas :: Platform -> (Alignment, CmmStatics) -> Doc +pprDatas platform (align, (Statics lbl dats)) + = vcat (pprAlign platform align : pprLabel platform lbl : map (pprData platform) dats) + -- TODO: could remove if align == 1 -#if darwin_TARGET_OS -pprData (CmmUninitialised bytes) = ptext (sLit ".space ") <> int bytes -#else -pprData (CmmUninitialised bytes) = ptext (sLit ".skip ") <> int bytes -#endif +pprData :: Platform -> CmmStatic -> Doc +pprData _ (CmmString str) = pprASCII str -pprData (CmmStaticLit lit) = pprDataItem lit +pprData platform (CmmUninitialised bytes) + | platformOS platform == OSDarwin = ptext (sLit ".space ") <> int bytes + | otherwise = ptext (sLit ".skip ") <> int bytes + +pprData _ (CmmStaticLit lit) = pprDataItem lit pprGloblDecl :: CLabel -> Doc pprGloblDecl lbl | not (externallyVisibleCLabel lbl) = empty | otherwise = ptext (sLit ".globl ") <> pprCLabel_asm lbl -pprTypeAndSizeDecl :: CLabel -> Doc -#if elf_OBJ_FORMAT -pprTypeAndSizeDecl lbl - | not (externallyVisibleCLabel lbl) = empty - | otherwise = ptext (sLit ".type ") <> - pprCLabel_asm lbl <> ptext (sLit ", @object") -#else -pprTypeAndSizeDecl _ - = empty -#endif +pprTypeAndSizeDecl :: Platform -> CLabel -> Doc +pprTypeAndSizeDecl platform lbl + | osElfTarget (platformOS platform) && externallyVisibleCLabel lbl + = ptext (sLit ".type ") <> + pprCLabel_asm lbl <> ptext (sLit ", @object") + | otherwise = empty -pprLabel :: CLabel -> Doc -pprLabel lbl = pprGloblDecl lbl $$ pprTypeAndSizeDecl lbl $$ (pprCLabel_asm lbl <> char ':') +pprLabel :: Platform -> CLabel -> Doc +pprLabel platform lbl = pprGloblDecl lbl + $$ pprTypeAndSizeDecl platform lbl + $$ (pprCLabel_asm lbl <> char ':') pprASCII :: [Word8] -> Doc @@ -142,15 +144,13 @@ pprASCII str do1 :: Word8 -> Doc do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w) -pprAlign :: Int -> Doc - - -pprAlign bytes - = ptext (sLit ".align ") <> int IF_OS_darwin(pow2, bytes) +pprAlign :: Platform -> Int -> Doc +pprAlign platform bytes + = ptext (sLit ".align ") <> int alignment where - -#if darwin_TARGET_OS - pow2 = log2 bytes + alignment = if platformOS platform == OSDarwin + then log2 bytes + else bytes log2 :: Int -> Int -- cache the common ones log2 1 = 0 @@ -158,18 +158,16 @@ pprAlign bytes log2 4 = 2 log2 8 = 3 log2 n = 1 + log2 (n `quot` 2) -#endif -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' -instance Outputable Instr where - ppr instr = Outputable.docToSDoc $ pprInstr instr - +instance PlatformOutputable Instr where + pprPlatform platform instr = Outputable.docToSDoc $ pprInstr platform instr -pprReg :: Size -> Reg -> Doc -pprReg s r +pprReg :: Platform -> Size -> Reg -> Doc +pprReg _ s r = case r of RegReal (RealRegSingle i) -> ppr_reg_no s i RegReal (RealRegPair _ _) -> panic "X86.Ppr: no reg pairs on this arch" @@ -338,8 +336,8 @@ pprImm (ImmConstantDiff a b) = pprImm a <> char '-' -pprAddr :: AddrMode -> Doc -pprAddr (ImmAddr imm off) +pprAddr :: Platform -> AddrMode -> Doc +pprAddr _ (ImmAddr imm off) = let pp_imm = pprImm imm in if (off == 0) then @@ -349,11 +347,11 @@ pprAddr (ImmAddr imm off) else pp_imm <> char '+' <> int off -pprAddr (AddrBaseIndex base index displacement) +pprAddr platform (AddrBaseIndex base index displacement) = let pp_disp = ppr_disp displacement pp_off p = pp_disp <> char '(' <> p <> char ')' - pp_reg r = pprReg archWordSize r + pp_reg r = pprReg platform archWordSize r in case (base, index) of (EABaseNone, EAIndexNone) -> pp_disp @@ -486,23 +484,23 @@ pprDataItem lit -pprInstr :: Instr -> Doc +pprInstr :: Platform -> Instr -> Doc -pprInstr (COMMENT _) = empty -- nuke 'em +pprInstr _ (COMMENT _) = empty -- nuke 'em {- -pprInstr (COMMENT s) = ptext (sLit "# ") <> ftext s +pprInstr _ (COMMENT s) = ptext (sLit "# ") <> ftext s -} -pprInstr (DELTA d) - = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d))) +pprInstr platform (DELTA d) + = pprInstr platform (COMMENT (mkFastString ("\tdelta = " ++ show d))) -pprInstr (NEWBLOCK _) +pprInstr _ (NEWBLOCK _) = panic "PprMach.pprInstr: NEWBLOCK" -pprInstr (LDATA _ _) +pprInstr _ (LDATA _ _) = panic "PprMach.pprInstr: LDATA" {- -pprInstr (SPILL reg slot) +pprInstr _ (SPILL reg slot) = hcat [ ptext (sLit "\tSPILL"), char ' ', @@ -510,7 +508,7 @@ pprInstr (SPILL reg slot) comma, ptext (sLit "SLOT") <> parens (int slot)] -pprInstr (RELOAD slot reg) +pprInstr _ (RELOAD slot reg) = hcat [ ptext (sLit "\tRELOAD"), char ' ', @@ -519,48 +517,48 @@ pprInstr (RELOAD slot reg) pprUserReg reg] -} -pprInstr (MOV size src dst) - = pprSizeOpOp (sLit "mov") size src dst +pprInstr platform (MOV size src dst) + = pprSizeOpOp platform (sLit "mov") size src dst -pprInstr (MOVZxL II32 src dst) = pprSizeOpOp (sLit "mov") II32 src dst +pprInstr platform (MOVZxL II32 src dst) = pprSizeOpOp platform (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 sizes src dst) = pprSizeOpOpCoerce (sLit "movz") sizes II32 src dst +pprInstr platform (MOVZxL sizes src dst) = pprSizeOpOpCoerce platform (sLit "movz") sizes 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 sizes src dst) = pprSizeOpOpCoerce (sLit "movs") sizes archWordSize src dst +pprInstr platform (MOVSxL sizes src dst) = pprSizeOpOpCoerce platform (sLit "movs") sizes archWordSize src dst -- here we do some patching, since the physical registers are only set late -- in the code generation. -pprInstr (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3)) +pprInstr platform (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3)) | reg1 == reg3 - = pprSizeOpOp (sLit "add") size (OpReg reg2) dst + = pprSizeOpOp platform (sLit "add") size (OpReg reg2) dst -pprInstr (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3)) +pprInstr platform (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3)) | reg2 == reg3 - = pprSizeOpOp (sLit "add") size (OpReg reg1) dst + = pprSizeOpOp platform (sLit "add") size (OpReg reg1) dst -pprInstr (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3)) +pprInstr platform (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3)) | reg1 == reg3 - = pprInstr (ADD size (OpImm displ) dst) + = pprInstr platform (ADD size (OpImm displ) dst) -pprInstr (LEA size src dst) = pprSizeOpOp (sLit "lea") size src dst +pprInstr platform (LEA size src dst) = pprSizeOpOp platform (sLit "lea") size src dst -pprInstr (ADD size (OpImm (ImmInt (-1))) dst) - = pprSizeOp (sLit "dec") size dst -pprInstr (ADD size (OpImm (ImmInt 1)) dst) - = pprSizeOp (sLit "inc") size dst -pprInstr (ADD size src dst) - = pprSizeOpOp (sLit "add") size src dst -pprInstr (ADC size src dst) - = pprSizeOpOp (sLit "adc") size src dst -pprInstr (SUB size src dst) = pprSizeOpOp (sLit "sub") size src dst -pprInstr (IMUL size op1 op2) = pprSizeOpOp (sLit "imul") size op1 op2 +pprInstr platform (ADD size (OpImm (ImmInt (-1))) dst) + = pprSizeOp platform (sLit "dec") size dst +pprInstr platform (ADD size (OpImm (ImmInt 1)) dst) + = pprSizeOp platform (sLit "inc") size dst +pprInstr platform (ADD size src dst) + = pprSizeOpOp platform (sLit "add") size src dst +pprInstr platform (ADC size src dst) + = pprSizeOpOp platform (sLit "adc") size src dst +pprInstr platform (SUB size src dst) = pprSizeOpOp platform (sLit "sub") size src dst +pprInstr platform (IMUL size op1 op2) = pprSizeOpOp platform (sLit "imul") size op1 op2 {- A hack. The Intel documentation says that "The two and three operand forms [of IMUL] may also be used with unsigned operands @@ -569,25 +567,25 @@ pprInstr (IMUL size op1 op2) = pprSizeOpOp (sLit "imul") size op1 op2 however, cannot be used to determine if the upper half of the result is non-zero." So there. -} -pprInstr (AND size src dst) = pprSizeOpOp (sLit "and") size src dst -pprInstr (OR size src dst) = pprSizeOpOp (sLit "or") size src dst +pprInstr platform (AND size src dst) = pprSizeOpOp platform (sLit "and") size src dst +pprInstr platform (OR size src dst) = pprSizeOpOp platform (sLit "or") size 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 size src dst) = pprSizeOpOp (sLit "xor") size src dst +pprInstr platform (XOR FF32 src dst) = pprOpOp platform (sLit "xorps") FF32 src dst +pprInstr platform (XOR FF64 src dst) = pprOpOp platform (sLit "xorpd") FF64 src dst +pprInstr platform (XOR size src dst) = pprSizeOpOp platform (sLit "xor") size src dst -pprInstr (NOT size op) = pprSizeOp (sLit "not") size op -pprInstr (NEGI size op) = pprSizeOp (sLit "neg") size op +pprInstr platform (NOT size op) = pprSizeOp platform (sLit "not") size op +pprInstr platform (NEGI size op) = pprSizeOp platform (sLit "neg") size op -pprInstr (SHL size src dst) = pprShift (sLit "shl") size src dst -pprInstr (SAR size src dst) = pprShift (sLit "sar") size src dst -pprInstr (SHR size src dst) = pprShift (sLit "shr") size src dst +pprInstr platform (SHL size src dst) = pprShift platform (sLit "shl") size src dst +pprInstr platform (SAR size src dst) = pprShift platform (sLit "sar") size src dst +pprInstr platform (SHR size src dst) = pprShift platform (sLit "shr") size src dst -pprInstr (BT size imm src) = pprSizeImmOp (sLit "bt") size imm src +pprInstr platform (BT size imm src) = pprSizeImmOp platform (sLit "bt") size imm src -pprInstr (CMP size src dst) - | is_float size = pprSizeOpOp (sLit "ucomi") size src dst -- SSE2 - | otherwise = pprSizeOpOp (sLit "cmp") size src dst +pprInstr platform (CMP size src dst) + | is_float size = pprSizeOpOp platform (sLit "ucomi") size src dst -- SSE2 + | otherwise = pprSizeOpOp platform (sLit "cmp") size src dst where -- This predicate is needed here and nowhere else is_float FF32 = True @@ -595,63 +593,63 @@ pprInstr (CMP size src dst) is_float FF80 = True is_float _ = False -pprInstr (TEST size src dst) = pprSizeOpOp (sLit "test") size src dst -pprInstr (PUSH size op) = pprSizeOp (sLit "push") size op -pprInstr (POP size op) = pprSizeOp (sLit "pop") size op +pprInstr platform (TEST size src dst) = pprSizeOpOp platform (sLit "test") size src dst +pprInstr platform (PUSH size op) = pprSizeOp platform (sLit "push") size op +pprInstr platform (POP size op) = pprSizeOp platform (sLit "pop") size op -- both unused (SDM): -- pprInstr PUSHA = ptext (sLit "\tpushal") -- pprInstr POPA = ptext (sLit "\tpopal") -pprInstr NOP = ptext (sLit "\tnop") -pprInstr (CLTD II32) = ptext (sLit "\tcltd") -pprInstr (CLTD II64) = ptext (sLit "\tcqto") +pprInstr _ NOP = ptext (sLit "\tnop") +pprInstr _ (CLTD II32) = ptext (sLit "\tcltd") +pprInstr _ (CLTD II64) = ptext (sLit "\tcqto") -pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand II8 op) +pprInstr platform (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand platform II8 op) -pprInstr (JXX cond blockid) +pprInstr _ (JXX cond blockid) = pprCondInstr (sLit "j") cond (pprCLabel_asm lab) where lab = mkAsmTempLabel (getUnique blockid) -pprInstr (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm) +pprInstr _ (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm) -pprInstr (JMP (OpImm imm)) = (<>) (ptext (sLit "\tjmp ")) (pprImm imm) -pprInstr (JMP op) = (<>) (ptext (sLit "\tjmp *")) (pprOperand archWordSize op) -pprInstr (JMP_TBL op _ _ _) = pprInstr (JMP op) -pprInstr (CALL (Left imm) _) = (<>) (ptext (sLit "\tcall ")) (pprImm imm) -pprInstr (CALL (Right reg) _) = (<>) (ptext (sLit "\tcall *")) (pprReg archWordSize reg) +pprInstr _ (JMP (OpImm imm)) = (<>) (ptext (sLit "\tjmp ")) (pprImm imm) +pprInstr platform (JMP op) = (<>) (ptext (sLit "\tjmp *")) (pprOperand platform archWordSize op) +pprInstr platform (JMP_TBL op _ _ _) = pprInstr platform (JMP op) +pprInstr _ (CALL (Left imm) _) = (<>) (ptext (sLit "\tcall ")) (pprImm imm) +pprInstr platform (CALL (Right reg) _) = (<>) (ptext (sLit "\tcall *")) (pprReg platform archWordSize reg) -pprInstr (IDIV sz op) = pprSizeOp (sLit "idiv") sz op -pprInstr (DIV sz op) = pprSizeOp (sLit "div") sz op -pprInstr (IMUL2 sz op) = pprSizeOp (sLit "imul") sz op +pprInstr platform (IDIV sz op) = pprSizeOp platform (sLit "idiv") sz op +pprInstr platform (DIV sz op) = pprSizeOp platform (sLit "div") sz op +pprInstr platform (IMUL2 sz op) = pprSizeOp platform (sLit "imul") sz op -- x86_64 only -pprInstr (MUL size op1 op2) = pprSizeOpOp (sLit "mul") size op1 op2 +pprInstr platform (MUL size op1 op2) = pprSizeOpOp platform (sLit "mul") size op1 op2 -pprInstr (FDIV size op1 op2) = pprSizeOpOp (sLit "div") size op1 op2 +pprInstr platform (FDIV size op1 op2) = pprSizeOpOp platform (sLit "div") size op1 op2 -pprInstr (CVTSS2SD from to) = pprRegReg (sLit "cvtss2sd") from to -pprInstr (CVTSD2SS from to) = pprRegReg (sLit "cvtsd2ss") from to -pprInstr (CVTTSS2SIQ sz from to) = pprSizeSizeOpReg (sLit "cvttss2si") FF32 sz from to -pprInstr (CVTTSD2SIQ sz from to) = pprSizeSizeOpReg (sLit "cvttsd2si") FF64 sz from to -pprInstr (CVTSI2SS sz from to) = pprSizeOpReg (sLit "cvtsi2ss") sz from to -pprInstr (CVTSI2SD sz from to) = pprSizeOpReg (sLit "cvtsi2sd") sz from to +pprInstr platform (CVTSS2SD from to) = pprRegReg platform (sLit "cvtss2sd") from to +pprInstr platform (CVTSD2SS from to) = pprRegReg platform (sLit "cvtsd2ss") from to +pprInstr platform (CVTTSS2SIQ sz from to) = pprSizeSizeOpReg platform (sLit "cvttss2si") FF32 sz from to +pprInstr platform (CVTTSD2SIQ sz from to) = pprSizeSizeOpReg platform (sLit "cvttsd2si") FF64 sz from to +pprInstr platform (CVTSI2SS sz from to) = pprSizeOpReg platform (sLit "cvtsi2ss") sz from to +pprInstr platform (CVTSI2SD sz from to) = pprSizeOpReg platform (sLit "cvtsi2sd") sz from to -- FETCHGOT for PIC on ELF platforms -pprInstr (FETCHGOT reg) +pprInstr platform (FETCHGOT reg) = vcat [ ptext (sLit "\tcall 1f"), - hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ], + hcat [ ptext (sLit "1:\tpopl\t"), pprReg platform II32 reg ], hcat [ ptext (sLit "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), "), - pprReg II32 reg ] + pprReg platform 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) +pprInstr platform (FETCHPC reg) = vcat [ ptext (sLit "\tcall 1f"), - hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ] + hcat [ ptext (sLit "1:\tpopl\t"), pprReg platform II32 reg ] ] @@ -661,36 +659,36 @@ pprInstr (FETCHPC reg) -- Simulating a flat register set on the x86 FP stack is tricky. -- you have to free %st(7) before pushing anything on the FP reg stack -- so as to preclude the possibility of a FP stack overflow exception. -pprInstr g@(GMOV src dst) +pprInstr platform g@(GMOV src dst) | src == dst = empty | otherwise - = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1]) + = pprG platform g (hcat [gtab, gpush src 0, gsemi, gpop dst 1]) -- GLD sz addr dst ==> FLDsz addr ; FSTP (dst+1) -pprInstr g@(GLD sz addr dst) - = pprG g (hcat [gtab, text "fld", pprSize_x87 sz, gsp, - pprAddr addr, gsemi, gpop dst 1]) +pprInstr platform g@(GLD sz addr dst) + = pprG platform g (hcat [gtab, text "fld", pprSize_x87 sz, gsp, + pprAddr platform addr, gsemi, gpop dst 1]) -- GST sz src addr ==> FLD dst ; FSTPsz addr -pprInstr g@(GST sz src addr) +pprInstr platform g@(GST sz src addr) | src == fake0 && sz /= FF80 -- fstt instruction doesn't exist - = pprG g (hcat [gtab, - text "fst", pprSize_x87 sz, gsp, pprAddr addr]) + = pprG platform g (hcat [gtab, + text "fst", pprSize_x87 sz, gsp, pprAddr platform addr]) | otherwise - = pprG g (hcat [gtab, gpush src 0, gsemi, - text "fstp", pprSize_x87 sz, gsp, pprAddr addr]) + = pprG platform g (hcat [gtab, gpush src 0, gsemi, + text "fstp", pprSize_x87 sz, gsp, pprAddr platform addr]) -pprInstr g@(GLDZ dst) - = pprG g (hcat [gtab, text "fldz ; ", gpop dst 1]) -pprInstr g@(GLD1 dst) - = pprG g (hcat [gtab, text "fld1 ; ", gpop dst 1]) +pprInstr platform g@(GLDZ dst) + = pprG platform g (hcat [gtab, text "fldz ; ", gpop dst 1]) +pprInstr platform g@(GLD1 dst) + = pprG platform g (hcat [gtab, text "fld1 ; ", gpop dst 1]) -pprInstr (GFTOI src dst) - = pprInstr (GDTOI src dst) +pprInstr platform (GFTOI src dst) + = pprInstr platform (GDTOI src dst) -pprInstr g@(GDTOI src dst) - = pprG g (vcat [ +pprInstr platform g@(GDTOI src dst) + = pprG platform g (vcat [ hcat [gtab, text "subl $8, %esp ; fnstcw 4(%esp)"], hcat [gtab, gpush src 0], hcat [gtab, text "movzwl 4(%esp), ", reg, @@ -701,20 +699,20 @@ pprInstr g@(GDTOI src dst) hcat [gtab, text "addl $8, %esp"] ]) where - reg = pprReg II32 dst + reg = pprReg platform II32 dst -pprInstr (GITOF src dst) - = pprInstr (GITOD src dst) +pprInstr platform (GITOF src dst) + = pprInstr platform (GITOD src dst) -pprInstr g@(GITOD src dst) - = pprG g (hcat [gtab, text "pushl ", pprReg II32 src, - text " ; fildl (%esp) ; ", - gpop dst 1, text " ; addl $4,%esp"]) +pprInstr platform g@(GITOD src dst) + = pprG platform g (hcat [gtab, text "pushl ", pprReg platform II32 src, + text " ; fildl (%esp) ; ", + gpop dst 1, text " ; addl $4,%esp"]) -pprInstr g@(GDTOF src dst) - = pprG g (vcat [gtab <> gpush src 0, - gtab <> text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ;", - gtab <> gpop dst 1]) +pprInstr platform g@(GDTOF src dst) + = pprG platform g (vcat [gtab <> gpush src 0, + gtab <> text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ;", + gtab <> gpop dst 1]) {- Gruesome swamp follows. If you're unfortunate enough to have ventured this far into the jungle AND you give a Rat's Ass (tm) what's going @@ -754,9 +752,9 @@ pprInstr g@(GDTOF src dst) decb %al -- if (incomparable || different) then (%al == 0, ZF=1) else (%al == 0xFF, ZF=0) -} -pprInstr g@(GCMP cond src1 src2) +pprInstr platform g@(GCMP cond src1 src2) | case cond of { NE -> True; _ -> False } - = pprG g (vcat [ + = pprG platform g (vcat [ hcat [gtab, text "pushl %eax ; ",gpush src1 0], hcat [gtab, text "fcomp ", greg src2 1, text "; fstsw %ax ; sahf ; setpe %ah"], @@ -764,7 +762,7 @@ pprInstr g@(GCMP cond src1 src2) text "orb %ah,%al ; decb %al ; popl %eax"] ]) | otherwise - = pprG g (vcat [ + = pprG platform g (vcat [ hcat [gtab, text "pushl %eax ; ",gpush src1 0], hcat [gtab, text "fcomp ", greg src2 1, text "; fstsw %ax ; sahf ; setpo %ah"], @@ -786,95 +784,95 @@ pprInstr g@(GCMP cond src1 src2) -- there should be no others -pprInstr g@(GABS _ src dst) - = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1]) +pprInstr platform g@(GABS _ src dst) + = pprG platform g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1]) -pprInstr g@(GNEG _ src dst) - = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1]) +pprInstr platform g@(GNEG _ src dst) + = pprG platform g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1]) -pprInstr g@(GSQRT sz src dst) - = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$ - hcat [gtab, gcoerceto sz, gpop dst 1]) +pprInstr platform g@(GSQRT sz src dst) + = pprG platform g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$ + hcat [gtab, gcoerceto sz, gpop dst 1]) -pprInstr g@(GSIN sz l1 l2 src dst) - = pprG g (pprTrigOp "fsin" False l1 l2 src dst sz) +pprInstr platform g@(GSIN sz l1 l2 src dst) + = pprG platform g (pprTrigOp "fsin" False l1 l2 src dst sz) -pprInstr g@(GCOS sz l1 l2 src dst) - = pprG g (pprTrigOp "fcos" False l1 l2 src dst sz) +pprInstr platform g@(GCOS sz l1 l2 src dst) + = pprG platform g (pprTrigOp "fcos" False l1 l2 src dst sz) -pprInstr g@(GTAN sz l1 l2 src dst) - = pprG g (pprTrigOp "fptan" True l1 l2 src dst sz) +pprInstr platform g@(GTAN sz l1 l2 src dst) + = pprG platform g (pprTrigOp "fptan" True l1 l2 src dst sz) -- In the translations for GADD, GMUL, GSUB and GDIV, -- the first two cases are mere optimisations. The otherwise clause -- generates correct code under all circumstances. -pprInstr g@(GADD _ src1 src2 dst) +pprInstr platform g@(GADD _ src1 src2 dst) | src1 == dst - = pprG g (text "\t#GADD-xxxcase1" $$ - hcat [gtab, gpush src2 0, - text " ; faddp %st(0),", greg src1 1]) + = pprG platform g (text "\t#GADD-xxxcase1" $$ + hcat [gtab, gpush src2 0, + text " ; faddp %st(0),", greg src1 1]) | src2 == dst - = pprG g (text "\t#GADD-xxxcase2" $$ - hcat [gtab, gpush src1 0, - text " ; faddp %st(0),", greg src2 1]) + = pprG platform g (text "\t#GADD-xxxcase2" $$ + hcat [gtab, gpush src1 0, + text " ; faddp %st(0),", greg src2 1]) | otherwise - = pprG g (hcat [gtab, gpush src1 0, - text " ; fadd ", greg src2 1, text ",%st(0)", - gsemi, gpop dst 1]) + = pprG platform g (hcat [gtab, gpush src1 0, + text " ; fadd ", greg src2 1, text ",%st(0)", + gsemi, gpop dst 1]) -pprInstr g@(GMUL _ src1 src2 dst) +pprInstr platform g@(GMUL _ src1 src2 dst) | src1 == dst - = pprG g (text "\t#GMUL-xxxcase1" $$ - hcat [gtab, gpush src2 0, - text " ; fmulp %st(0),", greg src1 1]) + = pprG platform g (text "\t#GMUL-xxxcase1" $$ + hcat [gtab, gpush src2 0, + text " ; fmulp %st(0),", greg src1 1]) | src2 == dst - = pprG g (text "\t#GMUL-xxxcase2" $$ - hcat [gtab, gpush src1 0, - text " ; fmulp %st(0),", greg src2 1]) + = pprG platform g (text "\t#GMUL-xxxcase2" $$ + hcat [gtab, gpush src1 0, + text " ; fmulp %st(0),", greg src2 1]) | otherwise - = pprG g (hcat [gtab, gpush src1 0, - text " ; fmul ", greg src2 1, text ",%st(0)", - gsemi, gpop dst 1]) + = pprG platform g (hcat [gtab, gpush src1 0, + text " ; fmul ", greg src2 1, text ",%st(0)", + gsemi, gpop dst 1]) -pprInstr g@(GSUB _ src1 src2 dst) +pprInstr platform g@(GSUB _ src1 src2 dst) | src1 == dst - = pprG g (text "\t#GSUB-xxxcase1" $$ - hcat [gtab, gpush src2 0, - text " ; fsubrp %st(0),", greg src1 1]) + = pprG platform g (text "\t#GSUB-xxxcase1" $$ + hcat [gtab, gpush src2 0, + text " ; fsubrp %st(0),", greg src1 1]) | src2 == dst - = pprG g (text "\t#GSUB-xxxcase2" $$ - hcat [gtab, gpush src1 0, - text " ; fsubp %st(0),", greg src2 1]) + = pprG platform g (text "\t#GSUB-xxxcase2" $$ + hcat [gtab, gpush src1 0, + text " ; fsubp %st(0),", greg src2 1]) | otherwise - = pprG g (hcat [gtab, gpush src1 0, - text " ; fsub ", greg src2 1, text ",%st(0)", - gsemi, gpop dst 1]) + = pprG platform g (hcat [gtab, gpush src1 0, + text " ; fsub ", greg src2 1, text ",%st(0)", + gsemi, gpop dst 1]) -pprInstr g@(GDIV _ src1 src2 dst) +pprInstr platform g@(GDIV _ src1 src2 dst) | src1 == dst - = pprG g (text "\t#GDIV-xxxcase1" $$ - hcat [gtab, gpush src2 0, - text " ; fdivrp %st(0),", greg src1 1]) + = pprG platform g (text "\t#GDIV-xxxcase1" $$ + hcat [gtab, gpush src2 0, + text " ; fdivrp %st(0),", greg src1 1]) | src2 == dst - = pprG g (text "\t#GDIV-xxxcase2" $$ - hcat [gtab, gpush src1 0, - text " ; fdivp %st(0),", greg src2 1]) + = pprG platform g (text "\t#GDIV-xxxcase2" $$ + hcat [gtab, gpush src1 0, + text " ; fdivp %st(0),", greg src2 1]) | otherwise - = pprG g (hcat [gtab, gpush src1 0, - text " ; fdiv ", greg src2 1, text ",%st(0)", - gsemi, gpop dst 1]) + = pprG platform g (hcat [gtab, gpush src1 0, + text " ; fdiv ", greg src2 1, text ",%st(0)", + gsemi, gpop dst 1]) -pprInstr GFREE +pprInstr _ GFREE = vcat [ ptext (sLit "\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)"), ptext (sLit "\tffree %st(4) ;ffree %st(5)") ] -pprInstr _ +pprInstr _ _ = panic "X86.Ppr.pprInstr: no match" @@ -953,49 +951,49 @@ gregno (RegReal (RealRegSingle i)) = i gregno _ = --pprPanic "gregno" (ppr other) 999 -- bogus; only needed for debug printing -pprG :: Instr -> Doc -> Doc -pprG fake actual - = (char '#' <> pprGInstr fake) $$ actual +pprG :: Platform -> Instr -> Doc -> Doc +pprG platform fake actual + = (char '#' <> pprGInstr platform fake) $$ actual -pprGInstr :: Instr -> Doc -pprGInstr (GMOV src dst) = pprSizeRegReg (sLit "gmov") FF64 src dst -pprGInstr (GLD sz src dst) = pprSizeAddrReg (sLit "gld") sz src dst -pprGInstr (GST sz src dst) = pprSizeRegAddr (sLit "gst") sz src dst +pprGInstr :: Platform -> Instr -> Doc +pprGInstr platform (GMOV src dst) = pprSizeRegReg platform (sLit "gmov") FF64 src dst +pprGInstr platform (GLD sz src dst) = pprSizeAddrReg platform (sLit "gld") sz src dst +pprGInstr platform (GST sz src dst) = pprSizeRegAddr platform (sLit "gst") sz src dst -pprGInstr (GLDZ dst) = pprSizeReg (sLit "gldz") FF64 dst -pprGInstr (GLD1 dst) = pprSizeReg (sLit "gld1") FF64 dst +pprGInstr platform (GLDZ dst) = pprSizeReg platform (sLit "gldz") FF64 dst +pprGInstr platform (GLD1 dst) = pprSizeReg platform (sLit "gld1") FF64 dst -pprGInstr (GFTOI src dst) = pprSizeSizeRegReg (sLit "gftoi") FF32 II32 src dst -pprGInstr (GDTOI src dst) = pprSizeSizeRegReg (sLit "gdtoi") FF64 II32 src dst +pprGInstr platform (GFTOI src dst) = pprSizeSizeRegReg platform (sLit "gftoi") FF32 II32 src dst +pprGInstr platform (GDTOI src dst) = pprSizeSizeRegReg platform (sLit "gdtoi") FF64 II32 src dst -pprGInstr (GITOF src dst) = pprSizeSizeRegReg (sLit "gitof") II32 FF32 src dst -pprGInstr (GITOD src dst) = pprSizeSizeRegReg (sLit "gitod") II32 FF64 src dst -pprGInstr (GDTOF src dst) = pprSizeSizeRegReg (sLit "gdtof") FF64 FF32 src dst +pprGInstr platform (GITOF src dst) = pprSizeSizeRegReg platform (sLit "gitof") II32 FF32 src dst +pprGInstr platform (GITOD src dst) = pprSizeSizeRegReg platform (sLit "gitod") II32 FF64 src dst +pprGInstr platform (GDTOF src dst) = pprSizeSizeRegReg platform (sLit "gdtof") FF64 FF32 src dst -pprGInstr (GCMP co src dst) = pprCondRegReg (sLit "gcmp_") FF64 co src dst -pprGInstr (GABS sz src dst) = pprSizeRegReg (sLit "gabs") sz src dst -pprGInstr (GNEG sz src dst) = pprSizeRegReg (sLit "gneg") sz src dst -pprGInstr (GSQRT sz src dst) = pprSizeRegReg (sLit "gsqrt") sz src dst -pprGInstr (GSIN sz _ _ src dst) = pprSizeRegReg (sLit "gsin") sz src dst -pprGInstr (GCOS sz _ _ src dst) = pprSizeRegReg (sLit "gcos") sz src dst -pprGInstr (GTAN sz _ _ src dst) = pprSizeRegReg (sLit "gtan") sz src dst +pprGInstr platform (GCMP co src dst) = pprCondRegReg platform (sLit "gcmp_") FF64 co src dst +pprGInstr platform (GABS sz src dst) = pprSizeRegReg platform (sLit "gabs") sz src dst +pprGInstr platform (GNEG sz src dst) = pprSizeRegReg platform (sLit "gneg") sz src dst +pprGInstr platform (GSQRT sz src dst) = pprSizeRegReg platform (sLit "gsqrt") sz src dst +pprGInstr platform (GSIN sz _ _ src dst) = pprSizeRegReg platform (sLit "gsin") sz src dst +pprGInstr platform (GCOS sz _ _ src dst) = pprSizeRegReg platform (sLit "gcos") sz src dst +pprGInstr platform (GTAN sz _ _ src dst) = pprSizeRegReg platform (sLit "gtan") sz src dst -pprGInstr (GADD sz src1 src2 dst) = pprSizeRegRegReg (sLit "gadd") sz src1 src2 dst -pprGInstr (GSUB sz src1 src2 dst) = pprSizeRegRegReg (sLit "gsub") sz src1 src2 dst -pprGInstr (GMUL sz src1 src2 dst) = pprSizeRegRegReg (sLit "gmul") sz src1 src2 dst -pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg (sLit "gdiv") sz src1 src2 dst +pprGInstr platform (GADD sz src1 src2 dst) = pprSizeRegRegReg platform (sLit "gadd") sz src1 src2 dst +pprGInstr platform (GSUB sz src1 src2 dst) = pprSizeRegRegReg platform (sLit "gsub") sz src1 src2 dst +pprGInstr platform (GMUL sz src1 src2 dst) = pprSizeRegRegReg platform (sLit "gmul") sz src1 src2 dst +pprGInstr platform (GDIV sz src1 src2 dst) = pprSizeRegRegReg platform (sLit "gdiv") sz src1 src2 dst -pprGInstr _ = panic "X86.Ppr.pprGInstr: no match" +pprGInstr _ _ = panic "X86.Ppr.pprGInstr: no match" pprDollImm :: Imm -> Doc pprDollImm i = ptext (sLit "$") <> pprImm i -pprOperand :: Size -> Operand -> Doc -pprOperand s (OpReg r) = pprReg s r -pprOperand _ (OpImm i) = pprDollImm i -pprOperand _ (OpAddr ea) = pprAddr ea +pprOperand :: Platform -> Size -> Operand -> Doc +pprOperand platform s (OpReg r) = pprReg platform s r +pprOperand _ _ (OpImm i) = pprDollImm i +pprOperand platform _ (OpAddr ea) = pprAddr platform ea pprMnemonic_ :: LitString -> Doc @@ -1008,164 +1006,164 @@ pprMnemonic name size = char '\t' <> ptext name <> pprSize size <> space -pprSizeImmOp :: LitString -> Size -> Imm -> Operand -> Doc -pprSizeImmOp name size imm op1 +pprSizeImmOp :: Platform -> LitString -> Size -> Imm -> Operand -> Doc +pprSizeImmOp platform name size imm op1 = hcat [ pprMnemonic name size, char '$', pprImm imm, comma, - pprOperand size op1 + pprOperand platform size op1 ] -pprSizeOp :: LitString -> Size -> Operand -> Doc -pprSizeOp name size op1 +pprSizeOp :: Platform -> LitString -> Size -> Operand -> Doc +pprSizeOp platform name size op1 = hcat [ pprMnemonic name size, - pprOperand size op1 + pprOperand platform size op1 ] -pprSizeOpOp :: LitString -> Size -> Operand -> Operand -> Doc -pprSizeOpOp name size op1 op2 +pprSizeOpOp :: Platform -> LitString -> Size -> Operand -> Operand -> Doc +pprSizeOpOp platform name size op1 op2 = hcat [ pprMnemonic name size, - pprOperand size op1, + pprOperand platform size op1, comma, - pprOperand size op2 + pprOperand platform size op2 ] -pprOpOp :: LitString -> Size -> Operand -> Operand -> Doc -pprOpOp name size op1 op2 +pprOpOp :: Platform -> LitString -> Size -> Operand -> Operand -> Doc +pprOpOp platform name size op1 op2 = hcat [ pprMnemonic_ name, - pprOperand size op1, + pprOperand platform size op1, comma, - pprOperand size op2 + pprOperand platform size op2 ] -pprSizeReg :: LitString -> Size -> Reg -> Doc -pprSizeReg name size reg1 +pprSizeReg :: Platform -> LitString -> Size -> Reg -> Doc +pprSizeReg platform name size reg1 = hcat [ pprMnemonic name size, - pprReg size reg1 + pprReg platform size reg1 ] -pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc -pprSizeRegReg name size reg1 reg2 +pprSizeRegReg :: Platform -> LitString -> Size -> Reg -> Reg -> Doc +pprSizeRegReg platform name size reg1 reg2 = hcat [ pprMnemonic name size, - pprReg size reg1, + pprReg platform size reg1, comma, - pprReg size reg2 + pprReg platform size reg2 ] -pprRegReg :: LitString -> Reg -> Reg -> Doc -pprRegReg name reg1 reg2 +pprRegReg :: Platform -> LitString -> Reg -> Reg -> Doc +pprRegReg platform name reg1 reg2 = hcat [ pprMnemonic_ name, - pprReg archWordSize reg1, + pprReg platform archWordSize reg1, comma, - pprReg archWordSize reg2 + pprReg platform archWordSize reg2 ] -pprSizeOpReg :: LitString -> Size -> Operand -> Reg -> Doc -pprSizeOpReg name size op1 reg2 +pprSizeOpReg :: Platform -> LitString -> Size -> Operand -> Reg -> Doc +pprSizeOpReg platform name size op1 reg2 = hcat [ pprMnemonic name size, - pprOperand size op1, + pprOperand platform size op1, comma, - pprReg archWordSize reg2 + pprReg platform archWordSize reg2 ] -pprCondRegReg :: LitString -> Size -> Cond -> Reg -> Reg -> Doc -pprCondRegReg name size cond reg1 reg2 +pprCondRegReg :: Platform -> LitString -> Size -> Cond -> Reg -> Reg -> Doc +pprCondRegReg platform name size cond reg1 reg2 = hcat [ char '\t', ptext name, pprCond cond, space, - pprReg size reg1, + pprReg platform size reg1, comma, - pprReg size reg2 + pprReg platform size reg2 ] -pprSizeSizeRegReg :: LitString -> Size -> Size -> Reg -> Reg -> Doc -pprSizeSizeRegReg name size1 size2 reg1 reg2 +pprSizeSizeRegReg :: Platform -> LitString -> Size -> Size -> Reg -> Reg -> Doc +pprSizeSizeRegReg platform name size1 size2 reg1 reg2 = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space, - pprReg size1 reg1, + pprReg platform size1 reg1, comma, - pprReg size2 reg2 + pprReg platform size2 reg2 ] -pprSizeSizeOpReg :: LitString -> Size -> Size -> Operand -> Reg -> Doc -pprSizeSizeOpReg name size1 size2 op1 reg2 +pprSizeSizeOpReg :: Platform -> LitString -> Size -> Size -> Operand -> Reg -> Doc +pprSizeSizeOpReg platform name size1 size2 op1 reg2 = hcat [ pprMnemonic name size2, - pprOperand size1 op1, + pprOperand platform size1 op1, comma, - pprReg size2 reg2 + pprReg platform size2 reg2 ] -pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc -pprSizeRegRegReg name size reg1 reg2 reg3 +pprSizeRegRegReg :: Platform -> LitString -> Size -> Reg -> Reg -> Reg -> Doc +pprSizeRegRegReg platform name size reg1 reg2 reg3 = hcat [ pprMnemonic name size, - pprReg size reg1, + pprReg platform size reg1, comma, - pprReg size reg2, + pprReg platform size reg2, comma, - pprReg size reg3 + pprReg platform size reg3 ] -pprSizeAddrReg :: LitString -> Size -> AddrMode -> Reg -> Doc -pprSizeAddrReg name size op dst +pprSizeAddrReg :: Platform -> LitString -> Size -> AddrMode -> Reg -> Doc +pprSizeAddrReg platform name size op dst = hcat [ pprMnemonic name size, - pprAddr op, + pprAddr platform op, comma, - pprReg size dst + pprReg platform size dst ] -pprSizeRegAddr :: LitString -> Size -> Reg -> AddrMode -> Doc -pprSizeRegAddr name size src op +pprSizeRegAddr :: Platform -> LitString -> Size -> Reg -> AddrMode -> Doc +pprSizeRegAddr platform name size src op = hcat [ pprMnemonic name size, - pprReg size src, + pprReg platform size src, comma, - pprAddr op + pprAddr platform op ] -pprShift :: LitString -> Size -> Operand -> Operand -> Doc -pprShift name size src dest +pprShift :: Platform -> LitString -> Size -> Operand -> Operand -> Doc +pprShift platform name size src dest = hcat [ pprMnemonic name size, - pprOperand II8 src, -- src is 8-bit sized + pprOperand platform II8 src, -- src is 8-bit sized comma, - pprOperand size dest + pprOperand platform size dest ] -pprSizeOpOpCoerce :: LitString -> Size -> Size -> Operand -> Operand -> Doc -pprSizeOpOpCoerce name size1 size2 op1 op2 +pprSizeOpOpCoerce :: Platform -> LitString -> Size -> Size -> Operand -> Operand -> Doc +pprSizeOpOpCoerce platform name size1 size2 op1 op2 = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space, - pprOperand size1 op1, + pprOperand platform size1 op1, comma, - pprOperand size2 op2 + pprOperand platform size2 op2 ] diff --git a/compiler/nativeGen/X86/RegInfo.hs b/compiler/nativeGen/X86/RegInfo.hs index 0f6613d00d..c09ebc5b15 100644 --- a/compiler/nativeGen/X86/RegInfo.hs +++ b/compiler/nativeGen/X86/RegInfo.hs @@ -28,20 +28,17 @@ mkVirtualReg u size FF80 -> VirtualRegD u _other -> VirtualRegI u -regDotColor :: RealReg -> SDoc -regDotColor reg - = let Just str = lookupUFM regColors reg - in text str +regDotColor :: Platform -> RealReg -> SDoc +regDotColor platform reg + = let Just str = lookupUFM (regColors platform) reg + in text str -regColors :: UniqFM [Char] -regColors = listToUFM (normalRegColors ++ fpRegColors) +regColors :: Platform -> UniqFM [Char] +regColors platform = listToUFM (normalRegColors platform ++ fpRegColors) --- TODO: We shouldn't be using defaultTargetPlatform here. --- We should be passing DynFlags in instead, and looking at --- its targetPlatform. - -normalRegColors :: [(Reg,String)] -normalRegColors = case platformArch defaultTargetPlatform of +normalRegColors :: Platform -> [(Reg,String)] +normalRegColors platform + = case platformArch platform of ArchX86 -> [ (eax, "#00ff00") , (ebx, "#0000ff") , (ecx, "#00ffff") |