Remove StgRubbishArg and CmmArg
[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 BasicTypes
47 import BlockId
48 import DynFlags
49 import FastString
50 import Module
51 import UniqFM
52 import Unique
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 HasDynFlags CmmParse where
94 getDynFlags = EC (\_ _ d -> do dflags <- getDynFlags
95 return (d, dflags))
96
97
98 -- | Takes the variable decarations and imports from the monad
99 -- and makes an environment, which is looped back into the computation.
100 -- In this way, we can have embedded declarations that scope over the whole
101 -- procedure, and imports that scope over the entire module.
102 -- Discards the local declaration contained within decl'
103 --
104 loopDecls :: CmmParse a -> CmmParse a
105 loopDecls (EC fcode) =
106 EC $ \c e globalDecls -> do
107 (_, a) <- F.fixC $ \ ~(decls, _) ->
108 fcode c (addListToUFM e decls) globalDecls
109 return (globalDecls, a)
110
111
112 -- | Get the current environment from the monad.
113 getEnv :: CmmParse Env
114 getEnv = EC $ \_ e s -> return (s, e)
115
116 -- | Get the current context name from the monad
117 getName :: CmmParse String
118 getName = EC $ \c _ s -> return (s, c)
119
120 -- | Set context name for a sub-parse
121 withName :: String -> CmmParse a -> CmmParse a
122 withName c' (EC fcode) = EC $ \_ e s -> fcode c' e s
123
124 addDecl :: FastString -> Named -> ExtCode
125 addDecl name named = EC $ \_ _ s -> return ((name, named) : s, ())
126
127
128 -- | Add a new variable to the list of local declarations.
129 -- The CmmExpr says where the value is stored.
130 addVarDecl :: FastString -> CmmExpr -> ExtCode
131 addVarDecl var expr = addDecl var (VarN expr)
132
133 -- | Add a new label to the list of local declarations.
134 addLabel :: FastString -> BlockId -> ExtCode
135 addLabel name block_id = addDecl name (LabelN block_id)
136
137
138 -- | Create a fresh local variable of a given type.
139 newLocal
140 :: CmmType -- ^ data type
141 -> FastString -- ^ name of variable
142 -> CmmParse LocalReg -- ^ register holding the value
143
144 newLocal ty name = do
145 u <- code newUnique
146 let reg = LocalReg u ty
147 addVarDecl name (CmmReg (CmmLocal reg))
148 return reg
149
150
151 -- | Allocate a fresh label.
152 newLabel :: FastString -> CmmParse BlockId
153 newLabel name = do
154 u <- code newUnique
155 addLabel name (mkBlockId u)
156 return (mkBlockId u)
157
158 newBlockId :: CmmParse BlockId
159 newBlockId = code F.newLabelC
160
161 -- | Add add a local function to the environment.
162 newFunctionName
163 :: FastString -- ^ name of the function
164 -> UnitId -- ^ package of the current module
165 -> ExtCode
166
167 newFunctionName name pkg = addDecl name (FunN pkg)
168
169
170 -- | Add an imported foreign label to the list of local declarations.
171 -- If this is done at the start of the module the declaration will scope
172 -- over the whole module.
173 newImport
174 :: (FastString, CLabel)
175 -> CmmParse ()
176
177 newImport (name, cmmLabel)
178 = addVarDecl name (CmmLit (CmmLabel cmmLabel))
179
180
181 -- | Lookup the BlockId bound to the label with this name.
182 -- If one hasn't been bound yet, create a fresh one based on the
183 -- Unique of the name.
184 lookupLabel :: FastString -> CmmParse BlockId
185 lookupLabel name = do
186 env <- getEnv
187 return $
188 case lookupUFM env name of
189 Just (LabelN l) -> l
190 _other -> mkBlockId (newTagUnique (getUnique name) 'L')
191
192
193 -- | Lookup the location of a named variable.
194 -- Unknown names are treated as if they had been 'import'ed from the runtime system.
195 -- This saves us a lot of bother in the RTS sources, at the expense of
196 -- deferring some errors to link time.
197 lookupName :: FastString -> CmmParse CmmExpr
198 lookupName name = do
199 env <- getEnv
200 return $
201 case lookupUFM env name of
202 Just (VarN e) -> e
203 Just (FunN pkg) -> CmmLit (CmmLabel (mkCmmCodeLabel pkg name))
204 _other -> CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId name))
205
206
207 -- | Lift an FCode computation into the CmmParse monad
208 code :: FCode a -> CmmParse a
209 code fc = EC $ \_ _ s -> do
210 r <- fc
211 return (s, r)
212
213 emit :: CmmAGraph -> CmmParse ()
214 emit = code . F.emit
215
216 emitLabel :: BlockId -> CmmParse ()
217 emitLabel = code . F.emitLabel
218
219 emitAssign :: CmmReg -> CmmExpr -> CmmParse ()
220 emitAssign l r = code (F.emitAssign l r)
221
222 emitStore :: CmmExpr -> CmmExpr -> CmmParse ()
223 emitStore l r = code (F.emitStore l r)
224
225 getCode :: CmmParse a -> CmmParse CmmAGraph
226 getCode (EC ec) = EC $ \c e s -> do
227 ((s',_), gr) <- F.getCodeR (ec c e s)
228 return (s', gr)
229
230 getCodeR :: CmmParse a -> CmmParse (a, CmmAGraph)
231 getCodeR (EC ec) = EC $ \c e s -> do
232 ((s', r), gr) <- F.getCodeR (ec c e s)
233 return (s', (r,gr))
234
235 getCodeScoped :: CmmParse a -> CmmParse (a, CmmAGraphScoped)
236 getCodeScoped (EC ec) = EC $ \c e s -> do
237 ((s', r), gr) <- F.getCodeScoped (ec c e s)
238 return (s', (r,gr))
239
240 emitOutOfLine :: BlockId -> CmmAGraphScoped -> CmmParse ()
241 emitOutOfLine l g = code (F.emitOutOfLine l g)
242
243 withUpdFrameOff :: UpdFrameOffset -> CmmParse () -> CmmParse ()
244 withUpdFrameOff size inner
245 = EC $ \c e s -> F.withUpdFrameOff size $ (unEC inner) c e s
246
247 getUpdFrameOff :: CmmParse UpdFrameOffset
248 getUpdFrameOff = code $ F.getUpdFrameOff