-----------------------------------------------------------------------------
--
-- 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (MVar a)
newMVar 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 :: LinkerEnv
linker_env = LinkerEnv
le { closure_env :: ClosureEnv
closure_env = ClosureEnv -> ClosureEnv
f ClosureEnv
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 = forall elt. (elt -> Bool) -> NameEnv elt -> NameEnv elt
filterNameEnv (Name -> Bool
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) (LinkerEnv -> ClosureEnv
closure_env LinkerEnv
le)
  , itbl_env :: ItblEnv
itbl_env    = forall elt. (elt -> Bool) -> NameEnv elt -> NameEnv elt
filterNameEnv (Name -> Bool
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) (LinkerEnv -> ItblEnv
itbl_env LinkerEnv
le)
  , addr_env :: AddrEnv
addr_env    = forall elt. (elt -> Bool) -> NameEnv elt -> NameEnv elt
filterNameEnv (Name -> Bool
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) (LinkerEnv -> AddrEnv
addr_env LinkerEnv
le)
  }

type ClosureEnv = NameEnv (Name, ForeignHValue)

emptyClosureEnv :: ClosureEnv
emptyClosureEnv :: ClosureEnv
emptyClosureEnv = forall a. NameEnv a
emptyNameEnv

extendClosureEnv :: ClosureEnv -> [(Name,ForeignHValue)] -> ClosureEnv
extendClosureEnv :: ClosureEnv -> [(Name, ForeignHValue)] -> ClosureEnv
extendClosureEnv ClosureEnv
cl_env [(Name, ForeignHValue)]
pairs
  = 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) =
    forall doc. IsDoc doc => [doc] -> doc
vcat [forall a. Outputable a => a -> SDoc
ppr UnitId
uid
         , forall a. Outputable a => a -> SDoc
ppr [LibrarySpec]
hs_objs
         , forall a. Outputable a => a -> SDoc
ppr [LibrarySpec]
non_hs_objs
         , 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 = 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 = 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 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)
     = (forall doc. IsLine doc => FilePath -> doc
text FilePath
"LinkableM" forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => doc -> doc
parens (forall doc. IsLine doc => FilePath -> doc
text (forall a. Show a => a -> FilePath
show UTCTime
when_made)) forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Module
mod)
       forall doc. IsDoc doc => doc -> doc -> doc
$$ Int -> SDoc -> SDoc
nest Int
3 (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)   = forall doc. IsLine doc => FilePath -> doc
text FilePath
"DotO" forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => FilePath -> doc
text FilePath
path
  ppr (DotA FilePath
path)   = forall doc. IsLine doc => FilePath -> doc
text FilePath
"DotA" forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => FilePath -> doc
text FilePath
path
  ppr (DotDLL FilePath
path) = forall doc. IsLine doc => FilePath -> doc
text FilePath
"DotDLL" forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => FilePath -> doc
text FilePath
path
  ppr (BCOs CompiledByteCode
bcos [SptEntry]
spt) = forall doc. IsLine doc => FilePath -> doc
text FilePath
"BCOs" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr CompiledByteCode
bcos forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr [SptEntry]
spt
  ppr (LoadedBCOs{})  = forall doc. IsLine doc => FilePath -> doc
text FilePath
"LoadedBCOs"
  ppr (CoreBindings {})       = 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) = forall a. Outputable a => a -> SDoc
ppr Id
id forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
colon forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Fingerprint
fpr


isObjectLinkable :: Linkable -> Bool
isObjectLinkable :: Linkable -> Bool
isObjectLinkable Linkable
l = Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Unlinked]
unlinked) Bool -> Bool -> 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 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)   = forall a. a -> Maybe a
Just FilePath
fn
nameOfObject_maybe (DotA FilePath
fn)   = forall a. a -> Maybe a
Just FilePath
fn
nameOfObject_maybe (DotDLL FilePath
fn) = forall a. a -> Maybe a
Just FilePath
fn
nameOfObject_maybe (CoreBindings {}) = forall a. Maybe a
Nothing
nameOfObject_maybe (LoadedBCOs{}) = forall a. Maybe a
Nothing
nameOfObject_maybe (BCOs {})   = 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 = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"nameOfObject" (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) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Unlinked -> [CompiledByteCode]
byteCodeOfObject [Unlinked]
ul
byteCodeOfObject Unlinked
other       = forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"byteCodeOfObject" (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) = forall doc. IsLine doc => FilePath -> doc
text FilePath
"Objects" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr (forall a b. (a -> b) -> [a] -> [b]
map (forall doc. IsLine doc => FilePath -> doc
text @SDoc) [FilePath]
objs)
  ppr (Archive FilePath
a) = forall doc. IsLine doc => FilePath -> doc
text FilePath
"Archive" forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => FilePath -> doc
text FilePath
a
  ppr (DLL FilePath
s) = forall doc. IsLine doc => FilePath -> doc
text FilePath
"DLL" forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => FilePath -> doc
text FilePath
s
  ppr (DLLPath FilePath
f) = forall doc. IsLine doc => FilePath -> doc
text FilePath
"DLLPath" forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => FilePath -> doc
text FilePath
f
  ppr (Framework FilePath
s) = forall doc. IsLine doc => FilePath -> doc
text FilePath
"Framework" forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => FilePath -> doc
text FilePath
s