X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FPackages.lhs;h=1402db10408f79212c867a1c33c626df10c94b2a;hp=bbaf8468932a24673e619855881367b666dc8430;hb=1a7d1b77334529ca96ed4cbc03fcb5f55dc2de4a;hpb=ee565d464248078a4f2d46f98667aa4fcdc56db4 diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index bbaf846..1402db1 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -4,6 +4,13 @@ % Package manipulation % \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module Packages ( module PackageConfig, @@ -42,15 +49,12 @@ import Config ( cProjectVersion ) import Name ( Name, nameModule_maybe ) import UniqFM import Module -import UniqSet import Util import Maybes ( expectJust, MaybeErr(..) ) import Panic import Outputable -#if __GLASGOW_HASKELL__ >= 603 -import System.Directory ( getAppUserDataDirectory ) -#else +#if __GLASGOW_HASKELL__ < 603 import Compat.Directory ( getAppUserDataDirectory ) #endif @@ -58,15 +62,15 @@ import System.Environment ( getEnv ) import Distribution.InstalledPackageInfo import Distribution.Package import Distribution.Version -import System.Directory ( doesFileExist, doesDirectoryExist, - getDirectoryContents ) -import Data.Maybe ( catMaybes ) -import Control.Monad ( foldM ) -import Data.List ( nub, partition, sortBy, isSuffixOf ) import FastString -import EXCEPTION ( throwDyn ) import ErrUtils ( debugTraceMsg, putMsg, Message ) +import System.Directory +import Data.Maybe +import Control.Monad +import Data.List +import Control.Exception ( throwDyn ) + -- --------------------------------------------------------------------------- -- The Package state @@ -110,9 +114,6 @@ import ErrUtils ( debugTraceMsg, putMsg, Message ) -- in a different DLL, by setting the DLL flag. data PackageState = PackageState { - origPkgIdMap :: PackageConfigMap, -- PackageId -> PackageConfig - -- The on-disk package database - pkgIdMap :: PackageConfigMap, -- PackageId -> PackageConfig -- The exposed flags are adjusted according to -package and -- -hide-package flags, and -ignore-package removes packages. @@ -170,7 +171,8 @@ initPackages dflags = do Just db -> return db (pkg_state, preload, this_pkg) <- mkPackageState dflags pkg_db [] (thisPackage dflags) - return (dflags{ pkgState = pkg_state, + return (dflags{ pkgDatabase = Just pkg_db, + pkgState = pkg_state, thisPackage = this_pkg }, preload) @@ -378,7 +380,8 @@ findWiredInPackages dflags pkgs preload this_package = do wired_in_pkgids = [ basePackageId, rtsPackageId, haskell98PackageId, - thPackageId ] + thPackageId, + ndpPackageId ] wired_in_names = map packageIdString wired_in_pkgids @@ -524,14 +527,17 @@ mkPackageState dflags orig_pkg_db preload0 this_package = do -- add base & rts to the preload packages basicLinkedPackages = filter (flip elemUFM pkg_db) [basePackageId,rtsPackageId] - preload2 = nub (basicLinkedPackages ++ map mkPackageId preload1) + -- but in any case remove the current package from the set of + -- preloaded packages so that base/rts does not end up in the + -- set up preloaded package when we are just building it + preload2 = nub (filter (/= new_this_pkg) + (basicLinkedPackages ++ map mkPackageId preload1)) -- Close the preload packages with their dependencies dep_preload <- closeDeps pkg_db (zip preload2 (repeat Nothing)) let new_dep_preload = filter (`notElem` preload0) dep_preload let pstate = PackageState{ preloadPackages = dep_preload, - origPkgIdMap = orig_pkg_db, pkgIdMap = pkg_db, moduleToPkgConfAll = mkModuleMap pkg_db } @@ -551,12 +557,12 @@ mkModuleMap pkg_db = foldr extend_modmap emptyUFM pkgids extend_modmap pkgid modmap = addListToUFM_C (++) modmap - [(m, [(pkg, m `elem` exposed_mods)]) | m <- all_mods] + ([(m, [(pkg, True)]) | m <- exposed_mods] ++ + [(m, [(pkg, False)]) | m <- hidden_mods]) where pkg = expectJust "mkModuleMap" (lookupPackage pkg_db pkgid) - exposed_mods = map mkModuleName (exposedModules pkg) - hidden_mods = map mkModuleName (hiddenModules pkg) - all_mods = exposed_mods ++ hidden_mods + exposed_mods = exposedModules pkg + hidden_mods = hiddenModules pkg pprPkg :: PackageConfig -> SDoc pprPkg p = text (showPackageId (package p)) @@ -593,26 +599,17 @@ getPackageLinkOpts dflags pkgs = do let tag = buildTag dflags rts_tag = rtsBuildTag dflags let - imp = if opt_Static then "" else "_dyn" - libs p = map ((++imp) . addSuffix) (hsLibraries p) - ++ hACK_dyn (extraLibraries p) + mkDynName | opt_Static = id + | otherwise = (++ ("-ghc" ++ cProjectVersion)) + libs p = map (mkDynName . addSuffix) (hsLibraries p) + ++ extraLibraries p all_opts p = map ("-l" ++) (libs p) ++ ldOptions p - suffix = if null tag then "" else '_':tag - rts_suffix = if null rts_tag then "" else '_':rts_tag + addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag) + addSuffix other_lib = other_lib ++ (expandTag tag) - addSuffix rts@"HSrts" = rts ++ rts_suffix - addSuffix other_lib = other_lib ++ suffix - - -- This is a hack that's even more horrible (and hopefully more temporary) - -- than the one below [referring to previous splittage of HSbase into chunks - -- to work around GNU ld bug]. HSbase_cbits and friends require the _dyn suffix - -- for dynamic linking, but not _p or other 'way' suffix. So we just add - -- _dyn to extraLibraries if they already have a _cbits suffix. - - hACK_dyn = map hack - where hack lib | not opt_Static && "_cbits" `isSuffixOf` lib = lib ++ "_dyn" - | otherwise = lib + expandTag t | null t = "" + | otherwise = '_':t return (concat (map all_opts ps)) @@ -707,5 +704,10 @@ dumpPackages :: DynFlags -> IO () dumpPackages dflags = do let pkg_map = pkgIdMap (pkgState dflags) putMsg dflags $ - vcat (map (text.showInstalledPackageInfo) (eltsUFM pkg_map)) + vcat (map (text.showInstalledPackageInfo.to_ipi) (eltsUFM pkg_map)) + where + to_ipi pkgconf@InstalledPackageInfo_{ exposedModules = e, + hiddenModules = h } = + pkgconf{ exposedModules = map moduleNameString e, + hiddenModules = map moduleNameString h } \end{code}