Support MO_{Add,Sub}IntC and MO_Add2 in the LLVM backend
[ghc.git] / compiler / codeGen / StgCmmExtCode.hs
1 {-# LANGUAGE CPP #-}
2
3 -- | Our extended FCode monad.
4
5 -- We add a mapping from names to CmmExpr, to support local variable names in
6 -- the concrete C-- code. The unique supply of the underlying FCode monad
7 -- is used to grab a new unique for each local variable.
8
9 -- In C--, a local variable can be declared anywhere within a proc,
10 -- and it scopes from the beginning of the proc to the end. Hence, we have
11 -- to collect declarations as we parse the proc, and feed the environment
12 -- back in circularly (to avoid a two-pass algorithm).
13
14 module StgCmmExtCode (
15 CmmParse, unEC,
16 Named(..), Env,
17
18 loopDecls,
19 getEnv,
20
21 withName,
22 getName,
23
24 newLocal,
25 newLabel,
26 newBlockId,
27 newFunctionName,
28 newImport,
29 lookupLabel,
30 lookupName,
31
32 code,
33 emit, emitLabel, emitAssign, emitStore,
34 getCode, getCodeR, getCodeScoped,
35 emitOutOfLine,
36 withUpdFrameOff, getUpdFrameOff
37 )
38
39 where
40
41 import qualified StgCmmMonad as F
42 import StgCmmMonad (FCode, newUnique)
43
44 import Cmm
45 import CLabel
46 import MkGraph
47
48 -- import BasicTypes
49 import BlockId
50 import DynFlags
51 import FastString
52 import Module
53 import UniqFM
54 import Unique
55
56 import Control.Monad (liftM, ap)
57 #if __GLASGOW_HASKELL__ < 709
58 import Control.Applicative (Applicative(..))
59 #endif
60
61 -- | The environment contains variable definitions or blockids.
62 data Named
63 = VarN CmmExpr -- ^ Holds CmmLit(CmmLabel ..) which gives the label type,
64 -- eg, RtsLabel, ForeignLabel, CmmLabel etc.
65
66 | FunN PackageKey -- ^ A function name from this package
67 | LabelN BlockId -- ^ A blockid of some code or data.
68
69 -- | An environment of named things.
70 type Env = UniqFM Named
71
72 -- | Local declarations that are in scope during code generation.
73 type Decls = [(FastString,Named)]
74
75 -- | Does a computation in the FCode monad, with a current environment
76 -- and a list of local declarations. Returns the resulting list of declarations.
77 newtype CmmParse a
78 = EC { unEC :: String -> Env -> Decls -> FCode (Decls, a) }
79
80 type ExtCode = CmmParse ()
81
82 returnExtFC :: a -> CmmParse a
83 returnExtFC a = EC $ \_ _ s -> return (s, a)
84
85 thenExtFC :: CmmParse a -> (a -> CmmParse b) -> CmmParse b
86 thenExtFC (EC m) k = EC $ \c e s -> do (s',r) <- m c e s; unEC (k r) c e s'
87
88 instance Functor CmmParse where
89 fmap = liftM
90
91 instance Applicative CmmParse where
92 pure = return
93 (<*>) = ap
94
95 instance Monad CmmParse where
96 (>>=) = thenExtFC
97 return = returnExtFC
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 newBlockId :: CmmParse BlockId
165 newBlockId = code F.newLabelC
166
167 -- | Add add a local function to the environment.
168 newFunctionName
169 :: FastString -- ^ name of the function
170 -> PackageKey -- ^ package of the current module
171 -> ExtCode
172
173 newFunctionName name pkg = addDecl name (FunN pkg)
174
175
176 -- | Add an imported foreign label to the list of local declarations.
177 -- If this is done at the start of the module the declaration will scope
178 -- over the whole module.
179 newImport
180 :: (FastString, CLabel)
181 -> CmmParse ()
182
183 newImport (name, cmmLabel)
184 = addVarDecl name (CmmLit (CmmLabel cmmLabel))
185
186
187 -- | Lookup the BlockId bound to the label with this name.
188 -- If one hasn't been bound yet, create a fresh one based on the
189 -- Unique of the name.
190 lookupLabel :: FastString -> CmmParse BlockId
191 lookupLabel name = do
192 env <- getEnv
193 return $
194 case lookupUFM env name of
195 Just (LabelN l) -> l
196 _other -> mkBlockId (newTagUnique (getUnique name) 'L')
197
198
199 -- | Lookup the location of a named variable.
200 -- Unknown names are treated as if they had been 'import'ed from the runtime system.
201 -- This saves us a lot of bother in the RTS sources, at the expense of
202 -- deferring some errors to link time.
203 lookupName :: FastString -> CmmParse CmmExpr
204 lookupName name = do
205 env <- getEnv
206 return $
207 case lookupUFM env name of
208 Just (VarN e) -> e
209 Just (FunN pkg) -> CmmLit (CmmLabel (mkCmmCodeLabel pkg name))
210 _other -> CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageKey name))
211
212
213 -- | Lift an FCode computation into the CmmParse monad
214 code :: FCode a -> CmmParse a
215 code fc = EC $ \_ _ s -> do
216 r <- fc
217 return (s, r)
218
219 emit :: CmmAGraph -> CmmParse ()
220 emit = code . F.emit
221
222 emitLabel :: BlockId -> CmmParse ()
223 emitLabel = code . F.emitLabel
224
225 emitAssign :: CmmReg -> CmmExpr -> CmmParse ()
226 emitAssign l r = code (F.emitAssign l r)
227
228 emitStore :: CmmExpr -> CmmExpr -> CmmParse ()
229 emitStore l r = code (F.emitStore l r)
230
231 getCode :: CmmParse a -> CmmParse CmmAGraph
232 getCode (EC ec) = EC $ \c e s -> do
233 ((s',_), gr) <- F.getCodeR (ec c e s)
234 return (s', gr)
235
236 getCodeR :: CmmParse a -> CmmParse (a, CmmAGraph)
237 getCodeR (EC ec) = EC $ \c e s -> do
238 ((s', r), gr) <- F.getCodeR (ec c e s)
239 return (s', (r,gr))
240
241 getCodeScoped :: CmmParse a -> CmmParse (a, CmmAGraphScoped)
242 getCodeScoped (EC ec) = EC $ \c e s -> do
243 ((s', r), gr) <- F.getCodeScoped (ec c e s)
244 return (s', (r,gr))
245
246 emitOutOfLine :: BlockId -> CmmAGraphScoped -> CmmParse ()
247 emitOutOfLine l g = code (F.emitOutOfLine l g)
248
249 withUpdFrameOff :: UpdFrameOffset -> CmmParse () -> CmmParse ()
250 withUpdFrameOff size inner
251 = EC $ \c e s -> F.withUpdFrameOff size $ (unEC inner) c e s
252
253 getUpdFrameOff :: CmmParse UpdFrameOffset
254 getUpdFrameOff = code $ F.getUpdFrameOff