Implement unboxed sum primitive type
[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 StgSyn
14
15 import CostCentre ( CollectedCCs )
16 import SCCfinal ( stgMassageForProfiling )
17 import StgLint ( lintStgBindings )
18 import StgStats ( showStgStats )
19 import UnariseStg ( unarise )
20
21 import DynFlags
22 import Module ( Module )
23 import ErrUtils
24 import SrcLoc
25 import UniqSupply ( mkSplitUniqSupply, splitUniqSupply )
26 import Outputable
27 import Control.Monad
28
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] -- 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 ; when (dopt Opt_D_verbose_stg2stg dflags)
40 (log_action dflags dflags NoReason SevDump noSrcSpan defaultDumpStyle (text "VERBOSE STG-TO-STG:"))
41
42 ; (binds', us', ccs) <- end_pass us "Stg2Stg" ([],[],[]) binds
43
44 -- Do the main business!
45 ; let (us0, us1) = splitUniqSupply us'
46 ; (processed_binds, _, cost_centres)
47 <- foldM do_stg_pass (binds', us0, ccs) (getStgToDo dflags)
48
49 ; dumpIfSet_dyn dflags Opt_D_dump_stg "Pre unarise:"
50 (pprStgBindings processed_binds)
51
52 ; let un_binds = unarise us1 processed_binds
53
54 ; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:"
55 (pprStgBindings un_binds)
56
57 ; return (un_binds, cost_centres)
58 }
59
60 where
61 stg_linter = if gopt Opt_DoStgLinting dflags
62 then lintStgBindings
63 else ( \ _whodunnit binds -> binds )
64
65 -------------------------------------------
66 do_stg_pass (binds, us, ccs) to_do
67 = let
68 (us1, us2) = splitUniqSupply us
69 in
70 case to_do of
71 D_stg_stats ->
72 trace (showStgStats binds)
73 end_pass us2 "StgStats" ccs binds
74
75 StgDoMassageForProfiling ->
76 {-# SCC "ProfMassage" #-}
77 let
78 (collected_CCs, binds3)
79 = stgMassageForProfiling dflags module_name us1 binds
80 in
81 end_pass us2 "ProfMassage" collected_CCs binds3
82
83 end_pass us2 what ccs binds2
84 = do -- report verbosely, if required
85 dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what
86 (vcat (map ppr binds2))
87 let linted_binds = stg_linter what binds2
88 return (linted_binds, us2, ccs)
89 -- return: processed binds
90 -- UniqueSupply for the next guy to use
91 -- cost-centres to be declared/registered (specialised)
92 -- add to description of what's happened (reverse order)
93
94 -- -----------------------------------------------------------------------------
95 -- StgToDo: abstraction of stg-to-stg passes to run.
96
97 -- | Optional Stg-to-Stg passes.
98 data StgToDo
99 = StgDoMassageForProfiling -- should be (next to) last
100 | D_stg_stats
101
102 -- | Which optional Stg-to-Stg passes to run. Depends on flags, ways etc.
103 getStgToDo :: DynFlags -> [StgToDo]
104 getStgToDo dflags
105 = todo2
106 where
107 stg_stats = gopt Opt_StgStats dflags
108
109 todo1 = if stg_stats then [D_stg_stats] else []
110
111 todo2 | WayProf `elem` ways dflags
112 = StgDoMassageForProfiling : todo1
113 | otherwise
114 = todo1