[project @ 2000-08-21 15:40:14 by sewardj]

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.

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))