{-# 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, getContext
)
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.BlockId
import GHC.Data.FastString
import GHC.Unit.Module
import GHC.Types.Unique.FM
import GHC.Types.Unique
import GHC.Types.Unique.Supply
import qualified GHC.Types.Unique.DSM as DSM
import Control.Monad (ap)
import GHC.Utils.Outputable (SDocContext)
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 -> b) -> CmmParse a -> CmmParse b)
-> (forall a b. a -> CmmParse b -> CmmParse a) -> Functor CmmParse
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
$cfmap :: forall a b. (a -> b) -> CmmParse a -> CmmParse b
fmap :: forall a b. (a -> b) -> CmmParse a -> CmmParse b
$c<$ :: forall a b. a -> CmmParse b -> CmmParse a
<$ :: forall a b. a -> CmmParse b -> CmmParse a
Functor)
type ExtCode = CmmParse ()
returnExtFC :: a -> CmmParse a
returnExtFC :: forall a. a -> CmmParse a
returnExtFC a
a = (String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
forall a.
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
EC ((String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a)
-> (String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
forall a b. (a -> b) -> a -> b
$ \String
_ Env
_ Decls
s -> (Decls, a) -> FCode (Decls, a)
forall a. a -> FCode a
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 = (String -> Env -> Decls -> FCode (Decls, b)) -> CmmParse b
forall a.
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
EC ((String -> Env -> Decls -> FCode (Decls, b)) -> CmmParse b)
-> (String -> Env -> Decls -> FCode (Decls, b)) -> CmmParse b
forall a b. (a -> b) -> a -> b
$ \String
c Env
e Decls
s -> do (s',r) <- String -> Env -> Decls -> FCode (Decls, a)
m String
c Env
e Decls
s; unEC (k r) c e s'
instance Applicative CmmParse where
pure :: forall a. a -> CmmParse a
pure = a -> CmmParse a
forall a. a -> CmmParse a
returnExtFC
<*> :: forall a b. CmmParse (a -> b) -> CmmParse a -> CmmParse 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
(>>=) = 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 = FCode UniqSupply -> CmmParse UniqSupply
forall a. FCode a -> CmmParse a
code FCode UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
getUniqueM :: CmmParse Unique
getUniqueM = (String -> Env -> Decls -> FCode (Decls, Unique))
-> CmmParse Unique
forall a.
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
EC ((String -> Env -> Decls -> FCode (Decls, Unique))
-> CmmParse Unique)
-> (String -> Env -> Decls -> FCode (Decls, Unique))
-> CmmParse Unique
forall a b. (a -> b) -> a -> b
$ \String
_ Env
_ Decls
decls -> do
u <- FCode Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
return (decls, u)
instance DSM.MonadGetUnique CmmParse where
getUniqueM :: CmmParse Unique
getUniqueM = CmmParse Unique
forall (m :: * -> *). MonadUnique m => m Unique
GHC.Types.Unique.Supply.getUniqueM
getProfile :: CmmParse Profile
getProfile :: CmmParse Profile
getProfile = (String -> Env -> Decls -> FCode (Decls, Profile))
-> CmmParse Profile
forall a.
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
EC (\String
_ Env
_ Decls
d -> (Decls
d,) (Profile -> (Decls, Profile))
-> FCode Profile -> FCode (Decls, Profile)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode Profile
F.getProfile)
getPlatform :: CmmParse Platform
getPlatform :: CmmParse Platform
getPlatform = (String -> Env -> Decls -> FCode (Decls, Platform))
-> CmmParse Platform
forall a.
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
EC (\String
_ Env
_ Decls
d -> (Decls
d,) (Platform -> (Decls, Platform))
-> FCode Platform -> FCode (Decls, Platform)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode Platform
F.getPlatform)
getContext :: CmmParse SDocContext
getContext :: CmmParse SDocContext
getContext = (String -> Env -> Decls -> FCode (Decls, SDocContext))
-> CmmParse SDocContext
forall a.
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
EC (\String
_ Env
_ Decls
d -> (Decls
d,) (SDocContext -> (Decls, SDocContext))
-> FCode SDocContext -> FCode (Decls, SDocContext)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode SDocContext
F.getContext)
loopDecls :: CmmParse a -> CmmParse a
loopDecls :: forall a. CmmParse a -> CmmParse a
loopDecls (EC String -> Env -> Decls -> FCode (Decls, a)
fcode) =
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
forall a.
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
EC ((String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a)
-> (String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
forall a b. (a -> b) -> a -> b
$ \String
c Env
e Decls
globalDecls -> do
(_, a) <- ((Decls, a) -> FCode (Decls, a)) -> FCode (Decls, a)
forall a. (a -> FCode a) -> FCode a
F.fixC (((Decls, a) -> FCode (Decls, a)) -> FCode (Decls, a))
-> ((Decls, a) -> FCode (Decls, a)) -> FCode (Decls, a)
forall a b. (a -> b) -> a -> b
$ \ ~(Decls
decls, a
_) ->
String -> Env -> Decls -> FCode (Decls, a)
fcode String
c (Env -> Decls -> Env
forall key elt.
Uniquable key =>
UniqFM key elt -> [(key, elt)] -> UniqFM key elt
addListToUFM Env
e Decls
decls) Decls
globalDecls
return (globalDecls, a)
getEnv :: CmmParse Env
getEnv :: CmmParse Env
getEnv = (String -> Env -> Decls -> FCode (Decls, Env)) -> CmmParse Env
forall a.
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
EC ((String -> Env -> Decls -> FCode (Decls, Env)) -> CmmParse Env)
-> (String -> Env -> Decls -> FCode (Decls, Env)) -> CmmParse Env
forall a b. (a -> b) -> a -> b
$ \String
_ Env
e Decls
s -> (Decls, Env) -> FCode (Decls, Env)
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (Decls
s, Env
e)
getName :: CmmParse String
getName :: CmmParse String
getName = (String -> Env -> Decls -> FCode (Decls, String))
-> CmmParse String
forall a.
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
EC ((String -> Env -> Decls -> FCode (Decls, String))
-> CmmParse String)
-> (String -> Env -> Decls -> FCode (Decls, String))
-> CmmParse String
forall a b. (a -> b) -> a -> b
$ \String
c Env
_ Decls
s -> (Decls, String) -> FCode (Decls, String)
forall a. a -> FCode a
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) = (String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
forall a.
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
EC ((String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a)
-> (String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
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 = (String -> Env -> Decls -> FCode (Decls, ())) -> ExtCode
forall a.
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
EC ((String -> Env -> Decls -> FCode (Decls, ())) -> ExtCode)
-> (String -> Env -> Decls -> FCode (Decls, ())) -> ExtCode
forall a b. (a -> b) -> a -> b
$ \String
_ Env
_ Decls
s -> (Decls, ()) -> FCode (Decls, ())
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return ((FastString
name, Named
named) (FastString, Named) -> Decls -> Decls
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
u <- FCode Unique -> CmmParse Unique
forall a. FCode a -> CmmParse a
code FCode Unique
newUnique
let reg = Unique -> CmmType -> LocalReg
LocalReg Unique
u CmmType
ty
addVarDecl name (CmmReg (CmmLocal reg))
return reg
newLabel :: FastString -> CmmParse BlockId
newLabel :: FastString -> CmmParse BlockId
newLabel FastString
name = do
u <- FCode Unique -> CmmParse Unique
forall a. FCode a -> CmmParse a
code FCode Unique
newUnique
addLabel name (mkBlockId u)
return (mkBlockId 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 <- CmmParse Env
getEnv
return $
case lookupUFM env name of
Just (LabelN BlockId
l) -> BlockId
l
Maybe Named
_other -> Unique -> BlockId
mkBlockId (Unique -> Char -> Unique
newTagUnique (FastString -> Unique
forall a. Uniquable a => a -> Unique
getUnique FastString
name) Char
'L')
lookupName :: FastString -> CmmParse CmmExpr
lookupName :: FastString -> CmmParse CmmExpr
lookupName FastString
name = do
env <- CmmParse Env
getEnv
return $
case lookupUFM env 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 = (String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
forall a.
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
EC ((String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a)
-> (String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
forall a b. (a -> b) -> a -> b
$ \String
_ Env
_ Decls
s -> do
r <- FCode a
fc
return (s, r)
emit :: CmmAGraph -> CmmParse ()
emit :: CmmAGraph -> ExtCode
emit = FCode () -> ExtCode
forall a. FCode a -> CmmParse a
code (FCode () -> ExtCode)
-> (CmmAGraph -> FCode ()) -> CmmAGraph -> ExtCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmAGraph -> FCode ()
F.emit
emitLabel :: BlockId -> CmmParse ()
emitLabel :: BlockId -> ExtCode
emitLabel = FCode () -> ExtCode
forall a. FCode a -> CmmParse a
code (FCode () -> ExtCode)
-> (BlockId -> FCode ()) -> BlockId -> ExtCode
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 = FCode () -> ExtCode
forall a. FCode a -> CmmParse a
code (CmmReg -> CmmExpr -> FCode ()
F.emitAssign CmmReg
l CmmExpr
r)
emitStore :: Maybe MemoryOrdering -> CmmExpr -> CmmExpr -> CmmParse ()
emitStore :: Maybe MemoryOrdering -> CmmExpr -> CmmExpr -> ExtCode
emitStore (Just MemoryOrdering
mem_ord) CmmExpr
l CmmExpr
r = do
platform <- CmmParse Platform
getPlatform
let w = CmmType -> Width
typeWidth (CmmType -> Width) -> CmmType -> Width
forall a b. (a -> b) -> a -> b
$ Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
r
emit $ mkUnsafeCall (PrimTarget $ MO_AtomicWrite w mem_ord) [] [l,r]
emitStore Maybe MemoryOrdering
Nothing CmmExpr
l CmmExpr
r = FCode () -> ExtCode
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) = (String -> Env -> Decls -> FCode (Decls, CmmAGraph))
-> CmmParse CmmAGraph
forall a.
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
EC ((String -> Env -> Decls -> FCode (Decls, CmmAGraph))
-> CmmParse CmmAGraph)
-> (String -> Env -> Decls -> FCode (Decls, CmmAGraph))
-> CmmParse CmmAGraph
forall a b. (a -> b) -> a -> b
$ \String
c Env
e Decls
s -> do
((s',_), gr) <- FCode (Decls, a) -> FCode ((Decls, a), CmmAGraph)
forall a. FCode a -> FCode (a, CmmAGraph)
F.getCodeR (String -> Env -> Decls -> FCode (Decls, a)
ec String
c Env
e Decls
s)
return (s', gr)
getCodeR :: CmmParse a -> CmmParse (a, CmmAGraph)
getCodeR :: forall a. CmmParse a -> CmmParse (a, CmmAGraph)
getCodeR (EC String -> Env -> Decls -> FCode (Decls, a)
ec) = (String -> Env -> Decls -> FCode (Decls, (a, CmmAGraph)))
-> CmmParse (a, CmmAGraph)
forall a.
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
EC ((String -> Env -> Decls -> FCode (Decls, (a, CmmAGraph)))
-> CmmParse (a, CmmAGraph))
-> (String -> Env -> Decls -> FCode (Decls, (a, CmmAGraph)))
-> CmmParse (a, CmmAGraph)
forall a b. (a -> b) -> a -> b
$ \String
c Env
e Decls
s -> do
((s', r), gr) <- FCode (Decls, a) -> FCode ((Decls, a), CmmAGraph)
forall a. FCode a -> FCode (a, CmmAGraph)
F.getCodeR (String -> Env -> Decls -> FCode (Decls, a)
ec String
c Env
e Decls
s)
return (s', (r,gr))
getCodeScoped :: CmmParse a -> CmmParse (a, CmmAGraphScoped)
getCodeScoped :: forall a. CmmParse a -> CmmParse (a, CmmAGraphScoped)
getCodeScoped (EC String -> Env -> Decls -> FCode (Decls, a)
ec) = (String -> Env -> Decls -> FCode (Decls, (a, CmmAGraphScoped)))
-> CmmParse (a, CmmAGraphScoped)
forall a.
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
EC ((String -> Env -> Decls -> FCode (Decls, (a, CmmAGraphScoped)))
-> CmmParse (a, CmmAGraphScoped))
-> (String -> Env -> Decls -> FCode (Decls, (a, CmmAGraphScoped)))
-> CmmParse (a, CmmAGraphScoped)
forall a b. (a -> b) -> a -> b
$ \String
c Env
e Decls
s -> do
((s', r), gr) <- FCode (Decls, a) -> FCode ((Decls, a), CmmAGraphScoped)
forall a. FCode a -> FCode (a, CmmAGraphScoped)
F.getCodeScoped (String -> Env -> Decls -> FCode (Decls, a)
ec String
c Env
e Decls
s)
return (s', (r,gr))
emitOutOfLine :: BlockId -> CmmAGraphScoped -> CmmParse ()
emitOutOfLine :: BlockId -> CmmAGraphScoped -> ExtCode
emitOutOfLine BlockId
l CmmAGraphScoped
g = FCode () -> ExtCode
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
= (String -> Env -> Decls -> FCode (Decls, ())) -> ExtCode
forall a.
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
EC ((String -> Env -> Decls -> FCode (Decls, ())) -> ExtCode)
-> (String -> Env -> Decls -> FCode (Decls, ())) -> ExtCode
forall a b. (a -> b) -> a -> b
$ \String
c Env
e Decls
s -> UpdFrameOffset -> FCode (Decls, ()) -> FCode (Decls, ())
forall a. UpdFrameOffset -> FCode a -> FCode a
F.withUpdFrameOff UpdFrameOffset
size (FCode (Decls, ()) -> FCode (Decls, ()))
-> FCode (Decls, ()) -> FCode (Decls, ())
forall a b. (a -> b) -> a -> b
$ (ExtCode -> String -> Env -> Decls -> FCode (Decls, ())
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 = FCode UpdFrameOffset -> CmmParse UpdFrameOffset
forall a. FCode a -> CmmParse a
code (FCode UpdFrameOffset -> CmmParse UpdFrameOffset)
-> FCode UpdFrameOffset -> CmmParse UpdFrameOffset
forall a b. (a -> b) -> a -> b
$ FCode UpdFrameOffset
F.getUpdFrameOff