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

import GHC.Prelude
import GHC.Platform

import GHC.Driver.Session

import GHC.Unit.Types
import GHC.Unit.State
import GHC.Unit.Env

import GHC.SysTools.Tasks

import GHC.Runtime.Interpreter

import GHC.Utils.Exception
import GHC.Utils.Logger

import Data.List (isPrefixOf, nub, sort, intersperse, intercalate)
import Data.Char
import Data.Maybe
import Control.Monad (join, forM, filterM, void)
import System.Directory (doesFileExist, getHomeDirectory)
import System.FilePath ((</>), (<.>))
import Text.ParserCombinators.ReadP as Parser

-- | 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 truly 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 :: Logger -> DynFlags -> [FilePath] -> FilePath -> IO ()
-- Make sure to honour -fno-use-rpaths if set on darwin as well see #20004
runInjectRPaths :: Logger -> DynFlags -> [FilePath] -> FilePath -> IO ()
runInjectRPaths Logger
_ DynFlags
dflags [FilePath]
_ FilePath
_ | Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_RPath DynFlags
dflags) = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
runInjectRPaths Logger
logger 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
<$> Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO FilePath
askOtool Logger
logger 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]
lines (FilePath -> [FilePath]) -> IO FilePath -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO FilePath
askOtool Logger
logger DynFlags
dflags Maybe FilePath
forall a. Maybe a
Nothing [FilePath -> Option
Option FilePath
"-l", FilePath -> Option
Option FilePath
dylib]
  let paths :: [FilePath]
paths = (FilePath -> Maybe FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FilePath -> Maybe FilePath
get_rpath [FilePath]
info
      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]
_  -> Logger -> DynFlags -> [Option] -> IO ()
runInstallNameTool Logger
logger 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]

get_rpath :: String -> Maybe FilePath
get_rpath :: FilePath -> Maybe FilePath
get_rpath FilePath
l = case ReadP FilePath -> ReadS FilePath
forall a. ReadP a -> ReadS a
readP_to_S ReadP FilePath
rpath_parser FilePath
l of
                [(FilePath
rpath, FilePath
"")] -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
rpath
                [(FilePath, FilePath)]
_ -> Maybe FilePath
forall a. Maybe a
Nothing


rpath_parser :: ReadP FilePath
rpath_parser :: ReadP FilePath
rpath_parser = do
  ReadP ()
skipSpaces
  ReadP FilePath -> ReadP ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReadP FilePath -> ReadP ()) -> ReadP FilePath -> ReadP ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ReadP FilePath
string FilePath
"path"
  ReadP FilePath -> ReadP ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReadP FilePath -> ReadP ()) -> ReadP FilePath -> ReadP ()
forall a b. (a -> b) -> a -> b
$ ReadP Char -> ReadP FilePath
forall a. ReadP a -> ReadP [a]
many1 ((Char -> Bool) -> ReadP Char
satisfy Char -> Bool
isSpace)
  FilePath
rpath <- ReadP Char -> ReadP FilePath
forall a. ReadP a -> ReadP [a]
many ReadP Char
get
  ReadP FilePath -> ReadP ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReadP FilePath -> ReadP ()) -> ReadP FilePath -> ReadP ()
forall a b. (a -> b) -> a -> b
$ ReadP Char -> ReadP FilePath
forall a. ReadP a -> ReadP [a]
many1 ((Char -> Bool) -> ReadP Char
satisfy Char -> Bool
isSpace)
  ReadP FilePath -> ReadP ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReadP FilePath -> ReadP ()) -> ReadP FilePath -> ReadP ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ReadP FilePath
string FilePath
"(offset "
  ReadP FilePath -> ReadP ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReadP FilePath -> ReadP ()) -> ReadP FilePath -> ReadP ()
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ReadP FilePath
munch1 Char -> Bool
isDigit
  ReadP Char -> ReadP ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReadP Char -> ReadP ()) -> ReadP Char -> ReadP ()
forall a b. (a -> b) -> a -> b
$ Char -> ReadP Char
Parser.char Char
')'
  ReadP ()
skipSpaces
  FilePath -> ReadP FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
rpath


getUnitFrameworkOpts :: UnitEnv -> [UnitId] -> IO [String]
getUnitFrameworkOpts :: UnitEnv -> [UnitId] -> IO [FilePath]
getUnitFrameworkOpts UnitEnv
unit_env [UnitId]
dep_packages
  | Platform -> Bool
platformUsesFrameworks (UnitEnv -> Platform
ue_platform UnitEnv
unit_env) = do
        [UnitInfo]
ps <- MaybeErr UnitErr [UnitInfo] -> IO [UnitInfo]
forall a. MaybeErr UnitErr a -> IO a
mayThrowUnitErr (UnitEnv -> [UnitId] -> MaybeErr UnitErr [UnitInfo]
preloadUnitsInfo' UnitEnv
unit_env [UnitId]
dep_packages)
        let pkg_framework_path_opts :: [FilePath]
pkg_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]
++) ([UnitInfo] -> [FilePath]
collectFrameworksDirs [UnitInfo]
ps)
            pkg_framework_opts :: [FilePath]
pkg_framework_opts      = [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [FilePath
"-framework", FilePath
fw]
                                             | FilePath
fw <- [UnitInfo] -> [FilePath]
collectFrameworks [UnitInfo]
ps
                                             ]
        [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 ]


{-
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 :: Interp -> [FilePath] -> FilePath -> IO (Maybe String)
loadFramework :: Interp -> [FilePath] -> FilePath -> IO (Maybe FilePath)
loadFramework Interp
interp [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 <- Interp -> FilePath -> IO (Maybe FilePath)
loadDLL Interp
interp (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)
          }