never executed always true always false
1 {-
2 (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
3
4 \section[SimplStg]{Driver for simplifying @STG@ programs}
5 -}
6
7
8 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
9 {-# LANGUAGE FlexibleContexts #-}
10 {-# LANGUAGE TypeFamilies #-}
11
12 module GHC.Stg.Pipeline ( stg2stg ) where
13
14 import GHC.Prelude
15
16 import GHC.Stg.Syntax
17
18 import GHC.Stg.Lint ( lintStgTopBindings )
19 import GHC.Stg.Stats ( showStgStats )
20 import GHC.Stg.DepAnal ( depSortStgPgm )
21 import GHC.Stg.Unarise ( unarise )
22 import GHC.Stg.BcPrep ( bcPrep )
23 import GHC.Stg.CSE ( stgCse )
24 import GHC.Stg.Lift ( stgLiftLams )
25 import GHC.Unit.Module ( Module )
26 import GHC.Runtime.Context ( InteractiveContext )
27
28 import GHC.Driver.Session
29 import GHC.Utils.Error
30 import GHC.Types.Unique.Supply
31 import GHC.Utils.Outputable
32 import GHC.Utils.Logger
33 import Control.Monad
34 import Control.Monad.IO.Class
35 import Control.Monad.Trans.Reader
36
37 newtype StgM a = StgM { _unStgM :: ReaderT Char IO a }
38 deriving (Functor, Applicative, Monad, MonadIO)
39
40 instance MonadUnique StgM where
41 getUniqueSupplyM = StgM $ do { mask <- ask
42 ; liftIO $! mkSplitUniqSupply mask}
43 getUniqueM = StgM $ do { mask <- ask
44 ; liftIO $! uniqFromMask mask}
45
46 runStgM :: Char -> StgM a -> IO a
47 runStgM mask (StgM m) = runReaderT m mask
48
49 stg2stg :: Logger
50 -> DynFlags -- includes spec of what stg-to-stg passes to do
51 -> InteractiveContext
52 -> Bool -- prepare for bytecode?
53 -> Module -- module being compiled
54 -> [StgTopBinding] -- input program
55 -> IO [StgTopBinding] -- output program
56 stg2stg logger dflags ictxt for_bytecode this_mod binds
57 = do { dump_when Opt_D_dump_stg_from_core "Initial STG:" binds
58 ; showPass logger "Stg2Stg"
59 -- Do the main business!
60 ; binds' <- runStgM 'g' $
61 foldM do_stg_pass binds (getStgToDo for_bytecode dflags)
62
63 -- Dependency sort the program as last thing. The program needs to be
64 -- in dependency order for the SRT algorithm to work (see
65 -- CmmBuildInfoTables, which also includes a detailed description of
66 -- the algorithm), and we don't guarantee that the program is already
67 -- sorted at this point. #16192 is for simplifier not preserving
68 -- dependency order. We also don't guarantee that StgLiftLams will
69 -- preserve the order or only create minimal recursive groups, so a
70 -- sorting pass is necessary.
71 ; let binds_sorted = depSortStgPgm this_mod binds'
72 ; return binds_sorted
73 }
74
75 where
76 stg_linter unarised
77 | gopt Opt_DoStgLinting dflags
78 = lintStgTopBindings logger dflags ictxt this_mod unarised
79 | otherwise
80 = \ _whodunnit _binds -> return ()
81
82 -------------------------------------------
83 do_stg_pass :: [StgTopBinding] -> StgToDo -> StgM [StgTopBinding]
84 do_stg_pass binds to_do
85 = case to_do of
86 StgDoNothing ->
87 return binds
88
89 StgStats ->
90 logTraceMsg logger "STG stats" (text (showStgStats binds)) (return binds)
91
92 StgCSE -> do
93 let binds' = {-# SCC "StgCse" #-} stgCse binds
94 end_pass "StgCse" binds'
95
96 StgLiftLams -> do
97 us <- getUniqueSupplyM
98 let binds' = {-# SCC "StgLiftLams" #-} stgLiftLams dflags us binds
99 end_pass "StgLiftLams" binds'
100
101 StgBcPrep -> do
102 us <- getUniqueSupplyM
103 let binds' = {-# SCC "StgBcPrep" #-} bcPrep us binds
104 end_pass "StgBcPrep" binds'
105
106 StgUnarise -> do
107 us <- getUniqueSupplyM
108 liftIO (stg_linter False "Pre-unarise" binds)
109 let binds' = unarise us binds
110 liftIO (dump_when Opt_D_dump_stg_unarised "Unarised STG:" binds')
111 liftIO (stg_linter True "Unarise" binds')
112 return binds'
113
114 opts = initStgPprOpts dflags
115 dump_when flag header binds
116 = putDumpFileMaybe logger flag header FormatSTG (pprStgTopBindings opts binds)
117
118 end_pass what binds2
119 = liftIO $ do -- report verbosely, if required
120 putDumpFileMaybe logger Opt_D_verbose_stg2stg what
121 FormatSTG (vcat (map (pprStgTopBinding opts) binds2))
122 stg_linter False what binds2
123 return binds2
124
125 -- -----------------------------------------------------------------------------
126 -- StgToDo: abstraction of stg-to-stg passes to run.
127
128 -- | Optional Stg-to-Stg passes.
129 data StgToDo
130 = StgCSE
131 -- ^ Common subexpression elimination
132 | StgLiftLams
133 -- ^ Lambda lifting closure variables, trading stack/register allocation for
134 -- heap allocation
135 | StgStats
136 | StgUnarise
137 -- ^ Mandatory unarise pass, desugaring unboxed tuple and sum binders
138 | StgBcPrep
139 -- ^ Mandatory when compiling to bytecode
140 | StgDoNothing
141 -- ^ Useful for building up 'getStgToDo'
142 deriving Eq
143
144 -- | Which Stg-to-Stg passes to run. Depends on flags, ways etc.
145 getStgToDo :: Bool -> DynFlags -> [StgToDo]
146 getStgToDo for_bytecode dflags =
147 filter (/= StgDoNothing)
148 [ mandatory StgUnarise
149 -- Important that unarisation comes first
150 -- See Note [StgCse after unarisation] in GHC.Stg.CSE
151 , optional Opt_StgCSE StgCSE
152 , optional Opt_StgLiftLams StgLiftLams
153 , runWhen for_bytecode StgBcPrep
154 , optional Opt_StgStats StgStats
155 ] where
156 optional opt = runWhen (gopt opt dflags)
157 mandatory = id
158
159 runWhen :: Bool -> StgToDo -> StgToDo
160 runWhen True todo = todo
161 runWhen _ _ = StgDoNothing