{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE LambdaCase #-}

-----------------------------------------------------------------------------
--
-- Types for the linkers and the loader
--
-- (c) The University of Glasgow 2019
--
-----------------------------------------------------------------------------
module GHC.Linker.Types
   ( Loader (..)
   , LoaderState (..)
   , uninitializedLoader
   , modifyClosureEnv
   , LinkerEnv(..)
   , filterLinkerEnv
   , ClosureEnv
   , emptyClosureEnv
   , extendClosureEnv
   , LinkableSet
   , mkLinkableSet
   , unionLinkableSet
   , ObjFile
   , SptEntry(..)
   , LibrarySpec(..)
   , LoadedPkgInfo(..)
   , PkgsLoaded

   -- * Linkable
   , Linkable(..)
   , LinkablePart(..)
   , LinkableObjectSort (..)
   , linkableIsNativeCodeOnly
   , linkableObjs
   , linkableLibs
   , linkableFiles
   , linkableBCOs
   , linkableNativeParts
   , linkablePartitionParts
   , linkablePartPath
   , linkablePartAllBCOs
   , isNativeCode
   , isNativeLib
   , linkableFilterByteCode
   , linkableFilterNative
   , partitionLinkables
   )
where

import GHC.Prelude
import GHC.Unit                ( UnitId, Module )
import GHC.ByteCode.Types      ( ItblEnv, AddrEnv, CompiledByteCode )
import GHCi.RemoteTypes        ( ForeignHValue, RemotePtr )
import GHCi.Message            ( LoadedDLL )

import GHC.Types.Name.Env      ( NameEnv, emptyNameEnv, extendNameEnvList, filterNameEnv )
import GHC.Types.Name          ( Name )
import GHC.Types.SptEntry

import GHC.Utils.Outputable

import Control.Concurrent.MVar
import Data.Time               ( UTCTime )
import GHC.Unit.Module.Env
import GHC.Types.Unique.DSet
import GHC.Types.Unique.DFM
import GHC.Unit.Module.WholeCoreBindings
import Data.Maybe (mapMaybe)
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import qualified Data.List.NonEmpty as NE


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

                        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.

Note [Looking up symbols in the relevant objects]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In #23415, we determined that a lot of time (>10s, or even up to >35s!) was
being spent on dynamically loading symbols before actually interpreting code
when `:main` was run in GHCi. The root cause was that for each symbol we wanted
to lookup, we would traverse the list of loaded objects and try find the symbol
in each of them with dlsym (i.e. looking up a symbol was, worst case, linear in
the amount of loaded objects).

To drastically improve load time (from +-38 seconds down to +-2s), we now:

1. For every of the native objects loaded for a given unit, store the handles returned by `dlopen`.
  - In `pkgs_loaded` of the `LoaderState`, which maps `UnitId`s to
    `LoadedPkgInfo`s, where the handles live in its field `loaded_pkg_hs_dlls`.

2. When looking up a Name (e.g. `lookupHsSymbol`), find that name's `UnitId` in
    the `pkgs_loaded` mapping,

3. And only look for the symbol (with `dlsym`) on the /handles relevant to that
    unit/, rather than in every loaded object.

Note [Symbols may not be found in pkgs_loaded]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Currently the `pkgs_loaded` mapping only contains the dynamic objects
associated with loaded units. Symbols defined in a static object (e.g. from a
statically-linked Haskell library) are found via the generic `lookupSymbol`
function call by `lookupHsSymbol` when the symbol is not found in any of the
dynamic objects of `pkgs_loaded`.

The rationale here is two-fold:

 * we have only observed major link-time issues in dynamic linking; lookups in
 the RTS linker's static symbol table seem to be fast enough

 * allowing symbol lookups restricted to a single ObjectCode would require the
 maintenance of a symbol table per `ObjectCode`, which would introduce time and
 space overhead

This fallback is further needed because we don't look in the haskell objects
loaded for the home units (see the call to `loadModuleLinkables` in
`loadDependencies`, as opposed to the call to `loadPackages'` in the same
function which updates `pkgs_loaded`). We should ultimately keep track of the
objects loaded (probably in `objs_loaded`, for which `LinkableSet` is a bit
unsatisfactory, see a suggestion in 51c5c4eb1f2a33e4dc88e6a37b7b7c135234ce9b)
and be able to lookup symbols specifically in them too (similarly to
`lookupSymbolInDLL`).
-}

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 LinkablePart 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 -> [RemotePtr LoadedDLL]
loaded_pkg_hs_dlls     :: ![RemotePtr LoadedDLL]
    -- ^ See Note [Looking up symbols in the relevant objects]
  , 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 ]


