X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcodeGen%2FCgMonad.lhs;h=6861a2c2c00c4c0eeda43b43166ca8bfe736072b;hb=d759c7231dde979ed2824bd39b2fdff24357d355;hp=61b358a6ba39b1d15559a6df5b9befe34062f7d1;hpb=418175d3c36ca51495d9dfb085fb01711e4c38f9;p=ghc-hetmet.git

diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs
index 61b358a..6861a2c 100644
--- a/compiler/codeGen/CgMonad.lhs
+++ b/compiler/codeGen/CgMonad.lhs
@@ -8,6 +8,13 @@ See the beginning of the top-level @CodeGen@ module, to see how this
 monadic stuff fits into the Big Picture.
 
 \begin{code}
+{-# OPTIONS_GHC -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
+-- for details
+
 module CgMonad (
 	Code,	-- type
 	FCode,	-- type
@@ -32,6 +39,7 @@ module CgMonad (
 	EndOfBlockInfo(..),
 	setEndOfBlockInfo, getEndOfBlockInfo,
 
+	setSRT, getSRT,
 	setSRTLabel, getSRTLabel, 
 	setTickyCtrLabel, getTickyCtrLabel,
 
@@ -65,6 +73,7 @@ import PackageConfig
 import Cmm
 import CmmUtils
 import CLabel
+import StgSyn (SRT)
 import SMRep
 import Module
 import Id
@@ -77,6 +86,7 @@ import FastString
 import Outputable
 
 import Control.Monad
+import Data.List
 
 infixr 9 `thenC`	-- Right-associative!
 infixr 9 `thenFC`
@@ -98,7 +108,8 @@ data CgInfoDownwards	-- information only passed *downwards* by the monad
 	cgd_dflags  :: DynFlags,
 	cgd_mod     :: Module,		-- Module being compiled
 	cgd_statics :: CgBindings,	-- [Id -> info] : static environment
-	cgd_srt     :: CLabel,		-- label of the current SRT
+	cgd_srt_lbl :: CLabel,		-- label of the current SRT
+        cgd_srt     :: SRT,		-- the current SRT
 	cgd_ticky   :: CLabel,		-- current destination for ticky counts
 	cgd_eob     :: EndOfBlockInfo	-- Info for stuff to do at end of basic block:
   }
@@ -108,6 +119,7 @@ initCgInfoDown dflags mod
   = MkCgInfoDown {	cgd_dflags  = dflags,
 			cgd_mod     = mod,
 			cgd_statics = emptyVarEnv,
+			cgd_srt_lbl = error "initC: srt_lbl",
 			cgd_srt     = error "initC: srt",
 			cgd_ticky   = mkTopTickyCtrLabel,
 			cgd_eob     = initEobInfo }
@@ -242,6 +254,7 @@ flattenCgStmts id stmts =
 isJump (CmmJump _ _) = True
 isJump (CmmBranch _) = True
 isJump (CmmSwitch _ _) = True
+isJump (CmmReturn _) = True
 isJump _ = False
 
 isOrdinaryStmt (CgStmt _) = True
@@ -730,9 +743,9 @@ emitData sect lits
   where
     data_block = CmmData sect lits
 
-emitProc :: [CmmLit] -> CLabel -> CmmFormals -> [CmmBasicBlock] -> Code
-emitProc lits lbl args blocks
-  = do  { let proc_block = CmmProc (map CmmStaticLit lits) lbl args blocks
+emitProc :: CmmInfo -> CLabel -> CmmFormals -> [CmmBasicBlock] -> Code
+emitProc info lbl args blocks
+  = do  { let proc_block = CmmProc info lbl args blocks
 	; state <- getState
 	; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
 
@@ -741,7 +754,7 @@ emitSimpleProc :: CLabel -> Code -> Code
 emitSimpleProc lbl code
   = do	{ stmts <- getCgStmts code
 	; blks <- cgStmtsToBlocks stmts
-	; emitProc [] lbl [] blks }
+	; emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] blks }
 
 getCmm :: Code -> FCode Cmm
 -- Get all the CmmTops (there should be no stmts)
@@ -828,12 +841,21 @@ getEndOfBlockInfo = do
 
 getSRTLabel :: FCode CLabel	-- Used only by cgPanic
 getSRTLabel = do info  <- getInfoDown
-		 return (cgd_srt info)
+		 return (cgd_srt_lbl info)
 
 setSRTLabel :: CLabel -> FCode a -> FCode a
 setSRTLabel srt_lbl code
   = do  info <- getInfoDown
-	withInfoDown code (info { cgd_srt = srt_lbl})
+	withInfoDown code (info { cgd_srt_lbl = srt_lbl})
+
+getSRT :: FCode SRT
+getSRT = do info <- getInfoDown
+            return (cgd_srt info)
+
+setSRT :: SRT -> FCode a -> FCode a
+setSRT srt code
+  = do info <- getInfoDown
+       withInfoDown code (info { cgd_srt = srt})
 
 -- ----------------------------------------------------------------------------
 -- Get/set the current ticky counter label