diff options
Diffstat (limited to 'compiler/main')
45 files changed, 4011 insertions, 2296 deletions
diff --git a/compiler/main/Annotations.hs b/compiler/main/Annotations.hs index 052b0615e7..f6d5a1cb12 100644 --- a/compiler/main/Annotations.hs +++ b/compiler/main/Annotations.hs @@ -17,6 +17,8 @@ module Annotations ( deserializeAnns ) where +import GhcPrelude + import Binary import Module ( Module ) import Name diff --git a/compiler/main/Ar.hs b/compiler/main/Ar.hs new file mode 100644 index 0000000000..814b71e248 --- /dev/null +++ b/compiler/main/Ar.hs @@ -0,0 +1,269 @@ +{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, CPP #-} +{- Note: [The need for Ar.hs] +Building `-staticlib` required the presence of libtool, and was a such +restricted to mach-o only. As libtool on macOS and gnu libtool are very +different, there was no simple portable way to support this. + +libtool for static archives does essentially: concatinate the input archives, +add the input objects, and create a symbol index. Using `ar` for this task +fails as even `ar` (bsd and gnu, llvm, ...) do not provide the same +features across platforms (e.g. index prefixed retrieval of objects with +the same name.) + +As Archives are rather simple structurally, we can just build the archives +with Haskell directly and use ranlib on the final result to get the symbol +index. This should allow us to work around with the differences/abailability +of libtool across differet platforms. +-} +module Ar + (ArchiveEntry(..) + ,Archive(..) + ,afilter + + ,parseAr + + ,loadAr + ,loadObj + ,writeBSDAr + ,writeGNUAr + + ,isBSDSymdef + ,isGNUSymdef + ) + where + +import GhcPrelude + +import Data.Semigroup (Semigroup) +import Data.List (mapAccumL, isPrefixOf) +import Data.Monoid ((<>)) +import Data.Binary.Get +import Data.Binary.Put +import Control.Monad +import Control.Applicative +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString.Lazy as L +#if !defined(mingw32_HOST_OS) +import qualified System.Posix.Files as POSIX +#endif +import System.FilePath (takeFileName) + +data ArchiveEntry = ArchiveEntry + { filename :: String -- ^ File name. + , filetime :: Int -- ^ File modification time. + , fileown :: Int -- ^ File owner. + , filegrp :: Int -- ^ File group. + , filemode :: Int -- ^ File mode. + , filesize :: Int -- ^ File size. + , filedata :: B.ByteString -- ^ File bytes. + } deriving (Eq, Show) + +newtype Archive = Archive [ArchiveEntry] + deriving (Eq, Show, Semigroup, Monoid) + +afilter :: (ArchiveEntry -> Bool) -> Archive -> Archive +afilter f (Archive xs) = Archive (filter f xs) + +isBSDSymdef, isGNUSymdef :: ArchiveEntry -> Bool +isBSDSymdef a = "__.SYMDEF" `isPrefixOf` (filename a) +isGNUSymdef a = "/" == (filename a) + +-- | Archives have numeric values padded with '\x20' to the right. +getPaddedInt :: B.ByteString -> Int +getPaddedInt = read . C.unpack . C.takeWhile (/= '\x20') + +putPaddedInt :: Int -> Int -> Put +putPaddedInt padding i = putPaddedString '\x20' padding (show i) + +putPaddedString :: Char -> Int -> String -> Put +putPaddedString pad padding s = putByteString . C.pack . take padding $ s `mappend` (repeat pad) + +getBSDArchEntries :: Get [ArchiveEntry] +getBSDArchEntries = do + empty <- isEmpty + if empty then + return [] + else do + name <- getByteString 16 + when ('/' `C.elem` name && C.take 3 name /= "#1/") $ + fail "Looks like GNU Archive" + time <- getPaddedInt <$> getByteString 12 + own <- getPaddedInt <$> getByteString 6 + grp <- getPaddedInt <$> getByteString 6 + mode <- getPaddedInt <$> getByteString 8 + st_size <- getPaddedInt <$> getByteString 10 + end <- getByteString 2 + when (end /= "\x60\x0a") $ + fail ("[BSD Archive] Invalid archive header end marker for name: " ++ + C.unpack name) + off1 <- liftM fromIntegral bytesRead :: Get Int + -- BSD stores extended filenames, by writing #1/<length> into the + -- name field, the first @length@ bytes then represent the file name + -- thus the payload size is filesize + file name length. + name <- if C.unpack (C.take 3 name) == "#1/" then + liftM (C.unpack . C.takeWhile (/= '\0')) (getByteString $ read $ C.unpack $ C.drop 3 name) + else + return $ C.unpack $ C.takeWhile (/= ' ') name + off2 <- liftM fromIntegral bytesRead :: Get Int + file <- getByteString (st_size - (off2 - off1)) + -- data sections are two byte aligned (see Trac #15396) + when (odd st_size) $ + void (getByteString 1) + + rest <- getBSDArchEntries + return $ (ArchiveEntry name time own grp mode (st_size - (off2 - off1)) file) : rest + +-- | GNU Archives feature a special '//' entry that contains the +-- extended names. Those are referred to as /<num>, where num is the +-- offset into the '//' entry. +-- In addition, filenames are terminated with '/' in the archive. +getGNUArchEntries :: Maybe ArchiveEntry -> Get [ArchiveEntry] +getGNUArchEntries extInfo = do + empty <- isEmpty + if empty + then return [] + else + do + name <- getByteString 16 + time <- getPaddedInt <$> getByteString 12 + own <- getPaddedInt <$> getByteString 6 + grp <- getPaddedInt <$> getByteString 6 + mode <- getPaddedInt <$> getByteString 8 + st_size <- getPaddedInt <$> getByteString 10 + end <- getByteString 2 + when (end /= "\x60\x0a") $ + fail ("[BSD Archive] Invalid archive header end marker for name: " ++ + C.unpack name) + file <- getByteString st_size + -- data sections are two byte aligned (see Trac #15396) + when (odd st_size) $ + void (getByteString 1) + name <- return . C.unpack $ + if C.unpack (C.take 1 name) == "/" + then case C.takeWhile (/= ' ') name of + name@"/" -> name -- symbol table + name@"//" -> name -- extendedn file names table + name -> getExtName extInfo (read . C.unpack $ C.drop 1 name) + else C.takeWhile (/= '/') name + case name of + "/" -> getGNUArchEntries extInfo + "//" -> getGNUArchEntries (Just (ArchiveEntry name time own grp mode st_size file)) + _ -> (ArchiveEntry name time own grp mode st_size file :) <$> getGNUArchEntries extInfo + + where + getExtName :: Maybe ArchiveEntry -> Int -> B.ByteString + getExtName Nothing _ = error "Invalid extended filename reference." + getExtName (Just info) offset = C.takeWhile (/= '/') . C.drop offset $ filedata info + +-- | put an Archive Entry. This assumes that the entries +-- have been preprocessed to account for the extenden file name +-- table section "//" e.g. for GNU Archives. Or that the names +-- have been move into the payload for BSD Archives. +putArchEntry :: ArchiveEntry -> PutM () +putArchEntry (ArchiveEntry name time own grp mode st_size file) = do + putPaddedString ' ' 16 name + putPaddedInt 12 time + putPaddedInt 6 own + putPaddedInt 6 grp + putPaddedInt 8 mode + putPaddedInt 10 (st_size + pad) + putByteString "\x60\x0a" + putByteString file + when (pad == 1) $ + putWord8 0x0a + where + pad = st_size `mod` 2 + +getArchMagic :: Get () +getArchMagic = do + magic <- liftM C.unpack $ getByteString 8 + if magic /= "!<arch>\n" + then fail $ "Invalid magic number " ++ show magic + else return () + +putArchMagic :: Put +putArchMagic = putByteString $ C.pack "!<arch>\n" + +getArch :: Get Archive +getArch = Archive <$> do + getArchMagic + getBSDArchEntries <|> getGNUArchEntries Nothing + +putBSDArch :: Archive -> PutM () +putBSDArch (Archive as) = do + putArchMagic + mapM_ putArchEntry (processEntries as) + + where + padStr pad size str = take size $ str <> repeat pad + nameSize name = case length name `divMod` 4 of + (n, 0) -> 4 * n + (n, _) -> 4 * (n + 1) + needExt name = length name > 16 || ' ' `elem` name + processEntry :: ArchiveEntry -> ArchiveEntry + processEntry archive@(ArchiveEntry name _ _ _ _ st_size _) + | needExt name = archive { filename = "#1/" <> show sz + , filedata = C.pack (padStr '\0' sz name) <> filedata archive + , filesize = st_size + sz } + | otherwise = archive + + where sz = nameSize name + + processEntries = map processEntry + +putGNUArch :: Archive -> PutM () +putGNUArch (Archive as) = do + putArchMagic + mapM_ putArchEntry (processEntries as) + + where + processEntry :: ArchiveEntry -> ArchiveEntry -> (ArchiveEntry, ArchiveEntry) + processEntry extInfo archive@(ArchiveEntry name _ _ _ _ _ _) + | length name > 15 = ( extInfo { filesize = filesize extInfo + length name + 2 + , filedata = filedata extInfo <> C.pack name <> "/\n" } + , archive { filename = "/" <> show (filesize extInfo) } ) + | otherwise = ( extInfo, archive { filename = name <> "/" } ) + + processEntries :: [ArchiveEntry] -> [ArchiveEntry] + processEntries = + uncurry (:) . mapAccumL processEntry (ArchiveEntry "//" 0 0 0 0 0 mempty) + +parseAr :: B.ByteString -> Archive +parseAr = runGet getArch . L.fromChunks . pure + +writeBSDAr, writeGNUAr :: FilePath -> Archive -> IO () +writeBSDAr fp = L.writeFile fp . runPut . putBSDArch +writeGNUAr fp = L.writeFile fp . runPut . putGNUArch + +loadAr :: FilePath -> IO Archive +loadAr fp = parseAr <$> B.readFile fp + +loadObj :: FilePath -> IO ArchiveEntry +loadObj fp = do + payload <- B.readFile fp + (modt, own, grp, mode) <- fileInfo fp + return $ ArchiveEntry + (takeFileName fp) modt own grp mode + (B.length payload) payload + +-- | Take a filePath and return (mod time, own, grp, mode in decimal) +fileInfo :: FilePath -> IO ( Int, Int, Int, Int) -- ^ mod time, own, grp, mode (in decimal) +#if defined(mingw32_HOST_OS) +-- on windows mod time, owner group and mode are zero. +fileInfo _ = pure (0,0,0,0) +#else +fileInfo fp = go <$> POSIX.getFileStatus fp + where go status = ( fromEnum $ POSIX.modificationTime status + , fromIntegral $ POSIX.fileOwner status + , fromIntegral $ POSIX.fileGroup status + , oct2dec . fromIntegral $ POSIX.fileMode status + ) + +oct2dec :: Int -> Int +oct2dec = foldl' (\a b -> a * 10 + b) 0 . reverse . dec 8 + where dec _ 0 = [] + dec b i = let (rest, last) = i `quotRem` b + in last:dec b rest + +#endif diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs index e6ecd17bdf..cb30b6fe6c 100644 --- a/compiler/main/CmdLineParser.hs +++ b/compiler/main/CmdLineParser.hs @@ -25,6 +25,8 @@ module CmdLineParser #include "HsVersions.h" +import GhcPrelude + import Util import Outputable import Panic @@ -77,8 +79,6 @@ data OptKind m -- Suppose the flag is -f | FloatSuffix (Float -> EwM m ()) -- -f or -f=n; pass n to fn | PassFlag (String -> EwM m ()) -- -f; pass "-f" fn | AnySuffix (String -> EwM m ()) -- -f or -farg; pass entire "-farg" to fn - | PrefixPred (String -> Bool) (String -> EwM m ()) - | AnySuffixPred (String -> Bool) (String -> EwM m ()) -------------------------------------------------------- @@ -240,11 +240,9 @@ processOneArg opt_kind rest arg args [] -> missingArgErr dash_arg (L _ arg1:args1) -> Right (f arg1, args1) + -- See Trac #12625 Prefix f | notNull rest_no_eq -> Right (f rest_no_eq, args) - | otherwise -> unknownFlagErr dash_arg - - PrefixPred _ f | notNull rest_no_eq -> Right (f rest_no_eq, args) - | otherwise -> unknownFlagErr dash_arg + | otherwise -> missingArgErr dash_arg PassFlag f | notNull rest -> unknownFlagErr dash_arg | otherwise -> Right (f dash_arg, args) @@ -261,7 +259,6 @@ processOneArg opt_kind rest arg args OptPrefix f -> Right (f rest_no_eq, args) AnySuffix f -> Right (f dash_arg, args) - AnySuffixPred _ f -> Right (f dash_arg, args) findArg :: [Flag m] -> String -> Maybe (String, OptKind m) findArg spec arg = @@ -279,15 +276,14 @@ arg_ok :: OptKind t -> [Char] -> String -> Bool arg_ok (NoArg _) rest _ = null rest arg_ok (HasArg _) _ _ = True arg_ok (SepArg _) rest _ = null rest -arg_ok (Prefix _) rest _ = notNull rest -arg_ok (PrefixPred p _) rest _ = notNull rest && p (dropEq rest) +arg_ok (Prefix _) _ _ = True -- Missing argument checked for in processOneArg t + -- to improve error message (Trac #12625) arg_ok (OptIntSuffix _) _ _ = True arg_ok (IntSuffix _) _ _ = True arg_ok (FloatSuffix _) _ _ = True arg_ok (OptPrefix _) _ _ = True arg_ok (PassFlag _) rest _ = null rest arg_ok (AnySuffix _) _ _ = True -arg_ok (AnySuffixPred p _) _ arg = p arg -- | Parse an Int -- diff --git a/compiler/main/CodeOutput.hs b/compiler/main/CodeOutput.hs index 34cada3ff9..478de594ac 100644 --- a/compiler/main/CodeOutput.hs +++ b/compiler/main/CodeOutput.hs @@ -10,6 +10,8 @@ module CodeOutput( codeOutput, outputForeignStubs ) where #include "HsVersions.h" +import GhcPrelude + import AsmCodeGen ( nativeCodeGen ) import LlvmCodeGen ( llvmCodeGen ) @@ -36,7 +38,6 @@ import Control.Exception import System.Directory import System.FilePath import System.IO -import Control.Monad (forM) {- ************************************************************************ @@ -51,7 +52,7 @@ codeOutput :: DynFlags -> FilePath -> ModLocation -> ForeignStubs - -> [(ForeignSrcLang, String)] + -> [(ForeignSrcLang, FilePath)] -- ^ additional files to be compiled with with the C compiler -> [InstalledUnitId] -> Stream IO RawCmmGroup () -- Compiled C-- @@ -59,7 +60,7 @@ codeOutput :: DynFlags (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}), [(ForeignSrcLang, FilePath)]{-foreign_fps-}) -codeOutput dflags this_mod filenm location foreign_stubs foreign_files pkg_deps +codeOutput dflags this_mod filenm location foreign_stubs foreign_fps pkg_deps cmm_stream = do { @@ -87,10 +88,6 @@ codeOutput dflags this_mod filenm location foreign_stubs foreign_files pkg_deps } ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs - ; foreign_fps <- forM foreign_files $ \(lang, file_contents) -> do - { fp <- outputForeignFile dflags lang file_contents; - ; return (lang, fp); - } ; case hscTarget dflags of { HscAsm -> outputAsm dflags this_mod location filenm linted_cmm_stream; @@ -268,14 +265,3 @@ outputForeignStubs_help fname doc_str header footer = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n") return True -outputForeignFile :: DynFlags -> ForeignSrcLang -> String -> IO FilePath -outputForeignFile dflags lang file_contents - = do - extension <- case lang of - LangC -> return "c" - LangCxx -> return "cpp" - LangObjc -> return "m" - LangObjcxx -> return "mm" - fp <- newTempName dflags TFL_CurrentModule extension - writeFile fp file_contents - return fp diff --git a/compiler/main/Constants.hs b/compiler/main/Constants.hs index 3dafbac996..7eda130917 100644 --- a/compiler/main/Constants.hs +++ b/compiler/main/Constants.hs @@ -6,6 +6,8 @@ module Constants (module Constants) where +import GhcPrelude + import Config hiVersion :: Integer @@ -36,5 +38,9 @@ mAX_SOLVER_ITERATIONS = 4 wORD64_SIZE :: Int wORD64_SIZE = 8 +-- Size of float in bytes. +fLOAT_SIZE :: Int +fLOAT_SIZE = 4 + tARGET_MAX_CHAR :: Int tARGET_MAX_CHAR = 0x10ffff diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs index 8cf14c57e5..741104596a 100644 --- a/compiler/main/DriverMkDepend.hs +++ b/compiler/main/DriverMkDepend.hs @@ -14,12 +14,13 @@ module DriverMkDepend ( #include "HsVersions.h" +import GhcPrelude + import qualified GHC import GhcMonad import DynFlags import Util import HscTypes -import FileCleanup ( newTempName ) import qualified SysTools import Module import Digraph ( SCC(..) ) diff --git a/compiler/main/DriverPhases.hs b/compiler/main/DriverPhases.hs index a59c452788..57455a5463 100644 --- a/compiler/main/DriverPhases.hs +++ b/compiler/main/DriverPhases.hs @@ -40,6 +40,8 @@ module DriverPhases ( #include "HsVersions.h" +import GhcPrelude + import {-# SOURCE #-} DynFlags import Outputable import Platform @@ -287,8 +289,8 @@ phaseInputExt LlvmOpt = "ll" phaseInputExt LlvmLlc = "bc" phaseInputExt LlvmMangle = "lm_s" phaseInputExt SplitAs = "split_s" -phaseInputExt CmmCpp = "cmm" -phaseInputExt Cmm = "cmmcpp" +phaseInputExt CmmCpp = "cmmcpp" +phaseInputExt Cmm = "cmm" phaseInputExt MergeForeign = "o" phaseInputExt StopLn = "o" diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 3fc35e5992..a9e486c94a 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation #-} +{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation, BangPatterns #-} {-# OPTIONS_GHC -fno-cse #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly @@ -28,20 +28,20 @@ module DriverPipeline ( phaseOutputFilename, getOutputFilename, getPipeState, getPipeEnv, hscPostBackendPhase, getLocation, setModLocation, setDynFlags, runPhase, exeFileName, - mkExtraObjToLinkIntoBinary, mkNoteObjsToLinkIntoBinary, maybeCreateManifest, linkingNeeded, checkLinkInfo, writeInterfaceOnlyMode ) where #include "HsVersions.h" -import AsmUtils +import GhcPrelude + import PipelineMonad import Packages import HeaderInfo import DriverPhases import SysTools -import Elf +import SysTools.ExtraObj import HscMain import Finder import HscTypes hiding ( Hsc ) @@ -63,15 +63,17 @@ import TcRnTypes import Hooks import qualified GHC.LanguageExtensions as LangExt import FileCleanup +import Ar import Exception import System.Directory import System.FilePath import System.IO import Control.Monad -import Data.List ( isSuffixOf ) +import Data.List ( isInfixOf, isSuffixOf, intercalate ) import Data.Maybe import Data.Version +import Data.Either ( partitionEithers ) -- --------------------------------------------------------------------------- -- Pre-process @@ -261,11 +263,10 @@ compileOne' m_tc_result mHscMessage -- imports a _stub.h file that we created here. current_dir = takeDirectory basename old_paths = includePaths dflags1 - prevailing_dflags = hsc_dflags hsc_env0 + !prevailing_dflags = hsc_dflags hsc_env0 dflags = - dflags1 { includePaths = current_dir : old_paths - , log_action = log_action prevailing_dflags - , log_finaliser = log_finaliser prevailing_dflags } + dflags1 { includePaths = addQuoteInclude old_paths [current_dir] + , log_action = log_action prevailing_dflags } -- use the prevailing log_action / log_finaliser, -- not the one cached in the summary. This is so -- that we can change the log_action without having @@ -300,12 +301,14 @@ compileOne' m_tc_result mHscMessage -- useful to implement facilities such as inline-c. compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath +compileForeign _ RawObject object_file = return object_file compileForeign hsc_env lang stub_c = do let phase = case lang of LangC -> Cc LangCxx -> Ccxx LangObjc -> Cobjc LangObjcxx -> Cobjcxx + RawObject -> panic "compileForeign: should be unreachable" (_, stub_o) <- runPipeline StopLn hsc_env (stub_c, Just (RealPhase phase)) Nothing (Temporary TFL_GhcSession) @@ -423,7 +426,7 @@ link' dflags batch_attempt_linking hpt -- Don't showPass in Batch mode; doLink will do that for us. let link = case ghcLink dflags of LinkBinary -> linkBinary - LinkStaticLib -> linkStaticLibCheck + LinkStaticLib -> linkStaticLib LinkDynLib -> linkDynLibCheck other -> panicBadLink other link dflags obj_files pkg_deps @@ -452,7 +455,7 @@ linkingNeeded dflags staticLink linkables pkg_deps = do -- first check object files and extra_ld_inputs let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ] e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs - let (errs,extra_times) = splitEithers e_extra_times + let (errs,extra_times) = partitionEithers e_extra_times let obj_times = map linkableTime linkables ++ extra_times if not (null errs) || any (t <) obj_times then return True @@ -468,55 +471,16 @@ linkingNeeded dflags staticLink linkables pkg_deps = do if any isNothing pkg_libfiles then return True else do e_lib_times <- mapM (tryIO . getModificationUTCTime) (catMaybes pkg_libfiles) - let (lib_errs,lib_times) = splitEithers e_lib_times + let (lib_errs,lib_times) = partitionEithers e_lib_times if not (null lib_errs) || any (t <) lib_times then return True else checkLinkInfo dflags pkg_deps exe_file --- Returns 'False' if it was, and we can avoid linking, because the --- previous binary was linked with "the same options". -checkLinkInfo :: DynFlags -> [InstalledUnitId] -> FilePath -> IO Bool -checkLinkInfo dflags pkg_deps exe_file - | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags))) - -- ToDo: Windows and OS X do not use the ELF binary format, so - -- readelf does not work there. We need to find another way to do - -- this. - = return False -- conservatively we should return True, but not - -- linking in this case was the behaviour for a long - -- time so we leave it as-is. - | otherwise - = do - link_info <- getLinkInfo dflags pkg_deps - debugTraceMsg dflags 3 $ text ("Link info: " ++ link_info) - m_exe_link_info <- readElfNoteAsString dflags exe_file - ghcLinkInfoSectionName ghcLinkInfoNoteName - let sameLinkInfo = (Just link_info == m_exe_link_info) - debugTraceMsg dflags 3 $ case m_exe_link_info of - Nothing -> text "Exe link info: Not found" - Just s - | sameLinkInfo -> text ("Exe link info is the same") - | otherwise -> text ("Exe link info is different: " ++ s) - return (not sameLinkInfo) - -platformSupportsSavingLinkOpts :: OS -> Bool -platformSupportsSavingLinkOpts os - | os == OSSolaris2 = False -- see #5382 - | otherwise = osElfTarget os - --- See Note [LinkInfo section] -ghcLinkInfoSectionName :: String -ghcLinkInfoSectionName = ".debug-ghc-link-info" - -- if we use the ".debug" prefix, then strip will strip it by default - --- Identifier for the note (see Note [LinkInfo section]) -ghcLinkInfoNoteName :: String -ghcLinkInfoNoteName = "GHC link info" - findHSLib :: DynFlags -> [String] -> String -> IO (Maybe FilePath) findHSLib dflags dirs lib = do let batch_lib_file = if WayDyn `notElem` ways dflags - then "lib" ++ lib <.> "a" - else mkSOName (targetPlatform dflags) lib + then "lib" ++ lib <.> "a" + else mkSOName (targetPlatform dflags) lib found <- filterM doesFileExist (map (</> batch_lib_file) dirs) case found of [] -> return Nothing @@ -574,7 +538,7 @@ doLink dflags stop_phase o_files = case ghcLink dflags of NoLink -> return () LinkBinary -> linkBinary dflags o_files [] - LinkStaticLib -> linkStaticLibCheck dflags o_files [] + LinkStaticLib -> linkStaticLib dflags o_files [] LinkDynLib -> linkDynLibCheck dflags o_files [] other -> panicBadLink other @@ -798,6 +762,7 @@ getOutputFilename stop_phase output basename dflags next_phase maybe_location odir = objectDir dflags osuf = objectSuf dflags keep_hc = gopt Opt_KeepHcFiles dflags + keep_hscpp = gopt Opt_KeepHscppFiles dflags keep_s = gopt Opt_KeepSFiles dflags keep_bc = gopt Opt_KeepLlvmFiles dflags @@ -814,6 +779,7 @@ getOutputFilename stop_phase output basename dflags next_phase maybe_location As _ | keep_s -> True LlvmOpt | keep_bc -> True HCc | keep_hc -> True + HsPp _ | keep_hscpp -> True -- See Trac #10869 _other -> False suffix = myPhaseInputExt next_phase @@ -830,6 +796,66 @@ getOutputFilename stop_phase output basename dflags next_phase maybe_location | Just d <- odir = d </> persistent | otherwise = persistent + +-- | The fast LLVM Pipeline skips the mangler and assembler, +-- emitting object code directly from llc. +-- +-- slow: opt -> llc -> .s -> mangler -> as -> .o +-- fast: opt -> llc -> .o +-- +-- hidden flag: -ffast-llvm +-- +-- if keep-s-files is specified, we need to go through +-- the slow pipeline (Kavon Farvardin requested this). +fastLlvmPipeline :: DynFlags -> Bool +fastLlvmPipeline dflags + = not (gopt Opt_KeepSFiles dflags) && gopt Opt_FastLlvm dflags + +-- | LLVM Options. These are flags to be passed to opt and llc, to ensure +-- consistency we list them in pairs, so that they form groups. +llvmOptions :: DynFlags + -> [(String, String)] -- ^ pairs of (opt, llc) arguments +llvmOptions dflags = + [("-enable-tbaa -tbaa", "-enable-tbaa") | gopt Opt_LlvmTBAA dflags ] + ++ [("-relocation-model=" ++ rmodel + ,"-relocation-model=" ++ rmodel) | not (null rmodel)] + ++ [("-stack-alignment=" ++ (show align) + ,"-stack-alignment=" ++ (show align)) | align > 0 ] + ++ [("", "-filetype=obj") | fastLlvmPipeline dflags ] + + -- Additional llc flags + ++ [("", "-mcpu=" ++ mcpu) | not (null mcpu) + , not (any (isInfixOf "-mcpu") (getOpts dflags opt_lc)) ] + ++ [("", "-mattr=" ++ attrs) | not (null attrs) ] + + where target = LLVM_TARGET + Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets dflags) + + -- Relocation models + rmodel | gopt Opt_PIC dflags = "pic" + | positionIndependent dflags = "pic" + | WayDyn `elem` ways dflags = "dynamic-no-pic" + | otherwise = "static" + + align :: Int + align = case platformArch (targetPlatform dflags) of + ArchX86_64 | isAvxEnabled dflags -> 32 + _ -> 0 + + attrs :: String + attrs = intercalate "," $ mattr + ++ ["+sse42" | isSse4_2Enabled dflags ] + ++ ["+sse2" | isSse2Enabled dflags ] + ++ ["+sse" | isSseEnabled dflags ] + ++ ["+avx512f" | isAvx512fEnabled dflags ] + ++ ["+avx2" | isAvx2Enabled dflags ] + ++ ["+avx" | isAvxEnabled dflags ] + ++ ["+avx512cd"| isAvx512cdEnabled dflags ] + ++ ["+avx512er"| isAvx512erEnabled dflags ] + ++ ["+avx512pf"| isAvx512pfEnabled dflags ] + ++ ["+bmi" | isBmiEnabled dflags ] + ++ ["+bmi2" | isBmi2Enabled dflags ] + -- ----------------------------------------------------------------------------- -- | Each phase in the pipeline returns the next phase to execute, and the -- name of the file in which the output was placed. @@ -968,8 +994,9 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0 -- the .hs files resides) to the include path, since this is -- what gcc does, and it's probably what you want. let current_dir = takeDirectory basename + new_includes = addQuoteInclude paths [current_dir] paths = includePaths dflags0 - dflags = dflags0 { includePaths = current_dir : paths } + dflags = dflags0 { includePaths = new_includes } setDynFlags dflags @@ -1136,8 +1163,11 @@ runPhase (RealPhase cc_phase) input_fn dflags -- files; this is the Value Add(TM) that using ghc instead of -- gcc gives you :) pkg_include_dirs <- liftIO $ getPackageIncludePath dflags pkgs - let include_paths = foldr (\ x xs -> ("-I" ++ x) : xs) [] - (cmdline_include_paths ++ pkg_include_dirs) + let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] + (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs) + let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) [] + (includePathsQuote cmdline_include_paths) + let include_paths = include_paths_quote ++ include_paths_global let gcc_extra_viac_flags = extraGccViaCFlags dflags let pic_c_flags = picCCOpts dflags @@ -1300,10 +1330,13 @@ runPhase (RealPhase (As with_cpp)) input_fn dflags liftIO $ createDirectoryIfMissing True (takeDirectory output_fn) ccInfo <- liftIO $ getCompilerInfo dflags + let global_includes = [ SysTools.Option ("-I" ++ p) + | p <- includePathsGlobal cmdline_include_paths ] + let local_includes = [ SysTools.Option ("-iquote" ++ p) + | p <- includePathsQuote cmdline_include_paths ] let runAssembler inputFilename outputFilename = liftIO $ as_prog dflags - ([ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ] - + (local_includes ++ global_includes -- See Note [-fPIC for assembler] ++ map SysTools.Option pic_c_flags @@ -1427,121 +1460,117 @@ runPhase (RealPhase SplitAs) _input_fn dflags ----------------------------------------------------------------------------- -- LlvmOpt phase - runPhase (RealPhase LlvmOpt) input_fn dflags = do - let opt_lvl = max 0 (min 2 $ optLevel dflags) - -- don't specify anything if user has specified commands. We do this - -- for opt but not llc since opt is very specifically for optimisation - -- passes only, so if the user is passing us extra options we assume - -- they know what they are doing and don't get in the way. - optFlag = if null (getOpts dflags opt_lo) - then map SysTools.Option $ words (llvmOpts !! opt_lvl) - else [] - tbaa | gopt Opt_LlvmTBAA dflags = "--enable-tbaa=true" - | otherwise = "--enable-tbaa=false" - - output_fn <- phaseOutputFilename LlvmLlc liftIO $ SysTools.runLlvmOpt dflags - ([ SysTools.FileOption "" input_fn, - SysTools.Option "-o", - SysTools.FileOption "" output_fn] - ++ optFlag - ++ [SysTools.Option tbaa]) + ( optFlag + ++ defaultOptions ++ + [ SysTools.FileOption "" input_fn + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn] + ) return (RealPhase LlvmLlc, output_fn) where -- we always (unless -optlo specified) run Opt since we rely on it to -- fix up some pretty big deficiencies in the code we generate - llvmOpts = [ "-mem2reg -globalopt" - , "-O1 -globalopt" - , "-O2" - ] + optIdx = max 0 $ min 2 $ optLevel dflags -- ensure we're in [0,2] + llvmOpts = case lookup optIdx $ llvmPasses dflags of + Just passes -> passes + Nothing -> panic ("runPhase LlvmOpt: llvm-passes file " + ++ "is missing passes for level " + ++ show optIdx) + + -- don't specify anything if user has specified commands. We do this + -- for opt but not llc since opt is very specifically for optimisation + -- passes only, so if the user is passing us extra options we assume + -- they know what they are doing and don't get in the way. + optFlag = if null (getOpts dflags opt_lo) + then map SysTools.Option $ words llvmOpts + else [] + + defaultOptions = map SysTools.Option . concat . fmap words . fst + $ unzip (llvmOptions dflags) ----------------------------------------------------------------------------- -- LlvmLlc phase runPhase (RealPhase LlvmLlc) input_fn dflags = do - let opt_lvl = max 0 (min 2 $ optLevel dflags) - -- iOS requires external references to be loaded indirectly from the - -- DATA segment or dyld traps at runtime writing into TEXT: see #7722 - rmodel | platformOS (targetPlatform dflags) == OSiOS = "dynamic-no-pic" - | gopt Opt_PIC dflags = "pic" - | WayDyn `elem` ways dflags = "dynamic-no-pic" - | otherwise = "static" - tbaa | gopt Opt_LlvmTBAA dflags = "--enable-tbaa=true" - | otherwise = "--enable-tbaa=false" - - -- hidden debugging flag '-dno-llvm-mangler' to skip mangling - let next_phase = case gopt Opt_NoLlvmMangler dflags of - False -> LlvmMangle - True | gopt Opt_SplitObjs dflags -> Splitter - True -> As False + next_phase <- if fastLlvmPipeline dflags + then maybeMergeForeign + -- hidden debugging flag '-dno-llvm-mangler' to skip mangling + else case gopt Opt_NoLlvmMangler dflags of + False -> return LlvmMangle + True | gopt Opt_SplitObjs dflags -> return Splitter + True -> return (As False) output_fn <- phaseOutputFilename next_phase liftIO $ SysTools.runLlvmLlc dflags - ([ SysTools.Option (llvmOpts !! opt_lvl), - SysTools.Option $ "-relocation-model=" ++ rmodel, - SysTools.FileOption "" input_fn, - SysTools.Option "-o", SysTools.FileOption "" output_fn] - ++ [SysTools.Option tbaa] - ++ map SysTools.Option fpOpts - ++ map SysTools.Option abiOpts - ++ map SysTools.Option sseOpts - ++ map SysTools.Option avxOpts - ++ map SysTools.Option avx512Opts - ++ map SysTools.Option stackAlignOpts) + ( optFlag + ++ defaultOptions + ++ [ SysTools.FileOption "" input_fn + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ] + ) return (RealPhase next_phase, output_fn) where - -- Bug in LLVM at O3 on OSX. - llvmOpts = if platformOS (targetPlatform dflags) == OSDarwin - then ["-O1", "-O2", "-O2"] - else ["-O1", "-O2", "-O3"] - -- On ARMv7 using LLVM, LLVM fails to allocate floating point registers - -- while compiling GHC source code. It's probably due to fact that it - -- does not enable VFP by default. Let's do this manually here - fpOpts = case platformArch (targetPlatform dflags) of - ArchARM ARMv7 ext _ -> if (elem VFPv3 ext) - then ["-mattr=+v7,+vfp3"] - else if (elem VFPv3D16 ext) - then ["-mattr=+v7,+vfp3,+d16"] - else [] - ArchARM ARMv6 ext _ -> if (elem VFPv2 ext) - then ["-mattr=+v6,+vfp2"] - else ["-mattr=+v6"] - _ -> [] - -- 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 _ _ HARD -> ["-float-abi=hard"] - ArchARM _ _ _ -> [] - _ -> [] - - sseOpts | isSse4_2Enabled dflags = ["-mattr=+sse42"] - | isSse2Enabled dflags = ["-mattr=+sse2"] - | isSseEnabled dflags = ["-mattr=+sse"] - | otherwise = [] - - avxOpts | isAvx512fEnabled dflags = ["-mattr=+avx512f"] - | isAvx2Enabled dflags = ["-mattr=+avx2"] - | isAvxEnabled dflags = ["-mattr=+avx"] - | otherwise = [] - - avx512Opts = - [ "-mattr=+avx512cd" | isAvx512cdEnabled dflags ] ++ - [ "-mattr=+avx512er" | isAvx512erEnabled dflags ] ++ - [ "-mattr=+avx512pf" | isAvx512pfEnabled dflags ] - - stackAlignOpts = - case platformArch (targetPlatform dflags) of - ArchX86_64 | isAvxEnabled dflags -> ["-stack-alignment=32"] - _ -> [] + -- Note [Clamping of llc optimizations] + -- + -- See #13724 + -- + -- we clamp the llc optimization between [1,2]. This is because passing -O0 + -- to llc 3.9 or llc 4.0, the naive register allocator can fail with + -- + -- Error while trying to spill R1 from class GPR: Cannot scavenge register + -- without an emergency spill slot! + -- + -- Observed at least with target 'arm-unknown-linux-gnueabihf'. + -- + -- + -- With LLVM4, llc -O3 crashes when ghc-stage1 tries to compile + -- rts/HeapStackCheck.cmm + -- + -- llc -O3 '-mtriple=arm-unknown-linux-gnueabihf' -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s + -- 0 llc 0x0000000102ae63e8 llvm::sys::PrintStackTrace(llvm::raw_ostream&) + 40 + -- 1 llc 0x0000000102ae69a6 SignalHandler(int) + 358 + -- 2 libsystem_platform.dylib 0x00007fffc23f4b3a _sigtramp + 26 + -- 3 libsystem_c.dylib 0x00007fffc226498b __vfprintf + 17876 + -- 4 llc 0x00000001029d5123 llvm::SelectionDAGISel::LowerArguments(llvm::Function const&) + 5699 + -- 5 llc 0x0000000102a21a35 llvm::SelectionDAGISel::SelectAllBasicBlocks(llvm::Function const&) + 3381 + -- 6 llc 0x0000000102a202b1 llvm::SelectionDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 1457 + -- 7 llc 0x0000000101bdc474 (anonymous namespace)::ARMDAGToDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 20 + -- 8 llc 0x00000001025573a6 llvm::MachineFunctionPass::runOnFunction(llvm::Function&) + 134 + -- 9 llc 0x000000010274fb12 llvm::FPPassManager::runOnFunction(llvm::Function&) + 498 + -- 10 llc 0x000000010274fd23 llvm::FPPassManager::runOnModule(llvm::Module&) + 67 + -- 11 llc 0x00000001027501b8 llvm::legacy::PassManagerImpl::run(llvm::Module&) + 920 + -- 12 llc 0x000000010195f075 compileModule(char**, llvm::LLVMContext&) + 12133 + -- 13 llc 0x000000010195bf0b main + 491 + -- 14 libdyld.dylib 0x00007fffc21e5235 start + 1 + -- Stack dump: + -- 0. Program arguments: llc -O3 -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s + -- 1. Running pass 'Function Pass Manager' on module '/var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc'. + -- 2. Running pass 'ARM Instruction Selection' on function '@"stg_gc_f1$def"' + -- + -- Observed at least with -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa + -- + llvmOpts = case optLevel dflags of + 0 -> "-O1" -- required to get the non-naive reg allocator. Passing -regalloc=greedy is not sufficient. + 1 -> "-O1" + _ -> "-O2" + + optFlag = if null (getOpts dflags opt_lc) + then map SysTools.Option $ words llvmOpts + else [] + + defaultOptions = map SysTools.Option . concat . fmap words . snd + $ unzip (llvmOptions dflags) + ----------------------------------------------------------------------------- -- LlvmMangle phase @@ -1624,143 +1653,6 @@ getLocation src_flavour mod_name = do | otherwise = location3 return location4 -mkExtraObj :: DynFlags -> Suffix -> String -> IO FilePath -mkExtraObj dflags extn xs - = do cFile <- newTempName dflags TFL_CurrentModule extn - oFile <- newTempName dflags TFL_GhcSession "o" - writeFile cFile xs - ccInfo <- liftIO $ getCompilerInfo dflags - SysTools.runCc dflags - ([Option "-c", - FileOption "" cFile, - Option "-o", - FileOption "" oFile] - ++ if extn /= "s" - then cOpts - else asmOpts ccInfo) - return oFile - where - -- Pass a different set of options to the C compiler depending one whether - -- we're compiling C or assembler. When compiling C, we pass the usual - -- set of include directories and PIC flags. - cOpts = map Option (picCCOpts dflags) - ++ map (FileOption "-I") - (includeDirs $ getPackageDetails dflags rtsUnitId) - - -- When compiling assembler code, we drop the usual C options, and if the - -- compiler is Clang, we add an extra argument to tell Clang to ignore - -- unused command line options. See trac #11684. - asmOpts ccInfo = - if any (ccInfo ==) [Clang, AppleClang, AppleClang51] - then [Option "-Qunused-arguments"] - else [] - - --- When linking a binary, we need to create a C main() function that --- starts everything off. This used to be compiled statically as part --- of the RTS, but that made it hard to change the -rtsopts setting, --- 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 -> IO FilePath -mkExtraObjToLinkIntoBinary dflags = do - when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ do - putLogMsg dflags NoReason SevInfo noSrcSpan - (defaultUserStyle dflags) - (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.") - - mkExtraObj dflags "c" (showSDoc dflags main) - - where - main - | gopt Opt_NoHsMain dflags = Outputable.empty - | otherwise = vcat [ - text "#include \"Rts.h\"", - text "extern StgClosure ZCMain_main_closure;", - text "int main(int argc, char *argv[])", - char '{', - text " RtsConfig __conf = defaultRtsConfig;", - text " __conf.rts_opts_enabled = " - <> text (show (rtsOptsEnabled dflags)) <> semi, - text " __conf.rts_opts_suggestions = " - <> text (if rtsOptsSuggestions dflags - then "true" - else "false") <> semi, - case rtsOpts dflags of - Nothing -> Outputable.empty - Just opts -> text " __conf.rts_opts= " <> - text (show opts) <> semi, - text " __conf.rts_hs_main = true;", - text " return hs_main(argc,argv,&ZCMain_main_closure,__conf);", - char '}', - char '\n' -- final newline, to keep gcc happy - ] - --- 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 -> [InstalledUnitId] -> 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 [ - -- "link info" section (see Note [LinkInfo section]) - makeElfNote ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info, - - -- ALL generated assembly must have this section to disable - -- executable stacks. See also - -- compiler/nativeGen/AsmCodeGen.hs for another instance - -- where we need to do this. - if platformHasGnuNonexecStack (targetPlatform dflags) - then text ".section .note.GNU-stack,\"\"," - <> sectionType "progbits" <> char '\n' - else Outputable.empty - ] - --- | Return the "link info" string --- --- See Note [LinkInfo section] -getLinkInfo :: DynFlags -> [InstalledUnitId] -> IO String -getLinkInfo dflags dep_packages = do - package_link_opts <- getPackageLinkOpts dflags dep_packages - pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags) - then getPackageFrameworks dflags dep_packages - else return [] - let extra_ld_inputs = ldInputs dflags - let - link_info = (package_link_opts, - pkg_frameworks, - rtsOpts dflags, - rtsOptsEnabled dflags, - gopt Opt_NoHsMain dflags, - map showOpt extra_ld_inputs, - getOpts dflags opt_l) - -- - return (show link_info) - - -{- Note [LinkInfo section] - ~~~~~~~~~~~~~~~~~~~~~~~ - -The "link info" is a string representing the parameters of the link. We save -this information in the binary, and the next time we link, if nothing else has -changed, we use the link info stored in the existing binary to decide whether -to re-link or not. - -The "link info" string is stored in a ELF section called ".debug-ghc-link-info" -(see ghcLinkInfoSectionName) with the SHT_NOTE type. For some time, it used to -not follow the specified record-based format (see #11022). - --} - - ----------------------------------------------------------------------------- -- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file @@ -1792,7 +1684,7 @@ Note [-Xlinker -rpath vs -Wl,-rpath] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Wl takes a comma-separated list of options which in the case of --Wl,-rpath -Wl,some,path,with,commas parses the the path with commas +-Wl,-rpath -Wl,some,path,with,commas parses the path with commas as separate options. Buck, the build system, produces paths with commas in them. @@ -1854,6 +1746,16 @@ linkBinary' staticLink dflags o_files dep_packages = do in ["-L" ++ l] ++ ["-Xlinker", "-rpath", "-Xlinker", libpath] | otherwise = ["-L" ++ l] + pkg_lib_path_opts <- + if gopt Opt_SingleLibFolder dflags + then do + libs <- getLibs dflags dep_packages + tmpDir <- newTempDir dflags + sequence_ [ copyFile lib (tmpDir </> basename) + | (lib, basename) <- libs] + return [ "-L" ++ tmpDir ] + else pure pkg_lib_path_opts + let dead_strip | gopt Opt_WholeArchiveHsLibs dflags = [] @@ -1932,13 +1834,12 @@ linkBinary' staticLink dflags o_files dep_packages = do ++ [ SysTools.Option "-o" , SysTools.FileOption "" output_fn ] + ++ libmLinkOpts ++ map SysTools.Option ( [] - -- See Note [No PIE eating when linking] - ++ (if sGccSupportsNoPie mySettings - then ["-no-pie"] - else []) + -- See Note [No PIE when linking] + ++ picCCOpts dflags -- Permit the linker to auto link _symbol to _imp_symbol. -- This lets us link against DLLs without needing an "import library". @@ -1956,7 +1857,7 @@ linkBinary' staticLink dflags o_files dep_packages = do -- on x86. ++ (if sLdSupportsCompactUnwind mySettings && not staticLink && - (platformOS platform == OSDarwin || platformOS platform == OSiOS) && + (platformOS platform == OSDarwin) && case platformArch platform of ArchX86 -> True ArchX86_64 -> True @@ -1995,6 +1896,9 @@ linkBinary' staticLink dflags o_files dep_packages = do ++ pkg_framework_opts ++ debug_opts ++ thread_opts + ++ (if platformOS platform == OSDarwin + then [ "-Wl,-dead_strip_dylibs" ] + else []) )) exeFileName :: Bool -> DynFlags -> FilePath @@ -2079,9 +1983,35 @@ linkDynLibCheck dflags o_files dep_packages linkDynLib dflags o_files dep_packages -linkStaticLibCheck :: DynFlags -> [String] -> [InstalledUnitId] -> IO () -linkStaticLibCheck dflags o_files dep_packages - = linkBinary' True dflags o_files dep_packages +-- | Linking a static lib will not really link anything. It will merely produce +-- a static archive of all dependent static libraries. The resulting library +-- will still need to be linked with any remaining link flags. +linkStaticLib :: DynFlags -> [String] -> [InstalledUnitId] -> IO () +linkStaticLib dflags o_files dep_packages = do + let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ] + modules = o_files ++ extra_ld_inputs + output_fn = exeFileName True dflags + + full_output_fn <- if isAbsolute output_fn + then return output_fn + else do d <- getCurrentDirectory + return $ normalise (d </> output_fn) + output_exists <- doesFileExist full_output_fn + (when output_exists) $ removeFile full_output_fn + + pkg_cfgs <- getPreloadPackagesAnd dflags dep_packages + archives <- concat <$> mapM (collectArchives dflags) pkg_cfgs + + ar <- foldl mappend + <$> (Archive <$> mapM loadObj modules) + <*> mapM loadAr archives + + if sLdIsGnuLd (settings dflags) + then writeGNUAr output_fn $ afilter (not . isGNUSymdef) ar + else writeBSDAr output_fn $ afilter (not . isBSDSymdef) ar + + -- run ranlib over the archive. write*Ar does *not* create the symbol index. + runRanlib dflags [SysTools.FileOption "" output_fn] -- ----------------------------------------------------------------------------- -- Running CPP @@ -2092,8 +2022,11 @@ doCpp dflags raw input_fn output_fn = do let cmdline_include_paths = includePaths dflags pkg_include_dirs <- getPackageIncludePath dflags [] - let include_paths = foldr (\ x xs -> "-I" : x : xs) [] - (cmdline_include_paths ++ pkg_include_dirs) + let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] + (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs) + let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) [] + (includePathsQuote cmdline_include_paths) + let include_paths = include_paths_quote ++ include_paths_global let verbFlags = getVerbFlags dflags @@ -2227,7 +2160,7 @@ joinObjectFiles dflags o_files output_fn = do SysTools.Option "-nostdlib", SysTools.Option "-Wl,-r" ] - -- See Note [No PIE eating while linking] in SysTools + -- See Note [No PIE while linking] in SysTools ++ (if sGccSupportsNoPie mySettings then [SysTools.Option "-no-pie"] else []) @@ -2300,20 +2233,19 @@ touchObjectFile dflags path = do createDirectoryIfMissing True $ takeDirectory path SysTools.touch dflags "Touching object file" path -haveRtsOptsFlags :: DynFlags -> Bool -haveRtsOptsFlags dflags = - isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of - RtsOptsSafeOnly -> False - _ -> True - -- | Find out path to @ghcversion.h@ file getGhcVersionPathName :: DynFlags -> IO FilePath getGhcVersionPathName dflags = do - dirs <- getPackageIncludePath dflags [toInstalledUnitId rtsUnitId] + candidates <- case ghcVersionFile dflags of + Just path -> return [path] + Nothing -> (map (</> "ghcversion.h")) <$> + (getPackageIncludePath dflags [toInstalledUnitId rtsUnitId]) - found <- filterM doesFileExist (map (</> "ghcversion.h") dirs) + found <- filterM doesFileExist candidates case found of - [] -> throwGhcExceptionIO (InstallationError ("ghcversion.h missing")) + [] -> throwGhcExceptionIO (InstallationError + ("ghcversion.h missing; tried: " + ++ intercalate ", " candidates)) (x:_) -> return x -- Note [-fPIC for assembler] diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index cc9bbb8684..9f0ba57bf5 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -24,7 +24,7 @@ module DynFlags ( WarningFlag(..), WarnReason(..), Language(..), PlatformConstants(..), - FatalMessager, LogAction, LogFinaliser, FlushOut(..), FlushErr(..), + FatalMessager, LogAction, FlushOut(..), FlushErr(..), ProfAuto(..), glasgowExtsFlags, warningGroups, warningHierarchies, @@ -36,6 +36,7 @@ module DynFlags ( xopt, xopt_set, xopt_unset, lang_set, useUnicodeSyntax, + useStarIsType, whenGeneratingDynamicToo, ifGeneratingDynamicToo, whenCannotGenerateDynamicToo, dynamicTooMkDynamicDynFlags, @@ -59,6 +60,9 @@ module DynFlags ( tablesNextToCode, mkTablesNextToCode, makeDynFlagsConsistent, shouldUseColor, + shouldUseHexWordLiterals, + positionIndependent, + optimisationFlags, Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays, wayGeneralFlags, wayUnsetGeneralFlags, @@ -75,6 +79,9 @@ module DynFlags ( safeDirectImpsReq, safeImplicitImpsReq, unsafeFlags, unsafeFlagsForInfer, + -- ** LLVM Targets + LlvmTarget(..), LlvmTargets, LlvmPasses, LlvmConfig, + -- ** System tool settings and locations Settings(..), targetPlatform, programName, projectVersion, @@ -82,12 +89,13 @@ module DynFlags ( versionedAppDir, extraGccViaCFlags, systemPackageConfig, pgm_L, pgm_P, pgm_F, pgm_c, pgm_s, pgm_a, pgm_l, pgm_dll, pgm_T, - pgm_windres, pgm_libtool, pgm_lo, pgm_lc, pgm_i, - opt_L, opt_P, opt_F, opt_c, opt_a, opt_l, opt_i, - opt_windres, opt_lo, opt_lc, - + pgm_windres, pgm_libtool, pgm_ar, pgm_ranlib, pgm_lo, pgm_lc, + pgm_lcc, pgm_i, opt_L, opt_P, opt_F, opt_c, opt_a, opt_l, opt_i, + opt_P_signature, + opt_windres, opt_lo, opt_lc, opt_lcc, -- ** Manipulating DynFlags + addPluginModuleName, defaultDynFlags, -- Settings -> DynFlags defaultWays, interpWays, @@ -107,6 +115,7 @@ module DynFlags ( setUnitId, interpretPackageEnv, canonicalizeHomeModule, + canonicalizeModuleIfHome, -- ** Parsing DynFlags parseDynamicFlagsCmdLine, @@ -145,6 +154,8 @@ module DynFlags ( isSseEnabled, isSse2Enabled, isSse4_2Enabled, + isBmiEnabled, + isBmi2Enabled, isAvxEnabled, isAvx2Enabled, isAvx512cdEnabled, @@ -157,15 +168,21 @@ module DynFlags ( CompilerInfo(..), -- * File cleanup - FilesToClean(..), emptyFilesToClean + FilesToClean(..), emptyFilesToClean, + + -- * Include specifications + IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes ) where #include "HsVersions.h" +import GhcPrelude + import Platform import PlatformConstants import Module import PackageConfig +import {-# SOURCE #-} Plugins import {-# SOURCE #-} Hooks import {-# SOURCE #-} PrelNames ( mAIN ) import {-# SOURCE #-} Packages (PackageState, emptyPackageState) @@ -183,13 +200,15 @@ import qualified Pretty import SrcLoc import BasicTypes ( IntWithInf, treatZeroAsInf ) import FastString +import Fingerprint import Outputable import Foreign.C ( CInt(..) ) import System.IO.Unsafe ( unsafeDupablePerformIO ) import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessageAnn - , getCaretDiagnostic, dumpSDoc ) + , getCaretDiagnostic ) import Json import SysTools.Terminal ( stderrSupportsAnsiColors ) +import SysTools.BaseDir ( expandToolDir, expandTopDir ) import System.IO.Unsafe ( unsafePerformIO ) import Data.IORef @@ -231,14 +250,8 @@ import Foreign (Ptr) -- needed for 2nd stage -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- If you modify anything in this file please make sure that your changes are --- described in the User's Guide. Usually at least two sections need to be --- updated: --- --- * Flag Reference section generated from the modules in --- utils/mkUserGuidePart/Options --- --- * Flag description in docs/users_guide/using.rst provides a detailed --- explanation of flags' usage. +-- described in the User's Guide. Please update the flag description in the +-- users guide (docs/users_guide) whenever you add or change a flag. -- Note [Supporting CLI completion] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -343,6 +356,7 @@ data DumpFlag | Opt_D_dump_core_stats | Opt_D_dump_deriv | Opt_D_dump_ds + | Opt_D_dump_ds_preopt | Opt_D_dump_foreign | Opt_D_dump_inlinings | Opt_D_dump_rule_firings @@ -360,6 +374,7 @@ data DumpFlag | Opt_D_dump_prep | Opt_D_dump_stg | Opt_D_dump_call_arity + | Opt_D_dump_exitify | Opt_D_dump_stranal | Opt_D_dump_str_signatures | Opt_D_dump_tc @@ -380,7 +395,6 @@ data DumpFlag | Opt_D_dump_splices | Opt_D_th_dec_file | Opt_D_dump_BCOs - | Opt_D_dump_vect | Opt_D_dump_ticked | Opt_D_dump_rtti | Opt_D_source_stats @@ -389,6 +403,7 @@ data DumpFlag | Opt_D_dump_hi_diffs | Opt_D_dump_mod_cycles | Opt_D_dump_mod_map + | Opt_D_dump_timings | Opt_D_dump_view_pattern_commoning | Opt_D_verbose_core2core | Opt_D_dump_debug @@ -397,6 +412,7 @@ data DumpFlag | Opt_D_no_debug_output deriving (Eq, Show, Enum) + -- | Enumerates the simple on-or-off dynamic flags data GeneralFlag -- See Note [Updating flag description in the User's Guide] @@ -410,6 +426,7 @@ data GeneralFlag | Opt_DoAsmLinting | Opt_DoAnnotationLinting | Opt_NoLlvmMangler -- hidden flag + | Opt_FastLlvm -- hidden flag | Opt_WarnIsError -- -Werror; makes warnings fatal | Opt_ShowWarnGroups -- Show the group a warning belongs to @@ -427,12 +444,14 @@ data GeneralFlag -- optimisation opts | Opt_CallArity + | Opt_Exitification | Opt_Strictness - | Opt_LateDmdAnal + | Opt_LateDmdAnal -- #6087 | Opt_KillAbsence | Opt_KillOneShot | Opt_FullLaziness | Opt_FloatIn + | Opt_LateSpecialise | Opt_Specialise | Opt_SpecialiseAggressively | Opt_CrossModuleSpecialise @@ -451,8 +470,6 @@ data GeneralFlag | Opt_UnboxSmallStrictFields | Opt_DictsCheap | Opt_EnableRewriteRules -- Apply rewrite rules during simplification - | Opt_Vectorise - | Opt_VectorisationAvoidance | 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 @@ -462,6 +479,7 @@ data GeneralFlag | Opt_IrrefutableTuples | Opt_CmmSink | Opt_CmmElimCommonBlocks + | Opt_AsmShortcutting | Opt_OmitYields | Opt_FunToThunk -- allow WwLib.mkWorkerArgs to remove all value lambdas | Opt_DictsStrict -- be strict in argument dictionaries @@ -470,7 +488,13 @@ data GeneralFlag | Opt_CprAnal | Opt_WorkerWrapper | Opt_SolveConstantDicts + | Opt_AlignmentSanitisation | Opt_CatchBottoms + | Opt_NumConstantFolding + + -- PreInlining is on by default. The option is there just to see how + -- bad things get if you turn it off! + | Opt_SimplPreInlining -- Interface files | Opt_IgnoreInterfacePragmas @@ -485,6 +509,8 @@ data GeneralFlag -- misc opts | Opt_Pp | Opt_ForceRecomp + | Opt_IgnoreOptimChanges + | Opt_IgnoreHpcChanges | Opt_ExcessPrecision | Opt_EagerBlackHoling | Opt_NoHsMain @@ -507,12 +533,17 @@ data GeneralFlag | Opt_IgnoreDotGhci | Opt_GhciSandbox | Opt_GhciHistory + | Opt_GhciLeakCheck | Opt_LocalGhciHistory + | Opt_NoIt | Opt_HelpfulErrors | Opt_DeferTypeErrors | Opt_DeferTypedHoles | Opt_DeferOutOfScopeVariables - | Opt_PIC + | Opt_PIC -- ^ @-fPIC@ + | Opt_PIE -- ^ @-fPIE@ + | Opt_PICExecutable -- ^ @-pie@ + | Opt_ExternalDynamicRefs | Opt_SccProfilingOn | Opt_Ticky | Opt_Ticky_Allocd @@ -526,10 +557,13 @@ data GeneralFlag | Opt_OptimalApplicativeDo | Opt_VersionMacros | Opt_WholeArchiveHsLibs - - -- PreInlining is on by default. The option is there just to see how - -- bad things get if you turn it off! - | Opt_SimplPreInlining + -- copy all libs into a single folder prior to linking binaries + -- this should elivate the excessive command line limit restrictions + -- on windows, by only requiring a single -L argument instead of + -- one for each dependency. At the time of this writing, gcc + -- forwards all -L flags to the collect2 command without using a + -- response file and as such breaking apart. + | Opt_SingleLibFolder -- output style opts | Opt_ErrorSpans -- Include full span info in error messages, @@ -538,6 +572,24 @@ data GeneralFlag | Opt_PprCaseAsLet | Opt_PprShowTicks | Opt_ShowHoleConstraints + -- Options relating to the display of valid hole fits + -- when generating an error message for a typed hole + -- See Note [Valid hole fits include] in TcHoleErrors.hs + | Opt_ShowValidHoleFits + | Opt_SortValidHoleFits + | Opt_SortBySizeHoleFits + | Opt_SortBySubsumHoleFits + | Opt_AbstractRefHoleFits + | Opt_UnclutterValidHoleFits + | Opt_ShowTypeAppOfHoleFits + | Opt_ShowTypeAppVarsOfHoleFits + | Opt_ShowDocsOfHoleFits + | Opt_ShowTypeOfHoleFits + | Opt_ShowProvOfHoleFits + | Opt_ShowMatchesOfHoleFits + + | Opt_ShowLoadedModules + | Opt_HexWordLiterals -- See Note [Print Hexadecimal Literals] -- Suppress all coercions, them replacing with '...' | Opt_SuppressCoercions @@ -557,13 +609,16 @@ data GeneralFlag -- Except for uniques, as some simplifier phases introduce new -- variables that have otherwise identical names. | Opt_SuppressUniques + | Opt_SuppressStgFreeVars | Opt_SuppressTicks -- Replaces Opt_PprShowTicks + | Opt_SuppressTimestamps -- ^ Suppress timestamps in dumps -- temporary flags | Opt_AutoLinkPackages | Opt_ImplicitImportQualified -- keeping stuff + | Opt_KeepHscppFiles | Opt_KeepHiDiffs | Opt_KeepHcFiles | Opt_KeepSFiles @@ -583,6 +638,65 @@ data GeneralFlag | Opt_G_NoOptCoercion deriving (Eq, Show, Enum) +-- Check whether a flag should be considered an "optimisation flag" +-- for purposes of recompilation avoidance (see +-- Note [Ignoring some flag changes] in FlagChecker). Being listed here is +-- not a guarantee that the flag has no other effect. We could, and +-- perhaps should, separate out the flags that have some minor impact on +-- program semantics and/or error behavior (e.g., assertions), but +-- then we'd need to go to extra trouble (and an additional flag) +-- to allow users to ignore the optimisation level even though that +-- means ignoring some change. +optimisationFlags :: EnumSet GeneralFlag +optimisationFlags = EnumSet.fromList + [ Opt_CallArity + , Opt_Strictness + , Opt_LateDmdAnal + , Opt_KillAbsence + , Opt_KillOneShot + , Opt_FullLaziness + , Opt_FloatIn + , Opt_LateSpecialise + , Opt_Specialise + , Opt_SpecialiseAggressively + , Opt_CrossModuleSpecialise + , Opt_StaticArgumentTransformation + , Opt_CSE + , Opt_StgCSE + , Opt_LiberateCase + , Opt_SpecConstr + , Opt_SpecConstrKeen + , Opt_DoLambdaEtaExpansion + , Opt_IgnoreAsserts + , Opt_DoEtaReduction + , Opt_CaseMerge + , Opt_CaseFolding + , Opt_UnboxStrictFields + , Opt_UnboxSmallStrictFields + , Opt_DictsCheap + , Opt_EnableRewriteRules + , Opt_RegsGraph + , Opt_RegsIterative + , Opt_PedanticBottoms + , Opt_LlvmTBAA + , Opt_LlvmPassVectorsInRegisters + , Opt_LlvmFillUndefWithGarbage + , Opt_IrrefutableTuples + , Opt_CmmSink + , Opt_CmmElimCommonBlocks + , Opt_AsmShortcutting + , Opt_OmitYields + , Opt_FunToThunk + , Opt_DictsStrict + , Opt_DmdTxDictSel + , Opt_Loopification + , Opt_CprAnal + , Opt_WorkerWrapper + , Opt_SolveConstantDicts + , Opt_CatchBottoms + , Opt_IgnoreAsserts + ] + -- | Used when outputting warnings: if a reason is given, it is -- displayed. If a warning isn't controlled by a flag, this is made -- explicit at the point of use. @@ -594,6 +708,33 @@ data WarnReason | ErrReason !(Maybe WarningFlag) deriving Show +-- | Used to differentiate the scope an include needs to apply to. +-- We have to split the include paths to avoid accidentally forcing recursive +-- includes since -I overrides the system search paths. See Trac #14312. +data IncludeSpecs + = IncludeSpecs { includePathsQuote :: [String] + , includePathsGlobal :: [String] + } + deriving Show + +-- | Append to the list of includes a path that shall be included using `-I` +-- when the C compiler is called. These paths override system search paths. +addGlobalInclude :: IncludeSpecs -> [String] -> IncludeSpecs +addGlobalInclude spec paths = let f = includePathsGlobal spec + in spec { includePathsGlobal = f ++ paths } + +-- | Append to the list of includes a path that shall be included using +-- `-iquote` when the C compiler is called. These paths only apply when quoted +-- includes are used. e.g. #include "foo.h" +addQuoteInclude :: IncludeSpecs -> [String] -> IncludeSpecs +addQuoteInclude spec paths = let f = includePathsQuote spec + in spec { includePathsQuote = f ++ paths } + +-- | Concatenate and flatten the list of global and quoted includes returning +-- just a flat list of paths. +flattenIncludes :: IncludeSpecs -> [String] +flattenIncludes specs = includePathsQuote specs ++ includePathsGlobal specs + instance Outputable WarnReason where ppr = text . show @@ -633,7 +774,6 @@ data WarningFlag = | Opt_WarnUnusedForalls | Opt_WarnWarningsDeprecations | Opt_WarnDeprecatedFlags - | Opt_WarnAMP -- Introduced in GHC 7.8, obsolete since 7.10 | Opt_WarnMissingMonadFailInstances -- since 8.0 | Opt_WarnSemigroup -- since 8.0 | Opt_WarnDodgyExports @@ -671,6 +811,12 @@ data WarningFlag = | Opt_WarnCPPUndef -- Since 8.2 | Opt_WarnUnbangedStrictPatterns -- Since 8.2 | Opt_WarnMissingHomeModules -- Since 8.2 + | Opt_WarnPartialFields -- Since 8.4 + | Opt_WarnMissingExportList + | Opt_WarnInaccessibleCode + | Opt_WarnStarIsType -- Since 8.6 + | Opt_WarnStarBinder -- Since 8.6 + | Opt_WarnImplicitKindVars -- Since 8.6 deriving (Eq, Show, Enum) data Language = Haskell98 | Haskell2010 @@ -703,6 +849,8 @@ data DynFlags = DynFlags { ghcLink :: GhcLink, hscTarget :: HscTarget, settings :: Settings, + llvmTargets :: LlvmTargets, + llvmPasses :: LlvmPasses, verbosity :: Int, -- ^ Verbosity level: see Note [Verbosity levels] optLevel :: Int, -- ^ Optimisation level debugLevel :: Int, -- ^ How much debug information to produce @@ -710,6 +858,7 @@ data DynFlags = DynFlags { maxSimplIterations :: Int, -- ^ Max simplifier iterations maxPmCheckIterations :: Int, -- ^ Max no iterations for pm checking ruleCheck :: Maybe String, + inlineCheck :: Maybe String, -- ^ A prefix to report inlining decisions about strictnessBefore :: [Int], -- ^ Additional demand analysis parMakeCount :: Maybe Int, -- ^ The number of modules to compile in parallel @@ -721,8 +870,14 @@ data DynFlags = DynFlags { maxRelevantBinds :: Maybe Int, -- ^ Maximum number of bindings from the type envt -- to show in type error messages - maxValidSubstitutions :: Maybe Int, -- ^ Maximum number of substitutions - -- to show in type error messages + maxValidHoleFits :: Maybe Int, -- ^ Maximum number of hole fits to show + -- in typed hole error messages + maxRefHoleFits :: Maybe Int, -- ^ Maximum number of refinement hole + -- fits to show in typed hole error + -- messages + refLevelHoleFits :: Maybe Int, -- ^ Maximum level of refinement for + -- refinement hole fits in typed hole + -- error messages maxUncoveredPatterns :: Int, -- ^ Maximum number of unmatched patterns to show -- in non-exhaustiveness warnings simplTickFactor :: Int, -- ^ Multiplier for simplifier ticks @@ -734,6 +889,8 @@ data DynFlags = DynFlags { floatLamArgs :: Maybe Int, -- ^ Arg count for lambda floating -- See CoreMonad.FloatOutSwitches + cmmProcAlignment :: Maybe Int, -- ^ Align Cmm functions at this boundary or use default. + historySize :: Int, -- ^ Simplification history size importPaths :: [FilePath], @@ -769,14 +926,6 @@ data DynFlags = DynFlags { dynObjectSuf :: String, dynHiSuf :: String, - -- Packages.isDllName needs to know whether a call is within a - -- single DLL or not. Normally it does this by seeing if the call - -- is to the same package, but for the ghc package, we split the - -- package between 2 DLLs. The dllSplit tells us which sets of - -- modules are in which package. - dllSplitFile :: Maybe FilePath, - dllSplit :: Maybe [Set String], - outputFile :: Maybe String, dynOutputFile :: Maybe String, outputHi :: Maybe String, @@ -792,7 +941,7 @@ data DynFlags = DynFlags { ldInputs :: [Option], - includePaths :: [String], + includePaths :: IncludeSpecs, libraryPaths :: [String], frameworkPaths :: [String], -- used on darwin only cmdlineFrameworks :: [String], -- ditto @@ -809,6 +958,12 @@ data DynFlags = DynFlags { frontendPluginOpts :: [String], -- ^ the @-ffrontend-opt@ flags given on the command line, in *reverse* -- order that they're specified on the command line. + plugins :: [LoadedPlugin], + -- ^ plugins loaded after processing arguments. What will be loaded here + -- is directed by pluginModNames. Arguments are loaded from + -- pluginModNameOpts. The purpose of this field is to cache the plugins so + -- they don't have to be loaded each time they are needed. + -- See 'DynamicLoading.initializePlugins'. -- GHC API hooks hooks :: Hooks, @@ -906,12 +1061,11 @@ data DynFlags = DynFlags { ghciHistSize :: Int, -- | MsgDoc output action: use "ErrUtils" instead of this if you can - initLogAction :: IO (Maybe LogOutput), log_action :: LogAction, - log_finaliser :: LogFinaliser, flushOut :: FlushOut, flushErr :: FlushErr, + ghcVersionFile :: Maybe FilePath, haddockOptions :: Maybe String, -- | GHCi scripts specified by -ghci-script, in reverse order @@ -935,6 +1089,7 @@ data DynFlags = DynFlags { -- | Machine dependent flags (-m<blah> stuff) sseVersion :: Maybe SseVersion, + bmiVersion :: Maybe BmiVersion, avx :: Bool, avx2 :: Bool, avx512cd :: Bool, -- Enable AVX-512 Conflict Detection Instructions. @@ -1007,11 +1162,22 @@ data ProfAuto | ProfAutoCalls -- ^ annotate call-sites deriving (Eq,Enum) +data LlvmTarget = LlvmTarget + { lDataLayout :: String + , lCPU :: String + , lAttributes :: [String] + } + +type LlvmTargets = [(String, LlvmTarget)] +type LlvmPasses = [(Int, String)] +type LlvmConfig = (LlvmTargets, LlvmPasses) + data Settings = Settings { - sTargetPlatform :: Platform, -- Filled in by SysTools - sGhcUsagePath :: FilePath, -- Filled in by SysTools - sGhciUsagePath :: FilePath, -- ditto - sTopDir :: FilePath, + sTargetPlatform :: Platform, -- Filled in by SysTools + sGhcUsagePath :: FilePath, -- ditto + sGhciUsagePath :: FilePath, -- ditto + sToolDir :: Maybe FilePath, -- ditto + sTopDir :: FilePath, -- ditto sTmpDir :: String, -- no trailing '/' sProgramName :: String, sProjectVersion :: String, @@ -1037,12 +1203,17 @@ data Settings = Settings { sPgm_T :: String, sPgm_windres :: String, sPgm_libtool :: String, + sPgm_ar :: String, + sPgm_ranlib :: String, sPgm_lo :: (String,[Option]), -- LLVM: opt llvm optimiser sPgm_lc :: (String,[Option]), -- LLVM: llc static compiler + sPgm_lcc :: (String,[Option]), -- LLVM: c compiler sPgm_i :: String, -- options for particular phases sOpt_L :: [String], sOpt_P :: [String], + sOpt_P_fingerprint :: Fingerprint, -- cached Fingerprint of sOpt_P + -- See Note [Repeated -optP hashing] sOpt_F :: [String], sOpt_c :: [String], sOpt_a :: [String], @@ -1050,6 +1221,7 @@ data Settings = Settings { sOpt_windres :: [String], sOpt_lo :: [String], -- LLVM: llvm optimiser sOpt_lc :: [String], -- LLVM: llc static compiler + sOpt_lcc :: [String], -- LLVM: c compiler sOpt_i :: [String], -- iserv options sPlatformConstants :: PlatformConstants @@ -1065,6 +1237,8 @@ ghcUsagePath :: DynFlags -> FilePath ghcUsagePath dflags = sGhcUsagePath (settings dflags) ghciUsagePath :: DynFlags -> FilePath ghciUsagePath dflags = sGhciUsagePath (settings dflags) +toolDir :: DynFlags -> Maybe FilePath +toolDir dflags = sToolDir (settings dflags) topDir :: DynFlags -> FilePath topDir dflags = sTopDir (settings dflags) tmpDir :: DynFlags -> String @@ -1097,6 +1271,12 @@ pgm_windres :: DynFlags -> String pgm_windres dflags = sPgm_windres (settings dflags) pgm_libtool :: DynFlags -> String pgm_libtool dflags = sPgm_libtool (settings dflags) +pgm_lcc :: DynFlags -> (String,[Option]) +pgm_lcc dflags = sPgm_lcc (settings dflags) +pgm_ar :: DynFlags -> String +pgm_ar dflags = sPgm_ar (settings dflags) +pgm_ranlib :: DynFlags -> String +pgm_ranlib dflags = sPgm_ranlib (settings dflags) pgm_lo :: DynFlags -> (String,[Option]) pgm_lo dflags = sPgm_lo (settings dflags) pgm_lc :: DynFlags -> (String,[Option]) @@ -1108,6 +1288,14 @@ opt_L dflags = sOpt_L (settings dflags) opt_P :: DynFlags -> [String] opt_P dflags = concatMap (wayOptP (targetPlatform dflags)) (ways dflags) ++ sOpt_P (settings dflags) + +-- This function packages everything that's needed to fingerprint opt_P +-- flags. See Note [Repeated -optP hashing]. +opt_P_signature :: DynFlags -> ([String], Fingerprint) +opt_P_signature dflags = + ( concatMap (wayOptP (targetPlatform dflags)) (ways dflags) + , sOpt_P_fingerprint (settings dflags)) + opt_F :: DynFlags -> [String] opt_F dflags = sOpt_F (settings dflags) opt_c :: DynFlags -> [String] @@ -1120,6 +1308,8 @@ opt_l dflags = concatMap (wayOptl (targetPlatform dflags)) (ways dflags) ++ sOpt_l (settings dflags) opt_windres :: DynFlags -> [String] opt_windres dflags = sOpt_windres (settings dflags) +opt_lcc :: DynFlags -> [String] +opt_lcc dflags = sOpt_lcc (settings dflags) opt_lo :: DynFlags -> [String] opt_lo dflags = sOpt_lo (settings dflags) opt_lc :: DynFlags -> [String] @@ -1319,12 +1509,22 @@ data DynLibLoader | SystemDependent deriving Eq -data RtsOptsEnabled = RtsOptsNone | RtsOptsSafeOnly | RtsOptsAll +data RtsOptsEnabled + = RtsOptsNone | RtsOptsIgnore | RtsOptsIgnoreAll | RtsOptsSafeOnly + | RtsOptsAll deriving (Show) shouldUseColor :: DynFlags -> Bool shouldUseColor dflags = overrideWith (canUseColor dflags) (useColor dflags) +shouldUseHexWordLiterals :: DynFlags -> Bool +shouldUseHexWordLiterals dflags = + Opt_HexWordLiterals `EnumSet.member` generalFlags dflags + +-- | Are we building with @-fPIE@ or @-fPIC@ enabled? +positionIndependent :: DynFlags -> Bool +positionIndependent dflags = gopt Opt_PIC dflags || gopt Opt_PIE dflags + ----------------------------------------------------------------------------- -- Ways @@ -1404,7 +1604,7 @@ wayGeneralFlags :: Platform -> Way -> [GeneralFlag] wayGeneralFlags _ (WayCustom {}) = [] wayGeneralFlags _ WayThreaded = [] wayGeneralFlags _ WayDebug = [] -wayGeneralFlags _ WayDyn = [Opt_PIC] +wayGeneralFlags _ WayDyn = [Opt_PIC, Opt_ExternalDynamicRefs] -- We could get away without adding -fPIC when compiling the -- modules of a program that is to be linked with -dynamic; the -- program itself does not need to be position-independent, only @@ -1547,8 +1747,8 @@ initDynFlags dflags = do -- | The normal 'DynFlags'. Note that they are not suitable for use in this form -- and must be fully initialized by 'GHC.runGhc' first. -defaultDynFlags :: Settings -> DynFlags -defaultDynFlags mySettings = +defaultDynFlags :: Settings -> LlvmConfig -> DynFlags +defaultDynFlags mySettings (myLlvmTargets, myLlvmPasses) = -- See Note [Updating flag description in the User's Guide] DynFlags { ghcMode = CompManager, @@ -1561,8 +1761,11 @@ defaultDynFlags mySettings = maxSimplIterations = 4, maxPmCheckIterations = 2000000, ruleCheck = Nothing, + inlineCheck = Nothing, maxRelevantBinds = Just 6, - maxValidSubstitutions = Just 6, + maxValidHoleFits = Just 6, + maxRefHoleFits = Just 6, + refLevelHoleFits = Nothing, maxUncoveredPatterns = 4, simplTickFactor = 100, specConstrThreshold = Just 2000, @@ -1570,6 +1773,7 @@ defaultDynFlags mySettings = specConstrRecursive = 3, liberateCaseThreshold = Just 2000, floatLamArgs = Just 0, -- Default: float only if no fvs + cmmProcAlignment = Nothing, historySize = 20, strictnessBefore = [], @@ -1603,12 +1807,10 @@ defaultDynFlags mySettings = dynObjectSuf = "dyn_" ++ phaseInputExt StopLn, dynHiSuf = "dyn_hi", - dllSplitFile = Nothing, - dllSplit = Nothing, - pluginModNames = [], pluginModNameOpts = [], frontendPluginOpts = [], + plugins = [], hooks = emptyHooks, outputFile = Nothing, @@ -1618,7 +1820,7 @@ defaultDynFlags mySettings = dumpPrefix = Nothing, dumpPrefixForce = Nothing, ldInputs = [], - includePaths = [], + includePaths = IncludeSpecs [] [], libraryPaths = [], frameworkPaths = [], cmdlineFrameworks = [], @@ -1641,6 +1843,9 @@ defaultDynFlags mySettings = buildTag = mkBuildTag (defaultWays mySettings), splitInfo = Nothing, settings = mySettings, + llvmTargets = myLlvmTargets, + llvmPasses = myLlvmPasses, + -- ghc -M values depMakefile = "Makefile", depIncludePkgDeps = False, @@ -1651,6 +1856,7 @@ defaultDynFlags mySettings = filesToClean = panic "defaultDynFlags: No filesToClean", dirsToClean = panic "defaultDynFlags: No dirsToClean", generatedDumps = panic "defaultDynFlags: No generatedDumps", + ghcVersionFile = Nothing, haddockOptions = Nothing, dumpFlags = EnumSet.empty, generalFlags = EnumSet.fromList (defaultFlags mySettings), @@ -1693,10 +1899,7 @@ defaultDynFlags mySettings = -- Logging - initLogAction = defaultLogOutput, - log_action = defaultLogAction, - log_finaliser = \ _ -> return (), flushOut = defaultFlushOut, flushErr = defaultFlushErr, @@ -1710,6 +1913,7 @@ defaultDynFlags mySettings = interactivePrint = Nothing, nextWrapperNum = panic "defaultDynFlags: No nextWrapperNum", sseVersion = Nothing, + bmiVersion = Nothing, avx = False, avx2 = False, avx512cd = False, @@ -1756,9 +1960,10 @@ interpreterDynamic dflags -- Note [JSON Error Messages] -- -- When the user requests the compiler output to be dumped as json --- we modify the log_action to collect all the messages in an IORef --- and then finally in GHC.withCleanupSession the log_finaliser is --- called which prints out the messages together. +-- we used to collect them all in an IORef and then print them at the end. +-- This doesn't work very well with GHCi. (See #14078) So instead we now +-- use the simpler method of just outputting a JSON document inplace to +-- stdout. -- -- Before the compiler calls log_action, it has already turned the `ErrMsg` -- into a formatted message. This means that we lose some possible @@ -1768,14 +1973,6 @@ interpreterDynamic dflags type FatalMessager = String -> IO () -data LogOutput = LogOutput - { getLogAction :: LogAction - , getLogFinaliser :: LogFinaliser - } - -defaultLogOutput :: IO (Maybe LogOutput) -defaultLogOutput = return $ Nothing - type LogAction = DynFlags -> WarnReason -> Severity @@ -1784,41 +1981,24 @@ type LogAction = DynFlags -> MsgDoc -> IO () -type LogFinaliser = DynFlags -> IO () - defaultFatalMessager :: FatalMessager defaultFatalMessager = hPutStrLn stderr -- See Note [JSON Error Messages] -jsonLogOutput :: IO (Maybe LogOutput) -jsonLogOutput = do - ref <- newIORef [] - return . Just $ LogOutput (jsonLogAction ref) (jsonLogFinaliser ref) - -jsonLogAction :: IORef [SDoc] -> LogAction -jsonLogAction iref dflags reason severity srcSpan style msg +-- +jsonLogAction :: LogAction +jsonLogAction dflags reason severity srcSpan _style msg = do - addMessage . withPprStyle (mkCodeStyle CStyle) . renderJSON $ - JSObject [ ( "span", json srcSpan ) - , ( "doc" , JSString (showSDoc dflags msg) ) - , ( "severity", json severity ) - , ( "reason" , json reason ) - ] - defaultLogAction dflags reason severity srcSpan style msg - where - addMessage m = modifyIORef iref (m:) - - -jsonLogFinaliser :: IORef [SDoc] -> DynFlags -> IO () -jsonLogFinaliser iref dflags = do - msgs <- readIORef iref - let fmt_msgs = brackets $ pprWithCommas (blankLine $$) msgs - output fmt_msgs - where - -- dumpSDoc uses log_action to output the dump - dflags' = dflags { log_action = defaultLogAction } - output doc = dumpSDoc dflags' neverQualify Opt_D_dump_json "" doc + defaultLogActionHPutStrDoc dflags stdout (doc $$ text "") + (mkCodeStyle CStyle) + where + doc = renderJSON $ + JSObject [ ( "span", json srcSpan ) + , ( "doc" , JSString (showSDoc dflags msg) ) + , ( "severity", json severity ) + , ( "reason" , json reason ) + ] defaultLogAction :: LogAction @@ -1935,6 +2115,9 @@ languageExtensions Nothing languageExtensions (Just Haskell98) = [LangExt.ImplicitPrelude, + -- See Note [When is StarIsType enabled] + LangExt.StarIsType, + LangExt.MonadFailDesugaring, LangExt.MonomorphismRestriction, LangExt.NPlusKPatterns, LangExt.DatatypeContexts, @@ -1949,6 +2132,9 @@ languageExtensions (Just Haskell98) languageExtensions (Just Haskell2010) = [LangExt.ImplicitPrelude, + -- See Note [When is StarIsType enabled] + LangExt.StarIsType, + LangExt.MonadFailDesugaring, LangExt.MonomorphismRestriction, LangExt.DatatypeContexts, LangExt.TraditionalRecordSyntax, @@ -2083,6 +2269,9 @@ lang_set dflags lang = useUnicodeSyntax :: DynFlags -> Bool useUnicodeSyntax = gopt Opt_PrintUnicodeSyntax +useStarIsType :: DynFlags -> Bool +useStarIsType = xopt LangExt.StarIsType + -- | Set the Haskell language standard to use setLanguage :: Language -> DynP () setLanguage l = upd (`lang_set` Just l) @@ -2195,7 +2384,8 @@ setOutputFile, setDynOutputFile, setOutputHi, setDumpPrefixForce setObjectDir f d = d { objectDir = Just f} setHiDir f d = d { hiDir = Just f} -setStubDir f d = d { stubDir = Just f, includePaths = f : includePaths d } +setStubDir f d = d { stubDir = Just f + , includePaths = addGlobalInclude (includePaths d) [f] } -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file -- \#included from the .hc file when compiling via C (i.e. unregisterised -- builds). @@ -2214,7 +2404,7 @@ setDynOutputFile f d = d { dynOutputFile = f} setOutputHi f d = d { outputHi = f} setJsonLogAction :: DynFlags -> DynFlags -setJsonLogAction d = d { initLogAction = jsonLogOutput } +setJsonLogAction d = d { log_action = jsonLogAction } thisComponentId :: DynFlags -> ComponentId thisComponentId dflags = @@ -2289,7 +2479,12 @@ setDumpPrefixForce f d = d { dumpPrefixForce = f} setPgmP f = let (pgm:args) = words f in alterSettings (\s -> s { sPgm_P = (pgm, map Option args)}) addOptl f = alterSettings (\s -> s { sOpt_l = f : sOpt_l s}) addOptc f = alterSettings (\s -> s { sOpt_c = f : sOpt_c s}) -addOptP f = alterSettings (\s -> s { sOpt_P = f : sOpt_P s}) +addOptP f = alterSettings (\s -> s { sOpt_P = f : sOpt_P s + , sOpt_P_fingerprint = fingerprintStrings (f : sOpt_P s) + }) + -- See Note [Repeated -optP hashing] + where + fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss setDepMakefile :: FilePath -> DynFlags -> DynFlags @@ -2307,6 +2502,9 @@ addDepSuffix s d = d { depSuffixes = s : depSuffixes d } addCmdlineFramework f d = d { cmdlineFrameworks = f : cmdlineFrameworks d} +addGhcVersionFile :: FilePath -> DynFlags -> DynFlags +addGhcVersionFile f d = d { ghcVersionFile = Just f } + addHaddockOpts f d = d { haddockOptions = Just f} addGhciScript f d = d { ghciScripts = f : ghciScripts d} @@ -2419,47 +2617,17 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do let (dflags5, consistency_warnings) = makeDynFlagsConsistent dflags4 - dflags6 <- case dllSplitFile dflags5 of - Nothing -> return (dflags5 { dllSplit = Nothing }) - Just f -> - case dllSplit dflags5 of - Just _ -> - -- If dllSplit is out of date then it would have - -- been set to Nothing. As it's a Just, it must be - -- up-to-date. - return dflags5 - Nothing -> - do xs <- liftIO $ readFile f - let ss = map (Set.fromList . words) (lines xs) - return $ dflags5 { dllSplit = Just ss } - -- Set timer stats & heap size - when (enableTimeStats dflags6) $ liftIO enableTimingStats - case (ghcHeapSize dflags6) of + when (enableTimeStats dflags5) $ liftIO enableTimingStats + case (ghcHeapSize dflags5) of Just x -> liftIO (setHeapSize x) _ -> return () - dflags7 <- liftIO $ setLogAction dflags6 - - liftIO $ setUnsafeGlobalDynFlags dflags7 + liftIO $ setUnsafeGlobalDynFlags dflags5 let warns' = map (Warn Cmd.NoReason) (consistency_warnings ++ sh_warns) - return (dflags7, leftover, warns' ++ warns) - -setLogAction :: DynFlags -> IO DynFlags -setLogAction dflags = do - mlogger <- initLogAction dflags - return $ - maybe - dflags - (\logger -> - dflags - { log_action = getLogAction logger - , log_finaliser = getLogFinaliser logger - , initLogAction = return $ Nothing -- Don't initialise it twice - }) - mlogger + return (dflags5, leftover, warns' ++ warns) -- | Write an error or warning to the 'LogOutput'. putLogMsg :: DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle @@ -2483,7 +2651,7 @@ safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Located String]) safeFlagCheck _ dflags | safeLanguageOn dflags = (dflagsUnset, warns) where -- Handle illegal flags under safe language. - (dflagsUnset, warns) = foldl check_method (dflags, []) unsafeFlags + (dflagsUnset, warns) = foldl' check_method (dflags, []) unsafeFlags check_method (df, warns) (str,loc,test,fix) | test df = (fix df, warns ++ safeFailure (loc df) str) @@ -2530,11 +2698,8 @@ allNonDeprecatedFlags = allFlagsDeps False allFlagsDeps :: Bool -> [String] allFlagsDeps keepDeprecated = [ '-':flagName flag | (deprecated, flag) <- flagsAllDeps - , ok (flagOptKind flag) , keepDeprecated || not (isDeprecated deprecated)] - where ok (PrefixPred _ _) = False - ok _ = True - isDeprecated Deprecated = True + where isDeprecated Deprecated = True isDeprecated _ = False {- @@ -2594,10 +2759,6 @@ add_dep_message (PassFlag f) message = PassFlag $ \s -> f s >> deprecate message add_dep_message (AnySuffix f) message = AnySuffix $ \s -> f s >> deprecate message -add_dep_message (PrefixPred pred f) message = - PrefixPred pred $ \s -> f s >> deprecate message -add_dep_message (AnySuffixPred pred f) message = - AnySuffixPred pred $ \s -> f s >> deprecate message ----------------------- The main flags themselves ------------------------------ -- See Note [Updating flag description in the User's Guide] @@ -2663,6 +2824,10 @@ dynamic_flags_deps = [ #endif , make_ord_flag defGhcFlag "relative-dynlib-paths" (NoArg (setGeneralFlag Opt_RelativeDynlibPaths)) + , make_ord_flag defGhcFlag "copy-libs-when-linking" + (NoArg (setGeneralFlag Opt_SingleLibFolder)) + , make_ord_flag defGhcFlag "pie" (NoArg (setGeneralFlag Opt_PICExecutable)) + , make_ord_flag defGhcFlag "no-pie" (NoArg (unSetGeneralFlag Opt_PICExecutable)) ------- Specific phases -------------------------------------------- -- need to appear before -pgmL to be parsed as LLVM flags. @@ -2692,6 +2857,11 @@ dynamic_flags_deps = [ (hasArg (\f -> alterSettings (\s -> s { sPgm_windres = f}))) , make_ord_flag defFlag "pgmlibtool" (hasArg (\f -> alterSettings (\s -> s { sPgm_libtool = f}))) + , make_ord_flag defFlag "pgmar" + (hasArg (\f -> alterSettings (\s -> s { sPgm_ar = f}))) + , make_ord_flag defFlag "pgmranlib" + (hasArg (\f -> alterSettings (\s -> s { sPgm_ranlib = f}))) + -- need to appear before -optl/-opta to be parsed as LLVM flags. , make_ord_flag defFlag "optlo" @@ -2746,9 +2916,6 @@ dynamic_flags_deps = [ (noArg (\d -> d { ghcLink=LinkStaticLib })) , make_ord_flag defGhcFlag "dynload" (hasArg parseDynLibLoaderMode) , make_ord_flag defGhcFlag "dylib-install-name" (hasArg setDylibInstallName) - -- -dll-split is an internal flag, used only during the GHC build - , make_ord_flag defHiddenFlag "dll-split" - (hasArg (\f d -> d { dllSplitFile = Just f, dllSplit = Nothing })) ------- Libraries --------------------------------------------------- , make_ord_flag defFlag "L" (Prefix addLibraryPath) @@ -2788,6 +2955,10 @@ dynamic_flags_deps = [ (NoArg (setGeneralFlag Opt_KeepHcFiles)) , make_ord_flag defGhcFlag "keep-hc-files" (NoArg (setGeneralFlag Opt_KeepHcFiles)) + , make_ord_flag defGhcFlag "keep-hscpp-file" + (NoArg (setGeneralFlag Opt_KeepHscppFiles)) + , make_ord_flag defGhcFlag "keep-hscpp-files" + (NoArg (setGeneralFlag Opt_KeepHscppFiles)) , make_ord_flag defGhcFlag "keep-s-file" (NoArg (setGeneralFlag Opt_KeepSFiles)) , make_ord_flag defGhcFlag "keep-s-files" @@ -2835,11 +3006,18 @@ dynamic_flags_deps = [ (NoArg (setRtsOptsEnabled RtsOptsSafeOnly)) , make_ord_flag defGhcFlag "rtsopts=none" (NoArg (setRtsOptsEnabled RtsOptsNone)) + , make_ord_flag defGhcFlag "rtsopts=ignore" + (NoArg (setRtsOptsEnabled RtsOptsIgnore)) + , make_ord_flag defGhcFlag "rtsopts=ignoreAll" + (NoArg (setRtsOptsEnabled RtsOptsIgnoreAll)) , make_ord_flag defGhcFlag "no-rtsopts" (NoArg (setRtsOptsEnabled RtsOptsNone)) , make_ord_flag defGhcFlag "no-rtsopts-suggestions" (noArg (\d -> d {rtsOptsSuggestions = False})) + , make_ord_flag defGhcFlag "dhex-word-literals" + (NoArg (setGeneralFlag Opt_HexWordLiterals)) + , make_ord_flag defGhcFlag "ghcversion-file" (hasArg addGhcVersionFile) , make_ord_flag defGhcFlag "main-is" (SepArg setMainIs) , make_ord_flag defGhcFlag "haddock" (NoArg (setGeneralFlag Opt_Haddock)) , make_ord_flag defGhcFlag "haddock-opts" (hasArg addHaddockOpts) @@ -2897,7 +3075,9 @@ dynamic_flags_deps = [ setGeneralFlag Opt_SuppressTypeApplications setGeneralFlag Opt_SuppressIdInfo setGeneralFlag Opt_SuppressTicks - setGeneralFlag Opt_SuppressTypeSignatures) + setGeneralFlag Opt_SuppressStgFreeVars + setGeneralFlag Opt_SuppressTypeSignatures + setGeneralFlag Opt_SuppressTimestamps) ------ Debugging ---------------------------------------------------- , make_ord_flag defGhcFlag "dstg-stats" @@ -2957,6 +3137,8 @@ dynamic_flags_deps = [ (setDumpFlag Opt_D_dump_deriv) , make_ord_flag defGhcFlag "ddump-ds" (setDumpFlag Opt_D_dump_ds) + , make_ord_flag defGhcFlag "ddump-ds-preopt" + (setDumpFlag Opt_D_dump_ds_preopt) , make_ord_flag defGhcFlag "ddump-foreign" (setDumpFlag Opt_D_dump_foreign) , make_ord_flag defGhcFlag "ddump-inlinings" @@ -2989,6 +3171,8 @@ dynamic_flags_deps = [ (setDumpFlag Opt_D_dump_stg) , make_ord_flag defGhcFlag "ddump-call-arity" (setDumpFlag Opt_D_dump_call_arity) + , make_ord_flag defGhcFlag "ddump-exitify" + (setDumpFlag Opt_D_dump_exitify) , make_ord_flag defGhcFlag "ddump-stranal" (setDumpFlag Opt_D_dump_stranal) , make_ord_flag defGhcFlag "ddump-str-signatures" @@ -3043,8 +3227,6 @@ dynamic_flags_deps = [ (setDumpFlag Opt_D_dump_hi) , make_ord_flag defGhcFlag "ddump-minimal-imports" (NoArg (setGeneralFlag Opt_D_dump_minimal_imports)) - , make_ord_flag defGhcFlag "ddump-vect" - (setDumpFlag Opt_D_dump_vect) , make_ord_flag defGhcFlag "ddump-hpc" (setDumpFlag Opt_D_dump_ticked) -- back compat , make_ord_flag defGhcFlag "ddump-ticked" @@ -3053,6 +3235,8 @@ dynamic_flags_deps = [ (setDumpFlag Opt_D_dump_mod_cycles) , make_ord_flag defGhcFlag "ddump-mod-map" (setDumpFlag Opt_D_dump_mod_map) + , make_ord_flag defGhcFlag "ddump-timings" + (setDumpFlag Opt_D_dump_timings) , make_ord_flag defGhcFlag "ddump-view-pattern-commoning" (setDumpFlag Opt_D_dump_view_pattern_commoning) , make_ord_flag defGhcFlag "ddump-to-file" @@ -3077,12 +3261,16 @@ dynamic_flags_deps = [ (NoArg (setGeneralFlag Opt_D_faststring_stats)) , make_ord_flag defGhcFlag "dno-llvm-mangler" (NoArg (setGeneralFlag Opt_NoLlvmMangler)) -- hidden flag + , make_ord_flag defGhcFlag "fast-llvm" + (NoArg (setGeneralFlag Opt_FastLlvm)) -- hidden flag , make_ord_flag defGhcFlag "ddump-debug" (setDumpFlag Opt_D_dump_debug) , make_ord_flag defGhcFlag "ddump-json" (noArg (flip dopt_set Opt_D_dump_json . setJsonLogAction ) ) , make_ord_flag defGhcFlag "dppr-debug" (setDumpFlag Opt_D_ppr_debug) + , make_ord_flag defGhcFlag "ddebug-output" + (noArg (flip dopt_unset Opt_D_no_debug_output)) , make_ord_flag defGhcFlag "dno-debug-output" (setDumpFlag Opt_D_no_debug_output) @@ -3098,6 +3286,10 @@ dynamic_flags_deps = [ d { sseVersion = Just SSE4 })) , make_ord_flag defGhcFlag "msse4.2" (noArg (\d -> d { sseVersion = Just SSE42 })) + , make_ord_flag defGhcFlag "mbmi" (noArg (\d -> + d { bmiVersion = Just BMI1 })) + , make_ord_flag defGhcFlag "mbmi2" (noArg (\d -> + d { bmiVersion = Just BMI2 })) , make_ord_flag defGhcFlag "mavx" (noArg (\d -> d { avx = True })) , make_ord_flag defGhcFlag "mavx2" (noArg (\d -> d { avx2 = True })) , make_ord_flag defGhcFlag "mavx512cd" (noArg (\d -> @@ -3160,7 +3352,6 @@ dynamic_flags_deps = [ ------ Optimisation flags ------------------------------------------ , make_dep_flag defGhcFlag "Onot" (noArgM $ setOptLevel 0 ) "Use -O0 instead" - , make_ord_flag defGhcFlag "Odph" (noArgM setDPHOpt) , make_ord_flag defGhcFlag "O" (optIntSuffixM (\mb_n -> setOptLevel (mb_n `orElse` 1))) -- If the number is missing, use 1 @@ -3170,10 +3361,20 @@ dynamic_flags_deps = [ (intSuffix (\n d -> d { maxRelevantBinds = Just n })) , make_ord_flag defFlag "fno-max-relevant-binds" (noArg (\d -> d { maxRelevantBinds = Nothing })) - , make_ord_flag defFlag "fmax-valid-substitutions" - (intSuffix (\n d -> d { maxValidSubstitutions = Just n })) - , make_ord_flag defFlag "fno-max-valid-substitutions" - (noArg (\d -> d { maxValidSubstitutions = Nothing })) + + , make_ord_flag defFlag "fmax-valid-hole-fits" + (intSuffix (\n d -> d { maxValidHoleFits = Just n })) + , make_ord_flag defFlag "fno-max-valid-hole-fits" + (noArg (\d -> d { maxValidHoleFits = Nothing })) + , make_ord_flag defFlag "fmax-refinement-hole-fits" + (intSuffix (\n d -> d { maxRefHoleFits = Just n })) + , make_ord_flag defFlag "fno-max-refinement-hole-fits" + (noArg (\d -> d { maxRefHoleFits = Nothing })) + , make_ord_flag defFlag "frefinement-level-hole-fits" + (intSuffix (\n d -> d { refLevelHoleFits = Just n })) + , make_ord_flag defFlag "fno-refinement-level-hole-fits" + (noArg (\d -> d { refLevelHoleFits = Nothing })) + , make_ord_flag defFlag "fmax-uncovered-patterns" (intSuffix (\n d -> d { maxUncoveredPatterns = n })) , make_ord_flag defFlag "fsimplifier-phases" @@ -3198,8 +3399,10 @@ dynamic_flags_deps = [ (intSuffix (\n d -> d { liberateCaseThreshold = Just n })) , make_ord_flag defFlag "fno-liberate-case-threshold" (noArg (\d -> d { liberateCaseThreshold = Nothing })) - , make_ord_flag defFlag "frule-check" + , make_ord_flag defFlag "drule-check" (sepArg (\s d -> d { ruleCheck = Just s })) + , make_ord_flag defFlag "dinline-check" + (sepArg (\s d -> d { inlineCheck = Just s })) , make_ord_flag defFlag "freduction-depth" (intSuffix (\n d -> d { reductionDepth = treatZeroAsInf n })) , make_ord_flag defFlag "fconstraint-solver-iterations" @@ -3218,6 +3421,10 @@ dynamic_flags_deps = [ (intSuffix (\n d -> d { floatLamArgs = Just n })) , make_ord_flag defFlag "ffloat-all-lams" (noArg (\d -> d { floatLamArgs = Nothing })) + , make_ord_flag defFlag "fproc-alignment" + (intSuffix (\n d -> d { cmmProcAlignment = Just n })) + + , make_ord_flag defFlag "fhistory-size" (intSuffix (\n d -> d { historySize = n })) , make_ord_flag defFlag "funfolding-creation-threshold" @@ -3311,6 +3518,8 @@ dynamic_flags_deps = [ d { safeInfer = False })) , make_ord_flag defGhcFlag "fPIC" (NoArg (setGeneralFlag Opt_PIC)) , make_ord_flag defGhcFlag "fno-PIC" (NoArg (unSetGeneralFlag Opt_PIC)) + , make_ord_flag defGhcFlag "fPIE" (NoArg (setGeneralFlag Opt_PIC)) + , make_ord_flag defGhcFlag "fno-PIE" (NoArg (unSetGeneralFlag Opt_PIC)) ------ Debugging flags ---------------------------------------------- , make_ord_flag defGhcFlag "g" (OptIntSuffix setDebugLevel) @@ -3323,10 +3532,7 @@ dynamic_flags_deps = [ ++ map (mkFlag turnOff "fno-" unSetGeneralFlag ) fFlagsDeps ++ map (mkFlag turnOn "W" setWarningFlag ) wWarningFlagsDeps ++ map (mkFlag turnOff "Wno-" unSetWarningFlag ) wWarningFlagsDeps - ++ map (mkFlag turnOn "Werror=" (\flag -> do { - ; setWarningFlag flag - ; setFatalWarningFlag flag })) - wWarningFlagsDeps + ++ map (mkFlag turnOn "Werror=" setWErrorFlag ) wWarningFlagsDeps ++ map (mkFlag turnOn "Wwarn=" unSetFatalWarningFlag ) wWarningFlagsDeps ++ map (mkFlag turnOn "Wno-error=" unSetFatalWarningFlag ) @@ -3338,6 +3544,12 @@ dynamic_flags_deps = [ ++ [ (NotDeprecated, unrecognisedWarning "W"), (Deprecated, unrecognisedWarning "fwarn-"), (Deprecated, unrecognisedWarning "fno-warn-") ] + ++ [ make_ord_flag defFlag "Werror=compat" + (NoArg (mapM_ setWErrorFlag minusWcompatOpts)) + , make_ord_flag defFlag "Wno-error=compat" + (NoArg (mapM_ unSetFatalWarningFlag minusWcompatOpts)) + , make_ord_flag defFlag "Wwarn=compat" + (NoArg (mapM_ unSetFatalWarningFlag minusWcompatOpts)) ] ++ map (mkFlag turnOn "f" setExtensionFlag ) fLangFlagsDeps ++ map (mkFlag turnOff "fno-" unSetExtensionFlag) fLangFlagsDeps ++ map (mkFlag turnOn "X" setExtensionFlag ) xFlagsDeps @@ -3563,8 +3775,6 @@ wWarningFlagsDeps = [ -- Please keep the list of flags below sorted alphabetically flagSpec "alternative-layout-rule-transitional" Opt_WarnAlternativeLayoutRuleTransitional, - depFlagSpec "amp" Opt_WarnAMP - "it has no effect", depFlagSpec "auto-orphans" Opt_WarnAutoOrphans "it has no effect", flagSpec "cpp-undef" Opt_WarnCPPUndef, @@ -3584,7 +3794,9 @@ wWarningFlagsDeps = [ flagSpec "redundant-constraints" Opt_WarnRedundantConstraints, flagSpec "duplicate-exports" Opt_WarnDuplicateExports, flagSpec "hi-shadowing" Opt_WarnHiShadows, + flagSpec "inaccessible-code" Opt_WarnInaccessibleCode, flagSpec "implicit-prelude" Opt_WarnImplicitPrelude, + flagSpec "implicit-kind-vars" Opt_WarnImplicitKindVars, flagSpec "incomplete-patterns" Opt_WarnIncompletePatterns, flagSpec "incomplete-record-updates" Opt_WarnIncompletePatternsRecUpd, flagSpec "incomplete-uni-patterns" Opt_WarnIncompleteUniPatterns, @@ -3592,6 +3804,7 @@ wWarningFlagsDeps = [ flagSpec "identities" Opt_WarnIdentities, flagSpec "missing-fields" Opt_WarnMissingFields, flagSpec "missing-import-lists" Opt_WarnMissingImportList, + flagSpec "missing-export-lists" Opt_WarnMissingExportList, depFlagSpec "missing-local-sigs" Opt_WarnMissingLocalSignatures "it is replaced by -Wmissing-local-signatures", flagSpec "missing-local-signatures" Opt_WarnMissingLocalSignatures, @@ -3644,7 +3857,10 @@ wWarningFlagsDeps = [ Opt_WarnMissingPatternSynonymSignatures, flagSpec "simplifiable-class-constraints" Opt_WarnSimplifiableClassConstraints, flagSpec "missing-home-modules" Opt_WarnMissingHomeModules, - flagSpec "unrecognised-warning-flags" Opt_WarnUnrecognisedWarningFlags ] + flagSpec "unrecognised-warning-flags" Opt_WarnUnrecognisedWarningFlags, + flagSpec "star-binder" Opt_WarnStarBinder, + flagSpec "star-is-type" Opt_WarnStarIsType, + flagSpec "partial-fields" Opt_WarnPartialFields ] -- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@ negatableFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)] @@ -3661,14 +3877,17 @@ dFlagsDeps = [ depFlagSpec' "ppr-ticks" Opt_PprShowTicks (\turn_on -> useInstead "-d" "suppress-ticks" (not turn_on)), flagSpec "suppress-ticks" Opt_SuppressTicks, + flagSpec "suppress-stg-free-vars" Opt_SuppressStgFreeVars, flagSpec "suppress-coercions" Opt_SuppressCoercions, flagSpec "suppress-idinfo" Opt_SuppressIdInfo, flagSpec "suppress-unfoldings" Opt_SuppressUnfoldings, flagSpec "suppress-module-prefixes" Opt_SuppressModulePrefixes, + flagSpec "suppress-timestamps" Opt_SuppressTimestamps, flagSpec "suppress-type-applications" Opt_SuppressTypeApplications, flagSpec "suppress-type-signatures" Opt_SuppressTypeSignatures, flagSpec "suppress-uniques" Opt_SuppressUniques, - flagSpec "suppress-var-kinds" Opt_SuppressVarKinds] + flagSpec "suppress-var-kinds" Opt_SuppressVarKinds + ] -- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@ fFlags :: [FlagSpec GeneralFlag] @@ -3679,10 +3898,12 @@ fFlagsDeps = [ -- See Note [Updating flag description in the User's Guide] -- See Note [Supporting CLI completion] -- Please keep the list of flags below sorted alphabetically + flagSpec "asm-shortcutting" Opt_AsmShortcutting, flagGhciSpec "break-on-error" Opt_BreakOnError, flagGhciSpec "break-on-exception" Opt_BreakOnException, flagSpec "building-cabal-package" Opt_BuildingCabalPackage, flagSpec "call-arity" Opt_CallArity, + flagSpec "exitification" Opt_Exitification, flagSpec "case-merge" Opt_CaseMerge, flagSpec "case-folding" Opt_CaseFolding, flagSpec "cmm-elim-common-blocks" Opt_CmmElimCommonBlocks, @@ -3705,15 +3926,20 @@ fFlagsDeps = [ flagSpec "error-spans" Opt_ErrorSpans, flagSpec "excess-precision" Opt_ExcessPrecision, flagSpec "expose-all-unfoldings" Opt_ExposeAllUnfoldings, + flagSpec "external-dynamic-refs" Opt_ExternalDynamicRefs, flagSpec "external-interpreter" Opt_ExternalInterpreter, flagSpec "flat-cache" Opt_FlatCache, flagSpec "float-in" Opt_FloatIn, flagSpec "force-recomp" Opt_ForceRecomp, + flagSpec "ignore-optim-changes" Opt_IgnoreOptimChanges, + flagSpec "ignore-hpc-changes" Opt_IgnoreHpcChanges, flagSpec "full-laziness" Opt_FullLaziness, flagSpec "fun-to-thunk" Opt_FunToThunk, flagSpec "gen-manifest" Opt_GenManifest, flagSpec "ghci-history" Opt_GhciHistory, + flagSpec "ghci-leak-check" Opt_GhciLeakCheck, flagGhciSpec "local-ghci-history" Opt_LocalGhciHistory, + flagGhciSpec "no-it" Opt_NoIt, flagSpec "ghci-sandbox" Opt_GhciSandbox, flagSpec "helpful-errors" Opt_HelpfulErrors, flagSpec "hpc" Opt_Hpc, @@ -3724,8 +3950,9 @@ fFlagsDeps = [ flagSpec "kill-absence" Opt_KillAbsence, flagSpec "kill-one-shot" Opt_KillOneShot, flagSpec "late-dmd-anal" Opt_LateDmdAnal, + flagSpec "late-specialise" Opt_LateSpecialise, flagSpec "liberate-case" Opt_LiberateCase, - flagHiddenSpec "llvm-pass-vectors-in-regs" Opt_LlvmPassVectorsInRegisters, + flagSpec "llvm-pass-vectors-in-regs" Opt_LlvmPassVectorsInRegisters, flagHiddenSpec "llvm-tbaa" Opt_LlvmTBAA, flagHiddenSpec "llvm-fill-undef-with-garbage" Opt_LlvmFillUndefWithGarbage, flagSpec "loopification" Opt_Loopification, @@ -3767,17 +3994,43 @@ fFlagsDeps = [ flagSpec "write-interface" Opt_WriteInterface, flagSpec "unbox-small-strict-fields" Opt_UnboxSmallStrictFields, flagSpec "unbox-strict-fields" Opt_UnboxStrictFields, - flagSpec "vectorisation-avoidance" Opt_VectorisationAvoidance, - flagSpec "vectorise" Opt_Vectorise, flagSpec "version-macros" Opt_VersionMacros, flagSpec "worker-wrapper" Opt_WorkerWrapper, flagSpec "solve-constant-dicts" Opt_SolveConstantDicts, flagSpec "catch-bottoms" Opt_CatchBottoms, + flagSpec "alignment-sanitisation" Opt_AlignmentSanitisation, + flagSpec "num-constant-folding" Opt_NumConstantFolding, flagSpec "show-warning-groups" Opt_ShowWarnGroups, flagSpec "hide-source-paths" Opt_HideSourcePaths, - flagSpec "show-hole-constraints" Opt_ShowHoleConstraints, + flagSpec "show-loaded-modules" Opt_ShowLoadedModules, flagSpec "whole-archive-hs-libs" Opt_WholeArchiveHsLibs ] + ++ fHoleFlags + +-- | These @-f\<blah\>@ flags have to do with the typed-hole error message or +-- the valid hole fits in that message. See Note [Valid hole fits include ...] +-- in the TcHoleErrors module. These flags can all be reversed with +-- @-fno-\<blah\>@ +fHoleFlags :: [(Deprecation, FlagSpec GeneralFlag)] +fHoleFlags = [ + flagSpec "show-hole-constraints" Opt_ShowHoleConstraints, + depFlagSpec' "show-valid-substitutions" Opt_ShowValidHoleFits + (useInstead "-f" "show-valid-hole-fits"), + flagSpec "show-valid-hole-fits" Opt_ShowValidHoleFits, + -- Sorting settings + flagSpec "sort-valid-hole-fits" Opt_SortValidHoleFits, + flagSpec "sort-by-size-hole-fits" Opt_SortBySizeHoleFits, + flagSpec "sort-by-subsumption-hole-fits" Opt_SortBySubsumHoleFits, + flagSpec "abstract-refinement-hole-fits" Opt_AbstractRefHoleFits, + -- Output format settings + flagSpec "show-hole-matches-of-hole-fits" Opt_ShowMatchesOfHoleFits, + flagSpec "show-provenance-of-hole-fits" Opt_ShowProvOfHoleFits, + flagSpec "show-type-of-hole-fits" Opt_ShowTypeOfHoleFits, + flagSpec "show-type-app-of-hole-fits" Opt_ShowTypeAppOfHoleFits, + flagSpec "show-type-app-vars-of-hole-fits" Opt_ShowTypeAppVarsOfHoleFits, + flagSpec "show-docs-of-hole-fits" Opt_ShowDocsOfHoleFits, + flagSpec "unclutter-valid-hole-fits" Opt_UnclutterValidHoleFits + ] -- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@ fLangFlags :: [FlagSpec LangExt.Extension] @@ -3810,10 +4063,6 @@ fLangFlagsDeps = [ (deprecatedForExtension "ImplicitParams"), depFlagSpec' "scoped-type-variables" LangExt.ScopedTypeVariables (deprecatedForExtension "ScopedTypeVariables"), - depFlagSpec' "parr" LangExt.ParallelArrays - (deprecatedForExtension "ParallelArrays"), - depFlagSpec' "PArr" LangExt.ParallelArrays - (deprecatedForExtension "ParallelArrays"), depFlagSpec' "allow-overlapping-instances" LangExt.OverlappingInstances (deprecatedForExtension "OverlappingInstances"), depFlagSpec' "allow-undecidable-instances" LangExt.UndecidableInstances @@ -3870,7 +4119,10 @@ xFlagsDeps = [ flagSpec "AlternativeLayoutRuleTransitional" LangExt.AlternativeLayoutRuleTransitional, flagSpec "Arrows" LangExt.Arrows, - flagSpec "AutoDeriveTypeable" LangExt.AutoDeriveTypeable, + depFlagSpecCond "AutoDeriveTypeable" LangExt.AutoDeriveTypeable + id + ("Typeable instances are created automatically " ++ + "for all types since GHC 8.2."), flagSpec "BangPatterns" LangExt.BangPatterns, flagSpec "BinaryLiterals" LangExt.BinaryLiterals, flagSpec "CApiFFI" LangExt.CApiFFI, @@ -3891,13 +4143,16 @@ xFlagsDeps = [ flagSpec "DeriveLift" LangExt.DeriveLift, flagSpec "DeriveTraversable" LangExt.DeriveTraversable, flagSpec "DerivingStrategies" LangExt.DerivingStrategies, + flagSpec "DerivingVia" LangExt.DerivingVia, flagSpec "DisambiguateRecordFields" LangExt.DisambiguateRecordFields, flagSpec "DoAndIfThenElse" LangExt.DoAndIfThenElse, + flagSpec "BlockArguments" LangExt.BlockArguments, depFlagSpec' "DoRec" LangExt.RecursiveDo (deprecatedForExtension "RecursiveDo"), flagSpec "DuplicateRecordFields" LangExt.DuplicateRecordFields, flagSpec "EmptyCase" LangExt.EmptyCase, flagSpec "EmptyDataDecls" LangExt.EmptyDataDecls, + flagSpec "EmptyDataDeriving" LangExt.EmptyDataDeriving, flagSpec "ExistentialQuantification" LangExt.ExistentialQuantification, flagSpec "ExplicitForAll" LangExt.ExplicitForAll, flagSpec "ExplicitNamespaces" LangExt.ExplicitNamespaces, @@ -3911,6 +4166,8 @@ xFlagsDeps = [ flagSpec "GHCForeignImportPrim" LangExt.GHCForeignImportPrim, flagSpec' "GeneralizedNewtypeDeriving" LangExt.GeneralizedNewtypeDeriving setGenDeriving, + flagSpec' "GeneralisedNewtypeDeriving" LangExt.GeneralizedNewtypeDeriving + setGenDeriving, flagSpec "ImplicitParams" LangExt.ImplicitParams, flagSpec "ImplicitPrelude" LangExt.ImplicitPrelude, flagSpec "ImpredicativeTypes" LangExt.ImpredicativeTypes, @@ -3934,10 +4191,12 @@ xFlagsDeps = [ flagSpec "MonomorphismRestriction" LangExt.MonomorphismRestriction, flagSpec "MultiParamTypeClasses" LangExt.MultiParamTypeClasses, flagSpec "MultiWayIf" LangExt.MultiWayIf, + flagSpec "NumericUnderscores" LangExt.NumericUnderscores, flagSpec "NPlusKPatterns" LangExt.NPlusKPatterns, flagSpec "NamedFieldPuns" LangExt.RecordPuns, flagSpec "NamedWildCards" LangExt.NamedWildCards, flagSpec "NegativeLiterals" LangExt.NegativeLiterals, + flagSpec "HexFloatLiterals" LangExt.HexFloatLiterals, flagSpec "NondecreasingIndentation" LangExt.NondecreasingIndentation, depFlagSpec' "NullaryTypeClasses" LangExt.NullaryTypeClasses (deprecatedForExtension "MultiParamTypeClasses"), @@ -3958,6 +4217,7 @@ xFlagsDeps = [ flagSpec "PatternSynonyms" LangExt.PatternSynonyms, flagSpec "PolyKinds" LangExt.PolyKinds, flagSpec "PolymorphicComponents" LangExt.RankNTypes, + flagSpec "QuantifiedConstraints" LangExt.QuantifiedConstraints, flagSpec "PostfixOperators" LangExt.PostfixOperators, flagSpec "QuasiQuotes" LangExt.QuasiQuotes, flagSpec "Rank2Types" LangExt.RankNTypes, @@ -3974,6 +4234,7 @@ xFlagsDeps = [ flagSpec "RoleAnnotations" LangExt.RoleAnnotations, flagSpec "ScopedTypeVariables" LangExt.ScopedTypeVariables, flagSpec "StandaloneDeriving" LangExt.StandaloneDeriving, + flagSpec "StarIsType" LangExt.StarIsType, flagSpec "StaticPointers" LangExt.StaticPointers, flagSpec "Strict" LangExt.Strict, flagSpec "StrictData" LangExt.StrictData, @@ -4016,7 +4277,8 @@ defaultFlags settings Opt_RPath, Opt_SharedImplib, Opt_SimplPreInlining, - Opt_VersionMacros + Opt_VersionMacros, + Opt_LlvmPassVectorsInRegisters ] ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns] @@ -4025,9 +4287,33 @@ defaultFlags settings ++ default_PIC platform ++ concatMap (wayGeneralFlags platform) (defaultWays settings) + ++ validHoleFitDefaults where platform = sTargetPlatform settings +-- | These are the default settings for the display and sorting of valid hole +-- fits in typed-hole error messages. See Note [Valid hole fits include ...] + -- in the TcHoleErrors module. +validHoleFitDefaults :: [GeneralFlag] +validHoleFitDefaults + = [ Opt_ShowTypeAppOfHoleFits + , Opt_ShowTypeOfHoleFits + , Opt_ShowProvOfHoleFits + , Opt_ShowMatchesOfHoleFits + , Opt_ShowValidHoleFits + , Opt_SortValidHoleFits + , Opt_SortBySizeHoleFits + , Opt_ShowHoleConstraints ] + + +validHoleFitsImpliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] +validHoleFitsImpliedGFlags + = [ (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits) + , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppVarsOfHoleFits) + , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowDocsOfHoleFits) + , (Opt_ShowTypeAppVarsOfHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits) + , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowProvOfHoleFits) ] + default_PIC :: Platform -> [GeneralFlag] default_PIC platform = case (platformOS platform, platformArch platform) of @@ -4046,7 +4332,7 @@ impliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] impliedGFlags = [(Opt_DeferTypeErrors, turnOn, Opt_DeferTypedHoles) ,(Opt_DeferTypeErrors, turnOn, Opt_DeferOutOfScopeVariables) ,(Opt_Strictness, turnOn, Opt_WorkerWrapper) - ] + ] ++ validHoleFitsImpliedGFlags -- General flags that are switched on/off when other general flags are switched -- off @@ -4057,6 +4343,7 @@ impliedXFlags :: [(LangExt.Extension, TurnOnFlag, LangExt.Extension)] impliedXFlags -- See Note [Updating flag description in the User's Guide] = [ (LangExt.RankNTypes, turnOn, LangExt.ExplicitForAll) + , (LangExt.QuantifiedConstraints, turnOn, LangExt.ExplicitForAll) , (LangExt.ScopedTypeVariables, turnOn, LangExt.ExplicitForAll) , (LangExt.LiberalTypeSynonyms, turnOn, LangExt.ExplicitForAll) , (LangExt.ExistentialQuantification, turnOn, LangExt.ExplicitForAll) @@ -4067,12 +4354,16 @@ impliedXFlags , (LangExt.RebindableSyntax, turnOff, LangExt.ImplicitPrelude) -- NB: turn off! + , (LangExt.DerivingVia, turnOn, LangExt.DerivingStrategies) + , (LangExt.GADTs, turnOn, LangExt.GADTSyntax) , (LangExt.GADTs, turnOn, LangExt.MonoLocalBinds) , (LangExt.TypeFamilies, turnOn, LangExt.MonoLocalBinds) , (LangExt.TypeFamilies, turnOn, LangExt.KindSignatures) -- Type families use kind signatures , (LangExt.PolyKinds, turnOn, LangExt.KindSignatures) -- Ditto polymorphic kinds + + -- TypeInType is now just a synonym for a couple of other extensions. , (LangExt.TypeInType, turnOn, LangExt.DataKinds) , (LangExt.TypeInType, turnOn, LangExt.PolyKinds) , (LangExt.TypeInType, turnOn, LangExt.KindSignatures) @@ -4107,19 +4398,27 @@ impliedXFlags , (LangExt.Strict, turnOn, LangExt.StrictData) ] +-- Note [When is StarIsType enabled] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The StarIsType extension determines whether to treat '*' as a regular type +-- operator or as a synonym for 'Data.Kind.Type'. Many existing pre-TypeInType +-- programs expect '*' to be synonymous with 'Type', so by default StarIsType is +-- enabled. +-- +-- Programs that use TypeOperators might expect to repurpose '*' for +-- multiplication or another binary operation, but making TypeOperators imply +-- NoStarIsType caused too much breakage on Hackage. +-- + -- Note [Documenting optimisation flags] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- If you change the list of flags enabled for particular optimisation levels --- please remember to update the User's Guide. The relevant files are: +-- please remember to update the User's Guide. The relevant file is: -- --- * utils/mkUserGuidePart/Options/ --- * docs/users_guide/using.rst +-- docs/users_guide/using-optimisation.rst -- --- The first contains the Flag Reference section, which briefly lists all --- available flags. The second contains a detailed description of the --- flags. Both places should contain information whether a flag is implied by --- -O0, -O or -O2. +-- Make sure to note whether a flag is implied by -O0, -O or -O2. optLevelFlags :: [([Int], GeneralFlag)] optLevelFlags -- see Note [Documenting optimisation flags] @@ -4127,19 +4426,16 @@ optLevelFlags -- see Note [Documenting optimisation flags] , ([0,1,2], Opt_DoEtaReduction) -- See Note [Eta-reduction in -O0] , ([0,1,2], Opt_DmdTxDictSel) , ([0,1,2], Opt_LlvmTBAA) - , ([0,1,2], Opt_VectorisationAvoidance) - -- This one is important for a tiresome reason: - -- we want to make sure that the bindings for data - -- constructors are eta-expanded. This is probably - -- a good thing anyway, but it seems fragile. , ([0], Opt_IgnoreInterfacePragmas) , ([0], Opt_OmitInterfacePragmas) , ([1,2], Opt_CallArity) + , ([1,2], Opt_Exitification) , ([1,2], Opt_CaseMerge) , ([1,2], Opt_CaseFolding) , ([1,2], Opt_CmmElimCommonBlocks) + , ([2], Opt_AsmShortcutting) , ([1,2], Opt_CmmSink) , ([1,2], Opt_CSE) , ([1,2], Opt_StgCSE) @@ -4156,6 +4452,7 @@ optLevelFlags -- see Note [Documenting optimisation flags] , ([1,2], Opt_CprAnal) , ([1,2], Opt_WorkerWrapper) , ([1,2], Opt_SolveConstantDicts) + , ([1,2], Opt_NumConstantFolding) , ([2], Opt_LiberateCase) , ([2], Opt_SpecConstr) @@ -4189,8 +4486,7 @@ removes an assertion failure. -} -- If you change the list of warning enabled by default -- please remember to update the User's Guide. The relevant file is: -- --- * utils/mkUserGuidePart/ --- * docs/users_guide/using-warnings.rst +-- docs/users_guide/using-warnings.rst -- | Warning groups. -- @@ -4261,7 +4557,9 @@ standardWarnings -- see Note [Documenting warning flags] Opt_WarnUnsupportedLlvmVersion, Opt_WarnTabs, Opt_WarnUnrecognisedWarningFlags, - Opt_WarnSimplifiableClassConstraints + Opt_WarnSimplifiableClassConstraints, + Opt_WarnStarBinder, + Opt_WarnInaccessibleCode ] -- | Things you get with -W @@ -4309,6 +4607,7 @@ minusWcompatOpts = [ Opt_WarnMissingMonadFailInstances , Opt_WarnSemigroup , Opt_WarnNonCanonicalMonoidInstances + , Opt_WarnImplicitKindVars ] enableUnusedBinds :: DynP () @@ -4332,6 +4631,7 @@ disableGlasgowExts :: DynP () disableGlasgowExts = do unSetGeneralFlag Opt_PrintExplicitForalls mapM_ unSetExtensionFlag glasgowExtsFlags +-- Please keep what_glasgow_exts_does.rst up to date with this list glasgowExtsFlags :: [LangExt.Extension] glasgowExtsFlags = [ LangExt.ConstrainedClassMethods @@ -4514,6 +4814,11 @@ setFatalWarningFlag, unSetFatalWarningFlag :: WarningFlag -> DynP () setFatalWarningFlag f = upd (\dfs -> wopt_set_fatal dfs f) unSetFatalWarningFlag f = upd (\dfs -> wopt_unset_fatal dfs f) +setWErrorFlag :: WarningFlag -> DynP () +setWErrorFlag flag = + do { setWarningFlag flag + ; setFatalWarningFlag flag } + -------------------------- setExtensionFlag, unSetExtensionFlag :: LangExt.Extension -> DynP () setExtensionFlag f = upd (setExtensionFlag' f) @@ -4669,6 +4974,12 @@ canonicalizeHomeModule dflags mod_name = Nothing -> mkModule (thisPackage dflags) mod_name Just mod -> mod +canonicalizeModuleIfHome :: DynFlags -> Module -> Module +canonicalizeModuleIfHome dflags mod + = if thisPackage dflags == moduleUnitId mod + then canonicalizeHomeModule dflags (moduleName mod) + else mod + -- ----------------------------------------------------------------------------- -- | Find the package environment (if one exists) @@ -4702,12 +5013,14 @@ interpretPackageEnv :: DynFlags -> IO DynFlags interpretPackageEnv dflags = do mPkgEnv <- runMaybeT $ msum $ [ getCmdLineArg >>= \env -> msum [ - probeEnvFile env + probeNullEnv env + , probeEnvFile env , probeEnvName env , cmdLineError env ] , getEnvVar >>= \env -> msum [ - probeEnvFile env + probeNullEnv env + , probeEnvFile env , probeEnvName env , envError env ] @@ -4720,8 +5033,14 @@ interpretPackageEnv dflags = do Nothing -> -- No environment found. Leave DynFlags unchanged. return dflags + Just "-" -> do + -- Explicitly disabled environment file. Leave DynFlags unchanged. + return dflags Just envfile -> do content <- readFile envfile + putLogMsg dflags NoReason SevInfo noSrcSpan + (defaultUserStyle dflags) + (text ("Loaded package environment from " ++ envfile)) let setFlags :: DynP () setFlags = do setGeneralFlag Opt_HideAllPackages @@ -4746,6 +5065,10 @@ interpretPackageEnv dflags = do guard =<< liftMaybeT (doesFileExist path) return path + probeNullEnv :: FilePath -> MaybeT IO FilePath + probeNullEnv "-" = return "-" + probeNullEnv _ = mzero + parseEnvFile :: FilePath -> String -> DynP () parseEnvFile envfile = mapM_ parseEntry . lines where @@ -4856,17 +5179,6 @@ checkOptLevel n dflags | otherwise = Right dflags --- -Odph is equivalent to --- --- -O2 optimise as much as possible --- -fmax-simplifier-iterations20 this is necessary sometimes --- -fsimplifier-phases=3 we use an additional simplifier phase for fusion --- -setDPHOpt :: DynFlags -> DynP DynFlags -setDPHOpt dflags = setOptLevel 2 (dflags { maxSimplIterations = 20 - , simplPhases = 3 - }) - setMainIs :: String -> DynP () setMainIs arg | not (null main_fn) && isLower (head main_fn) @@ -4898,7 +5210,8 @@ addLibraryPath p = upd (\s -> s{libraryPaths = libraryPaths s ++ splitPathList p}) addIncludePath p = - upd (\s -> s{includePaths = includePaths s ++ splitPathList p}) + upd (\s -> s{includePaths = + addGlobalInclude (includePaths s) (splitPathList p)}) addFrameworkPath p = upd (\s -> s{frameworkPaths = frameworkPaths s ++ splitPathList p}) @@ -4998,8 +5311,10 @@ setOptHpcDir arg = upd $ \ d -> d {hpcDir = arg} -- platform. picCCOpts :: DynFlags -> [String] -picCCOpts dflags - = case platformOS (targetPlatform dflags) of +picCCOpts dflags = pieOpts ++ picOpts + where + picOpts = + case platformOS (targetPlatform dflags) of OSDarwin -- Apple prefers to do things the other way round. -- PIC is on by default. @@ -5024,6 +5339,23 @@ picCCOpts dflags ["-fPIC", "-U__PIC__", "-D__PIC__"] | otherwise -> [] + pieOpts + | gopt Opt_PICExecutable dflags = ["-pie"] + -- See Note [No PIE when linking] + | sGccSupportsNoPie (settings dflags) = ["-no-pie"] + | otherwise = [] + + +{- +Note [No PIE while linking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As of 2016 some Linux distributions (e.g. Debian) have started enabling -pie by +default in their gcc builds. This is incompatible with -r as it implies that we +are producing an executable. Consequently, we must manually pass -no-pie to gcc +when joining object files or linking dynamic libraries. Unless, of course, the +user has explicitly requested a PIE executable with -pie. See #12759. +-} + picPOpts :: DynFlags -> [String] picPOpts dflags | gopt Opt_PIC dflags = ["-U__PIC__", "-D__PIC__"] @@ -5047,7 +5379,8 @@ compilerInfo dflags -- Next come the settings, so anything else can be overridden -- in the settings file (as "lookup" uses the first match for the -- key) - : rawSettings dflags + : map (fmap $ expandDirectories (topDir dflags) (toolDir dflags)) + (rawSettings dflags) ++ [("Project version", projectVersion dflags), ("Project Git commit id", cProjectGitCommitId), ("Booter version", cBooterVersion), @@ -5098,6 +5431,8 @@ compilerInfo dflags showBool True = "YES" showBool False = "NO" isWindows = platformOS (targetPlatform dflags) == OSMinGW32 + expandDirectories :: FilePath -> Maybe FilePath -> String -> String + expandDirectories topd mtoold = expandToolDir mtoold . expandTopDir topd -- Produced by deriveConstants #include "GHCConstantsHaskellWrappers.hs" @@ -5194,6 +5529,9 @@ makeDynFlagsConsistent dflags = let dflags' = dflags { hscTarget = HscLlvm } warn = "No native code generator, so using LLVM" in loop dflags' warn + | not (osElfTarget os) && gopt Opt_PIE dflags + = loop (gopt_unset dflags Opt_PIE) + "Position-independent only supported on ELF platforms" | os == OSDarwin && arch == ArchX86_64 && not (gopt Opt_PIC dflags) @@ -5234,9 +5572,11 @@ makeDynFlagsConsistent dflags -- initialized. defaultGlobalDynFlags :: DynFlags defaultGlobalDynFlags = - (defaultDynFlags settings) { verbosity = 2 } + (defaultDynFlags settings (llvmTargets, llvmPasses)) { verbosity = 2 } where - settings = panic "v_unsafeGlobalDynFlags: not initialised" + settings = panic "v_unsafeGlobalDynFlags: settings not initialised" + llvmTargets = panic "v_unsafeGlobalDynFlags: llvmTargets not initialised" + llvmPasses = panic "v_unsafeGlobalDynFlags: llvmPasses not initialised" #if STAGE < 2 GLOBAL_VAR(v_unsafeGlobalDynFlags, defaultGlobalDynFlags, DynFlags) @@ -5307,12 +5647,32 @@ isAvx512pfEnabled :: DynFlags -> Bool isAvx512pfEnabled dflags = avx512pf dflags -- ----------------------------------------------------------------------------- +-- BMI2 + +data BmiVersion = BMI1 + | BMI2 + deriving (Eq, Ord) + +isBmiEnabled :: DynFlags -> Bool +isBmiEnabled dflags = case platformArch (targetPlatform dflags) of + ArchX86_64 -> bmiVersion dflags >= Just BMI1 + ArchX86 -> bmiVersion dflags >= Just BMI1 + _ -> False + +isBmi2Enabled :: DynFlags -> Bool +isBmi2Enabled dflags = case platformArch (targetPlatform dflags) of + ArchX86_64 -> bmiVersion dflags >= Just BMI2 + ArchX86 -> bmiVersion dflags >= Just BMI2 + _ -> False + +-- ----------------------------------------------------------------------------- -- Linker/compiler information -- LinkerInfo contains any extra options needed by the system linker. data LinkerInfo = GnuLD [Option] | GnuGold [Option] + | LlvmLLD [Option] | DarwinLD [Option] | SolarisLD [Option] | AixLD [Option] diff --git a/compiler/main/DynFlags.hs-boot b/compiler/main/DynFlags.hs-boot index 5fd80fcd82..823fd22854 100644 --- a/compiler/main/DynFlags.hs-boot +++ b/compiler/main/DynFlags.hs-boot @@ -1,17 +1,20 @@ - module DynFlags where +import GhcPrelude import Platform data DynFlags data DumpFlag +data GeneralFlag -targetPlatform :: DynFlags -> Platform -pprUserLength :: DynFlags -> Int -pprCols :: DynFlags -> Int -unsafeGlobalDynFlags :: DynFlags -useUnicode :: DynFlags -> Bool -useUnicodeSyntax :: DynFlags -> Bool -shouldUseColor :: DynFlags -> Bool -hasPprDebug :: DynFlags -> Bool -hasNoDebugOutput :: DynFlags -> Bool +targetPlatform :: DynFlags -> Platform +pprUserLength :: DynFlags -> Int +pprCols :: DynFlags -> Int +unsafeGlobalDynFlags :: DynFlags +useUnicode :: DynFlags -> Bool +useUnicodeSyntax :: DynFlags -> Bool +useStarIsType :: DynFlags -> Bool +shouldUseColor :: DynFlags -> Bool +shouldUseHexWordLiterals :: DynFlags -> Bool +hasPprDebug :: DynFlags -> Bool +hasNoDebugOutput :: DynFlags -> Bool diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs index ffdce28762..764bf2dd41 100644 --- a/compiler/main/DynamicLoading.hs +++ b/compiler/main/DynamicLoading.hs @@ -2,9 +2,9 @@ -- | Dynamically lookup up values from modules and loading them. module DynamicLoading ( + initializePlugins, #if defined(GHCI) -- * Loading plugins - loadPlugins, loadFrontendPlugin, -- * Force loading information @@ -20,10 +20,14 @@ module DynamicLoading ( getHValueSafely, lessUnsafeCoerce #else - pluginError, + pluginError #endif ) where +import GhcPrelude +import HscTypes ( HscEnv ) +import DynFlags + #if defined(GHCI) import Linker ( linkModule, getHValue ) import GHCi ( wormhole ) @@ -36,8 +40,7 @@ import RdrName ( RdrName, ImportSpec(..), ImpDeclSpec(..) , gre_name, mkRdrQual ) import OccName ( OccName, mkVarOcc ) import RnNames ( gresFromAvails ) -import DynFlags -import Plugins ( Plugin, FrontendPlugin, CommandLineOption ) +import Plugins import PrelNames ( pluginTyConName, frontendPluginTyConName ) import HscTypes @@ -54,6 +57,7 @@ import Outputable import Exception import Hooks +import Control.Monad ( when, unless ) import Data.Maybe ( mapMaybe ) import GHC.Exts ( unsafeCoerce# ) @@ -63,31 +67,67 @@ import Module ( ModuleName, moduleNameString ) import Panic import Data.List ( intercalate ) +import Control.Monad ( unless ) + +#endif +-- | Loads the plugins specified in the pluginModNames field of the dynamic +-- flags. Should be called after command line arguments are parsed, but before +-- actual compilation starts. Idempotent operation. Should be re-called if +-- pluginModNames or pluginModNameOpts changes. +initializePlugins :: HscEnv -> DynFlags -> IO DynFlags +initializePlugins hsc_env df +#if !defined(GHCI) + = do let pluginMods = pluginModNames df + unless (null pluginMods) (pluginError pluginMods) + return df +#else + | map lpModuleName (plugins df) == pluginModNames df -- plugins not changed + && all (\p -> lpArguments p == argumentsForPlugin p (pluginModNameOpts df)) + (plugins df) -- arguments not changed + = return df -- no need to reload plugins + | otherwise + = do loadedPlugins <- loadPlugins (hsc_env { hsc_dflags = df }) + return $ df { plugins = loadedPlugins } + where argumentsForPlugin p = map snd . filter ((== lpModuleName p) . fst) #endif + #if defined(GHCI) -loadPlugins :: HscEnv -> IO [(ModuleName, Plugin, [CommandLineOption])] +loadPlugins :: HscEnv -> IO [LoadedPlugin] loadPlugins hsc_env - = do { plugins <- mapM (loadPlugin hsc_env) to_load + = do { unless (null to_load) $ + checkExternalInterpreter hsc_env + ; plugins <- mapM loadPlugin to_load ; return $ zipWith attachOptions to_load plugins } where dflags = hsc_dflags hsc_env to_load = pluginModNames dflags - attachOptions mod_nm plug = (mod_nm, plug, options) + attachOptions mod_nm (plug, mod) = LoadedPlugin plug mod (reverse options) where options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags , opt_mod_nm == mod_nm ] + loadPlugin = loadPlugin' (mkVarOcc "plugin") pluginTyConName hsc_env -loadPlugin :: HscEnv -> ModuleName -> IO Plugin -loadPlugin = loadPlugin' (mkVarOcc "plugin") pluginTyConName loadFrontendPlugin :: HscEnv -> ModuleName -> IO FrontendPlugin -loadFrontendPlugin = loadPlugin' (mkVarOcc "frontendPlugin") frontendPluginTyConName +loadFrontendPlugin hsc_env mod_name = do + checkExternalInterpreter hsc_env + fst <$> loadPlugin' (mkVarOcc "frontendPlugin") frontendPluginTyConName + hsc_env mod_name + +-- #14335 +checkExternalInterpreter :: HscEnv -> IO () +checkExternalInterpreter hsc_env = + when (gopt Opt_ExternalInterpreter dflags) $ + throwCmdLineError $ showSDoc dflags $ + text "Plugins require -fno-external-interpreter" + where + dflags = hsc_dflags hsc_env -loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO a +loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface) loadPlugin' occ_name plugin_name hsc_env mod_name = do { let plugin_rdr_name = mkRdrQual mod_name occ_name dflags = hsc_dflags hsc_env @@ -99,7 +139,7 @@ loadPlugin' occ_name plugin_name hsc_env mod_name [ text "The module", ppr mod_name , text "did not export the plugin name" , ppr plugin_rdr_name ]) ; - Just name -> + Just (name, mod_iface) -> do { plugin_tycon <- forceLoadTyCon hsc_env plugin_name ; mb_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon) @@ -109,7 +149,7 @@ loadPlugin' occ_name plugin_name hsc_env mod_name [ text "The value", ppr name , text "did not have the type" , ppr pluginTyConName, text "as required"]) - Just plugin -> return plugin } } } + Just plugin -> return (plugin, mod_iface) } } } -- | Force the interfaces for the given modules to be loaded. The 'SDoc' parameter is used @@ -216,7 +256,10 @@ lessUnsafeCoerce dflags context what = do -- loaded very partially: just enough that it can be used, without its -- rules and instances affecting (and being linked from!) the module -- being compiled. This was introduced by 57d6798. -lookupRdrNameInModuleForPlugins :: HscEnv -> ModuleName -> RdrName -> IO (Maybe Name) +-- +-- Need the module as well to record information in the interface file +lookupRdrNameInModuleForPlugins :: HscEnv -> ModuleName -> RdrName + -> IO (Maybe (Name, ModIface)) lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do -- First find the package the module resides in by searching exposed packages and home modules found_module <- findPluginModule hsc_env mod_name @@ -234,7 +277,7 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do imp_spec = ImpSpec decl_spec ImpAll env = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) (mi_exports iface)) case lookupGRE_RdrName rdr_name env of - [gre] -> return (Just (gre_name gre)) + [gre] -> return (Just (gre_name gre, iface)) [] -> return Nothing _ -> panic "lookupRdrNameInModule" diff --git a/compiler/main/Elf.hs b/compiler/main/Elf.hs index 599d4d9160..648f20aad9 100644 --- a/compiler/main/Elf.hs +++ b/compiler/main/Elf.hs @@ -14,6 +14,8 @@ module Elf ( makeElfNote ) where +import GhcPrelude + import AsmUtils import Exception import DynFlags diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs index 5883fe14da..c7fb8babe9 100644 --- a/compiler/main/ErrUtils.hs +++ b/compiler/main/ErrUtils.hs @@ -10,7 +10,7 @@ module ErrUtils ( -- * Basic types - Validity(..), andValid, allValid, isValid, getInvalids, + Validity(..), andValid, allValid, isValid, getInvalids, orValid, Severity(..), -- * Messages @@ -57,6 +57,8 @@ module ErrUtils ( #include "HsVersions.h" +import GhcPrelude + import Bag import Exception import Outputable @@ -108,6 +110,10 @@ allValid (v : vs) = v `andValid` allValid vs getInvalids :: [Validity] -> [MsgDoc] getInvalids vs = [d | NotValid d <- vs] +orValid :: Validity -> Validity -> Validity +orValid IsValid _ = IsValid +orValid _ v = v + -- ----------------------------------------------------------------------------- -- Basic error messages: just render a message with a source location. @@ -450,6 +456,29 @@ mkDumpDoc hdr doc where line = text (replicate 20 '=') +-- | Run an action with the handle of a 'DumpFlag' if we are outputting to a +-- file, otherwise 'Nothing'. +withDumpFileHandle :: DynFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO () +withDumpFileHandle dflags flag action = do + let mFile = chooseDumpFile dflags flag + case mFile of + Just fileName -> do + let gdref = generatedDumps dflags + gd <- readIORef gdref + let append = Set.member fileName gd + mode = if append then AppendMode else WriteMode + unless append $ + writeIORef gdref (Set.insert fileName gd) + createDirectoryIfMissing True (takeDirectory fileName) + withFile fileName mode $ \handle -> do + -- We do not want the dump file to be affected by + -- environment variables, but instead to always use + -- UTF8. See: + -- https://ghc.haskell.org/trac/ghc/ticket/10762 + hSetEncoding handle utf8 + + action (Just handle) + Nothing -> action Nothing -- | Write out a dump. -- If --dump-to-file is set then this goes to a file. @@ -461,43 +490,31 @@ mkDumpDoc hdr doc -- The 'DumpFlag' is used only to choose the filename to use if @--dump-to-file@ -- is used; it is not used to decide whether to dump the output dumpSDoc :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO () -dumpSDoc dflags print_unqual flag hdr doc - = do let mFile = chooseDumpFile dflags flag - dump_style = mkDumpStyle dflags print_unqual - case mFile of - Just fileName - -> do - let gdref = generatedDumps dflags - gd <- readIORef gdref - let append = Set.member fileName gd - mode = if append then AppendMode else WriteMode - unless append $ - writeIORef gdref (Set.insert fileName gd) - createDirectoryIfMissing True (takeDirectory fileName) - handle <- openFile fileName mode - - -- We do not want the dump file to be affected by - -- environment variables, but instead to always use - -- UTF8. See: - -- https://ghc.haskell.org/trac/ghc/ticket/10762 - hSetEncoding handle utf8 - - doc' <- if null hdr - then return doc - else do t <- getCurrentTime - let d = text (show t) - $$ blankLine - $$ doc - return $ mkDumpDoc hdr d - defaultLogActionHPrintDoc dflags handle doc' dump_style - hClose handle - - -- write the dump to stdout - Nothing -> do - let (doc', severity) - | null hdr = (doc, SevOutput) - | otherwise = (mkDumpDoc hdr doc, SevDump) - putLogMsg dflags NoReason severity noSrcSpan dump_style doc' +dumpSDoc dflags print_unqual flag hdr doc = + withDumpFileHandle dflags flag writeDump + where + dump_style = mkDumpStyle dflags print_unqual + + -- write dump to file + writeDump (Just handle) = do + doc' <- if null hdr + then return doc + else do t <- getCurrentTime + let timeStamp = if (gopt Opt_SuppressTimestamps dflags) + then empty + else text (show t) + let d = timeStamp + $$ blankLine + $$ doc + return $ mkDumpDoc hdr d + defaultLogActionHPrintDoc dflags handle doc' dump_style + + -- write the dump to stdout + writeDump Nothing = do + let (doc', severity) + | null hdr = (doc, SevOutput) + | otherwise = (mkDumpDoc hdr doc, SevDump) + putLogMsg dflags NoReason severity noSrcSpan dump_style doc' -- | Choose where to put a dump file based on DynFlags @@ -608,7 +625,7 @@ withTiming :: MonadIO m -> m a withTiming getDFlags what force_result action = do dflags <- getDFlags - if verbosity dflags >= 2 + if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags then do liftIO $ logInfo dflags (defaultUserStyle dflags) $ text "***" <+> what <> colon alloc0 <- liftIO getAllocationCounter @@ -619,14 +636,24 @@ withTiming getDFlags what force_result action alloc1 <- liftIO getAllocationCounter -- recall that allocation counter counts down let alloc = alloc0 - alloc1 - liftIO $ logInfo dflags (defaultUserStyle dflags) - (text "!!!" <+> what <> colon <+> text "finished in" - <+> doublePrec 2 (realToFrac (end - start) * 1e-9) - <+> text "milliseconds" - <> comma - <+> text "allocated" - <+> doublePrec 3 (realToFrac alloc / 1024 / 1024) - <+> text "megabytes") + time = realToFrac (end - start) * 1e-9 + + when (verbosity dflags >= 2) + $ liftIO $ logInfo dflags (defaultUserStyle dflags) + (text "!!!" <+> what <> colon <+> text "finished in" + <+> doublePrec 2 time + <+> text "milliseconds" + <> comma + <+> text "allocated" + <+> doublePrec 3 (realToFrac alloc / 1024 / 1024) + <+> text "megabytes") + + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_timings "" + $ text $ showSDocOneLine dflags + $ hsep [ what <> colon + , text "alloc=" <> ppr alloc + , text "time=" <> doublePrec 3 time + ] pure r else action diff --git a/compiler/main/ErrUtils.hs-boot b/compiler/main/ErrUtils.hs-boot index bbbf74e197..6f180af546 100644 --- a/compiler/main/ErrUtils.hs-boot +++ b/compiler/main/ErrUtils.hs-boot @@ -1,5 +1,6 @@ module ErrUtils where +import GhcPrelude import Outputable (SDoc, PrintUnqualified ) import SrcLoc (SrcSpan) import Json diff --git a/compiler/main/FileCleanup.hs b/compiler/main/FileCleanup.hs index f4c30d6112..35bed6149b 100644 --- a/compiler/main/FileCleanup.hs +++ b/compiler/main/FileCleanup.hs @@ -3,9 +3,12 @@ module FileCleanup ( TempFileLifetime(..) , cleanTempDirs, cleanTempFiles, cleanCurrentModuleTempFiles , addFilesToClean, changeTempFilesLifetime - , newTempName, newTempLibName + , newTempName, newTempLibName, newTempDir + , withSystemTempDirectory, withTempDirectory ) where +import GhcPrelude + import DynFlags import ErrUtils import Outputable @@ -129,6 +132,21 @@ newTempName dflags lifetime extn addFilesToClean dflags lifetime [filename] return filename +newTempDir :: DynFlags -> IO FilePath +newTempDir dflags + = do d <- getTempDir dflags + findTempDir (d </> "ghc_") + where + findTempDir :: FilePath -> IO FilePath + findTempDir prefix + = do n <- newTempSuffix dflags + let filename = prefix ++ show n + b <- doesDirectoryExist filename + if b then findTempDir prefix + else do createDirectory filename + -- see mkTempDir below; this is wrong: -> consIORef (dirsToClean dflags) filename + return filename + newTempLibName :: DynFlags -> TempFileLifetime -> Suffix -> IO (FilePath, FilePath, String) newTempLibName dflags lifetime extn @@ -247,3 +265,50 @@ foreign import ccall unsafe "_getpid" getProcessID :: IO Int getProcessID :: IO Int getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral #endif + +-- The following three functions are from the `temporary` package. + +-- | Create and use a temporary directory in the system standard temporary +-- directory. +-- +-- Behaves exactly the same as 'withTempDirectory', except that the parent +-- temporary directory will be that returned by 'getTemporaryDirectory'. +withSystemTempDirectory :: String -- ^ Directory name template. See 'openTempFile'. + -> (FilePath -> IO a) -- ^ Callback that can use the directory + -> IO a +withSystemTempDirectory template action = + getTemporaryDirectory >>= \tmpDir -> withTempDirectory tmpDir template action + + +-- | Create and use a temporary directory. +-- +-- Creates a new temporary directory inside the given directory, making use +-- of the template. The temp directory is deleted after use. For example: +-- +-- > withTempDirectory "src" "sdist." $ \tmpDir -> do ... +-- +-- The @tmpDir@ will be a new subdirectory of the given directory, e.g. +-- @src/sdist.342@. +withTempDirectory :: FilePath -- ^ Temp directory to create the directory in + -> String -- ^ Directory name template. See 'openTempFile'. + -> (FilePath -> IO a) -- ^ Callback that can use the directory + -> IO a +withTempDirectory targetDir template = + Exception.bracket + (createTempDirectory targetDir template) + (ignoringIOErrors . removeDirectoryRecursive) + +ignoringIOErrors :: IO () -> IO () +ignoringIOErrors ioe = ioe `catch` (\e -> const (return ()) (e :: IOError)) + + +createTempDirectory :: FilePath -> String -> IO FilePath +createTempDirectory dir template = do + pid <- getProcessID + findTempName pid + where findTempName x = do + let path = dir </> template ++ show x + createDirectory path + return path + `catchIO` \e -> if isAlreadyExistsError e + then findTempName (x+1) else ioError e diff --git a/compiler/main/Finder.hs b/compiler/main/Finder.hs index d1bf1c8073..9a3cb6009b 100644 --- a/compiler/main/Finder.hs +++ b/compiler/main/Finder.hs @@ -33,6 +33,8 @@ module Finder ( #include "HsVersions.h" +import GhcPrelude + import Module import HscTypes import Packages @@ -150,15 +152,17 @@ orIfNotFound this or_this = do res <- this case res of NotFound { fr_paths = paths1, fr_mods_hidden = mh1 - , fr_pkgs_hidden = ph1, fr_suggestions = s1 } + , fr_pkgs_hidden = ph1, fr_unusables = u1, fr_suggestions = s1 } -> do res2 <- or_this case res2 of NotFound { fr_paths = paths2, fr_pkg = mb_pkg2, fr_mods_hidden = mh2 - , fr_pkgs_hidden = ph2, fr_suggestions = s2 } + , fr_pkgs_hidden = ph2, fr_unusables = u2 + , fr_suggestions = s2 } -> return (NotFound { fr_paths = paths1 ++ paths2 , fr_pkg = mb_pkg2 -- snd arg is the package search , fr_mods_hidden = mh1 ++ mh2 , fr_pkgs_hidden = ph1 ++ ph2 + , fr_unusables = u1 ++ u2 , fr_suggestions = s1 ++ s2 }) _other -> return res2 _other -> return res @@ -203,6 +207,7 @@ findLookupResult hsc_env r = case r of InstalledNotFound fp _ -> return (NotFound{ fr_paths = fp, fr_pkg = Just (moduleUnitId m) , fr_pkgs_hidden = [] , fr_mods_hidden = [] + , fr_unusables = [] , fr_suggestions = []}) LookupMultiple rs -> return (FoundMultiple rs) @@ -210,11 +215,23 @@ findLookupResult hsc_env r = case r of return (NotFound{ fr_paths = [], fr_pkg = Nothing , fr_pkgs_hidden = map (moduleUnitId.fst) pkg_hiddens , fr_mods_hidden = map (moduleUnitId.fst) mod_hiddens + , fr_unusables = [] , fr_suggestions = [] }) + LookupUnusable unusable -> + let unusables' = map get_unusable unusable + get_unusable (m, ModUnusable r) = (moduleUnitId m, r) + get_unusable (_, r) = + pprPanic "findLookupResult: unexpected origin" (ppr r) + in return (NotFound{ fr_paths = [], fr_pkg = Nothing + , fr_pkgs_hidden = [] + , fr_mods_hidden = [] + , fr_unusables = unusables' + , fr_suggestions = [] }) LookupNotFound suggest -> return (NotFound{ fr_paths = [], fr_pkg = Nothing , fr_pkgs_hidden = [] , fr_mods_hidden = [] + , fr_unusables = [] , fr_suggestions = suggest }) modLocationCache :: HscEnv -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult @@ -258,6 +275,7 @@ findHomeModule hsc_env mod_name = do fr_pkg = Just uid, fr_mods_hidden = [], fr_pkgs_hidden = [], + fr_unusables = [], fr_suggestions = [] } where @@ -568,8 +586,19 @@ findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn]) -- Error messages cannotFindModule :: DynFlags -> ModuleName -> FindResult -> SDoc -cannotFindModule = cantFindErr (sLit "Could not find module") - (sLit "Ambiguous module name") +cannotFindModule flags mod res = + cantFindErr (sLit cannotFindMsg) + (sLit "Ambiguous module name") + flags mod res + where + cannotFindMsg = + case res of + NotFound { fr_mods_hidden = hidden_mods + , fr_pkgs_hidden = hidden_pkgs + , fr_unusables = unusables } + | not (null hidden_mods && null hidden_pkgs && null unusables) + -> "Could not load module" + _ -> "Could not find module" cannotFindInterface :: DynFlags -> ModuleName -> InstalledFindResult -> SDoc cannotFindInterface = cantFindInstalledErr (sLit "Failed to load interface for") @@ -596,6 +625,7 @@ cantFindErr _ multiple_found _ mod_name (FoundMultiple mods) pprMod (m, o) = text "it is bound as" <+> ppr m <+> text "by" <+> pprOrigin m o pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden" + pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable" pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma ( if e == Just True then [text "package" <+> ppr (moduleUnitId m)] @@ -617,20 +647,22 @@ cantFindErr cannot_find _ dflags mod_name find_result NotFound { fr_paths = files, fr_pkg = mb_pkg , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens - , fr_suggestions = suggest } + , fr_unusables = unusables, fr_suggestions = suggest } | Just pkg <- mb_pkg, pkg /= thisPackage dflags -> not_found_in_package pkg files | not (null suggest) - -> pp_suggestions suggest $$ tried_these files + -> pp_suggestions suggest $$ tried_these files dflags - | null files && null mod_hiddens && null pkg_hiddens + | null files && null mod_hiddens && + null pkg_hiddens && null unusables -> text "It is not a module in the current program, or in any known package." | otherwise -> vcat (map pkg_hidden pkg_hiddens) $$ vcat (map mod_hidden mod_hiddens) $$ - tried_these files + vcat (map unusable unusables) $$ + tried_these files dflags _ -> panic "cantFindErr" @@ -644,20 +676,13 @@ cantFindErr cannot_find _ dflags mod_name find_result in text "Perhaps you haven't installed the " <> text build <> text " libraries for package " <> quotes (ppr pkg) <> char '?' $$ - tried_these files + tried_these files dflags | otherwise = text "There are files missing in the " <> quotes (ppr pkg) <> text " package," $$ text "try running 'ghc-pkg check'." $$ - tried_these files - - tried_these files - | null files = Outputable.empty - | verbosity dflags < 3 = - text "Use -v to see a list of the files searched for." - | otherwise = - hang (text "Locations searched:") 2 $ vcat (map text files) + tried_these files dflags pkg_hidden :: UnitId -> SDoc pkg_hidden pkgid = @@ -665,18 +690,28 @@ cantFindErr cannot_find _ dflags mod_name find_result <+> quotes (ppr pkgid) --FIXME: we don't really want to show the unit id here we should -- show the source package id or installed package id if it's ambiguous - <> dot $$ cabal_pkg_hidden_hint pkgid - cabal_pkg_hidden_hint pkgid + <> dot $$ pkg_hidden_hint pkgid + pkg_hidden_hint pkgid | gopt Opt_BuildingCabalPackage dflags = let pkg = expectJust "pkg_hidden" (lookupPackage dflags pkgid) in text "Perhaps you need to add" <+> quotes (ppr (packageName pkg)) <+> text "to the build-depends in your .cabal file." + | Just pkg <- lookupPackage dflags pkgid + = text "You can run" <+> + quotes (text ":set -package " <> ppr (packageName pkg)) <+> + text "to expose it." $$ + text "(Note: this unloads all the modules in the current scope.)" | otherwise = Outputable.empty mod_hidden pkg = text "it is a hidden module in the package" <+> quotes (ppr pkg) + unusable (pkg, reason) + = text "It is a member of the package" + <+> quotes (ppr pkg) + $$ pprReason (text "which is") reason + pp_suggestions :: [ModuleSuggestion] -> SDoc pp_suggestions sugs | null sugs = Outputable.empty @@ -688,6 +723,7 @@ cantFindErr cannot_find _ dflags mod_name find_result -- also has a reexport, prefer that one pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o where provenance ModHidden = Outputable.empty + provenance (ModUnusable _) = Outputable.empty provenance (ModOrigin{ fromOrigPackage = e, fromExposedReexport = res, fromPackageFlag = f }) @@ -704,6 +740,7 @@ cantFindErr cannot_find _ dflags mod_name find_result | otherwise = Outputable.empty pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o where provenance ModHidden = Outputable.empty + provenance (ModUnusable _) = Outputable.empty provenance (ModOrigin{ fromOrigPackage = e, fromHiddenReexport = rhs }) | Just False <- e @@ -734,7 +771,7 @@ cantFindInstalledErr cannot_find _ dflags mod_name find_result -> text "It is not a module in the current program, or in any known package." | otherwise - -> tried_these files + -> tried_these files dflags _ -> panic "cantFindInstalledErr" @@ -760,17 +797,19 @@ cantFindInstalledErr cannot_find _ dflags mod_name find_result in text "Perhaps you haven't installed the " <> text build <> text " libraries for package " <> quotes (ppr pkg) <> char '?' $$ - tried_these files + tried_these files dflags | otherwise = text "There are files missing in the " <> quotes (ppr pkg) <> text " package," $$ text "try running 'ghc-pkg check'." $$ - tried_these files - - tried_these files - | null files = Outputable.empty - | verbosity dflags < 3 = - text "Use -v to see a list of the files searched for." - | otherwise = - hang (text "Locations searched:") 2 $ vcat (map text files) + tried_these files dflags + +tried_these :: [FilePath] -> DynFlags -> SDoc +tried_these files dflags + | null files = Outputable.empty + | verbosity dflags < 3 = + text "Use -v (or `:set -v` in ghci) " <> + text "to see a list of the files searched for." + | otherwise = + hang (text "Locations searched:") 2 $ vcat (map text files) diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 3ca07f1443..cf9c74f885 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -132,6 +132,9 @@ module GHC ( ForeignHValue, compileExprRemote, compileParsedExprRemote, + -- ** Docs + getDocs, GetDocsFailure(..), + -- ** Other runTcInteractive, -- Desired by some clients (Trac #8878) isStmt, hasImport, isImport, isDecl, @@ -283,6 +286,8 @@ module GHC ( #include "HsVersions.h" +import GhcPrelude hiding (init) + import ByteCodeTypes import InteractiveEval import InteractiveEvalTypes @@ -295,7 +300,8 @@ import HscMain import GhcMake import DriverPipeline ( compileOne' ) import GhcMonad -import TcRnMonad ( finalSafeMode, fixSafeInstances ) +import TcRnMonad ( finalSafeMode, fixSafeInstances, initIfaceTcRn ) +import LoadIface ( loadSysInterface ) import TcRnTypes import Packages import NameSet @@ -321,6 +327,7 @@ import HscTypes import CmdLineParser import DynFlags hiding (WarnReason(..)) import SysTools +import SysTools.BaseDir import Annotations import Module import Panic @@ -361,8 +368,6 @@ import System.Exit ( exitWith, ExitCode(..) ) import Exception import Data.IORef import System.FilePath -import System.IO -import Prelude hiding (init) -- %************************************************************************ @@ -472,7 +477,6 @@ withCleanupSession ghc = ghc `gfinally` cleanup cleanTempFiles dflags cleanTempDirs dflags stopIServ hsc_env -- shut down the IServ - log_finaliser dflags dflags -- exceptions will be blocked while we clean the temporary files, -- so there shouldn't be any difficulty if we receive further -- signals. @@ -492,8 +496,10 @@ withCleanupSession ghc = ghc `gfinally` cleanup initGhcMonad :: GhcMonad m => Maybe FilePath -> m () initGhcMonad mb_top_dir = do { env <- liftIO $ - do { mySettings <- initSysTools mb_top_dir - ; dflags <- initDynFlags (defaultDynFlags mySettings) + do { top_dir <- findTopDir mb_top_dir + ; mySettings <- initSysTools top_dir + ; myLlvmConfig <- initLlvmConfig top_dir + ; dflags <- initDynFlags (defaultDynFlags mySettings myLlvmConfig) ; checkBrokenTablesNextToCode dflags ; setUnsafeGlobalDynFlags dflags -- c.f. DynFlags.parseDynamicFlagsFull, which @@ -591,12 +597,11 @@ setProgramDynFlags dflags = setProgramDynFlags_ True dflags -- | Set the action taken when the compiler produces a message. This -- can also be accomplished using 'setProgramDynFlags', but using -- 'setLogAction' avoids invalidating the cached module graph. -setLogAction :: GhcMonad m => LogAction -> LogFinaliser -> m () -setLogAction action finaliser = do +setLogAction :: GhcMonad m => LogAction -> m () +setLogAction action = do dflags' <- getProgramDynFlags void $ setProgramDynFlags_ False $ - dflags' { log_action = action - , log_finaliser = finaliser } + dflags' { log_action = action } setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m [InstalledUnitId] setProgramDynFlags_ invalidate_needed dflags = do @@ -672,6 +677,8 @@ checkNewDynFlags dflags = do checkNewInteractiveDynFlags :: MonadIO m => DynFlags -> m DynFlags checkNewInteractiveDynFlags dflags0 = do + -- We currently don't support use of StaticPointers in expressions entered on + -- the REPL. See #12356. dflags1 <- if xopt LangExt.StaticPointers dflags0 then do liftIO $ printOrThrowWarnings dflags0 $ listToBag @@ -847,7 +854,7 @@ instance DesugaredMod DesugaredModule where coreModule m = dm_core_module m type ParsedSource = Located (HsModule GhcPs) -type RenamedSource = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [LIE GhcRn], +type RenamedSource = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)], Maybe LHsDocString) type TypecheckedSource = LHsBinds GhcTc @@ -1031,16 +1038,19 @@ compileCore simplify fn = do Just modSummary -> do -- Now we have the module name; -- parse, typecheck and desugar the module - mod_guts <- coreModule `fmap` - -- TODO: space leaky: call hsc* directly? - (desugarModule =<< typecheckModule =<< parseModule modSummary) + (tcg, mod_guts) <- -- TODO: space leaky: call hsc* directly? + do tm <- typecheckModule =<< parseModule modSummary + let tcg = fst (tm_internals tm) + (,) tcg . coreModule <$> desugarModule tm liftM (gutsToCoreModule (mg_safe_haskell mod_guts)) $ if simplify then do -- If simplify is true: simplify (hscSimplify), then tidy -- (tidyProgram). hsc_env <- getSession - simpl_guts <- liftIO $ hscSimplify hsc_env mod_guts + simpl_guts <- liftIO $ do + plugins <- readIORef (tcg_th_coreplugins tcg) + hscSimplify hsc_env plugins mod_guts tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts return $ Left tidy_guts else @@ -1240,12 +1250,22 @@ getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env) -- by 'Name'. Each name's lists will contain every instance in which that name -- is mentioned in the instance head. getNameToInstancesIndex :: GhcMonad m - => m (Messages, Maybe (NameEnv ([ClsInst], [FamInst]))) -getNameToInstancesIndex = do + => [Module] -- ^ visible modules. An orphan instance will be returned + -- if it is visible from at least one module in the list. + -> Maybe [Module] -- ^ modules to load. If this is not specified, we load + -- modules for everything that is in scope unqualified. + -> m (Messages, Maybe (NameEnv ([ClsInst], [FamInst]))) +getNameToInstancesIndex visible_mods mods_to_load = do hsc_env <- getSession liftIO $ runTcInteractive hsc_env $ - do { loadUnqualIfaces hsc_env (hsc_IC hsc_env) - ; InstEnvs {ie_global, ie_local, ie_visible} <- tcGetInstEnvs + do { case mods_to_load of + Nothing -> loadUnqualIfaces hsc_env (hsc_IC hsc_env) + Just mods -> + let doc = text "Need interface for reporting instances in scope" + in initIfaceTcRn $ mapM_ (loadSysInterface doc) mods + + ; InstEnvs {ie_global, ie_local} <- tcGetInstEnvs + ; let visible_mods' = mkModuleSet visible_mods ; (pkg_fie, home_fie) <- tcGetFamInstEnvs -- We use Data.Sequence.Seq because we are creating left associated -- mappends. @@ -1253,7 +1273,7 @@ getNameToInstancesIndex = do ; let cls_index = Map.fromListWith mappend [ (n, Seq.singleton ispec) | ispec <- instEnvElts ie_local ++ instEnvElts ie_global - , instIsVisible ie_visible ispec + , instIsVisible visible_mods' ispec , n <- nameSetElemsStable $ orphNamesOfClsInst ispec ] ; let fam_index = Map.fromListWith mappend @@ -1301,7 +1321,6 @@ pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a)) -- ---------------------------------------------------------------------------- -#if 0 -- ToDo: -- - Data and Typeable instances for HsSyn. @@ -1315,7 +1334,6 @@ pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a)) -- :browse will use either lm_toplev or inspect lm_interface, depending -- on whether the module is interpreted or not. -#endif -- Extract the filename, stringbuffer content and dynflags associed to a module -- diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index f4a9a319ac..39b6427173 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -33,6 +33,8 @@ module GhcMake( #include "HsVersions.h" +import GhcPrelude + import qualified Linker ( unload ) import DriverPhases @@ -199,11 +201,16 @@ warnMissingHomeModules hsc_env mod_graph = msg | gopt Opt_BuildingCabalPackage dflags - = text "These modules are needed for compilation but not listed in your .cabal file's other-modules: " - <> sep (map ppr missing) + = hang + (text "These modules are needed for compilation but not listed in your .cabal file's other-modules: ") + 4 + (sep (map ppr missing)) | otherwise - = text "Modules are not listed in command line but needed for compilation: " - <> sep (map ppr missing) + = + hang + (text "Modules are not listed in command line but needed for compilation: ") + 4 + (sep (map ppr missing)) warn = makeIntoWarning (Reason Opt_WarnMissingHomeModules) (mkPlainErrMsg dflags noSrcSpan msg) @@ -703,7 +710,7 @@ checkStability -> StableModules checkStability hpt sccs all_home_mods = - foldl checkSCC (emptyUniqSet, emptyUniqSet) sccs + foldl' checkSCC (emptyUniqSet, emptyUniqSet) sccs where checkSCC :: StableModules -> SCC ModSummary -> StableModules checkSCC (stable_obj, stable_bco) scc0 @@ -1172,7 +1179,13 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags mHscMessage cleanup Just (ms_mod lcl_mod, type_env_var) } lcl_hsc_env'' <- case finish_loop of Nothing -> return lcl_hsc_env' + -- In the non-parallel case, the retypecheck prior to + -- typechecking the loop closer includes all modules + -- EXCEPT the loop closer. However, our precomputed + -- SCCs include the loop closer, so we have to filter + -- it out. Just loop -> typecheckLoop lcl_dflags lcl_hsc_env' $ + filter (/= moduleName (fst this_build_mod)) $ map (moduleName . fst) loop -- Compile the module. @@ -1195,8 +1208,10 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags mHscMessage cleanup let hsc_env' = hsc_env { hsc_HPT = addToHpt (hsc_HPT hsc_env) this_mod mod_info } - -- If this module is a loop finisher, now is the time to - -- re-typecheck the loop. + -- We've finished typechecking the module, now we must + -- retypecheck the loop AGAIN to ensure unfoldings are + -- updated. This time, however, we include the loop + -- closer! hsc_env'' <- case finish_loop of Nothing -> return hsc_env' Just loop -> typecheckLoop lcl_dflags hsc_env' $ @@ -1672,6 +1687,42 @@ reTypecheckLoop hsc_env ms graph mss = mgModSummaries graph appearsAsBoot = (`elemModuleSet` mgBootModules graph) +-- | Given a non-boot ModSummary @ms@ of a module, for which there exists a +-- corresponding boot file in @graph@, return the set of modules which +-- transitively depend on this boot file. This function is slightly misnamed, +-- but its name "getModLoop" alludes to the fact that, when getModLoop is called +-- with a graph that does not contain @ms@ (non-parallel case) or is an +-- SCC with hs-boot nodes dropped (parallel-case), the modules which +-- depend on the hs-boot file are typically (but not always) the +-- modules participating in the recursive module loop. The returned +-- list includes the hs-boot file. +-- +-- Example: +-- let g represent the module graph: +-- C.hs +-- A.hs-boot imports C.hs +-- B.hs imports A.hs-boot +-- A.hs imports B.hs +-- genModLoop A.hs g == Just [A.hs-boot, B.hs, A.hs] +-- +-- It would also be permissible to omit A.hs from the graph, +-- in which case the result is [A.hs-boot, B.hs] +-- +-- Example: +-- A counter-example to the claim that modules returned +-- by this function participate in the loop occurs here: +-- +-- let g represent the module graph: +-- C.hs +-- A.hs-boot imports C.hs +-- B.hs imports A.hs-boot +-- A.hs imports B.hs +-- D.hs imports A.hs-boot +-- genModLoop A.hs g == Just [A.hs-boot, B.hs, A.hs, D.hs] +-- +-- Arguably, D.hs should import A.hs, not A.hs-boot, but +-- a dependency on the boot file is not illegal. +-- getModLoop :: ModSummary -> [ModSummary] @@ -1687,6 +1738,8 @@ getModLoop ms graph appearsAsBoot where this_mod = ms_mod ms +-- NB: sometimes mods has duplicates; this is harmless because +-- any duplicates get clobbered in addListToHpt and never get forced. typecheckLoop :: DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv typecheckLoop dflags hsc_env mods = do debugTraceMsg dflags 2 $ diff --git a/compiler/main/GhcMonad.hs b/compiler/main/GhcMonad.hs index 2673dd8e45..f72cacc7ef 100644 --- a/compiler/main/GhcMonad.hs +++ b/compiler/main/GhcMonad.hs @@ -23,6 +23,8 @@ module GhcMonad ( WarnErrLogger, defaultWarnErrLogger ) where +import GhcPrelude + import MonadUtils import HscTypes import DynFlags diff --git a/compiler/main/GhcPlugins.hs b/compiler/main/GhcPlugins.hs index c064c0e833..3e0facf97b 100644 --- a/compiler/main/GhcPlugins.hs +++ b/compiler/main/GhcPlugins.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} +{-# OPTIONS_GHC -fno-warn-duplicate-exports -fno-warn-orphans #-} -- | This module is not used by GHC itself. Rather, it exports all of -- the functions and types you are likely to need when writing a @@ -19,7 +19,10 @@ module GhcPlugins( module VarSet, module VarEnv, module NameSet, module NameEnv, module UniqSet, module UniqFM, module FiniteMap, module Util, module GHC.Serialized, module SrcLoc, module Outputable, - module UniqSupply, module Unique, module FastString + module UniqSupply, module Unique, module FastString, + + -- * Getting 'Name's + thNameToGhcName ) where -- Plugin stuff itself @@ -82,3 +85,48 @@ import Outputable import UniqSupply import Unique ( Unique, Uniquable(..) ) import FastString +import Data.Maybe + +import NameCache (lookupOrigNameCache) +import GhcPrelude +import MonadUtils ( mapMaybeM ) +import Convert ( thRdrNameGuesses ) +import TcEnv ( lookupGlobal ) + +import qualified Language.Haskell.TH as TH + +{- This instance is defined outside CoreMonad.hs so that + CoreMonad does not depend on TcEnv -} +instance MonadThings CoreM where + lookupThing name = do { hsc_env <- getHscEnv + ; liftIO $ lookupGlobal hsc_env name } + +{- +************************************************************************ +* * + Template Haskell interoperability +* * +************************************************************************ +-} + +-- | Attempt to convert a Template Haskell name to one that GHC can +-- understand. Original TH names such as those you get when you use +-- the @'foo@ syntax will be translated to their equivalent GHC name +-- exactly. Qualified or unqualified TH names will be dynamically bound +-- to names in the module being compiled, if possible. Exact TH names +-- will be bound to the name they represent, exactly. +thNameToGhcName :: TH.Name -> CoreM (Maybe Name) +thNameToGhcName th_name + = do { names <- mapMaybeM lookup (thRdrNameGuesses th_name) + -- Pick the first that works + -- E.g. reify (mkName "A") will pick the class A in preference + -- to the data constructor A + ; return (listToMaybe names) } + where + lookup rdr_name + | Just n <- isExact_maybe rdr_name -- This happens in derived code + = return $ if isExternalName n then Just n else Nothing + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name + = do { cache <- getOrigNameCache + ; return $ lookupOrigNameCache cache rdr_mod rdr_occ } + | otherwise = return Nothing diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index be38e53f3d..127cc6d911 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -18,6 +18,8 @@ module HeaderInfo ( getImports #include "HsVersions.h" +import GhcPrelude + import HscTypes import Parser ( parseHeader ) import Lexer @@ -120,7 +122,8 @@ mkPrelImports this_mod loc implicit_prelude import_decls preludeImportDecl :: LImportDecl GhcPs preludeImportDecl - = L loc $ ImportDecl { ideclSourceSrc = NoSourceText, + = L loc $ ImportDecl { ideclExt = noExt, + ideclSourceSrc = NoSourceText, ideclName = L loc pRELUDE_NAME, ideclPkgQual = Nothing, ideclSource = False, @@ -241,7 +244,8 @@ getOptions' dflags toks | IToptions_prag str <- getToken open , ITclose_prag <- getToken close = case toArgs str of - Left err -> panic ("getOptions'.parseToks: " ++ err) + Left _err -> optionsParseError str dflags $ -- #15053 + combineSrcSpans (getLoc open) (getLoc close) Right args -> map (L (getLoc open)) args ++ parseToks xs parseToks (open:close:xs) | ITinclude_prag str <- getToken open @@ -311,17 +315,15 @@ checkExtension dflags (L l ext) languagePragParseError :: DynFlags -> SrcSpan -> a languagePragParseError dflags loc = - throw $ mkSrcErr $ unitBag $ - (mkPlainErrMsg dflags loc $ + throwErr 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 TemplateHaskell, GADTs #-}") ]) + , nest 2 (text "E.g. {-# LANGUAGE TemplateHaskell, GADTs #-}") ] unsupportedExtnError :: DynFlags -> SrcSpan -> String -> a unsupportedExtnError dflags loc unsup = - throw $ mkSrcErr $ unitBag $ - mkPlainErrMsg dflags loc $ + throwErr dflags loc $ text "Unsupported extension: " <> text unsup $$ if null suggestions then Outputable.empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions) where @@ -337,3 +339,14 @@ optionsErrorMsgs dflags unhandled_flags flags_lines _filename ErrUtils.mkPlainErrMsg dflags flagSpan $ text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag +optionsParseError :: String -> DynFlags -> SrcSpan -> a -- #15053 +optionsParseError str dflags loc = + throwErr dflags loc $ + vcat [ text "Error while parsing OPTIONS_GHC pragma." + , text "Expecting whitespace-separated list of GHC options." + , text " E.g. {-# OPTIONS_GHC -Wall -O2 #-}" + , text ("Input was: " ++ show str) ] + +throwErr :: DynFlags -> SrcSpan -> SDoc -> a -- #15053 +throwErr dflags loc doc = + throw $ mkSrcErr $ unitBag $ mkPlainErrMsg dflags loc doc diff --git a/compiler/main/Hooks.hs b/compiler/main/Hooks.hs index 59126e98d5..f9d420ab61 100644 --- a/compiler/main/Hooks.hs +++ b/compiler/main/Hooks.hs @@ -2,8 +2,6 @@ -- NB: this module is SOURCE-imported by DynFlags, and should primarily -- refer to *types*, rather than *code* --- If you import too muchhere , then the revolting compiler_stage2_dll0_MODULES --- stuff in compiler/ghc.mk makes DynFlags link to too much stuff {-# LANGUAGE CPP #-} module Hooks ( Hooks @@ -25,6 +23,8 @@ module Hooks ( Hooks , createIservProcessHook ) where +import GhcPrelude + import DynFlags import PipelineMonad import HscTypes diff --git a/compiler/main/Hooks.hs-boot b/compiler/main/Hooks.hs-boot index 280de32063..f0246ef941 100644 --- a/compiler/main/Hooks.hs-boot +++ b/compiler/main/Hooks.hs-boot @@ -1,5 +1,7 @@ module Hooks where +import GhcPrelude () + data Hooks emptyHooks :: Hooks diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index c514e5b017..a8a33bfaad 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -82,7 +82,10 @@ module HscMain , hscAddSptEntries ) where +import GhcPrelude + import Data.Data hiding (Fixity, TyCon) +import DynFlags (addPluginModuleName) import Id import GHCi ( addSptEntry ) import GHCi.RemoteTypes ( ForeignHValue ) @@ -138,6 +141,8 @@ import Fingerprint ( Fingerprint ) import Hooks import TcEnv import PrelNames +import Plugins +import DynamicLoading ( initializePlugins ) import DynFlags import ErrUtils @@ -340,7 +345,7 @@ hscParse' mod_summary liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $ ppr rdr_module liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $ - text (showAstData NoBlankSrcSpan rdr_module) + showAstData NoBlankSrcSpan rdr_module liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $ ppSourceStats False rdr_module @@ -358,7 +363,7 @@ hscParse' mod_summary srcs0 = nub $ filter (not . (tmpDir dflags `isPrefixOf`)) $ filter (not . (== n_hspp)) $ map FilePath.normalise - $ filter (not . (isPrefixOf "<")) + $ filter (not . isPrefixOf "<") $ map unpackFS $ srcfiles pst srcs1 = case ml_hs_file (ms_location mod_summary) of @@ -370,7 +375,7 @@ hscParse' mod_summary -- filter them out: srcs2 <- liftIO $ filterM doesFileExist srcs1 - return HsParsedModule { + let res = HsParsedModule { hpm_module = rdr_module, hpm_src_files = srcs2, hpm_annotations @@ -379,32 +384,46 @@ hscParse' mod_summary :(annotations_comments pst))) } --- XXX: should this really be a Maybe X? Check under which circumstances this --- can become a Nothing and decide whether this should instead throw an --- exception/signal an error. -type RenamedStuff = - (Maybe (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [LIE GhcRn], - Maybe LHsDocString)) + -- apply parse transformation of plugins + let applyPluginAction p opts + = parsedResultAction p opts mod_summary + withPlugins dflags applyPluginAction res + + +-- ----------------------------------------------------------------------------- +-- | If the renamed source has been kept, extract it. Dump it if requested. +extract_renamed_stuff :: TcGblEnv -> Hsc (TcGblEnv, RenamedStuff) +extract_renamed_stuff tc_result = do + let rn_info = getRenamedStuff tc_result + + dflags <- getDynFlags + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_rn_ast "Renamer" $ + showAstData NoBlankSrcSpan rn_info + + return (tc_result, rn_info) + +-- ----------------------------------------------------------------------------- -- | Rename and typecheck a module, additionally returning the renamed syntax hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule -> IO (TcGblEnv, RenamedStuff) hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do - tc_result <- hscTypecheck True mod_summary (Just rdr_module) - - -- This 'do' is in the Maybe monad! - let rn_info = do decl <- tcg_rn_decls tc_result - let imports = tcg_rn_imports tc_result - exports = tcg_rn_exports tc_result - doc_hdr = tcg_doc_hdr tc_result - return (decl,imports,exports,doc_hdr) - - return (tc_result, rn_info) + tc_result <- hscTypecheck True mod_summary (Just rdr_module) + extract_renamed_stuff tc_result hscTypecheck :: Bool -- ^ Keep renamed source? -> ModSummary -> Maybe HsParsedModule -> Hsc TcGblEnv hscTypecheck keep_rn mod_summary mb_rdr_module = do + tc_result <- hscTypecheck' keep_rn mod_summary mb_rdr_module + _ <- extract_renamed_stuff tc_result + return tc_result + + +hscTypecheck' :: Bool -- ^ Keep renamed source? + -> ModSummary -> Maybe HsParsedModule + -> Hsc TcGblEnv +hscTypecheck' keep_rn mod_summary mb_rdr_module = do hsc_env <- getHscEnv let hsc_src = ms_hsc_src mod_summary dflags = hsc_dflags hsc_env @@ -421,7 +440,7 @@ hscTypecheck keep_rn mod_summary mb_rdr_module = do do hpm <- case mb_rdr_module of Just hpm -> return hpm Nothing -> hscParse' mod_summary - tc_result0 <- tcRnModule' hsc_env mod_summary keep_rn hpm + tc_result0 <- tcRnModule' mod_summary keep_rn hpm if hsc_src == HsigFile then do (iface, _, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 Nothing ioMsgMaybe $ @@ -429,42 +448,51 @@ hscTypecheck keep_rn mod_summary mb_rdr_module = do else return tc_result0 -- wrapper around tcRnModule to handle safe haskell extras -tcRnModule' :: HscEnv -> ModSummary -> Bool -> HsParsedModule +tcRnModule' :: ModSummary -> Bool -> HsParsedModule -> Hsc TcGblEnv -tcRnModule' hsc_env sum save_rn_syntax mod = do +tcRnModule' sum save_rn_syntax mod = do + hsc_env <- getHscEnv + dflags <- getDynFlags + tcg_res <- {-# SCC "Typecheck-Rename" #-} ioMsgMaybe $ - tcRnModule hsc_env (ms_hsc_src sum) save_rn_syntax mod + tcRnModule hsc_env sum + save_rn_syntax mod -- See Note [Safe Haskell Overlapping Instances Implementation] -- although this is used for more than just that failure case. (tcSafeOK, whyUnsafe) <- liftIO $ readIORef (tcg_safeInfer tcg_res) - dflags <- getDynFlags let allSafeOK = safeInferred dflags && tcSafeOK -- end of the safe haskell line, how to respond to user? - if not (safeHaskellOn dflags) || (safeInferOn dflags && not allSafeOK) - -- if safe Haskell off or safe infer failed, mark unsafe - then markUnsafeInfer tcg_res whyUnsafe - - -- module (could be) safe, throw warning if needed - else do - tcg_res' <- hscCheckSafeImports tcg_res - safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res') - when safe $ do - case wopt Opt_WarnSafe dflags of - True -> (logWarnings $ unitBag $ - makeIntoWarning (Reason Opt_WarnSafe) $ - mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $ - errSafe tcg_res') - False | safeHaskell dflags == Sf_Trustworthy && - wopt Opt_WarnTrustworthySafe dflags -> - (logWarnings $ unitBag $ - makeIntoWarning (Reason Opt_WarnTrustworthySafe) $ - mkPlainWarnMsg dflags (trustworthyOnLoc dflags) $ - errTwthySafe tcg_res') - False -> return () - return tcg_res' + res <- if not (safeHaskellOn dflags) + || (safeInferOn dflags && not allSafeOK) + -- if safe Haskell off or safe infer failed, mark unsafe + then markUnsafeInfer tcg_res whyUnsafe + + -- module (could be) safe, throw warning if needed + else do + tcg_res' <- hscCheckSafeImports tcg_res + safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res') + when safe $ do + case wopt Opt_WarnSafe dflags of + True -> (logWarnings $ unitBag $ + makeIntoWarning (Reason Opt_WarnSafe) $ + mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $ + errSafe tcg_res') + False | safeHaskell dflags == Sf_Trustworthy && + wopt Opt_WarnTrustworthySafe dflags -> + (logWarnings $ unitBag $ + makeIntoWarning (Reason Opt_WarnTrustworthySafe) $ + mkPlainWarnMsg dflags (trustworthyOnLoc dflags) $ + errTwthySafe tcg_res') + False -> return () + return tcg_res' + + -- apply plugins to the type checking result + + + return res where pprMod t = ppr $ moduleName $ tcg_mod t errSafe t = quotes (pprMod t) <+> text "has been inferred as safe!" @@ -506,7 +534,7 @@ makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result -------------------------------- It's the task of the compilation proper to compile Haskell, hs-boot and core -files to either byte-code, hard-code (C, asm, LLVM, ect) or to nothing at all +files to either byte-code, hard-code (C, asm, LLVM, etc.) or to nothing at all (the module is still parsed and type-checked. This feature is mostly used by IDE's and the likes). Compilation can happen in either 'one-shot', 'batch', 'nothing', or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch' @@ -644,15 +672,18 @@ hscIncrementalCompile :: Bool hscIncrementalCompile always_do_basic_recompilation_check m_tc_result mHscMessage hsc_env' mod_summary source_modified mb_old_iface mod_index = do + dflags <- initializePlugins hsc_env' (hsc_dflags hsc_env') + let hsc_env'' = hsc_env' { hsc_dflags = dflags } + -- One-shot mode needs a knot-tying mutable variable for interface -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var. -- See also Note [hsc_type_env_var hack] type_env_var <- newIORef emptyNameEnv let mod = ms_mod mod_summary - hsc_env | isOneShot (ghcMode (hsc_dflags hsc_env')) - = hsc_env' { hsc_type_env_var = Just (mod, type_env_var) } + hsc_env | isOneShot (ghcMode (hsc_dflags hsc_env'')) + = hsc_env'' { hsc_type_env_var = Just (mod, type_env_var) } | otherwise - = hsc_env' + = hsc_env'' -- NB: enter Hsc monad here so that we don't bail out early with -- -Werror on typechecker warnings; we also want to run the desugarer @@ -687,19 +718,19 @@ hscIncrementalCompile always_do_basic_recompilation_check m_tc_result -- to retypecheck but the resulting interface is exactly -- the same.) Right (FrontendTypecheck tc_result, mb_old_hash) -> - finish hsc_env mod_summary tc_result mb_old_hash + finish mod_summary tc_result mb_old_hash -- Runs the post-typechecking frontend (desugar and simplify), -- and then generates and writes out the final interface. We want -- to write the interface AFTER simplification so we can get -- as up-to-date and good unfoldings and other info as possible -- in the interface file. -finish :: HscEnv - -> ModSummary +finish :: ModSummary -> TcGblEnv -> Maybe Fingerprint -> Hsc (HscStatus, HomeModInfo) -finish hsc_env summary tc_result mb_old_hash = do +finish summary tc_result mb_old_hash = do + hsc_env <- getHscEnv let dflags = hsc_dflags hsc_env target = hscTarget dflags hsc_src = ms_hsc_src summary @@ -728,7 +759,8 @@ finish hsc_env summary tc_result mb_old_hash = do -- and generate a simple interface. then mk_simple_iface else do - desugared_guts <- hscSimplify' desugared_guts0 + plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result) + desugared_guts <- hscSimplify' plugins desugared_guts0 (iface, changed, details, cgguts) <- liftIO $ hscNormalIface hsc_env desugared_guts mb_old_hash return (iface, changed, details, HscRecomp cgguts summary) @@ -857,7 +889,7 @@ hscFileFrontEnd mod_summary = hscTypecheck False mod_summary Nothing hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv hscCheckSafeImports tcg_env = do dflags <- getDynFlags - tcg_env' <- checkSafeImports dflags tcg_env + tcg_env' <- checkSafeImports tcg_env checkRULES dflags tcg_env' where @@ -877,15 +909,16 @@ hscCheckSafeImports tcg_env = do -> return tcg_env' warns dflags rules = listToBag $ map (warnRules dflags) rules - warnRules dflags (L loc (HsRule n _ _ _ _ _ _)) = + warnRules dflags (L loc (HsRule _ n _ _ _ _)) = mkPlainWarnMsg dflags loc $ text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$ text "User defined rules are disabled under Safe Haskell" + warnRules _ (L _ (XRuleDecl _)) = panic "hscCheckSafeImports" -- | Validate that safe imported modules are actually safe. For modules in the -- HomePackage (the package the module we are compiling in resides) this just -- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules --- that reside in another package we also must check that the external pacakge +-- that reside in another package we also must check that the external package -- is trusted. See the Note [Safe Haskell Trust Check] above for more -- information. -- @@ -894,9 +927,10 @@ hscCheckSafeImports tcg_env = do -- RnNames.rnImportDecl for where package trust dependencies for a module are -- collected and unioned. Specifically see the Note [RnNames . Tracking Trust -- Transitively] and the Note [RnNames . Trust Own Package]. -checkSafeImports :: DynFlags -> TcGblEnv -> Hsc TcGblEnv -checkSafeImports dflags tcg_env +checkSafeImports :: TcGblEnv -> Hsc TcGblEnv +checkSafeImports tcg_env = do + dflags <- getDynFlags imps <- mapM condense imports' let (safeImps, regImps) = partition (\(_,_,s) -> s) imps @@ -932,8 +966,8 @@ checkSafeImports dflags tcg_env tcg_env' <- case (not infPassed) of True -> markUnsafeInfer tcg_env infErrs False -> return tcg_env - when (packageTrustOn dflags) $ checkPkgTrust dflags pkgReqs - let newTrust = pkgTrustReqs safePkgs infPkgs infPassed + when (packageTrustOn dflags) $ checkPkgTrust pkgReqs + let newTrust = pkgTrustReqs dflags safePkgs infPkgs infPassed return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust } where @@ -952,7 +986,9 @@ checkSafeImports dflags tcg_env cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal cond' v1 v2 | imv_is_safe v1 /= imv_is_safe v2 - = throwErrors $ unitBag $ mkPlainErrMsg dflags (imv_span v1) + = do + dflags <- getDynFlags + throwErrors $ unitBag $ mkPlainErrMsg dflags (imv_span v1) (text "Module" <+> ppr (imv_name v1) <+> (text $ "is imported both as a safe and unsafe import!")) | otherwise @@ -960,18 +996,19 @@ checkSafeImports dflags tcg_env -- easier interface to work with checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe InstalledUnitId) - checkSafe (m, l, _) = fst `fmap` hscCheckSafe' dflags m l + checkSafe (m, l, _) = fst `fmap` hscCheckSafe' m l -- what pkg's to add to our trust requirements - pkgTrustReqs :: Set InstalledUnitId -> Set InstalledUnitId -> Bool -> ImportAvails - pkgTrustReqs req inf infPassed | safeInferOn dflags + pkgTrustReqs :: DynFlags -> Set InstalledUnitId -> Set InstalledUnitId -> + Bool -> ImportAvails + pkgTrustReqs dflags req inf infPassed | safeInferOn dflags && safeHaskell dflags == Sf_None && infPassed = emptyImportAvails { imp_trust_pkgs = req `S.union` inf } - pkgTrustReqs _ _ _ | safeHaskell dflags == Sf_Unsafe + pkgTrustReqs dflags _ _ _ | safeHaskell dflags == Sf_Unsafe = emptyImportAvails - pkgTrustReqs req _ _ = emptyImportAvails { imp_trust_pkgs = req } + pkgTrustReqs _ req _ _ = emptyImportAvails { imp_trust_pkgs = req } -- | Check that a module is safe to import. -- @@ -980,16 +1017,15 @@ checkSafeImports dflags tcg_env hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool hscCheckSafe hsc_env m l = runHsc hsc_env $ do dflags <- getDynFlags - pkgs <- snd `fmap` hscCheckSafe' dflags m l - when (packageTrustOn dflags) $ checkPkgTrust dflags pkgs + pkgs <- snd `fmap` hscCheckSafe' m l + when (packageTrustOn dflags) $ checkPkgTrust pkgs errs <- getWarnings return $ isEmptyBag errs -- | Return if a module is trusted and the pkgs it depends on to be trusted. hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set InstalledUnitId) hscGetSafe hsc_env m l = runHsc hsc_env $ do - dflags <- getDynFlags - (self, pkgs) <- hscCheckSafe' dflags m l + (self, pkgs) <- hscCheckSafe' m l good <- isEmptyBag `fmap` getWarnings clearWarnings -- don't want them printed... let pkgs' | Just p <- self = S.insert p pkgs @@ -1000,18 +1036,21 @@ hscGetSafe hsc_env m l = runHsc hsc_env $ do -- Return (regardless of trusted or not) if the trust type requires the modules -- own package be trusted and a list of other packages required to be trusted -- (these later ones haven't been checked) but the own package trust has been. -hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe InstalledUnitId, Set InstalledUnitId) -hscCheckSafe' dflags m l = do +hscCheckSafe' :: Module -> SrcSpan + -> Hsc (Maybe InstalledUnitId, Set InstalledUnitId) +hscCheckSafe' m l = do + dflags <- getDynFlags (tw, pkgs) <- isModSafe m l case tw of - False -> return (Nothing, pkgs) - True | isHomePkg m -> return (Nothing, pkgs) + False -> return (Nothing, pkgs) + True | isHomePkg dflags m -> return (Nothing, pkgs) -- TODO: do we also have to check the trust of the instantiation? -- Not necessary if that is reflected in dependencies | otherwise -> return (Just $ toInstalledUnitId (moduleUnitId m), pkgs) where isModSafe :: Module -> SrcSpan -> Hsc (Bool, Set InstalledUnitId) isModSafe m l = do + dflags <- getDynFlags iface <- lookup' m case iface of -- can't load iface to check trust! @@ -1026,7 +1065,7 @@ hscCheckSafe' dflags m l = do -- check module is trusted safeM = trust `elem` [Sf_Safe, Sf_Trustworthy] -- check package is trusted - safeP = packageTrusted trust trust_own_pkg m + safeP = packageTrusted dflags trust trust_own_pkg m -- pkg trust reqs pkgRs = S.fromList . map fst $ filter snd $ dep_pkgs $ mi_deps iface' -- General errors we throw but Safe errors we log @@ -1054,18 +1093,19 @@ hscCheckSafe' dflags m l = do -- modules are trusted without requiring that their package is trusted. For -- trustworthy modules, modules in the home package are trusted but -- otherwise we check the package trust flag. - packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool - packageTrusted Sf_None _ _ = False -- shouldn't hit these cases - packageTrusted Sf_Unsafe _ _ = False -- prefer for completeness. - packageTrusted _ _ _ - | not (packageTrustOn dflags) = True - packageTrusted Sf_Safe False _ = True - packageTrusted _ _ m - | isHomePkg m = True - | otherwise = trusted $ getPackageDetails dflags (moduleUnitId m) + packageTrusted :: DynFlags -> SafeHaskellMode -> Bool -> Module -> Bool + packageTrusted _ Sf_None _ _ = False -- shouldn't hit these cases + packageTrusted _ Sf_Unsafe _ _ = False -- prefer for completeness. + packageTrusted dflags _ _ _ + | not (packageTrustOn dflags) = True + packageTrusted _ Sf_Safe False _ = True + packageTrusted dflags _ _ m + | isHomePkg dflags m = True + | otherwise = trusted $ getPackageDetails dflags (moduleUnitId m) lookup' :: Module -> Hsc (Maybe ModIface) lookup' m = do + dflags <- getDynFlags hsc_env <- getHscEnv hsc_eps <- liftIO $ hscEPS hsc_env let pkgIfaceT = eps_PIT hsc_eps @@ -1080,19 +1120,16 @@ hscCheckSafe' dflags m l = do return iface' - isHomePkg :: Module -> Bool - isHomePkg m + isHomePkg :: DynFlags -> Module -> Bool + isHomePkg dflags m | thisPackage dflags == moduleUnitId m = True | otherwise = False -- | Check the list of packages are trusted. -checkPkgTrust :: DynFlags -> Set InstalledUnitId -> Hsc () -checkPkgTrust dflags pkgs = - case errors of - [] -> return () - _ -> (liftIO . throwIO . mkSrcErr . listToBag) errors - where - errors = S.foldr go [] pkgs +checkPkgTrust :: Set InstalledUnitId -> Hsc () +checkPkgTrust pkgs = do + dflags <- getDynFlags + let errors = S.foldr go [] pkgs go pkg acc | trusted $ getInstalledPackageDetails dflags pkg = acc @@ -1100,6 +1137,9 @@ checkPkgTrust dflags pkgs = = (:acc) $ mkErrMsg dflags noSrcSpan (pkgQual dflags) $ text "The package (" <> ppr pkg <> text ") is required" <> text " to be trusted but it isn't!" + case errors of + [] -> return () + _ -> (liftIO . throwIO . mkSrcErr . listToBag) errors -- | Set module to unsafe and (potentially) wipe trust information. -- @@ -1163,14 +1203,18 @@ hscGetSafeMode tcg_env = do -- Simplifiers -------------------------------------------------------------- -hscSimplify :: HscEnv -> ModGuts -> IO ModGuts -hscSimplify hsc_env modguts = runHsc hsc_env $ hscSimplify' modguts +hscSimplify :: HscEnv -> [String] -> ModGuts -> IO ModGuts +hscSimplify hsc_env plugins modguts = + runHsc hsc_env $ hscSimplify' plugins modguts -hscSimplify' :: ModGuts -> Hsc ModGuts -hscSimplify' ds_result = do +hscSimplify' :: [String] -> ModGuts -> Hsc ModGuts +hscSimplify' plugins ds_result = do hsc_env <- getHscEnv + let hsc_env_with_plugins = hsc_env + { hsc_dflags = foldr addPluginModuleName (hsc_dflags hsc_env) plugins + } {-# SCC "Core2Core" #-} - liftIO $ core2core hsc_env ds_result + liftIO $ core2core hsc_env_with_plugins ds_result -------------------------------------------------------------- -- Interface generators @@ -1270,15 +1314,17 @@ hscGenHardCode hsc_env cgguts mod_summary output_filename = do ------------------- -- PREPARE FOR CODE GENERATION -- Do saturation and convert to A-normal form - prepd_binds <- {-# SCC "CorePrep" #-} + (prepd_binds, local_ccs) <- {-# SCC "CorePrep" #-} corePrepPgm hsc_env this_mod location core_binds data_tycons ----------------- Convert to STG ------------------ - (stg_binds, cost_centre_info) + (stg_binds, (caf_ccs, caf_cc_stacks)) <- {-# SCC "CoreToStg" #-} myCoreToStg dflags this_mod prepd_binds - let prof_init = profilingInitCode this_mod cost_centre_info + let cost_centre_info = + (S.toList local_ccs ++ caf_ccs, caf_cc_stacks) + prof_init = profilingInitCode this_mod cost_centre_info foreign_stubs = foreign_stubs0 `appendStubC` prof_init ------------------ Code generation ------------------ @@ -1335,7 +1381,7 @@ hscInteractive hsc_env cgguts mod_summary = do ------------------- -- PREPARE FOR CODE GENERATION -- Do saturation and convert to A-normal form - prepd_binds <- {-# SCC "CorePrep" #-} + (prepd_binds, _) <- {-# SCC "CorePrep" #-} corePrepPgm hsc_env this_mod location core_binds data_tycons ----------------- Generate byte code ------------------ comp_bc <- byteCodeGen hsc_env this_mod prepd_binds data_tycons mod_breaks @@ -1351,15 +1397,13 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do let dflags = hsc_dflags hsc_env cmm <- ioMsgMaybe $ parseCmmFile dflags filename liftIO $ do - us <- mkSplitUniqSupply 'S' - let initTopSRT = initUs_ us emptySRT dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose "Parsed Cmm" (ppr cmm) - (_, cmmgroup) <- cmmPipeline hsc_env initTopSRT cmm - rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup) let -- Make up a module name to give the NCG. We can't pass bottom here -- lest we reproduce #11784. mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename cmm_mod = mkModule (thisPackage dflags) mod_name + (_, cmmgroup) <- cmmPipeline hsc_env (emptySRT cmm_mod) cmm + rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup) _ <- codeOutput dflags cmm_mod output_filename no_loc NoStubs [] [] rawCmms return () @@ -1410,21 +1454,17 @@ doCodeGen hsc_env this_mod data_tycons osSubsectionsViaSymbols (platformOS (targetPlatform dflags)) = {-# SCC "cmmPipeline" #-} let run_pipeline us cmmgroup = do - let (topSRT', us') = initUs us emptySRT - (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT' cmmgroup - let srt | isEmptySRT topSRT = [] - | otherwise = srtToData topSRT - return (us', srt ++ cmmgroup) + (_topSRT, cmmgroup) <- + cmmPipeline hsc_env (emptySRT this_mod) cmmgroup + return (us, cmmgroup) in do _ <- Stream.mapAccumL run_pipeline us ppr_stream1 return () | otherwise = {-# SCC "cmmPipeline" #-} - let initTopSRT = initUs_ us emptySRT - run_pipeline = cmmPipeline hsc_env - in do topSRT <- Stream.mapAccumL run_pipeline initTopSRT ppr_stream1 - Stream.yield (srtToData topSRT) + let run_pipeline = cmmPipeline hsc_env + in void $ Stream.mapAccumL run_pipeline (emptySRT this_mod) ppr_stream1 let dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm @@ -1439,15 +1479,15 @@ doCodeGen hsc_env this_mod data_tycons myCoreToStg :: DynFlags -> Module -> CoreProgram -> IO ( [StgTopBinding] -- output program - , CollectedCCs) -- cost centre info (declared and used) + , CollectedCCs ) -- CAF cost centre info (declared and used) myCoreToStg dflags this_mod prepd_binds = do - let stg_binds + let (stg_binds, cost_centre_info) = {-# SCC "Core2Stg" #-} coreToStg dflags this_mod prepd_binds - (stg_binds2, cost_centre_info) + stg_binds2 <- {-# SCC "Stg2Stg" #-} - stg2stg dflags this_mod stg_binds + stg2stg dflags stg_binds return (stg_binds2, cost_centre_info) @@ -1553,7 +1593,9 @@ hscDeclsWithLocation hsc_env0 str source linenumber = ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv {- Simplify -} - simpl_mg <- liftIO $ hscSimplify hsc_env ds_result + simpl_mg <- liftIO $ do + plugins <- readIORef (tcg_th_coreplugins tc_gblenv) + hscSimplify hsc_env plugins ds_result {- Tidy -} (tidy_cg, mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg @@ -1571,7 +1613,7 @@ hscDeclsWithLocation hsc_env0 str source linenumber = {- Prepare For Code Generation -} -- Do saturation and convert to A-normal form - prepd_binds <- {-# SCC "CorePrep" #-} + (prepd_binds, _) <- {-# SCC "CorePrep" #-} liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons {- Generate byte code -} @@ -1668,7 +1710,7 @@ hscParseExpr expr = do hsc_env <- getHscEnv maybe_stmt <- hscParseStmt expr case maybe_stmt of - Just (L _ (BodyStmt expr _ _ _)) -> return expr + Just (L _ (BodyStmt _ expr _ _)) -> return expr _ -> throwErrors $ unitBag $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan (text "not an expression:" <+> quotes (text expr)) @@ -1713,7 +1755,7 @@ hscParseThingWithLocation source linenumber parser str logWarningsReportErrors (getMessages pst dflags) liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing) liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $ - text $ showAstData NoBlankSrcSpan thing + showAstData NoBlankSrcSpan thing return thing diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs index 598cb5be0a..ce59ca1877 100644 --- a/compiler/main/HscStats.hs +++ b/compiler/main/HscStats.hs @@ -8,6 +8,8 @@ module HscStats ( ppSourceStats ) where +import GhcPrelude + import Bag import HsSyn import Outputable @@ -68,18 +70,18 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls) (fixity_sigs, bind_tys, bind_specs, bind_inlines, generic_sigs) - = count_sigs [d | SigD d <- decls] + = 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] + 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_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] + val_decls = [d | ValD _ d <- decls] real_exports = case exports of { Nothing -> []; Just (L _ es) -> es } n_exports = length real_exports @@ -100,7 +102,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) (inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds) = sum5 (map inst_info inst_decls) - count_bind (PatBind { pat_lhs = L _ (VarPat _) }) = (1,0,0) + count_bind (PatBind { pat_lhs = L _ (VarPat{}) }) = (1,0,0) count_bind (PatBind {}) = (0,1,0) count_bind (FunBind {}) = (0,1,0) count_bind (PatSynBind {}) = (0,0,1) @@ -118,6 +120,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) 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) + import_info (L _ (XImportDecl _)) = panic "import_info" safe_info = qual_info qual_info False = 0 qual_info True = 1 @@ -153,6 +156,8 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) ss, is, length ats, length adts) where methods = map unLoc $ bagToList inst_meths + inst_info (ClsInstD _ (XClsInstDecl _)) = panic "inst_info" + inst_info (XInstDecl _) = panic "inst_info" -- TODO: use Sum monoid addpr :: (Int,Int,Int) -> Int diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index e064147965..77067c2ee2 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -44,7 +44,7 @@ module HscTypes ( lookupHpt, eltsHpt, filterHpt, allHpt, mapHpt, delFromHpt, addToHpt, addListToHpt, lookupHptDirectly, listToHpt, hptCompleteSigs, - hptInstances, hptRules, hptVectInfo, pprHPT, + hptInstances, hptRules, pprHPT, -- * State relating to known packages ExternalPackageState(..), EpsStats(..), addEpsInStats, @@ -106,7 +106,7 @@ module HscTypes ( -- * Information on imports and exports WhetherHasOrphans, IsBootInterface, Usage(..), Dependencies(..), noDependencies, - updNameCacheIO, + updNameCache, IfaceExport, -- * Warnings @@ -123,10 +123,6 @@ module HscTypes ( -- * Breakpoints ModBreaks (..), emptyModBreaks, - -- * Vectorisation information - VectInfo(..), IfaceVectInfo(..), noVectInfo, plusVectInfo, - noIfaceVectInfo, isNoIfaceVectInfo, - -- * Safe Haskell information IfaceTrustInfo, getSafeMode, setSafeMode, noIfaceTrustInfo, trustInfoToNum, numToTrustInfo, IsSafeImport, @@ -146,6 +142,8 @@ module HscTypes ( #include "HsVersions.h" +import GhcPrelude + import ByteCodeTypes import InteractiveEvalTypes ( Resume ) import GHCi.Message ( Pipe ) @@ -159,11 +157,9 @@ import Avail import Module import InstEnv ( InstEnv, ClsInst, identicalClsInstHead ) import FamInstEnv -import CoreSyn ( CoreProgram, RuleBase, CoreRule, CoreVect ) +import CoreSyn ( CoreProgram, RuleBase, CoreRule ) import Name import NameEnv -import NameSet -import VarEnv import VarSet import Var import Id @@ -178,8 +174,7 @@ import CoAxiom import ConLike import DataCon import PatSyn -import PrelNames ( gHC_PRIM, ioTyConName, printName, mkInteractiveModule - , eqTyConName ) +import PrelNames ( gHC_PRIM, ioTyConName, printName, mkInteractiveModule ) import TysWiredIn import Packages hiding ( Version(..) ) import CmdLineParser @@ -208,7 +203,6 @@ import qualified GHC.LanguageExtensions as LangExt import Foreign import Control.Monad ( guard, liftM, ap ) -import Data.Foldable ( foldl' ) import Data.IORef import Data.Time import Exception @@ -663,13 +657,6 @@ hptInstances hsc_env want_this_module return (md_insts details, md_fam_insts details) in (concat insts, concat famInsts) --- | Get the combined VectInfo of all modules in the home package table. In --- contrast to instances and rules, we don't care whether the modules are --- "below" us in the dependency sense. The VectInfo of those modules not "below" --- us does not affect the compilation of the current module. -hptVectInfo :: HscEnv -> VectInfo -hptVectInfo = concatVectInfo . hptAllThings ((: []) . md_vect_info . hm_details) - -- | Get rules from modules "below" this one (in the dependency sense) hptRules :: HscEnv -> [(ModuleName, IsBootInterface)] -> [CoreRule] hptRules = hptSomeThingsBelowUs (md_rules . hm_details) False @@ -828,6 +815,9 @@ data FindResult , fr_pkgs_hidden :: [UnitId] -- Module is in these packages, -- but the *package* is hidden + -- Modules are in these packages, but it is unusable + , fr_unusables :: [(UnitId, UnusablePackageReason)] + , fr_suggestions :: [ModuleSuggestion] -- Possible mis-spelled modules } @@ -855,7 +845,11 @@ data ModIface mi_iface_hash :: !Fingerprint, -- ^ Hash of the whole interface mi_mod_hash :: !Fingerprint, -- ^ Hash of the ABI only mi_flag_hash :: !Fingerprint, -- ^ Hash of the important flags - -- used when compiling this module + -- used when compiling the module, + -- excluding optimisation flags + mi_opt_hash :: !Fingerprint, -- ^ Hash of optimisation flags + mi_hpc_hash :: !Fingerprint, -- ^ Hash of hpc flags + mi_plugin_hash :: !Fingerprint, -- ^ Hash of plugins mi_orphan :: !WhetherHasOrphans, -- ^ Whether this module has orphans mi_finsts :: !WhetherHasFamInst, @@ -928,9 +922,7 @@ data ModIface mi_fam_insts :: [IfaceFamInst], -- ^ Sorted family instances mi_rules :: [IfaceRule], -- ^ Sorted rules mi_orphan_hash :: !Fingerprint, -- ^ Hash for orphan rules, class and family - -- instances, and vectorise pragmas combined - - mi_vect_info :: !IfaceVectInfo, -- ^ Vectorisation information + -- instances combined -- Cached environments for easy lookup -- These are computed (lazily) from other fields @@ -959,7 +951,16 @@ data ModIface -- itself) but imports some trustworthy modules from its own -- package (which does require its own package be trusted). -- See Note [RnNames . Trust Own Package] - mi_complete_sigs :: [IfaceCompleteMatch] + mi_complete_sigs :: [IfaceCompleteMatch], + + mi_doc_hdr :: Maybe HsDocString, + -- ^ Module header. + + mi_decl_docs :: DeclDocMap, + -- ^ Docs on declarations. + + mi_arg_docs :: ArgDocMap + -- ^ Docs on arguments. } -- | Old-style accessor for whether or not the ModIface came from an hs-boot @@ -1016,6 +1017,9 @@ instance Binary ModIface where mi_iface_hash= iface_hash, mi_mod_hash = mod_hash, mi_flag_hash = flag_hash, + mi_opt_hash = opt_hash, + mi_hpc_hash = hpc_hash, + mi_plugin_hash = plugin_hash, mi_orphan = orphan, mi_finsts = hasFamInsts, mi_deps = deps, @@ -1031,17 +1035,22 @@ instance Binary ModIface where mi_fam_insts = fam_insts, mi_rules = rules, mi_orphan_hash = orphan_hash, - mi_vect_info = vect_info, mi_hpc = hpc_info, mi_trust = trust, mi_trust_pkg = trust_pkg, - mi_complete_sigs = complete_sigs }) = do + mi_complete_sigs = complete_sigs, + mi_doc_hdr = doc_hdr, + mi_decl_docs = decl_docs, + mi_arg_docs = arg_docs }) = do put_ bh mod put_ bh sig_of put_ bh hsc_src put_ bh iface_hash put_ bh mod_hash put_ bh flag_hash + put_ bh opt_hash + put_ bh hpc_hash + put_ bh plugin_hash put_ bh orphan put_ bh hasFamInsts lazyPut bh deps @@ -1057,11 +1066,13 @@ instance Binary ModIface where put_ bh fam_insts lazyPut bh rules put_ bh orphan_hash - put_ bh vect_info put_ bh hpc_info put_ bh trust put_ bh trust_pkg put_ bh complete_sigs + lazyPut bh doc_hdr + lazyPut bh decl_docs + lazyPut bh arg_docs get bh = do mod <- get bh @@ -1070,6 +1081,9 @@ instance Binary ModIface where iface_hash <- get bh mod_hash <- get bh flag_hash <- get bh + opt_hash <- get bh + hpc_hash <- get bh + plugin_hash <- get bh orphan <- get bh hasFamInsts <- get bh deps <- lazyGet bh @@ -1085,11 +1099,13 @@ instance Binary ModIface where fam_insts <- {-# SCC "bin_fam_insts" #-} get bh rules <- {-# SCC "bin_rules" #-} lazyGet bh orphan_hash <- get bh - vect_info <- get bh hpc_info <- get bh trust <- get bh trust_pkg <- get bh complete_sigs <- get bh + doc_hdr <- lazyGet bh + decl_docs <- lazyGet bh + arg_docs <- lazyGet bh return (ModIface { mi_module = mod, mi_sig_of = sig_of, @@ -1097,6 +1113,9 @@ instance Binary ModIface where mi_iface_hash = iface_hash, mi_mod_hash = mod_hash, mi_flag_hash = flag_hash, + mi_opt_hash = opt_hash, + mi_hpc_hash = hpc_hash, + mi_plugin_hash = plugin_hash, mi_orphan = orphan, mi_finsts = hasFamInsts, mi_deps = deps, @@ -1113,7 +1132,6 @@ instance Binary ModIface where mi_fam_insts = fam_insts, mi_rules = rules, mi_orphan_hash = orphan_hash, - mi_vect_info = vect_info, mi_hpc = hpc_info, mi_trust = trust, mi_trust_pkg = trust_pkg, @@ -1121,7 +1139,10 @@ instance Binary ModIface where mi_warn_fn = mkIfaceWarnCache warns, mi_fix_fn = mkIfaceFixCache fixities, mi_hash_fn = mkIfaceHashCache decls, - mi_complete_sigs = complete_sigs }) + mi_complete_sigs = complete_sigs, + mi_doc_hdr = doc_hdr, + mi_decl_docs = decl_docs, + mi_arg_docs = arg_docs }) -- | The original names declared of a certain module that are exported type IfaceExport = AvailInfo @@ -1134,6 +1155,9 @@ emptyModIface mod mi_iface_hash = fingerprint0, mi_mod_hash = fingerprint0, mi_flag_hash = fingerprint0, + mi_opt_hash = fingerprint0, + mi_hpc_hash = fingerprint0, + mi_plugin_hash = fingerprint0, mi_orphan = False, mi_finsts = False, mi_hsc_src = HsSrcFile, @@ -1151,14 +1175,16 @@ emptyModIface mod mi_decls = [], mi_globals = Nothing, mi_orphan_hash = fingerprint0, - mi_vect_info = noIfaceVectInfo, mi_warn_fn = emptyIfaceWarnCache, mi_fix_fn = emptyIfaceFixCache, mi_hash_fn = emptyIfaceHashCache, mi_hpc = False, mi_trust = noIfaceTrustInfo, mi_trust_pkg = False, - mi_complete_sigs = [] } + mi_complete_sigs = [], + mi_doc_hdr = Nothing, + mi_decl_docs = emptyDeclDocMap, + mi_arg_docs = emptyArgDocMap } -- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface' @@ -1190,7 +1216,6 @@ data ModDetails md_rules :: ![CoreRule], -- ^ Domain may include 'Id's from other modules md_anns :: ![Annotation], -- ^ Annotations present in this module: currently -- they only annotate things also declared in this module - md_vect_info :: !VectInfo, -- ^ Module vectorisation information md_complete_sigs :: [CompleteMatch] -- ^ Complete match pragmas for this module } @@ -1204,7 +1229,6 @@ emptyModDetails md_rules = [], md_fam_insts = [], md_anns = [], - md_vect_info = noVectInfo, md_complete_sigs = [] } -- | Records the modules directly imported by a module for extracting e.g. @@ -1229,7 +1253,8 @@ data ImportedModsVal imv_span :: SrcSpan, -- ^ the source span of the whole import imv_is_safe :: IsSafeImport, -- ^ whether this is a safe import imv_is_hiding :: Bool, -- ^ whether this is an "hiding" import - imv_all_exports :: GlobalRdrEnv, -- ^ all the things the module could provide + imv_all_exports :: !GlobalRdrEnv, -- ^ all the things the module could provide + -- NB. BangPattern here: otherwise this leaks. (#15111) imv_qualified :: Bool -- ^ whether this is a qualified import } @@ -1263,16 +1288,13 @@ data ModGuts -- See Note [Overall plumbing for rules] in Rules.hs mg_binds :: !CoreProgram, -- ^ Bindings for this module mg_foreign :: !ForeignStubs, -- ^ Foreign exports declared in this module - mg_foreign_files :: ![(ForeignSrcLang, String)], + mg_foreign_files :: ![(ForeignSrcLang, FilePath)], -- ^ Files to be compiled with the C compiler mg_warns :: !Warnings, -- ^ Warnings declared in the module mg_anns :: [Annotation], -- ^ Annotations declared in this module mg_complete_sigs :: [CompleteMatch], -- ^ Complete Matches mg_hpc_info :: !HpcInfo, -- ^ Coverage tick boxes in the module mg_modBreaks :: !(Maybe ModBreaks), -- ^ Breakpoints for the module - mg_vect_decls:: ![CoreVect], -- ^ Vectorisation declarations in this module - -- (produced by desugarer & consumed by vectoriser) - mg_vect_info :: !VectInfo, -- ^ Pool of vectorised declarations in the module -- The next two fields are unusual, because they give instance -- environments for *all* modules in the home package, including @@ -1287,9 +1309,13 @@ data ModGuts -- one); c.f. 'tcg_fam_inst_env' mg_safe_haskell :: SafeHaskellMode, -- ^ Safe Haskell mode - mg_trust_pkg :: Bool -- ^ Do we need to trust our + mg_trust_pkg :: Bool, -- ^ Do we need to trust our -- own package for Safe Haskell? -- See Note [RnNames . Trust Own Package] + + mg_doc_hdr :: !(Maybe HsDocString), -- ^ Module header. + mg_decl_docs :: !DeclDocMap, -- ^ Docs on declarations. + mg_arg_docs :: !ArgDocMap -- ^ Docs on arguments. } -- The ModGuts takes on several slightly different forms: @@ -1320,11 +1346,11 @@ data CgGuts -- ^ The tidied main bindings, including -- previously-implicit bindings for record and class -- selectors, and data constructor wrappers. But *not* - -- data constructor workers; reason: we we regard them + -- data constructor workers; reason: we regard them -- as part of the code-gen of tycons cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs - cg_foreign_files :: ![(ForeignSrcLang, String)], + cg_foreign_files :: ![(ForeignSrcLang, FilePath)], cg_dep_pkgs :: ![InstalledUnitId], -- ^ Dependent packages, used to -- generate #includes for C code gen cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information @@ -1626,7 +1652,7 @@ extendInteractiveContext ictxt new_tythings new_cls_insts new_fam_insts defaults = ictxt { ic_mod_index = ic_mod_index ictxt + 1 -- Always bump this; even instances should create -- a new mod_index (Trac #9426) - , ic_tythings = new_tythings ++ ic_tythings ictxt + , ic_tythings = new_tythings ++ old_tythings , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings , ic_instances = ( new_cls_insts ++ old_cls_insts , new_fam_insts ++ fam_insts ) @@ -1636,6 +1662,8 @@ extendInteractiveContext ictxt new_tythings new_cls_insts new_fam_insts defaults , ic_fix_env = fix_env -- See Note [Fixity declarations in GHCi] } where + new_ids = [id | AnId id <- new_tythings] + old_tythings = filterOut (shadowed_by new_ids) (ic_tythings ictxt) -- Discard old instances that have been fully overridden -- See Note [Override identical instances in GHCi] @@ -1647,10 +1675,17 @@ extendInteractiveContextWithIds :: InteractiveContext -> [Id] -> InteractiveCont extendInteractiveContextWithIds ictxt new_ids | null new_ids = ictxt | otherwise = ictxt { ic_mod_index = ic_mod_index ictxt + 1 - , ic_tythings = new_tythings ++ ic_tythings ictxt + , ic_tythings = new_tythings ++ old_tythings , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings } where new_tythings = map AnId new_ids + old_tythings = filterOut (shadowed_by new_ids) (ic_tythings ictxt) + +shadowed_by :: [Id] -> TyThing -> Bool +shadowed_by ids = shadowed + where + shadowed id = getOccName id `elemOccSet` new_occs + new_occs = mkOccSet (map getOccName ids) setInteractivePackage :: HscEnv -> HscEnv -- Set the 'thisPackage' DynFlag to 'interactive' @@ -1675,7 +1710,7 @@ icExtendGblRdrEnv env tythings | is_sub_bndr thing = env | otherwise - = foldl extendGlobalRdrEnv env1 (concatMap localGREsFromAvail avail) + = foldl' extendGlobalRdrEnv env1 (concatMap localGREsFromAvail avail) where env1 = shadowNames env (concatMap availNames avail) avail = tyThingAvailInfo thing @@ -1696,8 +1731,13 @@ substInteractiveContext ictxt@InteractiveContext{ ic_tythings = tts } subst | isEmptyTCvSubst subst = ictxt | otherwise = ictxt { ic_tythings = map subst_ty tts } where - subst_ty (AnId id) = AnId $ id `setIdType` substTyUnchecked subst (idType id) - subst_ty tt = tt + subst_ty (AnId id) + = AnId $ id `setIdType` substTyAddInScope subst (idType id) + -- Variables in the interactive context *can* mention free type variables + -- because of the runtime debugger. Otherwise you'd expect all + -- variables bound in the interactive context to be closed. + subst_ty tt + = tt instance Outputable InteractiveImport where ppr (IIModule m) = char '*' <> ppr m @@ -1795,8 +1835,7 @@ mkPrintUnqualified dflags env = QueryQualify qual_name forceUnqualNames :: [Name] forceUnqualNames = - map tyConName [ constraintKindTyCon, heqTyCon, coercibleTyCon - , starKindTyCon, unicodeStarKindTyCon ] + map tyConName [ constraintKindTyCon, heqTyCon, coercibleTyCon ] ++ [ eqTyConName ] right_name gre = nameModule_maybe (gre_name gre) == Just mod @@ -2075,7 +2114,7 @@ extendTypeEnv :: TypeEnv -> TyThing -> TypeEnv extendTypeEnv env thing = extendNameEnv env (getName thing) thing extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv -extendTypeEnvList env things = foldl extendTypeEnv env things +extendTypeEnvList env things = foldl' extendTypeEnv env things extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv extendTypeEnvWithIds env ids @@ -2287,7 +2326,6 @@ lookupFixity env n = case lookupNameEnv env n of -- * A transformation rule in a module other than the one defining -- the function in the head of the rule -- --- * A vectorisation pragma type WhetherHasOrphans = Bool -- | Does this module define family instances? @@ -2332,6 +2370,9 @@ data Dependencies -- This is used by 'checkFamInstConsistency'. This -- does NOT include us, unlike 'imp_finsts'. See Note -- [The type family instance consistency story]. + + , dep_plgins :: [ModuleName] + -- ^ All the plugins used while compiling this module. } deriving( Eq ) -- Equality used only for old/new comparison in MkIface.addFingerprints @@ -2342,16 +2383,18 @@ instance Binary Dependencies where put_ bh (dep_pkgs deps) put_ bh (dep_orphs deps) put_ bh (dep_finsts deps) + put_ bh (dep_plgins deps) get bh = do ms <- get bh ps <- get bh os <- get bh fis <- get bh + pl <- get bh return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os, - dep_finsts = fis }) + dep_finsts = fis, dep_plgins = pl }) noDependencies :: Dependencies -noDependencies = Deps [] [] [] [] +noDependencies = Deps [] [] [] [] [] -- | Records modules for which changes may force recompilation of this module -- See wiki: http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance @@ -2481,7 +2524,6 @@ type PackageTypeEnv = TypeEnv type PackageRuleBase = RuleBase type PackageInstEnv = InstEnv type PackageFamInstEnv = FamInstEnv -type PackageVectInfo = VectInfo type PackageAnnEnv = AnnEnv type PackageCompleteMatchMap = CompleteMatchMap @@ -2543,8 +2585,6 @@ data ExternalPackageState -- from all the external-package modules eps_rule_base :: !PackageRuleBase, -- ^ The total 'RuleEnv' accumulated -- from all the external-package modules - eps_vect_info :: !PackageVectInfo, -- ^ The total 'VectInfo' accumulated - -- from all the external-package modules eps_ann_env :: !PackageAnnEnv, -- ^ The total 'AnnEnv' accumulated -- from all the external-package modules eps_complete_matches :: !PackageCompleteMatchMap, @@ -2583,11 +2623,11 @@ interface file); so we give it 'noSrcLoc' then. Later, when we find its binding site, we fix it up. -} -updNameCacheIO :: HscEnv - -> (NameCache -> (NameCache, c)) -- The updating function - -> IO c -updNameCacheIO hsc_env upd_fn - = atomicModifyIORef' (hsc_NC hsc_env) upd_fn +updNameCache :: IORef NameCache + -> (NameCache -> (NameCache, c)) -- The updating function + -> IO c +updNameCache ncRef upd_fn + = atomicModifyIORef' ncRef upd_fn mkSOName :: Platform -> FilePath -> FilePath mkSOName platform root @@ -2602,7 +2642,6 @@ soExt :: Platform -> FilePath soExt platform = case platformOS platform of OSDarwin -> "dylib" - OSiOS -> "dylib" OSMinGW32 -> "dll" _ -> "so" @@ -2848,119 +2887,6 @@ isHpcUsed (NoHpcInfo { hpcUsed = used }) = used {- ************************************************************************ * * -\subsection{Vectorisation Support} -* * -************************************************************************ - -The following information is generated and consumed by the vectorisation -subsystem. It communicates the vectorisation status of declarations from one -module to another. - -Why do we need both f and f_v in the ModGuts/ModDetails/EPS version VectInfo -below? We need to know `f' when converting to IfaceVectInfo. However, during -vectorisation, we need to know `f_v', whose `Var' we cannot lookup based -on just the OccName easily in a Core pass. --} - --- |Vectorisation information for 'ModGuts', 'ModDetails' and 'ExternalPackageState'; see also --- documentation at 'Vectorise.Env.GlobalEnv'. --- --- NB: The following tables may also include 'Var's, 'TyCon's and 'DataCon's from imported modules, --- which have been subsequently vectorised in the current module. --- -data VectInfo - = VectInfo - { vectInfoVar :: DVarEnv (Var , Var ) -- ^ @(f, f_v)@ keyed on @f@ - , vectInfoTyCon :: NameEnv (TyCon , TyCon) -- ^ @(T, T_v)@ keyed on @T@ - , vectInfoDataCon :: NameEnv (DataCon, DataCon) -- ^ @(C, C_v)@ keyed on @C@ - , vectInfoParallelVars :: DVarSet -- ^ set of parallel variables - , vectInfoParallelTyCons :: NameSet -- ^ set of parallel type constructors - } - --- |Vectorisation information for 'ModIface'; i.e, the vectorisation information propagated --- across module boundaries. --- --- NB: The field 'ifaceVectInfoVar' explicitly contains the workers of data constructors as well as --- class selectors — i.e., their mappings are /not/ implicitly generated from the data types. --- Moreover, whether the worker of a data constructor is in 'ifaceVectInfoVar' determines --- whether that data constructor was vectorised (or is part of an abstractly vectorised type --- constructor). --- -data IfaceVectInfo - = IfaceVectInfo - { ifaceVectInfoVar :: [Name] -- ^ All variables in here have a vectorised variant - , ifaceVectInfoTyCon :: [Name] -- ^ All 'TyCon's in here have a vectorised variant; - -- the name of the vectorised variant and those of its - -- data constructors are determined by - -- 'OccName.mkVectTyConOcc' and - -- 'OccName.mkVectDataConOcc'; the names of the - -- isomorphisms are determined by 'OccName.mkVectIsoOcc' - , ifaceVectInfoTyConReuse :: [Name] -- ^ The vectorised form of all the 'TyCon's in here - -- coincides with the unconverted form; the name of the - -- isomorphisms is determined by 'OccName.mkVectIsoOcc' - , ifaceVectInfoParallelVars :: [Name] -- iface version of 'vectInfoParallelVar' - , ifaceVectInfoParallelTyCons :: [Name] -- iface version of 'vectInfoParallelTyCon' - } - -noVectInfo :: VectInfo -noVectInfo - = VectInfo emptyDVarEnv emptyNameEnv emptyNameEnv emptyDVarSet emptyNameSet - -plusVectInfo :: VectInfo -> VectInfo -> VectInfo -plusVectInfo vi1 vi2 = - VectInfo (vectInfoVar vi1 `plusDVarEnv` vectInfoVar vi2) - (vectInfoTyCon vi1 `plusNameEnv` vectInfoTyCon vi2) - (vectInfoDataCon vi1 `plusNameEnv` vectInfoDataCon vi2) - (vectInfoParallelVars vi1 `unionDVarSet` vectInfoParallelVars vi2) - (vectInfoParallelTyCons vi1 `unionNameSet` vectInfoParallelTyCons vi2) - -concatVectInfo :: [VectInfo] -> VectInfo -concatVectInfo = foldr plusVectInfo noVectInfo - -noIfaceVectInfo :: IfaceVectInfo -noIfaceVectInfo = IfaceVectInfo [] [] [] [] [] - -isNoIfaceVectInfo :: IfaceVectInfo -> Bool -isNoIfaceVectInfo (IfaceVectInfo l1 l2 l3 l4 l5) - = null l1 && null l2 && null l3 && null l4 && null l5 - -instance Outputable VectInfo where - ppr info = vcat - [ text "variables :" <+> ppr (vectInfoVar info) - , text "tycons :" <+> ppr (vectInfoTyCon info) - , text "datacons :" <+> ppr (vectInfoDataCon info) - , text "parallel vars :" <+> ppr (vectInfoParallelVars info) - , text "parallel tycons :" <+> ppr (vectInfoParallelTyCons info) - ] - -instance Outputable IfaceVectInfo where - ppr info = vcat - [ text "variables :" <+> ppr (ifaceVectInfoVar info) - , text "tycons :" <+> ppr (ifaceVectInfoTyCon info) - , text "tycons reuse :" <+> ppr (ifaceVectInfoTyConReuse info) - , text "parallel vars :" <+> ppr (ifaceVectInfoParallelVars info) - , text "parallel tycons :" <+> ppr (ifaceVectInfoParallelTyCons info) - ] - - -instance Binary IfaceVectInfo where - put_ bh (IfaceVectInfo a1 a2 a3 a4 a5) = do - put_ bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - get bh = do - a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - return (IfaceVectInfo a1 a2 a3 a4 a5) - -{- -************************************************************************ -* * \subsection{Safe Haskell Support} * * ************************************************************************ diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 88d5dbe57d..452ccb3e80 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -30,6 +30,8 @@ module InteractiveEval ( exprType, typeKind, parseName, + getDocs, + GetDocsFailure(..), showModule, moduleIsBootOrNotObjectLinkable, parseExpr, compileParsedExpr, @@ -40,6 +42,8 @@ module InteractiveEval ( #include "HsVersions.h" +import GhcPrelude + import InteractiveEvalTypes import GHCi @@ -89,6 +93,8 @@ import Data.Dynamic import Data.Either import qualified Data.IntMap as IntMap import Data.List (find,intercalate) +import Data.Map (Map) +import qualified Data.Map as Map import StringBuffer (stringToStringBuffer) import Control.Monad import GHC.Exts @@ -808,7 +814,7 @@ isDecl dflags stmt = do case parseThing Parser.parseDeclaration dflags stmt of Lexer.POk _ thing -> case unLoc thing of - SpliceD _ -> False + SpliceD _ _ -> False _ -> True Lexer.PFailed _ _ _ -> False @@ -819,6 +825,70 @@ parseThing parser dflags stmt = do Lexer.unP parser (Lexer.mkPState dflags buf loc) +getDocs :: GhcMonad m + => Name + -> m (Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString)) + -- TODO: What about docs for constructors etc.? +getDocs name = + withSession $ \hsc_env -> do + case nameModule_maybe name of + Nothing -> pure (Left (NameHasNoModule name)) + Just mod -> do + if isInteractiveModule mod + then pure (Left InteractiveName) + else do + ModIface { mi_doc_hdr = mb_doc_hdr + , mi_decl_docs = DeclDocMap dmap + , mi_arg_docs = ArgDocMap amap + } <- liftIO $ hscGetModuleInterface hsc_env mod + if isNothing mb_doc_hdr && Map.null dmap && Map.null amap + then pure (Left (NoDocsInIface mod compiled)) + else pure (Right ( Map.lookup name dmap + , Map.findWithDefault Map.empty name amap)) + where + compiled = + -- TODO: Find a more direct indicator. + case nameSrcLoc name of + RealSrcLoc {} -> False + UnhelpfulLoc {} -> True + +-- | Failure modes for 'getDocs'. + +-- TODO: Find a way to differentiate between modules loaded without '-haddock' +-- and modules that contain no docs. +data GetDocsFailure + + -- | 'nameModule_maybe' returned 'Nothing'. + = NameHasNoModule Name + + -- | This is probably because the module was loaded without @-haddock@, + -- but it's also possible that the entire module contains no documentation. + | NoDocsInIface + Module + Bool -- ^ 'True': The module was compiled. + -- 'False': The module was :loaded. + + -- | The 'Name' was defined interactively. + | InteractiveName + +instance Outputable GetDocsFailure where + ppr (NameHasNoModule name) = + quotes (ppr name) <+> text "has no module where we could look for docs." + ppr (NoDocsInIface mod compiled) = vcat + [ text "Can't find any documentation for" <+> ppr mod <> char '.' + , text "This is probably because the module was" + <+> text (if compiled then "compiled" else "loaded") + <+> text "without '-haddock'," + , text "but it's also possible that the module contains no documentation." + , text "" + , if compiled + then text "Try re-compiling with '-haddock'." + else text "Try running ':set -haddock' and :load the file again." + -- TODO: Figure out why :reload doesn't load the docs and maybe fix it. + ] + ppr InteractiveName = + text "Docs are unavailable for interactive declarations." + -- ----------------------------------------------------------------------------- -- Getting the type of an expression @@ -838,7 +908,7 @@ typeKind normalise str = withSession $ \hsc_env -> do liftIO $ hscKcType hsc_env normalise str ----------------------------------------------------------------------------- --- Compile an expression, run it and deliver the result +-- Compile an expression, run it, and deliver the result -- | Parse an expression, the parsed expression can be further processed and -- passed to compileParsedExpr. @@ -846,19 +916,19 @@ parseExpr :: GhcMonad m => String -> m (LHsExpr GhcPs) parseExpr expr = withSession $ \hsc_env -> do liftIO $ runInteractiveHsc hsc_env $ hscParseExpr expr --- | Compile an expression, run it and deliver the resulting HValue. +-- | Compile an expression, run it, and deliver the resulting HValue. compileExpr :: GhcMonad m => String -> m HValue compileExpr expr = do parsed_expr <- parseExpr expr compileParsedExpr parsed_expr --- | Compile an expression, run it and deliver the resulting HValue. +-- | Compile an expression, run it, and deliver the resulting HValue. compileExprRemote :: GhcMonad m => String -> m ForeignHValue compileExprRemote expr = do parsed_expr <- parseExpr expr compileParsedExprRemote parsed_expr --- | Compile an parsed expression (before renaming), run it and deliver +-- | Compile a parsed expression (before renaming), run it, and deliver -- the resulting HValue. compileParsedExprRemote :: GhcMonad m => LHsExpr GhcPs -> m ForeignHValue compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do @@ -868,10 +938,15 @@ compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do -- create a new binding. let expr_fs = fsLit "_compileParsedExpr" expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc - let_stmt = L loc . LetStmt . L loc . HsValBinds $ - ValBindsIn (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) [] + let_stmt = L loc . LetStmt noExt . L loc . (HsValBinds noExt) $ + ValBinds noExt + (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) [] + + pstmt <- liftIO $ hscParsedStmt hsc_env let_stmt + let (hvals_io, fix_env) = case pstmt of + Just ([_id], hvals_io', fix_env') -> (hvals_io', fix_env') + _ -> panic "compileParsedExprRemote" - Just ([_id], hvals_io, fix_env) <- liftIO $ hscParsedStmt hsc_env let_stmt updateFixityEnv fix_env status <- liftIO $ evalStmt hsc_env False (EvalThis hvals_io) case status of @@ -892,7 +967,7 @@ dynCompileExpr expr = do parsed_expr <- parseExpr expr -- > Data.Dynamic.toDyn expr let loc = getLoc parsed_expr - to_dyn_expr = mkHsApp (L loc . HsVar . L loc $ getRdrName toDynName) + to_dyn_expr = mkHsApp (L loc . HsVar noExt . L loc $ getRdrName toDynName) parsed_expr hval <- compileParsedExpr to_dyn_expr return (unsafeCoerce# hval :: Dynamic) @@ -919,20 +994,22 @@ moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env -> -- RTTI primitives obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term -obtainTermFromVal hsc_env bound force ty x = - cvObtainTerm hsc_env bound force ty (unsafeCoerce# x) +obtainTermFromVal hsc_env bound force ty x + | gopt Opt_ExternalInterpreter (hsc_dflags hsc_env) + = throwIO (InstallationError + "this operation requires -fno-external-interpreter") + | otherwise + = cvObtainTerm hsc_env bound force ty (unsafeCoerce# x) obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term obtainTermFromId hsc_env bound force id = do - let dflags = hsc_dflags hsc_env - hv <- Linker.getHValue hsc_env (varName id) >>= wormhole dflags + hv <- Linker.getHValue hsc_env (varName id) cvObtainTerm hsc_env bound force (idType id) hv -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type) reconstructType hsc_env bound id = do - let dflags = hsc_dflags hsc_env - hv <- Linker.getHValue hsc_env (varName id) >>= wormhole dflags + hv <- Linker.getHValue hsc_env (varName id) cvReconstructType hsc_env bound (idType id) hv mkRuntimeUnkTyVar :: Name -> Kind -> TyVar diff --git a/compiler/main/InteractiveEvalTypes.hs b/compiler/main/InteractiveEvalTypes.hs index cb0121950f..3bc043f88b 100644 --- a/compiler/main/InteractiveEvalTypes.hs +++ b/compiler/main/InteractiveEvalTypes.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - -- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow, 2005-2007 @@ -14,6 +12,8 @@ module InteractiveEvalTypes ( BreakInfo(..) ) where +import GhcPrelude + import GHCi.RemoteTypes import GHCi.Message (EvalExpr, ResumeContext) import Id @@ -25,11 +25,7 @@ import SrcLoc import Exception import Data.Word -#if MIN_VERSION_base(4,9,0) import GHC.Stack.CCS -#else -import GHC.Stack as GHC.Stack.CCS -#endif data ExecOptions = ExecOptions diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs index 23f37da64d..b003f5fa5a 100644 --- a/compiler/main/PackageConfig.hs +++ b/compiler/main/PackageConfig.hs @@ -30,6 +30,8 @@ module PackageConfig ( #include "HsVersions.h" +import GhcPrelude + import GHC.PackageDb import Data.Version diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs index 2c5833fae4..04efa1fe51 100644 --- a/compiler/main/Packages.hs +++ b/compiler/main/Packages.hs @@ -7,7 +7,7 @@ module Packages ( module PackageConfig, -- * Reading the package config, and processing cmdline args - PackageState(preloadPackages, explicitPackages, requirementContext), + PackageState(preloadPackages, explicitPackages, moduleToPkgConfAll, requirementContext), PackageConfigMap, emptyPackageState, initPackages, @@ -35,6 +35,8 @@ module Packages ( LookupResult(..), ModuleSuggestion(..), ModuleOrigin(..), + UnusablePackageReason(..), + pprReason, -- * Inspecting the set of packages in scope getPackageIncludePath, @@ -46,8 +48,9 @@ module Packages ( getPackageConfigMap, getPreloadPackagesAnd, + collectArchives, collectIncludeDirs, collectLibraryPaths, collectLinkOpts, - packageHsLibs, + packageHsLibs, getLibs, -- * Utils unwireUnitId, @@ -61,6 +64,8 @@ where #include "HsVersions.h" +import GhcPrelude + import GHC.PackageDb import PackageConfig import DynFlags @@ -71,6 +76,7 @@ import UniqSet import Module import Util import Panic +import Platform import Outputable import Maybes @@ -88,12 +94,9 @@ import Data.Char ( toUpper ) import Data.List as List import Data.Map (Map) import Data.Set (Set) -import Data.Maybe (mapMaybe) import Data.Monoid (First(..)) -#if __GLASGOW_HASKELL__ > 710 import Data.Semigroup ( Semigroup ) import qualified Data.Semigroup as Semigroup -#endif import qualified Data.Map as Map import qualified Data.Map.Strict as MapStrict import qualified Data.Set as Set @@ -123,7 +126,7 @@ import Data.Version -- Let @depExposedPackages@ be the transitive closure from @exposedPackages@ of -- their dependencies. -- --- * When searching for a module from an preload import declaration, +-- * When searching for a module from a preload import declaration, -- only the exposed modules in @exposedPackages@ are valid. -- -- * When searching for a module from an implicit import, all modules @@ -156,6 +159,8 @@ data ModuleOrigin = -- (But maybe the user didn't realize), so we'll still keep track -- of these modules.) ModHidden + -- | Module is unavailable because the package is unusable. + | ModUnusable UnusablePackageReason -- | Module is public, and could have come from some places. | ModOrigin { -- | @Just False@ means that this module is in @@ -175,6 +180,7 @@ data ModuleOrigin = instance Outputable ModuleOrigin where ppr ModHidden = text "hidden module" + ppr (ModUnusable _) = text "unusable module" ppr (ModOrigin e res rhs f) = sep (punctuate comma ( (case e of Nothing -> [] @@ -207,7 +213,6 @@ fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False fromFlag :: ModuleOrigin fromFlag = ModOrigin Nothing [] [] True -#if __GLASGOW_HASKELL__ > 710 instance Semigroup ModuleOrigin where ModOrigin e res rhs f <> ModOrigin e' res' rhs' f' = ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f') @@ -217,23 +222,16 @@ instance Semigroup ModuleOrigin where g Nothing x = x g x Nothing = x _x <> _y = panic "ModOrigin: hidden module redefined" -#endif instance Monoid ModuleOrigin where mempty = ModOrigin Nothing [] [] False - mappend (ModOrigin e res rhs f) (ModOrigin e' res' rhs' f') = - ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f') - where g (Just b) (Just b') - | b == b' = Just b - | otherwise = panic "ModOrigin: package both exposed/hidden" - g Nothing x = x - g x Nothing = x - mappend _ _ = panic "ModOrigin: hidden module redefined" + mappend = (Semigroup.<>) -- | Is the name from the import actually visible? (i.e. does it cause -- ambiguity, or is it only relevant when we're making suggestions?) originVisible :: ModuleOrigin -> Bool originVisible ModHidden = False +originVisible (ModUnusable _) = False originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f -- | Are there actually no providers for this module? This will never occur @@ -287,6 +285,17 @@ instance Outputable UnitVisibility where uv_requirements = reqs, uv_explicit = explicit }) = ppr (b, rns, mb_pn, reqs, explicit) + +instance Semigroup UnitVisibility where + uv1 <> uv2 + = UnitVisibility + { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2 + , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2 + , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2) + , uv_requirements = Map.unionWith Set.union (uv_requirements uv1) (uv_requirements uv2) + , uv_explicit = uv_explicit uv1 || uv_explicit uv2 + } + instance Monoid UnitVisibility where mempty = UnitVisibility { uv_expose_all = False @@ -295,14 +304,7 @@ instance Monoid UnitVisibility where , uv_requirements = Map.empty , uv_explicit = False } - mappend uv1 uv2 - = UnitVisibility - { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2 - , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2 - , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2) - , uv_requirements = Map.unionWith Set.union (uv_requirements uv1) (uv_requirements uv2) - , uv_explicit = uv_explicit uv1 || uv_explicit uv2 - } + mappend = (Semigroup.<>) type WiredUnitId = DefUnitId type PreloadUnitId = InstalledUnitId @@ -415,7 +417,7 @@ searchPackageId dflags pid = filter ((pid ==) . sourcePackageId) extendPackageConfigMap :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap extendPackageConfigMap (PackageConfigMap pkg_map closure) new_pkgs - = PackageConfigMap (foldl add pkg_map new_pkgs) closure + = PackageConfigMap (foldl' add pkg_map new_pkgs) closure -- We also add the expanded version of the packageConfigId, so that -- 'improveUnitId' can find it. where add pkg_map p = addToUDFM (addToUDFM pkg_map (expandedPackageConfigId p) p) @@ -915,15 +917,6 @@ 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 dflags (ExposePackage _ (PackageArg pkg) _) [] - | is_dph_package pkg - = throwGhcExceptionIO (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 dflags flag reasons = packageFlagErr' dflags (pprFlag flag) reasons @@ -1149,7 +1142,8 @@ pprReason pref reason = case reason of pref <+> text "unusable due to cyclic dependencies:" $$ nest 2 (hsep (map ppr deps)) IgnoredDependencies deps -> - pref <+> text "unusable due to ignored dependencies:" $$ + pref <+> text ("unusable because the -ignore-package flag was used to " ++ + "ignore at least one of its dependencies:") $$ nest 2 (hsep (map ppr deps)) ShadowedDependencies deps -> pref <+> text "unusable due to shadowed dependencies:" $$ @@ -1525,7 +1519,7 @@ mkPackageState dflags dbs preload0 = do -- let preload1 = Map.keys (Map.filter uv_explicit vis_map) - let pkgname_map = foldl add Map.empty pkgs2 + let pkgname_map = foldl' add Map.empty pkgs2 where add pn_map p = Map.insert (packageName p) (componentId p) pn_map @@ -1561,7 +1555,10 @@ mkPackageState dflags dbs preload0 = do dep_preload <- closeDeps dflags pkg_db (zip (map toInstalledUnitId preload3) (repeat Nothing)) let new_dep_preload = filter (`notElem` preload0) dep_preload - let mod_map = mkModuleToPkgConfAll dflags pkg_db vis_map + let mod_map1 = mkModuleToPkgConfAll dflags pkg_db vis_map + mod_map2 = mkUnusableModuleToPkgConfAll unusable + mod_map = Map.union mod_map1 mod_map2 + when (dopt Opt_D_dump_mod_map dflags) $ printInfoForUser (dflags { pprCols = 200 }) alwaysQualify (pprModuleMap mod_map) @@ -1600,12 +1597,36 @@ mkModuleToPkgConfAll -> VisibilityMap -> ModuleToPkgConfAll mkModuleToPkgConfAll dflags pkg_db vis_map = - Map.foldlWithKey extend_modmap emptyMap vis_map + -- What should we fold on? Both situations are awkward: + -- + -- * Folding on the visibility map means that we won't create + -- entries for packages that aren't mentioned in vis_map + -- (e.g., hidden packages, causing #14717) + -- + -- * Folding on pkg_db is awkward because if we have an + -- Backpack instantiation, we need to possibly add a + -- package from pkg_db multiple times to the actual + -- ModuleToPkgConfAll. Also, we don't really want + -- definite package instantiations to show up in the + -- list of possibilities. + -- + -- So what will we do instead? We'll extend vis_map with + -- entries for every definite (for non-Backpack) and + -- indefinite (for Backpack) package, so that we get the + -- hidden entries we need. + Map.foldlWithKey extend_modmap emptyMap vis_map_extended where + vis_map_extended = Map.union vis_map {- preferred -} default_vis + + default_vis = Map.fromList + [ (packageConfigId pkg, mempty) + | pkg <- eltsUDFM (unPackageConfigMap pkg_db) + -- Exclude specific instantiations of an indefinite + -- package + , indefinite pkg || null (instantiatedWith pkg) + ] + emptyMap = Map.empty - sing pk m _ = Map.singleton (mkModule pk m) - addListTo = foldl' merge - merge m (k, v) = MapStrict.insertWith (Map.unionWith mappend) k v m setOrigins m os = fmap (const os) m extend_modmap modmap uid UnitVisibility { uv_expose_all = b, uv_renamings = rns } @@ -1633,19 +1654,19 @@ mkModuleToPkgConfAll dflags pkg_db vis_map = es :: Bool -> [(ModuleName, Map Module ModuleOrigin)] es e = do (m, exposedReexport) <- exposed_mods - let (pk', m', pkg', origin') = + let (pk', m', origin') = case exposedReexport of - Nothing -> (pk, m, pkg, fromExposedModules e) + Nothing -> (pk, m, fromExposedModules e) Just (Module pk' m') -> let pkg' = pkg_lookup pk' - in (pk', m', pkg', fromReexportedModules e pkg') - return (m, sing pk' m' pkg' origin') + in (pk', m', fromReexportedModules e pkg') + return (m, mkModMap pk' m' origin') esmap :: UniqFM (Map Module ModuleOrigin) esmap = listToUFM (es False) -- parameter here doesn't matter, orig will -- be overwritten - hiddens = [(m, sing pk m pkg ModHidden) | m <- hidden_mods] + hiddens = [(m, mkModMap pk m ModHidden) | m <- hidden_mods] pk = packageConfigId pkg pkg_lookup uid = lookupPackage' (isIndefinite dflags) pkg_db uid @@ -1654,6 +1675,43 @@ mkModuleToPkgConfAll dflags pkg_db vis_map = exposed_mods = exposedModules pkg hidden_mods = hiddenModules pkg +-- | Make a 'ModuleToPkgConfAll' covering a set of unusable packages. +mkUnusableModuleToPkgConfAll :: UnusablePackages -> ModuleToPkgConfAll +mkUnusableModuleToPkgConfAll unusables = + Map.foldl' extend_modmap Map.empty unusables + where + extend_modmap modmap (pkg, reason) = addListTo modmap bindings + where bindings :: [(ModuleName, Map Module ModuleOrigin)] + bindings = exposed ++ hidden + + origin = ModUnusable reason + pkg_id = packageConfigId pkg + + exposed = map get_exposed exposed_mods + hidden = [(m, mkModMap pkg_id m origin) | m <- hidden_mods] + + get_exposed (mod, Just mod') = (mod, Map.singleton mod' origin) + get_exposed (mod, _) = (mod, mkModMap pkg_id mod origin) + + exposed_mods = exposedModules pkg + hidden_mods = hiddenModules pkg + +-- | Add a list of key/value pairs to a nested map. +-- +-- The outer map is processed with 'Data.Map.Strict' to prevent memory leaks +-- when reloading modules in GHCi (see Trac #4029). This ensures that each +-- value is forced before installing into the map. +addListTo :: (Monoid a, Ord k1, Ord k2) + => Map k1 (Map k2 a) + -> [(k1, Map k2 a)] + -> Map k1 (Map k2 a) +addListTo = foldl' merge + where merge m (k, v) = MapStrict.insertWith (Map.unionWith mappend) k v m + +-- | Create a singleton module mapping +mkModMap :: UnitId -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin +mkModMap pkg mod = Map.singleton (mkModule pkg mod) + -- ----------------------------------------------------------------------------- -- Extracting information from the packages in scope @@ -1695,6 +1753,21 @@ collectLinkOpts dflags ps = concatMap (map ("-l" ++) . extraLibraries) ps, concatMap ldOptions ps ) +collectArchives :: DynFlags -> PackageConfig -> IO [FilePath] +collectArchives dflags pc = + filterM doesFileExist [ searchPath </> ("lib" ++ lib ++ ".a") + | searchPath <- searchPaths + , lib <- libs ] + where searchPaths = nub . filter notNull . libraryDirsForWay dflags $ pc + libs = packageHsLibs dflags pc ++ extraLibraries pc + +getLibs :: DynFlags -> [PreloadUnitId] -> IO [(String,String)] +getLibs dflags pkgs = do + ps <- getPreloadPackagesAnd dflags pkgs + fmap concat . forM ps $ \p -> do + let candidates = [ (l </> f, f) | l <- collectLibraryPaths dflags [p] + , f <- (\n -> "lib" ++ n ++ ".a") <$> packageHsLibs dflags p ] + filterM (doesFileExist . fst) candidates packageHsLibs :: DynFlags -> PackageConfig -> [String] packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) @@ -1726,7 +1799,19 @@ packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) | otherwise = panic ("Don't understand library name " ++ x) + -- Add _thr and other rts suffixes to packages named + -- `rts` or `rts-1.0`. Why both? Traditionally the rts + -- package is called `rts` only. However the tooling + -- usually expects a package name to have a version. + -- As such we will gradually move towards the `rts-1.0` + -- package name, at which point the `rts` package name + -- will eventually be unused. + -- + -- This change elevates the need to add custom hooks + -- and handling specifically for the `rts` package for + -- example in ghc-cabal. addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag) + addSuffix rts@"HSrts-1.0"= rts ++ (expandTag rts_tag) addSuffix other_lib = other_lib ++ (expandTag tag) expandTag t | null t = "" @@ -1782,6 +1867,9 @@ data LookupResult = -- an exact name match. First is due to package hidden, second -- is due to module being hidden | LookupHidden [(Module, ModuleOrigin)] [(Module, ModuleOrigin)] + -- | No modules found, but there were some unusable ones with + -- an exact name match + | LookupUnusable [(Module, ModuleOrigin)] -- | Nothing found, here are some suggested different names | LookupNotFound [ModuleSuggestion] -- suggestions @@ -1813,20 +1901,28 @@ lookupModuleWithSuggestions' dflags mod_map m mb_pn = case Map.lookup m mod_map of Nothing -> LookupNotFound suggestions Just xs -> - case foldl' classify ([],[],[]) (Map.toList xs) of - ([], [], []) -> LookupNotFound suggestions - (_, _, [(m, _)]) -> LookupFound m (mod_pkg m) - (_, _, exposed@(_:_)) -> LookupMultiple exposed - (hidden_pkg, hidden_mod, []) -> LookupHidden hidden_pkg hidden_mod + case foldl' classify ([],[],[], []) (Map.toList xs) of + ([], [], [], []) -> LookupNotFound suggestions + (_, _, _, [(m, _)]) -> LookupFound m (mod_pkg m) + (_, _, _, exposed@(_:_)) -> LookupMultiple exposed + ([], [], unusable@(_:_), []) -> LookupUnusable unusable + (hidden_pkg, hidden_mod, _, []) -> + LookupHidden hidden_pkg hidden_mod where - classify (hidden_pkg, hidden_mod, exposed) (m, origin0) = + classify (hidden_pkg, hidden_mod, unusable, exposed) (m, origin0) = let origin = filterOrigin mb_pn (mod_pkg m) origin0 x = (m, origin) in case origin of - ModHidden -> (hidden_pkg, x:hidden_mod, exposed) - _ | originEmpty origin -> (hidden_pkg, hidden_mod, exposed) - | originVisible origin -> (hidden_pkg, hidden_mod, x:exposed) - | otherwise -> (x:hidden_pkg, hidden_mod, exposed) + ModHidden + -> (hidden_pkg, x:hidden_mod, unusable, exposed) + ModUnusable _ + -> (hidden_pkg, hidden_mod, x:unusable, exposed) + _ | originEmpty origin + -> (hidden_pkg, hidden_mod, unusable, exposed) + | originVisible origin + -> (hidden_pkg, hidden_mod, unusable, x:exposed) + | otherwise + -> (x:hidden_pkg, hidden_mod, unusable, exposed) pkg_lookup p = lookupPackage dflags p `orElse` pprPanic "lookupModuleWithSuggestions" (ppr p <+> ppr m) mod_pkg = pkg_lookup . moduleUnitId @@ -1842,6 +1938,7 @@ lookupModuleWithSuggestions' dflags mod_map m mb_pn filterOrigin (Just pn) pkg o = case o of ModHidden -> if go pkg then ModHidden else mempty + (ModUnusable _) -> if go pkg then o else mempty ModOrigin { fromOrigPackage = e, fromExposedReexport = res, fromHiddenReexport = rhs } -> ModOrigin { @@ -1875,8 +1972,16 @@ listVisibleModuleNames dflags = -- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of -- 'PackageConfig's getPreloadPackagesAnd :: DynFlags -> [PreloadUnitId] -> IO [PackageConfig] -getPreloadPackagesAnd dflags pkgids = +getPreloadPackagesAnd dflags pkgids0 = let + pkgids = pkgids0 ++ + -- An indefinite package will have insts to HOLE, + -- which is not a real package. Don't look it up. + -- Fixes #14525 + if isIndefinite dflags + then [] + else map (toInstalledUnitId . moduleUnitId . snd) + (thisUnitIdInsts dflags) state = pkgState dflags pkg_map = pkgIdMap state preload = preloadPackages state @@ -1957,7 +2062,7 @@ isDllName :: DynFlags -> Module -> Name -> Bool -- the symbol comes from another dynamically-linked package, -- and applies on all platforms, not just Windows isDllName dflags this_mod name - | WayDyn `notElem` ways dflags = False + | not (gopt Opt_ExternalDynamicRefs dflags) = False | Just mod <- nameModule_maybe name -- Issue #8696 - when GHC is dynamically linked, it will attempt -- to load the dynamic dependencies of object files at compile @@ -1971,16 +2076,19 @@ isDllName dflags this_mod name -- In the mean time, always force dynamic indirections to be -- generated: when the module name isn't the module being -- compiled, references are dynamic. - = if mod /= this_mod - then True - else case dllSplit dflags of - Nothing -> False - Just ss -> - let findMod m = let modStr = moduleNameString (moduleName m) - in case find (modStr `Set.member`) ss of - Just i -> i - Nothing -> panic ("Can't find " ++ modStr ++ "in DLL split") - in findMod mod /= findMod this_mod + = case platformOS $ targetPlatform dflags of + -- On Windows the hack for #8696 makes it unlinkable. + -- As the entire setup of the code from Cmm down to the RTS expects + -- the use of trampolines for the imported functions only when + -- doing intra-package linking, e.g. refering to a symbol defined in the same + -- package should not use a trampoline. + -- I much rather have dynamic TH not supported than the entire Dynamic linking + -- not due to a hack. + -- Also not sure this would break on Windows anyway. + OSMinGW32 -> moduleUnitId mod /= moduleUnitId this_mod + + -- For the other platforms, still perform the hack + _ -> mod /= this_mod | otherwise = False -- no, it is not even an external name diff --git a/compiler/main/Packages.hs-boot b/compiler/main/Packages.hs-boot index 0ed59db92b..80b9ebf8ae 100644 --- a/compiler/main/Packages.hs-boot +++ b/compiler/main/Packages.hs-boot @@ -1,4 +1,5 @@ module Packages where +import GhcPrelude import {-# SOURCE #-} DynFlags(DynFlags) import {-# SOURCE #-} Module(ComponentId, UnitId, InstalledUnitId) data PackageState diff --git a/compiler/main/PipelineMonad.hs b/compiler/main/PipelineMonad.hs index c8345276fa..bbb1a17b65 100644 --- a/compiler/main/PipelineMonad.hs +++ b/compiler/main/PipelineMonad.hs @@ -9,6 +9,8 @@ module PipelineMonad ( , getPipeEnv, getPipeState, setDynFlags, setModLocation, setForeignOs ) where +import GhcPrelude + import MonadUtils import Outputable import DynFlags diff --git a/compiler/main/PlatformConstants.hs b/compiler/main/PlatformConstants.hs index c9a4072206..96b0f70e6d 100644 --- a/compiler/main/PlatformConstants.hs +++ b/compiler/main/PlatformConstants.hs @@ -10,6 +10,8 @@ module PlatformConstants (PlatformConstants(..)) where +import GhcPrelude + -- Produced by deriveConstants #include "GHCConstantsHaskellType.hs" diff --git a/compiler/main/Plugins.hs b/compiler/main/Plugins.hs index 273bf7abd9..e83ec08805 100644 --- a/compiler/main/Plugins.hs +++ b/compiler/main/Plugins.hs @@ -1,20 +1,39 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} module Plugins ( - FrontendPlugin(..), defaultFrontendPlugin, FrontendPluginAction, - Plugin(..), CommandLineOption, - defaultPlugin + FrontendPlugin(..), defaultFrontendPlugin, FrontendPluginAction + , Plugin(..), CommandLineOption, LoadedPlugin(..), lpModuleName + , defaultPlugin, keepRenamedSource, withPlugins, withPlugins_ + , PluginRecompile(..) + , purePlugin, impurePlugin, flagRecompile ) where -import CoreMonad ( CoreToDo, CoreM ) -import TcRnTypes ( TcPlugin ) +import GhcPrelude + +import {-# SOURCE #-} CoreMonad ( CoreToDo, CoreM ) +import qualified TcRnTypes +import TcRnTypes ( TcGblEnv, IfM, TcM, tcg_rn_decls, tcg_rn_exports ) +import HsSyn +import DynFlags +import HscTypes import GhcMonad import DriverPhases +import Module ( ModuleName, Module(moduleName)) +import Fingerprint +import Data.List +import Outputable (Outputable(..), text, (<+>)) + +--Qualified import so we can define a Semigroup instance +-- but it doesn't clash with Outputable.<> +import qualified Data.Semigroup +import Control.Monad -- | Command line options gathered from the -PModule.Name:stuff syntax -- are given to you as this type type CommandLineOption = String --- | 'Plugin' is the core compiler plugin data type. Try to avoid +-- | 'Plugin' is the compiler plugin data type. Try to avoid -- constructing one of these directly, and just modify some fields of -- 'defaultPlugin' instead: this is to try and preserve source-code -- compatibility when we add fields to this. @@ -22,24 +41,148 @@ type CommandLineOption = String -- Nonetheless, this API is preliminary and highly likely to change in -- the future. data Plugin = Plugin { - installCoreToDos :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] + installCoreToDos :: CorePlugin -- ^ Modify the Core pipeline that will be used for compilation. -- This is called as the Core pipeline is built for every module -- being compiled, and plugins get the opportunity to modify the -- pipeline in a nondeterministic order. - , tcPlugin :: [CommandLineOption] -> Maybe TcPlugin + , tcPlugin :: TcPlugin -- ^ An optional typechecker plugin, which may modify the -- behaviour of the constraint solver. + , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile + -- ^ Specify how the plugin should affect recompilation. + , parsedResultAction :: [CommandLineOption] -> ModSummary -> HsParsedModule + -> Hsc HsParsedModule + -- ^ Modify the module when it is parsed. This is called by + -- HscMain when the parsing is successful. + , renamedResultAction :: [CommandLineOption] -> TcGblEnv + -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn) + -- ^ Modify each group after it is renamed. This is called after each + -- `HsGroup` has been renamed. + , typeCheckResultAction :: [CommandLineOption] -> ModSummary -> TcGblEnv + -> TcM TcGblEnv + -- ^ Modify the module when it is type checked. This is called add the + -- very end of typechecking. + , spliceRunAction :: [CommandLineOption] -> LHsExpr GhcTc + -> TcM (LHsExpr GhcTc) + -- ^ Modify the TH splice or quasiqoute before it is run. + , interfaceLoadAction :: forall lcl . [CommandLineOption] -> ModIface + -> IfM lcl ModIface + -- ^ Modify an interface that have been loaded. This is called by + -- LoadIface when an interface is successfully loaded. Not applied to + -- the loading of the plugin interface. Tools that rely on information from + -- modules other than the currently compiled one should implement this + -- function. } +-- Note [Source plugins] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The `Plugin` datatype have been extended by fields that allow access to the +-- different inner representations that are generated during the compilation +-- process. These fields are `parsedResultAction`, `renamedResultAction`, +-- `typeCheckResultAction`, `spliceRunAction` and `interfaceLoadAction`. +-- +-- The main purpose of these plugins is to help tool developers. They allow +-- development tools to extract the information about the source code of a big +-- Haskell project during the normal build procedure. In this case the plugin +-- acts as the tools access point to the compiler that can be controlled by +-- compiler flags. This is important because the manipulation of compiler flags +-- is supported by most build environment. +-- +-- For the full discussion, check the full proposal at: +-- https://ghc.haskell.org/trac/ghc/wiki/ExtendedPluginsProposal + + +-- | A plugin with its arguments. The result of loading the plugin. +data LoadedPlugin = LoadedPlugin { + lpPlugin :: Plugin + -- ^ the actual callable plugin + , lpModule :: ModIface + -- ^ the module containing the plugin + , lpArguments :: [CommandLineOption] + -- ^ command line arguments for the plugin + } + +lpModuleName :: LoadedPlugin -> ModuleName +lpModuleName = moduleName . mi_module . lpModule + + +data PluginRecompile = ForceRecompile | NoForceRecompile | MaybeRecompile Fingerprint + +instance Outputable PluginRecompile where + ppr ForceRecompile = text "ForceRecompile" + ppr NoForceRecompile = text "NoForceRecompile" + ppr (MaybeRecompile fp) = text "MaybeRecompile" <+> ppr fp + +instance Semigroup PluginRecompile where + ForceRecompile <> _ = ForceRecompile + NoForceRecompile <> r = r + MaybeRecompile fp <> NoForceRecompile = MaybeRecompile fp + MaybeRecompile fp <> MaybeRecompile fp' = MaybeRecompile (fingerprintFingerprints [fp, fp']) + MaybeRecompile _fp <> ForceRecompile = ForceRecompile + +instance Monoid PluginRecompile where + mempty = NoForceRecompile +#if __GLASGOW_HASKELL__ < 804 + mappend = (Data.Semigroup.<>) +#endif + +type CorePlugin = [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +type TcPlugin = [CommandLineOption] -> Maybe TcRnTypes.TcPlugin + +purePlugin, impurePlugin, flagRecompile :: [CommandLineOption] -> IO PluginRecompile +purePlugin _args = return NoForceRecompile + +impurePlugin _args = return ForceRecompile + +flagRecompile = + return . MaybeRecompile . fingerprintFingerprints . map fingerprintString . sort + -- | Default plugin: does nothing at all! For compatibility reasons -- you should base all your plugin definitions on this default value. defaultPlugin :: Plugin defaultPlugin = Plugin { - installCoreToDos = const return - , tcPlugin = const Nothing + installCoreToDos = const return + , tcPlugin = const Nothing + , pluginRecompile = impurePlugin + , renamedResultAction = \_ env grp -> return (env, grp) + , parsedResultAction = \_ _ -> return + , typeCheckResultAction = \_ _ -> return + , spliceRunAction = \_ -> return + , interfaceLoadAction = \_ -> return } + +-- | A renamer plugin which mades the renamed source available in +-- a typechecker plugin. +keepRenamedSource :: [CommandLineOption] -> TcGblEnv + -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn) +keepRenamedSource _ gbl_env group = + return (gbl_env { tcg_rn_decls = update (tcg_rn_decls gbl_env) + , tcg_rn_exports = update_exports (tcg_rn_exports gbl_env) }, group) + where + update_exports Nothing = Just [] + update_exports m = m + + update Nothing = Just emptyRnGroup + update m = m + + +type PluginOperation m a = Plugin -> [CommandLineOption] -> a -> m a +type ConstPluginOperation m a = Plugin -> [CommandLineOption] -> a -> m () + +-- | Perform an operation by using all of the plugins in turn. +withPlugins :: Monad m => DynFlags -> PluginOperation m a -> a -> m a +withPlugins df transformation input + = foldM (\arg (LoadedPlugin p _ opts) -> transformation p opts arg) + input (plugins df) + +-- | Perform a constant operation by using all of the plugins in turn. +withPlugins_ :: Monad m => DynFlags -> ConstPluginOperation m a -> a -> m () +withPlugins_ df transformation input + = mapM_ (\(LoadedPlugin p _ opts) -> transformation p opts input) + (plugins df) + type FrontendPluginAction = [String] -> [(String, Maybe Phase)] -> Ghc () data FrontendPlugin = FrontendPlugin { frontend :: FrontendPluginAction diff --git a/compiler/main/Plugins.hs-boot b/compiler/main/Plugins.hs-boot new file mode 100644 index 0000000000..4ccd3d8402 --- /dev/null +++ b/compiler/main/Plugins.hs-boot @@ -0,0 +1,9 @@ +-- The plugins datatype is stored in DynFlags, so it needs to be +-- exposed without importing all of its implementation. +module Plugins where + +import GhcPrelude () + +data Plugin + +data LoadedPlugin diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index 86098a5e7f..b0a72cf499 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -19,6 +19,8 @@ module PprTyThing ( #include "HsVersions.h" +import GhcPrelude + import Type ( TyThing(..) ) import IfaceSyn ( ShowSub(..), ShowHowMuch(..), AltPpr(..) , showToHeader, pprIfaceDecl ) @@ -35,39 +37,68 @@ import Outputable -- ----------------------------------------------------------------------------- -- Pretty-printing entities that we get from the GHC API -{- Note [Pretty-printing TyThings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We pretty-print a TyThing by converting it to an IfaceDecl, -and pretty-printing that (see ppr_ty_thing below). -Here is why: +{- Note [Pretty printing via IfaceSyn] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Our general plan for prett-printing + - Types + - TyCons + - Classes + - Pattern synonyms + ...etc... + +is to convert them to IfaceSyn, and pretty-print that. For example + - pprType converts a Type to an IfaceType, and pretty prints that. + - pprTyThing converts the TyThing to an IfaceDecl, + and pretty prints that. + +So IfaceSyn play a dual role: + - it's the internal version of an interface files + - it's used for pretty-printing -* When pretty-printing (a type, say), the idiomatic solution is not to - "rename type variables on the fly", but rather to "tidy" the type - (which gives each variable a distinct print-name), and then - pretty-print it (without renaming). Separate the two - concerns. Functions like tidyType do this. +Why do this? -* Alas, for type constructors, TyCon, tidying does not work well, +* A significant reason is that we need to be able + to pretty-print IfaceSyn (to display Foo.hi), and it was a + pain to duplicate masses of pretty-printing goop, esp for + Type and IfaceType. + +* When pretty-printing (a type, say), we want to tidy (with + tidyType) to avoids having (forall a a. blah) where the two + a's have different uniques. + + Alas, for type constructors, TyCon, tidying does not work well, because a TyCon includes DataCons which include Types, which mention TyCons. And tidying can't tidy a mutually recursive data structure graph, only trees. -* One alternative would be to ensure that TyCons get type variables - with distinct print-names. That's ok for type variables but less - easy for kind variables. Processing data type declarations is - already so complicated that I don't think it's sensible to add the - extra requirement that it generates only "pretty" types and kinds. - -* One place the non-pretty names can show up is in GHCi. But another - is in interface files. Look at MkIface.tyThingToIfaceDecl which - converts a TyThing (i.e. TyCon, Class etc) to an IfaceDecl. And it - already does tidying as part of that conversion! Why? Because - interface files contains fast-strings, not uniques, so the names - must at least be distinct. - -So if we convert to IfaceDecl, we get a nice tidy IfaceDecl, and can -print that. Of course, that means that pretty-printing IfaceDecls -must be careful to display nice user-friendly results, but that's ok. +* Interface files contains fast-strings, not uniques, so the very same + tidying must take place when we convert to IfaceDecl. E.g. + MkIface.tyThingToIfaceDecl which converts a TyThing (i.e. TyCon, + Class etc) to an IfaceDecl. + + Bottom line: IfaceDecls are already 'tidy', so it's straightforward + to print them. + +* An alternative I once explored was to ensure that TyCons get type + variables with distinct print-names. That's ok for type variables + but less easy for kind variables. Processing data type declarations + is already so complicated that I don't think it's sensible to add + the extra requirement that it generates only "pretty" types and + kinds. + +Consequences: + +- IfaceSyn (and IfaceType) must contain enough information to + print nicely. Hence, for example, the IfaceAppArgs type, which + allows us to suppress invisible kind arguments in types + (see Note [Suppressing invisible arguments] in IfaceType) + +- In a few places we have info that is used only for pretty-printing, + and is totally ignored when turning IfaceSyn back into TyCons + etc (in TcIface). For example, IfaceClosedSynFamilyTyCon + stores a [IfaceAxBranch] that is used only for pretty-printing. + +- See Note [Free tyvars in IfaceType] in IfaceType See #7730, #8776 for details -} diff --git a/compiler/main/StaticPtrTable.hs b/compiler/main/StaticPtrTable.hs index ff0d47e4b1..47547fca5b 100644 --- a/compiler/main/StaticPtrTable.hs +++ b/compiler/main/StaticPtrTable.hs @@ -60,13 +60,13 @@ Here is a running example: in ...(static k)... * The renamer looks for out-of-scope names in the body of the static - form, as always If all names are in scope, the free variables of the + form, as always. If all names are in scope, the free variables of the body are stored in AST at the location of the static form. * The typechecker verifies that all free variables occurring in the static form are floatable to top level (see Note [Meaning of - IdBindingInfo] in TcRnTypes). In our example, 'k' is floatable, even - though it is bound in a nested let, we are fine. + IdBindingInfo] in TcRnTypes). In our example, 'k' is floatable. + Even though it is bound in a nested let, we are fine. * The desugarer replaces the static form with an application of the function 'makeStatic' (defined in module GHC.StaticPtr.Internal of @@ -122,6 +122,8 @@ Here is a running example: in upsweep after we have compiled the module (see GhcMake.upsweep'). -} +import GhcPrelude + import CLabel import CoreSyn import CoreUtils (collectMakeStaticArgs) diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs index 3d16124d72..9bbce19602 100644 --- a/compiler/main/SysTools.hs +++ b/compiler/main/SysTools.hs @@ -8,123 +8,63 @@ ----------------------------------------------------------------------------- -} -{-# LANGUAGE CPP, ScopedTypeVariables #-} +{-# LANGUAGE CPP, MultiWayIf, ScopedTypeVariables #-} module SysTools ( - -- Initialisation + -- * Initialisation initSysTools, + initLlvmConfig, - -- Interface to system tools - runUnlit, runCpp, runCc, -- [Option] -> IO () - runPp, -- [Option] -> IO () - runSplit, -- [Option] -> IO () - runAs, runLink, runLibtool, -- [Option] -> IO () - runMkDLL, - runWindres, - runLlvmOpt, - runLlvmLlc, - runClang, - figureLlvmVersion, - - getLinkerInfo, - getCompilerInfo, + -- * Interface to system tools + module SysTools.Tasks, + module SysTools.Info, linkDynLib, - askLd, - - touch, -- String -> String -> IO () copy, copyWithHeader, + -- * General utilities Option(..), + expandTopDir, + + -- * Platform-specifics + libmLinkOpts, - -- frameworks + -- * Mac OS X frameworks getPkgFrameworkOpts, getFrameworkOpts ) where #include "HsVersions.h" +import GhcPrelude + import Module import Packages import Config import Outputable import ErrUtils -import Panic import Platform import Util import DynFlags -import Exception -import FileCleanup +import Fingerprint -import LlvmCodeGen.Base (llvmVersionStr, supportedLlvmVersion) - -import Data.IORef -import System.Exit -import System.Environment import System.FilePath import System.IO -import System.IO.Error as IO import System.Directory -import Data.Char -import Data.List - -#if defined(mingw32_HOST_OS) -#if MIN_VERSION_Win32(2,5,0) -import qualified System.Win32.Types as Win32 -#else -import qualified System.Win32.Info as Win32 -#endif -import Foreign -import Foreign.C.String -import System.Win32.Types (DWORD, LPTSTR, HANDLE) -import System.Win32.Types (failIfNull, failIf, iNVALID_HANDLE_VALUE) -import System.Win32.File (createFile,closeHandle, gENERIC_READ, fILE_SHARE_READ, oPEN_EXISTING, fILE_ATTRIBUTE_NORMAL, fILE_FLAG_BACKUP_SEMANTICS ) -import System.Win32.DLL (loadLibrary, getProcAddress) -#endif - -import System.Process -import Control.Concurrent -import FastString -import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan ) - -#if defined(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 +import SysTools.ExtraObj +import SysTools.Info +import SysTools.Tasks +import SysTools.BaseDir {- -How GHC finds its files -~~~~~~~~~~~~~~~~~~~~~~~ - -[Note topdir] - -GHC needs various support files (library packages, RTS etc), plus -various auxiliary programs (cp, gcc, etc). It starts by finding topdir, -the root of GHC's support files - -On Unix: - - ghc always has a shell wrapper that passes a -B<dir> option - -On Windows: - - ghc never has a shell wrapper. - - we can find the location of the ghc binary, which is - $topdir/<foo>/<something>.exe - where <something> may be "ghc", "ghc-stage2", or similar - - we strip off the "<foo>/<something>.exe" to leave $topdir. - -from topdir we can find package.conf, ghc-asm, etc. - +Note [How GHC finds toolchain utilities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ SysTools.initSysProgs figures out exactly where all the auxiliary programs are, and initialises mutable variables to make it easy to call them. -To to this, it makes use of definitions in Config.hs, which is a Haskell +To do this, it makes use of definitions in Config.hs, which is a Haskell file containing variables whose value is figured out by the build system. Config.hs contains two sorts of things @@ -140,7 +80,6 @@ Config.hs contains two sorts of things for use when running *in-place* in a build tree (only) - --------------------------------------------- NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented): @@ -171,23 +110,43 @@ stuff. ************************************************************************ -} -initSysTools :: Maybe String -- Maybe TopDir path (without the '-B' prefix) +initLlvmConfig :: String + -> IO LlvmConfig +initLlvmConfig top_dir + = do + targets <- readAndParse "llvm-targets" mkLlvmTarget + passes <- readAndParse "llvm-passes" id + return (targets, passes) + where + readAndParse name builder = + do let llvmConfigFile = top_dir </> name + llvmConfigStr <- readFile llvmConfigFile + case maybeReadFuzzy llvmConfigStr of + Just s -> return (fmap builder <$> s) + Nothing -> pgmError ("Can't parse " ++ show llvmConfigFile) + + mkLlvmTarget :: (String, String, String) -> LlvmTarget + mkLlvmTarget (dl, cpu, attrs) = LlvmTarget dl cpu (words attrs) + + +initSysTools :: String -- TopDir path -> IO Settings -- Set all the mutable variables above, holding -- (a) the system programs -- (b) the package-config file -- (c) the GHC usage message -initSysTools mbMinusB - = do top_dir <- findTopDir mbMinusB - -- see [Note topdir] +initSysTools top_dir + = do -- see Note [topdir: How GHC finds its files] -- NB: top_dir is assumed to be in standard Unix -- format, '/' separated + mtool_dir <- findToolDir top_dir + -- see Note [tooldir: How GHC finds mingw and perl on Windows] - let settingsFile = top_dir </> "settings" - platformConstantsFile = top_dir </> "platformConstants" - installed :: FilePath -> FilePath + let installed :: FilePath -> FilePath installed file = top_dir </> file libexec :: FilePath -> FilePath libexec file = top_dir </> "bin" </> file + settingsFile = installed "settings" + platformConstantsFile = installed "platformConstants" settingsStr <- readFile settingsFile platformConstantsStr <- readFile platformConstantsFile @@ -203,16 +162,9 @@ initSysTools mbMinusB pgmError ("Can't parse " ++ show platformConstantsFile) let getSetting key = case lookup key mySettings of - Just xs -> - return $ case stripPrefix "$topdir" xs of - Just [] -> - top_dir - Just xs'@(c:_) - | isPathSeparator c -> - top_dir ++ xs' - _ -> - xs + Just xs -> return $ expandTopDir top_dir xs Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile) + getToolSetting key = expandToolDir mtool_dir <$> getSetting key getBooleanSetting key = case lookup key mySettings of Just "YES" -> return True Just "NO" -> return False @@ -234,14 +186,15 @@ initSysTools mbMinusB targetHasSubsectionsViaSymbols <- readSetting "target has subsections via symbols" myExtraGccViaCFlags <- getSetting "GCC extra via C opts" -- On Windows, mingw is distributed with GHC, - -- so we look in TopDir/../mingw/bin + -- so we look in TopDir/../mingw/bin, + -- as well as TopDir/../../mingw/bin for hadrian. -- It would perhaps be nice to be able to override this -- with the settings file, but it would be a little fiddly -- to make that possible, so for now you can't. - gcc_prog <- getSetting "C compiler command" + gcc_prog <- getToolSetting "C compiler command" gcc_args_str <- getSetting "C compiler flags" gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie" - cpp_prog <- getSetting "Haskell CPP command" + cpp_prog <- getToolSetting "Haskell CPP command" cpp_args_str <- getSetting "Haskell CPP flags" let unreg_gcc_args = if targetUnregisterised then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"] @@ -259,7 +212,7 @@ initSysTools mbMinusB ldSupportsBuildId <- getBooleanSetting "ld supports build-id" ldSupportsFilelist <- getBooleanSetting "ld supports filelist" ldIsGnuLd <- getBooleanSetting "ld is GNU ld" - perl_path <- getSetting "perl command" + perl_path <- getToolSetting "perl command" let pkgconfig_path = installed "package.conf.d" ghc_usage_msg_path = installed "ghc-usage.txt" @@ -272,12 +225,14 @@ initSysTools mbMinusB -- split is a Perl script split_script = libexec cGHC_SPLIT_PGM - windres_path <- getSetting "windres command" - libtool_path <- getSetting "libtool command" + windres_path <- getToolSetting "windres command" + libtool_path <- getToolSetting "libtool command" + ar_path <- getToolSetting "ar command" + ranlib_path <- getToolSetting "ranlib command" tmpdir <- getTemporaryDirectory - touch_path <- getSetting "touch command" + touch_path <- getToolSetting "touch command" let -- On Win32 we don't want to rely on #!/bin/perl, so we prepend -- a call to Perl to get the invocation of split. @@ -288,7 +243,7 @@ initSysTools mbMinusB (split_prog, split_args) | isWindowsHost = (perl_path, [Option split_script]) | otherwise = (split_script, []) - mkdll_prog <- getSetting "dllwrap command" + mkdll_prog <- getToolSetting "dllwrap command" let mkdll_args = [] -- cpp is derived from gcc on all platforms @@ -306,6 +261,7 @@ initSysTools mbMinusB -- We just assume on command line lc_prog <- getSetting "LLVM llc command" lo_prog <- getSetting "LLVM opt command" + lcc_prog <- getSetting "LLVM clang command" let iserv_prog = libexec "ghc-iserv" @@ -325,6 +281,7 @@ initSysTools mbMinusB sTmpDir = normalise tmpdir, sGhcUsagePath = ghc_usage_msg_path, sGhciUsagePath = ghci_usage_msg_path, + sToolDir = mtool_dir, sTopDir = top_dir, sRawSettings = mySettings, sExtraGccViaCFlags = words myExtraGccViaCFlags, @@ -347,291 +304,27 @@ initSysTools mbMinusB sPgm_T = touch_path, sPgm_windres = windres_path, sPgm_libtool = libtool_path, + sPgm_ar = ar_path, + sPgm_ranlib = ranlib_path, sPgm_lo = (lo_prog,[]), sPgm_lc = (lc_prog,[]), + sPgm_lcc = (lcc_prog,[]), sPgm_i = iserv_prog, sOpt_L = [], sOpt_P = [], + sOpt_P_fingerprint = fingerprint0, sOpt_F = [], sOpt_c = [], sOpt_a = [], sOpt_l = [], sOpt_windres = [], + sOpt_lcc = [], sOpt_lo = [], sOpt_lc = [], sOpt_i = [], sPlatformConstants = platformConstants } --- returns a Unix-format path (relying on getBaseDir to do so too) -findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix). - -> IO String -- TopDir (in Unix format '/' separated) -findTopDir (Just minusb) = return (normalise minusb) -findTopDir Nothing - = do -- Get directory of executable - maybe_exec_dir <- getBaseDir - case maybe_exec_dir of - -- "Just" on Windows, "Nothing" on unix - Nothing -> throwGhcExceptionIO (InstallationError "missing -B<dir> option") - Just dir -> return dir - -{- -************************************************************************ -* * -\subsection{Running an external program} -* * -************************************************************************ --} - -runUnlit :: DynFlags -> [Option] -> IO () -runUnlit dflags args = do - let prog = pgm_L dflags - opts = getOpts dflags opt_L - runSomething dflags "Literate pre-processor" prog - (map Option opts ++ args) - -runCpp :: DynFlags -> [Option] -> IO () -runCpp dflags args = do - let (p,args0) = pgm_P dflags - args1 = map Option (getOpts dflags opt_P) - args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags] - ++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags] - mb_env <- getGccEnv args2 - runSomethingFiltered dflags id "C pre-processor" p - (args0 ++ args1 ++ args2 ++ args) mb_env - -runPp :: DynFlags -> [Option] -> IO () -runPp dflags args = do - let prog = pgm_F dflags - opts = map Option (getOpts dflags opt_F) - runSomething dflags "Haskell pre-processor" prog (args ++ opts) - -runCc :: DynFlags -> [Option] -> IO () -runCc dflags args = do - let (p,args0) = pgm_c dflags - args1 = map Option (getOpts dflags opt_c) - args2 = args0 ++ args1 ++ args - mb_env <- getGccEnv args2 - runSomethingResponseFile dflags cc_filter "C Compiler" p args2 mb_env - where - -- discard some harmless warnings from gcc that we can't turn off - cc_filter = unlines . doFilter . lines - - {- - gcc gives warnings in chunks like so: - In file included from /foo/bar/baz.h:11, - from /foo/bar/baz2.h:22, - from wibble.c:33: - /foo/flibble:14: global register variable ... - /foo/flibble:15: warning: call-clobbered r... - We break it up into its chunks, remove any call-clobbered register - warnings from each chunk, and then delete any chunks that we have - emptied of warnings. - -} - doFilter = unChunkWarnings . filterWarnings . chunkWarnings [] - -- We can't assume that the output will start with an "In file inc..." - -- line, so we start off expecting a list of warnings rather than a - -- location stack. - chunkWarnings :: [String] -- The location stack to use for the next - -- list of warnings - -> [String] -- The remaining lines to look at - -> [([String], [String])] - chunkWarnings loc_stack [] = [(loc_stack, [])] - chunkWarnings loc_stack xs - = case break loc_stack_start xs of - (warnings, lss:xs') -> - case span loc_start_continuation xs' of - (lsc, xs'') -> - (loc_stack, warnings) : chunkWarnings (lss : lsc) xs'' - _ -> [(loc_stack, xs)] - - filterWarnings :: [([String], [String])] -> [([String], [String])] - filterWarnings [] = [] - -- If the warnings are already empty then we are probably doing - -- something wrong, so don't delete anything - filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs - filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of - [] -> filterWarnings zs - ys' -> (xs, ys') : filterWarnings zs - - unChunkWarnings :: [([String], [String])] -> [String] - unChunkWarnings [] = [] - unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs - - loc_stack_start s = "In file included from " `isPrefixOf` s - loc_start_continuation s = " from " `isPrefixOf` s - wantedWarning w - | "warning: call-clobbered register used" `isContainedIn` w = False - | otherwise = True - -isContainedIn :: String -> String -> Bool -xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys) - --- | Run the linker with some arguments and return the output -askLd :: DynFlags -> [Option] -> IO String -askLd dflags args = do - let (p,args0) = pgm_l dflags - args1 = map Option (getOpts dflags opt_l) - args2 = args0 ++ args1 ++ args - mb_env <- getGccEnv args2 - runSomethingWith dflags "gcc" p args2 $ \real_args -> - readCreateProcessWithExitCode' (proc p real_args){ env = mb_env } - --- Similar to System.Process.readCreateProcessWithExitCode, but stderr is --- inherited from the parent process, and output to stderr is not captured. -readCreateProcessWithExitCode' - :: CreateProcess - -> IO (ExitCode, String) -- ^ stdout -readCreateProcessWithExitCode' proc = do - (_, Just outh, _, pid) <- - createProcess proc{ std_out = CreatePipe } - - -- fork off a thread to start consuming the output - output <- hGetContents outh - outMVar <- newEmptyMVar - _ <- forkIO $ evaluate (length output) >> putMVar outMVar () - - -- wait on the output - takeMVar outMVar - hClose outh - - -- wait on the process - ex <- waitForProcess pid - - return (ex, output) - -replaceVar :: (String, String) -> [(String, String)] -> [(String, String)] -replaceVar (var, value) env = - (var, value) : filter (\(var',_) -> var /= var') env - --- | Version of @System.Process.readProcessWithExitCode@ that takes a --- key-value tuple to insert into the environment. -readProcessEnvWithExitCode - :: String -- ^ program path - -> [String] -- ^ program args - -> (String, String) -- ^ addition to the environment - -> IO (ExitCode, String, String) -- ^ (exit_code, stdout, stderr) -readProcessEnvWithExitCode prog args env_update = do - current_env <- getEnvironment - readCreateProcessWithExitCode (proc prog args) { - env = Just (replaceVar env_update current_env) } "" - --- Don't let gcc localize version info string, #8825 -c_locale_env :: (String, String) -c_locale_env = ("LANGUAGE", "C") - --- If the -B<dir> option is set, add <dir> to PATH. This works around --- a bug in gcc on Windows Vista where it can't find its auxiliary --- binaries (see bug #1110). -getGccEnv :: [Option] -> IO (Maybe [(String,String)]) -getGccEnv opts = - if null b_dirs - then return Nothing - else do env <- getEnvironment - return (Just (map mangle_path env)) - where - (b_dirs, _) = partitionWith get_b_opt opts - - get_b_opt (Option ('-':'B':dir)) = Left dir - get_b_opt other = Right other - - mangle_path (path,paths) | map toUpper path == "PATH" - = (path, '\"' : head b_dirs ++ "\";" ++ paths) - mangle_path other = other - -runSplit :: DynFlags -> [Option] -> IO () -runSplit dflags args = do - let (p,args0) = pgm_s dflags - runSomething dflags "Splitter" p (args0++args) - -runAs :: DynFlags -> [Option] -> IO () -runAs dflags args = do - let (p,args0) = pgm_a dflags - args1 = map Option (getOpts dflags opt_a) - args2 = args0 ++ args1 ++ args - mb_env <- getGccEnv args2 - runSomethingFiltered dflags id "Assembler" p args2 mb_env - --- | Run the LLVM Optimiser -runLlvmOpt :: DynFlags -> [Option] -> IO () -runLlvmOpt dflags args = do - let (p,args0) = pgm_lo dflags - args1 = map Option (getOpts dflags opt_lo) - runSomething dflags "LLVM Optimiser" p (args0 ++ args1 ++ args) - --- | Run the LLVM Compiler -runLlvmLlc :: DynFlags -> [Option] -> IO () -runLlvmLlc dflags args = do - let (p,args0) = pgm_lc dflags - args1 = map Option (getOpts dflags opt_lc) - runSomething dflags "LLVM Compiler" p (args0 ++ args1 ++ args) - --- | Run the clang compiler (used as an assembler for the LLVM --- backend on OS X as LLVM doesn't support the OS X system --- assembler) -runClang :: DynFlags -> [Option] -> IO () -runClang dflags args = do - -- we simply assume its available on the PATH - let clang = "clang" - -- be careful what options we call clang with - -- see #5903 and #7617 for bugs caused by this. - (_,args0) = pgm_a dflags - args1 = map Option (getOpts dflags opt_a) - args2 = args0 ++ args1 ++ args - mb_env <- getGccEnv args2 - Exception.catch (do - runSomethingFiltered dflags id "Clang (Assembler)" clang args2 mb_env - ) - (\(err :: SomeException) -> do - errorMsg dflags $ - text ("Error running clang! you need clang installed to use the" ++ - " LLVM backend") $+$ - text "(or GHC tried to execute clang incorrectly)" - throwIO err - ) - --- | Figure out which version of LLVM we are running this session -figureLlvmVersion :: DynFlags -> IO (Maybe (Int, Int)) -figureLlvmVersion dflags = do - let (pgm,opts) = pgm_lc dflags - args = filter notNull (map showOpt opts) - -- we grab the args even though they should be useless just in - -- case the user is using a customised 'llc' that requires some - -- of the options they've specified. llc doesn't care what other - -- options are specified when '-version' is used. - args' = args ++ ["-version"] - ver <- catchIO (do - (pin, pout, perr, _) <- runInteractiveProcess pgm args' - Nothing Nothing - {- > llc -version - LLVM (http://llvm.org/): - LLVM version 3.5.2 - ... - -} - hSetBinaryMode pout False - _ <- hGetLine pout - vline <- dropWhile (not . isDigit) `fmap` hGetLine pout - v <- case span (/= '.') vline of - ("",_) -> fail "no digits!" - (x,y) -> return (read x - , read $ takeWhile isDigit $ drop 1 y) - - hClose pin - hClose pout - hClose perr - return $ Just v - ) - (\err -> do - debugTraceMsg dflags 2 - (text "Error (figuring out LLVM version):" <+> - text (show err)) - errorMsg dflags $ vcat - [ text "Warning:", nest 9 $ - text "Couldn't figure out LLVM version!" $$ - text ("Make sure you have installed LLVM " ++ - llvmVersionStr supportedLlvmVersion) ] - return Nothing) - return ver {- Note [Windows stack usage] @@ -664,340 +357,6 @@ for more information. -} -{- Note [Run-time linker info] - -See also: Trac #5240, Trac #6063, Trac #10110 - -Before 'runLink', we need to be sure to get the relevant information -about the linker we're using at runtime to see if we need any extra -options. For example, GNU ld requires '--reduce-memory-overheads' and -'--hash-size=31' in order to use reasonable amounts of memory (see -trac #5240.) But this isn't supported in GNU gold. - -Generally, the linker changing from what was detected at ./configure -time has always been possible using -pgml, but on Linux it can happen -'transparently' by installing packages like binutils-gold, which -change what /usr/bin/ld actually points to. - -Clang vs GCC notes: - -For gcc, 'gcc -Wl,--version' gives a bunch of output about how to -invoke the linker before the version information string. For 'clang', -the version information for 'ld' is all that's output. For this -reason, we typically need to slurp up all of the standard error output -and look through it. - -Other notes: - -We cache the LinkerInfo inside DynFlags, since clients may link -multiple times. The definition of LinkerInfo is there to avoid a -circular dependency. - --} - -{- Note [ELF needed shared libs] - -Some distributions change the link editor's default handling of -ELF DT_NEEDED tags to include only those shared objects that are -needed to resolve undefined symbols. For Template Haskell we need -the last temporary shared library also if it is not needed for the -currently linked temporary shared library. We specify --no-as-needed -to override the default. This flag exists in GNU ld and GNU gold. - -The flag is only needed on ELF systems. On Windows (PE) and Mac OS X -(Mach-O) the flag is not needed. - --} - -{- Note [Windows static libGCC] - -The GCC versions being upgraded to in #10726 are configured with -dynamic linking of libgcc supported. This results in libgcc being -linked dynamically when a shared library is created. - -This introduces thus an extra dependency on GCC dll that was not -needed before by shared libraries created with GHC. This is a particular -issue on Windows because you get a non-obvious error due to this missing -dependency. This dependent dll is also not commonly on your path. - -For this reason using the static libgcc is preferred as it preserves -the same behaviour that existed before. There are however some very good -reasons to have the shared version as well as described on page 181 of -https://gcc.gnu.org/onlinedocs/gcc-5.2.0/gcc.pdf : - -"There are several situations in which an application should use the - shared ‘libgcc’ instead of the static version. The most common of these - is when the application wishes to throw and catch exceptions across different - shared libraries. In that case, each of the libraries as well as the application - itself should use the shared ‘libgcc’. " - --} - -neededLinkArgs :: LinkerInfo -> [Option] -neededLinkArgs (GnuLD o) = o -neededLinkArgs (GnuGold o) = o -neededLinkArgs (DarwinLD o) = o -neededLinkArgs (SolarisLD o) = o -neededLinkArgs (AixLD o) = o -neededLinkArgs UnknownLD = [] - --- Grab linker info and cache it in DynFlags. -getLinkerInfo :: DynFlags -> IO LinkerInfo -getLinkerInfo dflags = do - info <- readIORef (rtldInfo dflags) - case info of - Just v -> return v - Nothing -> do - v <- getLinkerInfo' dflags - writeIORef (rtldInfo dflags) (Just v) - return v - --- See Note [Run-time linker info]. -getLinkerInfo' :: DynFlags -> IO LinkerInfo -getLinkerInfo' dflags = do - let platform = targetPlatform dflags - os = platformOS platform - (pgm,args0) = pgm_l dflags - args1 = map Option (getOpts dflags opt_l) - args2 = args0 ++ args1 - args3 = filter notNull (map showOpt args2) - - -- Try to grab the info from the process output. - parseLinkerInfo stdo _stde _exitc - | any ("GNU ld" `isPrefixOf`) stdo = - -- GNU ld specifically needs to use less memory. This especially - -- hurts on small object files. Trac #5240. - -- Set DT_NEEDED for all shared libraries. Trac #10110. - -- TODO: Investigate if these help or hurt when using split sections. - return (GnuLD $ map Option ["-Wl,--hash-size=31", - "-Wl,--reduce-memory-overheads", - -- ELF specific flag - -- see Note [ELF needed shared libs] - "-Wl,--no-as-needed"]) - - | any ("GNU gold" `isPrefixOf`) stdo = - -- GNU gold only needs --no-as-needed. Trac #10110. - -- ELF specific flag, see Note [ELF needed shared libs] - return (GnuGold [Option "-Wl,--no-as-needed"]) - - -- Unknown linker. - | otherwise = fail "invalid --version output, or linker is unsupported" - - -- Process the executable call - info <- catchIO (do - case os of - OSSolaris2 -> - -- Solaris uses its own Solaris linker. Even all - -- GNU C are recommended to configure with Solaris - -- linker instead of using GNU binutils linker. Also - -- all GCC distributed with Solaris follows this rule - -- precisely so we assume here, the Solaris linker is - -- used. - return $ SolarisLD [] - OSAIX -> - -- IBM AIX uses its own non-binutils linker as well - return $ AixLD [] - OSDarwin -> - -- Darwin has neither GNU Gold or GNU LD, but a strange linker - -- that doesn't support --version. We can just assume that's - -- what we're using. - return $ DarwinLD [] - OSiOS -> - -- Ditto for iOS - return $ DarwinLD [] - OSMinGW32 -> - -- GHC doesn't support anything but GNU ld on Windows anyway. - -- Process creation is also fairly expensive on win32, so - -- we short-circuit here. - return $ GnuLD $ map Option - [ -- Reduce ld memory usage - "-Wl,--hash-size=31" - , "-Wl,--reduce-memory-overheads" - -- Emit gcc stack checks - -- Note [Windows stack usage] - , "-fstack-check" - -- Force static linking of libGCC - -- Note [Windows static libGCC] - , "-static-libgcc" ] - _ -> do - -- In practice, we use the compiler as the linker here. Pass - -- -Wl,--version to get linker version info. - (exitc, stdo, stde) <- readProcessEnvWithExitCode pgm - (["-Wl,--version"] ++ args3) - c_locale_env - -- Split the output by lines to make certain kinds - -- of processing easier. In particular, 'clang' and 'gcc' - -- have slightly different outputs for '-Wl,--version', but - -- it's still easy to figure out. - parseLinkerInfo (lines stdo) (lines stde) exitc - ) - (\err -> do - debugTraceMsg dflags 2 - (text "Error (figuring out linker information):" <+> - text (show err)) - errorMsg dflags $ hang (text "Warning:") 9 $ - text "Couldn't figure out linker information!" $$ - text "Make sure you're using GNU ld, GNU gold" <+> - text "or the built in OS X linker, etc." - return UnknownLD) - return info - --- Grab compiler info and cache it in DynFlags. -getCompilerInfo :: DynFlags -> IO CompilerInfo -getCompilerInfo dflags = do - info <- readIORef (rtccInfo dflags) - case info of - Just v -> return v - Nothing -> do - v <- getCompilerInfo' dflags - writeIORef (rtccInfo dflags) (Just v) - return v - --- See Note [Run-time linker info]. -getCompilerInfo' :: DynFlags -> IO CompilerInfo -getCompilerInfo' dflags = do - let (pgm,_) = pgm_c dflags - -- Try to grab the info from the process output. - parseCompilerInfo _stdo stde _exitc - -- Regular GCC - | any ("gcc version" `isInfixOf`) stde = - return GCC - -- Regular clang - | any ("clang version" `isInfixOf`) stde = - return Clang - -- XCode 5.1 clang - | any ("Apple LLVM version 5.1" `isPrefixOf`) stde = - return AppleClang51 - -- XCode 5 clang - | any ("Apple LLVM version" `isPrefixOf`) stde = - return AppleClang - -- XCode 4.1 clang - | any ("Apple clang version" `isPrefixOf`) stde = - return AppleClang - -- Unknown linker. - | otherwise = fail "invalid -v output, or compiler is unsupported" - - -- Process the executable call - info <- catchIO (do - (exitc, stdo, stde) <- - readProcessEnvWithExitCode pgm ["-v"] c_locale_env - -- Split the output by lines to make certain kinds - -- of processing easier. - parseCompilerInfo (lines stdo) (lines stde) exitc - ) - (\err -> do - debugTraceMsg dflags 2 - (text "Error (figuring out C compiler information):" <+> - text (show err)) - errorMsg dflags $ hang (text "Warning:") 9 $ - text "Couldn't figure out C compiler information!" $$ - text "Make sure you're using GNU gcc, or clang" - return UnknownCC) - return info - -runLink :: DynFlags -> [Option] -> IO () -runLink dflags args = do - -- See Note [Run-time linker info] - linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags - let (p,args0) = pgm_l dflags - args1 = map Option (getOpts dflags opt_l) - args2 = args0 ++ linkargs ++ args1 ++ args - mb_env <- getGccEnv args2 - runSomethingResponseFile dflags ld_filter "Linker" p args2 mb_env - where - ld_filter = case (platformOS (targetPlatform dflags)) of - OSSolaris2 -> sunos_ld_filter - _ -> id -{- - SunOS/Solaris ld emits harmless warning messages about unresolved - symbols in case of compiling into shared library when we do not - link against all the required libs. That is the case of GHC which - does not link against RTS library explicitly in order to be able to - choose the library later based on binary application linking - parameters. The warnings look like: - -Undefined first referenced - symbol in file -stg_ap_n_fast ./T2386_Lib.o -stg_upd_frame_info ./T2386_Lib.o -templatezmhaskell_LanguageziHaskellziTHziLib_litE_closure ./T2386_Lib.o -templatezmhaskell_LanguageziHaskellziTHziLib_appE_closure ./T2386_Lib.o -templatezmhaskell_LanguageziHaskellziTHziLib_conE_closure ./T2386_Lib.o -templatezmhaskell_LanguageziHaskellziTHziSyntax_mkNameGzud_closure ./T2386_Lib.o -newCAF ./T2386_Lib.o -stg_bh_upd_frame_info ./T2386_Lib.o -stg_ap_ppp_fast ./T2386_Lib.o -templatezmhaskell_LanguageziHaskellziTHziLib_stringL_closure ./T2386_Lib.o -stg_ap_p_fast ./T2386_Lib.o -stg_ap_pp_fast ./T2386_Lib.o -ld: warning: symbol referencing errors - - this is actually coming from T2386 testcase. The emitting of those - warnings is also a reason why so many TH testcases fail on Solaris. - - Following filter code is SunOS/Solaris linker specific and should - filter out only linker warnings. Please note that the logic is a - little bit more complex due to the simple reason that we need to preserve - any other linker emitted messages. If there are any. Simply speaking - if we see "Undefined" and later "ld: warning:..." then we omit all - text between (including) the marks. Otherwise we copy the whole output. --} - sunos_ld_filter :: String -> String - sunos_ld_filter = unlines . sunos_ld_filter' . lines - sunos_ld_filter' x = if (undefined_found x && ld_warning_found x) - then (ld_prefix x) ++ (ld_postfix x) - else x - breakStartsWith x y = break (isPrefixOf x) y - ld_prefix = fst . breakStartsWith "Undefined" - undefined_found = not . null . snd . breakStartsWith "Undefined" - ld_warn_break = breakStartsWith "ld: warning: symbol referencing errors" - ld_postfix = tail . snd . ld_warn_break - ld_warning_found = not . null . snd . ld_warn_break - - -runLibtool :: DynFlags -> [Option] -> IO () -runLibtool dflags args = do - linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags - let args1 = map Option (getOpts dflags opt_l) - args2 = [Option "-static"] ++ args1 ++ args ++ linkargs - libtool = pgm_libtool dflags - mb_env <- getGccEnv args2 - runSomethingFiltered dflags id "Linker" libtool args2 mb_env - -runMkDLL :: DynFlags -> [Option] -> IO () -runMkDLL dflags args = do - let (p,args0) = pgm_dll dflags - args1 = args0 ++ args - mb_env <- getGccEnv (args0++args) - runSomethingFiltered dflags id "Make DLL" p args1 mb_env - -runWindres :: DynFlags -> [Option] -> IO () -runWindres dflags args = do - let (gcc, gcc_args) = pgm_c dflags - windres = pgm_windres dflags - opts = map Option (getOpts dflags opt_windres) - quote x = "\"" ++ x ++ "\"" - args' = -- If windres.exe and gcc.exe are in a directory containing - -- spaces then windres fails to run gcc. We therefore need - -- to tell it what command to use... - Option ("--preprocessor=" ++ - unwords (map quote (gcc : - map showOpt gcc_args ++ - map showOpt opts ++ - ["-E", "-xc", "-DRC_INVOKED"]))) - -- ...but if we do that then if windres calls popen then - -- it can't understand the quoting, so we have to use - -- --use-temp-file so that it interprets it correctly. - -- See #1828. - : Option "--use-temp-file" - : args - mb_env <- getGccEnv gcc_args - runSomethingFiltered dflags id "Windres" windres args' mb_env - -touch :: DynFlags -> String -> String -> IO () -touch dflags purpose arg = - runSomething dflags purpose (pgm_T dflags) [FileOption "" arg] - copy :: DynFlags -> String -> FilePath -> FilePath -> IO () copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to @@ -1022,240 +381,6 @@ copyWithHeader dflags purpose maybe_header from to = do hPutStr h str hSetBinaryMode h True ------------------------------------------------------------------------------ --- Running an external program - -runSomething :: DynFlags - -> String -- For -v message - -> String -- Command name (possibly a full path) - -- assumed already dos-ified - -> [Option] -- Arguments - -- runSomething will dos-ify them - -> IO () - -runSomething dflags phase_name pgm args = - runSomethingFiltered dflags id phase_name pgm args Nothing - --- | Run a command, placing the arguments in an external response file. --- --- This command is used in order to avoid overlong command line arguments on --- Windows. The command line arguments are first written to an external, --- temporary response file, and then passed to the linker via @filepath. --- response files for passing them in. See: --- --- https://gcc.gnu.org/wiki/Response_Files --- https://ghc.haskell.org/trac/ghc/ticket/10777 -runSomethingResponseFile - :: DynFlags -> (String->String) -> String -> String -> [Option] - -> Maybe [(String,String)] -> IO () - -runSomethingResponseFile dflags filter_fn phase_name pgm args mb_env = - runSomethingWith dflags phase_name pgm args $ \real_args -> do - fp <- getResponseFile real_args - let args = ['@':fp] - r <- builderMainLoop dflags filter_fn pgm args mb_env - return (r,()) - where - getResponseFile args = do - fp <- newTempName dflags TFL_CurrentModule "rsp" - withFile fp WriteMode $ \h -> do -#if defined(mingw32_HOST_OS) - hSetEncoding h latin1 -#else - hSetEncoding h utf8 -#endif - hPutStr h $ unlines $ map escape args - return fp - - -- Note: Response files have backslash-escaping, double quoting, and are - -- whitespace separated (some implementations use newline, others any - -- whitespace character). Therefore, escape any backslashes, newlines, and - -- double quotes in the argument, and surround the content with double - -- quotes. - -- - -- Another possibility that could be considered would be to convert - -- backslashes in the argument to forward slashes. This would generally do - -- the right thing, since backslashes in general only appear in arguments - -- as part of file paths on Windows, and the forward slash is accepted for - -- those. However, escaping is more reliable, in case somehow a backslash - -- appears in a non-file. - escape x = concat - [ "\"" - , concatMap - (\c -> - case c of - '\\' -> "\\\\" - '\n' -> "\\n" - '\"' -> "\\\"" - _ -> [c]) - x - , "\"" - ] - -runSomethingFiltered - :: DynFlags -> (String->String) -> String -> String -> [Option] - -> Maybe [(String,String)] -> IO () - -runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do - runSomethingWith dflags phase_name pgm args $ \real_args -> do - r <- builderMainLoop dflags filter_fn pgm real_args mb_env - return (r,()) - -runSomethingWith - :: DynFlags -> String -> String -> [Option] - -> ([String] -> IO (ExitCode, a)) - -> IO a - -runSomethingWith dflags phase_name pgm args io = do - let real_args = filter notNull (map showOpt args) - cmdLine = showCommandForUser pgm real_args - traceCmd dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args - -handleProc :: String -> String -> IO (ExitCode, r) -> IO r -handleProc pgm phase_name proc = do - (rc, r) <- proc `catchIO` handler - case rc of - ExitSuccess{} -> return r - ExitFailure n -> throwGhcExceptionIO ( - ProgramError ("`" ++ takeFileName pgm ++ "'" ++ - " failed in phase `" ++ phase_name ++ "'." ++ - " (Exit code: " ++ show n ++ ")")) - where - handler err = - if IO.isDoesNotExistError err - then does_not_exist - else throwGhcExceptionIO (ProgramError $ show err) - - does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm)) - - -builderMainLoop :: DynFlags -> (String -> String) -> FilePath - -> [String] -> Maybe [(String, String)] - -> IO ExitCode -builderMainLoop dflags filter_fn pgm real_args mb_env = do - chan <- newChan - - -- We use a mask here rather than a bracket because we want - -- to distinguish between cleaning up with and without an - -- exception. This is to avoid calling terminateProcess - -- unless an exception was raised. - let safely inner = mask $ \restore -> do - -- acquire - (hStdIn, hStdOut, hStdErr, hProcess) <- restore $ - runInteractiveProcess pgm real_args Nothing mb_env - let cleanup_handles = do - hClose hStdIn - hClose hStdOut - hClose hStdErr - r <- try $ restore $ do - hSetBuffering hStdOut LineBuffering - hSetBuffering hStdErr LineBuffering - let make_reader_proc h = forkIO $ readerProc chan h filter_fn - bracketOnError (make_reader_proc hStdOut) killThread $ \_ -> - bracketOnError (make_reader_proc hStdErr) killThread $ \_ -> - inner hProcess - case r of - -- onException - Left (SomeException e) -> do - terminateProcess hProcess - cleanup_handles - throw e - -- cleanup when there was no exception - Right s -> do - cleanup_handles - return s - safely $ \h -> do - -- we don't want to finish until 2 streams have been complete - -- (stdout and stderr) - log_loop chan (2 :: Integer) - -- after that, we wait for the process to finish and return the exit code. - waitForProcess h - where - -- t starts at the number of streams we're listening to (2) decrements each - -- time a reader process sends EOF. We are safe from looping forever if a - -- reader thread dies, because they send EOF in a finally handler. - log_loop _ 0 = return () - log_loop chan t = do - msg <- readChan chan - case msg of - BuildMsg msg -> do - putLogMsg dflags NoReason SevInfo noSrcSpan - (defaultUserStyle dflags) msg - log_loop chan t - BuildError loc msg -> do - putLogMsg dflags NoReason SevError (mkSrcSpan loc loc) - (defaultUserStyle dflags) msg - log_loop chan t - EOF -> - log_loop chan (t-1) - -readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO () -readerProc chan hdl filter_fn = - (do str <- hGetContents hdl - loop (linesPlatform (filter_fn str)) Nothing) - `finally` - writeChan chan EOF - -- ToDo: check errors more carefully - -- ToDo: in the future, the filter should be implemented as - -- a stream transformer. - where - loop [] Nothing = return () - loop [] (Just err) = writeChan chan err - loop (l:ls) in_err = - case in_err of - Just err@(BuildError srcLoc msg) - | leading_whitespace l -> do - loop ls (Just (BuildError srcLoc (msg $$ text l))) - | otherwise -> do - writeChan chan err - checkError l ls - Nothing -> do - checkError l ls - _ -> panic "readerProc/loop" - - checkError l ls - = case parseError l of - Nothing -> do - writeChan chan (BuildMsg (text l)) - loop ls Nothing - Just (file, lineNum, colNum, msg) -> do - let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum - loop ls (Just (BuildError srcLoc (text msg))) - - leading_whitespace [] = False - leading_whitespace (x:_) = isSpace x - -parseError :: String -> Maybe (String, Int, Int, String) -parseError s0 = case breakColon s0 of - Just (filename, s1) -> - case breakIntColon s1 of - Just (lineNum, s2) -> - case breakIntColon s2 of - Just (columnNum, s3) -> - Just (filename, lineNum, columnNum, s3) - Nothing -> - Just (filename, lineNum, 0, s2) - Nothing -> Nothing - Nothing -> Nothing - -breakColon :: String -> Maybe (String, String) -breakColon xs = case break (':' ==) xs of - (ys, _:zs) -> Just (ys, zs) - _ -> Nothing - -breakIntColon :: String -> Maybe (Int, String) -breakIntColon xs = case break (':' ==) xs of - (ys, _:zs) - | not (null ys) && all isAscii ys && all isDigit ys -> - Just (read ys, zs) - _ -> Nothing - -data BuildMessage - = BuildMsg !SDoc - | BuildError !SrcLoc !SDoc - | EOF - - {- ************************************************************************ * * @@ -1264,117 +389,6 @@ data BuildMessage ************************************************************************ -} ------------------------------------------------------------------------------ --- Define getBaseDir :: IO (Maybe String) - -getBaseDir :: IO (Maybe String) -#if defined(mingw32_HOST_OS) --- Assuming we are running ghc, accessed by path $(stuff)/<foo>/ghc.exe, --- return the path $(stuff)/lib. -getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32. - where - try_size size = allocaArray (fromIntegral size) $ \buf -> do - ret <- c_GetModuleFileName nullPtr buf size - case ret of - 0 -> return Nothing - _ | ret < size -> do - path <- peekCWString buf - real <- getFinalPath path -- try to resolve symlinks paths - let libdir = (rootDir . sanitize . maybe path id) real - exists <- doesDirectoryExist libdir - if exists - then return $ Just libdir - else fail path - | otherwise -> try_size (size * 2) - - -- getFinalPath returns paths in full raw form. - -- Unfortunately GHC isn't set up to handle these - -- So if the call succeeded, we need to drop the - -- \\?\ prefix. - sanitize s = if "\\\\?\\" `isPrefixOf` s - then drop 4 s - else s - - rootDir s = case splitFileName $ normalise s of - (d, ghc_exe) - | lower ghc_exe `elem` ["ghc.exe", - "ghc-stage1.exe", - "ghc-stage2.exe", - "ghc-stage3.exe"] -> - case splitFileName $ takeDirectory d of - -- ghc is in $topdir/bin/ghc.exe - (d', _) -> takeDirectory d' </> "lib" - _ -> fail s - - fail s = panic ("can't decompose ghc.exe path: " ++ show s) - lower = map toLower - -foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW" - c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 - --- Attempt to resolve symlinks in order to find the actual location GHC --- is located at. See Trac #11759. -getFinalPath :: FilePath -> IO (Maybe FilePath) -getFinalPath name = do - dllHwnd <- failIfNull "LoadLibrary" $ loadLibrary "kernel32.dll" - -- Note: The API GetFinalPathNameByHandleW is only available starting from Windows Vista. - -- This means that we can't bind directly to it since it may be missing. - -- Instead try to find it's address at runtime and if we don't succeed consider the - -- function failed. - addr_m <- (fmap Just $ failIfNull "getProcAddress" $ getProcAddress dllHwnd "GetFinalPathNameByHandleW") - `catch` (\(_ :: SomeException) -> return Nothing) - case addr_m of - Nothing -> return Nothing - Just addr -> do handle <- failIf (==iNVALID_HANDLE_VALUE) "CreateFile" - $ createFile name - gENERIC_READ - fILE_SHARE_READ - Nothing - oPEN_EXISTING - (fILE_ATTRIBUTE_NORMAL .|. fILE_FLAG_BACKUP_SEMANTICS) - Nothing - let fnPtr = makeGetFinalPathNameByHandle $ castPtrToFunPtr addr - path <- Win32.try "GetFinalPathName" - (\buf len -> fnPtr handle buf len 0) 512 - `finally` closeHandle handle - return $ Just path - -type GetFinalPath = HANDLE -> LPTSTR -> DWORD -> DWORD -> IO DWORD - -foreign import WINDOWS_CCONV unsafe "dynamic" - makeGetFinalPathNameByHandle :: FunPtr GetFinalPath -> GetFinalPath -#else -getBaseDir = return Nothing -#endif - - --- Divvy up text stream into lines, taking platform dependent --- line termination into account. -linesPlatform :: String -> [String] -#if !defined(mingw32_HOST_OS) -linesPlatform ls = lines ls -#else -linesPlatform "" = [] -linesPlatform xs = - case lineBreak xs of - (as,xs1) -> as : linesPlatform xs1 - where - lineBreak "" = ("","") - lineBreak ('\r':'\n':xs) = ([],xs) - lineBreak ('\n':xs) = ([],xs) - lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs) - -#endif - -{- -Note [No PIE eating while linking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As of 2016 some Linux distributions (e.g. Debian) have started enabling -pie by -default in their gcc builds. This is incompatible with -r as it implies that we -are producing an executable. Consequently, we must manually pass -no-pie to gcc -when joining object files or linking dynamic libraries. See #12759. --} - linkDynLib :: DynFlags -> [String] -> [InstalledUnitId] -> IO () linkDynLib dflags0 o_files dep_packages = do @@ -1465,7 +479,7 @@ linkDynLib dflags0 o_files dep_packages ++ pkg_lib_path_opts ++ pkg_link_opts )) - _ | os `elem` [OSDarwin, OSiOS] -> do + _ | os == OSDarwin -> do ------------------------------------------------------------------- -- Making a darwin dylib ------------------------------------------------------------------- @@ -1524,6 +538,7 @@ linkDynLib dflags0 o_files dep_packages ++ map Option pkg_lib_path_opts ++ map Option pkg_link_opts ++ map Option pkg_framework_opts + ++ [ Option "-Wl,-dead_strip_dylibs" ] ) _ -> do ------------------------------------------------------------------- @@ -1531,19 +546,19 @@ linkDynLib dflags0 o_files dep_packages ------------------------------------------------------------------- let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } + unregisterised = platformUnregisterised (targetPlatform dflags) let bsymbolicFlag = -- we need symbolic linking to resolve - -- non-PIC intra-package-relocations - ["-Wl,-Bsymbolic"] + -- non-PIC intra-package-relocations for + -- performance (where symbolic linking works) + -- See Note [-Bsymbolic assumptions by GHC] + ["-Wl,-Bsymbolic" | not unregisterised] runLink dflags ( map Option verbFlags + ++ libmLinkOpts ++ [ Option "-o" , FileOption "" output_fn ] - -- See Note [No PIE eating when linking] - ++ (if sGccSupportsNoPie (settings dflags) - then [Option "-no-pie"] - else []) ++ map Option o_files ++ [ Option "-shared" ] ++ map Option bsymbolicFlag @@ -1556,6 +571,16 @@ linkDynLib dflags0 o_files dep_packages ++ map Option pkg_link_opts ) +-- | Some platforms require that we explicitly link against @libm@ if any +-- math-y things are used (which we assume to include all programs). See #14022. +libmLinkOpts :: [Option] +libmLinkOpts = +#if defined(HAVE_LIBM) + [Option "-lm"] +#else + [] +#endif + getPkgFrameworkOpts :: DynFlags -> Platform -> [InstalledUnitId] -> IO [String] getPkgFrameworkOpts dflags platform dep_packages | platformUsesFrameworks platform = do @@ -1583,3 +608,27 @@ getFrameworkOpts dflags platform -- reverse because they're added in reverse order from the cmd line: framework_opts = concat [ ["-framework", fw] | fw <- reverse frameworks ] + +{- +Note [-Bsymbolic assumptions by GHC] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +GHC has a few assumptions about interaction of relocations in NCG and linker: + +1. -Bsymbolic resolves internal references when the shared library is linked, + which is important for performance. +2. When there is a reference to data in a shared library from the main program, + the runtime linker relocates the data object into the main program using an + R_*_COPY relocation. +3. If we used -Bsymbolic, then this results in multiple copies of the data + object, because some references have already been resolved to point to the + original instance. This is bad! + +We work around [3.] for native compiled code by avoiding the generation of +R_*_COPY relocations. + +Unregisterised compiler can't evade R_*_COPY relocations easily thus we disable +-Bsymbolic linking there. + +See related Trac tickets: #4210, #15338 +-} diff --git a/compiler/main/SysTools/BaseDir.hs b/compiler/main/SysTools/BaseDir.hs new file mode 100644 index 0000000000..f858c8ffad --- /dev/null +++ b/compiler/main/SysTools/BaseDir.hs @@ -0,0 +1,281 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- +----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2001-2017 +-- +-- Finding the compiler's base directory. +-- +----------------------------------------------------------------------------- +-} + +module SysTools.BaseDir + ( expandTopDir, expandToolDir + , findTopDir, findToolDir + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Panic + +import System.Environment (lookupEnv) +import System.FilePath +import Data.List + +-- POSIX +#if defined(darwin_HOST_OS) || defined(linux_HOST_OS) +import System.Environment (getExecutablePath) +#endif + +-- Windows +#if defined(mingw32_HOST_OS) +# if MIN_VERSION_Win32(2,5,0) +# if !MIN_VERSION_base(4,11,0) +import qualified System.Win32.Types as Win32 +# endif +# else +import qualified System.Win32.Info as Win32 +# endif +# if MIN_VERSION_base(4,11,0) +import System.Environment (getExecutablePath) +import System.Directory (doesDirectoryExist) +# else +import Data.Char +import Exception +import Foreign +import Foreign.C.String +import System.Directory +import System.Win32.Types (DWORD, LPTSTR, HANDLE) +import System.Win32.Types (failIfNull, failIf, iNVALID_HANDLE_VALUE) +import System.Win32.File (createFile,closeHandle, gENERIC_READ, fILE_SHARE_READ, oPEN_EXISTING, fILE_ATTRIBUTE_NORMAL, fILE_FLAG_BACKUP_SEMANTICS ) +import System.Win32.DLL (loadLibrary, getProcAddress) +# endif +#endif + +#if defined(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 + +{- +Note [topdir: How GHC finds its files] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +GHC needs various support files (library packages, RTS etc), plus +various auxiliary programs (cp, gcc, etc). It starts by finding topdir, +the root of GHC's support files + +On Unix: + - ghc always has a shell wrapper that passes a -B<dir> option + +On Windows: + - ghc never has a shell wrapper. + - we can find the location of the ghc binary, which is + $topdir/<foo>/<something>.exe + where <something> may be "ghc", "ghc-stage2", or similar + - we strip off the "<foo>/<something>.exe" to leave $topdir. + +from topdir we can find package.conf, ghc-asm, etc. + + +Note [tooldir: How GHC finds mingw and perl on Windows] + +GHC has some custom logic on Windows for finding the mingw +toolchain and perl. Depending on whether GHC is built +with the make build system or Hadrian, and on whether we're +running a bindist, we might find the mingw toolchain and perl +either under $topdir/../{mingw, perl}/ or +$topdir/../../{mingw, perl}/. + +-} + +-- | Expand occurrences of the @$topdir@ interpolation in a string. +expandTopDir :: FilePath -> String -> String +expandTopDir = expandPathVar "topdir" + +-- | Expand occurrences of the @$tooldir@ interpolation in a string +-- on Windows, leave the string untouched otherwise. +expandToolDir :: Maybe FilePath -> String -> String +#if defined(mingw32_HOST_OS) +expandToolDir (Just tool_dir) s = expandPathVar "tooldir" tool_dir s +expandToolDir Nothing _ = panic "Could not determine $tooldir" +#else +expandToolDir _ s = s +#endif + +-- | @expandPathVar var value str@ +-- +-- replaces occurences of variable @$var@ with @value@ in str. +expandPathVar :: String -> FilePath -> String -> String +expandPathVar var value str + | Just str' <- stripPrefix ('$':var) str + , null str' || isPathSeparator (head str') + = value ++ expandPathVar var value str' +expandPathVar var value (x:xs) = x : expandPathVar var value xs +expandPathVar _ _ [] = [] + +-- | Returns a Unix-format path pointing to TopDir. +findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix). + -> IO String -- TopDir (in Unix format '/' separated) +findTopDir (Just minusb) = return (normalise minusb) +findTopDir Nothing + = do -- The _GHC_TOP_DIR environment variable can be used to specify + -- the top dir when the -B argument is not specified. It is not + -- intended for use by users, it was added specifically for the + -- purpose of running GHC within GHCi. + maybe_env_top_dir <- lookupEnv "_GHC_TOP_DIR" + case maybe_env_top_dir of + Just env_top_dir -> return env_top_dir + Nothing -> do + -- Get directory of executable + maybe_exec_dir <- getBaseDir + case maybe_exec_dir of + -- "Just" on Windows, "Nothing" on unix + Nothing -> throwGhcExceptionIO $ + InstallationError "missing -B<dir> option" + Just dir -> return dir + +getBaseDir :: IO (Maybe String) + +#if defined(mingw32_HOST_OS) + +-- locate the "base dir" when given the path +-- to the real ghc executable (as opposed to symlink) +-- that is running this function. +rootDir :: FilePath -> FilePath +rootDir = takeDirectory . takeDirectory . normalise + +#if MIN_VERSION_base(4,11,0) +getBaseDir = Just . (\p -> p </> "lib") . rootDir <$> getExecutablePath +#else +-- Assuming we are running ghc, accessed by path $(stuff)/<foo>/ghc.exe, +-- return the path $(stuff)/lib. +getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32. + where + try_size size = allocaArray (fromIntegral size) $ \buf -> do + ret <- c_GetModuleFileName nullPtr buf size + case ret of + 0 -> return Nothing + _ | ret < size -> do + path <- peekCWString buf + real <- getFinalPath path -- try to resolve symlinks paths + let libdir = (buildLibDir . sanitize . maybe path id) real + exists <- doesDirectoryExist libdir + if exists + then return $ Just libdir + else fail path + | otherwise -> try_size (size * 2) + + -- getFinalPath returns paths in full raw form. + -- Unfortunately GHC isn't set up to handle these + -- So if the call succeeded, we need to drop the + -- \\?\ prefix. + sanitize s = if "\\\\?\\" `isPrefixOf` s + then drop 4 s + else s + + buildLibDir :: FilePath -> FilePath + buildLibDir s = + (takeDirectory . takeDirectory . normalise $ s) </> "lib" + + fail s = panic ("can't decompose ghc.exe path: " ++ show s) + +foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW" + c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 + +-- Attempt to resolve symlinks in order to find the actual location GHC +-- is located at. See Trac #11759. +getFinalPath :: FilePath -> IO (Maybe FilePath) +getFinalPath name = do + dllHwnd <- failIfNull "LoadLibrary" $ loadLibrary "kernel32.dll" + -- Note: The API GetFinalPathNameByHandleW is only available starting from Windows Vista. + -- This means that we can't bind directly to it since it may be missing. + -- Instead try to find it's address at runtime and if we don't succeed consider the + -- function failed. + addr_m <- (fmap Just $ failIfNull "getProcAddress" $ getProcAddress dllHwnd "GetFinalPathNameByHandleW") + `catch` (\(_ :: SomeException) -> return Nothing) + case addr_m of + Nothing -> return Nothing + Just addr -> do handle <- failIf (==iNVALID_HANDLE_VALUE) "CreateFile" + $ createFile name + gENERIC_READ + fILE_SHARE_READ + Nothing + oPEN_EXISTING + (fILE_ATTRIBUTE_NORMAL .|. fILE_FLAG_BACKUP_SEMANTICS) + Nothing + let fnPtr = makeGetFinalPathNameByHandle $ castPtrToFunPtr addr + -- First try to resolve the path to get the actual path + -- of any symlinks or other file system redirections that + -- may be in place. However this function can fail, and in + -- the event it does fail, we need to try using the + -- original path and see if we can decompose that. + -- If the call fails Win32.try will raise an exception + -- that needs to be caught. See #14159 + path <- (Win32.try "GetFinalPathName" + (\buf len -> fnPtr handle buf len 0) 512 + `finally` closeHandle handle) + `catch` + (\(_ :: IOException) -> return name) + return $ Just path + +type GetFinalPath = HANDLE -> LPTSTR -> DWORD -> DWORD -> IO DWORD + +foreign import WINDOWS_CCONV unsafe "dynamic" + makeGetFinalPathNameByHandle :: FunPtr GetFinalPath -> GetFinalPath +#endif +#elif defined(darwin_HOST_OS) || defined(linux_HOST_OS) +-- on unix, this is a bit more confusing. +-- The layout right now is something like +-- +-- /bin/ghc-X.Y.Z <- wrapper script (1) +-- /bin/ghc <- symlink to wrapper script (2) +-- /lib/ghc-X.Y.Z/bin/ghc <- ghc executable (3) +-- /lib/ghc-X.Y.Z <- $topdir (4) +-- +-- As such, we first need to find the absolute location to the +-- binary. +-- +-- getExecutablePath will return (3). One takeDirectory will +-- give use /lib/ghc-X.Y.Z/bin, and another will give us (4). +-- +-- This of course only works due to the current layout. If +-- the layout is changed, such that we have ghc-X.Y.Z/{bin,lib} +-- this would need to be changed accordingly. +-- +getBaseDir = Just . (\p -> p </> "lib") . takeDirectory . takeDirectory <$> getExecutablePath +#else +getBaseDir = return Nothing +#endif + +-- See Note [tooldir: How GHC finds mingw and perl on Windows] +-- Returns @Nothing@ when not on Windows. +-- When called on Windows, it either throws an error when the +-- tooldir can't be located, or returns @Just tooldirpath@. +findToolDir + :: FilePath -- ^ topdir + -> IO (Maybe FilePath) +#if defined(mingw32_HOST_OS) +findToolDir top_dir = go 0 (top_dir </> "..") + where maxDepth = 3 + go :: Int -> FilePath -> IO (Maybe FilePath) + go k path + | k == maxDepth = throwGhcExceptionIO $ + InstallationError "could not detect mingw toolchain" + | otherwise = do + oneLevel <- doesDirectoryExist (path </> "mingw") + if oneLevel + then return (Just path) + else go (k+1) (path </> "..") +#else +findToolDir _ = return Nothing +#endif diff --git a/compiler/main/SysTools/ExtraObj.hs b/compiler/main/SysTools/ExtraObj.hs new file mode 100644 index 0000000000..bbcb1b6a7a --- /dev/null +++ b/compiler/main/SysTools/ExtraObj.hs @@ -0,0 +1,239 @@ +----------------------------------------------------------------------------- +-- +-- GHC Extra object linking code +-- +-- (c) The GHC Team 2017 +-- +----------------------------------------------------------------------------- + +module SysTools.ExtraObj ( + mkExtraObj, mkExtraObjToLinkIntoBinary, mkNoteObjsToLinkIntoBinary, + checkLinkInfo, getLinkInfo, getCompilerInfo, + ghcLinkInfoSectionName, ghcLinkInfoNoteName, platformSupportsSavingLinkOpts, + haveRtsOptsFlags +) where + +import AsmUtils +import ErrUtils +import DynFlags +import Packages +import Platform +import Outputable +import SrcLoc ( noSrcSpan ) +import Module +import Elf +import Util +import GhcPrelude + +import Control.Monad +import Data.Maybe + +import Control.Monad.IO.Class + +import FileCleanup +import SysTools.Tasks +import SysTools.Info + +mkExtraObj :: DynFlags -> Suffix -> String -> IO FilePath +mkExtraObj dflags extn xs + = do cFile <- newTempName dflags TFL_CurrentModule extn + oFile <- newTempName dflags TFL_GhcSession "o" + writeFile cFile xs + ccInfo <- liftIO $ getCompilerInfo dflags + runCc dflags + ([Option "-c", + FileOption "" cFile, + Option "-o", + FileOption "" oFile] + ++ if extn /= "s" + then cOpts + else asmOpts ccInfo) + return oFile + where + -- Pass a different set of options to the C compiler depending one whether + -- we're compiling C or assembler. When compiling C, we pass the usual + -- set of include directories and PIC flags. + cOpts = map Option (picCCOpts dflags) + ++ map (FileOption "-I") + (includeDirs $ getPackageDetails dflags rtsUnitId) + + -- When compiling assembler code, we drop the usual C options, and if the + -- compiler is Clang, we add an extra argument to tell Clang to ignore + -- unused command line options. See trac #11684. + asmOpts ccInfo = + if any (ccInfo ==) [Clang, AppleClang, AppleClang51] + then [Option "-Qunused-arguments"] + else [] + +-- When linking a binary, we need to create a C main() function that +-- starts everything off. This used to be compiled statically as part +-- of the RTS, but that made it hard to change the -rtsopts setting, +-- so now we generate and compile a main() stub as part of every +-- binary and pass the -rtsopts setting directly to the RTS (#5373) +-- +-- On Windows, when making a shared library we also may need a DllMain. +-- +mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath +mkExtraObjToLinkIntoBinary dflags = do + when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ do + putLogMsg dflags NoReason SevInfo noSrcSpan + (defaultUserStyle dflags) + (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.") + + mkExtraObj dflags "c" (showSDoc dflags main) + where + main + | gopt Opt_NoHsMain dflags = Outputable.empty + | otherwise + = case ghcLink dflags of + LinkDynLib -> if platformOS (targetPlatform dflags) == OSMinGW32 + then dllMain + else Outputable.empty + _ -> exeMain + + exeMain = vcat [ + text "#include \"Rts.h\"", + text "extern StgClosure ZCMain_main_closure;", + text "int main(int argc, char *argv[])", + char '{', + text " RtsConfig __conf = defaultRtsConfig;", + text " __conf.rts_opts_enabled = " + <> text (show (rtsOptsEnabled dflags)) <> semi, + text " __conf.rts_opts_suggestions = " + <> text (if rtsOptsSuggestions dflags + then "true" + else "false") <> semi, + case rtsOpts dflags of + Nothing -> Outputable.empty + Just opts -> text " __conf.rts_opts= " <> + text (show opts) <> semi, + text " __conf.rts_hs_main = true;", + text " return hs_main(argc,argv,&ZCMain_main_closure,__conf);", + char '}', + char '\n' -- final newline, to keep gcc happy + ] + + dllMain = vcat [ + text "#include \"Rts.h\"", + text "#include <windows.h>", + text "#include <stdbool.h>", + char '\n', + text "bool", + text "WINAPI", + text "DllMain ( HINSTANCE hInstance STG_UNUSED", + text " , DWORD reason STG_UNUSED", + text " , LPVOID reserved STG_UNUSED", + text " )", + text "{", + text " return true;", + text "}", + char '\n' -- final newline, to keep gcc happy + ] + +-- 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 -> [InstalledUnitId] -> 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 [ + -- "link info" section (see Note [LinkInfo section]) + makeElfNote ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info, + + -- ALL generated assembly must have this section to disable + -- executable stacks. See also + -- compiler/nativeGen/AsmCodeGen.hs for another instance + -- where we need to do this. + if platformHasGnuNonexecStack (targetPlatform dflags) + then text ".section .note.GNU-stack,\"\"," + <> sectionType "progbits" <> char '\n' + else Outputable.empty + ] + +-- | Return the "link info" string +-- +-- See Note [LinkInfo section] +getLinkInfo :: DynFlags -> [InstalledUnitId] -> IO String +getLinkInfo dflags dep_packages = do + package_link_opts <- getPackageLinkOpts dflags dep_packages + pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags) + then getPackageFrameworks dflags dep_packages + else return [] + let extra_ld_inputs = ldInputs dflags + let + link_info = (package_link_opts, + pkg_frameworks, + rtsOpts dflags, + rtsOptsEnabled dflags, + gopt Opt_NoHsMain dflags, + map showOpt extra_ld_inputs, + getOpts dflags opt_l) + -- + return (show link_info) + +platformSupportsSavingLinkOpts :: OS -> Bool +platformSupportsSavingLinkOpts os + | os == OSSolaris2 = False -- see #5382 + | otherwise = osElfTarget os + +-- See Note [LinkInfo section] +ghcLinkInfoSectionName :: String +ghcLinkInfoSectionName = ".debug-ghc-link-info" + -- if we use the ".debug" prefix, then strip will strip it by default + +-- Identifier for the note (see Note [LinkInfo section]) +ghcLinkInfoNoteName :: String +ghcLinkInfoNoteName = "GHC link info" + +-- Returns 'False' if it was, and we can avoid linking, because the +-- previous binary was linked with "the same options". +checkLinkInfo :: DynFlags -> [InstalledUnitId] -> FilePath -> IO Bool +checkLinkInfo dflags pkg_deps exe_file + | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags))) + -- ToDo: Windows and OS X do not use the ELF binary format, so + -- readelf does not work there. We need to find another way to do + -- this. + = return False -- conservatively we should return True, but not + -- linking in this case was the behaviour for a long + -- time so we leave it as-is. + | otherwise + = do + link_info <- getLinkInfo dflags pkg_deps + debugTraceMsg dflags 3 $ text ("Link info: " ++ link_info) + m_exe_link_info <- readElfNoteAsString dflags exe_file + ghcLinkInfoSectionName ghcLinkInfoNoteName + let sameLinkInfo = (Just link_info == m_exe_link_info) + debugTraceMsg dflags 3 $ case m_exe_link_info of + Nothing -> text "Exe link info: Not found" + Just s + | sameLinkInfo -> text ("Exe link info is the same") + | otherwise -> text ("Exe link info is different: " ++ s) + return (not sameLinkInfo) + +{- Note [LinkInfo section] + ~~~~~~~~~~~~~~~~~~~~~~~ + +The "link info" is a string representing the parameters of the link. We save +this information in the binary, and the next time we link, if nothing else has +changed, we use the link info stored in the existing binary to decide whether +to re-link or not. + +The "link info" string is stored in a ELF section called ".debug-ghc-link-info" +(see ghcLinkInfoSectionName) with the SHT_NOTE type. For some time, it used to +not follow the specified record-based format (see #11022). + +-} + +haveRtsOptsFlags :: DynFlags -> Bool +haveRtsOptsFlags dflags = + isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of + RtsOptsSafeOnly -> False + _ -> True diff --git a/compiler/main/SysTools/Info.hs b/compiler/main/SysTools/Info.hs new file mode 100644 index 0000000000..6b310578ff --- /dev/null +++ b/compiler/main/SysTools/Info.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- +-- Compiler information functions +-- +-- (c) The GHC Team 2017 +-- +----------------------------------------------------------------------------- +module SysTools.Info where + +import Exception +import ErrUtils +import DynFlags +import Outputable +import Util + +import Data.List +import Data.IORef + +import System.IO + +import Platform +import GhcPrelude + +import SysTools.Process + +{- Note [Run-time linker info] + +See also: Trac #5240, Trac #6063, Trac #10110 + +Before 'runLink', we need to be sure to get the relevant information +about the linker we're using at runtime to see if we need any extra +options. For example, GNU ld requires '--reduce-memory-overheads' and +'--hash-size=31' in order to use reasonable amounts of memory (see +trac #5240.) But this isn't supported in GNU gold. + +Generally, the linker changing from what was detected at ./configure +time has always been possible using -pgml, but on Linux it can happen +'transparently' by installing packages like binutils-gold, which +change what /usr/bin/ld actually points to. + +Clang vs GCC notes: + +For gcc, 'gcc -Wl,--version' gives a bunch of output about how to +invoke the linker before the version information string. For 'clang', +the version information for 'ld' is all that's output. For this +reason, we typically need to slurp up all of the standard error output +and look through it. + +Other notes: + +We cache the LinkerInfo inside DynFlags, since clients may link +multiple times. The definition of LinkerInfo is there to avoid a +circular dependency. + +-} + +{- Note [ELF needed shared libs] + +Some distributions change the link editor's default handling of +ELF DT_NEEDED tags to include only those shared objects that are +needed to resolve undefined symbols. For Template Haskell we need +the last temporary shared library also if it is not needed for the +currently linked temporary shared library. We specify --no-as-needed +to override the default. This flag exists in GNU ld and GNU gold. + +The flag is only needed on ELF systems. On Windows (PE) and Mac OS X +(Mach-O) the flag is not needed. + +-} + +{- Note [Windows static libGCC] + +The GCC versions being upgraded to in #10726 are configured with +dynamic linking of libgcc supported. This results in libgcc being +linked dynamically when a shared library is created. + +This introduces thus an extra dependency on GCC dll that was not +needed before by shared libraries created with GHC. This is a particular +issue on Windows because you get a non-obvious error due to this missing +dependency. This dependent dll is also not commonly on your path. + +For this reason using the static libgcc is preferred as it preserves +the same behaviour that existed before. There are however some very good +reasons to have the shared version as well as described on page 181 of +https://gcc.gnu.org/onlinedocs/gcc-5.2.0/gcc.pdf : + +"There are several situations in which an application should use the + shared ‘libgcc’ instead of the static version. The most common of these + is when the application wishes to throw and catch exceptions across different + shared libraries. In that case, each of the libraries as well as the application + itself should use the shared ‘libgcc’. " + +-} + +neededLinkArgs :: LinkerInfo -> [Option] +neededLinkArgs (GnuLD o) = o +neededLinkArgs (GnuGold o) = o +neededLinkArgs (LlvmLLD o) = o +neededLinkArgs (DarwinLD o) = o +neededLinkArgs (SolarisLD o) = o +neededLinkArgs (AixLD o) = o +neededLinkArgs UnknownLD = [] + +-- Grab linker info and cache it in DynFlags. +getLinkerInfo :: DynFlags -> IO LinkerInfo +getLinkerInfo dflags = do + info <- readIORef (rtldInfo dflags) + case info of + Just v -> return v + Nothing -> do + v <- getLinkerInfo' dflags + writeIORef (rtldInfo dflags) (Just v) + return v + +-- See Note [Run-time linker info]. +getLinkerInfo' :: DynFlags -> IO LinkerInfo +getLinkerInfo' dflags = do + let platform = targetPlatform dflags + os = platformOS platform + (pgm,args0) = pgm_l dflags + args1 = map Option (getOpts dflags opt_l) + args2 = args0 ++ args1 + args3 = filter notNull (map showOpt args2) + + -- Try to grab the info from the process output. + parseLinkerInfo stdo _stde _exitc + | any ("GNU ld" `isPrefixOf`) stdo = + -- GNU ld specifically needs to use less memory. This especially + -- hurts on small object files. Trac #5240. + -- Set DT_NEEDED for all shared libraries. Trac #10110. + -- TODO: Investigate if these help or hurt when using split sections. + return (GnuLD $ map Option ["-Wl,--hash-size=31", + "-Wl,--reduce-memory-overheads", + -- ELF specific flag + -- see Note [ELF needed shared libs] + "-Wl,--no-as-needed"]) + + | any ("GNU gold" `isPrefixOf`) stdo = + -- GNU gold only needs --no-as-needed. Trac #10110. + -- ELF specific flag, see Note [ELF needed shared libs] + return (GnuGold [Option "-Wl,--no-as-needed"]) + + | any ("LLD" `isPrefixOf`) stdo = + return (LlvmLLD []) + + -- Unknown linker. + | otherwise = fail "invalid --version output, or linker is unsupported" + + -- Process the executable call + info <- catchIO (do + case os of + OSSolaris2 -> + -- Solaris uses its own Solaris linker. Even all + -- GNU C are recommended to configure with Solaris + -- linker instead of using GNU binutils linker. Also + -- all GCC distributed with Solaris follows this rule + -- precisely so we assume here, the Solaris linker is + -- used. + return $ SolarisLD [] + OSAIX -> + -- IBM AIX uses its own non-binutils linker as well + return $ AixLD [] + OSDarwin -> + -- Darwin has neither GNU Gold or GNU LD, but a strange linker + -- that doesn't support --version. We can just assume that's + -- what we're using. + return $ DarwinLD [] + OSMinGW32 -> + -- GHC doesn't support anything but GNU ld on Windows anyway. + -- Process creation is also fairly expensive on win32, so + -- we short-circuit here. + return $ GnuLD $ map Option + [ -- Reduce ld memory usage + "-Wl,--hash-size=31" + , "-Wl,--reduce-memory-overheads" + -- Emit gcc stack checks + -- Note [Windows stack usage] + , "-fstack-check" + -- Force static linking of libGCC + -- Note [Windows static libGCC] + , "-static-libgcc" ] + _ -> do + -- In practice, we use the compiler as the linker here. Pass + -- -Wl,--version to get linker version info. + (exitc, stdo, stde) <- readProcessEnvWithExitCode pgm + (["-Wl,--version"] ++ args3) + c_locale_env + -- Split the output by lines to make certain kinds + -- of processing easier. In particular, 'clang' and 'gcc' + -- have slightly different outputs for '-Wl,--version', but + -- it's still easy to figure out. + parseLinkerInfo (lines stdo) (lines stde) exitc + ) + (\err -> do + debugTraceMsg dflags 2 + (text "Error (figuring out linker information):" <+> + text (show err)) + errorMsg dflags $ hang (text "Warning:") 9 $ + text "Couldn't figure out linker information!" $$ + text "Make sure you're using GNU ld, GNU gold" <+> + text "or the built in OS X linker, etc." + return UnknownLD) + return info + +-- Grab compiler info and cache it in DynFlags. +getCompilerInfo :: DynFlags -> IO CompilerInfo +getCompilerInfo dflags = do + info <- readIORef (rtccInfo dflags) + case info of + Just v -> return v + Nothing -> do + v <- getCompilerInfo' dflags + writeIORef (rtccInfo dflags) (Just v) + return v + +-- See Note [Run-time linker info]. +getCompilerInfo' :: DynFlags -> IO CompilerInfo +getCompilerInfo' dflags = do + let (pgm,_) = pgm_c dflags + -- Try to grab the info from the process output. + parseCompilerInfo _stdo stde _exitc + -- Regular GCC + | any ("gcc version" `isInfixOf`) stde = + return GCC + -- Regular clang + | any ("clang version" `isInfixOf`) stde = + return Clang + -- FreeBSD clang + | any ("FreeBSD clang version" `isInfixOf`) stde = + return Clang + -- XCode 5.1 clang + | any ("Apple LLVM version 5.1" `isPrefixOf`) stde = + return AppleClang51 + -- XCode 5 clang + | any ("Apple LLVM version" `isPrefixOf`) stde = + return AppleClang + -- XCode 4.1 clang + | any ("Apple clang version" `isPrefixOf`) stde = + return AppleClang + -- Unknown linker. + | otherwise = fail "invalid -v output, or compiler is unsupported" + + -- Process the executable call + info <- catchIO (do + (exitc, stdo, stde) <- + readProcessEnvWithExitCode pgm ["-v"] c_locale_env + -- Split the output by lines to make certain kinds + -- of processing easier. + parseCompilerInfo (lines stdo) (lines stde) exitc + ) + (\err -> do + debugTraceMsg dflags 2 + (text "Error (figuring out C compiler information):" <+> + text (show err)) + errorMsg dflags $ hang (text "Warning:") 9 $ + text "Couldn't figure out C compiler information!" $$ + text "Make sure you're using GNU gcc, or clang" + return UnknownCC) + return info diff --git a/compiler/main/SysTools/Process.hs b/compiler/main/SysTools/Process.hs new file mode 100644 index 0000000000..cc8f67d139 --- /dev/null +++ b/compiler/main/SysTools/Process.hs @@ -0,0 +1,347 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- +-- Misc process handling code for SysTools +-- +-- (c) The GHC Team 2017 +-- +----------------------------------------------------------------------------- +module SysTools.Process where + +#include "HsVersions.h" + +import Exception +import ErrUtils +import DynFlags +import FastString +import Outputable +import Panic +import GhcPrelude +import Util +import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan ) + +import Control.Concurrent +import Data.Char + +import System.Exit +import System.Environment +import System.FilePath +import System.IO +import System.IO.Error as IO +import System.Process + +import FileCleanup + +-- Similar to System.Process.readCreateProcessWithExitCode, but stderr is +-- inherited from the parent process, and output to stderr is not captured. +readCreateProcessWithExitCode' + :: CreateProcess + -> IO (ExitCode, String) -- ^ stdout +readCreateProcessWithExitCode' proc = do + (_, Just outh, _, pid) <- + createProcess proc{ std_out = CreatePipe } + + -- fork off a thread to start consuming the output + output <- hGetContents outh + outMVar <- newEmptyMVar + _ <- forkIO $ evaluate (length output) >> putMVar outMVar () + + -- wait on the output + takeMVar outMVar + hClose outh + + -- wait on the process + ex <- waitForProcess pid + + return (ex, output) + +replaceVar :: (String, String) -> [(String, String)] -> [(String, String)] +replaceVar (var, value) env = + (var, value) : filter (\(var',_) -> var /= var') env + +-- | Version of @System.Process.readProcessWithExitCode@ that takes a +-- key-value tuple to insert into the environment. +readProcessEnvWithExitCode + :: String -- ^ program path + -> [String] -- ^ program args + -> (String, String) -- ^ addition to the environment + -> IO (ExitCode, String, String) -- ^ (exit_code, stdout, stderr) +readProcessEnvWithExitCode prog args env_update = do + current_env <- getEnvironment + readCreateProcessWithExitCode (proc prog args) { + env = Just (replaceVar env_update current_env) } "" + +-- Don't let gcc localize version info string, #8825 +c_locale_env :: (String, String) +c_locale_env = ("LANGUAGE", "C") + +-- If the -B<dir> option is set, add <dir> to PATH. This works around +-- a bug in gcc on Windows Vista where it can't find its auxiliary +-- binaries (see bug #1110). +getGccEnv :: [Option] -> IO (Maybe [(String,String)]) +getGccEnv opts = + if null b_dirs + then return Nothing + else do env <- getEnvironment + return (Just (map mangle_path env)) + where + (b_dirs, _) = partitionWith get_b_opt opts + + get_b_opt (Option ('-':'B':dir)) = Left dir + get_b_opt other = Right other + + mangle_path (path,paths) | map toUpper path == "PATH" + = (path, '\"' : head b_dirs ++ "\";" ++ paths) + mangle_path other = other + + +----------------------------------------------------------------------------- +-- Running an external program + +runSomething :: DynFlags + -> String -- For -v message + -> String -- Command name (possibly a full path) + -- assumed already dos-ified + -> [Option] -- Arguments + -- runSomething will dos-ify them + -> IO () + +runSomething dflags phase_name pgm args = + runSomethingFiltered dflags id phase_name pgm args Nothing Nothing + +-- | Run a command, placing the arguments in an external response file. +-- +-- This command is used in order to avoid overlong command line arguments on +-- Windows. The command line arguments are first written to an external, +-- temporary response file, and then passed to the linker via @filepath. +-- response files for passing them in. See: +-- +-- https://gcc.gnu.org/wiki/Response_Files +-- https://ghc.haskell.org/trac/ghc/ticket/10777 +runSomethingResponseFile + :: DynFlags -> (String->String) -> String -> String -> [Option] + -> Maybe [(String,String)] -> IO () + +runSomethingResponseFile dflags filter_fn phase_name pgm args mb_env = + runSomethingWith dflags phase_name pgm args $ \real_args -> do + fp <- getResponseFile real_args + let args = ['@':fp] + r <- builderMainLoop dflags filter_fn pgm args Nothing mb_env + return (r,()) + where + getResponseFile args = do + fp <- newTempName dflags TFL_CurrentModule "rsp" + withFile fp WriteMode $ \h -> do +#if defined(mingw32_HOST_OS) + hSetEncoding h latin1 +#else + hSetEncoding h utf8 +#endif + hPutStr h $ unlines $ map escape args + return fp + + -- Note: Response files have backslash-escaping, double quoting, and are + -- whitespace separated (some implementations use newline, others any + -- whitespace character). Therefore, escape any backslashes, newlines, and + -- double quotes in the argument, and surround the content with double + -- quotes. + -- + -- Another possibility that could be considered would be to convert + -- backslashes in the argument to forward slashes. This would generally do + -- the right thing, since backslashes in general only appear in arguments + -- as part of file paths on Windows, and the forward slash is accepted for + -- those. However, escaping is more reliable, in case somehow a backslash + -- appears in a non-file. + escape x = concat + [ "\"" + , concatMap + (\c -> + case c of + '\\' -> "\\\\" + '\n' -> "\\n" + '\"' -> "\\\"" + _ -> [c]) + x + , "\"" + ] + +runSomethingFiltered + :: DynFlags -> (String->String) -> String -> String -> [Option] + -> Maybe FilePath -> Maybe [(String,String)] -> IO () + +runSomethingFiltered dflags filter_fn phase_name pgm args mb_cwd mb_env = do + runSomethingWith dflags phase_name pgm args $ \real_args -> do + r <- builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env + return (r,()) + +runSomethingWith + :: DynFlags -> String -> String -> [Option] + -> ([String] -> IO (ExitCode, a)) + -> IO a + +runSomethingWith dflags phase_name pgm args io = do + let real_args = filter notNull (map showOpt args) + cmdLine = showCommandForUser pgm real_args + traceCmd dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args + +handleProc :: String -> String -> IO (ExitCode, r) -> IO r +handleProc pgm phase_name proc = do + (rc, r) <- proc `catchIO` handler + case rc of + ExitSuccess{} -> return r + ExitFailure n -> throwGhcExceptionIO ( + ProgramError ("`" ++ takeFileName pgm ++ "'" ++ + " failed in phase `" ++ phase_name ++ "'." ++ + " (Exit code: " ++ show n ++ ")")) + where + handler err = + if IO.isDoesNotExistError err + then does_not_exist + else throwGhcExceptionIO (ProgramError $ show err) + + does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm)) + + +builderMainLoop :: DynFlags -> (String -> String) -> FilePath + -> [String] -> Maybe FilePath -> Maybe [(String, String)] + -> IO ExitCode +builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env = do + chan <- newChan + + -- We use a mask here rather than a bracket because we want + -- to distinguish between cleaning up with and without an + -- exception. This is to avoid calling terminateProcess + -- unless an exception was raised. + let safely inner = mask $ \restore -> do + -- acquire + (hStdIn, hStdOut, hStdErr, hProcess) <- restore $ + runInteractiveProcess pgm real_args mb_cwd mb_env + let cleanup_handles = do + hClose hStdIn + hClose hStdOut + hClose hStdErr + r <- try $ restore $ do + hSetBuffering hStdOut LineBuffering + hSetBuffering hStdErr LineBuffering + let make_reader_proc h = forkIO $ readerProc chan h filter_fn + bracketOnError (make_reader_proc hStdOut) killThread $ \_ -> + bracketOnError (make_reader_proc hStdErr) killThread $ \_ -> + inner hProcess + case r of + -- onException + Left (SomeException e) -> do + terminateProcess hProcess + cleanup_handles + throw e + -- cleanup when there was no exception + Right s -> do + cleanup_handles + return s + safely $ \h -> do + -- we don't want to finish until 2 streams have been complete + -- (stdout and stderr) + log_loop chan (2 :: Integer) + -- after that, we wait for the process to finish and return the exit code. + waitForProcess h + where + -- t starts at the number of streams we're listening to (2) decrements each + -- time a reader process sends EOF. We are safe from looping forever if a + -- reader thread dies, because they send EOF in a finally handler. + log_loop _ 0 = return () + log_loop chan t = do + msg <- readChan chan + case msg of + BuildMsg msg -> do + putLogMsg dflags NoReason SevInfo noSrcSpan + (defaultUserStyle dflags) msg + log_loop chan t + BuildError loc msg -> do + putLogMsg dflags NoReason SevError (mkSrcSpan loc loc) + (defaultUserStyle dflags) msg + log_loop chan t + EOF -> + log_loop chan (t-1) + +readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO () +readerProc chan hdl filter_fn = + (do str <- hGetContents hdl + loop (linesPlatform (filter_fn str)) Nothing) + `finally` + writeChan chan EOF + -- ToDo: check errors more carefully + -- ToDo: in the future, the filter should be implemented as + -- a stream transformer. + where + loop [] Nothing = return () + loop [] (Just err) = writeChan chan err + loop (l:ls) in_err = + case in_err of + Just err@(BuildError srcLoc msg) + | leading_whitespace l -> do + loop ls (Just (BuildError srcLoc (msg $$ text l))) + | otherwise -> do + writeChan chan err + checkError l ls + Nothing -> do + checkError l ls + _ -> panic "readerProc/loop" + + checkError l ls + = case parseError l of + Nothing -> do + writeChan chan (BuildMsg (text l)) + loop ls Nothing + Just (file, lineNum, colNum, msg) -> do + let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum + loop ls (Just (BuildError srcLoc (text msg))) + + leading_whitespace [] = False + leading_whitespace (x:_) = isSpace x + +parseError :: String -> Maybe (String, Int, Int, String) +parseError s0 = case breakColon s0 of + Just (filename, s1) -> + case breakIntColon s1 of + Just (lineNum, s2) -> + case breakIntColon s2 of + Just (columnNum, s3) -> + Just (filename, lineNum, columnNum, s3) + Nothing -> + Just (filename, lineNum, 0, s2) + Nothing -> Nothing + Nothing -> Nothing + +breakColon :: String -> Maybe (String, String) +breakColon xs = case break (':' ==) xs of + (ys, _:zs) -> Just (ys, zs) + _ -> Nothing + +breakIntColon :: String -> Maybe (Int, String) +breakIntColon xs = case break (':' ==) xs of + (ys, _:zs) + | not (null ys) && all isAscii ys && all isDigit ys -> + Just (read ys, zs) + _ -> Nothing + +data BuildMessage + = BuildMsg !SDoc + | BuildError !SrcLoc !SDoc + | EOF + +-- Divvy up text stream into lines, taking platform dependent +-- line termination into account. +linesPlatform :: String -> [String] +#if !defined(mingw32_HOST_OS) +linesPlatform ls = lines ls +#else +linesPlatform "" = [] +linesPlatform xs = + case lineBreak xs of + (as,xs1) -> as : linesPlatform xs1 + where + lineBreak "" = ("","") + lineBreak ('\r':'\n':xs) = ([],xs) + lineBreak ('\n':xs) = ([],xs) + lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs) + +#endif diff --git a/compiler/main/SysTools/Tasks.hs b/compiler/main/SysTools/Tasks.hs new file mode 100644 index 0000000000..66cc1ec1b2 --- /dev/null +++ b/compiler/main/SysTools/Tasks.hs @@ -0,0 +1,345 @@ +{-# LANGUAGE ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- +-- Tasks running external programs for SysTools +-- +-- (c) The GHC Team 2017 +-- +----------------------------------------------------------------------------- +module SysTools.Tasks where + +import Exception +import ErrUtils +import DynFlags +import Outputable +import Platform +import Util + +import Data.Char +import Data.List + +import System.IO +import System.Process +import GhcPrelude + +import LlvmCodeGen.Base (llvmVersionStr, supportedLlvmVersion) + +import SysTools.Process +import SysTools.Info + +{- +************************************************************************ +* * +\subsection{Running an external program} +* * +************************************************************************ +-} + +runUnlit :: DynFlags -> [Option] -> IO () +runUnlit dflags args = do + let prog = pgm_L dflags + opts = getOpts dflags opt_L + runSomething dflags "Literate pre-processor" prog + (map Option opts ++ args) + +runCpp :: DynFlags -> [Option] -> IO () +runCpp dflags args = do + let (p,args0) = pgm_P dflags + args1 = map Option (getOpts dflags opt_P) + args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags] + ++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags] + mb_env <- getGccEnv args2 + runSomethingFiltered dflags id "C pre-processor" p + (args0 ++ args1 ++ args2 ++ args) Nothing mb_env + +runPp :: DynFlags -> [Option] -> IO () +runPp dflags args = do + let prog = pgm_F dflags + opts = map Option (getOpts dflags opt_F) + runSomething dflags "Haskell pre-processor" prog (args ++ opts) + +runCc :: DynFlags -> [Option] -> IO () +runCc dflags args = do + let (p,args0) = pgm_c dflags + args1 = map Option (getOpts dflags opt_c) + args2 = args0 ++ args1 ++ args + mb_env <- getGccEnv args2 + runSomethingResponseFile dflags cc_filter "C Compiler" p args2 mb_env + where + -- discard some harmless warnings from gcc that we can't turn off + cc_filter = unlines . doFilter . lines + + {- + gcc gives warnings in chunks like so: + In file included from /foo/bar/baz.h:11, + from /foo/bar/baz2.h:22, + from wibble.c:33: + /foo/flibble:14: global register variable ... + /foo/flibble:15: warning: call-clobbered r... + We break it up into its chunks, remove any call-clobbered register + warnings from each chunk, and then delete any chunks that we have + emptied of warnings. + -} + doFilter = unChunkWarnings . filterWarnings . chunkWarnings [] + -- We can't assume that the output will start with an "In file inc..." + -- line, so we start off expecting a list of warnings rather than a + -- location stack. + chunkWarnings :: [String] -- The location stack to use for the next + -- list of warnings + -> [String] -- The remaining lines to look at + -> [([String], [String])] + chunkWarnings loc_stack [] = [(loc_stack, [])] + chunkWarnings loc_stack xs + = case break loc_stack_start xs of + (warnings, lss:xs') -> + case span loc_start_continuation xs' of + (lsc, xs'') -> + (loc_stack, warnings) : chunkWarnings (lss : lsc) xs'' + _ -> [(loc_stack, xs)] + + filterWarnings :: [([String], [String])] -> [([String], [String])] + filterWarnings [] = [] + -- If the warnings are already empty then we are probably doing + -- something wrong, so don't delete anything + filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs + filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of + [] -> filterWarnings zs + ys' -> (xs, ys') : filterWarnings zs + + unChunkWarnings :: [([String], [String])] -> [String] + unChunkWarnings [] = [] + unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs + + loc_stack_start s = "In file included from " `isPrefixOf` s + loc_start_continuation s = " from " `isPrefixOf` s + wantedWarning w + | "warning: call-clobbered register used" `isContainedIn` w = False + | otherwise = True + +isContainedIn :: String -> String -> Bool +xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys) + +-- | Run the linker with some arguments and return the output +askLd :: DynFlags -> [Option] -> IO String +askLd dflags args = do + let (p,args0) = pgm_l dflags + args1 = map Option (getOpts dflags opt_l) + args2 = args0 ++ args1 ++ args + mb_env <- getGccEnv args2 + runSomethingWith dflags "gcc" p args2 $ \real_args -> + readCreateProcessWithExitCode' (proc p real_args){ env = mb_env } + +runSplit :: DynFlags -> [Option] -> IO () +runSplit dflags args = do + let (p,args0) = pgm_s dflags + runSomething dflags "Splitter" p (args0++args) + +runAs :: DynFlags -> [Option] -> IO () +runAs dflags args = do + let (p,args0) = pgm_a dflags + args1 = map Option (getOpts dflags opt_a) + args2 = args0 ++ args1 ++ args + mb_env <- getGccEnv args2 + runSomethingFiltered dflags id "Assembler" p args2 Nothing mb_env + +-- | Run the LLVM Optimiser +runLlvmOpt :: DynFlags -> [Option] -> IO () +runLlvmOpt dflags args = do + let (p,args0) = pgm_lo dflags + args1 = map Option (getOpts dflags opt_lo) + -- We take care to pass -optlo flags (e.g. args0) last to ensure that the + -- user can override flags passed by GHC. See #14821. + runSomething dflags "LLVM Optimiser" p (args1 ++ args ++ args0) + +-- | Run the LLVM Compiler +runLlvmLlc :: DynFlags -> [Option] -> IO () +runLlvmLlc dflags args = do + let (p,args0) = pgm_lc dflags + args1 = map Option (getOpts dflags opt_lc) + runSomething dflags "LLVM Compiler" p (args0 ++ args1 ++ args) + +-- | Run the clang compiler (used as an assembler for the LLVM +-- backend on OS X as LLVM doesn't support the OS X system +-- assembler) +runClang :: DynFlags -> [Option] -> IO () +runClang dflags args = do + let (clang,_) = pgm_lcc dflags + -- be careful what options we call clang with + -- see #5903 and #7617 for bugs caused by this. + (_,args0) = pgm_a dflags + args1 = map Option (getOpts dflags opt_a) + args2 = args0 ++ args1 ++ args + mb_env <- getGccEnv args2 + Exception.catch (do + runSomethingFiltered dflags id "Clang (Assembler)" clang args2 Nothing mb_env + ) + (\(err :: SomeException) -> do + errorMsg dflags $ + text ("Error running clang! you need clang installed to use the" ++ + " LLVM backend") $+$ + text "(or GHC tried to execute clang incorrectly)" + throwIO err + ) + +-- | Figure out which version of LLVM we are running this session +figureLlvmVersion :: DynFlags -> IO (Maybe (Int, Int)) +figureLlvmVersion dflags = do + let (pgm,opts) = pgm_lc dflags + args = filter notNull (map showOpt opts) + -- we grab the args even though they should be useless just in + -- case the user is using a customised 'llc' that requires some + -- of the options they've specified. llc doesn't care what other + -- options are specified when '-version' is used. + args' = args ++ ["-version"] + ver <- catchIO (do + (pin, pout, perr, _) <- runInteractiveProcess pgm args' + Nothing Nothing + {- > llc -version + LLVM (http://llvm.org/): + LLVM version 3.5.2 + ... + -} + hSetBinaryMode pout False + _ <- hGetLine pout + vline <- dropWhile (not . isDigit) `fmap` hGetLine pout + v <- case span (/= '.') vline of + ("",_) -> fail "no digits!" + (x,y) -> return (read x + , read $ takeWhile isDigit $ drop 1 y) + + hClose pin + hClose pout + hClose perr + return $ Just v + ) + (\err -> do + debugTraceMsg dflags 2 + (text "Error (figuring out LLVM version):" <+> + text (show err)) + errorMsg dflags $ vcat + [ text "Warning:", nest 9 $ + text "Couldn't figure out LLVM version!" $$ + text ("Make sure you have installed LLVM " ++ + llvmVersionStr supportedLlvmVersion) ] + return Nothing) + return ver + + +runLink :: DynFlags -> [Option] -> IO () +runLink dflags args = do + -- See Note [Run-time linker info] + linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags + let (p,args0) = pgm_l dflags + args1 = map Option (getOpts dflags opt_l) + args2 = args0 ++ linkargs ++ args1 ++ args + mb_env <- getGccEnv args2 + runSomethingResponseFile dflags ld_filter "Linker" p args2 mb_env + where + ld_filter = case (platformOS (targetPlatform dflags)) of + OSSolaris2 -> sunos_ld_filter + _ -> id +{- + SunOS/Solaris ld emits harmless warning messages about unresolved + symbols in case of compiling into shared library when we do not + link against all the required libs. That is the case of GHC which + does not link against RTS library explicitly in order to be able to + choose the library later based on binary application linking + parameters. The warnings look like: + +Undefined first referenced + symbol in file +stg_ap_n_fast ./T2386_Lib.o +stg_upd_frame_info ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziLib_litE_closure ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziLib_appE_closure ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziLib_conE_closure ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziSyntax_mkNameGzud_closure ./T2386_Lib.o +newCAF ./T2386_Lib.o +stg_bh_upd_frame_info ./T2386_Lib.o +stg_ap_ppp_fast ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziLib_stringL_closure ./T2386_Lib.o +stg_ap_p_fast ./T2386_Lib.o +stg_ap_pp_fast ./T2386_Lib.o +ld: warning: symbol referencing errors + + this is actually coming from T2386 testcase. The emitting of those + warnings is also a reason why so many TH testcases fail on Solaris. + + Following filter code is SunOS/Solaris linker specific and should + filter out only linker warnings. Please note that the logic is a + little bit more complex due to the simple reason that we need to preserve + any other linker emitted messages. If there are any. Simply speaking + if we see "Undefined" and later "ld: warning:..." then we omit all + text between (including) the marks. Otherwise we copy the whole output. +-} + sunos_ld_filter :: String -> String + sunos_ld_filter = unlines . sunos_ld_filter' . lines + sunos_ld_filter' x = if (undefined_found x && ld_warning_found x) + then (ld_prefix x) ++ (ld_postfix x) + else x + breakStartsWith x y = break (isPrefixOf x) y + ld_prefix = fst . breakStartsWith "Undefined" + undefined_found = not . null . snd . breakStartsWith "Undefined" + ld_warn_break = breakStartsWith "ld: warning: symbol referencing errors" + ld_postfix = tail . snd . ld_warn_break + ld_warning_found = not . null . snd . ld_warn_break + + +runLibtool :: DynFlags -> [Option] -> IO () +runLibtool dflags args = do + linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags + let args1 = map Option (getOpts dflags opt_l) + args2 = [Option "-static"] ++ args1 ++ args ++ linkargs + libtool = pgm_libtool dflags + mb_env <- getGccEnv args2 + runSomethingFiltered dflags id "Linker" libtool args2 Nothing mb_env + +runAr :: DynFlags -> Maybe FilePath -> [Option] -> IO () +runAr dflags cwd args = do + let ar = pgm_ar dflags + runSomethingFiltered dflags id "Ar" ar args cwd Nothing + +askAr :: DynFlags -> Maybe FilePath -> [Option] -> IO String +askAr dflags mb_cwd args = do + let ar = pgm_ar dflags + runSomethingWith dflags "Ar" ar args $ \real_args -> + readCreateProcessWithExitCode' (proc ar real_args){ cwd = mb_cwd } + +runRanlib :: DynFlags -> [Option] -> IO () +runRanlib dflags args = do + let ranlib = pgm_ranlib dflags + runSomethingFiltered dflags id "Ranlib" ranlib args Nothing Nothing + +runMkDLL :: DynFlags -> [Option] -> IO () +runMkDLL dflags args = do + let (p,args0) = pgm_dll dflags + args1 = args0 ++ args + mb_env <- getGccEnv (args0++args) + runSomethingFiltered dflags id "Make DLL" p args1 Nothing mb_env + +runWindres :: DynFlags -> [Option] -> IO () +runWindres dflags args = do + let (gcc, gcc_args) = pgm_c dflags + windres = pgm_windres dflags + opts = map Option (getOpts dflags opt_windres) + quote x = "\"" ++ x ++ "\"" + args' = -- If windres.exe and gcc.exe are in a directory containing + -- spaces then windres fails to run gcc. We therefore need + -- to tell it what command to use... + Option ("--preprocessor=" ++ + unwords (map quote (gcc : + map showOpt gcc_args ++ + map showOpt opts ++ + ["-E", "-xc", "-DRC_INVOKED"]))) + -- ...but if we do that then if windres calls popen then + -- it can't understand the quoting, so we have to use + -- --use-temp-file so that it interprets it correctly. + -- See #1828. + : Option "--use-temp-file" + : args + mb_env <- getGccEnv gcc_args + runSomethingFiltered dflags id "Windres" windres args' Nothing mb_env + +touch :: DynFlags -> String -> String -> IO () +touch dflags purpose arg = + runSomething dflags purpose (pgm_T dflags) [FileOption "" arg] diff --git a/compiler/main/SysTools/Terminal.hs b/compiler/main/SysTools/Terminal.hs index b3bf6e651d..b7f343a3a5 100644 --- a/compiler/main/SysTools/Terminal.hs +++ b/compiler/main/SysTools/Terminal.hs @@ -1,6 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} module SysTools.Terminal (stderrSupportsAnsiColors) where + +import GhcPrelude + #if defined MIN_VERSION_terminfo import Control.Exception (catch) import Data.Maybe (fromMaybe) diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs index 4b9fbae599..4e93439588 100644 --- a/compiler/main/TidyPgm.hs +++ b/compiler/main/TidyPgm.hs @@ -12,6 +12,8 @@ module TidyPgm ( #include "HsVersions.h" +import GhcPrelude + import TcRnTypes import DynFlags import CoreSyn @@ -59,7 +61,6 @@ import Maybes import UniqSupply import ErrUtils (Severity(..)) import Outputable -import UniqDFM import SrcLoc import qualified ErrUtils as Err @@ -69,7 +70,7 @@ import Data.List ( sortBy ) import Data.IORef ( atomicModifyIORef' ) {- -Constructing the TypeEnv, Instances, Rules, VectInfo from which the +Constructing the TypeEnv, Instances, Rules from which the ModIface is constructed, and which goes on to subsequent modules in --make mode. @@ -163,7 +164,6 @@ mkBootModDetailsTc hsc_env , md_rules = [] , md_anns = [] , md_exports = exports - , md_vect_info = noVectInfo , md_complete_sigs = [] }) } @@ -200,7 +200,7 @@ mkBootTypeEnv exports ids tcs fam_insts globaliseAndTidyId :: Id -> Id --- Takes an LocalId with an External Name, +-- Takes a LocalId with an External Name, -- makes it into a GlobalId -- * unchanged Name (might be Internal or External) -- * unchanged details @@ -219,18 +219,22 @@ globaliseAndTidyId id Plan B: include pragmas, make interfaces ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Figure out which Ids are externally visible +* Step 1: Figure out which Ids are externally visible + See Note [Choosing external Ids] + +* Step 2: Gather the externally visible rules, separately from + the top-level bindings. + See Note [Finding external rules] -* Tidy the bindings, externalising appropriate Ids +* Step 3: Tidy the bindings, externalising appropriate Ids + See Note [Tidy the top-level bindings] * 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.) -Step 1: Figure out external Ids -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Note [choosing external names] - +Note [Choosing external Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See also the section "Interface stability" in the RecompilationAvoidance commentary: http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance @@ -240,9 +244,8 @@ First we figure out which Ids are "external" Ids. An unit. These are a) the user exported ones b) the ones bound to static forms - c) ones mentioned in the unfoldings, workers, - rules of externally-visible ones , - or vectorised versions of externally-visible ones + c) ones mentioned in the unfoldings, workers, or + rules of externally-visible ones While figuring out which Ids are external, we pick a "tidy" OccName for each one. That is, we make its OccName distinct from the other @@ -270,8 +273,8 @@ as the bindings themselves are deterministic (they sometimes aren't!), the order in which they are presented to the tidying phase does not affect the names we assign. -Step 2: Tidy the program -~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Tidy the top-level bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Next we traverse the bindings top to bottom. For each *top-level* binder @@ -318,7 +321,6 @@ tidyProgram hsc_env (ModGuts { mg_module = mod , mg_binds = binds , mg_patsyns = patsyns , mg_rules = imp_rules - , mg_vect_info = vect_info , mg_anns = anns , mg_complete_sigs = complete_sigs , mg_deps = deps @@ -345,7 +347,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ; (unfold_env, tidy_occ_env) <- chooseExternalIds hsc_env mod omit_prags expose_all - binds implicit_binds imp_rules (vectInfoVar vect_info) + binds implicit_binds imp_rules ; let { (trimmed_binds, trimmed_rules) = findExternalRules omit_prags binds imp_rules unfold_env } @@ -367,8 +369,6 @@ tidyProgram hsc_env (ModGuts { mg_module = mod -- and indeed it does, but if omit_prags is on, ext_rules is -- empty - ; tidy_vect_info = tidyVectInfo tidy_env vect_info - -- Tidy the Ids inside each PatSyn, very similarly to DFunIds -- and then override the PatSyns in the type_env with the new tidy ones -- This is really the only reason we keep mg_patsyns at all; otherwise @@ -438,7 +438,6 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ModDetails { md_types = tidy_type_env, md_rules = tidy_rules, md_insts = tidy_cls_insts, - md_vect_info = tidy_vect_info, md_fam_insts = fam_insts, md_exports = exports, md_anns = anns, -- are already tidy @@ -451,7 +450,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod tidyTypeEnv :: Bool -- Compiling without -O, so omit prags -> TypeEnv -> TypeEnv --- The competed type environment is gotten from +-- The completed 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 @@ -487,38 +486,6 @@ extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv extendTypeEnvWithPatSyns tidy_patsyns type_env = extendTypeEnvList type_env [AConLike (PatSynCon ps) | ps <- tidy_patsyns ] -tidyVectInfo :: TidyEnv -> VectInfo -> VectInfo -tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar = vars - , vectInfoParallelVars = parallelVars - }) - = info { vectInfoVar = tidy_vars - , vectInfoParallelVars = tidy_parallelVars - } - where - -- we only export mappings whose domain and co-domain is exported (otherwise, the iface is - -- inconsistent) - tidy_vars = mkDVarEnv [ (tidy_var, (tidy_var, tidy_var_v)) - | (var, var_v) <- eltsUDFM vars - , let tidy_var = lookup_var var - tidy_var_v = lookup_var var_v - , isExternalId tidy_var && isExportedId tidy_var - , isExternalId tidy_var_v && isExportedId tidy_var_v - , isDataConWorkId var || not (isImplicitId var) - ] - - tidy_parallelVars = mkDVarSet - [ tidy_var - | var <- dVarSetElems parallelVars - , let tidy_var = lookup_var var - , isExternalId tidy_var && isExportedId tidy_var - ] - - lookup_var var = lookupWithDefaultVarEnv var_env var var - - -- We need to make sure that all names getting into the iface version of 'VectInfo' are - -- external; otherwise, 'MkIface' will bomb out. - isExternalId = isExternalName . idName - {- Note [Don't attempt to trim data types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -619,7 +586,7 @@ get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id)) * * ************************************************************************ -See Note [Choosing external names]. +See Note [Choosing external Ids]. -} type UnfoldEnv = IdEnv (Name{-new name-}, Bool {-show unfolding-}) @@ -635,23 +602,22 @@ chooseExternalIds :: HscEnv -> [CoreBind] -> [CoreBind] -> [CoreRule] - -> DVarEnv (Var, Var) -> IO (UnfoldEnv, TidyOccEnv) -- Step 1 from the notes above -chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_rules vect_vars +chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_rules = do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders ; tidy_internal internal_ids unfold_env1 occ_env1 } where nc_var = hsc_NC hsc_env - -- init_ext_ids is the intial list of Ids that should be + -- init_ext_ids is the initial 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 + -- It is sorted, so that it has a deterministic order (i.e. it's the -- same list every time this module is compiled), in contrast to the -- bindings, which are ordered non-deterministically. init_work_list = zip init_ext_ids init_ext_ids @@ -659,13 +625,10 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_ -- An Id should be external if either (a) it is exported, -- (b) it appears in the RHS of a local rule for an imported Id, or - -- (c) it is the vectorised version of an imported Id. -- See Note [Which rules to expose] is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars - || id `elemVarSet` vect_var_vs rule_rhs_vars = mapUnionVarSet ruleRhsFreeVars imp_id_rules - vect_var_vs = mkVarSet [var_v | (var, var_v) <- eltsUDFM vect_vars, isGlobalId var] binders = map fst $ flattenBinds binds implicit_binders = bindersOfBinds implicit_binds @@ -715,9 +678,6 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_ | omit_prags = ([], False) | otherwise = addExternal expose_all refined_id - -- add vectorised version if any exists - new_ids' = new_ids ++ maybeToList (fmap snd $ lookupDVarEnv vect_vars idocc) - -- '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 @@ -728,7 +688,7 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_ referrer' | isExportedId refined_id = refined_id | otherwise = referrer -- - search (zip new_ids' (repeat referrer') ++ rest) unfold_env' occ_env' + search (zip new_ids (repeat referrer') ++ rest) unfold_env' occ_env' tidy_internal :: [Id] -> UnfoldEnv -> TidyOccEnv -> IO (UnfoldEnv, TidyOccEnv) @@ -778,7 +738,7 @@ a VarSet, which is in a non-deterministic order when converted to a list. Hence, here we define a free-variable finder that returns the free variables in the order that they are encountered. -See Note [Choosing external names] +See Note [Choosing external Ids] -} bndrFvsInOrder :: Bool -> Id -> [Id] @@ -1133,9 +1093,14 @@ tidyTopBinds :: HscEnv tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds = do mkIntegerId <- lookupMkIntegerName dflags hsc_env + mkNaturalId <- lookupMkNaturalName dflags hsc_env integerSDataCon <- lookupIntegerSDataConName dflags hsc_env - let cvt_integer = cvtLitInteger dflags mkIntegerId integerSDataCon - result = tidy cvt_integer init_env binds + naturalSDataCon <- lookupNaturalSDataConName dflags hsc_env + let cvt_literal nt i = case nt of + LitNumInteger -> Just (cvtLitInteger dflags mkIntegerId integerSDataCon i) + LitNumNatural -> Just (cvtLitNatural dflags mkNaturalId naturalSDataCon i) + _ -> Nothing + result = tidy cvt_literal init_env binds seqBinds (snd result) `seq` return result -- This seqBinds avoids a spike in space usage (see #13564) where @@ -1144,34 +1109,35 @@ tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds init_env = (init_occ_env, emptyVarEnv) tidy _ env [] = (env, []) - tidy cvt_integer env (b:bs) - = let (env1, b') = tidyTopBind dflags this_mod - cvt_integer unfold_env env b - (env2, bs') = tidy cvt_integer env1 bs + tidy cvt_literal env (b:bs) + = let (env1, b') = tidyTopBind dflags this_mod cvt_literal unfold_env + env b + (env2, bs') = tidy cvt_literal env1 bs in (env2, b':bs') ------------------------ tidyTopBind :: DynFlags -> Module - -> (Integer -> CoreExpr) + -> (LitNumType -> Integer -> Maybe CoreExpr) -> UnfoldEnv -> TidyEnv -> CoreBind -> (TidyEnv, CoreBind) -tidyTopBind dflags this_mod cvt_integer unfold_env +tidyTopBind dflags this_mod cvt_literal 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 dflags this_mod (subst1, cvt_integer) + caf_info = hasCafRefs dflags this_mod + (subst1, cvt_literal) (idArity bndr) rhs (bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 caf_info name' (bndr, rhs) subst2 = extendVarEnv subst1 bndr bndr' tidy_env2 = (occ_env, subst2) -tidyTopBind dflags this_mod cvt_integer unfold_env +tidyTopBind dflags this_mod cvt_literal unfold_env (occ_env, subst1) (Rec prs) = (tidy_env2, Rec prs') where @@ -1190,7 +1156,7 @@ tidyTopBind dflags this_mod cvt_integer unfold_env -- the group may refer indirectly to a CAF (because then, they all do). caf_info | or [ mayHaveCafRefs (hasCafRefs dflags this_mod - (subst1, cvt_integer) + (subst1, cvt_literal) (idArity bndr) rhs) | (bndr,rhs) <- prs ] = MayHaveCafRefs | otherwise = NoCafRefs @@ -1242,6 +1208,8 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_ `setCafInfo` caf_info `setArityInfo` arity `setStrictnessInfo` final_sig + `setUnfoldingInfo` minimal_unfold_info -- See note [Preserve evaluatedness] + -- in CoreTidy | otherwise -- Externally-visible Ids get the whole lot = vanillaIdInfo @@ -1278,7 +1246,8 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_ --------- Unfolding ------------ unf_info = unfoldingInfo idinfo unfold_info | show_unfold = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs - | otherwise = noUnfolding + | otherwise = minimal_unfold_info + minimal_unfold_info = zapUnfolding unf_info unf_from_rhs = mkTopUnfolding dflags is_bot tidy_rhs is_bot = isBottomingSig final_sig -- NB: do *not* expose the worker if show_unfold is off, @@ -1295,6 +1264,7 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_ -- for bottoming functions), but we might still have a worker/wrapper -- split (see Note [Worker-wrapper for bottoming functions] in WorkWrap.hs + --------- Arity ------------ -- Usually the Id will have an accurate arity on it, because -- the simplifier has just run, but not always. @@ -1332,25 +1302,28 @@ We compute hasCafRefs here, because IdInfo is supposed to be finalised after TidyPgm. But CorePrep does some transformations that affect CAF-hood. So we have to *predict* the result here, which is revolting. -In particular CorePrep expands Integer literals. So in the prediction code -here we resort to applying the same expansion (cvt_integer). Ugh! +In particular CorePrep expands Integer and Natural literals. So in the +prediction code here we resort to applying the same expansion (cvt_literal). +Ugh! -} -type CafRefEnv = (VarEnv Id, Integer -> CoreExpr) +type CafRefEnv = (VarEnv Id, LitNumType -> Integer -> Maybe CoreExpr) -- The env finds the Caf-ness of the Id - -- The Integer -> CoreExpr is the desugaring function for Integer literals + -- The LitNumType -> Integer -> CoreExpr is the desugaring functions for + -- Integer and Natural literals -- See Note [Disgusting computation of CafRefs] hasCafRefs :: DynFlags -> Module -> CafRefEnv -> Arity -> CoreExpr -> CafInfo -hasCafRefs dflags this_mod p@(_,cvt_integer) arity expr +hasCafRefs dflags this_mod (subst, cvt_literal) arity expr | is_caf || mentions_cafs = MayHaveCafRefs | otherwise = NoCafRefs where - mentions_cafs = cafRefsE p expr + mentions_cafs = cafRefsE expr is_dynamic_name = isDllName dflags this_mod - is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name cvt_integer expr) + is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name + cvt_literal expr) -- NB. we pass in the arity of the expression, which is expected -- to be calculated by exprArity. This is because exprArity @@ -1358,34 +1331,36 @@ hasCafRefs dflags this_mod p@(_,cvt_integer) arity expr -- CorePrep later on, and we don't want to duplicate that -- knowledge in rhsIsStatic below. -cafRefsE :: CafRefEnv -> Expr a -> Bool -cafRefsE p (Var id) = cafRefsV p id -cafRefsE p (Lit lit) = cafRefsL p lit -cafRefsE p (App f a) = cafRefsE p f || cafRefsE p a -cafRefsE p (Lam _ e) = cafRefsE p e -cafRefsE p (Let b e) = cafRefsEs p (rhssOfBind b) || cafRefsE p e -cafRefsE p (Case e _ _ alts) = 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 _) = False -cafRefsE _ (Coercion _) = False - -cafRefsEs :: CafRefEnv -> [Expr a] -> Bool -cafRefsEs _ [] = False -cafRefsEs p (e:es) = cafRefsE p e || cafRefsEs p es - -cafRefsL :: CafRefEnv -> Literal -> Bool --- 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@(_, cvt_integer) (LitInteger i _) = cafRefsE p (cvt_integer i) -cafRefsL _ _ = False - -cafRefsV :: CafRefEnv -> Id -> Bool -cafRefsV (subst, _) id - | not (isLocalId id) = mayHaveCafRefs (idCafInfo id) - | Just id' <- lookupVarEnv subst id = mayHaveCafRefs (idCafInfo id') - | otherwise = False + cafRefsE :: Expr a -> Bool + cafRefsE (Var id) = cafRefsV id + cafRefsE (Lit lit) = cafRefsL lit + cafRefsE (App f a) = cafRefsE f || cafRefsE a + cafRefsE (Lam _ e) = cafRefsE e + cafRefsE (Let b e) = cafRefsEs (rhssOfBind b) || cafRefsE e + cafRefsE (Case e _ _ alts) = cafRefsE e || cafRefsEs (rhssOfAlts alts) + cafRefsE (Tick _n e) = cafRefsE e + cafRefsE (Cast e _co) = cafRefsE e + cafRefsE (Type _) = False + cafRefsE (Coercion _) = False + + cafRefsEs :: [Expr a] -> Bool + cafRefsEs [] = False + cafRefsEs (e:es) = cafRefsE e || cafRefsEs es + + cafRefsL :: Literal -> Bool + -- 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. Same for LitNatural. + cafRefsL (LitNumber nt i _) = case cvt_literal nt i of + Just e -> cafRefsE e + Nothing -> False + cafRefsL _ = False + + cafRefsV :: Id -> Bool + cafRefsV id + | not (isLocalId id) = mayHaveCafRefs (idCafInfo id) + | Just id' <- lookupVarEnv subst id = mayHaveCafRefs (idCafInfo id') + | otherwise = False {- |