X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FPPC%2FCodeGen.hs;h=c96baddca1f9ec757a52a82ddf3b045f7e499507;hp=1215b2e6c6a15db46944bd9d8ba5a172582bcefc;hb=b2524b3960999fffdb3767900f58825903f6560f;hpb=572a047bcf7001a4a2b916cfec618082652f2ae6

diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs
index 1215b2e..c96badd 100644
--- a/compiler/nativeGen/PPC/CodeGen.hs
+++ b/compiler/nativeGen/PPC/CodeGen.hs
@@ -15,6 +15,7 @@
 
 module PPC.CodeGen ( 
 	cmmTopCodeGen, 
+	generateJumpTableForInstr,
 	InstrBlock 
 ) 
 
@@ -41,7 +42,7 @@ import Platform
 -- Our intermediate code:
 import BlockId
 import PprCmm		( pprExpr )
-import Cmm
+import OldCmm
 import CLabel
 
 -- The rest:
@@ -49,6 +50,7 @@ import StaticFlags	( opt_PIC )
 import OrdList
 import qualified Outputable as O
 import Outputable
+import Unique
 import DynFlags
 
 import Control.Monad	( mapAndUnzipM )
@@ -74,10 +76,10 @@ cmmTopCodeGen
 	-> RawCmmTop 
 	-> NatM [NatCmmTop Instr]
 
-cmmTopCodeGen dflags (CmmProc info lab params (ListGraph blocks)) = do
+cmmTopCodeGen dflags (CmmProc info lab (ListGraph blocks)) = do
   (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
   picBaseMb <- getPicBaseMaybeNat
-  let proc = CmmProc info lab params (ListGraph $ concat nat_blocks)
+  let proc = CmmProc info lab (ListGraph $ concat nat_blocks)
       tops = proc : concat statics
       os   = platformOS $ targetPlatform dflags
   case picBaseMb of
@@ -180,12 +182,12 @@ getRegisterReg (CmmLocal (LocalReg u pk))
   = RegVirtual $ mkVirtualReg u (cmmTypeSize pk)
 
 getRegisterReg (CmmGlobal mid)
-  = case get_GlobalReg_reg_or_addr mid of
-       Left reg -> reg
-       _other -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)
-          -- By this stage, the only MagicIds remaining should be the
-          -- ones which map to a real machine register on this
-          -- platform.  Hence ...
+  = case globalRegMaybe mid of
+        Just reg -> reg
+        Nothing  -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)
+        -- By this stage, the only MagicIds remaining should be the
+        -- ones which map to a real machine register on this
+        -- platform.  Hence ...
 
 
 {-
@@ -221,8 +223,8 @@ is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000
 -- | Convert a BlockId to some CmmStatic data
 jumpTableEntry :: Maybe BlockId -> CmmStatic
 jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordWidth)
-jumpTableEntry (Just (BlockId id)) = CmmStaticLit (CmmLabel blockLabel)
-    where blockLabel = mkAsmTempLabel id
+jumpTableEntry (Just blockid) = CmmStaticLit (CmmLabel blockLabel)
+    where blockLabel = mkAsmTempLabel (getUnique blockid)
 
 
 
@@ -377,6 +379,11 @@ iselExpr64 expr
 
 getRegister :: CmmExpr -> NatM Register
 
+getRegister (CmmReg (CmmGlobal PicBaseReg))
+  = do
+      reg <- getPicBaseNat archWordSize
+      return (Fixed archWordSize reg nilOL)
+
 getRegister (CmmReg reg) 
   = return (Fixed (cmmTypeSize (cmmRegType reg)) 
 		  (getRegisterReg reg) nilOL)
@@ -792,7 +799,7 @@ genJump (CmmLit (CmmLabel lbl))
 genJump tree
   = do
         (target,code) <- getSomeReg tree
-        return (code `snocOL` MTCTR target `snocOL` BCTR [])
+        return (code `snocOL` MTCTR target `snocOL` BCTR [] Nothing)
 
 
 -- -----------------------------------------------------------------------------
@@ -1120,22 +1127,12 @@ genSwitch expr ids
         dflags <- getDynFlagsNat
         dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
         (tableReg,t_code) <- getSomeReg $ dynRef
-        let
-            jumpTable = map jumpTableEntryRel ids
-            
-            jumpTableEntryRel Nothing
-                = CmmStaticLit (CmmInt 0 wordWidth)
-            jumpTableEntryRel (Just (BlockId id))
-                = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
-                where blockLabel = mkAsmTempLabel id
-
-            code = e_code `appOL` t_code `appOL` toOL [
-                            LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
+        let code = e_code `appOL` t_code `appOL` toOL [
                             SLW tmp reg (RIImm (ImmInt 2)),
                             LD II32 tmp (AddrRegReg tableReg tmp),
                             ADD tmp tmp (RIReg tableReg),
                             MTCTR tmp,
-                            BCTR [ id | Just id <- ids ]
+                            BCTR ids (Just lbl)
                     ]
         return code
   | otherwise
@@ -1143,19 +1140,27 @@ genSwitch expr ids
         (reg,e_code) <- getSomeReg expr
         tmp <- getNewRegNat II32
         lbl <- getNewLabelNat
-        let
-            jumpTable = map jumpTableEntry ids
-        
-            code = e_code `appOL` toOL [
-                            LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
+        let code = e_code `appOL` toOL [
                             SLW tmp reg (RIImm (ImmInt 2)),
                             ADDIS tmp tmp (HA (ImmCLbl lbl)),
                             LD II32 tmp (AddrRegImm tmp (LO (ImmCLbl lbl))),
                             MTCTR tmp,
-                            BCTR [ id | Just id <- ids ]
+                            BCTR ids (Just lbl)
                     ]
         return code
 
+generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr)
+generateJumpTableForInstr (BCTR ids (Just lbl)) =
+    let jumpTable
+            | opt_PIC   = map jumpTableEntryRel ids
+            | otherwise = map jumpTableEntry ids
+                where jumpTableEntryRel Nothing
+                        = CmmStaticLit (CmmInt 0 wordWidth)
+                      jumpTableEntryRel (Just blockid)
+                        = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
+                            where blockLabel = mkAsmTempLabel (getUnique blockid)
+    in Just (CmmData ReadOnlyData (CmmDataLabel lbl : jumpTable))
+generateJumpTableForInstr _ = Nothing
 
 -- -----------------------------------------------------------------------------
 -- 'condIntReg' and 'condFltReg': condition codes into registers