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
  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         = Var   CmmExpr         -- ^ Holds CmmLit(CmmLabel ..) which gives the label type,
  55                                 --      eg, RtsLabel, ForeignLabel, CmmLabel etc.
  56
  57         | Fun   PackageId       -- ^ A function name from this package
  58         | Label 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, Var 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, Label 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, Fun 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 (Label 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 (Var e)    -> e
 178         Just (Fun 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