%
+% (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
FCode, -- type
initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
- returnFC, fixC, checkedAbsC,
+ returnFC, fixC, fixC_, checkedAbsC,
stmtC, stmtsC, labelC, emitStmts, nopC, whenC, newLabelC,
newUnique, newUniqSupply,
EndOfBlockInfo(..),
setEndOfBlockInfo, getEndOfBlockInfo,
+ setSRT, getSRT,
setSRTLabel, getSRTLabel,
setTickyCtrLabel, getTickyCtrLabel,
getHpUsage, setHpUsage,
heapHWM,
- moduleName,
+ getModuleName,
Sequel(..), -- ToDo: unabstract?
-- ideally we wouldn't export these, but some other modules access internal state
- getState, setState, getInfoDown, getDynFlags, getThisPackage,
+ getState, setState, getInfoDown, getDynFlags, getThisPackage,
-- more localised access to monad state
getStkUsage, setStkUsage,
import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds )
-import DynFlags ( DynFlags(..) )
-import PackageConfig ( PackageId )
+import DynFlags
+import BlockId
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 FastString
+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`
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 }
-- by a case alternative.
Sequel
+initEobInfo :: EndOfBlockInfo
initEobInfo = EndOfBlockInfo 0 OnStack
\end{code}
\begin{code}
data Sequel
= OnStack -- Continuation is on the stack
- | UpdateCode -- Continuation is update
| CaseAlts
CLabel -- Jump to this; if the continuation is for a vectored
-- 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
where (fork_block, fork_blocks) = flatten (fromOL stmts)
where (block,blocks) = flatten ss
+isJump :: CmmStmt -> Bool
isJump (CmmJump _ _) = True
isJump (CmmBranch _) = True
+isJump (CmmSwitch _ _) = True
+isJump (CmmReturn _) = True
isJump _ = False
+isOrdinaryStmt :: CgStmt -> Bool
isOrdinaryStmt (CgStmt _) = True
isOrdinaryStmt _ = False
\end{code}
}
returnFC :: a -> FCode a
-returnFC val = FCode (\info_down state -> (val, state))
+returnFC val = FCode (\_ state -> (val, state))
\end{code}
\begin{code}
in
result
)
+
+fixC_ :: (a -> FCode a) -> FCode ()
+fixC_ fcode = fixC fcode >> return ()
\end{code}
%************************************************************************
\begin{code}
getState :: FCode CgState
-getState = FCode $ \info_down state -> (state,state)
+getState = FCode $ \_ state -> (state,state)
setState :: CgState -> FCode ()
-setState state = FCode $ \info_down _ -> ((),state)
+setState state = FCode $ \_ _ -> ((),state)
getStkUsage :: FCode StackUsage
getStkUsage = do
whenC :: Bool -> Code -> Code
whenC True code = code
-whenC False code = nopC
+whenC False _ = nopC
stmtC :: CmmStmt -> Code
stmtC stmt = emitCgStmt (CgStmt stmt)
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 -> CmmFormals -> [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 })
; setState $ state2 { cgs_tops = cgs_tops state1 }
- ; return (Cmm (fromOL (cgs_tops state2))) }
+ ; return (Cmm (fromOL (cgs_tops state2)))
+ }
-- ----------------------------------------------------------------------------
-- CgStmts
-- ----------------------------------------------------------------------------
-- 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
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
projects / ghc-hetmet.git / blobdiff