summaryrefslogtreecommitdiff
path: root/compiler/GHC/StgToCmm/ExtCode.hs
blob: cb57d970f0825bd4bd0d86fb14759f955c0da626 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
{-# LANGUAGE DeriveFunctor #-}
-- | Our extended FCode monad.

-- We add a mapping from names to CmmExpr, to support local variable names in
-- the concrete C-- code.  The unique supply of the underlying FCode monad
-- is used to grab a new unique for each local variable.

-- In C--, a local variable can be declared anywhere within a proc,
-- and it scopes from the beginning of the proc to the end.  Hence, we have
-- to collect declarations as we parse the proc, and feed the environment
-- back in circularly (to avoid a two-pass algorithm).

module GHC.StgToCmm.ExtCode (
        CmmParse, unEC,
        Named(..), Env,

        loopDecls,
        getEnv,

        withName,
        getName,

        newLocal,
        newLabel,
        newBlockId,
        newFunctionName,
        newImport,
        lookupLabel,
        lookupName,

        code,
        emit, emitLabel, emitAssign, emitStore,
        getCode, getCodeR, getCodeScoped,
        emitOutOfLine,
        withUpdFrameOff, getUpdFrameOff
)

where

import GHC.Prelude

import qualified GHC.StgToCmm.Monad as F
import GHC.StgToCmm.Monad (FCode, newUnique)

import GHC.Cmm
import GHC.Cmm.CLabel
import GHC.Cmm.Graph

import GHC.Cmm.BlockId
import GHC.Driver.Session
import GHC.Data.FastString
import GHC.Types.Module
import GHC.Types.Unique.FM
import GHC.Types.Unique
import GHC.Types.Unique.Supply

import Control.Monad (ap)

-- | The environment contains variable definitions or blockids.
data Named
        = VarN CmmExpr          -- ^ Holds CmmLit(CmmLabel ..) which gives the label type,
                                --      eg, RtsLabel, ForeignLabel, CmmLabel etc.

        | FunN   Unit           -- ^ A function name from this package
        | LabelN BlockId        -- ^ A blockid of some code or data.

-- | An environment of named things.
type Env        = UniqFM Named

-- | Local declarations that are in scope during code generation.
type Decls      = [(FastString,Named)]

-- | Does a computation in the FCode monad, with a current environment
--      and a list of local declarations. Returns the resulting list of declarations.
newtype CmmParse a
        = EC { unEC :: String -> Env -> Decls -> FCode (Decls, a) }
    deriving (Functor)

type ExtCode = CmmParse ()

returnExtFC :: a -> CmmParse a
returnExtFC a   = EC $ \_ _ s -> return (s, a)

thenExtFC :: CmmParse a -> (a -> CmmParse b) -> CmmParse b
thenExtFC (EC m) k = EC $ \c e s -> do (s',r) <- m c e s; unEC (k r) c e s'

instance Applicative CmmParse where
      pure = returnExtFC
      (<*>) = ap

instance Monad CmmParse where
  (>>=) = thenExtFC

instance MonadUnique CmmParse where
  getUniqueSupplyM = code getUniqueSupplyM
  getUniqueM = EC $ \_ _ decls -> do
    u <- getUniqueM
    return (decls, u)

instance HasDynFlags CmmParse where
    getDynFlags = EC (\_ _ d -> do dflags <- getDynFlags
                                   return (d, dflags))


-- | Takes the variable declarations and imports from the monad
--      and makes an environment, which is looped back into the computation.
--      In this way, we can have embedded declarations that scope over the whole
--      procedure, and imports that scope over the entire module.
--      Discards the local declaration contained within decl'
--
loopDecls :: CmmParse a -> CmmParse a
loopDecls (EC fcode) =
      EC $ \c e globalDecls -> do
        (_, a) <- F.fixC $ \ ~(decls, _) ->
          fcode c (addListToUFM e decls) globalDecls
        return (globalDecls, a)


-- | Get the current environment from the monad.
getEnv :: CmmParse Env
getEnv  = EC $ \_ e s -> return (s, e)

-- | Get the current context name from the monad
getName :: CmmParse String
getName  = EC $ \c _ s -> return (s, c)

-- | Set context name for a sub-parse
withName :: String -> CmmParse a -> CmmParse a
withName c' (EC fcode) = EC $ \_ e s -> fcode c' e s

addDecl :: FastString -> Named -> ExtCode
addDecl name named = EC $ \_ _ s -> return ((name, named) : s, ())


-- | Add a new variable to the list of local declarations.
--      The CmmExpr says where the value is stored.
addVarDecl :: FastString -> CmmExpr -> ExtCode
addVarDecl var expr = addDecl var (VarN expr)

-- | Add a new label to the list of local declarations.
addLabel :: FastString -> BlockId -> ExtCode
addLabel name block_id = addDecl name (LabelN block_id)


-- | Create a fresh local variable of a given type.
newLocal
        :: CmmType              -- ^ data type
        -> FastString           -- ^ name of variable
        -> CmmParse LocalReg    -- ^ register holding the value

newLocal ty name = do
   u <- code newUnique
   let reg = LocalReg u ty
   addVarDecl name (CmmReg (CmmLocal reg))
   return reg


-- | Allocate a fresh label.
newLabel :: FastString -> CmmParse BlockId
newLabel name = do
   u <- code newUnique
   addLabel name (mkBlockId u)
   return (mkBlockId u)

-- | Add add a local function to the environment.
newFunctionName
        :: FastString   -- ^ name of the function
        -> Unit         -- ^ package of the current module
        -> ExtCode

newFunctionName name pkg = addDecl name (FunN pkg)


-- | Add an imported foreign label to the list of local declarations.
--      If this is done at the start of the module the declaration will scope
--      over the whole module.
newImport
        :: (FastString, CLabel)
        -> CmmParse ()

newImport (name, cmmLabel)
   = addVarDecl name (CmmLit (CmmLabel cmmLabel))


-- | Lookup the BlockId bound to the label with this name.
--      If one hasn't been bound yet, create a fresh one based on the
--      Unique of the name.
lookupLabel :: FastString -> CmmParse BlockId
lookupLabel name = do
  env <- getEnv
  return $
     case lookupUFM env name of
        Just (LabelN l) -> l
        _other          -> mkBlockId (newTagUnique (getUnique name) 'L')


-- | Lookup the location of a named variable.
--      Unknown names are treated as if they had been 'import'ed from the runtime system.
--      This saves us a lot of bother in the RTS sources, at the expense of
--      deferring some errors to link time.
lookupName :: FastString -> CmmParse CmmExpr
lookupName name = do
  env    <- getEnv
  return $
     case lookupUFM env name of
        Just (VarN e)   -> e
        Just (FunN pkg) -> CmmLit (CmmLabel (mkCmmCodeLabel pkg          name))
        _other          -> CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId name))


