diff options
Diffstat (limited to 'ghc')
| -rw-r--r-- | ghc/GHCi/Leak.hs | 77 | ||||
| -rw-r--r-- | ghc/GHCi/UI.hs | 173 | ||||
| -rw-r--r-- | ghc/GHCi/UI/Info.hs | 22 | ||||
| -rw-r--r-- | ghc/GHCi/UI/Monad.hs | 34 | ||||
| -rw-r--r-- | ghc/GHCi/UI/Tags.hs | 5 | ||||
| -rw-r--r-- | ghc/Main.hs | 64 | ||||
| -rw-r--r-- | ghc/ghc-bin.cabal.in | 17 | ||||
| -rw-r--r-- | ghc/ghc.mk | 13 | ||||
| -rw-r--r-- | ghc/hschooks.c | 2 |
9 files changed, 329 insertions, 78 deletions
diff --git a/ghc/GHCi/Leak.hs b/ghc/GHCi/Leak.hs new file mode 100644 index 0000000000..47fed9c28f --- /dev/null +++ b/ghc/GHCi/Leak.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE RecordWildCards, LambdaCase, MagicHash, UnboxedTuples #-} +module GHCi.Leak + ( LeakIndicators + , getLeakIndicators + , checkLeakIndicators + ) where + +import Control.Monad +import Data.Bits +import DynFlags (settings, sTargetPlatform) +import Foreign.Ptr (ptrToIntPtr, intPtrToPtr) +import GHC +import GHC.Exts (anyToAddr#) +import GHC.Ptr (Ptr (..)) +import GHC.Types (IO (..)) +import HscTypes +import Outputable +import Platform (target32Bit) +import Prelude +import System.Mem +import System.Mem.Weak +import UniqDFM + +-- Checking for space leaks in GHCi. See #15111, and the +-- -fghci-leak-check flag. + +data LeakIndicators = LeakIndicators [LeakModIndicators] + +data LeakModIndicators = LeakModIndicators + { leakMod :: Weak HomeModInfo + , leakIface :: Weak ModIface + , leakDetails :: Weak ModDetails + , leakLinkable :: Maybe (Weak Linkable) + } + +-- | Grab weak references to some of the data structures representing +-- the currently loaded modules. +getLeakIndicators :: HscEnv -> IO LeakIndicators +getLeakIndicators HscEnv{..} = + fmap LeakIndicators $ + forM (eltsUDFM hsc_HPT) $ \hmi@HomeModInfo{..} -> do + leakMod <- mkWeakPtr hmi Nothing + leakIface <- mkWeakPtr hm_iface Nothing + leakDetails <- mkWeakPtr hm_details Nothing + leakLinkable <- mapM (`mkWeakPtr` Nothing) hm_linkable + return $ LeakModIndicators{..} + +-- | Look at the LeakIndicators collected by an earlier call to +-- `getLeakIndicators`, and print messasges if any of them are still +-- alive. +checkLeakIndicators :: DynFlags -> LeakIndicators -> IO () +checkLeakIndicators dflags (LeakIndicators leakmods) = do + performGC + forM_ leakmods $ \LeakModIndicators{..} -> do + deRefWeak leakMod >>= \case + Nothing -> return () + Just hmi -> + report ("HomeModInfo for " ++ + showSDoc dflags (ppr (mi_module (hm_iface hmi)))) (Just hmi) + deRefWeak leakIface >>= report "ModIface" + deRefWeak leakDetails >>= report "ModDetails" + forM_ leakLinkable $ \l -> deRefWeak l >>= report "Linkable" + where + report :: String -> Maybe a -> IO () + report _ Nothing = return () + report msg (Just a) = do + addr <- IO (\s -> case anyToAddr# a s of + (# s', addr #) -> (# s', Ptr addr #)) :: IO (Ptr ()) + putStrLn ("-fghci-leak-check: " ++ msg ++ " is still alive at " ++ + show (maskTagBits addr)) + + tagBits + | target32Bit (sTargetPlatform (settings dflags)) = 2 + | otherwise = 3 + + maskTagBits :: Ptr a -> Ptr a + maskTagBits p = intPtrToPtr (ptrToIntPtr p .&. complement (shiftL 1 tagBits - 1)) diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index 8012d741e0..1f862de4cb 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -43,15 +43,17 @@ import GHCi.RemoteTypes import GHCi.BreakArray import DynFlags import ErrUtils hiding (traceCmd) +import Finder import GhcMonad ( modifySession ) import qualified GHC import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..), TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc, + GetDocsFailure(..), getModuleGraph, handleSourceError ) import HsImpExp import HsSyn import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC, - setInteractivePrintName, hsc_dflags ) + setInteractivePrintName, hsc_dflags, msObjFilePath ) import Module import Name import Packages ( trusted, getPackageDetails, getInstalledPackageDetails, @@ -98,10 +100,12 @@ import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub, partition, sort, sortBy ) import qualified Data.Set as S import Data.Maybe +import Data.Map (Map) import qualified Data.Map as M import Data.Time.LocalTime ( getZonedTime ) import Data.Time.Format ( formatTime, defaultTimeLocale ) import Data.Version ( showVersion ) +import Prelude hiding ((<>)) import Exception hiding (catch) import Foreign hiding (void) @@ -132,6 +136,8 @@ import GHC.IO.Exception ( IOErrorType(InvalidArgument) ) import GHC.IO.Handle ( hFlushAll ) import GHC.TopHandler ( topHandler ) +import GHCi.Leak + ----------------------------------------------------------------------------- data GhciSettings = GhciSettings { @@ -175,6 +181,7 @@ ghciCommands = map mkCmd [ ("def", keepGoing (defineMacro False), completeExpression), ("def!", keepGoing (defineMacro True), completeExpression), ("delete", keepGoing deleteCmd, noCompletion), + ("doc", keepGoing' docCmd, completeIdentifier), ("edit", keepGoing' editFile, completeFilename), ("etags", keepGoing createETagsFileCmd, completeFilename), ("force", keepGoing forceCmd, completeExpression), @@ -207,6 +214,7 @@ ghciCommands = map mkCmd [ ("stepmodule",keepGoing stepModuleCmd, completeIdentifier), ("type", keepGoing' typeOfExpr, completeExpression), ("trace", keepGoing traceCmd, completeExpression), + ("unadd", keepGoingPaths unAddModule, completeFilename), ("undef", keepGoing undefineMacro, completeMacro), ("unset", keepGoing unsetOptions, completeSetOptions), ("where", keepGoing whereCmd, noCompletion) @@ -283,6 +291,7 @@ defFullHelpText = " (!: use regex instead of line number)\n" ++ " :def <cmd> <expr> define command :<cmd> (later defined command has\n" ++ " precedence, ::<cmd> is always a builtin command)\n" ++ + " :doc <name> display docs for the given name (experimental)\n" ++ " :edit <file> edit file\n" ++ " :edit edit last module\n" ++ " :etags [<file>] create tags file <file> for Emacs (default: \"TAGS\")\n" ++ @@ -304,6 +313,7 @@ defFullHelpText = " :type <expr> show the type of <expr>\n" ++ " :type +d <expr> show the type of <expr>, defaulting type variables\n" ++ " :type +v <expr> show the type of <expr>, with its specified tyvars\n" ++ + " :unadd <module> ... remove module(s) from the current target set\n" ++ " :undef <cmd> undefine user-defined command :<cmd>\n" ++ " :!<command> run the shell command <command>\n" ++ "\n" ++ @@ -370,6 +380,7 @@ defFullHelpText = " :show packages show the currently active package flags\n" ++ " :show paths show the currently active search paths\n" ++ " :show language show the currently active language flags\n" ++ + " :show targets show the current set of targets\n" ++ " :show <setting> show value of <setting>, which is one of\n" ++ " [args, prog, editor, stop]\n" ++ " :showi language show language flags for interactive evaluation\n" ++ @@ -786,16 +797,14 @@ checkPromptStringForErrors (_:xs) = checkPromptStringForErrors xs checkPromptStringForErrors "" = Nothing generatePromptFunctionFromString :: String -> PromptFunction -generatePromptFunctionFromString promptS = \_ _ -> do - (context, modules_names, line) <- getInfoForPrompt - - let +generatePromptFunctionFromString promptS modules_names line = + processString promptS + where processString :: String -> GHCi SDoc processString ('%':'s':xs) = liftM2 (<>) (return modules_list) (processString xs) where - modules_list = context <> modules_bit - modules_bit = hsep $ map text modules_names + modules_list = hsep $ map text modules_names processString ('%':'l':xs) = liftM2 (<>) (return $ ppr line) (processString xs) processString ('%':'d':xs) = @@ -856,8 +865,6 @@ generatePromptFunctionFromString promptS = \_ _ -> do processString "" = return empty - processString promptS - mkPrompt :: GHCi String mkPrompt = do st <- getGHCiState @@ -882,7 +889,10 @@ installInteractivePrint :: Maybe String -> Bool -> GHCi () installInteractivePrint Nothing _ = return () installInteractivePrint (Just ipFun) exprmode = do ok <- trySuccess $ do - (name:_) <- GHC.parseName ipFun + names <- GHC.parseName ipFun + let name = case names of + name':_ -> name' + [] -> panic "installInteractivePrint" modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name in he{hsc_IC = new_ic}) return Succeeded @@ -1078,6 +1088,10 @@ enqueueCommands cmds = do runStmt :: String -> SingleStep -> GHCi (Maybe GHC.ExecResult) runStmt stmt step = do dflags <- GHC.getInteractiveDynFlags + -- In GHCi, we disable `-fdefer-type-errors`, as well as `-fdefer-type-holes` + -- and `-fdefer-out-of-scope-variables` for **naked expressions**. The + -- declarations and statements are not affected. + -- See Note [Deferred type errors in GHCi] in typecheck/TcRnDriver.hs if | GHC.isStmt dflags stmt -> run_stmt | GHC.isImport dflags stmt -> run_import -- Every import declaration should be handled by `run_import`. As GHCi @@ -1513,7 +1527,7 @@ defineMacro overwrite s = do body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step) `mkHsApp` (nlHsPar expr) tySig = mkLHsSigWcType (stringTy `nlHsFunTy` ioM) - new_expr = L (getLoc expr) $ ExprWithTySig body tySig + new_expr = L (getLoc expr) $ ExprWithTySig tySig body hv <- GHC.compileParsedExprRemote new_expr let newCmd = Command { cmdName = macro_name @@ -1577,7 +1591,7 @@ getGhciStepIO = do ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy body = nlHsVar (getRdrName ghciStepIoMName) tySig = mkLHsSigWcType (ghciM `nlHsFunTy` ioM) - return $ noLoc $ ExprWithTySig body tySig + return $ noLoc $ ExprWithTySig tySig body ----------------------------------------------------------------------------- -- :check @@ -1601,6 +1615,38 @@ checkModule m = do return True afterLoad (successIf ok) False +----------------------------------------------------------------------------- +-- :doc + +docCmd :: String -> InputT GHCi () +docCmd "" = + throwGhcException (CmdLineError "syntax: ':doc <thing-you-want-docs-for>'") +docCmd s = do + -- TODO: Maybe also get module headers for module names + names <- GHC.parseName s + e_docss <- mapM GHC.getDocs names + sdocs <- mapM (either handleGetDocsFailure (pure . pprDocs)) e_docss + let sdocs' = vcat (intersperse (text "") sdocs) + unqual <- GHC.getPrintUnqual + dflags <- getDynFlags + (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs' + +-- TODO: also print arg docs. +pprDocs :: (Maybe HsDocString, Map Int HsDocString) -> SDoc +pprDocs (mb_decl_docs, _arg_docs) = + maybe + (text "<has no documentation>") + (text . unpackHDS) + mb_decl_docs + +handleGetDocsFailure :: GHC.GhcMonad m => GetDocsFailure -> m SDoc +handleGetDocsFailure no_docs = do + dflags <- getDynFlags + let msg = showPpr dflags no_docs + throwGhcException $ case no_docs of + NameHasNoModule {} -> Sorry msg + NoDocsInIface {} -> InstallationError msg + InteractiveName -> ProgramError msg ----------------------------------------------------------------------------- -- :load, :add, :reload @@ -1641,6 +1687,15 @@ loadModule' files = do -- require some re-working of the GHC interface, so we'll leave it -- as a ToDo for now. + hsc_env <- GHC.getSession + + -- Grab references to the currently loaded modules so that we can + -- see if they leak. + let !dflags = hsc_dflags hsc_env + leak_indicators <- if gopt Opt_GhciLeakCheck dflags + then liftIO $ getLeakIndicators hsc_env + else return (panic "no leak indicators") + -- unload first _ <- GHC.abandonAll lift discardActiveBreakPoints @@ -1648,7 +1703,10 @@ loadModule' files = do _ <- GHC.load LoadAllTargets GHC.setTargets targets - doLoadAndCollectInfo False LoadAllTargets + success <- doLoadAndCollectInfo False LoadAllTargets + when (gopt Opt_GhciLeakCheck dflags) $ + liftIO $ checkLeakIndicators dflags leak_indicators + return success -- | @:add@ command addModule :: [FilePath] -> InputT GHCi () @@ -1656,9 +1714,39 @@ addModule files = do lift revertCAFs -- always revert CAFs on load/add. files' <- mapM expandPath files targets <- mapM (\m -> GHC.guessTarget m Nothing) files' + targets' <- filterM checkTarget targets -- remove old targets with the same id; e.g. for :add *M + mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets' ] + mapM_ GHC.addTarget targets' + _ <- doLoadAndCollectInfo False LoadAllTargets + return () + where + checkTarget :: Target -> InputT GHCi Bool + checkTarget (Target (TargetModule m) _ _) = checkTargetModule m + checkTarget (Target (TargetFile f _) _ _) = liftIO $ checkTargetFile f + + checkTargetModule :: ModuleName -> InputT GHCi Bool + checkTargetModule m = do + hsc_env <- GHC.getSession + result <- liftIO $ + Finder.findImportedModule hsc_env m (Just (fsLit "this")) + case result of + Found _ _ -> return True + _ -> (liftIO $ putStrLn $ + "Module " ++ moduleNameString m ++ " not found") >> return False + + checkTargetFile :: String -> IO Bool + checkTargetFile f = do + exists <- (doesFileExist f) :: IO Bool + unless exists $ putStrLn $ "File " ++ f ++ " not found" + return exists + +-- | @:unadd@ command +unAddModule :: [FilePath] -> InputT GHCi () +unAddModule files = do + files' <- mapM expandPath files + targets <- mapM (\m -> GHC.guessTarget m Nothing) files' mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ] - mapM_ GHC.addTarget targets _ <- doLoadAndCollectInfo False LoadAllTargets return () @@ -1725,7 +1813,7 @@ afterLoad ok retain_context = do lift revertCAFs -- always revert CAFs on load. lift discardTickArrays loaded_mods <- getLoadedModules - modulesLoadedMsg ok (length loaded_mods) + modulesLoadedMsg ok loaded_mods lift $ setContextAfterLoad retain_context loaded_mods setContextAfterLoad :: Bool -> [GHC.ModSummary] -> GHCi () @@ -1801,22 +1889,36 @@ keepPackageImports = filterM is_pkg_import mod_name = unLoc (ideclName d) -modulesLoadedMsg :: SuccessFlag -> Int -> InputT GHCi () -modulesLoadedMsg ok num_mods = do +modulesLoadedMsg :: SuccessFlag -> [GHC.ModSummary] -> InputT GHCi () +modulesLoadedMsg ok mods = do dflags <- getDynFlags unqual <- GHC.getPrintUnqual - let status = case ok of - Failed -> text "Failed" - Succeeded -> text "Ok" - num_mods_pp = if num_mods == 1 - then "1 module" - else int num_mods <+> "modules" - msg = status <> text "," <+> num_mods_pp <+> "loaded." + msg <- if gopt Opt_ShowLoadedModules dflags + then do + mod_names <- mapM mod_name mods + let mod_commas + | null mods = text "none." + | otherwise = hsep (punctuate comma mod_names) <> text "." + return $ status <> text ", modules loaded:" <+> mod_commas + else do + return $ status <> text "," + <+> speakNOf (length mods) (text "module") <+> "loaded." when (verbosity dflags > 0) $ liftIO $ putStrLn $ showSDocForUser dflags unqual msg - + where + status = case ok of + Failed -> text "Failed" + Succeeded -> text "Ok" + + mod_name mod = do + is_interpreted <- GHC.moduleIsBootOrNotObjectLinkable mod + return $ if is_interpreted + then ppr (GHC.ms_mod mod) + else ppr (GHC.ms_mod mod) + <+> parens (text $ normalise $ msObjFilePath mod) + -- Fix #9887 -- | Run an 'ExceptT' wrapped 'GhcMonad' while handling source errors -- and printing 'throwE' strings to 'stderr' @@ -2510,7 +2612,9 @@ showDynFlags show_all dflags = do is_on = test f dflags quiet = not show_all && test f default_dflags == is_on - default_dflags = defaultDynFlags (settings dflags) + llvmConfig = (llvmTargets dflags, llvmPasses dflags) + + default_dflags = defaultDynFlags (settings dflags) llvmConfig (ghciFlags,others) = partition (\f -> flagSpecFlag f `elem` flgs) DynFlags.fFlags @@ -2764,6 +2868,7 @@ showCmd str = do , action "language" $ showLanguages , hidden "languages" $ showLanguages -- backwards compat , hidden "lang" $ showLanguages -- useful abbreviation + , action "targets" $ showTargets ] case words str of @@ -2920,12 +3025,22 @@ showLanguages' show_all dflags = is_on = test f dflags quiet = not show_all && test f default_dflags == is_on + llvmConfig = (llvmTargets dflags, llvmPasses dflags) + default_dflags = - defaultDynFlags (settings dflags) `lang_set` + defaultDynFlags (settings dflags) llvmConfig `lang_set` case language dflags of Nothing -> Just Haskell2010 other -> other +showTargets :: GHCi () +showTargets = mapM_ showTarget =<< GHC.getTargets + where + showTarget :: Target -> GHCi () + showTarget (Target (TargetFile f _) _ _) = liftIO (putStrLn f) + showTarget (Target (TargetModule m) _ _) = + liftIO (putStrLn $ moduleNameString m) + -- ----------------------------------------------------------------------------- -- Completion @@ -3137,7 +3252,7 @@ stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg case mb_span of Nothing -> stepCmd [] Just loc -> do - Just md <- getCurrentBreakModule + md <- fromMaybe (panic "stepLocalCmd") <$> getCurrentBreakModule current_toplevel_decl <- enclosingTickSpan md loc doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl) GHC.SingleStep @@ -3628,7 +3743,7 @@ turnOffBreak loc = do getModBreak :: Module -> GHCi (ForeignRef BreakArray, Array Int SrcSpan) getModBreak m = do - Just mod_info <- GHC.getModuleInfo m + mod_info <- fromMaybe (panic "getModBreak") <$> GHC.getModuleInfo m let modBreaks = GHC.modInfoModBreaks mod_info let arr = GHC.modBreaks_flags modBreaks let ticks = GHC.modBreaks_locs modBreaks diff --git a/ghc/GHCi/UI/Info.hs b/ghc/GHCi/UI/Info.hs index a114ebff29..0b354f93e7 100644 --- a/ghc/GHCi/UI/Info.hs +++ b/ghc/GHCi/UI/Info.hs @@ -3,7 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} --- | Get information on modules, expreesions, and identifiers +-- | Get information on modules, expressions, and identifiers module GHCi.UI.Info ( ModInfo(..) , SpanInfo(..) @@ -27,7 +27,7 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe import Data.Time -import Prelude hiding (mod) +import Prelude hiding (mod,(<>)) import System.Directory import qualified CoreUtils @@ -276,7 +276,9 @@ collectInfo ms loaded = do cacheInvalid name = case M.lookup name ms of Nothing -> return True Just mi -> do - let fp = ml_obj_file (ms_location (modinfoSummary mi)) + let src_fp = ml_hs_file (ms_location (modinfoSummary mi)) + obj_fp = ml_obj_file (ms_location (modinfoSummary mi)) + fp = fromMaybe obj_fp src_fp last' = modinfoLastUpdate mi exists <- doesFileExist fp if exists @@ -309,7 +311,7 @@ processAllTypeCheckedModule tcm = do -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsBind's getTypeLHsBind :: LHsBind GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type)) - getTypeLHsBind (L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _typ _}) + getTypeLHsBind (L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _}) = pure $ Just (Just (unLoc pid),getLoc pid,varType (unLoc pid)) getTypeLHsBind _ = pure Nothing @@ -321,19 +323,19 @@ processAllTypeCheckedModule tcm = do return $ fmap (\expr -> (mid, getLoc e, CoreUtils.exprType expr)) mbe where mid :: Maybe Id - mid | HsVar (L _ i) <- unwrapVar (unLoc e) = Just i - | otherwise = Nothing + mid | HsVar _ (L _ i) <- unwrapVar (unLoc e) = Just i + | otherwise = Nothing - unwrapVar (HsWrap _ var) = var - unwrapVar e' = e' + unwrapVar (HsWrap _ _ var) = var + unwrapVar e' = e' -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LPats's getTypeLPat :: LPat GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type)) getTypeLPat (L spn pat) = pure (Just (getMaybeId pat,spn,hsPatType pat)) where - getMaybeId (VarPat (L _ vid)) = Just vid - getMaybeId _ = Nothing + getMaybeId (VarPat _ (L _ vid)) = Just vid + getMaybeId _ = Nothing -- | Get ALL source spans in the source. listifyAllSpans :: Typeable a => TypecheckedSource -> [Located a] diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs index 46f0860ab9..45a52712da 100644 --- a/ghc/GHCi/UI/Monad.hs +++ b/ghc/GHCi/UI/Monad.hs @@ -55,12 +55,14 @@ import Data.Time import System.Environment import System.IO import Control.Monad +import Prelude hiding ((<>)) import System.Console.Haskeline (CompletionFunc, InputT) import qualified System.Console.Haskeline as Haskeline import Control.Monad.Trans.Class import Control.Monad.IO.Class import Data.Map.Strict (Map) +import qualified GHC.LanguageExtensions as LangExt ----------------------------------------------------------------------------- -- GHCi monad @@ -420,15 +422,13 @@ foreign import ccall "revertCAFs" rts_revertCAFs :: IO () -- | Compile "hFlush stdout; hFlush stderr" once, so we can use it repeatedly initInterpBuffering :: Ghc (ForeignHValue, ForeignHValue) initInterpBuffering = do - -- We take great care not to use do-notation in the expressions below, as - -- they are fragile in the presence of RebindableSyntax (Trac #13385). - nobuf <- GHC.compileExprRemote $ - " System.IO.hSetBuffering System.IO.stdin System.IO.NoBuffering" ++ - "`GHC.Base.thenIO` System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++ - "`GHC.Base.thenIO` System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering" - flush <- GHC.compileExprRemote $ - " System.IO.hFlush System.IO.stdout" ++ - "`GHC.Base.thenIO` System.IO.hFlush System.IO.stderr" + nobuf <- compileGHCiExpr $ + "do { System.IO.hSetBuffering System.IO.stdin System.IO.NoBuffering; " ++ + " System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering; " ++ + " System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering }" + flush <- compileGHCiExpr $ + "do { System.IO.hFlush System.IO.stdout; " ++ + " System.IO.hFlush System.IO.stderr }" return (nobuf, flush) -- | Invoke "hFlush stdout; hFlush stderr" in the interpreter @@ -451,6 +451,20 @@ turnOffBuffering_ fhv = do mkEvalWrapper :: GhcMonad m => String -> [String] -> m ForeignHValue mkEvalWrapper progname args = - GHC.compileExprRemote $ + compileGHCiExpr $ "\\m -> System.Environment.withProgName " ++ show progname ++ "(System.Environment.withArgs " ++ show args ++ " m)" + +compileGHCiExpr :: GhcMonad m => String -> m ForeignHValue +compileGHCiExpr expr = do + hsc_env <- getSession + let dflags = hsc_dflags hsc_env + -- RebindableSyntax can wreak havoc with GHCi in several ways + -- (see #13385 and #14342 for examples), so we take care to disable it + -- for the duration of running expressions that are internal to GHCi. + no_rb_hsc_env = + hsc_env { hsc_dflags = xopt_unset dflags LangExt.RebindableSyntax } + setSession no_rb_hsc_env + res <- GHC.compileExprRemote expr + setSession hsc_env + pure res diff --git a/ghc/GHCi/UI/Tags.hs b/ghc/GHCi/UI/Tags.hs index d8af7f8718..09a8406d96 100644 --- a/ghc/GHCi/UI/Tags.hs +++ b/ghc/GHCi/UI/Tags.hs @@ -25,13 +25,14 @@ import OccName (pprOccName) import ConLike import MonadUtils +import Control.Monad import Data.Function +import Data.List import Data.Maybe import Data.Ord import DriverPhases import Panic -import Data.List -import Control.Monad +import Prelude import System.Directory import System.IO import System.IO.Error diff --git a/ghc/Main.hs b/ghc/Main.hs index a75aba3e97..03ac60db2d 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -40,6 +40,7 @@ import Module ( ModuleName ) -- Various other random stuff that we need +import GHC.HandleEncoding import Config import Constants import HscTypes @@ -73,6 +74,7 @@ import Control.Monad import Data.Char import Data.List import Data.Maybe +import Prelude ----------------------------------------------------------------------------- -- ToDo: @@ -92,18 +94,7 @@ main = do hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering - -- Handle GHC-specific character encoding flags, allowing us to control how - -- GHC produces output regardless of OS. - env <- getEnvironment - case lookup "GHC_CHARENC" env of - Just "UTF-8" -> do - hSetEncoding stdout utf8 - hSetEncoding stderr utf8 - _ -> do - -- Avoid GHC erroring out when trying to display unhandled characters - hSetTranslit stdout - hSetTranslit stderr - + configureHandleEncoding GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do -- 1. extract the -B flag from the args argv0 <- getArgs @@ -179,10 +170,16 @@ main' postLoadMode dflags0 args flagWarnings = do -- can be overriden from the command-line -- XXX: this should really be in the interactive DynFlags, but -- we don't set that until later in interactiveUI - dflags2 | DoInteractive <- postLoadMode = imp_qual_enabled - | DoEval _ <- postLoadMode = imp_qual_enabled + -- We also set -fignore-optim-changes and -fignore-hpc-changes, + -- which are program-level options. Again, this doesn't really + -- feel like the right place to handle this, but we don't have + -- a great story for the moment. + dflags2 | DoInteractive <- postLoadMode = def_ghci_flags + | DoEval _ <- postLoadMode = def_ghci_flags | otherwise = dflags1 - where imp_qual_enabled = dflags1 `gopt_set` Opt_ImplicitImportQualified + where def_ghci_flags = dflags1 `gopt_set` Opt_ImplicitImportQualified + `gopt_set` Opt_IgnoreOptimChanges + `gopt_set` Opt_IgnoreHpcChanges -- The rest of the arguments are "dynamic" -- Leftover ones are presumably files @@ -216,9 +213,23 @@ main' postLoadMode dflags0 args flagWarnings = do let -- To simplify the handling of filepaths, we normalise all filepaths right - -- away - e.g., for win32 platforms, backslashes are converted - -- into forward slashes. - normal_fileish_paths = map (normalise . unLoc) fileish_args + -- away. Note the asymmetry of FilePath.normalise: + -- Linux: p/q -> p/q; p\q -> p\q + -- Windows: p/q -> p\q; p\q -> p\q + -- #12674: Filenames starting with a hypen get normalised from ./-foo.hs + -- to -foo.hs. We have to re-prepend the current directory. + normalise_hyp fp + | strt_dot_sl && "-" `isPrefixOf` nfp = cur_dir ++ nfp + | otherwise = nfp + where +#if defined(mingw32_HOST_OS) + strt_dot_sl = "./" `isPrefixOf` fp || ".\\" `isPrefixOf` fp +#else + strt_dot_sl = "./" `isPrefixOf` fp +#endif + cur_dir = '.' : [pathSeparator] + nfp = normalise fp + normal_fileish_paths = map (normalise_hyp . unLoc) fileish_args (srcs, objs) = partition_args normal_fileish_paths [] [] dflags5 = dflags4 { ldInputs = map (FileOption "") objs @@ -804,12 +815,12 @@ dumpFastStringStats dflags = do ]) -- we usually get more "has z-encoding" than "z-encoded", because -- when we z-encode a string it might hash to the exact same string, - -- which will is not counted as "z-encoded". Only strings whose + -- which is not counted as "z-encoded". Only strings whose -- Z-encoding is different from the original string are counted in -- the "z-encoded" total. putMsg dflags msg where - x `pcntOf` y = int ((x * 100) `quot` y) <> char '%' + x `pcntOf` y = int ((x * 100) `quot` y) Outputable.<> char '%' countFS :: Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int) countFS entries longest has_z [] = (entries, longest, has_z) @@ -933,5 +944,18 @@ people since we're linking GHC dynamically, but most things themselves link statically. -} +-- If GHC_LOADED_INTO_GHCI is not set when GHC is loaded into GHCi, then +-- running it causes an error like this: +-- +-- Loading temp shared object failed: +-- /tmp/ghc13836_0/libghc_1872.so: undefined symbol: initGCStatistics +-- +-- Skipping the foreign call fixes this problem, and the outer GHCi +-- should have already made this call anyway. +#if defined(GHC_LOADED_INTO_GHCI) +initGCStatistics :: IO () +initGCStatistics = return () +#else foreign import ccall safe "initGCStatistics" initGCStatistics :: IO () +#endif diff --git a/ghc/ghc-bin.cabal.in b/ghc/ghc-bin.cabal.in index b04c13a6c1..5c51058d81 100644 --- a/ghc/ghc-bin.cabal.in +++ b/ghc/ghc-bin.cabal.in @@ -38,18 +38,23 @@ Executable ghc ghc == @ProjectVersionMunged@ if os(windows) - Build-Depends: Win32 >= 2.3 && < 2.6 + Build-Depends: Win32 >= 2.3 && < 2.7 else - Build-Depends: unix == 2.7.* + Build-Depends: unix >= 2.7 && < 2.9 C-Sources: hschooks.c GHC-Options: -Wall + -Wnoncanonical-monad-instances + -Wnoncanonical-monadfail-instances + -Wnoncanonical-monoid-instances + if flag(ghci) -- NB: this is never built by the bootstrapping GHC+libraries Build-depends: - containers == 0.5.*, + containers >= 0.5 && < 0.7, deepseq == 1.4.*, + ghc-prim == 0.5.*, ghci == @ProjectVersionMunged@, haskeline == 0.7.*, time == 1.8.*, @@ -57,6 +62,7 @@ Executable ghc CPP-Options: -DGHCI GHC-Options: -fno-warn-name-shadowing Other-Modules: + GHCi.Leak GHCi.UI GHCi.UI.Info GHCi.UI.Monad @@ -78,3 +84,8 @@ Executable ghc CPP NondecreasingIndentation TupleSections + + -- This should match the default-extensions used in 'ghc.cabal'. This way, + -- GHCi can be used to load it all at once. + Default-Extensions: + NoImplicitPrelude diff --git a/ghc/ghc.mk b/ghc/ghc.mk index 319f969c75..6e329352ef 100644 --- a/ghc/ghc.mk +++ b/ghc/ghc.mk @@ -132,6 +132,12 @@ all_ghc_stage3 : $(GHC_STAGE3) $(INPLACE_LIB)/settings : settings "$(CP)" $< $@ +$(INPLACE_LIB)/llvm-targets : llvm-targets + "$(CP)" $< $@ + +$(INPLACE_LIB)/llvm-passes : llvm-passes + "$(CP)" $< $@ + $(INPLACE_LIB)/platformConstants: $(includes_GHCCONSTANTS_HASKELL_VALUE) "$(CP)" $< $@ @@ -140,6 +146,8 @@ $(INPLACE_LIB)/platformConstants: $(includes_GHCCONSTANTS_HASKELL_VALUE) GHC_DEPENDENCIES += $$(unlit_INPLACE) GHC_DEPENDENCIES += $(INPLACE_LIB)/settings +GHC_DEPENDENCIES += $(INPLACE_LIB)/llvm-targets +GHC_DEPENDENCIES += $(INPLACE_LIB)/llvm-passes GHC_DEPENDENCIES += $(INPLACE_LIB)/platformConstants $(GHC_STAGE1) : | $(GHC_DEPENDENCIES) @@ -167,11 +175,13 @@ $(GHC_STAGE2) : $(foreach w,$(GhcLibWays),libraries/base/dist-install/build/GHC/ endif INSTALL_LIBS += settings +INSTALL_LIBS += llvm-targets +INSTALL_LIBS += llvm-passes ifeq "$(Windows_Host)" "NO" install: install_ghc_link .PHONY: install_ghc_link -install_ghc_link: +install_ghc_link: $(call removeFiles,"$(DESTDIR)$(bindir)/$(CrossCompilePrefix)ghc") $(LN_S) $(CrossCompilePrefix)ghc-$(ProjectVersion) "$(DESTDIR)$(bindir)/$(CrossCompilePrefix)ghc" else @@ -183,4 +193,3 @@ install_ghc_post: install_bins $(call removeFiles,"$(DESTDIR)$(bindir)/ghc.exe") "$(MV)" -f $(DESTDIR)$(bindir)/ghc-stage$(INSTALL_GHC_STAGE).exe $(DESTDIR)$(bindir)/$(CrossCompilePrefix)ghc.exe endif - diff --git a/ghc/hschooks.c b/ghc/hschooks.c index 031cb02d1a..87feab370a 100644 --- a/ghc/hschooks.c +++ b/ghc/hschooks.c @@ -63,11 +63,9 @@ StackOverflowHook (StgWord stack_size) /* in bytes */ int main (int argc, char *argv[]) { RtsConfig conf = defaultRtsConfig; -#if __GLASGOW_HASKELL__ >= 711 conf.defaultsHook = defaultsHook; conf.rts_opts_enabled = RtsOptsAll; conf.stackOverflowHook = StackOverflowHook; -#endif extern StgClosure ZCMain_main_closure; hs_main(argc, argv, &ZCMain_main_closure, conf); |