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

Remove some old-codegen cruft

parent 3473e213
This diff is collapsed.
%
% (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
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] #))
......
%
% (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}
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment