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 IMPORT_1_3(IO(hPutStr,stderr))
  13
  14 import StgSyn
  15
  16 import LambdaLift       ( liftProgram )
  17 import Name             ( isLocallyDefined )
  18 import UniqSet          ( UniqSet(..), mapUniqSet )
  19 import CostCentre       ( CostCentre )
  20 import SCCfinal         ( stgMassageForProfiling )
  21 import StgLint          ( lintStgBindings )
  22 import StgStats         ( showStgStats )
  23 import StgVarInfo       ( setStgVarInfo )
  24 import UpdAnal          ( updateAnalyse )
  25
  26 import CmdLineOpts      ( opt_SccGroup, --Not used:opt_EnsureSplittableC,
  27                           opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg,
  28                           opt_DoStgLinting,
  29                           StgToDo(..)
  30                         )
  31 import Id               ( nullIdEnv, lookupIdEnv, addOneToIdEnv,
  32                           growIdEnvList, isNullIdEnv, SYN_IE(IdEnv),
  33                           setIdVisibility,
  34                           GenId{-instance Eq/Outputable -}, SYN_IE(Id)
  35                         )
  36 import Maybes           ( maybeToBool )
  37 import PprType          ( GenType{-instance Outputable-} )
  38 import PprStyle         ( PprStyle )
  39 import Pretty           ( Doc, ($$), vcat, text, ptext )
  40 import UniqSupply       ( splitUniqSupply, UniqSupply )
  41 import Util             ( mapAccumL, panic, assertPanic )
  42 #if __GLASGOW_HASKELL__ >= 202
  43 import Outputable       ( Outputable(..) )
  44 #endif
  45 \end{code}
  46
  47 \begin{code}
  48 stg2stg :: [StgToDo]            -- spec of what stg-to-stg passes to do
  49         -> FAST_STRING          -- module name (profiling only)
  50         -> PprStyle             -- printing style (for debugging only)
  51         -> UniqSupply           -- a name supply
  52         -> [StgBinding]         -- input...
  53         -> IO
  54             ([StgBinding],      -- output program...
  55              ([CostCentre],     -- local cost-centres that need to be decl'd
  56               [CostCentre]))    -- "extern" cost-centres
  57
  58 stg2stg stg_todos module_name ppr_style us binds
  59   = case (splitUniqSupply us)   of { (us4now, us4later) ->
  60
  61     (if do_verbose_stg2stg then
  62         hPutStr stderr "VERBOSE STG-TO-STG:\n" >>
  63         hPutStr stderr (show
  64         (($$) (ptext SLIT("*** Core2Stg:"))
  65                  (vcat (map (ppr ppr_style) (setStgVarInfo False binds)))
  66         ))
  67      else return ()) >>
  68
  69         -- Do the main business!
  70     foldl_mn do_stg_pass (binds, us4now, ([],[])) stg_todos
  71                 >>= \ (processed_binds, _, cost_centres) ->
  72
  73         --      Do essential wind-up
  74
  75 {- Nuked for now        SLPJ Dec 96
  76
  77         -- Essential wind-up: part (a), saturate RHSs
  78         -- This must occur *after* elimIndirections, because elimIndirections
  79         -- can change things' arities.  Consider:
  80         --      x_local = f x
  81         --      x_global = \a -> x_local a
  82         -- Then elimIndirections will change the program to
  83         --      x_global = f x
  84         -- and lo and behold x_global's arity has changed!
  85     case (satStgRhs processed_binds us4later) of { saturated_binds ->
  86 -}
  87
  88         -- Essential wind-up: part (b), 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
  99 {-
 100         Done in Core now.  Nuke soon. SLPJ Nov 96
 101
 102    No, STG passes may introduce toplevel bindings which
 103    have to be globalised here (later than Core anyway) -- SOF 2/97
 104
 105    Yes, lambda lifting now does the Right Thing.
 106
 107     let
 108                 -- ToDo: provide proper flag control!
 109         binds_to_mangle
 110           = if not do_unlocalising
 111             then processed_binds
 112             else snd (unlocaliseStgBinds unlocal_tag nullIdEnv processed_binds)
 113     in
 114 -}
 115
 116     return (setStgVarInfo do_let_no_escapes processed_binds, cost_centres)
 117    }
 118   where
 119     do_let_no_escapes  = opt_StgDoLetNoEscapes
 120     do_verbose_stg2stg = opt_D_verbose_stg2stg
 121
 122 {-
 123     (do_unlocalising, unlocal_tag)
 124      = case opt_EnsureSplittableC of
 125          Just tag -> (True, _PK_ tag)
 126          Nothing  -> (False, panic "tag")
 127 -}
 128     grp_name  = case (opt_SccGroup) of
 129                   Just xx -> _PK_ xx
 130                   Nothing -> module_name -- default: module name
 131
 132     -------------
 133     stg_linter = if False --LATER: opt_DoStgLinting (ToDo)
 134                  then lintStgBindings ppr_style
 135                  else ( \ whodunnit binds -> binds )
 136
 137     -------------------------------------------
 138     do_stg_pass (binds, us, ccs) to_do
 139       = let
 140             (us1, us2) = splitUniqSupply us
 141         in
 142         case to_do of
 143           StgDoStaticArgs ->  panic "STG static argument transformation deleted"
 144
 145           StgDoUpdateAnalysis ->
 146              ASSERT(null (fst ccs) && null (snd ccs))
 147              _scc_ "StgUpdAnal"
 148                 -- NB We have to do setStgVarInfo first!  (There's one
 149                 -- place free-var info is used) But no let-no-escapes,
 150                 -- because update analysis doesn't care.
 151              end_pass us2 "UpdAnal" ccs (updateAnalyse (setStgVarInfo False binds))
 152
 153           D_stg_stats ->
 154              trace (showStgStats binds)
 155              end_pass us2 "StgStats" ccs binds
 156
 157           StgDoLambdaLift ->
 158              _scc_ "StgLambdaLift"
 159                 -- NB We have to do setStgVarInfo first!
 160              let
 161                 binds3 = liftProgram module_name us1 (setStgVarInfo do_let_no_escapes binds)
 162              in
 163              end_pass us2 "LambdaLift" ccs binds3
 164
 165           StgDoMassageForProfiling ->
 166              _scc_ "ProfMassage"
 167              let
 168                  (collected_CCs, binds3)
 169                    = stgMassageForProfiling module_name grp_name us1 binds
 170              in
 171              end_pass us2 "ProfMassage" collected_CCs binds3
 172
 173     end_pass us2 what ccs binds2
 174       = -- report verbosely, if required
 175         (if do_verbose_stg2stg then
 176             hPutStr stderr (show
 177             (($$) (text ("*** "++what++":"))
 178                      (vcat (map (ppr ppr_style) binds2))
 179             ))
 180          else return ()) >>
 181         let
 182             linted_binds = stg_linter what binds2
 183         in
 184         return (linted_binds, us2, ccs)
 185             -- return: processed binds
 186             --         UniqueSupply for the next guy to use
 187             --         cost-centres to be declared/registered (specialised)
 188             --         add to description of what's happened (reverse order)
 189
 190 -- here so it can be inlined...
 191 foldl_mn f z []     = return z
 192 foldl_mn f z (x:xs) = f z x     >>= \ zz ->
 193                      foldl_mn f zz xs
 194 \end{code}
 195
 196 %************************************************************************
 197 %*                                                                      *
 198 \subsection[SimplStg-unlocalise]{Unlocalisation in STG code}
 199 %*                                                                      *
 200 %************************************************************************
 201
 202 The idea of all this ``unlocalise'' stuff is that in certain (prelude
 203 only) modules we split up the .hc file into lots of separate little
 204 files, which are separately compiled by the C compiler.  That gives
 205 lots of little .o files.  The idea is that if you happen to mention
 206 one of them you don't necessarily pull them all in.  (Pulling in a
 207 piece you don't need can be v bad, because it may mention other pieces
 208 you don't need either, and so on.)
 209
 210 Sadly, splitting up .hc files means that local names (like s234) are
 211 now globally visible, which can lead to clashes between two .hc
 212 files. So unlocaliseWhatnot goes through making all the local things
 213 into global things, essentially by giving them full names so when they
 214 are printed they'll have their module name too.  Pretty revolting
 215 really.
 216
 217 \begin{code}
 218 type UnlocalEnv = IdEnv Id
 219
 220 lookup_uenv :: UnlocalEnv -> Id -> Id
 221 lookup_uenv env id =  case lookupIdEnv env id of
 222                         Nothing     -> id
 223                         Just new_id -> new_id
 224 unlocaliseStgBinds :: FAST_STRING
 225                    -> UnlocalEnv
 226                    -> [StgBinding]
 227                    -> (UnlocalEnv, [StgBinding])
 228 unlocaliseStgBinds mod uenv []       = (uenv, [])
 229 unlocaliseStgBinds mod uenv (b : bs) =
 230   case unlocal_top_bind mod uenv b        of { (new_uenv, new_b) ->
 231   case unlocaliseStgBinds mod new_uenv bs of { (uenv3, new_bs) ->
 232     (uenv3, new_b : new_bs)
 233   }}
 234
 235 ------------------
 236 unlocal_top_bind :: FAST_STRING
 237                  -> UnlocalEnv
 238                  -> StgBinding
 239                  -> (UnlocalEnv, StgBinding)
 240 unlocal_top_bind mod uenv bind@(StgNonRec binder _) =
 241  let
 242   new_uenv =
 243    case lookupIdEnv uenv binder of
 244     Just global -> uenv
 245     Nothing     -> new_env
 246      where
 247       new_env    = addOneToIdEnv uenv binder new_global
 248       new_global = setIdVisibility mod binder
 249  in
 250  (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind)
 251
 252 unlocal_top_bind mod uenv bind@(StgRec pairs) =
 253  let
 254   new_env binder uenv =
 255     case lookupIdEnv uenv binder of
 256       Just global -> uenv
 257       Nothing     -> env'
 258         where
 259          env'       = addOneToIdEnv uenv binder new_global
 260          new_global = setIdVisibility mod binder
 261
 262   uenv' = foldr (new_env) uenv (map (fst) pairs)
 263  in
 264  (uenv', renameTopStgBind (lookup_uenv uenv') bind)
 265
 266 \end{code}
 267
 268 @renameTopStgBind@ renames top level binders and all occurrences thereof.
 269
 270 \begin{code}
 271 renameTopStgBind :: (Id -> Id) -> StgBinding -> StgBinding
 272 renameTopStgBind fn (StgNonRec b rhs) = StgNonRec (fn b) (mapStgBindeesRhs fn rhs)
 273 renameTopStgBind fn (StgRec pairs)    = StgRec [ (fn b, mapStgBindeesRhs fn r) | (b, r) <- pairs ]
 274 \end{code}
 275
 276 This utility function simply applies the given function to every
 277 bindee in the program.
 278
 279 \begin{code}
 280 mapStgBindeesBind :: (Id -> Id) -> StgBinding -> StgBinding
 281 mapStgBindeesBind fn (StgNonRec b rhs) = StgNonRec b (mapStgBindeesRhs fn rhs)
 282 mapStgBindeesBind fn (StgRec pairs)    = StgRec [ (b, mapStgBindeesRhs fn r) | (b, r) <- pairs ]
 283
 284 ------------------
 285 mapStgBindeesRhs :: (Id -> Id) -> StgRhs -> StgRhs
 286 mapStgBindeesRhs fn (StgRhsClosure cc bi fvs u args expr)
 287   = StgRhsClosure
 288         cc bi
 289         (map fn fvs)
 290         u
 291         (map fn args)
 292         (mapStgBindeesExpr fn expr)
 293
 294 mapStgBindeesRhs fn (StgRhsCon cc con atoms)
 295   = StgRhsCon cc con (map (mapStgBindeesArg fn) atoms)
 296
 297 ------------------
 298 mapStgBindeesExpr :: (Id -> Id) -> StgExpr -> StgExpr
 299
 300 mapStgBindeesExpr fn (StgApp f args lvs)
 301   = StgApp (mapStgBindeesArg fn f)
 302            (map (mapStgBindeesArg fn) args)
 303            (mapUniqSet fn lvs)
 304
 305 mapStgBindeesExpr fn (StgCon con atoms lvs)
 306   = StgCon con (map (mapStgBindeesArg fn) atoms) (mapUniqSet fn lvs)
 307
 308 mapStgBindeesExpr fn (StgPrim op atoms lvs)
 309   = StgPrim op (map (mapStgBindeesArg fn) atoms) (mapUniqSet fn lvs)
 310
 311 mapStgBindeesExpr fn (StgLet bind expr)
 312   = StgLet (mapStgBindeesBind fn bind) (mapStgBindeesExpr fn expr)
 313
 314 mapStgBindeesExpr fn (StgLetNoEscape lvs rhss_lvs bind body)
 315   = StgLetNoEscape (mapUniqSet fn lvs) (mapUniqSet fn rhss_lvs)
 316                    (mapStgBindeesBind fn bind) (mapStgBindeesExpr fn body)
 317
 318 mapStgBindeesExpr fn (StgSCC ty label expr)
 319   = StgSCC ty label (mapStgBindeesExpr fn expr)
 320
 321 mapStgBindeesExpr fn (StgCase expr lvs1 lvs2 uniq alts)
 322   = StgCase (mapStgBindeesExpr fn expr)
 323             (mapUniqSet fn lvs1)
 324             (mapUniqSet fn lvs2)
 325             uniq
 326             (mapStgBindeesAlts alts)
 327   where
 328     mapStgBindeesAlts (StgAlgAlts ty alts deflt)
 329       = StgAlgAlts ty (map mapStgBindeesBoxed_alt alts) (mapStgBindeesDeflt deflt)
 330       where
 331         mapStgBindeesBoxed_alt (c,ps,use_mask,expr) = (c,ps,use_mask,mapStgBindeesExpr fn expr)
 332
 333     mapStgBindeesAlts (StgPrimAlts ty alts deflt)
 334       = StgPrimAlts ty (map mapStgBindeesunboxed_alt alts) (mapStgBindeesDeflt deflt)
 335       where
 336         mapStgBindeesunboxed_alt (l,expr) = (l,mapStgBindeesExpr fn expr)
 337
 338     mapStgBindeesDeflt StgNoDefault                 = StgNoDefault
 339     mapStgBindeesDeflt (StgBindDefault b used expr) = StgBindDefault b used (mapStgBindeesExpr fn expr)
 340
 341 ------------------
 342 mapStgBindeesArg :: (Id -> Id) -> StgArg -> StgArg
 343 mapStgBindeesArg fn a@(StgLitArg _)   = a
 344 mapStgBindeesArg fn a@(StgConArg _)   = a
 345 mapStgBindeesArg fn a@(StgVarArg id)  = StgVarArg (fn id)
 346 \end{code}