{-# LANGUAGE ViewPatterns #-}
module GHC.Iface.Tidy.StaticPtrTable
( sptCreateStaticBinds
, sptModuleInitCode
, StaticPtrOpts (..)
)
where
import GHC.Prelude
import GHC.Platform
import GHC.Core
import GHC.Core.Utils (collectMakeStaticArgs)
import GHC.Core.DataCon
import GHC.Core.Make (mkStringExprFSWith,MkStringIds(..))
import GHC.Core.Type
import GHC.Cmm.CLabel
import GHC.Unit.Module
import GHC.Utils.Outputable as Outputable
import GHC.Linker.Types
import GHC.Types.Id
import GHC.Types.ForeignStubs
import GHC.Data.Maybe
import Control.Monad.Trans.State.Strict
import Data.List (intercalate)
import GHC.Fingerprint
data StaticPtrOpts = StaticPtrOpts
{ StaticPtrOpts -> Platform
opt_platform :: !Platform
, StaticPtrOpts -> Bool
opt_gen_cstub :: !Bool
, StaticPtrOpts -> MkStringIds
opt_mk_string :: !MkStringIds
, StaticPtrOpts -> DataCon
opt_static_ptr_info_datacon :: !DataCon
, StaticPtrOpts -> DataCon
opt_static_ptr_datacon :: !DataCon
}
sptCreateStaticBinds :: StaticPtrOpts -> Module -> CoreProgram -> IO ([SptEntry], Maybe CStub, CoreProgram)
sptCreateStaticBinds :: StaticPtrOpts
-> Module
-> CoreProgram
-> IO ([SptEntry], Maybe CStub, CoreProgram)
sptCreateStaticBinds StaticPtrOpts
opts Module
this_mod CoreProgram
binds = do
([SptEntry]
fps, CoreProgram
binds') <- StateT Int IO ([SptEntry], CoreProgram)
-> Int -> IO ([SptEntry], CoreProgram)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT ([SptEntry]
-> CoreProgram
-> CoreProgram
-> StateT Int IO ([SptEntry], CoreProgram)
go [] [] CoreProgram
binds) Int
0
let cstub :: Maybe CStub
cstub
| StaticPtrOpts -> Bool
opt_gen_cstub StaticPtrOpts
opts = CStub -> Maybe CStub
forall a. a -> Maybe a
Just (Platform -> Module -> [SptEntry] -> CStub
sptModuleInitCode (StaticPtrOpts -> Platform
opt_platform StaticPtrOpts
opts) Module
this_mod [SptEntry]
fps)
| Bool
otherwise = Maybe CStub
forall a. Maybe a
Nothing
([SptEntry], Maybe CStub, CoreProgram)
-> IO ([SptEntry], Maybe CStub, CoreProgram)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([SptEntry]
fps, Maybe CStub
cstub, CoreProgram
binds')
where
go :: [SptEntry]
-> CoreProgram
-> CoreProgram
-> StateT Int IO ([SptEntry], CoreProgram)
go [SptEntry]
fps CoreProgram
bs CoreProgram
xs = case CoreProgram
xs of
[] -> ([SptEntry], CoreProgram)
-> StateT Int IO ([SptEntry], CoreProgram)
forall a. a -> StateT Int IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([SptEntry] -> [SptEntry]
forall a. [a] -> [a]
reverse [SptEntry]
fps, CoreProgram -> CoreProgram
forall a. [a] -> [a]
reverse CoreProgram
bs)
CoreBind
bnd : CoreProgram
xs' -> do
([SptEntry]
fps', CoreBind
bnd') <- CoreBind -> StateT Int IO ([SptEntry], CoreBind)
replaceStaticBind CoreBind
bnd
[SptEntry]
-> CoreProgram
-> CoreProgram
-> StateT Int IO ([SptEntry], CoreProgram)
go ([SptEntry] -> [SptEntry]
forall a. [a] -> [a]
reverse [SptEntry]
fps' [SptEntry] -> [SptEntry] -> [SptEntry]
forall a. [a] -> [a] -> [a]
++ [SptEntry]
fps) (CoreBind
bnd' CoreBind -> CoreProgram -> CoreProgram
forall a. a -> [a] -> [a]
: CoreProgram
bs) CoreProgram
xs'
replaceStaticBind :: CoreBind
-> StateT Int IO ([SptEntry], CoreBind)
replaceStaticBind :: CoreBind -> StateT Int IO ([SptEntry], CoreBind)
replaceStaticBind (NonRec CoreBndr
b Expr CoreBndr
e) = do (Maybe SptEntry
mfp, (CoreBndr
b', Expr CoreBndr
e')) <- CoreBndr
-> Expr CoreBndr
-> StateT Int IO (Maybe SptEntry, (CoreBndr, Expr CoreBndr))
replaceStatic CoreBndr
b Expr CoreBndr
e
([SptEntry], CoreBind) -> StateT Int IO ([SptEntry], CoreBind)
forall a. a -> StateT Int IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SptEntry -> [SptEntry]
forall a. Maybe a -> [a]
maybeToList Maybe SptEntry
mfp, CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
b' Expr CoreBndr
e')
replaceStaticBind (Rec [(CoreBndr, Expr CoreBndr)]
rbs) = do
([Maybe SptEntry]
mfps, [(CoreBndr, Expr CoreBndr)]
rbs') <- [(Maybe SptEntry, (CoreBndr, Expr CoreBndr))]
-> ([Maybe SptEntry], [(CoreBndr, Expr CoreBndr)])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Maybe SptEntry, (CoreBndr, Expr CoreBndr))]
-> ([Maybe SptEntry], [(CoreBndr, Expr CoreBndr)]))
-> StateT Int IO [(Maybe SptEntry, (CoreBndr, Expr CoreBndr))]
-> StateT Int IO ([Maybe SptEntry], [(CoreBndr, Expr CoreBndr)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((CoreBndr, Expr CoreBndr)
-> StateT Int IO (Maybe SptEntry, (CoreBndr, Expr CoreBndr)))
-> [(CoreBndr, Expr CoreBndr)]
-> StateT Int IO [(Maybe SptEntry, (CoreBndr, Expr CoreBndr))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((CoreBndr
-> Expr CoreBndr
-> StateT Int IO (Maybe SptEntry, (CoreBndr, Expr CoreBndr)))
-> (CoreBndr, Expr CoreBndr)
-> StateT Int IO (Maybe SptEntry, (CoreBndr, Expr CoreBndr))
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry CoreBndr
-> Expr CoreBndr
-> StateT Int IO (Maybe SptEntry, (CoreBndr, Expr CoreBndr))
replaceStatic) [(CoreBndr, Expr CoreBndr)]
rbs
([SptEntry], CoreBind) -> StateT Int IO ([SptEntry], CoreBind)
forall a. a -> StateT Int IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Maybe SptEntry] -> [SptEntry]
forall a. [Maybe a] -> [a]
catMaybes [Maybe SptEntry]
mfps, [(CoreBndr, Expr CoreBndr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(CoreBndr, Expr CoreBndr)]
rbs')
replaceStatic :: Id -> CoreExpr
-> StateT Int IO (Maybe SptEntry, (Id, CoreExpr))
replaceStatic :: CoreBndr
-> Expr CoreBndr
-> StateT Int IO (Maybe SptEntry, (CoreBndr, Expr CoreBndr))
replaceStatic CoreBndr
b e :: Expr CoreBndr
e@(Expr CoreBndr -> ([CoreBndr], Expr CoreBndr)
collectTyBinders -> ([CoreBndr]
tvs, Expr CoreBndr
e0)) =
case Expr CoreBndr
-> Maybe (Expr CoreBndr, Type, Expr CoreBndr, Expr CoreBndr)
collectMakeStaticArgs Expr CoreBndr
e0 of
Maybe (Expr CoreBndr, Type, Expr CoreBndr, Expr CoreBndr)
Nothing -> (Maybe SptEntry, (CoreBndr, Expr CoreBndr))
-> StateT Int IO (Maybe SptEntry, (CoreBndr, Expr CoreBndr))
forall a. a -> StateT Int IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SptEntry
forall a. Maybe a
Nothing, (CoreBndr
b, Expr CoreBndr
e))
Just (Expr CoreBndr
_, Type
t, Expr CoreBndr
info, Expr CoreBndr
arg) -> do
(Fingerprint
fp, Expr CoreBndr
e') <- Type
-> Expr CoreBndr
-> Expr CoreBndr
-> StateT Int IO (Fingerprint, Expr CoreBndr)
mkStaticBind Type
t Expr CoreBndr
info Expr CoreBndr
arg
(Maybe SptEntry, (CoreBndr, Expr CoreBndr))
-> StateT Int IO (Maybe SptEntry, (CoreBndr, Expr CoreBndr))
forall a. a -> StateT Int IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SptEntry -> Maybe SptEntry
forall a. a -> Maybe a
Just (CoreBndr -> Fingerprint -> SptEntry
SptEntry CoreBndr
b Fingerprint
fp), (CoreBndr
b, (CoreBndr -> Expr CoreBndr -> Expr CoreBndr)
-> Expr CoreBndr -> [CoreBndr] -> Expr CoreBndr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. b -> Expr b -> Expr b
Lam Expr CoreBndr
e' [CoreBndr]
tvs))
mkStaticBind :: Type -> CoreExpr -> CoreExpr
-> StateT Int IO (Fingerprint, CoreExpr)
mkStaticBind :: Type
-> Expr CoreBndr
-> Expr CoreBndr
-> StateT Int IO (Fingerprint, Expr CoreBndr)
mkStaticBind Type
t Expr CoreBndr
srcLoc Expr CoreBndr
e = do
Int
i <- StateT Int IO Int
forall (m :: * -> *) s. Monad m => StateT s m s
get
Int -> StateT Int IO ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
let staticPtrInfoDataCon :: DataCon
staticPtrInfoDataCon = StaticPtrOpts -> DataCon
opt_static_ptr_info_datacon StaticPtrOpts
opts
let fp :: Fingerprint
fp@(Fingerprint Word64
w0 Word64
w1) = Int -> Fingerprint
mkStaticPtrFingerprint Int
i
let mk_string_fs :: FastString -> Expr CoreBndr
mk_string_fs = MkStringIds -> FastString -> Expr CoreBndr
mkStringExprFSWith (StaticPtrOpts -> MkStringIds
opt_mk_string StaticPtrOpts
opts)
let info :: Expr CoreBndr
info = DataCon -> [Expr CoreBndr] -> Expr CoreBndr
forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
staticPtrInfoDataCon
[ FastString -> Expr CoreBndr
mk_string_fs (FastString -> Expr CoreBndr) -> FastString -> Expr CoreBndr
forall a b. (a -> b) -> a -> b
$ Unit -> FastString
forall u. IsUnitId u => u -> FastString
unitFS (Unit -> FastString) -> Unit -> FastString
forall a b. (a -> b) -> a -> b
$ Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
this_mod
, FastString -> Expr CoreBndr
mk_string_fs (FastString -> Expr CoreBndr) -> FastString -> Expr CoreBndr
forall a b. (a -> b) -> a -> b
$ ModuleName -> FastString
moduleNameFS (ModuleName -> FastString) -> ModuleName -> FastString
forall a b. (a -> b) -> a -> b
$ Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
this_mod
, Expr CoreBndr
srcLoc
]
let staticPtrDataCon :: DataCon
staticPtrDataCon = StaticPtrOpts -> DataCon
opt_static_ptr_datacon StaticPtrOpts
opts
(Fingerprint, Expr CoreBndr)
-> StateT Int IO (Fingerprint, Expr CoreBndr)
forall a. a -> StateT Int IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Fingerprint
fp, DataCon -> [Expr CoreBndr] -> Expr CoreBndr
forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
staticPtrDataCon
[ Type -> Expr CoreBndr
forall b. Type -> Expr b
Type Type
t
, Word64 -> Expr CoreBndr
forall b. Word64 -> Expr b
mkWord64LitWord64 Word64
w0
, Word64 -> Expr CoreBndr
forall b. Word64 -> Expr b
mkWord64LitWord64 Word64
w1
, Expr CoreBndr
info
, Expr CoreBndr
e ])
mkStaticPtrFingerprint :: Int -> Fingerprint
mkStaticPtrFingerprint :: Int -> Fingerprint
mkStaticPtrFingerprint Int
n = String -> Fingerprint
fingerprintString (String -> Fingerprint) -> String -> Fingerprint
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
":"
[ Unit -> String
forall u. IsUnitId u => u -> String
unitString (Unit -> String) -> Unit -> String
forall a b. (a -> b) -> a -> b
$ Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
this_mod
, ModuleName -> String
moduleNameString (ModuleName -> String) -> ModuleName -> String
forall a b. (a -> b) -> a -> b
$ Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
this_mod
, Int -> String
forall a. Show a => a -> String
show Int
n
]
sptModuleInitCode :: Platform -> Module -> [SptEntry] -> CStub
sptModuleInitCode :: Platform -> Module -> [SptEntry] -> CStub
sptModuleInitCode Platform
_ Module
_ [] = CStub
forall a. Monoid a => a
mempty
sptModuleInitCode Platform
platform Module
this_mod [SptEntry]
entries =
Platform -> CLabel -> SDoc -> SDoc -> CStub
initializerCStub Platform
platform CLabel
init_fn_nm SDoc
empty SDoc
init_fn_body CStub -> CStub -> CStub
forall a. Monoid a => a -> a -> a
`mappend`
Platform -> CLabel -> SDoc -> SDoc -> CStub
finalizerCStub Platform
platform CLabel
fini_fn_nm SDoc
empty SDoc
fini_fn_body
where
init_fn_nm :: CLabel
init_fn_nm = Module -> String -> CLabel
mkInitializerStubLabel Module
this_mod String
"spt"
init_fn_body :: SDoc
init_fn_body = [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"static StgWord64 k" SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
i SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"[2] = "
SDoc -> SDoc -> SDoc
<> Fingerprint -> SDoc
pprFingerprint Fingerprint
fp SDoc -> SDoc -> SDoc
<> SDoc
semi
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"extern StgPtr "
SDoc -> SDoc -> SDoc
<> (Platform -> CLabel -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform (CLabel -> SDoc) -> CLabel -> SDoc
forall a b. (a -> b) -> a -> b
$ Name -> CafInfo -> CLabel
mkClosureLabel (CoreBndr -> Name
idName CoreBndr
n) (CoreBndr -> CafInfo
idCafInfo CoreBndr
n)) SDoc -> SDoc -> SDoc
<> SDoc
semi
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"hs_spt_insert" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens
([SDoc] -> SDoc
hcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma
[ Char -> SDoc
char Char
'k' SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
i
, Char -> SDoc
char Char
'&' SDoc -> SDoc -> SDoc
<> Platform -> CLabel -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform (Name -> CafInfo -> CLabel
mkClosureLabel (CoreBndr -> Name
idName CoreBndr
n) (CoreBndr -> CafInfo
idCafInfo CoreBndr
n))
]
)
SDoc -> SDoc -> SDoc
<> SDoc
semi
| (Int
i, SptEntry CoreBndr
n Fingerprint
fp) <- [Int] -> [SptEntry] -> [(Int, SptEntry)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [SptEntry]
entries
]
fini_fn_nm :: CLabel
fini_fn_nm = Module -> String -> CLabel
mkFinalizerStubLabel Module
this_mod String
"spt"
fini_fn_body :: SDoc
fini_fn_body = [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"StgWord64 k" SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
i SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"[2] = "
SDoc -> SDoc -> SDoc
<> Fingerprint -> SDoc
pprFingerprint Fingerprint
fp SDoc -> SDoc -> SDoc
<> SDoc
semi
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"hs_spt_remove" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (Char -> SDoc
char Char
'k' SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
i) SDoc -> SDoc -> SDoc
<> SDoc
semi
| (Int
i, (SptEntry CoreBndr
_ Fingerprint
fp)) <- [Int] -> [SptEntry] -> [(Int, SptEntry)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [SptEntry]
entries
]
pprFingerprint :: Fingerprint -> SDoc
pprFingerprint :: Fingerprint -> SDoc
pprFingerprint (Fingerprint Word64
w1 Word64
w2) =
SDoc -> SDoc
braces (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
hcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma
[ Integer -> SDoc
integer (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
w1) SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"ULL"
, Integer -> SDoc
integer (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
w2) SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"ULL"
]