[project @ 2004-08-13 13:04:50 by simonmar]
[ghc-hetmet.git] / ghc / compiler / ghci / Linker.lhs
index 9137031..0849859 100644 (file)
@@ -15,12 +15,12 @@ necessary.
 
 {-# OPTIONS -optc-DNON_POSIX_SOURCE -#include "Linker.h" #-}
 
-module Linker ( HValue, initDynLinker, showLinkerState,
+module Linker ( HValue, showLinkerState,
                linkExpr, unload, extendLinkEnv, 
                linkPackages,
        ) where
 
-#include "../includes/config.h"
+#include "../includes/ghcconfig.h"
 #include "HsVersions.h"
 
 import ObjLink         ( loadDLL, loadObj, unloadObj, resolveObjs, initObjLinker )
@@ -30,17 +30,17 @@ import ByteCodeAsm  ( CompiledByteCode(..), bcoFreeNames, UnlinkedBCO(..))
 
 import Packages
 import DriverState     ( v_Library_paths, v_Opt_l, v_Ld_inputs, getStaticOpts, v_ExplicitPackages )
+import DriverPhases    ( isObjectFilename, isDynLibFilename )
 import DriverUtil      ( getFileSuffix )
 #ifdef darwin_TARGET_OS
 import DriverState     ( v_Cmdline_frameworks, v_Framework_paths )
 #endif
 import Finder          ( findModule, findLinkable )
 import HscTypes
-import Name            ( Name,  nameModule, isExternalName, isWiredInName )
+import Name            ( Name, nameModule, nameModuleName, isExternalName, isWiredInName )
 import NameEnv
 import NameSet         ( nameSetToList )
 import Module
-import FastString      ( FastString(..), unpackFS )
 import ListSetOps      ( minusList )
 import CmdLineOpts     ( DynFlags(verbosity), getDynFlags )
 import BasicTypes      ( SuccessFlag(..), succeeded, failed )
@@ -144,7 +144,7 @@ filterNameMap mods env
    = filterNameEnv keep_elt env
    where
      keep_elt (n,_) = isExternalName n 
-                     && (moduleName (nameModule n) `elem` mods)
+                     && (nameModuleName n `elem` mods)
 \end{code}
 
 
@@ -215,7 +215,7 @@ reallyInitDynLinker
        ; lib_paths <- readIORef v_Library_paths
        ; cmdline_ld_inputs <- readIORef v_Ld_inputs
 
-       ; let (cmdline_libs, cmdline_objs) = partition libish cmdline_ld_inputs
+       ; classified_ld_inputs <- mapM classifyLdInput cmdline_ld_inputs
 
                -- (e) Link any MacOS frameworks
 #ifdef darwin_TARGET_OS        
@@ -226,8 +226,7 @@ reallyInitDynLinker
        ; let framework_paths = []
 #endif
                -- Finally do (c),(d),(e)       
-        ; let cmdline_lib_specs = map Object    cmdline_objs
-                              ++ map DLLPath   cmdline_libs
+        ; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ]
                               ++ map DLL       minus_ls 
                               ++ map Framework frameworks
        ; if null cmdline_lib_specs then return ()
@@ -241,14 +240,13 @@ reallyInitDynLinker
          else throwDyn (InstallationError "linking extra libraries/objects failed")
        }}
 
-libish :: String -> Bool
-libish f = getFileSuffix f `elem` dynlib_suffixes
-
-#ifdef mingw32_TARGET_OS
-dynlib_suffixes = ["dll", "DLL"]
-#else
-dynlib_suffixes = ["so"]
-#endif
+classifyLdInput :: FilePath -> IO (Maybe LibrarySpec)
+classifyLdInput f
+  | isObjectFilename f = return (Just (Object f))
+  | isDynLibFilename f = return (Just (DLLPath f))
+  | otherwise         = do
+       hPutStrLn stderr ("Warning: ignoring unrecognised input `" ++ f ++ "'")
+       return Nothing
 
 preloadLib :: DynFlags -> [String] -> [String] -> LibrarySpec -> IO ()
 preloadLib dflags lib_paths framework_paths lib_spec
@@ -306,8 +304,7 @@ preloadLib dflags lib_paths framework_paths lib_spec
 %************************************************************************
 
 \begin{code}
