{-# LANGUAGE TypeApplications #-}
module GHC.Linker.Types
( Loader (..)
, LoaderState (..)
, uninitializedLoader
, modifyClosureEnv
, LinkerEnv(..)
, filterLinkerEnv
, ClosureEnv
, emptyClosureEnv
, extendClosureEnv
, Linkable(..)
, LinkableSet
, mkLinkableSet
, unionLinkableSet
, ObjFile
, Unlinked(..)
, SptEntry(..)
, isObjectLinkable
, linkableObjs
, isObject
, nameOfObject
, nameOfObject_maybe
, isInterpretable
, byteCodeOfObject
, LibrarySpec(..)
, LoadedPkgInfo(..)
, PkgsLoaded
)
where
import GHC.Prelude
import GHC.Unit ( UnitId, Module )
import GHC.ByteCode.Types ( ItblEnv, AddrEnv, CompiledByteCode )
import GHC.Fingerprint.Type ( Fingerprint )
import GHCi.RemoteTypes ( ForeignHValue, RemotePtr )
import GHCi.Message ( LoadedDLL )
import GHC.Types.Var ( Id )
import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnvList, filterNameEnv )
import GHC.Types.Name ( Name )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import Control.Concurrent.MVar
import Data.Time ( UTCTime )
import Data.Maybe
import GHC.Unit.Module.Env
import GHC.Types.Unique.DSet
import GHC.Types.Unique.DFM
import GHC.Unit.Module.WholeCoreBindings
newtype Loader = Loader { Loader -> MVar (Maybe LoaderState)
loader_state :: MVar (Maybe LoaderState) }
data LoaderState = LoaderState
{ LoaderState -> LinkerEnv
linker_env :: !LinkerEnv
, LoaderState -> LinkableSet
bcos_loaded :: !LinkableSet
, LoaderState -> LinkableSet
objs_loaded :: !LinkableSet
, LoaderState -> PkgsLoaded
pkgs_loaded :: !PkgsLoaded
, LoaderState -> [(FilePath, FilePath)]
temp_sos :: ![(FilePath, String)]
}
uninitializedLoader :: IO Loader
uninitializedLoader :: IO Loader
uninitializedLoader = MVar (Maybe LoaderState) -> Loader
Loader (MVar (Maybe LoaderState) -> Loader)
-> IO (MVar (Maybe LoaderState)) -> IO Loader
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe LoaderState -> IO (MVar (Maybe LoaderState))
forall a. a -> IO (MVar a)
newMVar Maybe LoaderState
forall a. Maybe a
Nothing
modifyClosureEnv :: LoaderState -> (ClosureEnv -> ClosureEnv) -> LoaderState
modifyClosureEnv :: LoaderState -> (ClosureEnv -> ClosureEnv) -> LoaderState
modifyClosureEnv LoaderState
pls ClosureEnv -> ClosureEnv
f =
let le :: LinkerEnv
le = LoaderState -> LinkerEnv
linker_env LoaderState
pls
ce :: ClosureEnv
ce = LinkerEnv -> ClosureEnv
closure_env LinkerEnv
le
in LoaderState
pls { linker_env = le { closure_env = f ce } }
data LinkerEnv = LinkerEnv
{ LinkerEnv -> ClosureEnv
closure_env :: !ClosureEnv
, LinkerEnv -> ItblEnv
itbl_env :: !ItblEnv
, LinkerEnv -> AddrEnv
addr_env :: !AddrEnv
}
filterLinkerEnv :: (Name -> Bool) -> LinkerEnv -> LinkerEnv
filterLinkerEnv :: (Name -> Bool) -> LinkerEnv -> LinkerEnv
filterLinkerEnv Name -> Bool
f LinkerEnv
le = LinkerEnv
{ closure_env :: ClosureEnv
closure_env = ((Name, ForeignHValue) -> Bool) -> ClosureEnv -> ClosureEnv
forall elt. (elt -> Bool) -> NameEnv elt -> NameEnv elt
filterNameEnv (Name -> Bool
f (Name -> Bool)
-> ((Name, ForeignHValue) -> Name) -> (Name, ForeignHValue) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, ForeignHValue) -> Name
forall a b. (a, b) -> a
fst) (LinkerEnv -> ClosureEnv
closure_env LinkerEnv
le)
, itbl_env :: ItblEnv
itbl_env = ((Name, ItblPtr) -> Bool) -> ItblEnv -> ItblEnv
forall elt. (elt -> Bool) -> NameEnv elt -> NameEnv elt
filterNameEnv (Name -> Bool
f (Name -> Bool)
-> ((Name, ItblPtr) -> Name) -> (Name, ItblPtr) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, ItblPtr) -> Name
forall a b. (a, b) -> a
fst) (LinkerEnv -> ItblEnv
itbl_env LinkerEnv
le)
, addr_env :: AddrEnv
addr_env = ((Name, AddrPtr) -> Bool) -> AddrEnv -> AddrEnv
forall elt. (elt -> Bool) -> NameEnv elt -> NameEnv elt
filterNameEnv (Name -> Bool
f (Name -> Bool)
-> ((Name, AddrPtr) -> Name) -> (Name, AddrPtr) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, AddrPtr) -> Name
forall a b. (a, b) -> a
fst) (LinkerEnv -> AddrEnv
addr_env LinkerEnv
le)
}
type ClosureEnv = NameEnv (Name, ForeignHValue)
emptyClosureEnv :: ClosureEnv
emptyClosureEnv :: ClosureEnv
emptyClosureEnv = ClosureEnv
forall a. NameEnv a
emptyNameEnv
extendClosureEnv :: ClosureEnv -> [(Name,ForeignHValue)] -> ClosureEnv
extendClosureEnv :: ClosureEnv -> [(Name, ForeignHValue)] -> ClosureEnv
extendClosureEnv ClosureEnv
cl_env [(Name, ForeignHValue)]
pairs
= ClosureEnv -> [(Name, (Name, ForeignHValue))] -> ClosureEnv
forall a. NameEnv a -> [(Name, a)] -> NameEnv a
extendNameEnvList ClosureEnv
cl_env [ (Name
n, (Name
n,ForeignHValue
v)) | (Name
n,ForeignHValue
v) <- [(Name, ForeignHValue)]
pairs]
type PkgsLoaded = UniqDFM UnitId LoadedPkgInfo
data LoadedPkgInfo
= LoadedPkgInfo
{ LoadedPkgInfo -> UnitId
loaded_pkg_uid :: !UnitId
, LoadedPkgInfo -> [LibrarySpec]
loaded_pkg_hs_objs :: ![LibrarySpec]
, LoadedPkgInfo -> [LibrarySpec]
loaded_pkg_non_hs_objs :: ![LibrarySpec]
, LoadedPkgInfo -> [RemotePtr LoadedDLL]
loaded_pkg_hs_dlls :: ![RemotePtr LoadedDLL]
, LoadedPkgInfo -> UniqDSet UnitId
loaded_pkg_trans_deps :: UniqDSet UnitId
}
instance Outputable LoadedPkgInfo where
ppr :: LoadedPkgInfo -> SDoc
ppr (LoadedPkgInfo UnitId
uid [LibrarySpec]
hs_objs [LibrarySpec]
non_hs_objs [RemotePtr LoadedDLL]
_ UniqDSet UnitId
trans_deps) =
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
uid
, [LibrarySpec] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LibrarySpec]
hs_objs
, [LibrarySpec] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LibrarySpec]
non_hs_objs
, UniqDSet UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UniqDSet UnitId
trans_deps ]
data Linkable = LM {
Linkable -> UTCTime
linkableTime :: !UTCTime,
Linkable -> Module
linkableModule :: !Module,
Linkable -> [Unlinked]
linkableUnlinked :: [Unlinked]
}
type LinkableSet = ModuleEnv Linkable
mkLinkableSet :: [Linkable] -> LinkableSet
mkLinkableSet :: [Linkable] -> LinkableSet
mkLinkableSet [Linkable]
ls = [(Module, Linkable)] -> LinkableSet
forall a. [(Module, a)] -> ModuleEnv a
mkModuleEnv [(Linkable -> Module
linkableModule Linkable
l, Linkable
l) | Linkable
l <- [Linkable]
ls]
unionLinkableSet :: LinkableSet -> LinkableSet -> LinkableSet
unionLinkableSet :: LinkableSet -> LinkableSet -> LinkableSet
unionLinkableSet = (Linkable -> Linkable -> Linkable)
-> LinkableSet -> LinkableSet -> LinkableSet
forall a.
(a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a
plusModuleEnv_C Linkable -> Linkable -> Linkable
go
where
go :: Linkable -> Linkable -> Linkable
go Linkable
l1 Linkable
l2
| Linkable -> UTCTime
linkableTime Linkable
l1 UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> Linkable -> UTCTime
linkableTime Linkable
l2 = Linkable
l1
| Bool
otherwise = Linkable
l2
instance Outputable Linkable where
ppr :: Linkable -> SDoc
ppr (LM UTCTime
when_made Module
mod [Unlinked]
unlinkeds)
= (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"LinkableM" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text (UTCTime -> FilePath
forall a. Show a => a -> FilePath
show UTCTime
when_made)) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod)
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Int -> SDoc -> SDoc
nest Int
3 ([Unlinked] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Unlinked]
unlinkeds)
type ObjFile = FilePath
data Unlinked
= DotO ObjFile
| DotA FilePath
| DotDLL FilePath
| CoreBindings WholeCoreBindings
| LoadedBCOs [Unlinked]
| BCOs CompiledByteCode
[SptEntry]
instance Outputable Unlinked where
ppr :: Unlinked -> SDoc
ppr (DotO FilePath
path) = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"DotO" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
path
ppr (DotA FilePath
path) = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"DotA" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
path
ppr (DotDLL FilePath
path) = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"DotDLL" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
path
ppr (BCOs CompiledByteCode
bcos [SptEntry]
spt) = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"BCOs" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CompiledByteCode -> SDoc
forall a. Outputable a => a -> SDoc
ppr CompiledByteCode
bcos SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [SptEntry] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [SptEntry]
spt
ppr (LoadedBCOs{}) = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"LoadedBCOs"
ppr (CoreBindings {}) = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"FI"
data SptEntry = SptEntry Id Fingerprint
instance Outputable SptEntry where
ppr :: SptEntry -> SDoc
ppr (SptEntry Id
id Fingerprint
fpr) = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Fingerprint -> SDoc
forall a. Outputable a => a -> SDoc
ppr Fingerprint
fpr
isObjectLinkable :: Linkable -> Bool
isObjectLinkable :: Linkable -> Bool
isObjectLinkable Linkable
l = Bool -> Bool
not ([Unlinked] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Unlinked]
unlinked) Bool -> Bool -> Bool
&& (Unlinked -> Bool) -> [Unlinked] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Unlinked -> Bool
isObject [Unlinked]
unlinked
where unlinked :: [Unlinked]
unlinked = Linkable -> [Unlinked]
linkableUnlinked Linkable
l
linkableObjs :: Linkable -> [FilePath]
linkableObjs :: Linkable -> [FilePath]
linkableObjs Linkable
l = [ FilePath
f | DotO FilePath
f <- Linkable -> [Unlinked]
linkableUnlinked Linkable
l ]
isObject :: Unlinked -> Bool
isObject :: Unlinked -> Bool
isObject (DotO FilePath
_) = Bool
True
isObject (DotA FilePath
_) = Bool
True
isObject (DotDLL FilePath
_) = Bool
True
isObject Unlinked
_ = Bool
False
isInterpretable :: Unlinked -> Bool
isInterpretable :: Unlinked -> Bool
isInterpretable = Bool -> Bool
not (Bool -> Bool) -> (Unlinked -> Bool) -> Unlinked -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unlinked -> Bool
isObject
nameOfObject_maybe :: Unlinked -> Maybe FilePath
nameOfObject_maybe :: Unlinked -> Maybe FilePath
nameOfObject_maybe (DotO FilePath
fn) = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
fn
nameOfObject_maybe (DotA FilePath
fn) = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
fn
nameOfObject_maybe (DotDLL FilePath
fn) = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
fn
nameOfObject_maybe (CoreBindings {}) = Maybe FilePath
forall a. Maybe a
Nothing
nameOfObject_maybe (LoadedBCOs{}) = Maybe FilePath
forall a. Maybe a
Nothing
nameOfObject_maybe (BCOs {}) = Maybe FilePath
forall a. Maybe a
Nothing
nameOfObject :: Unlinked -> FilePath
nameOfObject :: Unlinked -> FilePath
nameOfObject Unlinked
o = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> SDoc -> FilePath
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"nameOfObject" (Unlinked -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unlinked
o)) (Unlinked -> Maybe FilePath
nameOfObject_maybe Unlinked
o)
byteCodeOfObject :: Unlinked -> [CompiledByteCode]
byteCodeOfObject :: Unlinked -> [CompiledByteCode]
byteCodeOfObject (BCOs CompiledByteCode
bc [SptEntry]
_) = [CompiledByteCode
bc]
byteCodeOfObject (LoadedBCOs [Unlinked]
ul) = (Unlinked -> [CompiledByteCode])
-> [Unlinked] -> [CompiledByteCode]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Unlinked -> [CompiledByteCode]
byteCodeOfObject [Unlinked]
ul
byteCodeOfObject Unlinked
other = FilePath -> SDoc -> [CompiledByteCode]
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"byteCodeOfObject" (Unlinked -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unlinked
other)
data LibrarySpec
= Objects [FilePath]
| Archive FilePath
| DLL String
| DLLPath FilePath
| Framework String
instance Outputable LibrarySpec where
ppr :: LibrarySpec -> SDoc
ppr (Objects [FilePath]
objs) = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Objects" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [SDoc] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((FilePath -> SDoc) -> [FilePath] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (forall doc. IsLine doc => FilePath -> doc
text @SDoc) [FilePath]
objs)
ppr (Archive FilePath
a) = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Archive" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
a
ppr (DLL FilePath
s) = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"DLL" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
s
ppr (DLLPath FilePath
f) = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"DLLPath" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
f
ppr (Framework FilePath
s) = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Framework" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
s