[Git][ghc/ghc][master] Implement executablePath for Solaris and make getBaseDir less platform-dependent
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sun Apr 23 17:39:48 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
499a1c20 by PHO at 2023-04-23T13:39:32-04:00
Implement executablePath for Solaris and make getBaseDir less platform-dependent
Use base-4.17 executablePath when possible, and fall back on
getExecutablePath when it's not available. The sole reason why getBaseDir
had #ifdef's was apparently that getExecutablePath wasn't reliable, and we
could reduce the number of CPP conditionals by making use of
executablePath instead.
Also export executablePath on js_HOST_ARCH.
- - - - -
3 changed files:
- libraries/base/System/Environment.hs
- libraries/base/System/Environment/ExecutablePath.hsc
- libraries/ghc-boot/GHC/BaseDir.hs
Changes:
=====================================
libraries/base/System/Environment.hs
=====================================
@@ -19,9 +19,7 @@ module System.Environment
(
getArgs,
getProgName,
-#if !defined(javascript_HOST_ARCH)
executablePath,
-#endif
getExecutablePath,
getEnv,
lookupEnv,
=====================================
libraries/base/System/Environment/ExecutablePath.hsc
=====================================
@@ -18,9 +18,7 @@
module System.Environment.ExecutablePath
( getExecutablePath
-##if !defined(javascript_HOST_ARCH)
, executablePath
-##endif
) where
##if defined(javascript_HOST_ARCH)
@@ -28,6 +26,9 @@ module System.Environment.ExecutablePath
getExecutablePath :: IO FilePath
getExecutablePath = return "a.jsexe"
+executablePath :: Maybe (IO (Maybe FilePath))
+executablePath = Nothing
+
##else
-- The imports are purposely kept completely disjoint to prevent edits
@@ -47,6 +48,12 @@ import Data.List (isSuffixOf)
import Foreign.C
import Foreign.Marshal.Array
import System.Posix.Internals
+#elif defined(solaris2_HOST_OS)
+import Control.Exception (catch, throw)
+import Foreign.C
+import Foreign.Marshal.Array
+import System.IO.Error (isDoesNotExistError)
+import System.Posix.Internals
#elif defined(freebsd_HOST_OS) || defined(netbsd_HOST_OS)
import Control.Exception (catch, throw)
import Foreign.C
@@ -101,7 +108,7 @@ getExecutablePath :: IO FilePath
--
-- If the operating system provides a reliable way to determine the current
-- executable, return the query action, otherwise return @Nothing at . The action
--- is defined on FreeBSD, Linux, MacOS, NetBSD, and Windows.
+-- is defined on FreeBSD, Linux, MacOS, NetBSD, Solaris, and Windows.
--
-- Even where the query action is defined, there may be situations where no
-- result is available, e.g. if the executable file was deleted while the
@@ -171,9 +178,9 @@ executablePath = Just (fmap Just getExecutablePath `catch` f)
| otherwise = throw e
--------------------------------------------------------------------------------
--- Linux
+-- Linux / Solaris
-#elif defined(linux_HOST_OS)
+#elif defined(linux_HOST_OS) || defined(solaris2_HOST_OS)
foreign import ccall unsafe "readlink"
c_readlink :: CString -> CString -> CSize -> IO CInt
@@ -190,6 +197,7 @@ readSymbolicLink file =
c_readlink s buf 4096
peekFilePathLen (buf,fromIntegral len)
+# if defined(linux_HOST_OS)
getExecutablePath = readSymbolicLink $ "/proc/self/exe"
executablePath = Just (check <$> getExecutablePath) where
@@ -200,6 +208,18 @@ executablePath = Just (check <$> getExecutablePath) where
check s | "(deleted)" `isSuffixOf` s = Nothing
| otherwise = Just s
+# elif defined(solaris2_HOST_OS)
+getExecutablePath = readSymbolicLink "/proc/self/path/a.out"
+
+executablePath = Just ((Just <$> getExecutablePath) `catch` f)
+ where
+ -- readlink(2) fails with ENOENT when the executable has been deleted,
+ -- even though the symlink itself still exists according to readdir(3).
+ f e | isDoesNotExistError e = pure Nothing
+ | otherwise = throw e
+
+#endif
+
--------------------------------------------------------------------------------
-- FreeBSD / NetBSD
=====================================
libraries/ghc-boot/GHC/BaseDir.hs
=====================================
@@ -12,7 +12,11 @@
-- installation location at build time. ghc-pkg also can expand those variables
-- and so needs the top dir location to do that too.
-module GHC.BaseDir where
+module GHC.BaseDir
+ ( expandTopDir
+ , expandPathVar
+ , getBaseDir
+ ) where
import Prelude -- See Note [Why do we import Prelude here?]
@@ -20,11 +24,9 @@ import Data.List (stripPrefix)
import Data.Maybe (listToMaybe)
import System.FilePath
--- Windows
-#if defined(mingw32_HOST_OS)
-import System.Environment (getExecutablePath)
--- POSIX
-#elif defined(darwin_HOST_OS) || defined(linux_HOST_OS) || defined(freebsd_HOST_OS) || defined(openbsd_HOST_OS) || defined(netbsd_HOST_OS)
+#if MIN_VERSION_base(4,17,0)
+import System.Environment (executablePath)
+#else
import System.Environment (getExecutablePath)
#endif
@@ -43,17 +45,27 @@ expandPathVar var value str
expandPathVar var value (x:xs) = x : expandPathVar var value xs
expandPathVar _ _ [] = []
+#if !MIN_VERSION_base(4,17,0)
+-- Polyfill for base-4.17 executablePath
+executablePath :: Maybe (IO (Maybe FilePath))
+executablePath = Just (Just <$> getExecutablePath)
+#elif !MIN_VERSION_base(4,18,0) && defined(js_HOST_ARCH)
+-- executablePath is missing from base < 4.18.0 on js_HOST_ARCH
+executablePath :: Maybe (IO (Maybe FilePath))
+executablePath = Nothing
+#endif
+
-- | Calculate the location of the base dir
getBaseDir :: IO (Maybe String)
#if defined(mingw32_HOST_OS)
-getBaseDir = Just . (\p -> p </> "lib") . rootDir <$> getExecutablePath
+getBaseDir = maybe (pure Nothing) ((((</> "lib") . rootDir) <$>) <$>) executablePath
where
-- locate the "base dir" when given the path
-- to the real ghc executable (as opposed to symlink)
-- that is running this function.
rootDir :: FilePath -> FilePath
rootDir = takeDirectory . takeDirectory . normalise
-#elif defined(darwin_HOST_OS) || defined(linux_HOST_OS) || defined(freebsd_HOST_OS) || defined(openbsd_HOST_OS) || defined(netbsd_HOST_OS)
+#else
-- on unix, this is a bit more confusing.
-- The layout right now is something like
--
@@ -65,14 +77,15 @@ getBaseDir = Just . (\p -> p </> "lib") . rootDir <$> getExecutablePath
-- As such, we first need to find the absolute location to the
-- binary.
--
--- getExecutablePath will return (3). One takeDirectory will
+-- executablePath will return (3). One takeDirectory will
-- give use /lib/ghc-X.Y.Z/bin, and another will give us (4).
--
-- This of course only works due to the current layout. If
-- the layout is changed, such that we have ghc-X.Y.Z/{bin,lib}
-- this would need to be changed accordingly.
--
-getBaseDir = Just . (\p -> p </> "lib") . takeDirectory . takeDirectory <$> getExecutablePath
-#else
-getBaseDir = return Nothing
+getBaseDir = maybe (pure Nothing) ((((</> "lib") . rootDir) <$>) <$>) executablePath
+ where
+ rootDir :: FilePath -> FilePath
+ rootDir = takeDirectory . takeDirectory
#endif
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/499a1c202522d849d91300c92be5d5623a46d264
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/499a1c202522d849d91300c92be5d5623a46d264
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230423/2cd3f218/attachment-0001.html>
More information about the ghc-commits
mailing list