module SimplStg ( stg2stg ) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
+IMPORT_1_3(IO(hPutStr,stderr))
import StgSyn
-import StgUtils
import LambdaLift ( liftProgram )
+import Name ( isLocallyDefined )
+import UniqSet ( UniqSet(..), mapUniqSet )
+import CostCentre ( CostCentre )
import SCCfinal ( stgMassageForProfiling )
-import SatStgRhs ( satStgRhs )
import StgLint ( lintStgBindings )
-import StgSAT ( doStaticArgs )
import StgStats ( showStgStats )
import StgVarInfo ( setStgVarInfo )
import UpdAnal ( updateAnalyse )
-import CmdLineOpts ( opt_EnsureSplittableC, opt_SccGroup,
+import CmdLineOpts ( opt_SccGroup, --Not used:opt_EnsureSplittableC,
opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg,
+ opt_DoStgLinting,
StgToDo(..)
)
import Id ( nullIdEnv, lookupIdEnv, addOneToIdEnv,
- growIdEnvList, isNullIdEnv, IdEnv(..),
- GenId{-instance Eq/Outputable -}
+ growIdEnvList, isNullIdEnv, SYN_IE(IdEnv),
+ setIdVisibility,
+ GenId{-instance Eq/Outputable -}, SYN_IE(Id)
)
-import MainMonad ( writeMn, thenMn_, thenMn, returnMn, MainIO(..) )
import Maybes ( maybeToBool )
-import Outputable ( isExported )
import PprType ( GenType{-instance Outputable-} )
-import Pretty ( ppShow, ppAbove, ppAboves, ppStr )
-import UniqSupply ( splitUniqSupply )
+import Outputable ( PprStyle, Outputable(..) )
+import Pretty ( Doc, ($$), vcat, text, ptext )
+import UniqSupply ( splitUniqSupply, UniqSupply )
import Util ( mapAccumL, panic, assertPanic )
-
-unlocaliseId = panic "SimplStg.unlocaliseId (ToDo)"
\end{code}
\begin{code}
-> PprStyle -- printing style (for debugging only)
-> UniqSupply -- a name supply
-> [StgBinding] -- input...
- -> MainIO
+ -> IO
([StgBinding], -- output program...
([CostCentre], -- local cost-centres that need to be decl'd
[CostCentre])) -- "extern" cost-centres
stg2stg stg_todos module_name ppr_style us binds
- = BSCC("Stg2Stg")
- case (splitUniqSupply us) of { (us4now, us4later) ->
+ = case (splitUniqSupply us) of { (us4now, us4later) ->
(if do_verbose_stg2stg then
- writeMn stderr "VERBOSE STG-TO-STG:\n" `thenMn_`
- writeMn stderr (ppShow 1000
- (ppAbove (ppStr ("*** Core2Stg:"))
- (ppAboves (map (ppr ppr_style) (setStgVarInfo False binds)))
+ hPutStr stderr "VERBOSE STG-TO-STG:\n" >>
+ hPutStr stderr (show
+ (($$) (ptext SLIT("*** Core2Stg:"))
+ (vcat (map (ppr ppr_style) (setStgVarInfo False binds)))
))
- else returnMn ()) `thenMn_`
+ else return ()) >>
-- Do the main business!
foldl_mn do_stg_pass (binds, us4now, ([],[])) stg_todos
- `thenMn` \ (processed_binds, _, cost_centres) ->
- -- Do essential wind-up: part (a) is SatStgRhs
-
- -- Not optional, because correct arity information is used by
- -- the code generator. Afterwards do setStgVarInfo; it gives
- -- the wrong answers if arities are subsequently changed,
- -- which stgSatRhs might do. Furthermore, setStgVarInfo
- -- decides about let-no-escape things, which in turn do a
- -- better job if arities are correct, which is done by
- -- satStgRhs.
-
- case (satStgRhs processed_binds us4later) of { saturated_binds ->
+ >>= \ (processed_binds, _, cost_centres) ->
- -- Essential wind-up: part (b), eliminate indirections
+ -- Do essential wind-up
- let no_ind_binds = elimIndirections saturated_binds in
+{- Nuked for now SLPJ Dec 96
+ -- Essential wind-up: part (a), saturate RHSs
+ -- This must occur *after* elimIndirections, because elimIndirections
+ -- can change things' arities. Consider:
+ -- x_local = f x
+ -- x_global = \a -> x_local a
+ -- Then elimIndirections will change the program to
+ -- x_global = f x
+ -- and lo and behold x_global's arity has changed!
+ case (satStgRhs processed_binds us4later) of { saturated_binds ->
+-}
- -- Essential wind-up: part (c), do setStgVarInfo. It has to
+ -- Essential wind-up: part (b), do setStgVarInfo. It has to
-- happen regardless, because the code generator uses its
-- decorations.
--
-- things, which in turn do a better job if arities are
-- correct, which is done by satStgRhs.
--
+
+{-
+ Done in Core now. Nuke soon. SLPJ Nov 96
+
+ No, STG passes may introduce toplevel bindings which
+ have to be globalised here (later than Core anyway) -- SOF 2/97
+
+ Yes, lambda lifting now does the Right Thing.
+
let
-- ToDo: provide proper flag control!
binds_to_mangle
= if not do_unlocalising
- then no_ind_binds
- else snd (unlocaliseStgBinds unlocal_tag nullIdEnv no_ind_binds)
+ then processed_binds
+ else snd (unlocaliseStgBinds unlocal_tag nullIdEnv processed_binds)
in
- returnMn (setStgVarInfo do_let_no_escapes binds_to_mangle, cost_centres)
- }}
- ESCC
+-}
+
+ return (setStgVarInfo do_let_no_escapes processed_binds, cost_centres)
+ }
where
do_let_no_escapes = opt_StgDoLetNoEscapes
do_verbose_stg2stg = opt_D_verbose_stg2stg
- (do_unlocalising, unlocal_tag)
- = case (opt_EnsureSplittableC) of
- Nothing -> (False, panic "tag")
- Just tag -> (True, tag)
-
+{-
+ (do_unlocalising, unlocal_tag)
+ = case opt_EnsureSplittableC of
+ Just tag -> (True, _PK_ tag)
+ Nothing -> (False, panic "tag")
+-}
grp_name = case (opt_SccGroup) of
- Just xx -> xx
+ Just xx -> _PK_ xx
Nothing -> module_name -- default: module name
-------------
- stg_linter = if False -- LATER: switch_is_on DoCoreLinting -- ToDo: DoStgLinting flag
+ stg_linter = if False --LATER: opt_DoStgLinting (ToDo)
then lintStgBindings ppr_style
else ( \ whodunnit binds -> binds )
(us1, us2) = splitUniqSupply us
in
case to_do of
- StgDoStaticArgs ->
- ASSERT(null (fst ccs) && null (snd ccs))
- BSCC("StgStaticArgs")
- let
- binds3 = doStaticArgs binds us1
- in
- end_pass us2 "StgStaticArgs" ccs binds3
- ESCC
+ StgDoStaticArgs -> panic "STG static argument transformation deleted"
StgDoUpdateAnalysis ->
ASSERT(null (fst ccs) && null (snd ccs))
- BSCC("StgUpdAnal")
+ _scc_ "StgUpdAnal"
-- NB We have to do setStgVarInfo first! (There's one
-- place free-var info is used) But no let-no-escapes,
-- because update analysis doesn't care.
end_pass us2 "UpdAnal" ccs (updateAnalyse (setStgVarInfo False binds))
- ESCC
D_stg_stats ->
trace (showStgStats binds)
end_pass us2 "StgStats" ccs binds
StgDoLambdaLift ->
- BSCC("StgLambdaLift")
+ _scc_ "StgLambdaLift"
-- NB We have to do setStgVarInfo first!
let
- binds3 = liftProgram us1 (setStgVarInfo do_let_no_escapes binds)
+ binds3 = liftProgram module_name us1 (setStgVarInfo do_let_no_escapes binds)
in
end_pass us2 "LambdaLift" ccs binds3
- ESCC
StgDoMassageForProfiling ->
- BSCC("ProfMassage")
+ _scc_ "ProfMassage"
let
(collected_CCs, binds3)
= stgMassageForProfiling module_name grp_name us1 binds
in
end_pass us2 "ProfMassage" collected_CCs binds3
- ESCC
end_pass us2 what ccs binds2
= -- report verbosely, if required
(if do_verbose_stg2stg then
- writeMn stderr (ppShow 1000
- (ppAbove (ppStr ("*** "++what++":"))
- (ppAboves (map (ppr ppr_style) binds2))
+ hPutStr stderr (show
+ (($$) (text ("*** "++what++":"))
+ (vcat (map (ppr ppr_style) binds2))
))
- else returnMn ()) `thenMn_`
+ else return ()) >>
let
linted_binds = stg_linter what binds2
in
- returnMn (linted_binds, us2, ccs)
+ return (linted_binds, us2, ccs)
-- return: processed binds
-- UniqueSupply for the next guy to use
-- cost-centres to be declared/registered (specialised)
-- add to description of what's happened (reverse order)
-- here so it can be inlined...
-foldl_mn f z [] = returnMn z
-foldl_mn f z (x:xs) = f z x `thenMn` \ zz ->
+foldl_mn f z [] = return z
+foldl_mn f z (x:xs) = f z x >>= \ zz ->
foldl_mn f zz xs
\end{code}
lookup_uenv env id = case lookupIdEnv env id of
Nothing -> id
Just new_id -> new_id
+unlocaliseStgBinds :: FAST_STRING
+ -> UnlocalEnv
+ -> [StgBinding]
+ -> (UnlocalEnv, [StgBinding])
+unlocaliseStgBinds mod uenv [] = (uenv, [])
+unlocaliseStgBinds mod uenv (b : bs) =
+ case unlocal_top_bind mod uenv b of { (new_uenv, new_b) ->
+ case unlocaliseStgBinds mod new_uenv bs of { (uenv3, new_bs) ->
+ (uenv3, new_b : new_bs)
+ }}
-unlocaliseStgBinds :: FAST_STRING -> UnlocalEnv -> [StgBinding] -> (UnlocalEnv, [StgBinding])
+------------------
+unlocal_top_bind :: FAST_STRING
+ -> UnlocalEnv
+ -> StgBinding
+ -> (UnlocalEnv, StgBinding)
+unlocal_top_bind mod uenv bind@(StgNonRec binder _) =
+ let
+ new_uenv =
+ case lookupIdEnv uenv binder of
+ Just global -> uenv
+ Nothing -> new_env
+ where
+ new_env = addOneToIdEnv uenv binder new_global
+ new_global = setIdVisibility mod binder
+ in
+ (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind)
+
+unlocal_top_bind mod uenv bind@(StgRec pairs) =
+ let
+ new_env binder uenv =
+ case lookupIdEnv uenv binder of
+ Just global -> uenv
+ Nothing -> env'
+ where
+ env' = addOneToIdEnv uenv binder new_global
+ new_global = setIdVisibility mod binder
+
+ uenv' = foldr (new_env) uenv (map (fst) pairs)
+ in
+ (uenv', renameTopStgBind (lookup_uenv uenv') bind)
-unlocaliseStgBinds mod uenv [] = (uenv, [])
+\end{code}
-unlocaliseStgBinds mod uenv (b : bs)
- = BIND unlocal_top_bind mod uenv b _TO_ (new_uenv, new_b) ->
- BIND unlocaliseStgBinds mod new_uenv bs _TO_ (uenv3, new_bs) ->
- (uenv3, new_b : new_bs)
- BEND BEND
+@renameTopStgBind@ renames top level binders and all occurrences thereof.
+
+\begin{code}
+renameTopStgBind :: (Id -> Id) -> StgBinding -> StgBinding
+renameTopStgBind fn (StgNonRec b rhs) = StgNonRec (fn b) (mapStgBindeesRhs fn rhs)
+renameTopStgBind fn (StgRec pairs) = StgRec [ (fn b, mapStgBindeesRhs fn r) | (b, r) <- pairs ]
+\end{code}
+
+This utility function simply applies the given function to every
+bindee in the program.
+
+\begin{code}
+mapStgBindeesBind :: (Id -> Id) -> StgBinding -> StgBinding
+mapStgBindeesBind fn (StgNonRec b rhs) = StgNonRec b (mapStgBindeesRhs fn rhs)
+mapStgBindeesBind fn (StgRec pairs) = StgRec [ (b, mapStgBindeesRhs fn r) | (b, r) <- pairs ]
------------------
+mapStgBindeesRhs :: (Id -> Id) -> StgRhs -> StgRhs
+mapStgBindeesRhs fn (StgRhsClosure cc bi fvs u args expr)
+ = StgRhsClosure
+ cc bi
+ (map fn fvs)
+ u
+ (map fn args)
+ (mapStgBindeesExpr fn expr)
+
+mapStgBindeesRhs fn (StgRhsCon cc con atoms)
+ = StgRhsCon cc con (map (mapStgBindeesArg fn) atoms)
-unlocal_top_bind :: FAST_STRING -> UnlocalEnv -> StgBinding -> (UnlocalEnv, StgBinding)
+------------------
+mapStgBindeesExpr :: (Id -> Id) -> StgExpr -> StgExpr
-unlocal_top_bind mod uenv bind@(StgNonRec binder _)
- = let new_uenv = case unlocaliseId mod binder of
- Nothing -> uenv
- Just new_binder -> addOneToIdEnv uenv binder new_binder
- in
- (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind)
+mapStgBindeesExpr fn (StgApp f args lvs)
+ = StgApp (mapStgBindeesArg fn f)
+ (map (mapStgBindeesArg fn) args)
+ (mapUniqSet fn lvs)
-unlocal_top_bind mod uenv bind@(StgRec pairs)
- = let maybe_unlocaliseds = [ (b, unlocaliseId mod b) | (b, _) <- pairs ]
- new_uenv = growIdEnvList uenv [ (b,new_b)
- | (b, Just new_b) <- maybe_unlocaliseds]
- in
- (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind)
-\end{code}
+mapStgBindeesExpr fn (StgCon con atoms lvs)
+ = StgCon con (map (mapStgBindeesArg fn) atoms) (mapUniqSet fn lvs)
-%************************************************************************
-%* *
-\subsection[SimplStg-indirections]{Eliminating indirections in STG code}
-%* *
-%************************************************************************
+mapStgBindeesExpr fn (StgPrim op atoms lvs)
+ = StgPrim op (map (mapStgBindeesArg fn) atoms) (mapUniqSet fn lvs)
-In @elimIndirections@, we look for things at the top-level of the form...
-\begin{verbatim}
- x_local = ....rhs...
- ...
- x_exported = x_local
- ...
-\end{verbatim}
-In cases we find like this, we go {\em backwards} and replace
-\tr{x_local} with \tr{...rhs...}, to produce
-\begin{verbatim}
- x_exported = ...rhs...
- ...
- ...
-\end{verbatim}
-This saves a gratuitous jump
-(from \tr{x_exported} to \tr{x_local}), and makes strictness
-information propagate better.
-
-If more than one exported thing is equal to a local thing (i.e., the
-local thing really is shared), then we eliminate only the first one. Thus:
-\begin{verbatim}
- x_local = ....rhs...
- ...
- x_exported1 = x_local
- ...
- x_exported2 = x_local
- ...
-\end{verbatim}
-becomes
-\begin{verbatim}
- x_exported1 = ....rhs...
- ...
- ...
- x_exported2 = x_exported1
- ...
-\end{verbatim}
-
-We also have to watch out for
-
- f = \xyz -> g x y z
-
-This can arise post lambda lifting; the original might have been
-
- f = \xyz -> letrec g = [xy] \ [k] -> e
- in
- g z
-
-Strategy: first collect the info; then make a \tr{Id -> Id} mapping.
-Then blast the whole program (LHSs as well as RHSs) with it.
+mapStgBindeesExpr fn (StgLet bind expr)
+ = StgLet (mapStgBindeesBind fn bind) (mapStgBindeesExpr fn expr)
-\begin{code}
-elimIndirections :: [StgBinding] -> [StgBinding]
+mapStgBindeesExpr fn (StgLetNoEscape lvs rhss_lvs bind body)
+ = StgLetNoEscape (mapUniqSet fn lvs) (mapUniqSet fn rhss_lvs)
+ (mapStgBindeesBind fn bind) (mapStgBindeesExpr fn body)
-elimIndirections binds_in
- = if isNullIdEnv blast_env then
- binds_in -- Nothing to do
- else
- [renameTopStgBind lookup_fn bind | Just bind <- reduced_binds]
- where
- lookup_fn id = case lookupIdEnv blast_env id of
- Just new_id -> new_id
- Nothing -> id
+mapStgBindeesExpr fn (StgSCC ty label expr)
+ = StgSCC ty label (mapStgBindeesExpr fn expr)
- (blast_env, reduced_binds) = mapAccumL try_bind nullIdEnv binds_in
-
- try_bind :: IdEnv Id -> StgBinding -> (IdEnv Id, Maybe StgBinding)
- try_bind env_so_far
- (StgNonRec exported_binder
- (StgRhsClosure _ _ _ _
- lambda_args
- (StgApp (StgVarArg local_binder) fun_args _)
- ))
- | isExported exported_binder && -- Only if this is exported
- not (isExported local_binder) && -- Only if this one is defined in this
- isLocallyDefined local_binder && -- module, so that we *can* change its
- -- binding to be the exported thing!
- not (in_dom env_so_far local_binder) && -- Only if we havn't seen it before
- args_match lambda_args fun_args -- Just an eta-expansion
-
- = (addOneToIdEnv env_so_far local_binder exported_binder,
- Nothing)
- where
- args_match [] [] = True
- args_match (la:las) (StgVarArg fa:fas) = la == fa && args_match las fas
- args_match _ _ = False
-
- try_bind env_so_far bind
- = (env_so_far, Just bind)
-
- in_dom env id = maybeToBool (lookupIdEnv env id)
-\end{code}
+mapStgBindeesExpr fn (StgCase expr lvs1 lvs2 uniq alts)
+ = StgCase (mapStgBindeesExpr fn expr)
+ (mapUniqSet fn lvs1)
+ (mapUniqSet fn lvs2)
+ uniq
+ (mapStgBindeesAlts alts)
+ where
+ mapStgBindeesAlts (StgAlgAlts ty alts deflt)
+ = StgAlgAlts ty (map mapStgBindeesBoxed_alt alts) (mapStgBindeesDeflt deflt)
+ where
+ mapStgBindeesBoxed_alt (c,ps,use_mask,expr) = (c,ps,use_mask,mapStgBindeesExpr fn expr)
-@renameTopStgBind@ renames top level binders and all occurrences thereof.
+ mapStgBindeesAlts (StgPrimAlts ty alts deflt)
+ = StgPrimAlts ty (map mapStgBindeesunboxed_alt alts) (mapStgBindeesDeflt deflt)
+ where
+ mapStgBindeesunboxed_alt (l,expr) = (l,mapStgBindeesExpr fn expr)
-\begin{code}
-renameTopStgBind :: (Id -> Id) -> StgBinding -> StgBinding
+ mapStgBindeesDeflt StgNoDefault = StgNoDefault
+ mapStgBindeesDeflt (StgBindDefault b used expr) = StgBindDefault b used (mapStgBindeesExpr fn expr)
-renameTopStgBind fn (StgNonRec b rhs) = StgNonRec (fn b) (mapStgBindeesRhs fn rhs)
-renameTopStgBind fn (StgRec pairs) = StgRec [ (fn b, mapStgBindeesRhs fn r) | (b, r) <- pairs ]
+------------------
+mapStgBindeesArg :: (Id -> Id) -> StgArg -> StgArg
+mapStgBindeesArg fn a@(StgLitArg _) = a
+mapStgBindeesArg fn a@(StgConArg _) = a
+mapStgBindeesArg fn a@(StgVarArg id) = StgVarArg (fn id)
\end{code}
projects / ghc-hetmet.git / blobdiff