-- | Information we can use to dynamically link modules into the compiler
data Linkable = Linkable
  { 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 -> NonEmpty LinkablePart
linkableParts :: NonEmpty LinkablePart
    -- ^ Files and chunks of code to link.
 }

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]

-- | Union of LinkableSets.
--
-- In case of conflict, keep the most recent Linkable (as per linkableTime)
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 (Linkable UTCTime
when_made Module
mod NonEmpty LinkablePart
parts)
     = (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Linkable" 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 (NonEmpty LinkablePart -> SDoc
forall a. Outputable a => a -> SDoc
ppr NonEmpty LinkablePart
parts)

type ObjFile = FilePath

-- | Classify the provenance of @.o@ products.
data LinkableObjectSort =
  -- | The object is the final product for a module.
  -- When linking splices, its file extension will be adapted to the
  -- interpreter's way if needed.
  ModuleObject
  |
  -- | The object was created from generated code for foreign stubs or foreign
  -- sources added by the user.
  -- Its file extension must be preserved, since there are no objects for
  -- alternative ways available.
  ForeignObject

-- | Objects which have yet to be linked by the compiler
data LinkablePart
  = DotO
      ObjFile
      -- ^ An object file (.o)
      LinkableObjectSort
      -- ^ Whether the object is an internal, intermediate build product that
      -- should not be adapted to the interpreter's way. Used for foreign stubs
      -- loaded from interfaces.

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

  | LazyBCOs
      CompiledByteCode
      -- ^ Some BCOs generated on-demand when forced. This is used for
      -- WholeCoreBindings, see Note [Interface Files with Core Definitions]
      [FilePath]
      -- ^ Objects containing foreign stubs and files

  | BCOs CompiledByteCode
    -- ^ A byte-code object, lives only in memory.

instance Outputable LinkablePart where
  ppr :: LinkablePart -> SDoc
ppr (DotO FilePath
path LinkableObjectSort
sort)   = 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 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> LinkableObjectSort -> SDoc
pprSort LinkableObjectSort
sort
    where
      pprSort :: LinkableObjectSort -> SDoc
pprSort = \case
        LinkableObjectSort
ModuleObject -> SDoc
forall doc. IsOutput doc => doc
empty
        LinkableObjectSort
ForeignObject -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"foreign")
  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
bco)        = 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
bco
  ppr (LazyBCOs{})      = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"LazyBCOs"
  ppr (CoreBindings {}) = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"CoreBindings"

-- | Return true if the linkable only consists of native code (no BCO)
linkableIsNativeCodeOnly :: Linkable -> Bool
linkableIsNativeCodeOnly :: Linkable -> Bool
linkableIsNativeCodeOnly Linkable
l = (LinkablePart -> Bool) -> [LinkablePart] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all LinkablePart -> Bool
isNativeCode (NonEmpty LinkablePart -> [LinkablePart]
forall a. NonEmpty a -> [a]
NE.toList (Linkable -> NonEmpty LinkablePart
linkableParts Linkable
l))

-- | List the BCOs parts of a linkable.
--
-- This excludes the LazyBCOs and the CoreBindings parts
linkableBCOs :: Linkable -> [CompiledByteCode]
linkableBCOs :: Linkable -> [CompiledByteCode]
linkableBCOs Linkable
l = [ CompiledByteCode
cbc | BCOs CompiledByteCode
cbc <- NonEmpty LinkablePart -> [LinkablePart]
forall a. NonEmpty a -> [a]
NE.toList (Linkable -> NonEmpty LinkablePart
linkableParts Linkable
l) ]

-- | List the native linkable parts (.o/.so/.dll) of a linkable
linkableNativeParts :: Linkable -> [LinkablePart]
linkableNativeParts :: Linkable -> [LinkablePart]
linkableNativeParts Linkable
l = (LinkablePart -> Bool) -> NonEmpty LinkablePart -> [LinkablePart]
forall a. (a -> Bool) -> NonEmpty a -> [a]
NE.filter LinkablePart -> Bool
isNativeCode (Linkable -> NonEmpty LinkablePart
linkableParts Linkable
l)

