-----------------------------------------------------------------------------
--
-- Types for the linkers and the loader
--
-- (c) The University of Glasgow 2019
--
-----------------------------------------------------------------------------
{-# 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 )

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


{- **********************************************************************

                        The Loader's state

  ********************************************************************* -}

{-
The loader state *must* match the actual state of the C dynamic linker at all
times.

The MVar used to hold the LoaderState contains a Maybe LoaderState. The MVar
serves to ensure mutual exclusion between multiple loaded copies of the GHC
library. The Maybe may be Nothing to indicate that the linker has not yet been
initialised.

The LinkerEnv maps Names to actual closures (for interpreted code only), for
use during linking.
-}

newtype Loader = Loader { Loader -> MVar (Maybe LoaderState)
loader_state :: MVar (Maybe LoaderState) }

data LoaderState = LoaderState
    { LoaderState -> LinkerEnv
linker_env :: !LinkerEnv
        -- ^ Current global mapping from Names to their true values

    , LoaderState -> LinkableSet
bcos_loaded :: !LinkableSet
        -- ^ The currently loaded interpreted modules (home package)

    , LoaderState -> LinkableSet
objs_loaded :: !LinkableSet
        -- ^ And the currently-loaded compiled modules (home package)

    , LoaderState -> PkgsLoaded
pkgs_loaded :: !PkgsLoaded
        -- ^ The currently-loaded packages; always object code
        -- haskell libraries, system libraries, transitive dependencies

    , LoaderState -> [(FilePath, FilePath)]
temp_sos :: ![(FilePath, String)]
        -- ^ We need to remember the name of previous temporary DLL/.so
        -- libraries so we can link them (see #10322)
    }

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
      -- ^ Current global mapping from closure Names to their true values

  , LinkerEnv -> ItblEnv
itbl_env    :: !ItblEnv
      -- ^ The current global mapping from RdrNames of DataCons to
      -- info table addresses.
      -- When a new Unlinked is linked into the running image, or an existing
      -- module in the image is replaced, the itbl_env must be updated
      -- appropriately.

  , LinkerEnv -> AddrEnv
addr_env    :: !AddrEnv
      -- ^ Like 'closure_env' and 'itbl_env', but for top-level 'Addr#' literals,
      -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode.
  }

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 -> 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 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 ]


-- | Information we can use to dynamically link modules into the compiler
data Linkable = LM {
  Linkable -> UTCTime
linkableTime     :: !UTCTime,          -- ^ Time at which this linkable was built
                                        -- (i.e. when the bytecodes were produced,
                                        --       or the mod date on the files)
  Linkable -> Module
linkableModule   :: !Module,           -- ^ The linkable module itself
  Linkable -> [Unlinked]
linkableUnlinked :: [Unlinked]
    -- ^ Those files and chunks of code we have yet to link.
    --
    -- INVARIANT: A valid linkable always has at least one 'Unlinked' item.
 }

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

-- | Objects which have yet to be linked by the compiler
data Unlinked
  = DotO ObjFile       -- ^ An object file (.o)
  | DotA FilePath      -- ^ Static archive file (.a)
  | DotDLL FilePath    -- ^ Dynamically linked library file (.so, .dll, .dylib)
  | CoreBindings WholeCoreBindings -- ^ Serialised core which we can turn into BCOs (or object files), or used by some other backend
                       -- See Note [Interface Files with Core Definitions]
  | LoadedBCOs [Unlinked] -- ^ A list of BCOs, but hidden behind extra indirection to avoid
                          -- being too strict.
  | BCOs CompiledByteCode
         [SptEntry]    -- ^ A byte-code object, lives only in memory. Also
                       -- carries some static pointer table entries which
                       -- should be loaded along with the BCOs.
                       -- See Note [Grand plan for static forms] in
                       -- "GHC.Iface.Tidy.StaticPtrTable".

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"

-- | An entry to be inserted into a module's static pointer table.
-- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable".
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
        -- A linkable with no Unlinked's is treated as a BCO.  We can
        -- generate a linkable with no Unlinked's as a result of
        -- compiling a module in NoBackend mode, and this choice
        -- happens to work well with checkStability in module GHC.

linkableObjs :: Linkable -> [FilePath]
linkableObjs :: Linkable -> [FilePath]
linkableObjs Linkable
l = [ FilePath
f | DotO FilePath
f <- Linkable -> [Unlinked]
linkableUnlinked Linkable
l ]

-------------------------------------------

-- | Is this an actual file on disk we can link in somehow?
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

-- | Is this a bytecode linkable with no file on disk?
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

-- | Retrieve the filename of the linkable if possible. Panic if it is a byte-code object
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)

-- | Retrieve the compiled byte-code if possible. Panic if it is a file-based linkable
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)

{- **********************************************************************

                Loading packages

  ********************************************************************* -}

data LibrarySpec
   = Objects [FilePath] -- Full path names of set of .o files, including trailing .o
                        -- We allow batched loading to ensure that cyclic symbol
                        -- references can be resolved (see #13786).
                        -- For dynamic objects only, try to find the object
                        -- file in all the directories specified in
                        -- v_Library_paths before giving up.

   | Archive FilePath   -- Full path name of a .a file, including trailing .a

   | DLL String         -- "Unadorned" name of a .DLL/.so
                        --  e.g.    On unix     "qt"  denotes "libqt.so"
                        --          On Windows  "burble"  denotes "burble.DLL" or "libburble.dll"
                        --  loadDLL is platform-specific and adds the lib/.so/.DLL
                        --  suffixes platform-dependently

   | DLLPath FilePath   -- Absolute or relative pathname to a dynamic library
                        -- (ends with .dll or .so).

   | Framework String   -- Only used for darwin, but does no harm

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