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 {-# OPTIONS -w #-}
   8 -- The above warning supression flag is a temporary kludge.
   9 -- While working on this module you are encouraged to remove it and fix
  10 -- any warnings in the module. See
  11 --     http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
  12 -- for details
  13
  14 module SimplStg ( stg2stg ) where
  15
  16 #include "HsVersions.h"
  17
  18 import StgSyn
  19
  20 import CostCentre       ( CollectedCCs )
  21 import SCCfinal         ( stgMassageForProfiling )
  22 import StgLint          ( lintStgBindings )
  23 import StgStats         ( showStgStats )
  24 import SRT              ( computeSRTs )
  25
  26 import DynFlags         ( DynFlags(..), DynFlag(..), dopt, StgToDo(..),
  27                           getStgToDo )
  28 import Id               ( Id )
  29 import Module           ( Module )
  30 import ErrUtils         ( doIfSet_dyn, dumpIfSet_dyn, showPass )
  31 import UniqSupply       ( mkSplitUniqSupply, splitUniqSupply )
  32 import Outputable
  33 \end{code}
  34
  35 \begin{code}
  36 stg2stg :: DynFlags                  -- includes spec of what stg-to-stg passes to do
  37         -> Module                    -- module name (profiling only)
  38         -> [StgBinding]              -- input...
  39         -> IO ( [(StgBinding,[(Id,[Id])])]  -- output program...
  40               , CollectedCCs)        -- cost centre information (declared and used)
  41
  42 stg2stg dflags module_name binds
  43   = do  { showPass dflags "Stg2Stg"
  44         ; us <- mkSplitUniqSupply 'g'
  45
  46         ; doIfSet_dyn dflags Opt_D_verbose_stg2stg
  47                       (printDump (text "VERBOSE STG-TO-STG:"))
  48
  49         ; (binds', us', ccs) <- end_pass us "Stg2Stg" ([],[],[]) binds
  50
  51                 -- Do the main business!
  52         ; (processed_binds, _, cost_centres)
  53                 <- foldl_mn do_stg_pass (binds', us', ccs) (getStgToDo 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 this_pkg module_name us1 binds
  83                  this_pkg = thisPackage dflags
  84              in
  85              end_pass us2 "ProfMassage" collected_CCs binds3
  86
  87     end_pass us2 what ccs binds2
  88       = do -- report verbosely, if required
  89            dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what
  90               (vcat (map ppr binds2))
  91            let linted_binds = stg_linter what binds2
  92            return (linted_binds, us2, ccs)
  93             -- return: processed binds
  94             --         UniqueSupply for the next guy to use
  95             --         cost-centres to be declared/registered (specialised)
  96             --         add to description of what's happened (reverse order)
  97
  98 -- here so it can be inlined...
  99 foldl_mn f z []     = return z
 100 foldl_mn f z (x:xs) = f z x     >>= \ zz ->
 101                      foldl_mn f zz xs
 102 \end{code}