diff options
Diffstat (limited to 'compiler/main')
25 files changed, 2496 insertions, 1910 deletions
diff --git a/compiler/main/Annotations.lhs b/compiler/main/Annotations.hs index ec61a1f4a6..277c059b11 100644 --- a/compiler/main/Annotations.lhs +++ b/compiler/main/Annotations.hs @@ -1,37 +1,30 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% - -\begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - +-- | +-- Support for source code annotation feature of GHC. That is the ANN pragma. +-- +-- (c) The University of Glasgow 2006 +-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-- module Annotations ( - -- * Main Annotation data types - Annotation(..), - AnnTarget(..), CoreAnnTarget, - getAnnTargetName_maybe, - - -- * AnnEnv for collecting and querying Annotations - AnnEnv, - mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv, findAnns, - deserializeAnns - ) where + -- * Main Annotation data types + Annotation(..), + AnnTarget(..), CoreAnnTarget, + getAnnTargetName_maybe, + + -- * AnnEnv for collecting and querying Annotations + AnnEnv, + mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv, findAnns, + deserializeAnns + ) where -import Name import Module ( Module ) +import Name import Outputable -import UniqFM import Serialized +import UniqFM import Unique -import Data.Typeable import Data.Maybe +import Data.Typeable import Data.Word ( Word8 ) @@ -40,14 +33,14 @@ import Data.Word ( Word8 ) data Annotation = Annotation { ann_target :: CoreAnnTarget, -- ^ The target of the annotation ann_value :: Serialized -- ^ 'Serialized' version of the annotation that - -- allows recovery of its value or can + -- allows recovery of its value or can -- be persisted to an interface file } -- | An annotation target data AnnTarget name = NamedTarget name -- ^ We are annotating something with a name: - -- a type or identifier + -- a type or identifier | ModuleTarget Module -- ^ We are annotating a particular module -- | The kind of annotation target found in the middle end of the compiler @@ -57,6 +50,7 @@ instance Functor AnnTarget where fmap f (NamedTarget nm) = NamedTarget (f nm) fmap _ (ModuleTarget mod) = ModuleTarget mod +-- | Get the 'name' of an annotation target if it exists. getAnnTargetName_maybe :: AnnTarget name -> Maybe name getAnnTargetName_maybe (NamedTarget nm) = Just nm getAnnTargetName_maybe _ = Nothing @@ -74,20 +68,25 @@ instance Outputable Annotation where ppr ann = ppr (ann_target ann) -- | A collection of annotations -newtype AnnEnv = MkAnnEnv (UniqFM [Serialized]) -- Can't use a type synonym or we hit bug #2412 due to source import +newtype AnnEnv = MkAnnEnv (UniqFM [Serialized]) +-- | An empty annotation environment. emptyAnnEnv :: AnnEnv emptyAnnEnv = MkAnnEnv emptyUFM +-- | Construct a new annotation environment that contains the list of +-- annotations provided. mkAnnEnv :: [Annotation] -> AnnEnv mkAnnEnv = extendAnnEnvList emptyAnnEnv +-- | Add the given annotation to the environment. extendAnnEnvList :: AnnEnv -> [Annotation] -> AnnEnv extendAnnEnvList (MkAnnEnv env) anns = MkAnnEnv $ addListToUFM_C (++) env $ map (\ann -> (getUnique (ann_target ann), [ann_value ann])) anns +-- | Union two annotation environments. plusAnnEnv :: AnnEnv -> AnnEnv -> AnnEnv plusAnnEnv (MkAnnEnv env1) (MkAnnEnv env2) = MkAnnEnv $ plusUFM_C (++) env1 env2 @@ -105,4 +104,4 @@ findAnns deserialize (MkAnnEnv ann_env) deserializeAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> UniqFM [a] deserializeAnns deserialize (MkAnnEnv ann_env) = mapUFM (mapMaybe (fromSerialized deserialize)) ann_env -\end{code} + diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs index 148e11f65b..c6d07ce027 100644 --- a/compiler/main/CmdLineParser.hs +++ b/compiler/main/CmdLineParser.hs @@ -243,6 +243,6 @@ missingArgErr f = Left ("missing argument for flag: " ++ f) errorsToGhcException :: [Located String] -> GhcException errorsToGhcException errs = - let errors = vcat [ ppr l <> text ": " <> text e | L l e <- errs ] - in UsageError (renderWithStyle errors cmdlineParserStyle) + UsageError $ + intercalate "\n" [ showUserSpan True l ++ ": " ++ e | L l e <- errs ] diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index f29b479db2..b4d6371a5d 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -17,7 +17,6 @@ import Finder ( mkStubPaths ) import PprC ( writeCs ) import OldCmmLint ( cmmLint ) import Packages -import Util import OldCmm ( RawCmmGroup ) import HscTypes import DynFlags @@ -26,10 +25,11 @@ import SysTools import Stream (Stream) import qualified Stream -import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit ) +import ErrUtils import Outputable import Module import Maybes ( firstJusts ) +import SrcLoc import Control.Exception import Control.Monad @@ -65,7 +65,7 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps cmm_stream do_lint cmm = do { showPass dflags "CmmLint" ; case cmmLint (targetPlatform dflags) cmm of - Just err -> do { printDump err + Just err -> do { log_action dflags dflags SevDump noSrcSpan defaultDumpStyle err ; ghcExit dflags 1 } Nothing -> return () @@ -201,14 +201,13 @@ outputForeignStubs dflags mod location stubs ForeignStubs h_code c_code -> do let stub_c_output_d = pprCode CStyle c_code - stub_c_output_w = showSDoc stub_c_output_d + stub_c_output_w = showSDoc dflags stub_c_output_d -- Header file protos for "foreign export"ed functions. stub_h_output_d = pprCode CStyle h_code - stub_h_output_w = showSDoc stub_h_output_d - -- in + stub_h_output_w = showSDoc dflags stub_h_output_d - createDirectoryHierarchy (takeDirectory stub_h) + createDirectoryIfMissing True (takeDirectory stub_h) dumpIfSet_dyn dflags Opt_D_dump_foreign "Foreign export header file" stub_h_output_d diff --git a/compiler/main/Constants.lhs b/compiler/main/Constants.lhs index 2e276f64c6..0cecb82f1a 100644 --- a/compiler/main/Constants.lhs +++ b/compiler/main/Constants.lhs @@ -13,8 +13,12 @@ module Constants (module Constants) where +import Config + #include "ghc_boot_platform.h" #include "../includes/HaskellConstants.hs" +hiVersion :: Integer +hiVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer \end{code} diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs index 1694aba9b8..953b2c4568 100644 --- a/compiler/main/DriverMkDepend.hs +++ b/compiler/main/DriverMkDepend.hs @@ -176,9 +176,9 @@ processDeps :: DynFlags -- -- For {-# SOURCE #-} imports the "hi" will be "hi-boot". -processDeps _ _ _ _ _ (CyclicSCC nodes) +processDeps dflags _ _ _ _ (CyclicSCC nodes) = -- There shouldn't be any cycles; report them - ghcError (ProgramError (showSDoc $ GHC.cyclicModuleErr nodes)) + ghcError (ProgramError (showSDoc dflags $ GHC.cyclicModuleErr nodes)) processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node) = do { let extra_suffixes = depSuffixes dflags @@ -240,8 +240,10 @@ findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps | otherwise -> return Nothing - fail -> throwOneError $ mkPlainErrMsg srcloc $ - cannotFindModule (hsc_dflags hsc_env) imp fail + fail -> + let dflags = hsc_dflags hsc_env + in throwOneError $ mkPlainErrMsg dflags srcloc $ + cannotFindModule dflags imp fail } ----------------------------- diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index df6e7fd163..47706798f7 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -326,8 +326,7 @@ link' dflags batch_attempt_linking hpt return Succeeded else do - compilationProgressMsg dflags $ showSDoc $ - (ptext (sLit "Linking") <+> text exe_file <+> text "...") + compilationProgressMsg dflags ("Linking " ++ exe_file ++ " ...") -- Don't showPass in Batch mode; doLink will do that for us. let link = case ghcLink dflags of @@ -774,7 +773,7 @@ runPhase (Cpp sf) input_fn dflags0 (dflags1, unhandled_flags, warns) <- io $ parseDynamicFilePragma dflags0 src_opts setDynFlags dflags1 - io $ checkProcessArgsResult unhandled_flags + io $ checkProcessArgsResult dflags1 unhandled_flags if not (xopt Opt_Cpp dflags1) then do -- we have to be careful to emit warnings only once. @@ -791,7 +790,7 @@ runPhase (Cpp sf) input_fn dflags0 src_opts <- io $ getOptionsFromFile dflags0 output_fn (dflags2, unhandled_flags, warns) <- io $ parseDynamicFilePragma dflags0 src_opts - io $ checkProcessArgsResult unhandled_flags + io $ checkProcessArgsResult dflags2 unhandled_flags unless (dopt Opt_Pp dflags2) $ io $ handleFlagWarnings dflags2 warns -- the HsPp pass below will emit warnings @@ -826,7 +825,7 @@ runPhase (HsPp sf) input_fn dflags (dflags1, unhandled_flags, warns) <- io $ parseDynamicFilePragma dflags src_opts setDynFlags dflags1 - io $ checkProcessArgsResult unhandled_flags + io $ checkProcessArgsResult dflags1 unhandled_flags io $ handleFlagWarnings dflags1 warns return (Hsc sf, output_fn) @@ -1176,14 +1175,17 @@ runPhase As input_fn dflags = do llvmVer <- io $ figureLlvmVersion dflags return $ case llvmVer of - Just n | n >= 30 -> SysTools.runClang - _ -> SysTools.runAs + -- using cGccLinkerOpts here but not clear if + -- opt_c isn't a better choice + Just n | n >= 30 -> + (SysTools.runClang, cGccLinkerOpts) + + _ -> (SysTools.runAs, getOpts dflags opt_a) | otherwise - = return SysTools.runAs + = return (SysTools.runAs, getOpts dflags opt_a) - as_prog <- whichAsProg - let as_opts = getOpts dflags opt_a + (as_prog, as_opts) <- whichAsProg let cmdline_include_paths = includePaths dflags next_phase <- maybeMergeStub @@ -1191,7 +1193,7 @@ runPhase As input_fn dflags -- we create directories for the object file, because it -- might be a hierarchical module. - io $ createDirectoryHierarchy (takeDirectory output_fn) + io $ createDirectoryIfMissing True (takeDirectory output_fn) io $ as_prog dflags (map SysTools.Option as_opts @@ -1230,7 +1232,7 @@ runPhase SplitAs _input_fn dflags osuf = objectSuf dflags split_odir = base_o ++ "_" ++ osuf ++ "_split" - io $ createDirectoryHierarchy split_odir + io $ createDirectoryIfMissing True split_odir -- remove M_split/ *.o, because we're going to archive M_split/ *.o -- later and we don't want to pick up any old objects. @@ -1369,7 +1371,8 @@ runPhase LlvmLlc input_fn dflags SysTools.Option "-o", SysTools.FileOption "" output_fn] ++ map SysTools.Option lc_opts ++ [SysTools.Option tbaa] - ++ map SysTools.Option fpOpts) + ++ map SysTools.Option fpOpts + ++ map SysTools.Option abiOpts) return (next_phase, output_fn) where @@ -1381,12 +1384,19 @@ runPhase LlvmLlc input_fn dflags -- 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 - ArchARM ARMv7 ext -> if (elem VFPv3 ext) + ArchARM ARMv7 ext _ -> if (elem VFPv3 ext) then ["-mattr=+v7,+vfp3"] else if (elem VFPv3D16 ext) then ["-mattr=+v7,+vfp3,+d16"] else [] _ -> [] + -- On Ubuntu/Debian with ARM hard float ABI, LLVM's llc still + -- compiles into soft-float ABI. We need to explicitly set abi + -- to hard + abiOpts = case platformArch (targetPlatform dflags) of + ArchARM ARMv7 _ HARD -> ["-float-abi=hard"] + ArchARM ARMv7 _ _ -> [] + _ -> [] ----------------------------------------------------------------------------- -- LlvmMangle phase @@ -1453,9 +1463,9 @@ runPhase_MoveBinary dflags input_fn return True | otherwise = return True -mkExtraCObj :: DynFlags -> String -> IO FilePath -mkExtraCObj dflags xs - = do cFile <- newTempName dflags "c" +mkExtraObj :: DynFlags -> Suffix -> String -> IO FilePath +mkExtraObj dflags extn xs + = do cFile <- newTempName dflags extn oFile <- newTempName dflags "o" writeFile cFile xs let rtsDetails = getPackageDetails (pkgState dflags) rtsPackageId @@ -1474,23 +1484,19 @@ mkExtraCObj dflags xs -- so now we generate and compile a main() stub as part of every -- binary and pass the -rtsopts setting directly to the RTS (#5373) -- -mkExtraObjToLinkIntoBinary :: DynFlags -> [PackageId] -> IO FilePath -mkExtraObjToLinkIntoBinary dflags dep_packages = do - link_info <- getLinkInfo dflags dep_packages - +mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath +mkExtraObjToLinkIntoBinary dflags = do let have_rts_opts_flags = isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of RtsOptsSafeOnly -> False _ -> True when (dopt Opt_NoHsMain dflags && have_rts_opts_flags) $ do - hPutStrLn stderr $ "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main.\n" ++ - " Call hs_init_ghc() from your main() function to set these options." + log_action dflags dflags SevInfo noSrcSpan defaultUserStyle + (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$ + text " Call hs_init_ghc() from your main() function to set these options.") - mkExtraCObj dflags (showSDoc (vcat [main, - link_opts link_info] - <> char '\n')) -- final newline, to - -- keep gcc happy + mkExtraObj dflags "c" (showSDoc dflags main) where main @@ -1508,31 +1514,40 @@ mkExtraObjToLinkIntoBinary dflags dep_packages = do Just opts -> ptext (sLit " __conf.rts_opts= ") <> text (show opts) <> semi, ptext (sLit " return hs_main(argc, argv, &ZCMain_main_closure,__conf);"), - char '}' + char '}', + char '\n' -- final newline, to keep gcc happy ] - link_opts info - | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags))) - = empty - | otherwise = hcat [ - text "__asm__(\"\\t.section ", text ghcLinkInfoSectionName, - text ",\\\"\\\",", - text elfSectionNote, - text "\\n", +-- Write out the link info section into a new assembly file. Previously +-- 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 -> [PackageId] -> IO [FilePath] +mkNoteObjsToLinkIntoBinary dflags dep_packages = do + link_info <- getLinkInfo dflags dep_packages + + if (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags))) + then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc dflags (link_opts link_info)) + else return [] + + where + link_opts info = hcat [ + text "\t.section ", text ghcLinkInfoSectionName, + text ",\"\",", + text elfSectionNote, + text "\n", - text "\\t.ascii \\\"", info', text "\\\"\\n\");" ] + text "\t.ascii \"", info', text "\"\n" ] where - -- we need to escape twice: once because we're inside a C string, - -- and again because we're inside an asm string. - info' = text $ (escape.escape) info + info' = text $ escape info escape :: String -> String escape = concatMap (charToC.fromIntegral.ord) elfSectionNote :: String elfSectionNote = case platformArch (targetPlatform dflags) of - ArchARM _ _ -> "%note" - _ -> "@note" + ArchARM _ _ _ -> "%note" + _ -> "@note" -- The "link info" is a string representing the parameters of the -- link. We save this information in the binary, and the next time we @@ -1661,7 +1676,8 @@ linkBinary dflags o_files dep_packages = do let lib_paths = libraryPaths dflags let lib_path_opts = map ("-L"++) lib_paths - extraLinkObj <- mkExtraObjToLinkIntoBinary dflags dep_packages + extraLinkObj <- mkExtraObjToLinkIntoBinary dflags + noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_packages pkg_link_opts <- getPackageLinkOpts dflags dep_packages @@ -1778,7 +1794,7 @@ linkBinary dflags o_files dep_packages = do ++ framework_path_opts ++ framework_opts ++ pkg_lib_path_opts - ++ [extraLinkObj] + ++ extraLinkObj:noteLinkObjs ++ pkg_link_opts ++ pkg_framework_path_opts ++ pkg_framework_opts @@ -2132,6 +2148,6 @@ hscPostBackendPhase dflags _ hsc_lang = touchObjectFile :: DynFlags -> FilePath -> IO () touchObjectFile dflags path = do - createDirectoryHierarchy $ takeDirectory path + createDirectoryIfMissing True $ takeDirectory path SysTools.touch dflags "Touching object file" path diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 0553bd8848..60b6e82bb7 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -16,7 +16,8 @@ module DynFlags ( DynFlag(..), WarningFlag(..), ExtensionFlag(..), - LogAction, + Language(..), + FatalMessager, LogAction, FlushOut(..), FlushErr(..), ProfAuto(..), glasgowExtsFlags, dopt, @@ -28,23 +29,29 @@ module DynFlags ( xopt, xopt_set, xopt_unset, + lang_set, DynFlags(..), HasDynFlags(..), ContainsDynFlags(..), RtsOptsEnabled(..), HscTarget(..), isObjectTarget, defaultObjectTarget, + targetRetainsAllBindings, GhcMode(..), isOneShot, GhcLink(..), isNoLink, PackageFlag(..), + PkgConfRef(..), Option(..), showOpt, DynLibLoader(..), fFlags, fWarningFlags, fLangFlags, xFlags, wayNames, dynFlagDependencies, + printOutputForUser, printInfoForUser, + -- ** Safe Haskell SafeHaskellMode(..), safeHaskellOn, safeImportsOn, safeLanguageOn, safeInferOn, packageTrustOn, safeDirectImpsReq, safeImplicitImpsReq, + unsafeFlags, -- ** System tool settings and locations Settings(..), @@ -60,7 +67,11 @@ module DynFlags ( -- ** Manipulating DynFlags defaultDynFlags, -- Settings -> DynFlags initDynFlags, -- DynFlags -> IO DynFlags + defaultFatalMessager, defaultLogAction, + defaultLogActionHPrintDoc, + defaultFlushOut, + defaultFlushErr, getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a] getVerbFlags, @@ -72,7 +83,13 @@ module DynFlags ( -- ** Parsing DynFlags parseDynamicFlagsCmdLine, parseDynamicFilePragma, + parseDynamicFlagsFull, + + -- ** Available DynFlags allFlags, + flagsAll, + flagsDynamic, + flagsPackage, supportedLanguagesAndExtensions, @@ -84,12 +101,15 @@ module DynFlags ( getStgToDo, -- * Compiler configuration suitable for display to the user - compilerInfo + compilerInfo, + #ifdef GHCI -- Only in stage 2 can we be sure that the RTS -- exposes the appropriate runtime boolean - , rtsIsProfiled + rtsIsProfiled, #endif + -- ** Only for use in the tracing functions in Outputable + tracingDynFlags, ) where #include "HsVersions.h" @@ -107,6 +127,7 @@ import Constants ( mAX_CONTEXT_REDUCTION_DEPTH ) import Panic import Util import Maybes ( orElse ) +import qualified Pretty import SrcLoc import FastString import Outputable @@ -128,7 +149,7 @@ import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import System.FilePath -import System.IO ( stderr, hPutChar ) +import System.IO import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet @@ -207,6 +228,7 @@ data DynFlag | Opt_D_dump_splices | Opt_D_dump_BCOs | Opt_D_dump_vect + | Opt_D_dump_avoid_vect | Opt_D_dump_ticked | Opt_D_dump_rtti | Opt_D_source_stats @@ -224,7 +246,7 @@ data DynFlag | Opt_DoStgLinting | Opt_DoCmmLinting | Opt_DoAsmLinting - | Opt_NoLlvmMangler + | Opt_NoLlvmMangler -- hidden flag | Opt_WarnIsError -- -Werror; makes warnings fatal @@ -247,11 +269,13 @@ data DynFlag | Opt_DictsCheap | Opt_EnableRewriteRules -- Apply rewrite rules during simplification | Opt_Vectorise + | Opt_AvoidVect | Opt_RegsGraph -- do graph coloring register allocation | Opt_RegsIterative -- do iterative coalescing graph coloring register allocation | Opt_PedanticBottoms -- Be picky about how we treat bottom - | Opt_LlvmTBAA -- Use LLVM TBAA infastructure for improving AA - | Opt_RegLiveness -- Use the STG Reg liveness information + | Opt_LlvmTBAA -- Use LLVM TBAA infastructure for improving AA (hidden flag) + | Opt_RegLiveness -- Use the STG Reg liveness information (hidden flag) + | Opt_IrrefutableTuples -- Interface files | Opt_IgnoreInterfacePragmas @@ -267,7 +291,6 @@ data DynFlag | Opt_ForceRecomp | Opt_ExcessPrecision | Opt_EagerBlackHoling - | Opt_ReadUserPackageConf | Opt_NoHsMain | Opt_SplitObjs | Opt_StgStats @@ -287,10 +310,16 @@ data DynFlag | Opt_BuildingCabalPackage | Opt_SSE2 | Opt_SSE4_2 + | Opt_IgnoreDotGhci | Opt_GhciSandbox | Opt_GhciHistory | Opt_HelpfulErrors | Opt_DeferTypeErrors + | Opt_Parallel + | Opt_GranMacros + + -- output style opts + | Opt_PprCaseAsLet -- temporary flags | Opt_RunCPS @@ -349,6 +378,7 @@ data WarningFlag = | Opt_WarnUnsafe | Opt_WarnSafe | Opt_WarnPointlessPragmas + | Opt_WarnUnsupportedCallingConventions deriving (Eq, Show, Enum) data Language = Haskell98 | Haskell2010 @@ -360,15 +390,18 @@ data SafeHaskellMode | Sf_Unsafe | Sf_Trustworthy | Sf_Safe - | Sf_SafeInfered + | Sf_SafeInferred deriving (Eq) +instance Show SafeHaskellMode where + show Sf_None = "None" + show Sf_Unsafe = "Unsafe" + show Sf_Trustworthy = "Trustworthy" + show Sf_Safe = "Safe" + show Sf_SafeInferred = "Safe-Inferred" + instance Outputable SafeHaskellMode where - ppr Sf_None = ptext $ sLit "None" - ppr Sf_Unsafe = ptext $ sLit "Unsafe" - ppr Sf_Trustworthy = ptext $ sLit "Trustworthy" - ppr Sf_Safe = ptext $ sLit "Safe" - ppr Sf_SafeInfered = ptext $ sLit "Safe-Infered" + ppr = text . show data ExtensionFlag = Opt_Cpp @@ -435,7 +468,6 @@ data ExtensionFlag | Opt_MonadComprehensions | Opt_GeneralizedNewtypeDeriving | Opt_RecursiveDo - | Opt_DoRec | Opt_PostfixOperators | Opt_TupleSections | Opt_PatternGuards @@ -444,6 +476,7 @@ data ExtensionFlag | Opt_RankNTypes | Opt_ImpredicativeTypes | Opt_TypeOperators + | Opt_ExplicitNamespaces | Opt_PackageImports | Opt_ExplicitForAll | Opt_AlternativeLayoutRule @@ -538,8 +571,8 @@ data DynFlags = DynFlags { depSuffixes :: [String], -- Package flags - extraPkgConfs :: [FilePath], - -- ^ The @-package-conf@ flags given on the command line, in the order + extraPkgConfs :: [PkgConfRef] -> [PkgConfRef], + -- ^ The @-package-db@ flags given on the command line, in the order -- they appeared. packageFlags :: [PackageFlag], @@ -585,12 +618,22 @@ data DynFlags = DynFlags { -- | MsgDoc output action: use "ErrUtils" instead of this if you can log_action :: LogAction, + flushOut :: FlushOut, + flushErr :: FlushErr, haddockOptions :: Maybe String, + ghciScripts :: [String], + + -- Output style options + pprUserLength :: Int, + pprCols :: Int, + traceLevel :: Int, -- Standard level is 1. Less verbose is 0. -- | what kind of {-# SCC #-} to add automatically profAuto :: ProfAuto, + interactivePrint :: Maybe String, + llvmVersion :: IORef (Int) } @@ -728,7 +771,7 @@ wayNames = map wayName . ways -- from an imported module. This will fail if no code has been generated -- for this module. You can use 'GHC.needsTemplateHaskell' to detect -- whether this might be the case and choose to either switch to a --- different target or avoid typechecking such modules. (The latter may +-- different target or avoid typechecking such modules. (The latter may be -- preferable for security reasons.) -- data HscTarget @@ -753,6 +796,17 @@ isObjectTarget HscAsm = True isObjectTarget HscLlvm = True isObjectTarget _ = False +-- | Does this target retain *all* top-level bindings for a module, +-- rather than just the exported bindings, in the TypeEnv and compiled +-- code (if any)? In interpreted mode we do this, so that GHCi can +-- call functions inside a module. In HscNothing mode we also do it, +-- so that Haddock can get access to the GlobalRdrEnv for a module +-- after typechecking it. +targetRetainsAllBindings :: HscTarget -> Bool +targetRetainsAllBindings HscInterpreted = True +targetRetainsAllBindings HscNothing = True +targetRetainsAllBindings _ = False + -- | The 'GhcMode' tells us whether we're doing multi-module -- compilation (controlled via the "GHC" API) or one-shot -- (single-module) compilation. This makes a difference primarily to @@ -899,7 +953,7 @@ defaultDynFlags mySettings = hpcDir = ".hpc", - extraPkgConfs = [], + extraPkgConfs = id, packageFlags = [], pkgDatabase = Nothing, pkgState = panic "no package state yet: call GHC.setSessionDynFlags", @@ -920,8 +974,9 @@ defaultDynFlags mySettings = haddockOptions = Nothing, flags = IntSet.fromList (map fromEnum defaultFlags), warningFlags = IntSet.fromList (map fromEnum standardWarnings), + ghciScripts = [], language = Nothing, - safeHaskell = Sf_SafeInfered, + safeHaskell = Sf_SafeInferred, thOnLoc = noSrcSpan, newDerivOnLoc = noSrcSpan, pkgTrustOnLoc = noSrcSpan, @@ -930,23 +985,72 @@ defaultDynFlags mySettings = extensions = [], extensionFlags = flattenExtensionFlags Nothing [], log_action = defaultLogAction, + flushOut = defaultFlushOut, + flushErr = defaultFlushErr, + pprUserLength = 5, + pprCols = 100, + traceLevel = 1, profAuto = NoProfAuto, - llvmVersion = panic "defaultDynFlags: No llvmVersion" + llvmVersion = panic "defaultDynFlags: No llvmVersion", + interactivePrint = Nothing } -type LogAction = Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO () +-- Do not use tracingDynFlags! +-- tracingDynFlags is a hack, necessary because we need to be able to +-- show SDocs when tracing, but we don't always have DynFlags available. +-- Do not use it if you can help it. It will not reflect options set +-- by the commandline flags, and all fields may be either wrong or +-- undefined. +tracingDynFlags :: DynFlags +tracingDynFlags = defaultDynFlags tracingSettings + where tracingSettings = panic "Settings not defined in tracingDynFlags" + +type FatalMessager = String -> IO () +type LogAction = DynFlags -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO () + +defaultFatalMessager :: FatalMessager +defaultFatalMessager = hPutStrLn stderr defaultLogAction :: LogAction -defaultLogAction severity srcSpan style msg - = case severity of - SevOutput -> printSDoc msg style - SevInfo -> printErrs msg style - SevFatal -> printErrs msg style - _ -> do hPutChar stderr '\n' - printErrs (mkLocMessage severity srcSpan msg) style - -- careful (#2302): printErrs prints in UTF-8, whereas - -- converting to string first and using hPutStr would - -- just emit the low 8 bits of each unicode char. +defaultLogAction dflags severity srcSpan style msg + = case severity of + SevOutput -> printSDoc msg style + SevDump -> hPrintDump dflags stdout msg + SevInfo -> printErrs msg style + SevFatal -> printErrs msg style + _ -> do hPutChar stderr '\n' + printErrs (mkLocMessage severity srcSpan msg) style + -- careful (#2302): printErrs prints in UTF-8, whereas + -- converting to string first and using hPutStr would + -- just emit the low 8 bits of each unicode char. + where printSDoc = defaultLogActionHPrintDoc dflags stdout + printErrs = defaultLogActionHPrintDoc dflags stderr + +defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO () +defaultLogActionHPrintDoc dflags h d sty + = do let doc = runSDoc d (initSDocContext dflags sty) + Pretty.printDoc Pretty.PageMode (pprCols dflags) h doc + hFlush h + +newtype FlushOut = FlushOut (IO ()) + +defaultFlushOut :: FlushOut +defaultFlushOut = FlushOut $ hFlush stdout + +newtype FlushErr = FlushErr (IO ()) + +defaultFlushErr :: FlushErr +defaultFlushErr = FlushErr $ hFlush stderr + +printOutputForUser :: DynFlags -> PrintUnqualified -> SDoc -> IO () +printOutputForUser = printSevForUser SevOutput + +printInfoForUser :: DynFlags -> PrintUnqualified -> SDoc -> IO () +printInfoForUser = printSevForUser SevInfo + +printSevForUser :: Severity -> DynFlags -> PrintUnqualified -> SDoc -> IO () +printSevForUser sev dflags unqual doc + = log_action dflags dflags sev noSrcSpan (mkUserStyle unqual AllTheWay) doc {- Note [Verbosity levels] @@ -1050,15 +1154,16 @@ xopt_unset dfs f in dfs { extensions = onoffs, extensionFlags = flattenExtensionFlags (language dfs) onoffs } +lang_set :: DynFlags -> Maybe Language -> DynFlags +lang_set dflags lang = + dflags { + language = lang, + extensionFlags = flattenExtensionFlags lang (extensions dflags) + } + -- | Set the Haskell language standard to use setLanguage :: Language -> DynP () -setLanguage l = upd f - where f dfs = let mLang = Just l - oneoffs = extensions dfs - in dfs { - language = mLang, - extensionFlags = flattenExtensionFlags mLang oneoffs - } +setLanguage l = upd (`lang_set` Just l) -- | Some modules have dependencies on others through the DynFlags rather than textual imports dynFlagDependencies :: DynFlags -> [ModuleName] @@ -1078,7 +1183,7 @@ safeLanguageOn dflags = safeHaskell dflags == Sf_Safe -- | Is the Safe Haskell safe inference mode active safeInferOn :: DynFlags -> Bool -safeInferOn dflags = safeHaskell dflags == Sf_SafeInfered +safeInferOn dflags = safeHaskell dflags == Sf_SafeInferred -- | Test if Safe Imports are on in some form safeImportsOn :: DynFlags -> Bool @@ -1109,14 +1214,27 @@ safeImplicitImpsReq d = safeLanguageOn d -- want to export this functionality from the module but do want to export the -- type constructors. combineSafeFlags :: SafeHaskellMode -> SafeHaskellMode -> DynP SafeHaskellMode -combineSafeFlags a b | a == Sf_SafeInfered = return b - | b == Sf_SafeInfered = return a - | a == Sf_None = return b - | b == Sf_None = return a - | a == b = return a - | otherwise = addErr errm >> return (panic errm) +combineSafeFlags a b | a == Sf_SafeInferred = return b + | b == Sf_SafeInferred = return a + | a == Sf_None = return b + | b == Sf_None = return a + | a == b = return a + | otherwise = addErr errm >> return (panic errm) where errm = "Incompatible Safe Haskell flags! (" - ++ showPpr a ++ ", " ++ showPpr b ++ ")" + ++ show a ++ ", " ++ show b ++ ")" + +-- | A list of unsafe flags under Safe Haskell. Tuple elements are: +-- * name of the flag +-- * function to get srcspan that enabled the flag +-- * function to test if the flag is on +-- * function to turn the flag off +unsafeFlags :: [(String, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)] +unsafeFlags = [("-XGeneralizedNewtypeDeriving", newDerivOnLoc, + xopt Opt_GeneralizedNewtypeDeriving, + flip xopt_unset Opt_GeneralizedNewtypeDeriving), + ("-XTemplateHaskell", thOnLoc, + xopt Opt_TemplateHaskell, + flip xopt_unset Opt_TemplateHaskell)] -- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order getOpts :: DynFlags -- ^ 'DynFlags' to retrieve the options from @@ -1136,7 +1254,8 @@ setObjectDir, setHiDir, setStubDir, setDumpDir, setOutputDir, setDylibInstallName, setObjectSuf, setHiSuf, setHcSuf, parseDynLibLoaderMode, setPgmP, addOptl, addOptP, - addCmdlineFramework, addHaddockOpts + addCmdlineFramework, addHaddockOpts, addGhciScript, + setInteractivePrint :: String -> DynFlags -> DynFlags setOutputFile, setOutputHi, setDumpPrefixForce :: Maybe String -> DynFlags -> DynFlags @@ -1208,6 +1327,10 @@ addCmdlineFramework f d = d{ cmdlineFrameworks = f : cmdlineFrameworks d} addHaddockOpts f d = d{ haddockOptions = Just f} +addGhciScript f d = d{ ghciScripts = f : ghciScripts d} + +setInteractivePrint f d = d{ interactivePrint = Just f} + -- ----------------------------------------------------------------------------- -- Command-line options @@ -1275,31 +1398,39 @@ getStgToDo dflags -- ----------------------------------------------------------------------------- -- Parsing the dynamic flags. + -- | Parse dynamic flags from a list of command line arguments. Returns the -- the parsed 'DynFlags', the left-over arguments, and a list of warnings. -- Throws a 'UsageError' if errors occurred during parsing (such as unknown -- flags or missing arguments). -parseDynamicFlagsCmdLine :: Monad m => - DynFlags -> [Located String] - -> m (DynFlags, [Located String], [Located String]) - -- ^ Updated 'DynFlags', left-over arguments, and - -- list of warnings. -parseDynamicFlagsCmdLine dflags args = parseDynamicFlags dflags args True +parseDynamicFlagsCmdLine :: Monad m => DynFlags -> [Located String] + -> m (DynFlags, [Located String], [Located String]) + -- ^ Updated 'DynFlags', left-over arguments, and + -- list of warnings. +parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAll True + -- | Like 'parseDynamicFlagsCmdLine' but does not allow the package flags --- (-package, -hide-package, -ignore-package, -hide-all-packages, -package-conf). +-- (-package, -hide-package, -ignore-package, -hide-all-packages, -package-db). -- Used to parse flags set in a modules pragma. -parseDynamicFilePragma :: Monad m => - DynFlags -> [Located String] +parseDynamicFilePragma :: Monad m => DynFlags -> [Located String] + -> m (DynFlags, [Located String], [Located String]) + -- ^ Updated 'DynFlags', left-over arguments, and + -- list of warnings. +parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamic False + + +-- | Parses the dynamically set flags for GHC. This is the most general form of +-- the dynamic flag parser that the other methods simply wrap. It allows +-- saying which flags are valid flags and indicating if we are parsing +-- arguments from the command line or from a file pragma. +parseDynamicFlagsFull :: Monad m + => [Flag (CmdLineP DynFlags)] -- ^ valid flags to match against + -> Bool -- ^ are the arguments from the command line? + -> DynFlags -- ^ current dynamic flags + -> [Located String] -- ^ arguments to parse -> m (DynFlags, [Located String], [Located String]) - -- ^ Updated 'DynFlags', left-over arguments, and - -- list of warnings. -parseDynamicFilePragma dflags args = parseDynamicFlags dflags args False - -parseDynamicFlags :: Monad m => - DynFlags -> [Located String] -> Bool - -> m (DynFlags, [Located String], [Located String]) -parseDynamicFlags dflags0 args cmdline = do +parseDynamicFlagsFull activeFlags cmdline dflags0 args = do -- XXX Legacy support code -- We used to accept things like -- optdep-f -optdepdepend @@ -1312,12 +1443,8 @@ parseDynamicFlags dflags0 args cmdline = do f xs = xs args' = f args - -- Note: -ignore-package (package_flags) must precede -i* (dynamic_flags) - flag_spec | cmdline = package_flags ++ dynamic_flags - | otherwise = dynamic_flags - let ((leftover, errs, warns), dflags1) - = runCmdLine (processArgs flag_spec args') dflags0 + = runCmdLine (processArgs activeFlags args') dflags0 when (not (null errs)) $ ghcError $ errorsToGhcException errs -- check for disabled flags in safe haskell @@ -1325,18 +1452,23 @@ parseDynamicFlags dflags0 args cmdline = do return (dflags2, leftover, sh_warns ++ warns) + -- | Check (and potentially disable) any extensions that aren't allowed -- in safe mode. +-- +-- The bool is to indicate if we are parsing command line flags (false means +-- file pragma). This allows us to generate better warnings. safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Located String]) safeFlagCheck _ dflags | not (safeLanguageOn dflags || safeInferOn dflags) = (dflags, []) +-- safe or safe-infer ON safeFlagCheck cmdl dflags = case safeLanguageOn dflags of True -> (dflags', warns) -- throw error if -fpackage-trust by itself with no safe haskell flag - False | not cmdl && safeInferOn dflags && packageTrustOn dflags + False | not cmdl && packageTrustOn dflags -> (dopt_unset dflags' Opt_PackageTrust, [L (pkgTrustOnLoc dflags') $ "-fpackage-trust ignored;" ++ @@ -1348,16 +1480,16 @@ safeFlagCheck cmdl dflags = | otherwise -> (dflags' { safeHaskell = Sf_None }, []) - -- Have we infered Unsafe? + -- Have we inferred Unsafe? -- See Note [HscMain . Safe Haskell Inference] where -- TODO: Can we do better than this for inference? safeInfOk = not $ xopt Opt_OverlappingInstances dflags - (dflags', warns) = foldl check_method (dflags, []) bad_flags + (dflags', warns) = foldl check_method (dflags, []) unsafeFlags check_method (df, warns) (str,loc,test,fix) - | test df = (apFix fix df, warns ++ safeFailure loc str) + | test df = (apFix fix df, warns ++ safeFailure (loc dflags) str) | otherwise = (df, warns) apFix f = if safeInferOn dflags then id else f @@ -1365,20 +1497,14 @@ safeFlagCheck cmdl dflags = safeFailure loc str = [L loc $ str ++ " is not allowed in Safe Haskell; ignoring " ++ str] - bad_flags = [("-XGeneralizedNewtypeDeriving", newDerivOnLoc dflags, - xopt Opt_GeneralizedNewtypeDeriving, - flip xopt_unset Opt_GeneralizedNewtypeDeriving), - ("-XTemplateHaskell", thOnLoc dflags, - xopt Opt_TemplateHaskell, - flip xopt_unset Opt_TemplateHaskell)] - - {- ********************************************************************** %* * DynFlags specifications %* * %********************************************************************* -} +-- | All dynamic flags option strings. These are the user facing strings for +-- enabling and disabling options. allFlags :: [String] allFlags = map ('-':) $ [ flagName flag | flag <- dynamic_flags ++ package_flags, ok (flagOptKind flag) ] ++ @@ -1392,6 +1518,23 @@ allFlags = map ('-':) $ fflags1 = [ name | (name, _, _) <- fWarningFlags ] fflags2 = [ name | (name, _, _) <- fLangFlags ] +{- + - Below we export user facing symbols for GHC dynamic flags for use with the + - GHC API. + -} + +-- All dynamic flags present in GHC. +flagsAll :: [Flag (CmdLineP DynFlags)] +flagsAll = package_flags ++ dynamic_flags + +-- All dynamic flags, minus package flags, present in GHC. +flagsDynamic :: [Flag (CmdLineP DynFlags)] +flagsDynamic = dynamic_flags + +-- ALl package flags present in GHC. +flagsPackage :: [Flag (CmdLineP DynFlags)] +flagsPackage = package_flags + --------------- The main flags themselves ------------------ dynamic_flags :: [Flag (CmdLineP DynFlags)] dynamic_flags = [ @@ -1505,7 +1648,8 @@ dynamic_flags = [ , Flag "haddock" (NoArg (setDynFlag Opt_Haddock)) , Flag "haddock-opts" (hasArg addHaddockOpts) , Flag "hpcdir" (SepArg setOptHpcDir) - + , Flag "ghci-script" (hasArg addGhciScript) + , Flag "interactive-print" (hasArg setInteractivePrint) ------- recompilation checker -------------------------------------- , Flag "recomp" (NoArg (do unSetDynFlag Opt_ForceRecomp deprecate "Use -fno-force-recomp instead")) @@ -1520,6 +1664,11 @@ dynamic_flags = [ , Flag "I" (Prefix addIncludePath) , Flag "i" (OptPrefix addImportPath) + ------ Output style options ----------------------------------------- + , Flag "dppr-user-length" (intSuffix (\n d -> d{ pprUserLength = n })) + , Flag "dppr-cols" (intSuffix (\n d -> d{ pprCols = n })) + , Flag "dtrace-level" (intSuffix (\n d -> d{ traceLevel = n })) + ------ Debugging ---------------------------------------------------- , Flag "dstg-stats" (NoArg (setDynFlag Opt_StgStats)) @@ -1594,6 +1743,7 @@ dynamic_flags = [ , Flag "ddump-hi" (setDumpFlag Opt_D_dump_hi) , Flag "ddump-minimal-imports" (setDumpFlag Opt_D_dump_minimal_imports) , Flag "ddump-vect" (setDumpFlag Opt_D_dump_vect) + , Flag "ddump-avoid-vect" (setDumpFlag Opt_D_dump_avoid_vect) , Flag "ddump-hpc" (setDumpFlag Opt_D_dump_ticked) -- back compat , Flag "ddump-ticked" (setDumpFlag Opt_D_dump_ticked) , Flag "ddump-mod-cycles" (setDumpFlag Opt_D_dump_mod_cycles) @@ -1608,7 +1758,7 @@ dynamic_flags = [ , Flag "dshow-passes" (NoArg (do forceRecompile setVerbosity $ Just 2)) , Flag "dfaststring-stats" (NoArg (setDynFlag Opt_D_faststring_stats)) - , Flag "dno-llvm-mangler" (NoArg (setDynFlag Opt_NoLlvmMangler)) + , Flag "dno-llvm-mangler" (NoArg (setDynFlag Opt_NoLlvmMangler)) -- hidden flag ------ Machine dependant (-m<blah>) stuff --------------------------- @@ -1691,6 +1841,10 @@ dynamic_flags = [ , Flag "fpackage-trust" (NoArg setPackageTrust) , Flag "fno-safe-infer" (NoArg (setSafeHaskell Sf_None)) ] + ++ map (mkFlag turnOn "" setDynFlag ) negatableFlags + ++ map (mkFlag turnOff "no-" unSetDynFlag) negatableFlags + ++ map (mkFlag turnOn "d" setDynFlag ) dFlags + ++ map (mkFlag turnOff "dno-" unSetDynFlag) dFlags ++ map (mkFlag turnOn "f" setDynFlag ) fFlags ++ map (mkFlag turnOff "fno-" unSetDynFlag) fFlags ++ map (mkFlag turnOn "f" setWarningFlag ) fWarningFlags @@ -1707,8 +1861,21 @@ dynamic_flags = [ package_flags :: [Flag (CmdLineP DynFlags)] package_flags = [ ------- Packages ---------------------------------------------------- - Flag "package-conf" (HasArg extraPkgConf_) - , Flag "no-user-package-conf" (NoArg (unSetDynFlag Opt_ReadUserPackageConf)) + Flag "package-db" (HasArg (addPkgConfRef . PkgConfFile)) + , Flag "clear-package-db" (NoArg clearPkgConf) + , Flag "no-global-package-db" (NoArg removeGlobalPkgConf) + , Flag "no-user-package-db" (NoArg removeUserPkgConf) + , Flag "global-package-db" (NoArg (addPkgConfRef GlobalPkgConf)) + , Flag "user-package-db" (NoArg (addPkgConfRef UserPkgConf)) + + -- backwards compat with GHC<=7.4 : + , Flag "package-conf" (HasArg $ \path -> do + addPkgConfRef (PkgConfFile path) + deprecate "Use -package-db instead") + , Flag "no-user-package-conf" (NoArg $ do + removeUserPkgConf + deprecate "Use -no-user-package-db instead") + , Flag "package-name" (hasArg setPackageName) , Flag "package-id" (HasArg exposePackageId) , Flag "package" (HasArg exposePackage) @@ -1795,7 +1962,18 @@ fWarningFlags = [ ( "warn-alternative-layout-rule-transitional", Opt_WarnAlternativeLayoutRuleTransitional, nop ), ( "warn-unsafe", Opt_WarnUnsafe, setWarnUnsafe ), ( "warn-safe", Opt_WarnSafe, setWarnSafe ), - ( "warn-pointless-pragmas", Opt_WarnPointlessPragmas, nop ) ] + ( "warn-pointless-pragmas", Opt_WarnPointlessPragmas, nop ), + ( "warn-unsupported-calling-conventions", Opt_WarnUnsupportedCallingConventions, nop ) ] + +-- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@ +negatableFlags :: [FlagSpec DynFlag] +negatableFlags = [ + ( "ignore-dot-ghci", Opt_IgnoreDotGhci, nop ) ] + +-- | These @-d\<blah\>@ flags can all be reversed with @-dno-\<blah\>@ +dFlags :: [FlagSpec DynFlag] +dFlags = [ + ( "ppr-case-as-let", Opt_PprCaseAsLet, nop ) ] -- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@ fFlags :: [FlagSpec DynFlag] @@ -1834,10 +2012,12 @@ fFlags = [ ( "run-cpsz", Opt_RunCPSZ, nop ), ( "new-codegen", Opt_TryNewCodeGen, nop ), ( "vectorise", Opt_Vectorise, nop ), + ( "avoid-vect", Opt_AvoidVect, nop ), ( "regs-graph", Opt_RegsGraph, nop ), ( "regs-iterative", Opt_RegsIterative, nop ), - ( "llvm-tbaa", Opt_LlvmTBAA, nop), - ( "reg-liveness", Opt_RegLiveness, nop), + ( "llvm-tbaa", Opt_LlvmTBAA, nop), -- hidden flag + ( "regs-liveness", Opt_RegLiveness, nop), -- hidden flag + ( "irrefutable-tuples", Opt_IrrefutableTuples, nop ), ( "gen-manifest", Opt_GenManifest, nop ), ( "embed-manifest", Opt_EmbedManifest, nop ), ( "ext-core", Opt_EmitExternalCore, nop ), @@ -1846,6 +2026,8 @@ fFlags = [ ( "ghci-history", Opt_GhciHistory, nop ), ( "helpful-errors", Opt_HelpfulErrors, nop ), ( "defer-type-errors", Opt_DeferTypeErrors, nop ), + ( "parallel", Opt_Parallel, nop ), + ( "gransim", Opt_GranMacros, nop ), ( "building-cabal-package", Opt_BuildingCabalPackage, nop ), ( "implicit-import-qualified", Opt_ImplicitImportQualified, nop ), ( "prof-count-entries", Opt_ProfCountEntries, nop ), @@ -1914,7 +2096,7 @@ languageFlags = [ -- features can be used. safeHaskellFlags :: [FlagSpec SafeHaskellMode] safeHaskellFlags = [mkF Sf_Unsafe, mkF Sf_Trustworthy, mkF Sf_Safe] - where mkF flag = (showPpr flag, flag, nop) + where mkF flag = (show flag, flag, nop) -- | These -X<blah> flags can all be reversed with -XNo<blah> xFlags :: [FlagSpec ExtensionFlag] @@ -1942,9 +2124,10 @@ xFlags = [ ( "RankNTypes", Opt_RankNTypes, nop ), ( "ImpredicativeTypes", Opt_ImpredicativeTypes, nop), ( "TypeOperators", Opt_TypeOperators, nop ), - ( "RecursiveDo", Opt_RecursiveDo, -- Enables 'mdo' - deprecatedForExtension "DoRec"), - ( "DoRec", Opt_DoRec, nop ), -- Enables 'rec' keyword + ( "ExplicitNamespaces", Opt_ExplicitNamespaces, nop ), + ( "RecursiveDo", Opt_RecursiveDo, nop ), -- Enables 'mdo' and 'rec' + ( "DoRec", Opt_RecursiveDo, + deprecatedForExtension "RecursiveDo" ), ( "Arrows", Opt_Arrows, nop ), ( "ParallelArrays", Opt_ParallelArrays, nop ), ( "TemplateHaskell", Opt_TemplateHaskell, checkTemplateHaskellOk ), @@ -2015,7 +2198,6 @@ xFlags = [ defaultFlags :: [DynFlag] defaultFlags = [ Opt_AutoLinkPackages, - Opt_ReadUserPackageConf, Opt_SharedImplib, @@ -2053,7 +2235,12 @@ impliedFlags , (Opt_TypeFamilies, turnOn, Opt_MonoLocalBinds) , (Opt_TypeFamilies, turnOn, Opt_KindSignatures) -- Type families use kind signatures - -- all over the place + , (Opt_PolyKinds, turnOn, Opt_KindSignatures) -- Ditto polymorphic kinds + + -- We turn this on so that we can export associated type + -- type synonyms in subordinates (e.g. MyClass(type AssocType)) + , (Opt_TypeFamilies, turnOn, Opt_ExplicitNamespaces) + , (Opt_TypeOperators, turnOn, Opt_ExplicitNamespaces) , (Opt_ImpredicativeTypes, turnOn, Opt_RankNTypes) @@ -2064,6 +2251,11 @@ impliedFlags , (Opt_RecordWildCards, turnOn, Opt_DisambiguateRecordFields) , (Opt_ParallelArrays, turnOn, Opt_ParallelListComp) + + -- An implicit parameter constraint, `?x::Int`, is desugared into + -- `IP "x" Int`, which requires a flexible context/instance. + , (Opt_ImplicitParams, turnOn, Opt_FlexibleContexts) + , (Opt_ImplicitParams, turnOn, Opt_FlexibleInstances) ] optLevelFlags :: [([Int], DynFlag)] @@ -2121,7 +2313,8 @@ standardWarnings Opt_WarnDodgyForeignImports, Opt_WarnWrongDoBind, Opt_WarnAlternativeLayoutRuleTransitional, - Opt_WarnPointlessPragmas + Opt_WarnPointlessPragmas, + Opt_WarnUnsupportedCallingConventions ] minusWOpts :: [WarningFlag] @@ -2184,7 +2377,8 @@ glasgowExtsFlags = [ , Opt_LiberalTypeSynonyms , Opt_RankNTypes , Opt_TypeOperators - , Opt_DoRec + , Opt_ExplicitNamespaces + , Opt_RecursiveDo , Opt_ParallelListComp , Opt_EmptyDataDecls , Opt_KindSignatures @@ -2347,8 +2541,28 @@ setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 }) addCmdlineHCInclude :: String -> DynP () addCmdlineHCInclude a = upd (\s -> s{cmdlineHcIncludes = a : cmdlineHcIncludes s}) -extraPkgConf_ :: FilePath -> DynP () -extraPkgConf_ p = upd (\s -> s{ extraPkgConfs = p : extraPkgConfs s }) +data PkgConfRef + = GlobalPkgConf + | UserPkgConf + | PkgConfFile FilePath + +addPkgConfRef :: PkgConfRef -> DynP () +addPkgConfRef p = upd $ \s -> s { extraPkgConfs = (p:) . extraPkgConfs s } + +removeUserPkgConf :: DynP () +removeUserPkgConf = upd $ \s -> s { extraPkgConfs = filter isNotUser . extraPkgConfs s } + where + isNotUser UserPkgConf = False + isNotUser _ = True + +removeGlobalPkgConf :: DynP () +removeGlobalPkgConf = upd $ \s -> s { extraPkgConfs = filter isNotGlobal . extraPkgConfs s } + where + isNotGlobal GlobalPkgConf = False + isNotGlobal _ = True + +clearPkgConf :: DynP () +clearPkgConf = upd $ \s -> s { extraPkgConfs = const [] } exposePackage, exposePackageId, hidePackage, ignorePackage, trustPackage, distrustPackage :: String -> DynP () diff --git a/compiler/main/DynFlags.hs-boot b/compiler/main/DynFlags.hs-boot new file mode 100644 index 0000000000..9f14d41600 --- /dev/null +++ b/compiler/main/DynFlags.hs-boot @@ -0,0 +1,13 @@ + +module DynFlags where + +import Platform + +data DynFlags + +tracingDynFlags :: DynFlags + +targetPlatform :: DynFlags -> Platform +pprUserLength :: DynFlags -> Int +pprCols :: DynFlags -> Int + diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs index cc382a74fe..84eb2612e0 100644 --- a/compiler/main/DynamicLoading.hs +++ b/compiler/main/DynamicLoading.hs @@ -70,9 +70,10 @@ forceLoadTyCon hsc_env con_name = do mb_con_thing <- lookupTypeHscEnv hsc_env con_name case mb_con_thing of - Nothing -> throwCmdLineErrorS $ missingTyThingError con_name + Nothing -> throwCmdLineErrorS dflags $ missingTyThingError con_name Just (ATyCon tycon) -> return tycon - Just con_thing -> throwCmdLineErrorS $ wrongTyThingError con_name con_thing + Just con_thing -> throwCmdLineErrorS dflags $ wrongTyThingError con_name con_thing + where dflags = hsc_dflags hsc_env -- | Loads the value corresponding to a 'Name' if that value has the given 'Type'. This only provides limited safety -- in that it is up to the user to ensure that that type corresponds to the type you try to use the return value at! @@ -91,7 +92,7 @@ getValueSafely hsc_env val_name expected_type = do -- Now look up the names for the value and type constructor in the type environment mb_val_thing <- lookupTypeHscEnv hsc_env val_name case mb_val_thing of - Nothing -> throwCmdLineErrorS $ missingTyThingError val_name + Nothing -> throwCmdLineErrorS dflags $ missingTyThingError val_name Just (AnId id) -> do -- Check the value type in the interface against the type recovered from the type constructor -- before finally casting the value to the type we assume corresponds to that constructor @@ -107,7 +108,8 @@ getValueSafely hsc_env val_name expected_type = do value <- lessUnsafeCoerce (hsc_dflags hsc_env) "getValueSafely" hval return $ Just value else return Nothing - Just val_thing -> throwCmdLineErrorS $ wrongTyThingError val_name val_thing + Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing + where dflags = hsc_dflags hsc_env -- | Coerce a value as usual, but: @@ -149,10 +151,9 @@ lookupRdrNameInModule hsc_env mod_name rdr_name = do [] -> return Nothing _ -> panic "lookupRdrNameInModule" - Nothing -> throwCmdLineErrorS $ hsep [ptext (sLit "Could not determine the exports of the module"), ppr mod_name] - err -> throwCmdLineErrorS $ cannotFindModule dflags mod_name err - where - dflags = hsc_dflags hsc_env + Nothing -> throwCmdLineErrorS dflags $ hsep [ptext (sLit "Could not determine the exports of the module"), ppr mod_name] + err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err + where dflags = hsc_dflags hsc_env wrongTyThingError :: Name -> TyThing -> SDoc @@ -161,8 +162,8 @@ wrongTyThingError name got_thing = hsep [ptext (sLit "The name"), ppr name, ptex missingTyThingError :: Name -> SDoc missingTyThingError name = hsep [ptext (sLit "The name"), ppr name, ptext (sLit "is not in the type environment: are you sure it exists?")] -throwCmdLineErrorS :: SDoc -> IO a -throwCmdLineErrorS = throwCmdLineError . showSDoc +throwCmdLineErrorS :: DynFlags -> SDoc -> IO a +throwCmdLineErrorS dflags = throwCmdLineError . showSDoc dflags throwCmdLineError :: String -> IO a throwCmdLineError = throwGhcException . CmdLineError diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index 6ba9df436c..daa66f9d2f 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -9,7 +9,7 @@ module ErrUtils ( ErrMsg, WarnMsg, Severity(..), Messages, ErrorMessages, WarningMessages, errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo, - MsgDoc, mkLocMessage, printError, pprMessageBag, pprErrMsgBag, + MsgDoc, mkLocMessage, pprMessageBag, pprErrMsgBag, pprErrMsgBagWithLoc, pprLocErrMsg, makeIntoWarning, errorsFound, emptyMessages, @@ -25,27 +25,32 @@ module ErrUtils ( -- * Messages during compilation putMsg, putMsgWith, errorMsg, - fatalErrorMsg, fatalErrorMsg', + fatalErrorMsg, fatalErrorMsg', fatalErrorMsg'', compilationProgressMsg, showPass, debugTraceMsg, + + prettyPrintGhcErrors, ) where #include "HsVersions.h" import Bag ( Bag, bagToList, isEmptyBag, emptyBag ) -import Util +import Exception import Outputable +import Panic import FastString import SrcLoc import DynFlags import StaticFlags ( opt_ErrorSpans ) +import System.Directory import System.Exit ( ExitCode(..), exitWith ) import System.FilePath import Data.List import qualified Data.Set as Set import Data.IORef +import Data.Ord import Control.Monad import System.IO @@ -59,7 +64,8 @@ type ErrorMessages = Bag ErrMsg data ErrMsg = ErrMsg { errMsgSpans :: [SrcSpan], errMsgContext :: PrintUnqualified, - errMsgShortDoc :: MsgDoc, + errMsgShortDoc :: MsgDoc, -- errMsgShort* should always + errMsgShortString :: String, -- contain the same text errMsgExtraInfo :: MsgDoc, errMsgSeverity :: Severity } @@ -70,13 +76,14 @@ type MsgDoc = SDoc data Severity = SevOutput + | SevDump | SevInfo | SevWarning | SevError | SevFatal instance Show ErrMsg where - show em = showSDoc (errMsgShortDoc em) + show em = errMsgShortString em pprMessageBag :: Bag MsgDoc -> SDoc pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) @@ -95,41 +102,40 @@ mkLocMessage severity locn msg -- For warnings, print Foo.hs:34: Warning: -- <the warning message> -printError :: SrcSpan -> MsgDoc -> IO () -printError span msg = printErrs (mkLocMessage SevError span msg) defaultErrStyle - makeIntoWarning :: ErrMsg -> ErrMsg makeIntoWarning err = err { errMsgSeverity = SevWarning } -- ----------------------------------------------------------------------------- -- Collecting up messages for later ordering and printing. -mk_err_msg :: Severity -> SrcSpan -> PrintUnqualified -> MsgDoc -> SDoc -> ErrMsg -mk_err_msg sev locn print_unqual msg extra +mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> MsgDoc -> SDoc -> ErrMsg +mk_err_msg dflags sev locn print_unqual msg extra = ErrMsg { errMsgSpans = [locn], errMsgContext = print_unqual - , errMsgShortDoc = msg, errMsgExtraInfo = extra + , errMsgShortDoc = msg , errMsgShortString = showSDoc dflags msg + , errMsgExtraInfo = extra , errMsgSeverity = sev } -mkLongErrMsg, mkLongWarnMsg :: SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg +mkLongErrMsg, mkLongWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg -- A long (multi-line) error message -mkErrMsg, mkWarnMsg :: SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg +mkErrMsg, mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg -- A short (one-line) error message -mkPlainErrMsg, mkPlainWarnMsg :: SrcSpan -> MsgDoc -> ErrMsg +mkPlainErrMsg, mkPlainWarnMsg :: DynFlags -> SrcSpan -> MsgDoc -> ErrMsg -- Variant that doesn't care about qualified/unqualified names -mkLongErrMsg locn unqual msg extra = mk_err_msg SevError locn unqual msg extra -mkErrMsg locn unqual msg = mk_err_msg SevError locn unqual msg empty -mkPlainErrMsg locn msg = mk_err_msg SevError locn alwaysQualify msg empty -mkLongWarnMsg locn unqual msg extra = mk_err_msg SevWarning locn unqual msg extra -mkWarnMsg locn unqual msg = mk_err_msg SevWarning locn unqual msg empty -mkPlainWarnMsg locn msg = mk_err_msg SevWarning locn alwaysQualify msg empty +mkLongErrMsg dflags locn unqual msg extra = mk_err_msg dflags SevError locn unqual msg extra +mkErrMsg dflags locn unqual msg = mk_err_msg dflags SevError locn unqual msg empty +mkPlainErrMsg dflags locn msg = mk_err_msg dflags SevError locn alwaysQualify msg empty +mkLongWarnMsg dflags locn unqual msg extra = mk_err_msg dflags SevWarning locn unqual msg extra +mkWarnMsg dflags locn unqual msg = mk_err_msg dflags SevWarning locn unqual msg empty +mkPlainWarnMsg dflags locn msg = mk_err_msg dflags SevWarning locn alwaysQualify msg empty ---------------- emptyMessages :: Messages emptyMessages = (emptyBag, emptyBag) -warnIsErrorMsg :: ErrMsg -warnIsErrorMsg = mkPlainErrMsg noSrcSpan (text "\nFailing due to -Werror.") +warnIsErrorMsg :: DynFlags -> ErrMsg +warnIsErrorMsg dflags + = mkPlainErrMsg dflags noSrcSpan (text "\nFailing due to -Werror.") errorsFound :: DynFlags -> Messages -> Bool errorsFound _dflags (_warns, errs) = not (isEmptyBag errs) @@ -140,26 +146,31 @@ printBagOfErrors dflags bag_of_errors pprErrMsgBag :: Bag ErrMsg -> [SDoc] pprErrMsgBag bag - = [ let style = mkErrStyle unqual + = [ sdocWithDynFlags $ \dflags -> + let style = mkErrStyle dflags unqual in withPprStyle style (d $$ e) | ErrMsg { errMsgShortDoc = d, errMsgExtraInfo = e, errMsgContext = unqual } <- sortMsgBag bag ] +pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc] +pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag bag ] + pprLocErrMsg :: ErrMsg -> SDoc pprLocErrMsg (ErrMsg { errMsgSpans = spans , errMsgShortDoc = d , errMsgExtraInfo = e , errMsgSeverity = sev , errMsgContext = unqual }) - = withPprStyle (mkErrStyle unqual) (mkLocMessage sev s (d $$ e)) + = sdocWithDynFlags $ \dflags -> + withPprStyle (mkErrStyle dflags unqual) (mkLocMessage sev s (d $$ e)) where (s : _) = spans -- Should be non-empty printMsgBag :: DynFlags -> Bag ErrMsg -> IO () printMsgBag dflags bag - = sequence_ [ let style = mkErrStyle unqual - in log_action dflags sev s style (d $$ e) + = sequence_ [ let style = mkErrStyle dflags unqual + in log_action dflags dflags sev s style (d $$ e) | ErrMsg { errMsgSpans = s:_, errMsgShortDoc = d, errMsgSeverity = sev, @@ -167,13 +178,8 @@ printMsgBag dflags bag errMsgContext = unqual } <- sortMsgBag bag ] sortMsgBag :: Bag ErrMsg -> [ErrMsg] -sortMsgBag bag = sortLe srcOrder $ bagToList bag - where - srcOrder err1 err2 = - case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of - LT -> True - EQ -> True - GT -> False +sortMsgBag bag = sortBy (comparing (head . errMsgSpans)) $ bagToList bag + -- TODO: Why "head ."? Why not compare the whole list? ghcExit :: DynFlags -> Int -> IO () ghcExit dflags val @@ -192,10 +198,10 @@ doIfSet_dyn dflags flag action | dopt flag dflags = action -- ----------------------------------------------------------------------------- -- Dumping -dumpIfSet :: Bool -> String -> SDoc -> IO () -dumpIfSet flag hdr doc +dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO () +dumpIfSet dflags flag hdr doc | not flag = return () - | otherwise = printDump (mkDumpDoc hdr doc) + | otherwise = log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc) dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO () dumpIfSet_dyn dflags flag hdr doc @@ -239,14 +245,14 @@ dumpSDoc dflags dflag hdr doc mode = if append then AppendMode else WriteMode when (not append) $ writeIORef gdref (Set.insert fileName gd) - createDirectoryHierarchy (takeDirectory fileName) + createDirectoryIfMissing True (takeDirectory fileName) handle <- openFile fileName mode - hPrintDump handle doc + hPrintDump dflags handle doc hClose handle -- write the dump to stdout Nothing - -> printDump (mkDumpDoc hdr doc) + -> log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc) -- | Choose where to put a dump file based on DynFlags @@ -299,33 +305,50 @@ ifVerbose dflags val act | otherwise = return () putMsg :: DynFlags -> MsgDoc -> IO () -putMsg dflags msg = log_action dflags SevInfo noSrcSpan defaultUserStyle msg +putMsg dflags msg = log_action dflags dflags SevInfo noSrcSpan defaultUserStyle msg putMsgWith :: DynFlags -> PrintUnqualified -> MsgDoc -> IO () putMsgWith dflags print_unqual msg - = log_action dflags SevInfo noSrcSpan sty msg + = log_action dflags dflags SevInfo noSrcSpan sty msg where sty = mkUserStyle print_unqual AllTheWay errorMsg :: DynFlags -> MsgDoc -> IO () -errorMsg dflags msg = log_action dflags SevError noSrcSpan defaultErrStyle msg +errorMsg dflags msg = + log_action dflags dflags SevError noSrcSpan (defaultErrStyle dflags) msg fatalErrorMsg :: DynFlags -> MsgDoc -> IO () -fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) msg +fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) dflags msg + +fatalErrorMsg' :: LogAction -> DynFlags -> MsgDoc -> IO () +fatalErrorMsg' la dflags msg = + la dflags SevFatal noSrcSpan (defaultErrStyle dflags) msg -fatalErrorMsg' :: LogAction -> MsgDoc -> IO () -fatalErrorMsg' la msg = la SevFatal noSrcSpan defaultErrStyle msg +fatalErrorMsg'' :: FatalMessager -> String -> IO () +fatalErrorMsg'' fm msg = fm msg compilationProgressMsg :: DynFlags -> String -> IO () compilationProgressMsg dflags msg - = ifVerbose dflags 1 (log_action dflags SevOutput noSrcSpan defaultUserStyle (text msg)) + = ifVerbose dflags 1 (log_action dflags dflags SevOutput noSrcSpan defaultUserStyle (text msg)) showPass :: DynFlags -> String -> IO () showPass dflags what - = ifVerbose dflags 2 (log_action dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon)) + = ifVerbose dflags 2 (log_action dflags dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon)) debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO () debugTraceMsg dflags val msg - = ifVerbose dflags val (log_action dflags SevInfo noSrcSpan defaultDumpStyle msg) + = ifVerbose dflags val (log_action dflags dflags SevInfo noSrcSpan defaultDumpStyle msg) + +prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a +prettyPrintGhcErrors dflags + = ghandle $ \e -> case e of + PprPanic str doc -> + pprDebugAndThen dflags panic str doc + PprSorry str doc -> + pprDebugAndThen dflags sorry str doc + PprProgramError str doc -> + pprDebugAndThen dflags pgmError str doc + _ -> + throw e \end{code} diff --git a/compiler/main/ErrUtils.lhs-boot b/compiler/main/ErrUtils.lhs-boot index 7718cbe2a6..6f4a373313 100644 --- a/compiler/main/ErrUtils.lhs-boot +++ b/compiler/main/ErrUtils.lhs-boot @@ -6,6 +6,7 @@ import SrcLoc (SrcSpan) data Severity = SevOutput + | SevDump | SevInfo | SevWarning | SevError diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index d3a8bb11de..bedb30002a 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -10,6 +10,7 @@ module GHC ( -- * Initialisation defaultErrorHandler, defaultCleanupHandler, + prettyPrintGhcErrors, -- * GHC Monad Ghc, GhcT, GhcMonad(..), HscEnv, @@ -24,8 +25,9 @@ module GHC ( DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt, GhcMode(..), GhcLink(..), defaultObjectTarget, parseDynamicFlags, - getSessionDynFlags, - setSessionDynFlags, + getSessionDynFlags, setSessionDynFlags, + getProgramDynFlags, setProgramDynFlags, + getInteractiveDynFlags, setInteractiveDynFlags, parseStaticFlags, -- * Targets @@ -71,10 +73,12 @@ module GHC ( modInfoIsExportedName, modInfoLookupName, modInfoIface, + modInfoSafe, lookupGlobalName, findGlobalAnns, mkPrintUnqualifiedForModule, ModIface(..), + SafeHaskellMode(..), -- * Querying the environment packageDbModules, @@ -119,6 +123,11 @@ module GHC ( #endif lookupName, +#ifdef GHCI + -- ** EXPERIMENTAL + setGHCiMonad, +#endif + -- * Abstract syntax elements -- ** Packages @@ -253,6 +262,7 @@ import HscMain import GhcMake import DriverPipeline ( compile' ) import GhcMonad +import TcRnMonad ( finalSafeMode ) import TcRnTypes import Packages import NameSet @@ -323,35 +333,36 @@ import Prelude hiding (init) -- Unless you want to handle exceptions yourself, you should wrap this around -- the top level of your program. The default handlers output the error -- message(s) to stderr and exit cleanly. -defaultErrorHandler :: (ExceptionMonad m, MonadIO m) => LogAction -> m a -> m a -defaultErrorHandler la inner = +defaultErrorHandler :: (ExceptionMonad m, MonadIO m) + => FatalMessager -> FlushOut -> m a -> m a +defaultErrorHandler fm (FlushOut flushOut) inner = -- top-level exception handler: any unrecognised exception is a compiler bug. ghandle (\exception -> liftIO $ do - hFlush stdout + flushOut case fromException exception of -- an IO exception probably isn't our fault, so don't panic Just (ioe :: IOException) -> - fatalErrorMsg' la (text (show ioe)) + fatalErrorMsg'' fm (show ioe) _ -> case fromException exception of Just UserInterrupt -> exitWith (ExitFailure 1) Just StackOverflow -> - fatalErrorMsg' la (text "stack overflow: use +RTS -K<size> to increase it") + fatalErrorMsg'' fm "stack overflow: use +RTS -K<size> to increase it" _ -> case fromException exception of Just (ex :: ExitCode) -> throw ex _ -> - fatalErrorMsg' la - (text (show (Panic (show exception)))) + fatalErrorMsg'' fm + (show (Panic (show exception))) exitWith (ExitFailure 1) ) $ -- error messages propagated as exceptions handleGhcException (\ge -> liftIO $ do - hFlush stdout + flushOut case ge of PhaseFailed _ code -> exitWith code Signal _ -> exitWith (ExitFailure 1) - _ -> do fatalErrorMsg' la (text (show ge)) + _ -> do fatalErrorMsg'' fm (show ge) exitWith (ExitFailure 1) ) $ inner @@ -448,11 +459,33 @@ initGhcMonad mb_top_dir = do -- %* * -- %************************************************************************ --- | Updates the DynFlags in a Session. This also reads --- the package database (unless it has already been read), --- and prepares the compilers knowledge about packages. It --- can be called again to load new packages: just add new --- package flags to (packageFlags dflags). +-- $DynFlags +-- +-- The GHC session maintains two sets of 'DynFlags': +-- +-- * The "interactive" @DynFlags@, which are used for everything +-- related to interactive evaluation, including 'runStmt', +-- 'runDecls', 'exprType', 'lookupName' and so on (everything +-- under \"Interactive evaluation\" in this module). +-- +-- * The "program" @DynFlags@, which are used when loading +-- whole modules with 'load' +-- +-- 'setInteractiveDynFlags', 'getInteractiveDynFlags' work with the +-- interactive @DynFlags@. +-- +-- 'setProgramDynFlags', 'getProgramDynFlags' work with the +-- program @DynFlags@. +-- +-- 'setSessionDynFlags' sets both @DynFlags@, and 'getSessionDynFlags' +-- retrieves the program @DynFlags@ (for backwards compatibility). + + +-- | Updates both the interactive and program DynFlags in a Session. +-- This also reads the package database (unless it has already been +-- read), and prepares the compilers knowledge about packages. It can +-- be called again to load new packages: just add new package flags to +-- (packageFlags dflags). -- -- Returns a list of new packages that may need to be linked in using -- the dynamic linker (see 'linkPackages') as a result of new package @@ -462,9 +495,33 @@ initGhcMonad mb_top_dir = do setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageId] setSessionDynFlags dflags = do (dflags', preload) <- liftIO $ initPackages dflags - modifySession (\h -> h{ hsc_dflags = dflags' }) + modifySession $ \h -> h{ hsc_dflags = dflags' + , hsc_IC = (hsc_IC h){ ic_dflags = dflags' } } + return preload + +-- | Sets the program 'DynFlags'. +setProgramDynFlags :: GhcMonad m => DynFlags -> m [PackageId] +setProgramDynFlags dflags = do + (dflags', preload) <- liftIO $ initPackages dflags + modifySession $ \h -> h{ hsc_dflags = dflags' } return preload +-- | Returns the program 'DynFlags'. +getProgramDynFlags :: GhcMonad m => m DynFlags +getProgramDynFlags = getSessionDynFlags + +-- | Set the 'DynFlags' used to evaluate interactive expressions. +-- Note: this cannot be used for changes to packages. Use +-- 'setSessionDynFlags', or 'setProgramDynFlags' and then copy the +-- 'pkgState' into the interactive @DynFlags@. +setInteractiveDynFlags :: GhcMonad m => DynFlags -> m () +setInteractiveDynFlags dflags = do + modifySession $ \h -> h{ hsc_IC = (hsc_IC h) { ic_dflags = dflags }} + +-- | Get the 'DynFlags' used to evaluate interactive expressions. +getInteractiveDynFlags :: GhcMonad m => m DynFlags +getInteractiveDynFlags = withSession $ \h -> return (ic_dflags (hsc_IC h)) + parseDynamicFlags :: Monad m => DynFlags -> [Located String] @@ -533,8 +590,9 @@ guessTarget str Nothing if looksLikeModuleName file then return (target (TargetModule (mkModuleName file))) else do + dflags <- getDynFlags throwGhcException - (ProgramError (showSDoc $ + (ProgramError (showSDoc dflags $ text "target" <+> quotes (text file) <+> text "is not a module name or a source file")) where @@ -662,9 +720,11 @@ getModSummary :: GhcMonad m => ModuleName -> m ModSummary getModSummary mod = do mg <- liftM hsc_mod_graph getSession case [ ms | ms <- mg, ms_mod_name ms == mod, not (isBootSummary ms) ] of - [] -> throw $ mkApiErr (text "Module not part of module graph") + [] -> do dflags <- getDynFlags + throw $ mkApiErr dflags (text "Module not part of module graph") [ms] -> return ms - multiple -> throw $ mkApiErr (text "getModSummary is ambiguous: " <+> ppr multiple) + multiple -> do dflags <- getDynFlags + throw $ mkApiErr dflags (text "getModSummary is ambiguous: " <+> ppr multiple) -- | Parse a module. -- @@ -689,6 +749,7 @@ typecheckModule pmod = do HsParsedModule { hpm_module = parsedSource pmod, hpm_src_files = pm_extra_src_files pmod } details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env + safe <- liftIO $ finalSafeMode (ms_hspp_opts ms) tc_gbl_env return $ TypecheckedModule { tm_internals_ = (tc_gbl_env, details), @@ -701,7 +762,8 @@ typecheckModule pmod = do minf_exports = availsToNameSet $ md_exports details, minf_rdr_env = Just (tcg_rdr_env tc_gbl_env), minf_instances = md_insts details, - minf_iface = Nothing + minf_iface = Nothing, + minf_safe = safe #ifdef GHCI ,minf_modBreaks = emptyModBreaks #endif @@ -775,12 +837,16 @@ data CoreModule -- | Type environment for types declared in this module cm_types :: !TypeEnv, -- | Declarations - cm_binds :: CoreProgram + cm_binds :: CoreProgram, + -- | Safe Haskell mode + cm_safe :: SafeHaskellMode } instance Outputable CoreModule where - ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb}) = - text "%module" <+> ppr mn <+> ppr te $$ vcat (map ppr cb) + ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb, + cm_safe = sf}) + = text "%module" <+> ppr mn <+> parens (ppr sf) <+> ppr te + $$ vcat (map ppr cb) -- | This is the way to get access to the Core bindings corresponding -- to a module. 'compileToCore' parses, typechecks, and @@ -794,15 +860,6 @@ compileToCoreModule = compileCore False -- as to return simplified and tidied Core. compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule compileToCoreSimplified = compileCore True -{- --- | Provided for backwards-compatibility: compileToCore returns just the Core --- bindings, but for most purposes, you probably want to call --- compileToCoreModule. -compileToCore :: GhcMonad m => FilePath -> m [CoreBind] -compileToCore fn = do - mod <- compileToCoreModule session fn - return $ cm_binds mod --} -- | Takes a CoreModule and compiles the bindings therein -- to object code. The first argument is a bool flag indicating -- whether to run the simplifier. @@ -817,7 +874,7 @@ compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do modLocation <- liftIO $ mkHiOnlyModLocation dflags (hiSuf dflags) cwd ((moduleNameSlashes . moduleName) mName) - let modSummary = ModSummary { ms_mod = mName, + let modSum = ModSummary { ms_mod = mName, ms_hsc_src = ExtCoreFile, ms_location = modLocation, -- By setting the object file timestamp to Nothing, @@ -836,7 +893,7 @@ compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do } hsc_env <- getSession - liftIO $ hscCompileCore hsc_env simplify modSummary (cm_binds cm) + liftIO $ hscCompileCore hsc_env simplify (cm_safe cm) modSum (cm_binds cm) compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule @@ -854,7 +911,7 @@ compileCore simplify fn = do mod_guts <- coreModule `fmap` -- TODO: space leaky: call hsc* directly? (desugarModule =<< typecheckModule =<< parseModule modSummary) - liftM gutsToCoreModule $ + liftM (gutsToCoreModule (mg_safe_haskell mod_guts)) $ if simplify then do -- If simplify is true: simplify (hscSimplify), then tidy @@ -871,18 +928,22 @@ compileCore simplify fn = do where -- two versions, based on whether we simplify (thus run tidyProgram, -- which returns a (CgGuts, ModDetails) pair, or not (in which case -- we just have a ModGuts. - gutsToCoreModule :: Either (CgGuts, ModDetails) ModGuts -> CoreModule - gutsToCoreModule (Left (cg, md)) = CoreModule { + gutsToCoreModule :: SafeHaskellMode + -> Either (CgGuts, ModDetails) ModGuts + -> CoreModule + gutsToCoreModule safe_mode (Left (cg, md)) = CoreModule { cm_module = cg_module cg, - cm_types = md_types md, - cm_binds = cg_binds cg + cm_types = md_types md, + cm_binds = cg_binds cg, + cm_safe = safe_mode } - gutsToCoreModule (Right mg) = CoreModule { + gutsToCoreModule safe_mode (Right mg) = CoreModule { cm_module = mg_module mg, cm_types = typeEnvFromEntities (bindersOfBinds (mg_binds mg)) (mg_tcs mg) (mg_fam_insts mg), - cm_binds = mg_binds mg + cm_binds = mg_binds mg, + cm_safe = safe_mode } -- %************************************************************************ @@ -929,9 +990,10 @@ data ModuleInfo = ModuleInfo { minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails? minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod minf_instances :: [ClsInst], - minf_iface :: Maybe ModIface + minf_iface :: Maybe ModIface, + minf_safe :: SafeHaskellMode #ifdef GHCI - ,minf_modBreaks :: ModBreaks + ,minf_modBreaks :: ModBreaks #endif } -- We don't want HomeModInfo here, because a ModuleInfo applies @@ -972,6 +1034,7 @@ getPackageModuleInfo hsc_env mdl minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails, minf_instances = error "getModuleInfo: instances for package module unimplemented", minf_iface = Just iface, + minf_safe = getSafeMode $ mi_trust iface, minf_modBreaks = emptyModBreaks })) #else @@ -992,7 +1055,8 @@ getHomeModuleInfo hsc_env mdl = minf_exports = availsToNameSet (md_exports details), minf_rdr_env = mi_globals $! hm_iface hmi, minf_instances = md_insts details, - minf_iface = Just iface + minf_iface = Just iface, + minf_safe = getSafeMode $ mi_trust iface #ifdef GHCI ,minf_modBreaks = getModBreaks hmi #endif @@ -1037,6 +1101,10 @@ modInfoLookupName minf name = withSession $ \hsc_env -> do modInfoIface :: ModuleInfo -> Maybe ModIface modInfoIface = minf_iface +-- | Retrieve module safe haskell mode +modInfoSafe :: ModuleInfo -> SafeHaskellMode +modInfoSafe = minf_safe + #ifdef GHCI modInfoModBreaks :: ModuleInfo -> ModBreaks modInfoModBreaks = minf_modBreaks @@ -1117,7 +1185,8 @@ getModuleSourceAndFlags :: GhcMonad m => Module -> m (String, StringBuffer, DynF getModuleSourceAndFlags mod = do m <- getModSummary (moduleName mod) case ml_hs_file $ ms_location m of - Nothing -> throw $ mkApiErr (text "No source available for module " <+> ppr mod) + Nothing -> do dflags <- getDynFlags + throw $ mkApiErr dflags (text "No source available for module " <+> ppr mod) Just sourceFile -> do source <- liftIO $ hGetStringBuffer sourceFile return (sourceFile, source, ms_hspp_opts m) @@ -1133,7 +1202,9 @@ getTokenStream mod = do let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 case lexTokenStream source startLoc flags of POk _ ts -> return ts - PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err) + PFailed span err -> + do dflags <- getDynFlags + throw $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err) -- | Give even more information on the source than 'getTokenStream' -- This function allows reconstructing the source completely with @@ -1144,7 +1215,9 @@ getRichTokenStream mod = do let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 case lexTokenStream source startLoc flags of POk _ ts -> return $ addSourceToTokens startLoc source ts - PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err) + PFailed span err -> + do dflags <- getDynFlags + throw $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err) -- | Given a source location and a StringBuffer corresponding to this -- location, return a rich token stream with the source associated to the @@ -1219,11 +1292,11 @@ findModule mod_name maybe_pkg = withSession $ \hsc_env -> do res <- findImportedModule hsc_env mod_name maybe_pkg case res of Found loc m | modulePackageId m /= this_pkg -> return m - | otherwise -> modNotLoadedError m loc + | otherwise -> modNotLoadedError dflags m loc err -> noModError dflags noSrcSpan mod_name err -modNotLoadedError :: Module -> ModLocation -> IO a -modNotLoadedError m loc = ghcError $ CmdLineError $ showSDoc $ +modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a +modNotLoadedError dflags m loc = ghcError $ CmdLineError $ showSDoc dflags $ text "module is not loaded:" <+> quotes (ppr (moduleName m)) <+> parens (text (expectJust "modNotLoadedError" (ml_hs_file loc))) @@ -1262,6 +1335,21 @@ isModuleTrusted :: GhcMonad m => Module -> m Bool isModuleTrusted m = withSession $ \hsc_env -> liftIO $ hscCheckSafe hsc_env m noSrcSpan +-- | EXPERIMENTAL: DO NOT USE. +-- +-- Set the monad GHCi lifts user statements into. +-- +-- Checks that a type (in string form) is an instance of the +-- @GHC.GHCi.GHCiSandboxIO@ type class. Sets it to be the GHCi monad if it is, +-- throws an error otherwise. +{-# WARNING setGHCiMonad "This is experimental! Don't use." #-} +setGHCiMonad :: GhcMonad m => String -> m () +setGHCiMonad name = withSession $ \hsc_env -> do + ty <- liftIO $ hscIsGHCiMonad hsc_env name + modifySession $ \s -> + let ic = (hsc_IC s) { ic_monad = ty } + in s { hsc_IC = ic } + getHistorySpan :: GhcMonad m => History -> m SrcSpan getHistorySpan h = withSession $ \hsc_env -> return $ InteractiveEval.getHistorySpan hsc_env h @@ -1301,7 +1389,7 @@ parser str dflags filename = case unP Parser.parseModule (mkPState dflags buf loc) of PFailed span err -> - Left (unitBag (mkPlainErrMsg span err)) + Left (unitBag (mkPlainErrMsg dflags span err)) POk pst rdr_module -> let (warns,_) = getMessages pst in diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index a2fb9edf16..322c631a4c 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -4,73 +4,65 @@ -- -- (c) The University of Glasgow, 2011 -- --- This module implements multi-module compilation, and is used --- by --make and GHCi. +-- This module implements multi-module compilation, and is used +-- by --make and GHCi. -- -- ----------------------------------------------------------------------------- - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module GhcMake( - depanal, - load, LoadHowMuch(..), + depanal, + load, LoadHowMuch(..), - topSortModuleGraph, + topSortModuleGraph, - noModError, cyclicModuleErr - ) where + noModError, cyclicModuleErr + ) where #include "HsVersions.h" #ifdef GHCI -import qualified Linker ( unload ) +import qualified Linker ( unload ) #endif -import DriverPipeline import DriverPhases -import GhcMonad -import Module -import HscTypes -import ErrUtils +import DriverPipeline import DynFlags -import HsSyn +import ErrUtils import Finder +import GhcMonad import HeaderInfo -import TcIface ( typecheckIface ) -import TcRnMonad ( initIfaceCheck ) -import RdrName ( RdrName ) +import HsSyn +import HscTypes +import Module +import RdrName ( RdrName ) +import TcIface ( typecheckIface ) +import TcRnMonad ( initIfaceCheck ) -import Exception ( evaluate, tryIO ) -import Panic -import SysTools +import Bag ( listToBag ) import BasicTypes -import SrcLoc -import Util import Digraph -import Bag ( listToBag ) -import Maybes ( expectJust, mapCatMaybes ) -import StringBuffer +import Exception ( evaluate, tryIO ) import FastString +import Maybes ( expectJust, mapCatMaybes ) import Outputable +import Panic +import SrcLoc +import StringBuffer +import SysTools import UniqFM +import Util import qualified Data.Map as Map -import qualified FiniteMap as Map( insertListWith) +import qualified FiniteMap as Map ( insertListWith ) -import System.Directory -import System.IO ( fixIO ) -import System.IO.Error ( isDoesNotExistError ) -import System.FilePath import Control.Monad -import Data.Maybe import Data.List import qualified Data.List as List +import Data.Maybe import Data.Time +import System.Directory +import System.FilePath +import System.IO ( fixIO ) +import System.IO.Error ( isDoesNotExistError ) -- ----------------------------------------------------------------------------- -- Loading the program @@ -94,14 +86,14 @@ depanal :: GhcMonad m => depanal excluded_mods allow_dup_roots = do hsc_env <- getSession let - dflags = hsc_dflags hsc_env - targets = hsc_targets hsc_env - old_graph = hsc_mod_graph hsc_env - + dflags = hsc_dflags hsc_env + targets = hsc_targets hsc_env + old_graph = hsc_mod_graph hsc_env + liftIO $ showPass dflags "Chasing dependencies" liftIO $ debugTraceMsg dflags 2 (hcat [ - text "Chasing modules from: ", - hcat (punctuate comma (map pprTarget targets))]) + text "Chasing modules from: ", + hcat (punctuate comma (map pprTarget targets))]) mod_graph <- liftIO $ downsweep hsc_env old_graph excluded_mods allow_dup_roots modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph } @@ -133,226 +125,219 @@ data LoadHowMuch -- load :: GhcMonad m => LoadHowMuch -> m SuccessFlag load how_much = do - mod_graph <- depanal [] False - load2 how_much mod_graph - -load2 :: GhcMonad m => LoadHowMuch -> [ModSummary] - -> m SuccessFlag -load2 how_much mod_graph = do - guessOutputFile - hsc_env <- getSession - - let hpt1 = hsc_HPT hsc_env - let dflags = hsc_dflags hsc_env - - -- The "bad" boot modules are the ones for which we have - -- B.hs-boot in the module graph, but no B.hs - -- The downsweep should have ensured this does not happen - -- (see msDeps) - let all_home_mods = [ms_mod_name s - | s <- mod_graph, not (isBootSummary s)] - bad_boot_mods = [s | s <- mod_graph, isBootSummary s, - not (ms_mod_name s `elem` all_home_mods)] - ASSERT( null bad_boot_mods ) return () - - -- check that the module given in HowMuch actually exists, otherwise - -- topSortModuleGraph will bomb later. - let checkHowMuch (LoadUpTo m) = checkMod m - checkHowMuch (LoadDependenciesOf m) = checkMod m - checkHowMuch _ = id - - checkMod m and_then - | m `elem` all_home_mods = and_then - | otherwise = do - liftIO $ errorMsg dflags (text "no such module:" <+> - quotes (ppr m)) - return Failed - - checkHowMuch how_much $ do - - -- mg2_with_srcimps drops the hi-boot nodes, returning a - -- graph with cycles. Among other things, it is used for - -- backing out partially complete cycles following a failed - -- upsweep, and for removing from hpt all the modules - -- not in strict downwards closure, during calls to compile. - let mg2_with_srcimps :: [SCC ModSummary] - mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing - - -- If we can determine that any of the {-# SOURCE #-} imports - -- are definitely unnecessary, then emit a warning. - warnUnnecessarySourceImports mg2_with_srcimps - - let - -- check the stability property for each module. - stable_mods@(stable_obj,stable_bco) - = checkStability hpt1 mg2_with_srcimps all_home_mods - - -- prune bits of the HPT which are definitely redundant now, - -- to save space. - pruned_hpt = pruneHomePackageTable hpt1 - (flattenSCCs mg2_with_srcimps) - stable_mods - - _ <- liftIO $ evaluate pruned_hpt - - -- before we unload anything, make sure we don't leave an old - -- interactive context around pointing to dead bindings. Also, - -- write the pruned HPT to allow the old HPT to be GC'd. - modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext, - hsc_HPT = pruned_hpt } - - liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$ - text "Stable BCO:" <+> ppr stable_bco) - - -- Unload any modules which are going to be re-linked this time around. - let stable_linkables = [ linkable - | m <- stable_obj++stable_bco, - Just hmi <- [lookupUFM pruned_hpt m], - Just linkable <- [hm_linkable hmi] ] - liftIO $ unload hsc_env stable_linkables - - -- We could at this point detect cycles which aren't broken by - -- a source-import, and complain immediately, but it seems better - -- to let upsweep_mods do this, so at least some useful work gets - -- done before the upsweep is abandoned. - --hPutStrLn stderr "after tsort:\n" - --hPutStrLn stderr (showSDoc (vcat (map ppr mg2))) - - -- Now do the upsweep, calling compile for each module in - -- turn. Final result is version 3 of everything. - - -- Topologically sort the module graph, this time including hi-boot - -- nodes, and possibly just including the portion of the graph - -- reachable from the module specified in the 2nd argument to load. - -- This graph should be cycle-free. - -- If we're restricting the upsweep to a portion of the graph, we - -- also want to retain everything that is still stable. - let full_mg :: [SCC ModSummary] - full_mg = topSortModuleGraph False mod_graph Nothing - - maybe_top_mod = case how_much of - LoadUpTo m -> Just m - LoadDependenciesOf m -> Just m - _ -> Nothing - - partial_mg0 :: [SCC ModSummary] - partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod - - -- LoadDependenciesOf m: we want the upsweep to stop just - -- short of the specified module (unless the specified module - -- is stable). - partial_mg - | LoadDependenciesOf _mod <- how_much - = ASSERT( case last partial_mg0 of - AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False ) - List.init partial_mg0 - | otherwise - = partial_mg0 - - stable_mg = - [ AcyclicSCC ms - | AcyclicSCC ms <- full_mg, - ms_mod_name ms `elem` stable_obj++stable_bco, - ms_mod_name ms `notElem` [ ms_mod_name ms' | - AcyclicSCC ms' <- partial_mg ] ] - - mg = stable_mg ++ partial_mg - - -- clean up between compilations - let cleanup hsc_env = intermediateCleanTempFiles dflags - (flattenSCCs mg2_with_srcimps) - hsc_env - - liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep") - 2 (ppr mg)) - - setSession hsc_env{ hsc_HPT = emptyHomePackageTable } - (upsweep_ok, modsUpswept) - <- upsweep pruned_hpt stable_mods cleanup mg - - -- Make modsDone be the summaries for each home module now - -- available; this should equal the domain of hpt3. - -- Get in in a roughly top .. bottom order (hence reverse). - - let modsDone = reverse modsUpswept - - -- Try and do linking in some form, depending on whether the - -- upsweep was completely or only partially successful. - - if succeeded upsweep_ok - - then - -- Easy; just relink it all. - do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.") - - -- Clean up after ourselves - hsc_env1 <- getSession - liftIO $ intermediateCleanTempFiles dflags modsDone hsc_env1 - - -- Issue a warning for the confusing case where the user - -- said '-o foo' but we're not going to do any linking. - -- We attempt linking if either (a) one of the modules is - -- called Main, or (b) the user said -no-hs-main, indicating - -- that main() is going to come from somewhere else. - -- - let ofile = outputFile dflags - let no_hs_main = dopt Opt_NoHsMain dflags - let - main_mod = mainModIs dflags - a_root_is_Main = any ((==main_mod).ms_mod) mod_graph - do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib - - when (ghcLink dflags == LinkBinary - && isJust ofile && not do_linking) $ - liftIO $ debugTraceMsg dflags 1 $ - text ("Warning: output was redirected with -o, " ++ - "but no output will be generated\n" ++ - "because there is no " ++ - moduleNameString (moduleName main_mod) ++ " module.") - - -- link everything together - linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1) - - loadFinish Succeeded linkresult - - else - -- Tricky. We need to back out the effects of compiling any - -- half-done cycles, both so as to clean up the top level envs - -- and to avoid telling the interactive linker to link them. - do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.") - - let modsDone_names - = map ms_mod modsDone - let mods_to_zap_names - = findPartiallyCompletedCycles modsDone_names - mg2_with_srcimps - let mods_to_keep - = filter ((`notElem` mods_to_zap_names).ms_mod) - modsDone - - hsc_env1 <- getSession - let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) - (hsc_HPT hsc_env1) - - -- Clean up after ourselves - liftIO $ intermediateCleanTempFiles dflags mods_to_keep hsc_env1 - - -- there should be no Nothings where linkables should be, now - ASSERT(all (isJust.hm_linkable) - (eltsUFM (hsc_HPT hsc_env))) do - - -- Link everything together - linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4 - - modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt4 } - loadFinish Failed linkresult - --- Finish up after a load. + mod_graph <- depanal [] False + guessOutputFile + hsc_env <- getSession + + let hpt1 = hsc_HPT hsc_env + let dflags = hsc_dflags hsc_env + + -- The "bad" boot modules are the ones for which we have + -- B.hs-boot in the module graph, but no B.hs + -- The downsweep should have ensured this does not happen + -- (see msDeps) + let all_home_mods = [ms_mod_name s + | s <- mod_graph, not (isBootSummary s)] + bad_boot_mods = [s | s <- mod_graph, isBootSummary s, + not (ms_mod_name s `elem` all_home_mods)] + ASSERT( null bad_boot_mods ) return () + + -- check that the module given in HowMuch actually exists, otherwise + -- topSortModuleGraph will bomb later. + let checkHowMuch (LoadUpTo m) = checkMod m + checkHowMuch (LoadDependenciesOf m) = checkMod m + checkHowMuch _ = id + + checkMod m and_then + | m `elem` all_home_mods = and_then + | otherwise = do + liftIO $ errorMsg dflags (text "no such module:" <+> + quotes (ppr m)) + return Failed + + checkHowMuch how_much $ do + + -- mg2_with_srcimps drops the hi-boot nodes, returning a + -- graph with cycles. Among other things, it is used for + -- backing out partially complete cycles following a failed + -- upsweep, and for removing from hpt all the modules + -- not in strict downwards closure, during calls to compile. + let mg2_with_srcimps :: [SCC ModSummary] + mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing + + -- If we can determine that any of the {-# SOURCE #-} imports + -- are definitely unnecessary, then emit a warning. + warnUnnecessarySourceImports mg2_with_srcimps + + let + -- check the stability property for each module. + stable_mods@(stable_obj,stable_bco) + = checkStability hpt1 mg2_with_srcimps all_home_mods + + -- prune bits of the HPT which are definitely redundant now, + -- to save space. + pruned_hpt = pruneHomePackageTable hpt1 + (flattenSCCs mg2_with_srcimps) + stable_mods + + _ <- liftIO $ evaluate pruned_hpt + + -- before we unload anything, make sure we don't leave an old + -- interactive context around pointing to dead bindings. Also, + -- write the pruned HPT to allow the old HPT to be GC'd. + modifySession $ \_ -> discardIC $ hsc_env { hsc_HPT = pruned_hpt } + + liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$ + text "Stable BCO:" <+> ppr stable_bco) + + -- Unload any modules which are going to be re-linked this time around. + let stable_linkables = [ linkable + | m <- stable_obj++stable_bco, + Just hmi <- [lookupUFM pruned_hpt m], + Just linkable <- [hm_linkable hmi] ] + liftIO $ unload hsc_env stable_linkables + + -- We could at this point detect cycles which aren't broken by + -- a source-import, and complain immediately, but it seems better + -- to let upsweep_mods do this, so at least some useful work gets + -- done before the upsweep is abandoned. + --hPutStrLn stderr "after tsort:\n" + --hPutStrLn stderr (showSDoc (vcat (map ppr mg2))) + + -- Now do the upsweep, calling compile for each module in + -- turn. Final result is version 3 of everything. + + -- Topologically sort the module graph, this time including hi-boot + -- nodes, and possibly just including the portion of the graph + -- reachable from the module specified in the 2nd argument to load. + -- This graph should be cycle-free. + -- If we're restricting the upsweep to a portion of the graph, we + -- also want to retain everything that is still stable. + let full_mg :: [SCC ModSummary] + full_mg = topSortModuleGraph False mod_graph Nothing + + maybe_top_mod = case how_much of + LoadUpTo m -> Just m + LoadDependenciesOf m -> Just m + _ -> Nothing + + partial_mg0 :: [SCC ModSummary] + partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod + + -- LoadDependenciesOf m: we want the upsweep to stop just + -- short of the specified module (unless the specified module + -- is stable). + partial_mg + | LoadDependenciesOf _mod <- how_much + = ASSERT( case last partial_mg0 of + AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False ) + List.init partial_mg0 + | otherwise + = partial_mg0 + + stable_mg = + [ AcyclicSCC ms + | AcyclicSCC ms <- full_mg, + ms_mod_name ms `elem` stable_obj++stable_bco, + ms_mod_name ms `notElem` [ ms_mod_name ms' | + AcyclicSCC ms' <- partial_mg ] ] + + mg = stable_mg ++ partial_mg + + -- clean up between compilations + let cleanup hsc_env = intermediateCleanTempFiles dflags + (flattenSCCs mg2_with_srcimps) + hsc_env + + liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep") + 2 (ppr mg)) + + setSession hsc_env{ hsc_HPT = emptyHomePackageTable } + (upsweep_ok, modsUpswept) + <- upsweep pruned_hpt stable_mods cleanup mg + + -- Make modsDone be the summaries for each home module now + -- available; this should equal the domain of hpt3. + -- Get in in a roughly top .. bottom order (hence reverse). + + let modsDone = reverse modsUpswept + + -- Try and do linking in some form, depending on whether the + -- upsweep was completely or only partially successful. + + if succeeded upsweep_ok + + then + -- Easy; just relink it all. + do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.") + + -- Clean up after ourselves + hsc_env1 <- getSession + liftIO $ intermediateCleanTempFiles dflags modsDone hsc_env1 + + -- Issue a warning for the confusing case where the user + -- said '-o foo' but we're not going to do any linking. + -- We attempt linking if either (a) one of the modules is + -- called Main, or (b) the user said -no-hs-main, indicating + -- that main() is going to come from somewhere else. + -- + let ofile = outputFile dflags + let no_hs_main = dopt Opt_NoHsMain dflags + let + main_mod = mainModIs dflags + a_root_is_Main = any ((==main_mod).ms_mod) mod_graph + do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib + + when (ghcLink dflags == LinkBinary + && isJust ofile && not do_linking) $ + liftIO $ debugTraceMsg dflags 1 $ + text ("Warning: output was redirected with -o, " ++ + "but no output will be generated\n" ++ + "because there is no " ++ + moduleNameString (moduleName main_mod) ++ " module.") + + -- link everything together + linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1) + + loadFinish Succeeded linkresult + + else + -- Tricky. We need to back out the effects of compiling any + -- half-done cycles, both so as to clean up the top level envs + -- and to avoid telling the interactive linker to link them. + do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.") + + let modsDone_names + = map ms_mod modsDone + let mods_to_zap_names + = findPartiallyCompletedCycles modsDone_names + mg2_with_srcimps + let mods_to_keep + = filter ((`notElem` mods_to_zap_names).ms_mod) + modsDone + + hsc_env1 <- getSession + let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) + (hsc_HPT hsc_env1) + + -- Clean up after ourselves + liftIO $ intermediateCleanTempFiles dflags mods_to_keep hsc_env1 + + -- there should be no Nothings where linkables should be, now + ASSERT(all (isJust.hm_linkable) + (eltsUFM (hsc_HPT hsc_env))) do + + -- Link everything together + linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4 + + modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt4 } + loadFinish Failed linkresult + + +-- | Finish up after a load. +loadFinish :: GhcMonad m => SuccessFlag -> SuccessFlag -> m SuccessFlag -- If the link failed, unload everything and return. -loadFinish :: GhcMonad m => - SuccessFlag -> SuccessFlag - -> m SuccessFlag loadFinish _all_ok Failed = do hsc_env <- getSession liftIO $ unload hsc_env [] @@ -362,16 +347,20 @@ loadFinish _all_ok Failed -- Empty the interactive context and set the module context to the topmost -- newly loaded module, or the Prelude if none were loaded. loadFinish all_ok Succeeded - = do modifySession $ \hsc_env -> hsc_env{ hsc_IC = emptyInteractiveContext } + = do modifySession discardIC return all_ok --- Forget the current program, but retain the persistent info in HscEnv +-- | Forget the current program, but retain the persistent info in HscEnv discardProg :: HscEnv -> HscEnv discardProg hsc_env - = hsc_env { hsc_mod_graph = emptyMG, - hsc_IC = emptyInteractiveContext, - hsc_HPT = emptyHomePackageTable } + = discardIC $ hsc_env { hsc_mod_graph = emptyMG + , hsc_HPT = emptyHomePackageTable } + +-- | Discard the contents of the InteractiveContext, but keep the DynFlags +discardIC :: HscEnv -> HscEnv +discardIC hsc_env + = hsc_env { hsc_IC = emptyInteractiveContext (ic_dflags (hsc_IC hsc_env)) } intermediateCleanTempFiles :: DynFlags -> [ModSummary] -> HscEnv -> IO () intermediateCleanTempFiles dflags summaries hsc_env @@ -416,13 +405,13 @@ guessOutputFile = modifySession $ \env -> Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } } -- ----------------------------------------------------------------------------- - +-- -- | Prune the HomePackageTable -- -- Before doing an upsweep, we can throw away: -- -- - For non-stable modules: --- - all ModDetails, all linked code +-- - all ModDetails, all linked code -- - all unlinked code that is out of date with respect to -- the source file -- @@ -430,34 +419,31 @@ guessOutputFile = modifySession $ \env -> -- space at the end of the upsweep, because the topmost ModDetails of the -- old HPT holds on to the entire type environment from the previous -- compilation. - -pruneHomePackageTable - :: HomePackageTable - -> [ModSummary] - -> ([ModuleName],[ModuleName]) - -> HomePackageTable - +pruneHomePackageTable :: HomePackageTable + -> [ModSummary] + -> ([ModuleName],[ModuleName]) + -> HomePackageTable pruneHomePackageTable hpt summ (stable_obj, stable_bco) = mapUFM prune hpt where prune hmi - | is_stable modl = hmi' - | otherwise = hmi'{ hm_details = emptyModDetails } - where - modl = moduleName (mi_module (hm_iface hmi)) - hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms - = hmi{ hm_linkable = Nothing } - | otherwise - = hmi - where ms = expectJust "prune" (lookupUFM ms_map modl) + | is_stable modl = hmi' + | otherwise = hmi'{ hm_details = emptyModDetails } + where + modl = moduleName (mi_module (hm_iface hmi)) + hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms + = hmi{ hm_linkable = Nothing } + | otherwise + = hmi + where ms = expectJust "prune" (lookupUFM ms_map modl) ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ] - is_stable m = m `elem` stable_obj || m `elem` stable_bco + is_stable m = m `elem` stable_obj || m `elem` stable_bco -- ----------------------------------------------------------------------------- - --- Return (names of) all those in modsDone who are part of a cycle --- as defined by theGraph. +-- +-- | Return (names of) all those in modsDone who are part of a cycle as defined +-- by theGraph. findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module] findPartiallyCompletedCycles modsDone theGraph = chew theGraph @@ -478,22 +464,21 @@ findPartiallyCompletedCycles modsDone theGraph -- --------------------------------------------------------------------------- --- Unloading - +-- +-- | Unloading unload :: HscEnv -> [Linkable] -> IO () -unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' +unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' = case ghcLink (hsc_dflags hsc_env) of #ifdef GHCI - LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables + LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables #else - LinkInMemory -> panic "unload: no interpreter" + LinkInMemory -> panic "unload: no interpreter" -- urgh. avoid warnings: hsc_env stable_linkables #endif - _other -> return () + _other -> return () -- ----------------------------------------------------------------------------- - {- | Stability tells us which modules definitely do not need to be recompiled. @@ -514,25 +499,25 @@ unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' stable m = stableObject m || stableBCO m stableObject m = - all stableObject (imports m) - && old linkable does not exist, or is == on-disk .o - && date(on-disk .o) > date(.hs) + all stableObject (imports m) + && old linkable does not exist, or is == on-disk .o + && date(on-disk .o) > date(.hs) stableBCO m = - all stable (imports m) - && date(BCO) > date(.hs) + all stable (imports m) + && date(BCO) > date(.hs) @ These properties embody the following ideas: - if a module is stable, then: - - if it has been compiled in a previous pass (present in HPT) - then it does not need to be compiled or re-linked. + - if it has been compiled in a previous pass (present in HPT) + then it does not need to be compiled or re-linked. - if it has not been compiled in a previous pass, - then we only need to read its .hi file from disk and - link it to produce a 'ModDetails'. + then we only need to read its .hi file from disk and + link it to produce a 'ModDetails'. - if a modules is not stable, we will definitely be at least re-linking, and possibly re-compiling it during the 'upsweep'. @@ -542,13 +527,12 @@ unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' - Note that objects are only considered stable if they only depend on other objects. We can't link object code against byte code. -} - checkStability - :: HomePackageTable -- HPT from last compilation - -> [SCC ModSummary] -- current module graph (cyclic) - -> [ModuleName] -- all home modules - -> ([ModuleName], -- stableObject - [ModuleName]) -- stableBCO + :: HomePackageTable -- HPT from last compilation + -> [SCC ModSummary] -- current module graph (cyclic) + -> [ModuleName] -- all home modules + -> ([ModuleName], -- stableObject + [ModuleName]) -- stableBCO checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs where @@ -557,65 +541,66 @@ checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs | stableBCOs = (stable_obj, scc_mods ++ stable_bco) | otherwise = (stable_obj, stable_bco) where - scc = flattenSCC scc0 - scc_mods = map ms_mod_name scc - home_module m = m `elem` all_home_mods && m `notElem` scc_mods + scc = flattenSCC scc0 + scc_mods = map ms_mod_name scc + home_module m = m `elem` all_home_mods && m `notElem` scc_mods scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc)) - -- all imports outside the current SCC, but in the home pkg - - stable_obj_imps = map (`elem` stable_obj) scc_allimps - stable_bco_imps = map (`elem` stable_bco) scc_allimps - - stableObjects = - and stable_obj_imps - && all object_ok scc - - stableBCOs = - and (zipWith (||) stable_obj_imps stable_bco_imps) - && all bco_ok scc - - object_ok ms - | Just t <- ms_obj_date ms = t >= ms_hs_date ms - && same_as_prev t - | otherwise = False - where - same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of - Just hmi | Just l <- hm_linkable hmi - -> isObjectLinkable l && t == linkableTime l - _other -> True - -- why '>=' rather than '>' above? If the filesystem stores - -- times to the nearset second, we may occasionally find that - -- the object & source have the same modification time, - -- especially if the source was automatically generated - -- and compiled. Using >= is slightly unsafe, but it matches - -- make's behaviour. + -- all imports outside the current SCC, but in the home pkg + + stable_obj_imps = map (`elem` stable_obj) scc_allimps + stable_bco_imps = map (`elem` stable_bco) scc_allimps + + stableObjects = + and stable_obj_imps + && all object_ok scc + + stableBCOs = + and (zipWith (||) stable_obj_imps stable_bco_imps) + && all bco_ok scc + + object_ok ms + | dopt Opt_ForceRecomp (ms_hspp_opts ms) = False + | Just t <- ms_obj_date ms = t >= ms_hs_date ms + && same_as_prev t + | otherwise = False + where + same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of + Just hmi | Just l <- hm_linkable hmi + -> isObjectLinkable l && t == linkableTime l + _other -> True + -- why '>=' rather than '>' above? If the filesystem stores + -- times to the nearset second, we may occasionally find that + -- the object & source have the same modification time, + -- especially if the source was automatically generated + -- and compiled. Using >= is slightly unsafe, but it matches + -- make's behaviour. -- -- But see #5527, where someone ran into this and it caused -- a problem. - bco_ok ms - = case lookupUFM hpt (ms_mod_name ms) of - Just hmi | Just l <- hm_linkable hmi -> - not (isObjectLinkable l) && - linkableTime l >= ms_hs_date ms - _other -> False + bco_ok ms + | dopt Opt_ForceRecomp (ms_hspp_opts ms) = False + | otherwise = case lookupUFM hpt (ms_mod_name ms) of + Just hmi | Just l <- hm_linkable hmi -> + not (isObjectLinkable l) && + linkableTime l >= ms_hs_date ms + _other -> False -- ----------------------------------------------------------------------------- - +-- -- | The upsweep -- -- This is where we compile each module in the module graph, in a pass -- from the bottom to the top of the graph. -- -- There better had not be any cyclic groups here -- we check for them. - upsweep :: GhcMonad m - => HomePackageTable -- ^ HPT from last time round (pruned) + => HomePackageTable -- ^ HPT from last time round (pruned) -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability) -> (HscEnv -> IO ()) -- ^ How to clean up unwanted tmp files - -> [SCC ModSummary] -- ^ Mods to do (the worklist) + -> [SCC ModSummary] -- ^ Mods to do (the worklist) -> m (SuccessFlag, [ModSummary]) -- ^ Returns: @@ -642,8 +627,8 @@ upsweep old_hpt stable_mods cleanup sccs = do upsweep' old_hpt done (AcyclicSCC mod:mods) mod_index nmods = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ - -- show (map (moduleUserString.moduleName.mi_module.hm_iface) - -- (moduleEnvElts (hsc_HPT hsc_env))) + -- show (map (moduleUserString.moduleName.mi_module.hm_iface) + -- (moduleEnvElts (hsc_HPT hsc_env))) let logger _mod = defaultWarnErrLogger hsc_env <- getSession @@ -662,21 +647,21 @@ upsweep old_hpt stable_mods cleanup sccs = do case mb_mod_info of Nothing -> return (Failed, done) Just mod_info -> do - let this_mod = ms_mod_name mod - - -- Add new info to hsc_env - hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info - hsc_env1 = hsc_env { hsc_HPT = hpt1 } - - -- Space-saving: delete the old HPT entry - -- for mod BUT if mod is a hs-boot - -- node, don't delete it. For the - -- interface, the HPT entry is probaby for the - -- main Haskell source file. Deleting it - -- would force the real module to be recompiled + let this_mod = ms_mod_name mod + + -- Add new info to hsc_env + hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info + hsc_env1 = hsc_env { hsc_HPT = hpt1 } + + -- Space-saving: delete the old HPT entry + -- for mod BUT if mod is a hs-boot + -- node, don't delete it. For the + -- interface, the HPT entry is probaby for the + -- main Haskell source file. Deleting it + -- would force the real module to be recompiled -- every time. - old_hpt1 | isBootSummary mod = old_hpt - | otherwise = delFromUFM old_hpt this_mod + old_hpt1 | isBootSummary mod = old_hpt + | otherwise = delFromUFM old_hpt this_mod done' = mod:done @@ -685,30 +670,29 @@ upsweep old_hpt stable_mods cleanup sccs = do hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done' setSession hsc_env2 - upsweep' old_hpt1 done' mods (mod_index+1) nmods + upsweep' old_hpt1 done' mods (mod_index+1) nmods -- | Compile a single module. Always produce a Linkable for it if -- successful. If no compilation happened, return the old Linkable. upsweep_mod :: HscEnv -> HomePackageTable - -> ([ModuleName],[ModuleName]) + -> ([ModuleName],[ModuleName]) -> ModSummary -> Int -- index of module -> Int -- total number of modules -> IO HomeModInfo - upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods = let - this_mod_name = ms_mod_name summary - this_mod = ms_mod summary - mb_obj_date = ms_obj_date summary - obj_fn = ml_obj_file (ms_location summary) - hs_date = ms_hs_date summary + this_mod_name = ms_mod_name summary + this_mod = ms_mod summary + mb_obj_date = ms_obj_date summary + obj_fn = ml_obj_file (ms_location summary) + hs_date = ms_hs_date summary - is_stable_obj = this_mod_name `elem` stable_obj - is_stable_bco = this_mod_name `elem` stable_bco + is_stable_obj = this_mod_name `elem` stable_obj + is_stable_bco = this_mod_name `elem` stable_bco - old_hmi = lookupUFM old_hpt this_mod_name + old_hmi = lookupUFM old_hpt this_mod_name -- We're using the dflags for this module now, obtained by -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas. @@ -729,23 +713,23 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods -- store the corrected hscTarget into the summary summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } } - -- The old interface is ok if - -- a) we're compiling a source file, and the old HPT - -- entry is for a source file - -- b) we're compiling a hs-boot file - -- Case (b) allows an hs-boot file to get the interface of its - -- real source file on the second iteration of the compilation - -- manager, but that does no harm. Otherwise the hs-boot file - -- will always be recompiled + -- The old interface is ok if + -- a) we're compiling a source file, and the old HPT + -- entry is for a source file + -- b) we're compiling a hs-boot file + -- Case (b) allows an hs-boot file to get the interface of its + -- real source file on the second iteration of the compilation + -- manager, but that does no harm. Otherwise the hs-boot file + -- will always be recompiled mb_old_iface - = case old_hmi of - Nothing -> Nothing - Just hm_info | isBootSummary summary -> Just iface - | not (mi_boot iface) -> Just iface - | otherwise -> Nothing - where - iface = hm_iface hm_info + = case old_hmi of + Nothing -> Nothing + Just hm_info | isBootSummary summary -> Just iface + | not (mi_boot iface) -> Just iface + | otherwise -> Nothing + where + iface = hm_iface hm_info compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo compile_it mb_linkable src_modified = @@ -850,13 +834,12 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable retainInTopLevelEnvs keep_these hpt = listToUFM [ (mod, expectJust "retain" mb_mod_info) - | mod <- keep_these - , let mb_mod_info = lookupUFM hpt mod - , isJust mb_mod_info ] + | mod <- keep_these + , let mb_mod_info = lookupUFM hpt mod + , isJust mb_mod_info ] -- --------------------------------------------------------------------------- -- Typecheck module loops - {- See bug #930. This code fixes a long-standing bug in --make. The problem is that when compiling the modules *inside* a loop, a data @@ -884,7 +867,6 @@ re-typecheck. Following this fix, GHC can compile itself with --make -O2. -} - reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv reTypecheckLoop hsc_env ms graph | not (isBootSummary ms) && @@ -924,17 +906,15 @@ reachableBackwards mod summaries root = expectJust "reachableBackwards" (lookup_node HsBootFile mod) -- --------------------------------------------------------------------------- --- Topological sort of the module graph - -type SummaryNode = (ModSummary, Int, [Int]) - +-- +-- | Topological sort of the module graph topSortModuleGraph - :: Bool + :: Bool -- ^ Drop hi-boot nodes? (see below) - -> [ModSummary] - -> Maybe ModuleName + -> [ModSummary] + -> Maybe ModuleName -- ^ Root module name. If @Nothing@, use the full graph. - -> [SCC ModSummary] + -> [SCC ModSummary] -- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes -- The resulting list of strongly-connected-components is in topologically -- sorted order, starting with the module(s) at the bottom of the @@ -943,12 +923,12 @@ topSortModuleGraph -- -- Drop hi-boot nodes (first boolean arg)? -- --- - @False@: treat the hi-boot summaries as nodes of the graph, --- so the graph must be acyclic +-- - @False@: treat the hi-boot summaries as nodes of the graph, +-- so the graph must be acyclic -- --- - @True@: eliminate the hi-boot nodes, and instead pretend --- the a source-import of Foo is an import of Foo --- The resulting graph has no hi-boot nodes, but can be cyclic +-- - @True@: eliminate the hi-boot nodes, and instead pretend +-- the a source-import of Foo is an import of Foo +-- The resulting graph has no hi-boot nodes, but can be cyclic topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph @@ -966,6 +946,8 @@ topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod | otherwise = ghcError (ProgramError "module does not exist") in graphFromEdgedVertices (seq root (reachableG graph root)) +type SummaryNode = (ModSummary, Int, [Int]) + summaryNodeKey :: SummaryNode -> Int summaryNodeKey (_, k, _) = k @@ -1022,14 +1004,14 @@ moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, l type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are -type NodeMap a = Map.Map NodeKey a -- keyed by (mod, src_file_type) pairs +type NodeMap a = Map.Map NodeKey a -- keyed by (mod, src_file_type) pairs msKey :: ModSummary -> NodeKey msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot) mkNodeMap :: [ModSummary] -> NodeMap ModSummary mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries] - + nodeMapElts :: NodeMap a -> [a] nodeMapElts = Map.elems @@ -1039,25 +1021,27 @@ nodeMapElts = Map.elems -- were necessary, then the edge would be part of a cycle. warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m () warnUnnecessarySourceImports sccs = do - logWarnings (listToBag (concatMap (check.flattenSCC) sccs)) - where check ms = - let mods_in_this_cycle = map ms_mod_name ms in - [ warn i | m <- ms, i <- ms_home_srcimps m, - unLoc i `notElem` mods_in_this_cycle ] - - warn :: Located ModuleName -> WarnMsg - warn (L loc mod) = - mkPlainErrMsg loc - (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ") - <+> quotes (ppr mod)) + dflags <- getDynFlags + logWarnings (listToBag (concatMap (check dflags . flattenSCC) sccs)) + where check dflags ms = + let mods_in_this_cycle = map ms_mod_name ms in + [ warn dflags i | m <- ms, i <- ms_home_srcimps m, + unLoc i `notElem` mods_in_this_cycle ] + + warn :: DynFlags -> Located ModuleName -> WarnMsg + warn dflags (L loc mod) = + mkPlainErrMsg dflags loc + (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ") + <+> quotes (ppr mod)) ----------------------------------------------------------------------------- --- Downsweep (dependency analysis) - +-- +-- | Downsweep (dependency analysis) +-- -- Chase downwards from the specified root set, returning summaries -- for all home modules encountered. Only follow source-import -- links. - +-- -- We pass in the previous collection of summaries, which is used as a -- cache to avoid recalculating a module summary if the source is -- unchanged. @@ -1065,18 +1049,17 @@ warnUnnecessarySourceImports sccs = do -- The returned list of [ModSummary] nodes has one node for each home-package -- module, plus one for any hs-boot files. The imports of these nodes -- are all there, including the imports of non-home-package modules. - downsweep :: HscEnv - -> [ModSummary] -- Old summaries - -> [ModuleName] -- Ignore dependencies on these; treat - -- them as if they were package modules - -> Bool -- True <=> allow multiple targets to have - -- the same module name; this is - -- very useful for ghc -M - -> IO [ModSummary] - -- The elts of [ModSummary] all have distinct - -- (Modules, IsBoot) identifiers, unless the Bool is true - -- in which case there can be repeats + -> [ModSummary] -- Old summaries + -> [ModuleName] -- Ignore dependencies on these; treat + -- them as if they were package modules + -> Bool -- True <=> allow multiple targets to have + -- the same module name; this is + -- very useful for ghc -M + -> IO [ModSummary] + -- The elts of [ModSummary] all have distinct + -- (Modules, IsBoot) identifiers, unless the Bool is true + -- in which case there can be repeats downsweep hsc_env old_summaries excl_mods allow_dup_roots = do rootSummaries <- mapM getRootSummary roots @@ -1085,86 +1068,86 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots summs <- loop (concatMap msDeps rootSummaries) root_map return summs where - roots = hsc_targets hsc_env + dflags = hsc_dflags hsc_env + roots = hsc_targets hsc_env - old_summary_map :: NodeMap ModSummary - old_summary_map = mkNodeMap old_summaries + old_summary_map :: NodeMap ModSummary + old_summary_map = mkNodeMap old_summaries - getRootSummary :: Target -> IO ModSummary - getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf) - = do exists <- liftIO $ doesFileExist file - if exists - then summariseFile hsc_env old_summaries file mb_phase + getRootSummary :: Target -> IO ModSummary + getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf) + = do exists <- liftIO $ doesFileExist file + if exists + then summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf - else throwOneError $ mkPlainErrMsg noSrcSpan $ - text "can't find file:" <+> text file - getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf) - = do maybe_summary <- summariseModule hsc_env old_summary_map False - (L rootLoc modl) obj_allowed + else throwOneError $ mkPlainErrMsg dflags noSrcSpan $ + text "can't find file:" <+> text file + getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf) + = do maybe_summary <- summariseModule hsc_env old_summary_map False + (L rootLoc modl) obj_allowed maybe_buf excl_mods - case maybe_summary of - Nothing -> packageModErr modl - Just s -> return s - - rootLoc = mkGeneralSrcSpan (fsLit "<command line>") - - -- In a root module, the filename is allowed to diverge from the module - -- name, so we have to check that there aren't multiple root files - -- defining the same module (otherwise the duplicates will be silently - -- ignored, leading to confusing behaviour). - checkDuplicates :: NodeMap [ModSummary] -> IO () - checkDuplicates root_map - | allow_dup_roots = return () - | null dup_roots = return () - | otherwise = liftIO $ multiRootsErr (head dup_roots) - where - dup_roots :: [[ModSummary]] -- Each at least of length 2 - dup_roots = filterOut isSingleton (nodeMapElts root_map) - - loop :: [(Located ModuleName,IsBootInterface)] - -- Work list: process these modules - -> NodeMap [ModSummary] - -- Visited set; the range is a list because - -- the roots can have the same module names - -- if allow_dup_roots is True - -> IO [ModSummary] - -- The result includes the worklist, except - -- for those mentioned in the visited set - loop [] done = return (concat (nodeMapElts done)) - loop ((wanted_mod, is_boot) : ss) done - | Just summs <- Map.lookup key done - = if isSingleton summs then - loop ss done - else - do { multiRootsErr summs; return [] } - | otherwise + case maybe_summary of + Nothing -> packageModErr dflags modl + Just s -> return s + + rootLoc = mkGeneralSrcSpan (fsLit "<command line>") + + -- In a root module, the filename is allowed to diverge from the module + -- name, so we have to check that there aren't multiple root files + -- defining the same module (otherwise the duplicates will be silently + -- ignored, leading to confusing behaviour). + checkDuplicates :: NodeMap [ModSummary] -> IO () + checkDuplicates root_map + | allow_dup_roots = return () + | null dup_roots = return () + | otherwise = liftIO $ multiRootsErr dflags (head dup_roots) + where + dup_roots :: [[ModSummary]] -- Each at least of length 2 + dup_roots = filterOut isSingleton (nodeMapElts root_map) + + loop :: [(Located ModuleName,IsBootInterface)] + -- Work list: process these modules + -> NodeMap [ModSummary] + -- Visited set; the range is a list because + -- the roots can have the same module names + -- if allow_dup_roots is True + -> IO [ModSummary] + -- The result includes the worklist, except + -- for those mentioned in the visited set + loop [] done = return (concat (nodeMapElts done)) + loop ((wanted_mod, is_boot) : ss) done + | Just summs <- Map.lookup key done + = if isSingleton summs then + loop ss done + else + do { multiRootsErr dflags summs; return [] } + | otherwise = do mb_s <- summariseModule hsc_env old_summary_map is_boot wanted_mod True Nothing excl_mods case mb_s of Nothing -> loop ss done Just s -> loop (msDeps s ++ ss) (Map.insert key [s] done) - where - key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile) + where + key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile) --- XXX Does the (++) here need to be flipped? mkRootMap :: [ModSummary] -> NodeMap [ModSummary] mkRootMap summaries = Map.insertListWith (flip (++)) [ (msKey s, [s]) | s <- summaries ] Map.empty -msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)] --- (msDeps s) returns the dependencies of the ModSummary s. +-- | Returns the dependencies of the ModSummary s. -- A wrinkle is that for a {-# SOURCE #-} import we return --- *both* the hs-boot file --- *and* the source file +-- *both* the hs-boot file +-- *and* the source file -- as "dependencies". That ensures that the list of all relevant -- modules always contains B.hs if it contains B.hs-boot. -- Remember, this pass isn't doing the topological sort. It's -- just gathering the list of all relevant ModSummaries +msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)] msDeps s = concat [ [(m,True), (m,False)] | m <- ms_home_srcimps s ] - ++ [ (m,False) | m <- ms_home_imps s ] + ++ [ (m,False) | m <- ms_home_imps s ] home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName] home_imps imps = [ ideclName i | L _ i <- imps, isLocal (ideclPkgQual i) ] @@ -1187,107 +1170,106 @@ ms_home_imps = home_imps . ms_imps -- We have two types of summarisation: -- -- * Summarise a file. This is used for the root module(s) passed to --- cmLoadModules. The file is read, and used to determine the root --- module name. The module name may differ from the filename. +-- cmLoadModules. The file is read, and used to determine the root +-- module name. The module name may differ from the filename. -- -- * Summarise a module. We are given a module name, and must provide --- a summary. The finder is used to locate the file in which the module --- resides. +-- a summary. The finder is used to locate the file in which the module +-- resides. summariseFile - :: HscEnv - -> [ModSummary] -- old summaries - -> FilePath -- source file name - -> Maybe Phase -- start phase + :: HscEnv + -> [ModSummary] -- old summaries + -> FilePath -- source file name + -> Maybe Phase -- start phase -> Bool -- object code allowed? - -> Maybe (StringBuffer,UTCTime) - -> IO ModSummary + -> Maybe (StringBuffer,UTCTime) + -> IO ModSummary summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf - -- we can use a cached summary if one is available and the - -- source file hasn't changed, But we have to look up the summary - -- by source file, rather than module name as we do in summarise. + -- we can use a cached summary if one is available and the + -- source file hasn't changed, But we have to look up the summary + -- by source file, rather than module name as we do in summarise. | Just old_summary <- findSummaryBySourceFile old_summaries file = do - let location = ms_location old_summary - - -- return the cached summary if the source didn't change - src_timestamp <- case maybe_buf of - Just (_,t) -> return t - Nothing -> liftIO $ getModificationUTCTime file - -- The file exists; we checked in getRootSummary above. - -- If it gets removed subsequently, then this - -- getModificationUTCTime may fail, but that's the right - -- behaviour. - - if ms_hs_date old_summary == src_timestamp - then do -- update the object-file timestamp - obj_timestamp <- + let location = ms_location old_summary + + src_timestamp <- get_src_timestamp + -- The file exists; we checked in getRootSummary above. + -- If it gets removed subsequently, then this + -- getModificationUTCTime may fail, but that's the right + -- behaviour. + + -- return the cached summary if the source didn't change + if ms_hs_date old_summary == src_timestamp + then do -- update the object-file timestamp + obj_timestamp <- if isObjectTarget (hscTarget (hsc_dflags hsc_env)) || obj_allowed -- bug #1205 then liftIO $ getObjTimestamp location False else return Nothing - return old_summary{ ms_obj_date = obj_timestamp } - else - new_summary + return old_summary{ ms_obj_date = obj_timestamp } + else + new_summary src_timestamp | otherwise - = new_summary + = do src_timestamp <- get_src_timestamp + new_summary src_timestamp where - new_summary = do - let dflags = hsc_dflags hsc_env + get_src_timestamp = case maybe_buf of + Just (_,t) -> return t + Nothing -> liftIO $ getModificationUTCTime file + -- getMofificationUTCTime may fail + + new_summary src_timestamp = do + let dflags = hsc_dflags hsc_env - (dflags', hspp_fn, buf) - <- preprocessFile hsc_env file mb_phase maybe_buf + (dflags', hspp_fn, buf) + <- preprocessFile hsc_env file mb_phase maybe_buf (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file - -- Make a ModLocation for this file - location <- liftIO $ mkHomeModLocation dflags mod_name file - - -- Tell the Finder cache where it is, so that subsequent calls - -- to findModule will find it, even if it's not on any search path - mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location + -- Make a ModLocation for this file + location <- liftIO $ mkHomeModLocation dflags mod_name file - src_timestamp <- case maybe_buf of - Just (_,t) -> return t - Nothing -> liftIO $ getModificationUTCTime file - -- getMofificationTime may fail + -- Tell the Finder cache where it is, so that subsequent calls + -- to findModule will find it, even if it's not on any search path + mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location -- when the user asks to load a source file by name, we only -- use an object file if -fobject-code is on. See #1205. - obj_timestamp <- + obj_timestamp <- if isObjectTarget (hscTarget (hsc_dflags hsc_env)) || obj_allowed -- bug #1205 then liftIO $ modificationTimeIfExists (ml_obj_file location) else return Nothing return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile, - ms_location = location, + ms_location = location, ms_hspp_file = hspp_fn, ms_hspp_opts = dflags', - ms_hspp_buf = Just buf, + ms_hspp_buf = Just buf, ms_srcimps = srcimps, ms_textual_imps = the_imps, - ms_hs_date = src_timestamp, - ms_obj_date = obj_timestamp }) + ms_hs_date = src_timestamp, + ms_obj_date = obj_timestamp }) findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary findSummaryBySourceFile summaries file = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms], - expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of - [] -> Nothing - (x:_) -> Just x + expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of + [] -> Nothing + (x:_) -> Just x -- Summarise a module, and pick up source and timestamp. summariseModule - :: HscEnv - -> NodeMap ModSummary -- Map of old summaries - -> IsBootInterface -- True <=> a {-# SOURCE #-} import - -> Located ModuleName -- Imported module to be summarised + :: HscEnv + -> NodeMap ModSummary -- Map of old summaries + -> IsBootInterface -- True <=> a {-# SOURCE #-} import + -> Located ModuleName -- Imported module to be summarised -> Bool -- object code allowed? - -> Maybe (StringBuffer, UTCTime) - -> [ModuleName] -- Modules to exclude - -> IO (Maybe ModSummary) -- Its new summary + -> Maybe (StringBuffer, UTCTime) + -> [ModuleName] -- Modules to exclude + -> IO (Maybe ModSummary) -- Its new summary summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) obj_allowed maybe_buf excl_mods @@ -1295,22 +1277,22 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) = return Nothing | Just old_summary <- Map.lookup (wanted_mod, hsc_src) old_summary_map - = do -- Find its new timestamp; all the - -- ModSummaries in the old map have valid ml_hs_files - let location = ms_location old_summary - src_fn = expectJust "summariseModule" (ml_hs_file location) - - -- check the modification time on the source file, and - -- return the cached summary if it hasn't changed. If the - -- file has disappeared, we need to call the Finder again. - case maybe_buf of - Just (_,t) -> check_timestamp old_summary location src_fn t - Nothing -> do - m <- tryIO (getModificationUTCTime src_fn) - case m of - Right t -> check_timestamp old_summary location src_fn t - Left e | isDoesNotExistError e -> find_it - | otherwise -> ioError e + = do -- Find its new timestamp; all the + -- ModSummaries in the old map have valid ml_hs_files + let location = ms_location old_summary + src_fn = expectJust "summariseModule" (ml_hs_file location) + + -- check the modification time on the source file, and + -- return the cached summary if it hasn't changed. If the + -- file has disappeared, we need to call the Finder again. + case maybe_buf of + Just (_,t) -> check_timestamp old_summary location src_fn t + Nothing -> do + m <- tryIO (getModificationUTCTime src_fn) + case m of + Right t -> check_timestamp old_summary location src_fn t + Left e | isDoesNotExistError e -> find_it + | otherwise -> ioError e | otherwise = find_it where @@ -1319,89 +1301,89 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) hsc_src = if is_boot then HsBootFile else HsSrcFile check_timestamp old_summary location src_fn src_timestamp - | ms_hs_date old_summary == src_timestamp = do - -- update the object-file timestamp + | ms_hs_date old_summary == src_timestamp = do + -- update the object-file timestamp obj_timestamp <- if isObjectTarget (hscTarget (hsc_dflags hsc_env)) || obj_allowed -- bug #1205 then getObjTimestamp location is_boot else return Nothing - return (Just old_summary{ ms_obj_date = obj_timestamp }) - | otherwise = - -- source changed: re-summarise. - new_summary location (ms_mod old_summary) src_fn src_timestamp + return (Just old_summary{ ms_obj_date = obj_timestamp }) + | otherwise = + -- source changed: re-summarise. + new_summary location (ms_mod old_summary) src_fn src_timestamp find_it = do - -- Don't use the Finder's cache this time. If the module was - -- previously a package module, it may have now appeared on the - -- search path, so we want to consider it to be a home module. If - -- the module was previously a home module, it may have moved. - uncacheModule hsc_env wanted_mod - found <- findImportedModule hsc_env wanted_mod Nothing - case found of - Found location mod - | isJust (ml_hs_file location) -> - -- Home package - just_found location mod - | otherwise -> - -- Drop external-pkg - ASSERT(modulePackageId mod /= thisPackage dflags) - return Nothing - - err -> noModError dflags loc wanted_mod err - -- Not found + -- Don't use the Finder's cache this time. If the module was + -- previously a package module, it may have now appeared on the + -- search path, so we want to consider it to be a home module. If + -- the module was previously a home module, it may have moved. + uncacheModule hsc_env wanted_mod + found <- findImportedModule hsc_env wanted_mod Nothing + case found of + Found location mod + | isJust (ml_hs_file location) -> + -- Home package + just_found location mod + | otherwise -> + -- Drop external-pkg + ASSERT(modulePackageId mod /= thisPackage dflags) + return Nothing + + err -> noModError dflags loc wanted_mod err + -- Not found just_found location mod = do - -- Adjust location to point to the hs-boot source file, - -- hi file, object file, when is_boot says so - let location' | is_boot = addBootSuffixLocn location - | otherwise = location - src_fn = expectJust "summarise2" (ml_hs_file location') + -- Adjust location to point to the hs-boot source file, + -- hi file, object file, when is_boot says so + let location' | is_boot = addBootSuffixLocn location + | otherwise = location + src_fn = expectJust "summarise2" (ml_hs_file location') - -- Check that it exists - -- It might have been deleted since the Finder last found it - maybe_t <- modificationTimeIfExists src_fn - case maybe_t of - Nothing -> noHsFileErr loc src_fn - Just t -> new_summary location' mod src_fn t + -- Check that it exists + -- It might have been deleted since the Finder last found it + maybe_t <- modificationTimeIfExists src_fn + case maybe_t of + Nothing -> noHsFileErr dflags loc src_fn + Just t -> new_summary location' mod src_fn t new_summary location mod src_fn src_timestamp = do - -- Preprocess the source file and get its imports - -- The dflags' contains the OPTIONS pragmas - (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf + -- Preprocess the source file and get its imports + -- The dflags' contains the OPTIONS pragmas + (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn - when (mod_name /= wanted_mod) $ - throwOneError $ mkPlainErrMsg mod_loc $ - text "File name does not match module name:" - $$ text "Saw:" <+> quotes (ppr mod_name) + when (mod_name /= wanted_mod) $ + throwOneError $ mkPlainErrMsg dflags' mod_loc $ + text "File name does not match module name:" + $$ text "Saw:" <+> quotes (ppr mod_name) $$ text "Expected:" <+> quotes (ppr wanted_mod) - -- Find the object timestamp, and return the summary - obj_timestamp <- + -- Find the object timestamp, and return the summary + obj_timestamp <- if isObjectTarget (hscTarget (hsc_dflags hsc_env)) || obj_allowed -- bug #1205 then getObjTimestamp location is_boot else return Nothing - return (Just (ModSummary { ms_mod = mod, - ms_hsc_src = hsc_src, - ms_location = location, - ms_hspp_file = hspp_fn, + return (Just (ModSummary { ms_mod = mod, + ms_hsc_src = hsc_src, + ms_location = location, + ms_hspp_file = hspp_fn, ms_hspp_opts = dflags', - ms_hspp_buf = Just buf, - ms_srcimps = srcimps, - ms_textual_imps = the_imps, - ms_hs_date = src_timestamp, - ms_obj_date = obj_timestamp })) + ms_hspp_buf = Just buf, + ms_srcimps = srcimps, + ms_textual_imps = the_imps, + ms_hs_date = src_timestamp, + ms_obj_date = obj_timestamp })) getObjTimestamp :: ModLocation -> Bool -> IO (Maybe UTCTime) getObjTimestamp location is_boot = if is_boot then return Nothing - else modificationTimeIfExists (ml_obj_file location) + else modificationTimeIfExists (ml_obj_file location) preprocessFile :: HscEnv @@ -1411,59 +1393,59 @@ preprocessFile :: HscEnv -> IO (DynFlags, FilePath, StringBuffer) preprocessFile hsc_env src_fn mb_phase Nothing = do - (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase) - buf <- hGetStringBuffer hspp_fn - return (dflags', hspp_fn, buf) + (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase) + buf <- hGetStringBuffer hspp_fn + return (dflags', hspp_fn, buf) preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) = do let dflags = hsc_dflags hsc_env - let local_opts = getOptions dflags buf src_fn + let local_opts = getOptions dflags buf src_fn - (dflags', leftovers, warns) + (dflags', leftovers, warns) <- parseDynamicFilePragma dflags local_opts - checkProcessArgsResult leftovers + checkProcessArgsResult dflags leftovers handleFlagWarnings dflags' warns - let needs_preprocessing - | Just (Unlit _) <- mb_phase = True - | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True - -- note: local_opts is only required if there's no Unlit phase - | xopt Opt_Cpp dflags' = True - | dopt Opt_Pp dflags' = True - | otherwise = False + let needs_preprocessing + | Just (Unlit _) <- mb_phase = True + | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True + -- note: local_opts is only required if there's no Unlit phase + | xopt Opt_Cpp dflags' = True + | dopt Opt_Pp dflags' = True + | otherwise = False - when needs_preprocessing $ - ghcError (ProgramError "buffer needs preprocesing; interactive check disabled") + when needs_preprocessing $ + ghcError (ProgramError "buffer needs preprocesing; interactive check disabled") - return (dflags', src_fn, buf) + return (dflags', src_fn, buf) ----------------------------------------------------------------------------- --- Error messages +-- Error messages ----------------------------------------------------------------------------- noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab -- ToDo: we don't have a proper line number for this error noModError dflags loc wanted_mod err - = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err - -noHsFileErr :: SrcSpan -> String -> IO a -noHsFileErr loc path - = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path + = throwOneError $ mkPlainErrMsg dflags loc $ cannotFindModule dflags wanted_mod err + +noHsFileErr :: DynFlags -> SrcSpan -> String -> IO a +noHsFileErr dflags loc path + = throwOneError $ mkPlainErrMsg dflags loc $ text "Can't find" <+> text path -packageModErr :: ModuleName -> IO a -packageModErr mod - = throwOneError $ mkPlainErrMsg noSrcSpan $ - text "module" <+> quotes (ppr mod) <+> text "is a package module" - -multiRootsErr :: [ModSummary] -> IO () -multiRootsErr [] = panic "multiRootsErr" -multiRootsErr summs@(summ1:_) - = throwOneError $ mkPlainErrMsg noSrcSpan $ - text "module" <+> quotes (ppr mod) <+> - text "is defined in multiple files:" <+> - sep (map text files) +packageModErr :: DynFlags -> ModuleName -> IO a +packageModErr dflags mod + = throwOneError $ mkPlainErrMsg dflags noSrcSpan $ + text "module" <+> quotes (ppr mod) <+> text "is a package module" + +multiRootsErr :: DynFlags -> [ModSummary] -> IO () +multiRootsErr _ [] = panic "multiRootsErr" +multiRootsErr dflags summs@(summ1:_) + = throwOneError $ mkPlainErrMsg dflags noSrcSpan $ + text "module" <+> quotes (ppr mod) <+> + text "is defined in multiple files:" <+> + sep (map text files) where mod = ms_mod summ1 files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs @@ -1498,5 +1480,5 @@ cyclicModuleErr mss ppr_ms :: ModSummary -> SDoc ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+> - (parens (text (msHsFilePath ms))) + (parens (text (msHsFilePath ms))) diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index 6322024c9e..91902d6b77 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -64,7 +64,7 @@ getImports :: DynFlags getImports dflags buf filename source_filename = do let loc = mkRealSrcLoc (mkFastString filename) 1 1 case unP parseHeader (mkPState dflags buf loc) of - PFailed span err -> parseError span err + PFailed span err -> parseError dflags span err POk pst rdr_module -> do let _ms@(_warns, errs) = getMessages pst -- don't log warnings: they'll be reported when we parse the file @@ -123,8 +123,8 @@ mkPrelImports this_mod loc implicit_prelude import_decls ideclAs = Nothing, ideclHiding = Nothing } -parseError :: SrcSpan -> MsgDoc -> IO a -parseError span err = throwOneError $ mkPlainErrMsg span err +parseError :: DynFlags -> SrcSpan -> MsgDoc -> IO a +parseError dflags span err = throwOneError $ mkPlainErrMsg dflags span err -------------------------------------------------------------- -- Get options @@ -141,7 +141,8 @@ getOptionsFromFile dflags filename (openBinaryFile filename ReadMode) (hClose) (\handle -> do - opts <- fmap getOptions' $ lazyGetToks dflags' filename handle + opts <- fmap (getOptions' dflags) + (lazyGetToks dflags' filename handle) seqList opts $ return opts) where -- We don't need to get haddock doc tokens when we're just -- getting the options from pragmas, and lazily lexing them @@ -160,12 +161,12 @@ blockSize = 1024 lazyGetToks :: DynFlags -> FilePath -> Handle -> IO [Located Token] lazyGetToks dflags filename handle = do buf <- hGetStringBufferBlock handle blockSize - unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False + unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False blockSize where loc = mkRealSrcLoc (mkFastString filename) 1 1 - lazyLexBuf :: Handle -> PState -> Bool -> IO [Located Token] - lazyLexBuf handle state eof = do + lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token] + lazyLexBuf handle state eof size = do case unP (lexer return) state of POk state' t -> do -- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ()) @@ -173,22 +174,26 @@ lazyGetToks dflags filename handle = do -- if this token reached the end of the buffer, and we haven't -- necessarily read up to the end of the file, then the token might -- be truncated, so read some more of the file and lex it again. - then getMore handle state + then getMore handle state size else case t of L _ ITeof -> return [t] - _other -> do rest <- lazyLexBuf handle state' eof + _other -> do rest <- lazyLexBuf handle state' eof size return (t : rest) - _ | not eof -> getMore handle state + _ | not eof -> getMore handle state size | otherwise -> return [L (RealSrcSpan (last_loc state)) ITeof] -- parser assumes an ITeof sentinel at the end - getMore :: Handle -> PState -> IO [Located Token] - getMore handle state = do + getMore :: Handle -> PState -> Int -> IO [Located Token] + getMore handle state size = do -- pprTrace "getMore" (text (show (buffer state))) (return ()) - nextbuf <- hGetStringBufferBlock handle blockSize - if (len nextbuf == 0) then lazyLexBuf handle state True else do + let new_size = size * 2 + -- double the buffer size each time we read a new block. This + -- counteracts the quadratic slowdown we otherwise get for very + -- large module names (#5981) + nextbuf <- hGetStringBufferBlock handle new_size + if (len nextbuf == 0) then lazyLexBuf handle state True new_size else do newbuf <- appendStringBuffers (buffer state) nextbuf - unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False + unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False new_size getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token] @@ -210,15 +215,16 @@ getOptions :: DynFlags -> FilePath -- ^ Source filename. Used for location info. -> [Located String] -- ^ Parsed options. getOptions dflags buf filename - = getOptions' (getToks dflags filename buf) + = getOptions' dflags (getToks dflags filename buf) -- The token parser is written manually because Happy can't -- return a partial result when it encounters a lexer error. -- We want to extract options before the buffer is passed through -- CPP, so we can't use the same trick as 'getImports'. -getOptions' :: [Located Token] -- Input buffer +getOptions' :: DynFlags + -> [Located Token] -- Input buffer -> [Located String] -- Options. -getOptions' toks +getOptions' dflags toks = parseToks toks where getToken (L _loc tok) = tok @@ -248,14 +254,14 @@ getOptions' toks = parseLanguage xs parseToks _ = [] parseLanguage (L loc (ITconid fs):rest) - = checkExtension (L loc fs) : + = checkExtension dflags (L loc fs) : case rest of (L _loc ITcomma):more -> parseLanguage more (L _loc ITclose_prag):more -> parseToks more - (L loc _):_ -> languagePragParseError loc + (L loc _):_ -> languagePragParseError dflags loc [] -> panic "getOptions'.parseLanguage(1) went past eof token" parseLanguage (tok:_) - = languagePragParseError (getLoc tok) + = languagePragParseError dflags (getLoc tok) parseLanguage [] = panic "getOptions'.parseLanguage(2) went past eof token" @@ -265,51 +271,51 @@ getOptions' toks -- -- Throws a 'SourceError' if the input list is non-empty claiming that the -- input flags are unknown. -checkProcessArgsResult :: MonadIO m => [Located String] -> m () -checkProcessArgsResult flags +checkProcessArgsResult :: MonadIO m => DynFlags -> [Located String] -> m () +checkProcessArgsResult dflags flags = when (notNull flags) $ liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags where mkMsg (L loc flag) - = mkPlainErrMsg loc $ + = mkPlainErrMsg dflags loc $ (text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag) ----------------------------------------------------------------------------- -checkExtension :: Located FastString -> Located String -checkExtension (L l ext) +checkExtension :: DynFlags -> Located FastString -> Located String +checkExtension dflags (L l ext) -- Checks if a given extension is valid, and if so returns -- its corresponding flag. Otherwise it throws an exception. = let ext' = unpackFS ext in if ext' `elem` supportedLanguagesAndExtensions then L l ("-X"++ext') - else unsupportedExtnError l ext' + else unsupportedExtnError dflags l ext' -languagePragParseError :: SrcSpan -> a -languagePragParseError loc = +languagePragParseError :: DynFlags -> SrcSpan -> a +languagePragParseError dflags loc = throw $ mkSrcErr $ unitBag $ - (mkPlainErrMsg loc $ + (mkPlainErrMsg dflags loc $ vcat [ text "Cannot parse LANGUAGE pragma" , text "Expecting comma-separated list of language options," , text "each starting with a capital letter" , nest 2 (text "E.g. {-# LANGUAGE RecordPuns, Generics #-}") ]) -unsupportedExtnError :: SrcSpan -> String -> a -unsupportedExtnError loc unsup = +unsupportedExtnError :: DynFlags -> SrcSpan -> String -> a +unsupportedExtnError dflags loc unsup = throw $ mkSrcErr $ unitBag $ - mkPlainErrMsg loc $ + mkPlainErrMsg dflags loc $ text "Unsupported extension: " <> text unsup $$ if null suggestions then empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions) where suggestions = fuzzyMatch unsup supportedLanguagesAndExtensions -optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages -optionsErrorMsgs unhandled_flags flags_lines _filename +optionsErrorMsgs :: DynFlags -> [String] -> [Located String] -> FilePath -> Messages +optionsErrorMsgs dflags unhandled_flags flags_lines _filename = (emptyBag, listToBag (map mkMsg unhandled_flags_lines)) where unhandled_flags_lines = [ L l f | f <- unhandled_flags, L l f' <- flags_lines, f == f' ] mkMsg (L flagSpan flag) = - ErrUtils.mkPlainErrMsg flagSpan $ + ErrUtils.mkPlainErrMsg dflags flagSpan $ text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index bdb26dfb38..000c9ead31 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -62,6 +62,7 @@ module HscMain , hscTcRnGetInfo , hscCheckSafe #ifdef GHCI + , hscIsGHCiMonad , hscGetModuleInterface , hscRnImportDecls , hscTcRnLookupRdrName @@ -151,6 +152,7 @@ import qualified Stream import Stream (Stream) import CLabel +import Util import Data.List import Control.Monad @@ -176,19 +178,17 @@ newHscEnv dflags = do fc_var <- newIORef emptyUFM mlc_var <- newIORef emptyModuleEnv optFuel <- initOptFuelState - safe_var <- newIORef True return HscEnv { hsc_dflags = dflags, hsc_targets = [], hsc_mod_graph = [], - hsc_IC = emptyInteractiveContext, + hsc_IC = emptyInteractiveContext dflags, hsc_HPT = emptyHomePackageTable, hsc_EPS = eps_var, hsc_NC = nc_var, hsc_FC = fc_var, hsc_MLC = mlc_var, hsc_OptFuel = optFuel, - hsc_type_env_var = Nothing, - hsc_safeInf = safe_var } + hsc_type_env_var = Nothing } knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta, @@ -222,6 +222,13 @@ runHsc hsc_env (Hsc hsc) = do printOrThrowWarnings (hsc_dflags hsc_env) w return a +-- A variant of runHsc that switches in the DynFlags from the +-- InteractiveContext before running the Hsc computation. +-- +runInteractiveHsc :: HscEnv -> Hsc a -> IO a +runInteractiveHsc hsc_env = + runHsc (hsc_env { hsc_dflags = ic_dflags (hsc_IC hsc_env) }) + getWarnings :: Hsc WarningMessages getWarnings = Hsc $ \_ w -> return (w, w) @@ -292,31 +299,41 @@ ioMsgMaybe' ioA = do #ifdef GHCI hscTcRnLookupRdrName :: HscEnv -> RdrName -> IO [Name] -hscTcRnLookupRdrName hsc_env rdr_name = - runHsc hsc_env $ ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name +hscTcRnLookupRdrName hsc_env0 rdr_name = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name #endif hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing) -hscTcRcLookupName hsc_env name = - runHsc hsc_env $ ioMsgMaybe' $ tcRnLookupName hsc_env name +hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe' $ tcRnLookupName hsc_env name -- ignore errors: the only error we're likely to get is -- "name not found", and the Maybe in the return type -- is used to indicate that. hscTcRnGetInfo :: HscEnv -> Name -> IO (Maybe (TyThing, Fixity, [ClsInst])) -hscTcRnGetInfo hsc_env name = - runHsc hsc_env $ ioMsgMaybe' $ tcRnGetInfo hsc_env name +hscTcRnGetInfo hsc_env0 name = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe' $ tcRnGetInfo hsc_env name #ifdef GHCI +hscIsGHCiMonad :: HscEnv -> String -> IO Name +hscIsGHCiMonad hsc_env name = + let icntxt = hsc_IC hsc_env + in runHsc hsc_env $ ioMsgMaybe $ isGHCiMonad hsc_env icntxt name + hscGetModuleInterface :: HscEnv -> Module -> IO ModIface -hscGetModuleInterface hsc_env mod = - runHsc hsc_env $ ioMsgMaybe $ getModuleInterface hsc_env mod +hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe $ getModuleInterface hsc_env mod -- ----------------------------------------------------------------------------- -- | Rename some import declarations hscRnImportDecls :: HscEnv -> [LImportDecl RdrName] -> IO GlobalRdrEnv -hscRnImportDecls hsc_env import_decls = - runHsc hsc_env $ ioMsgMaybe $ tcRnImportDecls hsc_env import_decls +hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe $ tcRnImportDecls hsc_env import_decls #endif -- ----------------------------------------------------------------------------- @@ -347,7 +364,7 @@ hscParse' mod_summary = do case unP parseModule (mkPState dflags buf loc) of PFailed span err -> - liftIO $ throwOneError (mkPlainErrMsg span err) + liftIO $ throwOneError (mkPlainErrMsg dflags span err) POk pst rdr_module -> do logWarningsReportErrors (getMessages pst) @@ -398,10 +415,7 @@ type RenamedStuff = hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule -> IO (TcGblEnv, RenamedStuff) hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do - tc_result <- {-# SCC "Typecheck-Rename" #-} - ioMsgMaybe $ - tcRnModule hsc_env (ms_hsc_src mod_summary) - True rdr_module + tc_result <- tcRnModule' hsc_env mod_summary True rdr_module -- This 'do' is in the Maybe monad! let rn_info = do decl <- tcg_rn_decls tc_result @@ -412,6 +426,34 @@ hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do return (tc_result, rn_info) +-- wrapper around tcRnModule to handle safe haskell extras +tcRnModule' :: HscEnv -> ModSummary -> Bool -> HsParsedModule + -> Hsc TcGblEnv +tcRnModule' hsc_env sum save_rn_syntax mod = do + tcg_res <- {-# SCC "Typecheck-Rename" #-} + ioMsgMaybe $ + tcRnModule hsc_env (ms_hsc_src sum) save_rn_syntax mod + + tcSafeOK <- liftIO $ readIORef (tcg_safeInfer tcg_res) + dflags <- getDynFlags + + -- end of the Safe Haskell line, how to respond to user? + if not (safeHaskellOn dflags) || (safeInferOn dflags && not tcSafeOK) + -- if safe haskell off or safe infer failed, wipe trust + then wipeTrust tcg_res emptyBag + + -- module safe, throw warning if needed + else do + tcg_res' <- hscCheckSafeImports tcg_res + safe <- liftIO $ readIORef (tcg_safeInfer tcg_res') + when (safe && wopt Opt_WarnSafe dflags) + (logWarnings $ unitBag $ + mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $ errSafe tcg_res') + return tcg_res' + where + pprMod t = ppr $ moduleName $ tcg_mod t + errSafe t = quotes (pprMod t) <+> text "has been inferred as safe!" + -- | Convert a typechecked module to Core hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts hscDesugar hsc_env mod_summary tc_result = @@ -436,9 +478,11 @@ hscDesugar' mod_location tc_result = do -- we should use fingerprint versions instead. makeSimpleIface :: HscEnv -> Maybe ModIface -> TcGblEnv -> ModDetails -> IO (ModIface,Bool) -makeSimpleIface hsc_env maybe_old_iface tc_result details = - runHsc hsc_env $ ioMsgMaybe $ - mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result +makeSimpleIface hsc_env maybe_old_iface tc_result details = runHsc hsc_env $ do + safe_mode <- hscGetSafeMode tc_result + ioMsgMaybe $ do + mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) safe_mode + details tc_result -- | Make a 'ModDetails' from the results of typechecking. Used when -- typechecking only, as opposed to full compilation. @@ -538,12 +582,12 @@ data HsCompiler a = HsCompiler { -> Hsc a, -- | Code generation for normal modules. - hscGenOutput :: ModGuts -> ModSummary -> Maybe Fingerprint + hscGenOutput :: ModGuts -> ModSummary -> Maybe Fingerprint -> Hsc a } genericHscCompile :: HsCompiler a - -> (HscEnv -> Maybe (Int,Int) -> RecompReason -> ModSummary -> IO ()) + -> (HscEnv -> Maybe (Int,Int) -> RecompileRequired -> ModSummary -> IO ()) -> HscEnv -> ModSummary -> SourceModified -> Maybe ModIface -> Maybe (Int, Int) -> IO a @@ -561,7 +605,7 @@ genericHscCompile compiler hscMessage hsc_env let mb_old_hash = fmap mi_iface_hash mb_checked_iface let skip iface = do - hscMessage hsc_env mb_mod_index RecompNotRequired mod_summary + hscMessage hsc_env mb_mod_index UpToDate mod_summary runHsc hsc_env $ hscNoRecomp compiler iface compile reason = do @@ -584,12 +628,12 @@ genericHscCompile compiler hscMessage hsc_env -- doing for us in one-shot mode. case mb_checked_iface of - Just iface | not recomp_reqd -> + Just iface | not (recompileRequired recomp_reqd) -> if mi_used_th iface && not stable - then compile RecompForcedByTH + then compile (RecompBecause "TH") else skip iface _otherwise -> - compile RecompRequired + compile recomp_reqd hscCheckRecompBackend :: HsCompiler a -> TcGblEnv -> Compiler a hscCheckRecompBackend compiler tc_result hsc_env mod_summary @@ -602,7 +646,7 @@ hscCheckRecompBackend compiler tc_result hsc_env mod_summary let mb_old_hash = fmap mi_iface_hash mb_checked_iface case mb_checked_iface of - Just iface | not recomp_reqd + Just iface | not (recompileRequired recomp_reqd) -> runHsc hsc_env $ hscNoRecomp compiler iface{ mi_globals = Just (tcg_rdr_env tc_result) } @@ -793,32 +837,33 @@ genModDetails old_iface -- Progress displayers. -------------------------------------------------------------- -data RecompReason = RecompNotRequired | RecompRequired | RecompForcedByTH - deriving Eq - -oneShotMsg :: HscEnv -> Maybe (Int,Int) -> RecompReason -> ModSummary -> IO () +oneShotMsg :: HscEnv -> Maybe (Int,Int) -> RecompileRequired -> ModSummary + -> IO () oneShotMsg hsc_env _mb_mod_index recomp _mod_summary = case recomp of - RecompNotRequired -> + UpToDate -> compilationProgressMsg (hsc_dflags hsc_env) $ "compilation IS NOT required" _other -> return () -batchMsg :: HscEnv -> Maybe (Int,Int) -> RecompReason -> ModSummary -> IO () +batchMsg :: HscEnv -> Maybe (Int,Int) -> RecompileRequired -> ModSummary + -> IO () batchMsg hsc_env mb_mod_index recomp mod_summary = case recomp of - RecompRequired -> showMsg "Compiling " - RecompNotRequired - | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " + MustCompile -> showMsg "Compiling " "" + UpToDate + | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " "" | otherwise -> return () - RecompForcedByTH -> showMsg "Compiling [TH] " + RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]") where - showMsg msg = - compilationProgressMsg (hsc_dflags hsc_env) $ + dflags = hsc_dflags hsc_env + showMsg msg reason = + compilationProgressMsg dflags $ (showModuleIndex mb_mod_index ++ - msg ++ showModMsg (hscTarget (hsc_dflags hsc_env)) - (recomp == RecompRequired) mod_summary) + msg ++ showModMsg dflags (hscTarget dflags) + (recompileRequired recomp) mod_summary) + ++ reason -------------------------------------------------------------- -- FrontEnds @@ -828,30 +873,8 @@ hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv hscFileFrontEnd mod_summary = do hpm <- hscParse' mod_summary hsc_env <- getHscEnv - dflags <- getDynFlags - tcg_env <- - {-# SCC "Typecheck-Rename" #-} - ioMsgMaybe $ - tcRnModule hsc_env (ms_hsc_src mod_summary) False hpm - tcSafeOK <- liftIO $ readIORef (tcg_safeInfer tcg_env) - - -- end of the Safe Haskell line, how to respond to user? - if not (safeHaskellOn dflags) || (safeInferOn dflags && not tcSafeOK) - - -- if safe haskell off or safe infer failed, wipe trust - then wipeTrust tcg_env emptyBag - - -- module safe, throw warning if needed - else do - tcg_env' <- hscCheckSafeImports tcg_env - safe <- liftIO $ hscGetSafeInf hsc_env - when (safe && wopt Opt_WarnSafe dflags) - (logWarnings $ unitBag $ - mkPlainWarnMsg (warnSafeOnLoc dflags) $ errSafe tcg_env') - return tcg_env' - where - pprMod t = ppr $ moduleName $ tcg_mod t - errSafe t = quotes (pprMod t) <+> text "has been infered as safe!" + tcg_env <- tcRnModule' hsc_env mod_summary False hpm + return tcg_env -------------------------------------------------------------- -- Safe Haskell @@ -901,22 +924,22 @@ hscCheckSafeImports tcg_env = do case safeLanguageOn dflags of True -> do -- we nuke user written RULES in -XSafe - logWarnings $ warns (tcg_rules tcg_env') + logWarnings $ warns dflags (tcg_rules tcg_env') return tcg_env' { tcg_rules = [] } False -- user defined RULES, so not safe or already unsafe | safeInferOn dflags && not (null $ tcg_rules tcg_env') || safeHaskell dflags == Sf_None - -> wipeTrust tcg_env' $ warns (tcg_rules tcg_env') + -> wipeTrust tcg_env' $ warns dflags (tcg_rules tcg_env') - -- trustworthy OR safe infered with no RULES + -- trustworthy OR safe inferred with no RULES | otherwise -> return tcg_env' where - warns rules = listToBag $ map warnRules rules - warnRules (L loc (HsRule n _ _ _ _ _ _)) = - mkPlainWarnMsg loc $ + warns dflags rules = listToBag $ map (warnRules dflags) rules + warnRules dflags (L loc (HsRule n _ _ _ _ _ _)) = + mkPlainWarnMsg dflags loc $ text "Rule \"" <> ftext n <> text "\" ignored" $+$ text "User defined rules are disabled under Safe Haskell" @@ -983,7 +1006,7 @@ checkSafeImports dflags tcg_env cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal cond' v1@(m1,_,l1,s1) (_,_,_,s2) | s1 /= s2 - = throwErrors $ unitBag $ mkPlainErrMsg l1 + = throwErrors $ unitBag $ mkPlainErrMsg dflags l1 (text "Module" <+> ppr m1 <+> (text $ "is imported both as a safe and unsafe import!")) | otherwise @@ -1022,16 +1045,16 @@ hscCheckSafe' dflags m l = do iface <- lookup' m case iface of -- can't load iface to check trust! - Nothing -> throwErrors $ unitBag $ mkPlainErrMsg l - $ text "Can't load the interface file for" <+> ppr m <> - text ", to check that it can be safely imported" + Nothing -> throwErrors $ unitBag $ mkPlainErrMsg dflags l + $ text "Can't load the interface file for" <+> ppr m + <> text ", to check that it can be safely imported" -- got iface, check trust Just iface' -> do let trust = getSafeMode $ mi_trust iface' trust_own_pkg = mi_trust_pkg iface' -- check module is trusted - safeM = trust `elem` [Sf_SafeInfered, Sf_Safe, Sf_Trustworthy] + safeM = trust `elem` [Sf_SafeInferred, Sf_Safe, Sf_Trustworthy] -- check package is trusted safeP = packageTrusted trust trust_own_pkg m -- pkg trust reqs @@ -1044,13 +1067,16 @@ hscCheckSafe' dflags m l = do return (trust == Sf_Trustworthy, pkgRs) where - pkgTrustErr = mkSrcErr $ unitBag $ mkPlainErrMsg l $ ppr m - <+> text "can't be safely imported!" <+> text "The package (" - <> ppr (modulePackageId m) - <> text ") the module resides in isn't trusted." - modTrustErr = unitBag $ mkPlainErrMsg l $ ppr m - <+> text "can't be safely imported!" - <+> text "The module itself isn't safe." + pkgTrustErr = mkSrcErr $ unitBag $ mkPlainErrMsg dflags l $ + sep [ ppr (moduleName m) + <> text ": Can't be safely imported!" + , text "The package (" <> ppr (modulePackageId m) + <> text ") the module resides in isn't trusted." + ] + modTrustErr = unitBag $ mkPlainErrMsg dflags l $ + sep [ ppr (moduleName m) + <> text ": Can't be safely imported!" + , text "The module itself isn't safe." ] -- | Check the package a module resides in is trusted. Safe compiled -- modules are trusted without requiring that their package is trusted. For @@ -1058,9 +1084,9 @@ hscCheckSafe' dflags m l = do -- otherwise we check the package trust flag. packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool packageTrusted _ _ _ - | not (packageTrustOn dflags) = True - packageTrusted Sf_Safe False _ = True - packageTrusted Sf_SafeInfered False _ = True + | not (packageTrustOn dflags) = True + packageTrusted Sf_Safe False _ = True + packageTrusted Sf_SafeInferred False _ = True packageTrusted _ _ m | isHomePkg m = True | otherwise = trusted $ getPackageDetails (pkgState dflags) @@ -1103,33 +1129,44 @@ checkPkgTrust dflags pkgs = | trusted $ getPackageDetails (pkgState dflags) pkg = Nothing | otherwise - = Just $ mkPlainErrMsg noSrcSpan - $ text "The package (" <> ppr pkg <> text ") is required" - <> text " to be trusted but it isn't!" + = Just $ mkPlainErrMsg dflags noSrcSpan + $ text "The package (" <> ppr pkg <> text ") is required" <> + text " to be trusted but it isn't!" -- | Set module to unsafe and wipe trust information. -- --- Make sure to call this method to set a module to infered unsafe, +-- Make sure to call this method to set a module to inferred unsafe, -- it should be a central and single failure method. wipeTrust :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv wipeTrust tcg_env whyUnsafe = do - env <- getHscEnv dflags <- getDynFlags when (wopt Opt_WarnUnsafe dflags) (logWarnings $ unitBag $ - mkPlainWarnMsg (warnUnsafeOnLoc dflags) whyUnsafe') + mkPlainWarnMsg dflags (warnUnsafeOnLoc dflags) (whyUnsafe' dflags)) - liftIO $ hscSetSafeInf env False + liftIO $ writeIORef (tcg_safeInfer tcg_env) False return $ tcg_env { tcg_imports = wiped_trust } where - wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = [] } - pprMod = ppr $ moduleName $ tcg_mod tcg_env - whyUnsafe' = vcat [ quotes pprMod <+> text "has been infered as unsafe!" - , text "Reason:" - , nest 4 (vcat $ pprErrMsgBag whyUnsafe) ] - + wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = [] } + pprMod = ppr $ moduleName $ tcg_mod tcg_env + whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!" + , text "Reason:" + , nest 4 $ (vcat $ badFlags df) $+$ + (vcat $ pprErrMsgBagWithLoc whyUnsafe) + ] + badFlags df = concat $ map (badFlag df) unsafeFlags + badFlag df (str,loc,on,_) + | on df = [mkLocMessage SevOutput (loc df) $ + text str <+> text "is not allowed in Safe Haskell"] + | otherwise = [] + +-- | Figure out the final correct safe haskell mode +hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode +hscGetSafeMode tcg_env = do + dflags <- getDynFlags + liftIO $ finalSafeMode dflags tcg_env -------------------------------------------------------------- -- Simplifiers @@ -1152,12 +1189,13 @@ hscSimpleIface :: TcGblEnv -> Maybe Fingerprint -> Hsc (ModIface, Bool, ModDetails) hscSimpleIface tc_result mb_old_iface = do - hsc_env <- getHscEnv - details <- liftIO $ mkBootModDetailsTc hsc_env tc_result + hsc_env <- getHscEnv + details <- liftIO $ mkBootModDetailsTc hsc_env tc_result + safe_mode <- hscGetSafeMode tc_result (new_iface, no_change) <- {-# SCC "MkFinalIface" #-} ioMsgMaybe $ - mkIfaceTc hsc_env mb_old_iface details tc_result + mkIfaceTc hsc_env mb_old_iface safe_mode details tc_result -- And the answer is ... liftIO $ dumpIfaceStats hsc_env return (new_iface, no_change, details) @@ -1226,13 +1264,13 @@ hscGenHardCode cgguts mod_summary = do -- PREPARE FOR CODE GENERATION -- Do saturation and convert to A-normal form prepd_binds <- {-# SCC "CorePrep" #-} - corePrepPgm dflags core_binds data_tycons ; + corePrepPgm dflags hsc_env core_binds data_tycons ; ----------------- Convert to STG ------------------ (stg_binds, cost_centre_info) <- {-# SCC "CoreToStg" #-} myCoreToStg dflags this_mod prepd_binds - let prof_init = profilingInitCode platform this_mod cost_centre_info + let prof_init = profilingInitCode this_mod cost_centre_info foreign_stubs = foreign_stubs0 `appendStubC` prof_init ------------------ Code generation ------------------ @@ -1253,7 +1291,7 @@ hscGenHardCode cgguts mod_summary = do cmmToRawCmm platform cmms let dump a = do dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm" - (pprPlatform platform a) + (ppr a) return a rawcmms1 = Stream.mapM dump rawcmms0 @@ -1286,8 +1324,9 @@ hscInteractive (iface, details, cgguts) mod_summary = do ------------------- -- PREPARE FOR CODE GENERATION -- Do saturation and convert to A-normal form + hsc_env <- getHscEnv prepd_binds <- {-# SCC "CorePrep" #-} - liftIO $ corePrepPgm dflags core_binds data_tycons ; + liftIO $ corePrepPgm dflags hsc_env core_binds data_tycons ----------------- Generate byte code ------------------ comp_bc <- liftIO $ byteCodeGen dflags this_mod prepd_binds data_tycons mod_breaks @@ -1330,7 +1369,6 @@ tryNewCodeGen :: HscEnv -> Module -> [TyCon] tryNewCodeGen hsc_env this_mod data_tycons cost_centre_info stg_binds hpc_info = do let dflags = hsc_dflags hsc_env - platform = targetPlatform dflags let cmm_stream :: Stream IO New.CmmGroup () cmm_stream = {-# SCC "StgCmm" #-} @@ -1343,8 +1381,7 @@ tryNewCodeGen hsc_env this_mod data_tycons -- to proc-point splitting). let dump1 a = do dumpIfSet_dyn dflags Opt_D_dump_cmmz - "Cmm produced by new codegen" - (pprPlatform platform a) + "Cmm produced by new codegen" (ppr a) return a ppr_stream1 = Stream.mapM dump1 cmm_stream @@ -1363,8 +1400,7 @@ tryNewCodeGen hsc_env this_mod data_tycons Stream.yield (cmmOfZgraph (srtToData topSRT)) let - dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" $ - pprPlatform platform a + dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" $ ppr a return a ppr_stream2 = Stream.mapM dump2 pipeline_stream @@ -1408,7 +1444,7 @@ IO monad as explained in Note [Interactively-bound Ids in GHCi] in TcRnDriver -- -- We return Nothing to indicate an empty statement (or comment only), not a -- parse error. -hscStmt :: HscEnv -> String -> IO (Maybe ([Id], IO [HValue])) +hscStmt :: HscEnv -> String -> IO (Maybe ([Id], IO [HValue], FixityEnv)) hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1 -- | Compile a stmt all the way to an HValue, but don't run it @@ -1419,8 +1455,10 @@ hscStmtWithLocation :: HscEnv -> String -- ^ The statement -> String -- ^ The source -> Int -- ^ Starting line - -> IO (Maybe ([Id], IO [HValue])) -hscStmtWithLocation hsc_env stmt source linenumber = runHsc hsc_env $ do + -> IO (Maybe ([Id], IO [HValue], FixityEnv)) +hscStmtWithLocation hsc_env0 stmt source linenumber = + runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv maybe_stmt <- hscParseStmtWithLocation source linenumber stmt case maybe_stmt of Nothing -> return Nothing @@ -1434,7 +1472,7 @@ hscStmtWithLocation hsc_env stmt source linenumber = runHsc hsc_env $ do -- Rename and typecheck it -- Here we lift the stmt into the IO monad, see Note -- [Interactively-bound Ids in GHCi] in TcRnDriver - (ids, tc_expr) <- ioMsgMaybe $ tcRnStmt hsc_env icntxt parsed_stmt + (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env icntxt parsed_stmt -- Desugar it ds_expr <- ioMsgMaybe $ @@ -1446,7 +1484,7 @@ hscStmtWithLocation hsc_env stmt source linenumber = runHsc hsc_env $ do hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr let hval_io = unsafeCoerce# hval :: IO [HValue] - return $ Just (ids, hval_io) + return $ Just (ids, hval_io, fix_env) -- | Compile a decls hscDecls :: HscEnv @@ -1460,7 +1498,9 @@ hscDeclsWithLocation :: HscEnv -> String -- ^ The source -> Int -- ^ Starting line -> IO ([TyThing], InteractiveContext) -hscDeclsWithLocation hsc_env str source linenumber = runHsc hsc_env $ do +hscDeclsWithLocation hsc_env0 str source linenumber = + runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv L _ (HsModule{ hsmodDecls = decls }) <- hscParseThingWithLocation source linenumber parseModule str @@ -1478,8 +1518,8 @@ hscDeclsWithLocation hsc_env str source linenumber = runHsc hsc_env $ do {- Desugar it -} -- We use a basically null location for iNTERACTIVE let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing, - ml_hi_file = undefined, - ml_obj_file = undefined} + ml_hi_file = panic "hsDeclsWithLocation:ml_hi_file", + ml_obj_file = panic "hsDeclsWithLocation:ml_hi_file"} ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv {- Simplify -} @@ -1498,7 +1538,7 @@ hscDeclsWithLocation hsc_env str source linenumber = runHsc hsc_env $ do {- Prepare For Code Generation -} -- Do saturation and convert to A-normal form prepd_binds <- {-# SCC "CorePrep" #-} - liftIO $ corePrepPgm dflags core_binds data_tycons + liftIO $ corePrepPgm dflags hsc_env core_binds data_tycons {- Generate byte code -} cbc <- liftIO $ byteCodeGen dflags this_mod @@ -1531,26 +1571,27 @@ hscDeclsWithLocation hsc_env str source linenumber = runHsc hsc_env $ do return (tythings, ictxt) hscImport :: HscEnv -> String -> IO (ImportDecl RdrName) -hscImport hsc_env str = runHsc hsc_env $ do +hscImport hsc_env str = runInteractiveHsc hsc_env $ do (L _ (HsModule{hsmodImports=is})) <- hscParseThing parseModule str case is of [i] -> return (unLoc i) _ -> liftIO $ throwOneError $ - mkPlainErrMsg noSrcSpan $ + mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan $ ptext (sLit "parse error in import declaration") -- | Typecheck an expression (but don't run it) hscTcExpr :: HscEnv -> String -- ^ The expression -> IO Type -hscTcExpr hsc_env expr = runHsc hsc_env $ do +hscTcExpr hsc_env0 expr = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv maybe_stmt <- hscParseStmt expr case maybe_stmt of Just (L _ (ExprStmt expr _ _ _)) -> ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr _ -> - throwErrors $ unitBag $ mkPlainErrMsg noSrcSpan + throwErrors $ unitBag $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan (text "not an expression:" <+> quotes (text expr)) -- | Find the kind of a type @@ -1559,7 +1600,8 @@ hscKcType -> Bool -- ^ Normalise the type -> String -- ^ The type as a string -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind -hscKcType hsc_env normalise str = runHsc hsc_env $ do +hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv ty <- hscParseType str ioMsgMaybe $ tcRnType hsc_env (hsc_IC hsc_env) normalise ty @@ -1577,7 +1619,7 @@ hscParseType = hscParseThing parseType hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName) hscParseIdentifier hsc_env str = - runHsc hsc_env $ hscParseThing parseIdentifier str + runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str hscParseThing :: (Outputable thing) => Lexer.P thing -> String -> Hsc thing hscParseThing = hscParseThingWithLocation "<interactive>" 1 @@ -1594,7 +1636,7 @@ hscParseThingWithLocation source linenumber parser str case unP parser (mkPState dflags buf loc) of PFailed span err -> do - let msg = mkPlainErrMsg span err + let msg = mkPlainErrMsg dflags span err throwErrors $ unitBag msg POk pst thing -> do @@ -1602,21 +1644,23 @@ hscParseThingWithLocation source linenumber parser str liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing) return thing -hscCompileCore :: HscEnv -> Bool -> ModSummary -> CoreProgram -> IO () -hscCompileCore hsc_env simplify mod_summary binds = runHsc hsc_env $ do - guts <- maybe_simplify (mkModGuts (ms_mod mod_summary) binds) - (iface, changed, _details, cgguts) <- hscNormalIface guts Nothing - hscWriteIface iface changed mod_summary - _ <- hscGenHardCode cgguts mod_summary - return () +hscCompileCore :: HscEnv -> Bool -> SafeHaskellMode -> ModSummary + -> CoreProgram -> IO () +hscCompileCore hsc_env simplify safe_mode mod_summary binds + = runHsc hsc_env $ do + guts <- maybe_simplify (mkModGuts (ms_mod mod_summary) safe_mode binds) + (iface, changed, _details, cgguts) <- hscNormalIface guts Nothing + hscWriteIface iface changed mod_summary + _ <- hscGenHardCode cgguts mod_summary + return () where maybe_simplify mod_guts | simplify = hscSimplify' mod_guts | otherwise = return mod_guts -- Makes a "vanilla" ModGuts. -mkModGuts :: Module -> CoreProgram -> ModGuts -mkModGuts mod binds = +mkModGuts :: Module -> SafeHaskellMode -> CoreProgram -> ModGuts +mkModGuts mod safe binds = ModGuts { mg_module = mod, mg_boot = False, @@ -1641,6 +1685,7 @@ mkModGuts mod binds = mg_vect_info = noVectInfo, mg_inst_env = emptyInstEnv, mg_fam_inst_env = emptyFamInstEnv, + mg_safe_haskell = safe, mg_trust_pkg = False, mg_dependent_files = [] } @@ -1670,7 +1715,7 @@ hscCompileCoreExpr hsc_env srcspan ds_expr let tidy_expr = tidyExpr emptyTidyEnv simpl_expr {- Prepare for codegen -} - prepd_expr <- corePrepExpr dflags tidy_expr + prepd_expr <- corePrepExpr dflags hsc_env tidy_expr {- Lint if necessary -} -- ToDo: improve SrcLoc @@ -1702,7 +1747,7 @@ hscCompileCoreExpr hsc_env srcspan ds_expr dumpIfaceStats :: HscEnv -> IO () dumpIfaceStats hsc_env = do eps <- readIORef (hsc_EPS hsc_env) - dumpIfSet (dump_if_trace || dump_rn_stats) + dumpIfSet dflags (dump_if_trace || dump_rn_stats) "Interface statistics" (ifaceStats eps) where diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs new file mode 100644 index 0000000000..79eb8f54cb --- /dev/null +++ b/compiler/main/HscStats.hs @@ -0,0 +1,160 @@ +-- | +-- Statistics for per-module compilations +-- +-- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +-- +module HscStats ( ppSourceStats ) where + +import Bag +import HsSyn +import Outputable +import RdrName +import SrcLoc +import Util + +import Data.Char + +-- | Source Statistics +ppSourceStats :: Bool -> Located (HsModule RdrName) -> SDoc +ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) + = (if short then hcat else vcat) + (map pp_val + [("ExportAll ", export_all), -- 1 if no export list + ("ExportDecls ", export_ds), + ("ExportModules ", export_ms), + ("Imports ", imp_no), + (" ImpSafe ", imp_safe), + (" ImpQual ", imp_qual), + (" ImpAs ", imp_as), + (" ImpAll ", imp_all), + (" ImpPartial ", imp_partial), + (" ImpHiding ", imp_hiding), + ("FixityDecls ", fixity_sigs), + ("DefaultDecls ", default_ds), + ("TypeDecls ", type_ds), + ("DataDecls ", data_ds), + ("NewTypeDecls ", newt_ds), + ("TypeFamilyDecls ", type_fam_ds), + ("DataConstrs ", data_constrs), + ("DataDerivings ", data_derivs), + ("ClassDecls ", class_ds), + ("ClassMethods ", class_method_ds), + ("DefaultMethods ", default_method_ds), + ("InstDecls ", inst_ds), + ("InstMethods ", inst_method_ds), + ("InstType ", inst_type_ds), + ("InstData ", inst_data_ds), + ("TypeSigs ", bind_tys), + ("GenericSigs ", generic_sigs), + ("ValBinds ", val_bind_ds), + ("FunBinds ", fn_bind_ds), + ("InlineMeths ", method_inlines), + ("InlineBinds ", bind_inlines), + ("SpecialisedMeths ", method_specs), + ("SpecialisedBinds ", bind_specs) + ]) + where + decls = map unLoc ldecls + + pp_val (_, 0) = empty + pp_val (str, n) + | not short = hcat [text str, int n] + | otherwise = hcat [text (trim str), equals, int n, semi] + + trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls) + + (fixity_sigs, bind_tys, bind_specs, bind_inlines, generic_sigs) + = count_sigs [d | SigD d <- decls] + -- NB: this omits fixity decls on local bindings and + -- in class decls. ToDo + + tycl_decls = [d | TyClD d <- decls] + (class_ds, type_ds, data_ds, newt_ds, type_fam_ds) = + countTyClDecls tycl_decls + + inst_decls = [d | InstD d <- decls] + inst_ds = length inst_decls + default_ds = count (\ x -> case x of { DefD{} -> True; _ -> False}) decls + val_decls = [d | ValD d <- decls] + + real_exports = case exports of { Nothing -> []; Just es -> es } + n_exports = length real_exports + export_ms = count (\ e -> case unLoc e of { IEModuleContents{} -> True;_ -> False}) + real_exports + export_ds = n_exports - export_ms + export_all = case exports of { Nothing -> 1; _ -> 0 } + + (val_bind_ds, fn_bind_ds) + = foldr add2 (0,0) (map count_bind val_decls) + + (imp_no, imp_safe, imp_qual, imp_as, imp_all, imp_partial, imp_hiding) + = foldr add7 (0,0,0,0,0,0,0) (map import_info imports) + (data_constrs, data_derivs) + = foldr add2 (0,0) (map data_info tycl_decls) + (class_method_ds, default_method_ds) + = foldr add2 (0,0) (map class_info tycl_decls) + (inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds) + = foldr add5 (0,0,0,0,0) (map inst_info inst_decls) + + count_bind (PatBind { pat_lhs = L _ (VarPat _) }) = (1,0) + count_bind (PatBind {}) = (0,1) + count_bind (FunBind {}) = (0,1) + count_bind b = pprPanic "count_bind: Unhandled binder" (ppr b) + + count_sigs sigs = foldr add5 (0,0,0,0,0) (map sig_info sigs) + + sig_info (FixSig _) = (1,0,0,0,0) + sig_info (TypeSig _ _) = (0,1,0,0,0) + sig_info (SpecSig _ _ _) = (0,0,1,0,0) + sig_info (InlineSig _ _) = (0,0,0,1,0) + sig_info (GenericSig _ _) = (0,0,0,0,1) + sig_info _ = (0,0,0,0,0) + + import_info (L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual + , ideclAs = as, ideclHiding = spec })) + = add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec) + safe_info = qual_info + qual_info False = 0 + qual_info True = 1 + as_info Nothing = 0 + as_info (Just _) = 1 + spec_info Nothing = (0,0,0,0,1,0,0) + spec_info (Just (False, _)) = (0,0,0,0,0,1,0) + spec_info (Just (True, _)) = (0,0,0,0,0,0,1) + + data_info (TyDecl { tcdTyDefn = TyData {td_cons = cs, td_derivs = derivs}}) + = (length cs, case derivs of Nothing -> 0 + Just ds -> length ds) + data_info _ = (0,0) + + class_info decl@(ClassDecl {}) + = case count_sigs (map unLoc (tcdSigs decl)) of + (_,classops,_,_,_) -> + (classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl))))) + class_info _ = (0,0) + + inst_info (FamInstD { lid_inst = d }) + = case countATDecl d of + (tyd, dtd) -> (0,0,0,tyd,dtd) + inst_info (ClsInstD { cid_binds = inst_meths, cid_sigs = inst_sigs, cid_fam_insts = ats }) + = case count_sigs (map unLoc inst_sigs) of + (_,_,ss,is,_) -> + case foldr add2 (0, 0) (map (countATDecl . unLoc) ats) of + (tyDecl, dtDecl) -> + (addpr (foldr add2 (0,0) + (map (count_bind.unLoc) (bagToList inst_meths))), + ss, is, tyDecl, dtDecl) + where + countATDecl (FamInstDecl { fid_defn = TyData {} }) = (0, 1) + countATDecl (FamInstDecl { fid_defn = TySynonym {} }) = (1, 0) + + addpr :: (Int,Int) -> Int + add2 :: (Int,Int) -> (Int,Int) -> (Int, Int) + add5 :: (Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int) + add7 :: (Int,Int,Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int, Int, Int) + + addpr (x,y) = x+y + add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2) + add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5) + add7 (x1,x2,x3,x4,x5,x6,x7) (y1,y2,y3,y4,y5,y6,y7) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6,x7+y7) + diff --git a/compiler/main/HscStats.lhs b/compiler/main/HscStats.lhs index 168e49af4a..b5fe0fdf86 100644 --- a/compiler/main/HscStats.lhs +++ b/compiler/main/HscStats.lhs @@ -141,7 +141,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) spec_info (Just (False, _)) = (0,0,0,0,0,1,0) spec_info (Just (True, _)) = (0,0,0,0,0,0,1) - data_info (TyData {tcdCons = cs, tcdDerivs = derivs}) + data_info (TyDecl { tcdTyDefn = TyData {td_cons = cs, td_derivs = derivs}}) = (length cs, case derivs of Nothing -> 0 Just ds -> length ds) data_info _ = (0,0) @@ -152,9 +152,9 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) (classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl))))) class_info _ = (0,0) - inst_info (FamInstDecl d) = case countATDecl d of + inst_info (FamInstD d) = case countATDecl d of (tyd, dtd) -> (0,0,0,tyd,dtd) - inst_info (ClsInstDecl _ inst_meths inst_sigs ats) + inst_info (ClsInstD _ inst_meths inst_sigs ats) = case count_sigs (map unLoc inst_sigs) of (_,_,ss,is,_) -> case foldr add2 (0, 0) (map (countATDecl . unLoc) ats) of @@ -163,10 +163,8 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) (map (count_bind.unLoc) (bagToList inst_meths))), ss, is, tyDecl, dtDecl) where - countATDecl (TyData {}) = (0, 1) - countATDecl (TySynonym {}) = (1, 0) - countATDecl d = pprPanic "countATDecl: Unhandled decl" - (ppr d) + countATDecl (FamInstDecl { fid_defn = TyData {} }) = (0, 1) + countATDecl (FamInstDecl { fid_defn = TySynonym {} }) = (1, 0) addpr :: (Int,Int) -> Int add2 :: (Int,Int) -> (Int,Int) -> (Int, Int) diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 9840b407ce..156f081d3e 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -44,6 +44,7 @@ module HscTypes ( InteractiveContext(..), emptyInteractiveContext, icPrintUnqual, icInScopeTTs, icPlusGblRdrEnv, extendInteractiveContext, substInteractiveContext, + setInteractivePrintName, InteractiveImport(..), mkPrintUnqualified, pprModulePrefix, @@ -73,7 +74,7 @@ module HscTypes ( -- * Information on imports and exports WhetherHasOrphans, IsBootInterface, Usage(..), Dependencies(..), noDependencies, - NameCache(..), OrigNameCache, OrigIParamCache, + NameCache(..), OrigNameCache, IfaceExport, -- * Warnings @@ -95,7 +96,6 @@ module HscTypes ( noIfaceVectInfo, isNoIfaceVectInfo, -- * Safe Haskell information - hscGetSafeInf, hscSetSafeInf, IfaceTrustInfo, getSafeMode, setSafeMode, noIfaceTrustInfo, trustInfoToNum, numToTrustInfo, IsSafeImport, @@ -137,7 +137,7 @@ import Annotations import Class import TyCon import DataCon -import PrelNames ( gHC_PRIM ) +import PrelNames ( gHC_PRIM, ioTyConName, printName ) import Packages hiding ( Version(..) ) import DynFlags import DriverPhases @@ -163,7 +163,6 @@ import Util import Control.Monad ( mplus, guard, liftM, when ) import Data.Array ( Array, array ) import Data.IORef -import Data.Map ( Map ) import Data.Time import Data.Word import Data.Typeable ( Typeable ) @@ -182,8 +181,8 @@ mkSrcErr = SourceError srcErrorMessages :: SourceError -> ErrorMessages srcErrorMessages (SourceError msgs) = msgs -mkApiErr :: SDoc -> GhcApiError -mkApiErr = GhcApiError +mkApiErr :: DynFlags -> SDoc -> GhcApiError +mkApiErr dflags msg = GhcApiError (showSDoc dflags msg) throwOneError :: MonadIO m => ErrMsg -> m ab throwOneError err = liftIO $ throwIO $ mkSrcErr $ unitBag err @@ -222,11 +221,11 @@ handleSourceError handler act = gcatch act (\(e :: SourceError) -> handler e) -- | An error thrown if the GHC API is used in an incorrect fashion. -newtype GhcApiError = GhcApiError SDoc +newtype GhcApiError = GhcApiError String deriving Typeable instance Show GhcApiError where - show (GhcApiError msg) = showSDoc msg + show (GhcApiError msg) = msg instance Exception GhcApiError @@ -236,7 +235,7 @@ printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO () printOrThrowWarnings dflags warns | dopt Opt_WarnIsError dflags = when (not (isEmptyBag warns)) $ do - throwIO $ mkSrcErr $ warns `snocBag` warnIsErrorMsg + throwIO $ mkSrcErr $ warns `snocBag` warnIsErrorMsg dflags | otherwise = printBagOfErrors dflags warns @@ -245,7 +244,7 @@ handleFlagWarnings dflags warns = when (wopt Opt_WarnDeprecatedFlags dflags) $ do -- It would be nicer if warns :: [Located MsgDoc], but that -- has circular import problems. - let bag = listToBag [ mkPlainWarnMsg loc (text warn) + let bag = listToBag [ mkPlainWarnMsg dflags loc (text warn) | L loc warn <- warns ] printOrThrowWarnings dflags bag @@ -324,24 +323,12 @@ data HscEnv -- by limiting the number of transformations, -- we can use binary search to help find compiler bugs. - hsc_type_env_var :: Maybe (Module, IORef TypeEnv), + hsc_type_env_var :: Maybe (Module, IORef TypeEnv) -- ^ Used for one-shot compilation only, to initialise -- the 'IfGblEnv'. See 'TcRnTypes.tcg_type_env_var' for -- 'TcRunTypes.TcGblEnv' - - hsc_safeInf :: {-# UNPACK #-} !(IORef Bool) - -- ^ Have we infered the module being compiled as - -- being safe? } --- | Get if the current module is considered safe or not by inference. -hscGetSafeInf :: HscEnv -> IO Bool -hscGetSafeInf hsc_env = readIORef (hsc_safeInf hsc_env) - --- | Set if the current module is considered safe or not by inference. -hscSetSafeInf :: HscEnv -> Bool -> IO () -hscSetSafeInf hsc_env b = writeIORef (hsc_safeInf hsc_env) b - -- | Retrieve the ExternalPackageState cache. hscEPS :: HscEnv -> IO ExternalPackageState hscEPS hsc_env = readIORef (hsc_EPS hsc_env) @@ -842,6 +829,8 @@ data ModGuts mg_fam_inst_env :: FamInstEnv, -- ^ Type-family instance enviroment for /home-package/ modules -- (including this one); c.f. 'tcg_fam_inst_env' + mg_safe_haskell :: SafeHaskellMode, + -- ^ Safe Haskell mode mg_trust_pkg :: Bool, -- ^ Do we need to trust our own package for Safe Haskell? -- See Note [RnNames . Trust Own Package] @@ -917,6 +906,13 @@ appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code) -- context in which statements are executed in a GHC session. data InteractiveContext = InteractiveContext { + ic_dflags :: DynFlags, + -- ^ The 'DynFlags' used to evaluate interative expressions + -- and statements. + + ic_monad :: Name, + -- ^ The monad that GHCi is executing in + ic_imports :: [InteractiveImport], -- ^ The GHCi context is extended with these imports -- @@ -946,6 +942,13 @@ data InteractiveContext -- time we update the context, we just take the results -- from the instance code that already does that. + ic_fix_env :: FixityEnv, + -- ^ Fixities declared in let statements + + ic_int_print :: Name, + -- ^ The function that is used for printing results + -- of expressions in ghci and -e mode. + #ifdef GHCI ic_resume :: [Resume], -- ^ The stack of breakpoint contexts @@ -977,13 +980,19 @@ hscDeclsWithLocation) and save them in ic_sys_vars. -} -- | Constructs an empty InteractiveContext. -emptyInteractiveContext :: InteractiveContext -emptyInteractiveContext - = InteractiveContext { ic_imports = [], +emptyInteractiveContext :: DynFlags -> InteractiveContext +emptyInteractiveContext dflags + = InteractiveContext { ic_dflags = dflags, + -- IO monad by default + ic_monad = ioTyConName, + ic_imports = [], ic_rn_gbl_env = emptyGlobalRdrEnv, ic_tythings = [], ic_sys_vars = [], ic_instances = ([],[]), + ic_fix_env = emptyNameEnv, + -- System.IO.print by default + ic_int_print = printName, #ifdef GHCI ic_resume = [], #endif @@ -1018,6 +1027,9 @@ extendInteractiveContext ictxt new_tythings new_names = [ nameOccName (getName id) | AnId id <- new_tythings ] +setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext +setInteractivePrintName ic n = ic{ic_int_print = n} + -- ToDo: should not add Ids to the gbl env here -- | Add TyThings to the GlobalRdrEnv, earlier ones in the list shadowing @@ -1041,7 +1053,7 @@ data InteractiveImport -- ^ Bring the exports of a particular module -- (filtered by an import decl) into scope - | IIModule Module + | IIModule ModuleName -- ^ Bring into scope the entire top-level envt of -- of this module, including the things imported -- into it. @@ -1088,7 +1100,7 @@ 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 -\begin{code} + \begin{code} -- | Creates some functions that work out the best ways to format -- names for the user according to a set of heuristics mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified @@ -1760,17 +1772,12 @@ its binding site, we fix it up. data NameCache = NameCache { nsUniqs :: UniqSupply, -- ^ Supply of uniques - nsNames :: OrigNameCache, + nsNames :: OrigNameCache -- ^ Ensures that one original name gets one unique - nsIPs :: OrigIParamCache - -- ^ Ensures that one implicit parameter name gets one unique } -- | Per-module cache of original 'OccName's given 'Name's type OrigNameCache = ModuleEnv (OccEnv Name) - --- | Module-local cache of implicit parameter 'OccName's given 'Name's -type OrigIParamCache = Map FastString (IPName Name) \end{code} @@ -1867,9 +1874,9 @@ instance Outputable ModSummary where char '}' ] -showModMsg :: HscTarget -> Bool -> ModSummary -> String -showModMsg target recomp mod_summary - = showSDoc $ +showModMsg :: DynFlags -> HscTarget -> Bool -> ModSummary -> String +showModMsg dflags target recomp mod_summary + = showSDoc dflags $ hsep [text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' '), char '(', text (normalise $ msHsFilePath mod_summary) <> comma, case target of @@ -1880,7 +1887,7 @@ showModMsg target recomp mod_summary char ')'] where mod = moduleName (ms_mod mod_summary) - mod_str = showSDoc (ppr mod) ++ hscSourceString (ms_hsc_src mod_summary) + mod_str = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary) \end{code} %************************************************************************ @@ -2056,26 +2063,26 @@ noIfaceTrustInfo = setSafeMode Sf_None trustInfoToNum :: IfaceTrustInfo -> Word8 trustInfoToNum it = case getSafeMode it of - Sf_None -> 0 - Sf_Unsafe -> 1 - Sf_Trustworthy -> 2 - Sf_Safe -> 3 - Sf_SafeInfered -> 4 + Sf_None -> 0 + Sf_Unsafe -> 1 + Sf_Trustworthy -> 2 + Sf_Safe -> 3 + Sf_SafeInferred -> 4 numToTrustInfo :: Word8 -> IfaceTrustInfo numToTrustInfo 0 = setSafeMode Sf_None numToTrustInfo 1 = setSafeMode Sf_Unsafe numToTrustInfo 2 = setSafeMode Sf_Trustworthy numToTrustInfo 3 = setSafeMode Sf_Safe -numToTrustInfo 4 = setSafeMode Sf_SafeInfered +numToTrustInfo 4 = setSafeMode Sf_SafeInferred numToTrustInfo n = error $ "numToTrustInfo: bad input number! (" ++ show n ++ ")" instance Outputable IfaceTrustInfo where - ppr (TrustInfo Sf_None) = ptext $ sLit "none" - ppr (TrustInfo Sf_Unsafe) = ptext $ sLit "unsafe" - ppr (TrustInfo Sf_Trustworthy) = ptext $ sLit "trustworthy" - ppr (TrustInfo Sf_Safe) = ptext $ sLit "safe" - ppr (TrustInfo Sf_SafeInfered) = ptext $ sLit "safe-infered" + ppr (TrustInfo Sf_None) = ptext $ sLit "none" + ppr (TrustInfo Sf_Unsafe) = ptext $ sLit "unsafe" + ppr (TrustInfo Sf_Trustworthy) = ptext $ sLit "trustworthy" + ppr (TrustInfo Sf_Safe) = ptext $ sLit "safe" + ppr (TrustInfo Sf_SafeInferred) = ptext $ sLit "safe-inferred" \end{code} %************************************************************************ diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index cdc2ca501a..60681fc6e7 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -43,6 +43,7 @@ import HscMain import HsSyn import HscTypes import InstEnv +import TyCon import Type hiding( typeKind ) import TcType hiding( typeKind ) import Var @@ -72,6 +73,7 @@ import MonadUtils import System.Directory import Data.Dynamic +import Data.Either import Data.List (find) import Control.Monad #if __GLASGOW_HASKELL__ >= 701 @@ -84,7 +86,6 @@ import GHC.Exts import Data.Array import Exception import Control.Concurrent -import System.IO import System.IO.Unsafe -- ----------------------------------------------------------------------------- @@ -176,6 +177,12 @@ findEnclosingDecls hsc_env inf = mb = getModBreaks hmi in modBreaks_decls mb ! breakInfo_number inf +-- | Update fixity environment in the current interactive context. +updateFixityEnv :: GhcMonad m => FixityEnv -> m () +updateFixityEnv fix_env = do + hsc_env <- getSession + let ic = hsc_IC hsc_env + setSession $ hsc_env { hsc_IC = ic { ic_fix_env = fix_env } } -- | Run a statement in the current interactive context. Statement -- may bind multple values. @@ -195,8 +202,9 @@ runStmtWithLocation source linenumber expr step = -- Turn off -fwarn-unused-bindings when running a statement, to hide -- warnings about the implicit bindings we introduce. - let dflags' = wopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds - hsc_env' = hsc_env{ hsc_dflags = dflags' } + let ic = hsc_IC hsc_env -- use the interactive dflags + idflags' = ic_dflags ic `wopt_unset` Opt_WarnUnusedBinds + hsc_env' = hsc_env{ hsc_IC = ic{ ic_dflags = idflags' } } -- compile to value (IO [HValue]), don't run r <- liftIO $ hscStmtWithLocation hsc_env' expr source linenumber @@ -205,11 +213,13 @@ runStmtWithLocation source linenumber expr step = -- empty statement / comment Nothing -> return (RunOk []) - Just (tyThings, hval) -> do + Just (tyThings, hval, fix_env) -> do + updateFixityEnv fix_env + status <- withVirtualCWD $ - withBreakAction (isStep step) dflags' breakMVar statusMVar $ do - liftIO $ sandboxIO dflags' statusMVar hval + withBreakAction (isStep step) idflags' breakMVar statusMVar $ do + liftIO $ sandboxIO idflags' statusMVar hval let ic = hsc_IC hsc_env bindings = (ic_tythings ic, ic_rn_gbl_env ic) @@ -229,13 +239,7 @@ runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name] runDeclsWithLocation source linenumber expr = do hsc_env <- getSession - - -- Turn off -fwarn-unused-bindings when running a statement, to hide - -- warnings about the implicit bindings we introduce. - let dflags' = wopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds - hsc_env' = hsc_env{ hsc_dflags = dflags' } - - (tyThings, ic) <- liftIO $ hscDeclsWithLocation hsc_env' expr source linenumber + (tyThings, ic) <- liftIO $ hscDeclsWithLocation hsc_env expr source linenumber setSession $ hsc_env { hsc_IC = ic } hsc_env <- getSession @@ -416,8 +420,8 @@ rethrow dflags io = Exception.catch io $ \se -> do withInterruptsSentTo :: ThreadId -> IO r -> IO r withInterruptsSentTo thread get_result = do - bracket (modifyMVar_ interruptTargetThread (return . (thread:))) - (\_ -> modifyMVar_ interruptTargetThread (\tl -> return $! tail tl)) + bracket (pushInterruptTargetThread thread) + (\_ -> popInterruptTargetThread) (\_ -> get_result) -- This function sets up the interpreter for catching breakpoints, and @@ -606,8 +610,9 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do -- Filter out any unboxed ids; -- we can't bind these at the prompt pointers = filter (\(id,_) -> isPointer id) vars - isPointer id | PtrRep <- idPrimRep id = True - | otherwise = False + isPointer id | UnaryRep ty <- repType (idType id) + , PtrRep <- typePrimRep ty = True + | otherwise = False (ids, offsets) = unzip pointers @@ -642,7 +647,6 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do -- - globalise the Id (Ids are supposed to be Global, apparently). -- let result_ok = isPointer result_id - && not (isUnboxedTupleType (idType result_id)) all_ids | result_ok = result_id : new_ids | otherwise = new_ids @@ -704,8 +708,9 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do WARN(True, text (":print failed to calculate the " ++ "improvement for a type")) hsc_env Just subst -> do - when (dopt Opt_D_dump_rtti (hsc_dflags hsc_env)) $ - printForUser stderr alwaysQualify $ + let dflags = hsc_dflags hsc_env + when (dopt Opt_D_dump_rtti dflags) $ + printInfoForUser dflags alwaysQualify $ fsep [text "RTTI Improvement for", ppr id, equals, ppr subst] let ic' = extendInteractiveContext @@ -763,11 +768,16 @@ abandonAll = do -- with the partial computation, which still ends in takeMVar, -- so any attempt to evaluate one of these thunks will block -- unless we fill in the MVar. +-- (c) wait for the thread to terminate by taking its status MVar. This +-- step is necessary to prevent race conditions with +-- -fbreak-on-exception (see #5975). -- See test break010. abandon_ :: Resume -> IO () abandon_ r = do killThread (resumeThreadId r) putMVar (resumeBreakMVar r) () + _ <- takeMVar (resumeStatMVar r) + return () -- ----------------------------------------------------------------------------- -- Bounded list, optimised for repeated cons @@ -804,27 +814,41 @@ fromListBL bound l = BL (length l) bound l [] setContext :: GhcMonad m => [InteractiveImport] -> m () setContext imports = do { hsc_env <- getSession - ; all_env <- liftIO $ findGlobalRdrEnv hsc_env imports + ; let dflags = hsc_dflags hsc_env + ; all_env_err <- liftIO $ findGlobalRdrEnv hsc_env imports + ; case all_env_err of + Left (mod, err) -> ghcError (formatError dflags mod err) + Right all_env -> do { ; let old_ic = hsc_IC hsc_env final_rdr_env = ic_tythings old_ic `icPlusGblRdrEnv` all_env ; modifySession $ \_ -> hsc_env{ hsc_IC = old_ic { ic_imports = imports - , ic_rn_gbl_env = final_rdr_env }}} + , ic_rn_gbl_env = final_rdr_env }}}} + where + formatError dflags mod err = ProgramError . showSDoc dflags $ + text "Cannot add module" <+> ppr mod <+> + text "to context:" <+> text err -findGlobalRdrEnv :: HscEnv -> [InteractiveImport] -> IO GlobalRdrEnv +findGlobalRdrEnv :: HscEnv -> [InteractiveImport] + -> IO (Either (ModuleName, String) GlobalRdrEnv) -- Compute the GlobalRdrEnv for the interactive context findGlobalRdrEnv hsc_env imports = do { idecls_env <- hscRnImportDecls hsc_env idecls -- This call also loads any orphan modules - ; imods_env <- mapM (mkTopLevEnv (hsc_HPT hsc_env)) imods - ; return (foldr plusGlobalRdrEnv idecls_env imods_env) } + ; return $ case partitionEithers (map mkEnv imods) of + ([], imods_env) -> Right (foldr plusGlobalRdrEnv idecls_env imods_env) + (err : _, _) -> Left err } where idecls :: [LImportDecl RdrName] idecls = [noLoc d | IIDecl d <- imports] - imods :: [Module] + imods :: [ModuleName] imods = [m | IIModule m <- imports] + mkEnv mod = case mkTopLevEnv (hsc_HPT hsc_env) mod of + Left err -> Left (mod, err) + Right env -> Right env + availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv availsToGlobalRdrEnv mod_name avails = mkGlobalRdrEnv (gresFromAvails imp_prov avails) @@ -836,17 +860,14 @@ availsToGlobalRdrEnv mod_name avails is_qual = False, is_dloc = srcLocSpan interactiveSrcLoc } -mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv +mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String GlobalRdrEnv mkTopLevEnv hpt modl - = case lookupUFM hpt (moduleName modl) of - Nothing -> ghcError (ProgramError ("mkTopLevEnv: not a home module " ++ - showSDoc (ppr modl))) + = case lookupUFM hpt modl of + Nothing -> Left "not a home module" Just details -> case mi_globals (hm_iface details) of - Nothing -> - ghcError (ProgramError ("mkTopLevEnv: not interpreted " - ++ showSDoc (ppr modl))) - Just env -> return env + Nothing -> Left "not interpreted" + Just env -> Right env -- | Get the interactive evaluation context, consisting of a pair of the -- set of modules from which we take the full top-level scope, and the set @@ -947,7 +968,8 @@ typeKind normalise str = withSession $ \hsc_env -> do compileExpr :: GhcMonad m => String -> m HValue compileExpr expr = withSession $ \hsc_env -> do - Just (ids, hval) <- liftIO $ hscStmt hsc_env ("let __cmCompileExpr = "++expr) + Just (ids, hval, fix_env) <- liftIO $ hscStmt hsc_env ("let __cmCompileExpr = "++expr) + updateFixityEnv fix_env hvals <- liftIO hval case (ids,hvals) of ([_],[hv]) -> return hv @@ -971,9 +993,11 @@ dynCompileExpr expr = do } setContext (IIDecl importDecl : iis) let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")" - Just (ids, hvals) <- withSession $ \hsc_env -> + Just (ids, hvals, fix_env) <- withSession $ \hsc_env -> liftIO $ hscStmt hsc_env stmt setContext iis + updateFixityEnv fix_env + vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic]) case (ids,vals) of (_:[], v:[]) -> return v @@ -986,7 +1010,8 @@ showModule :: GhcMonad m => ModSummary -> m String showModule mod_summary = withSession $ \hsc_env -> do interpreted <- isModuleInterpreted mod_summary - return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary) + let dflags = hsc_dflags hsc_env + return (showModMsg dflags (hscTarget dflags) interpreted mod_summary) isModuleInterpreted :: GhcMonad m => ModSummary -> m Bool isModuleInterpreted mod_summary = withSession $ \hsc_env -> diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs index 913e58c6fb..d34d9e1f5c 100644 --- a/compiler/main/PackageConfig.hs +++ b/compiler/main/PackageConfig.hs @@ -1,47 +1,42 @@ +-- | +-- Package configuration information: essentially the interface to Cabal, with +-- some utilities -- -- (c) The University of Glasgow, 2004 -- +module PackageConfig ( + -- $package_naming --- | Package configuration information: essentially the interface to Cabal, with some utilities - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details + -- * PackageId + mkPackageId, packageConfigId, -module PackageConfig ( - -- $package_naming - - -- * PackageId - mkPackageId, packageConfigId, - - -- * The PackageConfig type: information about a package - PackageConfig, - InstalledPackageInfo_(..), display, - Version(..), - PackageIdentifier(..), - defaultPackageConfig, + -- * The PackageConfig type: information about a package + PackageConfig, + InstalledPackageInfo_(..), display, + Version(..), + PackageIdentifier(..), + defaultPackageConfig, packageConfigToInstalledPackageInfo, - installedPackageInfoToPackageConfig, - ) where + installedPackageInfoToPackageConfig + ) where #include "HsVersions.h" -import Maybes -import Module import Distribution.InstalledPackageInfo import Distribution.ModuleName import Distribution.Package hiding (PackageId) import Distribution.Text import Distribution.Version +import Maybes +import Module + -- ----------------------------------------------------------------------------- --- Our PackageConfig type is just InstalledPackageInfo from Cabal. Later we +-- Our PackageConfig type is just InstalledPackageInfo from Cabal. Later we -- might need to extend it with some GHC-specific stuff, but for now it's fine. type PackageConfig = InstalledPackageInfo_ Module.ModuleName + defaultPackageConfig :: PackageConfig defaultPackageConfig = emptyInstalledPackageInfo @@ -51,9 +46,9 @@ defaultPackageConfig = emptyInstalledPackageInfo -- $package_naming -- #package_naming# -- Mostly the compiler deals in terms of 'PackageName's, which don't --- have the version suffix. This is so that we don't need to know the +-- have the version suffix. This is so that we don't need to know the -- version for the @-package-name@ flag, or know the versions of --- wired-in packages like @base@ & @rts@. Versions are confined to the +-- wired-in packages like @base@ & @rts@. Versions are confined to the -- package sub-system. -- -- This means that in theory you could have multiple base packages installed @@ -88,3 +83,4 @@ installedPackageInfoToPackageConfig hiddenModules = h })) = pkgconf{ exposedModules = map mkModuleName e, hiddenModules = map mkModuleName h } + diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index 1d6ad4a472..5bea131088 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -2,51 +2,44 @@ % (c) The University of Glasgow, 2006 % \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -- | Package manipulation module Packages ( - module PackageConfig, - - -- * The PackageConfigMap - PackageConfigMap, emptyPackageConfigMap, lookupPackage, - extendPackageConfigMap, dumpPackages, - - -- * Reading the package config, and processing cmdline args - PackageState(..), - initPackages, - getPackageDetails, - lookupModuleInAllPackages, lookupModuleWithSuggestions, - - -- * Inspecting the set of packages in scope - getPackageIncludePath, - getPackageLibraryPath, - getPackageLinkOpts, - getPackageExtraCcOpts, - getPackageFrameworkPath, - getPackageFrameworks, - getPreloadPackagesAnd, + module PackageConfig, + + -- * The PackageConfigMap + PackageConfigMap, emptyPackageConfigMap, lookupPackage, + extendPackageConfigMap, dumpPackages, + + -- * Reading the package config, and processing cmdline args + PackageState(..), + initPackages, + getPackageDetails, + lookupModuleInAllPackages, lookupModuleWithSuggestions, + + -- * Inspecting the set of packages in scope + getPackageIncludePath, + getPackageLibraryPath, + getPackageLinkOpts, + getPackageExtraCcOpts, + getPackageFrameworkPath, + getPackageFrameworks, + getPreloadPackagesAnd, collectIncludeDirs, collectLibraryPaths, collectLinkOpts, packageHsLibs, - -- * Utils - isDllName + -- * Utils + isDllName ) where #include "HsVersions.h" -import PackageConfig +import PackageConfig import DynFlags import StaticFlags -import Config ( cProjectVersion ) -import Name ( Name, nameModule_maybe ) +import Config ( cProjectVersion ) +import Name ( Name, nameModule_maybe ) import UniqFM import Module import Util @@ -66,6 +59,7 @@ import System.Directory import System.FilePath as FilePath import qualified System.FilePath.Posix as FilePath.Posix import Control.Monad +import Data.Char (isSpace) import Data.List as List import Data.Map (Map) import qualified Data.Map as Map @@ -81,12 +75,12 @@ import qualified Data.Set as Set -- -- The package state is computed by 'initPackages', and kept in DynFlags. -- --- * @-package <pkg>@ causes @<pkg>@ to become exposed, and all other packages --- with the same name to become hidden. --- +-- * @-package <pkg>@ causes @<pkg>@ to become exposed, and all other packages +-- with the same name to become hidden. +-- -- * @-hide-package <pkg>@ causes @<pkg>@ to become hidden. --- --- * Let @exposedPackages@ be the set of packages thus exposed. +-- +-- * Let @exposedPackages@ be the set of packages thus exposed. -- Let @depExposedPackages@ be the transitive closure from @exposedPackages@ of -- their dependencies. -- @@ -107,28 +101,28 @@ import qualified Data.Set as Set -- Notes on DLLs -- ~~~~~~~~~~~~~ --- When compiling module A, which imports module B, we need to --- know whether B will be in the same DLL as A. --- If it's in the same DLL, we refer to B_f_closure --- If it isn't, we refer to _imp__B_f_closure +-- When compiling module A, which imports module B, we need to +-- know whether B will be in the same DLL as A. +-- If it's in the same DLL, we refer to B_f_closure +-- If it isn't, we refer to _imp__B_f_closure -- When compiling A, we record in B's Module value whether it's -- in a different DLL, by setting the DLL flag. data PackageState = PackageState { - pkgIdMap :: PackageConfigMap, -- PackageId -> PackageConfig - -- The exposed flags are adjusted according to -package and - -- -hide-package flags, and -ignore-package removes packages. + pkgIdMap :: PackageConfigMap, -- PackageId -> PackageConfig + -- The exposed flags are adjusted according to -package and + -- -hide-package flags, and -ignore-package removes packages. preloadPackages :: [PackageId], - -- 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. + -- 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. - moduleToPkgConfAll :: UniqFM [(PackageConfig,Bool)], -- ModuleEnv mapping - -- Derived from pkgIdMap. - -- Maps Module to (pkgconf,exposed), where pkgconf is the - -- PackageConfig for the package containing the module, and - -- exposed is True if the package exposes that module. + moduleToPkgConfAll :: UniqFM [(PackageConfig,Bool)], -- ModuleEnv mapping + -- Derived from pkgIdMap. + -- Maps Module to (pkgconf,exposed), where pkgconf is the + -- PackageConfig for the package containing the module, and + -- exposed is True if the package exposes that module. installedPackageIdMap :: InstalledPackageIdMap } @@ -149,7 +143,7 @@ lookupPackage = lookupUFM extendPackageConfigMap :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap -extendPackageConfigMap pkg_map new_pkgs +extendPackageConfigMap pkg_map new_pkgs = foldl add pkg_map new_pkgs where add pkg_map p = addToUFM pkg_map (packageConfigId p) p @@ -159,10 +153,10 @@ getPackageDetails :: PackageState -> PackageId -> PackageConfig getPackageDetails ps pid = expectJust "getPackageDetails" (lookupPackage (pkgIdMap ps) pid) -- ---------------------------------------------------------------------------- --- Loading the package config files and building up the package state +-- Loading the package db files and building up the package state -- | Call this after 'DynFlags.parseDynFlags'. It reads the package --- configuration files, and sets up various internal tables of package +-- database files, and sets up various internal tables of package -- information, according to the package-related flags on the -- command-line (@-package@, @-hide-package@ etc.) -- @@ -175,14 +169,14 @@ getPackageDetails ps pid = expectJust "getPackageDetails" (lookupPackage (pkgIdM -- 'pkgState' in 'DynFlags' and return a list of packages to -- link in. initPackages :: DynFlags -> IO (DynFlags, [PackageId]) -initPackages dflags = do +initPackages dflags = do pkg_db <- case pkgDatabase dflags of Nothing -> readPackageConfigs dflags Just db -> return $ setBatchPackageFlags dflags db - (pkg_state, preload, this_pkg) + (pkg_state, preload, this_pkg) <- mkPackageState dflags pkg_db [] (thisPackage dflags) return (dflags{ pkgDatabase = Just pkg_db, - pkgState = pkg_state, + pkgState = pkg_state, thisPackage = this_pkg }, preload) @@ -191,66 +185,61 @@ initPackages dflags = do readPackageConfigs :: DynFlags -> IO [PackageConfig] readPackageConfigs dflags = do - e_pkg_path <- tryIO (getEnv "GHC_PACKAGE_PATH") - system_pkgconfs <- getSystemPackageConfigs dflags - - let pkgconfs = case e_pkg_path of - Left _ -> system_pkgconfs - Right path - | last cs == "" -> init cs ++ system_pkgconfs - | otherwise -> cs - where cs = parseSearchPath path - -- if the path ends in a separator (eg. "/foo/bar:") - -- the we tack on the system paths. - - pkgs <- mapM (readPackageConfig dflags) - (pkgconfs ++ reverse (extraPkgConfs dflags)) - -- later packages shadow earlier ones. extraPkgConfs - -- is in the opposite order to the flags on the - -- command line. - - return (concat pkgs) - - -getSystemPackageConfigs :: DynFlags -> IO [FilePath] -getSystemPackageConfigs dflags = do - -- System one always comes first - let system_pkgconf = systemPackageConfig dflags - - -- Read user's package conf (eg. ~/.ghc/i386-linux-6.3/package.conf) - -- unless the -no-user-package-conf flag was given. - user_pkgconf <- do - if not (dopt Opt_ReadUserPackageConf dflags) then return [] else do - appdir <- getAppUserDataDirectory "ghc" - let - dir = appdir </> (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion) - pkgconf = dir </> "package.conf.d" - -- - exist <- doesDirectoryExist pkgconf - if exist then return [pkgconf] else return [] - `catchIO` (\_ -> return []) - - return (system_pkgconf : user_pkgconf) + let system_conf_refs = [UserPkgConf, GlobalPkgConf] + + e_pkg_path <- tryIO (getEnv "GHC_PACKAGE_PATH") + let base_conf_refs = case e_pkg_path of + Left _ -> system_conf_refs + Right path + | null (last cs) + -> map PkgConfFile (init cs) ++ system_conf_refs + | otherwise + -> map PkgConfFile cs + where cs = parseSearchPath path + -- if the path ends in a separator (eg. "/foo/bar:") + -- then we tack on the system paths. + + let conf_refs = reverse (extraPkgConfs dflags base_conf_refs) + -- later packages shadow earlier ones. extraPkgConfs + -- is in the opposite order to the flags on the + -- command line. + confs <- liftM catMaybes $ mapM (resolvePackageConfig dflags) conf_refs + + liftM concat $ mapM (readPackageConfig dflags) confs + +resolvePackageConfig :: DynFlags -> PkgConfRef -> IO (Maybe FilePath) +resolvePackageConfig dflags GlobalPkgConf = return $ Just (systemPackageConfig dflags) +resolvePackageConfig _ UserPkgConf = handleIO (\_ -> return Nothing) $ do + appdir <- getAppUserDataDirectory "ghc" + let dir = appdir </> (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion) + pkgconf = dir </> "package.conf.d" + exist <- doesDirectoryExist pkgconf + return $ if exist then Just pkgconf else Nothing +resolvePackageConfig _ (PkgConfFile name) = return $ Just name readPackageConfig :: DynFlags -> FilePath -> IO [PackageConfig] readPackageConfig dflags conf_file = do isdir <- doesDirectoryExist conf_file - proto_pkg_configs <- + proto_pkg_configs <- if isdir then do let filename = conf_file </> "package.cache" debugTraceMsg dflags 2 (text "Using binary package database:" <+> text filename) conf <- readBinPackageDB filename return (map installedPackageInfoToPackageConfig conf) - else do + else do isfile <- doesFileExist conf_file when (not isfile) $ - ghcError $ InstallationError $ + ghcError $ InstallationError $ "can't find a package database at " ++ conf_file debugTraceMsg dflags 2 (text "Using package config file:" <+> text conf_file) str <- readFile conf_file - return (map installedPackageInfoToPackageConfig $ read str) + case reads str of + [(configs, rest)] + | all isSpace rest -> return (map installedPackageInfoToPackageConfig configs) + _ -> ghcError $ InstallationError $ + "invalid package database file " ++ conf_file let top_dir = topDir dflags @@ -293,7 +282,7 @@ mungePackagePaths top_dir pkgroot pkg = haddockInterfaces = munge_paths (haddockInterfaces pkg), haddockHTMLs = munge_urls (haddockHTMLs pkg) } - where + where munge_paths = map munge_path munge_urls = map munge_url @@ -329,56 +318,57 @@ mungePackagePaths top_dir pkgroot pkg = -- (-package, -hide-package, -ignore-package). applyPackageFlag - :: UnusablePackages + :: DynFlags + -> UnusablePackages -> [PackageConfig] -- Initial database -> PackageFlag -- flag to apply -> IO [PackageConfig] -- new database -applyPackageFlag unusable pkgs flag = +applyPackageFlag dflags unusable pkgs flag = case flag of ExposePackage str -> case selectPackages (matchingStr str) pkgs unusable of - Left ps -> packageFlagErr flag ps + Left ps -> packageFlagErr dflags flag ps Right (p:ps,qs) -> return (p':ps') - where p' = p {exposed=True} - ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs) + where p' = p {exposed=True} + ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs) _ -> panic "applyPackageFlag" ExposePackageId str -> case selectPackages (matchingId str) pkgs unusable of - Left ps -> packageFlagErr flag ps + Left ps -> packageFlagErr dflags flag ps Right (p:ps,qs) -> return (p':ps') - where p' = p {exposed=True} - ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs) + where p' = p {exposed=True} + ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs) _ -> panic "applyPackageFlag" HidePackage str -> case selectPackages (matchingStr str) pkgs unusable of - Left ps -> packageFlagErr flag ps + Left ps -> packageFlagErr dflags flag ps Right (ps,qs) -> return (map hide ps ++ qs) - where hide p = p {exposed=False} + where hide p = p {exposed=False} -- we trust all matching packages. Maybe should only trust first one? -- and leave others the same or set them untrusted TrustPackage str -> case selectPackages (matchingStr str) pkgs unusable of - Left ps -> packageFlagErr flag ps + Left ps -> packageFlagErr dflags flag ps Right (ps,qs) -> return (map trust ps ++ qs) - where trust p = p {trusted=True} + where trust p = p {trusted=True} DistrustPackage str -> case selectPackages (matchingStr str) pkgs unusable of - Left ps -> packageFlagErr flag ps + Left ps -> packageFlagErr dflags flag ps Right (ps,qs) -> return (map distrust ps ++ qs) - where distrust p = p {trusted=False} + where distrust p = p {trusted=False} _ -> panic "applyPackageFlag" where - -- When a package is requested to be exposed, we hide all other - -- packages with the same name. - hideAll name ps = map maybe_hide ps - where maybe_hide p + -- When a package is requested to be exposed, we hide all other + -- packages with the same name. + hideAll name ps = map maybe_hide ps + where maybe_hide p | pkgName (sourcePackageId p) == name = p {exposed=False} | otherwise = p @@ -401,8 +391,8 @@ selectPackages matches pkgs unusable -- version, or just the name if it is unambiguous. matchingStr :: String -> PackageConfig -> Bool matchingStr str p - = str == display (sourcePackageId p) - || str == display (pkgName (sourcePackageId p)) + = str == display (sourcePackageId p) + || str == display (pkgName (sourcePackageId p)) matchingId :: String -> PackageConfig -> Bool matchingId str p = InstalledPackageId str == installedPackageId p @@ -413,20 +403,21 @@ sortByVersion = sortBy (flip (comparing (pkgVersion.sourcePackageId))) comparing :: Ord a => (t -> a) -> t -> t -> Ordering comparing f a b = f a `compare` f b -packageFlagErr :: PackageFlag +packageFlagErr :: DynFlags + -> PackageFlag -> [(PackageConfig, UnusablePackageReason)] -> IO a -- for missing DPH package we emit a more helpful error message, because -- this may be the result of using -fdph-par or -fdph-seq. -packageFlagErr (ExposePackage pkg) [] | is_dph_package pkg - = ghcError (CmdLineError (showSDoc $ dph_err)) +packageFlagErr dflags (ExposePackage pkg) [] | is_dph_package pkg + = ghcError (CmdLineError (showSDoc dflags $ dph_err)) where dph_err = text "the " <> text pkg <> text " package is not installed." $$ text "To install it: \"cabal install dph\"." is_dph_package pkg = "dph" `isPrefixOf` pkg - -packageFlagErr flag reasons = ghcError (CmdLineError (showSDoc $ err)) - where err = text "cannot satisfy " <> ppr_flag <> + +packageFlagErr dflags flag reasons = ghcError (CmdLineError (showSDoc dflags $ err)) + where err = text "cannot satisfy " <> ppr_flag <> (if null reasons then empty else text ": ") $$ nest 4 (ppr_reasons $$ text "(use -v for more information)") @@ -452,20 +443,20 @@ packageFlagErr flag reasons = ghcError (CmdLineError (showSDoc $ err)) hideOldPackages :: DynFlags -> [PackageConfig] -> IO [PackageConfig] hideOldPackages dflags pkgs = mapM maybe_hide pkgs where maybe_hide p - | not (exposed p) = return p - | (p' : _) <- later_versions = do - debugTraceMsg dflags 2 $ - (ptext (sLit "hiding package") <+> pprSPkg p <+> - ptext (sLit "to avoid conflict with later version") <+> - pprSPkg p') - return (p {exposed=False}) - | otherwise = return p - where myname = pkgName (sourcePackageId p) - myversion = pkgVersion (sourcePackageId p) - later_versions = [ p | p <- pkgs, exposed p, - let pkg = sourcePackageId p, - pkgName pkg == myname, - pkgVersion pkg > myversion ] + | not (exposed p) = return p + | (p' : _) <- later_versions = do + debugTraceMsg dflags 2 $ + (ptext (sLit "hiding package") <+> pprSPkg p <+> + ptext (sLit "to avoid conflict with later version") <+> + pprSPkg p') + return (p {exposed=False}) + | otherwise = return p + where myname = pkgName (sourcePackageId p) + myversion = pkgVersion (sourcePackageId p) + later_versions = [ p | p <- pkgs, exposed p, + let pkg = sourcePackageId p, + pkgName pkg == myname, + pkgVersion pkg > myversion ] -- ----------------------------------------------------------------------------- -- Wired-in packages @@ -494,43 +485,43 @@ findWiredInPackages dflags pkgs = do matches :: PackageConfig -> String -> Bool pc `matches` pid = display (pkgName (sourcePackageId pc)) == pid - -- find which package corresponds to each wired-in package - -- delete any other packages with the same name - -- update the package and any dependencies to point to the new - -- one. + -- find which package corresponds to each wired-in package + -- delete any other packages with the same name + -- update the package and any dependencies to point to the new + -- one. -- -- When choosing which package to map to a wired-in package -- name, we prefer exposed packages, and pick the latest -- version. To override the default choice, -hide-package -- could be used to hide newer versions. -- - findWiredInPackage :: [PackageConfig] -> String - -> IO (Maybe InstalledPackageId) - findWiredInPackage pkgs wired_pkg = + findWiredInPackage :: [PackageConfig] -> String + -> IO (Maybe InstalledPackageId) + findWiredInPackage pkgs wired_pkg = let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] in - case all_ps of - [] -> notfound - many -> pick (head (sortByVersion many)) + case all_ps of + [] -> notfound + many -> pick (head (sortByVersion many)) where notfound = do - debugTraceMsg dflags 2 $ - ptext (sLit "wired-in package ") - <> text wired_pkg - <> ptext (sLit " not found.") - return Nothing - pick :: InstalledPackageInfo_ ModuleName + debugTraceMsg dflags 2 $ + ptext (sLit "wired-in package ") + <> text wired_pkg + <> ptext (sLit " not found.") + return Nothing + pick :: InstalledPackageInfo_ ModuleName -> IO (Maybe InstalledPackageId) pick pkg = do debugTraceMsg dflags 2 $ - ptext (sLit "wired-in package ") - <> text wired_pkg - <> ptext (sLit " mapped to ") - <> pprIPkg pkg - return (Just (installedPackageId pkg)) + ptext (sLit "wired-in package ") + <> text wired_pkg + <> ptext (sLit " mapped to ") + <> pprIPkg pkg + return (Just (installedPackageId pkg)) mb_wired_in_ids <- mapM (findWiredInPackage pkgs) wired_in_pkgids - let + let wired_in_ids = catMaybes mb_wired_in_ids -- this is old: we used to assume that if there were @@ -541,13 +532,13 @@ findWiredInPackages dflags pkgs = do -- wrappers that depend on this one. e.g. base-4.0 is the -- latest, base-3.0 is a compat wrapper depending on base-4.0. {- - deleteOtherWiredInPackages pkgs = filterOut bad pkgs - where bad p = any (p `matches`) wired_in_pkgids + deleteOtherWiredInPackages pkgs = filterOut bad pkgs + where bad p = any (p `matches`) wired_in_pkgids && package p `notElem` map fst wired_in_ids -} - updateWiredInDependencies pkgs = map upd_pkg pkgs - where upd_pkg p + updateWiredInDependencies pkgs = map upd_pkg pkgs + where upd_pkg p | installedPackageId p `elem` wired_in_ids = p { sourcePackageId = (sourcePackageId p){ pkgVersion = Version [] [] } } | otherwise @@ -650,9 +641,9 @@ ignorePackages flags pkgs = Map.fromList (concatMap doit flags) case partition (matchingStr str) pkgs of (ps, _) -> [ (installedPackageId p, IgnoredWithFlag) | p <- ps ] - -- missing package is not an error for -ignore-package, - -- because a common usage is to -ignore-package P as - -- a preventative measure just in case P exists. + -- missing package is not an error for -ignore-package, + -- because a common usage is to -ignore-package P as + -- a preventative measure just in case P exists. doit _ = panic "ignorePackages" -- ----------------------------------------------------------------------------- @@ -665,7 +656,7 @@ depClosure index ipids = closure Map.empty ipids 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) + | Just p <- Map.lookup ipid index = closure (Map.insert ipid p set) (depends p ++ ipids) | otherwise = closure set ipids @@ -688,7 +679,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do {- Plan. - 1. P = transitive closure of packages selected by -package-id + 1. P = transitive closure of packages selected by -package-id 2. Apply shadowing. When there are multiple packages with the same sourcePackageId, @@ -746,7 +737,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do ipid_selected = depClosure ipid_map [ InstalledPackageId i | ExposePackageId i <- flags ] - + (ignore_flags, other_flags) = partition is_ignore flags is_ignore IgnorePackage{} = True is_ignore _ = False @@ -765,7 +756,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do -- Modify the package database according to the command-line flags -- (-package, -hide-package, -ignore-package, -hide-all-packages). -- - pkgs1 <- foldM (applyPackageFlag unusable) pkgs0_unique other_flags + pkgs1 <- foldM (applyPackageFlag dflags unusable) pkgs0_unique other_flags let pkgs2 = filter (not . (`Map.member` unusable) . installedPackageId) pkgs1 -- Here we build up a set of the packages mentioned in -package @@ -776,7 +767,9 @@ mkPackageState dflags pkgs0 preload0 this_package = do -- let preload1 = [ installedPackageId p | f <- flags, p <- get_exposed f ] - get_exposed (ExposePackage s) = filter (matchingStr s) pkgs2 + get_exposed (ExposePackage s) + = take 1 $ sortByVersion (filter (matchingStr s) pkgs2) + -- -package P means "the latest version of P" (#7030) get_exposed (ExposePackageId s) = filter (matchingId s) pkgs2 get_exposed _ = [] @@ -793,7 +786,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do lookupIPID ipid@(InstalledPackageId str) | Just pid <- Map.lookup ipid ipid_map = return pid - | otherwise = missingPackageErr str + | otherwise = missingPackageErr dflags str preload2 <- mapM lookupIPID preload1 @@ -808,9 +801,9 @@ mkPackageState dflags pkgs0 preload0 this_package = do -- set up preloaded package when we are just building it preload3 = nub $ filter (/= this_package) $ (basicLinkedPackages ++ preload2) - + -- Close the preload packages with their dependencies - dep_preload <- closeDeps pkg_db ipid_map (zip preload3 (repeat Nothing)) + dep_preload <- closeDeps dflags pkg_db ipid_map (zip preload3 (repeat Nothing)) let new_dep_preload = filter (`notElem` preload0) dep_preload let pstate = PackageState{ preloadPackages = dep_preload, @@ -820,7 +813,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do } return (pstate, new_dep_preload, this_package) - + -- ----------------------------------------------------------------------------- -- Make the mapping from module to package info @@ -831,15 +824,15 @@ mkModuleMap mkModuleMap pkg_db = foldr extend_modmap emptyUFM pkgids where pkgids = map packageConfigId (eltsUFM pkg_db) - - extend_modmap pkgid modmap = - addListToUFM_C (++) modmap - ([(m, [(pkg, True)]) | m <- exposed_mods] ++ - [(m, [(pkg, False)]) | m <- hidden_mods]) - where - pkg = expectJust "mkModuleMap" (lookupPackage pkg_db pkgid) - exposed_mods = exposedModules pkg - hidden_mods = hiddenModules pkg + + extend_modmap pkgid modmap = + addListToUFM_C (++) modmap + ([(m, [(pkg, True)]) | m <- exposed_mods] ++ + [(m, [(pkg, False)]) | m <- hidden_mods]) + where + pkg = expectJust "mkModuleMap" (lookupPackage pkg_db pkgid) + exposed_mods = exposedModules pkg + hidden_mods = hiddenModules pkg pprSPkg :: PackageConfig -> SDoc pprSPkg p = text (display (sourcePackageId p)) @@ -863,7 +856,7 @@ getPackageIncludePath :: DynFlags -> [PackageId] -> IO [String] getPackageIncludePath dflags pkgs = collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs -collectIncludeDirs :: [PackageConfig] -> [FilePath] +collectIncludeDirs :: [PackageConfig] -> [FilePath] collectIncludeDirs ps = nub (filter notNull (concatMap includeDirs ps)) -- | Find all the library paths in these and the preload packages @@ -876,14 +869,14 @@ collectLibraryPaths ps = nub (filter notNull (concatMap libraryDirs ps)) -- | Find all the link options in these and the preload packages getPackageLinkOpts :: DynFlags -> [PackageId] -> IO [String] -getPackageLinkOpts dflags pkgs = +getPackageLinkOpts dflags pkgs = collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs collectLinkOpts :: DynFlags -> [PackageConfig] -> [String] collectLinkOpts dflags ps = concat (map all_opts ps) where - libs p = packageHsLibs dflags p ++ extraLibraries p - all_opts p = map ("-l" ++) (libs p) ++ ldOptions p + libs p = packageHsLibs dflags p ++ extraLibraries p + all_opts p = map ("-l" ++) (libs p) ++ ldOptions p packageHsLibs :: DynFlags -> PackageConfig -> [String] packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) @@ -895,7 +888,7 @@ packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) -- we leave out the _dyn, because it is superfluous -- debug RTS includes support for -eventlog - ways2 | WayDebug `elem` map wayName ways1 + ways2 | WayDebug `elem` map wayName ways1 = filter ((/= WayEventLog) . wayName) ways1 | otherwise = ways1 @@ -903,14 +896,14 @@ packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) tag = mkBuildTag (filter (not . wayRTSOnly) ways2) rts_tag = mkBuildTag ways2 - mkDynName | opt_Static = id - | otherwise = (++ ("-ghc" ++ cProjectVersion)) + mkDynName | opt_Static = id + | otherwise = (++ ("-ghc" ++ cProjectVersion)) addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag) addSuffix other_lib = other_lib ++ (expandTag tag) expandTag t | null t = "" - | otherwise = '_':t + | otherwise = '_':t -- | Find all the C-compiler options in these and the preload packages getPackageExtraCcOpts :: DynFlags -> [PackageId] -> IO [String] @@ -933,7 +926,7 @@ getPackageFrameworks dflags pkgs = do -- ----------------------------------------------------------------------------- -- Package Utils --- | Takes a 'Module', and if the module is in a package returns +-- | Takes a 'Module', and if the module is in a package returns -- @(pkgconf, exposed)@ where pkgconf is the PackageConfig for that package, -- and exposed is @True@ if the package exposes the module. lookupModuleInAllPackages :: DynFlags -> ModuleName -> [(PackageConfig,Bool)] @@ -968,28 +961,31 @@ lookupModuleWithSuggestions dflags m -- 'PackageConfig's getPreloadPackagesAnd :: DynFlags -> [PackageId] -> IO [PackageConfig] getPreloadPackagesAnd dflags pkgids = - let + 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 (foldM (add_package pkg_map ipid_map) preload pairs) + all_pkgs <- throwErr dflags (foldM (add_package pkg_map ipid_map) preload pairs) return (map (getPackageDetails state) 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 :: PackageConfigMap +closeDeps :: DynFlags + -> PackageConfigMap -> Map InstalledPackageId PackageId -> [(PackageId, Maybe PackageId)] -> IO [PackageId] -closeDeps pkg_map ipid_map ps = throwErr (closeDepsErr pkg_map ipid_map ps) +closeDeps dflags pkg_map ipid_map ps + = throwErr dflags (closeDepsErr pkg_map ipid_map ps) -throwErr :: MaybeErr MsgDoc a -> IO a -throwErr m = case m of - Failed e -> ghcError (CmdLineError (showSDoc e)) - Succeeded r -> return r +throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a +throwErr dflags m + = case m of + Failed e -> ghcError (CmdLineError (showSDoc dflags e)) + Succeeded r -> return r closeDepsErr :: PackageConfigMap -> Map InstalledPackageId PackageId @@ -998,21 +994,21 @@ closeDepsErr :: PackageConfigMap closeDepsErr pkg_map ipid_map ps = foldM (add_package pkg_map ipid_map) [] ps -- internal helper -add_package :: PackageConfigMap +add_package :: PackageConfigMap -> Map InstalledPackageId PackageId -> [PackageId] -> (PackageId,Maybe PackageId) -> MaybeErr MsgDoc [PackageId] add_package pkg_db ipid_map ps (p, mb_parent) - | p `elem` ps = return ps -- Check if we've already added this package + | p `elem` ps = return ps -- Check if we've already added this package | otherwise = case lookupPackage pkg_db p of - Nothing -> Failed (missingPackageMsg (packageIdString p) <> + Nothing -> Failed (missingPackageMsg (packageIdString p) <> missingDependencyMsg mb_parent) Just pkg -> do - -- Add the package's dependents also - ps' <- foldM add_package_ipid ps (depends pkg) - return (p : ps') + -- Add the package's dependents also + ps' <- foldM add_package_ipid ps (depends pkg) + return (p : ps') where add_package_ipid ps ipid@(InstalledPackageId str) | Just pid <- Map.lookup ipid ipid_map @@ -1020,8 +1016,9 @@ add_package pkg_db ipid_map ps (p, mb_parent) | otherwise = Failed (missingPackageMsg str <> missingDependencyMsg mb_parent) -missingPackageErr :: String -> IO a -missingPackageErr p = ghcError (CmdLineError (showSDoc (missingPackageMsg p))) +missingPackageErr :: DynFlags -> String -> IO a +missingPackageErr dflags p + = ghcError (CmdLineError (showSDoc dflags (missingPackageMsg p))) missingPackageMsg :: String -> SDoc missingPackageMsg p = ptext (sLit "unknown package:") <+> text p @@ -1049,9 +1046,9 @@ isDllName this_pkg name -- | Show package info on console, if verbosity is >= 3 dumpPackages :: DynFlags -> IO () dumpPackages dflags - = do let pkg_map = pkgIdMap (pkgState dflags) - putMsg dflags $ - vcat (map (text . showInstalledPackageInfo - . packageConfigToInstalledPackageInfo) - (eltsUFM pkg_map)) + = do let pkg_map = pkgIdMap (pkgState dflags) + putMsg dflags $ + vcat (map (text . showInstalledPackageInfo + . packageConfigToInstalledPackageInfo) + (eltsUFM pkg_map)) \end{code} diff --git a/compiler/main/StaticFlagParser.hs b/compiler/main/StaticFlagParser.hs index 07eb214f74..b927f12d2c 100644 --- a/compiler/main/StaticFlagParser.hs +++ b/compiler/main/StaticFlagParser.hs @@ -9,7 +9,11 @@ -- ----------------------------------------------------------------------------- -module StaticFlagParser (parseStaticFlags) where +module StaticFlagParser ( + parseStaticFlags, + parseStaticFlagsFull, + flagsStatic + ) where #include "HsVersions.h" @@ -46,11 +50,18 @@ import Data.List -- XXX: can we add an auto-generated list of static flags here? -- parseStaticFlags :: [Located String] -> IO ([Located String], [Located String]) -parseStaticFlags args = do +parseStaticFlags = parseStaticFlagsFull flagsStatic + +-- | Parse GHC's static flags as @parseStaticFlags@ does. However it also +-- takes a list of available static flags, such that certain flags can be +-- enabled or disabled through this argument. +parseStaticFlagsFull :: [Flag IO] -> [Located String] + -> IO ([Located String], [Located String]) +parseStaticFlagsFull flagsAvailable args = do ready <- readIORef v_opt_C_ready when ready $ ghcError (ProgramError "Too late for parseStaticFlags: call it before newSession") - (leftover, errs, warns1) <- processArgs static_flags args + (leftover, errs, warns1) <- processArgs flagsAvailable args when (not (null errs)) $ ghcError $ errorsToGhcException errs -- deal with the way flags: the way (eg. prof) gives rise to @@ -62,8 +73,10 @@ parseStaticFlags args = do let unreg_flags | cGhcUnregisterised == "YES" = unregFlags | otherwise = [] + -- as these are GHC generated flags, we parse them with all static flags + -- in scope, regardless of what availableFlags are passed in. (more_leftover, errs, warns2) <- - processArgs static_flags (unreg_flags ++ way_flags') + processArgs flagsStatic (unreg_flags ++ way_flags') -- see sanity code in staticOpts writeIORef v_opt_C_ready True @@ -88,7 +101,7 @@ parseStaticFlags args = do return (excess_prec ++ cg_flags ++ more_leftover ++ leftover, warns1 ++ warns2) -static_flags :: [Flag IO] +flagsStatic :: [Flag IO] -- All the static flags should appear in this list. It describes how each -- static flag should be processed. Two main purposes: -- (a) if a command-line flag doesn't appear in the list, GHC can complain @@ -102,13 +115,9 @@ static_flags :: [Flag IO] -- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override -- flags further down the list with the same prefix. -static_flags = [ - ------- GHCi ------------------------------------------------------- - Flag "ignore-dot-ghci" (PassFlag addOpt) - , Flag "read-dot-ghci" (NoArg (removeOpt "-ignore-dot-ghci")) - +flagsStatic = [ ------- ways -------------------------------------------------------- - , Flag "prof" (NoArg (addWay WayProf)) + Flag "prof" (NoArg (addWay WayProf)) , Flag "eventlog" (NoArg (addWay WayEventLog)) , Flag "parallel" (NoArg (addWay WayPar)) , Flag "gransim" (NoArg (addWay WayGran)) @@ -123,9 +132,6 @@ static_flags = [ ------ Debugging ---------------------------------------------------- , Flag "dppr-debug" (PassFlag addOpt) - , Flag "dppr-cols" (AnySuffix addOpt) - , Flag "dppr-user-length" (AnySuffix addOpt) - , Flag "dppr-case-as-let" (PassFlag addOpt) , Flag "dsuppress-all" (PassFlag addOpt) , Flag "dsuppress-uniques" (PassFlag addOpt) , Flag "dsuppress-coercions" (PassFlag addOpt) @@ -135,7 +141,6 @@ static_flags = [ , Flag "dsuppress-var-kinds" (PassFlag addOpt) , Flag "dsuppress-type-signatures" (PassFlag addOpt) , Flag "dopt-fuel" (AnySuffix addOpt) - , Flag "dtrace-level" (AnySuffix addOpt) , Flag "dno-debug-output" (PassFlag addOpt) , Flag "dstub-dead-values" (PassFlag addOpt) -- rest of the debugging flags are dynamic @@ -178,9 +183,6 @@ isStaticFlag f = "fscc-profiling", "fdicts-strict", "fspec-inline-join-points", - "firrefutable-tuples", - "fparallel", - "fgransim", "fno-hi-version-check", "dno-black-holing", "fno-state-hack", diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index c2f8674aa9..4695d83ed0 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -27,10 +27,7 @@ module StaticFlags ( WayName(..), Way(..), v_Ways, isRTSWay, mkBuildTag, -- Output style options - opt_PprUserLength, - opt_PprCols, - opt_PprCaseAsLet, - opt_PprStyle_Debug, opt_TraceLevel, + opt_PprStyle_Debug, opt_NoDebugOutput, -- Suppressing boring aspects of core dumps @@ -51,8 +48,6 @@ module StaticFlags ( -- language opts opt_DictsStrict, - opt_IrrefutableTuples, - opt_Parallel, -- optimisation opts opt_NoStateHack, @@ -79,11 +74,7 @@ module StaticFlags ( opt_Static, -- misc opts - opt_IgnoreDotGhci, - opt_GhciScripts, opt_ErrorSpans, - opt_GranMacros, - opt_HiVersion, opt_HistorySize, opt_Unregisterised, v_Ld_inputs, @@ -103,10 +94,11 @@ module StaticFlags ( import Config import FastString import Util -import Maybes ( firstJusts, catMaybes ) +import Maybes ( firstJusts ) import Panic import Control.Monad ( liftM3 ) +import Data.Function import Data.Maybe ( listToMaybe ) import Data.IORef import System.IO.Unsafe ( unsafePerformIO ) @@ -133,7 +125,6 @@ lookUp :: FastString -> Bool lookup_def_int :: String -> Int -> Int lookup_def_float :: String -> Float -> Float lookup_str :: String -> Maybe String -lookup_all_str :: String -> [String] -- holds the static opts while they're being collected, before -- being unsafely read by unpacked_static_opts below. @@ -164,10 +155,6 @@ lookup_str sw Just str -> Just str Nothing -> Nothing -lookup_all_str sw = map f $ catMaybes (map (stripPrefix sw) staticFlags) where - f ('=' : str) = str - f str = str - lookup_def_int sw def = case (lookup_str sw) of Nothing -> def -- Use default Just xx -> try_read sw xx @@ -204,12 +191,6 @@ unpacked_opts = expandAts l = [l] -} -opt_IgnoreDotGhci :: Bool -opt_IgnoreDotGhci = lookUp (fsLit "-ignore-dot-ghci") - -opt_GhciScripts :: [String] -opt_GhciScripts = lookup_all_str "-ghci-script" - -- debugging options -- | Suppress all that is suppressable in core dumps. -- Except for uniques, as some simplifier phases introduce new varibles that @@ -260,34 +241,10 @@ opt_SuppressUniques :: Bool opt_SuppressUniques = lookUp (fsLit "-dsuppress-uniques") --- | Display case expressions with a single alternative as strict let bindings -opt_PprCaseAsLet :: Bool -opt_PprCaseAsLet = lookUp (fsLit "-dppr-case-as-let") - --- | Set the maximum width of the dumps --- If GHC's command line options are bad then the options parser uses the --- pretty printer display the error message. In this case the staticFlags --- won't be initialized yet, so we must check for this case explicitly --- and return the default value. -opt_PprCols :: Int -opt_PprCols - = unsafePerformIO - $ do ready <- readIORef v_opt_C_ready - if (not ready) - then return 100 - else return $ lookup_def_int "-dppr-cols" 100 - opt_PprStyle_Debug :: Bool opt_PprStyle_Debug = lookUp (fsLit "-dppr-debug") -opt_TraceLevel :: Int -opt_TraceLevel = lookup_def_int "-dtrace-level" 1 -- Standard level is 1 - -- Less verbose is 0 - -opt_PprUserLength :: Int -opt_PprUserLength = lookup_def_int "-dppr-user-length" 5 --ToDo: give this a name - opt_Fuel :: Int opt_Fuel = lookup_def_int "-dopt-fuel" maxBound @@ -306,12 +263,6 @@ opt_Hpc = lookUp (fsLit "-fhpc") opt_DictsStrict :: Bool opt_DictsStrict = lookUp (fsLit "-fdicts-strict") -opt_IrrefutableTuples :: Bool -opt_IrrefutableTuples = lookUp (fsLit "-firrefutable-tuples") - -opt_Parallel :: Bool -opt_Parallel = lookUp (fsLit "-fparallel") - opt_SimpleListLiterals :: Bool opt_SimpleListLiterals = lookUp (fsLit "-fsimple-list-literals") @@ -324,12 +275,6 @@ opt_CprOff = lookUp (fsLit "-fcpr-off") opt_MaxWorkerArgs :: Int opt_MaxWorkerArgs = lookup_def_int "-fmax-worker-args" (10::Int) -opt_GranMacros :: Bool -opt_GranMacros = lookUp (fsLit "-fgransim") - -opt_HiVersion :: Integer -opt_HiVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer - opt_HistorySize :: Int opt_HistorySize = lookup_def_int "-fhistory-size" 20 @@ -354,7 +299,12 @@ opt_UF_CreationThreshold, opt_UF_UseThreshold :: Int opt_UF_DearOp, opt_UF_FunAppDiscount, opt_UF_DictDiscount :: Int opt_UF_KeenessFactor :: Float -opt_UF_CreationThreshold = lookup_def_int "-funfolding-creation-threshold" (450::Int) +opt_UF_CreationThreshold = lookup_def_int "-funfolding-creation-threshold" (750::Int) + -- This threshold must be reasonably high to take + -- account of possible discounts. + -- E.g. 450 is not enough in 'fulsom' for Interval.sqr to inline into Csg.calc + -- (The unfolding for sqr never makes it into the interface file.) + opt_UF_UseThreshold = lookup_def_int "-funfolding-use-threshold" (60::Int) opt_UF_FunAppDiscount = lookup_def_int "-funfolding-fun-discount" (60::Int) diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index b46ca17f49..49314f2823 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -79,6 +79,16 @@ import System.Process import Control.Concurrent import FastString import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan ) + +#ifdef mingw32_HOST_OS +# if defined(i386_HOST_ARCH) +# define WINDOWS_CCONV stdcall +# elif defined(x86_64_HOST_ARCH) +# define WINDOWS_CCONV ccall +# else +# error Unknown mingw32 arch +# endif +#endif \end{code} How GHC finds its files @@ -489,8 +499,8 @@ runClang dflags args = do runSomething dflags "Clang (Assembler)" clang args ) (\(err :: SomeException) -> do - putMsg dflags $ text $ "Error running clang! you need clang installed" - ++ " to use the LLVM backend" + errorMsg dflags $ text $ "Error running clang! you need clang installed" + ++ " to use the LLVM backend" throw err ) @@ -528,7 +538,7 @@ figureLlvmVersion dflags = do debugTraceMsg dflags 2 (text "Error (figuring out LLVM version):" <+> text (show err)) - putMsg dflags $ vcat + errorMsg dflags $ vcat [ text "Warning:", nest 9 $ text "Couldn't figure out LLVM version!" $$ text "Make sure you have installed LLVM"] @@ -841,10 +851,10 @@ builderMainLoop dflags filter_fn pgm real_args mb_env = do msg <- readChan chan case msg of BuildMsg msg -> do - log_action dflags SevInfo noSrcSpan defaultUserStyle msg + log_action dflags dflags SevInfo noSrcSpan defaultUserStyle msg loop chan hProcess t p exitcode BuildError loc msg -> do - log_action dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg + log_action dflags dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg loop chan hProcess t p exitcode EOF -> loop chan hProcess (t-1) p exitcode @@ -922,7 +932,8 @@ traceCmd dflags phase_name cmd_line action = do { let verb = verbosity dflags ; showPass dflags phase_name ; debugTraceMsg dflags 3 (text cmd_line) - ; hFlush stderr + ; case flushErr dflags of + FlushErr io -> io -- And run it! ; action `catchIO` handle_exn verb @@ -970,7 +981,7 @@ getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32. where fail = panic ("can't decompose ghc.exe path: " ++ show s) lower = map toLower -foreign import stdcall unsafe "windows.h GetModuleFileNameW" +foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW" c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 #else getBaseDir = return Nothing diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 34afd5ca0e..8e4e7dd0a0 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -4,13 +4,6 @@ \section{Tidying up Core} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module TidyPgm ( mkBootModDetailsTc, tidyProgram, globaliseAndTidyId ) where @@ -24,10 +17,11 @@ import CoreUnfold import CoreFVs import CoreTidy import CoreMonad +import CorePrep import CoreUtils import Literal import Rules -import CoreArity ( exprArity, exprBotStrictness_maybe ) +import CoreArity ( exprArity, exprBotStrictness_maybe ) import VarEnv import VarSet import Var @@ -41,7 +35,10 @@ import Name hiding (varName) import NameSet import NameEnv import Avail +import PrelNames import IfaceEnv +import TcEnv +import TcRnMonad import TcType import DataCon import TyCon @@ -51,14 +48,17 @@ import Packages( isDllName ) import HscTypes import Maybes import UniqSupply +import ErrUtils (Severity(..)) import Outputable import FastBool hiding ( fastOr ) +import SrcLoc import Util import FastString -import Control.Monad ( when ) -import Data.List ( sortBy ) -import Data.IORef ( IORef, readIORef, writeIORef ) +import Control.Monad +import Data.Function +import Data.List ( sortBy ) +import Data.IORef ( readIORef, writeIORef ) \end{code} @@ -73,7 +73,7 @@ important for *this* module, but it's essential for ghc --make: subsequent compilations must not see (e.g.) the arity if the interface file does not contain arity If they do, they'll exploit the arity; then the arity might change, but the iface file doesn't change => -recompilation does not happen => disaster. +recompilation does not happen => disaster. For data types, the final TypeEnv will have a TyThing for the TyCon, plus one for each DataCon; the interface file will contain just one @@ -81,9 +81,9 @@ data type declaration, but it is de-serialised back into a collection of TyThings. %************************************************************************ -%* * - Plan A: simpleTidyPgm -%* * +%* * + Plan A: simpleTidyPgm +%* * %************************************************************************ @@ -91,19 +91,19 @@ Plan A: mkBootModDetails: omit pragmas, make interfaces small ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * Ignore the bindings -* Drop all WiredIn things from the TypeEnv - (we never want them in interface files) +* Drop all WiredIn things from the TypeEnv + (we never want them in interface files) * Retain all TyCons and Classes in the TypeEnv, to avoid - having to find which ones are mentioned in the - types of exported Ids + having to find which ones are mentioned in the + types of exported Ids * Trim off the constructors of non-exported TyCons, both - from the TyCon and from the TypeEnv + from the TyCon and from the TypeEnv * Drop non-exported Ids from the TypeEnv -* Tidy the types of the DFunIds of Instances, +* Tidy the types of the DFunIds of Instances, make them into GlobalIds, (they already have External Names) and add them to the TypeEnv @@ -113,7 +113,7 @@ Plan A: mkBootModDetails: omit pragmas, make interfaces small * Drop rules altogether * Tidy the bindings, to ensure that the Caf and Arity - information is correct for each top-level binder; the + information is correct for each top-level binder; the code generator needs it. And to ensure that local names have distinct OccNames in case of object-file splitting @@ -125,7 +125,7 @@ Plan A: mkBootModDetails: omit pragmas, make interfaces small -- for hs-boot files mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails -mkBootModDetailsTc hsc_env +mkBootModDetailsTc hsc_env TcGblEnv{ tcg_exports = exports, tcg_type_env = type_env, -- just for the Ids tcg_tcs = tcs, @@ -133,23 +133,23 @@ mkBootModDetailsTc hsc_env tcg_fam_insts = fam_insts } = do { let dflags = hsc_dflags hsc_env - ; showPass dflags CoreTidy + ; showPass dflags CoreTidy - ; let { insts' = tidyInstances globaliseAndTidyId insts - ; dfun_ids = map instanceDFunId insts' + ; let { insts' = tidyInstances globaliseAndTidyId insts + ; dfun_ids = map instanceDFunId insts' ; type_env1 = mkBootTypeEnv (availsToNameSet exports) (typeEnvIds type_env) tcs fam_insts - ; type_env' = extendTypeEnvWithIds type_env1 dfun_ids - } - ; return (ModDetails { md_types = type_env' - , md_insts = insts' - , md_fam_insts = fam_insts - , md_rules = [] - , md_anns = [] - , md_exports = exports + ; type_env' = extendTypeEnvWithIds type_env1 dfun_ids + } + ; return (ModDetails { md_types = type_env' + , md_insts = insts' + , md_fam_insts = fam_insts + , md_rules = [] + , md_anns = [] + , md_exports = exports , md_vect_info = noVectInfo }) - } + } where mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [FamInst] -> TypeEnv @@ -158,12 +158,12 @@ mkBootTypeEnv exports ids tcs fam_insts typeEnvFromEntities final_ids tcs fam_insts where -- Find the LocalIds in the type env that are exported - -- Make them into GlobalIds, and tidy their types - -- - -- It's very important to remove the non-exported ones - -- because we don't tidy the OccNames, and if we don't remove - -- the non-exported ones we'll get many things with the - -- same name in the interface file, giving chaos. + -- Make them into GlobalIds, and tidy their types + -- + -- It's very important to remove the non-exported ones + -- because we don't tidy the OccNames, and if we don't remove + -- the non-exported ones we'll get many things with the + -- same name in the interface file, giving chaos. -- -- Do make sure that we keep Ids that are already Global. -- When typechecking an .hs-boot file, the Ids come through as @@ -181,12 +181,12 @@ mkBootTypeEnv exports ids tcs fam_insts globaliseAndTidyId :: Id -> Id --- Takes an LocalId with an External Name, --- makes it into a GlobalId +-- Takes an LocalId with an External Name, +-- makes it into a GlobalId -- * unchanged Name (might be Internal or External) -- * unchanged details -- * VanillaIdInfo (makes a conservative assumption about Caf-hood) -globaliseAndTidyId id +globaliseAndTidyId id = Id.setIdType (globaliseId id) tidy_type where tidy_type = tidyTopType (idType id) @@ -194,18 +194,18 @@ globaliseAndTidyId id %************************************************************************ -%* * - Plan B: tidy bindings, make TypeEnv full of IdInfo -%* * +%* * + Plan B: tidy bindings, make TypeEnv full of IdInfo +%* * %************************************************************************ -Plan B: include pragmas, make interfaces +Plan B: include pragmas, make interfaces ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * Figure out which Ids are externally visible * Tidy the bindings, externalising appropriate Ids -* Drop all Ids from the TypeEnv, and add all the External Ids from +* Drop all Ids from the TypeEnv, and add all the External Ids from the bindings. (This adds their IdInfo to the TypeEnv; and adds floated-out Ids that weren't even in the TypeEnv before.) @@ -221,7 +221,7 @@ First we figure out which Ids are "external" Ids. An "external" Id is one that is visible from outside the compilation unit. These are a) the user exported ones - b) ones mentioned in the unfoldings, workers, + b) ones mentioned in the unfoldings, workers, rules of externally-visible ones , or vectorised versions of externally-visible ones @@ -256,8 +256,8 @@ Step 2: Tidy the program Next we traverse the bindings top to bottom. For each *top-level* binder - 1. Make it into a GlobalId; its IdDetails becomes VanillaGlobal, - reflecting the fact that from now on we regard it as a global, + 1. Make it into a GlobalId; its IdDetails becomes VanillaGlobal, + reflecting the fact that from now on we regard it as a global, not local, Id 2. Give it a system-wide Unique. @@ -268,7 +268,7 @@ binder source of such system-wide uniques. For external Ids, use the original-name cache in the NameCache - to ensure that the unique assigned is the same as the Id had + to ensure that the unique assigned is the same as the Id had in any previous compilation run. 3. Rename top-level Ids according to the names we chose in step 1. @@ -276,14 +276,14 @@ binder make it have an Internal Name. This is used by the code generator to decide whether to make the label externally visible - 4. Give it its UTTERLY FINAL IdInfo; in ptic, - * its unfolding, if it should have one - - * its arity, computed from the number of visible lambdas + 4. Give it its UTTERLY FINAL IdInfo; in ptic, + * its unfolding, if it should have one + + * its arity, computed from the number of visible lambdas + + * its CAF info, computed from what is free in its RHS - * its CAF info, computed from what is free in its RHS - Finally, substitute these new top-level binders consistently throughout, including in unfoldings. We also tidy binders in RHSs, so that they print nicely in interfaces. @@ -299,16 +299,19 @@ tidyProgram hsc_env (ModGuts { mg_module = mod , mg_rules = imp_rules , mg_vect_info = vect_info , mg_anns = anns - , mg_deps = deps + , mg_deps = deps , mg_foreign = foreign_stubs , mg_hpc_info = hpc_info - , mg_modBreaks = modBreaks + , mg_modBreaks = modBreaks }) = do { let { dflags = hsc_dflags hsc_env ; omit_prags = dopt Opt_OmitInterfacePragmas dflags ; expose_all = dopt Opt_ExposeAllUnfoldings dflags ; th = xopt Opt_TemplateHaskell dflags + ; data_kinds = xopt Opt_DataKinds dflags + ; no_trim_types = th || data_kinds + -- See Note [When we can't trim types] } ; showPass dflags CoreTidy @@ -320,29 +323,29 @@ tidyProgram hsc_env (ModGuts { mg_module = mod } ; (unfold_env, tidy_occ_env) - <- chooseExternalIds hsc_env mod omit_prags expose_all + <- chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_rules (vectInfoVar vect_info) ; let { ext_rules = findExternalRules omit_prags binds imp_rules unfold_env } -- Glom together imp_rules and rules currently attached to binders -- Then pick just the ones we need to expose -- See Note [Which rules to expose] - ; let { (tidy_env, tidy_binds) - = tidyTopBinds hsc_env unfold_env tidy_occ_env binds } + ; (tidy_env, tidy_binds) + <- tidyTopBinds hsc_env unfold_env tidy_occ_env binds - ; let { export_set = availsToNameSet exports - ; final_ids = [ id | id <- bindersOfBinds tidy_binds, - isExternalName (idName id)] + ; let { export_set = availsToNameSet exports + ; final_ids = [ id | id <- bindersOfBinds tidy_binds, + isExternalName (idName id)] - ; tidy_type_env = tidyTypeEnv omit_prags th export_set + ; tidy_type_env = tidyTypeEnv omit_prags no_trim_types export_set (extendTypeEnvWithIds type_env final_ids) ; tidy_insts = tidyInstances (lookup_dfun tidy_type_env) insts - -- A DFunId will have a binding in tidy_binds, and so - -- will now be in final_env, replete with IdInfo - -- Its name will be unchanged since it was born, but - -- we want Global, IdInfo-rich (or not) DFunId in the - -- tidy_insts + -- A DFunId will have a binding in tidy_binds, and so + -- will now be in final_env, replete with IdInfo + -- Its name will be unchanged since it was born, but + -- we want Global, IdInfo-rich (or not) DFunId in the + -- tidy_insts ; tidy_rules = tidyRules tidy_env ext_rules -- You might worry that the tidy_env contains IdInfo-rich stuff @@ -369,19 +372,20 @@ tidyProgram hsc_env (ModGuts { mg_module = mod -- If the endPass didn't print the rules, but ddump-rules is -- on, print now - ; dumpIfSet (dopt Opt_D_dump_rules dflags - && (not (dopt Opt_D_dump_simpl dflags))) - CoreTidy + ; dumpIfSet dflags (dopt Opt_D_dump_rules dflags + && (not (dopt Opt_D_dump_simpl dflags))) + CoreTidy (ptext (sLit "rules")) (pprRulesForUser tidy_rules) -- Print one-line size info ; let cs = coreBindsStats tidy_binds ; when (dopt Opt_D_dump_core_stats dflags) - (printDump (ptext (sLit "Tidy size (terms,types,coercions)") - <+> ppr (moduleName mod) <> colon - <+> int (cs_tm cs) - <+> int (cs_ty cs) + (log_action dflags dflags SevDump noSrcSpan defaultDumpStyle + (ptext (sLit "Tidy size (terms,types,coercions)") + <+> ppr (moduleName mod) <> colon + <+> int (cs_tm cs) + <+> int (cs_ty cs) <+> int (cs_co cs) )) ; return (CgGuts { cg_module = mod, @@ -390,44 +394,44 @@ tidyProgram hsc_env (ModGuts { mg_module = mod cg_foreign = foreign_stubs, cg_dep_pkgs = map fst $ dep_pkgs deps, cg_hpc_info = hpc_info, - cg_modBreaks = modBreaks }, + cg_modBreaks = modBreaks }, ModDetails { md_types = tidy_type_env, - md_rules = tidy_rules, - md_insts = tidy_insts, + md_rules = tidy_rules, + md_insts = tidy_insts, md_vect_info = tidy_vect_info, md_fam_insts = fam_insts, - md_exports = exports, - md_anns = anns -- are already tidy + md_exports = exports, + md_anns = anns -- are already tidy }) - } + } lookup_dfun :: TypeEnv -> Var -> Id lookup_dfun type_env dfun_id = case lookupTypeEnv type_env (idName dfun_id) of - Just (AnId dfun_id') -> dfun_id' - _other -> pprPanic "lookup_dfun" (ppr dfun_id) + Just (AnId dfun_id') -> dfun_id' + _other -> pprPanic "lookup_dfun" (ppr dfun_id) -------------------------- tidyTypeEnv :: Bool -- Compiling without -O, so omit prags - -> Bool -- Template Haskell is on + -> Bool -- Type-trimming flag -> NameSet -> TypeEnv -> TypeEnv -- The competed type environment is gotten from -- a) the types and classes defined here (plus implicit things) -- b) adding Ids with correct IdInfo, including unfoldings, --- gotten from the bindings +-- gotten from the bindings -- From (b) we keep only those Ids with External names; --- the CoreTidy pass makes sure these are all and only --- the externally-accessible ones --- This truncates the type environment to include only the +-- the CoreTidy pass makes sure these are all and only +-- the externally-accessible ones +-- This truncates the type environment to include only the -- exported Ids and things needed from them, which saves space -tidyTypeEnv omit_prags th exports type_env +tidyTypeEnv omit_prags no_trim_types exports type_env = let type_env1 = filterNameEnv (not . isWiredInName . getName) type_env -- (1) remove wired-in things - type_env2 | omit_prags = mapNameEnv (trimThing th exports) type_env1 + type_env2 | omit_prags = mapNameEnv (trimThing no_trim_types exports) type_env1 | otherwise = type_env1 -- (2) trimmed if necessary in @@ -436,64 +440,103 @@ tidyTypeEnv omit_prags th exports type_env -------------------------- trimThing :: Bool -> NameSet -> TyThing -> TyThing -- Trim off inessentials, for boot files and no -O -trimThing th exports (ATyCon tc) - | not th && not (mustExposeTyCon exports tc) - = ATyCon (makeTyConAbstract tc) -- Note [Trimming and Template Haskell] +trimThing no_trim_types exports (ATyCon tc) + | not (mustExposeTyCon no_trim_types exports tc) + = ATyCon (makeTyConAbstract tc) -- Note [When we can't trim types] trimThing _th _exports (AnId id) - | not (isImplicitId id) + | not (isImplicitId id) = AnId (id `setIdInfo` vanillaIdInfo) -trimThing _th _exports other_thing +trimThing _th _exports other_thing = other_thing -{- Note [Trimming and Template Haskell] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (Trac #2386) this - module M(T, makeOne) where - data T = Yay String - makeOne = [| Yay "Yep" |] +{- Note [When we can't trim types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The basic idea of type trimming is to export algebraic data types +abstractly (without their data constructors) when compiling without +-O, unless of course they are explicitly exported by the user. + +We always export synonyms, because they can be mentioned in the type +of an exported Id. We could do a full dependency analysis starting +from the explicit exports, but that's quite painful, and not done for +now. + +But there are some times we can't do that, indicated by the 'no_trim_types' flag. + +First, Template Haskell. Consider (Trac #2386) this + module M(T, makeOne) where + data T = Yay String + makeOne = [| Yay "Yep" |] Notice that T is exported abstractly, but makeOne effectively exports it too! A module that splices in $(makeOne) will then look for a declartion of Yay, so it'd better be there. Hence, brutally but simply, we switch off type -constructor trimming if TH is enabled in this module. -} - - -mustExposeTyCon :: NameSet -- Exports - -> TyCon -- The tycon - -> Bool -- Can its rep be hidden? --- We are compiling without -O, and thus trying to write as little as +constructor trimming if TH is enabled in this module. + +Second, data kinds. Consider (Trac #5912) + {-# LANGUAGE DataKinds #-} + module M() where + data UnaryTypeC a = UnaryDataC a + type Bug = 'UnaryDataC +We always export synonyms, so Bug is exposed, and that means that +UnaryTypeC must be too, even though it's not explicitly exported. In +effect, DataKinds means that we'd need to do a full dependency analysis +to see what data constructors are mentioned. But we don't do that yet. + +In these two cases we just switch off type trimming altogether. + -} + +mustExposeTyCon :: Bool -- Type-trimming flag + -> NameSet -- Exports + -> TyCon -- The tycon + -> Bool -- Can its rep be hidden? +-- We are compiling without -O, and thus trying to write as little as -- possible into the interface file. But we must expose the details of -- any data types whose constructors or fields are exported -mustExposeTyCon exports tc - | not (isAlgTyCon tc) -- Synonyms +mustExposeTyCon no_trim_types exports tc + | no_trim_types -- See Note [When we can't trim types] = True - | isEnumerationTyCon tc -- For an enumeration, exposing the constructors - = True -- won't lead to the need for further exposure - -- (This includes data types with no constructors.) - | isFamilyTyCon tc -- Open type family + + | not (isAlgTyCon tc) -- Always expose synonyms (otherwise we'd have to + -- figure out whether it was mentioned in the type + -- of any other exported thing) = True - | otherwise -- Newtype, datatype - = any exported_con (tyConDataCons tc) - -- Expose rep if any datacon or field is exported + | isEnumerationTyCon tc -- For an enumeration, exposing the constructors + = True -- won't lead to the need for further exposure - || (isNewTyCon tc && isFFITy (snd (newTyConRhs tc))) - -- Expose the rep for newtypes if the rep is an FFI type. - -- For a very annoying reason. 'Foreign import' is meant to - -- be able to look through newtypes transparently, but it - -- can only do that if it can "see" the newtype representation + | isFamilyTyCon tc -- Open type family + = True + + -- Below here we just have data/newtype decls or family instances + + | null data_cons -- Ditto if there are no data constructors + = True -- (NB: empty data types do not count as enumerations + -- see Note [Enumeration types] in TyCon + + | any exported_con data_cons -- Expose rep if any datacon or field is exported + = True + + | isNewTyCon tc && isFFITy (snd (newTyConRhs tc)) + = True -- Expose the rep for newtypes if the rep is an FFI type. + -- For a very annoying reason. 'Foreign import' is meant to + -- be able to look through newtypes transparently, but it + -- can only do that if it can "see" the newtype representation + + | otherwise + = False where - exported_con con = any (`elemNameSet` exports) - (dataConName con : dataConFieldLabels con) + data_cons = tyConDataCons tc + exported_con con = any (`elemNameSet` exports) + (dataConName con : dataConFieldLabels con) tidyInstances :: (DFunId -> DFunId) -> [ClsInst] -> [ClsInst] tidyInstances tidy_dfun ispecs = map tidy ispecs where tidy ispec = setInstanceDFunId ispec $ - tidy_dfun (instanceDFunId ispec) + tidy_dfun (instanceDFunId ispec) \end{code} \begin{code} @@ -516,18 +559,18 @@ tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar = vars , isDataConWorkId var || not (isImplicitId var) ] - tidy_scalarVars = mkVarSet [ lookup_var var + tidy_scalarVars = mkVarSet [ lookup_var var | var <- varSetElems scalarVars , isGlobalId var || isExportedId var] - + lookup_var var = lookupWithDefaultVarEnv var_env var var \end{code} %************************************************************************ -%* * - Implicit bindings -%* * +%* * + Implicit bindings +%* * %************************************************************************ Note [Injecting implicit bindings] @@ -535,9 +578,9 @@ Note [Injecting implicit bindings] We inject the implict bindings right at the end, in CoreTidy. Some of these bindings, notably record selectors, are not constructed in an optimised form. E.g. record selector for - data T = MkT { x :: {-# UNPACK #-} !Int } + data T = MkT { x :: {-# UNPACK #-} !Int } Then the unfolding looks like - x = \t. case t of MkT x1 -> let x = I# x1 in x + x = \t. case t of MkT x1 -> let x = I# x1 in x This generates bad code unless it's first simplified a bit. That is why CoreUnfold.mkImplicitUnfolding uses simleExprOpt to do a bit of optimisation first. (Only matters when the selector is used curried; @@ -562,15 +605,15 @@ Oh: two other reasons for injecting them late: - If implicit Ids are already in the bindings when we start TidyPgm, we'd have to be careful not to treat them as external Ids (in the sense of findExternalIds); else the Ids mentioned in *their* - RHSs will be treated as external and you get an interface file + RHSs will be treated as external and you get an interface file saying a18 = <blah> - but nothing refererring to a18 (because the implicit Id is the + but nothing refererring to a18 (because the implicit Id is the one that does, and implicit Ids don't appear in interface files). - More seriously, the tidied type-envt will include the implicit Id replete with a18 in its unfolding; but we won't take account of a18 when computing a fingerprint for the class; result chaos. - + There is one sort of implicit binding that is injected still later, namely those for data constructor workers. Reason (I think): it's really just a code generation trick.... binding itself makes no sense. @@ -589,9 +632,9 @@ get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id)) %************************************************************************ -%* * +%* * \subsection{Step 1: finding externals} -%* * +%* * %************************************************************************ See Note [Choosing external names]. @@ -600,7 +643,7 @@ See Note [Choosing external names]. type UnfoldEnv = IdEnv (Name{-new name-}, Bool {-show unfolding-}) -- Maps each top-level Id to its new Name (the Id is tidied in step 2) -- The Unique is unchanged. If the new Name is external, it will be - -- visible in the interface file. + -- visible in the interface file. -- -- Bool => expose unfolding or not. @@ -619,13 +662,13 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_ ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders ; tidy_internal internal_ids unfold_env1 occ_env1 } where - nc_var = hsc_NC hsc_env + nc_var = hsc_NC hsc_env -- init_ext_ids is the intial list of Ids that should be -- externalised. It serves as the starting point for finding a -- deterministic, tidy, renaming for all external Ids in this -- module. - -- + -- -- It is sorted, so that it has adeterministic order (i.e. it's the -- same list every time this module is compiled), in contrast to the -- bindings, which are ordered non-deterministically. @@ -648,32 +691,32 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_ avoids = [getOccName name | bndr <- binders ++ implicit_binders, let name = idName bndr, isExternalName name ] - -- In computing our "avoids" list, we must include - -- all implicit Ids - -- all things with global names (assigned once and for - -- all by the renamer) - -- since their names are "taken". - -- The type environment is a convenient source of such things. + -- In computing our "avoids" list, we must include + -- all implicit Ids + -- all things with global names (assigned once and for + -- all by the renamer) + -- since their names are "taken". + -- The type environment is a convenient source of such things. -- In particular, the set of binders doesn't include -- implicit Ids at this stage. - -- We also make sure to avoid any exported binders. Consider - -- f{-u1-} = 1 -- Local decl - -- ... - -- f{-u2-} = 2 -- Exported decl - -- - -- The second exported decl must 'get' the name 'f', so we - -- have to put 'f' in the avoids list before we get to the first - -- decl. tidyTopId then does a no-op on exported binders. + -- We also make sure to avoid any exported binders. Consider + -- f{-u1-} = 1 -- Local decl + -- ... + -- f{-u2-} = 2 -- Exported decl + -- + -- The second exported decl must 'get' the name 'f', so we + -- have to put 'f' in the avoids list before we get to the first + -- decl. tidyTopId then does a no-op on exported binders. init_occ_env = initTidyOccEnv avoids search :: [(Id,Id)] -- The work-list: (external id, referrring id) - -- Make a tidy, external Name for the external id, + -- Make a tidy, external Name for the external id, -- add it to the UnfoldEnv, and do the same for the -- transitive closure of Ids it refers to - -- The referring id is used to generate a tidy - --- name for the external id + -- The referring id is used to generate a tidy + --- name for the external id -> UnfoldEnv -- id -> (new Name, show_unfold) -> TidyOccEnv -- occ env for choosing new Names -> IO (UnfoldEnv, TidyOccEnv) @@ -684,13 +727,13 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_ | idocc `elemVarEnv` unfold_env = search rest unfold_env occ_env | otherwise = do (occ_env', name') <- tidyTopName mod nc_var (Just referrer) occ_env idocc - let + let (new_ids, show_unfold) | omit_prags = ([], False) | otherwise = addExternal expose_all refined_id - -- 'idocc' is an *occurrence*, but we need to see the - -- unfolding in the *definition*; so look up in binder_set + -- 'idocc' is an *occurrence*, but we need to see the + -- unfolding in the *definition*; so look up in binder_set refined_id = case lookupVarSet binder_set idocc of Just id -> id Nothing -> WARN( True, ppr idocc ) idocc @@ -713,35 +756,35 @@ addExternal :: Bool -> Id -> ([Id], Bool) addExternal expose_all id = (new_needed_ids, show_unfold) where new_needed_ids = bndrFvsInOrder show_unfold id - idinfo = idInfo id + idinfo = idInfo id show_unfold = show_unfolding (unfoldingInfo idinfo) never_active = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo)) loop_breaker = isStrongLoopBreaker (occInfo idinfo) bottoming_fn = isBottomingSig (strictnessInfo idinfo `orElse` topSig) - -- Stuff to do with the Id's unfolding - -- We leave the unfolding there even if there is a worker - -- In GHCi the unfolding is used by importers + -- Stuff to do with the Id's unfolding + -- We leave the unfolding there even if there is a worker + -- In GHCi the unfolding is used by importers show_unfolding (CoreUnfolding { uf_src = src, uf_guidance = guidance }) - = expose_all -- 'expose_all' says to expose all - -- unfoldings willy-nilly + = expose_all -- 'expose_all' says to expose all + -- unfoldings willy-nilly - || isStableSource src -- Always expose things whose - -- source is an inline rule + || isStableSource src -- Always expose things whose + -- source is an inline rule - || not (bottoming_fn -- No need to inline bottom functions - || never_active -- Or ones that say not to - || loop_breaker -- Or that are loop breakers - || neverUnfoldGuidance guidance) + || not (bottoming_fn -- No need to inline bottom functions + || never_active -- Or ones that say not to + || loop_breaker -- Or that are loop breakers + || neverUnfoldGuidance guidance) show_unfolding (DFunUnfolding {}) = True show_unfolding _ = False \end{code} %************************************************************************ -%* * +%* * Deterministic free variables -%* * +%* * %************************************************************************ We want a deterministic free-variable list. exprFreeVars gives us @@ -760,10 +803,10 @@ run :: DFFV () -> [Id] run (DFFV m) = case m emptyVarSet (emptyVarSet, []) of ((_,ids),_) -> ids -newtype DFFV a - = DFFV (VarSet -- Envt: non-top-level things that are in scope +newtype DFFV a + = DFFV (VarSet -- Envt: non-top-level things that are in scope -- we don't want to record these as free vars - -> (VarSet, [Var]) -- Input State: (set, list) of free vars so far + -> (VarSet, [Var]) -- Input State: (set, list) of free vars so far -> ((VarSet,[Var]),a)) -- Output state instance Monad DFFV where @@ -780,22 +823,22 @@ extendScopeList :: [Var] -> DFFV a -> DFFV a extendScopeList vs (DFFV f) = DFFV (\env st -> f (extendVarSetList env vs) st) insert :: Var -> DFFV () -insert v = DFFV $ \ env (set, ids) -> - let keep_me = isLocalId v && +insert v = DFFV $ \ env (set, ids) -> + let keep_me = isLocalId v && not (v `elemVarSet` env) && - not (v `elemVarSet` set) - in if keep_me + not (v `elemVarSet` set) + in if keep_me then ((extendVarSet set v, v:ids), ()) else ((set, ids), ()) dffvExpr :: CoreExpr -> DFFV () dffvExpr (Var v) = insert v -dffvExpr (App e1 e2) = dffvExpr e1 >> dffvExpr e2 -dffvExpr (Lam v e) = extendScope v (dffvExpr e) +dffvExpr (App e1 e2) = dffvExpr e1 >> dffvExpr e2 +dffvExpr (Lam v e) = extendScope v (dffvExpr e) dffvExpr (Tick (Breakpoint _ ids) e) = mapM_ insert ids >> dffvExpr e dffvExpr (Tick _other e) = dffvExpr e -dffvExpr (Cast e _) = dffvExpr e +dffvExpr (Cast e _) = dffvExpr e dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e) dffvExpr (Let (Rec prs) e) = extendScopeList (map fst prs) $ (mapM_ dffvBind prs >> dffvExpr e) @@ -806,11 +849,11 @@ dffvAlt :: (t, [Var], CoreExpr) -> DFFV () dffvAlt (_,xs,r) = extendScopeList xs (dffvExpr r) dffvBind :: (Id, CoreExpr) -> DFFV () -dffvBind(x,r) +dffvBind(x,r) | not (isId x) = dffvExpr r | otherwise = dffvLetBndr False x >> dffvExpr r - -- Pass False because we are doing the RHS right here - -- If you say True you'll get *exponential* behaviour! + -- Pass False because we are doing the RHS right here + -- If you say True you'll get *exponential* behaviour! dffvLetBndr :: Bool -> Id -> DFFV () -- Gather the free vars of the RULES and unfolding of a binder @@ -832,14 +875,14 @@ dffvLetBndr vanilla_unfold id = case src of InlineRhs | vanilla_unfold -> dffvExpr rhs | otherwise -> return () - InlineWrapper v -> insert v - _ -> dffvExpr rhs - -- For a wrapper, externalise the wrapper id rather than the - -- fvs of the rhs. The two usually come down to the same thing - -- but I've seen cases where we had a wrapper id $w but a - -- rhs where $w had been inlined; see Trac #3922 - - go_unf (DFunUnfolding _ _ args) = mapM_ dffvExpr args + InlineWrapper v -> insert v + _ -> dffvExpr rhs + -- For a wrapper, externalise the wrapper id rather than the + -- fvs of the rhs. The two usually come down to the same thing + -- but I've seen cases where we had a wrapper id $w but a + -- rhs where $w had been inlined; see Trac #3922 + + go_unf (DFunUnfolding _ _ args) = mapM_ dffvExpr (dfunArgExprs args) go_unf _ = return () go_rule (BuiltinRule {}) = return () @@ -849,57 +892,57 @@ dffvLetBndr vanilla_unfold id %************************************************************************ -%* * +%* * tidyTopName -%* * +%* * %************************************************************************ -This is where we set names to local/global based on whether they really are +This is where we set names to local/global based on whether they really are externally visible (see comment at the top of this module). If the name was previously local, we have to give it a unique occurrence name if we intend to externalise it. \begin{code} tidyTopName :: Module -> IORef NameCache -> Maybe Id -> TidyOccEnv - -> Id -> IO (TidyOccEnv, Name) + -> Id -> IO (TidyOccEnv, Name) tidyTopName mod nc_var maybe_ref occ_env id | global && internal = return (occ_env, localiseName name) | global && external = return (occ_env, name) - -- Global names are assumed to have been allocated by the renamer, - -- so they already have the "right" unique - -- And it's a system-wide unique too + -- Global names are assumed to have been allocated by the renamer, + -- so they already have the "right" unique + -- And it's a system-wide unique too -- Now we get to the real reason that all this is in the IO Monad: -- we have to update the name cache in a nice atomic fashion | local && internal = do { nc <- readIORef nc_var - ; let (nc', new_local_name) = mk_new_local nc - ; writeIORef nc_var nc' - ; return (occ_env', new_local_name) } - -- Even local, internal names must get a unique occurrence, because - -- if we do -split-objs we externalise the name later, in the code generator - -- - -- Similarly, we must make sure it has a system-wide Unique, because - -- the byte-code generator builds a system-wide Name->BCO symbol table + ; let (nc', new_local_name) = mk_new_local nc + ; writeIORef nc_var nc' + ; return (occ_env', new_local_name) } + -- Even local, internal names must get a unique occurrence, because + -- if we do -split-objs we externalise the name later, in the code generator + -- + -- Similarly, we must make sure it has a system-wide Unique, because + -- the byte-code generator builds a system-wide Name->BCO symbol table | local && external = do { nc <- readIORef nc_var - ; let (nc', new_external_name) = mk_new_external nc - ; writeIORef nc_var nc' - ; return (occ_env', new_external_name) } + ; let (nc', new_external_name) = mk_new_external nc + ; writeIORef nc_var nc' + ; return (occ_env', new_external_name) } | otherwise = panic "tidyTopName" where - name = idName id + name = idName id external = isJust maybe_ref - global = isExternalName name - local = not global - internal = not external - loc = nameSrcSpan name + global = isExternalName name + local = not global + internal = not external + loc = nameSrcSpan name old_occ = nameOccName name new_occ - | Just ref <- maybe_ref, ref /= id = + | Just ref <- maybe_ref, ref /= id = mkOccName (occNameSpace old_occ) $ let ref_str = occNameString (getOccName ref) @@ -921,42 +964,42 @@ tidyTopName mod nc_var maybe_ref occ_env id (occ_env', occ') = tidyOccName occ_env new_occ mk_new_local nc = (nc { nsUniqs = us }, mkInternalName uniq occ' loc) - where - (uniq, us) = takeUniqFromSupply (nsUniqs nc) + where + (uniq, us) = takeUniqFromSupply (nsUniqs nc) mk_new_external nc = allocateGlobalBinder nc mod occ' loc - -- If we want to externalise a currently-local name, check - -- whether we have already assigned a unique for it. - -- If so, use it; if not, extend the table. - -- All this is done by allcoateGlobalBinder. - -- This is needed when *re*-compiling a module in GHCi; we must - -- use the same name for externally-visible things as we did before. + -- If we want to externalise a currently-local name, check + -- whether we have already assigned a unique for it. + -- If so, use it; if not, extend the table. + -- All this is done by allcoateGlobalBinder. + -- This is needed when *re*-compiling a module in GHCi; we must + -- use the same name for externally-visible things as we did before. \end{code} \begin{code} -findExternalRules :: Bool -- Omit pragmas +findExternalRules :: Bool -- Omit pragmas -> [CoreBind] - -> [CoreRule] -- Local rules for imported fns - -> UnfoldEnv -- Ids that are exported, so we need their rules - -> [CoreRule] + -> [CoreRule] -- Local rules for imported fns + -> UnfoldEnv -- Ids that are exported, so we need their rules + -> [CoreRule] -- The complete rules are gotten by combining - -- a) local rules for imported Ids - -- b) rules embedded in the top-level Ids + -- a) local rules for imported Ids + -- b) rules embedded in the top-level Ids findExternalRules omit_prags binds imp_id_rules unfold_env | omit_prags = [] | otherwise = filterOut internal_rule (imp_id_rules ++ local_rules) where local_rules = [ rule - | id <- bindersOfBinds binds, + | id <- bindersOfBinds binds, external_id id, - rule <- idCoreRules id - ] + rule <- idCoreRules id + ] internal_rule rule - = any (not . external_id) (varSetElems (ruleLhsFreeIds rule)) - -- Don't export a rule whose LHS mentions a locally-defined - -- Id that is completely internal (i.e. not visible to an - -- importing module) + = any (not . external_id) (varSetElems (ruleLhsFreeIds rule)) + -- Don't export a rule whose LHS mentions a locally-defined + -- Id that is completely internal (i.e. not visible to an + -- importing module) external_id id | Just (name,_) <- lookupVarEnv unfold_env id = isExternalName name @@ -965,76 +1008,79 @@ findExternalRules omit_prags binds imp_id_rules unfold_env Note [Which rules to expose] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -findExternalRules filters imp_rules to avoid binders that -aren't externally visible; but the externally-visible binders +findExternalRules filters imp_rules to avoid binders that +aren't externally visible; but the externally-visible binders are computed (by findExternalIds) assuming that all orphan -rules are externalised (see init_ext_ids in function -'search'). So in fact we may export more than we need. +rules are externalised (see init_ext_ids in function +'search'). So in fact we may export more than we need. (It's a sort of mutual recursion.) %************************************************************************ -%* * +%* * \subsection{Step 2: top-level tidying} -%* * +%* * %************************************************************************ \begin{code} -- TopTidyEnv: when tidying we need to know --- * nc_var: The NameCache, containing a unique supply and any pre-ordained Names. --- These may have arisen because the --- renamer read in an interface file mentioning M.$wf, say, --- and assigned it unique r77. If, on this compilation, we've --- invented an Id whose name is $wf (but with a different unique) --- we want to rename it to have unique r77, so that we can do easy --- comparisons with stuff from the interface file +-- * nc_var: The NameCache, containing a unique supply and any pre-ordained Names. +-- These may have arisen because the +-- renamer read in an interface file mentioning M.$wf, say, +-- and assigned it unique r77. If, on this compilation, we've +-- invented an Id whose name is $wf (but with a different unique) +-- we want to rename it to have unique r77, so that we can do easy +-- comparisons with stuff from the interface file -- --- * occ_env: The TidyOccEnv, which tells us which local occurrences +-- * occ_env: The TidyOccEnv, which tells us which local occurrences -- are 'used' -- -- * subst_env: A Var->Var mapping that substitutes the new Var for the old tidyTopBinds :: HscEnv - -> UnfoldEnv + -> UnfoldEnv -> TidyOccEnv - -> CoreProgram - -> (TidyEnv, CoreProgram) + -> CoreProgram + -> IO (TidyEnv, CoreProgram) tidyTopBinds hsc_env unfold_env init_occ_env binds - = tidy init_env binds + = do mkIntegerId <- liftM tyThingId + $ initTcForLookup hsc_env (tcLookupGlobal mkIntegerName) + return $ tidy mkIntegerId init_env binds where init_env = (init_occ_env, emptyVarEnv) this_pkg = thisPackage (hsc_dflags hsc_env) - tidy env [] = (env, []) - tidy env (b:bs) = let (env1, b') = tidyTopBind this_pkg unfold_env env b - (env2, bs') = tidy env1 bs - in - (env2, b':bs') + tidy _ env [] = (env, []) + tidy mkIntegerId env (b:bs) = let (env1, b') = tidyTopBind this_pkg mkIntegerId unfold_env env b + (env2, bs') = tidy mkIntegerId env1 bs + in + (env2, b':bs') ------------------------ tidyTopBind :: PackageId + -> Id -> UnfoldEnv - -> TidyEnv + -> TidyEnv -> CoreBind - -> (TidyEnv, CoreBind) + -> (TidyEnv, CoreBind) -tidyTopBind this_pkg unfold_env (occ_env,subst1) (NonRec bndr rhs) +tidyTopBind this_pkg mkIntegerId unfold_env (occ_env,subst1) (NonRec bndr rhs) = (tidy_env2, NonRec bndr' rhs') where Just (name',show_unfold) = lookupVarEnv unfold_env bndr - caf_info = hasCafRefs this_pkg subst1 (idArity bndr) rhs + caf_info = hasCafRefs this_pkg (mkIntegerId, subst1) (idArity bndr) rhs (bndr', rhs') = tidyTopPair show_unfold tidy_env2 caf_info name' (bndr, rhs) subst2 = extendVarEnv subst1 bndr bndr' tidy_env2 = (occ_env, subst2) -tidyTopBind this_pkg unfold_env (occ_env,subst1) (Rec prs) +tidyTopBind this_pkg mkIntegerId unfold_env (occ_env,subst1) (Rec prs) = (tidy_env2, Rec prs') where prs' = [ tidyTopPair show_unfold tidy_env2 caf_info name' (id,rhs) | (id,rhs) <- prs, - let (name',show_unfold) = + let (name',show_unfold) = expectJust "tidyTopBind" $ lookupVarEnv unfold_env id ] @@ -1043,70 +1089,70 @@ tidyTopBind this_pkg unfold_env (occ_env,subst1) (Rec prs) bndrs = map fst prs - -- the CafInfo for a recursive group says whether *any* rhs in - -- the group may refer indirectly to a CAF (because then, they all do). - caf_info - | or [ mayHaveCafRefs (hasCafRefs this_pkg subst1 (idArity bndr) rhs) - | (bndr,rhs) <- prs ] = MayHaveCafRefs - | otherwise = NoCafRefs + -- the CafInfo for a recursive group says whether *any* rhs in + -- the group may refer indirectly to a CAF (because then, they all do). + caf_info + | or [ mayHaveCafRefs (hasCafRefs this_pkg (mkIntegerId, subst1) (idArity bndr) rhs) + | (bndr,rhs) <- prs ] = MayHaveCafRefs + | otherwise = NoCafRefs ----------------------------------------------------------- tidyTopPair :: Bool -- show unfolding - -> TidyEnv -- The TidyEnv is used to tidy the IdInfo - -- It is knot-tied: don't look at it! - -> CafInfo - -> Name -- New name - -> (Id, CoreExpr) -- Binder and RHS before tidying - -> (Id, CoreExpr) - -- This function is the heart of Step 2 - -- The rec_tidy_env is the one to use for the IdInfo - -- It's necessary because when we are dealing with a recursive - -- group, a variable late in the group might be mentioned - -- in the IdInfo of one early in the group + -> TidyEnv -- The TidyEnv is used to tidy the IdInfo + -- It is knot-tied: don't look at it! + -> CafInfo + -> Name -- New name + -> (Id, CoreExpr) -- Binder and RHS before tidying + -> (Id, CoreExpr) + -- This function is the heart of Step 2 + -- The rec_tidy_env is the one to use for the IdInfo + -- It's necessary because when we are dealing with a recursive + -- group, a variable late in the group might be mentioned + -- in the IdInfo of one early in the group tidyTopPair show_unfold rhs_tidy_env caf_info name' (bndr, rhs) = (bndr1, rhs1) where bndr1 = mkGlobalId details name' ty' idinfo' - details = idDetails bndr -- Preserve the IdDetails - ty' = tidyTopType (idType bndr) + details = idDetails bndr -- Preserve the IdDetails + ty' = tidyTopType (idType bndr) rhs1 = tidyExpr rhs_tidy_env rhs - idinfo' = tidyTopIdInfo rhs_tidy_env name' rhs rhs1 (idInfo bndr) + idinfo' = tidyTopIdInfo rhs_tidy_env name' rhs rhs1 (idInfo bndr) show_unfold caf_info -- tidyTopIdInfo creates the final IdInfo for top-level -- binders. There are two delicate pieces: -- -- * Arity. After CoreTidy, this arity must not change any more. --- Indeed, CorePrep must eta expand where necessary to make --- the manifest arity equal to the claimed arity. +-- Indeed, CorePrep must eta expand where necessary to make +-- the manifest arity equal to the claimed arity. -- -- * CAF info. This must also remain valid through to code generation. --- We add the info here so that it propagates to all --- occurrences of the binders in RHSs, and hence to occurrences in --- unfoldings, which are inside Ids imported by GHCi. Ditto RULES. --- CoreToStg makes use of this when constructing SRTs. -tidyTopIdInfo :: TidyEnv -> Name -> CoreExpr -> CoreExpr +-- We add the info here so that it propagates to all +-- occurrences of the binders in RHSs, and hence to occurrences in +-- unfoldings, which are inside Ids imported by GHCi. Ditto RULES. +-- CoreToStg makes use of this when constructing SRTs. +tidyTopIdInfo :: TidyEnv -> Name -> CoreExpr -> CoreExpr -> IdInfo -> Bool -> CafInfo -> IdInfo tidyTopIdInfo rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info - | not is_external -- For internal Ids (not externally visible) - = vanillaIdInfo -- we only need enough info for code generation - -- Arity and strictness info are enough; - -- c.f. CoreTidy.tidyLetBndr - `setCafInfo` caf_info - `setArityInfo` arity - `setStrictnessInfo` final_sig - - | otherwise -- Externally-visible Ids get the whole lot + | not is_external -- For internal Ids (not externally visible) + = vanillaIdInfo -- we only need enough info for code generation + -- Arity and strictness info are enough; + -- c.f. CoreTidy.tidyLetBndr + `setCafInfo` caf_info + `setArityInfo` arity + `setStrictnessInfo` final_sig + + | otherwise -- Externally-visible Ids get the whole lot = vanillaIdInfo - `setCafInfo` caf_info - `setArityInfo` arity - `setStrictnessInfo` final_sig + `setCafInfo` caf_info + `setArityInfo` arity + `setStrictnessInfo` final_sig `setOccInfo` robust_occ_info - `setInlinePragInfo` (inlinePragInfo idinfo) - `setUnfoldingInfo` unfold_info - -- NB: we throw away the Rules - -- They have already been extracted by findExternalRules + `setInlinePragInfo` (inlinePragInfo idinfo) + `setUnfoldingInfo` unfold_info + -- NB: we throw away the Rules + -- They have already been extracted by findExternalRules where is_external = isExternalName name @@ -1132,9 +1178,9 @@ tidyTopIdInfo rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info --------- Unfolding ------------ unf_info = unfoldingInfo idinfo unfold_info | show_unfold = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs - | otherwise = noUnfolding + | otherwise = noUnfolding unf_from_rhs = mkTopUnfolding is_bot tidy_rhs - is_bot = case final_sig of + is_bot = case final_sig of Just sig -> isBottomingSig sig Nothing -> False -- NB: do *not* expose the worker if show_unfold is off, @@ -1143,17 +1189,17 @@ tidyTopIdInfo rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info -- This is important: if you expose the worker for a loop-breaker -- then you can make the simplifier go into an infinite loop, because -- in effect the unfolding is exposed. See Trac #1709 - -- + -- -- You might think that if show_unfold is False, then the thing should -- not be w/w'd in the first place. But a legitimate reason is this: - -- the function returns bottom + -- the function returns bottom -- In this case, show_unfold will be false (we don't expose unfoldings -- for bottoming functions), but we might still have a worker/wrapper -- split (see Note [Worker-wrapper for bottoming functions] in WorkWrap.lhs --------- Arity ------------ -- Usually the Id will have an accurate arity on it, because - -- the simplifier has just run, but not always. + -- the simplifier has just run, but not always. -- One case I found was when the last thing the simplifier -- did was to let-bind a non-atomic argument and then float -- it to the top level. So it seems more robust just to @@ -1162,9 +1208,9 @@ tidyTopIdInfo rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info \end{code} %************************************************************************ -%* * +%* * \subsection{Figuring out CafInfo for an expression} -%* * +%* * %************************************************************************ hasCafRefs decides whether a top-level closure can point into the dynamic heap. @@ -1173,55 +1219,56 @@ used to decide whether a particular closure needs to be referenced in an SRT or not. There are two reasons for setting MayHaveCafRefs: - a) The RHS is a CAF: a top-level updatable thunk. - b) The RHS refers to something that MayHaveCafRefs + a) The RHS is a CAF: a top-level updatable thunk. + b) The RHS refers to something that MayHaveCafRefs -Possible improvement: In an effort to keep the number of CAFs (and -hence the size of the SRTs) down, we could also look at the expression and -decide whether it requires a small bounded amount of heap, so we can ignore +Possible improvement: In an effort to keep the number of CAFs (and +hence the size of the SRTs) down, we could also look at the expression and +decide whether it requires a small bounded amount of heap, so we can ignore it as a CAF. In these cases however, we would need to use an additional -CAF list to keep track of non-collectable CAFs. +CAF list to keep track of non-collectable CAFs. \begin{code} -hasCafRefs :: PackageId -> VarEnv Var -> Arity -> CoreExpr -> CafInfo -hasCafRefs this_pkg p arity expr +hasCafRefs :: PackageId -> (Id, VarEnv Var) -> Arity -> CoreExpr -> CafInfo +hasCafRefs this_pkg p arity expr | is_caf || mentions_cafs = MayHaveCafRefs - | otherwise = NoCafRefs + | otherwise = NoCafRefs where mentions_cafs = isFastTrue (cafRefsE p expr) - is_dynamic_name = isDllName this_pkg + is_dynamic_name = isDllName this_pkg is_caf = not (arity > 0 || rhsIsStatic is_dynamic_name expr) -- NB. we pass in the arity of the expression, which is expected -- to be calculated by exprArity. This is because exprArity - -- knows how much eta expansion is going to be done by + -- knows how much eta expansion is going to be done by -- CorePrep later on, and we don't want to duplicate that -- knowledge in rhsIsStatic below. -cafRefsE :: VarEnv Id -> Expr a -> FastBool +cafRefsE :: (Id, VarEnv Id) -> Expr a -> FastBool cafRefsE p (Var id) = cafRefsV p id -cafRefsE p (Lit lit) = cafRefsL p lit -cafRefsE p (App f a) = fastOr (cafRefsE p f) (cafRefsE p) a -cafRefsE p (Lam _ e) = cafRefsE p e -cafRefsE p (Let b e) = fastOr (cafRefsEs p (rhssOfBind b)) (cafRefsE p) e +cafRefsE p (Lit lit) = cafRefsL p lit +cafRefsE p (App f a) = fastOr (cafRefsE p f) (cafRefsE p) a +cafRefsE p (Lam _ e) = cafRefsE p e +cafRefsE p (Let b e) = fastOr (cafRefsEs p (rhssOfBind b)) (cafRefsE p) e cafRefsE p (Case e _bndr _ alts) = fastOr (cafRefsE p e) (cafRefsEs p) (rhssOfAlts alts) cafRefsE p (Tick _n e) = cafRefsE p e -cafRefsE p (Cast e _co) = cafRefsE p e -cafRefsE _ (Type _) = fastBool False -cafRefsE _ (Coercion _) = fastBool False +cafRefsE p (Cast e _co) = cafRefsE p e +cafRefsE _ (Type _) = fastBool False +cafRefsE _ (Coercion _) = fastBool False -cafRefsEs :: VarEnv Id -> [Expr a] -> FastBool -cafRefsEs _ [] = fastBool False +cafRefsEs :: (Id, VarEnv Id) -> [Expr a] -> FastBool +cafRefsEs _ [] = fastBool False cafRefsEs p (e:es) = fastOr (cafRefsE p e) (cafRefsEs p) es -cafRefsL :: VarEnv Id -> Literal -> FastBool --- Don't forget that the embeded mk_integer id might have Caf refs! --- See Note [Integer literals] in Literal -cafRefsL p (LitInteger _ mk_integer) = cafRefsV p mk_integer +cafRefsL :: (Id, VarEnv Id) -> Literal -> FastBool +-- Don't forget that mk_integer id might have Caf refs! +-- We first need to convert the Integer into its final form, to +-- see whether mkInteger is used. +cafRefsL p@(mk_integer, _) (LitInteger i _) = cafRefsE p (cvtLitInteger mk_integer i) cafRefsL _ _ = fastBool False -cafRefsV :: VarEnv Id -> Id -> FastBool -cafRefsV p id +cafRefsV :: (Id, VarEnv Id) -> Id -> FastBool +cafRefsV (_, p) id | not (isLocalId id) = fastBool (mayHaveCafRefs (idCafInfo id)) | Just id' <- lookupVarEnv p id = fastBool (mayHaveCafRefs (idCafInfo id')) | otherwise = fastBool False |