module GHC.Linker.MacOS
   ( runInjectRPaths
   , getUnitFrameworks
   , getUnitFrameworkOpts
   , getUnitFrameworkPath
   , getFrameworkOpts
   , loadFramework
   )
where

import GHC.Prelude
import GHC.Platform

import GHC.Driver.Session
import GHC.Driver.Env

import GHC.Unit.Types
import GHC.Unit.State
import GHC.Unit.Home

import GHC.SysTools.Tasks

import GHC.Runtime.Interpreter (loadDLL)

import GHC.Utils.Outputable
import GHC.Utils.Exception
import GHC.Utils.Misc (ordNub )

import qualified GHC.Data.ShortText as ST

import Data.List
import Control.Monad (join, forM, filterM)
import System.Directory (doesFileExist, getHomeDirectory)
import System.FilePath ((</>), (<.>))

-- | On macOS we rely on the linkers @-dead_strip_dylibs@ flag to remove unused
-- libraries from the dynamic library.  We do this to reduce the number of load
-- commands that end up in the dylib, and has been limited to 32K (32768) since
-- macOS Sierra (10.14).
--
-- @-dead_strip_dylibs@ does not dead strip @-rpath@ entries, as such passing
-- @-l@ and @-rpath@ to the linker will result in the unnecesasry libraries not
-- being included in the load commands, however the @-rpath@ entries are all
-- forced to be included.  This can lead to 100s of @-rpath@ entries being
-- included when only a handful of libraries end up being truely linked.
--
-- Thus after building the library, we run a fixup phase where we inject the
-- @-rpath@ for each found library (in the given library search paths) into the
-- dynamic library through @-add_rpath@.
--
-- See Note [Dynamic linking on macOS]
runInjectRPaths :: DynFlags -> [FilePath] -> FilePath -> IO ()
runInjectRPaths :: DynFlags -> [FilePath] -> FilePath -> IO ()
runInjectRPaths DynFlags
dflags [FilePath]
lib_paths FilePath
dylib = do
  [FilePath]
info <- FilePath -> [FilePath]
lines (FilePath -> [FilePath]) -> IO FilePath -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynFlags -> Maybe FilePath -> [Option] -> IO FilePath
askOtool DynFlags
dflags Maybe FilePath
forall a. Maybe a
Nothing [FilePath -> Option
Option FilePath
"-L", FilePath -> Option
Option FilePath
dylib]
  -- filter the output for only the libraries. And then drop the @rpath prefix.
  let libs :: [FilePath]
libs = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop Int
7) ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf FilePath
"@rpath") ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([FilePath] -> FilePath
forall a. [a] -> a
head([FilePath] -> FilePath)
-> (FilePath -> [FilePath]) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
.FilePath -> [FilePath]
words) ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ [FilePath]
info
  -- find any pre-existing LC_PATH items
  [[FilePath]]