-- | Split linkable parts into (native code parts, BCOs parts)
linkablePartitionParts :: Linkable -> ([LinkablePart],[LinkablePart])
linkablePartitionParts :: Linkable -> ([LinkablePart], [LinkablePart])
linkablePartitionParts Linkable
l = (LinkablePart -> Bool)
-> NonEmpty LinkablePart -> ([LinkablePart], [LinkablePart])
forall a. (a -> Bool) -> NonEmpty a -> ([a], [a])
NE.partition LinkablePart -> Bool
isNativeCode (Linkable -> NonEmpty LinkablePart
linkableParts Linkable
l)

-- | List the native objects (.o) of a linkable
linkableObjs :: Linkable -> [FilePath]
linkableObjs :: Linkable -> [FilePath]
linkableObjs Linkable
l = (LinkablePart -> [FilePath]) -> NonEmpty LinkablePart -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LinkablePart -> [FilePath]
linkablePartObjectPaths (Linkable -> NonEmpty LinkablePart
linkableParts Linkable
l)

-- | List the native libraries (.so/.dll) of a linkable
linkableLibs :: Linkable -> [LinkablePart]
linkableLibs :: Linkable -> [LinkablePart]
linkableLibs Linkable
l = (LinkablePart -> Bool) -> NonEmpty LinkablePart -> [LinkablePart]
forall a. (a -> Bool) -> NonEmpty a -> [a]
NE.filter LinkablePart -> Bool
isNativeLib (Linkable -> NonEmpty LinkablePart
linkableParts Linkable
l)

-- | List the paths of the native objects and libraries (.o/.so/.dll)
linkableFiles :: Linkable -> [FilePath]
linkableFiles :: Linkable -> [FilePath]
linkableFiles Linkable
l = (LinkablePart -> [FilePath]) -> [LinkablePart] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LinkablePart -> [FilePath]
linkablePartNativePaths (NonEmpty LinkablePart -> [LinkablePart]
forall a. NonEmpty a -> [a]
NE.toList (Linkable -> NonEmpty LinkablePart
linkableParts Linkable
l))

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

-- | Is the part a native object or library? (.o/.so/.dll)
isNativeCode :: LinkablePart -> Bool
isNativeCode :: LinkablePart -> Bool
isNativeCode = \case
  DotO {}         -> Bool
True
  DotA {}         -> Bool
True
  DotDLL {}       -> Bool
True
  BCOs {}         -> Bool
False
  LazyBCOs{}      -> Bool
False
  CoreBindings {} -> Bool
False

-- | Is the part a native library? (.so/.dll)
isNativeLib :: LinkablePart -> Bool
isNativeLib :: LinkablePart -> Bool
isNativeLib = \case
  DotO {}         -> Bool
False
  DotA {}         -> Bool
True
  DotDLL {}       -> Bool
True
  BCOs {}         -> Bool
False
  LazyBCOs{}      -> Bool
False
  CoreBindings {} -> Bool
False

-- | Get the FilePath of linkable part (if applicable)
linkablePartPath :: LinkablePart -> Maybe FilePath
linkablePartPath :: LinkablePart -> Maybe FilePath
linkablePartPath = \case
  DotO FilePath
fn LinkableObjectSort
_       -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
fn
  DotA FilePath
fn         -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
fn
  DotDLL FilePath
fn       -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
fn
  CoreBindings {} -> Maybe FilePath
forall a. Maybe a
Nothing
  LazyBCOs {}     -> Maybe FilePath
forall a. Maybe a
Nothing
  BCOs {}         -> Maybe FilePath
forall a. Maybe a
Nothing

-- | Return the paths of all object code files (.o, .a, .so) contained in this
-- 'LinkablePart'.
linkablePartNativePaths :: LinkablePart -> [FilePath]
linkablePartNativePaths :: LinkablePart -> [FilePath]
linkablePartNativePaths = \case
  DotO FilePath
fn LinkableObjectSort
_       -> [FilePath
fn]
  DotA FilePath
fn         -> [FilePath
fn]
  DotDLL FilePath
fn       -> [FilePath
fn]
  CoreBindings {} -> []
  LazyBCOs CompiledByteCode
_ [FilePath]
fos  -> [FilePath]
fos
  BCOs {}         -> []

-- | Return the paths of all object files (.o) contained in this 'LinkablePart'.
linkablePartObjectPaths :: LinkablePart -> [FilePath]
linkablePartObjectPaths :: LinkablePart -> [FilePath]
linkablePartObjectPaths = \case
  DotO FilePath
fn LinkableObjectSort
_ -> [FilePath
fn]
  DotA FilePath