-linkExpr :: HscEnv -> PersistentCompilerState
-        -> UnlinkedBCO -> IO HValue
+linkExpr :: HscEnv -> UnlinkedBCO -> IO HValue
 
 -- Link a single expression, *including* first linking packages and 
 -- modules that this expression depends on.
@@ -315,13 +312,14 @@ linkExpr :: HscEnv -> PersistentCompilerState
 -- Raises an IO exception if it can't find a compiled version of the
 -- dependents to link.
 
-linkExpr hsc_env pcs root_ul_bco
+linkExpr hsc_env root_ul_bco
   = do {  
        -- Initialise the linker (if it's not been done already)
      initDynLinker
 
        -- Find what packages and linkables are required
-   ; (lnks, pkgs) <- getLinkDeps hpt pit needed_mods
+   ; eps <- readIORef (hsc_EPS hsc_env)
+   ; (lnks, pkgs) <- getLinkDeps hpt (eps_PIT eps) needed_mods
 
        -- Link the packages and modules required
    ; linkPackages dflags pkgs
@@ -340,7 +338,6 @@ linkExpr hsc_env pcs root_ul_bco
    ; return root_hval
    }}
    where
-     pit    = eps_PIT (pcs_EPS pcs)
      hpt    = hsc_HPT hsc_env
      dflags = hsc_dflags hsc_env
      free_names = nameSetToList (bcoFreeNames root_ul_bco)
@@ -471,9 +468,6 @@ findModuleLinkable_maybe lis mod
         [li] -> Just li
         many -> pprPanic "findModuleLinkable" (ppr mod)
 
-filterModuleLinkables :: (ModuleName -> Bool) -> [Linkable] -> [Linkable]
-filterModuleLinkables p ls = filter (p . linkableModName) ls
-
 linkableInSet :: Linkable -> [Linkable] -> Bool
 linkableInSet l objs_loaded =
   case findModuleLinkable_maybe objs_loaded (linkableModName l) of
@@ -648,8 +642,7 @@ unload_wkr dflags linkables pls
        objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls)
         bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls)
 
-               let objs_retained = map linkableModName objs_loaded'
-           bcos_retained = map linkableModName bcos_loaded'
+               let bcos_retained = map linkableModName bcos_loaded'
            itbl_env'     = filterNameMap bcos_retained (itbl_env pls)
             closure_env'  = filterNameMap bcos_retained (closure_env pls)
            new_pls = pls { itbl_env = itbl_env',
@@ -712,7 +705,7 @@ partOfGHCi
 #          if defined(mingw32_TARGET_OS) || defined(darwin_TARGET_OS)
            = [ ]
 #          else
-           = [ "base", "haskell98", "haskell-src", "readline" ]
+           = [ "base", "haskell98", "template-haskell", "readline" ]
 #          endif
 
 showLS (Object nm)    = "(static) " ++ nm
@@ -778,15 +771,26 @@ linkPackage dflags pkg
        -- See comments with partOfGHCi
        when (Packages.name pkg `notElem` partOfGHCi) $ do
            loadFrameworks pkg
-           mapM_ (load_dyn dirs) dlls
+            -- When a library A needs symbols from a library B, the order in
+            -- extra_libraries/extra_ld_opts is "-lA -lB", because that's the
+            -- way ld expects it for static linking. Dynamic linking is a
+            -- different story: When A has no dependency information for B,
+            -- dlopen-ing A with RTLD_NOW (see addDLL in Linker.c) will fail
+            -- when B has not been loaded before. In a nutshell: Reverse the
+            -- order of DLLs for dynamic linking.
+           -- This fixes a problem with the HOpenGL package (see "Compiling
+           -- HOpenGL under recent versions of GHC" on the HOpenGL list).
+           mapM_ (load_dyn dirs) (reverse dlls)
        
        -- After loading all the DLLs, we can load the static objects.
+       -- Ordering isn't important here, because we do one final link
+       -- step to resolve everything.
        mapM_ loadObj objs
 
         maybePutStr dflags "linking ... "
         ok <- resolveObjs
        if succeeded ok then maybePutStrLn dflags "done."
-             else panic ("can't load package `" ++ name pkg ++ "'")
+             else throwDyn (InstallationError ("unable to load package `" ++ name pkg ++ "'"))
 
 load_dyn dirs dll = do r <- loadDynamic dirs dll
                       case r of