info <- (FilePath -> [FilePath]) -> [FilePath] -> [[FilePath]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> [FilePath]
words([FilePath] -> [[FilePath]])
-> (FilePath -> [FilePath]) -> FilePath -> [[FilePath]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.FilePath -> [FilePath]
lines (FilePath -> [[FilePath]]) -> IO FilePath -> IO [[FilePath]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynFlags -> Maybe FilePath -> [Option] -> IO FilePath
askOtool DynFlags
dflags Maybe FilePath
forall a. Maybe a
Nothing [FilePath -> Option
Option FilePath
"-l", FilePath -> Option
Option FilePath
dylib]
  let paths :: [FilePath]
paths = ([FilePath] -> [FilePath]) -> [[FilePath]] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [FilePath] -> [FilePath]
f [[FilePath]]
info
        where f :: [FilePath] -> [FilePath]
f (FilePath
"path":FilePath
p:[FilePath]
_) = [FilePath
p]
              f [FilePath]
_            = []
      lib_paths' :: [FilePath]
lib_paths' = [ FilePath
p | FilePath
p <- [FilePath]
lib_paths, Bool -> Bool
not (FilePath
p FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
paths) ]
  -- only find those rpaths, that aren't already in the library.
  [FilePath]
rpaths <- [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub ([FilePath] -> [FilePath])
-> ([[FilePath]] -> [FilePath]) -> [[FilePath]] -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
sort ([FilePath] -> [FilePath])
-> ([[FilePath]] -> [FilePath]) -> [[FilePath]] -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[FilePath]] -> [FilePath]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[FilePath]] -> [FilePath]) -> IO [[FilePath]] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath] -> (FilePath -> IO [FilePath]) -> IO [[FilePath]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
libs (\FilePath
f -> (FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (\FilePath
l -> FilePath -> IO Bool
doesFileExist (FilePath
l FilePath -> FilePath -> FilePath
</> FilePath
f)) [FilePath]
lib_paths')
  -- inject the rpaths
  case [FilePath]
rpaths of
    [] -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [FilePath]
_  -> DynFlags -> [Option] -> IO ()
runInstallNameTool DynFlags
dflags ([Option] -> IO ()) -> [Option] -> IO ()
forall a b. (a -> b) -> a -> b
$ (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Option
Option ([FilePath] -> [Option]) -> [FilePath] -> [Option]
forall a b. (a -> b) -> a -> b
$ FilePath
"-add_rpath"FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:(FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
intersperse FilePath
"-add_rpath" [FilePath]
rpaths) [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
dylib]

getUnitFrameworkOpts :: DynFlags -> Platform -> [UnitId] -> IO [String]
getUnitFrameworkOpts :: DynFlags -> Platform -> [UnitId] -> IO [FilePath]
getUnitFrameworkOpts DynFlags
dflags Platform
platform [UnitId]
dep_packages
  | Platform -> Bool
platformUsesFrameworks Platform
platform = do
    [FilePath]
pkg_framework_path_opts <- do
        [FilePath]
pkg_framework_paths <- SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [FilePath]
getUnitFrameworkPath
                                 (DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
defaultUserStyle)
                                 (DynFlags -> UnitState
unitState DynFlags
dflags)
                                 (DynFlags -> HomeUnit
mkHomeUnitFromFlags DynFlags
dflags)
                                 [UnitId]
dep_packages
        [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
"-F" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) [FilePath]
pkg_framework_paths

    [FilePath]
pkg_framework_opts <- do
        [FilePath]
pkg_frameworks <- SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [FilePath]
getUnitFrameworks
                              (DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
defaultUserStyle)
                              (DynFlags -> UnitState
unitState DynFlags
dflags)
                              (DynFlags -> HomeUnit
mkHomeUnitFromFlags DynFlags
dflags)
                              [UnitId]
dep_packages
        [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [FilePath
"-framework", FilePath
fw] | FilePath
fw <- [FilePath]
pkg_frameworks ]

    [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath]
pkg_framework_path_opts [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
pkg_framework_opts)

  | Bool
otherwise = [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return []

getFrameworkOpts :: DynFlags -> Platform -> [String]
getFrameworkOpts :: DynFlags -> Platform -> [FilePath]
getFrameworkOpts DynFlags
dflags Platform
platform
  | Platform -> Bool
platformUsesFrameworks Platform
platform = [FilePath]
framework_path_opts [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
framework_opts
  | Bool
otherwise = []
  where
    framework_paths :: [FilePath]
framework_paths     = DynFlags -> [FilePath]
frameworkPaths DynFlags
dflags
    framework_path_opts :: [FilePath]
framework_path_opts = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
"-F" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) [FilePath]
framework_paths

    frameworks :: [FilePath]
frameworks     = DynFlags -> [FilePath]
cmdlineFrameworks DynFlags
dflags
    -- reverse because they're added in reverse order from the cmd line:
    framework_opts :: [FilePath]
framework_opts = [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [FilePath
"-framework", FilePath
fw]
                            | FilePath
fw <- [FilePath] -> [FilePath]
forall a. [a] -> [a]
reverse [FilePath]
frameworks ]


-- | Find all the package framework paths in these and the preload packages
getUnitFrameworkPath :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [String]
getUnitFrameworkPath :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [FilePath]
getUnitFrameworkPath SDocContext
ctx UnitState
unit_state HomeUnit
home_unit [UnitId]
pkgs = do
  [UnitInfo]
ps <- SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [UnitInfo]
getPreloadUnitsAnd SDocContext
ctx UnitState
unit_state HomeUnit
home_unit [UnitId]
pkgs
  [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ (ShortText -> FilePath) -> [ShortText] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ShortText -> FilePath
ST.unpack ([ShortText] -> [ShortText]
forall a. Ord a => [a] -> [a]
ordNub ((ShortText -> Bool) -> [ShortText] -> [ShortText]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (ShortText -> Bool) -> ShortText -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortText -> Bool
ST.null) ((UnitInfo -> [ShortText]) -> [UnitInfo] -> [ShortText]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap UnitInfo -> [ShortText]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitExtDepFrameworkDirs [UnitInfo]
ps)))

-- | Find all the package frameworks in these and the preload packages
getUnitFrameworks :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [String]
getUnitFrameworks :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [FilePath]
getUnitFrameworks SDocContext
ctx UnitState
unit_state HomeUnit
home_unit [UnitId]
pkgs = do
  [UnitInfo]
ps <- SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [UnitInfo]
getPreloadUnitsAnd SDocContext
ctx UnitState
unit_state HomeUnit
home_unit [UnitId]
pkgs
  [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ (ShortText -> FilePath) -> [ShortText] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ShortText -> FilePath
ST.unpack ((UnitInfo -> [ShortText]) -> [UnitInfo] -> [ShortText]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap UnitInfo -> [ShortText]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitExtDepFrameworks [UnitInfo]
ps)


{-
Note [macOS Big Sur dynamic libraries]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

macOS Big Sur makes the following change to how frameworks are shipped
with the OS:

> New in macOS Big Sur 11 beta, the system ships with a built-in
> dynamic linker cache of all system-provided libraries.  As part of
> this change, copies of dynamic libraries are no longer present on
> the filesystem.  Code that attempts to check for dynamic library
> presence by looking for a file at a path or enumerating a directory
> will fail.  Instead, check for library presence by attempting to
> dlopen() the path, which will correctly check for the library in the
> cache. (62986286)

(https://developer.apple.com/documentation/macos-release-notes/macos-big-sur-11-beta-release-notes/)

Therefore, the previous method of checking whether a library exists
before attempting to load it makes GHC.Linker.MacOS.loadFramework
fail to find frameworks installed at /System/Library/Frameworks.
Instead, any attempt to load a framework at runtime, such as by
passing -framework OpenGL to runghc or running code loading such a
framework with GHCi, fails with a 'not found' message.

GHC.Linker.MacOS.loadFramework now opportunistically loads the
framework libraries without checking for their existence first,
failing only if all attempts to load a given framework from any of the
various possible locations fail.  See also #18446, which this change
addresses.
-}

-- Darwin / MacOS X only: load a framework
-- a framework is a dynamic library packaged inside a directory of the same
-- name. They are searched for in different paths than normal libraries.
loadFramework :: HscEnv -> [FilePath] -> FilePath -> IO (Maybe String)
loadFramework :: HscEnv -> [FilePath] -> FilePath -> IO (Maybe FilePath)
loadFramework HscEnv
hsc_env [FilePath]
extraPaths FilePath
rootname
   = do { Either IOException FilePath
either_dir <- IO FilePath -> IO (Either IOException FilePath)
forall a. IO a -> IO (Either IOException a)
tryIO IO FilePath
getHomeDirectory
        ; let homeFrameworkPath :: [FilePath]
homeFrameworkPath = case Either IOException FilePath
either_dir of
                                  Left IOException
_ -> []
                                  Right FilePath
dir -> [FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
"Library/Frameworks"]
              ps :: [FilePath]
ps = [FilePath]
extraPaths [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
homeFrameworkPath [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
defaultFrameworkPaths
        ; Maybe [FilePath]
errs <- [FilePath] -> [FilePath] -> IO (Maybe [FilePath])
findLoadDLL [FilePath]
ps []
        ; Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath -> IO (Maybe FilePath))
-> Maybe FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ ([FilePath] -> FilePath) -> Maybe [FilePath] -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", ") Maybe [FilePath]
errs
        }
   where
     fwk_file :: FilePath
fwk_file = FilePath
rootname FilePath -> FilePath -> FilePath
<.> FilePath
"framework" FilePath -> FilePath -> FilePath
</> FilePath
rootname

     -- sorry for the hardcoded paths, I hope they won't change anytime soon:
     defaultFrameworkPaths :: [FilePath]
defaultFrameworkPaths = [FilePath
"/Library/Frameworks", FilePath
"/System/Library/Frameworks"]

     -- Try to call loadDLL for each candidate path.
     --
     -- See Note [macOS Big Sur dynamic libraries]
     findLoadDLL :: [FilePath] -> [FilePath] -> IO (Maybe [FilePath])
findLoadDLL [] [FilePath]
errs =
       -- Tried all our known library paths, but dlopen()
       -- has no built-in paths for frameworks: give up
       Maybe [FilePath] -> IO (Maybe [FilePath])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [FilePath] -> IO (Maybe [FilePath]))
-> Maybe [FilePath] -> IO (Maybe [FilePath])
forall a b. (a -> b) -> a -> b
$ [FilePath] -> Maybe [FilePath]
forall a. a -> Maybe a
Just [FilePath]
errs
     findLoadDLL (FilePath
p:[FilePath]
ps) [FilePath]
errs =
       do { Maybe FilePath
dll <- HscEnv -> FilePath -> IO (Maybe FilePath)
loadDLL HscEnv
hsc_env (FilePath
p FilePath -> FilePath -> FilePath
</> FilePath
fwk_file)
          ; case Maybe FilePath
dll of
              Maybe FilePath
Nothing  -> Maybe [FilePath] -> IO (Maybe [FilePath])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [FilePath]
forall a. Maybe a
Nothing
              Just FilePath
err -> [FilePath] -> [FilePath] -> IO (Maybe [FilePath])
findLoadDLL [FilePath]
ps ((FilePath
p FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
err)FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
errs)
          }