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