X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCgMonad.lhs;h=8a3b664fc1aa35bcc2980d9d5bb7244ec0a42eaf;hp=4f95c9b36a8a8e1d189d6b2b80aa6f42eb242e43;hb=18691d440f90a3dff4ef538091c886af505e5cf5;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs index 4f95c9b..8a3b664 100644 --- a/compiler/codeGen/CgMonad.lhs +++ b/compiler/codeGen/CgMonad.lhs @@ -1,8 +1,7 @@ % +% (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 @@ -14,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, @@ -33,6 +32,7 @@ module CgMonad ( EndOfBlockInfo(..), setEndOfBlockInfo, getEndOfBlockInfo, + setSRT, getSRT, setSRTLabel, getSRTLabel, setTickyCtrLabel, getTickyCtrLabel, @@ -42,12 +42,12 @@ module CgMonad ( 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, getHomeModules, + getState, setState, getInfoDown, getDynFlags, getThisPackage, -- more localised access to monad state getStkUsage, setStkUsage, @@ -61,23 +61,23 @@ module CgMonad ( import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds ) -import DynFlags ( DynFlags ) -import Packages ( HomeModules ) -import Cmm -import CmmUtils ( CmmStmts, isNopStmt ) +import DynFlags +import BlockId +import OldCmm +import OldCmmUtils 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 UniqSupply import Outputable -import Control.Monad ( liftM ) +import Control.Monad +import Data.List infixr 9 `thenC` -- Right-associative! infixr 9 `thenFC` @@ -97,20 +97,20 @@ along. data CgInfoDownwards -- information only passed *downwards* by the monad = MkCgInfoDown { cgd_dflags :: DynFlags, - cgd_hmods :: HomeModules, -- Packages we depend on 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: } -initCgInfoDown :: DynFlags -> HomeModules -> Module -> CgInfoDownwards -initCgInfoDown dflags hmods mod +initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards +initCgInfoDown dflags mod = MkCgInfoDown { cgd_dflags = dflags, - cgd_hmods = hmods, cgd_mod = mod, cgd_statics = emptyVarEnv, + cgd_srt_lbl = error "initC: srt_lbl", cgd_srt = error "initC: srt", cgd_ticky = mkTopTickyCtrLabel, cgd_eob = initEobInfo } @@ -156,6 +156,7 @@ data EndOfBlockInfo -- by a case alternative. Sequel +initEobInfo :: EndOfBlockInfo initEobInfo = EndOfBlockInfo 0 OnStack \end{code} @@ -166,14 +167,12 @@ 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 -- 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... @@ -220,7 +219,7 @@ flattenCgStmts id stmts = -- Eliminating these has to be done with a dead-code analysis. For now, -- we just make it into a well-formed block by adding a recursive jump. flatten [CgLabel id] - = ( [], [BasicBlock id [CmmBranch id]] ) + = ( [CmmBranch id], [BasicBlock id [CmmBranch id]] ) -- A jump/branch: throw away all the code up to the next label, because -- it is unreachable. Be careful to keep forks that we find on the way. @@ -233,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 @@ -243,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} @@ -378,16 +382,16 @@ instance Monad FCode where The Abstract~C is not in the environment so as to improve strictness. \begin{code} -initC :: DynFlags -> HomeModules -> Module -> FCode a -> IO a +initC :: DynFlags -> Module -> FCode a -> IO a -initC dflags hmods mod (FCode code) +initC dflags mod (FCode code) = do { uniqs <- mkSplitUniqSupply 'c' - ; case code (initCgInfoDown dflags hmods mod) (initCgState uniqs) of + ; case code (initCgInfoDown dflags mod) (initCgState uniqs) of (res, _) -> return res } returnFC :: a -> FCode a -returnFC val = FCode (\info_down state -> (val, state)) +returnFC val = FCode (\_ state -> (val, state)) \end{code} \begin{code} @@ -436,6 +440,9 @@ fixC fcode = FCode ( in result ) + +fixC_ :: (a -> FCode a) -> FCode () +fixC_ fcode = fixC fcode >> return () \end{code} %************************************************************************ @@ -447,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 @@ -510,8 +517,8 @@ getInfoDown = FCode $ \info_down state -> (info_down,state) getDynFlags :: FCode DynFlags getDynFlags = liftM cgd_dflags getInfoDown -getHomeModules :: FCode HomeModules -getHomeModules = liftM cgd_hmods getInfoDown +getThisPackage :: FCode PackageId +getThisPackage = liftM thisPackage getDynFlags withInfoDown :: FCode a -> CgInfoDownwards -> FCode a withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state @@ -692,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) @@ -701,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 @@ -733,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 @@ -806,8 +818,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 @@ -831,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