X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCgMonad.lhs;h=8a3b664fc1aa35bcc2980d9d5bb7244ec0a42eaf;hp=3c596a6fb97ab5f8a3e04609e99e89ba2abac957;hb=f8f0e76ad302fda30196ebc9230e5fcbc97be537;hpb=9ff76535edb25ab7434284adddb5c64708ecb547 diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs index 3c596a6..8a3b664 100644 --- a/compiler/codeGen/CgMonad.lhs +++ b/compiler/codeGen/CgMonad.lhs @@ -13,7 +13,7 @@ module CgMonad ( 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, @@ -32,6 +32,7 @@ module CgMonad ( EndOfBlockInfo(..), setEndOfBlockInfo, getEndOfBlockInfo, + setSRT, getSRT, setSRTLabel, getSRTLabel, setTickyCtrLabel, getTickyCtrLabel, @@ -46,7 +47,7 @@ module CgMonad ( 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, @@ -61,22 +62,22 @@ module CgMonad ( import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds ) import DynFlags -import PackageConfig -import Cmm -import CmmUtils +import BlockId +import OldCmm +import OldCmmUtils import CLabel +import StgSyn (SRT) import SMRep import Module import Id import VarEnv import OrdList import Unique -import Util import UniqSupply -import FastString import Outputable import Control.Monad +import Data.List infixr 9 `thenC` -- Right-associative! infixr 9 `thenFC` @@ -98,7 +99,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 +110,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 } @@ -153,6 +156,7 @@ data EndOfBlockInfo -- by a case alternative. Sequel +initEobInfo :: EndOfBlockInfo initEobInfo = EndOfBlockInfo 0 OnStack \end{code} @@ -163,7 +167,6 @@ block. \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 @@ -229,6 +232,7 @@ flattenCgStmts id stmts = 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 @@ -239,10 +243,14 @@ flattenCgStmts id stmts = 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} @@ -383,7 +391,7 @@ initC dflags mod (FCode code) } returnFC :: a -> FCode a -returnFC val = FCode (\info_down state -> (val, state)) +returnFC val = FCode (\_ state -> (val, state)) \end{code} \begin{code} @@ -432,6 +440,9 @@ fixC fcode = FCode ( in result ) + +fixC_ :: (a -> FCode a) -> FCode () +fixC_ fcode = fixC fcode >> return () \end{code} %************************************************************************ @@ -443,10 +454,10 @@ fixC fcode = FCode ( \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 @@ -688,7 +699,7 @@ nopC = return () whenC :: Bool -> Code -> Code whenC True code = code -whenC False code = nopC +whenC False _ = nopC stmtC :: CmmStmt -> Code stmtC stmt = emitCgStmt (CgStmt stmt) @@ -697,7 +708,8 @@ labelC :: BlockId -> Code labelC id = emitCgStmt (CgLabel id) newLabelC :: FCode BlockId -newLabelC = do { id <- newUnique; return (BlockId id) } +newLabelC = do { u <- newUnique + ; return $ mkBlockId u } checkedAbsC :: CmmStmt -> Code -- Emit code, eliminating no-ops @@ -729,26 +741,30 @@ 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 [] blocks + = do { let proc_block = CmmProc info lbl (ListGraph blocks) ; state <- getState ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } } +emitProc _ _ (_:_) _ = panic "emitProc called with nonempty args" emitSimpleProc :: CLabel -> Code -> Code -- Emit a procedure whose body is the specified code; no info table 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 @@ -827,12 +843,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