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.

2 files changed, 25 insertions, 7 deletions

diff --git a/libraries/base/System/Environment.hs b/libraries/base/System/Environment.hs
index 771b490196..44382acf45 100644
--- a/libraries/base/System/Environment.hs
+++ b/libraries/base/System/Environment.hs
@@ -19,9 +19,7 @@ module System.Environment
     (
       getArgs,
       getProgName,
-#if !defined(javascript_HOST_ARCH)
       executablePath,
-#endif
       getExecutablePath,
       getEnv,
       lookupEnv,
diff --git a/libraries/base/System/Environment/ExecutablePath.hsc b/libraries/base/System/Environment/ExecutablePath.hsc
index cb9fad7a7e..bb8d2f5ca1 100644
--- a/libraries/base/System/Environment/ExecutablePath.hsc
+++ b/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@.  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