summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSimon Marlow <marlowsd@gmail.com>2012-09-25 16:03:36 +0100
committerSimon Marlow <marlowsd@gmail.com>2012-09-25 16:13:17 +0100
commit16206a6603e87e15d61c57456267c5f7ba68050e (patch)
tree1c5577358d3c50adf44ef3dadbfa85c53a3ef27d
parent3473e213941b74a1074ec0cde77c0eeccf885e03 (diff)
downloadhaskell-16206a6603e87e15d61c57456267c5f7ba68050e.tar.gz
Remove some old-codegen cruft
-rw-r--r--compiler/cmm/CmmOpt.hs269
-rw-r--r--compiler/codeGen/CodeGen.lhs234
-rw-r--r--compiler/codeGen/StgCmm.hs8
-rw-r--r--compiler/ghc.cabal.in2
-rw-r--r--compiler/main/DynFlags.hs4
-rw-r--r--compiler/main/HscMain.hs14
-rw-r--r--compiler/nativeGen/AsmCodeGen.lhs15
-rw-r--r--compiler/simplStg/SRT.lhs166
-rw-r--r--compiler/simplStg/SimplStg.lhs13
-rw-r--r--compiler/stgSyn/StgSyn.lhs12
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