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