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
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
|
{-
(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
\section[SimplStg]{Driver for simplifying @STG@ programs}
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module GHC.Stg.Pipeline ( stg2stg ) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Stg.Syntax
import GHC.Stg.Lint ( lintStgTopBindings )
import GHC.Stg.Stats ( showStgStats )
import GHC.Stg.DepAnal ( depSortStgPgm )
import GHC.Stg.Unarise ( unarise )
import GHC.Stg.CSE ( stgCse )
import GHC.Stg.Lift ( stgLiftLams )
import GHC.Unit.Module ( Module )
import GHC.Runtime.Context ( InteractiveContext )
import GHC.Driver.Session
import GHC.Utils.Error
import GHC.Types.Unique.Supply
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Logger
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.State.Strict
newtype StgM a = StgM { _unStgM :: StateT Char IO a }
deriving (Functor, Applicative, Monad, MonadIO)
instance MonadUnique StgM where
getUniqueSupplyM = StgM $ do { mask <- get
; liftIO $! mkSplitUniqSupply mask}
getUniqueM = StgM $ do { mask <- get
; liftIO $! uniqFromMask mask}
runStgM :: Char -> StgM a -> IO a
runStgM mask (StgM m) = evalStateT m mask
stg2stg :: Logger
-> DynFlags -- includes spec of what stg-to-stg passes to do
-> InteractiveContext
-> Module -- module being compiled
-> [StgTopBinding] -- input program
-> IO [StgTopBinding] -- output program
stg2stg logger dflags ictxt this_mod binds
= do { dump_when Opt_D_dump_stg_from_core "Initial STG:" binds
; showPass logger dflags "Stg2Stg"
-- Do the main business!
; binds' <- runStgM 'g' $
foldM do_stg_pass binds (getStgToDo dflags)
-- Dependency sort the program as last thing. The program needs to be
-- in dependency order for the SRT algorithm to work (see
-- CmmBuildInfoTables, which also includes a detailed description of
-- the algorithm), and we don't guarantee that the program is already
-- sorted at this point. #16192 is for simplifier not preserving
-- dependency order. We also don't guarantee that StgLiftLams will
-- preserve the order or only create minimal recursive groups, so a
-- sorting pass is necessary.
; let binds_sorted = depSortStgPgm this_mod binds'
; return binds_sorted
}
where
stg_linter unarised
| gopt Opt_DoStgLinting dflags
= lintStgTopBindings logger dflags ictxt this_mod unarised
| 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
us <- getUniqueSupplyM
liftIO (stg_linter False "Pre-unarise" binds)
let binds' = unarise us binds
liftIO (dump_when Opt_D_dump_stg_unarised "Unarised STG:" binds')
liftIO (stg_linter True "Unarise" binds')
return binds'
opts = initStgPprOpts dflags
dump_when flag header binds
= dumpIfSet_dyn logger dflags flag header FormatSTG (pprStgTopBindings opts binds)
end_pass what binds2
= liftIO $ do -- report verbosely, if required
dumpIfSet_dyn logger dflags Opt_D_verbose_stg2stg what
FormatSTG (vcat (map (pprStgTopBinding opts) 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 GHC.Stg.CSE
, 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
|
