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 CostCentre       ( CostCentre, CostCentreStack )
  14 import SCCfinal         ( stgMassageForProfiling )
  15 import StgLint          ( lintStgBindings )
  16 import StgStats         ( showStgStats )
  17 import SRT              ( computeSRTs )
  18
  19 import CmdLineOpts      ( DynFlags, DynFlag(..), dopt,
  20                           opt_StgDoLetNoEscapes,
  21                           StgToDo(..), dopt_StgToDo
  22                         )
  23 import Id               ( Id )
  24 import Module           ( Module )
  25 import ErrUtils         ( doIfSet_dyn, dumpIfSet_dyn, showPass )
  26 import UniqSupply       ( mkSplitUniqSupply, splitUniqSupply, UniqSupply )
  27 import IO               ( hPutStr, stdout )
  28 import Outputable
  29 \end{code}
  30
  31 \begin{code}
  32 stg2stg :: DynFlags             -- includes spec of what stg-to-stg passes to do
  33         -> Module               -- module name (profiling only)
  34         -> [StgBinding]         -- input...
  35         -> IO
  36             ([(StgBinding,[Id])],  -- output program...
  37              ([CostCentre],        -- local cost-centres that need to be decl'd
  38               [CostCentre],        -- "extern" cost-centres
  39               [CostCentreStack]))  -- pre-defined "singleton" cost centre stacks
  40
  41 stg2stg dflags module_name binds
  42   = do  { showPass dflags "Stg2Stg"
  43         ; us <- mkSplitUniqSupply 'g'
  44
  45         ; doIfSet_dyn dflags Opt_D_verbose_stg2stg
  46                       (printDump (text "VERBOSE STG-TO-STG:"))
  47
  48         ; (binds', us', ccs) <- end_pass us "Stg2Stg" ([],[],[]) binds
  49
  50                 -- Do the main business!
  51         ; (processed_binds, _, cost_centres)
  52                 <- foldl_mn do_stg_pass (binds', us', ccs)
  53                             (dopt_StgToDo dflags)
  54
  55         ; let srt_binds = computeSRTs processed_binds
  56
  57         ; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:"
  58                         (pprStgBindingsWithSRTs srt_binds)
  59
  60         ; return (srt_binds, cost_centres)
  61    }
  62
  63   where
  64     stg_linter = if dopt Opt_DoStgLinting dflags
  65                  then lintStgBindings
  66                  else ( \ whodunnit binds -> binds )
  67
  68     -------------------------------------------
  69     do_stg_pass (binds, us, ccs) to_do
  70       = let
  71             (us1, us2) = splitUniqSupply us
  72         in
  73         case to_do of
  74           D_stg_stats ->
  75              trace (showStgStats binds)
  76              end_pass us2 "StgStats" ccs binds
  77
  78           StgDoMassageForProfiling ->
  79              _scc_ "ProfMassage"
  80              let
  81                  (collected_CCs, binds3)
  82                    = stgMassageForProfiling module_name us1 binds
  83              in
  84              end_pass us2 "ProfMassage" collected_CCs binds3
  85
  86     end_pass us2 what ccs binds2
  87       = -- report verbosely, if required
  88         (if dopt Opt_D_verbose_stg2stg dflags then
  89             hPutStr stdout (showSDoc
  90               (text ("*** "++what++":") $$ vcat (map ppr binds2)
  91             ))
  92          else return ()) >>
  93         let
  94             linted_binds = stg_linter what binds2
  95         in
  96         return (linted_binds, us2, ccs)
  97             -- return: processed binds
  98             --         UniqueSupply for the next guy to use
  99             --         cost-centres to be declared/registered (specialised)
 100             --         add to description of what's happened (reverse order)
 101
 102 -- here so it can be inlined...
 103 foldl_mn f z []     = return z
 104 foldl_mn f z (x:xs) = f z x     >>= \ zz ->
 105                      foldl_mn f zz xs
 106 \end{code}