ghc/compiler/simplStg/SimplStg.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section[SimplStg]{Driver for simplifying @STG@ programs}
   5
   6 \begin{code}
   7 module SimplStg ( stg2stg ) where
   8
   9 #include "HsVersions.h"
  10
  11 import StgSyn
  12
  13 import LambdaLift       ( liftProgram )
  14 import CostCentre       ( CostCentre, CostCentreStack )
  15 import SCCfinal         ( stgMassageForProfiling )
  16 import StgLint          ( lintStgBindings )
  17 import StgStats         ( showStgStats )
  18 import StgVarInfo       ( setStgVarInfo )
  19 import UpdAnal          ( updateAnalyse )
  20 import SRT              ( computeSRTs )
  21
  22 import CmdLineOpts      ( opt_SccGroup,
  23                           opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg,
  24                           opt_DoStgLinting, opt_D_dump_stg,
  25                           StgToDo(..)
  26                         )
  27 import Id               ( Id )
  28 import Module           ( Module, moduleString )
  29 import VarEnv
  30 import ErrUtils         ( doIfSet, dumpIfSet )
  31 import UniqSupply       ( splitUniqSupply, UniqSupply )
  32 import IO               ( hPutStr, stderr )
  33 import Outputable
  34 \end{code}
  35
  36 \begin{code}
  37 stg2stg :: [StgToDo]            -- spec of what stg-to-stg passes to do
  38         -> Module               -- module name (profiling only)
  39         -> UniqSupply           -- a name supply
  40         -> [StgBinding]         -- input...
  41         -> IO
  42             ([(StgBinding,[Id])],  -- output program...
  43              ([CostCentre],        -- local cost-centres that need to be decl'd
  44               [CostCentre],        -- "extern" cost-centres
  45               [CostCentreStack]))  -- pre-defined "singleton" cost centre stacks
  46
  47 stg2stg stg_todos module_name us binds
  48   = case (splitUniqSupply us)   of { (us4now, us4later) ->
  49
  50     doIfSet do_verbose_stg2stg
  51         (printErrs (text "VERBOSE STG-TO-STG:" $$
  52                     text "*** Core2Stg:" $$
  53                     vcat (map ppr (setStgVarInfo False binds)))) >>
  54
  55         -- Do the main business!
  56     foldl_mn do_stg_pass (binds, us4now, ([],[],[])) stg_todos
  57                 >>= \ (processed_binds, _, cost_centres) ->
  58
  59         --      Do essential wind-up
  60
  61         -- Essential wind-up: part (b), do setStgVarInfo. It has to
  62         -- happen regardless, because the code generator uses its
  63         -- decorations.
  64         --
  65         -- Why does it have to happen last?  Because earlier passes
  66         -- may move things around, which would change the live-var
  67         -- info.  Also, setStgVarInfo decides about let-no-escape
  68         -- things, which in turn do a better job if arities are
  69         -- correct, which is done by satStgRhs.
  70         --
  71
  72     let
  73         annotated_binds = setStgVarInfo do_let_no_escapes processed_binds
  74         srt_binds       = computeSRTs annotated_binds
  75     in
  76
  77     dumpIfSet opt_D_dump_stg "STG syntax:"
  78               (pprStgBindingsWithSRTs srt_binds)        >>
  79
  80     return (srt_binds, cost_centres)
  81    }
  82   where
  83     do_let_no_escapes  = opt_StgDoLetNoEscapes
  84     do_verbose_stg2stg = opt_D_verbose_stg2stg
  85
  86     grp_name  = case (opt_SccGroup) of
  87                   Just xx -> _PK_ xx
  88                   Nothing -> _PK_ (moduleString module_name) -- default: module name
  89
  90     -------------
  91     stg_linter = if opt_DoStgLinting
  92                  then lintStgBindings
  93                  else ( \ whodunnit binds -> binds )
  94
  95     -------------------------------------------
  96     do_stg_pass (binds, us, ccs) to_do
  97       = let
  98             (us1, us2) = splitUniqSupply us
  99         in
 100         case to_do of
 101           StgDoStaticArgs ->  panic "STG static argument transformation deleted"
 102
 103           StgDoUpdateAnalysis ->
 104              _scc_ "StgUpdAnal"
 105                 -- NB We have to do setStgVarInfo first!  (There's one
 106                 -- place free-var info is used) But no let-no-escapes,
 107                 -- because update analysis doesn't care.
 108              end_pass us2 "UpdAnal" ccs (updateAnalyse (setStgVarInfo False binds))
 109
 110           D_stg_stats ->
 111              trace (showStgStats binds)
 112              end_pass us2 "StgStats" ccs binds
 113
 114           StgDoLambdaLift ->
 115              _scc_ "StgLambdaLift"
 116                 -- NB We have to do setStgVarInfo first!
 117              let
 118                 binds3 = liftProgram module_name us1 (setStgVarInfo do_let_no_escapes binds)
 119              in
 120              end_pass us2 "LambdaLift" ccs binds3
 121
 122           StgDoMassageForProfiling ->
 123              _scc_ "ProfMassage"
 124              let
 125                  (collected_CCs, binds3)
 126                    = stgMassageForProfiling module_name grp_name us1 binds
 127              in
 128              end_pass us2 "ProfMassage" collected_CCs binds3
 129
 130     end_pass us2 what ccs binds2
 131       = -- report verbosely, if required
 132         (if do_verbose_stg2stg then
 133             hPutStr stderr (showSDoc
 134               (text ("*** "++what++":") $$ vcat (map ppr binds2)
 135             ))
 136          else return ()) >>
 137         let
 138             linted_binds = stg_linter what binds2
 139         in
 140         return (linted_binds, us2, ccs)
 141             -- return: processed binds
 142             --         UniqueSupply for the next guy to use
 143             --         cost-centres to be declared/registered (specialised)
 144             --         add to description of what's happened (reverse order)
 145
 146 -- here so it can be inlined...
 147 foldl_mn f z []     = return z
 148 foldl_mn f z (x:xs) = f z x     >>= \ zz ->
 149                      foldl_mn f zz xs
 150 \end{code}