X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FSPARC%2FCodeGen.hs;h=a4dbbe877152fe79836b21b10cee983179cbbf38;hp=550a1a3ecf0819a5552bc2723e7cb6f6c2c22cf1;hb=8133a9f47b99f4e65ed30551de32ad72c6b61b27;hpb=7f860170afc072bcf64baf6aeb854acf01146c90

diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs
index 550a1a3..a4dbbe8 100644
--- a/compiler/nativeGen/SPARC/CodeGen.hs
+++ b/compiler/nativeGen/SPARC/CodeGen.hs
@@ -8,6 +8,7 @@
 
 module SPARC.CodeGen ( 
 	cmmTopCodeGen, 
+	generateJumpTableForInstr,
 	InstrBlock 
 ) 
 
@@ -15,15 +16,17 @@ where
 
 #include "HsVersions.h"
 #include "nativeGen/NCG.h"
-#include "MachDeps.h"
+#include "../includes/MachDeps.h"
 
 -- NCG stuff:
+import SPARC.CodeGen.Sanity
 import SPARC.CodeGen.Amode
 import SPARC.CodeGen.CondCode
 import SPARC.CodeGen.Gen64
 import SPARC.CodeGen.Gen32
 import SPARC.CodeGen.CCall
 import SPARC.CodeGen.Base
+import SPARC.Ppr	()
 import SPARC.Instr
 import SPARC.Imm
 import SPARC.AddrMode
@@ -34,69 +37,70 @@ import NCGMonad
 
 -- Our intermediate code:
 import BlockId
-import Cmm
+import OldCmm
 import CLabel
 
 -- The rest:
 import StaticFlags	( opt_PIC )
 import OrdList
-import qualified Outputable as O
 import Outputable
+import Unique
 
 import Control.Monad	( mapAndUnzipM )
-import DynFlags
 
 -- | Top level code generation
 cmmTopCodeGen 
-	:: DynFlags
-	-> RawCmmTop 
+	:: RawCmmTop 
 	-> NatM [NatCmmTop Instr]
 
-cmmTopCodeGen _
-	(CmmProc info lab params (ListGraph blocks)) 
+cmmTopCodeGen
+	(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)
 	let tops 	= proc : concat statics
 
---	case picBaseMb of
---	 Just picBase -> initializePicBase picBase tops
---	 Nothing -> return tops
-  
   	return tops
   
-  
-cmmTopCodeGen _ (CmmData sec dat) = do
+cmmTopCodeGen (CmmData sec dat) = do
   return [CmmData sec dat]  -- no translation, we just use CmmStatic
 
 
-
+-- | Do code generation on a single block of CMM code.
+--	code generation may introduce new basic block boundaries, which
+-- 	are indicated by the NEWBLOCK instruction.  We must split up the
+-- 	instruction stream into basic blocks again.  Also, we extract
+-- 	LDATAs here too.
 basicBlockCodeGen 
 	:: CmmBasicBlock
 	-> NatM ( [NatBasicBlock Instr]
 		, [NatCmmTop Instr])
 
-basicBlockCodeGen (BasicBlock id stmts) = do
+basicBlockCodeGen cmm@(BasicBlock id stmts) = do
   instrs <- stmtsToInstrs stmts
-  -- code generation may introduce new basic block boundaries, which
-  -- are indicated by the NEWBLOCK instruction.  We must split up the
-  -- instruction stream into basic blocks again.  Also, we extract
-  -- LDATAs here too.
   let
-	(top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs
+	(top,other_blocks,statics) 
+		= foldrOL mkBlocks ([],[],[]) instrs
 	
 	mkBlocks (NEWBLOCK id) (instrs,blocks,statics) 
 	  = ([], BasicBlock id instrs : blocks, statics)
+
 	mkBlocks (LDATA sec dat) (instrs,blocks,statics) 
 	  = (instrs, blocks, CmmData sec dat:statics)
+
 	mkBlocks instr (instrs,blocks,statics)
 	  = (instr:instrs, blocks, statics)
-  -- in
-  return (BasicBlock id top : other_blocks, statics)
 
+	-- do intra-block sanity checking
+	blocksChecked
+	  	= map (checkBlock cmm)
+	  	$ BasicBlock id top : other_blocks
+
+  return (blocksChecked, statics)
 
+
+-- | Convert some Cmm statements to SPARC instructions.
 stmtsToInstrs :: [CmmStmt] -> NatM InstrBlock
 stmtsToInstrs stmts
    = do instrss <- mapM stmtToInstrs stmts
@@ -157,8 +161,8 @@ temporary, then do the other computation, and then use the temporary:
 -- | 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)
 
 
 
@@ -294,15 +298,11 @@ genSwitch expr ids
 		dst		<- getNewRegNat II32
 
 		label 		<- getNewLabelNat
-		let jumpTable	= map jumpTableEntry ids
 
 		return $ e_code `appOL`
 		 toOL	
-		 	-- the jump table
-			[ LDATA ReadOnlyData (CmmDataLabel label : jumpTable)
-
-			-- load base of jump table
-			, SETHI (HI (ImmCLbl label)) base_reg
+			[ -- load base of jump table
+			  SETHI (HI (ImmCLbl label)) base_reg
 			, OR    False base_reg (RIImm $ LO $ ImmCLbl label) base_reg
 			
 			-- the addrs in the table are 32 bits wide..
@@ -310,6 +310,11 @@ genSwitch expr ids
 
 			-- load and jump to the destination
 			, LD 	  II32 (AddrRegReg base_reg offset_reg) dst
-			, JMP_TBL (AddrRegImm dst (ImmInt 0)) [i | Just i <- ids]
+			, JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label
 			, NOP ]
 
+generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr)
+generateJumpTableForInstr (JMP_TBL _ ids label) =
+	let jumpTable = map jumpTableEntry ids
+	in Just (CmmData ReadOnlyData (CmmDataLabel label : jumpTable))
+generateJumpTableForInstr _ = Nothing