Merge branch 'master' of darcs.haskell.org:/srv/darcs//ghc

7 files changed, 161 insertions, 153 deletions

diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index 7c314ae84b..656af96b0e 100644
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -56,7 +56,6 @@ import OldPprCmm
 import CLabel
 
 import UniqFM
-import Unique           ( Unique, getUnique )
 import UniqSupply
 import DynFlags
 import Util
@@ -270,7 +269,7 @@ nativeCodeGen' dflags ncgImpl h us cmms
                 | dopt Opt_SplitObjs dflags = split_marker : tops
                 | otherwise                 = tops
 
-        split_marker = CmmProc Nothing mkSplitMarkerLabel (ListGraph [])
+        split_marker = CmmProc mapEmpty mkSplitMarkerLabel (ListGraph [])
 
 
 cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr)
@@ -599,7 +598,7 @@ sequenceTop
 
 sequenceTop _       top@(CmmData _ _) = top
 sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) =
-  CmmProc info lbl (ListGraph $ ncgMakeFarBranches ncgImpl $ sequenceBlocks blocks)
+  CmmProc info lbl (ListGraph $ ncgMakeFarBranches ncgImpl $ sequenceBlocks info blocks)
 
 -- The algorithm is very simple (and stupid): we make a graph out of
 -- the blocks where there is an edge from one block to another iff the
@@ -613,12 +612,13 @@ sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) =
 
 sequenceBlocks
         :: Instruction instr
-        => [NatBasicBlock instr]
+        => BlockEnv i
+        -> [NatBasicBlock instr]
         -> [NatBasicBlock instr]
 
-sequenceBlocks [] = []
-sequenceBlocks (entry:blocks) =
-  seqBlocks (mkNode entry : reverse (flattenSCCs (sccBlocks blocks)))
+sequenceBlocks _ [] = []
+sequenceBlocks infos (entry:blocks) =
+  seqBlocks infos (mkNode entry : reverse (flattenSCCs (sccBlocks blocks)))
   -- the first block is the entry point ==> it must remain at the start.
 
 
@@ -626,8 +626,8 @@ sccBlocks
         :: Instruction instr
         => [NatBasicBlock instr]
         -> [SCC ( NatBasicBlock instr
-                , Unique
-                , [Unique])]
+                , BlockId
+                , [BlockId])]
 
 sccBlocks blocks = stronglyConnCompFromEdgedVerticesR (map mkNode blocks)
 
@@ -635,30 +635,32 @@ sccBlocks blocks = stronglyConnCompFromEdgedVerticesR (map mkNode blocks)
 -- the block, and only if it has a single destination.
 getOutEdges
         :: Instruction instr
-        => [instr] -> [Unique]
+        => [instr] -> [BlockId]
 
 getOutEdges instrs
         = case jumpDestsOfInstr (last instrs) of
-                [one] -> [getUnique one]
+                [one] -> [one]
                 _many -> []
 
 mkNode :: (Instruction t)
        => GenBasicBlock t
-       -> (GenBasicBlock t, Unique, [Unique])
-mkNode block@(BasicBlock id instrs) = (block, getUnique id, getOutEdges instrs)
-
-seqBlocks :: (Eq t) => [(GenBasicBlock t1, t, [t])] -> [GenBasicBlock t1]
-seqBlocks [] = []
-seqBlocks ((block,_,[]) : rest)
-  = block : seqBlocks rest
-seqBlocks ((block@(BasicBlock id instrs),_,[next]) : rest)
-  | can_fallthrough = BasicBlock id (init instrs) : seqBlocks rest'
-  | otherwise       = block : seqBlocks rest'
+       -> (GenBasicBlock t, BlockId, [BlockId])
+mkNode block@(BasicBlock id instrs) = (block, id, getOutEdges instrs)
+
+seqBlocks :: BlockEnv i -> [(GenBasicBlock t1, BlockId, [BlockId])]
+                        -> [GenBasicBlock t1]
+seqBlocks _ [] = []
+seqBlocks infos ((block,_,[]) : rest)
+  = block : seqBlocks infos rest
+seqBlocks infos ((block@(BasicBlock id instrs),_,[next]) : rest)
+  | can_fallthrough = BasicBlock id (init instrs) : seqBlocks infos rest'
+  | otherwise       = block : seqBlocks infos rest'
   where
