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