Make the register allocator deal properly with switch tables.
Previously, it didn't calculate the correct flow edges away from the
indirect jump (in fact it didn't reckon there were any flow edges
leaving it :) which makes a nonsense of the live variable analysis in
the branches.
A jump insn can now optionally be annotated with a list of destination
labels, and if so, the register allocator creates flow edges to all of
them.
Jump tables are now re-enabled. They remain disabled for 4.08.1,
since we aren't fixing the problem properly on that branch.
I assume this problem wasn't exposed by the old register allocator
because of the live-range-approximation hacks used in it. Since it
was undocumented, we'll never know.
Sparc builds will now break until I fix them.
[ StLabel tmp_lbl
, StAssign PtrRep stgSp
(StIndex PtrRep stgSp (StInt (-1)))
[ StLabel tmp_lbl
, StAssign PtrRep stgSp
(StIndex PtrRep stgSp (StInt (-1)))
- , StJump (StInd WordRep stgSp)
+ , StJump NoDestInfo (StInd WordRep stgSp)
\begin{code}
gencode (CJump dest)
\begin{code}
gencode (CJump dest)
- = returnUs (\xs -> StJump (a2stix dest) : xs)
+ = returnUs (\xs -> StJump NoDestInfo (a2stix dest) : xs)
gencode (CFallThrough (CLbl lbl _))
= returnUs (\xs -> StFallThrough lbl : xs)
gencode (CReturn dest DirectReturn)
gencode (CFallThrough (CLbl lbl _))
= returnUs (\xs -> StFallThrough lbl : xs)
gencode (CReturn dest DirectReturn)
- = returnUs (\xs -> StJump (a2stix dest) : xs)
+ = returnUs (\xs -> StJump NoDestInfo (a2stix dest) : xs)
gencode (CReturn table (StaticVectoredReturn n))
gencode (CReturn table (StaticVectoredReturn n))
- = returnUs (\xs -> StJump dest : xs)
+ = returnUs (\xs -> StJump NoDestInfo dest : xs)
where
dest = StInd PtrRep (StIndex PtrRep (a2stix table)
(StInt (toInteger (-n-fixedItblSize-1))))
gencode (CReturn table (DynamicVectoredReturn am))
where
dest = StInd PtrRep (StIndex PtrRep (a2stix table)
(StInt (toInteger (-n-fixedItblSize-1))))
gencode (CReturn table (DynamicVectoredReturn am))
- = returnUs (\xs -> StJump dest : xs)
+ = returnUs (\xs -> StJump NoDestInfo dest : xs)
where
dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am],
where
dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am],
highest = if floating then targetMaxDouble else targetMaxInt
in
(
highest = if floating then targetMaxDouble else targetMaxInt
in
(
- if False && -- jump tables disabled for now until the register allocator is
- -- fixed to cope with them --SDM 18/8/2000
- not floating && choices > 4 && highTag - lowTag < toInteger (2 * choices) then
+ if not floating && choices > 4
+ && highTag - lowTag < toInteger (2 * choices)
+ then
mkJumpTable am' sortedAlts lowTag highTag udlbl
else
mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
)
mkJumpTable am' sortedAlts lowTag highTag udlbl
else
mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
)
gencode absC `thenUs` \ dflt_code ->
returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
gencode absC `thenUs` \ dflt_code ->
returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt (toInteger highTag)])
offset = StPrim IntSubOp [am, StInt lowTag]
cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt (toInteger highTag)])
offset = StPrim IntSubOp [am, StInt lowTag]
+ dsts = DestInfo (dflt : map fst branches)
- jump = StJump (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
+ jump = StJump dsts (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
tlbl = StLabel utlbl
table = StData PtrRep (mkTable branches [lowTag..highTag] [])
in
tlbl = StLabel utlbl
table = StData PtrRep (mkTable branches [lowTag..highTag] [])
in
stixConFold (StAssign pk dst src)
= StAssign pk (stixConFold dst) (stixConFold src)
stixConFold (StAssign pk dst src)
= StAssign pk (stixConFold dst) (stixConFold src)
-stixConFold (StJump addr) = StJump (stixConFold addr)
+stixConFold (StJump dsts addr) = StJump dsts (stixConFold addr)
stixConFold (StCondJump addr test)
= StCondJump addr (stixConFold test)
stixConFold (StCondJump addr test)
= StCondJump addr (stixConFold test)
Branch lab -- jmps to lab; add fe i_num -> i_target
-> let i_target = find_label lab
in
Branch lab -- jmps to lab; add fe i_num -> i_target
-> let i_target = find_label lab
in
- mk_succ_map i_num_1 ((i_num, [i_target]): rsucc_map)
- is
+ mk_succ_map i_num_1 ((i_num, [i_target]): rsucc_map) is
+
NextOrBranch lab
| null is -- jmps to label, or falls through, and this is
-- the last insn (a meaningless scenario);
NextOrBranch lab
| null is -- jmps to label, or falls through, and this is
-- the last insn (a meaningless scenario);
in
mk_succ_map i_num_1 ((i_num, [i_num_1, i_target]):rsucc_map)
is
in
mk_succ_map i_num_1 ((i_num, [i_num_1, i_target]):rsucc_map)
is
+ MultiFuture labels
+ -> -- A jump, whose targets are listed explicitly.
+ -- (Generated from table-based switch translations).
+ -- Add fes i_num -> x for each x in labels
+ let is_target = nub (map find_label labels)
+ in
+ mk_succ_map i_num_1 ((i_num, is_target):rsucc_map) is
-- Third phase: invert the successor map to get the predecessor
-- map, using an algorithm which is quadratic in the worst case,
-- Third phase: invert the successor map to get the predecessor
-- map, using an algorithm which is quadratic in the worst case,
import PrimOp ( PrimOp(..) )
import CallConv ( cCallConv )
import Stix ( getNatLabelNCG, StixTree(..),
import PrimOp ( PrimOp(..) )
import CallConv ( cCallConv )
import Stix ( getNatLabelNCG, StixTree(..),
- StixReg(..), CodeSegment(..),
+ StixReg(..), CodeSegment(..), DestInfo,
pprStixTree, ppStixReg,
NatM, thenNat, returnNat, mapNat,
mapAndUnzipNat, mapAccumLNat,
pprStixTree, ppStixReg,
NatM, thenNat, returnNat, mapNat,
mapAndUnzipNat, mapAccumLNat,
StLabel lab -> returnNat (unitOL (LABEL lab))
StLabel lab -> returnNat (unitOL (LABEL lab))
- StJump arg -> genJump (derefDLL arg)
+ StJump dsts arg -> genJump dsts (derefDLL arg)
StCondJump lab arg -> genCondJump lab (derefDLL arg)
-- A call returning void, ie one done for its side-effects
StCondJump lab arg -> genCondJump lab (derefDLL arg)
-- A call returning void, ie one done for its side-effects
register allocator.
\begin{code}
register allocator.
\begin{code}
-genJump :: StixTree{-the branch target-} -> NatM InstrBlock
+genJump :: DestInfo -> StixTree{-the branch target-} -> NatM InstrBlock
target = ImmCLbl lbl
genJump tree
target = ImmCLbl lbl
genJump tree
- = getRegister tree `thenNat` \ register ->
+ = getRegister tree `thenNat` \ register ->
getNewRegNCG PtrRep `thenNat` \ tmp ->
let
dst = registerName register pv
getNewRegNCG PtrRep `thenNat` \ tmp ->
let
dst = registerName register pv
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if i386_TARGET_ARCH
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if i386_TARGET_ARCH
+genJump dsts (StInd pk mem)
= getAmode mem `thenNat` \ amode ->
let
code = amodeCode amode
target = amodeAddr amode
in
= getAmode mem `thenNat` \ amode ->
let
code = amodeCode amode
target = amodeAddr amode
in
- returnNat (code `snocOL` JMP (OpAddr target))
+ returnNat (code `snocOL` JMP dsts (OpAddr target))
- = returnNat (unitOL (JMP (OpImm target)))
+ = returnNat (unitOL (JMP dsts (OpImm target)))
| otherwise
= getRegister tree `thenNat` \ register ->
| otherwise
= getRegister tree `thenNat` \ register ->
code = registerCode register tmp
target = registerName register tmp
in
code = registerCode register tmp
target = registerName register tmp
in
- returnNat (code `snocOL` JMP (OpReg target))
+ returnNat (code `snocOL` JMP dsts (OpReg target))
where
imm = maybeImm tree
target = case imm of Just x -> x
where
imm = maybeImm tree
target = case imm of Just x -> x
# endif
)
import PrimRep ( PrimRep(..) )
# endif
)
import PrimRep ( PrimRep(..) )
-import Stix ( StixTree(..), StixReg(..), CodeSegment )
+import Stix ( StixTree(..), StixReg(..), CodeSegment, DestInfo(..) )
import Panic ( panic )
import GlaExts ( word2Int#, int2Word#, shiftRL#, and#, (/=#) )
import Outputable ( pprPanic, ppr )
import Panic ( panic )
import GlaExts ( word2Int#, int2Word#, shiftRL#, and#, (/=#) )
import Outputable ( pprPanic, ppr )
- | JMP Operand -- target
+ | JMP DestInfo Operand -- possible dests, target
| JXX Cond CLabel -- target
| CALL Imm
| JXX Cond CLabel -- target
| CALL Imm
ffree_before_nonlocal_transfers insn
= case insn of
ffree_before_nonlocal_transfers insn
= case insn of
- CALL _ -> [GFREE, insn]
- JMP (OpImm (ImmCLbl clbl)) | isAsmTemp clbl -> [insn]
- JMP _ -> [GFREE, insn]
- other -> [insn]
+ CALL _ -> [GFREE, insn]
+ -- Jumps to immediate labels are local
+ JMP _ (OpImm (ImmCLbl clbl)) | isAsmTemp clbl -> [insn]
+ -- If a jump mentions dests, it is a local jump thru
+ -- a case table.
+ JMP (DestInfo _) _ -> [insn]
+ JMP _ _ -> [GFREE, insn]
+ other -> [insn]
-- if you ever add a new FP insn to the fake x86 FP insn set,
-- if you ever add a new FP insn to the fake x86 FP insn set,
pprInstr (JXX cond lab) = pprCondInstr SLIT("j") cond (pprCLabel_asm lab)
pprInstr (JXX cond lab) = pprCondInstr SLIT("j") cond (pprCLabel_asm lab)
-pprInstr (JMP (OpImm imm)) = (<>) (ptext SLIT("\tjmp ")) (pprImm imm)
-pprInstr (JMP op) = (<>) (ptext SLIT("\tjmp *")) (pprOperand L op)
-pprInstr (CALL imm)
- = (<>) (ptext SLIT("\tcall ")) (pprImm imm)
+pprInstr (JMP dsts (OpImm imm)) = (<>) (ptext SLIT("\tjmp ")) (pprImm imm)
+pprInstr (JMP dsts op) = (<>) (ptext SLIT("\tjmp *")) (pprOperand L op)
+pprInstr (CALL imm) = (<>) (ptext SLIT("\tcall ")) (pprImm imm)
-- Simulating a flat register set on the x86 FP stack is tricky.
-- Simulating a flat register set on the x86 FP stack is tricky.
import List ( partition, sort )
import MachMisc
import MachRegs
import List ( partition, sort )
import MachMisc
import MachRegs
+import Stix ( DestInfo(..) )
import CLabel ( pprCLabel_asm, isAsmTemp, CLabel{-instance Ord-} )
import FiniteMap ( addToFM, lookupFM, FiniteMap )
import Outputable
import CLabel ( pprCLabel_asm, isAsmTemp, CLabel{-instance Ord-} )
import FiniteMap ( addToFM, lookupFM, FiniteMap )
import Outputable
CMP sz src dst -> mkRU (use_R src ++ use_R dst) []
SETCC cond op -> mkRU [] (def_W op)
JXX cond lbl -> mkRU [] []
CMP sz src dst -> mkRU (use_R src ++ use_R dst) []
SETCC cond op -> mkRU [] (def_W op)
JXX cond lbl -> mkRU [] []
- JMP op -> mkRU (use_R op) []
+ JMP dsts op -> mkRU (use_R op) []
CALL imm -> mkRU [] callClobberedRegs
CLTD -> mkRU [eax] [edx]
NOP -> mkRU [] []
CALL imm -> mkRU [] callClobberedRegs
CLTD -> mkRU [eax] [edx]
NOP -> mkRU [] []
| Next -- falls through to next insn
| Branch CLabel -- unconditional branch to the label
| NextOrBranch CLabel -- conditional branch to the label
| Next -- falls through to next insn
| Branch CLabel -- unconditional branch to the label
| NextOrBranch CLabel -- conditional branch to the label
+ | MultiFuture [CLabel] -- multiple specific futures
--instance Outputable InsnFuture where
-- ppr NoFuture = text "NoFuture"
--instance Outputable InsnFuture where
-- ppr NoFuture = text "NoFuture"
JXX _ clbl | isAsmTemp clbl -> NextOrBranch clbl
JXX _ _ -> panic "insnFuture: conditional jump to non-local label"
JXX _ clbl | isAsmTemp clbl -> NextOrBranch clbl
JXX _ _ -> panic "insnFuture: conditional jump to non-local label"
+ -- If the insn says what its dests are, use em!
+ JMP (DestInfo dsts) _ -> MultiFuture dsts
+
-- unconditional jump to local label
-- unconditional jump to local label
- JMP (OpImm (ImmCLbl clbl)) | isAsmTemp clbl -> Branch clbl
+ JMP NoDestInfo (OpImm (ImmCLbl clbl)) | isAsmTemp clbl -> Branch clbl
-- unconditional jump to non-local label
-- unconditional jump to non-local label
+ JMP NoDestInfo lbl -> NoFuture
+
+ -- be extra-paranoid
+ JMP _ _ -> panic "insnFuture(x86): JMP wierdness"
PUSH sz op -> patch1 (PUSH sz) op
POP sz op -> patch1 (POP sz) op
SETCC cond op -> patch1 (SETCC cond) op
PUSH sz op -> patch1 (PUSH sz) op
POP sz op -> patch1 (POP sz) op
SETCC cond op -> patch1 (SETCC cond) op
- JMP op -> patch1 JMP op
+ JMP dsts op -> patch1 (JMP dsts) op
GMOV src dst -> GMOV (env src) (env dst)
GLD sz src dst -> GLD sz (lookupAddr src) (env dst)
GMOV src dst -> GMOV (env src) (env dst)
GLD sz src dst -> GLD sz (lookupAddr src) (env dst)
CodeSegment(..), StixReg(..), StixTree(..), StixTreeList,
pprStixTrees, pprStixTree, ppStixReg,
stixCountTempUses, stixSubst,
CodeSegment(..), StixReg(..), StixTree(..), StixTreeList,
pprStixTrees, pprStixTree, ppStixReg,
stixCountTempUses, stixSubst,
stgBaseReg, stgNode, stgSp, stgSu, stgSpLim,
stgHp, stgHpLim, stgTagReg, stgR9, stgR10,
stgBaseReg, stgNode, stgSp, stgSu, stgSpLim,
stgHp, stgHpLim, stgTagReg, stgR9, stgR10,
| StFunBegin CLabel
| StFunEnd CLabel
| StFunBegin CLabel
| StFunEnd CLabel
- -- An unconditional jump. This instruction is terminal.
- -- Dynamic targets are allowed
+ -- An unconditional jump. This instruction may or may not jump
+ -- out of the register allocation domain (basic block, more or
+ -- less). For correct register allocation when this insn is used
+ -- to jump through a jump table, we optionally allow a list of
+ -- the exact targets to be attached, so that the allocator can
+ -- easily construct the exact flow edges leaving this insn.
+ -- Dynamic targets are allowed.
+ | StJump DestInfo StixTree
-- A fall-through, from slow to fast
-- A fall-through, from slow to fast
+-- used by insnFuture in RegAllocInfo.lhs
+data DestInfo
+ = NoDestInfo -- no supplied dests; infer from context
+ | DestInfo [CLabel] -- precisely these dests and no others
+
+pprDests :: DestInfo -> SDoc
+pprDests NoDestInfo = text "NoDestInfo"
+pprDests (DestInfo dsts) = brack (hsep (map pprCLabel dsts))
+
+
pprStixTrees :: [StixTree] -> SDoc
pprStixTrees ts
= vcat [
pprStixTrees :: [StixTree] -> SDoc
pprStixTrees ts
= vcat [
]
paren t = char '(' <> t <> char ')'
]
paren t = char '(' <> t <> char ')'
+brack t = char '[' <> t <> char ']'
pprStixTree :: StixTree -> SDoc
pprStixTree t
pprStixTree :: StixTree -> SDoc
pprStixTree t
StLabel ll -> pprCLabel ll <+> char ':'
StFunBegin ll -> char ' ' $$ paren (text "FunBegin" <+> pprCLabel ll)
StFunEnd ll -> paren (text "FunEnd" <+> pprCLabel ll)
StLabel ll -> pprCLabel ll <+> char ':'
StFunBegin ll -> char ' ' $$ paren (text "FunBegin" <+> pprCLabel ll)
StFunEnd ll -> paren (text "FunEnd" <+> pprCLabel ll)
- StJump t -> paren (text "Jump" <+> pprStixTree t)
+ StJump dsts t -> paren (text "Jump" <+> pprDests dsts <+> pprStixTree t)
StFallThrough ll -> paren (text "FallThru" <+> pprCLabel ll)
StCondJump l t -> paren (text "JumpC" <+> pprCLabel l
<+> pprStixTree t)
StFallThrough ll -> paren (text "FallThru" <+> pprCLabel ll)
StCondJump l t -> paren (text "JumpC" <+> pprCLabel l
<+> pprStixTree t)
StIndex pk t1 t2 -> qq t1 + qq t2
StInd pk t1 -> qq t1
StAssign pk t1 t2 -> qq t1 + qq t2
StIndex pk t1 t2 -> qq t1 + qq t2
StInd pk t1 -> qq t1
StAssign pk t1 t2 -> qq t1 + qq t2
+ StJump dsts t1 -> qq t1
StCondJump lbl t1 -> qq t1
StData pk ts -> sum (map qq ts)
StPrim op ts -> sum (map qq ts)
StCondJump lbl t1 -> qq t1
StData pk ts -> sum (map qq ts)
StPrim op ts -> sum (map qq ts)
StIndex pk t1 t2 -> StIndex pk (qq t1) (qq t2)
StInd pk t1 -> StInd pk (qq t1)
StAssign pk t1 t2 -> StAssign pk (qq t1) (qq t2)
StIndex pk t1 t2 -> StIndex pk (qq t1) (qq t2)
StInd pk t1 -> StInd pk (qq t1)
StAssign pk t1 t2 -> StAssign pk (qq t1) (qq t2)
- StJump t1 -> StJump (qq t1)
+ StJump dsts t1 -> StJump dsts (qq t1)
StCondJump lbl t1 -> StCondJump lbl (qq t1)
StData pk ts -> StData pk (map qq ts)
StPrim op ts -> StPrim op (map qq ts)
StCondJump lbl t1 -> StCondJump lbl (qq t1)
StData pk ts -> StData pk (map qq ts)
StPrim op ts -> StPrim op (map qq ts)
updatePAP, stackOverflow :: StixTree
updatePAP, stackOverflow :: StixTree
-updatePAP = StJump stg_update_PAP
+updatePAP = StJump NoDestInfo stg_update_PAP
stackOverflow = StCall SLIT("StackOverflow") cCallConv VoidRep []
\end{code}
stackOverflow = StCall SLIT("StackOverflow") cCallConv VoidRep []
\end{code}
mkStJump_to_GCentry :: String -> StixTree
mkStJump_to_GCentry gcname
-- | opt_Static
mkStJump_to_GCentry :: String -> StixTree
mkStJump_to_GCentry gcname
-- | opt_Static
- = StJump (StCLbl (mkRtsGCEntryLabel gcname))
+ = StJump NoDestInfo (StCLbl (mkRtsGCEntryLabel gcname))
-- | otherwise -- it's in a different DLL
-- = StJump (StInd PtrRep (StLitLbl True sdoc))
-- | otherwise -- it's in a different DLL
-- = StJump (StInd PtrRep (StLitLbl True sdoc))