-        (can_fallthrough, rest') = reorder next [] rest
+        can_fallthrough = not (mapMember next infos) && can_reorder
+        (can_reorder, rest') = reorder next [] rest
           -- TODO: we should do a better job for cycles; try to maximise the
           -- fallthroughs within a loop.
-seqBlocks _ = panic "AsmCodegen:seqBlocks"
+seqBlocks _ _ = panic "AsmCodegen:seqBlocks"
 
 reorder :: (Eq a) => a -> [(t, a, t1)] -> [(t, a, t1)] -> (Bool, [(t, a, t1)])
 reorder  _ accum [] = (False, reverse accum)
@@ -733,8 +735,8 @@ shortcutBranches dflags ncgImpl tops
     mapping = foldr plusUFM emptyUFM mappings
 
 build_mapping :: NcgImpl statics instr jumpDest
-              -> GenCmmDecl d t (ListGraph instr)
-              -> (GenCmmDecl d t (ListGraph instr), UniqFM jumpDest)
+              -> GenCmmDecl d (BlockEnv t) (ListGraph instr)
+              -> (GenCmmDecl d (BlockEnv t) (ListGraph instr), UniqFM jumpDest)
 build_mapping _ top@(CmmData _ _) = (top, emptyUFM)
 build_mapping _ (CmmProc info lbl (ListGraph []))
   = (CmmProc info lbl (ListGraph []), emptyUFM)
@@ -750,13 +752,17 @@ build_mapping ncgImpl (CmmProc info lbl (ListGraph (head:blocks)))
     split (s, shortcut_blocks, others) b@(BasicBlock id [insn])
         | Just jd <- canShortcut ncgImpl insn,
           Just dest <- getJumpDestBlockId ncgImpl jd,
+          not (has_info id),
           (setMember dest s) || dest == id -- loop checks
         = (s, shortcut_blocks, b : others)
     split (s, shortcut_blocks, others) (BasicBlock id [insn])
-        | Just dest <- canShortcut ncgImpl insn
+        | Just dest <- canShortcut ncgImpl insn,
+          not (has_info id)
         = (setInsert id s, (id,dest) : shortcut_blocks, others)
     split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others)
 
+    -- do not eliminate blocks that have an info table
+    has_info l = mapMember l info
 
     -- build a mapping from BlockId to JumpDest for shorting branches
     mapping = foldl add emptyUFM shortcut_blocks
diff --git a/compiler/nativeGen/Instruction.hs b/compiler/nativeGen/Instruction.hs
index 0d4161f843..b67ff9d40f 100644
--- a/compiler/nativeGen/Instruction.hs
+++ b/compiler/nativeGen/Instruction.hs
@@ -39,13 +39,13 @@ noUsage  = RU [] []
 type NatCmm instr
         = GenCmmGroup
                 CmmStatics
-                (Maybe CmmStatics)
+                (BlockEnv CmmStatics)
                 (ListGraph instr)
 
 type NatCmmDecl statics instr
         = GenCmmDecl
                 statics
-                (Maybe CmmStatics)
+                (BlockEnv CmmStatics)
                 (ListGraph instr)
 
 
diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs
index 1b49a495f5..55cc6d2a0d 100644
--- a/compiler/nativeGen/PPC/Ppr.hs
+++ b/compiler/nativeGen/PPC/Ppr.hs
@@ -50,42 +50,43 @@ pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc
 pprNatCmmDecl (CmmData section dats) =
   pprSectionHeader section $$ pprDatas dats
 
- -- special case for split markers:
-pprNatCmmDecl (CmmProc Nothing lbl (ListGraph []))
-    = pprLabel lbl
-
- -- special case for code without an info table:
-pprNatCmmDecl (CmmProc Nothing lbl (ListGraph blocks)) =
-  pprSectionHeader Text $$
-  pprLabel lbl $$ -- blocks guaranteed not null, so label needed
-  vcat (map pprBasicBlock blocks)
-
-pprNatCmmDecl (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blocks)) =
-  sdocWithPlatform $ \platform ->
-  pprSectionHeader Text $$
-  (
-       (if platformHasSubsectionsViaSymbols platform
-        then ppr (mkDeadStripPreventer info_lbl) <> char ':'
-        else empty) $$
-       vcat (map pprData info) $$
-       pprLabel info_lbl
-  ) $$
-  vcat (map pprBasicBlock blocks) $$
-     -- above: Even the first block gets a label, because with branch-chain
-     -- elimination, it might be the target of a goto.
-        (if platformHasSubsectionsViaSymbols platform
-         then
-         -- If we are using the .subsections_via_symbols directive
-         -- (available on recent versions of Darwin),
-         -- we have to make sure that there is some kind of reference
-         -- 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).
-                  text "\t.long "
-              <+> ppr info_lbl
-              <+> char '-'
-              <+> ppr (mkDeadStripPreventer info_lbl)
-         else empty)
+pprNatCmmDecl proc@(CmmProc _ lbl (ListGraph blocks)) =
+  case topInfoTable proc of
+    Nothing ->
+       case blocks of
+         []     -> -- special case for split markers:
+           pprLabel lbl
+         blocks -> -- special case for code without info table:
+           pprSectionHeader Text $$
+           pprLabel lbl $$ -- blocks guaranteed not null, so label needed
+           vcat (map pprBasicBlock blocks)
+
+    Just (Statics info_lbl info) ->
+      sdocWithPlatform $ \platform ->
+      pprSectionHeader Text $$
+      (
+           (if platformHasSubsectionsViaSymbols platform
+            then ppr (mkDeadStripPreventer info_lbl) <> char ':'
+            else empty) $$
+           vcat (map pprData info) $$
+           pprLabel info_lbl
+      ) $$
+      vcat (map pprBasicBlock blocks) $$
+         -- above: Even the first block gets a label, because with branch-chain
+         -- elimination, it might be the target of a goto.
+            (if platformHasSubsectionsViaSymbols platform
+             then
+             -- If we are using the .subsections_via_symbols directive
+             -- (available on recent versions of Darwin),
+             -- we have to make sure that there is some kind of reference
+             -- 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).
+                      text "\t.long "
+                  <+> ppr info_lbl
+                  <+> char '-'
+                  <+> ppr (mkDeadStripPreventer info_lbl)
+             else empty)
 
 
 pprBasicBlock :: NatBasicBlock Instr -> SDoc
