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