put coqPassCoreToCore on the CoreM monad, greatly simplify Desugar.lhs
[ghc-hetmet.git] / 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 this_pkg module_name us1 binds
76                  this_pkg = thisPackage dflags
77              in
78              end_pass us2 "ProfMassage" collected_CCs binds3
79
80     end_pass us2 what ccs binds2
81       = do -- report verbosely, if required
82            dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what
83               (vcat (map ppr binds2))
84            let linted_binds = stg_linter what binds2
85            return (linted_binds, us2, ccs)
86             -- return: processed binds
87             --         UniqueSupply for the next guy to use
88             --         cost-centres to be declared/registered (specialised)
89             --         add to description of what's happened (reverse order)
90
91 -- here so it can be inlined...
92 foldl_mn :: (b -> a -> IO b) -> b -> [a] -> IO b
93 foldl_mn _ z []     = return z
94 foldl_mn f z (x:xs) = f z x     >>= \ zz ->
95                      foldl_mn f zz xs
96 \end{code}