monadic stuff fits into the Big Picture.
\begin{code}
+{-# OPTIONS -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/Commentary/CodingStyle#Warnings
+-- for details
+
module CgMonad (
Code, -- type
FCode, -- type
EndOfBlockInfo(..),
setEndOfBlockInfo, getEndOfBlockInfo,
+ setSRT, getSRT,
setSRTLabel, getSRTLabel,
setTickyCtrLabel, getTickyCtrLabel,
import Cmm
import CmmUtils
import CLabel
+import StgSyn (SRT)
import SMRep
import Module
import Id
import VarEnv
import OrdList
import Unique
-import Util
+import Util()
import UniqSupply
-import FastString
+import FastString()
import Outputable
import Control.Monad
+import Data.List
infixr 9 `thenC` -- Right-associative!
infixr 9 `thenFC`
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:
}
= 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 }
-- 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...
where (block,blocks) = flatten stmts
(CgFork fork_id stmts : ss) ->
flatten (CgFork fork_id stmts : CgStmt stmt : ss)
+ (CgStmt {} : _) -> panic "CgStmt not seen as ordinary"
flatten (s:ss) =
case s of
isJump (CmmJump _ _) = True
isJump (CmmBranch _) = True
+isJump (CmmSwitch _ _) = True
+isJump (CmmReturn _) = True
isJump _ = False
isOrdinaryStmt (CgStmt _) = True
labelC id = emitCgStmt (CgLabel id)
newLabelC :: FCode BlockId
-newLabelC = do { id <- newUnique; return (BlockId id) }
+newLabelC = do { u <- newUnique
+ ; return $ BlockId u }
checkedAbsC :: CmmStmt -> Code
-- Emit code, eliminating no-ops
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 -> CmmFormalsWithoutKinds -> [CmmBasicBlock] -> Code
+emitProc info lbl args blocks
+ = do { let proc_block = CmmProc info lbl args (ListGraph blocks)
; state <- getState
; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
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)
+-- Return a single Cmm which may be split from other Cmms by
+-- object splitting (at a later stage)
getCmm code
= do { state1 <- getState
; ((), state2) <- withState code (state1 { cgs_tops = nilOL })
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