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

diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs
index 550a1a3..6a34557 100644
--- a/compiler/nativeGen/SPARC/CodeGen.hs
+++ b/compiler/nativeGen/SPARC/CodeGen.hs
@@ -18,12 +18,14 @@ where
 #include "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
@@ -57,46 +59,49 @@ cmmTopCodeGen _
  = do	
  	(nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
 
---	picBaseMb 	<- getPicBaseMaybeNat
 	let proc 	= CmmProc info lab params (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
   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