diff options
| -rw-r--r-- | compiler/cmm/CmmOpt.hs | 269 | ||||
| -rw-r--r-- | compiler/codeGen/CodeGen.lhs | 234 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmm.hs | 8 | ||||
| -rw-r--r-- | compiler/ghc.cabal.in | 2 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 4 | ||||
| -rw-r--r-- | compiler/main/HscMain.hs | 14 | ||||
| -rw-r--r-- | compiler/nativeGen/AsmCodeGen.lhs | 15 | ||||
| -rw-r--r-- | compiler/simplStg/SRT.lhs | 166 | ||||
| -rw-r--r-- | compiler/simplStg/SimplStg.lhs | 13 | ||||
| -rw-r--r-- | compiler/stgSyn/StgSyn.lhs | 12 |
10 files changed, 15 insertions, 722 deletions
diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index 0df24a6a66..32afa1d078 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -7,8 +7,6 @@ ----------------------------------------------------------------------------- module CmmOpt ( - cmmEliminateDeadBlocks, - cmmMiniInline, cmmMachOpFold, cmmMachOpFoldM, cmmLoopifyForC, @@ -17,282 +15,15 @@ module CmmOpt ( #include "HsVersions.h" import OldCmm -import OldPprCmm -import CmmNode (wrapRecExp) -import CmmUtils import DynFlags import CLabel -import UniqFM -import Unique -import Util import FastTypes import Outputable import Platform -import BlockId import Data.Bits import Data.Maybe -import Data.List - --- ----------------------------------------------------------------------------- --- Eliminates dead blocks - -{- -We repeatedly expand the set of reachable blocks until we hit a -fixpoint, and then prune any blocks that were not in this set. This is -actually a required optimization, as dead blocks can cause problems -for invariants in the linear register allocator (and possibly other -places.) --} - --- Deep fold over statements could probably be abstracted out, but it --- might not be worth the effort since OldCmm is moribund -cmmEliminateDeadBlocks :: [CmmBasicBlock] -> [CmmBasicBlock] -cmmEliminateDeadBlocks [] = [] -cmmEliminateDeadBlocks blocks@(BasicBlock base_id _:_) = - let -- Calculate what's reachable from what block - reachableMap = foldl' f emptyUFM blocks -- lazy in values - where f m (BasicBlock block_id stmts) = addToUFM m block_id (reachableFrom stmts) - reachableFrom stmts = foldl stmt [] stmts - where - stmt m CmmNop = m - stmt m (CmmComment _) = m - stmt m (CmmAssign _ e) = expr m e - stmt m (CmmStore e1 e2) = expr (expr m e1) e2 - stmt m (CmmCall c _ as _) = f (actuals m as) c - where f m (CmmCallee e _) = expr m e - f m (CmmPrim _ Nothing) = m - f m (CmmPrim _ (Just stmts)) = foldl' stmt m stmts - stmt m (CmmBranch b) = b:m - stmt m (CmmCondBranch e b) = b:(expr m e) - stmt m (CmmSwitch e bs) = catMaybes bs ++ expr m e - stmt m (CmmJump e _) = expr m e - stmt m (CmmReturn) = m - actuals m as = foldl' (\m h -> expr m (hintlessCmm h)) m as - -- We have to do a deep fold into CmmExpr because - -- there may be a BlockId in the CmmBlock literal. - expr m (CmmLit l) = lit m l - expr m (CmmLoad e _) = expr m e - expr m (CmmReg _) = m - expr m (CmmMachOp _ es) = foldl' expr m es - expr m (CmmStackSlot _ _) = m - expr m (CmmRegOff _ _) = m - lit m (CmmBlock b) = b:m - lit m _ = m - -- go todo done - reachable = go [base_id] (setEmpty :: BlockSet) - where go [] m = m - go (x:xs) m - | setMember x m = go xs m - | otherwise = go (add ++ xs) (setInsert x m) - where add = fromMaybe (panic "cmmEliminateDeadBlocks: unknown block") - (lookupUFM reachableMap x) - in filter (\(BasicBlock block_id _) -> setMember block_id reachable) blocks - --- ----------------------------------------------------------------------------- --- The mini-inliner - -{- -This pass inlines assignments to temporaries. Temporaries that are -only used once are unconditionally inlined. Temporaries that are used -two or more times are only inlined if they are assigned a literal. It -works as follows: - - - count uses of each temporary - - for each temporary: - - attempt to push it forward to the statement that uses it - - only push forward past assignments to other temporaries - (assumes that temporaries are single-assignment) - - if we reach the statement that uses it, inline the rhs - and delete the original assignment. - -[N.B. In the Quick C-- compiler, this optimization is achieved by a - combination of two dataflow passes: forward substitution (peephole - optimization) and dead-assignment elimination. ---NR] - -Possible generalisations: here is an example from factorial - -Fac_zdwfac_entry: - cmG: - _smi = R2; - if (_smi != 0) goto cmK; - R1 = R3; - jump I64[Sp]; - cmK: - _smn = _smi * R3; - R2 = _smi + (-1); - R3 = _smn; - jump Fac_zdwfac_info; - -We want to inline _smi and _smn. To inline _smn: - - - we must be able to push forward past assignments to global regs. - We can do this if the rhs of the assignment we are pushing - forward doesn't refer to the global reg being assigned to; easy - to test. - -To inline _smi: - - - It is a trivial replacement, reg for reg, but it occurs more than - once. - - We can inline trivial assignments even if the temporary occurs - more than once, as long as we don't eliminate the original assignment - (this doesn't help much on its own). - - We need to be able to propagate the assignment forward through jumps; - if we did this, we would find that it can be inlined safely in all - its occurrences. --} - -countUses :: UserOfLocalRegs a => a -> UniqFM Int -countUses a = foldRegsUsed (\m r -> addToUFM_C (+) m r 1) emptyUFM a - -cmmMiniInline :: DynFlags -> [CmmBasicBlock] -> [CmmBasicBlock] -cmmMiniInline dflags blocks = map do_inline blocks - where do_inline (BasicBlock id stmts) - = BasicBlock id (cmmMiniInlineStmts dflags (countUses blocks) stmts) - -cmmMiniInlineStmts :: DynFlags -> UniqFM Int -> [CmmStmt] -> [CmmStmt] -cmmMiniInlineStmts _ _ [] = [] -cmmMiniInlineStmts dflags uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts) - -- not used: just discard this assignment - | 0 <- lookupWithDefaultUFM uses 0 u - = cmmMiniInlineStmts dflags uses stmts - - -- used (foldable to small thing): try to inline at all the use sites - | Just n <- lookupUFM uses u, - e <- wrapRecExp foldExp expr, - isTiny e - = - ncgDebugTrace ("nativeGen: inlining " ++ showSDoc dflags (pprStmt stmt)) $ - case lookForInlineMany u e stmts of - (m, stmts') - | n == m -> cmmMiniInlineStmts dflags (delFromUFM uses u) stmts' - | otherwise -> - stmt : cmmMiniInlineStmts dflags (adjustUFM (\x -> x - m) uses u) stmts' - - -- used once (non-literal): try to inline at the use site - | Just 1 <- lookupUFM uses u, - Just stmts' <- lookForInline u expr stmts - = - ncgDebugTrace ("nativeGen: inlining " ++ showSDoc dflags (pprStmt stmt)) $ - cmmMiniInlineStmts dflags uses stmts' - where - isTiny (CmmLit _) = True - isTiny (CmmReg (CmmGlobal _)) = True - -- not CmmLocal: that might invalidate the usage analysis results - isTiny _ = False - - foldExp (CmmMachOp op args) = cmmMachOpFold dflags op args - foldExp e = e - - ncgDebugTrace str x = if ncgDebugIsOn then trace str x else x - -cmmMiniInlineStmts platform uses (stmt:stmts) - = stmt : cmmMiniInlineStmts platform uses stmts - --- | Takes a register, a 'CmmLit' expression assigned to that --- register, and a list of statements. Inlines the expression at all --- use sites of the register. Returns the number of substituations --- made and the, possibly modified, list of statements. -lookForInlineMany :: Unique -> CmmExpr -> [CmmStmt] -> (Int, [CmmStmt]) -lookForInlineMany u expr stmts = lookForInlineMany' u expr regset stmts - where regset = foldRegsUsed extendRegSet emptyRegSet expr - -lookForInlineMany' :: Unique -> CmmExpr -> RegSet -> [CmmStmt] -> (Int, [CmmStmt]) -lookForInlineMany' _ _ _ [] = (0, []) -lookForInlineMany' u expr regset stmts@(stmt : rest) - | Just n <- lookupUFM (countUses stmt) u, okToInline expr stmt - = let stmt' = inlineStmt u expr stmt in - if okToSkip stmt' u expr regset - then case lookForInlineMany' u expr regset rest of - (m, stmts) -> let z = n + m - in z `seq` (z, stmt' : stmts) - else (n, stmt' : rest) - - | okToSkip stmt u expr regset - = case lookForInlineMany' u expr regset rest of - (n, stmts) -> (n, stmt : stmts) - - | otherwise - = (0, stmts) - - -lookForInline :: Unique -> CmmExpr -> [CmmStmt] -> Maybe [CmmStmt] -lookForInline u expr stmts = lookForInline' u expr regset stmts - where regset = foldRegsUsed extendRegSet emptyRegSet expr - -lookForInline' :: Unique -> CmmExpr -> RegSet -> [CmmStmt] -> Maybe [CmmStmt] -lookForInline' _ _ _ [] = panic "lookForInline' []" -lookForInline' u expr regset (stmt : rest) - | Just 1 <- lookupUFM (countUses stmt) u, okToInline expr stmt - = Just (inlineStmt u expr stmt : rest) - - | okToSkip stmt u expr regset - = case lookForInline' u expr regset rest of - Nothing -> Nothing - Just stmts -> Just (stmt:stmts) - - | otherwise - = Nothing - - --- we don't inline into CmmCall if the expression refers to global --- registers. This is a HACK to avoid global registers clashing with --- C argument-passing registers, really the back-end ought to be able --- to handle it properly, but currently neither PprC nor the NCG can --- do it. See also CgForeignCall:load_args_into_temps. -okToInline :: CmmExpr -> CmmStmt -> Bool -okToInline expr CmmCall{} = hasNoGlobalRegs expr -okToInline _ _ = True - --- Expressions aren't side-effecting. Temporaries may or may not --- be single-assignment depending on the source (the old code --- generator creates single-assignment code, but hand-written Cmm --- and Cmm from the new code generator is not single-assignment.) --- So we do an extra check to make sure that the register being --- changed is not one we were relying on. I don't know how much of a --- performance hit this is (we have to create a regset for every --- instruction.) -- EZY -okToSkip :: CmmStmt -> Unique -> CmmExpr -> RegSet -> Bool -okToSkip stmt u expr regset - = case stmt of - CmmNop -> True - CmmComment{} -> True - CmmAssign (CmmLocal r@(LocalReg u' _)) _rhs | u' /= u && not (r `elemRegSet` regset) -> True - CmmAssign g@(CmmGlobal _) _rhs -> not (g `regUsedIn` expr) - CmmStore _ _ -> not_a_load expr - _other -> False - where - not_a_load (CmmMachOp _ args) = all not_a_load args - not_a_load (CmmLoad _ _) = False - not_a_load _ = True - -inlineStmt :: Unique -> CmmExpr -> CmmStmt -> CmmStmt -inlineStmt u a (CmmAssign r e) = CmmAssign r (inlineExpr u a e) -inlineStmt u a (CmmStore e1 e2) = CmmStore (inlineExpr u a e1) (inlineExpr u a e2) -inlineStmt u a (CmmCall target regs es ret) - = CmmCall (infn target) regs es' ret - where infn (CmmCallee fn cconv) = CmmCallee (inlineExpr u a fn) cconv - infn (CmmPrim p mStmts) = CmmPrim p (fmap (map (inlineStmt u a)) mStmts) - es' = [ (CmmHinted (inlineExpr u a e) hint) | (CmmHinted e hint) <- es ] -inlineStmt u a (CmmCondBranch e d) = CmmCondBranch (inlineExpr u a e) d -inlineStmt u a (CmmSwitch e d) = CmmSwitch (inlineExpr u a e) d -inlineStmt u a (CmmJump e live) = CmmJump (inlineExpr u a e) live -inlineStmt _ _ other_stmt = other_stmt - -inlineExpr :: Unique -> CmmExpr -> CmmExpr -> CmmExpr -inlineExpr u a e@(CmmReg (CmmLocal (LocalReg u' _))) - | u == u' = a - | otherwise = e -inlineExpr u a e@(CmmRegOff (CmmLocal (LocalReg u' rep)) off) - | u == u' = CmmMachOp (MO_Add width) [a, CmmLit (CmmInt (fromIntegral off) width)] - | otherwise = e - where - width = typeWidth rep -inlineExpr u a (CmmLoad e rep) = CmmLoad (inlineExpr u a e) rep -inlineExpr u a (CmmMachOp op es) = CmmMachOp op (map (inlineExpr u a) es) -inlineExpr _ _ other_expr = other_expr -- ----------------------------------------------------------------------------- -- MachOp constant folder diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs deleted file mode 100644 index 311f947248..0000000000 --- a/compiler/codeGen/CodeGen.lhs +++ /dev/null @@ -1,234 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% - -The Code Generator - -This module says how things get going at the top level. - -@codeGen@ is the interface to the outside world. The \tr{cgTop*} -functions drive the mangling of top-level bindings. - -\begin{code} - -module CodeGen ( codeGen ) where - -#include "HsVersions.h" - --- Required so that CgExpr is reached via at least one non-SOURCE --- import. Before, that wasn't the case, and CM therefore didn't --- bother to compile it. -import CgExpr ( {-NOTHING!-} ) -- DO NOT DELETE THIS IMPORT -import CgProf -import CgMonad -import CgBindery -import CgClosure -import CgCon -import CgUtils -import CgHpc - -import CLabel -import OldCmm -import OldPprCmm () - -import StgSyn -import PrelNames -import DynFlags - -import HscTypes -import CostCentre -import Id -import Name -import TyCon -import Module -import ErrUtils -import Panic -import Outputable -import Util - -import OrdList -import Stream (Stream, liftIO) -import qualified Stream - -import Data.IORef - -codeGen :: DynFlags - -> Module -- Module we are compiling - -> [TyCon] -- Type constructors - -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. - -> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs - -> HpcInfo -- Profiling info - -> Stream IO CmmGroup () - -- N.B. returning '[Cmm]' and not 'Cmm' here makes it - -- possible for object splitting to split up the - -- pieces later. - -codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info - - = do { liftIO $ showPass dflags "CodeGen" - - ; cgref <- liftIO $ newIORef =<< initC - ; let cg :: FCode CmmGroup -> Stream IO CmmGroup () - cg fcode = do - cmm <- liftIO $ do - st <- readIORef cgref - let (a,st') = runC dflags this_mod st fcode - - dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" $ ppr a - - -- NB. stub-out cgs_tops and cgs_stmts. This fixes - -- a big space leak. DO NOT REMOVE! - writeIORef cgref $! st'{ cgs_tops = nilOL, - cgs_stmts = nilOL } - return a - Stream.yield cmm - - ; cg (getCmm $ mkModuleInit dflags cost_centre_info this_mod hpc_info) - - ; mapM_ (cg . getCmm . cgTopBinding dflags) stg_binds - - ; mapM_ (cg . cgTyCon) data_tycons - } - -mkModuleInit - :: DynFlags - -> CollectedCCs -- cost centre info - -> Module - -> HpcInfo - -> Code - -mkModuleInit dflags cost_centre_info this_mod hpc_info - = do { -- Allocate the static boolean that records if this - ; whenC (dopt Opt_Hpc dflags) $ - hpcTable this_mod hpc_info - - ; whenC (dopt Opt_SccProfilingOn dflags) $ do - initCostCentres cost_centre_info - - -- For backwards compatibility: user code may refer to this - -- label for calling hs_add_root(). - ; emitDecl (CmmData Data (Statics (mkPlainModuleInitLabel this_mod) [])) - - ; whenC (this_mod == mainModIs dflags) $ - emitSimpleProc (mkPlainModuleInitLabel rOOT_MAIN) $ return () - } -\end{code} - - - -Cost-centre profiling: Besides the usual stuff, we must produce -declarations for the cost-centres defined in this module; - -(The local cost-centres involved in this are passed into the -code-generator.) - -\begin{code} -initCostCentres :: CollectedCCs -> Code --- Emit the declarations, and return code to register them -initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs) - = do dflags <- getDynFlags - if not (dopt Opt_SccProfilingOn dflags) - then nopC - else do mapM_ emitCostCentreDecl local_CCs - mapM_ emitCostCentreStackDecl singleton_CCSs -\end{code} - -%************************************************************************ -%* * -\subsection[codegen-top-bindings]{Converting top-level STG bindings} -%* * -%************************************************************************ - -@cgTopBinding@ is only used for top-level bindings, since they need -to be allocated statically (not in the heap) and need to be labelled. -No unboxed bindings can happen at top level. - -In the code below, the static bindings are accumulated in the -@MkCgState@, and transferred into the ``statics'' slot by @forkStatics@. -This is so that we can write the top level processing in a compositional -style, with the increasing static environment being plumbed as a state -variable. - -\begin{code} -cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> Code -cgTopBinding dflags (StgNonRec id rhs, srts) - = do { id' <- maybeExternaliseId dflags id - ; mapM_ (mkSRT [id']) srts - ; (id,info) <- cgTopRhs id' rhs - ; addBindC id info -- Add the *un-externalised* Id to the envt, - -- so we find it when we look up occurrences - } - -cgTopBinding dflags (StgRec pairs, srts) - = do { let (bndrs, rhss) = unzip pairs - ; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs - ; let pairs' = zip bndrs' rhss - ; mapM_ (mkSRT bndrs') srts - ; _new_binds <- fixC (\ new_binds -> do - { addBindsC new_binds - ; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' }) - ; nopC } - -mkSRT :: [Id] -> (Id,[Id]) -> Code -mkSRT _ (_,[]) = nopC -mkSRT these (id,ids) - = do { ids <- mapFCs remap ids - ; id <- remap id - ; emitRODataLits "CodeGen.mkSRT" (mkSRTLabel (idName id) (idCafInfo id)) - (map (\id -> CmmLabel $ mkClosureLabel (idName id) (idCafInfo id)) ids) - } - where - -- Sigh, better map all the ids against the environment in - -- case they've been externalised (see maybeExternaliseId below). - remap id = case filter (==id) these of - (id':_) -> returnFC id' - [] -> do { info <- getCgIdInfo id; return (cgIdInfoId info) } - --- Urgh! I tried moving the forkStatics call from the rhss of cgTopRhs --- to enclose the listFCs in cgTopBinding, but that tickled the --- statics "error" call in initC. I DON'T UNDERSTAND WHY! - -cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo) - -- The Id is passed along for setting up a binding... - -- It's already been externalised if necessary - -cgTopRhs bndr (StgRhsCon _cc con args) - = forkStatics (cgTopRhsCon bndr con args) - -cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag srt args body) - = ASSERT(null fvs) -- There should be no free variables - setSRTLabel (mkSRTLabel (idName bndr) (idCafInfo bndr)) $ - setSRT srt $ - forkStatics (cgTopRhsClosure bndr cc bi upd_flag args body) -\end{code} - - -%************************************************************************ -%* * -\subsection{Stuff to support splitting} -%* * -%************************************************************************ - -If we're splitting the object, we need to externalise all the top-level names -(and then make sure we only use the externalised one in any C label we use -which refers to this name). - -\begin{code} -maybeExternaliseId :: DynFlags -> Id -> FCode Id -maybeExternaliseId dflags id - | dopt Opt_SplitObjs dflags, -- Externalise the name for -split-objs - isInternalName name = do { mod <- getModuleName - ; returnFC (setIdName id (externalise mod)) } - | otherwise = returnFC id - where - externalise mod = mkExternalName uniq mod new_occ loc - name = idName id - uniq = nameUnique name - new_occ = mkLocalOcc uniq (nameOccName name) - loc = nameSrcSpan name - -- We want to conjure up a name that can't clash with any - -- existing name. So we generate - -- Mod_$L243foo - -- where 243 is the unique. -\end{code} diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index f1022e5280..37ca5e0d43 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -52,7 +52,7 @@ codeGen :: DynFlags -> Module -> [TyCon] -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. - -> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs + -> [StgBinding] -- Bindings to convert -> HpcInfo -> Stream IO CmmGroup () -- Output as a stream, so codegen can -- be interleaved with output @@ -114,8 +114,8 @@ This is so that we can write the top level processing in a compositional style, with the increasing static environment being plumbed as a state variable. -} -cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> FCode () -cgTopBinding dflags (StgNonRec id rhs, _srts) +cgTopBinding :: DynFlags -> StgBinding -> FCode () +cgTopBinding dflags (StgNonRec id rhs) = do { id' <- maybeExternaliseId dflags id ; (info, fcode) <- cgTopRhs id' rhs ; fcode @@ -123,7 +123,7 @@ cgTopBinding dflags (StgNonRec id rhs, _srts) -- so we find it when we look up occurrences } -cgTopBinding dflags (StgRec pairs, _srts) +cgTopBinding dflags (StgRec pairs) = do { let (bndrs, rhss) = unzip pairs ; bndrs' <- Prelude.mapM (maybeExternaliseId dflags) bndrs ; let pairs' = zip bndrs' rhss diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index f07cccffe0..6d83150eb6 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -245,7 +245,6 @@ Library StgCmmTicky StgCmmUtils ClosureInfo - CodeGen SMRep CoreArity CoreFVs @@ -364,7 +363,6 @@ Library SimplMonad SimplUtils Simplify - SRT SimplStg StgStats UnariseStg diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 080539a68c..ed273d90e5 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -348,7 +348,6 @@ data DynFlag | Opt_RunCPSZ | Opt_AutoLinkPackages | Opt_ImplicitImportQualified - | Opt_TryNewCodeGen -- keeping stuff | Opt_KeepHiDiffs @@ -2267,7 +2266,6 @@ fFlags = [ ( "print-bind-contents", Opt_PrintBindContents, nop ), ( "run-cps", Opt_RunCPS, nop ), ( "run-cpsz", Opt_RunCPSZ, nop ), - ( "new-codegen", Opt_TryNewCodeGen, nop ), ( "vectorise", Opt_Vectorise, nop ), ( "avoid-vect", Opt_AvoidVect, nop ), ( "regs-graph", Opt_RegsGraph, nop ), @@ -2461,8 +2459,6 @@ defaultFlags platform Opt_SharedImplib, - Opt_TryNewCodeGen, - Opt_GenManifest, Opt_EmbedManifest, Opt_PrintBindContents, diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 5c3fa0d0e5..9a4935cc5b 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -90,7 +90,6 @@ import Panic import GHC.Exts #endif -import Id import Module import Packages import RdrName @@ -119,7 +118,6 @@ import ProfInit import TyCon import Name import SimplStg ( stg2stg ) -import CodeGen ( codeGen ) import qualified OldCmm as Old import qualified Cmm as New import CmmParse ( parseCmmFile ) @@ -1284,16 +1282,10 @@ hscGenHardCode cgguts mod_summary = do ------------------ Code generation ------------------ - cmms <- if dopt Opt_TryNewCodeGen dflags - then {-# SCC "NewCodeGen" #-} + cmms <- {-# SCC "NewCodeGen" #-} tryNewCodeGen hsc_env this_mod data_tycons cost_centre_info stg_binds hpc_info - else {-# SCC "CodeGen" #-} - return (codeGen dflags this_mod data_tycons - cost_centre_info - stg_binds hpc_info) - ------------------ Code output ----------------------- rawcmms0 <- {-# SCC "cmmToRawCmm" #-} @@ -1369,7 +1361,7 @@ hscCompileCmmFile hsc_env filename = runHsc hsc_env $ do tryNewCodeGen :: HscEnv -> Module -> [TyCon] -> CollectedCCs - -> [(StgBinding,[(Id,[Id])])] + -> [StgBinding] -> HpcInfo -> IO (Stream IO Old.CmmGroup ()) -- Note we produce a 'Stream' of CmmGroups, so that the @@ -1437,7 +1429,7 @@ tryNewCodeGen hsc_env this_mod data_tycons myCoreToStg :: DynFlags -> Module -> CoreProgram - -> IO ( [(StgBinding,[(Id,[Id])])] -- output program + -> IO ( [StgBinding] -- output program , CollectedCCs) -- cost centre info (declared and used) myCoreToStg dflags this_mod prepd_binds = do stg_binds diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 870d285390..47fd96c426 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -51,7 +51,7 @@ import NCGMonad import BlockId import CgUtils ( fixStgRegisters ) import OldCmm -import CmmOpt ( cmmEliminateDeadBlocks, cmmMiniInline, cmmMachOpFold ) +import CmmOpt ( cmmMachOpFold ) import OldPprCmm import CLabel @@ -858,15 +858,13 @@ genMachCode dflags cmmTopCodeGen cmm_top Here we do: (a) Constant folding - (b) Simple inlining: a temporary which is assigned to and then - used, once, can be shorted. (c) Position independent code and dynamic linking (i) introduce the appropriate indirections and position independent refs (ii) compile a list of imported symbols (d) Some arch-specific optimizations -(a) and (b) will be moving to the new Hoopl pipeline, however, (c) and +(a) will be moving to the new Hoopl pipeline, however, (c) and (d) are only needed by the native backend and will continue to live here. @@ -881,14 +879,7 @@ Ideas for other things we could do (put these in Hoopl please!): cmmToCmm :: DynFlags -> RawCmmDecl -> (RawCmmDecl, [CLabel]) cmmToCmm _ top@(CmmData _ _) = (top, []) cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do - let reachable_blocks | dopt Opt_TryNewCodeGen dflags = blocks - | otherwise = cmmEliminateDeadBlocks blocks - -- The new codegen path has already eliminated unreachable blocks by now - - inlined_blocks | dopt Opt_TryNewCodeGen dflags = reachable_blocks - | otherwise = cmmMiniInline dflags reachable_blocks - - blocks' <- mapM cmmBlockConFold inlined_blocks + blocks' <- mapM cmmBlockConFold blocks return $ CmmProc info lbl (ListGraph blocks') newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #)) diff --git a/compiler/simplStg/SRT.lhs b/compiler/simplStg/SRT.lhs deleted file mode 100644 index 92cfad3283..0000000000 --- a/compiler/simplStg/SRT.lhs +++ /dev/null @@ -1,166 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1998 -% - -Run through the STG code and compute the Static Reference Table for -each let-binding. At the same time, we figure out which top-level -bindings have no CAF references, and record the fact in their IdInfo. - -\begin{code} -module SRT( computeSRTs ) where - -#include "HsVersions.h" - -import StgSyn -import Id ( Id ) -import VarSet -import VarEnv -import Maybes ( orElse, expectJust ) -import Bitmap - -import DynFlags -import Outputable - -import Data.List -\end{code} - -\begin{code} -computeSRTs :: DynFlags -> [StgBinding] -> [(StgBinding,[(Id,[Id])])] - -- The incoming bindingd are filled with SRTEntries in their SRT slots - -- the outgoing ones have NoSRT/SRT values instead - -computeSRTs dflags binds = srtTopBinds dflags emptyVarEnv binds - --- -------------------------------------------------------------------------- --- Top-level Bindings - -srtTopBinds :: DynFlags -> IdEnv Id -> [StgBinding] -> [(StgBinding, [(Id,[Id])])] - -srtTopBinds _ _ [] = [] -srtTopBinds dflags env (StgNonRec b rhs : binds) = - (StgNonRec b rhs', [(b,srt')]) : srtTopBinds dflags env' binds - where - (rhs', srt) = srtTopRhs dflags b rhs - env' = maybeExtendEnv env b rhs - srt' = applyEnvList env srt -srtTopBinds dflags env (StgRec bs : binds) = - (StgRec (zip bndrs rhss), zip bndrs srts') : srtTopBinds dflags env binds - where - (rhss, srts) = unzip [ srtTopRhs dflags b r | (b,r) <- bs ] - bndrs = map fst bs - srts' = map (applyEnvList env) srts - --- Shorting out indirections in SRTs: if a binding has an SRT with a single --- element in it, we just inline it with that element everywhere it occurs --- in other SRTs. --- --- This is in a way a generalisation of the CafInfo. CafInfo says --- whether a top-level binding has *zero* CAF references, allowing us --- to omit it from SRTs. Here, we pick up bindings with *one* CAF --- reference, and inline its SRT everywhere it occurs. We could pass --- this information across module boundaries too, but we currently --- don't. - -maybeExtendEnv ::IdEnv Id -> Id -> StgRhs -> IdEnv Id -maybeExtendEnv env bndr (StgRhsClosure _ _ _ ReEntrant (SRTEntries cafs) _ _) - | [one] <- varSetElems cafs - = extendVarEnv env bndr (applyEnv env one) -maybeExtendEnv env _ _ = env - -applyEnvList :: IdEnv Id -> [Id] -> [Id] -applyEnvList env = map (applyEnv env) - -applyEnv :: IdEnv Id -> Id -> Id -applyEnv env id = lookupVarEnv env id `orElse` id - --- ---- Top-level right hand sides: - -srtTopRhs :: DynFlags -> Id -> StgRhs -> (StgRhs, [Id]) - -srtTopRhs _ _ rhs@(StgRhsCon _ _ _) = (rhs, []) -srtTopRhs dflags _ rhs@(StgRhsClosure _ _ _ _ (SRTEntries cafs) _ _) - = (srtRhs dflags table rhs, elems) - where - elems = varSetElems cafs - table = mkVarEnv (zip elems [0..]) -srtTopRhs _ _ (StgRhsClosure _ _ _ _ NoSRT _ _) = panic "srtTopRhs NoSRT" -srtTopRhs _ _ (StgRhsClosure _ _ _ _ (SRT _ _ _) _ _) = panic "srtTopRhs SRT" - --- ---- Binds: - -srtBind :: DynFlags -> IdEnv Int -> StgBinding -> StgBinding - -srtBind dflags table (StgNonRec binder rhs) = StgNonRec binder (srtRhs dflags table rhs) -srtBind dflags table (StgRec pairs) = StgRec [ (b, srtRhs dflags table r) | (b,r) <- pairs ] - --- ---- Right Hand Sides: - -srtRhs :: DynFlags -> IdEnv Int -> StgRhs -> StgRhs - -srtRhs _ _ e@(StgRhsCon _ _ _) = e -srtRhs dflags table (StgRhsClosure cc bi free_vars u srt args body) - = StgRhsClosure cc bi free_vars u (constructSRT dflags table srt) args - $! (srtExpr dflags table body) - --- --------------------------------------------------------------------------- --- Expressions - -srtExpr :: DynFlags -> IdEnv Int -> StgExpr -> StgExpr - -srtExpr _ _ e@(StgApp _ _) = e -srtExpr _ _ e@(StgLit _) = e -srtExpr _ _ e@(StgConApp _ _) = e -srtExpr _ _ e@(StgOpApp _ _ _) = e - -srtExpr dflags table (StgSCC cc tick push expr) = StgSCC cc tick push $! srtExpr dflags table expr - -srtExpr dflags table (StgTick m n expr) = StgTick m n $! srtExpr dflags table expr - -srtExpr dflags table (StgCase scrut live1 live2 uniq srt alt_type alts) - = StgCase expr' live1 live2 uniq srt' alt_type alts' - where - expr' = srtExpr dflags table scrut - srt' = constructSRT dflags table srt - alts' = map (srtAlt dflags table) alts - -srtExpr dflags table (StgLet bind body) - = srtBind dflags table bind =: \ bind' -> - srtExpr dflags table body =: \ body' -> - StgLet bind' body' - -srtExpr dflags table (StgLetNoEscape live1 live2 bind body) - = srtBind dflags table bind =: \ bind' -> - srtExpr dflags table body =: \ body' -> - StgLetNoEscape live1 live2 bind' body' - -srtExpr _ _table expr = pprPanic "srtExpr" (ppr expr) - -srtAlt :: DynFlags -> IdEnv Int -> StgAlt -> StgAlt -srtAlt dflags table (con,args,used,rhs) - = (,,,) con args used $! srtExpr dflags table rhs - ------------------------------------------------------------------------------ --- Construct an SRT bitmap. - -constructSRT :: DynFlags -> IdEnv Int -> SRT -> SRT -constructSRT dflags table (SRTEntries entries) - | isEmptyVarSet entries = NoSRT - | otherwise = seqBitmap bitmap $ SRT offset len bitmap - where - ints = map (expectJust "constructSRT" . lookupVarEnv table) - (varSetElems entries) - sorted_ints = sort ints - offset = head sorted_ints - bitmap_entries = map (subtract offset) sorted_ints - len = last bitmap_entries + 1 - bitmap = intsToBitmap dflags len bitmap_entries -constructSRT _ _ NoSRT = panic "constructSRT NoSRT" -constructSRT _ _ (SRT {}) = panic "constructSRT SRT" - --- --------------------------------------------------------------------------- --- Misc stuff - -(=:) :: a -> (a -> b) -> b -a =: k = k a - -\end{code} diff --git a/compiler/simplStg/SimplStg.lhs b/compiler/simplStg/SimplStg.lhs index 129d8c6423..871a5f4960 100644 --- a/compiler/simplStg/SimplStg.lhs +++ b/compiler/simplStg/SimplStg.lhs @@ -22,12 +22,10 @@ import SCCfinal ( stgMassageForProfiling ) import StgLint ( lintStgBindings ) import StgStats ( showStgStats ) import UnariseStg ( unarise ) -import SRT ( computeSRTs ) import DynFlags ( DynFlags(..), DynFlag(..), dopt, StgToDo(..), getStgToDo ) -import Id ( Id ) -import Module ( Module ) +import Module ( Module ) import ErrUtils import SrcLoc import UniqSupply ( mkSplitUniqSupply, splitUniqSupply ) @@ -38,7 +36,7 @@ import Outputable stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do -> Module -- module name (profiling only) -> [StgBinding] -- input... - -> IO ( [(StgBinding,[(Id,[Id])])] -- output program... + -> IO ( [StgBinding] -- output program... , CollectedCCs) -- cost centre information (declared and used) stg2stg dflags module_name binds @@ -56,14 +54,11 @@ stg2stg dflags module_name binds <- foldl_mn do_stg_pass (binds', us0, ccs) (getStgToDo dflags) ; let un_binds = unarise us1 processed_binds - ; let srt_binds - | dopt Opt_TryNewCodeGen dflags = zip un_binds (repeat []) - | otherwise = computeSRTs dflags un_binds ; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:" - (pprStgBindingsWithSRTs srt_binds) + (pprStgBindings un_binds) - ; return (srt_binds, cost_centres) + ; return (un_binds, cost_centres) } where diff --git a/compiler/stgSyn/StgSyn.lhs b/compiler/stgSyn/StgSyn.lhs index e5c525e4c3..8d00f94ead 100644 --- a/compiler/stgSyn/StgSyn.lhs +++ b/compiler/stgSyn/StgSyn.lhs @@ -38,7 +38,7 @@ module StgSyn ( isDllConApp, stgArgType, - pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs, + pprStgBinding, pprStgBindings, pprStgLVs ) where @@ -651,16 +651,6 @@ pprStgBinding bind = pprGenStgBinding bind pprStgBindings :: [StgBinding] -> SDoc pprStgBindings binds = vcat (map pprGenStgBinding binds) -pprGenStgBindingWithSRT :: (OutputableBndr bndr, Outputable bdee, Ord bdee) - => (GenStgBinding bndr bdee,[(Id,[Id])]) -> SDoc -pprGenStgBindingWithSRT (bind,srts) - = vcat $ pprGenStgBinding bind : map pprSRT srts - where pprSRT (id,srt) = - ptext (sLit "SRT") <> parens (ppr id) <> ptext (sLit ": ") <> ppr srt - -pprStgBindingsWithSRTs :: [(StgBinding,[(Id,[Id])])] -> SDoc -pprStgBindingsWithSRTs binds = vcat (map pprGenStgBindingWithSRT binds) - instance (Outputable bdee) => Outputable (GenStgArg bdee) where ppr = pprStgArg |