testsuite: Assert that testsuite ways are known
[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 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
9 {-# LANGUAGE FlexibleContexts #-}
10 {-# LANGUAGE TypeFamilies #-}
11
12 module SimplStg ( stg2stg ) where
13
14 #include "HsVersions.h"
15
16 import GhcPrelude
17
18 import StgSyn
19
20 import StgLint ( lintStgTopBindings )
21 import StgStats ( showStgStats )
22 import UnariseStg ( unarise )
23 import StgCse ( stgCse )
24 import StgLiftLams ( stgLiftLams )
25 import Module ( Module )
26
27 import DynFlags
28 import ErrUtils
29 import UniqSupply
30 import Outputable
31 import Control.Monad
32 import Control.Monad.IO.Class
33 import Control.Monad.Trans.State.Strict
34
35 newtype StgM a = StgM { _unStgM :: StateT UniqSupply IO a }
36 deriving (Functor, Applicative, Monad, MonadIO)
37
38 instance MonadUnique StgM where
39 getUniqueSupplyM = StgM (state splitUniqSupply)
40 getUniqueM = StgM (state takeUniqFromSupply)
41
42 runStgM :: UniqSupply -> StgM a -> IO a
43 runStgM us (StgM m) = evalStateT m us
44
45 stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do
46 -> Module -- module being compiled
47 -> [StgTopBinding] -- input program
48 -> IO [StgTopBinding] -- output program
49
50 stg2stg dflags this_mod binds
51 = do { showPass dflags "Stg2Stg"
52 ; us <- mkSplitUniqSupply 'g'
53
54 -- Do the main business!
55 ; binds' <- runStgM us $
56 foldM do_stg_pass binds (getStgToDo dflags)
57
58 ; dump_when Opt_D_dump_stg "STG syntax:" binds'
59
60 ; return binds'
61 }
62
63 where
64 stg_linter what
65 | gopt Opt_DoStgLinting dflags
66 = lintStgTopBindings dflags this_mod what
67 | otherwise
68 = \ _whodunnit _binds -> return ()
69
70 -------------------------------------------
71 do_stg_pass :: [StgTopBinding] -> StgToDo -> StgM [StgTopBinding]
72 do_stg_pass binds to_do
73 = case to_do of
74 StgDoNothing ->
75 return binds
76
77 StgStats ->
78 trace (showStgStats binds) (return binds)
79
80 StgCSE -> do
81 let binds' = {-# SCC "StgCse" #-} stgCse binds
82 end_pass "StgCse" binds'
83
84 StgLiftLams -> do
85 us <- getUniqueSupplyM
86 let binds' = {-# SCC "StgLiftLams" #-} stgLiftLams dflags us binds
87 end_pass "StgLiftLams" binds'
88
89 StgUnarise -> do
90 liftIO (dump_when Opt_D_dump_stg "Pre unarise:" binds)
91 us <- getUniqueSupplyM
92 liftIO (stg_linter False "Pre-unarise" binds)
93 let binds' = unarise us binds
94 liftIO (stg_linter True "Unarise" binds')
95 return binds'
96
97 dump_when flag header binds
98 = dumpIfSet_dyn dflags flag header (pprStgTopBindings binds)
99
100 end_pass what binds2
101 = liftIO $ do -- report verbosely, if required
102 dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what
103 (vcat (map ppr binds2))
104 stg_linter False what binds2
105 return binds2
106
107 -- -----------------------------------------------------------------------------
108 -- StgToDo: abstraction of stg-to-stg passes to run.
109
110 -- | Optional Stg-to-Stg passes.
111 data StgToDo
112 = StgCSE
113 -- ^ Common subexpression elimination
114 | StgLiftLams
115 -- ^ Lambda lifting closure variables, trading stack/register allocation for
116 -- heap allocation
117 | StgStats
118 | StgUnarise
119 -- ^ Mandatory unarise pass, desugaring unboxed tuple and sum binders
120 | StgDoNothing
121 -- ^ Useful for building up 'getStgToDo'
122 deriving Eq
123
124 -- | Which Stg-to-Stg passes to run. Depends on flags, ways etc.
125 getStgToDo :: DynFlags -> [StgToDo]
126 getStgToDo dflags =
127 filter (/= StgDoNothing)
128 [ mandatory StgUnarise
129 -- Important that unarisation comes first
130 -- See Note [StgCse after unarisation] in StgCse
131 , optional Opt_StgCSE StgCSE
132 , optional Opt_StgLiftLams StgLiftLams
133 , optional Opt_StgStats StgStats
134 ] where
135 optional opt = runWhen (gopt opt dflags)
136 mandatory = id
137
138 runWhen :: Bool -> StgToDo -> StgToDo
139 runWhen True todo = todo
140 runWhen _ _ = StgDoNothing