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