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