[commit: ghc] master: Fix the PPC and SPARC NCGs to handle multiple info tables in a proc (8224ee1)

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/8224ee19793fb4eb5dfa69371ac0a07798aa879e

>---------------------------------------------------------------

commit 8224ee19793fb4eb5dfa69371ac0a07798aa879e
Author: Simon Marlow <[email protected]>
Date:   Fri Sep 7 12:50:08 2012 +0100

    Fix the PPC and SPARC NCGs to handle multiple info tables in a proc

>---------------------------------------------------------------

 compiler/nativeGen/PPC/Ppr.hs   |   37 +++++++++++++++++++++----------------
 compiler/nativeGen/SPARC/Ppr.hs |   37 +++++++++++++++++++++----------------
 2 files changed, 42 insertions(+), 32 deletions(-)

diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs
index 55cc6d2..681b31d 100644
--- a/compiler/nativeGen/PPC/Ppr.hs
+++ b/compiler/nativeGen/PPC/Ppr.hs
@@ -31,6 +31,7 @@ import RegClass
 import TargetReg
 
 import OldCmm
+import BlockId
 
 import CLabel
 
@@ -50,7 +51,7 @@ pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc
 pprNatCmmDecl (CmmData section dats) =
   pprSectionHeader section $$ pprDatas dats
 
-pprNatCmmDecl proc@(CmmProc _ lbl (ListGraph blocks)) =
+pprNatCmmDecl proc@(CmmProc top_info lbl (ListGraph blocks)) =
   case topInfoTable proc of
     Nothing ->
        case blocks of
@@ -59,19 +60,15 @@ pprNatCmmDecl proc@(CmmProc _ lbl (ListGraph blocks)) =
          blocks -> -- special case for code without info table:
            pprSectionHeader Text $$
            pprLabel lbl $$ -- blocks guaranteed not null, so label needed
-           vcat (map pprBasicBlock blocks)
+           vcat (map (pprBasicBlock top_info) blocks)
 
-    Just (Statics info_lbl info) ->
+    Just (Statics info_lbl _) ->
       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) $$
+      (if platformHasSubsectionsViaSymbols platform
+          then pprSectionHeader Text $$
+               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
@@ -89,10 +86,18 @@ pprNatCmmDecl proc@(CmmProc _ lbl (ListGraph blocks)) =
              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
 
 
 
diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs
index e57e5e2..8ae3b4b 100644
--- a/compiler/nativeGen/SPARC/Ppr.hs
+++ b/compiler/nativeGen/SPARC/Ppr.hs
@@ -38,6 +38,7 @@ import PprBase
 import OldCmm
 import OldPprCmm()
 import CLabel
+import BlockId
 
 import Unique           ( Uniquable(..), pprUnique )
 import Outputable
@@ -52,7 +53,7 @@ pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc
 pprNatCmmDecl (CmmData section dats) =
   pprSectionHeader section $$ pprDatas dats
 
-pprNatCmmDecl proc@(CmmProc _ lbl (ListGraph blocks)) =
+pprNatCmmDecl proc@(CmmProc top_info lbl (ListGraph blocks)) =
   case topInfoTable proc of
     Nothing ->
        case blocks of
@@ -61,19 +62,15 @@ pprNatCmmDecl proc@(CmmProc _ lbl (ListGraph blocks)) =
          blocks -> -- special case for code without info table:
            pprSectionHeader Text $$
            pprLabel lbl $$ -- blocks guaranteed not null, so label needed
-           vcat (map pprBasicBlock blocks)
+           vcat (map (pprBasicBlock top_info) blocks)
 
-    Just (Statics info_lbl info) ->
+    Just (Statics info_lbl _) ->
       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) $$
+      (if platformHasSubsectionsViaSymbols platform
+          then pprSectionHeader Text $$
+               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
@@ -91,10 +88,18 @@ pprNatCmmDecl proc@(CmmProc _ lbl (ListGraph blocks)) =
              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 :: CmmStatics -> SDoc