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 SRT              ( computeSRTs )
  20
  21 import CmdLineOpts      ( opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg,
  22                           opt_DoStgLinting, opt_D_dump_stg,
  23                           StgToDo(..)
  24                         )
  25 import Id               ( Id )
  26 import Module           ( Module, moduleString )
  27 import VarEnv
  28 import ErrUtils         ( doIfSet, dumpIfSet )
  29 import UniqSupply       ( splitUniqSupply, UniqSupply )
  30 import IO               ( hPutStr, stdout )
  31 import Outputable
  32 \end{code}
  33
  34 \begin{code}
  35 stg2stg :: [StgToDo]            -- spec of what stg-to-stg passes to do
  36         -> Module               -- module name (profiling only)
  37         -> UniqSupply           -- a name supply
  38         -> [StgBinding]         -- input...
  39         -> IO
  40             ([(StgBinding,[Id])],  -- output program...
  41              ([CostCentre],        -- local cost-centres that need to be decl'd
  42               [CostCentre],        -- "extern" cost-centres
  43               [CostCentreStack]))  -- pre-defined "singleton" cost centre stacks
  44
  45 stg2stg stg_todos module_name us binds
  46   = case (splitUniqSupply us)   of { (us4now, us4later) ->
  47
  48     doIfSet opt_D_verbose_stg2stg (printErrs (text "VERBOSE STG-TO-STG:")) >>
  49
  50     end_pass us4now "Core2Stg" ([],[],[]) binds
  51                 >>= \ (binds', us, ccs) ->
  52
  53         -- Do the main business!
  54     foldl_mn do_stg_pass (binds', us, ccs) stg_todos
  55                 >>= \ (processed_binds, _, cost_centres) ->
  56
  57         --      Do essential wind-up
  58
  59         -- Essential wind-up: part (b), do setStgVarInfo. It has to
  60         -- happen regardless, because the code generator uses its
  61         -- decorations.
  62         --
  63         -- Why does it have to happen last?  Because earlier passes
  64         -- may move things around, which would change the live-var
  65         -- info.  Also, setStgVarInfo decides about let-no-escape
  66         -- things, which in turn do a better job if arities are
  67         -- correct, which is done by satStgRhs.
  68         --
  69
  70     let
  71         annotated_binds = setStgVarInfo opt_StgDoLetNoEscapes processed_binds
  72         srt_binds       = computeSRTs annotated_binds
  73     in
  74
  75     dumpIfSet opt_D_dump_stg "STG syntax:"
  76               (pprStgBindingsWithSRTs srt_binds)        >>
  77
  78     return (srt_binds, cost_centres)
  79    }
  80
  81   where
  82     stg_linter = if opt_DoStgLinting
  83                  then lintStgBindings
  84                  else ( \ whodunnit binds -> binds )
  85
  86     -------------------------------------------
  87     do_stg_pass (binds, us, ccs) to_do
  88       = let
  89             (us1, us2) = splitUniqSupply us
  90         in
  91         case to_do of
  92           StgDoStaticArgs ->  panic "STG static argument transformation deleted"
  93
  94           D_stg_stats ->
  95              trace (showStgStats binds)
  96              end_pass us2 "StgStats" ccs binds
  97
  98           StgDoLambdaLift ->
  99              _scc_ "StgLambdaLift"
 100                 -- NB We have to do setStgVarInfo first!
 101              let
 102                 binds3 = liftProgram module_name us1 (setStgVarInfo opt_StgDoLetNoEscapes binds)
 103              in
 104              end_pass us2 "LambdaLift" ccs binds3
 105
 106           StgDoMassageForProfiling ->
 107              _scc_ "ProfMassage"
 108              let
 109                  (collected_CCs, binds3)
 110                    = stgMassageForProfiling module_name us1 binds
 111              in
 112              end_pass us2 "ProfMassage" collected_CCs binds3
 113
 114     end_pass us2 what ccs binds2
 115       = -- report verbosely, if required
 116         (if opt_D_verbose_stg2stg then
 117             hPutStr stdout (showSDoc
 118               (text ("*** "++what++":") $$ vcat (map ppr binds2)
 119             ))
 120          else return ()) >>
 121         let
 122             linted_binds = stg_linter what binds2
 123         in
 124         return (linted_binds, us2, ccs)
 125             -- return: processed binds
 126             --         UniqueSupply for the next guy to use
 127             --         cost-centres to be declared/registered (specialised)
 128             --         add to description of what's happened (reverse order)
 129
 130 -- here so it can be inlined...
 131 foldl_mn f z []     = return z
 132 foldl_mn f z (x:xs) = f z x     >>= \ zz ->
 133                      foldl_mn f zz xs
 134 \end{code}