Commit e5374a1b authored by Jan Stolarek's avatar Jan Stolarek

Cleanup StgCmm pass

This cleanup includes:
  * removing dead code. This includes forkStatics function,
    which was in fact one big noop, and global bindings in
    CgInfoDownwards,
  * converting functions that used FCode monad only to
    access DynFlags into functions that take DynFlags
    as a parameter and don't work in a monad,
  * addBindC function is now smarter. It extracts Id from
    CgIdInfo passed to it in the same way addBindsC does.
    Previously this was done at every call site, which was
    redundant.
parent 3f279f37
......@@ -118,33 +118,33 @@ variable. -}
cgTopBinding :: DynFlags -> StgBinding -> FCode ()
cgTopBinding dflags (StgNonRec id rhs)
= do { id' <- maybeExternaliseId dflags id
; (info, fcode) <- cgTopRhs NonRecursive id' rhs
; let (info, fcode) = cgTopRhs dflags NonRecursive id' rhs
; fcode
; addBindC (cg_id info) info -- Add the *un-externalised* Id to the envt,
-- so we find it when we look up occurrences
; addBindC info -- Add the *un-externalised* Id to the envt,
-- so we find it when we look up occurrences
}
cgTopBinding dflags (StgRec pairs)
= do { let (bndrs, rhss) = unzip pairs
; bndrs' <- Prelude.mapM (maybeExternaliseId dflags) bndrs
; let pairs' = zip bndrs' rhss
; r <- sequence $ unzipWith (cgTopRhs Recursive) pairs'
; let (infos, fcodes) = unzip r
r = unzipWith (cgTopRhs dflags Recursive) pairs'
(infos, fcodes) = unzip r
; addBindsC infos
; sequence_ fcodes
}
cgTopRhs :: RecFlag -> Id -> StgRhs -> FCode (CgIdInfo, FCode ())
cgTopRhs :: DynFlags -> RecFlag -> Id -> StgRhs -> (CgIdInfo, FCode ())
-- The Id is passed along for setting up a binding...
-- It's already been externalised if necessary
cgTopRhs _rec bndr (StgRhsCon _cc con args)
= forkStatics (cgTopRhsCon bndr con args)
cgTopRhs dflags _rec bndr (StgRhsCon _cc con args)
= cgTopRhsCon dflags bndr con args
cgTopRhs rec bndr (StgRhsClosure cc bi fvs upd_flag _srt args body)
cgTopRhs dflags rec bndr (StgRhsClosure cc bi fvs upd_flag _srt args body)
= ASSERT(null fvs) -- There should be no free variables
forkStatics (cgTopRhsClosure rec bndr cc bi upd_flag args body)
cgTopRhsClosure dflags rec bndr cc bi upd_flag args body
---------------------------------------------------------------
......
......@@ -58,22 +58,21 @@ import Control.Monad
-- For closures bound at top level, allocate in static space.
-- They should have no free variables.
cgTopRhsClosure :: RecFlag -- member of a recursive group?
cgTopRhsClosure :: DynFlags
-> RecFlag -- member of a recursive group?
-> Id
-> CostCentreStack -- Optional cost centre annotation
-> StgBinderInfo
-> UpdateFlag
-> [Id] -- Args
-> StgExpr
-> FCode (CgIdInfo, FCode ())
cgTopRhsClosure rec id ccs _ upd_flag args body
= do { dflags <- getDynFlags
; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args
; let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id)
cg_id_info = litIdInfo dflags id lf_info (CmmLabel closure_label)
; return (cg_id_info, gen_code dflags lf_info closure_label)
}
-> (CgIdInfo, FCode ())
cgTopRhsClosure dflags rec id ccs _ upd_flag args body =
let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id)
cg_id_info = litIdInfo dflags id lf_info (CmmLabel closure_label)
lf_info = mkClosureLFInfo dflags id TopLevel [] upd_flag args
in (cg_id_info, gen_code dflags lf_info closure_label)
where
-- special case for a indirection (f = g). We create an IND_STATIC
-- closure pointing directly to the indirectee. This is exactly
......@@ -128,7 +127,7 @@ cgTopRhsClosure rec id ccs _ upd_flag args body
cgBind :: StgBinding -> FCode ()
cgBind (StgNonRec name rhs)
= do { (info, fcode) <- cgRhs name rhs
; addBindC (cg_id info) info
; addBindC info
; init <- fcode
; emit init }
-- init cannot be used in body, so slightly better to sink it eagerly
......@@ -316,8 +315,8 @@ mkRhsClosure dflags bndr _cc _bi
arity = length fvs
---------- Default case ------------------
mkRhsClosure _ bndr cc _ fvs upd_flag args body
= do { lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
mkRhsClosure dflags bndr cc _ fvs upd_flag args body
= do { let lf_info = mkClosureLFInfo dflags bndr NotTopLevel fvs upd_flag args
; (id_info, reg) <- rhsIdInfo bndr lf_info
; return (id_info, gen_code lf_info reg) }
where
......@@ -410,17 +409,18 @@ cgRhsStdThunk bndr lf_info payload
; return (mkRhsInit dflags reg lf_info hp_plus_n) }
mkClosureLFInfo :: Id -- The binder
mkClosureLFInfo :: DynFlags
-> Id -- The binder
-> TopLevelFlag -- True of top level
-> [NonVoid Id] -- Free vars
-> UpdateFlag -- Update flag
-> [Id] -- Args
-> FCode LambdaFormInfo
mkClosureLFInfo bndr top fvs upd_flag args
| null args = return (mkLFThunk (idType bndr) top (map unsafe_stripNV fvs) upd_flag)
-> LambdaFormInfo
mkClosureLFInfo dflags bndr top fvs upd_flag args
| null args =
mkLFThunk (idType bndr) top (map unsafe_stripNV fvs) upd_flag
| otherwise =
do { arg_descr <- mkArgDescr (idName bndr) args
; return (mkLFReEntrant top (map unsafe_stripNV fvs) args arg_descr) }
mkLFReEntrant top (map unsafe_stripNV fvs) args (mkArgDescr dflags args)
------------------------------------------------------------------------
......
......@@ -50,22 +50,21 @@ import Data.Char
-- Top-level constructors
---------------------------------------------------------------
cgTopRhsCon :: Id -- Name of thing bound to this RHS
cgTopRhsCon :: DynFlags
-> Id -- Name of thing bound to this RHS
-> DataCon -- Id
-> [StgArg] -- Args
-> FCode (CgIdInfo, FCode ())
cgTopRhsCon id con args
= do dflags <- getDynFlags
let id_info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label)
return ( id_info, gen_code )
-> (CgIdInfo, FCode ())
cgTopRhsCon dflags id con args =
let id_info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label)
in (id_info, gen_code)
where
name = idName id
caffy = idCafInfo id -- any stgArgHasCafRefs args
closure_label = mkClosureLabel name caffy
gen_code =
do { dflags <- getDynFlags
; this_mod <- getModuleName
do { this_mod <- getModuleName
; when (platformOS (targetPlatform dflags) == OSMinGW32) $
-- Windows DLLs have a problem with static cross-DLL refs.
ASSERT( not (isDllConApp dflags this_mod con args) ) return ()
......
......@@ -8,8 +8,6 @@
module StgCmmEnv (
CgIdInfo,
cgIdInfoId, cgIdInfoLF,
litIdInfo, lneIdInfo, rhsIdInfo, mkRhsInit,
idInfoToAmode,
......@@ -113,12 +111,6 @@ addDynTag :: DynFlags -> CmmExpr -> DynTag -> CmmExpr
-- A tag adds a byte offset to the pointer
addDynTag dflags expr tag = cmmOffsetB dflags expr tag
cgIdInfoId :: CgIdInfo -> Id
cgIdInfoId = cg_id
cgIdInfoLF :: CgIdInfo -> LambdaFormInfo
cgIdInfoLF = cg_lf
maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])
maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args)
maybeLetNoEscape _other = Nothing
......@@ -132,10 +124,10 @@ maybeLetNoEscape _other = Nothing
-- modifying(modifyBindC) and looking up (getCgIdInfo) bindings.
---------------------------------------------------------
addBindC :: Id -> CgIdInfo -> FCode ()
addBindC name stuff_to_bind = do
addBindC :: CgIdInfo -> FCode ()
addBindC stuff_to_bind = do
binds <- getBinds
setBinds $ extendVarEnv binds name stuff_to_bind
setBinds $ extendVarEnv binds (cg_id stuff_to_bind) stuff_to_bind
addBindsC :: [CgIdInfo] -> FCode ()
addBindsC new_bindings = do
......@@ -147,39 +139,26 @@ addBindsC new_bindings = do
getCgIdInfo :: Id -> FCode CgIdInfo
getCgIdInfo id
= do { -- Try local bindings first
; local_binds <- getBinds
= do { dflags <- getDynFlags
; local_binds <- getBinds -- Try local bindings first
; case lookupVarEnv local_binds id of {
Just info -> return info ;
Nothing -> do
{ -- Try top-level bindings
static_binds <- getStaticBinds
; case lookupVarEnv static_binds id of {
Just info -> return info ;
Nothing ->
Nothing -> do {
-- Should be imported; make up a CgIdInfo for it
let
name = idName id
in
if isExternalName name then do
let ext_lbl = CmmLabel (mkClosureLabel name $ idCafInfo id)
dflags <- getDynFlags
return (litIdInfo dflags id (mkLFImported id) ext_lbl)
else
-- Bug
cgLookupPanic id
}}}}
let name = idName id
; if isExternalName name then
let ext_lbl = CmmLabel (mkClosureLabel name $ idCafInfo id)
in return (litIdInfo dflags id (mkLFImported id) ext_lbl)
else
cgLookupPanic id -- Bug
}}}
cgLookupPanic :: Id -> FCode a
cgLookupPanic id
= do static_binds <- getStaticBinds
local_binds <- getBinds
= do local_binds <- getBinds
pprPanic "StgCmmEnv: variable not found"
(vcat [ppr id,
ptext (sLit "static binds for:"),
vcat [ ppr (cg_id info) | info <- varEnvElts static_binds ],
ptext (sLit "local binds for:"),
vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ]
])
......@@ -210,7 +189,7 @@ bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg
bindToReg nvid@(NonVoid id) lf_info
= do dflags <- getDynFlags
let reg = idToReg dflags nvid
addBindC id (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))
addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))
return reg
rebindToReg :: NonVoid Id -> FCode LocalReg
......@@ -218,7 +197,7 @@ rebindToReg :: NonVoid Id -> FCode LocalReg
-- get its LF info from the envt
rebindToReg nvid@(NonVoid id)
= do { info <- getCgIdInfo id
; bindToReg nvid (cgIdInfoLF info) }
; bindToReg nvid (cg_lf info) }
bindArgToReg :: NonVoid Id -> FCode LocalReg
bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)
......
......@@ -106,7 +106,7 @@ cgLneBinds join_id (StgNonRec bndr rhs)
-- See Note [Saving the current cost centre]
; (info, fcode) <- cgLetNoEscapeRhs join_id local_cc bndr rhs
; fcode
; addBindC (cg_id info) info }
; addBindC info }
cgLneBinds join_id (StgRec pairs)
= do { local_cc <- saveCurrentCostCentre
......@@ -676,9 +676,9 @@ cgTailCall fun_id fun_info args = do
where
fun_arg = StgVarArg fun_id
fun_name = idName fun_id
fun = idInfoToAmode fun_info
lf_info = cgIdInfoLF fun_info
fun_name = idName fun_id
fun = idInfoToAmode fun_info
lf_info = cg_lf fun_info
node_points dflags = nodeMustPointToIt dflags lf_info
......
......@@ -39,8 +39,7 @@ import CmmInfo
import CLabel
import StgSyn
import Id
import Name
import TyCon ( PrimRep(..) )
import TyCon ( PrimRep(..) )
import BasicTypes ( RepArity )
import DynFlags
import Module
......@@ -360,15 +359,14 @@ mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags False
-- bring in ARG_P, ARG_N, etc.
#include "../includes/rts/storage/FunTypes.h"
mkArgDescr :: Name -> [Id] -> FCode ArgDescr
mkArgDescr _nm args
= do dflags <- getDynFlags
let arg_bits = argBits dflags arg_reps
arg_reps = filter isNonV (map idArgRep args)
mkArgDescr :: DynFlags -> [Id] -> ArgDescr
mkArgDescr dflags args
= let arg_bits = argBits dflags arg_reps
arg_reps = filter isNonV (map idArgRep args)
-- Getting rid of voids eases matching of standard patterns
case stdPattern arg_reps of
Just spec_id -> return (ArgSpec spec_id)
Nothing -> return (ArgGen arg_bits)
in case stdPattern arg_reps of
Just spec_id -> ArgSpec spec_id
Nothing -> ArgGen arg_bits
argBits :: DynFlags -> [ArgRep] -> [Bool] -- True for non-ptr, False for ptr
argBits _ [] = []
......
......@@ -26,7 +26,7 @@ module StgCmmMonad (
mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto,
mkCall, mkCmmCall,
forkClosureBody, forkStatics, forkAlts, forkProc, codeOnly,
forkClosureBody, forkAlts, forkProc, codeOnly,
ConTagZ,
......@@ -48,7 +48,7 @@ module StgCmmMonad (
-- more localised access to monad state
CgIdInfo(..), CgLoc(..),
getBinds, setBinds, getStaticBinds,
getBinds, setBinds,
-- out of general friendliness, we also export ...
CgInfoDownwards(..), CgState(..) -- non-abstract
......@@ -171,7 +171,6 @@ data CgInfoDownwards -- information only passed *downwards* by the monad
= MkCgInfoDown {
cgd_dflags :: DynFlags,
cgd_mod :: Module, -- Module being compiled
cgd_statics :: CgBindings, -- [Id -> info] : static environment
cgd_updfr_off :: UpdFrameOffset, -- Size of current update frame
cgd_ticky :: CLabel, -- Current destination for ticky counts
cgd_sequel :: Sequel -- What to do at end of basic block
......@@ -299,7 +298,6 @@ initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
initCgInfoDown dflags mod
= MkCgInfoDown { cgd_dflags = dflags
, cgd_mod = mod
, cgd_statics = emptyVarEnv
, cgd_updfr_off = initUpdFrameOff dflags
, cgd_ticky = mkTopTickyCtrLabel
, cgd_sequel = initSequel }
......@@ -428,11 +426,6 @@ setBinds new_binds = do
state <- getState
setState $ state {cgs_binds = new_binds}
getStaticBinds :: FCode CgBindings
getStaticBinds = do
info <- getInfoDown
return (cgd_statics info)
withState :: FCode a -> CgState -> FCode (a,CgState)
withState (FCode fcode) newstate = FCode $ \info_down state ->
case fcode info_down newstate of
......@@ -548,24 +541,6 @@ forkClosureBody body_code
((),fork_state_out) = doFCode body_code body_info_down fork_state_in
; setState $ state `addCodeBlocksFrom` fork_state_out }
forkStatics :: FCode a -> FCode a
-- @forkStatics@ $fc$ compiles $fc$ in an environment whose *statics* come
-- from the current *local bindings*, but which is otherwise freshly initialised.
-- The Abstract~C returned is attached to the current state, but the
-- bindings and usage information is otherwise unchanged.
forkStatics body_code
= do { dflags <- getDynFlags
; info <- getInfoDown
; us <- newUniqSupply
; state <- getState
; let rhs_info_down = info { cgd_statics = cgs_binds state
, cgd_sequel = initSequel
, cgd_updfr_off = initUpdFrameOff dflags }
(result, fork_state_out) = doFCode body_code rhs_info_down
(initCgState us)
; setState (state `addCodeBlocksFrom` fork_state_out)
; return result }
forkProc :: FCode a -> FCode a
-- 'forkProc' takes a code and compiles it in the *current* environment,
-- returning the graph thus constructed.
......
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