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,
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
-import PackageConfig
+import BlockId
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 }
-- 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
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
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