_ -> []
  DotDLL FilePath
_ -> []
  CoreBindings {} -> []
  LazyBCOs CompiledByteCode
_ [FilePath]
fos -> [FilePath]
fos
  BCOs {} -> []

-- | Retrieve the compiled byte-code from the linkable part.
--
-- Contrary to linkableBCOs, this includes byte-code from LazyBCOs.
linkablePartAllBCOs :: LinkablePart -> [CompiledByteCode]
linkablePartAllBCOs :: LinkablePart -> [CompiledByteCode]
linkablePartAllBCOs = \case
  BCOs CompiledByteCode
bco    -> [CompiledByteCode
bco]
  LazyBCOs CompiledByteCode
bcos [FilePath]
_ -> [CompiledByteCode
bcos]
  LinkablePart
_           -> []

linkableFilter :: (LinkablePart -> [LinkablePart]) -> Linkable -> Maybe Linkable
linkableFilter :: (LinkablePart -> [LinkablePart]) -> Linkable -> Maybe Linkable
linkableFilter LinkablePart -> [LinkablePart]
f Linkable
linkable = do
  new <- [LinkablePart] -> Maybe (NonEmpty LinkablePart)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ((LinkablePart -> [LinkablePart])
-> NonEmpty LinkablePart -> [LinkablePart]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap LinkablePart -> [LinkablePart]
f (Linkable -> NonEmpty LinkablePart
linkableParts Linkable
linkable))
  Just linkable {linkableParts = new}

linkablePartNative :: LinkablePart -> [LinkablePart]
linkablePartNative :: LinkablePart -> [LinkablePart]
linkablePartNative = \case
  u :: LinkablePart
u@DotO {}  -> [LinkablePart
u]
  u :: LinkablePart
u@DotA {} -> [LinkablePart
u]
  u :: LinkablePart
u@DotDLL {} -> [LinkablePart
u]
  LazyBCOs CompiledByteCode
_ [FilePath]
os -> [FilePath -> LinkableObjectSort -> LinkablePart
DotO FilePath
f LinkableObjectSort
ForeignObject | FilePath
f <- [FilePath]
os]
  LinkablePart
_ -> []

linkablePartByteCode :: LinkablePart -> [LinkablePart]
linkablePartByteCode :: LinkablePart -> [LinkablePart]
linkablePartByteCode = \case
  u :: LinkablePart
u@BCOs {}  -> [LinkablePart
u]
  LazyBCOs CompiledByteCode
bcos [FilePath]
_ -> [CompiledByteCode -> LinkablePart
BCOs CompiledByteCode
bcos]
  LinkablePart
_ -> []

-- | Transform the 'LinkablePart' list in this 'Linkable' to contain only
-- object code files (.o, .a, .so) without 'LazyBCOs'.
-- If no 'LinkablePart' remains, return 'Nothing'.
linkableFilterNative :: Linkable -> Maybe Linkable
linkableFilterNative :: Linkable -> Maybe Linkable
linkableFilterNative = (LinkablePart -> [LinkablePart]) -> Linkable -> Maybe Linkable
linkableFilter LinkablePart -> [LinkablePart]
linkablePartNative

-- | Transform the 'LinkablePart' list in this 'Linkable' to contain only byte
-- code without 'LazyBCOs'.
-- If no 'LinkablePart' remains, return 'Nothing'.
linkableFilterByteCode :: Linkable -> Maybe Linkable
linkableFilterByteCode :: Linkable -> Maybe Linkable
linkableFilterByteCode = (LinkablePart -> [LinkablePart]) -> Linkable -> Maybe Linkable
linkableFilter LinkablePart -> [LinkablePart]
linkablePartByteCode

-- | Split the 'LinkablePart' lists in each 'Linkable' into only object code
-- files (.o, .a, .so) and only byte code, without 'LazyBCOs', and return two
-- lists containing the nonempty 'Linkable's for each.
partitionLinkables :: [Linkable] -> ([Linkable], [Linkable])
partitionLinkables :: [Linkable] -> ([Linkable], [Linkable])
partitionLinkables [Linkable]
linkables =
  (
    (Linkable -> Maybe Linkable) -> [Linkable] -> [Linkable]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Linkable -> Maybe Linkable
linkableFilterNative [Linkable]
linkables,
    (Linkable -> Maybe Linkable) -> [Linkable] -> [Linkable]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Linkable -> Maybe Linkable
linkableFilterByteCode [Linkable]
linkables
  )

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

                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