{-# 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 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)
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