ghc/compiler/simplStg/SimplStg.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
   3 %
   4 \section[SimplStg]{Driver for simplifying @STG@ programs}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module SimplStg ( stg2stg ) where
  10
  11 import Ubiq{-uitous-}
  12
  13 import StgSyn
  14 import StgUtils
  15
  16 import LambdaLift       ( liftProgram )
  17 import Name             ( isLocallyDefined )
  18 import SCCfinal         ( stgMassageForProfiling )
  19 import SatStgRhs        ( satStgRhs )
  20 import StgLint          ( lintStgBindings )
  21 import StgSAT           ( doStaticArgs )
  22 import StgStats         ( showStgStats )
  23 import StgVarInfo       ( setStgVarInfo )
  24 import UpdAnal          ( updateAnalyse )
  25
  26 import CmdLineOpts      ( opt_EnsureSplittableC, opt_SccGroup,
  27                           opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg,
  28                           StgToDo(..)
  29                         )
  30 import Id               ( nullIdEnv, lookupIdEnv, addOneToIdEnv,
  31                           growIdEnvList, isNullIdEnv, IdEnv(..),
  32                           GenId{-instance Eq/Outputable -}
  33                         )
  34 import Maybes           ( maybeToBool )
  35 import Name             ( isExported )
  36 import PprType          ( GenType{-instance Outputable-} )
  37 import Pretty           ( ppShow, ppAbove, ppAboves, ppStr )
  38 import UniqSupply       ( splitUniqSupply )
  39 import Util             ( mapAccumL, panic, assertPanic )
  40
  41 unlocaliseId = panic "SimplStg.unlocaliseId (ToDo)"
  42 \end{code}
  43
  44 \begin{code}
  45 stg2stg :: [StgToDo]            -- spec of what stg-to-stg passes to do
  46         -> FAST_STRING          -- module name (profiling only)
  47         -> PprStyle             -- printing style (for debugging only)
  48         -> UniqSupply           -- a name supply
  49         -> [StgBinding]         -- input...
  50         -> IO
  51             ([StgBinding],      -- output program...
  52              ([CostCentre],     -- local cost-centres that need to be decl'd
  53               [CostCentre]))    -- "extern" cost-centres
  54
  55 stg2stg stg_todos module_name ppr_style us binds
  56   = _scc_ "Stg2Stg"
  57     case (splitUniqSupply us)   of { (us4now, us4later) ->
  58
  59     (if do_verbose_stg2stg then
  60         hPutStr stderr "VERBOSE STG-TO-STG:\n" >>
  61         hPutStr stderr (ppShow 1000
  62         (ppAbove (ppStr ("*** Core2Stg:"))
  63                  (ppAboves (map (ppr ppr_style) (setStgVarInfo False binds)))
  64         ))
  65      else return ()) >>
  66
  67         -- Do the main business!
  68     foldl_mn do_stg_pass (binds, us4now, ([],[])) stg_todos
  69                 >>= \ (processed_binds, _, cost_centres) ->
  70         -- Do essential wind-up: part (a) is SatStgRhs
  71
  72         -- Not optional, because correct arity information is used by
  73         -- the code generator.  Afterwards do setStgVarInfo; it gives
  74         -- the wrong answers if arities are subsequently changed,
  75         -- which stgSatRhs might do.  Furthermore, setStgVarInfo
  76         -- decides about let-no-escape things, which in turn do a
  77         -- better job if arities are correct, which is done by
  78         -- satStgRhs.
  79
  80     case (satStgRhs processed_binds us4later) of { saturated_binds ->
  81
  82         -- Essential wind-up: part (b), eliminate indirections
  83
  84     let no_ind_binds = elimIndirections saturated_binds in
  85
  86
  87         -- Essential wind-up: part (c), do setStgVarInfo. It has to
  88         -- happen regardless, because the code generator uses its
  89         -- decorations.
  90         --
  91         -- Why does it have to happen last?  Because earlier passes
  92         -- may move things around, which would change the live-var
  93         -- info.  Also, setStgVarInfo decides about let-no-escape
  94         -- things, which in turn do a better job if arities are
  95         -- correct, which is done by satStgRhs.
  96         --
  97     let
  98                 -- ToDo: provide proper flag control!
  99         binds_to_mangle
 100           = if not do_unlocalising
 101             then no_ind_binds
 102             else snd (unlocaliseStgBinds unlocal_tag nullIdEnv no_ind_binds)
 103     in
 104     return (setStgVarInfo do_let_no_escapes binds_to_mangle, cost_centres)
 105     }}
 106   where
 107     do_let_no_escapes  = opt_StgDoLetNoEscapes
 108     do_verbose_stg2stg = opt_D_verbose_stg2stg
 109
 110     (do_unlocalising, unlocal_tag)
 111       = case (opt_EnsureSplittableC) of
 112               Nothing  -> (False, panic "tag")
 113               Just tag -> (True,  _PK_ tag)
 114
 115     grp_name  = case (opt_SccGroup) of
 116                   Just xx -> _PK_ xx
 117                   Nothing -> module_name -- default: module name
 118
 119     -------------
 120     stg_linter = if False -- LATER: switch_is_on DoCoreLinting -- ToDo: DoStgLinting flag
 121                  then lintStgBindings ppr_style
 122                  else ( \ whodunnit binds -> binds )
 123
 124     -------------------------------------------
 125     do_stg_pass (binds, us, ccs) to_do
 126       = let
 127             (us1, us2) = splitUniqSupply us
 128         in
 129         case to_do of
 130           StgDoStaticArgs ->
 131              ASSERT(null (fst ccs) && null (snd ccs))
 132              _scc_ "StgStaticArgs"
 133              let
 134                  binds3 = doStaticArgs binds us1
 135              in
 136              end_pass us2 "StgStaticArgs" ccs binds3
 137
 138           StgDoUpdateAnalysis ->
 139              ASSERT(null (fst ccs) && null (snd ccs))
 140              _scc_ "StgUpdAnal"
 141                 -- NB We have to do setStgVarInfo first!  (There's one
 142                 -- place free-var info is used) But no let-no-escapes,
 143                 -- because update analysis doesn't care.
 144              end_pass us2 "UpdAnal" ccs (updateAnalyse (setStgVarInfo False binds))
 145
 146           D_stg_stats ->
 147              trace (showStgStats binds)
 148              end_pass us2 "StgStats" ccs binds
 149
 150           StgDoLambdaLift ->
 151              _scc_ "StgLambdaLift"
 152                 -- NB We have to do setStgVarInfo first!
 153              let
 154                 binds3 = liftProgram us1 (setStgVarInfo do_let_no_escapes binds)
 155              in
 156              end_pass us2 "LambdaLift" ccs binds3
 157
 158           StgDoMassageForProfiling ->
 159              _scc_ "ProfMassage"
 160              let
 161                  (collected_CCs, binds3)
 162                    = stgMassageForProfiling module_name grp_name us1 binds
 163              in
 164              end_pass us2 "ProfMassage" collected_CCs binds3
 165
 166     end_pass us2 what ccs binds2
 167       = -- report verbosely, if required
 168         (if do_verbose_stg2stg then
 169             hPutStr stderr (ppShow 1000
 170             (ppAbove (ppStr ("*** "++what++":"))
 171                      (ppAboves (map (ppr ppr_style) binds2))
 172             ))
 173          else return ()) >>
 174         let
 175             linted_binds = stg_linter what binds2
 176         in
 177         return (linted_binds, us2, ccs)
 178             -- return: processed binds
 179             --         UniqueSupply for the next guy to use
 180             --         cost-centres to be declared/registered (specialised)
 181             --         add to description of what's happened (reverse order)
 182
 183 -- here so it can be inlined...
 184 foldl_mn f z []     = return z
 185 foldl_mn f z (x:xs) = f z x     >>= \ zz ->
 186                      foldl_mn f zz xs
 187 \end{code}
 188
 189 %************************************************************************
 190 %*                                                                      *
 191 \subsection[SimplStg-unlocalise]{Unlocalisation in STG code}
 192 %*                                                                      *
 193 %************************************************************************
 194
 195 The idea of all this ``unlocalise'' stuff is that in certain (prelude
 196 only) modules we split up the .hc file into lots of separate little
 197 files, which are separately compiled by the C compiler.  That gives
 198 lots of little .o files.  The idea is that if you happen to mention
 199 one of them you don't necessarily pull them all in.  (Pulling in a
 200 piece you don't need can be v bad, because it may mention other pieces
 201 you don't need either, and so on.)
 202
 203 Sadly, splitting up .hc files means that local names (like s234) are
 204 now globally visible, which can lead to clashes between two .hc
 205 files. So unlocaliseWhatnot goes through making all the local things
 206 into global things, essentially by giving them full names so when they
 207 are printed they'll have their module name too.  Pretty revolting
 208 really.
 209
 210 \begin{code}
 211 type UnlocalEnv = IdEnv Id
 212
 213 lookup_uenv :: UnlocalEnv -> Id -> Id
 214 lookup_uenv env id =  case lookupIdEnv env id of
 215                         Nothing     -> id
 216                         Just new_id -> new_id
 217
 218 unlocaliseStgBinds :: FAST_STRING -> UnlocalEnv -> [StgBinding] -> (UnlocalEnv, [StgBinding])
 219
 220 unlocaliseStgBinds mod uenv [] = (uenv, [])
 221
 222 unlocaliseStgBinds mod uenv (b : bs)
 223   = case (unlocal_top_bind mod uenv b)        of { (new_uenv, new_b) ->
 224     case (unlocaliseStgBinds mod new_uenv bs) of { (uenv3, new_bs) ->
 225     (uenv3, new_b : new_bs) }}
 226
 227 ------------------
 228
 229 unlocal_top_bind :: FAST_STRING -> UnlocalEnv -> StgBinding -> (UnlocalEnv, StgBinding)
 230
 231 unlocal_top_bind mod uenv bind@(StgNonRec binder _)
 232   = let new_uenv = case unlocaliseId mod binder of
 233                         Nothing         -> uenv
 234                         Just new_binder -> addOneToIdEnv uenv binder new_binder
 235     in
 236     (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind)
 237
 238 unlocal_top_bind mod uenv bind@(StgRec pairs)
 239   = let maybe_unlocaliseds  = [ (b, unlocaliseId mod b) | (b, _) <- pairs ]
 240         new_uenv            = growIdEnvList uenv [ (b,new_b)
 241                                                  | (b, Just new_b) <- maybe_unlocaliseds]
 242     in
 243     (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind)
 244 \end{code}
 245
 246 %************************************************************************
 247 %*                                                                      *
 248 \subsection[SimplStg-indirections]{Eliminating indirections in STG code}
 249 %*                                                                      *
 250 %************************************************************************
 251
 252 In @elimIndirections@, we look for things at the top-level of the form...
 253 \begin{verbatim}
 254     x_local = ....rhs...
 255     ...
 256     x_exported = x_local
 257     ...
 258 \end{verbatim}
 259 In cases we find like this, we go {\em backwards} and replace
 260 \tr{x_local} with \tr{...rhs...}, to produce
 261 \begin{verbatim}
 262     x_exported = ...rhs...
 263     ...
 264     ...
 265 \end{verbatim}
 266 This saves a gratuitous jump
 267 (from \tr{x_exported} to \tr{x_local}), and makes strictness
 268 information propagate better.
 269
 270 If more than one exported thing is equal to a local thing (i.e., the
 271 local thing really is shared), then we eliminate only the first one.  Thus:
 272 \begin{verbatim}
 273     x_local = ....rhs...
 274     ...
 275     x_exported1 = x_local
 276     ...
 277     x_exported2 = x_local
 278     ...
 279 \end{verbatim}
 280 becomes
 281 \begin{verbatim}
 282     x_exported1 = ....rhs...
 283     ...
 284     ...
 285     x_exported2 = x_exported1
 286     ...
 287 \end{verbatim}
 288
 289 We also have to watch out for
 290
 291         f = \xyz -> g x y z
 292
 293 This can arise post lambda lifting; the original might have been
 294
 295         f = \xyz -> letrec g = [xy] \ [k] -> e
 296                     in
 297                     g z
 298
 299 Strategy: first collect the info; then make a \tr{Id -> Id} mapping.
 300 Then blast the whole program (LHSs as well as RHSs) with it.
 301
 302 \begin{code}
 303 elimIndirections :: [StgBinding] -> [StgBinding]
 304
 305 elimIndirections binds_in
 306   = if isNullIdEnv blast_env then
 307         binds_in            -- Nothing to do
 308     else
 309         [renameTopStgBind lookup_fn bind | Just bind <- reduced_binds]
 310   where
 311     lookup_fn id = case lookupIdEnv blast_env id of
 312                         Just new_id -> new_id
 313                         Nothing     -> id
 314
 315     (blast_env, reduced_binds) = mapAccumL try_bind nullIdEnv binds_in
 316
 317     try_bind :: IdEnv Id -> StgBinding -> (IdEnv Id, Maybe StgBinding)
 318     try_bind env_so_far
 319              (StgNonRec exported_binder
 320                        (StgRhsClosure _ _ _ _
 321                                 lambda_args
 322                                 (StgApp (StgVarArg local_binder) fun_args _)
 323              ))
 324         | isExported exported_binder &&     -- Only if this is exported
 325           not (isExported local_binder) &&  -- Only if this one is defined in this
 326           isLocallyDefined local_binder &&  -- module, so that we *can* change its
 327                                             -- binding to be the exported thing!
 328           not (in_dom env_so_far local_binder) && -- Only if we havn't seen it before
 329           args_match lambda_args fun_args   -- Just an eta-expansion
 330
 331         = (addOneToIdEnv env_so_far local_binder exported_binder,
 332            Nothing)
 333         where
 334           args_match [] [] = True
 335           args_match (la:las) (StgVarArg fa:fas) = la == fa && args_match las fas
 336           args_match _  _  = False
 337
 338     try_bind env_so_far bind
 339         = (env_so_far, Just bind)
 340
 341     in_dom env id = maybeToBool (lookupIdEnv env id)
 342 \end{code}
 343
 344 @renameTopStgBind@ renames top level binders and all occurrences thereof.
 345
 346 \begin{code}
 347 renameTopStgBind :: (Id -> Id) -> StgBinding -> StgBinding
 348
 349 renameTopStgBind fn (StgNonRec b rhs) = StgNonRec (fn b) (mapStgBindeesRhs fn rhs)
 350 renameTopStgBind fn (StgRec pairs)    = StgRec [ (fn b, mapStgBindeesRhs fn r) | (b, r) <- pairs ]
 351 \end{code}