635df3ce41c4300913aca4d0ae8fed0ac58a2403
[ghc.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 {-# OPTIONS -fno-warn-tabs #-}
8 -- The above warning supression flag is a temporary kludge.
9 -- While working on this module you are encouraged to remove it and
10 -- detab the module (please do the detabbing in a separate patch). See
11 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
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 UnariseStg       ( unarise )
25 import SRT              ( computeSRTs )
26
27 import DynFlags         ( DynFlags(..), DynFlag(..), dopt, StgToDo(..),
28                           getStgToDo )
29 import Id               ( Id )
30 import Module           ( Module )
31 import ErrUtils
32 import SrcLoc
33 import UniqSupply       ( mkSplitUniqSupply, splitUniqSupply )
34 import Outputable
35 \end{code}
36
37 \begin{code}
38 stg2stg :: DynFlags                  -- includes spec of what stg-to-stg passes to do
39         -> Module                    -- module name (profiling only)
40         -> [StgBinding]              -- input...
41         -> IO ( [(StgBinding,[(Id,[Id])])]  -- output program...
42               , CollectedCCs)        -- cost centre information (declared and used)
43
44 stg2stg dflags module_name binds
45   = do  { showPass dflags "Stg2Stg"
46         ; us <- mkSplitUniqSupply 'g'
47
48         ; doIfSet_dyn dflags Opt_D_verbose_stg2stg 
49                       (log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (text "VERBOSE STG-TO-STG:"))
50
51         ; (binds', us', ccs) <- end_pass us "Stg2Stg" ([],[],[]) binds
52
53                 -- Do the main business!
54         ; let (us0, us1) = splitUniqSupply us'
55         ; (processed_binds, _, cost_centres) 
56                 <- foldl_mn do_stg_pass (binds', us0, ccs) (getStgToDo dflags)
57
58         ; let un_binds = unarise us1 processed_binds
59         ; let srt_binds
60                | dopt Opt_TryNewCodeGen dflags = zip un_binds (repeat [])
61                | otherwise = computeSRTs un_binds
62
63         ; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:" 
64                         (pprStgBindingsWithSRTs srt_binds)
65
66         ; return (srt_binds, cost_centres)
67    }
68
69   where
70     stg_linter = if dopt Opt_DoStgLinting dflags
71                  then lintStgBindings
72                  else ( \ _whodunnit binds -> binds )
73
74     -------------------------------------------
75     do_stg_pass (binds, us, ccs) to_do
76       = let
77             (us1, us2) = splitUniqSupply us
78         in
79         case to_do of
80           D_stg_stats ->
81              trace (showStgStats binds)
82              end_pass us2 "StgStats" ccs binds
83
84           StgDoMassageForProfiling ->
85              {-# SCC "ProfMassage" #-}
86              let
87                  (collected_CCs, binds3)
88                    = stgMassageForProfiling dflags module_name us1 binds
89              in
90              end_pass us2 "ProfMassage" collected_CCs binds3
91
92     end_pass us2 what ccs binds2
93       = do -- report verbosely, if required
94            dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what
95               (vcat (map ppr binds2))
96            let linted_binds = stg_linter what binds2
97            return (linted_binds, us2, ccs)
98             -- return: processed binds
99             --         UniqueSupply for the next guy to use
100             --         cost-centres to be declared/registered (specialised)
101             --         add to description of what's happened (reverse order)
102
103 -- here so it can be inlined...
104 foldl_mn :: (b -> a -> IO b) -> b -> [a] -> IO b
105 foldl_mn _ z []     = return z
106 foldl_mn f z (x:xs) = f z x     >>= \ zz ->
107                      foldl_mn f zz xs
108 \end{code}