[commit: ghc] master: Relocatable GHC (bb11a2d)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/bb11a2d976b933ad870a2888d665d98385dc55fd/ghc

>---------------------------------------------------------------

commit bb11a2d976b933ad870a2888d665d98385dc55fd
Author: Moritz Angermann <moritz.angermann at gmail.com>
Date:   Fri Nov 17 15:04:50 2017 +0800

    Relocatable GHC
    
    GHC and the binary distribution that's produced is
    not relocatable outside of Windows.  This diff tries to
    address this for at least Linux and macOS.
    
    Reviewers: austin, hvr, bgamari, erikd, goldfire, Phyx
    
    Reviewed By: bgamari
    
    Subscribers: duog, rwbarton, thomie, erikd
    
    Differential Revision: https://phabricator.haskell.org/D4121


>---------------------------------------------------------------

bb11a2d976b933ad870a2888d665d98385dc55fd
 compiler/main/SysTools.hs | 21 +++++++++++++++++++++
 utils/ghc-pkg/Main.hs     | 11 +++++++++++
 2 files changed, 32 insertions(+)

diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs
index 21ed03b..860b724 100644
--- a/compiler/main/SysTools.hs
+++ b/compiler/main/SysTools.hs
@@ -48,6 +48,7 @@ import Platform
 import Util
 import DynFlags
 
+import System.Environment (getExecutablePath)
 import System.FilePath
 import System.IO
 import System.Directory
@@ -530,6 +531,26 @@ type GetFinalPath = HANDLE -> LPTSTR -> DWORD -> DWORD -> IO DWORD
 
 foreign import WINDOWS_CCONV unsafe "dynamic"
   makeGetFinalPathNameByHandle :: FunPtr GetFinalPath -> GetFinalPath
+#elif defined(darwin_HOST_OS) || defined(linux_HOST_OS)
+-- on unix, this is a bit more confusing.
+-- The layout right now is somehting like
+--
+--   /bin/ghc-X.Y.Z <- wrapper script (1)
+--   /bin/ghc       <- symlink to wrapper script (2)
+--   /lib/ghc-X.Y.Z/bin/ghc <- ghc executable (3)
+--   /lib/ghc-X.Y.Z <- $topdir (4)
+--
+-- As such, we first need to find the absolute location to the
+-- binary.
+--
+-- getExecutablePath 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
 #endif
diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 6420dd4..3dafffd 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -2116,6 +2116,17 @@ getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
 
 foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
   c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
+#elfi defined(darwin_HOST_OS) || defined(linux_HOST_OS)
+-- TODO: a) this is copy-pasta from SysTools.hs / getBaseDir. Why can't we reuse
+--          this here? and parameterise getBaseDir over the executable (for
+--          windows)?
+--          Answer: we can not, because if we share `getBaseDir` via `ghc-boot`,
+--                  that would add `base` as a dependency for windows.
+--       b) why is the windows getBaseDir logic, not part of getExecutablePath?
+--          it would be much wider available then and we could drop all the
+--          custom logic?
+--          Answer: yes this should happen. No one has found the time just yet.
+getLibDir = Just . (\p -> p </> "lib") . takeDirectory . takeDirectory <$> getExecutablePath
 #else
 getLibDir :: IO (Maybe String)
 getLibDir = return Nothing