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 SCCfinal         ( stgMassageForProfiling )
  18 import SatStgRhs        ( satStgRhs )
  19 import StgLint          ( lintStgBindings )
  20 import StgSAT           ( doStaticArgs )
  21 import StgStats         ( showStgStats )
  22 import StgVarInfo       ( setStgVarInfo )
  23 import UpdAnal          ( updateAnalyse )
  24
  25 import CmdLineOpts      ( opt_EnsureSplittableC, opt_SccGroup,
  26                           opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg,
  27                           StgToDo(..)
  28                         )
  29 import Id               ( nullIdEnv, lookupIdEnv, addOneToIdEnv,
  30                           growIdEnvList, isNullIdEnv, IdEnv(..),
  31                           GenId{-instance Eq/Outputable -}
  32                         )
  33 import MainMonad        ( writeMn, thenMn_, thenMn, returnMn, MainIO(..) )
  34 import Maybes           ( maybeToBool )
  35 import Outputable       ( 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         -> MainIO
  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   = BSCC("Stg2Stg")
  57     case (splitUniqSupply us)   of { (us4now, us4later) ->
  58
  59     (if do_verbose_stg2stg then
  60         writeMn stderr "VERBOSE STG-TO-STG:\n" `thenMn_`
  61         writeMn stderr (ppShow 1000
  62         (ppAbove (ppStr ("*** Core2Stg:"))
  63                  (ppAboves (map (ppr ppr_style) (setStgVarInfo False binds)))
  64         ))
  65      else returnMn ()) `thenMn_`
  66
  67         -- Do the main business!
  68     foldl_mn do_stg_pass (binds, us4now, ([],[])) stg_todos
  69                 `thenMn` \ (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     returnMn (setStgVarInfo do_let_no_escapes binds_to_mangle, cost_centres)
 105     }}
 106     ESCC
 107   where
 108     do_let_no_escapes  = opt_StgDoLetNoEscapes
 109     do_verbose_stg2stg = opt_D_verbose_stg2stg
 110
 111     (do_unlocalising, unlocal_tag)
 112       = case (opt_EnsureSplittableC) of
 113               Nothing  -> (False, panic "tag")
 114               Just tag -> (True,  tag)
 115
 116     grp_name  = case (opt_SccGroup) of
 117                   Just xx -> xx
 118                   Nothing -> module_name -- default: module name
 119
 120     -------------
 121     stg_linter = if False -- LATER: switch_is_on DoCoreLinting -- ToDo: DoStgLinting flag
 122                  then lintStgBindings ppr_style
 123                  else ( \ whodunnit binds -> binds )
 124
 125     -------------------------------------------
 126     do_stg_pass (binds, us, ccs) to_do
 127       = let
 128             (us1, us2) = splitUniqSupply us
 129         in
 130         case to_do of
 131           StgDoStaticArgs ->
 132              ASSERT(null (fst ccs) && null (snd ccs))
 133              BSCC("StgStaticArgs")
 134              let
 135                  binds3 = doStaticArgs binds us1
 136              in
 137              end_pass us2 "StgStaticArgs" ccs binds3
 138              ESCC
 139
 140           StgDoUpdateAnalysis ->
 141              ASSERT(null (fst ccs) && null (snd ccs))
 142              BSCC("StgUpdAnal")
 143                 -- NB We have to do setStgVarInfo first!  (There's one
 144                 -- place free-var info is used) But no let-no-escapes,
 145                 -- because update analysis doesn't care.
 146              end_pass us2 "UpdAnal" ccs (updateAnalyse (setStgVarInfo False binds))
 147              ESCC
 148
 149           D_stg_stats ->
 150              trace (showStgStats binds)
 151              end_pass us2 "StgStats" ccs binds
 152
 153           StgDoLambdaLift ->
 154              BSCC("StgLambdaLift")
 155                 -- NB We have to do setStgVarInfo first!
 156              let
 157                 binds3 = liftProgram us1 (setStgVarInfo do_let_no_escapes binds)
 158              in
 159              end_pass us2 "LambdaLift" ccs binds3
 160              ESCC
 161
 162           StgDoMassageForProfiling ->
 163              BSCC("ProfMassage")
 164              let
 165                  (collected_CCs, binds3)
 166                    = stgMassageForProfiling module_name grp_name us1 binds
 167              in
 168              end_pass us2 "ProfMassage" collected_CCs binds3
 169              ESCC
 170
 171     end_pass us2 what ccs binds2
 172       = -- report verbosely, if required
 173         (if do_verbose_stg2stg then
 174             writeMn stderr (ppShow 1000
 175             (ppAbove (ppStr ("*** "++what++":"))
 176                      (ppAboves (map (ppr ppr_style) binds2))
 177             ))
 178          else returnMn ()) `thenMn_`
 179         let
 180             linted_binds = stg_linter what binds2
 181         in
 182         returnMn (linted_binds, us2, ccs)
 183             -- return: processed binds
 184             --         UniqueSupply for the next guy to use
 185             --         cost-centres to be declared/registered (specialised)
 186             --         add to description of what's happened (reverse order)
 187
 188 -- here so it can be inlined...
 189 foldl_mn f z []     = returnMn z
 190 foldl_mn f z (x:xs) = f z x     `thenMn` \ zz ->
 191                      foldl_mn f zz xs
 192 \end{code}
 193
 194 %************************************************************************
 195 %*                                                                      *
 196 \subsection[SimplStg-unlocalise]{Unlocalisation in STG code}
 197 %*                                                                      *
 198 %************************************************************************
 199
 200 The idea of all this ``unlocalise'' stuff is that in certain (prelude
 201 only) modules we split up the .hc file into lots of separate little
 202 files, which are separately compiled by the C compiler.  That gives
 203 lots of little .o files.  The idea is that if you happen to mention
 204 one of them you don't necessarily pull them all in.  (Pulling in a
 205 piece you don't need can be v bad, because it may mention other pieces
 206 you don't need either, and so on.)
 207
 208 Sadly, splitting up .hc files means that local names (like s234) are
 209 now globally visible, which can lead to clashes between two .hc
 210 files. So unlocaliseWhatnot goes through making all the local things
 211 into global things, essentially by giving them full names so when they
 212 are printed they'll have their module name too.  Pretty revolting
 213 really.
 214
 215 \begin{code}
 216 type UnlocalEnv = IdEnv Id
 217
 218 lookup_uenv :: UnlocalEnv -> Id -> Id
 219 lookup_uenv env id =  case lookupIdEnv env id of
 220                         Nothing     -> id
 221                         Just new_id -> new_id
 222
 223 unlocaliseStgBinds :: FAST_STRING -> UnlocalEnv -> [StgBinding] -> (UnlocalEnv, [StgBinding])
 224
 225 unlocaliseStgBinds mod uenv [] = (uenv, [])
 226
 227 unlocaliseStgBinds mod uenv (b : bs)
 228   = BIND unlocal_top_bind mod uenv b        _TO_ (new_uenv, new_b) ->
 229     BIND unlocaliseStgBinds mod new_uenv bs _TO_ (uenv3, new_bs) ->
 230     (uenv3, new_b : new_bs)
 231     BEND BEND
 232
 233 ------------------
 234
 235 unlocal_top_bind :: FAST_STRING -> UnlocalEnv -> StgBinding -> (UnlocalEnv, StgBinding)
 236
 237 unlocal_top_bind mod uenv bind@(StgNonRec binder _)
 238   = let new_uenv = case unlocaliseId mod binder of
 239                         Nothing         -> uenv
 240                         Just new_binder -> addOneToIdEnv uenv binder new_binder
 241     in
 242     (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind)
 243
 244 unlocal_top_bind mod uenv bind@(StgRec pairs)
 245   = let maybe_unlocaliseds  = [ (b, unlocaliseId mod b) | (b, _) <- pairs ]
 246         new_uenv            = growIdEnvList uenv [ (b,new_b)
 247                                                  | (b, Just new_b) <- maybe_unlocaliseds]
 248     in
 249     (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind)
 250 \end{code}
 251
 252 %************************************************************************
 253 %*                                                                      *
 254 \subsection[SimplStg-indirections]{Eliminating indirections in STG code}
 255 %*                                                                      *
 256 %************************************************************************
 257
 258 In @elimIndirections@, we look for things at the top-level of the form...
 259 \begin{verbatim}
 260     x_local = ....rhs...
 261     ...
 262     x_exported = x_local
 263     ...
 264 \end{verbatim}
 265 In cases we find like this, we go {\em backwards} and replace
 266 \tr{x_local} with \tr{...rhs...}, to produce
 267 \begin{verbatim}
 268     x_exported = ...rhs...
 269     ...
 270     ...
 271 \end{verbatim}
 272 This saves a gratuitous jump
 273 (from \tr{x_exported} to \tr{x_local}), and makes strictness
 274 information propagate better.
 275
 276 If more than one exported thing is equal to a local thing (i.e., the
 277 local thing really is shared), then we eliminate only the first one.  Thus:
 278 \begin{verbatim}
 279     x_local = ....rhs...
 280     ...
 281     x_exported1 = x_local
 282     ...
 283     x_exported2 = x_local
 284     ...
 285 \end{verbatim}
 286 becomes
 287 \begin{verbatim}
 288     x_exported1 = ....rhs...
 289     ...
 290     ...
 291     x_exported2 = x_exported1
 292     ...
 293 \end{verbatim}
 294
 295 We also have to watch out for
 296
 297         f = \xyz -> g x y z
 298
 299 This can arise post lambda lifting; the original might have been
 300
 301         f = \xyz -> letrec g = [xy] \ [k] -> e
 302                     in
 303                     g z
 304
 305 Strategy: first collect the info; then make a \tr{Id -> Id} mapping.
 306 Then blast the whole program (LHSs as well as RHSs) with it.
 307
 308 \begin{code}
 309 elimIndirections :: [StgBinding] -> [StgBinding]
 310
 311 elimIndirections binds_in
 312   = if isNullIdEnv blast_env then
 313         binds_in            -- Nothing to do
 314     else
 315         [renameTopStgBind lookup_fn bind | Just bind <- reduced_binds]
 316   where
 317     lookup_fn id = case lookupIdEnv blast_env id of
 318                         Just new_id -> new_id
 319                         Nothing     -> id
 320
 321     (blast_env, reduced_binds) = mapAccumL try_bind nullIdEnv binds_in
 322
 323     try_bind :: IdEnv Id -> StgBinding -> (IdEnv Id, Maybe StgBinding)
 324     try_bind env_so_far
 325              (StgNonRec exported_binder
 326                        (StgRhsClosure _ _ _ _
 327                                 lambda_args
 328                                 (StgApp (StgVarArg local_binder) fun_args _)
 329              ))
 330         | isExported exported_binder &&     -- Only if this is exported
 331           not (isExported local_binder) &&  -- Only if this one is defined in this
 332           isLocallyDefined local_binder &&  -- module, so that we *can* change its
 333                                             -- binding to be the exported thing!
 334           not (in_dom env_so_far local_binder) && -- Only if we havn't seen it before
 335           args_match lambda_args fun_args   -- Just an eta-expansion
 336
 337         = (addOneToIdEnv env_so_far local_binder exported_binder,
 338            Nothing)
 339         where
 340           args_match [] [] = True
 341           args_match (la:las) (StgVarArg fa:fas) = la == fa && args_match las fas
 342           args_match _  _  = False
 343
 344     try_bind env_so_far bind
 345         = (env_so_far, Just bind)
 346
 347     in_dom env id = maybeToBool (lookupIdEnv env id)
 348 \end{code}
 349
 350 @renameTopStgBind@ renames top level binders and all occurrences thereof.
 351
 352 \begin{code}
 353 renameTopStgBind :: (Id -> Id) -> StgBinding -> StgBinding
 354
 355 renameTopStgBind fn (StgNonRec b rhs) = StgNonRec (fn b) (mapStgBindeesRhs fn rhs)
 356 renameTopStgBind fn (StgRec pairs)    = StgRec [ (fn b, mapStgBindeesRhs fn r) | (b, r) <- pairs ]
 357 \end{code}