{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TupleSections #-}
-- | 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,
        getProfile, getPlatform, getPtrOpts
)

where

import GHC.Prelude

import GHC.Platform
import GHC.Platform.Profile

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.Info

import GHC.Cmm.BlockId
import GHC.Driver.Session
import GHC.Data.FastString
import GHC.Unit.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   UnitId         -- ^ A function name from this unit
        | LabelN BlockId        -- ^ A blockid of some code or data.

-- | An environment of named things.
type Env        = UniqFM FastString 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 { forall a. CmmParse a -> String -> Env -> Decls -> FCode (Decls, a)
unEC :: String -> Env -> Decls -> FCode (Decls, a) }
    deriving (forall a b. a -> CmmParse b -> CmmParse a
forall a b. (a -> b) -> CmmParse a -> CmmParse b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> CmmParse b -> CmmParse a
$c<$ :: forall a b. a -> CmmParse b -> CmmParse a
fmap :: forall a b. (a -> b) -> CmmParse a -> CmmParse b
$cfmap :: forall a b. (a -> b) -> CmmParse a -> CmmParse b
Functor)

type ExtCode = CmmParse ()

returnExtFC :: a -> CmmParse a
returnExtFC :: forall a. a -> CmmParse a
returnExtFC a
a   = forall a.
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
EC forall a b. (a -> b) -> a -> b
$ \String
_ Env
_ Decls
s -> forall (m :: * -> *) a. Monad m => a -> m a
return (Decls
s, a
a)

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

instance Applicative CmmParse where
      pure :: forall a. a -> CmmParse a
pure = forall a. a -> CmmParse a
returnExtFC
      <*> :: forall a b. CmmParse (a -> b) -> CmmParse a -> CmmParse b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad CmmParse where
  >>= :: forall a b. CmmParse a -> (a -> CmmParse b) -> CmmParse b
(>>=) = forall a b. CmmParse a -> (a -> CmmParse b) -> CmmParse b
thenExtFC

instance MonadUnique CmmParse where
  getUniqueSupplyM :: CmmParse UniqSupply
getUniqueSupplyM = forall a. FCode a -> CmmParse a
code forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
  getUniqueM :: CmmParse Unique
getUniqueM = forall a.
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
EC forall a b. (a -> b) -> a -> b
$ \String
_ Env
_ Decls
decls -> do
    Unique
u <- forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
    forall (m :: * -> *) a. Monad m => a -> m a
return (Decls
decls, Unique
u)

instance HasDynFlags CmmParse where
    getDynFlags :: CmmParse DynFlags
