5f412b3cf8796c7a84887fcbbc292323729a9b8a
[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 newLocal,
20 newLabel,
21 newBlockId,
22 newFunctionName,
23 newImport,
24 lookupLabel,
25 lookupName,
26
27 code,
28 emit, emitLabel, emitAssign, emitStore,
29 getCode, getCodeR,
30 emitOutOfLine,
31 withUpdFrameOff, getUpdFrameOff
32 )
33
34 where
35
36 import qualified StgCmmMonad as F
37 import StgCmmMonad (FCode, newUnique)
38
39 import Cmm
40 import CLabel
41 import MkGraph
42
43 -- import BasicTypes
44 import BlockId
45 import DynFlags
46 import FastString
47 import Module
48 import UniqFM
49 import Unique
50
51 import Control.Monad (liftM, ap)
52 import Control.Applicative (Applicative(..))
53
54
55 -- | The environment contains variable definitions or blockids.
56 data Named
57 = VarN CmmExpr -- ^ Holds CmmLit(CmmLabel ..) which gives the label type,
58 -- eg, RtsLabel, ForeignLabel, CmmLabel etc.
59
60 | FunN PackageKey -- ^ A function name from this package
61 | LabelN BlockId -- ^ A blockid of some code or data.
62
63 -- | An environment of named things.
64 type Env = UniqFM Named
65
66 -- | Local declarations that are in scope during code generation.
67 type Decls = [(FastString,Named)]
68
69 -- | Does a computation in the FCode monad, with a current environment
70 -- and a list of local declarations. Returns the resulting list of declarations.
71 newtype CmmParse a
72 = EC { unEC :: Env -> Decls -> FCode (Decls, a) }
73
74 type ExtCode = CmmParse ()
75
76 returnExtFC :: a -> CmmParse a
77 returnExtFC a = EC $ \_ s -> return (s, a)
78
79 thenExtFC :: CmmParse a -> (a -> CmmParse b) -> CmmParse b
80 thenExtFC (EC m) k = EC $ \e s -> do (s',r) <- m e s; unEC (k r) e s'
81
82 instance Functor CmmParse where
83 fmap = liftM
84
85 instance Applicative CmmParse where
86 pure = return
87 (<*>) = ap
88
89 instance Monad CmmParse where
90 (>>=) = thenExtFC
91 return = returnExtFC
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 $ \e globalDecls -> do
107 (_, a) <- F.fixC (\ ~(decls, _) -> fcode (addListToUFM e decls) globalDecls)
108 return (globalDecls, a)
109
110
111 -- | Get the current environment from the monad.
112 getEnv :: CmmParse Env
113 getEnv = EC $ \e s -> return (s, e)
114
115
116 addDecl :: FastString -> Named -> ExtCode
117 addDecl name named = EC $ \_ s -> return ((name, named) : s, ())
118
119
120 -- | Add a new variable to the list of local declarations.
121 -- The CmmExpr says where the value is stored.
122 addVarDecl :: FastString -> CmmExpr -> ExtCode
123 addVarDecl var expr = addDecl var (VarN expr)
124
125 -- | Add a new label to the list of local declarations.
126 addLabel :: FastString -> BlockId -> ExtCode
127 addLabel name block_id = addDecl name (LabelN block_id)
128
129
130 -- | Create a fresh local variable of a given type.
131 newLocal
132 :: CmmType -- ^ data type
133 -> FastString -- ^ name of variable
134 -> CmmParse LocalReg -- ^ register holding the value
135
136 newLocal ty name = do
137 u <- code newUnique
138 let reg = LocalReg u ty
139 addVarDecl name (CmmReg (CmmLocal reg))
140 return reg
141
142
143 -- | Allocate a fresh label.
144 newLabel :: FastString -> CmmParse BlockId
145 newLabel name = do
146 u <- code newUnique
147 addLabel name (mkBlockId u)
148 return (mkBlockId u)
149
150 newBlockId :: CmmParse BlockId
151 newBlockId = code F.newLabelC
152
153 -- | Add add a local function to the environment.
154 newFunctionName
155 :: FastString -- ^ name of the function
156 -> PackageKey -- ^ package of the current module
157 -> ExtCode
158
159 newFunctionName name pkg = addDecl name (FunN pkg)
160
161
162 -- | Add an imported foreign label to the list of local declarations.
163 -- If this is done at the start of the module the declaration will scope
164 -- over the whole module.
165 newImport
166 :: (FastString, CLabel)
167 -> CmmParse ()
168
169 newImport (name, cmmLabel)
170 = addVarDecl name (CmmLit (CmmLabel cmmLabel))
171
172
173 -- | Lookup the BlockId bound to the label with this name.
174 -- If one hasn't been bound yet, create a fresh one based on the
175 -- Unique of the name.
176 lookupLabel :: FastString -> CmmParse BlockId
177 lookupLabel name = do
178 env <- getEnv
179 return $
180 case lookupUFM env name of
181 Just (LabelN l) -> l
182 _other -> mkBlockId (newTagUnique (getUnique name) 'L')
183
184
185 -- | Lookup the location of a named variable.
186 -- Unknown names are treated as if they had been 'import'ed from the runtime system.
187 -- This saves us a lot of bother in the RTS sources, at the expense of
188 -- deferring some errors to link time.
189 lookupName :: FastString -> CmmParse CmmExpr
190 lookupName name = do
191 env <- getEnv
192 return $
193 case lookupUFM env name of
194 Just (VarN e) -> e
195 Just (FunN pkg) -> CmmLit (CmmLabel (mkCmmCodeLabel pkg name))
196 _other -> CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageKey name))
197
198
199 -- | Lift an FCode computation into the CmmParse monad
200 code :: FCode a -> CmmParse a
201 code fc = EC $ \_ s -> do
202 r <- fc
203 return (s, r)
204
205 emit :: CmmAGraph -> CmmParse ()
206 emit = code . F.emit
207
208 emitLabel :: BlockId -> CmmParse ()
209 emitLabel = code. F.emitLabel
210
211 emitAssign :: CmmReg -> CmmExpr -> CmmParse ()
212 emitAssign l r = code (F.emitAssign l r)
213
214 emitStore :: CmmExpr -> CmmExpr -> CmmParse ()
215 emitStore l r = code (F.emitStore l r)
216
217 getCode :: CmmParse a -> CmmParse CmmAGraph
218 getCode (EC ec) = EC $ \e s -> do
219 ((s',_), gr) <- F.getCodeR (ec e s)
220 return (s', gr)
221
222 getCodeR :: CmmParse a -> CmmParse (a, CmmAGraph)
223 getCodeR (EC ec) = EC $ \e s -> do
224 ((s', r), gr) <- F.getCodeR (ec e s)
225 return (s', (r,gr))
226
227 emitOutOfLine :: BlockId -> CmmAGraph -> CmmParse ()
228 emitOutOfLine l g = code (F.emitOutOfLine l g)
229
230 withUpdFrameOff :: UpdFrameOffset -> CmmParse () -> CmmParse ()
231 withUpdFrameOff size inner
232 = EC $ \e s -> F.withUpdFrameOff size $ (unEC inner) e s
233
234 getUpdFrameOff :: CmmParse UpdFrameOffset
235 getUpdFrameOff = code $ F.getUpdFrameOff