-- | Lift an FCode computation into the CmmParse monad
code :: FCode a -> CmmParse a
code fc = EC $ \_ _ s -> do
                r <- fc
                return (s, r)

emit :: CmmAGraph -> CmmParse ()
emit = code . F.emit

emitLabel :: BlockId -> CmmParse ()
emitLabel = code . F.emitLabel

emitAssign :: CmmReg  -> CmmExpr -> CmmParse ()
emitAssign l r = code (F.emitAssign l r)

emitStore :: CmmExpr  -> CmmExpr -> CmmParse ()
emitStore l r = code (F.emitStore l r)

getCode :: CmmParse a -> CmmParse CmmAGraph
getCode (EC ec) = EC $ \c e s -> do
  ((s',_), gr) <- F.getCodeR (ec c e s)
  return (s', gr)

getCodeR :: CmmParse a -> CmmParse (a, CmmAGraph)
getCodeR (EC ec) = EC $ \c e s -> do
  ((s', r), gr) <- F.getCodeR (ec c e s)
  return (s', (r,gr))

getCodeScoped :: CmmParse a -> CmmParse (a, CmmAGraphScoped)
getCodeScoped (EC ec) = EC $ \c e s -> do
  ((s', r), gr) <- F.getCodeScoped (ec c e s)
  return (s', (r,gr))

emitOutOfLine :: BlockId -> CmmAGraphScoped -> CmmParse ()
emitOutOfLine l g = code (F.emitOutOfLine l g)

withUpdFrameOff :: UpdFrameOffset -> CmmParse () -> CmmParse ()
withUpdFrameOff size inner
  = EC $ \c e s -> F.withUpdFrameOff size $ (unEC inner) c e s

getUpdFrameOff :: CmmParse UpdFrameOffset
getUpdFrameOff = code $ F.getUpdFrameOff