diff --git a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
index 3bf49a31f2..c17b65d6e2 100644
--- a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
@@ -235,16 +235,10 @@ joinToTargets_again
 --
 makeRegMovementGraph :: RegMap Loc -> RegMap Loc -> [(Unique, Loc, [Loc])]
 makeRegMovementGraph adjusted_assig dest_assig
- = let
- 	mkNodes src vreg
-	 = expandNode vreg src
-	 $ lookupWithDefaultUFM_Directly
-           	dest_assig
-                (panic "RegAllocLinear.makeRegMovementGraph")
-		vreg
-
-   in	[ node 	| (vreg, src) <- ufmToList adjusted_assig
- 		, node <- mkNodes src vreg ]
+ = [ node       | (vreg, src) <- ufmToList adjusted_assig
+                    -- source reg might not be needed at the dest:
+                , Just loc <- [lookupUFM_Directly dest_assig vreg]
+                , node <- expandNode vreg src loc ]
 
 
 -- | Expand out the destination, so InBoth destinations turn into
diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs
index 5ceee3e242..fc585d9438 100644
--- a/compiler/nativeGen/RegAlloc/Liveness.hs
+++ b/compiler/nativeGen/RegAlloc/Liveness.hs
@@ -160,7 +160,7 @@ data Liveness
 -- | Stash regs live on entry to each basic block in the info part of the cmm code.
 data LiveInfo
         = LiveInfo
-                (Maybe CmmStatics)                      -- cmm info table static stuff
+                (BlockEnv 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
@@ -215,7 +215,7 @@ instance Outputable instr
 
 instance Outputable LiveInfo where
     ppr (LiveInfo mb_static firstId liveVRegsOnEntry liveSlotsOnEntry)
-        =  (maybe empty (ppr) mb_static)
+        =  (ppr mb_static)
         $$ text "# firstId          = " <> ppr firstId
         $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry
         $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry)
diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs
index 91a2b894c5..b384b6e0ba 100644
--- a/compiler/nativeGen/SPARC/Ppr.hs
+++ b/compiler/nativeGen/SPARC/Ppr.hs
@@ -52,41 +52,43 @@ pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc
 pprNatCmmDecl (CmmData section dats) =
   pprSectionHeader section $$ pprDatas dats
 
- -- special case for split markers:
-pprNatCmmDecl (CmmProc Nothing lbl (ListGraph [])) = pprLabel lbl
-
- -- special case for code without info table:
-pprNatCmmDecl (CmmProc Nothing lbl (ListGraph blocks)) =
-  pprSectionHeader Text $$
-  pprLabel lbl $$ -- blocks guaranteed not null, so label needed
-  vcat (map pprBasicBlock blocks)
-
-pprNatCmmDecl (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blocks)) =
-  sdocWithPlatform $ \platform ->
-  pprSectionHeader Text $$
-  (
-       (if platformHasSubsectionsViaSymbols platform
-        then ppr (mkDeadStripPreventer info_lbl) <> char ':'
-        else empty) $$
-       vcat (map pprData info) $$
-       pprLabel info_lbl
-  ) $$
-  vcat (map pprBasicBlock blocks) $$
-     -- above: Even the first block gets a label, because with branch-chain
-     -- elimination, it might be the target of a goto.
-        (if platformHasSubsectionsViaSymbols platform
-         then
-         -- If we are using the .subsections_via_symbols directive
-         -- (available on recent versions of Darwin),
-         -- we have to make sure that there is some kind of reference
-         -- 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).
-                  text "\t.long "
-              <+> ppr info_lbl
-              <+> char '-'
-              <+> ppr (mkDeadStripPreventer info_lbl)
-         else empty)
+pprNatCmmDecl proc@(CmmProc _ lbl (ListGraph blocks)) =
+  case topInfoTable proc of
+    Nothing ->
+       case blocks of
+         []     -> -- special case for split markers:
+           pprLabel lbl
+         blocks -> -- special case for code without info table:
+           pprSectionHeader Text $$
+           pprLabel lbl $$ -- blocks guaranteed not null, so label needed
+           vcat (map pprBasicBlock blocks)
+
+    Just (Statics info_lbl info) ->
+      sdocWithPlatform $ \platform ->
+      pprSectionHeader Text $$
+      (
+           (if platformHasSubsectionsViaSymbols platform
+            then ppr (mkDeadStripPreventer info_lbl) <> char ':'
+            else empty) $$
+           vcat (map pprData info) $$
+           pprLabel info_lbl
+      ) $$
+      vcat (map pprBasicBlock blocks) $$
+         -- above: Even the first block gets a label, because with branch-chain
+         -- elimination, it might be the target of a goto.
+            (if platformHasSubsectionsViaSymbols platform
+             then
+             -- If we are using the .subsections_via_symbols directive
+             -- (available on recent versions of Darwin),
+             -- we have to make sure that there is some kind of reference
+             -- 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).
+                      text "\t.long "
+                  <+> ppr info_lbl
+                  <+> char '-'
+                  <+> ppr (mkDeadStripPreventer info_lbl)
+             else empty)
 
 
 pprBasicBlock :: NatBasicBlock Instr -> SDoc
diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs
index e844376806..7a40e6b02d 100644
--- a/compiler/nativeGen/X86/Ppr.hs
+++ b/compiler/nativeGen/X86/Ppr.hs
@@ -32,6 +32,7 @@ import Reg
 import PprBase
 
 
+import BlockId
 import BasicTypes       (Alignment)
 import OldCmm
 import CLabel
@@ -51,43 +52,40 @@ pprNatCmmDecl :: NatCmmDecl (Alignment, CmmStatics) Instr -> SDoc
 pprNatCmmDecl (CmmData section dats) =
   pprSectionHeader section $$ pprDatas dats
 
