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 -- XXX This define is a bit of a hack, and should be done more nicely
  10 #define FAST_STRING_NOT_NEEDED 1
  11 #include "HsVersions.h"
  12
  13 import StgSyn
  14
  15 import CostCentre       ( CollectedCCs )
  16 import SCCfinal         ( stgMassageForProfiling )
  17 import StgLint          ( lintStgBindings )
  18 import StgStats         ( showStgStats )
  19 import SRT              ( computeSRTs )
  20
  21 import DynFlags         ( DynFlags(..), DynFlag(..), dopt, StgToDo(..),
  22                           getStgToDo )
  23 import Id               ( Id )
  24 import Module           ( Module )
  25 import ErrUtils         ( doIfSet_dyn, dumpIfSet_dyn, showPass )
  26 import UniqSupply       ( mkSplitUniqSupply, splitUniqSupply )
  27 import Outputable
  28 \end{code}
  29
  30 \begin{code}
  31 stg2stg :: DynFlags                  -- includes spec of what stg-to-stg passes to do
  32         -> Module                    -- module name (profiling only)
  33         -> [StgBinding]              -- input...
  34         -> IO ( [(StgBinding,[(Id,[Id])])]  -- output program...
  35               , CollectedCCs)        -- cost centre information (declared and used)
  36
  37 stg2stg dflags module_name binds
  38   = do  { showPass dflags "Stg2Stg"
  39         ; us <- mkSplitUniqSupply 'g'
  40
  41         ; doIfSet_dyn dflags Opt_D_verbose_stg2stg
  42                       (printDump (text "VERBOSE STG-TO-STG:"))
  43
  44         ; (binds', us', ccs) <- end_pass us "Stg2Stg" ([],[],[]) binds
  45
  46                 -- Do the main business!
  47         ; (processed_binds, _, cost_centres)
  48                 <- foldl_mn do_stg_pass (binds', us', ccs) (getStgToDo dflags)
  49
  50         ; let srt_binds = computeSRTs processed_binds
  51
  52         ; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:"
  53                         (pprStgBindingsWithSRTs srt_binds)
  54
  55         ; return (srt_binds, cost_centres)
  56    }
  57
  58   where
  59     stg_linter = if dopt Opt_DoStgLinting dflags
  60                  then lintStgBindings
  61                  else ( \ _whodunnit binds -> binds )
  62
  63     -------------------------------------------
  64     do_stg_pass (binds, us, ccs) to_do
  65       = let
  66             (us1, us2) = splitUniqSupply us
  67         in
  68         case to_do of
  69           D_stg_stats ->
  70              trace (showStgStats binds)
  71              end_pass us2 "StgStats" ccs binds
  72
  73           StgDoMassageForProfiling ->
  74              {-# SCC "ProfMassage" #-}
  75              let
  76                  (collected_CCs, binds3)
  77                    = stgMassageForProfiling this_pkg module_name us1 binds
  78                  this_pkg = thisPackage dflags
  79              in
  80              end_pass us2 "ProfMassage" collected_CCs binds3
  81
  82     end_pass us2 what ccs binds2
  83       = do -- report verbosely, if required
  84            dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what
  85               (vcat (map ppr binds2))
  86            let linted_binds = stg_linter what binds2
  87            return (linted_binds, us2, ccs)
  88             -- return: processed binds
  89             --         UniqueSupply for the next guy to use
  90             --         cost-centres to be declared/registered (specialised)
  91             --         add to description of what's happened (reverse order)
  92
  93 -- here so it can be inlined...
  94 foldl_mn :: (b -> a -> IO b) -> b -> [a] -> IO b
  95 foldl_mn _ z []     = return z
  96 foldl_mn f z (x:xs) = f z x     >>= \ zz ->
  97                      foldl_mn f zz xs
  98 \end{code}