summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ghc/compiler/nativeGen/AbsCStixGen.lhs21
-rw-r--r--ghc/compiler/nativeGen/AsmCodeGen.lhs2
-rw-r--r--ghc/compiler/nativeGen/AsmRegAlloc.lhs11
-rw-r--r--ghc/compiler/nativeGen/MachCode.lhs18
-rw-r--r--ghc/compiler/nativeGen/MachMisc.lhs16
-rw-r--r--ghc/compiler/nativeGen/PprMach.lhs7
-rw-r--r--ghc/compiler/nativeGen/RegAllocInfo.lhs17
-rw-r--r--ghc/compiler/nativeGen/Stix.lhs29
-rw-r--r--ghc/compiler/nativeGen/StixMacro.lhs4
9 files changed, 80 insertions, 45 deletions
diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs
index ebc7aeeb06..2a3fe2d905 100644
--- a/ghc/compiler/nativeGen/AbsCStixGen.lhs
+++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs
@@ -181,7 +181,7 @@ Here we handle top-level things, like @CCodeBlock@s and
[ StLabel tmp_lbl
, StAssign PtrRep stgSp
(StIndex PtrRep stgSp (StInt (-1)))
- , StJump (StInd WordRep stgSp)
+ , StJump NoDestInfo (StInd WordRep stgSp)
])
gentopcode absC
@@ -348,22 +348,22 @@ which varies depending on whether we're profiling etc.
\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)
- = returnUs (\xs -> StJump (a2stix dest) : xs)
+ = returnUs (\xs -> StJump NoDestInfo (a2stix dest) : xs)
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))
- = 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],
@@ -506,14 +506,14 @@ be tuned.)
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
)
- `thenUs` \ alt_code ->
+ `thenUs` \ alt_code ->
gencode absC `thenUs` \ dflt_code ->
returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
@@ -557,8 +557,9 @@ already finish with a jump to the join point.
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
diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs
index bbbc760ed3..02348192d6 100644
--- a/ghc/compiler/nativeGen/AsmCodeGen.lhs
+++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs
@@ -224,7 +224,7 @@ stixConFold (StInd pk addr) = StInd pk (stixConFold addr)
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)
diff --git a/ghc/compiler/nativeGen/AsmRegAlloc.lhs b/ghc/compiler/nativeGen/AsmRegAlloc.lhs
index 162befc912..02c564918d 100644
--- a/ghc/compiler/nativeGen/AsmRegAlloc.lhs
+++ b/ghc/compiler/nativeGen/AsmRegAlloc.lhs
@@ -771,8 +771,8 @@ find_flow_edges insns
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);
@@ -785,6 +785,13 @@ find_flow_edges insns
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,
diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs
index 57bdc39251..0d7dcb8c7d 100644
--- a/ghc/compiler/nativeGen/MachCode.lhs
+++ b/ghc/compiler/nativeGen/MachCode.lhs
@@ -26,7 +26,7 @@ import PrimRep ( isFloatingRep, PrimRep(..) )
import PrimOp ( PrimOp(..) )
import CallConv ( cCallConv )
import Stix ( getNatLabelNCG, StixTree(..),
- StixReg(..), CodeSegment(..),
+ StixReg(..), CodeSegment(..), DestInfo,
pprStixTree, ppStixReg,
NatM, thenNat, returnNat, mapNat,
mapAndUnzipNat, mapAccumLNat,
@@ -68,7 +68,7 @@ stmt2Instrs stmt = case stmt of
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
@@ -1982,7 +1982,7 @@ branch instruction. Other CLabels are assumed to be far away.
register allocator.
\begin{code}
-genJump :: StixTree{-the branch target-} -> NatM InstrBlock
+genJump :: DestInfo -> StixTree{-the branch target-} -> NatM InstrBlock
#if alpha_TARGET_ARCH
@@ -1993,7 +1993,7 @@ genJump (StCLbl lbl)
target = ImmCLbl lbl
genJump tree
- = getRegister tree `thenNat` \ register ->
+ = getRegister tree `thenNat` \ register ->
getNewRegNCG PtrRep `thenNat` \ tmp ->
let
dst = registerName register pv
@@ -2009,17 +2009,17 @@ genJump tree
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if i386_TARGET_ARCH
-genJump (StInd pk mem)
+genJump dsts (StInd pk mem)
= 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))
-genJump tree
+genJump dsts tree
| maybeToBool imm
- = returnNat (unitOL (JMP (OpImm target)))
+ = returnNat (unitOL (JMP dsts (OpImm target)))
| otherwise
= getRegister tree `thenNat` \ register ->
@@ -2028,7 +2028,7 @@ genJump tree
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
diff --git a/ghc/compiler/nativeGen/MachMisc.lhs b/ghc/compiler/nativeGen/MachMisc.lhs
index 8f5c168ce3..116b8f94f0 100644
--- a/ghc/compiler/nativeGen/MachMisc.lhs
+++ b/ghc/compiler/nativeGen/MachMisc.lhs
@@ -50,7 +50,7 @@ import MachRegs ( stgReg, callerSaves, RegLoc(..),
# 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 )
@@ -529,7 +529,7 @@ Hence GLDZ and GLD1. Bwahahahahahahaha!
-- Jumping around.
- | JMP Operand -- target
+ | JMP DestInfo Operand -- possible dests, target
| JXX Cond CLabel -- target
| CALL Imm
@@ -552,10 +552,14 @@ i386_insert_ffrees insns
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,
diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs
index 5235a5c854..24808961ee 100644
--- a/ghc/compiler/nativeGen/PprMach.lhs
+++ b/ghc/compiler/nativeGen/PprMach.lhs
@@ -959,10 +959,9 @@ pprInstr (SETCC cond op) = pprCondInstr SLIT("set") cond (pprOperand B op)
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.
diff --git a/ghc/compiler/nativeGen/RegAllocInfo.lhs b/ghc/compiler/nativeGen/RegAllocInfo.lhs
index 392371ed89..f0e7afe407 100644
--- a/ghc/compiler/nativeGen/RegAllocInfo.lhs
+++ b/ghc/compiler/nativeGen/RegAllocInfo.lhs
@@ -39,7 +39,7 @@ module RegAllocInfo (
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
@@ -251,7 +251,7 @@ regUsage instr = case instr of
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 [] []
@@ -481,6 +481,7 @@ data InsnFuture
| 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"
@@ -513,11 +514,17 @@ insnFuture insn
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
- JMP (OpImm (ImmCLbl clbl)) | isAsmTemp clbl -> Branch clbl
+ JMP NoDestInfo (OpImm (ImmCLbl clbl)) | isAsmTemp clbl -> Branch clbl
-- unconditional jump to non-local label
- JMP lbl -> NoFuture
+ JMP NoDestInfo lbl -> NoFuture
+
+ -- be extra-paranoid
+ JMP _ _ -> panic "insnFuture(x86): JMP wierdness"
boring -> Next
@@ -638,7 +645,7 @@ patchRegs instr env = case instr of
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)
diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs
index e222cdc6d5..1223490855 100644
--- a/ghc/compiler/nativeGen/Stix.lhs
+++ b/ghc/compiler/nativeGen/Stix.lhs
@@ -7,6 +7,7 @@ module Stix (
CodeSegment(..), StixReg(..), StixTree(..), StixTreeList,
pprStixTrees, pprStixTree, ppStixReg,
stixCountTempUses, stixSubst,
+ DestInfo(..),
stgBaseReg, stgNode, stgSp, stgSu, stgSpLim,
stgHp, stgHpLim, stgTagReg, stgR9, stgR10,
@@ -81,10 +82,15 @@ data StixTree
| 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 StixTree
+ | StJump DestInfo StixTree
-- A fall-through, from slow to fast
@@ -120,6 +126,16 @@ data StixTree
| StComment FAST_STRING
+-- 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 [
@@ -129,6 +145,7 @@ pprStixTrees ts
]
paren t = char '(' <> t <> char ')'
+brack t = char '[' <> t <> char ']'
pprStixTree :: StixTree -> SDoc
pprStixTree t
@@ -149,7 +166,7 @@ pprStixTree t
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)
@@ -260,7 +277,7 @@ stixCountTempUses u t
StIndex pk t1 t2 -> qq t1 + qq t2
StInd pk t1 -> qq t1
StAssign pk t1 t2 -> qq t1 + qq t2
- StJump t1 -> qq t1
+ StJump dsts t1 -> qq t1
StCondJump lbl t1 -> qq t1
StData pk ts -> sum (map qq ts)
StPrim op ts -> sum (map qq ts)
@@ -304,7 +321,7 @@ stixMapUniques f t
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)
diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs
index 415d7c8c5d..7127883ad3 100644
--- a/ghc/compiler/nativeGen/StixMacro.lhs
+++ b/ghc/compiler/nativeGen/StixMacro.lhs
@@ -212,7 +212,7 @@ stg_update_PAP = StCLbl mkStgUpdatePAPLabel
updatePAP, stackOverflow :: StixTree
-updatePAP = StJump stg_update_PAP
+updatePAP = StJump NoDestInfo stg_update_PAP
stackOverflow = StCall SLIT("StackOverflow") cCallConv VoidRep []
\end{code}
@@ -338,7 +338,7 @@ checkCode macro args assts
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))
View Lorry Controller Status