diff options
Diffstat (limited to 'compiler/main')
| -rw-r--r-- | compiler/main/CodeOutput.hs | 10 | ||||
| -rw-r--r-- | compiler/main/DriverMkDepend.hs | 13 | ||||
| -rw-r--r-- | compiler/main/DriverPipeline.hs | 336 | ||||
| -rw-r--r-- | compiler/main/DynFlags.hs | 82 | ||||
| -rw-r--r-- | compiler/main/Finder.hs | 46 | ||||
| -rw-r--r-- | compiler/main/GHC.hs | 17 | ||||
| -rw-r--r-- | compiler/main/GhcMake.hs | 12 | ||||
| -rw-r--r-- | compiler/main/HeaderInfo.hs | 10 | ||||
| -rw-r--r-- | compiler/main/Hooks.hs | 5 | ||||
| -rw-r--r-- | compiler/main/HscMain.hs | 336 | ||||
| -rw-r--r-- | compiler/main/HscTypes.hs | 63 | ||||
| -rw-r--r-- | compiler/main/InteractiveEval.hs | 2 | ||||
| -rw-r--r-- | compiler/main/PackageConfig.hs | 70 | ||||
| -rw-r--r-- | compiler/main/Packages.hs | 358 | ||||
| -rw-r--r-- | compiler/main/Packages.hs-boot | 4 | ||||
| -rw-r--r-- | compiler/main/SysTools.hs | 41 | ||||
| -rw-r--r-- | compiler/main/TidyPgm.hs | 6 |
17 files changed, 577 insertions, 834 deletions
diff --git a/compiler/main/CodeOutput.hs b/compiler/main/CodeOutput.hs index f55a15a842..00a0801c47 100644 --- a/compiler/main/CodeOutput.hs +++ b/compiler/main/CodeOutput.hs @@ -50,7 +50,7 @@ codeOutput :: DynFlags -> FilePath -> ModLocation -> ForeignStubs - -> [PackageKey] + -> [UnitId] -> Stream IO RawCmmGroup () -- Compiled C-- -> IO (FilePath, (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-})) @@ -100,7 +100,7 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action outputC :: DynFlags -> FilePath -> Stream IO RawCmmGroup () - -> [PackageKey] + -> [UnitId] -> IO () outputC dflags filenm cmm_stream packages @@ -115,7 +115,7 @@ outputC dflags filenm cmm_stream packages -- * -#include options from the cmdline and OPTIONS pragmas -- * the _stub.h file, if there is one. -- - let rts = getPackageDetails dflags rtsPackageKey + let rts = getPackageDetails dflags rtsUnitId let cc_injects = unlines (map mk_include (includes rts)) mk_include h_file = @@ -124,7 +124,7 @@ outputC dflags filenm cmm_stream packages '<':_ -> "#include "++h_file _ -> "#include \""++h_file++"\"" - let pkg_names = map packageKeyString packages + let pkg_names = map unitIdString packages doOutput filenm $ \ h -> do hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") @@ -208,7 +208,7 @@ outputForeignStubs dflags mod location stubs -- we need the #includes from the rts package for the stub files let rts_includes = - let rts_pkg = getPackageDetails dflags rtsPackageKey in + let rts_pkg = getPackageDetails dflags rtsUnitId in concatMap mk_include (includes rts_pkg) mk_include i = "#include \"" ++ i ++ "\"\n" diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs index aae4d0e7c2..1541d95c62 100644 --- a/compiler/main/DriverMkDepend.hs +++ b/compiler/main/DriverMkDepend.hs @@ -16,7 +16,6 @@ module DriverMkDepend ( import qualified GHC import GhcMonad -import HsSyn ( ImportDecl(..) ) import DynFlags import Util import HscTypes @@ -30,7 +29,6 @@ import Panic import SrcLoc import Data.List import FastString -import BasicTypes ( StringLiteral(..) ) import Exception import ErrUtils @@ -227,9 +225,8 @@ processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node) -- Emit a dependency for each import ; let do_imps is_boot idecls = sequence_ - [ do_imp loc is_boot (fmap sl_fs $ ideclPkgQual i) mod - | L loc i <- idecls, - let mod = unLoc (ideclName i), + [ do_imp loc is_boot mb_pkg mod + | (mb_pkg, L loc mod) <- idecls, mod `notElem` excl_mods ] ; do_imps True (ms_srcimps node) @@ -379,7 +376,7 @@ pprCycle summaries = pp_group (CyclicSCC summaries) pp_ms loop_breaker $$ vcat (map pp_group groups) where (boot_only, others) = partition is_boot_only mss - is_boot_only ms = not (any in_group (map (ideclName.unLoc) (ms_imps ms))) + is_boot_only ms = not (any in_group (map snd (ms_imps ms))) in_group (L _ m) = m `elem` group_mods group_mods = map (moduleName . ms_mod) mss @@ -388,8 +385,8 @@ pprCycle summaries = pp_group (CyclicSCC summaries) groups = GHC.topSortModuleGraph True all_others Nothing pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' ')) - <+> (pp_imps empty (map (ideclName.unLoc) (ms_imps summary)) $$ - pp_imps (ptext (sLit "{-# SOURCE #-}")) (map (ideclName.unLoc) (ms_srcimps summary))) + <+> (pp_imps empty (map snd (ms_imps summary)) $$ + pp_imps (ptext (sLit "{-# SOURCE #-}")) (map snd (ms_srcimps summary))) where mod_str = moduleNameString (moduleName (ms_mod summary)) diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index a45507e635..e83f7d66a3 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -64,10 +64,8 @@ import MonadUtils import Platform import TcRnTypes import Hooks -import MkIface import Exception -import Data.IORef ( readIORef ) import System.Directory import System.FilePath import System.IO @@ -133,173 +131,90 @@ compileOne' :: Maybe TcGblEnv compileOne' m_tc_result mHscMessage hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable source_modified0 - | HsBootMerge <- ms_hsc_src summary - = do -- Do a boot merge instead! For now, something very simple - output_fn <- getOutputFilename next_phase - Temporary basename dflags next_phase (Just location) - e <- genericHscMergeRequirement mHscMessage - hsc_env summary mb_old_iface (mod_index, nmods) - - case e of - -- TODO: dedup - Left iface -> - do details <- genModDetails hsc_env iface - return (HomeModInfo{ hm_details = details, - hm_iface = iface, - hm_linkable = maybe_old_linkable }) - Right (iface0, mb_old_hash) -> - case hsc_lang of - HscInterpreted -> - do (iface, _no_change) <- mkIfaceDirect hsc_env mb_old_hash iface0 - details <- genModDetails hsc_env iface - -- Merges don't need to link in any bytecode, unlike - -- HsSrcFiles. - let linkable = LM (ms_hs_date summary) this_mod [] - return (HomeModInfo{ hm_details = details, - hm_iface = iface, - hm_linkable = Just linkable }) - - HscNothing -> - do (iface, no_change) <- mkIfaceDirect hsc_env mb_old_hash iface0 - details <- genModDetails hsc_env iface - when (gopt Opt_WriteInterface dflags) $ - hscWriteIface dflags iface no_change summary - let linkable = LM (ms_hs_date summary) this_mod [] - return (HomeModInfo{ hm_details = details, - hm_iface = iface, - hm_linkable = Just linkable }) - _ -> - do (iface, no_change) <- mkIfaceDirect hsc_env mb_old_hash iface0 - hscWriteIface dflags iface no_change summary - - -- #10660: Use the pipeline instead of calling - -- compileEmptyStub directly, so -dynamic-too gets - -- handled properly - let mod_name = ms_mod_name summary - _ <- runPipeline StopLn hsc_env - (output_fn, - Just (HscOut src_flavour - mod_name HscUpdateBootMerge)) - (Just basename) - Persistent - (Just location) - Nothing - - details <- genModDetails hsc_env iface - - o_time <- getModificationUTCTime object_filename - let linkable = - LM o_time this_mod [DotO object_filename] - return (HomeModInfo{ hm_details = details, - hm_iface = iface, - hm_linkable = Just linkable }) - - | otherwise = do debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp) - -- What file to generate the output into? - output_fn <- getOutputFilename next_phase - Temporary basename dflags next_phase (Just location) - - e <- genericHscCompileGetFrontendResult - always_do_basic_recompilation_check - m_tc_result mHscMessage - hsc_env summary source_modified mb_old_iface (mod_index, nmods) - - case e of - Left iface -> - do details <- genModDetails hsc_env iface - MASSERT(isJust maybe_old_linkable || isNoLink (ghcLink dflags)) - return (HomeModInfo{ hm_details = details, - hm_iface = iface, - hm_linkable = maybe_old_linkable }) - - Right (tc_result, mb_old_hash) -> - -- run the compiler - case hsc_lang of - HscInterpreted -> - case ms_hsc_src summary of - HsBootFile -> - do (iface, _changed, details) <- hscSimpleIface hsc_env tc_result mb_old_hash - return (HomeModInfo{ hm_details = details, - hm_iface = iface, - hm_linkable = maybe_old_linkable }) - _ -> do guts0 <- hscDesugar hsc_env summary tc_result - guts <- hscSimplify hsc_env guts0 - (iface, _changed, details, cgguts) <- hscNormalIface hsc_env guts mb_old_hash - (hasStub, comp_bc, modBreaks) <- hscInteractive hsc_env cgguts summary - - stub_o <- case hasStub of - Nothing -> return [] - Just stub_c -> do - stub_o <- compileStub hsc_env stub_c - return [DotO stub_o] - - let hs_unlinked = [BCOs comp_bc modBreaks] - unlinked_time = ms_hs_date summary - -- Why do we use the timestamp of the source file here, - -- rather than the current time? This works better in - -- the case where the local clock is out of sync - -- with the filesystem's clock. It's just as accurate: - -- if the source is modified, then the linkable will - -- be out of date. - let linkable = LM unlinked_time this_mod - (hs_unlinked ++ stub_o) - - return (HomeModInfo{ hm_details = details, - hm_iface = iface, - hm_linkable = Just linkable }) - HscNothing -> - do (iface, changed, details) <- hscSimpleIface hsc_env tc_result mb_old_hash - when (gopt Opt_WriteInterface dflags) $ - hscWriteIface dflags iface changed summary - let linkable = if isHsBoot src_flavour - then maybe_old_linkable - else Just (LM (ms_hs_date summary) this_mod []) - return (HomeModInfo{ hm_details = details, - hm_iface = iface, - hm_linkable = linkable }) - _ -> - case ms_hsc_src summary of - HsBootMerge -> panic "This driver can't handle it" - HsBootFile -> - do (iface, changed, details) <- hscSimpleIface hsc_env tc_result mb_old_hash - hscWriteIface dflags iface changed summary - - touchObjectFile dflags object_filename - - return (HomeModInfo{ - hm_details = details, - hm_iface = iface, - hm_linkable = maybe_old_linkable }) - - HsSrcFile -> - do guts0 <- hscDesugar hsc_env summary tc_result - guts <- hscSimplify hsc_env guts0 - (iface, changed, details, cgguts) <- hscNormalIface hsc_env guts mb_old_hash - hscWriteIface dflags iface changed summary - - -- We're in --make mode: finish the compilation pipeline. - let mod_name = ms_mod_name summary - _ <- runPipeline StopLn hsc_env - (output_fn, - Just (HscOut src_flavour mod_name (HscRecomp cgguts summary))) - (Just basename) - Persistent - (Just location) - Nothing - -- The object filename comes from the ModLocation - o_time <- getModificationUTCTime object_filename - let linkable = LM o_time this_mod [DotO object_filename] - - return (HomeModInfo{ hm_details = details, - hm_iface = iface, - hm_linkable = Just linkable }) + (status, hmi0) <- hscIncrementalCompile + always_do_basic_recompilation_check + m_tc_result mHscMessage + hsc_env summary source_modified mb_old_iface (mod_index, nmods) + + case (status, hsc_lang) of + (HscUpToDate, _) -> + ASSERT( isJust maybe_old_linkable || isNoLink (ghcLink dflags) ) + return hmi0 { hm_linkable = maybe_old_linkable } + (HscNotGeneratingCode, HscNothing) -> + let mb_linkable = if isHsBoot src_flavour + then Nothing + -- TODO: Questionable. + else Just (LM (ms_hs_date summary) this_mod []) + in return hmi0 { hm_linkable = mb_linkable } + (HscNotGeneratingCode, _) -> panic "compileOne HscNotGeneratingCode" + (_, HscNothing) -> panic "compileOne HscNothing" + (HscUpdateBoot, HscInterpreted) -> do + return hmi0 + (HscUpdateBoot, _) -> do + touchObjectFile dflags object_filename + return hmi0 + (HscUpdateBootMerge, HscInterpreted) -> + let linkable = LM (ms_hs_date summary) this_mod [] + in return hmi0 { hm_linkable = Just linkable } + (HscUpdateBootMerge, _) -> do + output_fn <- getOutputFilename next_phase + Temporary basename dflags next_phase (Just location) + + -- #10660: Use the pipeline instead of calling + -- compileEmptyStub directly, so -dynamic-too gets + -- handled properly + _ <- runPipeline StopLn hsc_env + (output_fn, + Just (HscOut src_flavour + mod_name HscUpdateBootMerge)) + (Just basename) + Persistent + (Just location) + Nothing + o_time <- getModificationUTCTime object_filename + let linkable = LM o_time this_mod [DotO object_filename] + return hmi0 { hm_linkable = Just linkable } + (HscRecomp cgguts summary, HscInterpreted) -> do + (hasStub, comp_bc, modBreaks) <- hscInteractive hsc_env cgguts summary + + stub_o <- case hasStub of + Nothing -> return [] + Just stub_c -> do + stub_o <- compileStub hsc_env stub_c + return [DotO stub_o] + + let hs_unlinked = [BCOs comp_bc modBreaks] + unlinked_time = ms_hs_date summary + -- Why do we use the timestamp of the source file here, + -- rather than the current time? This works better in + -- the case where the local clock is out of sync + -- with the filesystem's clock. It's just as accurate: + -- if the source is modified, then the linkable will + -- be out of date. + let linkable = LM unlinked_time (ms_mod summary) + (hs_unlinked ++ stub_o) + return hmi0 { hm_linkable = Just linkable } + (HscRecomp cgguts summary, _) -> do + output_fn <- getOutputFilename next_phase + Temporary basename dflags next_phase (Just location) + -- We're in --make mode: finish the compilation pipeline. + _ <- runPipeline StopLn hsc_env + (output_fn, + Just (HscOut src_flavour mod_name (HscRecomp cgguts summary))) + (Just basename) + Persistent + (Just location) + Nothing + -- The object filename comes from the ModLocation + o_time <- getModificationUTCTime object_filename + let linkable = LM o_time this_mod [DotO object_filename] + return hmi0 { hm_linkable = Just linkable } + where dflags0 = ms_hspp_opts summary - this_mod = ms_mod summary - src_flavour = ms_hsc_src summary location = ms_location summary input_fn = expectJust "compile:hs" (ml_hs_file location) input_fnpp = ms_hspp_file summary @@ -310,6 +225,13 @@ compileOne' m_tc_result mHscMessage isDynWay = any (== WayDyn) (ways dflags0) isProfWay = any (== WayProf) (ways dflags0) + + src_flavour = ms_hsc_src summary + this_mod = ms_mod summary + mod_name = ms_mod_name summary + next_phase = hscPostBackendPhase dflags src_flavour hsc_lang + object_filename = ml_obj_file location + -- #8180 - when using TemplateHaskell, switch on -dynamic-too so -- the linker can correctly load the object files. @@ -329,15 +251,12 @@ compileOne' m_tc_result mHscMessage -- Figure out what lang we're generating hsc_lang = hscTarget dflags - -- ... and what the next phase should be - next_phase = hscPostBackendPhase dflags src_flavour hsc_lang -- -fforce-recomp should also work with --make force_recomp = gopt Opt_ForceRecomp dflags source_modified | force_recomp = SourceModified | otherwise = source_modified0 - object_filename = ml_obj_file location always_do_basic_recompilation_check = case hsc_lang of HscInterpreted -> True @@ -478,7 +397,7 @@ link' dflags batch_attempt_linking hpt return Succeeded -linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [PackageKey] -> IO Bool +linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [UnitId] -> IO Bool linkingNeeded dflags staticLink linkables pkg_deps = do -- if the modification time on the executable is later than the -- modification times on all of the objects and libraries, then omit @@ -514,7 +433,7 @@ linkingNeeded dflags staticLink linkables pkg_deps = do -- Returns 'False' if it was, and we can avoid linking, because the -- previous binary was linked with "the same options". -checkLinkInfo :: DynFlags -> [PackageKey] -> FilePath -> IO Bool +checkLinkInfo :: DynFlags -> [UnitId] -> FilePath -> IO Bool checkLinkInfo dflags pkg_deps exe_file | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags))) -- ToDo: Windows and OS X do not use the ELF binary format, so @@ -1087,8 +1006,9 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0 ms_merge_imps = (False, []) } -- run the compiler! - result <- liftIO $ hscCompileOneShot hsc_env' - mod_summary source_unchanged + let msg hsc_env _ what _ = oneShotMsg hsc_env what + (result, _) <- liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env' + mod_summary source_unchanged Nothing (1,1) return (HscOut src_flavour mod_name result, panic "HscOut doesn't have an input filename") @@ -1261,7 +1181,7 @@ runPhase (RealPhase cc_phase) input_fn dflags -- way we do the import depends on whether we're currently compiling -- the base package or not. ++ (if platformOS platform == OSMinGW32 && - thisPackage dflags == basePackageKey + thisPackage dflags == baseUnitId then [ "-DCOMPILING_BASE_PACKAGE" ] else []) @@ -1338,14 +1258,7 @@ runPhase (RealPhase (As with_cpp)) input_fn dflags -- assembler, so we use clang as the assembler instead. (#5636) let whichAsProg | hscTarget dflags == HscLlvm && platformOS (targetPlatform dflags) == OSDarwin - = do - -- be careful what options we call clang with - -- see #5903 and #7617 for bugs caused by this. - llvmVer <- liftIO $ figureLlvmVersion dflags - return $ case llvmVer of - Just n | n >= 30 -> SysTools.runClang - _ -> SysTools.runAs - + = return SysTools.runClang | otherwise = return SysTools.runAs as_prog <- whichAsProg @@ -1487,18 +1400,15 @@ runPhase (RealPhase SplitAs) _input_fn dflags runPhase (RealPhase LlvmOpt) input_fn dflags = do - ver <- liftIO $ readIORef (llvmVersion dflags) - let opt_lvl = max 0 (min 2 $ optLevel dflags) -- don't specify anything if user has specified commands. We do this -- for opt but not llc since opt is very specifically for optimisation -- passes only, so if the user is passing us extra options we assume -- they know what they are doing and don't get in the way. optFlag = if null (getOpts dflags opt_lo) - then map SysTools.Option $ words (llvmOpts ver !! opt_lvl) + then map SysTools.Option $ words (llvmOpts !! opt_lvl) else [] - tbaa | ver < 29 = "" -- no tbaa in 2.8 and earlier - | gopt Opt_LlvmTBAA dflags = "--enable-tbaa=true" + tbaa | gopt Opt_LlvmTBAA dflags = "--enable-tbaa=true" | otherwise = "--enable-tbaa=false" @@ -1512,22 +1422,19 @@ runPhase (RealPhase LlvmOpt) input_fn dflags ++ [SysTools.Option tbaa]) return (RealPhase LlvmLlc, output_fn) - where + where -- we always (unless -optlo specified) run Opt since we rely on it to -- fix up some pretty big deficiencies in the code we generate - llvmOpts ver = [ "-mem2reg -globalopt" - , if ver >= 34 then "-O1 -globalopt" else "-O1" - -- LLVM 3.4 -O1 doesn't eliminate aliases reliably (bug #8855) - , "-O2" - ] + llvmOpts = [ "-mem2reg -globalopt" + , "-O1 -globalopt" + , "-O2" + ] ----------------------------------------------------------------------------- -- LlvmLlc phase runPhase (RealPhase LlvmLlc) input_fn dflags = do - ver <- liftIO $ readIORef (llvmVersion dflags) - let opt_lvl = max 0 (min 2 $ optLevel dflags) -- iOS requires external references to be loaded indirectly from the -- DATA segment or dyld traps at runtime writing into TEXT: see #7722 @@ -1535,8 +1442,7 @@ runPhase (RealPhase LlvmLlc) input_fn dflags | gopt Opt_PIC dflags = "pic" | not (gopt Opt_Static dflags) = "dynamic-no-pic" | otherwise = "static" - tbaa | ver < 29 = "" -- no tbaa in 2.8 and earlier - | gopt Opt_LlvmTBAA dflags = "--enable-tbaa=true" + tbaa | gopt Opt_LlvmTBAA dflags = "--enable-tbaa=true" | otherwise = "--enable-tbaa=false" -- hidden debugging flag '-dno-llvm-mangler' to skip mangling @@ -1544,13 +1450,8 @@ runPhase (RealPhase LlvmLlc) input_fn dflags False -> LlvmMangle True | gopt Opt_SplitObjs dflags -> Splitter True -> As False - - output_fn <- phaseOutputFilename next_phase - -- AVX can cause LLVM 3.2 to generate a C-like frame pointer - -- prelude, see #9391 - when (ver == 32 && isAvxEnabled dflags) $ liftIO $ errorMsg dflags $ text - "Note: LLVM 3.2 has known problems with AVX instructions (see trac #9391)" + output_fn <- phaseOutputFilename next_phase liftIO $ SysTools.runLlvmLlc dflags ([ SysTools.Option (llvmOpts !! opt_lvl), @@ -1561,7 +1462,7 @@ runPhase (RealPhase LlvmLlc) input_fn dflags ++ map SysTools.Option fpOpts ++ map SysTools.Option abiOpts ++ map SysTools.Option sseOpts - ++ map SysTools.Option (avxOpts ver) + ++ map SysTools.Option avxOpts ++ map SysTools.Option avx512Opts ++ map SysTools.Option stackAlignOpts) @@ -1574,7 +1475,7 @@ runPhase (RealPhase LlvmLlc) input_fn dflags -- On ARMv7 using LLVM, LLVM fails to allocate floating point registers -- while compiling GHC source code. It's probably due to fact that it -- does not enable VFP by default. Let's do this manually here - fpOpts = case platformArch (targetPlatform dflags) of + fpOpts = case platformArch (targetPlatform dflags) of ArchARM ARMv7 ext _ -> if (elem VFPv3 ext) then ["-mattr=+v7,+vfp3"] else if (elem VFPv3D16 ext) @@ -1597,11 +1498,10 @@ runPhase (RealPhase LlvmLlc) input_fn dflags | isSseEnabled dflags = ["-mattr=+sse"] | otherwise = [] - avxOpts ver | isAvx512fEnabled dflags = ["-mattr=+avx512f"] - | isAvx2Enabled dflags = ["-mattr=+avx2"] - | isAvxEnabled dflags = ["-mattr=+avx"] - | ver == 32 = ["-mattr=-avx"] -- see #9391 - | otherwise = [] + avxOpts | isAvx512fEnabled dflags = ["-mattr=+avx512f"] + | isAvx2Enabled dflags = ["-mattr=+avx2"] + | isAvxEnabled dflags = ["-mattr=+avx"] + | otherwise = [] avx512Opts = [ "-mattr=+avx512cd" | isAvx512cdEnabled dflags ] ++ @@ -1693,7 +1593,7 @@ mkExtraObj dflags extn xs = do cFile <- newTempName dflags extn oFile <- newTempName dflags "o" writeFile cFile xs - let rtsDetails = getPackageDetails dflags rtsPackageKey + let rtsDetails = getPackageDetails dflags rtsUnitId pic_c_flags = picCCOpts dflags SysTools.runCc dflags ([Option "-c", @@ -1748,7 +1648,7 @@ mkExtraObjToLinkIntoBinary dflags = do -- this was included as inline assembly in the main.c file but this -- is pretty fragile. gas gets upset trying to calculate relative offsets -- that span the .note section (notably .text) when debug info is present -mkNoteObjsToLinkIntoBinary :: DynFlags -> [PackageKey] -> IO [FilePath] +mkNoteObjsToLinkIntoBinary :: DynFlags -> [UnitId] -> IO [FilePath] mkNoteObjsToLinkIntoBinary dflags dep_packages = do link_info <- getLinkInfo dflags dep_packages @@ -1789,7 +1689,7 @@ mkNoteObjsToLinkIntoBinary dflags dep_packages = do -- link. We save this information in the binary, and the next time we -- link, if nothing else has changed, we use the link info stored in -- the existing binary to decide whether to re-link or not. -getLinkInfo :: DynFlags -> [PackageKey] -> IO String +getLinkInfo :: DynFlags -> [UnitId] -> IO String getLinkInfo dflags dep_packages = do package_link_opts <- getPackageLinkOpts dflags dep_packages pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags) @@ -1810,13 +1710,13 @@ getLinkInfo dflags dep_packages = do ----------------------------------------------------------------------------- -- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file -getHCFilePackages :: FilePath -> IO [PackageKey] +getHCFilePackages :: FilePath -> IO [UnitId] getHCFilePackages filename = Exception.bracket (openFile filename ReadMode) hClose $ \h -> do l <- hGetLine h case l of '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest -> - return (map stringToPackageKey (words rest)) + return (map stringToUnitId (words rest)) _other -> return [] @@ -1833,10 +1733,10 @@ getHCFilePackages filename = -- read any interface files), so the user must explicitly specify all -- the packages. -linkBinary :: DynFlags -> [FilePath] -> [PackageKey] -> IO () +linkBinary :: DynFlags -> [FilePath] -> [UnitId] -> IO () linkBinary = linkBinary' False -linkBinary' :: Bool -> DynFlags -> [FilePath] -> [PackageKey] -> IO () +linkBinary' :: Bool -> DynFlags -> [FilePath] -> [UnitId] -> IO () linkBinary' staticLink dflags o_files dep_packages = do let platform = targetPlatform dflags mySettings = settings dflags @@ -2080,7 +1980,7 @@ maybeCreateManifest dflags exe_filename | otherwise = return [] -linkDynLibCheck :: DynFlags -> [String] -> [PackageKey] -> IO () +linkDynLibCheck :: DynFlags -> [String] -> [UnitId] -> IO () linkDynLibCheck dflags o_files dep_packages = do when (haveRtsOptsFlags dflags) $ do @@ -2090,7 +1990,7 @@ linkDynLibCheck dflags o_files dep_packages linkDynLib dflags o_files dep_packages -linkStaticLibCheck :: DynFlags -> [String] -> [PackageKey] -> IO () +linkStaticLibCheck :: DynFlags -> [String] -> [UnitId] -> IO () linkStaticLibCheck dflags o_files dep_packages = do when (platformOS (targetPlatform dflags) `notElem` [OSiOS, OSDarwin]) $ @@ -2275,7 +2175,7 @@ haveRtsOptsFlags dflags = -- | Find out path to @ghcversion.h@ file getGhcVersionPathName :: DynFlags -> IO FilePath getGhcVersionPathName dflags = do - dirs <- getPackageIncludePath dflags [rtsPackageKey] + dirs <- getPackageIncludePath dflags [rtsUnitId] found <- filterM doesFileExist (map (</> "ghcversion.h") dirs) case found of diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 3327a1effe..3ecb1031a4 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -92,7 +92,7 @@ module DynFlags ( getVerbFlags, updOptLevel, setTmpDir, - setPackageKey, + setUnitId, interpretPackageEnv, -- ** Parsing DynFlags @@ -100,10 +100,6 @@ module DynFlags ( parseDynamicFilePragma, parseDynamicFlagsFull, - -- ** Package key cache - PackageKeyCache, - ShPackageKey(..), - -- ** Available DynFlags allFlags, flagsAll, @@ -181,8 +177,6 @@ import Foreign.C ( CInt(..) ) import System.IO.Unsafe ( unsafeDupablePerformIO ) #endif import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessage ) -import UniqFM -import UniqSet import System.IO.Unsafe ( unsafePerformIO ) import Data.IORef @@ -667,29 +661,6 @@ type SigOf = Map ModuleName Module getSigOf :: DynFlags -> ModuleName -> Maybe Module getSigOf dflags n = Map.lookup n (sigOf dflags) --- NameCache updNameCache -type PackageKeyEnv = UniqFM -type PackageKeyCache = PackageKeyEnv ShPackageKey - --- | An elaborated representation of a 'PackageKey', which records --- all of the components that go into the hashed 'PackageKey'. -data ShPackageKey - = ShPackageKey { - shPackageKeyUnitName :: !UnitName, - shPackageKeyLibraryName :: !LibraryName, - shPackageKeyInsts :: ![(ModuleName, Module)], - shPackageKeyFreeHoles :: UniqSet ModuleName - } - | ShDefinitePackageKey { - shPackageKey :: !PackageKey - } - deriving Eq - -instance Outputable ShPackageKey where - ppr (ShPackageKey pn vh insts fh) - = ppr pn <+> ppr vh <+> ppr insts <+> parens (ppr fh) - ppr (ShDefinitePackageKey pk) = ppr pk - -- | Contains not only a collection of 'GeneralFlag's but also a plethora of -- information relating to the compilation of a single file or GHC session data DynFlags = DynFlags { @@ -734,10 +705,7 @@ data DynFlags = DynFlags { solverIterations :: IntWithInf, -- ^ Number of iterations in the constraints solver -- Typically only 1 is needed - thisPackage :: PackageKey, -- ^ key of package currently being compiled - thisLibraryName :: LibraryName, - -- ^ the version hash which identifies the textual - -- package being compiled. + thisPackage :: UnitId, -- ^ key of package currently being compiled -- ways ways :: [Way], -- ^ Way flags from the command line @@ -824,7 +792,6 @@ data DynFlags = DynFlags { -- Packages.initPackages pkgDatabase :: Maybe [PackageConfig], pkgState :: PackageState, - pkgKeyCache :: {-# UNPACK #-} !(IORef PackageKeyCache), -- Temporary files -- These have to be IORefs, because the defaultCleanupHandler needs to @@ -902,8 +869,6 @@ data DynFlags = DynFlags { interactivePrint :: Maybe String, - llvmVersion :: IORef Int, - nextWrapperNum :: IORef (ModuleEnv Int), -- | Machine dependant flags (-m<blah> stuff) @@ -1153,7 +1118,7 @@ isNoLink _ = False data PackageArg = PackageArg String -- ^ @-package@, by 'PackageName' | PackageIdArg String -- ^ @-package-id@, by 'SourcePackageId' - | PackageKeyArg String -- ^ @-package-key@, by 'InstalledPackageId' + | UnitIdArg String -- ^ @-package-key@, by 'ComponentId' deriving (Eq, Show) -- | Represents the renaming that may be associated with an exposed @@ -1411,7 +1376,6 @@ initDynFlags dflags = do refDirsToClean <- newIORef Map.empty refFilesToNotIntermediateClean <- newIORef [] refGeneratedDumps <- newIORef Set.empty - refLlvmVersion <- newIORef 28 refRtldInfo <- newIORef Nothing refRtccInfo <- newIORef Nothing wrapperNum <- newIORef emptyModuleEnv @@ -1428,7 +1392,6 @@ initDynFlags dflags = do dirsToClean = refDirsToClean, filesToNotIntermediateClean = refFilesToNotIntermediateClean, generatedDumps = refGeneratedDumps, - llvmVersion = refLlvmVersion, nextWrapperNum = wrapperNum, useUnicode = canUseUnicode, rtldInfo = refRtldInfo, @@ -1473,8 +1436,7 @@ defaultDynFlags mySettings = reductionDepth = treatZeroAsInf mAX_REDUCTION_DEPTH, solverIterations = treatZeroAsInf mAX_SOLVER_ITERATIONS, - thisPackage = mainPackageKey, - thisLibraryName = LibraryName nilFS, + thisPackage = mainUnitId, objectDir = Nothing, dylibInstallName = Nothing, @@ -1520,7 +1482,6 @@ defaultDynFlags mySettings = pkgDatabase = Nothing, -- This gets filled in with GHC.setSessionDynFlags pkgState = emptyPackageState, - pkgKeyCache = v_unsafePkgKeyCache, ways = defaultWays mySettings, buildTag = mkBuildTag (defaultWays mySettings), rtsBuildTag = mkBuildTag (defaultWays mySettings), @@ -1583,7 +1544,6 @@ defaultDynFlags mySettings = useUnicode = False, traceLevel = 1, profAuto = NoProfAuto, - llvmVersion = panic "defaultDynFlags: No llvmVersion", interactivePrint = Nothing, nextWrapperNum = panic "defaultDynFlags: No nextWrapperNum", sseVersion = Nothing, @@ -1954,10 +1914,10 @@ parseSigOf str = case filter ((=="").snd) (readP_to_S parse str) of m <- tok $ parseModule return (n, m) parseModule = do - pk <- munch1 (\c -> isAlphaNum c || c `elem` "-_") + pk <- munch1 (\c -> isAlphaNum c || c `elem` "-_.") _ <- R.char ':' m <- parseModuleName - return (mkModule (stringToPackageKey pk) m) + return (mkModule (stringToUnitId pk) m) tok m = skipSpaces >> m setSigOf :: String -> DynFlags -> DynFlags @@ -2766,13 +2726,12 @@ package_flags = [ deprecate "Use -no-user-package-db instead") , defGhcFlag "package-name" (HasArg $ \name -> do - upd (setPackageKey name) + upd (setUnitId name) deprecate "Use -this-package-key instead") - , defGhcFlag "this-package-key" (hasArg setPackageKey) - , defGhcFlag "library-name" (hasArg setLibraryName) + , defGhcFlag "this-package-key" (hasArg setUnitId) , defFlag "package-id" (HasArg exposePackageId) , defFlag "package" (HasArg exposePackage) - , defFlag "package-key" (HasArg exposePackageKey) + , defFlag "package-key" (HasArg exposeUnitId) , defFlag "hide-package" (HasArg hidePackage) , defFlag "hide-all-packages" (NoArg (setGeneralFlag Opt_HideAllPackages)) , defFlag "package-env" (HasArg setPackageEnv) @@ -2877,7 +2836,8 @@ fWarningFlags = [ Opt_WarnAlternativeLayoutRuleTransitional, flagSpec' "warn-amp" Opt_WarnAMP (\_ -> deprecate "it has no effect, and will be removed in GHC 7.12"), - flagSpec "warn-auto-orphans" Opt_WarnAutoOrphans, + flagSpec' "warn-auto-orphans" Opt_WarnAutoOrphans + (\_ -> deprecate "it has no effect"), flagSpec "warn-deferred-type-errors" Opt_WarnDeferredTypeErrors, flagSpec "warn-deprecations" Opt_WarnWarningsDeprecations, flagSpec "warn-deprecated-flags" Opt_WarnDeprecatedFlags, @@ -3751,15 +3711,15 @@ parsePackageFlag constr str = case filter ((=="").snd) (readP_to_S parse str) of return (orig, orig)) tok m = m >>= \x -> skipSpaces >> return x -exposePackage, exposePackageId, exposePackageKey, hidePackage, ignorePackage, +exposePackage, exposePackageId, exposeUnitId, hidePackage, ignorePackage, trustPackage, distrustPackage :: String -> DynP () exposePackage p = upd (exposePackage' p) exposePackageId p = upd (\s -> s{ packageFlags = parsePackageFlag PackageIdArg p : packageFlags s }) -exposePackageKey p = +exposeUnitId p = upd (\s -> s{ packageFlags = - parsePackageFlag PackageKeyArg p : packageFlags s }) + parsePackageFlag UnitIdArg p : packageFlags s }) hidePackage p = upd (\s -> s{ packageFlags = HidePackage p : packageFlags s }) ignorePackage p = @@ -3774,11 +3734,8 @@ exposePackage' p dflags = dflags { packageFlags = parsePackageFlag PackageArg p : packageFlags dflags } -setPackageKey :: String -> DynFlags -> DynFlags -setPackageKey p s = s{ thisPackage = stringToPackageKey p } - -setLibraryName :: String -> DynFlags -> DynFlags -setLibraryName v s = s{ thisLibraryName = LibraryName (mkFastString v) } +setUnitId :: String -> DynFlags -> DynFlags +setUnitId p s = s{ thisPackage = stringToUnitId p } -- ----------------------------------------------------------------------------- -- | Find the package environment (if one exists) @@ -3927,10 +3884,10 @@ setMainIs arg | not (null main_fn) && isLower (head main_fn) -- The arg looked like "Foo.Bar.baz" = upd $ \d -> d{ mainFunIs = Just main_fn, - mainModIs = mkModule mainPackageKey (mkModuleName main_mod) } + mainModIs = mkModule mainUnitId (mkModuleName main_mod) } | isUpper (head arg) -- The arg looked like "Foo" or "Foo.Bar" - = upd $ \d -> d{ mainModIs = mkModule mainPackageKey (mkModuleName arg) } + = upd $ \d -> d{ mainModIs = mkModule mainUnitId (mkModuleName arg) } | otherwise -- The arg looked like "baz" = upd $ \d -> d{ mainFunIs = Just arg } @@ -4120,6 +4077,7 @@ compilerInfo dflags ("Support parallel --make", "YES"), ("Support reexported-modules", "YES"), ("Support thinning and renaming package flags", "YES"), + ("Requires unified installed package IDs", "YES"), ("Uses package keys", "YES"), ("Dynamic by default", if dYNAMIC_BY_DEFAULT dflags then "YES" else "NO"), @@ -4270,8 +4228,6 @@ unsafeGlobalDynFlags = unsafePerformIO $ readIORef v_unsafeGlobalDynFlags setUnsafeGlobalDynFlags :: DynFlags -> IO () setUnsafeGlobalDynFlags = writeIORef v_unsafeGlobalDynFlags -GLOBAL_VAR(v_unsafePkgKeyCache, emptyUFM, PackageKeyCache) - -- ----------------------------------------------------------------------------- -- SSE and AVX diff --git a/compiler/main/Finder.hs b/compiler/main/Finder.hs index 208475fefb..1ccf33f668 100644 --- a/compiler/main/Finder.hs +++ b/compiler/main/Finder.hs @@ -72,7 +72,7 @@ flushFinderCaches hsc_env = where this_pkg = thisPackage (hsc_dflags hsc_env) fc_ref = hsc_FC hsc_env - is_ext mod _ | modulePackageKey mod /= this_pkg = True + is_ext mod _ | moduleUnitId mod /= this_pkg = True | otherwise = False addToFinderCache :: IORef FinderCache -> Module -> FindResult -> IO () @@ -121,7 +121,7 @@ findImportedModule hsc_env mod_name mb_pkg = findExactModule :: HscEnv -> Module -> IO FindResult findExactModule hsc_env mod = let dflags = hsc_dflags hsc_env - in if modulePackageKey mod == thisPackage dflags + in if moduleUnitId mod == thisPackage dflags then findHomeModule hsc_env (moduleName mod) else findPackageModule hsc_env mod @@ -167,8 +167,8 @@ findExposedPackageModule hsc_env mod_name mb_pkg return (FoundMultiple rs) LookupHidden pkg_hiddens mod_hiddens -> return (NotFound{ fr_paths = [], fr_pkg = Nothing - , fr_pkgs_hidden = map (modulePackageKey.fst) pkg_hiddens - , fr_mods_hidden = map (modulePackageKey.fst) mod_hiddens + , fr_pkgs_hidden = map (moduleUnitId.fst) pkg_hiddens + , fr_mods_hidden = map (moduleUnitId.fst) mod_hiddens , fr_suggestions = [] }) LookupNotFound suggest -> return (NotFound{ fr_paths = [], fr_pkg = Nothing @@ -211,7 +211,7 @@ uncacheModule hsc_env mod = do -- 2. When you have a package qualified import with package name "this", -- we shortcut to the home module. -- --- 3. When we look up an exact 'Module', if the package key associated with +-- 3. When we look up an exact 'Module', if the unit id associated with -- the module is the current home module do a look up in the home module. -- -- 4. Some special-case code in GHCi (ToDo: Figure out why that needs to @@ -258,7 +258,7 @@ findPackageModule :: HscEnv -> Module -> IO FindResult findPackageModule hsc_env mod = do let dflags = hsc_dflags hsc_env - pkg_id = modulePackageKey mod + pkg_id = moduleUnitId mod -- case lookupPackage dflags pkg_id of Nothing -> return (NoPackage pkg_id) @@ -268,12 +268,12 @@ findPackageModule hsc_env mod = do -- requires a few invariants to be upheld: (1) the 'Module' in question must -- be the module identifier of the *original* implementation of a module, -- not a reexport (this invariant is upheld by @Packages.hs@) and (2) --- the 'PackageConfig' must be consistent with the package key in the 'Module'. +-- the 'PackageConfig' must be consistent with the unit id in the 'Module'. -- The redundancy is to avoid an extra lookup in the package state -- for the appropriate config. findPackageModule_ :: HscEnv -> Module -> PackageConfig -> IO FindResult findPackageModule_ hsc_env mod pkg_conf = - ASSERT( modulePackageKey mod == packageConfigId pkg_conf ) + ASSERT( moduleUnitId mod == packageConfigId pkg_conf ) modLocationCache hsc_env mod $ -- special case for GHC.Prim; we won't find it in the filesystem. @@ -343,7 +343,7 @@ searchPathExts paths mod exts ] search [] = return (NotFound { fr_paths = map fst to_search - , fr_pkg = Just (modulePackageKey mod) + , fr_pkg = Just (moduleUnitId mod) , fr_mods_hidden = [], fr_pkgs_hidden = [] , fr_suggestions = [] }) @@ -531,7 +531,7 @@ cantFindErr _ multiple_found _ mod_name (FoundMultiple mods) where unambiguousPackages = foldl' unambiguousPackage (Just []) mods unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _) - = Just (modulePackageKey m : xs) + = Just (moduleUnitId m : xs) unambiguousPackage _ _ = Nothing pprMod (m, o) = ptext (sLit "it is bound as") <+> ppr m <+> @@ -539,7 +539,7 @@ cantFindErr _ multiple_found _ mod_name (FoundMultiple mods) pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden" pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma ( if e == Just True - then [ptext (sLit "package") <+> ppr (modulePackageKey m)] + then [ptext (sLit "package") <+> ppr (moduleUnitId m)] else [] ++ map ((ptext (sLit "a reexport in package") <+>) .ppr.packageConfigId) res ++ @@ -553,7 +553,7 @@ cantFindErr cannot_find _ dflags mod_name find_result more_info = case find_result of NoPackage pkg - -> ptext (sLit "no package key matching") <+> quotes (ppr pkg) <+> + -> ptext (sLit "no unit id matching") <+> quotes (ppr pkg) <+> ptext (sLit "was found") $$ looks_like_srcpkgid pkg NotFound { fr_paths = files, fr_pkg = mb_pkg @@ -600,11 +600,11 @@ cantFindErr cannot_find _ dflags mod_name find_result | otherwise = hang (ptext (sLit "Locations searched:")) 2 $ vcat (map text files) - pkg_hidden :: PackageKey -> SDoc + pkg_hidden :: UnitId -> SDoc pkg_hidden pkgid = ptext (sLit "It is a member of the hidden package") <+> quotes (ppr pkgid) - --FIXME: we don't really want to show the package key here we should + --FIXME: we don't really want to show the unit id here we should -- show the source package id or installed package id if it's ambiguous <> dot $$ cabal_pkg_hidden_hint pkgid cabal_pkg_hidden_hint pkgid @@ -615,13 +615,13 @@ cantFindErr cannot_find _ dflags mod_name find_result ptext (sLit "to the build-depends in your .cabal file.") | otherwise = Outputable.empty - looks_like_srcpkgid :: PackageKey -> SDoc + looks_like_srcpkgid :: UnitId -> SDoc looks_like_srcpkgid pk - -- Unsafely coerce a package key FastString into a source package ID + -- Unsafely coerce a unit id FastString into a source package ID -- FastString and see if it means anything. - | (pkg:pkgs) <- searchPackageId dflags (SourcePackageId (packageKeyFS pk)) - = parens (text "This package key looks like the source package ID;" $$ - text "the real package key is" <+> quotes (ftext (packageKeyFS (packageKey pkg))) $$ + | (pkg:pkgs) <- searchPackageId dflags (SourcePackageId (unitIdFS pk)) + = parens (text "This unit ID looks like the source package ID;" $$ + text "the real unit ID is" <+> quotes (ftext (unitIdFS (unitId pkg))) $$ (if null pkgs then Outputable.empty else text "and" <+> int (length pkgs) <+> text "other candidates")) -- Todo: also check if it looks like a package name! @@ -645,9 +645,9 @@ cantFindErr cannot_find _ dflags mod_name find_result fromExposedReexport = res, fromPackageFlag = f }) | Just True <- e - = parens (ptext (sLit "from") <+> ppr (modulePackageKey mod)) + = parens (ptext (sLit "from") <+> ppr (moduleUnitId mod)) | f && moduleName mod == m - = parens (ptext (sLit "from") <+> ppr (modulePackageKey mod)) + = parens (ptext (sLit "from") <+> ppr (moduleUnitId mod)) | (pkg:_) <- res = parens (ptext (sLit "from") <+> ppr (packageConfigId pkg) <> comma <+> ptext (sLit "reexporting") <+> ppr mod) @@ -661,8 +661,8 @@ cantFindErr cannot_find _ dflags mod_name find_result fromHiddenReexport = rhs }) | Just False <- e = parens (ptext (sLit "needs flag -package-key") - <+> ppr (modulePackageKey mod)) + <+> ppr (moduleUnitId mod)) | (pkg:_) <- rhs - = parens (ptext (sLit "needs flag -package-key") + = parens (ptext (sLit "needs flag -package-id") <+> ppr (packageConfigId pkg)) | otherwise = Outputable.empty diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 17c0a0da2f..1f7b1173cb 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -156,10 +156,10 @@ module GHC ( -- * Abstract syntax elements -- ** Packages - PackageKey, + UnitId, -- ** Modules - Module, mkModule, pprModule, moduleName, modulePackageKey, + Module, mkModule, pprModule, moduleName, moduleUnitId, ModuleName, mkModuleName, moduleNameString, -- ** Names @@ -399,7 +399,6 @@ defaultErrorHandler fm (FlushOut flushOut) inner = (\ge -> liftIO $ do flushOut case ge of - PhaseFailed _ code -> exitWith code Signal _ -> exitWith (ExitFailure 1) _ -> do fatalErrorMsg'' fm (show ge) exitWith (ExitFailure 1) @@ -570,7 +569,7 @@ checkBrokenTablesNextToCode' dflags -- flags. If you are not doing linking or doing static linking, you -- can ignore the list of packages returned. -- -setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageKey] +setSessionDynFlags :: GhcMonad m => DynFlags -> m [UnitId] setSessionDynFlags dflags = do dflags' <- checkNewDynFlags dflags (dflags'', preload) <- liftIO $ initPackages dflags' @@ -580,7 +579,7 @@ setSessionDynFlags dflags = do return preload -- | Sets the program 'DynFlags'. -setProgramDynFlags :: GhcMonad m => DynFlags -> m [PackageKey] +setProgramDynFlags :: GhcMonad m => DynFlags -> m [UnitId] setProgramDynFlags dflags = do dflags' <- checkNewDynFlags dflags (dflags'', preload) <- liftIO $ initPackages dflags' @@ -1361,7 +1360,7 @@ showRichTokenStream ts = go startLoc ts "" -- ----------------------------------------------------------------------------- -- Interactive evaluation --- | Takes a 'ModuleName' and possibly a 'PackageKey', and consults the +-- | Takes a 'ModuleName' and possibly a 'UnitId', and consults the -- filesystem and package database to find the corresponding 'Module', -- using the algorithm that is used for an @import@ declaration. findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module @@ -1371,7 +1370,7 @@ findModule mod_name maybe_pkg = withSession $ \hsc_env -> do this_pkg = thisPackage dflags -- case maybe_pkg of - Just pkg | fsToPackageKey pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do + Just pkg | fsToUnitId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do res <- findImportedModule hsc_env mod_name maybe_pkg case res of Found _ m -> return m @@ -1383,7 +1382,7 @@ findModule mod_name maybe_pkg = withSession $ \hsc_env -> do Nothing -> liftIO $ do res <- findImportedModule hsc_env mod_name maybe_pkg case res of - Found loc m | modulePackageKey m /= this_pkg -> return m + Found loc m | moduleUnitId m /= this_pkg -> return m | otherwise -> modNotLoadedError dflags m loc err -> throwOneError $ noModError dflags noSrcSpan mod_name err @@ -1428,7 +1427,7 @@ isModuleTrusted m = withSession $ \hsc_env -> liftIO $ hscCheckSafe hsc_env m noSrcSpan -- | Return if a module is trusted and the pkgs it depends on to be trusted. -moduleTrustReqs :: GhcMonad m => Module -> m (Bool, [PackageKey]) +moduleTrustReqs :: GhcMonad m => Module -> m (Bool, [UnitId]) moduleTrustReqs m = withSession $ \hsc_env -> liftIO $ hscGetSafe hsc_env m noSrcSpan diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index 3d29b1d38e..65df44b83d 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -34,10 +34,8 @@ import ErrUtils import Finder import GhcMonad import HeaderInfo -import HsSyn import HscTypes import Module -import RdrName ( RdrName ) import TcIface ( typecheckIface ) import TcRnMonad ( initIfaceCheck ) @@ -1627,7 +1625,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots calcDeps summ | HsBootFile <- ms_hsc_src summ , Just m <- getSigOf (hsc_dflags hsc_env) (moduleName (ms_mod summ)) - , modulePackageKey m == thisPackage (hsc_dflags hsc_env) + , moduleUnitId m == thisPackage (hsc_dflags hsc_env) = (noLoc (moduleName m), NotBoot) : msDeps summ | otherwise = msDeps summ @@ -1720,9 +1718,9 @@ msDeps s = then [ (noLoc (moduleName (ms_mod s)), IsBoot) ] else [] -home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName] -home_imps imps = [ ideclName i | L _ i <- imps, - isLocal (fmap sl_fs $ ideclPkgQual i) ] +home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName] +home_imps imps = [ lmodname | (mb_pkg, lmodname) <- imps, + isLocal mb_pkg ] where isLocal Nothing = True isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special isLocal _ = False @@ -1922,7 +1920,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) just_found location mod | otherwise -> -- Drop external-pkg - ASSERT(modulePackageKey mod /= thisPackage dflags) + ASSERT(moduleUnitId mod /= thisPackage dflags) return Nothing err -> return $ Just $ Left $ noModError dflags loc wanted_mod err diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index 3473a4ab88..b4c3f81678 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -37,6 +37,7 @@ import Maybes import Bag ( emptyBag, listToBag, unitBag ) import MonadUtils import Exception +import BasicTypes import Control.Monad import System.IO @@ -54,7 +55,9 @@ getImports :: DynFlags -- reporting parse error locations. -> FilePath -- ^ The original source filename (used for locations -- in the function result) - -> IO ([Located (ImportDecl RdrName)], [Located (ImportDecl RdrName)], Located ModuleName) + -> IO ([(Maybe FastString, Located ModuleName)], + [(Maybe FastString, Located ModuleName)], + Located ModuleName) -- ^ The source imports, normal imports, and the module name. getImports dflags buf filename source_filename = do let loc = mkRealSrcLoc (mkFastString filename) 1 1 @@ -83,8 +86,11 @@ getImports dflags buf filename source_filename = do implicit_prelude = xopt Opt_ImplicitPrelude dflags implicit_imports = mkPrelImports (unLoc mod) main_loc implicit_prelude imps + convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i) in - return (src_idecls, implicit_imports ++ ordinary_imps, mod) + return (map convImport src_idecls, + map convImport (implicit_imports ++ ordinary_imps), + mod) mkPrelImports :: ModuleName -> SrcSpan -- Attribute the "import Prelude" to this location diff --git a/compiler/main/Hooks.hs b/compiler/main/Hooks.hs index f9339b1cef..f75214b4f4 100644 --- a/compiler/main/Hooks.hs +++ b/compiler/main/Hooks.hs @@ -14,7 +14,6 @@ module Hooks ( Hooks , tcForeignImportsHook , tcForeignExportsHook , hscFrontendHook - , hscCompileOneShotHook , hscCompileCoreExprHook , ghcPrimIfaceHook , runPhaseHook @@ -58,14 +57,12 @@ import Data.Maybe emptyHooks :: Hooks emptyHooks = Hooks Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing data Hooks = Hooks { dsForeignsHook :: Maybe ([LForeignDecl Id] -> DsM (ForeignStubs, OrdList (Id, CoreExpr))) , tcForeignImportsHook :: Maybe ([LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt)) , tcForeignExportsHook :: Maybe ([LForeignDecl Name] -> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt)) - , hscFrontendHook :: Maybe (ModSummary -> Hsc TcGblEnv) - , hscCompileOneShotHook :: Maybe (HscEnv -> ModSummary -> SourceModified -> IO HscStatus) + , hscFrontendHook :: Maybe (ModSummary -> Hsc FrontendResult) , hscCompileCoreExprHook :: Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO HValue) , ghcPrimIfaceHook :: Maybe ModIface , runPhaseHook :: Maybe (PhasePlus -> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath)) diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index e5c6ce14ec..64143e0c03 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -19,10 +19,11 @@ -- from here on in (although it has mutable components, for the -- caches). -- --- Warning messages are dealt with consistently throughout this API: --- during compilation warnings are collected, and before any function --- in @HscMain@ returns, the warnings are either printed, or turned --- into a real compialtion error if the @-Werror@ flag is enabled. +-- We use the Hsc monad to deal with warning messages consistently: +-- specifically, while executing within an Hsc monad, warnings are +-- collected. When a Hsc monad returns to an IO monad, the +-- warnings are printed, or compilation aborts if the @-Werror@ +-- flag is enabled. -- -- (c) The GRASP/AQUA Project, Glasgow University, 1993-2000 -- @@ -36,12 +37,11 @@ module HscMain -- * Compiling complete source files , Messager, batchMsg , HscStatus (..) - , hscCompileOneShot + , hscIncrementalCompile , hscCompileCmmFile , hscCompileCore - , genericHscCompileGetFrontendResult - , genericHscMergeRequirement + , hscIncrementalFrontend , genModDetails , hscSimpleIface @@ -58,12 +58,14 @@ module HscMain , makeSimpleDetails , hscSimplify -- ToDo, shouldn't really export this + -- * Safe Haskell + , hscCheckSafe + , hscGetSafe + -- * Support for interactive evaluation , hscParseIdentifier , hscTcRcLookupName , hscTcRnGetInfo - , hscCheckSafe - , hscGetSafe #ifdef GHCI , hscIsGHCiMonad , hscGetModuleInterface @@ -458,7 +460,7 @@ makeSimpleIface :: HscEnv -> Maybe ModIface -> TcGblEnv -> ModDetails -> IO (ModIface,Bool) makeSimpleIface hsc_env maybe_old_iface tc_result details = runHsc hsc_env $ do safe_mode <- hscGetSafeMode tc_result - ioMsgMaybe $ do + liftIO $ do mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) safe_mode details tc_result @@ -513,73 +515,38 @@ This is the only thing that isn't caught by the type-system. type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModSummary -> IO () --- | Analogous to 'genericHscCompileGetFrontendResult', this function --- calls 'hscMergeFrontEnd' if recompilation is necessary. It does --- not write out the resulting 'ModIface' (see 'compileOne'). --- TODO: maybe fold this 'genericHscCompileGetFrontendResult' into --- some higher-order function -genericHscMergeRequirement :: - Maybe Messager - -> HscEnv - -> ModSummary - -> Maybe ModIface -- Old interface, if available - -> (Int,Int) -- (i,n) = module i of n (for msgs) - -> IO (Either ModIface (ModIface, Maybe Fingerprint)) -genericHscMergeRequirement mHscMessage - hsc_env mod_summary mb_old_iface mod_index = do - let msg what = case mHscMessage of - Just hscMessage -> - hscMessage hsc_env mod_index what mod_summary - Nothing -> return () - - skip iface = do - msg UpToDate - return (Left iface) - - -- TODO: hook this - compile mb_old_hash reason = do - msg reason - r <- hscMergeFrontEnd hsc_env mod_summary - return $ Right (r, mb_old_hash) - - (recomp_reqd, mb_checked_iface) - <- {-# SCC "checkOldIface" #-} - checkOldIface hsc_env mod_summary - SourceUnmodified mb_old_iface - case mb_checked_iface of - Just iface | not (recompileRequired recomp_reqd) -> skip iface - _ -> compile (fmap mi_iface_hash mb_checked_iface) recomp_reqd - --- | This function runs 'genericHscFrontend' if recompilation is necessary. --- It does not write out the results of typechecking (see 'compileOne'). -genericHscCompileGetFrontendResult :: - Bool -- always do basic recompilation check? - -> Maybe TcGblEnv - -> Maybe Messager - -> HscEnv - -> ModSummary - -> SourceModified - -> Maybe ModIface -- Old interface, if available - -> (Int,Int) -- (i,n) = module i of n (for msgs) - -> IO (Either ModIface (TcGblEnv, Maybe Fingerprint)) - -genericHscCompileGetFrontendResult +-- | This function runs GHC's frontend with recompilation +-- avoidance. Specifically, it checks if recompilation is needed, +-- and if it is, it parses and typechecks the input module. +-- It does not write out the results of typechecking (See +-- compileOne and hscIncrementalCompile). +hscIncrementalFrontend :: Bool -- always do basic recompilation check? + -> Maybe TcGblEnv + -> Maybe Messager + -> ModSummary + -> SourceModified + -> Maybe ModIface -- Old interface, if available + -> (Int,Int) -- (i,n) = module i of n (for msgs) + -> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint)) + +hscIncrementalFrontend always_do_basic_recompilation_check m_tc_result - mHscMessage hsc_env mod_summary source_modified mb_old_iface mod_index + mHscMessage mod_summary source_modified mb_old_iface mod_index = do + hsc_env <- getHscEnv let msg what = case mHscMessage of Just hscMessage -> hscMessage hsc_env mod_index what mod_summary Nothing -> return () skip iface = do - msg UpToDate + liftIO $ msg UpToDate return $ Left iface compile mb_old_hash reason = do - msg reason - tc_result <- runHsc hsc_env $ genericHscFrontend mod_summary - return $ Right (tc_result, mb_old_hash) + liftIO $ msg reason + result <- genericHscFrontend mod_summary + return $ Right (result, mb_old_hash) stable = case source_modified of SourceUnmodifiedAndStable -> True @@ -588,11 +555,11 @@ genericHscCompileGetFrontendResult case m_tc_result of Just tc_result | not always_do_basic_recompilation_check -> - return $ Right (tc_result, Nothing) + return $ Right (FrontendTypecheck tc_result, Nothing) _ -> do (recomp_reqd, mb_checked_iface) <- {-# SCC "checkOldIface" #-} - checkOldIface hsc_env mod_summary + liftIO $ checkOldIface hsc_env mod_summary source_modified mb_old_iface -- save the interface that comes back from checkOldIface. -- In one-shot mode we don't have the old iface until this @@ -624,101 +591,149 @@ genericHscCompileGetFrontendResult case m_tc_result of Nothing -> compile mb_old_hash recomp_reqd Just tc_result -> - return $ Right (tc_result, mb_old_hash) + return $ Right (FrontendTypecheck tc_result, mb_old_hash) -genericHscFrontend :: ModSummary -> Hsc TcGblEnv +genericHscFrontend :: ModSummary -> Hsc FrontendResult genericHscFrontend mod_summary = getHooked hscFrontendHook genericHscFrontend' >>= ($ mod_summary) -genericHscFrontend' :: ModSummary -> Hsc TcGblEnv -genericHscFrontend' mod_summary = hscFileFrontEnd mod_summary +genericHscFrontend' :: ModSummary -> Hsc FrontendResult +genericHscFrontend' mod_summary + | ms_hsc_src mod_summary == HsBootMerge + = FrontendMerge `fmap` hscMergeFrontEnd mod_summary + | otherwise + = FrontendTypecheck `fmap` hscFileFrontEnd mod_summary -------------------------------------------------------------- -- Compilers -------------------------------------------------------------- -hscCompileOneShot :: HscEnv - -> ModSummary - -> SourceModified - -> IO HscStatus -hscCompileOneShot env = - lookupHook hscCompileOneShotHook hscCompileOneShot' (hsc_dflags env) env - -- Compile Haskell/boot in OneShot mode. -hscCompileOneShot' :: HscEnv - -> ModSummary - -> SourceModified - -> IO HscStatus -hscCompileOneShot' hsc_env mod_summary src_changed +hscIncrementalCompile :: Bool + -> Maybe TcGblEnv + -> Maybe Messager + -> HscEnv + -> ModSummary + -> SourceModified + -> Maybe ModIface + -> (Int,Int) + -- HomeModInfo does not contain linkable, since we haven't + -- code-genned yet + -> IO (HscStatus, HomeModInfo) +hscIncrementalCompile always_do_basic_recompilation_check m_tc_result + mHscMessage hsc_env' mod_summary source_modified mb_old_iface mod_index = do -- One-shot mode needs a knot-tying mutable variable for interface -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var. type_env_var <- newIORef emptyNameEnv let mod = ms_mod mod_summary - hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) } - - msg what = oneShotMsg hsc_env' what + hsc_env = hsc_env'{ hsc_type_env_var = Just (mod, type_env_var) } - skip = do msg UpToDate - dumpIfaceStats hsc_env' - return HscUpToDate + -- NB: enter Hsc monad here so that we don't bail out early with + -- -Werror on typechecker warnings; we also want to run the desugarer + -- to get those warnings too. (But we'll always exit at that point + -- because the desugarer runs ioMsgMaybe.) + runHsc hsc_env $ do + let dflags = hsc_dflags hsc_env - compile mb_old_hash reason = runHsc hsc_env' $ do - liftIO $ msg reason - tc_result <- genericHscFrontend mod_summary - guts0 <- hscDesugar' (ms_location mod_summary) tc_result - dflags <- getDynFlags + e <- hscIncrementalFrontend always_do_basic_recompilation_check m_tc_result mHscMessage + mod_summary source_modified mb_old_iface mod_index + case e of + Left iface -> do + details <- liftIO $ genModDetails hsc_env iface + return (HscUpToDate, HomeModInfo{ + hm_details = details, + hm_iface = iface, + hm_linkable = Nothing + }) + Right (result, mb_old_hash) -> do + (status, hmi, no_change) <- case result of + FrontendTypecheck tc_result -> + if hscTarget dflags /= HscNothing && + ms_hsc_src mod_summary == HsSrcFile + then finish hsc_env mod_summary tc_result mb_old_hash + else finishTypecheckOnly hsc_env mod_summary tc_result mb_old_hash + FrontendMerge raw_iface -> + finishMerge hsc_env mod_summary raw_iface mb_old_hash + liftIO $ hscMaybeWriteIface dflags (hm_iface hmi) no_change mod_summary + return (status, hmi) + +-- Generates and writes out the final interface for an hs-boot merge. +finishMerge :: HscEnv + -> ModSummary + -> ModIface + -> Maybe Fingerprint + -> Hsc (HscStatus, HomeModInfo, Bool) +finishMerge hsc_env summary iface0 mb_old_hash = do + MASSERT( ms_hsc_src summary == HsBootMerge ) + (iface, changed) <- liftIO $ mkIfaceDirect hsc_env mb_old_hash iface0 + details <- liftIO $ genModDetails hsc_env iface + let dflags = hsc_dflags hsc_env + hsc_status = case hscTarget dflags of - HscNothing -> do - when (gopt Opt_WriteInterface dflags) $ liftIO $ do - (iface, changed, _details) <- hscSimpleIface hsc_env tc_result mb_old_hash - hscWriteIface dflags iface changed mod_summary - return HscNotGeneratingCode - _ -> - case ms_hsc_src mod_summary of - HsBootFile -> - do (iface, changed, _) <- hscSimpleIface' tc_result mb_old_hash - liftIO $ hscWriteIface dflags iface changed mod_summary - return HscUpdateBoot - HsSrcFile -> - do guts <- hscSimplify' guts0 - (iface, changed, _details, cgguts) <- hscNormalIface' guts mb_old_hash - liftIO $ hscWriteIface dflags iface changed mod_summary - return $ HscRecomp cgguts mod_summary - HsBootMerge -> panic "hscCompileOneShot HsBootMerge" - - -- XXX This is always False, because in one-shot mode the - -- concept of stability does not exist. The driver never - -- passes SourceUnmodifiedAndStable in here. - stable = case src_changed of - SourceUnmodifiedAndStable -> True - _ -> False - - (recomp_reqd, mb_checked_iface) - <- {-# SCC "checkOldIface" #-} - checkOldIface hsc_env' mod_summary src_changed Nothing - -- save the interface that comes back from checkOldIface. - -- In one-shot mode we don't have the old iface until this - -- point, when checkOldIface reads it from the disk. - let mb_old_hash = fmap mi_iface_hash mb_checked_iface - - case mb_checked_iface of - Just iface | not (recompileRequired recomp_reqd) -> - -- If the module used TH splices when it was last compiled, - -- then the recompilation check is not accurate enough (#481) - -- and we must ignore it. However, if the module is stable - -- (none of the modules it depends on, directly or indirectly, - -- changed), then we *can* skip recompilation. This is why - -- the SourceModified type contains SourceUnmodifiedAndStable, - -- and it's pretty important: otherwise ghc --make would - -- always recompile TH modules, even if nothing at all has - -- changed. Stability is just the same check that make is - -- doing for us in one-shot mode. - if mi_used_th iface && not stable - then compile mb_old_hash (RecompBecause "TH") - else skip - _ -> - compile mb_old_hash recomp_reqd + HscNothing -> HscNotGeneratingCode + _ -> HscUpdateBootMerge + return (hsc_status, + HomeModInfo{ hm_details = details, + hm_iface = iface, + hm_linkable = Nothing }, + changed) + +-- Generates and writes out the final interface for a typecheck. +finishTypecheckOnly :: HscEnv + -> ModSummary + -> TcGblEnv + -> Maybe Fingerprint + -> Hsc (HscStatus, HomeModInfo, Bool) +finishTypecheckOnly hsc_env summary tc_result mb_old_hash = do + let dflags = hsc_dflags hsc_env + MASSERT( hscTarget dflags == HscNothing || ms_hsc_src summary == HsBootFile ) + (iface, changed, details) <- liftIO $ hscSimpleIface hsc_env tc_result mb_old_hash + let hsc_status = + case (hscTarget dflags, ms_hsc_src summary) of + (HscNothing, _) -> HscNotGeneratingCode + (_, HsBootFile) -> HscUpdateBoot + _ -> panic "finishTypecheckOnly" + return (hsc_status, + HomeModInfo{ hm_details = details, + hm_iface = iface, + hm_linkable = Nothing }, + changed) + +-- Runs the post-typechecking frontend (desugar and simplify), +-- and then generates and writes out the final interface. We want +-- to write the interface AFTER simplification so we can get +-- as up-to-date and good unfoldings and other info as possible +-- in the interface file. This is only ever run for HsSrcFile, +-- and NOT for HscNothing. +finish :: HscEnv + -> ModSummary + -> TcGblEnv + -> Maybe Fingerprint + -> Hsc (HscStatus, HomeModInfo, Bool) +finish hsc_env summary tc_result mb_old_hash = do + let dflags = hsc_dflags hsc_env + MASSERT( ms_hsc_src summary == HsSrcFile ) + MASSERT( hscTarget dflags /= HscNothing ) + guts0 <- hscDesugar' (ms_location summary) tc_result + guts <- hscSimplify' guts0 + (iface, changed, details, cgguts) <- liftIO $ hscNormalIface hsc_env guts mb_old_hash + + return (HscRecomp cgguts summary, + HomeModInfo{ hm_details = details, + hm_iface = iface, + hm_linkable = Nothing }, + changed) + +hscMaybeWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO () +hscMaybeWriteIface dflags iface changed summary = + let force_write_interface = gopt Opt_WriteInterface dflags + write_interface = case hscTarget dflags of + HscNothing -> False + HscInterpreted -> False + _ -> True + in when (write_interface || force_write_interface) $ + hscWriteIface dflags iface changed summary -------------------------------------------------------------- -- NoRecomp handlers @@ -768,8 +783,9 @@ batchMsg hsc_env mod_index recomp mod_summary = -- | Given an 'HsBootMerge' 'ModSummary', merges all @hs-boot@ files -- under this module name into a composite, publically visible 'ModIface'. -hscMergeFrontEnd :: HscEnv -> ModSummary -> IO ModIface -hscMergeFrontEnd hsc_env mod_summary = do +hscMergeFrontEnd :: ModSummary -> Hsc ModIface +hscMergeFrontEnd mod_summary = do + hsc_env <- getHscEnv MASSERT( ms_hsc_src mod_summary == HsBootMerge ) let dflags = hsc_dflags hsc_env -- TODO: actually merge in signatures from external packages. @@ -783,7 +799,7 @@ hscMergeFrontEnd hsc_env mod_summary = do iface0 <- case lookupHptByModule hpt mod of Just hm -> return (hm_iface hm) Nothing -> do - mb_iface0 <- initIfaceCheck hsc_env + mb_iface0 <- liftIO . initIfaceCheck hsc_env $ findAndReadIface (text "merge-requirements") mod is_boot case mb_iface0 of @@ -949,7 +965,7 @@ checkSafeImports dflags tcg_env impInfo = tcg_imports tcg_env -- ImportAvails imports = imp_mods impInfo -- ImportedMods imports' = moduleEnvToList imports -- (Module, [ImportedModsVal]) - pkgReqs = imp_trust_pkgs impInfo -- [PackageKey] + pkgReqs = imp_trust_pkgs impInfo -- [UnitId] condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport) condense (_, []) = panic "HscMain.condense: Pattern match failure!" @@ -992,7 +1008,7 @@ hscCheckSafe hsc_env m l = runHsc hsc_env $ do return $ isEmptyBag errs -- | Return if a module is trusted and the pkgs it depends on to be trusted. -hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, [PackageKey]) +hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, [UnitId]) hscGetSafe hsc_env m l = runHsc hsc_env $ do dflags <- getDynFlags (self, pkgs) <- hscCheckSafe' dflags m l @@ -1006,15 +1022,15 @@ hscGetSafe hsc_env m l = runHsc hsc_env $ do -- Return (regardless of trusted or not) if the trust type requires the modules -- own package be trusted and a list of other packages required to be trusted -- (these later ones haven't been checked) but the own package trust has been. -hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe PackageKey, [PackageKey]) +hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe UnitId, [UnitId]) hscCheckSafe' dflags m l = do (tw, pkgs) <- isModSafe m l case tw of False -> return (Nothing, pkgs) True | isHomePkg m -> return (Nothing, pkgs) - | otherwise -> return (Just $ modulePackageKey m, pkgs) + | otherwise -> return (Just $ moduleUnitId m, pkgs) where - isModSafe :: Module -> SrcSpan -> Hsc (Bool, [PackageKey]) + isModSafe :: Module -> SrcSpan -> Hsc (Bool, [UnitId]) isModSafe m l = do iface <- lookup' m case iface of @@ -1046,7 +1062,7 @@ hscCheckSafe' dflags m l = do pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $ sep [ ppr (moduleName m) <> text ": Can't be safely imported!" - , text "The package (" <> ppr (modulePackageKey m) + , text "The package (" <> ppr (moduleUnitId m) <> text ") the module resides in isn't trusted." ] modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $ @@ -1066,7 +1082,7 @@ hscCheckSafe' dflags m l = do packageTrusted Sf_Safe False _ = True packageTrusted _ _ m | isHomePkg m = True - | otherwise = trusted $ getPackageDetails dflags (modulePackageKey m) + | otherwise = trusted $ getPackageDetails dflags (moduleUnitId m) lookup' :: Module -> Hsc (Maybe ModIface) lookup' m = do @@ -1090,11 +1106,11 @@ hscCheckSafe' dflags m l = do isHomePkg :: Module -> Bool isHomePkg m - | thisPackage dflags == modulePackageKey m = True + | thisPackage dflags == moduleUnitId m = True | otherwise = False -- | Check the list of packages are trusted. -checkPkgTrust :: DynFlags -> [PackageKey] -> Hsc () +checkPkgTrust :: DynFlags -> [UnitId] -> Hsc () checkPkgTrust dflags pkgs = case errors of [] -> return () @@ -1200,7 +1216,7 @@ hscSimpleIface' tc_result mb_old_iface = do safe_mode <- hscGetSafeMode tc_result (new_iface, no_change) <- {-# SCC "MkFinalIface" #-} - ioMsgMaybe $ + liftIO $ mkIfaceTc hsc_env mb_old_iface safe_mode details tc_result -- And the answer is ... liftIO $ dumpIfaceStats hsc_env @@ -1228,7 +1244,7 @@ hscNormalIface' simpl_result mb_old_iface = do -- until after code output (new_iface, no_change) <- {-# SCC "MkFinalIface" #-} - ioMsgMaybe $ + liftIO $ mkIface hsc_env mb_old_iface details simpl_result liftIO $ dumpIfaceStats hsc_env @@ -1508,7 +1524,7 @@ hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do handleWarnings -- Then code-gen, and link it - -- It's important NOT to have package 'interactive' as thisPackageKey + -- It's important NOT to have package 'interactive' as thisUnitId -- for linking, else we try to link 'main' and can't find it. -- Whereas the linker already knows to ignore 'interactive' let src_span = srcLocSpan interactiveSrcLoc diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index ce5d37f00a..317a9413ec 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -451,7 +451,7 @@ instance Outputable TargetId where -- | Helps us find information about modules in the home package type HomePackageTable = ModuleNameEnv HomeModInfo -- Domain = modules in the home package that have been fully compiled - -- "home" package key cached here for convenience + -- "home" unit id cached here for convenience -- | Helps us find information about modules in the imported packages type PackageIfaceTable = ModuleEnv ModIface @@ -683,7 +683,7 @@ type FinderCache = ModuleEnv FindResult data FindResult = Found ModLocation Module -- ^ The module was found - | NoPackage PackageKey + | NoPackage UnitId -- ^ The requested package was not found | FoundMultiple [(Module, ModuleOrigin)] -- ^ _Error_: both in multiple packages @@ -692,14 +692,14 @@ data FindResult | NotFound { fr_paths :: [FilePath] -- Places where I looked - , fr_pkg :: Maybe PackageKey -- Just p => module is in this package's + , fr_pkg :: Maybe UnitId -- Just p => module is in this package's -- manifest, but couldn't find -- the .hi file - , fr_mods_hidden :: [PackageKey] -- Module is in these packages, + , fr_mods_hidden :: [UnitId] -- Module is in these packages, -- but the *module* is hidden - , fr_pkgs_hidden :: [PackageKey] -- Module is in these packages, + , fr_pkgs_hidden :: [UnitId] -- Module is in these packages, -- but the *package* is hidden , fr_suggestions :: [ModuleSuggestion] -- Possible mis-spelled modules @@ -1123,7 +1123,7 @@ data CgGuts -- as part of the code-gen of tycons cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs - cg_dep_pkgs :: ![PackageKey], -- ^ Dependent packages, used to + cg_dep_pkgs :: ![UnitId], -- ^ Dependent packages, used to -- generate #includes for C code gen cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information cg_modBreaks :: !ModBreaks -- ^ Module breakpoints @@ -1162,7 +1162,7 @@ as if they were defined in modules interactive:Ghci2 ...etc... with each bunch of declarations using a new module, all sharing a -common package 'interactive' (see Module.interactivePackageKey, and +common package 'interactive' (see Module.interactiveUnitId, and PrelNames.mkInteractiveModule). This scheme deals well with shadowing. For example: @@ -1454,7 +1454,7 @@ shadowed_by ids = shadowed setInteractivePackage :: HscEnv -> HscEnv -- Set the 'thisPackage' DynFlag to 'interactive' setInteractivePackage hsc_env - = hsc_env { hsc_dflags = (hsc_dflags hsc_env) { thisPackage = interactivePackageKey } } + = hsc_env { hsc_dflags = (hsc_dflags hsc_env) { thisPackage = interactiveUnitId } } setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext setInteractivePrintName ic n = ic{ic_int_print = n} @@ -1538,20 +1538,13 @@ exposed (say P2), so we use M.T for that, and P1:M.T for the other one. This is handled by the qual_mod component of PrintUnqualified, inside the (ppr mod) of case (3), in Name.pprModulePrefix -Note [Printing package keys] +Note [Printing unit ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In the old days, original names were tied to PackageIds, which directly corresponded to the entities that users wrote in Cabal files, and were perfectly suitable for printing when we need to disambiguate packages. However, with -PackageKey, the situation is different. First, the key is not a human readable -at all, so we need to consult the package database to find the appropriate -PackageId to display. Second, there may be multiple copies of a library visible -with the same PackageId, in which case we need to disambiguate. For now, -we just emit the actual package key (which the user can go look up); however, -another scheme is to (recursively) say which dependencies are different. - -NB: When we extend package keys to also have holes, we will have to disambiguate -those as well. +UnitId, the situation can be different: if the key is instantiated with +some holes, we should try to give the user some more useful information. -} -- | Creates some functions that work out the best ways to format @@ -1563,7 +1556,7 @@ mkPrintUnqualified dflags env = QueryQualify qual_name where qual_name mod occ | [] <- unqual_gres - , modulePackageKey mod `elem` [primPackageKey, basePackageKey, thPackageKey] + , moduleUnitId mod `elem` [primUnitId, baseUnitId, thUnitId] , not (isDerivedOccName occ) = NameUnqual -- For names from ubiquitous packages that come with GHC, if -- there are no entities called unqualified 'occ', then @@ -1609,10 +1602,10 @@ mkPrintUnqualified dflags env = QueryQualify qual_name -- is only one exposed package which exports this module, don't qualify. mkQualModule :: DynFlags -> QueryQualifyModule mkQualModule dflags mod - | modulePackageKey mod == thisPackage dflags = False + | moduleUnitId mod == thisPackage dflags = False | [(_, pkgconfig)] <- lookup, - packageConfigId pkgconfig == modulePackageKey mod + packageConfigId pkgconfig == moduleUnitId mod -- this says: we are given a module P:M, is there just one exposed package -- that exposes a module M, and is it package P? = False @@ -1622,10 +1615,10 @@ mkQualModule dflags mod -- | Creates a function for formatting packages based on two heuristics: -- (1) don't qualify if the package in question is "main", and (2) only qualify --- with a package key if the package ID would be ambiguous. +-- with a unit id if the package ID would be ambiguous. mkQualPackage :: DynFlags -> QueryQualifyPackage mkQualPackage dflags pkg_key - | pkg_key == mainPackageKey || pkg_key == interactivePackageKey + | pkg_key == mainUnitId || pkg_key == interactiveUnitId -- Skip the lookup if it's main, since it won't be in the package -- database! = False @@ -2085,7 +2078,7 @@ data Dependencies -- I.e. modules that this one imports, or that are in the -- dep_mods of those directly-imported modules - , dep_pkgs :: [(PackageKey, Bool)] + , dep_pkgs :: [(UnitId, Bool)] -- ^ All packages transitively below this module -- I.e. packages to which this module's direct imports belong, -- or that are in the dep_pkgs of those modules @@ -2407,9 +2400,9 @@ data ModSummary -- ^ Timestamp of hi file, if we *only* are typechecking (it is -- 'Nothing' otherwise. -- See Note [Recompilation checking when typechecking only] and #9243 - ms_srcimps :: [Located (ImportDecl RdrName)], + ms_srcimps :: [(Maybe FastString, Located ModuleName)], -- ^ Source imports of the module - ms_textual_imps :: [Located (ImportDecl RdrName)], + ms_textual_imps :: [(Maybe FastString, Located ModuleName)], -- ^ Non-source imports of the module from the module *text* ms_merge_imps :: (Bool, [Module]), -- ^ Non-textual imports computed for HsBootMerge @@ -2425,26 +2418,12 @@ data ModSummary ms_mod_name :: ModSummary -> ModuleName ms_mod_name = moduleName . ms_mod -ms_imps :: ModSummary -> [Located (ImportDecl RdrName)] +ms_imps :: ModSummary -> [(Maybe FastString, Located ModuleName)] ms_imps ms = ms_textual_imps ms ++ map mk_additional_import (dynFlagDependencies (ms_hspp_opts ms)) where - -- This is a not-entirely-satisfactory means of creating an import - -- that corresponds to an import that did not occur in the program - -- text, such as those induced by the use of plugins (the -plgFoo - -- flag) - mk_additional_import mod_nm = noLoc $ ImportDecl { - ideclSourceSrc = Nothing, - ideclName = noLoc mod_nm, - ideclPkgQual = Nothing, - ideclSource = False, - ideclImplicit = True, -- Maybe implicit because not "in the program text" - ideclQualified = False, - ideclAs = Nothing, - ideclHiding = Nothing, - ideclSafe = False - } + mk_additional_import mod_nm = (Nothing, noLoc mod_nm) -- The ModLocation contains both the original source filename and the -- filename of the cleaned-up source file after all preprocessing has been diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 6b0c4851e1..2b2fdaf9e8 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -927,7 +927,7 @@ getContext = withSession $ \HscEnv{ hsc_IC=ic } -> -- its full top-level scope available. moduleIsInterpreted :: GhcMonad m => Module -> m Bool moduleIsInterpreted modl = withSession $ \h -> - if modulePackageKey modl /= thisPackage (hsc_dflags h) + if moduleUnitId modl /= thisPackage (hsc_dflags h) then return False else case lookupUFM (hsc_HPT h) (moduleName modl) of Just details -> return (isJust (mi_globals (hm_iface details))) diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs index 71a84d8622..3fdb0af1d3 100644 --- a/compiler/main/PackageConfig.hs +++ b/compiler/main/PackageConfig.hs @@ -9,23 +9,18 @@ module PackageConfig ( -- $package_naming - -- * PackageKey + -- * UnitId packageConfigId, - -- * LibraryName - LibraryName(..), - -- * The PackageConfig type: information about a package PackageConfig, InstalledPackageInfo(..), - InstalledPackageId(..), + ComponentId(..), SourcePackageId(..), PackageName(..), - UnitName(..), Version(..), - packageUnitName, defaultPackageConfig, - installedPackageIdString, + componentIdString, sourcePackageIdString, packageNameString, pprPackageConfig, @@ -42,29 +37,27 @@ import Module import Unique -- ----------------------------------------------------------------------------- --- Our PackageConfig type is the InstalledPackageInfo from bin-package-db, +-- Our PackageConfig type is the InstalledPackageInfo from ghc-boot, -- which is similar to a subset of the InstalledPackageInfo type from Cabal. type PackageConfig = InstalledPackageInfo - InstalledPackageId + ComponentId SourcePackageId PackageName - Module.PackageKey + Module.UnitId Module.ModuleName -- TODO: there's no need for these to be FastString, as we don't need the uniq -- feature, but ghc doesn't currently have convenient support for any -- other compact string types, e.g. plain ByteString or Text. -newtype InstalledPackageId = InstalledPackageId FastString deriving (Eq, Ord) +newtype ComponentId = ComponentId FastString deriving (Eq, Ord) newtype SourcePackageId = SourcePackageId FastString deriving (Eq, Ord) newtype PackageName = PackageName FastString deriving (Eq, Ord) -newtype UnitName = UnitName FastString deriving (Eq, Ord) -newtype LibraryName = LibraryName FastString deriving (Eq, Ord) -instance BinaryStringRep InstalledPackageId where - fromStringRep = InstalledPackageId . mkFastStringByteString - toStringRep (InstalledPackageId s) = fastStringToByteString s +instance BinaryStringRep ComponentId where + fromStringRep = ComponentId . mkFastStringByteString + toStringRep (ComponentId s) = fastStringToByteString s instance BinaryStringRep SourcePackageId where fromStringRep = SourcePackageId . mkFastStringByteString @@ -74,12 +67,8 @@ instance BinaryStringRep PackageName where fromStringRep = PackageName . mkFastStringByteString toStringRep (PackageName s) = fastStringToByteString s -instance BinaryStringRep LibraryName where - fromStringRep = LibraryName . mkFastStringByteString - toStringRep (LibraryName s) = fastStringToByteString s - -instance Uniquable InstalledPackageId where - getUnique (InstalledPackageId n) = getUnique n +instance Uniquable ComponentId where + getUnique (ComponentId n) = getUnique n instance Uniquable SourcePackageId where getUnique (SourcePackageId n) = getUnique n @@ -87,14 +76,8 @@ instance Uniquable SourcePackageId where instance Uniquable PackageName where getUnique (PackageName n) = getUnique n -instance Outputable InstalledPackageId where - ppr (InstalledPackageId str) = ftext str - -instance Outputable UnitName where - ppr (UnitName str) = ftext str - -instance Outputable LibraryName where - ppr (LibraryName str) = ftext str +instance Outputable ComponentId where + ppr (ComponentId str) = ftext str instance Outputable SourcePackageId where ppr (SourcePackageId str) = ftext str @@ -124,10 +107,10 @@ pprOriginalModule (OriginalModule originalPackageId originalModuleName) = defaultPackageConfig :: PackageConfig defaultPackageConfig = emptyInstalledPackageInfo -installedPackageIdString :: PackageConfig -> String -installedPackageIdString pkg = unpackFS str +componentIdString :: PackageConfig -> String +componentIdString pkg = unpackFS str where - InstalledPackageId str = installedPackageId pkg + ComponentId str = componentId pkg sourcePackageIdString :: PackageConfig -> String sourcePackageIdString pkg = unpackFS str @@ -144,8 +127,7 @@ pprPackageConfig InstalledPackageInfo {..} = vcat [ field "name" (ppr packageName), field "version" (text (showVersion packageVersion)), - field "id" (ppr installedPackageId), - field "key" (ppr packageKey), + field "id" (ppr componentId), field "exposed" (ppr exposed), field "exposed-modules" (if all isExposedModule exposedModules @@ -175,20 +157,16 @@ pprPackageConfig InstalledPackageInfo {..} = -- ----------------------------------------------------------------------------- --- PackageKey (package names, versions and dep hash) +-- UnitId (package names, versions and dep hash) -- $package_naming -- #package_naming# --- Mostly the compiler deals in terms of 'PackageKey's, which are md5 hashes +-- Mostly the compiler deals in terms of 'UnitId's, which are md5 hashes -- of a package ID, keys of its dependencies, and Cabal flags. You're expected --- to pass in the package key in the @-this-package-key@ flag. However, for +-- to pass in the unit id in the @-this-package-key@ flag. However, for -- wired-in packages like @base@ & @rts@, we don't necessarily know what the -- version is, so these are handled specially; see #wired_in_packages#. --- | Get the GHC 'PackageKey' right out of a Cabalish 'PackageConfig' -packageConfigId :: PackageConfig -> PackageKey -packageConfigId = packageKey - -packageUnitName :: PackageConfig -> UnitName -packageUnitName pkg = let PackageName fs = packageName pkg - in UnitName fs +-- | Get the GHC 'UnitId' right out of a Cabalish 'PackageConfig' +packageConfigId :: PackageConfig -> UnitId +packageConfigId = unitId diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs index bb0aba241e..0e32947b31 100644 --- a/compiler/main/Packages.hs +++ b/compiler/main/Packages.hs @@ -18,7 +18,6 @@ module Packages ( -- * Querying the package config lookupPackage, - resolveInstalledPackageId, searchPackageId, getPackageDetails, listVisibleModuleNames, @@ -41,7 +40,7 @@ module Packages ( packageHsLibs, -- * Utils - packageKeyPackageIdString, + unitIdPackageIdString, pprFlag, pprPackages, pprPackagesSimple, @@ -214,18 +213,18 @@ originEmpty :: ModuleOrigin -> Bool originEmpty (ModOrigin Nothing [] [] False) = True originEmpty _ = False --- | 'UniqFM' map from 'PackageKey' -type PackageKeyMap = UniqFM +-- | 'UniqFM' map from 'UnitId' +type UnitIdMap = UniqFM --- | 'UniqFM' map from 'PackageKey' to 'PackageConfig' -type PackageConfigMap = PackageKeyMap PackageConfig +-- | 'UniqFM' map from 'UnitId' to 'PackageConfig' +type PackageConfigMap = UnitIdMap PackageConfig --- | 'UniqFM' map from 'PackageKey' to (1) whether or not all modules which +-- | 'UniqFM' map from 'UnitId' to (1) whether or not all modules which -- are exposed should be dumped into scope, (2) any custom renamings that -- should also be apply, and (3) what package name is associated with the -- key, if it might be hidden type VisibilityMap = - PackageKeyMap (Bool, [(ModuleName, ModuleName)], FastString) + UnitIdMap (Bool, [(ModuleName, ModuleName)], FastString) -- | Map from 'ModuleName' to 'Module' to all the origins of the bindings -- in scope. The 'PackageConf' is not cached, mostly for convenience reasons @@ -234,7 +233,7 @@ type ModuleToPkgConfAll = Map ModuleName (Map Module ModuleOrigin) data PackageState = PackageState { - -- | A mapping of 'PackageKey' to 'PackageConfig'. This list is adjusted + -- | A mapping of 'UnitId' to 'PackageConfig'. This list is adjusted -- so that only valid packages are here. 'PackageConfig' reflects -- what was stored *on disk*, except for the 'trusted' flag, which -- is adjusted at runtime. (In particular, some packages in this map @@ -244,39 +243,32 @@ data PackageState = PackageState { -- | The packages we're going to link in eagerly. This list -- should be in reverse dependency order; that is, a package -- is always mentioned before the packages it depends on. - preloadPackages :: [PackageKey], + preloadPackages :: [UnitId], -- | This is a full map from 'ModuleName' to all modules which may possibly -- be providing it. These providers may be hidden (but we'll still want -- to report them in error messages), or it may be an ambiguous import. - moduleToPkgConfAll :: ModuleToPkgConfAll, - - -- | This is a map from 'InstalledPackageId' to 'PackageKey', since GHC - -- internally deals in package keys but the database may refer to installed - -- package IDs. - installedPackageIdMap :: InstalledPackageIdMap + moduleToPkgConfAll :: ModuleToPkgConfAll } emptyPackageState :: PackageState emptyPackageState = PackageState { pkgIdMap = emptyUFM, preloadPackages = [], - moduleToPkgConfAll = Map.empty, - installedPackageIdMap = Map.empty + moduleToPkgConfAll = Map.empty } -type InstalledPackageIdMap = Map InstalledPackageId PackageKey -type InstalledPackageIndex = Map InstalledPackageId PackageConfig +type InstalledPackageIndex = Map UnitId PackageConfig -- | Empty package configuration map emptyPackageConfigMap :: PackageConfigMap emptyPackageConfigMap = emptyUFM -- | Find the package we know about with the given key (e.g. @foo_HASH@), if any -lookupPackage :: DynFlags -> PackageKey -> Maybe PackageConfig +lookupPackage :: DynFlags -> UnitId -> Maybe PackageConfig lookupPackage dflags = lookupPackage' (pkgIdMap (pkgState dflags)) -lookupPackage' :: PackageConfigMap -> PackageKey -> Maybe PackageConfig +lookupPackage' :: PackageConfigMap -> UnitId -> Maybe PackageConfig lookupPackage' = lookupUFM -- | Search for packages with a given package ID (e.g. \"foo-0.1\") @@ -293,7 +285,7 @@ extendPackageConfigMap pkg_map new_pkgs -- | Looks up the package with the given id in the package state, panicing if it is -- not found -getPackageDetails :: DynFlags -> PackageKey -> PackageConfig +getPackageDetails :: DynFlags -> UnitId -> PackageConfig getPackageDetails dflags pid = expectJust "getPackageDetails" (lookupPackage dflags pid) @@ -304,12 +296,6 @@ getPackageDetails dflags pid = listPackageConfigMap :: DynFlags -> [PackageConfig] listPackageConfigMap dflags = eltsUFM (pkgIdMap (pkgState dflags)) --- | Looks up a 'PackageKey' given an 'InstalledPackageId' -resolveInstalledPackageId :: DynFlags -> InstalledPackageId -> PackageKey -resolveInstalledPackageId dflags ipid = - expectJust "resolveInstalledPackageId" - (Map.lookup ipid (installedPackageIdMap (pkgState dflags))) - -- ---------------------------------------------------------------------------- -- Loading the package db files and building up the package state @@ -326,7 +312,7 @@ resolveInstalledPackageId dflags ipid = -- 'packageFlags' field of the 'DynFlags', and it will update the -- 'pkgState' in 'DynFlags' and return a list of packages to -- link in. -initPackages :: DynFlags -> IO (DynFlags, [PackageKey]) +initPackages :: DynFlags -> IO (DynFlags, [UnitId]) initPackages dflags = do pkg_db <- case pkgDatabase dflags of Nothing -> readPackageConfigs dflags @@ -563,15 +549,15 @@ matchingStr str p || str == packageNameString p matchingId :: String -> PackageConfig -> Bool -matchingId str p = str == installedPackageIdString p +matchingId str p = str == componentIdString p matchingKey :: String -> PackageConfig -> Bool -matchingKey str p = str == packageKeyString (packageConfigId p) +matchingKey str p = str == unitIdString (packageConfigId p) matching :: PackageArg -> PackageConfig -> Bool matching (PackageArg str) = matchingStr str matching (PackageIdArg str) = matchingId str -matching (PackageKeyArg str) = matchingKey str +matching (UnitIdArg str) = matchingKey str sortByVersion :: [PackageConfig] -> [PackageConfig] sortByVersion = sortBy (flip (comparing packageVersion)) @@ -602,7 +588,7 @@ packageFlagErr dflags flag reasons text "(use -v for more information)") ppr_reasons = vcat (map ppr_reason reasons) ppr_reason (p, reason) = - pprReason (ppr (installedPackageId p) <+> text "is") reason + pprReason (ppr (unitId p) <+> text "is") reason pprFlag :: PackageFlag -> SDoc pprFlag flag = case flag of @@ -614,7 +600,7 @@ pprFlag flag = case flag of where ppr_arg arg = case arg of PackageArg p -> text "-package " <> text p PackageIdArg p -> text "-package-id " <> text p - PackageKeyArg p -> text "-package-key " <> text p + UnitIdArg p -> text "-package-key " <> text p ppr_rns (ModRenaming True []) = Outputable.empty ppr_rns (ModRenaming b rns) = if b then text "with" else Outputable.empty <+> @@ -626,13 +612,15 @@ pprFlag flag = case flag of -- Wired-in packages wired_in_pkgids :: [String] -wired_in_pkgids = map packageKeyString wiredInPackageKeys +wired_in_pkgids = map unitIdString wiredInUnitIds + +type WiredPackagesMap = Map UnitId UnitId findWiredInPackages :: DynFlags -> [PackageConfig] -- database -> VisibilityMap -- info on what packages are visible - -> IO ([PackageConfig], VisibilityMap) + -> IO ([PackageConfig], VisibilityMap, WiredPackagesMap) findWiredInPackages dflags pkgs vis_map = do -- @@ -686,14 +674,14 @@ findWiredInPackages dflags pkgs vis_map = do ptext (sLit "wired-in package ") <> text wired_pkg <> ptext (sLit " mapped to ") - <> ppr (installedPackageId pkg) + <> ppr (unitId pkg) return (Just pkg) mb_wired_in_pkgs <- mapM (findWiredInPackage pkgs) wired_in_pkgids let wired_in_pkgs = catMaybes mb_wired_in_pkgs - wired_in_ids = map installedPackageId wired_in_pkgs + wired_in_ids = map unitId wired_in_pkgs -- this is old: we used to assume that if there were -- multiple versions of wired-in packages installed that @@ -708,32 +696,45 @@ findWiredInPackages dflags pkgs vis_map = do && package p `notElem` map fst wired_in_ids -} - updateWiredInDependencies pkgs = map upd_pkg pkgs + wiredInMap :: Map UnitId UnitId + wiredInMap = foldl' add_mapping Map.empty pkgs + where add_mapping m pkg + | let key = unitId pkg + , key `elem` wired_in_ids + = Map.insert key (stringToUnitId (packageNameString pkg)) m + | otherwise = m + + updateWiredInDependencies pkgs = map (upd_deps . upd_pkg) pkgs where upd_pkg pkg - | installedPackageId pkg `elem` wired_in_ids + | unitId pkg `elem` wired_in_ids = pkg { - packageKey = stringToPackageKey (packageNameString pkg) + unitId = stringToUnitId (packageNameString pkg) } | otherwise = pkg + upd_deps pkg = pkg { + depends = map upd_wired_in (depends pkg) + } + upd_wired_in key + | Just key' <- Map.lookup key wiredInMap = key' + | otherwise = key updateVisibilityMap vis_map = foldl' f vis_map wired_in_pkgs where f vm p = case lookupUFM vis_map (packageConfigId p) of Nothing -> vm - Just r -> addToUFM vm (stringToPackageKey + Just r -> addToUFM vm (stringToUnitId (packageNameString p)) r - return (updateWiredInDependencies pkgs, updateVisibilityMap vis_map) + return (updateWiredInDependencies pkgs, updateVisibilityMap vis_map, wiredInMap) -- ---------------------------------------------------------------------------- data UnusablePackageReason = IgnoredWithFlag - | MissingDependencies [InstalledPackageId] - | ShadowedBy InstalledPackageId + | MissingDependencies [UnitId] -type UnusablePackages = Map InstalledPackageId +type UnusablePackages = Map UnitId (PackageConfig, UnusablePackageReason) pprReason :: SDoc -> UnusablePackageReason -> SDoc @@ -744,8 +745,6 @@ pprReason pref reason = case reason of pref <+> ptext (sLit "unusable due to missing or recursive dependencies:") $$ nest 2 (hsep (map ppr deps)) - ShadowedBy ipid -> - pref <+> ptext (sLit "shadowed by package ") <> ppr ipid reportUnusable :: DynFlags -> UnusablePackages -> IO () reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs) @@ -770,62 +769,31 @@ findBroken pkgs = go [] Map.empty pkgs go avail ipids not_avail = case partitionWith (depsAvailable ipids) not_avail of ([], not_avail) -> - Map.fromList [ (installedPackageId p, (p, MissingDependencies deps)) + Map.fromList [ (unitId p, (p, MissingDependencies deps)) | (p,deps) <- not_avail ] (new_avail, not_avail) -> go (new_avail ++ avail) new_ipids (map fst not_avail) where new_ipids = Map.insertList - [ (installedPackageId p, p) | p <- new_avail ] + [ (unitId p, p) | p <- new_avail ] ipids depsAvailable :: InstalledPackageIndex -> PackageConfig - -> Either PackageConfig (PackageConfig, [InstalledPackageId]) + -> Either PackageConfig (PackageConfig, [UnitId]) depsAvailable ipids pkg | null dangling = Left pkg | otherwise = Right (pkg, dangling) where dangling = filter (not . (`Map.member` ipids)) (depends pkg) -- ----------------------------------------------------------------------------- --- Eliminate shadowed packages, giving the user some feedback - --- later packages in the list should shadow earlier ones with the same --- package name/version. Additionally, a package may be preferred if --- it is in the transitive closure of packages selected using -package-id --- flags. -type UnusablePackage = (PackageConfig, UnusablePackageReason) -shadowPackages :: [PackageConfig] -> [InstalledPackageId] -> UnusablePackages -shadowPackages pkgs preferred - = let (shadowed,_) = foldl check ([],emptyUFM) pkgs - in Map.fromList shadowed - where - check :: ([(InstalledPackageId, UnusablePackage)], UniqFM PackageConfig) - -> PackageConfig - -> ([(InstalledPackageId, UnusablePackage)], UniqFM PackageConfig) - check (shadowed,pkgmap) pkg - | Just oldpkg <- lookupUFM pkgmap pkgid - , let - ipid_new = installedPackageId pkg - ipid_old = installedPackageId oldpkg - -- - , ipid_old /= ipid_new - = if ipid_old `elem` preferred - then ((ipid_new, (pkg, ShadowedBy ipid_old)) : shadowed, pkgmap) - else ((ipid_old, (oldpkg, ShadowedBy ipid_new)) : shadowed, pkgmap') - | otherwise - = (shadowed, pkgmap') - where - pkgid = packageKeyFS (packageKey pkg) - pkgmap' = addToUFM pkgmap pkgid pkg - --- ----------------------------------------------------------------------------- +-- Ignore packages ignorePackages :: [PackageFlag] -> [PackageConfig] -> UnusablePackages ignorePackages flags pkgs = Map.fromList (concatMap doit flags) where doit (IgnorePackage str) = case partition (matchingStr str) pkgs of - (ps, _) -> [ (installedPackageId p, (p, IgnoredWithFlag)) + (ps, _) -> [ (unitId p, (p, IgnoredWithFlag)) | p <- ps ] -- missing package is not an error for -ignore-package, -- because a common usage is to -ignore-package P as @@ -833,115 +801,87 @@ ignorePackages flags pkgs = Map.fromList (concatMap doit flags) doit _ = panic "ignorePackages" -- ----------------------------------------------------------------------------- - -depClosure :: InstalledPackageIndex - -> [InstalledPackageId] - -> [InstalledPackageId] -depClosure index ipids = closure Map.empty ipids - where - closure set [] = Map.keys set - closure set (ipid : ipids) - | ipid `Map.member` set = closure set ipids - | Just p <- Map.lookup ipid index = closure (Map.insert ipid p set) - (depends p ++ ipids) - | otherwise = closure set ipids - --- ----------------------------------------------------------------------------- -- When all the command-line options are in, we can process our package -- settings and populate the package state. mkPackageState :: DynFlags -> [PackageConfig] -- initial database - -> [PackageKey] -- preloaded packages + -> [UnitId] -- preloaded packages -> IO (PackageState, - [PackageKey], -- new packages to preload - PackageKey) -- this package, might be modified if the current + [UnitId], -- new packages to preload + UnitId) -- this package, might be modified if the current -- package is a wired-in package. mkPackageState dflags0 pkgs0 preload0 = do dflags <- interpretPackageEnv dflags0 - -- Compute the package key + -- Compute the unit id let this_package = thisPackage dflags {- Plan. - 1. P = transitive closure of packages selected by -package-id - - 2. Apply shadowing. When there are multiple packages with the same - packageKey, - * if one is in P, use that one - * otherwise, use the one highest in the package stack - [ - rationale: we cannot use two packages with the same packageKey - in the same program, because packageKey is the symbol prefix. - Hence we must select a consistent set of packages to use. We have - a default algorithm for doing this: packages higher in the stack - shadow those lower down. This default algorithm can be overriden - by giving explicit -package-id flags; then we have to take these - preferences into account when selecting which other packages are - made available. - - Our simple algorithm throws away some solutions: there may be other - consistent sets that would satisfy the -package flags, but it's - not GHC's job to be doing constraint solving. - ] - - 3. remove packages selected by -ignore-package - - 4. remove any packages with missing dependencies, or mutually recursive + 1. When there are multiple packages with the same + installed package ID, if they have the same ABI hash, use the one + highest in the package stack. Otherwise, error. + + 2. remove packages selected by -ignore-package + + 3. remove any packages with missing dependencies, or mutually recursive dependencies. - 5. report (with -v) any packages that were removed by steps 2-4 + 4. report (with -v) any packages that were removed by steps 2-4 - 6. apply flags to set exposed/hidden on the resulting packages + 5. apply flags to set exposed/hidden on the resulting packages - if any flag refers to a package which was removed by 2-4, then we can give an error message explaining why - 7. hide any packages which are superseded by later exposed packages + 6. hide any packages which are superseded by later exposed packages -} let - flags = reverse (packageFlags dflags) - -- pkgs0 with duplicate packages filtered out. This is -- important: it is possible for a package in the global package - -- DB to have the same IPID as a package in the user DB, and - -- we want the latter to take precedence. This is not the same - -- as shadowing (below), since in this case the two packages - -- have the same ABI and are interchangeable. + -- DB to have the same key as a package in the user DB, and + -- we want the latter to take precedence. -- - -- #4072: note that we must retain the ordering of the list here - -- so that shadowing behaves as expected when we apply it later. - pkgs0_unique = snd $ foldr del (Set.empty,[]) pkgs0 - where del p (s,ps) - | pid `Set.member` s = (s,ps) - | otherwise = (Set.insert pid s, p:ps) - where pid = installedPackageId p - -- XXX this is just a variant of nub - - ipid_map = Map.fromList [ (installedPackageId p, p) | p <- pkgs0 ] - - ipid_selected = depClosure ipid_map - [ InstalledPackageId (mkFastString i) - | ExposePackage (PackageIdArg i) _ <- flags ] - + -- NB: We have to check that the ABIs of the old and new packages + -- are equal; if they are not that's a fatal error. + -- + -- TODO: might be useful to report when this shadowing occurs + (_, pkgs0_unique, abis) = foldr del (Set.empty,[],Map.empty) pkgs0 + where del p (s,ps,a) + | key `Set.member` s = (s,ps,a') + | otherwise = (Set.insert key s, p:ps, a') + where key = unitId p + a' = Map.insertWith Set.union key + (Set.singleton (abiHash p)) a + failed_abis = [ (key, Set.toList as) + | (key, as) <- Map.toList abis + , Set.size as > 1 ] + + unless (null failed_abis) $ do + throwGhcException (CmdLineError (showSDoc dflags + (text "package db: duplicate packages with incompatible ABIs:" $$ + nest 4 (vcat [ ppr key <+> text "has ABIs" <> colon <+> + hsep (punctuate comma (map text as)) + | (key, as) <- failed_abis])))) + + let flags = reverse (packageFlags dflags) (ignore_flags, other_flags) = partition is_ignore flags is_ignore IgnorePackage{} = True is_ignore _ = False - shadowed = shadowPackages pkgs0_unique ipid_selected ignored = ignorePackages ignore_flags pkgs0_unique - isBroken = (`Map.member` (Map.union shadowed ignored)).installedPackageId + isBroken = (`Map.member` ignored) . unitId pkgs0' = filter (not . isBroken) pkgs0_unique broken = findBroken pkgs0' - unusable = shadowed `Map.union` ignored `Map.union` broken - pkgs1 = filter (not . (`Map.member` unusable) . installedPackageId) pkgs0' + unusable = ignored `Map.union` broken + pkgs1 = filter (not . (`Map.member` unusable) . unitId) pkgs0' reportUnusable dflags unusable @@ -976,11 +916,11 @@ mkPackageState dflags0 pkgs0 preload0 = do -- -- Sort out which packages are wired in. This has to be done last, since - -- it modifies the package keys of wired in packages, but when we process + -- it modifies the unit ids of wired in packages, but when we process -- package arguments we need to key against the old versions. We also -- have to update the visibility map in the process. -- - (pkgs3, vis_map) <- findWiredInPackages dflags pkgs2 vis_map2 + (pkgs3, vis_map, wired_map) <- findWiredInPackages dflags pkgs2 vis_map2 -- -- Here we build up a set of the packages mentioned in -package @@ -989,7 +929,9 @@ mkPackageState dflags0 pkgs0 preload0 = do -- should contain at least rts & base, which is why we pretend that -- the command line contains -package rts & -package base. -- - let preload1 = [ installedPackageId p | f <- flags, p <- get_exposed f ] + let preload1 = [ let key = unitId p + in fromMaybe key (Map.lookup key wired_map) + | f <- flags, p <- get_exposed f ] get_exposed (ExposePackage a _) = take 1 . sortByVersion . filter (matching a) @@ -998,21 +940,14 @@ mkPackageState dflags0 pkgs0 preload0 = do let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs3 - ipid_map = Map.fromList [ (installedPackageId p, packageConfigId p) - | p <- pkgs3 ] - - lookupIPID ipid - | Just pid <- Map.lookup ipid ipid_map = return pid - | otherwise = missingPackageErr dflags ipid - - preload2 <- mapM lookupIPID preload1 + let preload2 = preload1 let -- add base & rts to the preload packages basicLinkedPackages | gopt Opt_AutoLinkPackages dflags = filter (flip elemUFM pkg_db) - [basePackageKey, rtsPackageKey] + [baseUnitId, rtsUnitId] | otherwise = [] -- but in any case remove the current package from the set of -- preloaded packages so that base/rts does not end up in the @@ -1021,14 +956,13 @@ mkPackageState dflags0 pkgs0 preload0 = do $ (basicLinkedPackages ++ preload2) -- Close the preload packages with their dependencies - dep_preload <- closeDeps dflags pkg_db ipid_map (zip preload3 (repeat Nothing)) + dep_preload <- closeDeps dflags pkg_db (zip preload3 (repeat Nothing)) let new_dep_preload = filter (`notElem` preload0) dep_preload let pstate = PackageState{ preloadPackages = dep_preload, pkgIdMap = pkg_db, - moduleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map, - installedPackageIdMap = ipid_map + moduleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db vis_map } return (pstate, new_dep_preload, this_package) @@ -1039,10 +973,9 @@ mkPackageState dflags0 pkgs0 preload0 = do mkModuleToPkgConfAll :: DynFlags -> PackageConfigMap - -> InstalledPackageIdMap -> VisibilityMap -> ModuleToPkgConfAll -mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map = +mkModuleToPkgConfAll dflags pkg_db vis_map = foldl' extend_modmap emptyMap (eltsUFM pkg_db) where emptyMap = Map.empty @@ -1078,9 +1011,8 @@ mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map = let (pk', m', pkg', origin') = case exposedReexport of Nothing -> (pk, m, pkg, fromExposedModules e) - Just (OriginalModule ipid' m') -> - let pk' = expectJust "mkModuleToPkgConf" (Map.lookup ipid' ipid_map) - pkg' = pkg_lookup pk' + Just (OriginalModule pk' m') -> + let pkg' = pkg_lookup pk' in (pk', m', pkg', fromReexportedModules e pkg') return (m, sing pk' m' pkg' origin') @@ -1108,7 +1040,7 @@ mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map = -- use. -- | Find all the include directories in these and the preload packages -getPackageIncludePath :: DynFlags -> [PackageKey] -> IO [String] +getPackageIncludePath :: DynFlags -> [UnitId] -> IO [String] getPackageIncludePath dflags pkgs = collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs @@ -1116,7 +1048,7 @@ collectIncludeDirs :: [PackageConfig] -> [FilePath] collectIncludeDirs ps = nub (filter notNull (concatMap includeDirs ps)) -- | Find all the library paths in these and the preload packages -getPackageLibraryPath :: DynFlags -> [PackageKey] -> IO [String] +getPackageLibraryPath :: DynFlags -> [UnitId] -> IO [String] getPackageLibraryPath dflags pkgs = collectLibraryPaths `fmap` getPreloadPackagesAnd dflags pkgs @@ -1125,7 +1057,7 @@ collectLibraryPaths ps = nub (filter notNull (concatMap libraryDirs ps)) -- | Find all the link options in these and the preload packages, -- returning (package hs lib options, extra library options, other flags) -getPackageLinkOpts :: DynFlags -> [PackageKey] -> IO ([String], [String], [String]) +getPackageLinkOpts :: DynFlags -> [UnitId] -> IO ([String], [String], [String]) getPackageLinkOpts dflags pkgs = collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs @@ -1174,19 +1106,19 @@ packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) | otherwise = '_':t -- | Find all the C-compiler options in these and the preload packages -getPackageExtraCcOpts :: DynFlags -> [PackageKey] -> IO [String] +getPackageExtraCcOpts :: DynFlags -> [UnitId] -> IO [String] getPackageExtraCcOpts dflags pkgs = do ps <- getPreloadPackagesAnd dflags pkgs return (concatMap ccOptions ps) -- | Find all the package framework paths in these and the preload packages -getPackageFrameworkPath :: DynFlags -> [PackageKey] -> IO [String] +getPackageFrameworkPath :: DynFlags -> [UnitId] -> IO [String] getPackageFrameworkPath dflags pkgs = do ps <- getPreloadPackagesAnd dflags pkgs return (nub (filter notNull (concatMap frameworkDirs ps))) -- | Find all the package frameworks in these and the preload packages -getPackageFrameworks :: DynFlags -> [PackageKey] -> IO [String] +getPackageFrameworks :: DynFlags -> [UnitId] -> IO [String] getPackageFrameworks dflags pkgs = do ps <- getPreloadPackagesAnd dflags pkgs return (concatMap frameworks ps) @@ -1204,7 +1136,7 @@ lookupModuleInAllPackages dflags m LookupFound a b -> [(a,b)] LookupMultiple rs -> map f rs where f (m,_) = (m, expectJust "lookupModule" (lookupPackage dflags - (modulePackageKey m))) + (moduleUnitId m))) _ -> [] -- | The result of performing a lookup @@ -1248,7 +1180,7 @@ lookupModuleWithSuggestions dflags m mb_pn pkg_lookup = expectJust "lookupModuleWithSuggestions" . lookupPackage dflags pkg_state = pkgState dflags - mod_pkg = pkg_lookup . modulePackageKey + mod_pkg = pkg_lookup . moduleUnitId -- Filters out origins which are not associated with the given package -- qualifier. No-op if there is no package qualifier. Test if this @@ -1293,27 +1225,25 @@ listVisibleModuleNames dflags = -- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of -- 'PackageConfig's -getPreloadPackagesAnd :: DynFlags -> [PackageKey] -> IO [PackageConfig] +getPreloadPackagesAnd :: DynFlags -> [UnitId] -> IO [PackageConfig] getPreloadPackagesAnd dflags pkgids = let state = pkgState dflags pkg_map = pkgIdMap state - ipid_map = installedPackageIdMap state preload = preloadPackages state pairs = zip pkgids (repeat Nothing) in do - all_pkgs <- throwErr dflags (foldM (add_package pkg_map ipid_map) preload pairs) + all_pkgs <- throwErr dflags (foldM (add_package pkg_map) preload pairs) return (map (getPackageDetails dflags) all_pkgs) -- Takes a list of packages, and returns the list with dependencies included, -- in reverse dependency order (a package appears before those it depends on). closeDeps :: DynFlags -> PackageConfigMap - -> Map InstalledPackageId PackageKey - -> [(PackageKey, Maybe PackageKey)] - -> IO [PackageKey] -closeDeps dflags pkg_map ipid_map ps - = throwErr dflags (closeDepsErr pkg_map ipid_map ps) + -> [(UnitId, Maybe UnitId)] + -> IO [UnitId] +closeDeps dflags pkg_map ps + = throwErr dflags (closeDepsErr pkg_map ps) throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a throwErr dflags m @@ -1322,18 +1252,16 @@ throwErr dflags m Succeeded r -> return r closeDepsErr :: PackageConfigMap - -> Map InstalledPackageId PackageKey - -> [(PackageKey,Maybe PackageKey)] - -> MaybeErr MsgDoc [PackageKey] -closeDepsErr pkg_map ipid_map ps = foldM (add_package pkg_map ipid_map) [] ps + -> [(UnitId,Maybe UnitId)] + -> MaybeErr MsgDoc [UnitId] +closeDepsErr pkg_map ps = foldM (add_package pkg_map) [] ps -- internal helper add_package :: PackageConfigMap - -> Map InstalledPackageId PackageKey - -> [PackageKey] - -> (PackageKey,Maybe PackageKey) - -> MaybeErr MsgDoc [PackageKey] -add_package pkg_db ipid_map ps (p, mb_parent) + -> [UnitId] + -> (UnitId,Maybe UnitId) + -> MaybeErr MsgDoc [UnitId] +add_package pkg_db ps (p, mb_parent) | p `elem` ps = return ps -- Check if we've already added this package | otherwise = case lookupPackage' pkg_db p of @@ -1341,37 +1269,29 @@ add_package pkg_db ipid_map ps (p, mb_parent) missingDependencyMsg mb_parent) Just pkg -> do -- Add the package's dependents also - ps' <- foldM add_package_ipid ps (depends pkg) + ps' <- foldM add_unit_key ps (depends pkg) return (p : ps') where - add_package_ipid ps ipid - | Just pid <- Map.lookup ipid ipid_map - = add_package pkg_db ipid_map ps (pid, Just p) - | otherwise - = Failed (missingPackageMsg ipid - <> missingDependencyMsg mb_parent) - -missingPackageErr :: Outputable pkgid => DynFlags -> pkgid -> IO a -missingPackageErr dflags p - = throwGhcExceptionIO (CmdLineError (showSDoc dflags (missingPackageMsg p))) + add_unit_key ps key + = add_package pkg_db ps (key, Just p) missingPackageMsg :: Outputable pkgid => pkgid -> SDoc missingPackageMsg p = ptext (sLit "unknown package:") <+> ppr p -missingDependencyMsg :: Maybe PackageKey -> SDoc +missingDependencyMsg :: Maybe UnitId -> SDoc missingDependencyMsg Nothing = Outputable.empty missingDependencyMsg (Just parent) - = space <> parens (ptext (sLit "dependency of") <+> ftext (packageKeyFS parent)) + = space <> parens (ptext (sLit "dependency of") <+> ftext (unitIdFS parent)) -- ----------------------------------------------------------------------------- -packageKeyPackageIdString :: DynFlags -> PackageKey -> Maybe String -packageKeyPackageIdString dflags pkg_key - | pkg_key == mainPackageKey = Just "main" +unitIdPackageIdString :: DynFlags -> UnitId -> Maybe String +unitIdPackageIdString dflags pkg_key + | pkg_key == mainUnitId = Just "main" | otherwise = fmap sourcePackageIdString (lookupPackage dflags pkg_key) -- | Will the 'Name' come from a dynamically linked library? -isDllName :: DynFlags -> PackageKey -> Module -> Name -> Bool +isDllName :: DynFlags -> UnitId -> Module -> Name -> Bool -- Despite the "dll", I think this function just means that -- the synbol comes from another dynamically-linked package, -- and applies on all platforms, not just Windows @@ -1420,7 +1340,7 @@ pprPackagesWith pprIPI dflags = -- be different from the package databases (exposure, trust) pprPackagesSimple :: DynFlags -> SDoc pprPackagesSimple = pprPackagesWith pprIPI - where pprIPI ipi = let InstalledPackageId i = installedPackageId ipi + where pprIPI ipi = let i = unitIdFS (unitId ipi) e = if exposed ipi then text "E" else text " " t = if trusted ipi then text "T" else text " " in e <> t <> text " " <> ftext i @@ -1432,7 +1352,7 @@ pprModuleMap dflags = where pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e))) pprEntry m (m',o) - | m == moduleName m' = ppr (modulePackageKey m') <+> parens (ppr o) + | m == moduleName m' = ppr (moduleUnitId m') <+> parens (ppr o) | otherwise = ppr m' <+> parens (ppr o) fsPackageName :: PackageConfig -> FastString diff --git a/compiler/main/Packages.hs-boot b/compiler/main/Packages.hs-boot index bac04bc20a..1197fadb57 100644 --- a/compiler/main/Packages.hs-boot +++ b/compiler/main/Packages.hs-boot @@ -1,7 +1,7 @@ module Packages where -- Well, this is kind of stupid... -import {-# SOURCE #-} Module (PackageKey) +import {-# SOURCE #-} Module (UnitId) import {-# SOURCE #-} DynFlags (DynFlags) data PackageState -packageKeyPackageIdString :: DynFlags -> PackageKey -> Maybe String +unitIdPackageIdString :: DynFlags -> UnitId -> Maybe String emptyPackageState :: PackageState diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs index 15baa38bf5..1a1d4b50f5 100644 --- a/compiler/main/SysTools.hs +++ b/compiler/main/SysTools.hs @@ -613,7 +613,7 @@ runClang dflags args = do ) -- | Figure out which version of LLVM we are running this session -figureLlvmVersion :: DynFlags -> IO (Maybe Int) +figureLlvmVersion :: DynFlags -> IO (Maybe (Int, Int)) figureLlvmVersion dflags = do let (pgm,opts) = pgm_lc dflags args = filter notNull (map showOpt opts) @@ -626,17 +626,18 @@ figureLlvmVersion dflags = do (pin, pout, perr, _) <- runInteractiveProcess pgm args' Nothing Nothing {- > llc -version - Low Level Virtual Machine (http://llvm.org/): - llvm version 2.8 (Ubuntu 2.8-0Ubuntu1) + LLVM (http://llvm.org/): + LLVM version 3.5.2 ... -} hSetBinaryMode pout False _ <- hGetLine pout - vline <- hGetLine pout - v <- case filter isDigit vline of - [] -> fail "no digits!" - [x] -> fail $ "only 1 digit! (" ++ show x ++ ")" - (x:y:_) -> return ((read [x,y]) :: Int) + vline <- dropWhile (not . isDigit) `fmap` hGetLine pout + v <- case span (/= '.') vline of + ("",_) -> fail "no digits!" + (x,y) -> return (read x + , read $ takeWhile isDigit $ drop 1 y) + hClose pin hClose pout hClose perr @@ -1327,19 +1328,15 @@ handleProc pgm phase_name proc = do (rc, r) <- proc `catchIO` handler case rc of ExitSuccess{} -> return r - ExitFailure n - -- rawSystem returns (ExitFailure 127) if the exec failed for any - -- reason (eg. the program doesn't exist). This is the only clue - -- we have, but we need to report something to the user because in - -- the case of a missing program there will otherwise be no output - -- at all. - | n == 127 -> does_not_exist - | otherwise -> throwGhcExceptionIO (PhaseFailed phase_name rc) + ExitFailure n -> throwGhcExceptionIO ( + ProgramError ("`" ++ takeBaseName pgm ++ "'" ++ + " failed in phase `" ++ phase_name ++ "'." ++ + " (Exit code: " ++ show n ++ ")")) where handler err = if IO.isDoesNotExistError err then does_not_exist - else IO.ioError err + else throwGhcExceptionIO (ProgramError $ show err) does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm)) @@ -1473,7 +1470,7 @@ traceCmd dflags phase_name cmd_line action where handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n') ; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn)) - ; throwGhcExceptionIO (PhaseFailed phase_name (ExitFailure 1)) } + ; throwGhcExceptionIO (ProgramError (show exn))} {- ************************************************************************ @@ -1544,7 +1541,7 @@ linesPlatform xs = #endif -linkDynLib :: DynFlags -> [String] -> [PackageKey] -> IO () +linkDynLib :: DynFlags -> [String] -> [UnitId] -> IO () linkDynLib dflags0 o_files dep_packages = do let -- This is a rather ugly hack to fix dynamically linked @@ -1590,7 +1587,7 @@ linkDynLib dflags0 o_files dep_packages OSMinGW32 -> pkgs _ -> - filter ((/= rtsPackageKey) . packageConfigId) pkgs + filter ((/= rtsUnitId) . packageConfigId) pkgs let pkg_link_opts = let (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs_no_rts in package_hs_libs ++ extra_libs ++ other_flags @@ -1600,7 +1597,7 @@ linkDynLib dflags0 o_files dep_packages -- frameworks pkg_framework_opts <- getPkgFrameworkOpts dflags platform - (map packageKey pkgs) + (map unitId pkgs) let framework_opts = getFrameworkOpts dflags platform case os of @@ -1721,7 +1718,7 @@ linkDynLib dflags0 o_files dep_packages ++ map Option pkg_link_opts ) -getPkgFrameworkOpts :: DynFlags -> Platform -> [PackageKey] -> IO [String] +getPkgFrameworkOpts :: DynFlags -> Platform -> [UnitId] -> IO [String] getPkgFrameworkOpts dflags platform dep_packages | platformUsesFrameworks platform = do pkg_framework_path_opts <- do diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs index 2b31a03b21..e2a772f8d4 100644 --- a/compiler/main/TidyPgm.hs +++ b/compiler/main/TidyPgm.hs @@ -832,7 +832,7 @@ dffvLetBndr :: Bool -> Id -> DFFV () -- we say "True" if we are exposing that unfolding dffvLetBndr vanilla_unfold id = do { go_unf (unfoldingInfo idinfo) - ; mapM_ go_rule (specInfoRules (specInfo idinfo)) } + ; mapM_ go_rule (ruleInfoRules (ruleInfo idinfo)) } where idinfo = idInfo id @@ -1123,7 +1123,7 @@ tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds ------------------------ tidyTopBind :: DynFlags - -> PackageKey + -> UnitId -> Module -> (Integer -> CoreExpr) -> UnfoldEnv @@ -1311,7 +1311,7 @@ type CafRefEnv = (VarEnv Id, Integer -> CoreExpr) -- The Integer -> CoreExpr is the desugaring function for Integer literals -- See Note [Disgusting computation of CafRefs] -hasCafRefs :: DynFlags -> PackageKey -> Module +hasCafRefs :: DynFlags -> UnitId -> Module -> CafRefEnv -> Arity -> CoreExpr -> CafInfo hasCafRefs dflags this_pkg this_mod p@(_,cvt_integer) arity expr |