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
  25         lookupLabel,
  26         lookupName,
  27
  28         code,
  29         code2,
  30         nopEC,
  31         stmtEC,
  32         stmtsEC,
  33         getCgStmtsEC,
  34         getCgStmtsEC',
  35         forkLabelledCodeEC
  36 )
  37
  38 where
  39
  40 import CgMonad
  41
  42 import CLabel
  43 import Cmm
  44
  45 import BasicTypes
  46 import BlockId
  47 import FastString
  48 import Module
  49 import UniqFM
  50 import Unique
  51
  52
  53 -- | The environment contains variable definitions or blockids.
  54 data Named
  55         = Var   CmmExpr         -- ^ Holds CmmLit(CmmLabel ..) which gives the label type,
  56                                 --      eg, RtsLabel, ForeignLabel, CmmLabel etc.
  57
  58         | Fun   PackageId       -- ^ A function name from this package
  59         | Label BlockId         -- ^ A blockid of some code or data.
  60
  61 -- | An environment of named things.
  62 type Env        = UniqFM Named
  63
  64 -- | Local declarations that are in scope during code generation.
  65 type Decls      = [(FastString,Named)]
  66
  67 -- | Does a computation in the FCode monad, with a current environment
  68 --      and a list of local declarations. Returns the resulting list of declarations.
  69 newtype ExtFCode a
  70         = EC { unEC :: Env -> Decls -> FCode (Decls, a) }
  71
  72 type ExtCode = ExtFCode ()
  73
  74 returnExtFC :: a -> ExtFCode a
  75 returnExtFC a   = EC $ \_ s -> return (s, a)
  76
  77 thenExtFC :: ExtFCode a -> (a -> ExtFCode b) -> ExtFCode b
  78 thenExtFC (EC m) k = EC $ \e s -> do (s',r) <- m e s; unEC (k r) e s'
  79
  80 instance Monad ExtFCode where
  81   (>>=) = thenExtFC
  82   return = returnExtFC
  83
  84
  85 -- | Takes the variable decarations and imports from the monad
  86 --      and makes an environment, which is looped back into the computation.
  87 --      In this way, we can have embedded declarations that scope over the whole
  88 --      procedure, and imports that scope over the entire module.
  89 --      Discards the local declaration contained within decl'
  90 --
  91 loopDecls :: ExtFCode a -> ExtFCode a
  92 loopDecls (EC fcode) =
  93       EC $ \e globalDecls -> do
  94         (_, a) <- fixC (\ ~(decls, _) -> fcode (addListToUFM e (decls ++ globalDecls)) globalDecls)
  95         return (globalDecls, a)
  96
  97
  98 -- | Get the current environment from the monad.
  99 getEnv :: ExtFCode Env
 100 getEnv  = EC $ \e s -> return (s, e)
 101
 102
 103 -- | Add a new variable to the list of local declarations.
 104 --      The CmmExpr says where the value is stored.
 105 addVarDecl :: FastString -> CmmExpr -> ExtCode
 106 addVarDecl var expr
 107         = EC $ \_ s -> return ((var, Var expr):s, ())
 108
 109 -- | Add a new label to the list of local declarations.
 110 addLabel :: FastString -> BlockId -> ExtCode
 111 addLabel name block_id
 112         = EC $ \_ s -> return ((name, Label block_id):s, ())
 113
 114
 115 -- | Create a fresh local variable of a given type.
 116 newLocal
 117         :: CmmType              -- ^ data type
 118         -> FastString           -- ^ name of variable
 119         -> ExtFCode LocalReg    -- ^ register holding the value
 120
 121 newLocal ty name = do
 122    u <- code newUnique
 123    let reg = LocalReg u ty
 124    addVarDecl name (CmmReg (CmmLocal reg))
 125    return reg
 126
 127
 128 -- | Allocate a fresh label.
 129 newLabel :: FastString -> ExtFCode BlockId
 130 newLabel name = do
 131    u <- code newUnique
 132    addLabel name (BlockId u)
 133    return (BlockId u)
 134
 135
 136 -- | Add add a local function to the environment.
 137 newFunctionName
 138         :: FastString   -- ^ name of the function
 139         -> PackageId    -- ^ package of the current module
 140         -> ExtCode
 141
 142 newFunctionName name pkg
 143         = EC $ \_ s -> return ((name, Fun pkg):s, ())
 144
 145
 146 -- | Add an imported foreign label to the list of local declarations.
 147 --      If this is done at the start of the module the declaration will scope
 148 --      over the whole module.
 149 --      CLabel's labelDynamic classifies these labels as dynamic, hence the
 150 --      code generator emits PIC code for them.
 151 newImport :: (Maybe PackageId, FastString) -> ExtFCode ()
 152 newImport (Nothing, name)
 153    = addVarDecl name (CmmLit (CmmLabel (mkForeignLabel name Nothing True IsFunction)))
 154
 155 newImport (Just pkg, name)
 156    = addVarDecl name (CmmLit (CmmLabel (mkCmmCodeLabel pkg name)))
 157
 158 -- | Lookup the BlockId bound to the label with this name.
 159 --      If one hasn't been bound yet, create a fresh one based on the
 160 --      Unique of the name.
 161 lookupLabel :: FastString -> ExtFCode BlockId
 162 lookupLabel name = do
 163   env <- getEnv
 164   return $
 165      case lookupUFM env name of
 166         Just (Label l)  -> l
 167         _other          -> BlockId (newTagUnique (getUnique name) 'L')
 168
 169
 170 -- | Lookup the location of a named variable.
 171 --      Unknown names are treated as if they had been 'import'ed from the runtime system.
 172 --      This saves us a lot of bother in the RTS sources, at the expense of
 173 --      deferring some errors to link time.
 174 lookupName :: FastString -> ExtFCode CmmExpr
 175 lookupName name = do
 176   env    <- getEnv
 177   return $
 178      case lookupUFM env name of
 179         Just (Var e)    -> e
 180         Just (Fun pkg)  -> CmmLit (CmmLabel (mkCmmCodeLabel pkg          name))
 181         _other          -> CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId name))
 182
 183
 184 -- | Lift an FCode computation into the ExtFCode monad
 185 code :: FCode a -> ExtFCode a
 186 code fc = EC $ \_ s -> do
 187                 r <- fc
 188                 return (s, r)
 189
 190
 191 code2 :: (FCode (Decls,b) -> FCode ((Decls,b),c)) -> ExtFCode b -> ExtFCode c
 192 code2 f (EC ec)
 193         = EC $ \e s -> do
 194                 ((s', _),c) <- f (ec e s)
 195                 return (s',c)
 196
 197
 198 -- | Do nothing in the ExtFCode monad.
 199 nopEC :: ExtFCode ()
 200 nopEC = code nopC
 201
 202
 203 -- | Accumulate a CmmStmt into the monad state.
 204 stmtEC :: CmmStmt -> ExtFCode ()
 205 stmtEC stmt = code (stmtC stmt)
 206
 207
 208 -- | Accumulate some CmmStmts into the monad state.
 209 stmtsEC :: [CmmStmt] -> ExtFCode ()
 210 stmtsEC stmts = code (stmtsC stmts)
 211
 212
 213 -- | Get the generated statements out of the monad state.
 214 getCgStmtsEC :: ExtFCode a -> ExtFCode CgStmts
 215 getCgStmtsEC = code2 getCgStmts'
 216
 217
 218 -- | Get the generated statements, and the return value out of the monad state.
 219 getCgStmtsEC' :: ExtFCode a -> ExtFCode (a, CgStmts)
 220 getCgStmtsEC' = code2 (\m -> getCgStmts' m >>= f)
 221   where f ((decl, b), c) = return ((decl, b), (b, c))
 222
 223
 224 -- | Emit a chunk of code outside the instruction stream,
 225 --      and return its block id.
 226 forkLabelledCodeEC :: ExtFCode a -> ExtFCode BlockId
 227 forkLabelledCodeEC ec = do
 228   stmts <- getCgStmtsEC ec
 229   code (forkCgStmts stmts)
 230
 231