never executed always true always false
1 {-# LANGUAGE DeriveFunctor #-}
2 {-# LANGUAGE TupleSections #-}
3 -- | Our extended FCode monad.
4
5 -- We add a mapping from names to CmmExpr, to support local variable names in
6 -- the concrete C-- code. The unique supply of the underlying FCode monad
7 -- is used to grab a new unique for each local variable.
8
9 -- In C--, a local variable can be declared anywhere within a proc,
10 -- and it scopes from the beginning of the proc to the end. Hence, we have
11 -- to collect declarations as we parse the proc, and feed the environment
12 -- back in circularly (to avoid a two-pass algorithm).
13
14 module GHC.StgToCmm.ExtCode (
15 CmmParse, unEC,
16 Named(..), Env,
17
18 loopDecls,
19 getEnv,
20
21 withName,
22 getName,
23
24 newLocal,
25 newLabel,
26 newBlockId,
27 newFunctionName,
28 newImport,
29 lookupLabel,
30 lookupName,
31
32 code,
33 emit, emitLabel, emitAssign, emitStore,
34 getCode, getCodeR, getCodeScoped,
35 emitOutOfLine,
36 withUpdFrameOff, getUpdFrameOff,
37 getProfile, getPlatform, getPtrOpts
38 )
39
40 where
41
42 import GHC.Prelude
43
44 import GHC.Platform
45 import GHC.Platform.Profile
46
47 import qualified GHC.StgToCmm.Monad as F
48 import GHC.StgToCmm.Monad (FCode, newUnique)
49
50 import GHC.Cmm
51 import GHC.Cmm.CLabel
52 import GHC.Cmm.Graph
53 import GHC.Cmm.Info
54
55 import GHC.Cmm.BlockId
56 import GHC.Driver.Session
57 import GHC.Data.FastString
58 import GHC.Unit.Module
59 import GHC.Types.Unique.FM
60 import GHC.Types.Unique
61 import GHC.Types.Unique.Supply
62
63 import Control.Monad (ap)
64
65 -- | The environment contains variable definitions or blockids.
66 data Named
67 = VarN CmmExpr -- ^ Holds CmmLit(CmmLabel ..) which gives the label type,
68 -- eg, RtsLabel, ForeignLabel, CmmLabel etc.
69
70 | FunN UnitId -- ^ A function name from this unit
71 | LabelN BlockId -- ^ A blockid of some code or data.
72
73 -- | An environment of named things.
74 type Env = UniqFM FastString Named
75
76 -- | Local declarations that are in scope during code generation.
77 type Decls = [(FastString,Named)]
78
79 -- | Does a computation in the FCode monad, with a current environment
80 -- and a list of local declarations. Returns the resulting list of declarations.
81 newtype CmmParse a
82 = EC { unEC :: String -> Env -> Decls -> FCode (Decls, a) }
83 deriving (Functor)
84
85 type ExtCode = CmmParse ()
86
87 returnExtFC :: a -> CmmParse a
88 returnExtFC a = EC $ \_ _ s -> return (s, a)
89
90 thenExtFC :: CmmParse a -> (a -> CmmParse b) -> CmmParse b
91 thenExtFC (EC m) k = EC $ \c e s -> do (s',r) <- m c e s; unEC (k r) c e s'
92
93 instance Applicative CmmParse where
94 pure = returnExtFC
95 (<*>) = ap
96
97 instance Monad CmmParse where
98 (>>=) = thenExtFC
99
100 instance MonadUnique CmmParse where
101 getUniqueSupplyM = code getUniqueSupplyM
102 getUniqueM = EC $ \_ _ decls -> do
103 u <- getUniqueM
104 return (decls, u)
105
106 instance HasDynFlags CmmParse where
107 getDynFlags = EC (\_ _ d -> (d,) <$> getDynFlags)
108
109 getProfile :: CmmParse Profile
110 getProfile = EC (\_ _ d -> (d,) <$> F.getProfile)
111
112 getPlatform :: CmmParse Platform
113 getPlatform = EC (\_ _ d -> (d,) <$> F.getPlatform)
114
115 getPtrOpts :: CmmParse PtrOpts
116 getPtrOpts = EC (\_ _ d -> (d,) <$> F.getPtrOpts)
117
118 -- | Takes the variable declarations and imports from the monad
119 -- and makes an environment, which is looped back into the computation.
120 -- In this way, we can have embedded declarations that scope over the whole
121 -- procedure, and imports that scope over the entire module.
122 -- Discards the local declaration contained within decl'
123 --
124 loopDecls :: CmmParse a -> CmmParse a
125 loopDecls (EC fcode) =
126 EC $ \c e globalDecls -> do
127 (_, a) <- F.fixC $ \ ~(decls, _) ->
128 fcode c (addListToUFM e decls) globalDecls
129 return (globalDecls, a)
130
131
132 -- | Get the current environment from the monad.
133 getEnv :: CmmParse Env
134 getEnv = EC $ \_ e s -> return (s, e)
135
136 -- | Get the current context name from the monad
137 getName :: CmmParse String
138 getName = EC $ \c _ s -> return (s, c)
139
140 -- | Set context name for a sub-parse
141 withName :: String -> CmmParse a -> CmmParse a
142 withName c' (EC fcode) = EC $ \_ e s -> fcode c' e s
143
144 addDecl :: FastString -> Named -> ExtCode
145 addDecl name named = EC $ \_ _ s -> return ((name, named) : s, ())
146
147
148 -- | Add a new variable to the list of local declarations.
149 -- The CmmExpr says where the value is stored.
150 addVarDecl :: FastString -> CmmExpr -> ExtCode
151 addVarDecl var expr = addDecl var (VarN expr)
152
153 -- | Add a new label to the list of local declarations.
154 addLabel :: FastString -> BlockId -> ExtCode
155 addLabel name block_id = addDecl name (LabelN block_id)
156
157
158 -- | Create a fresh local variable of a given type.
159 newLocal
160 :: CmmType -- ^ data type
161 -> FastString -- ^ name of variable
162 -> CmmParse LocalReg -- ^ register holding the value
163
164 newLocal ty name = do
165 u <- code newUnique
166 let reg = LocalReg u ty
167 addVarDecl name (CmmReg (CmmLocal reg))
168 return reg
169
170
171 -- | Allocate a fresh label.
172 newLabel :: FastString -> CmmParse BlockId
173 newLabel name = do
174 u <- code newUnique
175 addLabel name (mkBlockId u)
176 return (mkBlockId u)
177
178 -- | Add a local function to the environment.
179 newFunctionName
180 :: FastString -- ^ name of the function
181 -> UnitId -- ^ package of the current module
182 -> ExtCode
183
184 newFunctionName name pkg = addDecl name (FunN pkg)
185
186
187 -- | Add an imported foreign label to the list of local declarations.
188 -- If this is done at the start of the module the declaration will scope
189 -- over the whole module.
190 newImport
191 :: (FastString, CLabel)
192 -> CmmParse ()
193
194 newImport (name, cmmLabel)
195 = addVarDecl name (CmmLit (CmmLabel cmmLabel))
196
197
198 -- | Lookup the BlockId bound to the label with this name.
199 -- If one hasn't been bound yet, create a fresh one based on the
200 -- Unique of the name.
201 lookupLabel :: FastString -> CmmParse BlockId
202 lookupLabel name = do
203 env <- getEnv
204 return $
205 case lookupUFM env name of
206 Just (LabelN l) -> l
207 _other -> mkBlockId (newTagUnique (getUnique name) 'L')
208
209
210 -- | Lookup the location of a named variable.
211 -- Unknown names are treated as if they had been 'import'ed from the runtime system.
212 -- This saves us a lot of bother in the RTS sources, at the expense of
213 -- deferring some errors to link time.
214 lookupName :: FastString -> CmmParse CmmExpr
215 lookupName name = do
216 env <- getEnv
217 return $
218 case lookupUFM env name of
219 Just (VarN e) -> e
220 Just (FunN uid) -> CmmLit (CmmLabel (mkCmmCodeLabel uid name))
221 _other -> CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId name))
222
223
224 -- | Lift an FCode computation into the CmmParse monad
225 code :: FCode a -> CmmParse a
226 code fc = EC $ \_ _ s -> do
227 r <- fc
228 return (s, r)
229
230 emit :: CmmAGraph -> CmmParse ()
231 emit = code . F.emit
232
233 emitLabel :: BlockId -> CmmParse ()
234 emitLabel = code . F.emitLabel
235
236 emitAssign :: CmmReg -> CmmExpr -> CmmParse ()
237 emitAssign l r = code (F.emitAssign l r)
238
239 emitStore :: CmmExpr -> CmmExpr -> CmmParse ()
240 emitStore l r = code (F.emitStore l r)
241
242 getCode :: CmmParse a -> CmmParse CmmAGraph
243 getCode (EC ec) = EC $ \c e s -> do
244 ((s',_), gr) <- F.getCodeR (ec c e s)
245 return (s', gr)
246
247 getCodeR :: CmmParse a -> CmmParse (a, CmmAGraph)
248 getCodeR (EC ec) = EC $ \c e s -> do
249 ((s', r), gr) <- F.getCodeR (ec c e s)
250 return (s', (r,gr))
251
252 getCodeScoped :: CmmParse a -> CmmParse (a, CmmAGraphScoped)
253 getCodeScoped (EC ec) = EC $ \c e s -> do
254 ((s', r), gr) <- F.getCodeScoped (ec c e s)
255 return (s', (r,gr))
256
257 emitOutOfLine :: BlockId -> CmmAGraphScoped -> CmmParse ()
258 emitOutOfLine l g = code (F.emitOutOfLine l g)
259
260 withUpdFrameOff :: UpdFrameOffset -> CmmParse () -> CmmParse ()
261 withUpdFrameOff size inner
262 = EC $ \c e s -> F.withUpdFrameOff size $ (unEC inner) c e s
263
264 getUpdFrameOff :: CmmParse UpdFrameOffset
265 getUpdFrameOff = code $ F.getUpdFrameOff