never executed always true always false
    1 {-# LANGUAGE DeriveFunctor #-}
    2 {-# LANGUAGE TupleSections #-}
    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 GHC.StgToCmm.ExtCode (
   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         getProfile, getPlatform, getPtrOpts
   38 )
   39 
   40 where
   41 
   42 import GHC.Prelude
   43 
   44 import GHC.Platform
   45 import GHC.Platform.Profile
   46 
   47 import qualified GHC.StgToCmm.Monad as F
   48 import GHC.StgToCmm.Monad (FCode, newUnique)
   49 
   50 import GHC.Cmm
   51 import GHC.Cmm.CLabel
   52 import GHC.Cmm.Graph
   53 import GHC.Cmm.Info
   54 
   55 import GHC.Cmm.BlockId
   56 import GHC.Driver.Session
   57 import GHC.Data.FastString
   58 import GHC.Unit.Module
   59 import GHC.Types.Unique.FM
   60 import GHC.Types.Unique
   61 import GHC.Types.Unique.Supply
   62 
   63 import Control.Monad (ap)
   64 
   65 -- | The environment contains variable definitions or blockids.
   66 data Named
   67         = VarN CmmExpr          -- ^ Holds CmmLit(CmmLabel ..) which gives the label type,
   68                                 --      eg, RtsLabel, ForeignLabel, CmmLabel etc.
   69 
   70         | FunN   UnitId         -- ^ A function name from this unit
   71         | LabelN BlockId        -- ^ A blockid of some code or data.
   72 
   73 -- | An environment of named things.
   74 type Env        = UniqFM FastString Named
   75 
   76 -- | Local declarations that are in scope during code generation.
   77 type Decls      = [(FastString,Named)]
   78 
   79 -- | Does a computation in the FCode monad, with a current environment
   80 --      and a list of local declarations. Returns the resulting list of declarations.
   81 newtype CmmParse a
   82         = EC { unEC :: String -> Env -> Decls -> FCode (Decls, a) }
   83     deriving (Functor)
   84 
   85 type ExtCode = CmmParse ()
   86 
   87 returnExtFC :: a -> CmmParse a
   88 returnExtFC a   = EC $ \_ _ s -> return (s, a)
   89 
   90 thenExtFC :: CmmParse a -> (a -> CmmParse b) -> CmmParse b
   91 thenExtFC (EC m) k = EC $ \c e s -> do (s',r) <- m c e s; unEC (k r) c e s'
   92 
   93 instance Applicative CmmParse where
   94       pure = returnExtFC
   95       (<*>) = ap
   96 
   97 instance Monad CmmParse where
   98   (>>=) = thenExtFC
   99 
  100 instance MonadUnique CmmParse where
  101   getUniqueSupplyM = code getUniqueSupplyM
  102   getUniqueM = EC $ \_ _ decls -> do
  103     u <- getUniqueM
  104     return (decls, u)
  105 
  106 instance HasDynFlags CmmParse where
  107     getDynFlags = EC (\_ _ d -> (d,) <$> getDynFlags)
  108 
  109 getProfile :: CmmParse Profile
  110 getProfile = EC (\_ _ d -> (d,) <$> F.getProfile)
  111 
  112 getPlatform :: CmmParse Platform
  113 getPlatform = EC (\_ _ d -> (d,) <$> F.getPlatform)
  114 
  115 getPtrOpts :: CmmParse PtrOpts
  116 getPtrOpts = EC (\_ _ d -> (d,) <$> F.getPtrOpts)
  117 
  118 -- | Takes the variable declarations and imports from the monad
  119 --      and makes an environment, which is looped back into the computation.
  120 --      In this way, we can have embedded declarations that scope over the whole
  121 --      procedure, and imports that scope over the entire module.
  122 --      Discards the local declaration contained within decl'
  123 --
  124 loopDecls :: CmmParse a -> CmmParse a
  125 loopDecls (EC fcode) =
  126       EC $ \c e globalDecls -> do
  127         (_, a) <- F.fixC $ \ ~(decls, _) ->
  128           fcode c (addListToUFM e decls) globalDecls
  129         return (globalDecls, a)
  130 
  131 
  132 -- | Get the current environment from the monad.
  133 getEnv :: CmmParse Env
  134 getEnv  = EC $ \_ e s -> return (s, e)
  135 
  136 -- | Get the current context name from the monad
  137 getName :: CmmParse String
  138 getName  = EC $ \c _ s -> return (s, c)
  139 
  140 -- | Set context name for a sub-parse
  141 withName :: String -> CmmParse a -> CmmParse a
  142 withName c' (EC fcode) = EC $ \_ e s -> fcode c' e s
  143 
  144 addDecl :: FastString -> Named -> ExtCode
  145 addDecl name named = EC $ \_ _ s -> return ((name, named) : s, ())
  146 
  147 
  148 -- | Add a new variable to the list of local declarations.
  149 --      The CmmExpr says where the value is stored.
  150 addVarDecl :: FastString -> CmmExpr -> ExtCode
  151 addVarDecl var expr = addDecl var (VarN expr)
  152 
  153 -- | Add a new label to the list of local declarations.
  154 addLabel :: FastString -> BlockId -> ExtCode
  155 addLabel name block_id = addDecl name (LabelN block_id)
  156 
  157 
  158 -- | Create a fresh local variable of a given type.
  159 newLocal
  160         :: CmmType              -- ^ data type
  161         -> FastString           -- ^ name of variable
  162         -> CmmParse LocalReg    -- ^ register holding the value
  163 
  164 newLocal ty name = do
  165    u <- code newUnique
  166    let reg = LocalReg u ty
  167    addVarDecl name (CmmReg (CmmLocal reg))
  168    return reg
  169 
  170 
  171 -- | Allocate a fresh label.
  172 newLabel :: FastString -> CmmParse BlockId
  173 newLabel name = do
  174    u <- code newUnique
  175    addLabel name (mkBlockId u)
  176    return (mkBlockId u)
  177 
  178 -- | Add a local function to the environment.
  179 newFunctionName
  180         :: FastString   -- ^ name of the function
  181         -> UnitId       -- ^ package of the current module
  182         -> ExtCode
  183 
  184 newFunctionName name pkg = addDecl name (FunN pkg)
  185 
  186 
  187 -- | Add an imported foreign label to the list of local declarations.
  188 --      If this is done at the start of the module the declaration will scope
  189 --      over the whole module.
  190 newImport
  191         :: (FastString, CLabel)
  192         -> CmmParse ()
  193 
  194 newImport (name, cmmLabel)
  195    = addVarDecl name (CmmLit (CmmLabel cmmLabel))
  196 
  197 
  198 -- | Lookup the BlockId bound to the label with this name.
  199 --      If one hasn't been bound yet, create a fresh one based on the
  200 --      Unique of the name.
  201 lookupLabel :: FastString -> CmmParse BlockId
  202 lookupLabel name = do
  203   env <- getEnv
  204   return $
  205      case lookupUFM env name of
  206         Just (LabelN l) -> l
  207         _other          -> mkBlockId (newTagUnique (getUnique name) 'L')
  208 
  209 
  210 -- | Lookup the location of a named variable.
  211 --      Unknown names are treated as if they had been 'import'ed from the runtime system.
  212 --      This saves us a lot of bother in the RTS sources, at the expense of
  213 --      deferring some errors to link time.
  214 lookupName :: FastString -> CmmParse CmmExpr
  215 lookupName name = do
  216   env    <- getEnv
  217   return $
  218      case lookupUFM env name of
  219         Just (VarN e)   -> e
  220         Just (FunN uid) -> CmmLit (CmmLabel (mkCmmCodeLabel uid       name))
  221         _other          -> CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId name))
  222 
  223 
  224 -- | Lift an FCode computation into the CmmParse monad
  225 code :: FCode a -> CmmParse a
  226 code fc = EC $ \_ _ s -> do
  227                 r <- fc
  228                 return (s, r)
  229 
  230 emit :: CmmAGraph -> CmmParse ()
  231 emit = code . F.emit
  232 
  233 emitLabel :: BlockId -> CmmParse ()
  234 emitLabel = code . F.emitLabel
  235 
  236 emitAssign :: CmmReg  -> CmmExpr -> CmmParse ()
  237 emitAssign l r = code (F.emitAssign l r)
  238 
  239 emitStore :: CmmExpr  -> CmmExpr -> CmmParse ()
  240 emitStore l r = code (F.emitStore l r)
  241 
  242 getCode :: CmmParse a -> CmmParse CmmAGraph
  243 getCode (EC ec) = EC $ \c e s -> do
  244   ((s',_), gr) <- F.getCodeR (ec c e s)
  245   return (s', gr)
  246 
  247 getCodeR :: CmmParse a -> CmmParse (a, CmmAGraph)
  248 getCodeR (EC ec) = EC $ \c e s -> do
  249   ((s', r), gr) <- F.getCodeR (ec c e s)
  250   return (s', (r,gr))
  251 
  252 getCodeScoped :: CmmParse a -> CmmParse (a, CmmAGraphScoped)
  253 getCodeScoped (EC ec) = EC $ \c e s -> do
  254   ((s', r), gr) <- F.getCodeScoped (ec c e s)
  255   return (s', (r,gr))
  256 
  257 emitOutOfLine :: BlockId -> CmmAGraphScoped -> CmmParse ()
  258 emitOutOfLine l g = code (F.emitOutOfLine l g)
  259 
  260 withUpdFrameOff :: UpdFrameOffset -> CmmParse () -> CmmParse ()
  261 withUpdFrameOff size inner
  262   = EC $ \c e s -> F.withUpdFrameOff size $ (unEC inner) c e s
  263 
  264 getUpdFrameOff :: CmmParse UpdFrameOffset
  265 getUpdFrameOff = code $ F.getUpdFrameOff