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