import SCCfinal ( stgMassageForProfiling )
import SatStgRhs ( satStgRhs )
import StgLint ( lintStgBindings )
-import StgSAT ( doStaticArgs )
import StgStats ( showStgStats )
import StgVarInfo ( setStgVarInfo )
import UpdAnal ( updateAnalyse )
opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg,
StgToDo(..)
)
-import Id ( externallyVisibleId,
- nullIdEnv, lookupIdEnv, addOneToIdEnv,
+import Id ( nullIdEnv, lookupIdEnv, addOneToIdEnv,
growIdEnvList, isNullIdEnv, SYN_IE(IdEnv),
GenId{-instance Eq/Outputable -}
)
import UniqSupply ( splitUniqSupply )
import Util ( mapAccumL, panic, assertPanic )
-unlocaliseId = panic "SimplStg.unlocaliseId (ToDo)"
\end{code}
\begin{code}
-- Do the main business!
foldl_mn do_stg_pass (binds, us4now, ([],[])) stg_todos
>>= \ (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.
+ -- Do essential wind-up
- case (satStgRhs processed_binds us4later) of { saturated_binds ->
-
- -- Essential wind-up: part (b), eliminate indirections
-
- 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
let
-- ToDo: provide proper flag control!
binds_to_mangle
= if not do_unlocalising
- then no_ind_binds
+ then saturated_binds
else snd (unlocaliseStgBinds unlocal_tag nullIdEnv no_ind_binds)
in
- return (setStgVarInfo do_let_no_escapes binds_to_mangle, cost_centres)
- }}
+-}
+
+ 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, _PK_ tag)
-
grp_name = case (opt_SccGroup) of
Just xx -> _PK_ xx
Nothing -> module_name -- default: module name
(us1, us2) = splitUniqSupply us
in
case to_do of
- StgDoStaticArgs ->
- ASSERT(null (fst ccs) && null (snd ccs))
- _scc_ "StgStaticArgs"
- let
- binds3 = doStaticArgs binds us1
- in
- end_pass us2 "StgStaticArgs" ccs binds3
+ StgDoStaticArgs -> panic "STG static argument transformation deleted"
StgDoUpdateAnalysis ->
ASSERT(null (fst ccs) && null (snd ccs))
foldl_mn f zz xs
\end{code}
-%************************************************************************
-%* *
-\subsection[SimplStg-unlocalise]{Unlocalisation in STG code}
-%* *
-%************************************************************************
-
-The idea of all this ``unlocalise'' stuff is that in certain (prelude
-only) modules we split up the .hc file into lots of separate little
-files, which are separately compiled by the C compiler. That gives
-lots of little .o files. The idea is that if you happen to mention
-one of them you don't necessarily pull them all in. (Pulling in a
-piece you don't need can be v bad, because it may mention other pieces
-you don't need either, and so on.)
-
-Sadly, splitting up .hc files means that local names (like s234) are
-now globally visible, which can lead to clashes between two .hc
-files. So unlocaliseWhatnot goes through making all the local things
-into global things, essentially by giving them full names so when they
-are printed they'll have their module name too. Pretty revolting
-really.
-\begin{code}
-type UnlocalEnv = IdEnv Id
-
-lookup_uenv :: UnlocalEnv -> Id -> Id
-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) }}
-
-------------------
-
-unlocal_top_bind :: FAST_STRING -> UnlocalEnv -> StgBinding -> (UnlocalEnv, StgBinding)
-
-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)
-
-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}
-
-%************************************************************************
-%* *
-\subsection[SimplStg-indirections]{Eliminating indirections in STG code}
-%* *
-%************************************************************************
-
-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.
-
-\begin{code}
-elimIndirections :: [StgBinding] -> [StgBinding]
-
-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
-
- (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 _)
- ))
- | externallyVisibleId exported_binder && -- Only if this is exported
- not (externallyVisibleId 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}
-
-@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}
projects / ghc-hetmet.git / blobdiff