{-# LANGUAGE DeriveFunctor #-}
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
)
where
import GhcPrelude
import qualified GHC.StgToCmm.Monad as F
import GHC.StgToCmm.Monad (FCode, newUnique)
import Cmm
import CLabel
import MkGraph
import BlockId
import DynFlags
import FastString
import Module
import UniqFM
import Unique
import UniqSupply
import Control.Monad (ap)
data Named
= VarN CmmExpr
| FunN UnitId
| LabelN BlockId
type Env = UniqFM Named
type Decls = [(FastString,Named)]
newtype CmmParse a
= EC { CmmParse a -> String -> Env -> Decls -> FCode (Decls, a)
unEC :: String -> Env -> Decls -> FCode (Decls, a) }
deriving (a -> CmmParse b -> CmmParse a
(a -> b) -> CmmParse a -> CmmParse b
(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
<$ :: a -> CmmParse b -> CmmParse a
$c<$ :: forall a b. a -> CmmParse b -> CmmParse a
fmap :: (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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return (Decls
s, a
a)
thenExtFC :: CmmParse a -> (a -> CmmParse b) -> CmmParse b
thenExtFC :: 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 (Decls
s',a
r) <- String -> Env -> Decls -> FCode (Decls, a)
m String
c Env
e Decls
s; CmmParse b -> String -> Env -> Decls -> FCode (Decls, b)
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 :: a -> CmmParse a
pure = a -> CmmParse a
forall a. a -> CmmParse a
returnExtFC
<*> :: 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
>>= :: 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
Unique
u <- FCode Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
(Decls, Unique) -> FCode (Decls, Unique)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decls
decls, Unique
u)
instance HasDynFlags CmmParse where
getDynFlags :: CmmParse DynFlags
getDynFlags = (String -> Env -> Decls -> FCode (Decls, DynFlags))
-> CmmParse DynFlags
forall a.
(String -> Env -> Decls -> FCode (Decls, a)) -> CmmParse a
EC (\String
_ Env
_ Decls
d -> do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
(Decls, DynFlags) -> FCode (Decls, DynFlags)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decls
d, DynFlags
dflags))
loopDecls :: CmmParse a -> CmmParse a
loopDecls :: 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
(Decls
_, a
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 elt -> [(key, elt)] -> UniqFM elt
addListToUFM Env
e Decls
decls) Decls
globalDecls
(Decls, a) -> FCode (Decls, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decls
globalDecls, a
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 (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 (m :: * -> *) a. Monad m => a -> m a
return (Decls
s, String
c)
withName :: String -> CmmParse a -> CmmParse a
withName :: 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 (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
Unique
u <- FCode Unique -> CmmParse Unique
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))
LocalReg -> CmmParse LocalReg
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 <- FCode Unique -> CmmParse Unique
forall a. FCode a -> CmmParse a
code FCode Unique
newUnique
FastString -> BlockId -> ExtCode
addLabel FastString
name (Unique -> BlockId
mkBlockId Unique
u)
BlockId -> CmmParse BlockId
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
BlockId -> CmmParse BlockId
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId -> CmmParse BlockId) -> BlockId -> CmmParse BlockId
forall a b. (a -> b) -> a -> b
$
case Env -> FastString -> Maybe Named
forall key elt. Uniquable key => UniqFM 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 (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
env <- CmmParse Env
getEnv
CmmExpr -> CmmParse CmmExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmExpr -> CmmParse CmmExpr) -> CmmExpr -> CmmParse CmmExpr
forall a b. (a -> b) -> a -> b
$
case Env -> FastString -> Maybe Named
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM Env
env FastString
name of
Just (VarN CmmExpr
e) -> CmmExpr
e
Just (FunN UnitId
pkg) -> CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel (UnitId -> FastString -> CLabel
mkCmmCodeLabel UnitId
pkg 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 :: 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
a
r <- FCode a
fc
(Decls, a) -> FCode (Decls, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decls
s, a
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 :: CmmExpr -> CmmExpr -> CmmParse ()
emitStore :: CmmExpr -> CmmExpr -> ExtCode
emitStore 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 :: 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
((Decls
s',a
_), CmmAGraph
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)
(Decls, CmmAGraph) -> FCode (Decls, CmmAGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decls
s', CmmAGraph
gr)
getCodeR :: CmmParse a -> CmmParse (a, CmmAGraph)
getCodeR :: 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
((Decls
s', a
r), CmmAGraph
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)
(Decls, (a, CmmAGraph)) -> FCode (Decls, (a, CmmAGraph))
forall (m :: * -> *) a. Monad m => a -> m a
return (Decls
s', (a
r,CmmAGraph
gr))
getCodeScoped :: CmmParse a -> CmmParse (a, CmmAGraphScoped)
getCodeScoped :: 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
((Decls
s', a
r), CmmAGraphScoped
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)
(Decls, (a, CmmAGraphScoped))
-> FCode (Decls, (a, CmmAGraphScoped))
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 = 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