- -- special case for split markers:
-pprNatCmmDecl (CmmProc Nothing lbl (ListGraph [])) = pprLabel lbl
-
- -- special case for code without info table:
-pprNatCmmDecl (CmmProc Nothing lbl (ListGraph blocks)) =
-  pprSectionHeader Text $$
-  pprLabel lbl $$ -- blocks guaranteed not null, so label needed
-  vcat (map pprBasicBlock blocks) $$
-  pprSizeDecl lbl
-
-pprNatCmmDecl (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blocks)) =
-  sdocWithPlatform $ \platform ->
-  pprSectionHeader Text $$
-  (
-       (if platformHasSubsectionsViaSymbols platform
-        then ppr (mkDeadStripPreventer info_lbl) <> char ':'
-        else empty) $$
-       vcat (map pprData info) $$
-       pprLabel info_lbl
-  ) $$
-  vcat (map pprBasicBlock blocks) $$
-     -- above: Even the first block gets a label, because with branch-chain
-     -- elimination, it might be the target of a goto.
-        (if platformHasSubsectionsViaSymbols platform
-         then
-         -- If we are using the .subsections_via_symbols directive
-         -- (available on recent versions of Darwin),
-         -- we have to make sure that there is some kind of reference
-         -- 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).
-                  text "\t.long "
-              <+> ppr info_lbl
-              <+> char '-'
-              <+> ppr (mkDeadStripPreventer info_lbl)
-         else empty) $$
-  pprSizeDecl info_lbl
+pprNatCmmDecl proc@(CmmProc top_info lbl (ListGraph blocks)) =
+  case topInfoTable proc of
+    Nothing ->
+       case blocks of
+         []     -> -- special case for split markers:
+           pprLabel lbl
+         blocks -> -- special case for code without info table:
+           pprSectionHeader Text $$
+           pprLabel lbl $$ -- blocks guaranteed not null, so label needed
+           vcat (map (pprBasicBlock top_info) blocks) $$
+           pprSizeDecl lbl
+
+    Just (Statics info_lbl _) ->
+      sdocWithPlatform $ \platform ->
+      (if platformHasSubsectionsViaSymbols platform
+          then ppr (mkDeadStripPreventer info_lbl) <> char ':'
+          else empty) $$
+      vcat (map (pprBasicBlock top_info) blocks) $$
+         -- above: Even the first block gets a label, because with branch-chain
+         -- elimination, it might be the target of a goto.
+            (if platformHasSubsectionsViaSymbols platform
+             then
+             -- If we are using the .subsections_via_symbols directive
+             -- (available on recent versions of Darwin),
+             -- we have to make sure that there is some kind of reference
+             -- 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).
+                      text "\t.long "
+                  <+> ppr info_lbl
+                  <+> char '-'
+                  <+> ppr (mkDeadStripPreventer info_lbl)
+             else empty) $$
+      pprSizeDecl info_lbl
 
 -- | Output the ELF .size directive.
 pprSizeDecl :: CLabel -> SDoc
@@ -98,11 +96,18 @@ pprSizeDecl lbl
      <> ptext (sLit ", .-") <> ppr lbl
    else empty
 
-pprBasicBlock :: NatBasicBlock Instr -> SDoc
-pprBasicBlock (BasicBlock blockid instrs) =
-  pprLabel (mkAsmTempLabel (getUnique blockid)) $$
-  vcat (map pprInstr instrs)
-
+pprBasicBlock :: BlockEnv CmmStatics -> NatBasicBlock Instr -> SDoc
+pprBasicBlock info_env (BasicBlock blockid instrs)
+  = maybe_infotable $$
+    pprLabel (mkAsmTempLabel (getUnique blockid)) $$
+    vcat (map pprInstr instrs)
+  where
+    maybe_infotable = case mapLookup blockid info_env of
+       Nothing   -> empty
+       Just (Statics info_lbl info) ->
+           pprSectionHeader Text $$
+           vcat (map pprData info) $$
+           pprLabel info_lbl
 
 pprDatas :: (Alignment, CmmStatics) -> SDoc
 pprDatas (align, (Statics lbl dats))