Commit 16206a66 authored by Simon Marlow's avatar Simon Marlow

Remove some old-codegen cruft

parent 3473e213
......@@ -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
......
%
% (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}
......@@ -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
......
......@@ -245,7 +245,6 @@ Library
StgCmmTicky
StgCmmUtils
ClosureInfo
CodeGen
SMRep
CoreArity
CoreFVs
......@@ -364,7 +363,6 @@ Library
SimplMonad
SimplUtils
Simplify
SRT
SimplStg
StgStats
UnariseStg
......
......@@ -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,
......
......@@ -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
......
......@@ -51,7 +51,7 @@ import NCGMonad
import BlockId