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