830dd19aea9d23ee9d8d609df5c6faa6d70b6a8e
[ghc.git] / compiler / simplStg / SimplStg.hs
1 {-
2 (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
3
4 \section[SimplStg]{Driver for simplifying @STG@ programs}
5 -}
6
7 {-# LANGUAGE CPP #-}
8
9 module SimplStg ( stg2stg ) where
10
11 #include "HsVersions.h"
12
13 import GhcPrelude
14
15 import StgSyn
16
17 import StgLint ( lintStgTopBindings )
18 import StgStats ( showStgStats )
19 import UnariseStg ( unarise )
20 import StgCse ( stgCse )
21
22 import DynFlags
23 import ErrUtils
24 import UniqSupply ( mkSplitUniqSupply )
25 import Outputable
26 import Control.Monad
27
28 stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do
29 -> [StgTopBinding] -- input...
30 -> IO [StgTopBinding] -- output program
31
32 stg2stg dflags binds
33 = do { showPass dflags "Stg2Stg"
34 ; us <- mkSplitUniqSupply 'g'
35
36 -- Do the main business!
37 ; dumpIfSet_dyn dflags Opt_D_dump_stg "Pre unarise:"
38 (pprStgTopBindings binds)
39
40 ; stg_linter False "Pre-unarise" binds
41 ; let un_binds = unarise us binds
42 ; stg_linter True "Unarise" un_binds
43 -- Important that unarisation comes first
44 -- See Note [StgCse after unarisation] in StgCse
45
46 ; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:"
47 (pprStgTopBindings un_binds)
48
49 ; foldM do_stg_pass un_binds (getStgToDo dflags)
50 }
51
52 where
53 stg_linter unarised
54 | gopt Opt_DoStgLinting dflags = lintStgTopBindings dflags unarised
55 | otherwise = \ _whodunnit _binds -> return ()
56
57 -------------------------------------------
58 do_stg_pass binds to_do
59 = case to_do of
60 D_stg_stats ->
61 trace (showStgStats binds) (return binds)
62
63 StgCSE ->
64 {-# SCC "StgCse" #-}
65 let
66 binds' = stgCse binds
67 in
68 end_pass "StgCse" binds'
69
70 end_pass what binds2
71 = do -- report verbosely, if required
72 dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what
73 (pprStgTopBindings binds2)
74 stg_linter True what binds2
75 return binds2
76
77 -- -----------------------------------------------------------------------------
78 -- StgToDo: abstraction of stg-to-stg passes to run.
79
80 -- | Optional Stg-to-Stg passes.
81 data StgToDo
82 = StgCSE
83 | D_stg_stats
84
85 -- | Which optional Stg-to-Stg passes to run. Depends on flags, ways etc.
86 getStgToDo :: DynFlags -> [StgToDo]
87 getStgToDo dflags
88 = [ StgCSE | gopt Opt_StgCSE dflags] ++
89 [ D_stg_stats | stg_stats ]
90 where
91 stg_stats = gopt Opt_StgStats dflags