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_Trace
  12
  13 import StgSyn
  14 import StgUtils
  15
  16 import LambdaLift       ( liftProgram )
  17 import SCCfinal         ( stgMassageForProfiling )
  18 import SatStgRhs        ( satStgRhs )
  19 import StgStats         ( showStgStats )
  20 import StgVarInfo       ( setStgVarInfo )
  21 import UpdAnal          ( updateAnalyse )
  22
  23 import CmdLineOpts
  24 import Id               ( unlocaliseId )
  25 import MainMonad
  26 import Maybes           ( maybeToBool, Maybe(..) )
  27 import Outputable
  28 import Pretty
  29 import StgLint          ( lintStgBindings )
  30 import StgSAT           ( doStaticArgs )
  31 import UniqSet
  32 import UniqSupply
  33 import Util
  34 \end{code}
  35
  36 \begin{code}
  37 stg2stg :: [StgToDo]                    -- spec of what stg-to-stg passes to do
  38         -> (GlobalSwitch -> SwitchResult)-- access to all global cmd-line opts
  39         -> FAST_STRING                  -- module name (profiling only)
  40         -> PprStyle                     -- printing style (for debugging only)
  41         -> UniqSupply           -- a name supply
  42         -> [StgBinding]         -- input...
  43         -> MainIO
  44             ([StgBinding],              -- output program...
  45              ([CostCentre],             -- local cost-centres that need to be decl'd
  46               [CostCentre]))            -- "extern" cost-centres
  47
  48 stg2stg stg_todos sw_chkr module_name ppr_style us binds
  49   = BSCC("Stg2Stg")
  50     case (splitUniqSupply us)   of { (us4now, us4later) ->
  51
  52     (if do_verbose_stg2stg then
  53         writeMn stderr "VERBOSE STG-TO-STG:\n" `thenMn_`
  54         writeMn stderr (ppShow 1000
  55         (ppAbove (ppStr ("*** Core2Stg:"))
  56                  (ppAboves (map (ppr ppr_style) (setStgVarInfo False binds)))
  57         ))
  58      else returnMn ()) `thenMn_`
  59
  60         -- Do the main business!
  61     foldl_mn do_stg_pass (binds, us4now, ([],[])) stg_todos
  62                 `thenMn` \ (processed_binds, _, cost_centres) ->
  63         -- Do essential wind-up: part (a) is SatStgRhs
  64
  65         -- Not optional, because correct arity information is used by
  66         -- the code generator.  Afterwards do setStgVarInfo; it gives
  67         -- the wrong answers if arities are subsequently changed,
  68         -- which stgSatRhs might do.  Furthermore, setStgVarInfo
  69         -- decides about let-no-escape things, which in turn do a
  70         -- better job if arities are correct, which is done by
  71         -- satStgRhs.
  72
  73     case (satStgRhs processed_binds us4later) of { saturated_binds ->
  74
  75         -- Essential wind-up: part (b), eliminate indirections
  76
  77     let no_ind_binds = elimIndirections saturated_binds in
  78
  79
  80         -- Essential wind-up: part (c), do setStgVarInfo. It has to
  81         -- happen regardless, because the code generator uses its
  82         -- decorations.
  83         --
  84         -- Why does it have to happen last?  Because earlier passes
  85         -- may move things around, which would change the live-var
  86         -- info.  Also, setStgVarInfo decides about let-no-escape
  87         -- things, which in turn do a better job if arities are
  88         -- correct, which is done by satStgRhs.
  89         --
  90     let
  91                 -- ToDo: provide proper flag control!
  92         binds_to_mangle
  93           = if not do_unlocalising
  94             then no_ind_binds
  95             else snd (unlocaliseStgBinds unlocal_tag nullIdEnv no_ind_binds)
  96     in
  97     returnMn (setStgVarInfo do_let_no_escapes binds_to_mangle, cost_centres)
  98     }}
  99     ESCC
 100   where
 101     switch_is_on = switchIsOn sw_chkr
 102
 103     do_let_no_escapes  = switch_is_on StgDoLetNoEscapes
 104     do_verbose_stg2stg = switch_is_on D_verbose_stg2stg
 105
 106     (do_unlocalising, unlocal_tag)
 107       = case (stringSwitchSet sw_chkr EnsureSplittableC) of
 108               Nothing  -> (False, panic "tag")
 109               Just tag -> (True,  _PK_ tag)
 110
 111     grp_name  = case (stringSwitchSet sw_chkr SccGroup) of
 112                   Just xx -> _PK_ xx
 113                   Nothing -> module_name -- default: module name
 114
 115     -------------
 116     stg_linter = if False -- LATER: switch_is_on DoCoreLinting -- ToDo: DoStgLinting flag
 117                  then lintStgBindings ppr_style
 118                  else ( \ whodunnit binds -> binds )
 119
 120     -------------------------------------------
 121     do_stg_pass (binds, us, ccs) to_do
 122       = let
 123             (us1, us2) = splitUniqSupply us
 124         in
 125         case to_do of
 126           StgDoStaticArgs ->
 127              ASSERT(null (fst ccs) && null (snd ccs))
 128              BSCC("StgStaticArgs")
 129              let
 130                  binds3 = doStaticArgs binds us1
 131              in
 132              end_pass us2 "StgStaticArgs" ccs binds3
 133              ESCC
 134
 135           StgDoUpdateAnalysis ->
 136              ASSERT(null (fst ccs) && null (snd ccs))
 137              BSCC("StgUpdAnal")
 138                 -- NB We have to do setStgVarInfo first!  (There's one
 139                 -- place free-var info is used) But no let-no-escapes,
 140                 -- because update analysis doesn't care.
 141              end_pass us2 "UpdAnal" ccs (updateAnalyse (setStgVarInfo False binds))
 142              ESCC
 143
 144           D_stg_stats ->
 145              trace (showStgStats binds)
 146              end_pass us2 "StgStats" ccs binds
 147
 148           StgDoLambdaLift ->
 149              BSCC("StgLambdaLift")
 150                 -- NB We have to do setStgVarInfo first!
 151              let
 152                 binds3 = liftProgram us1 (setStgVarInfo do_let_no_escapes binds)
 153              in
 154              end_pass us2 "LambdaLift" ccs binds3
 155              ESCC
 156
 157           StgDoMassageForProfiling ->
 158              BSCC("ProfMassage")
 159              let
 160                  (collected_CCs, binds3)
 161                    = stgMassageForProfiling module_name grp_name us1 switch_is_on binds
 162              in
 163              end_pass us2 "ProfMassage" collected_CCs binds3
 164              ESCC
 165
 166     end_pass us2 what ccs binds2
 167       = -- report verbosely, if required
 168         (if do_verbose_stg2stg then
 169             writeMn stderr (ppShow 1000
 170             (ppAbove (ppStr ("*** "++what++":"))
 171                      (ppAboves (map (ppr ppr_style) binds2))
 172             ))
 173          else returnMn ()) `thenMn_`
 174         let
 175             linted_binds = stg_linter what binds2
 176         in
 177         returnMn (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 []     = returnMn z
 185 foldl_mn f z (x:xs) = f z x     `thenMn` \ 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   = BIND unlocal_top_bind mod uenv b        _TO_ (new_uenv, new_b) ->
 224     BIND unlocaliseStgBinds mod new_uenv bs _TO_ (uenv3, new_bs) ->
 225     (uenv3, new_b : new_bs)
 226     BEND BEND
 227
 228 ------------------
 229
 230 unlocal_top_bind :: FAST_STRING -> UnlocalEnv -> StgBinding -> (UnlocalEnv, StgBinding)
 231
 232 unlocal_top_bind mod uenv bind@(StgNonRec binder _)
 233   = let new_uenv = case unlocaliseId mod binder of
 234                         Nothing         -> uenv
 235                         Just new_binder -> addOneToIdEnv uenv binder new_binder
 236     in
 237     (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind)
 238
 239 unlocal_top_bind mod uenv bind@(StgRec pairs)
 240   = let maybe_unlocaliseds  = [ (b, unlocaliseId mod b) | (b, _) <- pairs ]
 241         new_uenv            = growIdEnvList uenv [ (b,new_b)
 242                                                  | (b, Just new_b) <- maybe_unlocaliseds]
 243     in
 244     (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind)
 245 \end{code}
 246
 247 %************************************************************************
 248 %*                                                                      *
 249 \subsection[SimplStg-indirections]{Eliminating indirections in STG code}
 250 %*                                                                      *
 251 %************************************************************************
 252
 253 In @elimIndirections@, we look for things at the top-level of the form...
 254 \begin{verbatim}
 255     x_local = ....rhs...
 256     ...
 257     x_exported = x_local
 258     ...
 259 \end{verbatim}
 260 In cases we find like this, we go {\em backwards} and replace
 261 \tr{x_local} with \tr{...rhs...}, to produce
 262 \begin{verbatim}
 263     x_exported = ...rhs...
 264     ...
 265     ...
 266 \end{verbatim}
 267 This saves a gratuitous jump
 268 (from \tr{x_exported} to \tr{x_local}), and makes strictness
 269 information propagate better.
 270
 271 If more than one exported thing is equal to a local thing (i.e., the
 272 local thing really is shared), then we eliminate only the first one.  Thus:
 273 \begin{verbatim}
 274     x_local = ....rhs...
 275     ...
 276     x_exported1 = x_local
 277     ...
 278     x_exported2 = x_local
 279     ...
 280 \end{verbatim}
 281 becomes
 282 \begin{verbatim}
 283     x_exported1 = ....rhs...
 284     ...
 285     ...
 286     x_exported2 = x_exported1
 287     ...
 288 \end{verbatim}
 289
 290 We also have to watch out for
 291
 292         f = \xyz -> g x y z
 293
 294 This can arise post lambda lifting; the original might have been
 295
 296         f = \xyz -> letrec g = [xy] \ [k] -> e
 297                     in
 298                     g z
 299
 300 Strategy: first collect the info; then make a \tr{Id -> Id} mapping.
 301 Then blast the whole program (LHSs as well as RHSs) with it.
 302
 303 \begin{code}
 304 elimIndirections :: [StgBinding] -> [StgBinding]
 305
 306 elimIndirections binds_in
 307   = if isNullIdEnv blast_env then
 308         binds_in            -- Nothing to do
 309     else
 310         [renameTopStgBind lookup_fn bind | Just bind <- reduced_binds]
 311   where
 312     lookup_fn id = case lookupIdEnv blast_env id of
 313                         Just new_id -> new_id
 314                         Nothing     -> id
 315
 316     (blast_env, reduced_binds) = mapAccumL try_bind nullIdEnv binds_in
 317
 318     try_bind :: IdEnv Id -> StgBinding -> (IdEnv Id, Maybe StgBinding)
 319     try_bind env_so_far
 320              (StgNonRec exported_binder
 321                        (StgRhsClosure _ _ _ _
 322                                 lambda_args
 323                                 (StgApp (StgVarArg local_binder) fun_args _)
 324              ))
 325         | isExported exported_binder &&     -- Only if this is exported
 326           not (isExported local_binder) &&  -- Only if this one is defined in this
 327           isLocallyDefined local_binder &&  -- module, so that we *can* change its
 328                                             -- binding to be the exported thing!
 329           not (in_dom env_so_far local_binder) && -- Only if we havn't seen it before
 330           args_match lambda_args fun_args   -- Just an eta-expansion
 331
 332         = (addOneToIdEnv env_so_far local_binder exported_binder,
 333            Nothing)
 334         where
 335           args_match [] [] = True
 336           args_match (la:las) (StgVarArg fa:fas) = la == fa && args_match las fas
 337           args_match _  _  = False
 338
 339     try_bind env_so_far bind
 340         = (env_so_far, Just bind)
 341
 342     in_dom env id = maybeToBool (lookupIdEnv env id)
 343 \end{code}
 344
 345 @renameTopStgBind@ renames top level binders and all occurrences thereof.
 346
 347 \begin{code}
 348 renameTopStgBind :: (Id -> Id) -> StgBinding -> StgBinding
 349
 350 renameTopStgBind fn (StgNonRec b rhs) = StgNonRec (fn b) (mapStgBindeesRhs fn rhs)
 351 renameTopStgBind fn (StgRec pairs)    = StgRec [ (fn b, mapStgBindeesRhs fn r) | (b, r) <- pairs ]
 352 \end{code}