{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TupleSections #-}
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)
data Named
= VarN CmmExpr
| FunN UnitId
| LabelN BlockId
type Env = UniqFM FastString Named
type Decls = [(FastString,Named)]
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)
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)
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)
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)
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, ())
addVarDecl :: FastString -> CmmExpr -> ExtCode
addVarDecl :: FastString -> CmmExpr -> ExtCode
addVarDecl FastString
var CmmExpr
expr = FastString -> Named -> ExtCode
addDecl FastString
var (CmmExpr -> Named
VarN CmmExpr
expr)
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)
newLocal
:: CmmType
-> FastString
-> CmmParse LocalReg
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
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)
newFunctionName
:: FastString
-> UnitId
-> ExtCode
newFunctionName :: FastString -> UnitId -> ExtCode
newFunctionName FastString
name UnitId
pkg = FastString -> Named -> ExtCode
addDecl FastString
name (UnitId -> Named
FunN UnitId
pkg)
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))
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')
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))
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