Add {-# OPTIONS_GHC -w #-} and some blurb to all compiler modules

[ghc-hetmet.git] / compiler / codeGen / CgMonad.lhs

diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs
index 1866df4..6861a2c 100644 (file)
--- a/compiler/codeGen/CgMonad.lhs
+++ b/compiler/codeGen/CgMonad.lhs
@@ -1,14 +1,20 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CgMonad.lhs,v 1.45 2005/06/21 10:44:41 simonmar Exp $
-%
 \section[CgMonad]{The code generation monad}
 
 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
@@ -33,6 +39,7 @@ module CgMonad (
        EndOfBlockInfo(..),
        setEndOfBlockInfo, getEndOfBlockInfo,
 
+       setSRT, getSRT,
        setSRTLabel, getSRTLabel, 
        setTickyCtrLabel, getTickyCtrLabel,
 
@@ -42,7 +49,7 @@ module CgMonad (
        getHpUsage,  setHpUsage,
        heapHWM,
 
-       moduleName,
+       getModuleName,
 
        Sequel(..), -- ToDo: unabstract?
 
@@ -61,23 +68,25 @@ module CgMonad (
 
 import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds )
 
-import DynFlags                ( DynFlags(..) )
-import PackageConfig   ( PackageId )
+import DynFlags
+import PackageConfig
 import Cmm
-import CmmUtils                ( CmmStmts, isNopStmt )
+import CmmUtils
 import CLabel
-import SMRep           ( WordOff )
-import Module          ( Module )
-import Id              ( Id )
+import StgSyn (SRT)
+import SMRep
+import Module
+import Id
 import VarEnv
 import OrdList
-import Unique          ( Unique )
-import Util            ( mapAccumL )
-import UniqSupply      ( UniqSupply, mkSplitUniqSupply, splitUniqSupply, uniqFromSupply )
+import Unique
+import Util
+import UniqSupply
 import FastString
 import Outputable
 
-import Control.Monad   ( liftM )
+import Control.Monad
+import Data.List
 
 infixr 9 `thenC`       -- Right-associative!
 infixr 9 `thenFC`
@@ -99,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:
   }
@@ -109,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 }
@@ -171,7 +182,6 @@ data Sequel
                     -- case this might be the label of a return vector
          SemiTaggingStuff
          Id          -- The case binder, only used to see if it's dead
-         Bool        -- True <=> polymorphic, push a SEQ frame too
 
 type SemiTaggingStuff
   = Maybe                      -- Maybe[1] we don't have any semi-tagging stuff...
@@ -243,6 +253,8 @@ flattenCgStmts id stmts =
 
 isJump (CmmJump _ _) = True
 isJump (CmmBranch _) = True
+isJump (CmmSwitch _ _) = True
+isJump (CmmReturn _) = True
 isJump _ = False
 
 isOrdinaryStmt (CgStmt _) = True
@@ -731,9 +743,9 @@ emitData sect lits
   where
     data_block = CmmData sect lits
 
-emitProc :: [CmmLit] -> CLabel -> [LocalReg] -> [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 } }
 
@@ -742,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)
@@ -804,8 +816,8 @@ consCgStmt stmt stmts = CgStmt stmt `consOL` stmts
 -- ----------------------------------------------------------------------------
 -- Get the current module name
 
-moduleName :: FCode Module
-moduleName = do { info <- getInfoDown; return (cgd_mod info) }
+getModuleName :: FCode Module
+getModuleName = do { info <- getInfoDown; return (cgd_mod info) }
 
 -- ----------------------------------------------------------------------------
 -- Get/set the end-of-block info
@@ -829,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