a651319a49f3575d3ab6a446bc2d02698c8803b3
[ghc.git] / compiler / codeGen / CgExtCode.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 {-# OPTIONS -fno-warn-tabs #-}
13 -- The above warning supression flag is a temporary kludge.
14 -- While working on this module you are encouraged to remove it and
15 -- detab the module (please do the detabbing in a separate patch). See
16 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
17 -- for details
18
19 module CgExtCode (
20 ExtFCode(..),
21 ExtCode,
22 Named(..), Env,
23
24 loopDecls,
25 getEnv,
26
27 newLocal,
28 newLabel,
29 newFunctionName,
30 newImport,
31 lookupLabel,
32 lookupName,
33
34 code,
35 code2,
36 nopEC,
37 stmtEC,
38 stmtsEC,
39 getCgStmtsEC,
40 getCgStmtsEC',
41 forkLabelledCodeEC
42 )
43
44 where
45
46 import CgMonad
47
48 import CLabel
49 import OldCmm hiding( ClosureTypeInfo(..) )
50
51 -- import BasicTypes
52 import BlockId
53 import DynFlags
54 import FastString
55 import Module
56 import UniqFM
57 import Unique
58
59
60 -- | The environment contains variable definitions or blockids.
61 data Named
62 = VarN CmmExpr -- ^ Holds CmmLit(CmmLabel ..) which gives the label type,
63 -- eg, RtsLabel, ForeignLabel, CmmLabel etc.
64
65 | FunN PackageId -- ^ A function name from this package
66 | LabelN BlockId -- ^ A blockid of some code or data.
67
68 -- | An environment of named things.
69 type Env = UniqFM Named
70
71 -- | Local declarations that are in scope during code generation.
72 type Decls = [(FastString,Named)]
73
74 -- | Does a computation in the FCode monad, with a current environment
75 -- and a list of local declarations. Returns the resulting list of declarations.
76 newtype ExtFCode a
77 = EC { unEC :: Env -> Decls -> FCode (Decls, a) }
78
79 type ExtCode = ExtFCode ()
80
81 returnExtFC :: a -> ExtFCode a
82 returnExtFC a = EC $ \_ s -> return (s, a)
83
84 thenExtFC :: ExtFCode a -> (a -> ExtFCode b) -> ExtFCode b
85 thenExtFC (EC m) k = EC $ \e s -> do (s',r) <- m e s; unEC (k r) e s'
86
87 instance Monad ExtFCode where
88 (>>=) = thenExtFC
89 return = returnExtFC
90
91 instance HasDynFlags ExtFCode where
92 getDynFlags = EC (\_ d -> do dflags <- getDynFlags
93 return (d, dflags))
94
95
96 -- | Takes the variable decarations and imports from the monad
97 -- and makes an environment, which is looped back into the computation.
98 -- In this way, we can have embedded declarations that scope over the whole
99 -- procedure, and imports that scope over the entire module.
100 -- Discards the local declaration contained within decl'
101 --
102 loopDecls :: ExtFCode a -> ExtFCode a
103 loopDecls (EC fcode) =
104 EC $ \e globalDecls -> do
105 (_, a) <- fixC (\ ~(decls, _) -> fcode (addListToUFM e (decls ++ globalDecls)) globalDecls)
106 return (globalDecls, a)
107
108
109 -- | Get the current environment from the monad.
110 getEnv :: ExtFCode Env
111 getEnv = EC $ \e s -> return (s, e)
112
113
114 -- | Add a new variable to the list of local declarations.
115 -- The CmmExpr says where the value is stored.
116 addVarDecl :: FastString -> CmmExpr -> ExtCode
117 addVarDecl var expr
118 = EC $ \_ s -> return ((var, VarN expr):s, ())
119
120 -- | Add a new label to the list of local declarations.
121 addLabel :: FastString -> BlockId -> ExtCode
122 addLabel name block_id
123 = EC $ \_ s -> return ((name, LabelN block_id):s, ())
124
125
126 -- | Create a fresh local variable of a given type.
127 newLocal
128 :: CmmType -- ^ data type
129 -> FastString -- ^ name of variable
130 -> ExtFCode LocalReg -- ^ register holding the value
131
132 newLocal ty name = do
133 u <- code newUnique
134 let reg = LocalReg u ty
135 addVarDecl name (CmmReg (CmmLocal reg))
136 return reg
137
138
139 -- | Allocate a fresh label.
140 newLabel :: FastString -> ExtFCode BlockId
141 newLabel name = do
142 u <- code newUnique
143 addLabel name (mkBlockId u)
144 return (mkBlockId u)
145
146
147 -- | Add add a local function to the environment.
148 newFunctionName
149 :: FastString -- ^ name of the function
150 -> PackageId -- ^ package of the current module
151 -> ExtCode
152
153 newFunctionName name pkg
154 = EC $ \_ s -> return ((name, FunN pkg):s, ())
155
156
157 -- | Add an imported foreign label to the list of local declarations.
158 -- If this is done at the start of the module the declaration will scope
159 -- over the whole module.
160 newImport
161 :: (FastString, CLabel)
162 -> ExtFCode ()
163
164 newImport (name, cmmLabel)
165 = addVarDecl name (CmmLit (CmmLabel cmmLabel))
166
167
168 -- | Lookup the BlockId bound to the label with this name.
169 -- If one hasn't been bound yet, create a fresh one based on the
170 -- Unique of the name.
171 lookupLabel :: FastString -> ExtFCode BlockId
172 lookupLabel name = do
173 env <- getEnv
174 return $
175 case lookupUFM env name of
176 Just (LabelN l) -> l
177 _other -> mkBlockId (newTagUnique (getUnique name) 'L')
178
179
180 -- | Lookup the location of a named variable.
181 -- Unknown names are treated as if they had been 'import'ed from the runtime system.
182 -- This saves us a lot of bother in the RTS sources, at the expense of
183 -- deferring some errors to link time.
184 lookupName :: FastString -> ExtFCode CmmExpr
185 lookupName name = do
186 env <- getEnv
187 return $
188 case lookupUFM env name of
189 Just (VarN e) -> e
190 Just (FunN pkg) -> CmmLit (CmmLabel (mkCmmCodeLabel pkg name))
191 _other -> CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId name))
192
193
194 -- | Lift an FCode computation into the ExtFCode monad
195 code :: FCode a -> ExtFCode a
196 code fc = EC $ \_ s -> do
197 r <- fc
198 return (s, r)
199
200
201 code2 :: (FCode (Decls,b) -> FCode ((Decls,b),c)) -> ExtFCode b -> ExtFCode c
202 code2 f (EC ec)
203 = EC $ \e s -> do
204 ((s', _),c) <- f (ec e s)
205 return (s',c)
206
207
208 -- | Do nothing in the ExtFCode monad.
209 nopEC :: ExtFCode ()
210 nopEC = code nopC
211
212
213 -- | Accumulate a CmmStmt into the monad state.
214 stmtEC :: CmmStmt -> ExtFCode ()
215 stmtEC stmt = code (stmtC stmt)
216
217
218 -- | Accumulate some CmmStmts into the monad state.
219 stmtsEC :: [CmmStmt] -> ExtFCode ()
220 stmtsEC stmts = code (stmtsC stmts)
221
222
223 -- | Get the generated statements out of the monad state.
224 getCgStmtsEC :: ExtFCode a -> ExtFCode CgStmts
225 getCgStmtsEC = code2 getCgStmts'
226
227
228 -- | Get the generated statements, and the return value out of the monad state.
229 getCgStmtsEC' :: ExtFCode a -> ExtFCode (a, CgStmts)
230 getCgStmtsEC' = code2 (\m -> getCgStmts' m >>= f)
231 where f ((decl, b), c) = return ((decl, b), (b, c))
232
233
234 -- | Emit a chunk of code outside the instruction stream,
235 -- and return its block id.
236 forkLabelledCodeEC :: ExtFCode a -> ExtFCode BlockId
237 forkLabelledCodeEC ec = do
238 stmts <- getCgStmtsEC ec
239 code (forkCgStmts stmts)
240
241