getDynFlags = forall a.
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
EC (\String
_ Env
_ Decls
d -> (Decls
d,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags)

getProfile :: CmmParse Profile
getProfile :: CmmParse Profile
getProfile = forall a.
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
EC (\String
_ Env
_ Decls
d -> (Decls
d,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode Profile
F.getProfile)

getPlatform :: CmmParse Platform
getPlatform :: CmmParse Platform
getPlatform = forall a.
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
EC (\String
_ Env
_ Decls
d -> (Decls
d,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode Platform
F.getPlatform)

getPtrOpts :: CmmParse PtrOpts
getPtrOpts :: CmmParse PtrOpts
getPtrOpts = forall a.
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
EC (\String
_ Env
_ Decls
d -> (Decls
d,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode PtrOpts
F.getPtrOpts)

-- | 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 :: forall a. CmmParse a -> CmmParse a
loopDecls (EC String -> Env -> Decls -> FCode (Decls, a)
fcode) =
      forall a.
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
EC forall a b. (a -> b) -> a -> b
$ \String
c Env
e Decls
globalDecls -> do
        (Decls
_, a
a) <- forall a. (a -> FCode a) -> FCode a
F.fixC forall a b. (a -> b) -> a -> b
$ \ ~(Decls
decls, a
_) ->
          String -> Env -> Decls -> FCode (Decls, a)
fcode String
c (forall key elt.
Uniquable key =>
UniqFM key elt -> [(key, elt)] -> UniqFM key elt
addListToUFM Env
e Decls
decls) Decls
globalDecls
        forall (m :: * -> *) a. Monad m => a -> m a
return (Decls
globalDecls, a
a)


-- | Get the current environment from the monad.
getEnv :: CmmParse Env
getEnv :: CmmParse Env
getEnv  = forall a.
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
EC forall a b. (a -> b) -> a -> b
$ \String
_ Env
e Decls
s -> forall (m :: * -> *) a. Monad m => a -> m a
return (Decls
s, Env
e)

-- | Get the current context name from the monad
getName :: CmmParse String
getName :: CmmParse String
getName  = forall a.
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
EC forall a b. (a -> b) -> a -> b
$ \String
c Env
_ Decls
s -> forall (m :: * -> *) a. Monad m => a -> m a
return (Decls
s, String
c)

-- | Set context name for a sub-parse
withName :: String -> CmmParse a -> CmmParse a
withName :: forall a. String -> CmmParse a -> CmmParse a
withName String
c' (EC String -> Env -> Decls -> FCode (Decls, a)
fcode) = forall a.
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
EC forall a b. (a -> b) -> a -> b
$ \String
_ Env
e Decls
s -> String -> Env -> Decls -> FCode (Decls, a)
fcode String
c' Env
e Decls
s

addDecl :: FastString -> Named -> ExtCode
addDecl :: FastString -> Named -> ExtCode
addDecl FastString
name Named
named = forall a.
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
EC forall a b. (a -> b) -> a -> b
$ \String
_ Env
_ Decls
s -> forall (m :: * -> *) a. Monad m => a -> m a
return ((FastString
name, Named
named) forall a. a -> [a] -> [a]
: Decls
s, ())


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

-- | Add a new label to the list of local declarations.
addLabel :: FastString -> BlockId -> ExtCode
addLabel :: FastString -> BlockId -> ExtCode
addLabel FastString
name BlockId
block_id = FastString -> Named -> ExtCode
addDecl FastString
name (BlockId -> Named
LabelN BlockId
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 :: CmmType -> FastString -> CmmParse LocalReg
newLocal CmmType
ty FastString
name = do
   Unique
u <- forall a. FCode a -> CmmParse a
code FCode Unique
newUnique
   let reg :: LocalReg
reg = Unique -> CmmType -> LocalReg
LocalReg Unique
u CmmType
ty
   FastString -> CmmExpr -> ExtCode
addVarDecl FastString
name (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
reg))
   forall (m :: * -> *) a. Monad m => a -> m a
return LocalReg
reg


-- | Allocate a fresh label.
newLabel :: FastString -> CmmParse BlockId
newLabel :: FastString -> CmmParse BlockId
newLabel FastString
name = do
   Unique
u <- forall a. FCode a -> CmmParse a
code FCode Unique
newUnique
   FastString -> BlockId -> ExtCode
addLabel FastString
name (Unique -> BlockId
mkBlockId Unique
u)
   forall (m :: * -> *) a. Monad m => a -> m a
return (Unique -> BlockId
mkBlockId Unique
u)

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

newFunctionName :: FastString -> UnitId -> ExtCode
newFunctionName FastString
name UnitId
pkg = FastString -> Named -> ExtCode
addDecl FastString
name (UnitId -> Named
FunN UnitId
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 :: (FastString, CLabel) -> ExtCode
newImport (FastString
name, CLabel
cmmLabel)
   = FastString -> CmmExpr -> ExtCode
addVarDecl FastString
name (CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel CLabel
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 :: FastString -> CmmParse BlockId
lookupLabel FastString
name = do
  Env
env <- CmmParse Env
getEnv
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
     case forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM Env
env FastString
name of
        Just (LabelN BlockId
l) -> BlockId
l
        Maybe Named
_other          -> Unique -> BlockId
mkBlockId (Unique -> Char -> Unique
newTagUnique (forall a. Uniquable a => a -> Unique
getUnique FastString
name) Char
'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 :: FastString -> CmmParse CmmExpr
lookupName FastString
name = do
  Env
env    <- CmmParse Env
getEnv
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
     case forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM Env
env FastString
name of
        Just (VarN CmmExpr
e)   -> CmmExpr
e
        Just (FunN UnitId
uid) -> CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel (UnitId -> FastString -> CLabel
mkCmmCodeLabel UnitId
uid       FastString
name))
        Maybe Named
_other          -> CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel (UnitId -> FastString -> CLabel
mkCmmCodeLabel UnitId
rtsUnitId FastString
name))


-- | Lift an FCode computation into the CmmParse monad
code :: FCode a -> CmmParse a
code :: forall a. FCode a -> CmmParse a
code FCode a
fc = forall a.
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
EC forall a b. (a -> b) -> a -> b
$ \String
_ Env
_ Decls
s -> do
                a
r <- FCode a
fc
                forall (m :: * -> *) a. Monad m => a -> m a
return (Decls
s, a
r)

emit :: CmmAGraph -> CmmParse ()
emit :: CmmAGraph -> ExtCode
emit = forall a. FCode a -> CmmParse a
code forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmAGraph -> FCode ()
F.emit

emitLabel :: BlockId -> CmmParse ()
emitLabel :: BlockId -> ExtCode
emitLabel = forall a. FCode a -> CmmParse a
code forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockId -> FCode ()
F.emitLabel

emitAssign :: CmmReg  -> CmmExpr -> CmmParse ()
emitAssign :: CmmReg -> CmmExpr -> ExtCode
emitAssign CmmReg
l CmmExpr
r = forall a. FCode a -> CmmParse a
code (CmmReg -> CmmExpr -> FCode ()
F.emitAssign CmmReg
l CmmExpr
r)

emitStore :: CmmExpr  -> CmmExpr -> CmmParse ()
emitStore :: CmmExpr -> CmmExpr -> ExtCode
emitStore CmmExpr
l CmmExpr
r = forall a. FCode a -> CmmParse a
code (CmmExpr -> CmmExpr -> FCode ()
F.emitStore CmmExpr
l CmmExpr
r)

getCode :: CmmParse a -> CmmParse CmmAGraph
getCode :: forall a. CmmParse a -> CmmParse CmmAGraph
getCode (EC String -> Env -> Decls -> FCode (Decls, a)
ec) = forall a.
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
EC forall a b. (a -> b) -> a -> b
$ \String
c Env
e Decls
s -> do
  ((Decls
s',a
_), CmmAGraph
gr) <- forall a. FCode a -> FCode (a, CmmAGraph)
F.getCodeR (String -> Env -> Decls -> FCode (Decls, a)
ec String
c Env
e Decls
s)
  forall (m :: * -> *) a. Monad m => a -> m a
return (Decls
s', CmmAGraph
gr)

getCodeR :: CmmParse a -> CmmParse (a, CmmAGraph)
getCodeR :: forall a. CmmParse a -> CmmParse (a, CmmAGraph)
getCodeR (EC String -> Env -> Decls -> FCode (Decls, a)
ec) = forall a.
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
EC forall a b. (a -> b) -> a -> b
$ \String
c Env
e Decls
s -> do
  ((Decls
s', a
r), CmmAGraph
gr) <- forall a. FCode a -> FCode (a, CmmAGraph)
F.getCodeR (String -> Env -> Decls -> FCode (Decls, a)
ec String
c Env
e Decls
s)
  forall (m :: * -> *) a. Monad m => a -> m a
return (Decls
s', (a
r,CmmAGraph
gr))

getCodeScoped :: CmmParse a -> CmmParse (a, CmmAGraphScoped)
getCodeScoped :: forall a. CmmParse a -> CmmParse (a, CmmAGraphScoped)
getCodeScoped (EC String -> Env -> Decls -> FCode (Decls, a)
ec) = forall a.
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
EC forall a b. (a -> b) -> a -> b
$ \String
c Env
e Decls
s -> do
  ((Decls
s', a
r), CmmAGraphScoped
gr) <- forall a. FCode a -> FCode (a, CmmAGraphScoped)
F.getCodeScoped (String -> Env -> Decls -> FCode (Decls, a)
ec String
c Env
e Decls
s)
  forall (m :: * -> *) a. Monad m => a -> m a
return (Decls
s', (a
r,CmmAGraphScoped
gr))

emitOutOfLine :: BlockId -> CmmAGraphScoped -> CmmParse ()
emitOutOfLine :: BlockId -> CmmAGraphScoped -> ExtCode
emitOutOfLine BlockId
l CmmAGraphScoped
g = forall a. FCode a -> CmmParse a
code (BlockId -> CmmAGraphScoped -> FCode ()
F.emitOutOfLine BlockId
l CmmAGraphScoped
g)

withUpdFrameOff :: UpdFrameOffset -> CmmParse () -> CmmParse ()
withUpdFrameOff :: UpdFrameOffset -> ExtCode -> ExtCode
withUpdFrameOff UpdFrameOffset
size ExtCode
inner
  = forall a.
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
EC forall a b. (a -> b) -> a -> b
$ \String
c Env
e Decls
s -> forall a. UpdFrameOffset -> FCode a -> FCode a
F.withUpdFrameOff UpdFrameOffset
size forall a b. (a -> b) -> a -> b
$ (forall a. CmmParse a -> String -> Env -> Decls -> FCode (Decls, a)
unEC ExtCode
inner) String
c Env
e Decls
s

getUpdFrameOff :: CmmParse UpdFrameOffset
getUpdFrameOff :: CmmParse UpdFrameOffset
getUpdFrameOff = forall a. FCode a -> CmmParse a
code forall a b. (a -> b) -> a -> b
$ FCode UpdFrameOffset
F.getUpdFrameOff