Produce new-style Cmm from the Cmm parser
[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(..),
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
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 CmmParse a
69 = EC { unEC :: Env -> Decls -> FCode (Decls, a) }
70
71 type ExtCode = CmmParse ()
72
73 returnExtFC :: a -> CmmParse a
74 returnExtFC a = EC $ \_ s -> return (s, a)
75
76 thenExtFC :: CmmParse a -> (a -> CmmParse b) -> CmmParse b
77 thenExtFC (EC m) k = EC $ \e s -> do (s',r) <- m e s; unEC (k r) e s'
78
79 instance Monad CmmParse where
80 (>>=) = thenExtFC
81 return = returnExtFC
82
83 instance HasDynFlags CmmParse where
84 getDynFlags = EC (\_ d -> do dflags <- getDynFlags
85 return (d, dflags))
86
87
88 -- | Takes the variable decarations and imports from the monad
89 -- and makes an environment, which is looped back into the computation.
90 -- In this way, we can have embedded declarations that scope over the whole
91 -- procedure, and imports that scope over the entire module.
92 -- Discards the local declaration contained within decl'
93 --
94 loopDecls :: CmmParse a -> CmmParse a
95 loopDecls (EC fcode) =
96 EC $ \e globalDecls -> do
97 (_, a) <- F.fixC (\ ~(decls, _) -> fcode (addListToUFM e (decls ++ globalDecls)) globalDecls)
98 return (globalDecls, a)
99
100
101 -- | Get the current environment from the monad.
102 getEnv :: CmmParse Env
103 getEnv = EC $ \e s -> return (s, e)
104
105
106 -- | Add a new variable to the list of local declarations.
107 -- The CmmExpr says where the value is stored.
108 addVarDecl :: FastString -> CmmExpr -> ExtCode
109 addVarDecl var expr
110 = EC $ \_ s -> return ((var, VarN expr):s, ())
111
112 -- | Add a new label to the list of local declarations.
113 addLabel :: FastString -> BlockId -> ExtCode
114 addLabel name block_id
115 = EC $ \_ s -> return ((name, LabelN block_id):s, ())
116
117
118 -- | Create a fresh local variable of a given type.
119 newLocal
120 :: CmmType -- ^ data type
121 -> FastString -- ^ name of variable
122 -> CmmParse LocalReg -- ^ register holding the value
123
124 newLocal ty name = do
125 u <- code newUnique
126 let reg = LocalReg u ty
127 addVarDecl name (CmmReg (CmmLocal reg))
128 return reg
129
130
131 -- | Allocate a fresh label.
132 newLabel :: FastString -> CmmParse BlockId
133 newLabel name = do
134 u <- code newUnique
135 addLabel name (mkBlockId u)
136 return (mkBlockId u)
137
138 newBlockId :: CmmParse BlockId
139 newBlockId = code F.newLabelC
140
141 -- | Add add a local function to the environment.
142 newFunctionName
143 :: FastString -- ^ name of the function
144 -> PackageId -- ^ package of the current module
145 -> ExtCode
146
147 newFunctionName name pkg
148 = EC $ \_ s -> return ((name, FunN pkg):s, ())
149
150
151 -- | Add an imported foreign label to the list of local declarations.
152 -- If this is done at the start of the module the declaration will scope
153 -- over the whole module.
154 newImport
155 :: (FastString, CLabel)
156 -> CmmParse ()
157
158 newImport (name, cmmLabel)
159 = addVarDecl name (CmmLit (CmmLabel cmmLabel))
160
161
162 -- | Lookup the BlockId bound to the label with this name.
163 -- If one hasn't been bound yet, create a fresh one based on the
164 -- Unique of the name.
165 lookupLabel :: FastString -> CmmParse BlockId
166 lookupLabel name = do
167 env <- getEnv
168 return $
169 case lookupUFM env name of
170 Just (LabelN l) -> l
171 _other -> mkBlockId (newTagUnique (getUnique name) 'L')
172
173
174 -- | Lookup the location of a named variable.
175 -- Unknown names are treated as if they had been 'import'ed from the runtime system.
176 -- This saves us a lot of bother in the RTS sources, at the expense of
177 -- deferring some errors to link time.
178 lookupName :: FastString -> CmmParse CmmExpr
179 lookupName name = do
180 env <- getEnv
181 return $
182 case lookupUFM env name of
183 Just (VarN e) -> e
184 Just (FunN pkg) -> CmmLit (CmmLabel (mkCmmCodeLabel pkg name))
185 _other -> CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId name))
186
187
188 -- | Lift an FCode computation into the CmmParse monad
189 code :: FCode a -> CmmParse a
190 code fc = EC $ \_ s -> do
191 r <- fc
192 return (s, r)
193
194 emit :: CmmAGraph -> CmmParse ()
195 emit = code . F.emit
196
197 emitLabel :: BlockId -> CmmParse ()
198 emitLabel = code. F.emitLabel
199
200 emitAssign :: CmmReg -> CmmExpr -> CmmParse ()
201 emitAssign l r = code (F.emitAssign l r)
202
203 emitStore :: CmmExpr -> CmmExpr -> CmmParse ()
204 emitStore l r = code (F.emitStore l r)
205
206 getCode :: CmmParse a -> CmmParse CmmAGraph
207 getCode (EC ec) = EC $ \e s -> do
208 ((s',_), gr) <- F.getCodeR (ec e s)
209 return (s', gr)
210
211 getCodeR :: CmmParse a -> CmmParse (a, CmmAGraph)
212 getCodeR (EC ec) = EC $ \e s -> do
213 ((s', r), gr) <- F.getCodeR (ec e s)
214 return (s', (r,gr))
215
216 emitOutOfLine :: BlockId -> CmmAGraph -> CmmParse ()
217 emitOutOfLine l g = code (F.emitOutOfLine l g)
218
219 withUpdFrameOff :: UpdFrameOffset -> CmmParse () -> CmmParse ()
220 withUpdFrameOff size inner
221 = EC $ \e s -> F.withUpdFrameOff size $ (unEC inner) e s
222
223 getUpdFrameOff :: CmmParse UpdFrameOffset
224 getUpdFrameOff = code $ F.getUpdFrameOff