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