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