Skip to content

GitLab

Glasgow Haskell Compiler
Glasgow Haskell Compiler
Commit 730301c6 authored by Ian Lynagh's avatar Ian Lynagh
Browse files
Options

Remove more defaultTargetPlatform uses

parent 5c718b15
Show whitespace changes
Inline Side-by-side
Showing with 358 additions and 315 deletions
compiler/nativeGen/AsmCodeGen.lhs
View file @ 730301c6
......@@ -245,7 +245,7 @@ nativeCodeGen' dflags ncgImpl h us cmms
dumpIfSet_dyn dflags
Opt_D_dump_asm_conflicts "Register conflict graph"
$ Color.dotGraph
targetRegDotColor
(targetRegDotColor platform)
(Color.trivColorable platform
(targetVirtualRegSqueeze platform)
(targetRealRegSqueeze platform))
......@@ -386,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
......
compiler/nativeGen/Instruction.hs
View file @ 730301c6
......@@ -14,6 +14,7 @@ import Reg
import BlockId
import OldCmm
import Platform
-- | Holds a list of source and destination registers used by a
-- particular instruction.
......@@ -103,7 +104,8 @@ class Instruction instr where
-- | An instruction to spill a register into a spill slot.
mkSpillInstr
:: Reg -- ^ the reg to spill
:: Platform
-> Reg -- ^ the reg to spill
-> Int -- ^ the current stack delta
-> Int -- ^ spill slot to use
-> instr
......@@ -111,7 +113,8 @@ class Instruction instr where
-- | An instruction to reload a register from a spill slot.
mkLoadInstr
:: Reg -- ^ the reg to reload.
:: Platform
-> Reg -- ^ the reg to reload.
-> Int -- ^ the current stack delta
-> Int -- ^ the spill slot to use
-> instr
......@@ -137,7 +140,8 @@ class Instruction instr where
-- | Copy the value in a register to another one.
-- Must work for all register classes.
mkRegRegMoveInstr
:: Reg -- ^ source register
:: Platform
-> Reg -- ^ source register
-> Reg -- ^ destination register
-> instr
......
compiler/nativeGen/NCGMonad.hs
View file @ 730301c6
......@@ -132,14 +132,16 @@ getNewLabelNat
getNewRegNat :: Size -> NatM Reg
getNewRegNat rep
= do u <- getUniqueNat
return (RegVirtual $ targetMkVirtualReg u rep)
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
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)
......
compiler/nativeGen/PPC/CodeGen.hs
View file @ 730301c6
......@@ -404,11 +404,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
......
compiler/nativeGen/PPC/Instr.hs
View file @ 730301c6
......@@ -32,6 +32,7 @@ import OldCmm
import FastString
import CLabel
import Outputable
import Platform
import FastBool
--------------------------------------------------------------------------------
......@@ -52,7 +53,7 @@ instance Instruction Instr where
mkLoadInstr = ppc_mkLoadInstr
takeDeltaInstr = ppc_takeDeltaInstr
isMetaInstr = ppc_isMetaInstr
mkRegRegMoveInstr = ppc_mkRegRegMoveInstr
mkRegRegMoveInstr _ = ppc_mkRegRegMoveInstr
takeRegRegMoveInstr = ppc_takeRegRegMoveInstr
mkJumpInstr = ppc_mkJumpInstr
......@@ -346,15 +347,16 @@ ppc_patchJumpInstr insn patchF
-- | An instruction to spill a register into a spill slot.
ppc_mkSpillInstr
:: Reg -- register to spill
:: 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
:: 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"
......
compiler/nativeGen/PPC/Ppr.hs
View file @ 730301c6
......@@ -58,12 +58,12 @@ pprNatCmmTop _ (CmmData section dats) =
pprNatCmmTop _ (CmmProc Nothing lbl (ListGraph [])) = pprLabel lbl
-- special case for code without an info table:
pprNatCmmTop _ (CmmProc Nothing lbl (ListGraph blocks)) =
pprNatCmmTop platform (CmmProc Nothing lbl (ListGraph blocks)) =
pprSectionHeader Text $$
pprLabel lbl $$ -- blocks guaranteed not null, so label needed
vcat (map pprBasicBlock blocks)
vcat (map (pprBasicBlock platform) blocks)
pprNatCmmTop _ (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blocks)) =
pprNatCmmTop platform (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blocks)) =
pprSectionHeader Text $$
(
#if HAVE_SUBSECTIONS_VIA_SYMBOLS
......@@ -73,7 +73,7 @@ pprNatCmmTop _ (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blo
vcat (map pprData info) $$
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
......@@ -90,10 +90,10 @@ pprNatCmmTop _ (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blo
#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)
......@@ -143,7 +143,7 @@ pprASCII str
-- pprInstr: print an 'Instr'
instance PlatformOutputable Instr where
pprPlatform _ instr = Outputable.docToSDoc $ pprInstr instr
pprPlatform platform instr = Outputable.docToSDoc $ pprInstr platform instr
pprReg :: Reg -> Doc
......@@ -337,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',
......@@ -364,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',
......@@ -373,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
......@@ -391,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
......@@ -409,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,
......@@ -420,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,
......@@ -431,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',
......@@ -439,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',
......@@ -447,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',
......@@ -459,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',
......@@ -475,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',
......@@ -491,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,
......@@ -500,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),
......@@ -513,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',
......@@ -550,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 ],
......@@ -570,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',
......@@ -580,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',
......@@ -596,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,
......@@ -606,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 ", "),
......@@ -625,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
......@@ -642,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 ", "),
......@@ -654,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
......
compiler/nativeGen/RegAlloc/Graph/Main.hs
View file @ 730301c6
......@@ -165,7 +165,7 @@ regAlloc_spin
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
......
compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
View file @ 730301c6
......@@ -39,6 +39,7 @@ import UniqFM
import Unique
import State
import Outputable
import Platform
import Data.List
import Data.Maybe
......@@ -54,20 +55,21 @@ type Slot = Int
-- | Clean out unneeded spill\/reloads from this top level thing.
cleanSpills
:: Instruction instr
=> LiveCmmTop statics instr -> LiveCmmTop statics 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
=> 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
:: Platform
-> Instruction instr
=> 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
......@@ -136,36 +139,37 @@ cleanBlockForward (BasicBlock blockId instrs)
--
cleanForward
:: Instruction instr
=> BlockId -- ^ the block that we're currently in
=> 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 []
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)