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