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