X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcodeGen%2FCgMonad.lhs;h=688591292cb8497fc0093f5452a2eaa06d626b78;hb=1f8efd5d6214c490ef4942134abf5de9f468d29c;hp=4f95c9b36a8a8e1d189d6b2b80aa6f42eb242e43;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs index 4f95c9b..6885912 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 @@ -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,24 @@ module CgMonad ( import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds ) -import DynFlags ( DynFlags ) -import Packages ( HomeModules ) +import DynFlags +import PackageConfig 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 Unique +import Util +import UniqSupply import FastString import Outputable -import Control.Monad ( liftM ) +import Control.Monad infixr 9 `thenC` -- Right-associative! infixr 9 `thenFC` @@ -97,20 +98,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 } @@ -173,7 +174,6 @@ data Sequel -- 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 +220,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. @@ -245,6 +245,7 @@ flattenCgStmts id stmts = isJump (CmmJump _ _) = True isJump (CmmBranch _) = True +isJump (CmmSwitch _ _) = True isJump _ = False isOrdinaryStmt (CgStmt _) = True @@ -378,11 +379,11 @@ 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 } @@ -510,8 +511,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 @@ -733,9 +734,9 @@ 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 args blocks + = do { let proc_block = CmmProc info lbl args blocks ; state <- getState ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } } @@ -744,7 +745,7 @@ emitSimpleProc :: CLabel -> Code -> Code 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) @@ -806,8 +807,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 +832,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