diff options
| author | Sylvain Henry <sylvain@haskus.fr> | 2020-02-18 11:08:48 +0100 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-02-21 20:46:40 -0500 |
| commit | 240f5bf6f53515535be5bf3ef7632aa69ae21e3e (patch) | |
| tree | dc7be78ca126c66af0aeb9f7944ebfc0ac5a211c /compiler/GHC | |
| parent | be7068a6130f394dcefbcb5d09c2944deca2270d (diff) | |
| download | haskell-240f5bf6f53515535be5bf3ef7632aa69ae21e3e.tar.gz | |
Modules: Driver (#13009)
submodule updates: nofib, haddock
Diffstat (limited to 'compiler/GHC')
129 files changed, 22933 insertions, 169 deletions
diff --git a/compiler/GHC/ByteCode/Asm.hs b/compiler/GHC/ByteCode/Asm.hs index 95e728c2a6..79b0bc2766 100644 --- a/compiler/GHC/ByteCode/Asm.hs +++ b/compiler/GHC/ByteCode/Asm.hs @@ -23,7 +23,7 @@ import GHC.ByteCode.Types import GHCi.RemoteTypes import GHC.Runtime.Interpreter -import HscTypes +import GHC.Driver.Types import Name import NameSet import Literal @@ -31,7 +31,7 @@ import TyCon import FastString import GHC.StgToCmm.Layout ( ArgRep(..) ) import GHC.Runtime.Heap.Layout -import DynFlags +import GHC.Driver.Session import Outputable import GHC.Platform import Util diff --git a/compiler/GHC/ByteCode/InfoTable.hs b/compiler/GHC/ByteCode/InfoTable.hs index 40a107756d..80a259d94d 100644 --- a/compiler/GHC/ByteCode/InfoTable.hs +++ b/compiler/GHC/ByteCode/InfoTable.hs @@ -13,8 +13,8 @@ import GhcPrelude import GHC.ByteCode.Types import GHC.Runtime.Interpreter -import DynFlags -import HscTypes +import GHC.Driver.Session +import GHC.Driver.Types import Name ( Name, getName ) import NameEnv import DataCon ( DataCon, dataConRepArgTys, dataConIdentity ) diff --git a/compiler/GHC/ByteCode/Linker.hs b/compiler/GHC/ByteCode/Linker.hs index 69bdb63a91..1e77b0967e 100644 --- a/compiler/GHC/ByteCode/Linker.hs +++ b/compiler/GHC/ByteCode/Linker.hs @@ -27,7 +27,7 @@ import SizedSeq import GHC.Runtime.Interpreter import GHC.ByteCode.Types -import HscTypes +import GHC.Driver.Types import Name import NameEnv import PrimOp diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs index 8cac0aa5dd..f3cf8019d0 100644 --- a/compiler/GHC/Cmm/CLabel.hs +++ b/compiler/GHC/Cmm/CLabel.hs @@ -118,7 +118,7 @@ import GhcPrelude import IdInfo import BasicTypes import {-# SOURCE #-} GHC.Cmm.BlockId (BlockId, mkBlockId) -import Packages +import GHC.Driver.Packages import Module import Name import Unique @@ -126,7 +126,7 @@ import PrimOp import CostCentre import Outputable import FastString -import DynFlags +import GHC.Driver.Session import GHC.Platform import UniqSet import Util diff --git a/compiler/GHC/Cmm/CallConv.hs b/compiler/GHC/Cmm/CallConv.hs index db9603c524..40f348f9e0 100644 --- a/compiler/GHC/Cmm/CallConv.hs +++ b/compiler/GHC/Cmm/CallConv.hs @@ -12,7 +12,7 @@ import GHC.Runtime.Heap.Layout import GHC.Cmm (Convention(..)) import GHC.Cmm.Ppr () -- For Outputable instances -import DynFlags +import GHC.Driver.Session import GHC.Platform import Outputable diff --git a/compiler/GHC/Cmm/Expr.hs b/compiler/GHC/Cmm/Expr.hs index 3b4f0156a0..9be4200f85 100644 --- a/compiler/GHC/Cmm/Expr.hs +++ b/compiler/GHC/Cmm/Expr.hs @@ -36,7 +36,7 @@ import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Cmm.MachOp import GHC.Cmm.Type -import DynFlags +import GHC.Driver.Session import Outputable (panic) import Unique diff --git a/compiler/GHC/Cmm/Graph.hs b/compiler/GHC/Cmm/Graph.hs index 1d8b44776d..c07f694897 100644 --- a/compiler/GHC/Cmm/Graph.hs +++ b/compiler/GHC/Cmm/Graph.hs @@ -31,7 +31,7 @@ import GHC.Cmm.Switch (SwitchTargets) import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label -import DynFlags +import GHC.Driver.Session import FastString import ForeignCall import OrdList diff --git a/compiler/GHC/Cmm/Info.hs b/compiler/GHC/Cmm/Info.hs index 6948f78969..6b2a3d82c6 100644 --- a/compiler/GHC/Cmm/Info.hs +++ b/compiler/GHC/Cmm/Info.hs @@ -46,7 +46,7 @@ import GHC.Cmm.Dataflow.Collections import GHC.Platform import Maybes -import DynFlags +import GHC.Driver.Session import ErrUtils (withTimingSilent) import Panic import UniqSupply diff --git a/compiler/GHC/Cmm/Info/Build.hs b/compiler/GHC/Cmm/Info/Build.hs index 92619b8959..54a7d8fb91 100644 --- a/compiler/GHC/Cmm/Info/Build.hs +++ b/compiler/GHC/Cmm/Info/Build.hs @@ -24,7 +24,7 @@ import Digraph import GHC.Cmm.CLabel import GHC.Cmm import GHC.Cmm.Utils -import DynFlags +import GHC.Driver.Session import Maybes import Outputable import GHC.Runtime.Heap.Layout diff --git a/compiler/GHC/Cmm/LayoutStack.hs b/compiler/GHC/Cmm/LayoutStack.hs index b34de95982..2b6051dd38 100644 --- a/compiler/GHC/Cmm/LayoutStack.hs +++ b/compiler/GHC/Cmm/LayoutStack.hs @@ -29,7 +29,7 @@ import Maybes import UniqFM import Util -import DynFlags +import GHC.Driver.Session import FastString import Outputable hiding ( isEmpty ) import qualified Data.Set as Set diff --git a/compiler/GHC/Cmm/Lint.hs b/compiler/GHC/Cmm/Lint.hs index d70fed3b9e..a6bec1f187 100644 --- a/compiler/GHC/Cmm/Lint.hs +++ b/compiler/GHC/Cmm/Lint.hs @@ -23,7 +23,7 @@ import GHC.Cmm.Liveness import GHC.Cmm.Switch (switchTargetsToList) import GHC.Cmm.Ppr () -- For Outputable instances import Outputable -import DynFlags +import GHC.Driver.Session import Control.Monad (ap) diff --git a/compiler/GHC/Cmm/Liveness.hs b/compiler/GHC/Cmm/Liveness.hs index 2b598f52e5..10d4ca8dfd 100644 --- a/compiler/GHC/Cmm/Liveness.hs +++ b/compiler/GHC/Cmm/Liveness.hs @@ -14,7 +14,7 @@ where import GhcPrelude -import DynFlags +import GHC.Driver.Session import GHC.Cmm.BlockId import GHC.Cmm import GHC.Cmm.Ppr.Expr () -- For Outputable instances diff --git a/compiler/GHC/Cmm/MachOp.hs b/compiler/GHC/Cmm/MachOp.hs index a887477028..d811d4808f 100644 --- a/compiler/GHC/Cmm/MachOp.hs +++ b/compiler/GHC/Cmm/MachOp.hs @@ -32,7 +32,7 @@ import GhcPrelude import GHC.Cmm.Type import Outputable -import DynFlags +import GHC.Driver.Session ----------------------------------------------------------------------------- -- MachOp diff --git a/compiler/GHC/Cmm/Monad.hs b/compiler/GHC/Cmm/Monad.hs index eccaf72676..d6c8a5b3cc 100644 --- a/compiler/GHC/Cmm/Monad.hs +++ b/compiler/GHC/Cmm/Monad.hs @@ -17,7 +17,7 @@ import GhcPrelude import Control.Monad -import DynFlags +import GHC.Driver.Session import Lexer newtype PD a = PD { unPD :: DynFlags -> PState -> ParseResult a } diff --git a/compiler/GHC/Cmm/Node.hs b/compiler/GHC/Cmm/Node.hs index f7cee80145..f26fb2c9d9 100644 --- a/compiler/GHC/Cmm/Node.hs +++ b/compiler/GHC/Cmm/Node.hs @@ -31,7 +31,7 @@ import GhcPrelude hiding (succ) import GHC.Platform.Regs import GHC.Cmm.Expr import GHC.Cmm.Switch -import DynFlags +import GHC.Driver.Session import FastString import ForeignCall import Outputable diff --git a/compiler/GHC/Cmm/Opt.hs b/compiler/GHC/Cmm/Opt.hs index 1db37ae58c..7dd43852a6 100644 --- a/compiler/GHC/Cmm/Opt.hs +++ b/compiler/GHC/Cmm/Opt.hs @@ -17,7 +17,7 @@ import GhcPrelude import GHC.Cmm.Utils import GHC.Cmm -import DynFlags +import GHC.Driver.Session import Util import Outputable diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y index 2e6762e68a..69a2a9347e 100644 --- a/compiler/GHC/Cmm/Parser.y +++ b/compiler/GHC/Cmm/Parser.y @@ -242,7 +242,7 @@ import Literal import Unique import UniqFM import SrcLoc -import DynFlags +import GHC.Driver.Session import ErrUtils import StringBuffer import FastString diff --git a/compiler/GHC/Cmm/Pipeline.hs b/compiler/GHC/Cmm/Pipeline.hs index 9fd484fdb2..88db550d8a 100644 --- a/compiler/GHC/Cmm/Pipeline.hs +++ b/compiler/GHC/Cmm/Pipeline.hs @@ -23,9 +23,9 @@ import GHC.Cmm.Sink import GHC.Cmm.Dataflow.Collections import UniqSupply -import DynFlags +import GHC.Driver.Session import ErrUtils -import HscTypes +import GHC.Driver.Types import Control.Monad import Outputable import GHC.Platform diff --git a/compiler/GHC/Cmm/Ppr/Decl.hs b/compiler/GHC/Cmm/Ppr/Decl.hs index e91c4b6277..6c19d5f7a6 100644 --- a/compiler/GHC/Cmm/Ppr/Decl.hs +++ b/compiler/GHC/Cmm/Ppr/Decl.hs @@ -43,7 +43,7 @@ import GhcPrelude import GHC.Cmm.Ppr.Expr import GHC.Cmm -import DynFlags +import GHC.Driver.Session import Outputable import FastString diff --git a/compiler/GHC/Cmm/ProcPoint.hs b/compiler/GHC/Cmm/ProcPoint.hs index 1e4b70bd23..42bd342e86 100644 --- a/compiler/GHC/Cmm/ProcPoint.hs +++ b/compiler/GHC/Cmm/ProcPoint.hs @@ -11,7 +11,7 @@ where import GhcPrelude hiding (last, unzip, succ, zip) -import DynFlags +import GHC.Driver.Session import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Cmm diff --git a/compiler/GHC/Cmm/Sink.hs b/compiler/GHC/Cmm/Sink.hs index 8e231df300..ceb4f874ee 100644 --- a/compiler/GHC/Cmm/Sink.hs +++ b/compiler/GHC/Cmm/Sink.hs @@ -16,7 +16,7 @@ import GHC.Cmm.Dataflow.Graph import GHC.Platform.Regs import GHC.Platform (isARM, platformArch) -import DynFlags +import GHC.Driver.Session import Unique import UniqFM diff --git a/compiler/GHC/Cmm/Switch.hs b/compiler/GHC/Cmm/Switch.hs index ea7932ca17..f297bd8b5e 100644 --- a/compiler/GHC/Cmm/Switch.hs +++ b/compiler/GHC/Cmm/Switch.hs @@ -15,7 +15,7 @@ module GHC.Cmm.Switch ( import GhcPrelude import Outputable -import DynFlags +import GHC.Driver.Session import GHC.Cmm.Dataflow.Label (Label) import Data.Maybe diff --git a/compiler/GHC/Cmm/Switch/Implement.hs b/compiler/GHC/Cmm/Switch/Implement.hs index 859fe81b8d..2074c465ad 100644 --- a/compiler/GHC/Cmm/Switch/Implement.hs +++ b/compiler/GHC/Cmm/Switch/Implement.hs @@ -12,7 +12,7 @@ import GHC.Cmm import GHC.Cmm.Utils import GHC.Cmm.Switch import UniqSupply -import DynFlags +import GHC.Driver.Session import MonadUtils (concatMapM) -- diff --git a/compiler/GHC/Cmm/Type.hs b/compiler/GHC/Cmm/Type.hs index 867a260078..2fb4ea61a7 100644 --- a/compiler/GHC/Cmm/Type.hs +++ b/compiler/GHC/Cmm/Type.hs @@ -31,7 +31,7 @@ where import GhcPrelude -import DynFlags +import GHC.Driver.Session import FastString import Outputable diff --git a/compiler/GHC/Cmm/Utils.hs b/compiler/GHC/Cmm/Utils.hs index c62f7eb3df..5a34ae45e2 100644 --- a/compiler/GHC/Cmm/Utils.hs +++ b/compiler/GHC/Cmm/Utils.hs @@ -80,7 +80,7 @@ import GHC.Cmm import GHC.Cmm.BlockId import GHC.Cmm.CLabel import Outputable -import DynFlags +import GHC.Driver.Session import Unique import GHC.Platform.Regs diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs index 25b32be0d0..f7245f5c30 100644 --- a/compiler/GHC/CmmToC.hs +++ b/compiler/GHC/CmmToC.hs @@ -40,7 +40,7 @@ import GHC.Cmm.Switch -- Utils import CPrim -import DynFlags +import GHC.Driver.Session import FastString import Outputable import GHC.Platform diff --git a/compiler/GHC/CmmToLlvm.hs b/compiler/GHC/CmmToLlvm.hs index f84c2901a5..d89b8e93cf 100644 --- a/compiler/GHC/CmmToLlvm.hs +++ b/compiler/GHC/CmmToLlvm.hs @@ -29,7 +29,7 @@ import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Ppr import BufWrite -import DynFlags +import GHC.Driver.Session import GHC.Platform ( platformArch, Arch(..) ) import ErrUtils import FastString diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs index 5cfef04029..9d97f3eb3c 100644 --- a/compiler/GHC/CmmToLlvm/Base.hs +++ b/compiler/GHC/CmmToLlvm/Base.hs @@ -48,7 +48,7 @@ import GHC.CmmToLlvm.Regs import GHC.Cmm.CLabel import GHC.Platform.Regs ( activeStgRegs ) -import DynFlags +import GHC.Driver.Session import FastString import GHC.Cmm hiding ( succ ) import GHC.Cmm.Utils (regsOverlap) diff --git a/compiler/GHC/CmmToLlvm/CodeGen.hs b/compiler/GHC/CmmToLlvm/CodeGen.hs index 947ba31f35..62ebeb9ba7 100644 --- a/compiler/GHC/CmmToLlvm/CodeGen.hs +++ b/compiler/GHC/CmmToLlvm/CodeGen.hs @@ -25,7 +25,7 @@ import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Collections -import DynFlags +import GHC.Driver.Session import FastString import ForeignCall import Outputable hiding (panic, pprPanic) diff --git a/compiler/GHC/CmmToLlvm/Data.hs b/compiler/GHC/CmmToLlvm/Data.hs index b20c9bd360..7a6320f947 100644 --- a/compiler/GHC/CmmToLlvm/Data.hs +++ b/compiler/GHC/CmmToLlvm/Data.hs @@ -17,7 +17,7 @@ import GHC.CmmToLlvm.Base import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Cmm -import DynFlags +import GHC.Driver.Session import GHC.Platform import FastString diff --git a/compiler/GHC/CmmToLlvm/Mangler.hs b/compiler/GHC/CmmToLlvm/Mangler.hs index 1cdad2009f..6bf27267d7 100644 --- a/compiler/GHC/CmmToLlvm/Mangler.hs +++ b/compiler/GHC/CmmToLlvm/Mangler.hs @@ -13,7 +13,7 @@ module GHC.CmmToLlvm.Mangler ( llvmFixupAsm ) where import GhcPrelude -import DynFlags ( DynFlags, targetPlatform ) +import GHC.Driver.Session ( DynFlags, targetPlatform ) import GHC.Platform ( platformArch, Arch(..) ) import ErrUtils ( withTiming ) import Outputable ( text ) diff --git a/compiler/GHC/CmmToLlvm/Regs.hs b/compiler/GHC/CmmToLlvm/Regs.hs index 60c27c8f44..af2a88c4c9 100644 --- a/compiler/GHC/CmmToLlvm/Regs.hs +++ b/compiler/GHC/CmmToLlvm/Regs.hs @@ -16,7 +16,7 @@ import GhcPrelude import GHC.Llvm import GHC.Cmm.Expr -import DynFlags +import GHC.Driver.Session import FastString import Outputable ( panic ) import Unique diff --git a/compiler/GHC/CoreToByteCode.hs b/compiler/GHC/CoreToByteCode.hs index 318364fd7c..a2b18601ca 100644 --- a/compiler/GHC/CoreToByteCode.hs +++ b/compiler/GHC/CoreToByteCode.hs @@ -22,7 +22,7 @@ import GHC.Runtime.Interpreter import GHCi.FFI import GHCi.RemoteTypes import BasicTypes -import DynFlags +import GHC.Driver.Session import Outputable import GHC.Platform import Name @@ -30,7 +30,7 @@ import MkId import Id import Var ( updateVarType ) import ForeignCall -import HscTypes +import GHC.Driver.Types import CoreUtils import CoreSyn import PprCore diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs index 2e922b6de6..ead7a12da0 100644 --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -41,7 +41,7 @@ import Outputable import MonadUtils import FastString import Util -import DynFlags +import GHC.Driver.Session import ForeignCall import Demand ( isUsedOnce ) import PrimOp ( PrimCall(..), primOpWrapperId ) diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index edfe9cc363..300c95f6df 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -21,7 +21,7 @@ import GhcPrelude import OccurAnal -import HscTypes +import GHC.Driver.Types import PrelNames import MkId ( realWorldPrimId ) import CoreUtils @@ -50,7 +50,7 @@ import UniqSupply import Maybes import OrdList import ErrUtils -import DynFlags +import GHC.Driver.Session import Util import Outputable import FastString diff --git a/compiler/GHC/Data/Bitmap.hs b/compiler/GHC/Data/Bitmap.hs index c778a575f8..1b93d6000d 100644 --- a/compiler/GHC/Data/Bitmap.hs +++ b/compiler/GHC/Data/Bitmap.hs @@ -18,7 +18,7 @@ module GHC.Data.Bitmap ( import GhcPrelude import GHC.Runtime.Heap.Layout -import DynFlags +import GHC.Driver.Session import Util import Data.Bits diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs new file mode 100644 index 0000000000..e5364e3d3f --- /dev/null +++ b/compiler/GHC/Driver/Backpack.hs @@ -0,0 +1,830 @@ +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} + +-- | This is the driver for the 'ghc --backpack' mode, which +-- is a reimplementation of the "package manager" bits of +-- Backpack directly in GHC. The basic method of operation +-- is to compile packages and then directly insert them into +-- GHC's in memory database. +-- +-- The compilation products of this mode aren't really suitable +-- for Cabal, because GHC makes up component IDs for the things +-- it builds and doesn't serialize out the database contents. +-- But it's still handy for constructing tests. + +module GHC.Driver.Backpack (doBackpack) where + +#include "HsVersions.h" + +import GhcPrelude + +-- In a separate module because it hooks into the parser. +import GHC.Driver.Backpack.Syntax + +import ApiAnnotation +import GHC hiding (Failed, Succeeded) +import GHC.Driver.Packages +import Parser +import Lexer +import GHC.Driver.Monad +import GHC.Driver.Session +import TcRnMonad +import TcRnDriver +import Module +import GHC.Driver.Types +import StringBuffer +import FastString +import ErrUtils +import SrcLoc +import GHC.Driver.Main +import UniqFM +import UniqDFM +import Outputable +import Maybes +import HeaderInfo +import GHC.Iface.Utils +import GHC.Driver.Make +import UniqDSet +import PrelNames +import BasicTypes hiding (SuccessFlag(..)) +import GHC.Driver.Finder +import Util + +import qualified GHC.LanguageExtensions as LangExt + +import Panic +import Data.List ( partition ) +import System.Exit +import Control.Monad +import System.FilePath +import Data.Version + +-- for the unification +import Data.IORef +import Data.Map (Map) +import qualified Data.Map as Map + +-- | Entry point to compile a Backpack file. +doBackpack :: [FilePath] -> Ghc () +doBackpack [src_filename] = do + -- Apply options from file to dflags + dflags0 <- getDynFlags + let dflags1 = dflags0 + src_opts <- liftIO $ getOptionsFromFile dflags1 src_filename + (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts + modifySession (\hsc_env -> hsc_env {hsc_dflags = dflags}) + -- Cribbed from: preprocessFile / GHC.Driver.Pipeline + liftIO $ checkProcessArgsResult dflags unhandled_flags + liftIO $ handleFlagWarnings dflags warns + -- TODO: Preprocessing not implemented + + buf <- liftIO $ hGetStringBuffer src_filename + let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great + case unP parseBackpack (mkPState dflags buf loc) of + PFailed pst -> throwErrors (getErrorMessages pst dflags) + POk _ pkgname_bkp -> do + -- OK, so we have an LHsUnit PackageName, but we want an + -- LHsUnit HsComponentId. So let's rename it. + let bkp = renameHsUnits dflags (packageNameMap pkgname_bkp) pkgname_bkp + initBkpM src_filename bkp $ + forM_ (zip [1..] bkp) $ \(i, lunit) -> do + let comp_name = unLoc (hsunitName (unLoc lunit)) + msgTopPackage (i,length bkp) comp_name + innerBkpM $ do + let (cid, insts) = computeUnitId lunit + if null insts + then if cid == ComponentId (fsLit "main") + then compileExe lunit + else compileUnit cid [] + else typecheckUnit cid insts +doBackpack _ = + throwGhcException (CmdLineError "--backpack can only process a single file") + +computeUnitId :: LHsUnit HsComponentId -> (ComponentId, [(ModuleName, Module)]) +computeUnitId (L _ unit) = (cid, [ (r, mkHoleModule r) | r <- reqs ]) + where + cid = hsComponentId (unLoc (hsunitName unit)) + reqs = uniqDSetToList (unionManyUniqDSets (map (get_reqs . unLoc) (hsunitBody unit))) + get_reqs (DeclD HsigFile (L _ modname) _) = unitUniqDSet modname + get_reqs (DeclD HsSrcFile _ _) = emptyUniqDSet + get_reqs (DeclD HsBootFile _ _) = emptyUniqDSet + get_reqs (IncludeD (IncludeDecl (L _ hsuid) _ _)) = + unitIdFreeHoles (convertHsUnitId hsuid) + +-- | Tiny enum for all types of Backpack operations we may do. +data SessionType + -- | A compilation operation which will result in a + -- runnable executable being produced. + = ExeSession + -- | A type-checking operation which produces only + -- interface files, no object files. + | TcSession + -- | A compilation operation which produces both + -- interface files and object files. + | CompSession + deriving (Eq) + +-- | Create a temporary Session to do some sort of type checking or +-- compilation. +withBkpSession :: ComponentId + -> [(ModuleName, Module)] + -> [(UnitId, ModRenaming)] + -> SessionType -- what kind of session are we doing + -> BkpM a -- actual action to run + -> BkpM a +withBkpSession cid insts deps session_type do_this = do + dflags <- getDynFlags + let (ComponentId cid_fs) = cid + is_primary = False + uid_str = unpackFS (hashUnitId cid insts) + cid_str = unpackFS cid_fs + -- There are multiple units in a single Backpack file, so we + -- need to separate out the results in those cases. Right now, + -- we follow this hierarchy: + -- $outputdir/$compid --> typecheck results + -- $outputdir/$compid/$unitid --> compile results + key_base p | Just f <- p dflags = f + | otherwise = "." + sub_comp p | is_primary = p + | otherwise = p </> cid_str + outdir p | CompSession <- session_type + -- Special case when package is definite + , not (null insts) = sub_comp (key_base p) </> uid_str + | otherwise = sub_comp (key_base p) + withTempSession (overHscDynFlags (\dflags -> + -- If we're type-checking an indefinite package, we want to + -- turn on interface writing. However, if the user also + -- explicitly passed in `-fno-code`, we DON'T want to write + -- interfaces unless the user also asked for `-fwrite-interface`. + -- See Note [-fno-code mode] + (case session_type of + -- Make sure to write interfaces when we are type-checking + -- indefinite packages. + TcSession | hscTarget dflags /= HscNothing + -> flip gopt_set Opt_WriteInterface + | otherwise -> id + CompSession -> id + ExeSession -> id) $ + dflags { + hscTarget = case session_type of + TcSession -> HscNothing + _ -> hscTarget dflags, + thisUnitIdInsts_ = Just insts, + thisComponentId_ = Just cid, + thisInstalledUnitId = + case session_type of + TcSession -> newInstalledUnitId cid Nothing + -- No hash passed if no instances + _ | null insts -> newInstalledUnitId cid Nothing + | otherwise -> newInstalledUnitId cid (Just (hashUnitId cid insts)), + -- Setup all of the output directories according to our hierarchy + objectDir = Just (outdir objectDir), + hiDir = Just (outdir hiDir), + stubDir = Just (outdir stubDir), + -- Unset output-file for non exe builds + outputFile = if session_type == ExeSession + then outputFile dflags + else Nothing, + -- Clear the import path so we don't accidentally grab anything + importPaths = [], + -- Synthesized the flags + packageFlags = packageFlags dflags ++ map (\(uid0, rn) -> + let uid = unwireUnitId dflags (improveUnitId (getUnitInfoMap dflags) $ renameHoleUnitId dflags (listToUFM insts) uid0) + in ExposePackage + (showSDoc dflags + (text "-unit-id" <+> ppr uid <+> ppr rn)) + (UnitIdArg uid) rn) deps + } )) $ do + dflags <- getSessionDynFlags + -- pprTrace "flags" (ppr insts <> ppr deps) $ return () + -- Calls initPackages + _ <- setSessionDynFlags dflags + do_this + +withBkpExeSession :: [(UnitId, ModRenaming)] -> BkpM a -> BkpM a +withBkpExeSession deps do_this = do + withBkpSession (ComponentId (fsLit "main")) [] deps ExeSession do_this + +getSource :: ComponentId -> BkpM (LHsUnit HsComponentId) +getSource cid = do + bkp_env <- getBkpEnv + case Map.lookup cid (bkp_table bkp_env) of + Nothing -> pprPanic "missing needed dependency" (ppr cid) + Just lunit -> return lunit + +typecheckUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM () +typecheckUnit cid insts = do + lunit <- getSource cid + buildUnit TcSession cid insts lunit + +compileUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM () +compileUnit cid insts = do + -- Let everyone know we're building this unit ID + msgUnitId (newUnitId cid insts) + lunit <- getSource cid + buildUnit CompSession cid insts lunit + +-- | Compute the dependencies with instantiations of a syntactic +-- HsUnit; e.g., wherever you see @dependency p[A=<A>]@ in a +-- unit file, return the 'UnitId' corresponding to @p[A=<A>]@. +-- The @include_sigs@ parameter controls whether or not we also +-- include @dependency signature@ declarations in this calculation. +-- +-- Invariant: this NEVER returns InstalledUnitId. +hsunitDeps :: Bool {- include sigs -} -> HsUnit HsComponentId -> [(UnitId, ModRenaming)] +hsunitDeps include_sigs unit = concatMap get_dep (hsunitBody unit) + where + get_dep (L _ (IncludeD (IncludeDecl (L _ hsuid) mb_lrn is_sig))) + | include_sigs || not is_sig = [(convertHsUnitId hsuid, go mb_lrn)] + | otherwise = [] + where + go Nothing = ModRenaming True [] + go (Just lrns) = ModRenaming False (map convRn lrns) + where + convRn (L _ (Renaming (L _ from) Nothing)) = (from, from) + convRn (L _ (Renaming (L _ from) (Just (L _ to)))) = (from, to) + get_dep _ = [] + +buildUnit :: SessionType -> ComponentId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM () +buildUnit session cid insts lunit = do + -- NB: include signature dependencies ONLY when typechecking. + -- If we're compiling, it's not necessary to recursively + -- compile a signature since it isn't going to produce + -- any object files. + let deps_w_rns = hsunitDeps (session == TcSession) (unLoc lunit) + raw_deps = map fst deps_w_rns + dflags <- getDynFlags + -- The compilation dependencies are just the appropriately filled + -- in unit IDs which must be compiled before we can compile. + let hsubst = listToUFM insts + deps0 = map (renameHoleUnitId dflags hsubst) raw_deps + + -- Build dependencies OR make sure they make sense. BUT NOTE, + -- we can only check the ones that are fully filled; the rest + -- we have to defer until we've typechecked our local signature. + -- TODO: work this into GHC.Driver.Make!! + forM_ (zip [1..] deps0) $ \(i, dep) -> + case session of + TcSession -> return () + _ -> compileInclude (length deps0) (i, dep) + + dflags <- getDynFlags + -- IMPROVE IT + let deps = map (improveUnitId (getUnitInfoMap dflags)) deps0 + + mb_old_eps <- case session of + TcSession -> fmap Just getEpsGhc + _ -> return Nothing + + conf <- withBkpSession cid insts deps_w_rns session $ do + + dflags <- getDynFlags + mod_graph <- hsunitModuleGraph dflags (unLoc lunit) + -- pprTrace "mod_graph" (ppr mod_graph) $ return () + + msg <- mkBackpackMsg + ok <- load' LoadAllTargets (Just msg) mod_graph + when (failed ok) (liftIO $ exitWith (ExitFailure 1)) + + let hi_dir = expectJust (panic "hiDir Backpack") $ hiDir dflags + export_mod ms = (ms_mod_name ms, ms_mod ms) + -- Export everything! + mods = [ export_mod ms | ms <- mgModSummaries mod_graph + , ms_hsc_src ms == HsSrcFile ] + + -- Compile relevant only + hsc_env <- getSession + let home_mod_infos = eltsUDFM (hsc_HPT hsc_env) + linkables = map (expectJust "bkp link" . hm_linkable) + . filter ((==HsSrcFile) . mi_hsc_src . hm_iface) + $ home_mod_infos + getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) + obj_files = concatMap getOfiles linkables + + let compat_fs = (case cid of ComponentId fs -> fs) + compat_pn = PackageName compat_fs + + return InstalledPackageInfo { + -- Stub data + abiHash = "", + sourcePackageId = SourcePackageId compat_fs, + packageName = compat_pn, + packageVersion = makeVersion [0], + unitId = toInstalledUnitId (thisPackage dflags), + sourceLibName = Nothing, + componentId = cid, + instantiatedWith = insts, + -- Slight inefficiency here haha + exposedModules = map (\(m,n) -> (m,Just n)) mods, + hiddenModules = [], -- TODO: doc only + depends = case session of + -- Technically, we should state that we depend + -- on all the indefinite libraries we used to + -- typecheck this. However, this field isn't + -- really used for anything, so we leave it + -- blank for now. + TcSession -> [] + _ -> map (toInstalledUnitId . unwireUnitId dflags) + $ deps ++ [ moduleUnitId mod + | (_, mod) <- insts + , not (isHoleModule mod) ], + abiDepends = [], + ldOptions = case session of + TcSession -> [] + _ -> obj_files, + importDirs = [ hi_dir ], + exposed = False, + indefinite = case session of + TcSession -> True + _ -> False, + -- nope + hsLibraries = [], + extraLibraries = [], + extraGHCiLibraries = [], + libraryDynDirs = [], + libraryDirs = [], + frameworks = [], + frameworkDirs = [], + ccOptions = [], + includes = [], + includeDirs = [], + haddockInterfaces = [], + haddockHTMLs = [], + trusted = False + } + + + addPackage conf + case mb_old_eps of + Just old_eps -> updateEpsGhc_ (const old_eps) + _ -> return () + +compileExe :: LHsUnit HsComponentId -> BkpM () +compileExe lunit = do + msgUnitId mainUnitId + let deps_w_rns = hsunitDeps False (unLoc lunit) + deps = map fst deps_w_rns + -- no renaming necessary + forM_ (zip [1..] deps) $ \(i, dep) -> + compileInclude (length deps) (i, dep) + withBkpExeSession deps_w_rns $ do + dflags <- getDynFlags + mod_graph <- hsunitModuleGraph dflags (unLoc lunit) + msg <- mkBackpackMsg + ok <- load' LoadAllTargets (Just msg) mod_graph + when (failed ok) (liftIO $ exitWith (ExitFailure 1)) + +-- | Register a new virtual package database containing a single unit +addPackage :: GhcMonad m => UnitInfo -> m () +addPackage pkg = do + dflags <- GHC.getSessionDynFlags + case pkgDatabase dflags of + Nothing -> panic "addPackage: called too early" + Just dbs -> do + let newdb = PackageDatabase + { packageDatabasePath = "(in memory " ++ showSDoc dflags (ppr (unitId pkg)) ++ ")" + , packageDatabaseUnits = [pkg] + } + _ <- GHC.setSessionDynFlags (dflags { pkgDatabase = Just (dbs ++ [newdb]) }) + return () + +-- Precondition: UnitId is NOT InstalledUnitId +compileInclude :: Int -> (Int, UnitId) -> BkpM () +compileInclude n (i, uid) = do + hsc_env <- getSession + let dflags = hsc_dflags hsc_env + msgInclude (i, n) uid + -- Check if we've compiled it already + case lookupUnit dflags uid of + Nothing -> do + case splitUnitIdInsts uid of + (_, Just indef) -> + innerBkpM $ compileUnit (indefUnitIdComponentId indef) + (indefUnitIdInsts indef) + _ -> return () + Just _ -> return () + +-- ---------------------------------------------------------------------------- +-- Backpack monad + +-- | Backpack monad is a 'GhcMonad' which also maintains a little extra state +-- beyond the 'Session', c.f. 'BkpEnv'. +type BkpM = IOEnv BkpEnv + +-- | Backpack environment. NB: this has a 'Session' and not an 'HscEnv', +-- because we are going to update the 'HscEnv' as we go. +data BkpEnv + = BkpEnv { + -- | The session + bkp_session :: Session, + -- | The filename of the bkp file we're compiling + bkp_filename :: FilePath, + -- | Table of source units which we know how to compile + bkp_table :: Map ComponentId (LHsUnit HsComponentId), + -- | When a package we are compiling includes another package + -- which has not been compiled, we bump the level and compile + -- that. + bkp_level :: Int + } + +-- Blah, to get rid of the default instance for IOEnv +-- TODO: just make a proper new monad for BkpM, rather than use IOEnv +instance {-# OVERLAPPING #-} HasDynFlags BkpM where + getDynFlags = fmap hsc_dflags getSession + +instance GhcMonad BkpM where + getSession = do + Session s <- fmap bkp_session getEnv + readMutVar s + setSession hsc_env = do + Session s <- fmap bkp_session getEnv + writeMutVar s hsc_env + +-- | Get the current 'BkpEnv'. +getBkpEnv :: BkpM BkpEnv +getBkpEnv = getEnv + +-- | Get the nesting level, when recursively compiling modules. +getBkpLevel :: BkpM Int +getBkpLevel = bkp_level `fmap` getBkpEnv + +-- | Apply a function on 'DynFlags' on an 'HscEnv' +overHscDynFlags :: (DynFlags -> DynFlags) -> HscEnv -> HscEnv +overHscDynFlags f hsc_env = hsc_env { hsc_dflags = f (hsc_dflags hsc_env) } + +-- | Run a 'BkpM' computation, with the nesting level bumped one. +innerBkpM :: BkpM a -> BkpM a +innerBkpM do_this = do + -- NB: withTempSession mutates, so we don't have to worry + -- about bkp_session being stale. + updEnv (\env -> env { bkp_level = bkp_level env + 1 }) do_this + +-- | Update the EPS from a 'GhcMonad'. TODO move to appropriate library spot. +updateEpsGhc_ :: GhcMonad m => (ExternalPackageState -> ExternalPackageState) -> m () +updateEpsGhc_ f = do + hsc_env <- getSession + liftIO $ atomicModifyIORef' (hsc_EPS hsc_env) (\x -> (f x, ())) + +-- | Get the EPS from a 'GhcMonad'. +getEpsGhc :: GhcMonad m => m ExternalPackageState +getEpsGhc = do + hsc_env <- getSession + liftIO $ readIORef (hsc_EPS hsc_env) + +-- | Run 'BkpM' in 'Ghc'. +initBkpM :: FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a +initBkpM file bkp m = do + reifyGhc $ \session -> do + let env = BkpEnv { + bkp_session = session, + bkp_table = Map.fromList [(hsComponentId (unLoc (hsunitName (unLoc u))), u) | u <- bkp], + bkp_filename = file, + bkp_level = 0 + } + runIOEnv env m + +-- ---------------------------------------------------------------------------- +-- Messaging + +-- | Print a compilation progress message, but with indentation according +-- to @level@ (for nested compilation). +backpackProgressMsg :: Int -> DynFlags -> String -> IO () +backpackProgressMsg level dflags msg = + compilationProgressMsg dflags $ replicate (level * 2) ' ' ++ msg + +-- | Creates a 'Messager' for Backpack compilation; this is basically +-- a carbon copy of 'batchMsg' but calling 'backpackProgressMsg', which +-- handles indentation. +mkBackpackMsg :: BkpM Messager +mkBackpackMsg = do + level <- getBkpLevel + return $ \hsc_env mod_index recomp mod_summary -> + let dflags = hsc_dflags hsc_env + showMsg msg reason = + backpackProgressMsg level dflags $ + showModuleIndex mod_index ++ + msg ++ showModMsg dflags (hscTarget dflags) + (recompileRequired recomp) mod_summary + ++ reason + in case recomp of + MustCompile -> showMsg "Compiling " "" + UpToDate + | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " "" + | otherwise -> return () + RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]") + +-- | 'PprStyle' for Backpack messages; here we usually want the module to +-- be qualified (so we can tell how it was instantiated.) But we try not +-- to qualify packages so we can use simple names for them. +backpackStyle :: DynFlags -> PprStyle +backpackStyle dflags = + mkUserStyle dflags + (QueryQualify neverQualifyNames + alwaysQualifyModules + neverQualifyPackages) AllTheWay + +-- | Message when we initially process a Backpack unit. +msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM () +msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do + dflags <- getDynFlags + level <- getBkpLevel + liftIO . backpackProgressMsg level dflags + $ showModuleIndex (i, n) ++ "Processing " ++ unpackFS fs_pn + +-- | Message when we instantiate a Backpack unit. +msgUnitId :: UnitId -> BkpM () +msgUnitId pk = do + dflags <- getDynFlags + level <- getBkpLevel + liftIO . backpackProgressMsg level dflags + $ "Instantiating " ++ renderWithStyle + (initSDocContext dflags (backpackStyle dflags)) + (ppr pk) + +-- | Message when we include a Backpack unit. +msgInclude :: (Int,Int) -> UnitId -> BkpM () +msgInclude (i,n) uid = do + dflags <- getDynFlags + level <- getBkpLevel + liftIO . backpackProgressMsg level dflags + $ showModuleIndex (i, n) ++ "Including " ++ + renderWithStyle (initSDocContext dflags (backpackStyle dflags)) + (ppr uid) + +-- ---------------------------------------------------------------------------- +-- Conversion from PackageName to HsComponentId + +type PackageNameMap a = Map PackageName a + +-- For now, something really simple, since we're not actually going +-- to use this for anything +unitDefines :: LHsUnit PackageName -> (PackageName, HsComponentId) +unitDefines (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) }) + = (pn, HsComponentId pn (ComponentId fs)) + +packageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId +packageNameMap units = Map.fromList (map unitDefines units) + +renameHsUnits :: DynFlags -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId] +renameHsUnits dflags m units = map (fmap renameHsUnit) units + where + + renamePackageName :: PackageName -> HsComponentId + renamePackageName pn = + case Map.lookup pn m of + Nothing -> + case lookupPackageName dflags pn of + Nothing -> error "no package name" + Just cid -> HsComponentId pn cid + Just hscid -> hscid + + renameHsUnit :: HsUnit PackageName -> HsUnit HsComponentId + renameHsUnit u = + HsUnit { + hsunitName = fmap renamePackageName (hsunitName u), + hsunitBody = map (fmap renameHsUnitDecl) (hsunitBody u) + } + + renameHsUnitDecl :: HsUnitDecl PackageName -> HsUnitDecl HsComponentId + renameHsUnitDecl (DeclD a b c) = DeclD a b c + renameHsUnitDecl (IncludeD idecl) = + IncludeD IncludeDecl { + idUnitId = fmap renameHsUnitId (idUnitId idecl), + idModRenaming = idModRenaming idecl, + idSignatureInclude = idSignatureInclude idecl + } + + renameHsUnitId :: HsUnitId PackageName -> HsUnitId HsComponentId + renameHsUnitId (HsUnitId ln subst) + = HsUnitId (fmap renamePackageName ln) (map (fmap renameHsModuleSubst) subst) + + renameHsModuleSubst :: HsModuleSubst PackageName -> HsModuleSubst HsComponentId + renameHsModuleSubst (lk, lm) + = (lk, fmap renameHsModuleId lm) + + renameHsModuleId :: HsModuleId PackageName -> HsModuleId HsComponentId + renameHsModuleId (HsModuleVar lm) = HsModuleVar lm + renameHsModuleId (HsModuleId luid lm) = HsModuleId (fmap renameHsUnitId luid) lm + +convertHsUnitId :: HsUnitId HsComponentId -> UnitId +convertHsUnitId (HsUnitId (L _ hscid) subst) + = newUnitId (hsComponentId hscid) (map (convertHsModuleSubst . unLoc) subst) + +convertHsModuleSubst :: HsModuleSubst HsComponentId -> (ModuleName, Module) +convertHsModuleSubst (L _ modname, L _ m) = (modname, convertHsModuleId m) + +convertHsModuleId :: HsModuleId HsComponentId -> Module +convertHsModuleId (HsModuleVar (L _ modname)) = mkHoleModule modname +convertHsModuleId (HsModuleId (L _ hsuid) (L _ modname)) = mkModule (convertHsUnitId hsuid) modname + + + +{- +************************************************************************ +* * + Module graph construction +* * +************************************************************************ +-} + +-- | This is our version of GHC.Driver.Make.downsweep, but with a few modifications: +-- +-- 1. Every module is required to be mentioned, so we don't do any funny +-- business with targets or recursively grabbing dependencies. (We +-- could support this in principle). +-- 2. We support inline modules, whose summary we have to synthesize ourself. +-- +-- We don't bother trying to support GHC.Driver.Make for now, it's more trouble +-- than it's worth for inline modules. +hsunitModuleGraph :: DynFlags -> HsUnit HsComponentId -> BkpM ModuleGraph +hsunitModuleGraph dflags unit = do + let decls = hsunitBody unit + pn = hsPackageName (unLoc (hsunitName unit)) + + -- 1. Create a HsSrcFile/HsigFile summary for every + -- explicitly mentioned module/signature. + let get_decl (L _ (DeclD hsc_src lmodname mb_hsmod)) = do + Just `fmap` summariseDecl pn hsc_src lmodname mb_hsmod + get_decl _ = return Nothing + nodes <- catMaybes `fmap` mapM get_decl decls + + -- 2. For each hole which does not already have an hsig file, + -- create an "empty" hsig file to induce compilation for the + -- requirement. + let node_map = Map.fromList [ ((ms_mod_name n, ms_hsc_src n == HsigFile), n) + | n <- nodes ] + req_nodes <- fmap catMaybes . forM (thisUnitIdInsts dflags) $ \(mod_name, _) -> + let has_local = Map.member (mod_name, True) node_map + in if has_local + then return Nothing + else fmap Just $ summariseRequirement pn mod_name + + -- 3. Return the kaboodle + return $ mkModuleGraph $ nodes ++ req_nodes + +summariseRequirement :: PackageName -> ModuleName -> BkpM ModSummary +summariseRequirement pn mod_name = do + hsc_env <- getSession + let dflags = hsc_dflags hsc_env + + let PackageName pn_fs = pn + location <- liftIO $ mkHomeModLocation2 dflags mod_name + (unpackFS pn_fs </> moduleNameSlashes mod_name) "hsig" + + env <- getBkpEnv + time <- liftIO $ getModificationUTCTime (bkp_filename env) + hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location) + hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location) + let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1) + + mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location + + extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name + + return ModSummary { + ms_mod = mod, + ms_hsc_src = HsigFile, + ms_location = location, + ms_hs_date = time, + ms_obj_date = Nothing, + ms_iface_date = hi_timestamp, + ms_hie_date = hie_timestamp, + ms_srcimps = [], + ms_textual_imps = extra_sig_imports, + ms_parsed_mod = Just (HsParsedModule { + hpm_module = L loc (HsModule { + hsmodName = Just (L loc mod_name), + hsmodExports = Nothing, + hsmodImports = [], + hsmodDecls = [], + hsmodDeprecMessage = Nothing, + hsmodHaddockModHeader = Nothing + }), + hpm_src_files = [], + hpm_annotations = ApiAnns Map.empty Nothing Map.empty [] + }), + ms_hspp_file = "", -- none, it came inline + ms_hspp_opts = dflags, + ms_hspp_buf = Nothing + } + +summariseDecl :: PackageName + -> HscSource + -> Located ModuleName + -> Maybe (Located HsModule) + -> BkpM ModSummary +summariseDecl pn hsc_src (L _ modname) (Just hsmod) = hsModuleToModSummary pn hsc_src modname hsmod +summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing + = do hsc_env <- getSession + let dflags = hsc_dflags hsc_env + -- TODO: this looks for modules in the wrong place + r <- liftIO $ summariseModule hsc_env + Map.empty -- GHC API recomp not supported + (hscSourceToIsBoot hsc_src) + lmodname + True -- Target lets you disallow, but not here + Nothing -- GHC API buffer support not supported + [] -- No exclusions + case r of + Nothing -> throwOneError (mkPlainErrMsg dflags loc (text "module" <+> ppr modname <+> text "was not found")) + Just (Left err) -> throwErrors err + Just (Right summary) -> return summary + +-- | Up until now, GHC has assumed a single compilation target per source file. +-- Backpack files with inline modules break this model, since a single file +-- may generate multiple output files. How do we decide to name these files? +-- Should there only be one output file? This function our current heuristic, +-- which is we make a "fake" module and use that. +hsModuleToModSummary :: PackageName + -> HscSource + -> ModuleName + -> Located HsModule + -> BkpM ModSummary +hsModuleToModSummary pn hsc_src modname + hsmod = do + let imps = hsmodImports (unLoc hsmod) + loc = getLoc hsmod + hsc_env <- getSession + -- Sort of the same deal as in GHC.Driver.Pipeline's getLocation + -- Use the PACKAGE NAME to find the location + let PackageName unit_fs = pn + dflags = hsc_dflags hsc_env + -- Unfortunately, we have to define a "fake" location in + -- order to appease the various code which uses the file + -- name to figure out where to put, e.g. object files. + -- To add insult to injury, we don't even actually use + -- these filenames to figure out where the hi files go. + -- A travesty! + location0 <- liftIO $ mkHomeModLocation2 dflags modname + (unpackFS unit_fs </> + moduleNameSlashes modname) + (case hsc_src of + HsigFile -> "hsig" + HsBootFile -> "hs-boot" + HsSrcFile -> "hs") + -- DANGEROUS: bootifying can POISON the module finder cache + let location = case hsc_src of + HsBootFile -> addBootSuffixLocnOut location0 + _ -> location0 + -- This duplicates a pile of logic in GHC.Driver.Make + env <- getBkpEnv + time <- liftIO $ getModificationUTCTime (bkp_filename env) + hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location) + hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location) + + -- Also copied from 'getImports' + let (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps + + -- GHC.Prim doesn't exist physically, so don't go looking for it. + ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc) + ord_idecls + + implicit_prelude = xopt LangExt.ImplicitPrelude dflags + implicit_imports = mkPrelImports modname loc + implicit_prelude imps + convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i) + + extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname + + let normal_imports = map convImport (implicit_imports ++ ordinary_imps) + required_by_imports <- liftIO $ implicitRequirements hsc_env normal_imports + + -- So that Finder can find it, even though it doesn't exist... + this_mod <- liftIO $ addHomeModuleToFinder hsc_env modname location + return ModSummary { + ms_mod = this_mod, + ms_hsc_src = hsc_src, + ms_location = location, + ms_hspp_file = (case hiDir dflags of + Nothing -> "" + Just d -> d) </> ".." </> moduleNameSlashes modname <.> "hi", + ms_hspp_opts = dflags, + ms_hspp_buf = Nothing, + ms_srcimps = map convImport src_idecls, + ms_textual_imps = normal_imports + -- We have to do something special here: + -- due to merging, requirements may end up with + -- extra imports + ++ extra_sig_imports + ++ required_by_imports, + -- This is our hack to get the parse tree to the right spot + ms_parsed_mod = Just (HsParsedModule { + hpm_module = hsmod, + hpm_src_files = [], -- TODO if we preprocessed it + hpm_annotations = ApiAnns Map.empty Nothing Map.empty [] -- BOGUS + }), + ms_hs_date = time, + ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS + ms_iface_date = hi_timestamp, + ms_hie_date = hie_timestamp + } + +-- | Create a new, externally provided hashed unit id from +-- a hash. +newInstalledUnitId :: ComponentId -> Maybe FastString -> InstalledUnitId +newInstalledUnitId (ComponentId cid_fs) (Just fs) + = InstalledUnitId (cid_fs `appendFS` mkFastString "+" `appendFS` fs) +newInstalledUnitId (ComponentId cid_fs) Nothing + = InstalledUnitId cid_fs diff --git a/compiler/GHC/Driver/Backpack/Syntax.hs b/compiler/GHC/Driver/Backpack/Syntax.hs new file mode 100644 index 0000000000..709427ebd0 --- /dev/null +++ b/compiler/GHC/Driver/Backpack/Syntax.hs @@ -0,0 +1,83 @@ +-- | This is the syntax for bkp files which are parsed in 'ghc --backpack' +-- mode. This syntax is used purely for testing purposes. + +module GHC.Driver.Backpack.Syntax ( + -- * Backpack abstract syntax + HsUnitId(..), + LHsUnitId, + HsModuleSubst, + LHsModuleSubst, + HsModuleId(..), + LHsModuleId, + HsComponentId(..), + LHsUnit, HsUnit(..), + LHsUnitDecl, HsUnitDecl(..), + IncludeDecl(..), + LRenaming, Renaming(..), + ) where + +import GhcPrelude + +import GHC.Driver.Phases +import GHC.Hs +import SrcLoc +import Outputable +import Module +import UnitInfo + +{- +************************************************************************ +* * + User syntax +* * +************************************************************************ +-} + +data HsComponentId = HsComponentId { + hsPackageName :: PackageName, + hsComponentId :: ComponentId + } + +instance Outputable HsComponentId where + ppr (HsComponentId _pn cid) = ppr cid -- todo debug with pn + +data HsUnitId n = HsUnitId (Located n) [LHsModuleSubst n] +type LHsUnitId n = Located (HsUnitId n) + +type HsModuleSubst n = (Located ModuleName, LHsModuleId n) +type LHsModuleSubst n = Located (HsModuleSubst n) + +data HsModuleId n = HsModuleVar (Located ModuleName) + | HsModuleId (LHsUnitId n) (Located ModuleName) +type LHsModuleId n = Located (HsModuleId n) + +-- | Top level @unit@ declaration in a Backpack file. +data HsUnit n = HsUnit { + hsunitName :: Located n, + hsunitBody :: [LHsUnitDecl n] + } +type LHsUnit n = Located (HsUnit n) + +-- | A declaration in a package, e.g. a module or signature definition, +-- or an include. +data HsUnitDecl n + = DeclD HscSource (Located ModuleName) (Maybe (Located HsModule)) + | IncludeD (IncludeDecl n) +type LHsUnitDecl n = Located (HsUnitDecl n) + +-- | An include of another unit +data IncludeDecl n = IncludeDecl { + idUnitId :: LHsUnitId n, + idModRenaming :: Maybe [ LRenaming ], + -- | Is this a @dependency signature@ include? If so, + -- we don't compile this include when we instantiate this + -- unit (as there should not be any modules brought into + -- scope.) + idSignatureInclude :: Bool + } + +-- | Rename a module from one name to another. The identity renaming +-- means that the module should be brought into scope. +data Renaming = Renaming { renameFrom :: Located ModuleName + , renameTo :: Maybe (Located ModuleName) } +type LRenaming = Located Renaming diff --git a/compiler/GHC/Driver/CmdLine.hs b/compiler/GHC/Driver/CmdLine.hs new file mode 100644 index 0000000000..9b71e3d3fb --- /dev/null +++ b/compiler/GHC/Driver/CmdLine.hs @@ -0,0 +1,339 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} + +------------------------------------------------------------------------------- +-- +-- | Command-line parser +-- +-- This is an abstract command-line parser used by DynFlags. +-- +-- (c) The University of Glasgow 2005 +-- +------------------------------------------------------------------------------- + +module GHC.Driver.CmdLine + ( + processArgs, OptKind(..), GhcFlagMode(..), + CmdLineP(..), getCmdLineState, putCmdLineState, + Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag, + errorsToGhcException, + + Err(..), Warn(..), WarnReason(..), + + EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM, + deprecate + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Util +import Outputable +import Panic +import Bag +import SrcLoc +import Json + +import Data.Function +import Data.List + +import Control.Monad (liftM, ap) + +-------------------------------------------------------- +-- The Flag and OptKind types +-------------------------------------------------------- + +data Flag m = Flag + { flagName :: String, -- Flag, without the leading "-" + flagOptKind :: OptKind m, -- What to do if we see it + flagGhcMode :: GhcFlagMode -- Which modes this flag affects + } + +defFlag :: String -> OptKind m -> Flag m +defFlag name optKind = Flag name optKind AllModes + +defGhcFlag :: String -> OptKind m -> Flag m +defGhcFlag name optKind = Flag name optKind OnlyGhc + +defGhciFlag :: String -> OptKind m -> Flag m +defGhciFlag name optKind = Flag name optKind OnlyGhci + +defHiddenFlag :: String -> OptKind m -> Flag m +defHiddenFlag name optKind = Flag name optKind HiddenFlag + +-- | GHC flag modes describing when a flag has an effect. +data GhcFlagMode + = OnlyGhc -- ^ The flag only affects the non-interactive GHC + | OnlyGhci -- ^ The flag only affects the interactive GHC + | AllModes -- ^ The flag affects multiple ghc modes + | HiddenFlag -- ^ This flag should not be seen in cli completion + +data OptKind m -- Suppose the flag is -f + = NoArg (EwM m ()) -- -f all by itself + | HasArg (String -> EwM m ()) -- -farg or -f arg + | SepArg (String -> EwM m ()) -- -f arg + | Prefix (String -> EwM m ()) -- -farg + | OptPrefix (String -> EwM m ()) -- -f or -farg (i.e. the arg is optional) + | OptIntSuffix (Maybe Int -> EwM m ()) -- -f or -f=n; pass n to fn + | IntSuffix (Int -> EwM m ()) -- -f or -f=n; pass n to fn + | 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 + + +-------------------------------------------------------- +-- The EwM monad +-------------------------------------------------------- + +-- | Used when filtering warnings: if a reason is given +-- it can be filtered out when displaying. +data WarnReason + = NoReason + | ReasonDeprecatedFlag + | ReasonUnrecognisedFlag + deriving (Eq, Show) + +instance Outputable WarnReason where + ppr = text . show + +instance ToJson WarnReason where + json NoReason = JSNull + json reason = JSString $ show reason + +-- | A command-line error message +newtype Err = Err { errMsg :: Located String } + +-- | A command-line warning message and the reason it arose +data Warn = Warn + { warnReason :: WarnReason, + warnMsg :: Located String + } + +type Errs = Bag Err +type Warns = Bag Warn + +-- EwM ("errors and warnings monad") is a monad +-- transformer for m that adds an (err, warn) state +newtype EwM m a = EwM { unEwM :: Located String -- Current parse arg + -> Errs -> Warns + -> m (Errs, Warns, a) } + +instance Monad m => Functor (EwM m) where + fmap = liftM + +instance Monad m => Applicative (EwM m) where + pure v = EwM (\_ e w -> return (e, w, v)) + (<*>) = ap + +instance Monad m => Monad (EwM m) where + (EwM f) >>= k = EwM (\l e w -> do (e', w', r) <- f l e w + unEwM (k r) l e' w') + +runEwM :: EwM m a -> m (Errs, Warns, a) +runEwM action = unEwM action (panic "processArgs: no arg yet") emptyBag emptyBag + +setArg :: Located String -> EwM m () -> EwM m () +setArg l (EwM f) = EwM (\_ es ws -> f l es ws) + +addErr :: Monad m => String -> EwM m () +addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` Err (L loc e), ws, ())) + +addWarn :: Monad m => String -> EwM m () +addWarn = addFlagWarn NoReason + +addFlagWarn :: Monad m => WarnReason -> String -> EwM m () +addFlagWarn reason msg = EwM $ + (\(L loc _) es ws -> return (es, ws `snocBag` Warn reason (L loc msg), ())) + +deprecate :: Monad m => String -> EwM m () +deprecate s = do + arg <- getArg + addFlagWarn ReasonDeprecatedFlag (arg ++ " is deprecated: " ++ s) + +getArg :: Monad m => EwM m String +getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg)) + +getCurLoc :: Monad m => EwM m SrcSpan +getCurLoc = EwM (\(L loc _) es ws -> return (es, ws, loc)) + +liftEwM :: Monad m => m a -> EwM m a +liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) }) + + +-------------------------------------------------------- +-- A state monad for use in the command-line parser +-------------------------------------------------------- + +-- (CmdLineP s) typically instantiates the 'm' in (EwM m) and (OptKind m) +newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) } + deriving (Functor) + +instance Applicative (CmdLineP s) where + pure a = CmdLineP $ \s -> (a, s) + (<*>) = ap + +instance Monad (CmdLineP s) where + m >>= k = CmdLineP $ \s -> + let (a, s') = runCmdLine m s + in runCmdLine (k a) s' + + +getCmdLineState :: CmdLineP s s +getCmdLineState = CmdLineP $ \s -> (s,s) +putCmdLineState :: s -> CmdLineP s () +putCmdLineState s = CmdLineP $ \_ -> ((),s) + + +-------------------------------------------------------- +-- Processing arguments +-------------------------------------------------------- + +processArgs :: Monad m + => [Flag m] -- cmdline parser spec + -> [Located String] -- args + -> m ( [Located String], -- spare args + [Err], -- errors + [Warn] ) -- warnings +processArgs spec args = do + (errs, warns, spare) <- runEwM action + return (spare, bagToList errs, bagToList warns) + where + action = process args [] + + -- process :: [Located String] -> [Located String] -> EwM m [Located String] + process [] spare = return (reverse spare) + + process (locArg@(L _ ('-' : arg)) : args) spare = + case findArg spec arg of + Just (rest, opt_kind) -> + case processOneArg opt_kind rest arg args of + Left err -> + let b = process args spare + in (setArg locArg $ addErr err) >> b + + Right (action,rest) -> + let b = process rest spare + in (setArg locArg $ action) >> b + + Nothing -> process args (locArg : spare) + + process (arg : args) spare = process args (arg : spare) + + +processOneArg :: OptKind m -> String -> String -> [Located String] + -> Either String (EwM m (), [Located String]) +processOneArg opt_kind rest arg args + = let dash_arg = '-' : arg + rest_no_eq = dropEq rest + in case opt_kind of + NoArg a -> ASSERT(null rest) Right (a, args) + + HasArg f | notNull rest_no_eq -> Right (f rest_no_eq, args) + | otherwise -> case args of + [] -> missingArgErr dash_arg + (L _ arg1:args1) -> Right (f arg1, args1) + + -- See #9776 + SepArg f -> case args of + [] -> missingArgErr dash_arg + (L _ arg1:args1) -> Right (f arg1, args1) + + -- See #12625 + Prefix f | notNull rest_no_eq -> Right (f rest_no_eq, args) + | otherwise -> missingArgErr dash_arg + + PassFlag f | notNull rest -> unknownFlagErr dash_arg + | otherwise -> Right (f dash_arg, args) + + OptIntSuffix f | null rest -> Right (f Nothing, args) + | Just n <- parseInt rest_no_eq -> Right (f (Just n), args) + | otherwise -> Left ("malformed integer argument in " ++ dash_arg) + + IntSuffix f | Just n <- parseInt rest_no_eq -> Right (f n, args) + | otherwise -> Left ("malformed integer argument in " ++ dash_arg) + + FloatSuffix f | Just n <- parseFloat rest_no_eq -> Right (f n, args) + | otherwise -> Left ("malformed float argument in " ++ dash_arg) + + OptPrefix f -> Right (f rest_no_eq, args) + AnySuffix f -> Right (f dash_arg, args) + +findArg :: [Flag m] -> String -> Maybe (String, OptKind m) +findArg spec arg = + case sortBy (compare `on` (length . fst)) -- prefer longest matching flag + [ (removeSpaces rest, optKind) + | flag <- spec, + let optKind = flagOptKind flag, + Just rest <- [stripPrefix (flagName flag) arg], + arg_ok optKind rest arg ] + of + [] -> Nothing + (one:_) -> Just one + +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 _) _ _ = True -- Missing argument checked for in processOneArg t + -- to improve error message (#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 + +-- | Parse an Int +-- +-- Looks for "433" or "=342", with no trailing gubbins +-- * n or =n => Just n +-- * gibberish => Nothing +parseInt :: String -> Maybe Int +parseInt s = case reads s of + ((n,""):_) -> Just n + _ -> Nothing + +parseFloat :: String -> Maybe Float +parseFloat s = case reads s of + ((n,""):_) -> Just n + _ -> Nothing + +-- | Discards a leading equals sign +dropEq :: String -> String +dropEq ('=' : s) = s +dropEq s = s + +unknownFlagErr :: String -> Either String a +unknownFlagErr f = Left ("unrecognised flag: " ++ f) + +missingArgErr :: String -> Either String a +missingArgErr f = Left ("missing argument for flag: " ++ f) + +-------------------------------------------------------- +-- Utils +-------------------------------------------------------- + + +-- See Note [Handling errors when parsing flags] +errorsToGhcException :: [(String, -- Location + String)] -- Error + -> GhcException +errorsToGhcException errs = + UsageError $ intercalate "\n" $ [ l ++ ": " ++ e | (l, e) <- errs ] + +{- Note [Handling errors when parsing commandline flags] + +Parsing of static and mode flags happens before any session is started, i.e., +before the first call to 'GHC.withGhc'. Therefore, to report errors for +invalid usage of these two types of flags, we can not call any function that +needs DynFlags, as there are no DynFlags available yet (unsafeGlobalDynFlags +is not set either). So we always print "on the commandline" as the location, +which is true except for Api users, which is probably ok. + +When reporting errors for invalid usage of dynamic flags we /can/ make use of +DynFlags, and we do so explicitly in DynFlags.parseDynamicFlagsFull. + +Before, we called unsafeGlobalDynFlags when an invalid (combination of) +flag(s) was given on the commandline, resulting in panics (#9963). +-} diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs new file mode 100644 index 0000000000..e52d3216d5 --- /dev/null +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -0,0 +1,264 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + +\section{Code output phase} +-} + +{-# LANGUAGE CPP #-} + +module GHC.Driver.CodeOutput ( codeOutput, outputForeignStubs ) where + +#include "HsVersions.h" + +import GhcPrelude + +import AsmCodeGen ( nativeCodeGen ) +import GHC.CmmToLlvm ( llvmCodeGen ) + +import UniqSupply ( mkSplitUniqSupply ) + +import GHC.Driver.Finder ( mkStubPaths ) +import GHC.CmmToC ( writeC ) +import GHC.Cmm.Lint ( cmmLint ) +import GHC.Driver.Packages +import GHC.Cmm ( RawCmmGroup ) +import GHC.Driver.Types +import GHC.Driver.Session +import Stream ( Stream ) +import qualified Stream +import FileCleanup + +import ErrUtils +import Outputable +import Module +import SrcLoc + +import Control.Exception +import System.Directory +import System.FilePath +import System.IO + +{- +************************************************************************ +* * +\subsection{Steering} +* * +************************************************************************ +-} + +codeOutput :: DynFlags + -> Module + -> FilePath + -> ModLocation + -> ForeignStubs + -> [(ForeignSrcLang, FilePath)] + -- ^ additional files to be compiled with with the C compiler + -> [InstalledUnitId] + -> Stream IO RawCmmGroup a -- Compiled C-- + -> IO (FilePath, + (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}), + [(ForeignSrcLang, FilePath)]{-foreign_fps-}, + a) + +codeOutput dflags this_mod filenm location foreign_stubs foreign_fps pkg_deps + cmm_stream + = + do { + -- Lint each CmmGroup as it goes past + ; let linted_cmm_stream = + if gopt Opt_DoCmmLinting dflags + then Stream.mapM do_lint cmm_stream + else cmm_stream + + do_lint cmm = withTimingSilent + dflags + (text "CmmLint"<+>brackets (ppr this_mod)) + (const ()) $ do + { case cmmLint dflags cmm of + Just err -> do { log_action dflags + dflags + NoReason + SevDump + noSrcSpan + (defaultDumpStyle dflags) + err + ; ghcExit dflags 1 + } + Nothing -> return () + ; return cmm + } + + ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs + ; a <- case hscTarget dflags of + HscAsm -> outputAsm dflags this_mod location filenm + linted_cmm_stream + HscC -> outputC dflags filenm linted_cmm_stream pkg_deps + HscLlvm -> outputLlvm dflags filenm linted_cmm_stream + HscInterpreted -> panic "codeOutput: HscInterpreted" + HscNothing -> panic "codeOutput: HscNothing" + ; return (filenm, stubs_exist, foreign_fps, a) + } + +doOutput :: String -> (Handle -> IO a) -> IO a +doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action + +{- +************************************************************************ +* * +\subsection{C} +* * +************************************************************************ +-} + +outputC :: DynFlags + -> FilePath + -> Stream IO RawCmmGroup a + -> [InstalledUnitId] + -> IO a + +outputC dflags filenm cmm_stream packages + = do + withTiming dflags (text "C codegen") (\a -> seq a () {- FIXME -}) $ do + + -- figure out which header files to #include in the generated .hc file: + -- + -- * extra_includes from packages + -- * -#include options from the cmdline and OPTIONS pragmas + -- * the _stub.h file, if there is one. + -- + let rts = getPackageDetails dflags rtsUnitId + + let cc_injects = unlines (map mk_include (includes rts)) + mk_include h_file = + case h_file of + '"':_{-"-} -> "#include "++h_file + '<':_ -> "#include "++h_file + _ -> "#include \""++h_file++"\"" + + let pkg_names = map installedUnitIdString packages + + doOutput filenm $ \ h -> do + hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") + hPutStr h cc_injects + Stream.consume cmm_stream (writeC dflags h) + +{- +************************************************************************ +* * +\subsection{Assembler} +* * +************************************************************************ +-} + +outputAsm :: DynFlags -> Module -> ModLocation -> FilePath + -> Stream IO RawCmmGroup a + -> IO a +outputAsm dflags this_mod location filenm cmm_stream + | platformMisc_ghcWithNativeCodeGen $ platformMisc dflags + = do ncg_uniqs <- mkSplitUniqSupply 'n' + + debugTraceMsg dflags 4 (text "Outputing asm to" <+> text filenm) + + {-# SCC "OutputAsm" #-} doOutput filenm $ + \h -> {-# SCC "NativeCodeGen" #-} + nativeCodeGen dflags this_mod location h ncg_uniqs cmm_stream + + | otherwise + = panic "This compiler was built without a native code generator" + +{- +************************************************************************ +* * +\subsection{LLVM} +* * +************************************************************************ +-} + +outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a +outputLlvm dflags filenm cmm_stream + = do {-# SCC "llvm_output" #-} doOutput filenm $ + \f -> {-# SCC "llvm_CodeGen" #-} + llvmCodeGen dflags f cmm_stream + +{- +************************************************************************ +* * +\subsection{Foreign import/export} +* * +************************************************************************ +-} + +outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs + -> IO (Bool, -- Header file created + Maybe FilePath) -- C file created +outputForeignStubs dflags mod location stubs + = do + let stub_h = mkStubPaths dflags (moduleName mod) location + stub_c <- newTempName dflags TFL_CurrentModule "c" + + case stubs of + NoStubs -> + return (False, Nothing) + + ForeignStubs h_code c_code -> do + let + stub_c_output_d = pprCode CStyle c_code + stub_c_output_w = showSDoc dflags stub_c_output_d + + -- Header file protos for "foreign export"ed functions. + stub_h_output_d = pprCode CStyle h_code + stub_h_output_w = showSDoc dflags stub_h_output_d + + createDirectoryIfMissing True (takeDirectory stub_h) + + dumpIfSet_dyn dflags Opt_D_dump_foreign + "Foreign export header file" + FormatC + stub_h_output_d + + -- we need the #includes from the rts package for the stub files + let rts_includes = + let rts_pkg = getPackageDetails dflags rtsUnitId in + concatMap mk_include (includes rts_pkg) + mk_include i = "#include \"" ++ i ++ "\"\n" + + -- wrapper code mentions the ffi_arg type, which comes from ffi.h + ffi_includes + | platformMisc_libFFI $ platformMisc dflags = "#include <ffi.h>\n" + | otherwise = "" + + stub_h_file_exists + <- outputForeignStubs_help stub_h stub_h_output_w + ("#include <HsFFI.h>\n" ++ cplusplus_hdr) cplusplus_ftr + + dumpIfSet_dyn dflags Opt_D_dump_foreign + "Foreign export stubs" FormatC stub_c_output_d + + stub_c_file_exists + <- outputForeignStubs_help stub_c stub_c_output_w + ("#define IN_STG_CODE 0\n" ++ + "#include <Rts.h>\n" ++ + rts_includes ++ + ffi_includes ++ + cplusplus_hdr) + cplusplus_ftr + -- We're adding the default hc_header to the stub file, but this + -- isn't really HC code, so we need to define IN_STG_CODE==0 to + -- avoid the register variables etc. being enabled. + + return (stub_h_file_exists, if stub_c_file_exists + then Just stub_c + else Nothing ) + where + cplusplus_hdr = "#if defined(__cplusplus)\nextern \"C\" {\n#endif\n" + cplusplus_ftr = "#if defined(__cplusplus)\n}\n#endif\n" + + +-- Don't use doOutput for dumping the f. export stubs +-- since it is more than likely that the stubs file will +-- turn out to be empty, in which case no file should be created. +outputForeignStubs_help :: FilePath -> String -> String -> String -> IO Bool +outputForeignStubs_help _fname "" _header _footer = return False +outputForeignStubs_help fname doc_str header footer + = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n") + return True diff --git a/compiler/GHC/Driver/Finder.hs b/compiler/GHC/Driver/Finder.hs new file mode 100644 index 0000000000..c7c9c1af1f --- /dev/null +++ b/compiler/GHC/Driver/Finder.hs @@ -0,0 +1,844 @@ +{- +(c) The University of Glasgow, 2000-2006 + +\section[Finder]{Module Finder} +-} + +{-# LANGUAGE CPP #-} + +module GHC.Driver.Finder ( + flushFinderCaches, + FindResult(..), + findImportedModule, + findPluginModule, + findExactModule, + findHomeModule, + findExposedPackageModule, + mkHomeModLocation, + mkHomeModLocation2, + mkHiOnlyModLocation, + mkHiPath, + mkObjPath, + addHomeModuleToFinder, + uncacheModule, + mkStubPaths, + + findObjectLinkableMaybe, + findObjectLinkable, + + cannotFindModule, + cannotFindInterface, + + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Module +import GHC.Driver.Types +import GHC.Driver.Packages +import FastString +import Util +import PrelNames ( gHC_PRIM ) +import GHC.Driver.Session +import Outputable +import Maybes ( expectJust ) + +import Data.IORef ( IORef, readIORef, atomicModifyIORef' ) +import System.Directory +import System.FilePath +import Control.Monad +import Data.Time + + +type FileExt = String -- Filename extension +type BaseName = String -- Basename of file + +-- ----------------------------------------------------------------------------- +-- The Finder + +-- The Finder provides a thin filesystem abstraction to the rest of +-- the compiler. For a given module, it can tell you where the +-- source, interface, and object files for that module live. + +-- It does *not* know which particular package a module lives in. Use +-- Packages.lookupModuleInAllPackages for that. + +-- ----------------------------------------------------------------------------- +-- The finder's cache + +-- remove all the home modules from the cache; package modules are +-- assumed to not move around during a session. +flushFinderCaches :: HscEnv -> IO () +flushFinderCaches hsc_env = + atomicModifyIORef' fc_ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ()) + where + this_pkg = thisPackage (hsc_dflags hsc_env) + fc_ref = hsc_FC hsc_env + is_ext mod _ | not (installedModuleUnitId mod `installedUnitIdEq` this_pkg) = True + | otherwise = False + +addToFinderCache :: IORef FinderCache -> InstalledModule -> InstalledFindResult -> IO () +addToFinderCache ref key val = + atomicModifyIORef' ref $ \c -> (extendInstalledModuleEnv c key val, ()) + +removeFromFinderCache :: IORef FinderCache -> InstalledModule -> IO () +removeFromFinderCache ref key = + atomicModifyIORef' ref $ \c -> (delInstalledModuleEnv c key, ()) + +lookupFinderCache :: IORef FinderCache -> InstalledModule -> IO (Maybe InstalledFindResult) +lookupFinderCache ref key = do + c <- readIORef ref + return $! lookupInstalledModuleEnv c key + +-- ----------------------------------------------------------------------------- +-- The three external entry points + +-- | Locate a module that was imported by the user. We have the +-- module's name, and possibly a package name. Without a package +-- name, this function will use the search path and the known exposed +-- packages to find the module, if a package is specified then only +-- that package is searched for the module. + +findImportedModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult +findImportedModule hsc_env mod_name mb_pkg = + case mb_pkg of + Nothing -> unqual_import + Just pkg | pkg == fsLit "this" -> home_import -- "this" is special + | otherwise -> pkg_import + where + home_import = findHomeModule hsc_env mod_name + + pkg_import = findExposedPackageModule hsc_env mod_name mb_pkg + + unqual_import = home_import + `orIfNotFound` + findExposedPackageModule hsc_env mod_name Nothing + +-- | Locate a plugin module requested by the user, for a compiler +-- plugin. This consults the same set of exposed packages as +-- 'findImportedModule', unless @-hide-all-plugin-packages@ or +-- @-plugin-package@ are specified. +findPluginModule :: HscEnv -> ModuleName -> IO FindResult +findPluginModule hsc_env mod_name = + findHomeModule hsc_env mod_name + `orIfNotFound` + findExposedPluginPackageModule hsc_env mod_name + +-- | Locate a specific 'Module'. The purpose of this function is to +-- create a 'ModLocation' for a given 'Module', that is to find out +-- where the files associated with this module live. It is used when +-- reading the interface for a module mentioned by another interface, +-- for example (a "system import"). + +findExactModule :: HscEnv -> InstalledModule -> IO InstalledFindResult +findExactModule hsc_env mod = + let dflags = hsc_dflags hsc_env + in if installedModuleUnitId mod `installedUnitIdEq` thisPackage dflags + then findInstalledHomeModule hsc_env (installedModuleName mod) + else findPackageModule hsc_env mod + +-- ----------------------------------------------------------------------------- +-- Helpers + +-- | Given a monadic actions @this@ and @or_this@, first execute +-- @this@. If the returned 'FindResult' is successful, return +-- it; otherwise, execute @or_this@. If both failed, this function +-- also combines their failure messages in a reasonable way. +orIfNotFound :: Monad m => m FindResult -> m FindResult -> m FindResult +orIfNotFound this or_this = do + res <- this + case res of + NotFound { fr_paths = paths1, fr_mods_hidden = mh1 + , 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_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 + +-- | Helper function for 'findHomeModule': this function wraps an IO action +-- which would look up @mod_name@ in the file system (the home package), +-- and first consults the 'hsc_FC' cache to see if the lookup has already +-- been done. Otherwise, do the lookup (with the IO action) and save +-- the result in the finder cache and the module location cache (if it +-- was successful.) +homeSearchCache :: HscEnv -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult +homeSearchCache hsc_env mod_name do_this = do + let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name + modLocationCache hsc_env mod do_this + +findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString + -> IO FindResult +findExposedPackageModule hsc_env mod_name mb_pkg + = findLookupResult hsc_env + $ lookupModuleWithSuggestions + (hsc_dflags hsc_env) mod_name mb_pkg + +findExposedPluginPackageModule :: HscEnv -> ModuleName + -> IO FindResult +findExposedPluginPackageModule hsc_env mod_name + = findLookupResult hsc_env + $ lookupPluginModuleWithSuggestions + (hsc_dflags hsc_env) mod_name Nothing + +findLookupResult :: HscEnv -> LookupResult -> IO FindResult +findLookupResult hsc_env r = case r of + LookupFound m pkg_conf -> do + let im = fst (splitModuleInsts m) + r' <- findPackageModule_ hsc_env im pkg_conf + case r' of + -- TODO: ghc -M is unlikely to do the right thing + -- with just the location of the thing that was + -- instantiated; you probably also need all of the + -- implicit locations from the instances + InstalledFound loc _ -> return (Found loc m) + InstalledNoPackage _ -> return (NoPackage (moduleUnitId m)) + 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) + LookupHidden pkg_hiddens mod_hiddens -> + 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 +modLocationCache hsc_env mod do_this = do + m <- lookupFinderCache (hsc_FC hsc_env) mod + case m of + Just result -> return result + Nothing -> do + result <- do_this + addToFinderCache (hsc_FC hsc_env) mod result + return result + +mkHomeInstalledModule :: DynFlags -> ModuleName -> InstalledModule +mkHomeInstalledModule dflags mod_name = + let iuid = thisInstalledUnitId dflags + in InstalledModule iuid mod_name + +-- This returns a module because it's more convenient for users +addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module +addHomeModuleToFinder hsc_env mod_name loc = do + let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name + addToFinderCache (hsc_FC hsc_env) mod (InstalledFound loc mod) + return (mkModule (thisPackage (hsc_dflags hsc_env)) mod_name) + +uncacheModule :: HscEnv -> ModuleName -> IO () +uncacheModule hsc_env mod_name = do + let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name + removeFromFinderCache (hsc_FC hsc_env) mod + +-- ----------------------------------------------------------------------------- +-- The internal workers + +findHomeModule :: HscEnv -> ModuleName -> IO FindResult +findHomeModule hsc_env mod_name = do + r <- findInstalledHomeModule hsc_env mod_name + return $ case r of + InstalledFound loc _ -> Found loc (mkModule uid mod_name) + InstalledNoPackage _ -> NoPackage uid -- impossible + InstalledNotFound fps _ -> NotFound { + fr_paths = fps, + fr_pkg = Just uid, + fr_mods_hidden = [], + fr_pkgs_hidden = [], + fr_unusables = [], + fr_suggestions = [] + } + where + dflags = hsc_dflags hsc_env + uid = thisPackage dflags + +-- | Implements the search for a module name in the home package only. Calling +-- this function directly is usually *not* what you want; currently, it's used +-- as a building block for the following operations: +-- +-- 1. When you do a normal package lookup, we first check if the module +-- is available in the home module, before looking it up in the package +-- database. +-- +-- 2. When you have a package qualified import with package name "this", +-- we shortcut to the home module. +-- +-- 3. When we look up an exact 'Module', if the unit id associated with +-- the module is the current home module do a look up in the home module. +-- +-- 4. Some special-case code in GHCi (ToDo: Figure out why that needs to +-- call this.) +findInstalledHomeModule :: HscEnv -> ModuleName -> IO InstalledFindResult +findInstalledHomeModule hsc_env mod_name = + homeSearchCache hsc_env mod_name $ + let + dflags = hsc_dflags hsc_env + home_path = importPaths dflags + hisuf = hiSuf dflags + mod = mkHomeInstalledModule dflags mod_name + + source_exts = + [ ("hs", mkHomeModLocationSearched dflags mod_name "hs") + , ("lhs", mkHomeModLocationSearched dflags mod_name "lhs") + , ("hsig", mkHomeModLocationSearched dflags mod_name "hsig") + , ("lhsig", mkHomeModLocationSearched dflags mod_name "lhsig") + ] + + -- we use mkHomeModHiOnlyLocation instead of mkHiOnlyModLocation so that + -- when hiDir field is set in dflags, we know to look there (see #16500) + hi_exts = [ (hisuf, mkHomeModHiOnlyLocation dflags mod_name) + , (addBootSuffix hisuf, mkHomeModHiOnlyLocation dflags mod_name) + ] + + -- In compilation manager modes, we look for source files in the home + -- package because we can compile these automatically. In one-shot + -- compilation mode we look for .hi and .hi-boot files only. + exts | isOneShot (ghcMode dflags) = hi_exts + | otherwise = source_exts + in + + -- special case for GHC.Prim; we won't find it in the filesystem. + -- This is important only when compiling the base package (where GHC.Prim + -- is a home module). + if mod `installedModuleEq` gHC_PRIM + then return (InstalledFound (error "GHC.Prim ModLocation") mod) + else searchPathExts home_path mod exts + + +-- | Search for a module in external packages only. +findPackageModule :: HscEnv -> InstalledModule -> IO InstalledFindResult +findPackageModule hsc_env mod = do + let + dflags = hsc_dflags hsc_env + pkg_id = installedModuleUnitId mod + -- + case lookupInstalledPackage dflags pkg_id of + Nothing -> return (InstalledNoPackage pkg_id) + Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf + +-- | Look up the interface file associated with module @mod@. This function +-- requires a few invariants to be upheld: (1) the 'Module' in question must +-- be the module identifier of the *original* implementation of a module, +-- not a reexport (this invariant is upheld by @Packages.hs@) and (2) +-- the 'UnitInfo' must be consistent with the unit id in the 'Module'. +-- The redundancy is to avoid an extra lookup in the package state +-- for the appropriate config. +findPackageModule_ :: HscEnv -> InstalledModule -> UnitInfo -> IO InstalledFindResult +findPackageModule_ hsc_env mod pkg_conf = + ASSERT2( installedModuleUnitId mod == installedUnitInfoId pkg_conf, ppr (installedModuleUnitId mod) <+> ppr (installedUnitInfoId pkg_conf) ) + modLocationCache hsc_env mod $ + + -- special case for GHC.Prim; we won't find it in the filesystem. + if mod `installedModuleEq` gHC_PRIM + then return (InstalledFound (error "GHC.Prim ModLocation") mod) + else + + let + dflags = hsc_dflags hsc_env + tag = buildTag dflags + + -- hi-suffix for packages depends on the build tag. + package_hisuf | null tag = "hi" + | otherwise = tag ++ "_hi" + + mk_hi_loc = mkHiOnlyModLocation dflags package_hisuf + + import_dirs = importDirs pkg_conf + -- we never look for a .hi-boot file in an external package; + -- .hi-boot files only make sense for the home package. + in + case import_dirs of + [one] | MkDepend <- ghcMode dflags -> do + -- there's only one place that this .hi file can be, so + -- don't bother looking for it. + let basename = moduleNameSlashes (installedModuleName mod) + loc <- mk_hi_loc one basename + return (InstalledFound loc mod) + _otherwise -> + searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)] + +-- ----------------------------------------------------------------------------- +-- General path searching + +searchPathExts + :: [FilePath] -- paths to search + -> InstalledModule -- module name + -> [ ( + FileExt, -- suffix + FilePath -> BaseName -> IO ModLocation -- action + ) + ] + -> IO InstalledFindResult + +searchPathExts paths mod exts + = do result <- search to_search +{- + hPutStrLn stderr (showSDoc $ + vcat [text "Search" <+> ppr mod <+> sep (map (text. fst) exts) + , nest 2 (vcat (map text paths)) + , case result of + Succeeded (loc, p) -> text "Found" <+> ppr loc + Failed fs -> text "not found"]) +-} + return result + + where + basename = moduleNameSlashes (installedModuleName mod) + + to_search :: [(FilePath, IO ModLocation)] + to_search = [ (file, fn path basename) + | path <- paths, + (ext,fn) <- exts, + let base | path == "." = basename + | otherwise = path </> basename + file = base <.> ext + ] + + search [] = return (InstalledNotFound (map fst to_search) (Just (installedModuleUnitId mod))) + + search ((file, mk_result) : rest) = do + b <- doesFileExist file + if b + then do { loc <- mk_result; return (InstalledFound loc mod) } + else search rest + +mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt + -> FilePath -> BaseName -> IO ModLocation +mkHomeModLocationSearched dflags mod suff path basename = do + mkHomeModLocation2 dflags mod (path </> basename) suff + +-- ----------------------------------------------------------------------------- +-- Constructing a home module location + +-- This is where we construct the ModLocation for a module in the home +-- package, for which we have a source file. It is called from three +-- places: +-- +-- (a) Here in the finder, when we are searching for a module to import, +-- using the search path (-i option). +-- +-- (b) The compilation manager, when constructing the ModLocation for +-- a "root" module (a source file named explicitly on the command line +-- or in a :load command in GHCi). +-- +-- (c) The driver in one-shot mode, when we need to construct a +-- ModLocation for a source file named on the command-line. +-- +-- Parameters are: +-- +-- mod +-- The name of the module +-- +-- path +-- (a): The search path component where the source file was found. +-- (b) and (c): "." +-- +-- src_basename +-- (a): (moduleNameSlashes mod) +-- (b) and (c): The filename of the source file, minus its extension +-- +-- ext +-- The filename extension of the source file (usually "hs" or "lhs"). + +mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO ModLocation +mkHomeModLocation dflags mod src_filename = do + let (basename,extension) = splitExtension src_filename + mkHomeModLocation2 dflags mod basename extension + +mkHomeModLocation2 :: DynFlags + -> ModuleName + -> FilePath -- Of source module, without suffix + -> String -- Suffix + -> IO ModLocation +mkHomeModLocation2 dflags mod src_basename ext = do + let mod_basename = moduleNameSlashes mod + + obj_fn = mkObjPath dflags src_basename mod_basename + hi_fn = mkHiPath dflags src_basename mod_basename + hie_fn = mkHiePath dflags src_basename mod_basename + + return (ModLocation{ ml_hs_file = Just (src_basename <.> ext), + ml_hi_file = hi_fn, + ml_obj_file = obj_fn, + ml_hie_file = hie_fn }) + +mkHomeModHiOnlyLocation :: DynFlags + -> ModuleName + -> FilePath + -> BaseName + -> IO ModLocation +mkHomeModHiOnlyLocation dflags mod path basename = do + loc <- mkHomeModLocation2 dflags mod (path </> basename) "" + return loc { ml_hs_file = Nothing } + +mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String + -> IO ModLocation +mkHiOnlyModLocation dflags hisuf path basename + = do let full_basename = path </> basename + obj_fn = mkObjPath dflags full_basename basename + hie_fn = mkHiePath dflags full_basename basename + return ModLocation{ ml_hs_file = Nothing, + ml_hi_file = full_basename <.> hisuf, + -- Remove the .hi-boot suffix from + -- hi_file, if it had one. We always + -- want the name of the real .hi file + -- in the ml_hi_file field. + ml_obj_file = obj_fn, + ml_hie_file = hie_fn + } + +-- | Constructs the filename of a .o file for a given source file. +-- Does /not/ check whether the .o file exists +mkObjPath + :: DynFlags + -> FilePath -- the filename of the source file, minus the extension + -> String -- the module name with dots replaced by slashes + -> FilePath +mkObjPath dflags basename mod_basename = obj_basename <.> osuf + where + odir = objectDir dflags + osuf = objectSuf dflags + + obj_basename | Just dir <- odir = dir </> mod_basename + | otherwise = basename + + +-- | Constructs the filename of a .hi file for a given source file. +-- Does /not/ check whether the .hi file exists +mkHiPath + :: DynFlags + -> FilePath -- the filename of the source file, minus the extension + -> String -- the module name with dots replaced by slashes + -> FilePath +mkHiPath dflags basename mod_basename = hi_basename <.> hisuf + where + hidir = hiDir dflags + hisuf = hiSuf dflags + + hi_basename | Just dir <- hidir = dir </> mod_basename + | otherwise = basename + +-- | Constructs the filename of a .hie file for a given source file. +-- Does /not/ check whether the .hie file exists +mkHiePath + :: DynFlags + -> FilePath -- the filename of the source file, minus the extension + -> String -- the module name with dots replaced by slashes + -> FilePath +mkHiePath dflags basename mod_basename = hie_basename <.> hiesuf + where + hiedir = hieDir dflags + hiesuf = hieSuf dflags + + hie_basename | Just dir <- hiedir = dir </> mod_basename + | otherwise = basename + + + +-- ----------------------------------------------------------------------------- +-- Filenames of the stub files + +-- We don't have to store these in ModLocations, because they can be derived +-- from other available information, and they're only rarely needed. + +mkStubPaths + :: DynFlags + -> ModuleName + -> ModLocation + -> FilePath + +mkStubPaths dflags mod location + = let + stubdir = stubDir dflags + + mod_basename = moduleNameSlashes mod + src_basename = dropExtension $ expectJust "mkStubPaths" + (ml_hs_file location) + + stub_basename0 + | Just dir <- stubdir = dir </> mod_basename + | otherwise = src_basename + + stub_basename = stub_basename0 ++ "_stub" + in + stub_basename <.> "h" + +-- ----------------------------------------------------------------------------- +-- findLinkable isn't related to the other stuff in here, +-- but there's no other obvious place for it + +findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable) +findObjectLinkableMaybe mod locn + = do let obj_fn = ml_obj_file locn + maybe_obj_time <- modificationTimeIfExists obj_fn + case maybe_obj_time of + Nothing -> return Nothing + Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time) + +-- Make an object linkable when we know the object file exists, and we know +-- its modification time. +findObjectLinkable :: Module -> FilePath -> UTCTime -> IO Linkable +findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn]) + -- We used to look for _stub.o files here, but that was a bug (#706) + -- Now GHC merges the stub.o into the main .o (#3687) + +-- ----------------------------------------------------------------------------- +-- Error messages + +cannotFindModule :: DynFlags -> ModuleName -> FindResult -> SDoc +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") + (sLit "Ambiguous interface for") + +cantFindErr :: PtrString -> PtrString -> DynFlags -> ModuleName -> FindResult + -> SDoc +cantFindErr _ multiple_found _ mod_name (FoundMultiple mods) + | Just pkgs <- unambiguousPackages + = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( + sep [text "it was found in multiple packages:", + hsep (map ppr pkgs) ] + ) + | otherwise + = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( + vcat (map pprMod mods) + ) + where + unambiguousPackages = foldl' unambiguousPackage (Just []) mods + unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _) + = Just (moduleUnitId m : xs) + unambiguousPackage _ _ = Nothing + + 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)] + else [] ++ + map ((text "a reexport in package" <+>) + .ppr.packageConfigId) res ++ + if f then [text "a package flag"] else [] + ) + +cantFindErr cannot_find _ dflags mod_name find_result + = ptext cannot_find <+> quotes (ppr mod_name) + $$ more_info + where + more_info + = case find_result of + NoPackage pkg + -> text "no unit id matching" <+> quotes (ppr pkg) <+> + text "was found" + + NotFound { fr_paths = files, fr_pkg = mb_pkg + , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens + , 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 dflags + + | 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) $$ + vcat (map unusable unusables) $$ + tried_these files dflags + + _ -> panic "cantFindErr" + + build_tag = buildTag dflags + + not_found_in_package pkg files + | build_tag /= "" + = let + build = if build_tag == "p" then "profiling" + else "\"" ++ build_tag ++ "\"" + in + text "Perhaps you haven't installed the " <> text build <> + text " libraries for package " <> quotes (ppr pkg) <> char '?' $$ + 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 dflags + + pkg_hidden :: UnitId -> SDoc + pkg_hidden uid = + text "It is a member of the hidden package" + <+> quotes (ppr uid) + --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 $$ pkg_hidden_hint uid + pkg_hidden_hint uid + | gopt Opt_BuildingCabalPackage dflags + = let pkg = expectJust "pkg_hidden" (lookupUnit dflags uid) + in text "Perhaps you need to add" <+> + quotes (ppr (packageName pkg)) <+> + text "to the build-depends in your .cabal file." + | Just pkg <- lookupUnit dflags uid + = 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 + | otherwise = hang (text "Perhaps you meant") + 2 (vcat (map pp_sugg sugs)) + + -- NB: Prefer the *original* location, and then reexports, and then + -- package flags when making suggestions. ToDo: if the original package + -- 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 }) + | Just True <- e + = parens (text "from" <+> ppr (moduleUnitId mod)) + | f && moduleName mod == m + = parens (text "from" <+> ppr (moduleUnitId mod)) + | (pkg:_) <- res + = parens (text "from" <+> ppr (packageConfigId pkg) + <> comma <+> text "reexporting" <+> ppr mod) + | f + = parens (text "defined via package flags to be" + <+> ppr mod) + | 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 + = parens (text "needs flag -package-key" + <+> ppr (moduleUnitId mod)) + | (pkg:_) <- rhs + = parens (text "needs flag -package-id" + <+> ppr (packageConfigId pkg)) + | otherwise = Outputable.empty + +cantFindInstalledErr :: PtrString -> PtrString -> DynFlags -> ModuleName + -> InstalledFindResult -> SDoc +cantFindInstalledErr cannot_find _ dflags mod_name find_result + = ptext cannot_find <+> quotes (ppr mod_name) + $$ more_info + where + more_info + = case find_result of + InstalledNoPackage pkg + -> text "no unit id matching" <+> quotes (ppr pkg) <+> + text "was found" $$ looks_like_srcpkgid pkg + + InstalledNotFound files mb_pkg + | Just pkg <- mb_pkg, not (pkg `installedUnitIdEq` thisPackage dflags) + -> not_found_in_package pkg files + + | null files + -> text "It is not a module in the current program, or in any known package." + + | otherwise + -> tried_these files dflags + + _ -> panic "cantFindInstalledErr" + + build_tag = buildTag dflags + + looks_like_srcpkgid :: InstalledUnitId -> SDoc + looks_like_srcpkgid pk + -- Unsafely coerce a unit id FastString into a source package ID + -- FastString and see if it means anything. + | (pkg:pkgs) <- searchPackageId dflags (SourcePackageId (installedUnitIdFS pk)) + = parens (text "This unit ID looks like the source package ID;" $$ + text "the real unit ID is" <+> quotes (ftext (installedUnitIdFS (unitId pkg))) $$ + (if null pkgs then Outputable.empty + else text "and" <+> int (length pkgs) <+> text "other candidates")) + -- Todo: also check if it looks like a package name! + | otherwise = Outputable.empty + + not_found_in_package pkg files + | build_tag /= "" + = let + build = if build_tag == "p" then "profiling" + else "\"" ++ build_tag ++ "\"" + in + text "Perhaps you haven't installed the " <> text build <> + text " libraries for package " <> quotes (ppr pkg) <> char '?' $$ + 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 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/GHC/Driver/Hooks.hs b/compiler/GHC/Driver/Hooks.hs new file mode 100644 index 0000000000..027d8831b7 --- /dev/null +++ b/compiler/GHC/Driver/Hooks.hs @@ -0,0 +1,121 @@ +-- \section[Hooks]{Low level API hooks} + +-- NB: this module is SOURCE-imported by DynFlags, and should primarily +-- refer to *types*, rather than *code* + +{-# LANGUAGE CPP, RankNTypes #-} + +module GHC.Driver.Hooks + ( Hooks + , emptyHooks + , lookupHook + , getHooked + -- the hooks: + , dsForeignsHook + , tcForeignImportsHook + , tcForeignExportsHook + , hscFrontendHook + , hscCompileCoreExprHook + , ghcPrimIfaceHook + , runPhaseHook + , runMetaHook + , linkHook + , runRnSpliceHook + , getValueSafelyHook + , createIservProcessHook + , stgToCmmHook + , cmmToRawCmmHook + ) +where + +import GhcPrelude + +import GHC.Driver.Session +import GHC.Driver.Pipeline.Monad +import GHC.Driver.Types +import GHC.Hs.Decls +import GHC.Hs.Binds +import GHC.Hs.Expr +import OrdList +import TcRnTypes +import Bag +import RdrName +import Name +import Id +import CoreSyn +import GHCi.RemoteTypes +import SrcLoc +import Type +import System.Process +import BasicTypes +import Module +import TyCon +import CostCentre +import GHC.Stg.Syntax +import Stream +import GHC.Cmm +import GHC.Hs.Extension + +import Data.Maybe + +{- +************************************************************************ +* * +\subsection{Hooks} +* * +************************************************************************ +-} + +-- | Hooks can be used by GHC API clients to replace parts of +-- the compiler pipeline. If a hook is not installed, GHC +-- uses the default built-in behaviour + +emptyHooks :: Hooks +emptyHooks = Hooks + { dsForeignsHook = Nothing + , tcForeignImportsHook = Nothing + , tcForeignExportsHook = Nothing + , hscFrontendHook = Nothing + , hscCompileCoreExprHook = Nothing + , ghcPrimIfaceHook = Nothing + , runPhaseHook = Nothing + , runMetaHook = Nothing + , linkHook = Nothing + , runRnSpliceHook = Nothing + , getValueSafelyHook = Nothing + , createIservProcessHook = Nothing + , stgToCmmHook = Nothing + , cmmToRawCmmHook = Nothing + } + +data Hooks = Hooks + { dsForeignsHook :: Maybe ([LForeignDecl GhcTc] + -> DsM (ForeignStubs, OrdList (Id, CoreExpr))) + , tcForeignImportsHook :: Maybe ([LForeignDecl GhcRn] + -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)) + , tcForeignExportsHook :: Maybe ([LForeignDecl GhcRn] + -> TcM (LHsBinds GhcTcId, [LForeignDecl GhcTcId], Bag GlobalRdrElt)) + , hscFrontendHook :: Maybe (ModSummary -> Hsc FrontendResult) + , hscCompileCoreExprHook :: + Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue) + , ghcPrimIfaceHook :: Maybe ModIface + , runPhaseHook :: Maybe (PhasePlus -> FilePath -> DynFlags + -> CompPipeline (PhasePlus, FilePath)) + , runMetaHook :: Maybe (MetaHook TcM) + , linkHook :: Maybe (GhcLink -> DynFlags -> Bool + -> HomePackageTable -> IO SuccessFlag) + , runRnSpliceHook :: Maybe (HsSplice GhcRn -> RnM (HsSplice GhcRn)) + , getValueSafelyHook :: Maybe (HscEnv -> Name -> Type + -> IO (Maybe HValue)) + , createIservProcessHook :: Maybe (CreateProcess -> IO ProcessHandle) + , stgToCmmHook :: Maybe (DynFlags -> Module -> [TyCon] -> CollectedCCs + -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup ()) + , cmmToRawCmmHook :: forall a . Maybe (DynFlags -> Maybe Module -> Stream IO CmmGroupSRTs a + -> IO (Stream IO RawCmmGroup a)) + } + +getHooked :: (Functor f, HasDynFlags f) => (Hooks -> Maybe a) -> a -> f a +getHooked hook def = fmap (lookupHook hook def) getDynFlags + +lookupHook :: (Hooks -> Maybe a) -> a -> DynFlags -> a +lookupHook hook def = fromMaybe def . hook . hooks diff --git a/compiler/GHC/Driver/Hooks.hs-boot b/compiler/GHC/Driver/Hooks.hs-boot new file mode 100644 index 0000000000..40ee5560ee --- /dev/null +++ b/compiler/GHC/Driver/Hooks.hs-boot @@ -0,0 +1,7 @@ +module GHC.Driver.Hooks where + +import GhcPrelude () + +data Hooks + +emptyHooks :: Hooks diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs new file mode 100644 index 0000000000..e5c030f741 --- /dev/null +++ b/compiler/GHC/Driver/Main.hs @@ -0,0 +1,1952 @@ +{-# LANGUAGE BangPatterns, CPP, MagicHash, NondecreasingIndentation #-} +{-# OPTIONS_GHC -fprof-auto-top #-} + +------------------------------------------------------------------------------- +-- +-- | Main API for compiling plain Haskell source code. +-- +-- This module implements compilation of a Haskell source. It is +-- /not/ concerned with preprocessing of source files; this is handled +-- in GHC.Driver.Pipeline +-- +-- There are various entry points depending on what mode we're in: +-- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and +-- "interactive" mode (GHCi). There are also entry points for +-- individual passes: parsing, typechecking/renaming, desugaring, and +-- simplification. +-- +-- All the functions here take an 'HscEnv' as a parameter, but none of +-- them return a new one: 'HscEnv' is treated as an immutable value +-- from here on in (although it has mutable components, for the +-- caches). +-- +-- We use the Hsc monad to deal with warning messages consistently: +-- specifically, while executing within an Hsc monad, warnings are +-- collected. When a Hsc monad returns to an IO monad, the +-- warnings are printed, or compilation aborts if the @-Werror@ +-- flag is enabled. +-- +-- (c) The GRASP/AQUA Project, Glasgow University, 1993-2000 +-- +------------------------------------------------------------------------------- + +module GHC.Driver.Main + ( + -- * Making an HscEnv + newHscEnv + + -- * Compiling complete source files + , Messager, batchMsg + , HscStatus (..) + , hscIncrementalCompile + , hscMaybeWriteIface + , hscCompileCmmFile + + , hscGenHardCode + , hscInteractive + + -- * Running passes separately + , hscParse + , hscTypecheckRename + , hscDesugar + , makeSimpleDetails + , hscSimplify -- ToDo, shouldn't really export this + + -- * Safe Haskell + , hscCheckSafe + , hscGetSafe + + -- * Support for interactive evaluation + , hscParseIdentifier + , hscTcRcLookupName + , hscTcRnGetInfo + , hscIsGHCiMonad + , hscGetModuleInterface + , hscRnImportDecls + , hscTcRnLookupRdrName + , hscStmt, hscParseStmtWithLocation, hscStmtWithLocation, hscParsedStmt + , hscDecls, hscParseDeclsWithLocation, hscDeclsWithLocation, hscParsedDecls + , hscTcExpr, TcRnExprMode(..), hscImport, hscKcType + , hscParseExpr + , hscParseType + , hscCompileCoreExpr + -- * Low-level exports for hooks + , hscCompileCoreExpr' + -- We want to make sure that we export enough to be able to redefine + -- hsc_typecheck in client code + , hscParse', hscSimplify', hscDesugar', tcRnModule', doCodeGen + , getHscEnv + , hscSimpleIface' + , oneShotMsg + , dumpIfaceStats + , ioMsgMaybe + , showModuleIndex + , hscAddSptEntries + ) where + +import GhcPrelude + +import Data.Data hiding (Fixity, TyCon) +import Data.Maybe ( fromJust ) +import Id +import GHC.Runtime.Interpreter ( addSptEntry ) +import GHCi.RemoteTypes ( ForeignHValue ) +import GHC.CoreToByteCode ( byteCodeGen, coreExprToBCOs ) +import GHC.Runtime.Linker +import CoreTidy ( tidyExpr ) +import Type ( Type ) +import {- Kind parts of -} Type ( Kind ) +import CoreLint ( lintInteractiveExpr ) +import VarEnv ( emptyTidyEnv ) +import Panic +import ConLike +import Control.Concurrent + +import ApiAnnotation +import Module +import GHC.Driver.Packages +import RdrName +import GHC.Hs +import GHC.Hs.Dump +import CoreSyn +import StringBuffer +import Parser +import Lexer +import SrcLoc +import TcRnDriver +import GHC.IfaceToCore ( typecheckIface ) +import TcRnMonad +import TcHsSyn ( ZonkFlexi (DefaultFlexi) ) +import NameCache ( initNameCache ) +import GHC.Iface.Load ( ifaceStats, initExternalPackageState ) +import PrelInfo +import GHC.Iface.Utils +import GHC.HsToCore +import SimplCore +import GHC.Iface.Tidy +import GHC.CoreToStg.Prep +import GHC.CoreToStg ( coreToStg ) +import GHC.Stg.Syntax +import GHC.Stg.FVs ( annTopBindingsFreeVars ) +import GHC.Stg.Pipeline ( stg2stg ) +import qualified GHC.StgToCmm as StgToCmm ( codeGen ) +import CostCentre +import ProfInit +import TyCon +import Name +import NameSet +import GHC.Cmm +import GHC.Cmm.Parser ( parseCmmFile ) +import GHC.Cmm.Info.Build +import GHC.Cmm.Pipeline +import GHC.Cmm.Info +import GHC.Driver.CodeOutput +import InstEnv +import FamInstEnv +import Fingerprint ( Fingerprint ) +import GHC.Driver.Hooks +import TcEnv +import PrelNames +import GHC.Driver.Plugins +import GHC.Runtime.Loader ( initializePlugins ) + +import GHC.Driver.Session +import ErrUtils + +import Outputable +import NameEnv +import HscStats ( ppSourceStats ) +import GHC.Driver.Types +import FastString +import UniqSupply +import Bag +import Exception +import qualified Stream +import Stream (Stream) + +import Util + +import Data.List ( nub, isPrefixOf, partition ) +import Control.Monad +import Data.IORef +import System.FilePath as FilePath +import System.Directory +import System.IO (fixIO) +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Set (Set) +import Data.Functor +import Control.DeepSeq (force) + +import GHC.Iface.Ext.Ast ( mkHieFile ) +import GHC.Iface.Ext.Types ( getAsts, hie_asts, hie_module ) +import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result) +import GHC.Iface.Ext.Debug ( diffFile, validateScopes ) + +#include "HsVersions.h" + + +{- ********************************************************************** +%* * + Initialisation +%* * +%********************************************************************* -} + +newHscEnv :: DynFlags -> IO HscEnv +newHscEnv dflags = do + eps_var <- newIORef initExternalPackageState + us <- mkSplitUniqSupply 'r' + nc_var <- newIORef (initNameCache us knownKeyNames) + fc_var <- newIORef emptyInstalledModuleEnv + iserv_mvar <- newMVar Nothing + emptyDynLinker <- uninitializedLinker + return HscEnv { hsc_dflags = dflags + , hsc_targets = [] + , hsc_mod_graph = emptyMG + , hsc_IC = emptyInteractiveContext dflags + , hsc_HPT = emptyHomePackageTable + , hsc_EPS = eps_var + , hsc_NC = nc_var + , hsc_FC = fc_var + , hsc_type_env_var = Nothing + , hsc_iserv = iserv_mvar + , hsc_dynLinker = emptyDynLinker + } + +-- ----------------------------------------------------------------------------- + +getWarnings :: Hsc WarningMessages +getWarnings = Hsc $ \_ w -> return (w, w) + +clearWarnings :: Hsc () +clearWarnings = Hsc $ \_ _ -> return ((), emptyBag) + +logWarnings :: WarningMessages -> Hsc () +logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w) + +getHscEnv :: Hsc HscEnv +getHscEnv = Hsc $ \e w -> return (e, w) + +handleWarnings :: Hsc () +handleWarnings = do + dflags <- getDynFlags + w <- getWarnings + liftIO $ printOrThrowWarnings dflags w + clearWarnings + +-- | log warning in the monad, and if there are errors then +-- throw a SourceError exception. +logWarningsReportErrors :: Messages -> Hsc () +logWarningsReportErrors (warns,errs) = do + logWarnings warns + when (not $ isEmptyBag errs) $ throwErrors errs + +-- | Log warnings and throw errors, assuming the messages +-- contain at least one error (e.g. coming from PFailed) +handleWarningsThrowErrors :: Messages -> Hsc a +handleWarningsThrowErrors (warns, errs) = do + logWarnings warns + dflags <- getDynFlags + (wWarns, wErrs) <- warningsToMessages dflags <$> getWarnings + liftIO $ printBagOfErrors dflags wWarns + throwErrors (unionBags errs wErrs) + +-- | Deal with errors and warnings returned by a compilation step +-- +-- In order to reduce dependencies to other parts of the compiler, functions +-- outside the "main" parts of GHC return warnings and errors as a parameter +-- and signal success via by wrapping the result in a 'Maybe' type. This +-- function logs the returned warnings and propagates errors as exceptions +-- (of type 'SourceError'). +-- +-- This function assumes the following invariants: +-- +-- 1. If the second result indicates success (is of the form 'Just x'), +-- there must be no error messages in the first result. +-- +-- 2. If there are no error messages, but the second result indicates failure +-- there should be warnings in the first result. That is, if the action +-- failed, it must have been due to the warnings (i.e., @-Werror@). +ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a +ioMsgMaybe ioA = do + ((warns,errs), mb_r) <- liftIO ioA + logWarnings warns + case mb_r of + Nothing -> throwErrors errs + Just r -> ASSERT( isEmptyBag errs ) return r + +-- | like ioMsgMaybe, except that we ignore error messages and return +-- 'Nothing' instead. +ioMsgMaybe' :: IO (Messages, Maybe a) -> Hsc (Maybe a) +ioMsgMaybe' ioA = do + ((warns,_errs), mb_r) <- liftIO $ ioA + logWarnings warns + return mb_r + +-- ----------------------------------------------------------------------------- +-- | Lookup things in the compiler's environment + +hscTcRnLookupRdrName :: HscEnv -> Located RdrName -> IO [Name] +hscTcRnLookupRdrName hsc_env0 rdr_name + = runInteractiveHsc hsc_env0 $ + do { hsc_env <- getHscEnv + ; ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name } + +hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing) +hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe' $ tcRnLookupName hsc_env name + -- ignore errors: the only error we're likely to get is + -- "name not found", and the Maybe in the return type + -- is used to indicate that. + +hscTcRnGetInfo :: HscEnv -> Name + -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)) +hscTcRnGetInfo hsc_env0 name + = runInteractiveHsc hsc_env0 $ + do { hsc_env <- getHscEnv + ; ioMsgMaybe' $ tcRnGetInfo hsc_env name } + +hscIsGHCiMonad :: HscEnv -> String -> IO Name +hscIsGHCiMonad hsc_env name + = runHsc hsc_env $ ioMsgMaybe $ isGHCiMonad hsc_env name + +hscGetModuleInterface :: HscEnv -> Module -> IO ModIface +hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe $ getModuleInterface hsc_env mod + +-- ----------------------------------------------------------------------------- +-- | Rename some import declarations +hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv +hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe $ tcRnImportDecls hsc_env import_decls + +-- ----------------------------------------------------------------------------- +-- | parse a file, returning the abstract syntax + +hscParse :: HscEnv -> ModSummary -> IO HsParsedModule +hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary + +-- internal version, that doesn't fail due to -Werror +hscParse' :: ModSummary -> Hsc HsParsedModule +hscParse' mod_summary + | Just r <- ms_parsed_mod mod_summary = return r + | otherwise = {-# SCC "Parser" #-} + withTimingD (text "Parser"<+>brackets (ppr $ ms_mod mod_summary)) + (const ()) $ do + dflags <- getDynFlags + let src_filename = ms_hspp_file mod_summary + maybe_src_buf = ms_hspp_buf mod_summary + + -------------------------- Parser ---------------- + -- sometimes we already have the buffer in memory, perhaps + -- because we needed to parse the imports out of it, or get the + -- module name. + buf <- case maybe_src_buf of + Just b -> return b + Nothing -> liftIO $ hGetStringBuffer src_filename + + let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 + let parseMod | HsigFile == ms_hsc_src mod_summary + = parseSignature + | otherwise = parseModule + + case unP parseMod (mkPState dflags buf loc) of + PFailed pst -> + handleWarningsThrowErrors (getMessages pst dflags) + POk pst rdr_module -> do + let (warns, errs) = getMessages pst dflags + logWarnings warns + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" + FormatHaskell (ppr rdr_module) + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" + FormatHaskell (showAstData NoBlankSrcSpan rdr_module) + liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" + FormatText (ppSourceStats False rdr_module) + when (not $ isEmptyBag errs) $ throwErrors errs + + -- To get the list of extra source files, we take the list + -- that the parser gave us, + -- - eliminate files beginning with '<'. gcc likes to use + -- pseudo-filenames like "<built-in>" and "<command-line>" + -- - normalise them (eliminate differences between ./f and f) + -- - filter out the preprocessed source file + -- - filter out anything beginning with tmpdir + -- - remove duplicates + -- - filter out the .hs/.lhs source filename if we have one + -- + let n_hspp = FilePath.normalise src_filename + srcs0 = nub $ filter (not . (tmpDir dflags `isPrefixOf`)) + $ filter (not . (== n_hspp)) + $ map FilePath.normalise + $ filter (not . isPrefixOf "<") + $ map unpackFS + $ srcfiles pst + srcs1 = case ml_hs_file (ms_location mod_summary) of + Just f -> filter (/= FilePath.normalise f) srcs0 + Nothing -> srcs0 + + -- sometimes we see source files from earlier + -- preprocessing stages that cannot be found, so just + -- filter them out: + srcs2 <- liftIO $ filterM doesFileExist srcs1 + + let api_anns = ApiAnns { + apiAnnItems = M.fromListWith (++) $ annotations pst, + apiAnnEofPos = eof_pos pst, + apiAnnComments = M.fromList (annotations_comments pst), + apiAnnRogueComments = comment_q pst + } + res = HsParsedModule { + hpm_module = rdr_module, + hpm_src_files = srcs2, + hpm_annotations = api_anns + } + + -- 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 :: ModSummary -> TcGblEnv -> Hsc RenamedStuff +extract_renamed_stuff mod_summary tc_result = do + let rn_info = getRenamedStuff tc_result + + dflags <- getDynFlags + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_rn_ast "Renamer" + FormatHaskell (showAstData NoBlankSrcSpan rn_info) + + -- Create HIE files + when (gopt Opt_WriteHie dflags) $ do + -- I assume this fromJust is safe because `-fwrite-hie-file` + -- enables the option which keeps the renamed source. + hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info) + let out_file = ml_hie_file $ ms_location mod_summary + liftIO $ writeHieFile out_file hieFile + + -- Validate HIE files + when (gopt Opt_ValidateHie dflags) $ do + hs_env <- Hsc $ \e w -> return (e, w) + liftIO $ do + -- Validate Scopes + let mdl = hie_module hieFile + case validateScopes mdl $ getAsts $ hie_asts hieFile of + [] -> putMsg dflags $ text "Got valid scopes" + xs -> do + putMsg dflags $ text "Got invalid scopes" + mapM_ (putMsg dflags) xs + -- Roundtrip testing + nc <- readIORef $ hsc_NC hs_env + (file', _) <- readHieFile nc out_file + case diffFile hieFile (hie_file_result file') of + [] -> + putMsg dflags $ text "Got no roundtrip errors" + xs -> do + putMsg dflags $ text "Got roundtrip errors" + mapM_ (putMsg dflags) xs + return 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 $ + hsc_typecheck True mod_summary (Just rdr_module) + + +-- | A bunch of logic piled around around @tcRnModule'@, concerning a) backpack +-- b) concerning dumping rename info and hie files. It would be nice to further +-- separate this stuff out, probably in conjunction better separating renaming +-- and type checking (#17781). +hsc_typecheck :: Bool -- ^ Keep renamed source? + -> ModSummary -> Maybe HsParsedModule + -> Hsc (TcGblEnv, RenamedStuff) +hsc_typecheck keep_rn mod_summary mb_rdr_module = do + hsc_env <- getHscEnv + let hsc_src = ms_hsc_src mod_summary + dflags = hsc_dflags hsc_env + outer_mod = ms_mod mod_summary + mod_name = moduleName outer_mod + outer_mod' = mkModule (thisPackage dflags) mod_name + inner_mod = canonicalizeHomeModule dflags mod_name + src_filename = ms_hspp_file mod_summary + real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1 + keep_rn' = gopt Opt_WriteHie dflags || keep_rn + MASSERT( moduleUnitId outer_mod == thisPackage dflags ) + tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod) + then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod' real_loc + else + do hpm <- case mb_rdr_module of + Just hpm -> return hpm + Nothing -> hscParse' mod_summary + tc_result0 <- tcRnModule' mod_summary keep_rn' hpm + if hsc_src == HsigFile + then do (iface, _, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 Nothing + ioMsgMaybe $ + tcRnMergeSignatures hsc_env hpm tc_result0 iface + else return tc_result0 + -- TODO are we extracting anything when we merely instantiate a signature? + -- If not, try to move this into the "else" case above. + rn_info <- extract_renamed_stuff mod_summary tc_result + return (tc_result, rn_info) + +-- wrapper around tcRnModule to handle safe haskell extras +tcRnModule' :: ModSummary -> Bool -> HsParsedModule + -> Hsc TcGblEnv +tcRnModule' sum save_rn_syntax mod = do + hsc_env <- getHscEnv + dflags <- getDynFlags + + -- -Wmissing-safe-haskell-mode + when (not (safeHaskellModeEnabled dflags) + && wopt Opt_WarnMissingSafeHaskellMode dflags) $ + logWarnings $ unitBag $ + makeIntoWarning (Reason Opt_WarnMissingSafeHaskellMode) $ + mkPlainWarnMsg dflags (getLoc (hpm_module mod)) $ + warnMissingSafeHaskellMode + + tcg_res <- {-# SCC "Typecheck-Rename" #-} + ioMsgMaybe $ + 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) + let allSafeOK = safeInferred dflags && tcSafeOK + + -- end of the safe haskell line, how to respond to user? + 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 + | safeHaskell dflags == Sf_Safe -> return () + | otherwise -> (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!" + errTwthySafe t = quotes (pprMod t) + <+> text "is marked as Trustworthy but has been inferred as safe!" + warnMissingSafeHaskellMode = ppr (moduleName (ms_mod sum)) + <+> text "is missing Safe Haskell mode" + +-- | Convert a typechecked module to Core +hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts +hscDesugar hsc_env mod_summary tc_result = + runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result + +hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts +hscDesugar' mod_location tc_result = do + hsc_env <- getHscEnv + r <- ioMsgMaybe $ + {-# SCC "deSugar" #-} + deSugar hsc_env mod_location tc_result + + -- always check -Werror after desugaring, this is the last opportunity for + -- warnings to arise before the backend. + handleWarnings + return r + +-- | Make a 'ModDetails' from the results of typechecking. Used when +-- typechecking only, as opposed to full compilation. +makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails +makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result + + +{- ********************************************************************** +%* * + The main compiler pipeline +%* * +%********************************************************************* -} + +{- + -------------------------------- + The compilation proper + -------------------------------- + +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, 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' +mode targets hard-code, 'nothing' mode targets nothing and 'interactive' mode +targets byte-code. + +The modes are kept separate because of their different types and meanings: + + * In 'one-shot' mode, we're only compiling a single file and can therefore + discard the new ModIface and ModDetails. This is also the reason it only + targets hard-code; compiling to byte-code or nothing doesn't make sense when + we discard the result. + + * 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface + and ModDetails. 'Batch' mode doesn't target byte-code since that require us to + return the newly compiled byte-code. + + * 'Nothing' mode has exactly the same type as 'batch' mode but they're still + kept separate. This is because compiling to nothing is fairly special: We + don't output any interface files, we don't run the simplifier and we don't + generate any code. + + * 'Interactive' mode is similar to 'batch' mode except that we return the + compiled byte-code together with the ModIface and ModDetails. + +Trying to compile a hs-boot file to byte-code will result in a run-time error. +This is the only thing that isn't caught by the type-system. +-} + + +type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModSummary -> IO () + +-- | This function runs GHC's frontend with recompilation +-- avoidance. Specifically, it checks if recompilation is needed, +-- and if it is, it parses and typechecks the input module. +-- It does not write out the results of typechecking (See +-- compileOne and hscIncrementalCompile). +hscIncrementalFrontend :: Bool -- always do basic recompilation check? + -> Maybe TcGblEnv + -> Maybe Messager + -> ModSummary + -> SourceModified + -> Maybe ModIface -- Old interface, if available + -> (Int,Int) -- (i,n) = module i of n (for msgs) + -> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint)) + +hscIncrementalFrontend + always_do_basic_recompilation_check m_tc_result + mHscMessage mod_summary source_modified mb_old_iface mod_index + = do + hsc_env <- getHscEnv + + let msg what = case mHscMessage of + Just hscMessage -> hscMessage hsc_env mod_index what mod_summary + Nothing -> return () + + skip iface = do + liftIO $ msg UpToDate + return $ Left iface + + compile mb_old_hash reason = do + liftIO $ msg reason + (tc_result, _) <- hsc_typecheck False mod_summary Nothing + return $ Right (FrontendTypecheck tc_result, mb_old_hash) + + stable = case source_modified of + SourceUnmodifiedAndStable -> True + _ -> False + + case m_tc_result of + Just tc_result + | not always_do_basic_recompilation_check -> + return $ Right (FrontendTypecheck tc_result, Nothing) + _ -> do + (recomp_reqd, mb_checked_iface) + <- {-# SCC "checkOldIface" #-} + liftIO $ checkOldIface hsc_env mod_summary + source_modified mb_old_iface + -- save the interface that comes back from checkOldIface. + -- In one-shot mode we don't have the old iface until this + -- point, when checkOldIface reads it from the disk. + let mb_old_hash = fmap (mi_iface_hash . mi_final_exts) mb_checked_iface + + case mb_checked_iface of + Just iface | not (recompileRequired recomp_reqd) -> + -- If the module used TH splices when it was last + -- compiled, then the recompilation check is not + -- accurate enough (#481) and we must ignore + -- it. However, if the module is stable (none of + -- the modules it depends on, directly or + -- indirectly, changed), then we *can* skip + -- recompilation. This is why the SourceModified + -- type contains SourceUnmodifiedAndStable, and + -- it's pretty important: otherwise ghc --make + -- would always recompile TH modules, even if + -- nothing at all has changed. Stability is just + -- the same check that make is doing for us in + -- one-shot mode. + case m_tc_result of + Nothing + | mi_used_th iface && not stable -> + compile mb_old_hash (RecompBecause "TH") + _ -> + skip iface + _ -> + case m_tc_result of + Nothing -> compile mb_old_hash recomp_reqd + Just tc_result -> + return $ Right (FrontendTypecheck tc_result, mb_old_hash) + +-------------------------------------------------------------- +-- Compilers +-------------------------------------------------------------- + +-- | Used by both OneShot and batch mode. Runs the pipeline HsSyn and Core parts +-- of the pipeline. +-- We return a interface if we already had an old one around and recompilation +-- was not needed. Otherwise it will be created during later passes when we +-- run the compilation pipeline. +hscIncrementalCompile :: Bool + -> Maybe TcGblEnv + -> Maybe Messager + -> HscEnv + -> ModSummary + -> SourceModified + -> Maybe ModIface + -> (Int,Int) + -> IO (HscStatus, DynFlags) +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) } + | otherwise + = 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 + -- to get those warnings too. (But we'll always exit at that point + -- because the desugarer runs ioMsgMaybe.) + runHsc hsc_env $ do + e <- hscIncrementalFrontend always_do_basic_recompilation_check m_tc_result mHscMessage + mod_summary source_modified mb_old_iface mod_index + case e of + -- We didn't need to do any typechecking; the old interface + -- file on disk was good enough. + Left iface -> do + -- Knot tying! See Note [Knot-tying typecheckIface] + details <- liftIO . fixIO $ \details' -> do + let hsc_env' = + hsc_env { + hsc_HPT = addToHpt (hsc_HPT hsc_env) + (ms_mod_name mod_summary) (HomeModInfo iface details' Nothing) + } + -- NB: This result is actually not that useful + -- in one-shot mode, since we're not going to do + -- any further typechecking. It's much more useful + -- in make mode, since this HMI will go into the HPT. + details <- genModDetails hsc_env' iface + return details + return (HscUpToDate iface details, dflags) + -- We finished type checking. (mb_old_hash is the hash of + -- the interface that existed on disk; it's possible we had + -- to retypecheck but the resulting interface is exactly + -- the same.) + Right (FrontendTypecheck tc_result, mb_old_hash) -> do + status <- finish mod_summary tc_result mb_old_hash + return (status, dflags) + +-- Runs the post-typechecking frontend (desugar and simplify). We want to +-- generate most of the interface as late as possible. This gets us up-to-date +-- and good unfoldings and other info in the interface file. +-- +-- We might create a interface right away, in which case we also return the +-- updated HomeModInfo. But we might also need to run the backend first. In the +-- later case Status will be HscRecomp and we return a function from ModIface -> +-- HomeModInfo. +-- +-- HscRecomp in turn will carry the information required to compute a interface +-- when passed the result of the code generator. So all this can and is done at +-- the call site of the backend code gen if it is run. +finish :: ModSummary + -> TcGblEnv + -> Maybe Fingerprint + -> Hsc HscStatus +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 + + -- Desugar, if appropriate + -- + -- We usually desugar even when we are not generating code, otherwise we + -- would miss errors thrown by the desugaring (see #10600). The only + -- exceptions are when the Module is Ghc.Prim or when it is not a + -- HsSrcFile Module. + mb_desugar <- + if ms_mod summary /= gHC_PRIM && hsc_src == HsSrcFile + then Just <$> hscDesugar' (ms_location summary) tc_result + else pure Nothing + + -- Simplify, if appropriate, and (whether we simplified or not) generate an + -- interface file. + case mb_desugar of + -- Just cause we desugared doesn't mean we are generating code, see above. + Just desugared_guts | target /= HscNothing -> do + plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result) + simplified_guts <- hscSimplify' plugins desugared_guts + + (cg_guts, details) <- {-# SCC "CoreTidy" #-} + liftIO $ tidyProgram hsc_env simplified_guts + + let !partial_iface = + {-# SCC "GHC.Driver.Main.mkPartialIface" #-} + -- This `force` saves 2M residency in test T10370 + -- See Note [Avoiding space leaks in toIface*] for details. + force (mkPartialIface hsc_env details simplified_guts) + + return HscRecomp { hscs_guts = cg_guts, + hscs_mod_location = ms_location summary, + hscs_mod_details = details, + hscs_partial_iface = partial_iface, + hscs_old_iface_hash = mb_old_hash, + hscs_iface_dflags = dflags } + + -- We are not generating code, so we can skip simplification + -- and generate a simple interface. + _ -> do + (iface, mb_old_iface_hash, details) <- liftIO $ + hscSimpleIface hsc_env tc_result mb_old_hash + + liftIO $ hscMaybeWriteIface dflags iface mb_old_iface_hash (ms_location summary) + + return $ case (target, hsc_src) of + (HscNothing, _) -> HscNotGeneratingCode iface details + (_, HsBootFile) -> HscUpdateBoot iface details + (_, HsigFile) -> HscUpdateSig iface details + _ -> panic "finish" + +{- +Note [Writing interface files] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We write interface files in GHC.Driver.Main and GHC.Driver.Pipeline using +hscMaybeWriteIface, but only once per compilation (twice with dynamic-too). + +* If a compilation does NOT require (re)compilation of the hard code we call + hscMaybeWriteIface inside GHC.Driver.Main:finish. +* If we run in One Shot mode and target bytecode we write it in compileOne' +* Otherwise we must be compiling to regular hard code and require recompilation. + In this case we create the interface file inside RunPhase using the interface + generator contained inside the HscRecomp status. +-} +hscMaybeWriteIface :: DynFlags -> ModIface -> Maybe Fingerprint -> ModLocation -> IO () +hscMaybeWriteIface dflags iface old_iface location = do + let force_write_interface = gopt Opt_WriteInterface dflags + write_interface = case hscTarget dflags of + HscNothing -> False + HscInterpreted -> False + _ -> True + no_change = old_iface == Just (mi_iface_hash (mi_final_exts iface)) + + when (write_interface || force_write_interface) $ + hscWriteIface dflags iface no_change location + +-------------------------------------------------------------- +-- NoRecomp handlers +-------------------------------------------------------------- + +-- NB: this must be knot-tied appropriately, see hscIncrementalCompile +genModDetails :: HscEnv -> ModIface -> IO ModDetails +genModDetails hsc_env old_iface + = do + new_details <- {-# SCC "tcRnIface" #-} + initIfaceLoad hsc_env (typecheckIface old_iface) + dumpIfaceStats hsc_env + return new_details + +-------------------------------------------------------------- +-- Progress displayers. +-------------------------------------------------------------- + +oneShotMsg :: HscEnv -> RecompileRequired -> IO () +oneShotMsg hsc_env recomp = + case recomp of + UpToDate -> + compilationProgressMsg (hsc_dflags hsc_env) $ + "compilation IS NOT required" + _ -> + return () + +batchMsg :: Messager +batchMsg hsc_env mod_index recomp mod_summary = + case recomp of + MustCompile -> showMsg "Compiling " "" + UpToDate + | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " "" + | otherwise -> return () + RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]") + where + dflags = hsc_dflags hsc_env + showMsg msg reason = + compilationProgressMsg dflags $ + (showModuleIndex mod_index ++ + msg ++ showModMsg dflags (hscTarget dflags) + (recompileRequired recomp) mod_summary) + ++ reason + +-------------------------------------------------------------- +-- Safe Haskell +-------------------------------------------------------------- + +-- Note [Safe Haskell Trust Check] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Safe Haskell checks that an import is trusted according to the following +-- rules for an import of module M that resides in Package P: +-- +-- * If M is recorded as Safe and all its trust dependencies are OK +-- then M is considered safe. +-- * If M is recorded as Trustworthy and P is considered trusted and +-- all M's trust dependencies are OK then M is considered safe. +-- +-- By trust dependencies we mean that the check is transitive. So if +-- a module M that is Safe relies on a module N that is trustworthy, +-- importing module M will first check (according to the second case) +-- that N is trusted before checking M is trusted. +-- +-- This is a minimal description, so please refer to the user guide +-- for more details. The user guide is also considered the authoritative +-- source in this matter, not the comments or code. + + +-- Note [Safe Haskell Inference] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Safe Haskell does Safe inference on modules that don't have any specific +-- safe haskell mode flag. The basic approach to this is: +-- * When deciding if we need to do a Safe language check, treat +-- an unmarked module as having -XSafe mode specified. +-- * For checks, don't throw errors but return them to the caller. +-- * Caller checks if there are errors: +-- * For modules explicitly marked -XSafe, we throw the errors. +-- * For unmarked modules (inference mode), we drop the errors +-- and mark the module as being Unsafe. +-- +-- It used to be that we only did safe inference on modules that had no Safe +-- Haskell flags, but now we perform safe inference on all modules as we want +-- to allow users to set the `-Wsafe`, `-Wunsafe` and +-- `-Wtrustworthy-safe` flags on Trustworthy and Unsafe modules so that a +-- user can ensure their assumptions are correct and see reasons for why a +-- module is safe or unsafe. +-- +-- This is tricky as we must be careful when we should throw an error compared +-- to just warnings. For checking safe imports we manage it as two steps. First +-- we check any imports that are required to be safe, then we check all other +-- imports to see if we can infer them to be safe. + + +-- | Check that the safe imports of the module being compiled are valid. +-- If not we either issue a compilation error if the module is explicitly +-- using Safe Haskell, or mark the module as unsafe if we're in safe +-- inference mode. +hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv +hscCheckSafeImports tcg_env = do + dflags <- getDynFlags + tcg_env' <- checkSafeImports tcg_env + checkRULES dflags tcg_env' + + where + checkRULES dflags tcg_env' = do + case safeLanguageOn dflags of + True -> do + -- XSafe: we nuke user written RULES + logWarnings $ warns dflags (tcg_rules tcg_env') + return tcg_env' { tcg_rules = [] } + False + -- SafeInferred: user defined RULES, so not safe + | safeInferOn dflags && not (null $ tcg_rules tcg_env') + -> markUnsafeInfer tcg_env' $ warns dflags (tcg_rules tcg_env') + + -- Trustworthy OR SafeInferred: with no RULES + | otherwise + -> return tcg_env' + + warns dflags rules = listToBag $ map (warnRules dflags) rules + + warnRules :: DynFlags -> GenLocated SrcSpan (RuleDecl GhcTc) -> ErrMsg + warnRules dflags (L loc (HsRule { rd_name = n })) = + mkPlainWarnMsg dflags loc $ + text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$ + text "User defined rules are disabled under Safe Haskell" + warnRules _ (L _ (XRuleDecl nec)) = noExtCon nec + +-- | 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 package +-- is trusted. See the Note [Safe Haskell Trust Check] above for more +-- information. +-- +-- The code for this is quite tricky as the whole algorithm is done in a few +-- distinct phases in different parts of the code base. See +-- GHC.Rename.Names.rnImportDecl for where package trust dependencies for a +-- module are collected and unioned. Specifically see the Note [Tracking Trust +-- Transitively] in GHC.Rename.Names and the Note [Trust Own Package] in +-- GHC.Rename.Names. +checkSafeImports :: TcGblEnv -> Hsc TcGblEnv +checkSafeImports tcg_env + = do + dflags <- getDynFlags + imps <- mapM condense imports' + let (safeImps, regImps) = partition (\(_,_,s) -> s) imps + + -- We want to use the warning state specifically for detecting if safe + -- inference has failed, so store and clear any existing warnings. + oldErrs <- getWarnings + clearWarnings + + -- Check safe imports are correct + safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps + safeErrs <- getWarnings + clearWarnings + + -- Check non-safe imports are correct if inferring safety + -- See the Note [Safe Haskell Inference] + (infErrs, infPkgs) <- case (safeInferOn dflags) of + False -> return (emptyBag, S.empty) + True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps + infErrs <- getWarnings + clearWarnings + return (infErrs, infPkgs) + + -- restore old errors + logWarnings oldErrs + + case (isEmptyBag safeErrs) of + -- Failed safe check + False -> liftIO . throwIO . mkSrcErr $ safeErrs + + -- Passed safe check + True -> do + let infPassed = isEmptyBag infErrs + tcg_env' <- case (not infPassed) of + True -> markUnsafeInfer tcg_env infErrs + False -> return tcg_env + when (packageTrustOn dflags) $ checkPkgTrust pkgReqs + let newTrust = pkgTrustReqs dflags safePkgs infPkgs infPassed + return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust } + + where + impInfo = tcg_imports tcg_env -- ImportAvails + imports = imp_mods impInfo -- ImportedMods + imports1 = moduleEnvToList imports -- (Module, [ImportedBy]) + imports' = map (fmap importedByUser) imports1 -- (Module, [ImportedModsVal]) + pkgReqs = imp_trust_pkgs impInfo -- [UnitId] + + condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport) + condense (_, []) = panic "GHC.Driver.Main.condense: Pattern match failure!" + condense (m, x:xs) = do imv <- foldlM cond' x xs + return (m, imv_span imv, imv_is_safe imv) + + -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport) + cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal + cond' v1 v2 + | imv_is_safe v1 /= imv_is_safe v2 + = do + dflags <- getDynFlags + throwOneError $ mkPlainErrMsg dflags (imv_span v1) + (text "Module" <+> ppr (imv_name v1) <+> + (text $ "is imported both as a safe and unsafe import!")) + | otherwise + = return v1 + + -- easier interface to work with + checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe InstalledUnitId) + checkSafe (m, l, _) = fst `fmap` hscCheckSafe' m l + + -- what pkg's to add to our trust requirements + pkgTrustReqs :: DynFlags -> Set InstalledUnitId -> Set InstalledUnitId -> + Bool -> ImportAvails + pkgTrustReqs dflags req inf infPassed | safeInferOn dflags + && not (safeHaskellModeEnabled dflags) && infPassed + = emptyImportAvails { + imp_trust_pkgs = req `S.union` inf + } + pkgTrustReqs dflags _ _ _ | safeHaskell dflags == Sf_Unsafe + = emptyImportAvails + pkgTrustReqs _ req _ _ = emptyImportAvails { imp_trust_pkgs = req } + +-- | Check that a module is safe to import. +-- +-- We return True to indicate the import is safe and False otherwise +-- although in the False case an exception may be thrown first. +hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool +hscCheckSafe hsc_env m l = runHsc hsc_env $ do + dflags <- getDynFlags + 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 + (self, pkgs) <- hscCheckSafe' m l + good <- isEmptyBag `fmap` getWarnings + clearWarnings -- don't want them printed... + let pkgs' | Just p <- self = S.insert p pkgs + | otherwise = pkgs + return (good, pkgs') + +-- | Is a module trusted? If not, throw or log errors depending on the type. +-- 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' :: 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 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! + Nothing -> throwOneError $ mkPlainErrMsg dflags l + $ text "Can't load the interface file for" <+> ppr m + <> text ", to check that it can be safely imported" + + -- got iface, check trust + Just iface' -> + let trust = getSafeMode $ mi_trust iface' + trust_own_pkg = mi_trust_pkg iface' + -- check module is trusted + safeM = trust `elem` [Sf_Safe, Sf_SafeInferred, Sf_Trustworthy] + -- check package is trusted + safeP = packageTrusted dflags trust trust_own_pkg m + -- pkg trust reqs + pkgRs = S.fromList . map fst $ filter snd $ dep_pkgs $ mi_deps iface' + -- warn if Safe module imports Safe-Inferred module. + warns = if wopt Opt_WarnInferredSafeImports dflags + && safeLanguageOn dflags + && trust == Sf_SafeInferred + then inferredImportWarn + else emptyBag + -- General errors we throw but Safe errors we log + errs = case (safeM, safeP) of + (True, True ) -> emptyBag + (True, False) -> pkgTrustErr + (False, _ ) -> modTrustErr + in do + logWarnings warns + logWarnings errs + return (trust == Sf_Trustworthy, pkgRs) + + where + inferredImportWarn = unitBag + $ makeIntoWarning (Reason Opt_WarnInferredSafeImports) + $ mkErrMsg dflags l (pkgQual dflags) + $ sep + [ text "Importing Safe-Inferred module " + <> ppr (moduleName m) + <> text " from explicitly Safe module" + ] + pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $ + sep [ ppr (moduleName m) + <> text ": Can't be safely imported!" + , text "The package (" <> ppr (moduleUnitId m) + <> text ") the module resides in isn't trusted." + ] + modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $ + sep [ ppr (moduleName m) + <> text ": Can't be safely imported!" + , text "The module itself isn't safe." ] + + -- | Check the package a module resides in is trusted. Safe compiled + -- modules are trusted without requiring that their package is trusted. For + -- trustworthy modules, modules in the home package are trusted but + -- otherwise we check the package trust flag. + packageTrusted :: DynFlags -> SafeHaskellMode -> Bool -> Module -> Bool + packageTrusted _ Sf_None _ _ = False -- shouldn't hit these cases + packageTrusted _ Sf_Ignore _ _ = 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 _ Sf_SafeInferred False _ = True + packageTrusted dflags _ _ m + | isHomePkg dflags m = True + | otherwise = trusted $ getPackageDetails dflags (moduleUnitId m) + + lookup' :: Module -> Hsc (Maybe ModIface) + lookup' m = do + hsc_env <- getHscEnv + hsc_eps <- liftIO $ hscEPS hsc_env + let pkgIfaceT = eps_PIT hsc_eps + homePkgT = hsc_HPT hsc_env + iface = lookupIfaceByModule homePkgT pkgIfaceT m + -- the 'lookupIfaceByModule' method will always fail when calling from GHCi + -- as the compiler hasn't filled in the various module tables + -- so we need to call 'getModuleInterface' to load from disk + iface' <- case iface of + Just _ -> return iface + Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m) + return iface' + + + isHomePkg :: DynFlags -> Module -> Bool + isHomePkg dflags m + | thisPackage dflags == moduleUnitId m = True + | otherwise = False + +-- | Check the list of packages are trusted. +checkPkgTrust :: Set InstalledUnitId -> Hsc () +checkPkgTrust pkgs = do + dflags <- getDynFlags + let errors = S.foldr go [] pkgs + go pkg acc + | trusted $ getInstalledPackageDetails dflags pkg + = acc + | otherwise + = (: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. +-- +-- Make sure to call this method to set a module to inferred unsafe, it should +-- be a central and single failure method. We only wipe the trust information +-- when we aren't in a specific Safe Haskell mode. +-- +-- While we only use this for recording that a module was inferred unsafe, we +-- may call it on modules using Trustworthy or Unsafe flags so as to allow +-- warning flags for safety to function correctly. See Note [Safe Haskell +-- Inference]. +markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv +markUnsafeInfer tcg_env whyUnsafe = do + dflags <- getDynFlags + + when (wopt Opt_WarnUnsafe dflags) + (logWarnings $ unitBag $ makeIntoWarning (Reason Opt_WarnUnsafe) $ + mkPlainWarnMsg dflags (warnUnsafeOnLoc dflags) (whyUnsafe' dflags)) + + liftIO $ writeIORef (tcg_safeInfer tcg_env) (False, whyUnsafe) + -- NOTE: Only wipe trust when not in an explicitly safe haskell mode. Other + -- times inference may be on but we are in Trustworthy mode -- so we want + -- to record safe-inference failed but not wipe the trust dependencies. + case not (safeHaskellModeEnabled dflags) of + True -> return $ tcg_env { tcg_imports = wiped_trust } + False -> return tcg_env + + where + wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = S.empty } + pprMod = ppr $ moduleName $ tcg_mod tcg_env + whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!" + , text "Reason:" + , nest 4 $ (vcat $ badFlags df) $+$ + (vcat $ pprErrMsgBagWithLoc whyUnsafe) $+$ + (vcat $ badInsts $ tcg_insts tcg_env) + ] + badFlags df = concatMap (badFlag df) unsafeFlagsForInfer + badFlag df (str,loc,on,_) + | on df = [mkLocMessage SevOutput (loc df) $ + text str <+> text "is not allowed in Safe Haskell"] + | otherwise = [] + badInsts insts = concatMap badInst insts + + checkOverlap (NoOverlap _) = False + checkOverlap _ = True + + badInst ins | checkOverlap (overlapMode (is_flag ins)) + = [mkLocMessage SevOutput (nameSrcSpan $ getName $ is_dfun ins) $ + ppr (overlapMode $ is_flag ins) <+> + text "overlap mode isn't allowed in Safe Haskell"] + | otherwise = [] + + +-- | Figure out the final correct safe haskell mode +hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode +hscGetSafeMode tcg_env = do + dflags <- getDynFlags + liftIO $ finalSafeMode dflags tcg_env + +-------------------------------------------------------------- +-- Simplifiers +-------------------------------------------------------------- + +hscSimplify :: HscEnv -> [String] -> ModGuts -> IO ModGuts +hscSimplify hsc_env plugins modguts = + runHsc hsc_env $ hscSimplify' plugins modguts + +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_with_plugins ds_result + +-------------------------------------------------------------- +-- Interface generators +-------------------------------------------------------------- + +-- | Generate a striped down interface file, e.g. for boot files or when ghci +-- generates interface files. See Note [simpleTidyPgm - mkBootModDetailsTc] +hscSimpleIface :: HscEnv + -> TcGblEnv + -> Maybe Fingerprint + -> IO (ModIface, Maybe Fingerprint, ModDetails) +hscSimpleIface hsc_env tc_result mb_old_iface + = runHsc hsc_env $ hscSimpleIface' tc_result mb_old_iface + +hscSimpleIface' :: TcGblEnv + -> Maybe Fingerprint + -> Hsc (ModIface, Maybe Fingerprint, ModDetails) +hscSimpleIface' tc_result mb_old_iface = do + hsc_env <- getHscEnv + details <- liftIO $ mkBootModDetailsTc hsc_env tc_result + safe_mode <- hscGetSafeMode tc_result + new_iface + <- {-# SCC "MkFinalIface" #-} + liftIO $ + mkIfaceTc hsc_env safe_mode details tc_result + -- And the answer is ... + liftIO $ dumpIfaceStats hsc_env + return (new_iface, mb_old_iface, details) + +-------------------------------------------------------------- +-- BackEnd combinators +-------------------------------------------------------------- +{- +Note [Interface filename extensions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +ModLocation only contains the base names, however when generating dynamic files +the actual extension might differ from the default. + +So we only load the base name from ModLocation and replace the actual extension +according to the information in DynFlags. + +If we generate a interface file right after running the core pipeline we will +have set -dynamic-too and potentially generate both interface files at the same +time. + +If we generate a interface file after running the backend then dynamic-too won't +be set, however then the extension will be contained in the dynflags instead so +things still work out fine. +-} + +hscWriteIface :: DynFlags -> ModIface -> Bool -> ModLocation -> IO () +hscWriteIface dflags iface no_change mod_location = do + -- mod_location only contains the base name, so we rebuild the + -- correct file extension from the dynflags. + let ifaceBaseFile = ml_hi_file mod_location + unless no_change $ + let ifaceFile = buildIfName ifaceBaseFile (hiSuf dflags) + in {-# SCC "writeIface" #-} + writeIfaceFile dflags ifaceFile iface + whenGeneratingDynamicToo dflags $ do + -- TODO: We should do a no_change check for the dynamic + -- interface file too + -- When we generate iface files after core + let dynDflags = dynamicTooMkDynamicDynFlags dflags + -- dynDflags will have set hiSuf correctly. + dynIfaceFile = buildIfName ifaceBaseFile (hiSuf dynDflags) + + writeIfaceFile dynDflags dynIfaceFile iface + where + buildIfName :: String -> String -> String + buildIfName baseName suffix + | Just name <- outputHi dflags + = name + | otherwise + = let with_hi = replaceExtension baseName suffix + in addBootSuffix_maybe (mi_boot iface) with_hi + +-- | Compile to hard-code. +hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath + -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], NameSet) + -- ^ @Just f@ <=> _stub.c is f +hscGenHardCode hsc_env cgguts location output_filename = do + let CgGuts{ -- This is the last use of the ModGuts in a compilation. + -- From now on, we just use the bits we need. + cg_module = this_mod, + cg_binds = core_binds, + cg_tycons = tycons, + cg_foreign = foreign_stubs0, + cg_foreign_files = foreign_files, + cg_dep_pkgs = dependencies, + cg_hpc_info = hpc_info } = cgguts + dflags = hsc_dflags hsc_env + data_tycons = filter isDataTyCon tycons + -- cg_tycons includes newtypes, for the benefit of External Core, + -- but we don't generate any code for newtypes + + ------------------- + -- PREPARE FOR CODE GENERATION + -- Do saturation and convert to A-normal form + (prepd_binds, local_ccs) <- {-# SCC "CorePrep" #-} + corePrepPgm hsc_env this_mod location + core_binds data_tycons + ----------------- Convert to STG ------------------ + (stg_binds, (caf_ccs, caf_cc_stacks)) + <- {-# SCC "CoreToStg" #-} + myCoreToStg dflags this_mod prepd_binds + + 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 ------------------ + + -- The back-end is streamed: each top-level function goes + -- from Stg all the way to asm before dealing with the next + -- top-level function, so showPass isn't very useful here. + -- Hence we have one showPass for the whole backend, the + -- next showPass after this will be "Assembler". + withTiming dflags + (text "CodeGen"<+>brackets (ppr this_mod)) + (const ()) $ do + cmms <- {-# SCC "StgToCmm" #-} + doCodeGen hsc_env this_mod data_tycons + cost_centre_info + stg_binds hpc_info + + ------------------ Code output ----------------------- + rawcmms0 <- {-# SCC "cmmToRawCmm" #-} + lookupHook cmmToRawCmmHook + (\dflg _ -> cmmToRawCmm dflg) dflags dflags (Just this_mod) cmms + + let dump a = do + unless (null a) $ + dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (ppr a) + return a + rawcmms1 = Stream.mapM dump rawcmms0 + + (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, caf_infos) + <- {-# SCC "codeOutput" #-} + codeOutput dflags this_mod output_filename location + foreign_stubs foreign_files dependencies rawcmms1 + return (output_filename, stub_c_exists, foreign_fps, caf_infos) + + +hscInteractive :: HscEnv + -> CgGuts + -> ModLocation + -> IO (Maybe FilePath, CompiledByteCode, [SptEntry]) +hscInteractive hsc_env cgguts location = do + let dflags = hsc_dflags hsc_env + let CgGuts{ -- This is the last use of the ModGuts in a compilation. + -- From now on, we just use the bits we need. + cg_module = this_mod, + cg_binds = core_binds, + cg_tycons = tycons, + cg_foreign = foreign_stubs, + cg_modBreaks = mod_breaks, + cg_spt_entries = spt_entries } = cgguts + + data_tycons = filter isDataTyCon tycons + -- cg_tycons includes newtypes, for the benefit of External Core, + -- but we don't generate any code for newtypes + + ------------------- + -- PREPARE FOR CODE GENERATION + -- Do saturation and convert to A-normal form + (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 + ------------------ Create f-x-dynamic C-side stuff ----- + (_istub_h_exists, istub_c_exists) + <- outputForeignStubs dflags this_mod location foreign_stubs + return (istub_c_exists, comp_bc, spt_entries) + +------------------------------ + +hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO () +hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do + let dflags = hsc_dflags hsc_env + cmm <- ioMsgMaybe $ parseCmmFile dflags filename + liftIO $ do + dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (ppr cmm) + 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 + + -- Compile decls in Cmm files one decl at a time, to avoid re-ordering + -- them in SRT analysis. + -- + -- Re-ordering here causes breakage when booting with C backend because + -- in C we must declare before use, but SRT algorithm is free to + -- re-order [A, B] (B refers to A) when A is not CAFFY and return [B, A] + cmmgroup <- + concatMapM (\cmm -> snd <$> cmmPipeline hsc_env (emptySRT cmm_mod) [cmm]) cmm + + unless (null cmmgroup) $ + dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" + FormatCMM (ppr cmmgroup) + rawCmms <- lookupHook cmmToRawCmmHook + (\dflgs _ -> cmmToRawCmm dflgs) dflags dflags Nothing (Stream.yield cmmgroup) + _ <- codeOutput dflags cmm_mod output_filename no_loc NoStubs [] [] + rawCmms + return () + where + no_loc = ModLocation{ ml_hs_file = Just filename, + ml_hi_file = panic "hscCompileCmmFile: no hi file", + ml_obj_file = panic "hscCompileCmmFile: no obj file", + ml_hie_file = panic "hscCompileCmmFile: no hie file"} + +-------------------- Stuff for new code gen --------------------- + +{- +Note [Forcing of stg_binds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The two last steps in the STG pipeline are: + +* Sorting the bindings in dependency order. +* Annotating them with free variables. + +We want to make sure we do not keep references to unannotated STG bindings +alive, nor references to bindings which have already been compiled to Cmm. + +We explicitly force the bindings to avoid this. + +This reduces residency towards the end of the CodeGen phase significantly +(5-10%). +-} + +doCodeGen :: HscEnv -> Module -> [TyCon] + -> CollectedCCs + -> [StgTopBinding] + -> HpcInfo + -> IO (Stream IO CmmGroupSRTs NameSet) + -- Note we produce a 'Stream' of CmmGroups, so that the + -- backend can be run incrementally. Otherwise it generates all + -- the C-- up front, which has a significant space cost. +doCodeGen hsc_env this_mod data_tycons + cost_centre_info stg_binds hpc_info = do + let dflags = hsc_dflags hsc_env + + let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds + + dumpIfSet_dyn dflags Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings stg_binds_w_fvs) + + let cmm_stream :: Stream IO CmmGroup () + -- See Note [Forcing of stg_binds] + cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-} + lookupHook stgToCmmHook StgToCmm.codeGen dflags dflags this_mod data_tycons + cost_centre_info stg_binds_w_fvs hpc_info + + -- codegen consumes a stream of CmmGroup, and produces a new + -- stream of CmmGroup (not necessarily synchronised: one + -- CmmGroup on input may produce many CmmGroups on output due + -- to proc-point splitting). + + let dump1 a = do + unless (null a) $ + dumpIfSet_dyn dflags Opt_D_dump_cmm_from_stg + "Cmm produced by codegen" FormatCMM (ppr a) + return a + + ppr_stream1 = Stream.mapM dump1 cmm_stream + + pipeline_stream = + {-# SCC "cmmPipeline" #-} + Stream.mapAccumL (cmmPipeline hsc_env) (emptySRT this_mod) ppr_stream1 + <&> (srtMapNonCAFs . moduleSRTMap) + + dump2 a = do + unless (null a) $ + dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" FormatCMM (ppr a) + return a + + return (Stream.mapM dump2 pipeline_stream) + +myCoreToStg :: DynFlags -> Module -> CoreProgram + -> IO ( [StgTopBinding] -- output program + , CollectedCCs ) -- CAF cost centre info (declared and used) +myCoreToStg dflags this_mod prepd_binds = do + let (stg_binds, cost_centre_info) + = {-# SCC "Core2Stg" #-} + coreToStg dflags this_mod prepd_binds + + stg_binds2 + <- {-# SCC "Stg2Stg" #-} + stg2stg dflags this_mod stg_binds + + return (stg_binds2, cost_centre_info) + + +{- ********************************************************************** +%* * +\subsection{Compiling a do-statement} +%* * +%********************************************************************* -} + +{- +When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When +you run it you get a list of HValues that should be the same length as the list +of names; add them to the ClosureEnv. + +A naked expression returns a singleton Name [it]. The stmt is lifted into the +IO monad as explained in Note [Interactively-bound Ids in GHCi] in GHC.Driver.Types +-} + +-- | Compile a stmt all the way to an HValue, but don't run it +-- +-- We return Nothing to indicate an empty statement (or comment only), not a +-- parse error. +hscStmt :: HscEnv -> String -> IO (Maybe ([Id], ForeignHValue, FixityEnv)) +hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1 + +-- | Compile a stmt all the way to an HValue, but don't run it +-- +-- We return Nothing to indicate an empty statement (or comment only), not a +-- parse error. +hscStmtWithLocation :: HscEnv + -> String -- ^ The statement + -> String -- ^ The source + -> Int -- ^ Starting line + -> IO ( Maybe ([Id] + , ForeignHValue {- IO [HValue] -} + , FixityEnv)) +hscStmtWithLocation hsc_env0 stmt source linenumber = + runInteractiveHsc hsc_env0 $ do + maybe_stmt <- hscParseStmtWithLocation source linenumber stmt + case maybe_stmt of + Nothing -> return Nothing + + Just parsed_stmt -> do + hsc_env <- getHscEnv + liftIO $ hscParsedStmt hsc_env parsed_stmt + +hscParsedStmt :: HscEnv + -> GhciLStmt GhcPs -- ^ The parsed statement + -> IO ( Maybe ([Id] + , ForeignHValue {- IO [HValue] -} + , FixityEnv)) +hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do + -- Rename and typecheck it + (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env stmt + + -- Desugar it + ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr + liftIO (lintInteractiveExpr "desugar expression" hsc_env ds_expr) + handleWarnings + + -- Then code-gen, and link it + -- It's important NOT to have package 'interactive' as thisUnitId + -- for linking, else we try to link 'main' and can't find it. + -- Whereas the linker already knows to ignore 'interactive' + let src_span = srcLocSpan interactiveSrcLoc + hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr + + return $ Just (ids, hval, fix_env) + +-- | Compile a decls +hscDecls :: HscEnv + -> String -- ^ The statement + -> IO ([TyThing], InteractiveContext) +hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "<interactive>" 1 + +hscParseDeclsWithLocation :: HscEnv -> String -> Int -> String -> IO [LHsDecl GhcPs] +hscParseDeclsWithLocation hsc_env source line_num str = do + L _ (HsModule{ hsmodDecls = decls }) <- + runInteractiveHsc hsc_env $ + hscParseThingWithLocation source line_num parseModule str + return decls + +-- | Compile a decls +hscDeclsWithLocation :: HscEnv + -> String -- ^ The statement + -> String -- ^ The source + -> Int -- ^ Starting line + -> IO ([TyThing], InteractiveContext) +hscDeclsWithLocation hsc_env str source linenumber = do + L _ (HsModule{ hsmodDecls = decls }) <- + runInteractiveHsc hsc_env $ + hscParseThingWithLocation source linenumber parseModule str + hscParsedDecls hsc_env decls + +hscParsedDecls :: HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext) +hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do + {- Rename and typecheck it -} + hsc_env <- getHscEnv + tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env decls + + {- Grab the new instances -} + -- We grab the whole environment because of the overlapping that may have + -- been done. See the notes at the definition of InteractiveContext + -- (ic_instances) for more details. + let defaults = tcg_default tc_gblenv + + {- Desugar it -} + -- We use a basically null location for iNTERACTIVE + let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing, + ml_hi_file = panic "hsDeclsWithLocation:ml_hi_file", + ml_obj_file = panic "hsDeclsWithLocation:ml_obj_file", + ml_hie_file = panic "hsDeclsWithLocation:ml_hie_file" } + ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv + + {- Simplify -} + 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 + + let !CgGuts{ cg_module = this_mod, + cg_binds = core_binds, + cg_tycons = tycons, + cg_modBreaks = mod_breaks } = tidy_cg + + !ModDetails { md_insts = cls_insts + , md_fam_insts = fam_insts } = mod_details + -- Get the *tidied* cls_insts and fam_insts + + data_tycons = filter isDataTyCon tycons + + {- Prepare For Code Generation -} + -- Do saturation and convert to A-normal form + (prepd_binds, _) <- {-# SCC "CorePrep" #-} + liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons + + {- Generate byte code -} + cbc <- liftIO $ byteCodeGen hsc_env this_mod + prepd_binds data_tycons mod_breaks + + let src_span = srcLocSpan interactiveSrcLoc + liftIO $ linkDecls hsc_env src_span cbc + + {- Load static pointer table entries -} + liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg) + + let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg) + patsyns = mg_patsyns simpl_mg + + ext_ids = [ id | id <- bindersOfBinds core_binds + , isExternalName (idName id) + , not (isDFunId id || isImplicitId id) ] + -- We only need to keep around the external bindings + -- (as decided by GHC.Iface.Tidy), since those are the only ones + -- that might later be looked up by name. But we can exclude + -- - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in GHC.Driver.Types + -- - Implicit Ids, which are implicit in tcs + -- c.f. TcRnDriver.runTcInteractive, which reconstructs the TypeEnv + + new_tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns + ictxt = hsc_IC hsc_env + -- See Note [Fixity declarations in GHCi] + fix_env = tcg_fix_env tc_gblenv + new_ictxt = extendInteractiveContext ictxt new_tythings cls_insts + fam_insts defaults fix_env + return (new_tythings, new_ictxt) + +-- | Load the given static-pointer table entries into the interpreter. +-- See Note [Grand plan for static forms] in StaticPtrTable. +hscAddSptEntries :: HscEnv -> [SptEntry] -> IO () +hscAddSptEntries hsc_env entries = do + let add_spt_entry :: SptEntry -> IO () + add_spt_entry (SptEntry i fpr) = do + val <- getHValue hsc_env (idName i) + addSptEntry hsc_env fpr val + mapM_ add_spt_entry entries + +{- + Note [Fixity declarations in GHCi] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + To support fixity declarations on types defined within GHCi (as requested + in #10018) we record the fixity environment in InteractiveContext. + When we want to evaluate something TcRnDriver.runTcInteractive pulls out this + fixity environment and uses it to initialize the global typechecker environment. + After the typechecker has finished its business, an updated fixity environment + (reflecting whatever fixity declarations were present in the statements we + passed it) will be returned from hscParsedStmt. This is passed to + updateFixityEnv, which will stuff it back into InteractiveContext, to be + used in evaluating the next statement. + +-} + +hscImport :: HscEnv -> String -> IO (ImportDecl GhcPs) +hscImport hsc_env str = runInteractiveHsc hsc_env $ do + (L _ (HsModule{hsmodImports=is})) <- + hscParseThing parseModule str + case is of + [L _ i] -> return i + _ -> liftIO $ throwOneError $ + mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan $ + text "parse error in import declaration" + +-- | Typecheck an expression (but don't run it) +hscTcExpr :: HscEnv + -> TcRnExprMode + -> String -- ^ The expression + -> IO Type +hscTcExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + parsed_expr <- hscParseExpr expr + ioMsgMaybe $ tcRnExpr hsc_env mode parsed_expr + +-- | Find the kind of a type, after generalisation +hscKcType + :: HscEnv + -> Bool -- ^ Normalise the type + -> String -- ^ The type as a string + -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind +hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ty <- hscParseType str + ioMsgMaybe $ tcRnType hsc_env DefaultFlexi normalise ty + +hscParseExpr :: String -> Hsc (LHsExpr GhcPs) +hscParseExpr expr = do + hsc_env <- getHscEnv + maybe_stmt <- hscParseStmt expr + case maybe_stmt of + Just (L _ (BodyStmt _ expr _ _)) -> return expr + _ -> throwOneError $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan + (text "not an expression:" <+> quotes (text expr)) + +hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs)) +hscParseStmt = hscParseThing parseStmt + +hscParseStmtWithLocation :: String -> Int -> String + -> Hsc (Maybe (GhciLStmt GhcPs)) +hscParseStmtWithLocation source linenumber stmt = + hscParseThingWithLocation source linenumber parseStmt stmt + +hscParseType :: String -> Hsc (LHsType GhcPs) +hscParseType = hscParseThing parseType + +hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName) +hscParseIdentifier hsc_env str = + runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str + +hscParseThing :: (Outputable thing, Data thing) + => Lexer.P thing -> String -> Hsc thing +hscParseThing = hscParseThingWithLocation "<interactive>" 1 + +hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int + -> Lexer.P thing -> String -> Hsc thing +hscParseThingWithLocation source linenumber parser str + = withTimingD + (text "Parser [source]") + (const ()) $ {-# SCC "Parser" #-} do + dflags <- getDynFlags + + let buf = stringToStringBuffer str + loc = mkRealSrcLoc (fsLit source) linenumber 1 + + case unP parser (mkPState dflags buf loc) of + PFailed pst -> do + handleWarningsThrowErrors (getMessages pst dflags) + + POk pst thing -> do + logWarningsReportErrors (getMessages pst dflags) + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" + FormatHaskell (ppr thing) + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" + FormatHaskell (showAstData NoBlankSrcSpan thing) + return thing + + +{- ********************************************************************** +%* * + Desugar, simplify, convert to bytecode, and link an expression +%* * +%********************************************************************* -} + +hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue +hscCompileCoreExpr hsc_env = + lookupHook hscCompileCoreExprHook hscCompileCoreExpr' (hsc_dflags hsc_env) hsc_env + +hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue +hscCompileCoreExpr' hsc_env srcspan ds_expr + = do { let dflags = hsc_dflags hsc_env + + {- Simplify it -} + ; simpl_expr <- simplifyExpr hsc_env ds_expr + + {- Tidy it (temporary, until coreSat does cloning) -} + ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr + + {- Prepare for codegen -} + ; prepd_expr <- corePrepExpr dflags hsc_env tidy_expr + + {- Lint if necessary -} + ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr + + {- Convert to BCOs -} + ; bcos <- coreExprToBCOs hsc_env + (icInteractiveModule (hsc_IC hsc_env)) prepd_expr + + {- link it -} + ; hval <- linkExpr hsc_env srcspan bcos + + ; return hval } + + +{- ********************************************************************** +%* * + Statistics on reading interfaces +%* * +%********************************************************************* -} + +dumpIfaceStats :: HscEnv -> IO () +dumpIfaceStats hsc_env = do + eps <- readIORef (hsc_EPS hsc_env) + dumpIfSet dflags (dump_if_trace || dump_rn_stats) + "Interface statistics" + (ifaceStats eps) + where + dflags = hsc_dflags hsc_env + dump_rn_stats = dopt Opt_D_dump_rn_stats dflags + dump_if_trace = dopt Opt_D_dump_if_trace dflags + + +{- ********************************************************************** +%* * + Progress Messages: Module i of n +%* * +%********************************************************************* -} + +showModuleIndex :: (Int, Int) -> String +showModuleIndex (i,n) = "[" ++ padded ++ " of " ++ n_str ++ "] " + where + n_str = show n + i_str = show i + padded = replicate (length n_str - length i_str) ' ' ++ i_str diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs new file mode 100644 index 0000000000..e1aa392771 --- /dev/null +++ b/compiler/GHC/Driver/Make.hs @@ -0,0 +1,2739 @@ +{-# LANGUAGE BangPatterns, CPP, NondecreasingIndentation, ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2011 +-- +-- This module implements multi-module compilation, and is used +-- by --make and GHCi. +-- +-- ----------------------------------------------------------------------------- +module GHC.Driver.Make ( + depanal, depanalE, depanalPartial, + load, load', LoadHowMuch(..), + + downsweep, + + topSortModuleGraph, + + ms_home_srcimps, ms_home_imps, + + IsBoot(..), + summariseModule, + hscSourceToIsBoot, + findExtraSigImports, + implicitRequirements, + + noModError, cyclicModuleErr, + moduleGraphNodes, SummaryNode + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import qualified GHC.Runtime.Linker as Linker + +import GHC.Driver.Phases +import GHC.Driver.Pipeline +import GHC.Driver.Session +import ErrUtils +import GHC.Driver.Finder +import GHC.Driver.Monad +import HeaderInfo +import GHC.Driver.Types +import Module +import GHC.IfaceToCore ( typecheckIface ) +import TcRnMonad ( initIfaceCheck ) +import GHC.Driver.Main + +import Bag ( unitBag, listToBag, unionManyBags, isEmptyBag ) +import BasicTypes +import Digraph +import Exception ( tryIO, gbracket, gfinally ) +import FastString +import Maybes ( expectJust ) +import Name +import MonadUtils ( allM ) +import Outputable +import Panic +import SrcLoc +import StringBuffer +import UniqFM +import UniqDSet +import TcBackpack +import GHC.Driver.Packages +import UniqSet +import Util +import qualified GHC.LanguageExtensions as LangExt +import NameEnv +import FileCleanup + +import Data.Either ( rights, partitionEithers ) +import qualified Data.Map as Map +import Data.Map (Map) +import qualified Data.Set as Set +import qualified FiniteMap as Map ( insertListWith ) + +import Control.Concurrent ( forkIOWithUnmask, killThread ) +import qualified GHC.Conc as CC +import Control.Concurrent.MVar +import Control.Concurrent.QSem +import Control.Exception +import Control.Monad +import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE ) +import Data.IORef +import Data.List +import qualified Data.List as List +import Data.Foldable (toList) +import Data.Maybe +import Data.Ord ( comparing ) +import Data.Time +import System.Directory +import System.FilePath +import System.IO ( fixIO ) +import System.IO.Error ( isDoesNotExistError ) + +import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities ) + +label_self :: String -> IO () +label_self thread_name = do + self_tid <- CC.myThreadId + CC.labelThread self_tid thread_name + +-- ----------------------------------------------------------------------------- +-- Loading the program + +-- | Perform a dependency analysis starting from the current targets +-- and update the session with the new module graph. +-- +-- Dependency analysis entails parsing the @import@ directives and may +-- therefore require running certain preprocessors. +-- +-- Note that each 'ModSummary' in the module graph caches its 'DynFlags'. +-- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the +-- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module. Thus if you want +-- changes to the 'DynFlags' to take effect you need to call this function +-- again. +-- In case of errors, just throw them. +-- +depanal :: GhcMonad m => + [ModuleName] -- ^ excluded modules + -> Bool -- ^ allow duplicate roots + -> m ModuleGraph +depanal excluded_mods allow_dup_roots = do + (errs, mod_graph) <- depanalE excluded_mods allow_dup_roots + if isEmptyBag errs + then pure mod_graph + else throwErrors errs + +-- | Perform dependency analysis like in 'depanal'. +-- In case of errors, the errors and an empty module graph are returned. +depanalE :: GhcMonad m => -- New for #17459 + [ModuleName] -- ^ excluded modules + -> Bool -- ^ allow duplicate roots + -> m (ErrorMessages, ModuleGraph) +depanalE excluded_mods allow_dup_roots = do + hsc_env <- getSession + (errs, mod_graph) <- depanalPartial excluded_mods allow_dup_roots + if isEmptyBag errs + then do + warnMissingHomeModules hsc_env mod_graph + setSession hsc_env { hsc_mod_graph = mod_graph } + pure (errs, mod_graph) + else do + -- We don't have a complete module dependency graph, + -- The graph may be disconnected and is unusable. + setSession hsc_env { hsc_mod_graph = emptyMG } + pure (errs, emptyMG) + + +-- | Perform dependency analysis like 'depanal' but return a partial module +-- graph even in the face of problems with some modules. +-- +-- Modules which have parse errors in the module header, failing +-- preprocessors or other issues preventing them from being summarised will +-- simply be absent from the returned module graph. +-- +-- Unlike 'depanal' this function will not update 'hsc_mod_graph' with the +-- new module graph. +depanalPartial + :: GhcMonad m + => [ModuleName] -- ^ excluded modules + -> Bool -- ^ allow duplicate roots + -> m (ErrorMessages, ModuleGraph) + -- ^ possibly empty 'Bag' of errors and a module graph. +depanalPartial excluded_mods allow_dup_roots = do + hsc_env <- getSession + let + dflags = hsc_dflags hsc_env + targets = hsc_targets hsc_env + old_graph = hsc_mod_graph hsc_env + + withTiming dflags (text "Chasing dependencies") (const ()) $ do + liftIO $ debugTraceMsg dflags 2 (hcat [ + text "Chasing modules from: ", + hcat (punctuate comma (map pprTarget targets))]) + + -- Home package modules may have been moved or deleted, and new + -- source files may have appeared in the home package that shadow + -- external package modules, so we have to discard the existing + -- cached finder data. + liftIO $ flushFinderCaches hsc_env + + mod_summariesE <- liftIO $ downsweep hsc_env (mgModSummaries old_graph) + excluded_mods allow_dup_roots + let + (errs, mod_summaries) = partitionEithers mod_summariesE + mod_graph = mkModuleGraph mod_summaries + return (unionManyBags errs, mod_graph) + +-- Note [Missing home modules] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Sometimes user doesn't want GHC to pick up modules, not explicitly listed +-- in a command line. For example, cabal may want to enable this warning +-- when building a library, so that GHC warns user about modules, not listed +-- neither in `exposed-modules`, nor in `other-modules`. +-- +-- Here "home module" means a module, that doesn't come from an other package. +-- +-- For example, if GHC is invoked with modules "A" and "B" as targets, +-- but "A" imports some other module "C", then GHC will issue a warning +-- about module "C" not being listed in a command line. +-- +-- The warning in enabled by `-Wmissing-home-modules`. See #13129 +warnMissingHomeModules :: GhcMonad m => HscEnv -> ModuleGraph -> m () +warnMissingHomeModules hsc_env mod_graph = + when (wopt Opt_WarnMissingHomeModules dflags && not (null missing)) $ + logWarnings (listToBag [warn]) + where + dflags = hsc_dflags hsc_env + targets = map targetId (hsc_targets hsc_env) + + is_known_module mod = any (is_my_target mod) targets + + -- We need to be careful to handle the case where (possibly + -- path-qualified) filenames (aka 'TargetFile') rather than module + -- names are being passed on the GHC command-line. + -- + -- For instance, `ghc --make src-exe/Main.hs` and + -- `ghc --make -isrc-exe Main` are supposed to be equivalent. + -- Note also that we can't always infer the associated module name + -- directly from the filename argument. See #13727. + is_my_target mod (TargetModule name) + = moduleName (ms_mod mod) == name + is_my_target mod (TargetFile target_file _) + | Just mod_file <- ml_hs_file (ms_location mod) + = target_file == mod_file || + + -- Don't warn on B.hs-boot if B.hs is specified (#16551) + addBootSuffix target_file == mod_file || + + -- We can get a file target even if a module name was + -- originally specified in a command line because it can + -- be converted in guessTarget (by appending .hs/.lhs). + -- So let's convert it back and compare with module name + mkModuleName (fst $ splitExtension target_file) + == moduleName (ms_mod mod) + is_my_target _ _ = False + + missing = map (moduleName . ms_mod) $ + filter (not . is_known_module) (mgModSummaries mod_graph) + + msg + | gopt Opt_BuildingCabalPackage dflags + = hang + (text "These modules are needed for compilation but not listed in your .cabal file's other-modules: ") + 4 + (sep (map ppr missing)) + | otherwise + = + 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) + +-- | Describes which modules of the module graph need to be loaded. +data LoadHowMuch + = LoadAllTargets + -- ^ Load all targets and its dependencies. + | LoadUpTo ModuleName + -- ^ Load only the given module and its dependencies. + | LoadDependenciesOf ModuleName + -- ^ Load only the dependencies of the given module, but not the module + -- itself. + +-- | Try to load the program. See 'LoadHowMuch' for the different modes. +-- +-- This function implements the core of GHC's @--make@ mode. It preprocesses, +-- compiles and loads the specified modules, avoiding re-compilation wherever +-- possible. Depending on the target (see 'DynFlags.hscTarget') compiling +-- and loading may result in files being created on disk. +-- +-- Calls the 'defaultWarnErrLogger' after each compiling each module, whether +-- successful or not. +-- +-- If errors are encountered during dependency analysis, the module `depanalE` +-- returns together with the errors an empty ModuleGraph. +-- After processing this empty ModuleGraph, the errors of depanalE are thrown. +-- All other errors are reported using the 'defaultWarnErrLogger'. +-- +load :: GhcMonad m => LoadHowMuch -> m SuccessFlag +load how_much = do + (errs, mod_graph) <- depanalE [] False -- #17459 + success <- load' how_much (Just batchMsg) mod_graph + warnUnusedPackages + if isEmptyBag errs + then pure success + else throwErrors errs + +-- Note [Unused packages] +-- +-- Cabal passes `--package-id` flag for each direct dependency. But GHC +-- loads them lazily, so when compilation is done, we have a list of all +-- actually loaded packages. All the packages, specified on command line, +-- but never loaded, are probably unused dependencies. + +warnUnusedPackages :: GhcMonad m => m () +warnUnusedPackages = do + hsc_env <- getSession + eps <- liftIO $ hscEPS hsc_env + + let dflags = hsc_dflags hsc_env + pit = eps_PIT eps + + let loadedPackages + = map (getPackageDetails dflags) + . nub . sort + . map moduleUnitId + . moduleEnvKeys + $ pit + + requestedArgs = mapMaybe packageArg (packageFlags dflags) + + unusedArgs + = filter (\arg -> not $ any (matching dflags arg) loadedPackages) + requestedArgs + + let warn = makeIntoWarning + (Reason Opt_WarnUnusedPackages) + (mkPlainErrMsg dflags noSrcSpan msg) + msg = vcat [ text "The following packages were specified" <+> + text "via -package or -package-id flags," + , text "but were not needed for compilation:" + , nest 2 (vcat (map (withDash . pprUnusedArg) unusedArgs)) ] + + when (wopt Opt_WarnUnusedPackages dflags && not (null unusedArgs)) $ + logWarnings (listToBag [warn]) + + where + packageArg (ExposePackage _ arg _) = Just arg + packageArg _ = Nothing + + pprUnusedArg (PackageArg str) = text str + pprUnusedArg (UnitIdArg uid) = ppr uid + + withDash = (<+>) (text "-") + + matchingStr :: String -> UnitInfo -> Bool + matchingStr str p + = str == sourcePackageIdString p + || str == packageNameString p + + matching :: DynFlags -> PackageArg -> UnitInfo -> Bool + matching _ (PackageArg str) p = matchingStr str p + matching dflags (UnitIdArg uid) p = uid == realUnitId dflags p + + -- For wired-in packages, we have to unwire their id, + -- otherwise they won't match package flags + realUnitId :: DynFlags -> UnitInfo -> UnitId + realUnitId dflags + = unwireUnitId dflags + . DefiniteUnitId + . DefUnitId + . installedUnitInfoId + +-- | Generalized version of 'load' which also supports a custom +-- 'Messager' (for reporting progress) and 'ModuleGraph' (generally +-- produced by calling 'depanal'. +load' :: GhcMonad m => LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag +load' how_much mHscMessage mod_graph = do + modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph } + guessOutputFile + hsc_env <- getSession + + let hpt1 = hsc_HPT hsc_env + let dflags = hsc_dflags hsc_env + + -- The "bad" boot modules are the ones for which we have + -- B.hs-boot in the module graph, but no B.hs + -- The downsweep should have ensured this does not happen + -- (see msDeps) + let all_home_mods = + mkUniqSet [ ms_mod_name s + | s <- mgModSummaries mod_graph, not (isBootSummary s)] + -- TODO: Figure out what the correct form of this assert is. It's violated + -- when you have HsBootMerge nodes in the graph: then you'll have hs-boot + -- files without corresponding hs files. + -- bad_boot_mods = [s | s <- mod_graph, isBootSummary s, + -- not (ms_mod_name s `elem` all_home_mods)] + -- ASSERT( null bad_boot_mods ) return () + + -- check that the module given in HowMuch actually exists, otherwise + -- topSortModuleGraph will bomb later. + let checkHowMuch (LoadUpTo m) = checkMod m + checkHowMuch (LoadDependenciesOf m) = checkMod m + checkHowMuch _ = id + + checkMod m and_then + | m `elementOfUniqSet` all_home_mods = and_then + | otherwise = do + liftIO $ errorMsg dflags (text "no such module:" <+> + quotes (ppr m)) + return Failed + + checkHowMuch how_much $ do + + -- mg2_with_srcimps drops the hi-boot nodes, returning a + -- graph with cycles. Among other things, it is used for + -- backing out partially complete cycles following a failed + -- upsweep, and for removing from hpt all the modules + -- not in strict downwards closure, during calls to compile. + let mg2_with_srcimps :: [SCC ModSummary] + mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing + + -- If we can determine that any of the {-# SOURCE #-} imports + -- are definitely unnecessary, then emit a warning. + warnUnnecessarySourceImports mg2_with_srcimps + + let + -- check the stability property for each module. + stable_mods@(stable_obj,stable_bco) + = checkStability hpt1 mg2_with_srcimps all_home_mods + + -- prune bits of the HPT which are definitely redundant now, + -- to save space. + pruned_hpt = pruneHomePackageTable hpt1 + (flattenSCCs mg2_with_srcimps) + stable_mods + + _ <- liftIO $ evaluate pruned_hpt + + -- before we unload anything, make sure we don't leave an old + -- interactive context around pointing to dead bindings. Also, + -- write the pruned HPT to allow the old HPT to be GC'd. + setSession $ discardIC $ hsc_env { hsc_HPT = pruned_hpt } + + liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$ + text "Stable BCO:" <+> ppr stable_bco) + + -- Unload any modules which are going to be re-linked this time around. + let stable_linkables = [ linkable + | m <- nonDetEltsUniqSet stable_obj ++ + nonDetEltsUniqSet stable_bco, + -- It's OK to use nonDetEltsUniqSet here + -- because it only affects linking. Besides + -- this list only serves as a poor man's set. + Just hmi <- [lookupHpt pruned_hpt m], + Just linkable <- [hm_linkable hmi] ] + liftIO $ unload hsc_env stable_linkables + + -- We could at this point detect cycles which aren't broken by + -- a source-import, and complain immediately, but it seems better + -- to let upsweep_mods do this, so at least some useful work gets + -- done before the upsweep is abandoned. + --hPutStrLn stderr "after tsort:\n" + --hPutStrLn stderr (showSDoc (vcat (map ppr mg2))) + + -- Now do the upsweep, calling compile for each module in + -- turn. Final result is version 3 of everything. + + -- Topologically sort the module graph, this time including hi-boot + -- nodes, and possibly just including the portion of the graph + -- reachable from the module specified in the 2nd argument to load. + -- This graph should be cycle-free. + -- If we're restricting the upsweep to a portion of the graph, we + -- also want to retain everything that is still stable. + let full_mg :: [SCC ModSummary] + full_mg = topSortModuleGraph False mod_graph Nothing + + maybe_top_mod = case how_much of + LoadUpTo m -> Just m + LoadDependenciesOf m -> Just m + _ -> Nothing + + partial_mg0 :: [SCC ModSummary] + partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod + + -- LoadDependenciesOf m: we want the upsweep to stop just + -- short of the specified module (unless the specified module + -- is stable). + partial_mg + | LoadDependenciesOf _mod <- how_much + = ASSERT( case last partial_mg0 of + AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False ) + List.init partial_mg0 + | otherwise + = partial_mg0 + + stable_mg = + [ AcyclicSCC ms + | AcyclicSCC ms <- full_mg, + stable_mod_summary ms ] + + stable_mod_summary ms = + ms_mod_name ms `elementOfUniqSet` stable_obj || + ms_mod_name ms `elementOfUniqSet` stable_bco + + -- the modules from partial_mg that are not also stable + -- NB. also keep cycles, we need to emit an error message later + unstable_mg = filter not_stable partial_mg + where not_stable (CyclicSCC _) = True + not_stable (AcyclicSCC ms) + = not $ stable_mod_summary ms + + -- Load all the stable modules first, before attempting to load + -- an unstable module (#7231). + mg = stable_mg ++ unstable_mg + + -- clean up between compilations + let cleanup = cleanCurrentModuleTempFiles . hsc_dflags + liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep") + 2 (ppr mg)) + + n_jobs <- case parMakeCount dflags of + Nothing -> liftIO getNumProcessors + Just n -> return n + let upsweep_fn | n_jobs > 1 = parUpsweep n_jobs + | otherwise = upsweep + + setSession hsc_env{ hsc_HPT = emptyHomePackageTable } + (upsweep_ok, modsUpswept) <- withDeferredDiagnostics $ + upsweep_fn mHscMessage pruned_hpt stable_mods cleanup mg + + -- Make modsDone be the summaries for each home module now + -- available; this should equal the domain of hpt3. + -- Get in in a roughly top .. bottom order (hence reverse). + + let modsDone = reverse modsUpswept + + -- Try and do linking in some form, depending on whether the + -- upsweep was completely or only partially successful. + + if succeeded upsweep_ok + + then + -- Easy; just relink it all. + do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.") + + -- Clean up after ourselves + hsc_env1 <- getSession + liftIO $ cleanCurrentModuleTempFiles dflags + + -- Issue a warning for the confusing case where the user + -- said '-o foo' but we're not going to do any linking. + -- We attempt linking if either (a) one of the modules is + -- called Main, or (b) the user said -no-hs-main, indicating + -- that main() is going to come from somewhere else. + -- + let ofile = outputFile dflags + let no_hs_main = gopt Opt_NoHsMain dflags + let + main_mod = mainModIs dflags + a_root_is_Main = mgElemModule mod_graph main_mod + do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib + + -- link everything together + linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1) + + if ghcLink dflags == LinkBinary && isJust ofile && not do_linking + then do + liftIO $ errorMsg dflags $ text + ("output was redirected with -o, " ++ + "but no output will be generated\n" ++ + "because there is no " ++ + moduleNameString (moduleName main_mod) ++ " module.") + -- This should be an error, not a warning (#10895). + loadFinish Failed linkresult + else + loadFinish Succeeded linkresult + + else + -- Tricky. We need to back out the effects of compiling any + -- half-done cycles, both so as to clean up the top level envs + -- and to avoid telling the interactive linker to link them. + do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.") + + let modsDone_names + = map ms_mod modsDone + let mods_to_zap_names + = findPartiallyCompletedCycles modsDone_names + mg2_with_srcimps + let (mods_to_clean, mods_to_keep) = + partition ((`Set.member` mods_to_zap_names).ms_mod) modsDone + hsc_env1 <- getSession + let hpt4 = hsc_HPT hsc_env1 + -- We must change the lifetime to TFL_CurrentModule for any temp + -- file created for an element of mod_to_clean during the upsweep. + -- These include preprocessed files and object files for loaded + -- modules. + unneeded_temps = concat + [ms_hspp_file : object_files + | ModSummary{ms_mod, ms_hspp_file} <- mods_to_clean + , let object_files = maybe [] linkableObjs $ + lookupHpt hpt4 (moduleName ms_mod) + >>= hm_linkable + ] + liftIO $ + changeTempFilesLifetime dflags TFL_CurrentModule unneeded_temps + liftIO $ cleanCurrentModuleTempFiles dflags + + let hpt5 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) + hpt4 + + -- Clean up after ourselves + + -- there should be no Nothings where linkables should be, now + let just_linkables = + isNoLink (ghcLink dflags) + || allHpt (isJust.hm_linkable) + (filterHpt ((== HsSrcFile).mi_hsc_src.hm_iface) + hpt5) + ASSERT( just_linkables ) do + + -- Link everything together + linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt5 + + modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt5 } + loadFinish Failed linkresult + + +-- | Finish up after a load. +loadFinish :: GhcMonad m => SuccessFlag -> SuccessFlag -> m SuccessFlag + +-- If the link failed, unload everything and return. +loadFinish _all_ok Failed + = do hsc_env <- getSession + liftIO $ unload hsc_env [] + modifySession discardProg + return Failed + +-- Empty the interactive context and set the module context to the topmost +-- newly loaded module, or the Prelude if none were loaded. +loadFinish all_ok Succeeded + = do modifySession discardIC + return all_ok + + +-- | Forget the current program, but retain the persistent info in HscEnv +discardProg :: HscEnv -> HscEnv +discardProg hsc_env + = discardIC $ hsc_env { hsc_mod_graph = emptyMG + , hsc_HPT = emptyHomePackageTable } + +-- | Discard the contents of the InteractiveContext, but keep the DynFlags. +-- It will also keep ic_int_print and ic_monad if their names are from +-- external packages. +discardIC :: HscEnv -> HscEnv +discardIC hsc_env + = hsc_env { hsc_IC = empty_ic { ic_int_print = new_ic_int_print + , ic_monad = new_ic_monad } } + where + -- Force the new values for ic_int_print and ic_monad to avoid leaking old_ic + !new_ic_int_print = keep_external_name ic_int_print + !new_ic_monad = keep_external_name ic_monad + dflags = ic_dflags old_ic + old_ic = hsc_IC hsc_env + empty_ic = emptyInteractiveContext dflags + keep_external_name ic_name + | nameIsFromExternalPackage this_pkg old_name = old_name + | otherwise = ic_name empty_ic + where + this_pkg = thisPackage dflags + old_name = ic_name old_ic + +-- | If there is no -o option, guess the name of target executable +-- by using top-level source file name as a base. +guessOutputFile :: GhcMonad m => m () +guessOutputFile = modifySession $ \env -> + let dflags = hsc_dflags env + -- Force mod_graph to avoid leaking env + !mod_graph = hsc_mod_graph env + mainModuleSrcPath :: Maybe String + mainModuleSrcPath = do + ms <- mgLookupModule mod_graph (mainModIs dflags) + ml_hs_file (ms_location ms) + name = fmap dropExtension mainModuleSrcPath + + name_exe = do +#if defined(mingw32_HOST_OS) + -- we must add the .exe extension unconditionally here, otherwise + -- when name has an extension of its own, the .exe extension will + -- not be added by GHC.Driver.Pipeline.exeFileName. See #2248 + name' <- fmap (<.> "exe") name +#else + name' <- name +#endif + mainModuleSrcPath' <- mainModuleSrcPath + -- #9930: don't clobber input files (unless they ask for it) + if name' == mainModuleSrcPath' + then throwGhcException . UsageError $ + "default output name would overwrite the input file; " ++ + "must specify -o explicitly" + else Just name' + in + case outputFile dflags of + Just _ -> env + Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } } + +-- ----------------------------------------------------------------------------- +-- +-- | Prune the HomePackageTable +-- +-- Before doing an upsweep, we can throw away: +-- +-- - For non-stable modules: +-- - all ModDetails, all linked code +-- - all unlinked code that is out of date with respect to +-- the source file +-- +-- This is VERY IMPORTANT otherwise we'll end up requiring 2x the +-- space at the end of the upsweep, because the topmost ModDetails of the +-- old HPT holds on to the entire type environment from the previous +-- compilation. +pruneHomePackageTable :: HomePackageTable + -> [ModSummary] + -> StableModules + -> HomePackageTable +pruneHomePackageTable hpt summ (stable_obj, stable_bco) + = mapHpt prune hpt + where prune hmi + | is_stable modl = hmi' + | otherwise = hmi'{ hm_details = emptyModDetails } + where + modl = moduleName (mi_module (hm_iface hmi)) + hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms + = hmi{ hm_linkable = Nothing } + | otherwise + = hmi + where ms = expectJust "prune" (lookupUFM ms_map modl) + + ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ] + + is_stable m = + m `elementOfUniqSet` stable_obj || + m `elementOfUniqSet` stable_bco + +-- ----------------------------------------------------------------------------- +-- +-- | Return (names of) all those in modsDone who are part of a cycle as defined +-- by theGraph. +findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> Set.Set Module +findPartiallyCompletedCycles modsDone theGraph + = Set.unions + [mods_in_this_cycle + | CyclicSCC vs <- theGraph -- Acyclic? Not interesting. + , let names_in_this_cycle = Set.fromList (map ms_mod vs) + mods_in_this_cycle = + Set.intersection (Set.fromList modsDone) names_in_this_cycle + -- If size mods_in_this_cycle == size names_in_this_cycle, + -- then this cycle has already been completed and we're not + -- interested. + , Set.size mods_in_this_cycle < Set.size names_in_this_cycle] + + +-- --------------------------------------------------------------------------- +-- +-- | Unloading +unload :: HscEnv -> [Linkable] -> IO () +unload hsc_env stable_linkables -- Unload everything *except* 'stable_linkables' + = case ghcLink (hsc_dflags hsc_env) of + LinkInMemory -> Linker.unload hsc_env stable_linkables + _other -> return () + +-- ----------------------------------------------------------------------------- +{- | + + Stability tells us which modules definitely do not need to be recompiled. + There are two main reasons for having stability: + + - avoid doing a complete upsweep of the module graph in GHCi when + modules near the bottom of the tree have not changed. + + - to tell GHCi when it can load object code: we can only load object code + for a module when we also load object code fo all of the imports of the + module. So we need to know that we will definitely not be recompiling + any of these modules, and we can use the object code. + + The stability check is as follows. Both stableObject and + stableBCO are used during the upsweep phase later. + +@ + stable m = stableObject m || stableBCO m + + stableObject m = + all stableObject (imports m) + && old linkable does not exist, or is == on-disk .o + && date(on-disk .o) > date(.hs) + + stableBCO m = + all stable (imports m) + && date(BCO) > date(.hs) +@ + + These properties embody the following ideas: + + - if a module is stable, then: + + - if it has been compiled in a previous pass (present in HPT) + then it does not need to be compiled or re-linked. + + - if it has not been compiled in a previous pass, + then we only need to read its .hi file from disk and + link it to produce a 'ModDetails'. + + - if a modules is not stable, we will definitely be at least + re-linking, and possibly re-compiling it during the 'upsweep'. + All non-stable modules can (and should) therefore be unlinked + before the 'upsweep'. + + - Note that objects are only considered stable if they only depend + on other objects. We can't link object code against byte code. + + - Note that even if an object is stable, we may end up recompiling + if the interface is out of date because an *external* interface + has changed. The current code in GHC.Driver.Make handles this case + fairly poorly, so be careful. +-} + +type StableModules = + ( UniqSet ModuleName -- stableObject + , UniqSet ModuleName -- stableBCO + ) + + +checkStability + :: HomePackageTable -- HPT from last compilation + -> [SCC ModSummary] -- current module graph (cyclic) + -> UniqSet ModuleName -- all home modules + -> StableModules + +checkStability hpt sccs all_home_mods = + foldl' checkSCC (emptyUniqSet, emptyUniqSet) sccs + where + checkSCC :: StableModules -> SCC ModSummary -> StableModules + checkSCC (stable_obj, stable_bco) scc0 + | stableObjects = (addListToUniqSet stable_obj scc_mods, stable_bco) + | stableBCOs = (stable_obj, addListToUniqSet stable_bco scc_mods) + | otherwise = (stable_obj, stable_bco) + where + scc = flattenSCC scc0 + scc_mods = map ms_mod_name scc + home_module m = + m `elementOfUniqSet` all_home_mods && m `notElem` scc_mods + + scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc)) + -- all imports outside the current SCC, but in the home pkg + + stable_obj_imps = map (`elementOfUniqSet` stable_obj) scc_allimps + stable_bco_imps = map (`elementOfUniqSet` stable_bco) scc_allimps + + stableObjects = + and stable_obj_imps + && all object_ok scc + + stableBCOs = + and (zipWith (||) stable_obj_imps stable_bco_imps) + && all bco_ok scc + + object_ok ms + | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False + | Just t <- ms_obj_date ms = t >= ms_hs_date ms + && same_as_prev t + | otherwise = False + where + same_as_prev t = case lookupHpt hpt (ms_mod_name ms) of + Just hmi | Just l <- hm_linkable hmi + -> isObjectLinkable l && t == linkableTime l + _other -> True + -- why '>=' rather than '>' above? If the filesystem stores + -- times to the nearest second, we may occasionally find that + -- the object & source have the same modification time, + -- especially if the source was automatically generated + -- and compiled. Using >= is slightly unsafe, but it matches + -- make's behaviour. + -- + -- But see #5527, where someone ran into this and it caused + -- a problem. + + bco_ok ms + | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False + | otherwise = case lookupHpt hpt (ms_mod_name ms) of + Just hmi | Just l <- hm_linkable hmi -> + not (isObjectLinkable l) && + linkableTime l >= ms_hs_date ms + _other -> False + +{- Parallel Upsweep + - + - The parallel upsweep attempts to concurrently compile the modules in the + - compilation graph using multiple Haskell threads. + - + - The Algorithm + - + - A Haskell thread is spawned for each module in the module graph, waiting for + - its direct dependencies to finish building before it itself begins to build. + - + - Each module is associated with an initially empty MVar that stores the + - result of that particular module's compile. If the compile succeeded, then + - the HscEnv (synchronized by an MVar) is updated with the fresh HMI of that + - module, and the module's HMI is deleted from the old HPT (synchronized by an + - IORef) to save space. + - + - Instead of immediately outputting messages to the standard handles, all + - compilation output is deferred to a per-module TQueue. A QSem is used to + - limit the number of workers that are compiling simultaneously. + - + - Meanwhile, the main thread sequentially loops over all the modules in the + - module graph, outputting the messages stored in each module's TQueue. +-} + +-- | Each module is given a unique 'LogQueue' to redirect compilation messages +-- to. A 'Nothing' value contains the result of compilation, and denotes the +-- end of the message queue. +data LogQueue = LogQueue !(IORef [Maybe (WarnReason, Severity, SrcSpan, PprStyle, MsgDoc)]) + !(MVar ()) + +-- | The graph of modules to compile and their corresponding result 'MVar' and +-- 'LogQueue'. +type CompilationGraph = [(ModSummary, MVar SuccessFlag, LogQueue)] + +-- | Build a 'CompilationGraph' out of a list of strongly-connected modules, +-- also returning the first, if any, encountered module cycle. +buildCompGraph :: [SCC ModSummary] -> IO (CompilationGraph, Maybe [ModSummary]) +buildCompGraph [] = return ([], Nothing) +buildCompGraph (scc:sccs) = case scc of + AcyclicSCC ms -> do + mvar <- newEmptyMVar + log_queue <- do + ref <- newIORef [] + sem <- newEmptyMVar + return (LogQueue ref sem) + (rest,cycle) <- buildCompGraph sccs + return ((ms,mvar,log_queue):rest, cycle) + CyclicSCC mss -> return ([], Just mss) + +-- A Module and whether it is a boot module. +type BuildModule = (Module, IsBoot) + +-- | 'Bool' indicating if a module is a boot module or not. We need to treat +-- boot modules specially when building compilation graphs, since they break +-- cycles. Regular source files and signature files are treated equivalently. +data IsBoot = IsBoot | NotBoot + deriving (Ord, Eq, Show, Read) + +-- | Tests if an 'HscSource' is a boot file, primarily for constructing +-- elements of 'BuildModule'. +hscSourceToIsBoot :: HscSource -> IsBoot +hscSourceToIsBoot HsBootFile = IsBoot +hscSourceToIsBoot _ = NotBoot + +mkBuildModule :: ModSummary -> BuildModule +mkBuildModule ms = (ms_mod ms, if isBootSummary ms then IsBoot else NotBoot) + +-- | The entry point to the parallel upsweep. +-- +-- See also the simpler, sequential 'upsweep'. +parUpsweep + :: GhcMonad m + => Int + -- ^ The number of workers we wish to run in parallel + -> Maybe Messager + -> HomePackageTable + -> StableModules + -> (HscEnv -> IO ()) + -> [SCC ModSummary] + -> m (SuccessFlag, + [ModSummary]) +parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do + hsc_env <- getSession + let dflags = hsc_dflags hsc_env + + when (not (null (unitIdsToCheck dflags))) $ + throwGhcException (ProgramError "Backpack typechecking not supported with -j") + + -- The bits of shared state we'll be using: + + -- The global HscEnv is updated with the module's HMI when a module + -- successfully compiles. + hsc_env_var <- liftIO $ newMVar hsc_env + + -- The old HPT is used for recompilation checking in upsweep_mod. When a + -- module successfully gets compiled, its HMI is pruned from the old HPT. + old_hpt_var <- liftIO $ newIORef old_hpt + + -- What we use to limit parallelism with. + par_sem <- liftIO $ newQSem n_jobs + + + let updNumCapabilities = liftIO $ do + n_capabilities <- getNumCapabilities + n_cpus <- getNumProcessors + -- Setting number of capabilities more than + -- CPU count usually leads to high userspace + -- lock contention. #9221 + let n_caps = min n_jobs n_cpus + unless (n_capabilities /= 1) $ setNumCapabilities n_caps + return n_capabilities + -- Reset the number of capabilities once the upsweep ends. + let resetNumCapabilities orig_n = liftIO $ setNumCapabilities orig_n + + gbracket updNumCapabilities resetNumCapabilities $ \_ -> do + + -- Sync the global session with the latest HscEnv once the upsweep ends. + let finallySyncSession io = io `gfinally` do + hsc_env <- liftIO $ readMVar hsc_env_var + setSession hsc_env + + finallySyncSession $ do + + -- Build the compilation graph out of the list of SCCs. Module cycles are + -- handled at the very end, after some useful work gets done. Note that + -- this list is topologically sorted (by virtue of 'sccs' being sorted so). + (comp_graph,cycle) <- liftIO $ buildCompGraph sccs + let comp_graph_w_idx = zip comp_graph [1..] + + -- The list of all loops in the compilation graph. + -- NB: For convenience, the last module of each loop (aka the module that + -- finishes the loop) is prepended to the beginning of the loop. + let graph = map fstOf3 (reverse comp_graph) + boot_modules = mkModuleSet [ms_mod ms | ms <- graph, isBootSummary ms] + comp_graph_loops = go graph boot_modules + where + remove ms bm + | isBootSummary ms = delModuleSet bm (ms_mod ms) + | otherwise = bm + go [] _ = [] + go mg@(ms:mss) boot_modules + | Just loop <- getModLoop ms mg (`elemModuleSet` boot_modules) + = map mkBuildModule (ms:loop) : go mss (remove ms boot_modules) + | otherwise + = go mss (remove ms boot_modules) + + -- Build a Map out of the compilation graph with which we can efficiently + -- look up the result MVar associated with a particular home module. + let home_mod_map :: Map BuildModule (MVar SuccessFlag, Int) + home_mod_map = + Map.fromList [ (mkBuildModule ms, (mvar, idx)) + | ((ms,mvar,_),idx) <- comp_graph_w_idx ] + + + liftIO $ label_self "main --make thread" + -- For each module in the module graph, spawn a worker thread that will + -- compile this module. + let { spawnWorkers = forM comp_graph_w_idx $ \((mod,!mvar,!log_queue),!mod_idx) -> + forkIOWithUnmask $ \unmask -> do + liftIO $ label_self $ unwords + [ "worker --make thread" + , "for module" + , show (moduleNameString (ms_mod_name mod)) + , "number" + , show mod_idx + ] + -- Replace the default log_action with one that writes each + -- message to the module's log_queue. The main thread will + -- deal with synchronously printing these messages. + -- + -- Use a local filesToClean var so that we can clean up + -- intermediate files in a timely fashion (as soon as + -- compilation for that module is finished) without having to + -- worry about accidentally deleting a simultaneous compile's + -- important files. + lcl_files_to_clean <- newIORef emptyFilesToClean + let lcl_dflags = dflags { log_action = parLogAction log_queue + , filesToClean = lcl_files_to_clean } + + -- Unmask asynchronous exceptions and perform the thread-local + -- work to compile the module (see parUpsweep_one). + m_res <- try $ unmask $ prettyPrintGhcErrors lcl_dflags $ + parUpsweep_one mod home_mod_map comp_graph_loops + lcl_dflags mHscMessage cleanup + par_sem hsc_env_var old_hpt_var + stable_mods mod_idx (length sccs) + + res <- case m_res of + Right flag -> return flag + Left exc -> do + -- Don't print ThreadKilled exceptions: they are used + -- to kill the worker thread in the event of a user + -- interrupt, and the user doesn't have to be informed + -- about that. + when (fromException exc /= Just ThreadKilled) + (errorMsg lcl_dflags (text (show exc))) + return Failed + + -- Populate the result MVar. + putMVar mvar res + + -- Write the end marker to the message queue, telling the main + -- thread that it can stop waiting for messages from this + -- particular compile. + writeLogQueue log_queue Nothing + + -- Add the remaining files that weren't cleaned up to the + -- global filesToClean ref, for cleanup later. + FilesToClean + { ftcCurrentModule = cm_files + , ftcGhcSession = gs_files + } <- readIORef (filesToClean lcl_dflags) + addFilesToClean dflags TFL_CurrentModule $ Set.toList cm_files + addFilesToClean dflags TFL_GhcSession $ Set.toList gs_files + + -- Kill all the workers, masking interrupts (since killThread is + -- interruptible). XXX: This is not ideal. + ; killWorkers = uninterruptibleMask_ . mapM_ killThread } + + + -- Spawn the workers, making sure to kill them later. Collect the results + -- of each compile. + results <- liftIO $ bracket spawnWorkers killWorkers $ \_ -> + -- Loop over each module in the compilation graph in order, printing + -- each message from its log_queue. + forM comp_graph $ \(mod,mvar,log_queue) -> do + printLogs dflags log_queue + result <- readMVar mvar + if succeeded result then return (Just mod) else return Nothing + + + -- Collect and return the ModSummaries of all the successful compiles. + -- NB: Reverse this list to maintain output parity with the sequential upsweep. + let ok_results = reverse (catMaybes results) + + -- Handle any cycle in the original compilation graph and return the result + -- of the upsweep. + case cycle of + Just mss -> do + liftIO $ fatalErrorMsg dflags (cyclicModuleErr mss) + return (Failed,ok_results) + Nothing -> do + let success_flag = successIf (all isJust results) + return (success_flag,ok_results) + + where + writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,PprStyle,MsgDoc) -> IO () + writeLogQueue (LogQueue ref sem) msg = do + atomicModifyIORef' ref $ \msgs -> (msg:msgs,()) + _ <- tryPutMVar sem () + return () + + -- The log_action callback that is used to synchronize messages from a + -- worker thread. + parLogAction :: LogQueue -> LogAction + parLogAction log_queue _dflags !reason !severity !srcSpan !style !msg = do + writeLogQueue log_queue (Just (reason,severity,srcSpan,style,msg)) + + -- Print each message from the log_queue using the log_action from the + -- session's DynFlags. + printLogs :: DynFlags -> LogQueue -> IO () + printLogs !dflags (LogQueue ref sem) = read_msgs + where read_msgs = do + takeMVar sem + msgs <- atomicModifyIORef' ref $ \xs -> ([], reverse xs) + print_loop msgs + + print_loop [] = read_msgs + print_loop (x:xs) = case x of + Just (reason,severity,srcSpan,style,msg) -> do + putLogMsg dflags reason severity srcSpan style msg + print_loop xs + -- Exit the loop once we encounter the end marker. + Nothing -> return () + +-- The interruptible subset of the worker threads' work. +parUpsweep_one + :: ModSummary + -- ^ The module we wish to compile + -> Map BuildModule (MVar SuccessFlag, Int) + -- ^ The map of home modules and their result MVar + -> [[BuildModule]] + -- ^ The list of all module loops within the compilation graph. + -> DynFlags + -- ^ The thread-local DynFlags + -> Maybe Messager + -- ^ The messager + -> (HscEnv -> IO ()) + -- ^ The callback for cleaning up intermediate files + -> QSem + -- ^ The semaphore for limiting the number of simultaneous compiles + -> MVar HscEnv + -- ^ The MVar that synchronizes updates to the global HscEnv + -> IORef HomePackageTable + -- ^ The old HPT + -> StableModules + -- ^ Sets of stable objects and BCOs + -> Int + -- ^ The index of this module + -> Int + -- ^ The total number of modules + -> IO SuccessFlag + -- ^ The result of this compile +parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags mHscMessage cleanup par_sem + hsc_env_var old_hpt_var stable_mods mod_index num_mods = do + + let this_build_mod = mkBuildModule mod + + let home_imps = map unLoc $ ms_home_imps mod + let home_src_imps = map unLoc $ ms_home_srcimps mod + + -- All the textual imports of this module. + let textual_deps = Set.fromList $ mapFst (mkModule (thisPackage lcl_dflags)) $ + zip home_imps (repeat NotBoot) ++ + zip home_src_imps (repeat IsBoot) + + -- Dealing with module loops + -- ~~~~~~~~~~~~~~~~~~~~~~~~~ + -- + -- Not only do we have to deal with explicit textual dependencies, we also + -- have to deal with implicit dependencies introduced by import cycles that + -- are broken by an hs-boot file. We have to ensure that: + -- + -- 1. A module that breaks a loop must depend on all the modules in the + -- loop (transitively or otherwise). This is normally always fulfilled + -- by the module's textual dependencies except in degenerate loops, + -- e.g.: + -- + -- A.hs imports B.hs-boot + -- B.hs doesn't import A.hs + -- C.hs imports A.hs, B.hs + -- + -- In this scenario, getModLoop will detect the module loop [A,B] but + -- the loop finisher B doesn't depend on A. So we have to explicitly add + -- A in as a dependency of B when we are compiling B. + -- + -- 2. A module that depends on a module in an external loop can't proceed + -- until the entire loop is re-typechecked. + -- + -- These two invariants have to be maintained to correctly build a + -- compilation graph with one or more loops. + + + -- The loop that this module will finish. After this module successfully + -- compiles, this loop is going to get re-typechecked. + let finish_loop = listToMaybe + [ tail loop | loop <- comp_graph_loops + , head loop == this_build_mod ] + + -- If this module finishes a loop then it must depend on all the other + -- modules in that loop because the entire module loop is going to be + -- re-typechecked once this module gets compiled. These extra dependencies + -- are this module's "internal" loop dependencies, because this module is + -- inside the loop in question. + let int_loop_deps = Set.fromList $ + case finish_loop of + Nothing -> [] + Just loop -> filter (/= this_build_mod) loop + + -- If this module depends on a module within a loop then it must wait for + -- that loop to get re-typechecked, i.e. it must wait on the module that + -- finishes that loop. These extra dependencies are this module's + -- "external" loop dependencies, because this module is outside of the + -- loop(s) in question. + let ext_loop_deps = Set.fromList + [ head loop | loop <- comp_graph_loops + , any (`Set.member` textual_deps) loop + , this_build_mod `notElem` loop ] + + + let all_deps = foldl1 Set.union [textual_deps, int_loop_deps, ext_loop_deps] + + -- All of the module's home-module dependencies. + let home_deps_with_idx = + [ home_dep | dep <- Set.toList all_deps + , Just home_dep <- [Map.lookup dep home_mod_map] ] + + -- Sort the list of dependencies in reverse-topological order. This way, by + -- the time we get woken up by the result of an earlier dependency, + -- subsequent dependencies are more likely to have finished. This step + -- effectively reduces the number of MVars that each thread blocks on. + let home_deps = map fst $ sortBy (flip (comparing snd)) home_deps_with_idx + + -- Wait for the all the module's dependencies to finish building. + deps_ok <- allM (fmap succeeded . readMVar) home_deps + + -- We can't build this module if any of its dependencies failed to build. + if not deps_ok + then return Failed + else do + -- Any hsc_env at this point is OK to use since we only really require + -- that the HPT contains the HMIs of our dependencies. + hsc_env <- readMVar hsc_env_var + old_hpt <- readIORef old_hpt_var + + let logger err = printBagOfErrors lcl_dflags (srcErrorMessages err) + + -- Limit the number of parallel compiles. + let withSem sem = bracket_ (waitQSem sem) (signalQSem sem) + mb_mod_info <- withSem par_sem $ + handleSourceError (\err -> do logger err; return Nothing) $ do + -- Have the ModSummary and HscEnv point to our local log_action + -- and filesToClean var. + let lcl_mod = localize_mod mod + let lcl_hsc_env = localize_hsc_env hsc_env + + -- Re-typecheck the loop + -- This is necessary to make sure the knot is tied when + -- we close a recursive module loop, see bug #12035. + type_env_var <- liftIO $ newIORef emptyNameEnv + let lcl_hsc_env' = lcl_hsc_env { hsc_type_env_var = + 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. + mod_info <- upsweep_mod lcl_hsc_env'' mHscMessage old_hpt stable_mods + lcl_mod mod_index num_mods + return (Just mod_info) + + case mb_mod_info of + Nothing -> return Failed + Just mod_info -> do + let this_mod = ms_mod_name mod + + -- Prune the old HPT unless this is an hs-boot module. + unless (isBootSummary mod) $ + atomicModifyIORef' old_hpt_var $ \old_hpt -> + (delFromHpt old_hpt this_mod, ()) + + -- Update and fetch the global HscEnv. + lcl_hsc_env' <- modifyMVar hsc_env_var $ \hsc_env -> do + let hsc_env' = hsc_env + { hsc_HPT = addToHpt (hsc_HPT hsc_env) + this_mod mod_info } + -- 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' $ + map (moduleName . fst) loop + return (hsc_env'', localize_hsc_env hsc_env'') + + -- Clean up any intermediate files. + cleanup lcl_hsc_env' + return Succeeded + + where + localize_mod mod + = mod { ms_hspp_opts = (ms_hspp_opts mod) + { log_action = log_action lcl_dflags + , filesToClean = filesToClean lcl_dflags } } + + localize_hsc_env hsc_env + = hsc_env { hsc_dflags = (hsc_dflags hsc_env) + { log_action = log_action lcl_dflags + , filesToClean = filesToClean lcl_dflags } } + +-- ----------------------------------------------------------------------------- +-- +-- | The upsweep +-- +-- This is where we compile each module in the module graph, in a pass +-- from the bottom to the top of the graph. +-- +-- There better had not be any cyclic groups here -- we check for them. +upsweep + :: GhcMonad m + => Maybe Messager + -> HomePackageTable -- ^ HPT from last time round (pruned) + -> StableModules -- ^ stable modules (see checkStability) + -> (HscEnv -> IO ()) -- ^ How to clean up unwanted tmp files + -> [SCC ModSummary] -- ^ Mods to do (the worklist) + -> m (SuccessFlag, + [ModSummary]) + -- ^ Returns: + -- + -- 1. A flag whether the complete upsweep was successful. + -- 2. The 'HscEnv' in the monad has an updated HPT + -- 3. A list of modules which succeeded loading. + +upsweep mHscMessage old_hpt stable_mods cleanup sccs = do + dflags <- getSessionDynFlags + (res, done) <- upsweep' old_hpt emptyMG sccs 1 (length sccs) + (unitIdsToCheck dflags) done_holes + return (res, reverse $ mgModSummaries done) + where + done_holes = emptyUniqSet + + keep_going this_mods old_hpt done mods mod_index nmods uids_to_check done_holes = do + let sum_deps ms (AcyclicSCC mod) = + if any (flip elem . map (unLoc . snd) $ ms_imps mod) ms + then ms_mod_name mod:ms + else ms + sum_deps ms _ = ms + dep_closure = foldl' sum_deps this_mods mods + dropped_ms = drop (length this_mods) (reverse dep_closure) + prunable (AcyclicSCC mod) = elem (ms_mod_name mod) dep_closure + prunable _ = False + mods' = filter (not . prunable) mods + nmods' = nmods - length dropped_ms + + when (not $ null dropped_ms) $ do + dflags <- getSessionDynFlags + liftIO $ fatalErrorMsg dflags (keepGoingPruneErr dropped_ms) + (_, done') <- upsweep' old_hpt done mods' (mod_index+1) nmods' uids_to_check done_holes + return (Failed, done') + + upsweep' + :: GhcMonad m + => HomePackageTable + -> ModuleGraph + -> [SCC ModSummary] + -> Int + -> Int + -> [UnitId] + -> UniqSet ModuleName + -> m (SuccessFlag, ModuleGraph) + upsweep' _old_hpt done + [] _ _ uids_to_check _ + = do hsc_env <- getSession + liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnitId hsc_env) uids_to_check + return (Succeeded, done) + + upsweep' _old_hpt done + (CyclicSCC ms:mods) mod_index nmods uids_to_check done_holes + = do dflags <- getSessionDynFlags + liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms) + if gopt Opt_KeepGoing dflags + then keep_going (map ms_mod_name ms) old_hpt done mods mod_index nmods + uids_to_check done_holes + else return (Failed, done) + + upsweep' old_hpt done + (AcyclicSCC mod:mods) mod_index nmods uids_to_check done_holes + = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ + -- show (map (moduleUserString.moduleName.mi_module.hm_iface) + -- (moduleEnvElts (hsc_HPT hsc_env))) + let logger _mod = defaultWarnErrLogger + + hsc_env <- getSession + + -- TODO: Cache this, so that we don't repeatedly re-check + -- our imports when you run --make. + let (ready_uids, uids_to_check') + = partition (\uid -> isEmptyUniqDSet + (unitIdFreeHoles uid `uniqDSetMinusUniqSet` done_holes)) + uids_to_check + done_holes' + | ms_hsc_src mod == HsigFile + = addOneToUniqSet done_holes (ms_mod_name mod) + | otherwise = done_holes + liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnitId hsc_env) ready_uids + + -- Remove unwanted tmp files between compilations + liftIO (cleanup hsc_env) + + -- Get ready to tie the knot + type_env_var <- liftIO $ newIORef emptyNameEnv + let hsc_env1 = hsc_env { hsc_type_env_var = + Just (ms_mod mod, type_env_var) } + setSession hsc_env1 + + -- Lazily reload the HPT modules participating in the loop. + -- See Note [Tying the knot]--if we don't throw out the old HPT + -- and reinitalize the knot-tying process, anything that was forced + -- while we were previously typechecking won't get updated, this + -- was bug #12035. + hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done + setSession hsc_env2 + + mb_mod_info + <- handleSourceError + (\err -> do logger mod (Just err); return Nothing) $ do + mod_info <- liftIO $ upsweep_mod hsc_env2 mHscMessage old_hpt stable_mods + mod mod_index nmods + logger mod Nothing -- log warnings + return (Just mod_info) + + case mb_mod_info of + Nothing -> do + dflags <- getSessionDynFlags + if gopt Opt_KeepGoing dflags + then keep_going [ms_mod_name mod] old_hpt done mods mod_index nmods + uids_to_check done_holes + else return (Failed, done) + Just mod_info -> do + let this_mod = ms_mod_name mod + + -- Add new info to hsc_env + hpt1 = addToHpt (hsc_HPT hsc_env2) this_mod mod_info + hsc_env3 = hsc_env2 { hsc_HPT = hpt1, hsc_type_env_var = Nothing } + + -- Space-saving: delete the old HPT entry + -- for mod BUT if mod is a hs-boot + -- node, don't delete it. For the + -- interface, the HPT entry is probably for the + -- main Haskell source file. Deleting it + -- would force the real module to be recompiled + -- every time. + old_hpt1 | isBootSummary mod = old_hpt + | otherwise = delFromHpt old_hpt this_mod + + done' = extendMG done mod + + -- fixup our HomePackageTable after we've finished compiling + -- a mutually-recursive loop. We have to do this again + -- to make sure we have the final unfoldings, which may + -- not have been computed accurately in the previous + -- retypecheck. + hsc_env4 <- liftIO $ reTypecheckLoop hsc_env3 mod done' + setSession hsc_env4 + + -- Add any necessary entries to the static pointer + -- table. See Note [Grand plan for static forms] in + -- StaticPtrTable. + when (hscTarget (hsc_dflags hsc_env4) == HscInterpreted) $ + liftIO $ hscAddSptEntries hsc_env4 + [ spt + | Just linkable <- pure $ hm_linkable mod_info + , unlinked <- linkableUnlinked linkable + , BCOs _ spts <- pure unlinked + , spt <- spts + ] + + upsweep' old_hpt1 done' mods (mod_index+1) nmods uids_to_check' done_holes' + +unitIdsToCheck :: DynFlags -> [UnitId] +unitIdsToCheck dflags = + nubSort $ concatMap goUnitId (explicitPackages (pkgState dflags)) + where + goUnitId uid = + case splitUnitIdInsts uid of + (_, Just indef) -> + let insts = indefUnitIdInsts indef + in uid : concatMap (goUnitId . moduleUnitId . snd) insts + _ -> [] + +maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime) +maybeGetIfaceDate dflags location + | writeInterfaceOnlyMode dflags + -- Minor optimization: it should be harmless to check the hi file location + -- always, but it's better to avoid hitting the filesystem if possible. + = modificationTimeIfExists (ml_hi_file location) + | otherwise + = return Nothing + +-- | Compile a single module. Always produce a Linkable for it if +-- successful. If no compilation happened, return the old Linkable. +upsweep_mod :: HscEnv + -> Maybe Messager + -> HomePackageTable + -> StableModules + -> ModSummary + -> Int -- index of module + -> Int -- total number of modules + -> IO HomeModInfo +upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_index nmods + = let + this_mod_name = ms_mod_name summary + this_mod = ms_mod summary + mb_obj_date = ms_obj_date summary + mb_if_date = ms_iface_date summary + obj_fn = ml_obj_file (ms_location summary) + hs_date = ms_hs_date summary + + is_stable_obj = this_mod_name `elementOfUniqSet` stable_obj + is_stable_bco = this_mod_name `elementOfUniqSet` stable_bco + + old_hmi = lookupHpt old_hpt this_mod_name + + -- We're using the dflags for this module now, obtained by + -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas. + dflags = ms_hspp_opts summary + prevailing_target = hscTarget (hsc_dflags hsc_env) + local_target = hscTarget dflags + + -- If OPTIONS_GHC contains -fasm or -fllvm, be careful that + -- we don't do anything dodgy: these should only work to change + -- from -fllvm to -fasm and vice-versa, or away from -fno-code, + -- otherwise we could end up trying to link object code to byte + -- code. + target = if prevailing_target /= local_target + && (not (isObjectTarget prevailing_target) + || not (isObjectTarget local_target)) + && not (prevailing_target == HscNothing) + && not (prevailing_target == HscInterpreted) + then prevailing_target + else local_target + + -- store the corrected hscTarget into the summary + summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } } + + -- The old interface is ok if + -- a) we're compiling a source file, and the old HPT + -- entry is for a source file + -- b) we're compiling a hs-boot file + -- Case (b) allows an hs-boot file to get the interface of its + -- real source file on the second iteration of the compilation + -- manager, but that does no harm. Otherwise the hs-boot file + -- will always be recompiled + + mb_old_iface + = case old_hmi of + Nothing -> Nothing + Just hm_info | isBootSummary summary -> Just iface + | not (mi_boot iface) -> Just iface + | otherwise -> Nothing + where + iface = hm_iface hm_info + + compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo + compile_it mb_linkable src_modified = + compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods + mb_old_iface mb_linkable src_modified + + compile_it_discard_iface :: Maybe Linkable -> SourceModified + -> IO HomeModInfo + compile_it_discard_iface mb_linkable src_modified = + compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods + Nothing mb_linkable src_modified + + -- With the HscNothing target we create empty linkables to avoid + -- recompilation. We have to detect these to recompile anyway if + -- the target changed since the last compile. + is_fake_linkable + | Just hmi <- old_hmi, Just l <- hm_linkable hmi = + null (linkableUnlinked l) + | otherwise = + -- we have no linkable, so it cannot be fake + False + + implies False _ = True + implies True x = x + + in + case () of + _ + -- Regardless of whether we're generating object code or + -- byte code, we can always use an existing object file + -- if it is *stable* (see checkStability). + | is_stable_obj, Just hmi <- old_hmi -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "skipping stable obj mod:" <+> ppr this_mod_name) + return hmi + -- object is stable, and we have an entry in the + -- old HPT: nothing to do + + | is_stable_obj, isNothing old_hmi -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling stable on-disk mod:" <+> ppr this_mod_name) + linkable <- liftIO $ findObjectLinkable this_mod obj_fn + (expectJust "upsweep1" mb_obj_date) + compile_it (Just linkable) SourceUnmodifiedAndStable + -- object is stable, but we need to load the interface + -- off disk to make a HMI. + + | not (isObjectTarget target), is_stable_bco, + (target /= HscNothing) `implies` not is_fake_linkable -> + ASSERT(isJust old_hmi) -- must be in the old_hpt + let Just hmi = old_hmi in do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "skipping stable BCO mod:" <+> ppr this_mod_name) + return hmi + -- BCO is stable: nothing to do + + | not (isObjectTarget target), + Just hmi <- old_hmi, + Just l <- hm_linkable hmi, + not (isObjectLinkable l), + (target /= HscNothing) `implies` not is_fake_linkable, + linkableTime l >= ms_hs_date summary -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling non-stable BCO mod:" <+> ppr this_mod_name) + compile_it (Just l) SourceUnmodified + -- we have an old BCO that is up to date with respect + -- to the source: do a recompilation check as normal. + + -- When generating object code, if there's an up-to-date + -- object file on the disk, then we can use it. + -- However, if the object file is new (compared to any + -- linkable we had from a previous compilation), then we + -- must discard any in-memory interface, because this + -- means the user has compiled the source file + -- separately and generated a new interface, that we must + -- read from the disk. + -- + | isObjectTarget target, + Just obj_date <- mb_obj_date, + obj_date >= hs_date -> do + case old_hmi of + Just hmi + | Just l <- hm_linkable hmi, + isObjectLinkable l && linkableTime l == obj_date -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name) + compile_it (Just l) SourceUnmodified + _otherwise -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name) + linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date + compile_it_discard_iface (Just linkable) SourceUnmodified + + -- See Note [Recompilation checking in -fno-code mode] + | writeInterfaceOnlyMode dflags, + Just if_date <- mb_if_date, + if_date >= hs_date -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "skipping tc'd mod:" <+> ppr this_mod_name) + compile_it Nothing SourceUnmodified + + _otherwise -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling mod:" <+> ppr this_mod_name) + compile_it Nothing SourceModified + + +{- Note [-fno-code mode] +~~~~~~~~~~~~~~~~~~~~~~~~ +GHC offers the flag -fno-code for the purpose of parsing and typechecking a +program without generating object files. This is intended to be used by tooling +and IDEs to provide quick feedback on any parser or type errors as cheaply as +possible. + +When GHC is invoked with -fno-code no object files or linked output will be +generated. As many errors and warnings as possible will be generated, as if +-fno-code had not been passed. The session DynFlags will have +hscTarget == HscNothing. + +-fwrite-interface +~~~~~~~~~~~~~~~~ +Whether interface files are generated in -fno-code mode is controlled by the +-fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is +not also passed. Recompilation avoidance requires interface files, so passing +-fno-code without -fwrite-interface should be avoided. If -fno-code were +re-implemented today, -fwrite-interface would be discarded and it would be +considered always on; this behaviour is as it is for backwards compatibility. + +================================================================ +IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER +================================================================ + +Template Haskell +~~~~~~~~~~~~~~~~ +A module using template haskell may invoke an imported function from inside a +splice. This will cause the type-checker to attempt to execute that code, which +would fail if no object files had been generated. See #8025. To rectify this, +during the downsweep we patch the DynFlags in the ModSummary of any home module +that is imported by a module that uses template haskell, to generate object +code. + +The flavour of generated object code is chosen by defaultObjectTarget for the +target platform. It would likely be faster to generate bytecode, but this is not +supported on all platforms(?Please Confirm?), and does not support the entirety +of GHC haskell. See #1257. + +The object files (and interface files if -fwrite-interface is disabled) produced +for template haskell are written to temporary files. + +Note that since template haskell can run arbitrary IO actions, -fno-code mode +is no more secure than running without it. + +Potential TODOS: +~~~~~ +* Remove -fwrite-interface and have interface files always written in -fno-code + mode +* Both .o and .dyn_o files are generated for template haskell, but we only need + .dyn_o. Fix it. +* In make mode, a message like + Compiling A (A.hs, /tmp/ghc_123.o) + is shown if downsweep enabled object code generation for A. Perhaps we should + show "nothing" or "temporary object file" instead. Note that one + can currently use -keep-tmp-files and inspect the generated file with the + current behaviour. +* Offer a -no-codedir command line option, and write what were temporary + object files there. This would speed up recompilation. +* Use existing object files (if they are up to date) instead of always + generating temporary ones. +-} + +-- Note [Recompilation checking in -fno-code mode] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- If we are compiling with -fno-code -fwrite-interface, there won't +-- be any object code that we can compare against, nor should there +-- be: we're *just* generating interface files. In this case, we +-- want to check if the interface file is new, in lieu of the object +-- file. See also #9243. + +-- Filter modules in the HPT +retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable +retainInTopLevelEnvs keep_these hpt + = listToHpt [ (mod, expectJust "retain" mb_mod_info) + | mod <- keep_these + , let mb_mod_info = lookupHpt hpt mod + , isJust mb_mod_info ] + +-- --------------------------------------------------------------------------- +-- Typecheck module loops +{- +See bug #930. This code fixes a long-standing bug in --make. The +problem is that when compiling the modules *inside* a loop, a data +type that is only defined at the top of the loop looks opaque; but +after the loop is done, the structure of the data type becomes +apparent. + +The difficulty is then that two different bits of code have +different notions of what the data type looks like. + +The idea is that after we compile a module which also has an .hs-boot +file, we re-generate the ModDetails for each of the modules that +depends on the .hs-boot file, so that everyone points to the proper +TyCons, Ids etc. defined by the real module, not the boot module. +Fortunately re-generating a ModDetails from a ModIface is easy: the +function GHC.IfaceToCore.typecheckIface does exactly that. + +Picking the modules to re-typecheck is slightly tricky. Starting from +the module graph consisting of the modules that have already been +compiled, we reverse the edges (so they point from the imported module +to the importing module), and depth-first-search from the .hs-boot +node. This gives us all the modules that depend transitively on the +.hs-boot module, and those are exactly the modules that we need to +re-typecheck. + +Following this fix, GHC can compile itself with --make -O2. +-} + +reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv +reTypecheckLoop hsc_env ms graph + | Just loop <- getModLoop ms mss appearsAsBoot + -- SOME hs-boot files should still + -- get used, just not the loop-closer. + , let non_boot = filter (\l -> not (isBootSummary l && + ms_mod l == ms_mod ms)) loop + = typecheckLoop (hsc_dflags hsc_env) hsc_env (map ms_mod_name non_boot) + | otherwise + = return hsc_env + where + 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] + -> (Module -> Bool) -- check if a module appears as a boot module in 'graph' + -> Maybe [ModSummary] +getModLoop ms graph appearsAsBoot + | not (isBootSummary ms) + , appearsAsBoot this_mod + , let mss = reachableBackwards (ms_mod_name ms) graph + = Just mss + | otherwise + = Nothing + 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 $ + text "Re-typechecking loop: " <> ppr mods + new_hpt <- + fixIO $ \new_hpt -> do + let new_hsc_env = hsc_env{ hsc_HPT = new_hpt } + mds <- initIfaceCheck (text "typecheckLoop") new_hsc_env $ + mapM (typecheckIface . hm_iface) hmis + let new_hpt = addListToHpt old_hpt + (zip mods [ hmi{ hm_details = details } + | (hmi,details) <- zip hmis mds ]) + return new_hpt + return hsc_env{ hsc_HPT = new_hpt } + where + old_hpt = hsc_HPT hsc_env + hmis = map (expectJust "typecheckLoop" . lookupHpt old_hpt) mods + +reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary] +reachableBackwards mod summaries + = [ node_payload node | node <- reachableG (transposeG graph) root ] + where -- the rest just sets up the graph: + (graph, lookup_node) = moduleGraphNodes False summaries + root = expectJust "reachableBackwards" (lookup_node HsBootFile mod) + +-- --------------------------------------------------------------------------- +-- +-- | Topological sort of the module graph +topSortModuleGraph + :: Bool + -- ^ Drop hi-boot nodes? (see below) + -> ModuleGraph + -> Maybe ModuleName + -- ^ Root module name. If @Nothing@, use the full graph. + -> [SCC ModSummary] +-- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes +-- The resulting list of strongly-connected-components is in topologically +-- sorted order, starting with the module(s) at the bottom of the +-- dependency graph (ie compile them first) and ending with the ones at +-- the top. +-- +-- Drop hi-boot nodes (first boolean arg)? +-- +-- - @False@: treat the hi-boot summaries as nodes of the graph, +-- so the graph must be acyclic +-- +-- - @True@: eliminate the hi-boot nodes, and instead pretend +-- the a source-import of Foo is an import of Foo +-- The resulting graph has no hi-boot nodes, but can be cyclic + +topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod + = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph + where + summaries = mgModSummaries module_graph + -- stronglyConnCompG flips the original order, so if we reverse + -- the summaries we get a stable topological sort. + (graph, lookup_node) = + moduleGraphNodes drop_hs_boot_nodes (reverse summaries) + + initial_graph = case mb_root_mod of + Nothing -> graph + Just root_mod -> + -- restrict the graph to just those modules reachable from + -- the specified module. We do this by building a graph with + -- the full set of nodes, and determining the reachable set from + -- the specified node. + let root | Just node <- lookup_node HsSrcFile root_mod + , graph `hasVertexG` node + = node + | otherwise + = throwGhcException (ProgramError "module does not exist") + in graphFromEdgedVerticesUniq (seq root (reachableG graph root)) + +type SummaryNode = Node Int ModSummary + +summaryNodeKey :: SummaryNode -> Int +summaryNodeKey = node_key + +summaryNodeSummary :: SummaryNode -> ModSummary +summaryNodeSummary = node_payload + +moduleGraphNodes :: Bool -> [ModSummary] + -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode) +moduleGraphNodes drop_hs_boot_nodes summaries = + (graphFromEdgedVerticesUniq nodes, lookup_node) + where + numbered_summaries = zip summaries [1..] + + lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode + lookup_node hs_src mod = Map.lookup (mod, hscSourceToIsBoot hs_src) node_map + + lookup_key :: HscSource -> ModuleName -> Maybe Int + lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod) + + node_map :: NodeMap SummaryNode + node_map = Map.fromList [ ((moduleName (ms_mod s), + hscSourceToIsBoot (ms_hsc_src s)), node) + | node <- nodes + , let s = summaryNodeSummary node ] + + -- We use integers as the keys for the SCC algorithm + nodes :: [SummaryNode] + nodes = [ DigraphNode s key out_keys + | (s, key) <- numbered_summaries + -- Drop the hi-boot ones if told to do so + , not (isBootSummary s && drop_hs_boot_nodes) + , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++ + out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++ + (-- see [boot-edges] below + if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile + then [] + else case lookup_key HsBootFile (ms_mod_name s) of + Nothing -> [] + Just k -> [k]) ] + + -- [boot-edges] if this is a .hs and there is an equivalent + -- .hs-boot, add a link from the former to the latter. This + -- has the effect of detecting bogus cases where the .hs-boot + -- depends on the .hs, by introducing a cycle. Additionally, + -- it ensures that we will always process the .hs-boot before + -- the .hs, and so the HomePackageTable will always have the + -- most up to date information. + + -- Drop hs-boot nodes by using HsSrcFile as the key + hs_boot_key | drop_hs_boot_nodes = HsSrcFile + | otherwise = HsBootFile + + out_edge_keys :: HscSource -> [ModuleName] -> [Int] + out_edge_keys hi_boot ms = mapMaybe (lookup_key hi_boot) ms + -- If we want keep_hi_boot_nodes, then we do lookup_key with + -- IsBoot; else NotBoot + +-- The nodes of the graph are keyed by (mod, is boot?) pairs +-- NB: hsig files show up as *normal* nodes (not boot!), since they don't +-- participate in cycles (for now) +type NodeKey = (ModuleName, IsBoot) +type NodeMap a = Map.Map NodeKey a + +msKey :: ModSummary -> NodeKey +msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) + = (moduleName mod, hscSourceToIsBoot boot) + +mkNodeMap :: [ModSummary] -> NodeMap ModSummary +mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries] + +nodeMapElts :: NodeMap a -> [a] +nodeMapElts = Map.elems + +-- | If there are {-# SOURCE #-} imports between strongly connected +-- components in the topological sort, then those imports can +-- definitely be replaced by ordinary non-SOURCE imports: if SOURCE +-- were necessary, then the edge would be part of a cycle. +warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m () +warnUnnecessarySourceImports sccs = do + dflags <- getDynFlags + when (wopt Opt_WarnUnusedImports dflags) + (logWarnings (listToBag (concatMap (check dflags . flattenSCC) sccs))) + where check dflags ms = + let mods_in_this_cycle = map ms_mod_name ms in + [ warn dflags i | m <- ms, i <- ms_home_srcimps m, + unLoc i `notElem` mods_in_this_cycle ] + + warn :: DynFlags -> Located ModuleName -> WarnMsg + warn dflags (L loc mod) = + mkPlainErrMsg dflags loc + (text "Warning: {-# SOURCE #-} unnecessary in import of " + <+> quotes (ppr mod)) + + +----------------------------------------------------------------------------- +-- +-- | Downsweep (dependency analysis) +-- +-- Chase downwards from the specified root set, returning summaries +-- for all home modules encountered. Only follow source-import +-- links. +-- +-- We pass in the previous collection of summaries, which is used as a +-- cache to avoid recalculating a module summary if the source is +-- unchanged. +-- +-- The returned list of [ModSummary] nodes has one node for each home-package +-- module, plus one for any hs-boot files. The imports of these nodes +-- are all there, including the imports of non-home-package modules. +downsweep :: HscEnv + -> [ModSummary] -- Old summaries + -> [ModuleName] -- Ignore dependencies on these; treat + -- them as if they were package modules + -> Bool -- True <=> allow multiple targets to have + -- the same module name; this is + -- very useful for ghc -M + -> IO [Either ErrorMessages ModSummary] + -- The elts of [ModSummary] all have distinct + -- (Modules, IsBoot) identifiers, unless the Bool is true + -- in which case there can be repeats +downsweep hsc_env old_summaries excl_mods allow_dup_roots + = do + rootSummaries <- mapM getRootSummary roots + let (errs, rootSummariesOk) = partitionEithers rootSummaries -- #17549 + root_map = mkRootMap rootSummariesOk + checkDuplicates root_map + map0 <- loop (concatMap calcDeps rootSummariesOk) root_map + -- if we have been passed -fno-code, we enable code generation + -- for dependencies of modules that have -XTemplateHaskell, + -- otherwise those modules will fail to compile. + -- See Note [-fno-code mode] #8025 + map1 <- if hscTarget dflags == HscNothing + then enableCodeGenForTH + (defaultObjectTarget dflags) + map0 + else if hscTarget dflags == HscInterpreted + then enableCodeGenForUnboxedTuplesOrSums + (defaultObjectTarget dflags) + map0 + else return map0 + if null errs + then pure $ concat $ nodeMapElts map1 + else pure $ map Left errs + where + calcDeps = msDeps + + dflags = hsc_dflags hsc_env + roots = hsc_targets hsc_env + + old_summary_map :: NodeMap ModSummary + old_summary_map = mkNodeMap old_summaries + + getRootSummary :: Target -> IO (Either ErrorMessages ModSummary) + getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf) + = do exists <- liftIO $ doesFileExist file + if exists || isJust maybe_buf + then summariseFile hsc_env old_summaries file mb_phase + obj_allowed maybe_buf + else return $ Left $ unitBag $ mkPlainErrMsg dflags noSrcSpan $ + text "can't find file:" <+> text file + getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf) + = do maybe_summary <- summariseModule hsc_env old_summary_map NotBoot + (L rootLoc modl) obj_allowed + maybe_buf excl_mods + case maybe_summary of + Nothing -> return $ Left $ moduleNotFoundErr dflags modl + Just s -> return s + + rootLoc = mkGeneralSrcSpan (fsLit "<command line>") + + -- In a root module, the filename is allowed to diverge from the module + -- name, so we have to check that there aren't multiple root files + -- defining the same module (otherwise the duplicates will be silently + -- ignored, leading to confusing behaviour). + checkDuplicates :: NodeMap [Either ErrorMessages ModSummary] -> IO () + checkDuplicates root_map + | allow_dup_roots = return () + | null dup_roots = return () + | otherwise = liftIO $ multiRootsErr dflags (head dup_roots) + where + dup_roots :: [[ModSummary]] -- Each at least of length 2 + dup_roots = filterOut isSingleton $ map rights $ nodeMapElts root_map + + loop :: [(Located ModuleName,IsBoot)] + -- Work list: process these modules + -> NodeMap [Either ErrorMessages ModSummary] + -- Visited set; the range is a list because + -- the roots can have the same module names + -- if allow_dup_roots is True + -> IO (NodeMap [Either ErrorMessages ModSummary]) + -- The result is the completed NodeMap + loop [] done = return done + loop ((wanted_mod, is_boot) : ss) done + | Just summs <- Map.lookup key done + = if isSingleton summs then + loop ss done + else + do { multiRootsErr dflags (rights summs); return Map.empty } + | otherwise + = do mb_s <- summariseModule hsc_env old_summary_map + is_boot wanted_mod True + Nothing excl_mods + case mb_s of + Nothing -> loop ss done + Just (Left e) -> loop ss (Map.insert key [Left e] done) + Just (Right s)-> do + new_map <- + loop (calcDeps s) (Map.insert key [Right s] done) + loop ss new_map + where + key = (unLoc wanted_mod, is_boot) + +-- | Update the every ModSummary that is depended on +-- by a module that needs template haskell. We enable codegen to +-- the specified target, disable optimization and change the .hi +-- and .o file locations to be temporary files. +-- See Note [-fno-code mode] +enableCodeGenForTH :: HscTarget + -> NodeMap [Either ErrorMessages ModSummary] + -> IO (NodeMap [Either ErrorMessages ModSummary]) +enableCodeGenForTH = + enableCodeGenWhen condition should_modify TFL_CurrentModule TFL_GhcSession + where + condition = isTemplateHaskellOrQQNonBoot + should_modify (ModSummary { ms_hspp_opts = dflags }) = + hscTarget dflags == HscNothing && + -- Don't enable codegen for TH on indefinite packages; we + -- can't compile anything anyway! See #16219. + not (isIndefinite dflags) + +-- | Update the every ModSummary that is depended on +-- by a module that needs unboxed tuples. We enable codegen to +-- the specified target, disable optimization and change the .hi +-- and .o file locations to be temporary files. +-- +-- This is used used in order to load code that uses unboxed tuples +-- or sums into GHCi while still allowing some code to be interpreted. +enableCodeGenForUnboxedTuplesOrSums :: HscTarget + -> NodeMap [Either ErrorMessages ModSummary] + -> IO (NodeMap [Either ErrorMessages ModSummary]) +enableCodeGenForUnboxedTuplesOrSums = + enableCodeGenWhen condition should_modify TFL_GhcSession TFL_CurrentModule + where + condition ms = + unboxed_tuples_or_sums (ms_hspp_opts ms) && + not (gopt Opt_ByteCode (ms_hspp_opts ms)) && + not (isBootSummary ms) + unboxed_tuples_or_sums d = + xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d + should_modify (ModSummary { ms_hspp_opts = dflags }) = + hscTarget dflags == HscInterpreted + +-- | Helper used to implement 'enableCodeGenForTH' and +-- 'enableCodeGenForUnboxedTuples'. In particular, this enables +-- unoptimized code generation for all modules that meet some +-- condition (first parameter), or are dependencies of those +-- modules. The second parameter is a condition to check before +-- marking modules for code generation. +enableCodeGenWhen + :: (ModSummary -> Bool) + -> (ModSummary -> Bool) + -> TempFileLifetime + -> TempFileLifetime + -> HscTarget + -> NodeMap [Either ErrorMessages ModSummary] + -> IO (NodeMap [Either ErrorMessages ModSummary]) +enableCodeGenWhen condition should_modify staticLife dynLife target nodemap = + traverse (traverse (traverse enable_code_gen)) nodemap + where + enable_code_gen ms + | ModSummary + { ms_mod = ms_mod + , ms_location = ms_location + , ms_hsc_src = HsSrcFile + , ms_hspp_opts = dflags + } <- ms + , should_modify ms + , ms_mod `Set.member` needs_codegen_set + = do + let new_temp_file suf dynsuf = do + tn <- newTempName dflags staticLife suf + let dyn_tn = tn -<.> dynsuf + addFilesToClean dflags dynLife [dyn_tn] + return tn + -- We don't want to create .o or .hi files unless we have been asked + -- to by the user. But we need them, so we patch their locations in + -- the ModSummary with temporary files. + -- + (hi_file, o_file) <- + -- If ``-fwrite-interface` is specified, then the .o and .hi files + -- are written into `-odir` and `-hidir` respectively. #16670 + if gopt Opt_WriteInterface dflags + then return (ml_hi_file ms_location, ml_obj_file ms_location) + else (,) <$> (new_temp_file (hiSuf dflags) (dynHiSuf dflags)) + <*> (new_temp_file (objectSuf dflags) (dynObjectSuf dflags)) + return $ + ms + { ms_location = + ms_location {ml_hi_file = hi_file, ml_obj_file = o_file} + , ms_hspp_opts = updOptLevel 0 $ dflags {hscTarget = target} + } + | otherwise = return ms + + needs_codegen_set = transitive_deps_set + [ ms + | mss <- Map.elems nodemap + , Right ms <- mss + , condition ms + ] + + -- find the set of all transitive dependencies of a list of modules. + transitive_deps_set modSums = foldl' go Set.empty modSums + where + go marked_mods ms@ModSummary{ms_mod} + | ms_mod `Set.member` marked_mods = marked_mods + | otherwise = + let deps = + [ dep_ms + -- If a module imports a boot module, msDeps helpfully adds a + -- dependency to that non-boot module in it's result. This + -- means we don't have to think about boot modules here. + | (L _ mn, NotBoot) <- msDeps ms + , dep_ms <- + toList (Map.lookup (mn, NotBoot) nodemap) >>= toList >>= + toList + ] + new_marked_mods = Set.insert ms_mod marked_mods + in foldl' go new_marked_mods deps + +mkRootMap :: [ModSummary] -> NodeMap [Either ErrorMessages ModSummary] +mkRootMap summaries = Map.insertListWith (flip (++)) + [ (msKey s, [Right s]) | s <- summaries ] + Map.empty + +-- | Returns the dependencies of the ModSummary s. +-- A wrinkle is that for a {-# SOURCE #-} import we return +-- *both* the hs-boot file +-- *and* the source file +-- as "dependencies". That ensures that the list of all relevant +-- modules always contains B.hs if it contains B.hs-boot. +-- Remember, this pass isn't doing the topological sort. It's +-- just gathering the list of all relevant ModSummaries +msDeps :: ModSummary -> [(Located ModuleName, IsBoot)] +msDeps s = + concat [ [(m,IsBoot), (m,NotBoot)] | m <- ms_home_srcimps s ] + ++ [ (m,NotBoot) | m <- ms_home_imps s ] + +----------------------------------------------------------------------------- +-- Summarising modules + +-- We have two types of summarisation: +-- +-- * Summarise a file. This is used for the root module(s) passed to +-- cmLoadModules. The file is read, and used to determine the root +-- module name. The module name may differ from the filename. +-- +-- * Summarise a module. We are given a module name, and must provide +-- a summary. The finder is used to locate the file in which the module +-- resides. + +summariseFile + :: HscEnv + -> [ModSummary] -- old summaries + -> FilePath -- source file name + -> Maybe Phase -- start phase + -> Bool -- object code allowed? + -> Maybe (StringBuffer,UTCTime) + -> IO (Either ErrorMessages ModSummary) + +summariseFile hsc_env old_summaries src_fn mb_phase obj_allowed maybe_buf + -- we can use a cached summary if one is available and the + -- source file hasn't changed, But we have to look up the summary + -- by source file, rather than module name as we do in summarise. + | Just old_summary <- findSummaryBySourceFile old_summaries src_fn + = do + let location = ms_location old_summary + dflags = hsc_dflags hsc_env + + src_timestamp <- get_src_timestamp + -- The file exists; we checked in getRootSummary above. + -- If it gets removed subsequently, then this + -- getModificationUTCTime may fail, but that's the right + -- behaviour. + + -- return the cached summary if the source didn't change + checkSummaryTimestamp + hsc_env dflags obj_allowed NotBoot (new_summary src_fn) + old_summary location src_timestamp + + | otherwise + = do src_timestamp <- get_src_timestamp + new_summary src_fn src_timestamp + where + get_src_timestamp = case maybe_buf of + Just (_,t) -> return t + Nothing -> liftIO $ getModificationUTCTime src_fn + -- getModificationUTCTime may fail + + new_summary src_fn src_timestamp = runExceptT $ do + preimps@PreprocessedImports {..} + <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf + + + -- Make a ModLocation for this file + location <- liftIO $ mkHomeModLocation (hsc_dflags hsc_env) pi_mod_name src_fn + + -- Tell the Finder cache where it is, so that subsequent calls + -- to findModule will find it, even if it's not on any search path + mod <- liftIO $ addHomeModuleToFinder hsc_env pi_mod_name location + + liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary + { nms_src_fn = src_fn + , nms_src_timestamp = src_timestamp + , nms_is_boot = NotBoot + , nms_hsc_src = + if isHaskellSigFilename src_fn + then HsigFile + else HsSrcFile + , nms_location = location + , nms_mod = mod + , nms_obj_allowed = obj_allowed + , nms_preimps = preimps + } + +findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary +findSummaryBySourceFile summaries file + = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms], + expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of + [] -> Nothing + (x:_) -> Just x + +checkSummaryTimestamp + :: HscEnv -> DynFlags -> Bool -> IsBoot + -> (UTCTime -> IO (Either e ModSummary)) + -> ModSummary -> ModLocation -> UTCTime + -> IO (Either e ModSummary) +checkSummaryTimestamp + hsc_env dflags obj_allowed is_boot new_summary + old_summary location src_timestamp + | ms_hs_date old_summary == src_timestamp && + not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do + -- update the object-file timestamp + obj_timestamp <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + || obj_allowed -- bug #1205 + then liftIO $ getObjTimestamp location is_boot + else return Nothing + + -- We have to repopulate the Finder's cache for file targets + -- because the file might not even be on the regular search path + -- and it was likely flushed in depanal. This is not technically + -- needed when we're called from sumariseModule but it shouldn't + -- hurt. + _ <- addHomeModuleToFinder hsc_env + (moduleName (ms_mod old_summary)) location + + hi_timestamp <- maybeGetIfaceDate dflags location + hie_timestamp <- modificationTimeIfExists (ml_hie_file location) + + return $ Right old_summary + { ms_obj_date = obj_timestamp + , ms_iface_date = hi_timestamp + , ms_hie_date = hie_timestamp + } + + | otherwise = + -- source changed: re-summarise. + new_summary src_timestamp + +-- Summarise a module, and pick up source and timestamp. +summariseModule + :: HscEnv + -> NodeMap ModSummary -- Map of old summaries + -> IsBoot -- IsBoot <=> a {-# SOURCE #-} import + -> Located ModuleName -- Imported module to be summarised + -> Bool -- object code allowed? + -> Maybe (StringBuffer, UTCTime) + -> [ModuleName] -- Modules to exclude + -> IO (Maybe (Either ErrorMessages ModSummary)) -- Its new summary + +summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) + obj_allowed maybe_buf excl_mods + | wanted_mod `elem` excl_mods + = return Nothing + + | Just old_summary <- Map.lookup (wanted_mod, is_boot) old_summary_map + = do -- Find its new timestamp; all the + -- ModSummaries in the old map have valid ml_hs_files + let location = ms_location old_summary + src_fn = expectJust "summariseModule" (ml_hs_file location) + + -- check the modification time on the source file, and + -- return the cached summary if it hasn't changed. If the + -- file has disappeared, we need to call the Finder again. + case maybe_buf of + Just (_,t) -> + Just <$> check_timestamp old_summary location src_fn t + Nothing -> do + m <- tryIO (getModificationUTCTime src_fn) + case m of + Right t -> + Just <$> check_timestamp old_summary location src_fn t + Left e | isDoesNotExistError e -> find_it + | otherwise -> ioError e + + | otherwise = find_it + where + dflags = hsc_dflags hsc_env + + check_timestamp old_summary location src_fn = + checkSummaryTimestamp + hsc_env dflags obj_allowed is_boot + (new_summary location (ms_mod old_summary) src_fn) + old_summary location + + find_it = do + found <- findImportedModule hsc_env wanted_mod Nothing + case found of + Found location mod + | isJust (ml_hs_file location) -> + -- Home package + Just <$> just_found location mod + + _ -> return Nothing + -- Not found + -- (If it is TRULY not found at all, we'll + -- error when we actually try to compile) + + just_found location mod = do + -- Adjust location to point to the hs-boot source file, + -- hi file, object file, when is_boot says so + let location' | IsBoot <- is_boot = addBootSuffixLocn location + | otherwise = location + src_fn = expectJust "summarise2" (ml_hs_file location') + + -- Check that it exists + -- It might have been deleted since the Finder last found it + maybe_t <- modificationTimeIfExists src_fn + case maybe_t of + Nothing -> return $ Left $ noHsFileErr dflags loc src_fn + Just t -> new_summary location' mod src_fn t + + new_summary location mod src_fn src_timestamp + = runExceptT $ do + preimps@PreprocessedImports {..} + <- getPreprocessedImports hsc_env src_fn Nothing maybe_buf + + -- NB: Despite the fact that is_boot is a top-level parameter, we + -- don't actually know coming into this function what the HscSource + -- of the module in question is. This is because we may be processing + -- this module because another module in the graph imported it: in this + -- case, we know if it's a boot or not because of the {-# SOURCE #-} + -- annotation, but we don't know if it's a signature or a regular + -- module until we actually look it up on the filesystem. + let hsc_src = case is_boot of + IsBoot -> HsBootFile + _ | isHaskellSigFilename src_fn -> HsigFile + | otherwise -> HsSrcFile + + when (pi_mod_name /= wanted_mod) $ + throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $ + text "File name does not match module name:" + $$ text "Saw:" <+> quotes (ppr pi_mod_name) + $$ text "Expected:" <+> quotes (ppr wanted_mod) + + when (hsc_src == HsigFile && isNothing (lookup pi_mod_name (thisUnitIdInsts dflags))) $ + let suggested_instantiated_with = + hcat (punctuate comma $ + [ ppr k <> text "=" <> ppr v + | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name) + : thisUnitIdInsts dflags) + ]) + in throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $ + text "Unexpected signature:" <+> quotes (ppr pi_mod_name) + $$ if gopt Opt_BuildingCabalPackage dflags + then parens (text "Try adding" <+> quotes (ppr pi_mod_name) + <+> text "to the" + <+> quotes (text "signatures") + <+> text "field in your Cabal file.") + else parens (text "Try passing -instantiated-with=\"" <> + suggested_instantiated_with <> text "\"" $$ + text "replacing <" <> ppr pi_mod_name <> text "> as necessary.") + + liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary + { nms_src_fn = src_fn + , nms_src_timestamp = src_timestamp + , nms_is_boot = is_boot + , nms_hsc_src = hsc_src + , nms_location = location + , nms_mod = mod + , nms_obj_allowed = obj_allowed + , nms_preimps = preimps + } + +-- | Convenience named arguments for 'makeNewModSummary' only used to make +-- code more readable, not exported. +data MakeNewModSummary + = MakeNewModSummary + { nms_src_fn :: FilePath + , nms_src_timestamp :: UTCTime + , nms_is_boot :: IsBoot + , nms_hsc_src :: HscSource + , nms_location :: ModLocation + , nms_mod :: Module + , nms_obj_allowed :: Bool + , nms_preimps :: PreprocessedImports + } + +makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary +makeNewModSummary hsc_env MakeNewModSummary{..} = do + let PreprocessedImports{..} = nms_preimps + let dflags = hsc_dflags hsc_env + + -- when the user asks to load a source file by name, we only + -- use an object file if -fobject-code is on. See #1205. + obj_timestamp <- liftIO $ + if isObjectTarget (hscTarget dflags) + || nms_obj_allowed -- bug #1205 + then getObjTimestamp nms_location nms_is_boot + else return Nothing + + hi_timestamp <- maybeGetIfaceDate dflags nms_location + hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location) + + extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name + required_by_imports <- implicitRequirements hsc_env pi_theimps + + return $ ModSummary + { ms_mod = nms_mod + , ms_hsc_src = nms_hsc_src + , ms_location = nms_location + , ms_hspp_file = pi_hspp_fn + , ms_hspp_opts = pi_local_dflags + , ms_hspp_buf = Just pi_hspp_buf + , ms_parsed_mod = Nothing + , ms_srcimps = pi_srcimps + , ms_textual_imps = + pi_theimps ++ extra_sig_imports ++ required_by_imports + , ms_hs_date = nms_src_timestamp + , ms_iface_date = hi_timestamp + , ms_hie_date = hie_timestamp + , ms_obj_date = obj_timestamp + } + +getObjTimestamp :: ModLocation -> IsBoot -> IO (Maybe UTCTime) +getObjTimestamp location is_boot + = if is_boot == IsBoot then return Nothing + else modificationTimeIfExists (ml_obj_file location) + +data PreprocessedImports + = PreprocessedImports + { pi_local_dflags :: DynFlags + , pi_srcimps :: [(Maybe FastString, Located ModuleName)] + , pi_theimps :: [(Maybe FastString, Located ModuleName)] + , pi_hspp_fn :: FilePath + , pi_hspp_buf :: StringBuffer + , pi_mod_name_loc :: SrcSpan + , pi_mod_name :: ModuleName + } + +-- Preprocess the source file and get its imports +-- The pi_local_dflags contains the OPTIONS pragmas +getPreprocessedImports + :: HscEnv + -> FilePath + -> Maybe Phase + -> Maybe (StringBuffer, UTCTime) + -- ^ optional source code buffer and modification time + -> ExceptT ErrorMessages IO PreprocessedImports +getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do + (pi_local_dflags, pi_hspp_fn) + <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase + pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn + (pi_srcimps, pi_theimps, L pi_mod_name_loc pi_mod_name) + <- ExceptT $ getImports pi_local_dflags pi_hspp_buf pi_hspp_fn src_fn + return PreprocessedImports {..} + + +----------------------------------------------------------------------------- +-- Error messages +----------------------------------------------------------------------------- + +-- Defer and group warning, error and fatal messages so they will not get lost +-- in the regular output. +withDeferredDiagnostics :: GhcMonad m => m a -> m a +withDeferredDiagnostics f = do + dflags <- getDynFlags + if not $ gopt Opt_DeferDiagnostics dflags + then f + else do + warnings <- liftIO $ newIORef [] + errors <- liftIO $ newIORef [] + fatals <- liftIO $ newIORef [] + + let deferDiagnostics _dflags !reason !severity !srcSpan !style !msg = do + let action = putLogMsg dflags reason severity srcSpan style msg + case severity of + SevWarning -> atomicModifyIORef' warnings $ \i -> (action: i, ()) + SevError -> atomicModifyIORef' errors $ \i -> (action: i, ()) + SevFatal -> atomicModifyIORef' fatals $ \i -> (action: i, ()) + _ -> action + + printDeferredDiagnostics = liftIO $ + forM_ [warnings, errors, fatals] $ \ref -> do + -- This IORef can leak when the dflags leaks, so let us always + -- reset the content. + actions <- atomicModifyIORef' ref $ \i -> ([], i) + sequence_ $ reverse actions + + setLogAction action = modifySession $ \hsc_env -> + hsc_env{ hsc_dflags = (hsc_dflags hsc_env){ log_action = action } } + + gbracket + (setLogAction deferDiagnostics) + (\_ -> setLogAction (log_action dflags) >> printDeferredDiagnostics) + (\_ -> f) + +noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> ErrMsg +-- ToDo: we don't have a proper line number for this error +noModError dflags loc wanted_mod err + = mkPlainErrMsg dflags loc $ cannotFindModule dflags wanted_mod err + +noHsFileErr :: DynFlags -> SrcSpan -> String -> ErrorMessages +noHsFileErr dflags loc path + = unitBag $ mkPlainErrMsg dflags loc $ text "Can't find" <+> text path + +moduleNotFoundErr :: DynFlags -> ModuleName -> ErrorMessages +moduleNotFoundErr dflags mod + = unitBag $ mkPlainErrMsg dflags noSrcSpan $ + text "module" <+> quotes (ppr mod) <+> text "cannot be found locally" + +multiRootsErr :: DynFlags -> [ModSummary] -> IO () +multiRootsErr _ [] = panic "multiRootsErr" +multiRootsErr dflags summs@(summ1:_) + = throwOneError $ mkPlainErrMsg dflags noSrcSpan $ + text "module" <+> quotes (ppr mod) <+> + text "is defined in multiple files:" <+> + sep (map text files) + where + mod = ms_mod summ1 + files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs + +keepGoingPruneErr :: [ModuleName] -> SDoc +keepGoingPruneErr ms + = vcat (( text "-fkeep-going in use, removing the following" <+> + text "dependencies and continuing:"): + map (nest 6 . ppr) ms ) + +cyclicModuleErr :: [ModSummary] -> SDoc +-- From a strongly connected component we find +-- a single cycle to report +cyclicModuleErr mss + = ASSERT( not (null mss) ) + case findCycle graph of + Nothing -> text "Unexpected non-cycle" <+> ppr mss + Just path -> vcat [ text "Module imports form a cycle:" + , nest 2 (show_path path) ] + where + graph :: [Node NodeKey ModSummary] + graph = [ DigraphNode ms (msKey ms) (get_deps ms) | ms <- mss] + + get_deps :: ModSummary -> [NodeKey] + get_deps ms = ([ (unLoc m, IsBoot) | m <- ms_home_srcimps ms ] ++ + [ (unLoc m, NotBoot) | m <- ms_home_imps ms ]) + + show_path [] = panic "show_path" + show_path [m] = text "module" <+> ppr_ms m + <+> text "imports itself" + show_path (m1:m2:ms) = vcat ( nest 7 (text "module" <+> ppr_ms m1) + : nest 6 (text "imports" <+> ppr_ms m2) + : go ms ) + where + go [] = [text "which imports" <+> ppr_ms m1] + go (m:ms) = (text "which imports" <+> ppr_ms m) : go ms + + + ppr_ms :: ModSummary -> SDoc + ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+> + (parens (text (msHsFilePath ms))) diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs new file mode 100644 index 0000000000..d1d3b00394 --- /dev/null +++ b/compiler/GHC/Driver/MakeFile.hs @@ -0,0 +1,424 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- +-- Makefile Dependency Generation +-- +-- (c) The University of Glasgow 2005 +-- +----------------------------------------------------------------------------- + +module GHC.Driver.MakeFile + ( doMkDependHS + ) +where + +#include "HsVersions.h" + +import GhcPrelude + +import qualified GHC +import GHC.Driver.Monad +import GHC.Driver.Session +import Util +import GHC.Driver.Types +import qualified SysTools +import Module +import Digraph ( SCC(..) ) +import GHC.Driver.Finder +import Outputable +import Panic +import SrcLoc +import Data.List +import FastString +import FileCleanup + +import Exception +import ErrUtils + +import System.Directory +import System.FilePath +import System.IO +import System.IO.Error ( isEOFError ) +import Control.Monad ( when ) +import Data.Maybe ( isJust ) +import Data.IORef + +----------------------------------------------------------------- +-- +-- The main function +-- +----------------------------------------------------------------- + +doMkDependHS :: GhcMonad m => [FilePath] -> m () +doMkDependHS srcs = do + -- Initialisation + dflags0 <- GHC.getSessionDynFlags + + -- We kludge things a bit for dependency generation. Rather than + -- generating dependencies for each way separately, we generate + -- them once and then duplicate them for each way's osuf/hisuf. + -- We therefore do the initial dependency generation with an empty + -- way and .o/.hi extensions, regardless of any flags that might + -- be specified. + let dflags = dflags0 { + ways = [], + buildTag = mkBuildTag [], + hiSuf = "hi", + objectSuf = "o" + } + _ <- GHC.setSessionDynFlags dflags + + when (null (depSuffixes dflags)) $ liftIO $ + throwGhcExceptionIO (ProgramError "You must specify at least one -dep-suffix") + + files <- liftIO $ beginMkDependHS dflags + + -- Do the downsweep to find all the modules + targets <- mapM (\s -> GHC.guessTarget s Nothing) srcs + GHC.setTargets targets + let excl_mods = depExcludeMods dflags + module_graph <- GHC.depanal excl_mods True {- Allow dup roots -} + + -- Sort into dependency order + -- There should be no cycles + let sorted = GHC.topSortModuleGraph False module_graph Nothing + + -- Print out the dependencies if wanted + liftIO $ debugTraceMsg dflags 2 (text "Module dependencies" $$ ppr sorted) + + -- Process them one by one, dumping results into makefile + -- and complaining about cycles + hsc_env <- getSession + root <- liftIO getCurrentDirectory + mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted + + -- If -ddump-mod-cycles, show cycles in the module graph + liftIO $ dumpModCycles dflags module_graph + + -- Tidy up + liftIO $ endMkDependHS dflags files + + -- Unconditional exiting is a bad idea. If an error occurs we'll get an + --exception; if that is not caught it's fine, but at least we have a + --chance to find out exactly what went wrong. Uncomment the following + --line if you disagree. + + --`GHC.ghcCatch` \_ -> io $ exitWith (ExitFailure 1) + +----------------------------------------------------------------- +-- +-- beginMkDependHs +-- Create a temporary file, +-- find the Makefile, +-- slurp through it, etc +-- +----------------------------------------------------------------- + +data MkDepFiles + = MkDep { mkd_make_file :: FilePath, -- Name of the makefile + mkd_make_hdl :: Maybe Handle, -- Handle for the open makefile + mkd_tmp_file :: FilePath, -- Name of the temporary file + mkd_tmp_hdl :: Handle } -- Handle of the open temporary file + +beginMkDependHS :: DynFlags -> IO MkDepFiles +beginMkDependHS dflags = do + -- open a new temp file in which to stuff the dependency info + -- as we go along. + tmp_file <- newTempName dflags TFL_CurrentModule "dep" + tmp_hdl <- openFile tmp_file WriteMode + + -- open the makefile + let makefile = depMakefile dflags + exists <- doesFileExist makefile + mb_make_hdl <- + if not exists + then return Nothing + else do + makefile_hdl <- openFile makefile ReadMode + + -- slurp through until we get the magic start string, + -- copying the contents into dep_makefile + let slurp = do + l <- hGetLine makefile_hdl + if (l == depStartMarker) + then return () + else do hPutStrLn tmp_hdl l; slurp + + -- slurp through until we get the magic end marker, + -- throwing away the contents + let chuck = do + l <- hGetLine makefile_hdl + if (l == depEndMarker) + then return () + else chuck + + catchIO slurp + (\e -> if isEOFError e then return () else ioError e) + catchIO chuck + (\e -> if isEOFError e then return () else ioError e) + + return (Just makefile_hdl) + + + -- write the magic marker into the tmp file + hPutStrLn tmp_hdl depStartMarker + + return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl, + mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl}) + + +----------------------------------------------------------------- +-- +-- processDeps +-- +----------------------------------------------------------------- + +processDeps :: DynFlags + -> HscEnv + -> [ModuleName] + -> FilePath + -> Handle -- Write dependencies to here + -> SCC ModSummary + -> IO () +-- Write suitable dependencies to handle +-- Always: +-- this.o : this.hs +-- +-- If the dependency is on something other than a .hi file: +-- this.o this.p_o ... : dep +-- otherwise +-- this.o ... : dep.hi +-- this.p_o ... : dep.p_hi +-- ... +-- (where .o is $osuf, and the other suffixes come from +-- the cmdline -s options). +-- +-- For {-# SOURCE #-} imports the "hi" will be "hi-boot". + +processDeps dflags _ _ _ _ (CyclicSCC nodes) + = -- There shouldn't be any cycles; report them + throwGhcExceptionIO (ProgramError (showSDoc dflags $ GHC.cyclicModuleErr nodes)) + +processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node) + = do { let extra_suffixes = depSuffixes dflags + include_pkg_deps = depIncludePkgDeps dflags + src_file = msHsFilePath node + obj_file = msObjFilePath node + obj_files = insertSuffixes obj_file extra_suffixes + + do_imp loc is_boot pkg_qual imp_mod + = do { mb_hi <- findDependency hsc_env loc pkg_qual imp_mod + is_boot include_pkg_deps + ; case mb_hi of { + Nothing -> return () ; + Just hi_file -> do + { let hi_files = insertSuffixes hi_file extra_suffixes + write_dep (obj,hi) = writeDependency root hdl [obj] hi + + -- Add one dependency for each suffix; + -- e.g. A.o : B.hi + -- A.x_o : B.x_hi + ; mapM_ write_dep (obj_files `zip` hi_files) }}} + + + -- Emit std dependency of the object(s) on the source file + -- Something like A.o : A.hs + ; writeDependency root hdl obj_files src_file + + -- Emit a dependency for each CPP import + ; when (depIncludeCppDeps dflags) $ do + -- CPP deps are descovered in the module parsing phase by parsing + -- comment lines left by the preprocessor. + -- Note that GHC.parseModule may throw an exception if the module + -- fails to parse, which may not be desirable (see #16616). + { session <- Session <$> newIORef hsc_env + ; parsedMod <- reflectGhc (GHC.parseModule node) session + ; mapM_ (writeDependency root hdl obj_files) + (GHC.pm_extra_src_files parsedMod) + } + + -- Emit a dependency for each import + + ; let do_imps is_boot idecls = sequence_ + [ do_imp loc is_boot mb_pkg mod + | (mb_pkg, L loc mod) <- idecls, + mod `notElem` excl_mods ] + + ; do_imps True (ms_srcimps node) + ; do_imps False (ms_imps node) + } + + +findDependency :: HscEnv + -> SrcSpan + -> Maybe FastString -- package qualifier, if any + -> ModuleName -- Imported module + -> IsBootInterface -- Source import + -> Bool -- Record dependency on package modules + -> IO (Maybe FilePath) -- Interface file file +findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps + = do { -- Find the module; this will be fast because + -- we've done it once during downsweep + r <- findImportedModule hsc_env imp pkg + ; case r of + Found loc _ + -- Home package: just depend on the .hi or hi-boot file + | isJust (ml_hs_file loc) || include_pkg_deps + -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc))) + + -- Not in this package: we don't need a dependency + | otherwise + -> return Nothing + + fail -> + let dflags = hsc_dflags hsc_env + in throwOneError $ mkPlainErrMsg dflags srcloc $ + cannotFindModule dflags imp fail + } + +----------------------------- +writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO () +-- (writeDependency r h [t1,t2] dep) writes to handle h the dependency +-- t1 t2 : dep +writeDependency root hdl targets dep + = do let -- We need to avoid making deps on + -- c:/foo/... + -- on cygwin as make gets confused by the : + -- Making relative deps avoids some instances of this. + dep' = makeRelative root dep + forOutput = escapeSpaces . reslash Forwards . normalise + output = unwords (map forOutput targets) ++ " : " ++ forOutput dep' + hPutStrLn hdl output + +----------------------------- +insertSuffixes + :: FilePath -- Original filename; e.g. "foo.o" + -> [String] -- Suffix prefixes e.g. ["x_", "y_"] + -> [FilePath] -- Zapped filenames e.g. ["foo.x_o", "foo.y_o"] + -- Note that that the extra bit gets inserted *before* the old suffix + -- We assume the old suffix contains no dots, so we know where to + -- split it +insertSuffixes file_name extras + = [ basename <.> (extra ++ suffix) | extra <- extras ] + where + (basename, suffix) = case splitExtension file_name of + -- Drop the "." from the extension + (b, s) -> (b, drop 1 s) + + +----------------------------------------------------------------- +-- +-- endMkDependHs +-- Complete the makefile, close the tmp file etc +-- +----------------------------------------------------------------- + +endMkDependHS :: DynFlags -> MkDepFiles -> IO () + +endMkDependHS dflags + (MkDep { mkd_make_file = makefile, mkd_make_hdl = makefile_hdl, + mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl }) + = do + -- write the magic marker into the tmp file + hPutStrLn tmp_hdl depEndMarker + + case makefile_hdl of + Nothing -> return () + Just hdl -> do + + -- slurp the rest of the original makefile and copy it into the output + let slurp = do + l <- hGetLine hdl + hPutStrLn tmp_hdl l + slurp + + catchIO slurp + (\e -> if isEOFError e then return () else ioError e) + + hClose hdl + + hClose tmp_hdl -- make sure it's flushed + + -- Create a backup of the original makefile + when (isJust makefile_hdl) + (SysTools.copy dflags ("Backing up " ++ makefile) + makefile (makefile++".bak")) + + -- Copy the new makefile in place + SysTools.copy dflags "Installing new makefile" tmp_file makefile + + +----------------------------------------------------------------- +-- Module cycles +----------------------------------------------------------------- + +dumpModCycles :: DynFlags -> ModuleGraph -> IO () +dumpModCycles dflags module_graph + | not (dopt Opt_D_dump_mod_cycles dflags) + = return () + + | null cycles + = putMsg dflags (text "No module cycles") + + | otherwise + = putMsg dflags (hang (text "Module cycles found:") 2 pp_cycles) + where + + cycles :: [[ModSummary]] + cycles = + [ c | CyclicSCC c <- GHC.topSortModuleGraph True module_graph Nothing ] + + pp_cycles = vcat [ (text "---------- Cycle" <+> int n <+> ptext (sLit "----------")) + $$ pprCycle c $$ blankLine + | (n,c) <- [1..] `zip` cycles ] + +pprCycle :: [ModSummary] -> SDoc +-- Print a cycle, but show only the imports within the cycle +pprCycle summaries = pp_group (CyclicSCC summaries) + where + cycle_mods :: [ModuleName] -- The modules in this cycle + cycle_mods = map (moduleName . ms_mod) summaries + + pp_group (AcyclicSCC ms) = pp_ms ms + pp_group (CyclicSCC mss) + = ASSERT( not (null boot_only) ) + -- The boot-only list must be non-empty, else there would + -- be an infinite chain of non-boot imports, and we've + -- already checked for that in processModDeps + pp_ms loop_breaker $$ vcat (map pp_group groups) + where + (boot_only, others) = partition is_boot_only mss + is_boot_only ms = not (any in_group (map snd (ms_imps ms))) + in_group (L _ m) = m `elem` group_mods + group_mods = map (moduleName . ms_mod) mss + + loop_breaker = head boot_only + all_others = tail boot_only ++ others + groups = + GHC.topSortModuleGraph True (mkModuleGraph all_others) Nothing + + pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' ')) + <+> (pp_imps empty (map snd (ms_imps summary)) $$ + pp_imps (text "{-# SOURCE #-}") (map snd (ms_srcimps summary))) + where + mod_str = moduleNameString (moduleName (ms_mod summary)) + + pp_imps :: SDoc -> [Located ModuleName] -> SDoc + pp_imps _ [] = empty + pp_imps what lms + = case [m | L _ m <- lms, m `elem` cycle_mods] of + [] -> empty + ms -> what <+> text "imports" <+> + pprWithCommas ppr ms + +----------------------------------------------------------------- +-- +-- Flags +-- +----------------------------------------------------------------- + +depStartMarker, depEndMarker :: String +depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies" +depEndMarker = "# DO NOT DELETE: End of Haskell dependencies" + diff --git a/compiler/GHC/Driver/Monad.hs b/compiler/GHC/Driver/Monad.hs new file mode 100644 index 0000000000..3825757ac6 --- /dev/null +++ b/compiler/GHC/Driver/Monad.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE CPP, DeriveFunctor, RankNTypes #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2010 +-- +-- The Session type and related functionality +-- +-- ----------------------------------------------------------------------------- + +module GHC.Driver.Monad ( + -- * 'Ghc' monad stuff + GhcMonad(..), + Ghc(..), + GhcT(..), liftGhcT, + reflectGhc, reifyGhc, + getSessionDynFlags, + liftIO, + Session(..), withSession, modifySession, withTempSession, + + -- ** Warnings + logWarnings, printException, + WarnErrLogger, defaultWarnErrLogger + ) where + +import GhcPrelude + +import MonadUtils +import GHC.Driver.Types +import GHC.Driver.Session +import Exception +import ErrUtils + +import Control.Monad +import Data.IORef + +-- ----------------------------------------------------------------------------- +-- | A monad that has all the features needed by GHC API calls. +-- +-- In short, a GHC monad +-- +-- - allows embedding of IO actions, +-- +-- - can log warnings, +-- +-- - allows handling of (extensible) exceptions, and +-- +-- - maintains a current session. +-- +-- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad' +-- before any call to the GHC API functions can occur. +-- +class (Functor m, MonadIO m, ExceptionMonad m, HasDynFlags m) => GhcMonad m where + getSession :: m HscEnv + setSession :: HscEnv -> m () + +-- | Call the argument with the current session. +withSession :: GhcMonad m => (HscEnv -> m a) -> m a +withSession f = getSession >>= f + +-- | Grabs the DynFlags from the Session +getSessionDynFlags :: GhcMonad m => m DynFlags +getSessionDynFlags = withSession (return . hsc_dflags) + +-- | Set the current session to the result of applying the current session to +-- the argument. +modifySession :: GhcMonad m => (HscEnv -> HscEnv) -> m () +modifySession f = do h <- getSession + setSession $! f h + +withSavedSession :: GhcMonad m => m a -> m a +withSavedSession m = do + saved_session <- getSession + m `gfinally` setSession saved_session + +-- | Call an action with a temporarily modified Session. +withTempSession :: GhcMonad m => (HscEnv -> HscEnv) -> m a -> m a +withTempSession f m = + withSavedSession $ modifySession f >> m + +-- ----------------------------------------------------------------------------- +-- | A monad that allows logging of warnings. + +logWarnings :: GhcMonad m => WarningMessages -> m () +logWarnings warns = do + dflags <- getSessionDynFlags + liftIO $ printOrThrowWarnings dflags warns + +-- ----------------------------------------------------------------------------- +-- | A minimal implementation of a 'GhcMonad'. If you need a custom monad, +-- e.g., to maintain additional state consider wrapping this monad or using +-- 'GhcT'. +newtype Ghc a = Ghc { unGhc :: Session -> IO a } deriving (Functor) + +-- | The Session is a handle to the complete state of a compilation +-- session. A compilation session consists of a set of modules +-- constituting the current program or library, the context for +-- interactive evaluation, and various caches. +data Session = Session !(IORef HscEnv) + +instance Applicative Ghc where + pure a = Ghc $ \_ -> return a + g <*> m = do f <- g; a <- m; return (f a) + +instance Monad Ghc where + m >>= g = Ghc $ \s -> do a <- unGhc m s; unGhc (g a) s + +instance MonadIO Ghc where + liftIO ioA = Ghc $ \_ -> ioA + +instance MonadFix Ghc where + mfix f = Ghc $ \s -> mfix (\x -> unGhc (f x) s) + +instance ExceptionMonad Ghc where + gcatch act handle = + Ghc $ \s -> unGhc act s `gcatch` \e -> unGhc (handle e) s + gmask f = + Ghc $ \s -> gmask $ \io_restore -> + let + g_restore (Ghc m) = Ghc $ \s -> io_restore (m s) + in + unGhc (f g_restore) s + +instance HasDynFlags Ghc where + getDynFlags = getSessionDynFlags + +instance GhcMonad Ghc where + getSession = Ghc $ \(Session r) -> readIORef r + setSession s' = Ghc $ \(Session r) -> writeIORef r s' + +-- | Reflect a computation in the 'Ghc' monad into the 'IO' monad. +-- +-- You can use this to call functions returning an action in the 'Ghc' monad +-- inside an 'IO' action. This is needed for some (too restrictive) callback +-- arguments of some library functions: +-- +-- > libFunc :: String -> (Int -> IO a) -> IO a +-- > ghcFunc :: Int -> Ghc a +-- > +-- > ghcFuncUsingLibFunc :: String -> Ghc a -> Ghc a +-- > ghcFuncUsingLibFunc str = +-- > reifyGhc $ \s -> +-- > libFunc $ \i -> do +-- > reflectGhc (ghcFunc i) s +-- +reflectGhc :: Ghc a -> Session -> IO a +reflectGhc m = unGhc m + +-- > Dual to 'reflectGhc'. See its documentation. +reifyGhc :: (Session -> IO a) -> Ghc a +reifyGhc act = Ghc $ act + +-- ----------------------------------------------------------------------------- +-- | A monad transformer to add GHC specific features to another monad. +-- +-- Note that the wrapped monad must support IO and handling of exceptions. +newtype GhcT m a = GhcT { unGhcT :: Session -> m a } + deriving (Functor) + +liftGhcT :: m a -> GhcT m a +liftGhcT m = GhcT $ \_ -> m + +instance Applicative m => Applicative (GhcT m) where + pure x = GhcT $ \_ -> pure x + g <*> m = GhcT $ \s -> unGhcT g s <*> unGhcT m s + +instance Monad m => Monad (GhcT m) where + m >>= k = GhcT $ \s -> do a <- unGhcT m s; unGhcT (k a) s + +instance MonadIO m => MonadIO (GhcT m) where + liftIO ioA = GhcT $ \_ -> liftIO ioA + +instance ExceptionMonad m => ExceptionMonad (GhcT m) where + gcatch act handle = + GhcT $ \s -> unGhcT act s `gcatch` \e -> unGhcT (handle e) s + gmask f = + GhcT $ \s -> gmask $ \io_restore -> + let + g_restore (GhcT m) = GhcT $ \s -> io_restore (m s) + in + unGhcT (f g_restore) s + +instance MonadIO m => HasDynFlags (GhcT m) where + getDynFlags = GhcT $ \(Session r) -> liftM hsc_dflags (liftIO $ readIORef r) + +instance ExceptionMonad m => GhcMonad (GhcT m) where + getSession = GhcT $ \(Session r) -> liftIO $ readIORef r + setSession s' = GhcT $ \(Session r) -> liftIO $ writeIORef r s' + + +-- | Print the error message and all warnings. Useful inside exception +-- handlers. Clears warnings after printing. +printException :: GhcMonad m => SourceError -> m () +printException err = do + dflags <- getSessionDynFlags + liftIO $ printBagOfErrors dflags (srcErrorMessages err) + +-- | A function called to log warnings and errors. +type WarnErrLogger = forall m. GhcMonad m => Maybe SourceError -> m () + +defaultWarnErrLogger :: WarnErrLogger +defaultWarnErrLogger Nothing = return () +defaultWarnErrLogger (Just e) = printException e + diff --git a/compiler/GHC/Driver/Packages.hs b/compiler/GHC/Driver/Packages.hs new file mode 100644 index 0000000000..572da5f3d1 --- /dev/null +++ b/compiler/GHC/Driver/Packages.hs @@ -0,0 +1,2215 @@ +-- (c) The University of Glasgow, 2006 + +{-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns, FlexibleContexts #-} + +-- | Package manipulation +module GHC.Driver.Packages ( + module UnitInfo, + + -- * Reading the package config, and processing cmdline args + PackageState(preloadPackages, explicitPackages, moduleNameProvidersMap, requirementContext), + PackageDatabase (..), + UnitInfoMap, + emptyPackageState, + initPackages, + readPackageDatabases, + readPackageDatabase, + getPackageConfRefs, + resolvePackageDatabase, + listUnitInfoMap, + + -- * Querying the package config + lookupUnit, + lookupUnit', + lookupInstalledPackage, + lookupPackageName, + improveUnitId, + searchPackageId, + getPackageDetails, + getInstalledPackageDetails, + componentIdString, + displayInstalledUnitId, + listVisibleModuleNames, + lookupModuleInAllPackages, + lookupModuleWithSuggestions, + lookupPluginModuleWithSuggestions, + LookupResult(..), + ModuleSuggestion(..), + ModuleOrigin(..), + UnusablePackageReason(..), + pprReason, + + -- * Inspecting the set of packages in scope + getPackageIncludePath, + getPackageLibraryPath, + getPackageLinkOpts, + getPackageExtraCcOpts, + getPackageFrameworkPath, + getPackageFrameworks, + getUnitInfoMap, + getPreloadPackagesAnd, + + collectArchives, + collectIncludeDirs, collectLibraryPaths, collectLinkOpts, + packageHsLibs, getLibs, + + -- * Utils + unwireUnitId, + pprFlag, + pprPackages, + pprPackagesSimple, + pprModuleMap, + isIndefinite, + isDllName + ) +where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.PackageDb +import UnitInfo +import GHC.Driver.Session +import Name ( Name, nameModule_maybe ) +import UniqFM +import UniqDFM +import UniqSet +import Module +import Util +import Panic +import GHC.Platform +import Outputable +import Maybes + +import System.Environment ( getEnv ) +import FastString +import ErrUtils ( debugTraceMsg, MsgDoc, dumpIfSet_dyn, + withTiming, DumpFormat (..) ) +import Exception + +import System.Directory +import System.FilePath as FilePath +import qualified System.FilePath.Posix as FilePath.Posix +import Control.Monad +import Data.Graph (stronglyConnComp, SCC(..)) +import Data.Char ( toUpper ) +import Data.List as List +import Data.Map (Map) +import Data.Set (Set) +import Data.Monoid (First(..)) +import qualified Data.Semigroup as Semigroup +import qualified Data.Map as Map +import qualified Data.Map.Strict as MapStrict +import qualified Data.Set as Set +import Data.Version + +-- --------------------------------------------------------------------------- +-- The Package state + +-- | Package state is all stored in 'DynFlags', including the details of +-- all packages, which packages are exposed, and which modules they +-- provide. +-- +-- The package state is computed by 'initPackages', and kept in DynFlags. +-- It is influenced by various package flags: +-- +-- * @-package <pkg>@ and @-package-id <pkg>@ cause @<pkg>@ to become exposed. +-- If @-hide-all-packages@ was not specified, these commands also cause +-- all other packages with the same name to become hidden. +-- +-- * @-hide-package <pkg>@ causes @<pkg>@ to become hidden. +-- +-- * (there are a few more flags, check below for their semantics) +-- +-- The package state has the following properties. +-- +-- * Let @exposedPackages@ be the set of packages thus exposed. +-- Let @depExposedPackages@ be the transitive closure from @exposedPackages@ of +-- their dependencies. +-- +-- * 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 +-- from @depExposedPackages@ are valid. +-- +-- * When linking in a compilation manager mode, we link in packages the +-- program depends on (the compiler knows this list by the +-- time it gets to the link step). Also, we link in all packages +-- which were mentioned with preload @-package@ flags on the command-line, +-- or are a transitive dependency of same, or are \"base\"\/\"rts\". +-- The reason for this is that we might need packages which don't +-- contain any Haskell modules, and therefore won't be discovered +-- by the normal mechanism of dependency tracking. + +-- Notes on DLLs +-- ~~~~~~~~~~~~~ +-- When compiling module A, which imports module B, we need to +-- know whether B will be in the same DLL as A. +-- If it's in the same DLL, we refer to B_f_closure +-- If it isn't, we refer to _imp__B_f_closure +-- When compiling A, we record in B's Module value whether it's +-- in a different DLL, by setting the DLL flag. + +-- | Given a module name, there may be multiple ways it came into scope, +-- possibly simultaneously. This data type tracks all the possible ways +-- it could have come into scope. Warning: don't use the record functions, +-- they're partial! +data ModuleOrigin = + -- | Module is hidden, and thus never will be available for import. + -- (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 + -- someone's @exported-modules@ list, but that package is hidden; + -- @Just True@ means that it is available; @Nothing@ means neither + -- applies. + fromOrigPackage :: Maybe Bool + -- | Is the module available from a reexport of an exposed package? + -- There could be multiple. + , fromExposedReexport :: [UnitInfo] + -- | Is the module available from a reexport of a hidden package? + , fromHiddenReexport :: [UnitInfo] + -- | Did the module export come from a package flag? (ToDo: track + -- more information. + , fromPackageFlag :: Bool + } + +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 -> [] + Just False -> [text "hidden package"] + Just True -> [text "exposed package"]) ++ + (if null res + then [] + else [text "reexport by" <+> + sep (map (ppr . packageConfigId) res)]) ++ + (if null rhs + then [] + else [text "hidden reexport by" <+> + sep (map (ppr . packageConfigId) res)]) ++ + (if f then [text "package flag"] else []) + )) + +-- | Smart constructor for a module which is in @exposed-modules@. Takes +-- as an argument whether or not the defining package is exposed. +fromExposedModules :: Bool -> ModuleOrigin +fromExposedModules e = ModOrigin (Just e) [] [] False + +-- | Smart constructor for a module which is in @reexported-modules@. Takes +-- as an argument whether or not the reexporting package is exposed, and +-- also its 'UnitInfo'. +fromReexportedModules :: Bool -> UnitInfo -> ModuleOrigin +fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False +fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False + +-- | Smart constructor for a module which was bound by a package flag. +fromFlag :: ModuleOrigin +fromFlag = ModOrigin Nothing [] [] True + +instance Semigroup ModuleOrigin where + 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 + _x <> _y = panic "ModOrigin: hidden module redefined" + +instance Monoid ModuleOrigin where + mempty = ModOrigin Nothing [] [] False + 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 +-- except when we're filtering based on package imports. +originEmpty :: ModuleOrigin -> Bool +originEmpty (ModOrigin Nothing [] [] False) = True +originEmpty _ = False + +-- | 'UniqFM' map from 'InstalledUnitId' +type InstalledUnitIdMap = UniqDFM + +-- | 'UniqFM' map from 'UnitId' to 'UnitInfo', plus +-- the transitive closure of preload packages. +data UnitInfoMap = UnitInfoMap { + unUnitInfoMap :: InstalledUnitIdMap UnitInfo, + -- | The set of transitively reachable packages according + -- to the explicitly provided command line arguments. + -- See Note [UnitId to InstalledUnitId improvement] + preloadClosure :: UniqSet InstalledUnitId + } + +-- | 'UniqFM' map from 'UnitId' to a 'UnitVisibility'. +type VisibilityMap = Map UnitId UnitVisibility + +-- | 'UnitVisibility' records the various aspects of visibility of a particular +-- 'UnitId'. +data UnitVisibility = UnitVisibility + { uv_expose_all :: Bool + -- ^ Should all modules in exposed-modules should be dumped into scope? + , uv_renamings :: [(ModuleName, ModuleName)] + -- ^ Any custom renamings that should bring extra 'ModuleName's into + -- scope. + , uv_package_name :: First FastString + -- ^ The package name is associated with the 'UnitId'. This is used + -- to implement legacy behavior where @-package foo-0.1@ implicitly + -- hides any packages named @foo@ + , uv_requirements :: Map ModuleName (Set IndefModule) + -- ^ The signatures which are contributed to the requirements context + -- from this unit ID. + , uv_explicit :: Bool + -- ^ Whether or not this unit was explicitly brought into scope, + -- as opposed to implicitly via the 'exposed' fields in the + -- package database (when @-hide-all-packages@ is not passed.) + } + +instance Outputable UnitVisibility where + ppr (UnitVisibility { + uv_expose_all = b, + uv_renamings = rns, + uv_package_name = First mb_pn, + 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 + , uv_renamings = [] + , uv_package_name = First Nothing + , uv_requirements = Map.empty + , uv_explicit = False + } + mappend = (Semigroup.<>) + +type WiredUnitId = DefUnitId +type PreloadUnitId = InstalledUnitId + +-- | Map from 'ModuleName' to a set of of module providers (i.e. a 'Module' and +-- its 'ModuleOrigin'). +-- +-- NB: the set is in fact a 'Map Module ModuleOrigin', probably to keep only one +-- origin for a given 'Module' +type ModuleNameProvidersMap = + Map ModuleName (Map Module ModuleOrigin) + +data PackageState = PackageState { + -- | A mapping of 'UnitId' to 'UnitInfo'. This list is adjusted + -- so that only valid packages are here. 'UnitInfo' reflects + -- what was stored *on disk*, except for the 'trusted' flag, which + -- is adjusted at runtime. (In particular, some packages in this map + -- may have the 'exposed' flag be 'False'.) + unitInfoMap :: UnitInfoMap, + + -- | A mapping of 'PackageName' to 'ComponentId'. This is used when + -- users refer to packages in Backpack includes. + packageNameMap :: Map PackageName ComponentId, + + -- | A mapping from wired in names to the original names from the + -- package database. + unwireMap :: Map WiredUnitId WiredUnitId, + + -- | The packages we're going to link in eagerly. This list + -- should be in reverse dependency order; that is, a package + -- is always mentioned before the packages it depends on. + preloadPackages :: [PreloadUnitId], + + -- | Packages which we explicitly depend on (from a command line flag). + -- We'll use this to generate version macros. + explicitPackages :: [UnitId], + + -- | This is a full map from 'ModuleName' to all modules which may possibly + -- be providing it. These providers may be hidden (but we'll still want + -- to report them in error messages), or it may be an ambiguous import. + moduleNameProvidersMap :: !ModuleNameProvidersMap, + + -- | A map, like 'moduleNameProvidersMap', but controlling plugin visibility. + pluginModuleNameProvidersMap :: !ModuleNameProvidersMap, + + -- | A map saying, for each requirement, what interfaces must be merged + -- together when we use them. For example, if our dependencies + -- are @p[A=<A>]@ and @q[A=<A>,B=r[C=<A>]:B]@, then the interfaces + -- to merge for A are @p[A=<A>]:A@, @q[A=<A>,B=r[C=<A>]:B]:A@ + -- and @r[C=<A>]:C@. + -- + -- There's an entry in this map for each hole in our home library. + requirementContext :: Map ModuleName [IndefModule] + } + +emptyPackageState :: PackageState +emptyPackageState = PackageState { + unitInfoMap = emptyUnitInfoMap, + packageNameMap = Map.empty, + unwireMap = Map.empty, + preloadPackages = [], + explicitPackages = [], + moduleNameProvidersMap = Map.empty, + pluginModuleNameProvidersMap = Map.empty, + requirementContext = Map.empty + } + +-- | Package database +data PackageDatabase = PackageDatabase + { packageDatabasePath :: FilePath + , packageDatabaseUnits :: [UnitInfo] + } + +type InstalledPackageIndex = Map InstalledUnitId UnitInfo + +-- | Empty package configuration map +emptyUnitInfoMap :: UnitInfoMap +emptyUnitInfoMap = UnitInfoMap emptyUDFM emptyUniqSet + +-- | Find the unit we know about with the given unit id, if any +lookupUnit :: DynFlags -> UnitId -> Maybe UnitInfo +lookupUnit dflags = lookupUnit' (isIndefinite dflags) (unitInfoMap (pkgState dflags)) + +-- | A more specialized interface, which takes a boolean specifying +-- whether or not to look for on-the-fly renamed interfaces, and +-- just a 'UnitInfoMap' rather than a 'DynFlags' (so it can +-- be used while we're initializing 'DynFlags' +lookupUnit' :: Bool -> UnitInfoMap -> UnitId -> Maybe UnitInfo +lookupUnit' False (UnitInfoMap pkg_map _) uid = lookupUDFM pkg_map uid +lookupUnit' True m@(UnitInfoMap pkg_map _) uid = + case splitUnitIdInsts uid of + (iuid, Just indef) -> + fmap (renamePackage m (indefUnitIdInsts indef)) + (lookupUDFM pkg_map iuid) + (_, Nothing) -> lookupUDFM pkg_map uid + +{- +-- | Find the indefinite package for a given 'ComponentId'. +-- The way this works is just by fiat'ing that every indefinite package's +-- unit key is precisely its component ID; and that they share uniques. +lookupComponentId :: DynFlags -> ComponentId -> Maybe UnitInfo +lookupComponentId dflags (ComponentId cid_fs) = lookupUDFM pkg_map cid_fs + where + UnitInfoMap pkg_map = unitInfoMap (pkgState dflags) +-} + +-- | Find the package we know about with the given package name (e.g. @foo@), if any +-- (NB: there might be a locally defined unit name which overrides this) +lookupPackageName :: DynFlags -> PackageName -> Maybe ComponentId +lookupPackageName dflags n = Map.lookup n (packageNameMap (pkgState dflags)) + +-- | Search for packages with a given package ID (e.g. \"foo-0.1\") +searchPackageId :: DynFlags -> SourcePackageId -> [UnitInfo] +searchPackageId dflags pid = filter ((pid ==) . sourcePackageId) + (listUnitInfoMap dflags) + +-- | Extends the package configuration map with a list of package configs. +extendUnitInfoMap + :: UnitInfoMap -> [UnitInfo] -> UnitInfoMap +extendUnitInfoMap (UnitInfoMap pkg_map closure) new_pkgs + = UnitInfoMap (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 (expandedUnitInfoId p) p) + (installedUnitInfoId p) p + +-- | Looks up the package with the given id in the package state, panicing if it is +-- not found +getPackageDetails :: HasDebugCallStack => DynFlags -> UnitId -> UnitInfo +getPackageDetails dflags pid = + case lookupUnit dflags pid of + Just config -> config + Nothing -> pprPanic "getPackageDetails" (ppr pid) + +lookupInstalledPackage :: DynFlags -> InstalledUnitId -> Maybe UnitInfo +lookupInstalledPackage dflags uid = lookupInstalledPackage' (unitInfoMap (pkgState dflags)) uid + +lookupInstalledPackage' :: UnitInfoMap -> InstalledUnitId -> Maybe UnitInfo +lookupInstalledPackage' (UnitInfoMap db _) uid = lookupUDFM db uid + +getInstalledPackageDetails :: HasDebugCallStack => DynFlags -> InstalledUnitId -> UnitInfo +getInstalledPackageDetails dflags uid = + case lookupInstalledPackage dflags uid of + Just config -> config + Nothing -> pprPanic "getInstalledPackageDetails" (ppr uid) + +-- | Get a list of entries from the package database. NB: be careful with +-- this function, although all packages in this map are "visible", this +-- does not imply that the exposed-modules of the package are available +-- (they may have been thinned or renamed). +listUnitInfoMap :: DynFlags -> [UnitInfo] +listUnitInfoMap dflags = eltsUDFM pkg_map + where + UnitInfoMap pkg_map _ = unitInfoMap (pkgState dflags) + +-- ---------------------------------------------------------------------------- +-- Loading the package db files and building up the package state + +-- | Read the package database files, and sets up various internal tables of +-- package information, according to the package-related flags on the +-- command-line (@-package@, @-hide-package@ etc.) +-- +-- Returns a list of packages to link in if we're doing dynamic linking. +-- This list contains the packages that the user explicitly mentioned with +-- @-package@ flags. +-- +-- 'initPackages' can be called again subsequently after updating the +-- 'packageFlags' field of the 'DynFlags', and it will update the +-- 'pkgState' in 'DynFlags' and return a list of packages to +-- link in. +initPackages :: DynFlags -> IO (DynFlags, [PreloadUnitId]) +initPackages dflags = withTiming dflags + (text "initializing package database") + forcePkgDb $ do + read_pkg_dbs <- + case pkgDatabase dflags of + Nothing -> readPackageDatabases dflags + Just dbs -> return dbs + + let + distrust_all db = db { packageDatabaseUnits = distrustAllUnits (packageDatabaseUnits db) } + + pkg_dbs + | gopt Opt_DistrustAllPackages dflags = map distrust_all read_pkg_dbs + | otherwise = read_pkg_dbs + + (pkg_state, preload, insts) + <- mkPackageState dflags pkg_dbs [] + return (dflags{ pkgDatabase = Just read_pkg_dbs, + pkgState = pkg_state, + thisUnitIdInsts_ = insts }, + preload) + where + forcePkgDb (dflags, _) = unitInfoMap (pkgState dflags) `seq` () + +-- ----------------------------------------------------------------------------- +-- Reading the package database(s) + +readPackageDatabases :: DynFlags -> IO [PackageDatabase] +readPackageDatabases dflags = do + conf_refs <- getPackageConfRefs dflags + confs <- liftM catMaybes $ mapM (resolvePackageDatabase dflags) conf_refs + mapM (readPackageDatabase dflags) confs + + +getPackageConfRefs :: DynFlags -> IO [PkgDbRef] +getPackageConfRefs dflags = do + let system_conf_refs = [UserPkgDb, GlobalPkgDb] + + e_pkg_path <- tryIO (getEnv $ map toUpper (programName dflags) ++ "_PACKAGE_PATH") + let base_conf_refs = case e_pkg_path of + Left _ -> system_conf_refs + Right path + | not (null path) && isSearchPathSeparator (last path) + -> map PkgDbPath (splitSearchPath (init path)) ++ system_conf_refs + | otherwise + -> map PkgDbPath (splitSearchPath path) + + -- Apply the package DB-related flags from the command line to get the + -- final list of package DBs. + -- + -- Notes on ordering: + -- * The list of flags is reversed (later ones first) + -- * We work with the package DB list in "left shadows right" order + -- * and finally reverse it at the end, to get "right shadows left" + -- + return $ reverse (foldr doFlag base_conf_refs (packageDBFlags dflags)) + where + doFlag (PackageDB p) dbs = p : dbs + doFlag NoUserPackageDB dbs = filter isNotUser dbs + doFlag NoGlobalPackageDB dbs = filter isNotGlobal dbs + doFlag ClearPackageDBs _ = [] + + isNotUser UserPkgDb = False + isNotUser _ = True + + isNotGlobal GlobalPkgDb = False + isNotGlobal _ = True + +-- | Return the path of a package database from a 'PkgDbRef'. Return 'Nothing' +-- when the user database filepath is expected but the latter doesn't exist. +-- +-- NB: This logic is reimplemented in Cabal, so if you change it, +-- make sure you update Cabal. (Or, better yet, dump it in the +-- compiler info so Cabal can use the info.) +resolvePackageDatabase :: DynFlags -> PkgDbRef -> IO (Maybe FilePath) +resolvePackageDatabase dflags GlobalPkgDb = return $ Just (globalPackageDatabasePath dflags) +resolvePackageDatabase dflags UserPkgDb = runMaybeT $ do + dir <- versionedAppDir dflags + let pkgconf = dir </> "package.conf.d" + exist <- tryMaybeT $ doesDirectoryExist pkgconf + if exist then return pkgconf else mzero +resolvePackageDatabase _ (PkgDbPath name) = return $ Just name + +readPackageDatabase :: DynFlags -> FilePath -> IO PackageDatabase +readPackageDatabase dflags conf_file = do + isdir <- doesDirectoryExist conf_file + + proto_pkg_configs <- + if isdir + then readDirStyleUnitInfo conf_file + else do + isfile <- doesFileExist conf_file + if isfile + then do + mpkgs <- tryReadOldFileStyleUnitInfo + case mpkgs of + Just pkgs -> return pkgs + Nothing -> throwGhcExceptionIO $ InstallationError $ + "ghc no longer supports single-file style package " ++ + "databases (" ++ conf_file ++ + ") use 'ghc-pkg init' to create the database with " ++ + "the correct format." + else throwGhcExceptionIO $ InstallationError $ + "can't find a package database at " ++ conf_file + + let + -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot + conf_file' = dropTrailingPathSeparator conf_file + top_dir = topDir dflags + pkgroot = takeDirectory conf_file' + pkg_configs1 = map (mungeUnitInfo top_dir pkgroot) + proto_pkg_configs + -- + return $ PackageDatabase conf_file' pkg_configs1 + where + readDirStyleUnitInfo conf_dir = do + let filename = conf_dir </> "package.cache" + cache_exists <- doesFileExist filename + if cache_exists + then do + debugTraceMsg dflags 2 $ text "Using binary package database:" + <+> text filename + readPackageDbForGhc filename + else do + -- If there is no package.cache file, we check if the database is not + -- empty by inspecting if the directory contains any .conf file. If it + -- does, something is wrong and we fail. Otherwise we assume that the + -- database is empty. + debugTraceMsg dflags 2 $ text "There is no package.cache in" + <+> text conf_dir + <> text ", checking if the database is empty" + db_empty <- all (not . isSuffixOf ".conf") + <$> getDirectoryContents conf_dir + if db_empty + then do + debugTraceMsg dflags 3 $ text "There are no .conf files in" + <+> text conf_dir <> text ", treating" + <+> text "package database as empty" + return [] + else do + throwGhcExceptionIO $ InstallationError $ + "there is no package.cache in " ++ conf_dir ++ + " even though package database is not empty" + + + -- Single-file style package dbs have been deprecated for some time, but + -- it turns out that Cabal was using them in one place. So this is a + -- workaround to allow older Cabal versions to use this newer ghc. + -- We check if the file db contains just "[]" and if so, we look for a new + -- dir-style db in conf_file.d/, ie in a dir next to the given file. + -- We cannot just replace the file with a new dir style since Cabal still + -- assumes it's a file and tries to overwrite with 'writeFile'. + -- ghc-pkg also cooperates with this workaround. + tryReadOldFileStyleUnitInfo = do + content <- readFile conf_file `catchIO` \_ -> return "" + if take 2 content == "[]" + then do + let conf_dir = conf_file <.> "d" + direxists <- doesDirectoryExist conf_dir + if direxists + then do debugTraceMsg dflags 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir) + liftM Just (readDirStyleUnitInfo conf_dir) + else return (Just []) -- ghc-pkg will create it when it's updated + else return Nothing + +distrustAllUnits :: [UnitInfo] -> [UnitInfo] +distrustAllUnits pkgs = map distrust pkgs + where + distrust pkg = pkg{ trusted = False } + +mungeUnitInfo :: FilePath -> FilePath + -> UnitInfo -> UnitInfo +mungeUnitInfo top_dir pkgroot = + mungeDynLibFields + . mungePackagePaths top_dir pkgroot + +mungeDynLibFields :: UnitInfo -> UnitInfo +mungeDynLibFields pkg = + pkg { + libraryDynDirs = libraryDynDirs pkg + `orIfNull` libraryDirs pkg + } + where + orIfNull [] flags = flags + orIfNull flags _ = flags + +-- TODO: This code is duplicated in utils/ghc-pkg/Main.hs +mungePackagePaths :: FilePath -> FilePath -> UnitInfo -> UnitInfo +-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec +-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) +-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}. +-- The "pkgroot" is the directory containing the package database. +-- +-- Also perform a similar substitution for the older GHC-specific +-- "$topdir" variable. The "topdir" is the location of the ghc +-- installation (obtained from the -B option). +mungePackagePaths top_dir pkgroot pkg = + pkg { + importDirs = munge_paths (importDirs pkg), + includeDirs = munge_paths (includeDirs pkg), + libraryDirs = munge_paths (libraryDirs pkg), + libraryDynDirs = munge_paths (libraryDynDirs pkg), + frameworkDirs = munge_paths (frameworkDirs pkg), + haddockInterfaces = munge_paths (haddockInterfaces pkg), + haddockHTMLs = munge_urls (haddockHTMLs pkg) + } + where + munge_paths = map munge_path + munge_urls = map munge_url + + munge_path p + | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p' + | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p' + | otherwise = p + + munge_url p + | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p' + | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p' + | otherwise = p + + toUrlPath r p = "file:///" + -- URLs always use posix style '/' separators: + ++ FilePath.Posix.joinPath + (r : -- We need to drop a leading "/" or "\\" + -- if there is one: + dropWhile (all isPathSeparator) + (FilePath.splitDirectories p)) + + -- We could drop the separator here, and then use </> above. However, + -- by leaving it in and using ++ we keep the same path separator + -- rather than letting FilePath change it to use \ as the separator + stripVarPrefix var path = case stripPrefix var path of + Just [] -> Just [] + Just cs@(c : _) | isPathSeparator c -> Just cs + _ -> Nothing + + +-- ----------------------------------------------------------------------------- +-- Modify our copy of the package database based on trust flags, +-- -trust and -distrust. + +applyTrustFlag + :: DynFlags + -> PackagePrecedenceIndex + -> UnusablePackages + -> [UnitInfo] + -> TrustFlag + -> IO [UnitInfo] +applyTrustFlag dflags prec_map unusable pkgs flag = + case flag of + -- we trust all matching packages. Maybe should only trust first one? + -- and leave others the same or set them untrusted + TrustPackage str -> + case selectPackages prec_map (PackageArg str) pkgs unusable of + Left ps -> trustFlagErr dflags flag ps + Right (ps,qs) -> return (map trust ps ++ qs) + where trust p = p {trusted=True} + + DistrustPackage str -> + case selectPackages prec_map (PackageArg str) pkgs unusable of + Left ps -> trustFlagErr dflags flag ps + Right (ps,qs) -> return (distrustAllUnits ps ++ qs) + +-- | A little utility to tell if the 'thisPackage' is indefinite +-- (if it is not, we should never use on-the-fly renaming.) +isIndefinite :: DynFlags -> Bool +isIndefinite dflags = not (unitIdIsDefinite (thisPackage dflags)) + +applyPackageFlag + :: DynFlags + -> PackagePrecedenceIndex + -> UnitInfoMap + -> UnusablePackages + -> Bool -- if False, if you expose a package, it implicitly hides + -- any previously exposed packages with the same name + -> [UnitInfo] + -> VisibilityMap -- Initially exposed + -> PackageFlag -- flag to apply + -> IO VisibilityMap -- Now exposed + +applyPackageFlag dflags prec_map pkg_db unusable no_hide_others pkgs vm flag = + case flag of + ExposePackage _ arg (ModRenaming b rns) -> + case findPackages prec_map pkg_db arg pkgs unusable of + Left ps -> packageFlagErr dflags flag ps + Right (p:_) -> return vm' + where + n = fsPackageName p + + -- If a user says @-unit-id p[A=<A>]@, this imposes + -- a requirement on us: whatever our signature A is, + -- it must fulfill all of p[A=<A>]:A's requirements. + -- This method is responsible for computing what our + -- inherited requirements are. + reqs | UnitIdArg orig_uid <- arg = collectHoles orig_uid + | otherwise = Map.empty + + collectHoles uid = case splitUnitIdInsts uid of + (_, Just indef) -> + let local = [ Map.singleton + (moduleName mod) + (Set.singleton $ IndefModule indef mod_name) + | (mod_name, mod) <- indefUnitIdInsts indef + , isHoleModule mod ] + recurse = [ collectHoles (moduleUnitId mod) + | (_, mod) <- indefUnitIdInsts indef ] + in Map.unionsWith Set.union $ local ++ recurse + -- Other types of unit identities don't have holes + (_, Nothing) -> Map.empty + + + uv = UnitVisibility + { uv_expose_all = b + , uv_renamings = rns + , uv_package_name = First (Just n) + , uv_requirements = reqs + , uv_explicit = True + } + vm' = Map.insertWith mappend (packageConfigId p) uv vm_cleared + -- In the old days, if you said `ghc -package p-0.1 -package p-0.2` + -- (or if p-0.1 was registered in the pkgdb as exposed: True), + -- the second package flag would override the first one and you + -- would only see p-0.2 in exposed modules. This is good for + -- usability. + -- + -- However, with thinning and renaming (or Backpack), there might be + -- situations where you legitimately want to see two versions of a + -- package at the same time, and this behavior would make it + -- impossible to do so. So we decided that if you pass + -- -hide-all-packages, this should turn OFF the overriding behavior + -- where an exposed package hides all other packages with the same + -- name. This should not affect Cabal at all, which only ever + -- exposes one package at a time. + -- + -- NB: Why a variable no_hide_others? We have to apply this logic to + -- -plugin-package too, and it's more consistent if the switch in + -- behavior is based off of + -- -hide-all-packages/-hide-all-plugin-packages depending on what + -- flag is in question. + vm_cleared | no_hide_others = vm + -- NB: renamings never clear + | (_:_) <- rns = vm + | otherwise = Map.filterWithKey + (\k uv -> k == packageConfigId p + || First (Just n) /= uv_package_name uv) vm + _ -> panic "applyPackageFlag" + + HidePackage str -> + case findPackages prec_map pkg_db (PackageArg str) pkgs unusable of + Left ps -> packageFlagErr dflags flag ps + Right ps -> return vm' + where vm' = foldl' (flip Map.delete) vm (map packageConfigId ps) + +-- | Like 'selectPackages', but doesn't return a list of unmatched +-- packages. Furthermore, any packages it returns are *renamed* +-- if the 'UnitArg' has a renaming associated with it. +findPackages :: PackagePrecedenceIndex + -> UnitInfoMap -> PackageArg -> [UnitInfo] + -> UnusablePackages + -> Either [(UnitInfo, UnusablePackageReason)] + [UnitInfo] +findPackages prec_map pkg_db arg pkgs unusable + = let ps = mapMaybe (finder arg) pkgs + in if null ps + then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y)) + (Map.elems unusable)) + else Right (sortByPreference prec_map ps) + where + finder (PackageArg str) p + = if str == sourcePackageIdString p || str == packageNameString p + then Just p + else Nothing + finder (UnitIdArg uid) p + = let (iuid, mb_indef) = splitUnitIdInsts uid + in if iuid == installedUnitInfoId p + then Just (case mb_indef of + Nothing -> p + Just indef -> renamePackage pkg_db (indefUnitIdInsts indef) p) + else Nothing + +selectPackages :: PackagePrecedenceIndex -> PackageArg -> [UnitInfo] + -> UnusablePackages + -> Either [(UnitInfo, UnusablePackageReason)] + ([UnitInfo], [UnitInfo]) +selectPackages prec_map arg pkgs unusable + = let matches = matching arg + (ps,rest) = partition matches pkgs + in if null ps + then Left (filter (matches.fst) (Map.elems unusable)) + else Right (sortByPreference prec_map ps, rest) + +-- | Rename a 'UnitInfo' according to some module instantiation. +renamePackage :: UnitInfoMap -> [(ModuleName, Module)] + -> UnitInfo -> UnitInfo +renamePackage pkg_map insts conf = + let hsubst = listToUFM insts + smod = renameHoleModule' pkg_map hsubst + new_insts = map (\(k,v) -> (k,smod v)) (instantiatedWith conf) + in conf { + instantiatedWith = new_insts, + exposedModules = map (\(mod_name, mb_mod) -> (mod_name, fmap smod mb_mod)) + (exposedModules conf) + } + + +-- A package named on the command line can either include the +-- version, or just the name if it is unambiguous. +matchingStr :: String -> UnitInfo -> Bool +matchingStr str p + = str == sourcePackageIdString p + || str == packageNameString p + +matchingId :: InstalledUnitId -> UnitInfo -> Bool +matchingId uid p = uid == installedUnitInfoId p + +matching :: PackageArg -> UnitInfo -> Bool +matching (PackageArg str) = matchingStr str +matching (UnitIdArg (DefiniteUnitId (DefUnitId uid))) = matchingId uid +matching (UnitIdArg _) = \_ -> False -- TODO: warn in this case + +-- | This sorts a list of packages, putting "preferred" packages first. +-- See 'compareByPreference' for the semantics of "preference". +sortByPreference :: PackagePrecedenceIndex -> [UnitInfo] -> [UnitInfo] +sortByPreference prec_map = sortBy (flip (compareByPreference prec_map)) + +-- | Returns 'GT' if @pkg@ should be preferred over @pkg'@ when picking +-- which should be "active". Here is the order of preference: +-- +-- 1. First, prefer the latest version +-- 2. If the versions are the same, prefer the package that +-- came in the latest package database. +-- +-- Pursuant to #12518, we could change this policy to, for example, remove +-- the version preference, meaning that we would always prefer the packages +-- in later package database. +-- +-- Instead, we use that preference based policy only when one of the packages +-- is integer-gmp and the other is integer-simple. +-- This currently only happens when we're looking up which concrete +-- package to use in place of @integer-wired-in@ and that two different +-- package databases supply a different integer library. For more about +-- the fake @integer-wired-in@ package, see Note [The integer library] +-- in the @PrelNames@ module. +compareByPreference + :: PackagePrecedenceIndex + -> UnitInfo + -> UnitInfo + -> Ordering +compareByPreference prec_map pkg pkg' + | Just prec <- Map.lookup (unitId pkg) prec_map + , Just prec' <- Map.lookup (unitId pkg') prec_map + , differentIntegerPkgs pkg pkg' + = compare prec prec' + + | otherwise + = case comparing packageVersion pkg pkg' of + GT -> GT + EQ | Just prec <- Map.lookup (unitId pkg) prec_map + , Just prec' <- Map.lookup (unitId pkg') prec_map + -- Prefer the package from the later DB flag (i.e., higher + -- precedence) + -> compare prec prec' + | otherwise + -> EQ + LT -> LT + + where isIntegerPkg p = packageNameString p `elem` + ["integer-simple", "integer-gmp"] + differentIntegerPkgs p p' = + isIntegerPkg p && isIntegerPkg p' && + (packageName p /= packageName p') + +comparing :: Ord a => (t -> a) -> t -> t -> Ordering +comparing f a b = f a `compare` f b + +packageFlagErr :: DynFlags + -> PackageFlag + -> [(UnitInfo, UnusablePackageReason)] + -> IO a +packageFlagErr dflags flag reasons + = packageFlagErr' dflags (pprFlag flag) reasons + +trustFlagErr :: DynFlags + -> TrustFlag + -> [(UnitInfo, UnusablePackageReason)] + -> IO a +trustFlagErr dflags flag reasons + = packageFlagErr' dflags (pprTrustFlag flag) reasons + +packageFlagErr' :: DynFlags + -> SDoc + -> [(UnitInfo, UnusablePackageReason)] + -> IO a +packageFlagErr' dflags flag_doc reasons + = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err)) + where err = text "cannot satisfy " <> flag_doc <> + (if null reasons then Outputable.empty else text ": ") $$ + nest 4 (ppr_reasons $$ + text "(use -v for more information)") + ppr_reasons = vcat (map ppr_reason reasons) + ppr_reason (p, reason) = + pprReason (ppr (unitId p) <+> text "is") reason + +pprFlag :: PackageFlag -> SDoc +pprFlag flag = case flag of + HidePackage p -> text "-hide-package " <> text p + ExposePackage doc _ _ -> text doc + +pprTrustFlag :: TrustFlag -> SDoc +pprTrustFlag flag = case flag of + TrustPackage p -> text "-trust " <> text p + DistrustPackage p -> text "-distrust " <> text p + +-- ----------------------------------------------------------------------------- +-- Wired-in packages +-- +-- See Note [Wired-in packages] in Module + +type WiredInUnitId = String +type WiredPackagesMap = Map WiredUnitId WiredUnitId + +wired_in_unitids :: [WiredInUnitId] +wired_in_unitids = map unitIdString wiredInUnitIds + +findWiredInPackages + :: DynFlags + -> PackagePrecedenceIndex + -> [UnitInfo] -- database + -> VisibilityMap -- info on what packages are visible + -- for wired in selection + -> IO ([UnitInfo], -- package database updated for wired in + WiredPackagesMap) -- map from unit id to wired identity + +findWiredInPackages dflags prec_map pkgs vis_map = do + -- Now we must find our wired-in packages, and rename them to + -- their canonical names (eg. base-1.0 ==> base), as described + -- in Note [Wired-in packages] in Module + let + matches :: UnitInfo -> WiredInUnitId -> Bool + pc `matches` pid + -- See Note [The integer library] in PrelNames + | pid == unitIdString integerUnitId + = packageNameString pc `elem` ["integer-gmp", "integer-simple"] + pc `matches` pid = packageNameString pc == pid + + -- find which package corresponds to each wired-in package + -- delete any other packages with the same name + -- update the package and any dependencies to point to the new + -- one. + -- + -- When choosing which package to map to a wired-in package + -- name, we try to pick the latest version of exposed packages. + -- However, if there are no exposed wired in packages available + -- (e.g. -hide-all-packages was used), we can't bail: we *have* + -- to assign a package for the wired-in package: so we try again + -- with hidden packages included to (and pick the latest + -- version). + -- + -- You can also override the default choice by using -ignore-package: + -- this works even when there is no exposed wired in package + -- available. + -- + findWiredInPackage :: [UnitInfo] -> WiredInUnitId + -> IO (Maybe (WiredInUnitId, UnitInfo)) + findWiredInPackage pkgs wired_pkg = + let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] + all_exposed_ps = + [ p | p <- all_ps + , Map.member (packageConfigId p) vis_map ] in + case all_exposed_ps of + [] -> case all_ps of + [] -> notfound + many -> pick (head (sortByPreference prec_map many)) + many -> pick (head (sortByPreference prec_map many)) + where + notfound = do + debugTraceMsg dflags 2 $ + text "wired-in package " + <> text wired_pkg + <> text " not found." + return Nothing + pick :: UnitInfo + -> IO (Maybe (WiredInUnitId, UnitInfo)) + pick pkg = do + debugTraceMsg dflags 2 $ + text "wired-in package " + <> text wired_pkg + <> text " mapped to " + <> ppr (unitId pkg) + return (Just (wired_pkg, pkg)) + + + mb_wired_in_pkgs <- mapM (findWiredInPackage pkgs) wired_in_unitids + let + wired_in_pkgs = catMaybes mb_wired_in_pkgs + + -- this is old: we used to assume that if there were + -- multiple versions of wired-in packages installed that + -- they were mutually exclusive. Now we're assuming that + -- you have one "main" version of each wired-in package + -- (the latest version), and the others are backward-compat + -- wrappers that depend on this one. e.g. base-4.0 is the + -- latest, base-3.0 is a compat wrapper depending on base-4.0. + {- + deleteOtherWiredInPackages pkgs = filterOut bad pkgs + where bad p = any (p `matches`) wired_in_unitids + && package p `notElem` map fst wired_in_ids + -} + + wiredInMap :: Map WiredUnitId WiredUnitId + wiredInMap = Map.fromList + [ (key, DefUnitId (stringToInstalledUnitId wiredInUnitId)) + | (wiredInUnitId, pkg) <- wired_in_pkgs + , Just key <- pure $ definiteUnitInfoId pkg + ] + + updateWiredInDependencies pkgs = map (upd_deps . upd_pkg) pkgs + where upd_pkg pkg + | Just def_uid <- definiteUnitInfoId pkg + , Just wiredInUnitId <- Map.lookup def_uid wiredInMap + = let fs = installedUnitIdFS (unDefUnitId wiredInUnitId) + in pkg { + unitId = fsToInstalledUnitId fs, + componentId = ComponentId fs + } + | otherwise + = pkg + upd_deps pkg = pkg { + -- temporary harmless DefUnitId invariant violation + depends = map (unDefUnitId . upd_wired_in wiredInMap . DefUnitId) (depends pkg), + exposedModules + = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v)) + (exposedModules pkg) + } + + + return (updateWiredInDependencies pkgs, wiredInMap) + +-- Helper functions for rewiring Module and UnitId. These +-- rewrite UnitIds of modules in wired-in packages to the form known to the +-- compiler, as described in Note [Wired-in packages] in Module. +-- +-- For instance, base-4.9.0.0 will be rewritten to just base, to match +-- what appears in PrelNames. + +upd_wired_in_mod :: WiredPackagesMap -> Module -> Module +upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m + +upd_wired_in_uid :: WiredPackagesMap -> UnitId -> UnitId +upd_wired_in_uid wiredInMap (DefiniteUnitId def_uid) = + DefiniteUnitId (upd_wired_in wiredInMap def_uid) +upd_wired_in_uid wiredInMap (IndefiniteUnitId indef_uid) = + IndefiniteUnitId $ newIndefUnitId + (indefUnitIdComponentId indef_uid) + (map (\(x,y) -> (x,upd_wired_in_mod wiredInMap y)) (indefUnitIdInsts indef_uid)) + +upd_wired_in :: WiredPackagesMap -> DefUnitId -> DefUnitId +upd_wired_in wiredInMap key + | Just key' <- Map.lookup key wiredInMap = key' + | otherwise = key + +updateVisibilityMap :: WiredPackagesMap -> VisibilityMap -> VisibilityMap +updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (Map.toList wiredInMap) + where f vm (from, to) = case Map.lookup (DefiniteUnitId from) vis_map of + Nothing -> vm + Just r -> Map.insert (DefiniteUnitId to) r + (Map.delete (DefiniteUnitId from) vm) + + +-- ---------------------------------------------------------------------------- + +-- | The reason why a package is unusable. +data UnusablePackageReason + = -- | We ignored it explicitly using @-ignore-package@. + IgnoredWithFlag + -- | This package transitively depends on a package that was never present + -- in any of the provided databases. + | BrokenDependencies [InstalledUnitId] + -- | This package transitively depends on a package involved in a cycle. + -- Note that the list of 'InstalledUnitId' reports the direct dependencies + -- of this package that (transitively) depended on the cycle, and not + -- the actual cycle itself (which we report separately at high verbosity.) + | CyclicDependencies [InstalledUnitId] + -- | This package transitively depends on a package which was ignored. + | IgnoredDependencies [InstalledUnitId] + -- | This package transitively depends on a package which was + -- shadowed by an ABI-incompatible package. + | ShadowedDependencies [InstalledUnitId] + +instance Outputable UnusablePackageReason where + ppr IgnoredWithFlag = text "[ignored with flag]" + ppr (BrokenDependencies uids) = brackets (text "broken" <+> ppr uids) + ppr (CyclicDependencies uids) = brackets (text "cyclic" <+> ppr uids) + ppr (IgnoredDependencies uids) = brackets (text "ignored" <+> ppr uids) + ppr (ShadowedDependencies uids) = brackets (text "shadowed" <+> ppr uids) + +type UnusablePackages = Map InstalledUnitId + (UnitInfo, UnusablePackageReason) + +pprReason :: SDoc -> UnusablePackageReason -> SDoc +pprReason pref reason = case reason of + IgnoredWithFlag -> + pref <+> text "ignored due to an -ignore-package flag" + BrokenDependencies deps -> + pref <+> text "unusable due to missing dependencies:" $$ + nest 2 (hsep (map ppr deps)) + CyclicDependencies deps -> + pref <+> text "unusable due to cyclic dependencies:" $$ + nest 2 (hsep (map ppr deps)) + IgnoredDependencies deps -> + 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:" $$ + nest 2 (hsep (map ppr deps)) + +reportCycles :: DynFlags -> [SCC UnitInfo] -> IO () +reportCycles dflags sccs = mapM_ report sccs + where + report (AcyclicSCC _) = return () + report (CyclicSCC vs) = + debugTraceMsg dflags 2 $ + text "these packages are involved in a cycle:" $$ + nest 2 (hsep (map (ppr . unitId) vs)) + +reportUnusable :: DynFlags -> UnusablePackages -> IO () +reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs) + where + report (ipid, (_, reason)) = + debugTraceMsg dflags 2 $ + pprReason + (text "package" <+> ppr ipid <+> text "is") reason + +-- ---------------------------------------------------------------------------- +-- +-- Utilities on the database +-- + +-- | A reverse dependency index, mapping an 'InstalledUnitId' to +-- the 'InstalledUnitId's which have a dependency on it. +type RevIndex = Map InstalledUnitId [InstalledUnitId] + +-- | Compute the reverse dependency index of a package database. +reverseDeps :: InstalledPackageIndex -> RevIndex +reverseDeps db = Map.foldl' go Map.empty db + where + go r pkg = foldl' (go' (unitId pkg)) r (depends pkg) + go' from r to = Map.insertWith (++) to [from] r + +-- | Given a list of 'InstalledUnitId's to remove, a database, +-- and a reverse dependency index (as computed by 'reverseDeps'), +-- remove those packages, plus any packages which depend on them. +-- Returns the pruned database, as well as a list of 'UnitInfo's +-- that was removed. +removePackages :: [InstalledUnitId] -> RevIndex + -> InstalledPackageIndex + -> (InstalledPackageIndex, [UnitInfo]) +removePackages uids index m = go uids (m,[]) + where + go [] (m,pkgs) = (m,pkgs) + go (uid:uids) (m,pkgs) + | Just pkg <- Map.lookup uid m + = case Map.lookup uid index of + Nothing -> go uids (Map.delete uid m, pkg:pkgs) + Just rdeps -> go (rdeps ++ uids) (Map.delete uid m, pkg:pkgs) + | otherwise + = go uids (m,pkgs) + +-- | Given a 'UnitInfo' from some 'InstalledPackageIndex', +-- return all entries in 'depends' which correspond to packages +-- that do not exist in the index. +depsNotAvailable :: InstalledPackageIndex + -> UnitInfo + -> [InstalledUnitId] +depsNotAvailable pkg_map pkg = filter (not . (`Map.member` pkg_map)) (depends pkg) + +-- | Given a 'UnitInfo' from some 'InstalledPackageIndex' +-- return all entries in 'abiDepends' which correspond to packages +-- that do not exist, OR have mismatching ABIs. +depsAbiMismatch :: InstalledPackageIndex + -> UnitInfo + -> [InstalledUnitId] +depsAbiMismatch pkg_map pkg = map fst . filter (not . abiMatch) $ abiDepends pkg + where + abiMatch (dep_uid, abi) + | Just dep_pkg <- Map.lookup dep_uid pkg_map + = abiHash dep_pkg == abi + | otherwise + = False + +-- ----------------------------------------------------------------------------- +-- Ignore packages + +ignorePackages :: [IgnorePackageFlag] -> [UnitInfo] -> UnusablePackages +ignorePackages flags pkgs = Map.fromList (concatMap doit flags) + where + doit (IgnorePackage str) = + case partition (matchingStr str) pkgs of + (ps, _) -> [ (unitId p, (p, IgnoredWithFlag)) + | p <- ps ] + -- missing package is not an error for -ignore-package, + -- because a common usage is to -ignore-package P as + -- a preventative measure just in case P exists. + +-- ---------------------------------------------------------------------------- +-- +-- Merging databases +-- + +-- | For each package, a mapping from uid -> i indicates that this +-- package was brought into GHC by the ith @-package-db@ flag on +-- the command line. We use this mapping to make sure we prefer +-- packages that were defined later on the command line, if there +-- is an ambiguity. +type PackagePrecedenceIndex = Map InstalledUnitId Int + +-- | Given a list of databases, merge them together, where +-- packages with the same unit id in later databases override +-- earlier ones. This does NOT check if the resulting database +-- makes sense (that's done by 'validateDatabase'). +mergeDatabases :: DynFlags -> [PackageDatabase] + -> IO (InstalledPackageIndex, PackagePrecedenceIndex) +mergeDatabases dflags = foldM merge (Map.empty, Map.empty) . zip [1..] + where + merge (pkg_map, prec_map) (i, PackageDatabase db_path db) = do + debugTraceMsg dflags 2 $ + text "loading package database" <+> text db_path + forM_ (Set.toList override_set) $ \pkg -> + debugTraceMsg dflags 2 $ + text "package" <+> ppr pkg <+> + text "overrides a previously defined package" + return (pkg_map', prec_map') + where + db_map = mk_pkg_map db + mk_pkg_map = Map.fromList . map (\p -> (unitId p, p)) + + -- The set of UnitIds which appear in both db and pkgs. These are the + -- ones that get overridden. Compute this just to give some + -- helpful debug messages at -v2 + override_set :: Set InstalledUnitId + override_set = Set.intersection (Map.keysSet db_map) + (Map.keysSet pkg_map) + + -- Now merge the sets together (NB: in case of duplicate, + -- first argument preferred) + pkg_map' :: InstalledPackageIndex + pkg_map' = Map.union db_map pkg_map + + prec_map' :: PackagePrecedenceIndex + prec_map' = Map.union (Map.map (const i) db_map) prec_map + +-- | Validates a database, removing unusable packages from it +-- (this includes removing packages that the user has explicitly +-- ignored.) Our general strategy: +-- +-- 1. Remove all broken packages (dangling dependencies) +-- 2. Remove all packages that are cyclic +-- 3. Apply ignore flags +-- 4. Remove all packages which have deps with mismatching ABIs +-- +validateDatabase :: DynFlags -> InstalledPackageIndex + -> (InstalledPackageIndex, UnusablePackages, [SCC UnitInfo]) +validateDatabase dflags pkg_map1 = + (pkg_map5, unusable, sccs) + where + ignore_flags = reverse (ignorePackageFlags dflags) + + -- Compute the reverse dependency index + index = reverseDeps pkg_map1 + + -- Helper function + mk_unusable mk_err dep_matcher m uids = + Map.fromList [ (unitId pkg, (pkg, mk_err (dep_matcher m pkg))) + | pkg <- uids ] + + -- Find broken packages + directly_broken = filter (not . null . depsNotAvailable pkg_map1) + (Map.elems pkg_map1) + (pkg_map2, broken) = removePackages (map unitId directly_broken) index pkg_map1 + unusable_broken = mk_unusable BrokenDependencies depsNotAvailable pkg_map2 broken + + -- Find recursive packages + sccs = stronglyConnComp [ (pkg, unitId pkg, depends pkg) + | pkg <- Map.elems pkg_map2 ] + getCyclicSCC (CyclicSCC vs) = map unitId vs + getCyclicSCC (AcyclicSCC _) = [] + (pkg_map3, cyclic) = removePackages (concatMap getCyclicSCC sccs) index pkg_map2 + unusable_cyclic = mk_unusable CyclicDependencies depsNotAvailable pkg_map3 cyclic + + -- Apply ignore flags + directly_ignored = ignorePackages ignore_flags (Map.elems pkg_map3) + (pkg_map4, ignored) = removePackages (Map.keys directly_ignored) index pkg_map3 + unusable_ignored = mk_unusable IgnoredDependencies depsNotAvailable pkg_map4 ignored + + -- Knock out packages whose dependencies don't agree with ABI + -- (i.e., got invalidated due to shadowing) + directly_shadowed = filter (not . null . depsAbiMismatch pkg_map4) + (Map.elems pkg_map4) + (pkg_map5, shadowed) = removePackages (map unitId directly_shadowed) index pkg_map4 + unusable_shadowed = mk_unusable ShadowedDependencies depsAbiMismatch pkg_map5 shadowed + + unusable = directly_ignored `Map.union` unusable_ignored + `Map.union` unusable_broken + `Map.union` unusable_cyclic + `Map.union` unusable_shadowed + +-- ----------------------------------------------------------------------------- +-- When all the command-line options are in, we can process our package +-- settings and populate the package state. + +mkPackageState + :: DynFlags + -- initial databases, in the order they were specified on + -- the command line (later databases shadow earlier ones) + -> [PackageDatabase] + -> [PreloadUnitId] -- preloaded packages + -> IO (PackageState, + [PreloadUnitId], -- new packages to preload + Maybe [(ModuleName, Module)]) + +mkPackageState dflags dbs preload0 = do +{- + Plan. + + There are two main steps for making the package state: + + 1. We want to build a single, unified package database based + on all of the input databases, which upholds the invariant that + there is only one package per any UnitId and there are no + dangling dependencies. We'll do this by merging, and + then successively filtering out bad dependencies. + + a) Merge all the databases together. + If an input database defines unit ID that is already in + the unified database, that package SHADOWS the existing + package in the current unified database. Note that + order is important: packages defined later in the list of + command line arguments shadow those defined earlier. + + b) Remove all packages with missing dependencies, or + mutually recursive dependencies. + + b) Remove packages selected by -ignore-package from input database + + c) Remove all packages which depended on packages that are now + shadowed by an ABI-incompatible package + + d) report (with -v) any packages that were removed by steps 1-3 + + 2. We want to look at the flags controlling package visibility, + and build a mapping of what module names are in scope and + where they live. + + a) on the final, unified database, we apply -trust/-distrust + flags directly, modifying the database so that the 'trusted' + field has the correct value. + + b) we use the -package/-hide-package flags to compute a + visibility map, stating what packages are "exposed" for + the purposes of computing the module map. + * if any flag refers to a package which was removed by 1-5, then + we can give an error message explaining why + * if -hide-all-packages was not specified, this step also + hides packages which are superseded by later exposed packages + * this step is done TWICE if -plugin-package/-hide-all-plugin-packages + are used + + c) based on the visibility map, we pick wired packages and rewrite + them to have the expected unitId. + + d) finally, using the visibility map and the package database, + we build a mapping saying what every in scope module name points to. +-} + + -- This, and the other reverse's that you will see, are due to the fact that + -- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order + -- than they are on the command line. + let other_flags = reverse (packageFlags dflags) + debugTraceMsg dflags 2 $ + text "package flags" <+> ppr other_flags + + -- Merge databases together, without checking validity + (pkg_map1, prec_map) <- mergeDatabases dflags dbs + + -- Now that we've merged everything together, prune out unusable + -- packages. + let (pkg_map2, unusable, sccs) = validateDatabase dflags pkg_map1 + + reportCycles dflags sccs + reportUnusable dflags unusable + + -- Apply trust flags (these flags apply regardless of whether + -- or not packages are visible or not) + pkgs1 <- foldM (applyTrustFlag dflags prec_map unusable) + (Map.elems pkg_map2) (reverse (trustFlags dflags)) + let prelim_pkg_db = extendUnitInfoMap emptyUnitInfoMap pkgs1 + + -- + -- Calculate the initial set of units from package databases, prior to any package flags. + -- + -- Conceptually, we select the latest versions of all valid (not unusable) *packages* + -- (not units). This is empty if we have -hide-all-packages. + -- + -- Then we create an initial visibility map with default visibilities for all + -- exposed, definite units which belong to the latest valid packages. + -- + let preferLater unit unit' = + case compareByPreference prec_map unit unit' of + GT -> unit + _ -> unit' + addIfMorePreferable m unit = addToUDFM_C preferLater m (fsPackageName unit) unit + -- This is the set of maximally preferable packages. In fact, it is a set of + -- most preferable *units* keyed by package name, which act as stand-ins in + -- for "a package in a database". We use units here because we don't have + -- "a package in a database" as a type currently. + mostPreferablePackageReps = if gopt Opt_HideAllPackages dflags + then emptyUDFM + else foldl' addIfMorePreferable emptyUDFM pkgs1 + -- When exposing units, we want to consider all of those in the most preferable + -- packages. We can implement that by looking for units that are equi-preferable + -- with the most preferable unit for package. Being equi-preferable means that + -- they must be in the same database, with the same version, and the same package name. + -- + -- We must take care to consider all these units and not just the most + -- preferable one, otherwise we can end up with problems like #16228. + mostPreferable u = + case lookupUDFM mostPreferablePackageReps (fsPackageName u) of + Nothing -> False + Just u' -> compareByPreference prec_map u u' == EQ + vis_map1 = foldl' (\vm p -> + -- Note: we NEVER expose indefinite packages by + -- default, because it's almost assuredly not + -- what you want (no mix-in linking has occurred). + if exposed p && unitIdIsDefinite (packageConfigId p) && mostPreferable p + then Map.insert (packageConfigId p) + UnitVisibility { + uv_expose_all = True, + uv_renamings = [], + uv_package_name = First (Just (fsPackageName p)), + uv_requirements = Map.empty, + uv_explicit = False + } + vm + else vm) + Map.empty pkgs1 + + -- + -- Compute a visibility map according to the command-line flags (-package, + -- -hide-package). This needs to know about the unusable packages, since if a + -- user tries to enable an unusable package, we should let them know. + -- + vis_map2 <- foldM (applyPackageFlag dflags prec_map prelim_pkg_db unusable + (gopt Opt_HideAllPackages dflags) pkgs1) + vis_map1 other_flags + + -- + -- Sort out which packages are wired in. This has to be done last, since + -- it modifies the unit ids of wired in packages, but when we process + -- package arguments we need to key against the old versions. + -- + (pkgs2, wired_map) <- findWiredInPackages dflags prec_map pkgs1 vis_map2 + let pkg_db = extendUnitInfoMap emptyUnitInfoMap pkgs2 + + -- Update the visibility map, so we treat wired packages as visible. + let vis_map = updateVisibilityMap wired_map vis_map2 + + let hide_plugin_pkgs = gopt Opt_HideAllPluginPackages dflags + plugin_vis_map <- + case pluginPackageFlags dflags of + -- common case; try to share the old vis_map + [] | not hide_plugin_pkgs -> return vis_map + | otherwise -> return Map.empty + _ -> do let plugin_vis_map1 + | hide_plugin_pkgs = Map.empty + -- Use the vis_map PRIOR to wired in, + -- because otherwise applyPackageFlag + -- won't work. + | otherwise = vis_map2 + plugin_vis_map2 + <- foldM (applyPackageFlag dflags prec_map prelim_pkg_db unusable + (gopt Opt_HideAllPluginPackages dflags) pkgs1) + plugin_vis_map1 + (reverse (pluginPackageFlags dflags)) + -- Updating based on wired in packages is mostly + -- good hygiene, because it won't matter: no wired in + -- package has a compiler plugin. + -- TODO: If a wired in package had a compiler plugin, + -- and you tried to pick different wired in packages + -- with the plugin flags and the normal flags... what + -- would happen? I don't know! But this doesn't seem + -- likely to actually happen. + return (updateVisibilityMap wired_map plugin_vis_map2) + + -- + -- Here we build up a set of the packages mentioned in -package + -- flags on the command line; these are called the "preload" + -- packages. we link these packages in eagerly. The preload set + -- should contain at least rts & base, which is why we pretend that + -- the command line contains -package rts & -package base. + -- + -- NB: preload IS important even for type-checking, because we + -- need the correct include path to be set. + -- + let preload1 = Map.keys (Map.filter uv_explicit vis_map) + + let pkgname_map = foldl' add Map.empty pkgs2 + where add pn_map p + = Map.insert (packageName p) (componentId p) pn_map + + -- The explicitPackages accurately reflects the set of packages we have turned + -- on; as such, it also is the only way one can come up with requirements. + -- The requirement context is directly based off of this: we simply + -- look for nested unit IDs that are directly fed holes: the requirements + -- of those units are precisely the ones we need to track + let explicit_pkgs = Map.keys vis_map + req_ctx = Map.map (Set.toList) + $ Map.unionsWith Set.union (map uv_requirements (Map.elems vis_map)) + + + let preload2 = preload1 + + let + -- add base & rts to the preload packages + basicLinkedPackages + | gopt Opt_AutoLinkPackages dflags + = filter (flip elemUDFM (unUnitInfoMap pkg_db)) + [baseUnitId, rtsUnitId] + | otherwise = [] + -- but in any case remove the current package from the set of + -- preloaded packages so that base/rts does not end up in the + -- set up preloaded package when we are just building it + -- (NB: since this is only relevant for base/rts it doesn't matter + -- that thisUnitIdInsts_ is not wired yet) + -- + preload3 = ordNub $ filter (/= thisPackage dflags) + $ (basicLinkedPackages ++ preload2) + + -- Close the preload packages with their dependencies + dep_preload <- closeDeps dflags pkg_db (zip (map toInstalledUnitId preload3) (repeat Nothing)) + let new_dep_preload = filter (`notElem` preload0) dep_preload + + let mod_map1 = mkModuleNameProvidersMap dflags pkg_db vis_map + mod_map2 = mkUnusableModuleNameProvidersMap unusable + mod_map = Map.union mod_map1 mod_map2 + + dumpIfSet_dyn (dflags { pprCols = 200 }) Opt_D_dump_mod_map "Mod Map" + FormatText + (pprModuleMap mod_map) + + -- Force pstate to avoid leaking the dflags0 passed to mkPackageState + let !pstate = PackageState{ + preloadPackages = dep_preload, + explicitPackages = explicit_pkgs, + unitInfoMap = pkg_db, + moduleNameProvidersMap = mod_map, + pluginModuleNameProvidersMap = mkModuleNameProvidersMap dflags pkg_db plugin_vis_map, + packageNameMap = pkgname_map, + unwireMap = Map.fromList [ (v,k) | (k,v) <- Map.toList wired_map ], + requirementContext = req_ctx + } + let new_insts = fmap (map (fmap (upd_wired_in_mod wired_map))) (thisUnitIdInsts_ dflags) + return (pstate, new_dep_preload, new_insts) + +-- | Given a wired-in 'UnitId', "unwire" it into the 'UnitId' +-- that it was recorded as in the package database. +unwireUnitId :: DynFlags -> UnitId -> UnitId +unwireUnitId dflags uid@(DefiniteUnitId def_uid) = + maybe uid DefiniteUnitId (Map.lookup def_uid (unwireMap (pkgState dflags))) +unwireUnitId _ uid = uid + +-- ----------------------------------------------------------------------------- +-- | Makes the mapping from module to package info + +-- Slight irritation: we proceed by leafing through everything +-- in the installed package database, which makes handling indefinite +-- packages a bit bothersome. + +mkModuleNameProvidersMap + :: DynFlags + -> UnitInfoMap + -> VisibilityMap + -> ModuleNameProvidersMap +mkModuleNameProvidersMap dflags pkg_db 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 + -- ModuleNameProvidersMap. 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 (unUnitInfoMap pkg_db) + -- Exclude specific instantiations of an indefinite + -- package + , indefinite pkg || null (instantiatedWith pkg) + ] + + emptyMap = Map.empty + setOrigins m os = fmap (const os) m + extend_modmap modmap uid + UnitVisibility { uv_expose_all = b, uv_renamings = rns } + = addListTo modmap theBindings + where + pkg = unit_lookup uid + + theBindings :: [(ModuleName, Map Module ModuleOrigin)] + theBindings = newBindings b rns + + newBindings :: Bool + -> [(ModuleName, ModuleName)] + -> [(ModuleName, Map Module ModuleOrigin)] + newBindings e rns = es e ++ hiddens ++ map rnBinding rns + + rnBinding :: (ModuleName, ModuleName) + -> (ModuleName, Map Module ModuleOrigin) + rnBinding (orig, new) = (new, setOrigins origEntry fromFlag) + where origEntry = case lookupUFM esmap orig of + Just r -> r + Nothing -> throwGhcException (CmdLineError (showSDoc dflags + (text "package flag: could not find module name" <+> + ppr orig <+> text "in package" <+> ppr pk))) + + es :: Bool -> [(ModuleName, Map Module ModuleOrigin)] + es e = do + (m, exposedReexport) <- exposed_mods + let (pk', m', origin') = + case exposedReexport of + Nothing -> (pk, m, fromExposedModules e) + Just (Module pk' m') -> + let pkg' = unit_lookup pk' + 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, mkModMap pk m ModHidden) | m <- hidden_mods] + + pk = packageConfigId pkg + unit_lookup uid = lookupUnit' (isIndefinite dflags) pkg_db uid + `orElse` pprPanic "unit_lookup" (ppr uid) + + exposed_mods = exposedModules pkg + hidden_mods = hiddenModules pkg + +-- | Make a 'ModuleNameProvidersMap' covering a set of unusable packages. +mkUnusableModuleNameProvidersMap :: UnusablePackages -> ModuleNameProvidersMap +mkUnusableModuleNameProvidersMap 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 #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 + +-- Many of these functions take a list of packages: in those cases, +-- the list is expected to contain the "dependent packages", +-- i.e. those packages that were found to be depended on by the +-- current module/program. These can be auto or non-auto packages, it +-- doesn't really matter. The list is always combined with the list +-- of preload (command-line) packages to determine which packages to +-- use. + +-- | Find all the include directories in these and the preload packages +getPackageIncludePath :: DynFlags -> [PreloadUnitId] -> IO [String] +getPackageIncludePath dflags pkgs = + collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs + +collectIncludeDirs :: [UnitInfo] -> [FilePath] +collectIncludeDirs ps = ordNub (filter notNull (concatMap includeDirs ps)) + +-- | Find all the library paths in these and the preload packages +getPackageLibraryPath :: DynFlags -> [PreloadUnitId] -> IO [String] +getPackageLibraryPath dflags pkgs = + collectLibraryPaths dflags `fmap` getPreloadPackagesAnd dflags pkgs + +collectLibraryPaths :: DynFlags -> [UnitInfo] -> [FilePath] +collectLibraryPaths dflags = ordNub . filter notNull + . concatMap (libraryDirsForWay dflags) + +-- | Find all the link options in these and the preload packages, +-- returning (package hs lib options, extra library options, other flags) +getPackageLinkOpts :: DynFlags -> [PreloadUnitId] -> IO ([String], [String], [String]) +getPackageLinkOpts dflags pkgs = + collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs + +collectLinkOpts :: DynFlags -> [UnitInfo] -> ([String], [String], [String]) +collectLinkOpts dflags ps = + ( + concatMap (map ("-l" ++) . packageHsLibs dflags) ps, + concatMap (map ("-l" ++) . extraLibraries) ps, + concatMap ldOptions ps + ) +collectArchives :: DynFlags -> UnitInfo -> IO [FilePath] +collectArchives dflags pc = + filterM doesFileExist [ searchPath </> ("lib" ++ lib ++ ".a") + | searchPath <- searchPaths + , lib <- libs ] + where searchPaths = ordNub . 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 -> UnitInfo -> [String] +packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) + where + ways0 = ways dflags + + ways1 = filter (/= WayDyn) ways0 + -- the name of a shared library is libHSfoo-ghc<version>.so + -- we leave out the _dyn, because it is superfluous + + -- debug and profiled RTSs include support for -eventlog + ways2 | WayDebug `elem` ways1 || WayProf `elem` ways1 + = filter (/= WayEventLog) ways1 + | otherwise + = ways1 + + tag = mkBuildTag (filter (not . wayRTSOnly) ways2) + rts_tag = mkBuildTag ways2 + + mkDynName x + | WayDyn `notElem` ways dflags = x + | "HS" `isPrefixOf` x = + x ++ '-':programName dflags ++ projectVersion dflags + -- For non-Haskell libraries, we use the name "Cfoo". The .a + -- file is libCfoo.a, and the .so is libfoo.so. That way the + -- linker knows what we mean for the vanilla (-lCfoo) and dyn + -- (-lfoo) ways. We therefore need to strip the 'C' off here. + | Just x' <- stripPrefix "C" x = x' + | 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 = "" + | otherwise = '_':t + +-- | Either the 'libraryDirs' or 'libraryDynDirs' as appropriate for the way. +libraryDirsForWay :: DynFlags -> UnitInfo -> [String] +libraryDirsForWay dflags + | WayDyn `elem` ways dflags = libraryDynDirs + | otherwise = libraryDirs + +-- | Find all the C-compiler options in these and the preload packages +getPackageExtraCcOpts :: DynFlags -> [PreloadUnitId] -> IO [String] +getPackageExtraCcOpts dflags pkgs = do + ps <- getPreloadPackagesAnd dflags pkgs + return (concatMap ccOptions ps) + +-- | Find all the package framework paths in these and the preload packages +getPackageFrameworkPath :: DynFlags -> [PreloadUnitId] -> IO [String] +getPackageFrameworkPath dflags pkgs = do + ps <- getPreloadPackagesAnd dflags pkgs + return (ordNub (filter notNull (concatMap frameworkDirs ps))) + +-- | Find all the package frameworks in these and the preload packages +getPackageFrameworks :: DynFlags -> [PreloadUnitId] -> IO [String] +getPackageFrameworks dflags pkgs = do + ps <- getPreloadPackagesAnd dflags pkgs + return (concatMap frameworks ps) + +-- ----------------------------------------------------------------------------- +-- Package Utils + +-- | Takes a 'ModuleName', and if the module is in any package returns +-- list of modules which take that name. +lookupModuleInAllPackages :: DynFlags + -> ModuleName + -> [(Module, UnitInfo)] +lookupModuleInAllPackages dflags m + = case lookupModuleWithSuggestions dflags m Nothing of + LookupFound a b -> [(a,b)] + LookupMultiple rs -> map f rs + where f (m,_) = (m, expectJust "lookupModule" (lookupUnit dflags + (moduleUnitId m))) + _ -> [] + +-- | The result of performing a lookup +data LookupResult = + -- | Found the module uniquely, nothing else to do + LookupFound Module UnitInfo + -- | Multiple modules with the same name in scope + | LookupMultiple [(Module, ModuleOrigin)] + -- | No modules found, but there were some hidden ones with + -- 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 + +data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin + | SuggestHidden ModuleName Module ModuleOrigin + +lookupModuleWithSuggestions :: DynFlags + -> ModuleName + -> Maybe FastString + -> LookupResult +lookupModuleWithSuggestions dflags + = lookupModuleWithSuggestions' dflags + (moduleNameProvidersMap (pkgState dflags)) + +lookupPluginModuleWithSuggestions :: DynFlags + -> ModuleName + -> Maybe FastString + -> LookupResult +lookupPluginModuleWithSuggestions dflags + = lookupModuleWithSuggestions' dflags + (pluginModuleNameProvidersMap (pkgState dflags)) + +lookupModuleWithSuggestions' :: DynFlags + -> ModuleNameProvidersMap + -> ModuleName + -> Maybe FastString + -> LookupResult +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_unit m) + (_, _, _, exposed@(_:_)) -> LookupMultiple exposed + ([], [], unusable@(_:_), []) -> LookupUnusable unusable + (hidden_pkg, hidden_mod, _, []) -> + LookupHidden hidden_pkg hidden_mod + where + classify (hidden_pkg, hidden_mod, unusable, exposed) (m, origin0) = + let origin = filterOrigin mb_pn (mod_unit m) origin0 + x = (m, origin) + in case origin of + 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) + + unit_lookup p = lookupUnit dflags p `orElse` pprPanic "lookupModuleWithSuggestions" (ppr p <+> ppr m) + mod_unit = unit_lookup . moduleUnitId + + -- Filters out origins which are not associated with the given package + -- qualifier. No-op if there is no package qualifier. Test if this + -- excluded all origins with 'originEmpty'. + filterOrigin :: Maybe FastString + -> UnitInfo + -> ModuleOrigin + -> ModuleOrigin + filterOrigin Nothing _ o = o + 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 { + fromOrigPackage = if go pkg then e else Nothing + , fromExposedReexport = filter go res + , fromHiddenReexport = filter go rhs + , fromPackageFlag = False -- always excluded + } + where go pkg = pn == fsPackageName pkg + + suggestions + | gopt Opt_HelpfulErrors dflags = + fuzzyLookup (moduleNameString m) all_mods + | otherwise = [] + + all_mods :: [(String, ModuleSuggestion)] -- All modules + all_mods = sortBy (comparing fst) $ + [ (moduleNameString m, suggestion) + | (m, e) <- Map.toList (moduleNameProvidersMap (pkgState dflags)) + , suggestion <- map (getSuggestion m) (Map.toList e) + ] + getSuggestion name (mod, origin) = + (if originVisible origin then SuggestVisible else SuggestHidden) + name mod origin + +listVisibleModuleNames :: DynFlags -> [ModuleName] +listVisibleModuleNames dflags = + map fst (filter visible (Map.toList (moduleNameProvidersMap (pkgState dflags)))) + where visible (_, ms) = any originVisible (Map.elems ms) + +-- | Find all the 'UnitInfo' in both the preload packages from 'DynFlags' and corresponding to the list of +-- 'UnitInfo's +getPreloadPackagesAnd :: DynFlags -> [PreloadUnitId] -> IO [UnitInfo] +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 = unitInfoMap state + preload = preloadPackages state + pairs = zip pkgids (repeat Nothing) + in do + all_pkgs <- throwErr dflags (foldM (add_package dflags pkg_map) preload pairs) + return (map (getInstalledPackageDetails dflags) all_pkgs) + +-- Takes a list of packages, and returns the list with dependencies included, +-- in reverse dependency order (a package appears before those it depends on). +closeDeps :: DynFlags + -> UnitInfoMap + -> [(InstalledUnitId, Maybe InstalledUnitId)] + -> IO [InstalledUnitId] +closeDeps dflags pkg_map ps + = throwErr dflags (closeDepsErr dflags pkg_map ps) + +throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a +throwErr dflags m + = case m of + Failed e -> throwGhcExceptionIO (CmdLineError (showSDoc dflags e)) + Succeeded r -> return r + +closeDepsErr :: DynFlags + -> UnitInfoMap + -> [(InstalledUnitId,Maybe InstalledUnitId)] + -> MaybeErr MsgDoc [InstalledUnitId] +closeDepsErr dflags pkg_map ps = foldM (add_package dflags pkg_map) [] ps + +-- internal helper +add_package :: DynFlags + -> UnitInfoMap + -> [PreloadUnitId] + -> (PreloadUnitId,Maybe PreloadUnitId) + -> MaybeErr MsgDoc [PreloadUnitId] +add_package dflags pkg_db ps (p, mb_parent) + | p `elem` ps = return ps -- Check if we've already added this package + | otherwise = + case lookupInstalledPackage' pkg_db p of + Nothing -> Failed (missingPackageMsg p <> + missingDependencyMsg mb_parent) + Just pkg -> do + -- Add the package's dependents also + ps' <- foldM add_unit_key ps (depends pkg) + return (p : ps') + where + add_unit_key ps key + = add_package dflags pkg_db ps (key, Just p) + +missingPackageMsg :: Outputable pkgid => pkgid -> SDoc +missingPackageMsg p = text "unknown package:" <+> ppr p + +missingDependencyMsg :: Maybe InstalledUnitId -> SDoc +missingDependencyMsg Nothing = Outputable.empty +missingDependencyMsg (Just parent) + = space <> parens (text "dependency of" <+> ftext (installedUnitIdFS parent)) + +-- ----------------------------------------------------------------------------- + +componentIdString :: DynFlags -> ComponentId -> Maybe String +componentIdString dflags cid = do + conf <- lookupInstalledPackage dflags (componentIdToInstalledUnitId cid) + return $ + case sourceLibName conf of + Nothing -> sourcePackageIdString conf + Just (PackageName libname) -> + packageNameString conf + ++ "-" ++ showVersion (packageVersion conf) + ++ ":" ++ unpackFS libname + +displayInstalledUnitId :: DynFlags -> InstalledUnitId -> Maybe String +displayInstalledUnitId dflags uid = + fmap sourcePackageIdString (lookupInstalledPackage dflags uid) + +-- | Will the 'Name' come from a dynamically linked library? +isDllName :: DynFlags -> Module -> Name -> Bool +-- Despite the "dll", I think this function just means that +-- the symbol comes from another dynamically-linked package, +-- and applies on all platforms, not just Windows +isDllName dflags this_mod name + | 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 + -- time for things like QuasiQuotes or + -- TemplateHaskell. Unfortunately, this interacts badly with + -- intra-package linking, because we don't generate indirect + -- (dynamic) symbols for intra-package calls. This means that if a + -- module with an intra-package call is loaded without its + -- dependencies, then GHC fails to link. This is the cause of # + -- + -- In the mean time, always force dynamic indirections to be + -- generated: when the module name isn't the module being + -- compiled, references are dynamic. + = 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. referring 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 + +-- ----------------------------------------------------------------------------- +-- Displaying packages + +-- | Show (very verbose) package info +pprPackages :: DynFlags -> SDoc +pprPackages = pprPackagesWith pprUnitInfo + +pprPackagesWith :: (UnitInfo -> SDoc) -> DynFlags -> SDoc +pprPackagesWith pprIPI dflags = + vcat (intersperse (text "---") (map pprIPI (listUnitInfoMap dflags))) + +-- | Show simplified package info. +-- +-- The idea is to only print package id, and any information that might +-- be different from the package databases (exposure, trust) +pprPackagesSimple :: DynFlags -> SDoc +pprPackagesSimple = pprPackagesWith pprIPI + where pprIPI ipi = let i = installedUnitIdFS (unitId ipi) + e = if exposed ipi then text "E" else text " " + t = if trusted ipi then text "T" else text " " + in e <> t <> text " " <> ftext i + +-- | Show the mapping of modules to where they come from. +pprModuleMap :: ModuleNameProvidersMap -> SDoc +pprModuleMap mod_map = + vcat (map pprLine (Map.toList mod_map)) + where + pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e))) + pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc + pprEntry m (m',o) + | m == moduleName m' = ppr (moduleUnitId m') <+> parens (ppr o) + | otherwise = ppr m' <+> parens (ppr o) + +fsPackageName :: UnitInfo -> FastString +fsPackageName = mkFastString . packageNameString + +-- | Given a fully instantiated 'UnitId', improve it into a +-- 'InstalledUnitId' if we can find it in the package database. +improveUnitId :: UnitInfoMap -> UnitId -> UnitId +improveUnitId _ uid@(DefiniteUnitId _) = uid -- short circuit +improveUnitId pkg_map uid = + -- Do NOT lookup indefinite ones, they won't be useful! + case lookupUnit' False pkg_map uid of + Nothing -> uid + Just pkg -> + -- Do NOT improve if the indefinite unit id is not + -- part of the closure unique set. See + -- Note [UnitId to InstalledUnitId improvement] + if installedUnitInfoId pkg `elementOfUniqSet` preloadClosure pkg_map + then packageConfigId pkg + else uid + +-- | Retrieve the 'UnitInfoMap' from 'DynFlags'; used +-- in the @hs-boot@ loop-breaker. +getUnitInfoMap :: DynFlags -> UnitInfoMap +getUnitInfoMap = unitInfoMap . pkgState diff --git a/compiler/GHC/Driver/Packages.hs-boot b/compiler/GHC/Driver/Packages.hs-boot new file mode 100644 index 0000000000..89fb2a1c18 --- /dev/null +++ b/compiler/GHC/Driver/Packages.hs-boot @@ -0,0 +1,12 @@ +module GHC.Driver.Packages where +import GhcPrelude +import {-# SOURCE #-} GHC.Driver.Session (DynFlags) +import {-# SOURCE #-} Module(ComponentId, UnitId, InstalledUnitId) +data PackageState +data UnitInfoMap +data PackageDatabase +emptyPackageState :: PackageState +componentIdString :: DynFlags -> ComponentId -> Maybe String +displayInstalledUnitId :: DynFlags -> InstalledUnitId -> Maybe String +improveUnitId :: UnitInfoMap -> UnitId -> UnitId +getUnitInfoMap :: DynFlags -> UnitInfoMap diff --git a/compiler/GHC/Driver/Phases.hs b/compiler/GHC/Driver/Phases.hs new file mode 100644 index 0000000000..45cb4656ba --- /dev/null +++ b/compiler/GHC/Driver/Phases.hs @@ -0,0 +1,370 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- +-- GHC Driver +-- +-- (c) The University of Glasgow 2002 +-- +----------------------------------------------------------------------------- + +module GHC.Driver.Phases ( + HscSource(..), isHsBootOrSig, isHsigFile, hscSourceString, + Phase(..), + happensBefore, eqPhase, anyHsc, isStopLn, + startPhase, + phaseInputExt, + + isHaskellishSuffix, + isHaskellSrcSuffix, + isBackpackishSuffix, + isObjectSuffix, + isCishSuffix, + isDynLibSuffix, + isHaskellUserSrcSuffix, + isHaskellSigSuffix, + isSourceSuffix, + + isHaskellishTarget, + + isHaskellishFilename, + isHaskellSrcFilename, + isHaskellSigFilename, + isObjectFilename, + isCishFilename, + isDynLibFilename, + isHaskellUserSrcFilename, + isSourceFilename + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} GHC.Driver.Session +import Outputable +import GHC.Platform +import System.FilePath +import Binary +import Util + +----------------------------------------------------------------------------- +-- Phases + +{- + Phase of the | Suffix saying | Flag saying | (suffix of) + compilation system | ``start here''| ``stop after''| output file + + literate pre-processor | .lhs | - | - + C pre-processor (opt.) | - | -E | - + Haskell compiler | .hs | -C, -S | .hc, .s + C compiler (opt.) | .hc or .c | -S | .s + assembler | .s or .S | -c | .o + linker | other | - | a.out +-} + +-- Note [HscSource types] +-- ~~~~~~~~~~~~~~~~~~~~~~ +-- There are three types of source file for Haskell code: +-- +-- * HsSrcFile is an ordinary hs file which contains code, +-- +-- * HsBootFile is an hs-boot file, which is used to break +-- recursive module imports (there will always be an +-- HsSrcFile associated with it), and +-- +-- * HsigFile is an hsig file, which contains only type +-- signatures and is used to specify signatures for +-- modules. +-- +-- Syntactically, hs-boot files and hsig files are quite similar: they +-- only include type signatures and must be associated with an +-- actual HsSrcFile. isHsBootOrSig allows us to abstract over code +-- which is indifferent to which. However, there are some important +-- differences, mostly owing to the fact that hsigs are proper +-- modules (you `import Sig` directly) whereas HsBootFiles are +-- temporary placeholders (you `import {-# SOURCE #-} Mod). +-- When we finish compiling the true implementation of an hs-boot, +-- we replace the HomeModInfo with the real HsSrcFile. An HsigFile, on the +-- other hand, is never replaced (in particular, we *cannot* use the +-- HomeModInfo of the original HsSrcFile backing the signature, since it +-- will export too many symbols.) +-- +-- Additionally, while HsSrcFile is the only Haskell file +-- which has *code*, we do generate .o files for HsigFile, because +-- this is how the recompilation checker figures out if a file +-- needs to be recompiled. These are fake object files which +-- should NOT be linked against. + +data HscSource + = HsSrcFile | HsBootFile | HsigFile + deriving( Eq, Ord, Show ) + -- Ord needed for the finite maps we build in CompManager + +instance Binary HscSource where + put_ bh HsSrcFile = putByte bh 0 + put_ bh HsBootFile = putByte bh 1 + put_ bh HsigFile = putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> return HsSrcFile + 1 -> return HsBootFile + _ -> return HsigFile + +hscSourceString :: HscSource -> String +hscSourceString HsSrcFile = "" +hscSourceString HsBootFile = "[boot]" +hscSourceString HsigFile = "[sig]" + +-- See Note [isHsBootOrSig] +isHsBootOrSig :: HscSource -> Bool +isHsBootOrSig HsBootFile = True +isHsBootOrSig HsigFile = True +isHsBootOrSig _ = False + +isHsigFile :: HscSource -> Bool +isHsigFile HsigFile = True +isHsigFile _ = False + +data Phase + = Unlit HscSource + | Cpp HscSource + | HsPp HscSource + | Hsc HscSource + | Ccxx -- Compile C++ + | Cc -- Compile C + | Cobjc -- Compile Objective-C + | Cobjcxx -- Compile Objective-C++ + | HCc -- Haskellised C (as opposed to vanilla C) compilation + | As Bool -- Assembler for regular assembly files (Bool: with-cpp) + | LlvmOpt -- Run LLVM opt tool over llvm assembly + | LlvmLlc -- LLVM bitcode to native assembly + | LlvmMangle -- Fix up TNTC by processing assembly produced by LLVM + | CmmCpp -- pre-process Cmm source + | Cmm -- parse & compile Cmm code + | MergeForeign -- merge in the foreign object files + + -- The final phase is a pseudo-phase that tells the pipeline to stop. + -- There is no runPhase case for it. + | StopLn -- Stop, but linking will follow, so generate .o file + deriving (Eq, Show) + +instance Outputable Phase where + ppr p = text (show p) + +anyHsc :: Phase +anyHsc = Hsc (panic "anyHsc") + +isStopLn :: Phase -> Bool +isStopLn StopLn = True +isStopLn _ = False + +eqPhase :: Phase -> Phase -> Bool +-- Equality of constructors, ignoring the HscSource field +-- NB: the HscSource field can be 'bot'; see anyHsc above +eqPhase (Unlit _) (Unlit _) = True +eqPhase (Cpp _) (Cpp _) = True +eqPhase (HsPp _) (HsPp _) = True +eqPhase (Hsc _) (Hsc _) = True +eqPhase Cc Cc = True +eqPhase Cobjc Cobjc = True +eqPhase HCc HCc = True +eqPhase (As x) (As y) = x == y +eqPhase LlvmOpt LlvmOpt = True +eqPhase LlvmLlc LlvmLlc = True +eqPhase LlvmMangle LlvmMangle = True +eqPhase CmmCpp CmmCpp = True +eqPhase Cmm Cmm = True +eqPhase MergeForeign MergeForeign = True +eqPhase StopLn StopLn = True +eqPhase Ccxx Ccxx = True +eqPhase Cobjcxx Cobjcxx = True +eqPhase _ _ = False + +{- Note [Partial ordering on phases] + +We want to know which phases will occur before which others. This is used for +sanity checking, to ensure that the pipeline will stop at some point (see +GHC.Driver.Pipeline.runPipeline). + +A < B iff A occurs before B in a normal compilation pipeline. + +There is explicitly not a total ordering on phases, because in registerised +builds, the phase `HsC` doesn't happen before nor after any other phase. + +Although we check that a normal user doesn't set the stop_phase to HsC through +use of -C with registerised builds (in Main.checkOptions), it is still +possible for a ghc-api user to do so. So be careful when using the function +happensBefore, and don't think that `not (a <= b)` implies `b < a`. +-} +happensBefore :: DynFlags -> Phase -> Phase -> Bool +happensBefore dflags p1 p2 = p1 `happensBefore'` p2 + where StopLn `happensBefore'` _ = False + x `happensBefore'` y = after_x `eqPhase` y + || after_x `happensBefore'` y + where after_x = nextPhase dflags x + +nextPhase :: DynFlags -> Phase -> Phase +nextPhase dflags p + -- A conservative approximation to the next phase, used in happensBefore + = case p of + Unlit sf -> Cpp sf + Cpp sf -> HsPp sf + HsPp sf -> Hsc sf + Hsc _ -> maybeHCc + LlvmOpt -> LlvmLlc + LlvmLlc -> LlvmMangle + LlvmMangle -> As False + As _ -> MergeForeign + Ccxx -> As False + Cc -> As False + Cobjc -> As False + Cobjcxx -> As False + CmmCpp -> Cmm + Cmm -> maybeHCc + HCc -> As False + MergeForeign -> StopLn + StopLn -> panic "nextPhase: nothing after StopLn" + where maybeHCc = if platformUnregisterised (targetPlatform dflags) + then HCc + else As False + +-- the first compilation phase for a given file is determined +-- by its suffix. +startPhase :: String -> Phase +startPhase "lhs" = Unlit HsSrcFile +startPhase "lhs-boot" = Unlit HsBootFile +startPhase "lhsig" = Unlit HsigFile +startPhase "hs" = Cpp HsSrcFile +startPhase "hs-boot" = Cpp HsBootFile +startPhase "hsig" = Cpp HsigFile +startPhase "hscpp" = HsPp HsSrcFile +startPhase "hspp" = Hsc HsSrcFile +startPhase "hc" = HCc +startPhase "c" = Cc +startPhase "cpp" = Ccxx +startPhase "C" = Cc +startPhase "m" = Cobjc +startPhase "M" = Cobjcxx +startPhase "mm" = Cobjcxx +startPhase "cc" = Ccxx +startPhase "cxx" = Ccxx +startPhase "s" = As False +startPhase "S" = As True +startPhase "ll" = LlvmOpt +startPhase "bc" = LlvmLlc +startPhase "lm_s" = LlvmMangle +startPhase "o" = StopLn +startPhase "cmm" = CmmCpp +startPhase "cmmcpp" = Cmm +startPhase _ = StopLn -- all unknown file types + +-- This is used to determine the extension for the output from the +-- current phase (if it generates a new file). The extension depends +-- on the next phase in the pipeline. +phaseInputExt :: Phase -> String +phaseInputExt (Unlit HsSrcFile) = "lhs" +phaseInputExt (Unlit HsBootFile) = "lhs-boot" +phaseInputExt (Unlit HsigFile) = "lhsig" +phaseInputExt (Cpp _) = "lpp" -- intermediate only +phaseInputExt (HsPp _) = "hscpp" -- intermediate only +phaseInputExt (Hsc _) = "hspp" -- intermediate only + -- NB: as things stand, phaseInputExt (Hsc x) must not evaluate x + -- because runPipeline uses the StopBefore phase to pick the + -- output filename. That could be fixed, but watch out. +phaseInputExt HCc = "hc" +phaseInputExt Ccxx = "cpp" +phaseInputExt Cobjc = "m" +phaseInputExt Cobjcxx = "mm" +phaseInputExt Cc = "c" +phaseInputExt (As True) = "S" +phaseInputExt (As False) = "s" +phaseInputExt LlvmOpt = "ll" +phaseInputExt LlvmLlc = "bc" +phaseInputExt LlvmMangle = "lm_s" +phaseInputExt CmmCpp = "cmmcpp" +phaseInputExt Cmm = "cmm" +phaseInputExt MergeForeign = "o" +phaseInputExt StopLn = "o" + +haskellish_src_suffixes, backpackish_suffixes, haskellish_suffixes, cish_suffixes, + haskellish_user_src_suffixes, haskellish_sig_suffixes + :: [String] +-- When a file with an extension in the haskellish_src_suffixes group is +-- loaded in --make mode, its imports will be loaded too. +haskellish_src_suffixes = haskellish_user_src_suffixes ++ + [ "hspp", "hscpp" ] +haskellish_suffixes = haskellish_src_suffixes ++ + [ "hc", "cmm", "cmmcpp" ] +cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S", "ll", "bc", "lm_s", "m", "M", "mm" ] + +-- Will not be deleted as temp files: +haskellish_user_src_suffixes = + haskellish_sig_suffixes ++ [ "hs", "lhs", "hs-boot", "lhs-boot" ] +haskellish_sig_suffixes = [ "hsig", "lhsig" ] +backpackish_suffixes = [ "bkp" ] + +objish_suffixes :: Platform -> [String] +-- Use the appropriate suffix for the system on which +-- the GHC-compiled code will run +objish_suffixes platform = case platformOS platform of + OSMinGW32 -> [ "o", "O", "obj", "OBJ" ] + _ -> [ "o" ] + +dynlib_suffixes :: Platform -> [String] +dynlib_suffixes platform = case platformOS platform of + OSMinGW32 -> ["dll", "DLL"] + OSDarwin -> ["dylib", "so"] + _ -> ["so"] + +isHaskellishSuffix, isBackpackishSuffix, isHaskellSrcSuffix, isCishSuffix, + isHaskellUserSrcSuffix, isHaskellSigSuffix + :: String -> Bool +isHaskellishSuffix s = s `elem` haskellish_suffixes +isBackpackishSuffix s = s `elem` backpackish_suffixes +isHaskellSigSuffix s = s `elem` haskellish_sig_suffixes +isHaskellSrcSuffix s = s `elem` haskellish_src_suffixes +isCishSuffix s = s `elem` cish_suffixes +isHaskellUserSrcSuffix s = s `elem` haskellish_user_src_suffixes + +isObjectSuffix, isDynLibSuffix :: Platform -> String -> Bool +isObjectSuffix platform s = s `elem` objish_suffixes platform +isDynLibSuffix platform s = s `elem` dynlib_suffixes platform + +isSourceSuffix :: String -> Bool +isSourceSuffix suff = isHaskellishSuffix suff + || isCishSuffix suff + || isBackpackishSuffix suff + +-- | When we are given files (modified by -x arguments) we need +-- to determine if they are Haskellish or not to figure out +-- how we should try to compile it. The rules are: +-- +-- 1. If no -x flag was specified, we check to see if +-- the file looks like a module name, has no extension, +-- or has a Haskell source extension. +-- +-- 2. If an -x flag was specified, we just make sure the +-- specified suffix is a Haskell one. +isHaskellishTarget :: (String, Maybe Phase) -> Bool +isHaskellishTarget (f,Nothing) = + looksLikeModuleName f || isHaskellSrcFilename f || not (hasExtension f) +isHaskellishTarget (_,Just phase) = + phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm + , StopLn] + +isHaskellishFilename, isHaskellSrcFilename, isCishFilename, + isHaskellUserSrcFilename, isSourceFilename, isHaskellSigFilename + :: FilePath -> Bool +-- takeExtension return .foo, so we drop 1 to get rid of the . +isHaskellishFilename f = isHaskellishSuffix (drop 1 $ takeExtension f) +isHaskellSrcFilename f = isHaskellSrcSuffix (drop 1 $ takeExtension f) +isCishFilename f = isCishSuffix (drop 1 $ takeExtension f) +isHaskellUserSrcFilename f = isHaskellUserSrcSuffix (drop 1 $ takeExtension f) +isSourceFilename f = isSourceSuffix (drop 1 $ takeExtension f) +isHaskellSigFilename f = isHaskellSigSuffix (drop 1 $ takeExtension f) + +isObjectFilename, isDynLibFilename :: Platform -> FilePath -> Bool +isObjectFilename platform f = isObjectSuffix platform (drop 1 $ takeExtension f) +isDynLibFilename platform f = isDynLibSuffix platform (drop 1 $ takeExtension f) diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs new file mode 100644 index 0000000000..3c31e34eb8 --- /dev/null +++ b/compiler/GHC/Driver/Pipeline.hs @@ -0,0 +1,2340 @@ +{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation, BangPatterns, MultiWayIf #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +----------------------------------------------------------------------------- +-- +-- GHC Driver +-- +-- (c) The University of Glasgow 2005 +-- +----------------------------------------------------------------------------- + +module GHC.Driver.Pipeline ( + -- Run a series of compilation steps in a pipeline, for a + -- collection of source files. + oneShot, compileFile, + + -- Interfaces for the batch-mode driver + linkBinary, + + -- Interfaces for the compilation manager (interpreted/batch-mode) + preprocess, + compileOne, compileOne', + link, + + -- Exports for hooks to override runPhase and link + PhasePlus(..), CompPipeline(..), PipeEnv(..), PipeState(..), + phaseOutputFilename, getOutputFilename, getPipeState, getPipeEnv, + hscPostBackendPhase, getLocation, setModLocation, setDynFlags, + runPhase, exeFileName, + maybeCreateManifest, + doCpp, + linkingNeeded, checkLinkInfo, writeInterfaceOnlyMode + ) where + +#include <ghcplatform.h> +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Driver.Pipeline.Monad +import GHC.Driver.Packages +import HeaderInfo +import GHC.Driver.Phases +import SysTools +import SysTools.ExtraObj +import GHC.Driver.Main +import GHC.Driver.Finder +import GHC.Driver.Types hiding ( Hsc ) +import Outputable +import Module +import ErrUtils +import GHC.Driver.Session +import Panic +import Util +import StringBuffer ( hGetStringBuffer, hPutStringBuffer ) +import BasicTypes ( SuccessFlag(..) ) +import Maybes ( expectJust ) +import SrcLoc +import GHC.CmmToLlvm ( llvmFixupAsm, llvmVersionList ) +import MonadUtils +import GHC.Platform +import TcRnTypes +import ToolSettings +import GHC.Driver.Hooks +import qualified GHC.LanguageExtensions as LangExt +import FileCleanup +import Ar +import Bag ( unitBag ) +import FastString ( mkFastString ) +import GHC.Iface.Utils ( mkFullIface ) +import UpdateCafInfos ( updateModDetailsCafInfos ) + +import Exception +import System.Directory +import System.FilePath +import System.IO +import Control.Monad +import Data.List ( isInfixOf, intercalate ) +import Data.Maybe +import Data.Version +import Data.Either ( partitionEithers ) + +import Data.Time ( UTCTime ) + +-- --------------------------------------------------------------------------- +-- Pre-process + +-- | Just preprocess a file, put the result in a temp. file (used by the +-- compilation manager during the summary phase). +-- +-- We return the augmented DynFlags, because they contain the result +-- of slurping in the OPTIONS pragmas + +preprocess :: HscEnv + -> FilePath -- ^ input filename + -> Maybe InputFileBuffer + -- ^ optional buffer to use instead of reading the input file + -> Maybe Phase -- ^ starting phase + -> IO (Either ErrorMessages (DynFlags, FilePath)) +preprocess hsc_env input_fn mb_input_buf mb_phase = + handleSourceError (\err -> return (Left (srcErrorMessages err))) $ + ghandle handler $ + fmap Right $ do + MASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn) + (dflags, fp, mb_iface) <- runPipeline anyHsc hsc_env (input_fn, mb_input_buf, fmap RealPhase mb_phase) + Nothing + -- We keep the processed file for the whole session to save on + -- duplicated work in ghci. + (Temporary TFL_GhcSession) + Nothing{-no ModLocation-} + []{-no foreign objects-} + -- We stop before Hsc phase so we shouldn't generate an interface + MASSERT(isNothing mb_iface) + return (dflags, fp) + where + srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1 + handler (ProgramError msg) = return $ Left $ unitBag $ + mkPlainErrMsg (hsc_dflags hsc_env) srcspan $ text msg + handler ex = throwGhcExceptionIO ex + +-- --------------------------------------------------------------------------- + +-- | Compile +-- +-- Compile a single module, under the control of the compilation manager. +-- +-- This is the interface between the compilation manager and the +-- compiler proper (hsc), where we deal with tedious details like +-- reading the OPTIONS pragma from the source file, converting the +-- C or assembly that GHC produces into an object file, and compiling +-- FFI stub files. +-- +-- NB. No old interface can also mean that the source has changed. + +compileOne :: HscEnv + -> ModSummary -- ^ summary for module being compiled + -> Int -- ^ module N ... + -> Int -- ^ ... of M + -> Maybe ModIface -- ^ old interface, if we have one + -> Maybe Linkable -- ^ old linkable, if we have one + -> SourceModified + -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful + +compileOne = compileOne' Nothing (Just batchMsg) + +compileOne' :: Maybe TcGblEnv + -> Maybe Messager + -> HscEnv + -> ModSummary -- ^ summary for module being compiled + -> Int -- ^ module N ... + -> Int -- ^ ... of M + -> Maybe ModIface -- ^ old interface, if we have one + -> Maybe Linkable -- ^ old linkable, if we have one + -> SourceModified + -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful + +compileOne' m_tc_result mHscMessage + hsc_env0 summary mod_index nmods mb_old_iface mb_old_linkable + source_modified0 + = do + + debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp) + + -- Run the pipeline up to codeGen (so everything up to, but not including, STG) + (status, plugin_dflags) <- hscIncrementalCompile + always_do_basic_recompilation_check + m_tc_result mHscMessage + hsc_env summary source_modified mb_old_iface (mod_index, nmods) + + let flags = hsc_dflags hsc_env0 + in do unless (gopt Opt_KeepHiFiles flags) $ + addFilesToClean flags TFL_CurrentModule $ + [ml_hi_file $ ms_location summary] + unless (gopt Opt_KeepOFiles flags) $ + addFilesToClean flags TFL_GhcSession $ + [ml_obj_file $ ms_location summary] + + -- Use an HscEnv with DynFlags updated with the plugin info (returned from + -- hscIncrementalCompile) + let hsc_env' = hsc_env{ hsc_dflags = plugin_dflags } + + case (status, hsc_lang) of + (HscUpToDate iface hmi_details, _) -> + -- TODO recomp014 triggers this assert. What's going on?! + -- ASSERT( isJust mb_old_linkable || isNoLink (ghcLink dflags) ) + return $! HomeModInfo iface hmi_details mb_old_linkable + (HscNotGeneratingCode iface hmi_details, HscNothing) -> + let mb_linkable = if isHsBootOrSig src_flavour + then Nothing + -- TODO: Questionable. + else Just (LM (ms_hs_date summary) this_mod []) + in return $! HomeModInfo iface hmi_details mb_linkable + (HscNotGeneratingCode _ _, _) -> panic "compileOne HscNotGeneratingCode" + (_, HscNothing) -> panic "compileOne HscNothing" + (HscUpdateBoot iface hmi_details, HscInterpreted) -> do + return $! HomeModInfo iface hmi_details Nothing + (HscUpdateBoot iface hmi_details, _) -> do + touchObjectFile dflags object_filename + return $! HomeModInfo iface hmi_details Nothing + (HscUpdateSig iface hmi_details, HscInterpreted) -> do + let !linkable = LM (ms_hs_date summary) this_mod [] + return $! HomeModInfo iface hmi_details (Just linkable) + (HscUpdateSig iface hmi_details, _) -> do + output_fn <- getOutputFilename next_phase + (Temporary TFL_CurrentModule) basename dflags + next_phase (Just location) + + -- #10660: Use the pipeline instead of calling + -- compileEmptyStub directly, so -dynamic-too gets + -- handled properly + _ <- runPipeline StopLn hsc_env' + (output_fn, + Nothing, + Just (HscOut src_flavour + mod_name (HscUpdateSig iface hmi_details))) + (Just basename) + Persistent + (Just location) + [] + o_time <- getModificationUTCTime object_filename + let !linkable = LM o_time this_mod [DotO object_filename] + return $! HomeModInfo iface hmi_details (Just linkable) + (HscRecomp { hscs_guts = cgguts, + hscs_mod_location = mod_location, + hscs_mod_details = hmi_details, + hscs_partial_iface = partial_iface, + hscs_old_iface_hash = mb_old_iface_hash, + hscs_iface_dflags = iface_dflags }, HscInterpreted) -> do + -- In interpreted mode the regular codeGen backend is not run so we + -- generate a interface without codeGen info. + final_iface <- mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface Nothing + liftIO $ hscMaybeWriteIface dflags final_iface mb_old_iface_hash (ms_location summary) + + (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env' cgguts mod_location + + stub_o <- case hasStub of + Nothing -> return [] + Just stub_c -> do + stub_o <- compileStub hsc_env' stub_c + return [DotO stub_o] + + let hs_unlinked = [BCOs comp_bc spt_entries] + unlinked_time = ms_hs_date summary + -- Why do we use the timestamp of the source file here, + -- rather than the current time? This works better in + -- the case where the local clock is out of sync + -- with the filesystem's clock. It's just as accurate: + -- if the source is modified, then the linkable will + -- be out of date. + let !linkable = LM unlinked_time (ms_mod summary) + (hs_unlinked ++ stub_o) + return $! HomeModInfo final_iface hmi_details (Just linkable) + (HscRecomp{}, _) -> do + output_fn <- getOutputFilename next_phase + (Temporary TFL_CurrentModule) + basename dflags next_phase (Just location) + -- We're in --make mode: finish the compilation pipeline. + (_, _, Just (iface, details)) <- runPipeline StopLn hsc_env' + (output_fn, + Nothing, + Just (HscOut src_flavour mod_name status)) + (Just basename) + Persistent + (Just location) + [] + -- The object filename comes from the ModLocation + o_time <- getModificationUTCTime object_filename + let !linkable = LM o_time this_mod [DotO object_filename] + return $! HomeModInfo iface details (Just linkable) + + where dflags0 = ms_hspp_opts summary + this_mod = ms_mod summary + location = ms_location summary + input_fn = expectJust "compile:hs" (ml_hs_file location) + input_fnpp = ms_hspp_file summary + mod_graph = hsc_mod_graph hsc_env0 + needsLinker = needsTemplateHaskellOrQQ mod_graph + isDynWay = any (== WayDyn) (ways dflags0) + isProfWay = any (== WayProf) (ways dflags0) + internalInterpreter = not (gopt Opt_ExternalInterpreter dflags0) + + src_flavour = ms_hsc_src summary + mod_name = ms_mod_name summary + next_phase = hscPostBackendPhase src_flavour hsc_lang + object_filename = ml_obj_file location + + -- #8180 - when using TemplateHaskell, switch on -dynamic-too so + -- the linker can correctly load the object files. This isn't necessary + -- when using -fexternal-interpreter. + dflags1 = if dynamicGhc && internalInterpreter && + not isDynWay && not isProfWay && needsLinker + then gopt_set dflags0 Opt_BuildDynamicToo + else dflags0 + + -- #16331 - when no "internal interpreter" is available but we + -- need to process some TemplateHaskell or QuasiQuotes, we automatically + -- turn on -fexternal-interpreter. + dflags2 = if not internalInterpreter && needsLinker + then gopt_set dflags1 Opt_ExternalInterpreter + else dflags1 + + basename = dropExtension input_fn + + -- We add the directory in which the .hs files resides) to the import + -- path. This is needed when we try to compile the .hc file later, if it + -- imports a _stub.h file that we created here. + current_dir = takeDirectory basename + old_paths = includePaths dflags2 + !prevailing_dflags = hsc_dflags hsc_env0 + dflags = + dflags2 { 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 + -- to re-summarize all the source files. + hsc_env = hsc_env0 {hsc_dflags = dflags} + + -- Figure out what lang we're generating + hsc_lang = hscTarget dflags + + -- -fforce-recomp should also work with --make + force_recomp = gopt Opt_ForceRecomp dflags + source_modified + | force_recomp = SourceModified + | otherwise = source_modified0 + + always_do_basic_recompilation_check = case hsc_lang of + HscInterpreted -> True + _ -> False + +----------------------------------------------------------------------------- +-- stub .h and .c files (for foreign export support), and cc files. + +-- The _stub.c file is derived from the haskell source file, possibly taking +-- into account the -stubdir option. +-- +-- The object file created by compiling the _stub.c file is put into a +-- temporary file, which will be later combined with the main .o file +-- (see the MergeForeigns phase). +-- +-- Moreover, we also let the user emit arbitrary C/C++/ObjC/ObjC++ files +-- from TH, that are then compiled and linked to the module. This is +-- 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 + LangAsm -> As True -- allow CPP + RawObject -> panic "compileForeign: should be unreachable" + (_, stub_o, _) <- runPipeline StopLn hsc_env + (stub_c, Nothing, Just (RealPhase phase)) + Nothing (Temporary TFL_GhcSession) + Nothing{-no ModLocation-} + [] + return stub_o + +compileStub :: HscEnv -> FilePath -> IO FilePath +compileStub hsc_env stub_c = compileForeign hsc_env LangC stub_c + +compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO () +compileEmptyStub dflags hsc_env basename location mod_name = do + -- To maintain the invariant that every Haskell file + -- compiles to object code, we make an empty (but + -- valid) stub object file for signatures. However, + -- we make sure this object file has a unique symbol, + -- so that ranlib on OS X doesn't complain, see + -- https://gitlab.haskell.org/ghc/ghc/issues/12673 + -- and https://github.com/haskell/cabal/issues/2257 + empty_stub <- newTempName dflags TFL_CurrentModule "c" + let src = text "int" <+> ppr (mkModule (thisPackage dflags) mod_name) <+> text "= 0;" + writeFile empty_stub (showSDoc dflags (pprCode CStyle src)) + _ <- runPipeline StopLn hsc_env + (empty_stub, Nothing, Nothing) + (Just basename) + Persistent + (Just location) + [] + return () + +-- --------------------------------------------------------------------------- +-- Link + +link :: GhcLink -- interactive or batch + -> DynFlags -- dynamic flags + -> Bool -- attempt linking in batch mode? + -> HomePackageTable -- what to link + -> IO SuccessFlag + +-- For the moment, in the batch linker, we don't bother to tell doLink +-- which packages to link -- it just tries all that are available. +-- batch_attempt_linking should only be *looked at* in batch mode. It +-- should only be True if the upsweep was successful and someone +-- exports main, i.e., we have good reason to believe that linking +-- will succeed. + +link ghcLink dflags + = lookupHook linkHook l dflags ghcLink dflags + where + l LinkInMemory _ _ _ + = if platformMisc_ghcWithInterpreter $ platformMisc dflags + then -- Not Linking...(demand linker will do the job) + return Succeeded + else panicBadLink LinkInMemory + + l NoLink _ _ _ + = return Succeeded + + l LinkBinary dflags batch_attempt_linking hpt + = link' dflags batch_attempt_linking hpt + + l LinkStaticLib dflags batch_attempt_linking hpt + = link' dflags batch_attempt_linking hpt + + l LinkDynLib dflags batch_attempt_linking hpt + = link' dflags batch_attempt_linking hpt + +panicBadLink :: GhcLink -> a +panicBadLink other = panic ("link: GHC not built to link this way: " ++ + show other) + +link' :: DynFlags -- dynamic flags + -> Bool -- attempt linking in batch mode? + -> HomePackageTable -- what to link + -> IO SuccessFlag + +link' dflags batch_attempt_linking hpt + | batch_attempt_linking + = do + let + staticLink = case ghcLink dflags of + LinkStaticLib -> True + _ -> False + + home_mod_infos = eltsHpt hpt + + -- the packages we depend on + pkg_deps = concatMap (map fst . dep_pkgs . mi_deps . hm_iface) home_mod_infos + + -- the linkables to link + linkables = map (expectJust "link".hm_linkable) home_mod_infos + + debugTraceMsg dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables)) + + -- check for the -no-link flag + if isNoLink (ghcLink dflags) + then do debugTraceMsg dflags 3 (text "link(batch): linking omitted (-c flag given).") + return Succeeded + else do + + let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) + obj_files = concatMap getOfiles linkables + + exe_file = exeFileName staticLink dflags + + linking_needed <- linkingNeeded dflags staticLink linkables pkg_deps + + if not (gopt Opt_ForceRecomp dflags) && not linking_needed + then do debugTraceMsg dflags 2 (text exe_file <+> text "is up to date, linking not required.") + return Succeeded + else do + + compilationProgressMsg dflags ("Linking " ++ exe_file ++ " ...") + + -- Don't showPass in Batch mode; doLink will do that for us. + let link = case ghcLink dflags of + LinkBinary -> linkBinary + LinkStaticLib -> linkStaticLib + LinkDynLib -> linkDynLibCheck + other -> panicBadLink other + link dflags obj_files pkg_deps + + debugTraceMsg dflags 3 (text "link: done") + + -- linkBinary only returns if it succeeds + return Succeeded + + | otherwise + = do debugTraceMsg dflags 3 (text "link(batch): upsweep (partially) failed OR" $$ + text " Main.main not exported; not linking.") + return Succeeded + + +linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [InstalledUnitId] -> IO Bool +linkingNeeded dflags staticLink linkables pkg_deps = do + -- if the modification time on the executable is later than the + -- modification times on all of the objects and libraries, then omit + -- linking (unless the -fforce-recomp flag was given). + let exe_file = exeFileName staticLink dflags + e_exe_time <- tryIO $ getModificationUTCTime exe_file + case e_exe_time of + Left _ -> return True + Right t -> 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) = partitionEithers e_extra_times + let obj_times = map linkableTime linkables ++ extra_times + if not (null errs) || any (t <) obj_times + then return True + else do + + -- next, check libraries. XXX this only checks Haskell libraries, + -- not extra_libraries or -l things from the command line. + let pkg_hslibs = [ (collectLibraryPaths dflags [c], lib) + | Just c <- map (lookupInstalledPackage dflags) pkg_deps, + lib <- packageHsLibs dflags c ] + + pkg_libfiles <- mapM (uncurry (findHSLib dflags)) pkg_hslibs + if any isNothing pkg_libfiles then return True else do + e_lib_times <- mapM (tryIO . getModificationUTCTime) + (catMaybes pkg_libfiles) + 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 + +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 + found <- filterM doesFileExist (map (</> batch_lib_file) dirs) + case found of + [] -> return Nothing + (x:_) -> return (Just x) + +-- ----------------------------------------------------------------------------- +-- Compile files in one-shot mode. + +oneShot :: HscEnv -> Phase -> [(String, Maybe Phase)] -> IO () +oneShot hsc_env stop_phase srcs = do + o_files <- mapM (compileFile hsc_env stop_phase) srcs + doLink (hsc_dflags hsc_env) stop_phase o_files + +compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath +compileFile hsc_env stop_phase (src, mb_phase) = do + exists <- doesFileExist src + when (not exists) $ + throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src)) + + let + dflags = hsc_dflags hsc_env + mb_o_file = outputFile dflags + ghc_link = ghcLink dflags -- Set by -c or -no-link + + -- When linking, the -o argument refers to the linker's output. + -- otherwise, we use it as the name for the pipeline's output. + output + -- If we are doing -fno-code, then act as if the output is + -- 'Temporary'. This stops GHC trying to copy files to their + -- final location. + | HscNothing <- hscTarget dflags = Temporary TFL_CurrentModule + | StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent + -- -o foo applies to linker + | isJust mb_o_file = SpecificFile + -- -o foo applies to the file we are compiling now + | otherwise = Persistent + + ( _, out_file, _) <- runPipeline stop_phase hsc_env + (src, Nothing, fmap RealPhase mb_phase) + Nothing + output + Nothing{-no ModLocation-} [] + return out_file + + +doLink :: DynFlags -> Phase -> [FilePath] -> IO () +doLink dflags stop_phase o_files + | not (isStopLn stop_phase) + = return () -- We stopped before the linking phase + + | otherwise + = case ghcLink dflags of + NoLink -> return () + LinkBinary -> linkBinary dflags o_files [] + LinkStaticLib -> linkStaticLib dflags o_files [] + LinkDynLib -> linkDynLibCheck dflags o_files [] + other -> panicBadLink other + + +-- --------------------------------------------------------------------------- + +-- | Run a compilation pipeline, consisting of multiple phases. +-- +-- This is the interface to the compilation pipeline, which runs +-- a series of compilation steps on a single source file, specifying +-- at which stage to stop. +-- +-- The DynFlags can be modified by phases in the pipeline (eg. by +-- OPTIONS_GHC pragmas), and the changes affect later phases in the +-- pipeline. +runPipeline + :: Phase -- ^ When to stop + -> HscEnv -- ^ Compilation environment + -> (FilePath, Maybe InputFileBuffer, Maybe PhasePlus) + -- ^ Pipeline input file name, optional + -- buffer and maybe -x suffix + -> Maybe FilePath -- ^ original basename (if different from ^^^) + -> PipelineOutput -- ^ Output filename + -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module + -> [FilePath] -- ^ foreign objects + -> IO (DynFlags, FilePath, Maybe (ModIface, ModDetails)) + -- ^ (final flags, output filename, interface) +runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase) + mb_basename output maybe_loc foreign_os + + = do let + dflags0 = hsc_dflags hsc_env0 + + -- Decide where dump files should go based on the pipeline output + dflags = dflags0 { dumpPrefix = Just (basename ++ ".") } + hsc_env = hsc_env0 {hsc_dflags = dflags} + + (input_basename, suffix) = splitExtension input_fn + suffix' = drop 1 suffix -- strip off the . + basename | Just b <- mb_basename = b + | otherwise = input_basename + + -- If we were given a -x flag, then use that phase to start from + start_phase = fromMaybe (RealPhase (startPhase suffix')) mb_phase + + isHaskell (RealPhase (Unlit _)) = True + isHaskell (RealPhase (Cpp _)) = True + isHaskell (RealPhase (HsPp _)) = True + isHaskell (RealPhase (Hsc _)) = True + isHaskell (HscOut {}) = True + isHaskell _ = False + + isHaskellishFile = isHaskell start_phase + + env = PipeEnv{ stop_phase, + src_filename = input_fn, + src_basename = basename, + src_suffix = suffix', + output_spec = output } + + when (isBackpackishSuffix suffix') $ + throwGhcExceptionIO (UsageError + ("use --backpack to process " ++ input_fn)) + + -- We want to catch cases of "you can't get there from here" before + -- we start the pipeline, because otherwise it will just run off the + -- end. + let happensBefore' = happensBefore dflags + case start_phase of + RealPhase start_phase' -> + -- See Note [Partial ordering on phases] + -- Not the same as: (stop_phase `happensBefore` start_phase') + when (not (start_phase' `happensBefore'` stop_phase || + start_phase' `eqPhase` stop_phase)) $ + throwGhcExceptionIO (UsageError + ("cannot compile this file to desired target: " + ++ input_fn)) + HscOut {} -> return () + + -- Write input buffer to temp file if requested + input_fn' <- case (start_phase, mb_input_buf) of + (RealPhase real_start_phase, Just input_buf) -> do + let suffix = phaseInputExt real_start_phase + fn <- newTempName dflags TFL_CurrentModule suffix + hdl <- openBinaryFile fn WriteMode + -- Add a LINE pragma so reported source locations will + -- mention the real input file, not this temp file. + hPutStrLn hdl $ "{-# LINE 1 \""++ input_fn ++ "\"#-}" + hPutStringBuffer hdl input_buf + hClose hdl + return fn + (_, _) -> return input_fn + + debugTraceMsg dflags 4 (text "Running the pipeline") + r <- runPipeline' start_phase hsc_env env input_fn' + maybe_loc foreign_os + + -- If we are compiling a Haskell module, and doing + -- -dynamic-too, but couldn't do the -dynamic-too fast + -- path, then rerun the pipeline for the dyn way + let dflags = hsc_dflags hsc_env + -- NB: Currently disabled on Windows (ref #7134, #8228, and #5987) + when (not $ platformOS (targetPlatform dflags) == OSMinGW32) $ do + when isHaskellishFile $ whenCannotGenerateDynamicToo dflags $ do + debugTraceMsg dflags 4 + (text "Running the pipeline again for -dynamic-too") + let dflags' = dynamicTooMkDynamicDynFlags dflags + hsc_env' <- newHscEnv dflags' + _ <- runPipeline' start_phase hsc_env' env input_fn' + maybe_loc foreign_os + return () + return r + +runPipeline' + :: PhasePlus -- ^ When to start + -> HscEnv -- ^ Compilation environment + -> PipeEnv + -> FilePath -- ^ Input filename + -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module + -> [FilePath] -- ^ foreign objects, if we have one + -> IO (DynFlags, FilePath, Maybe (ModIface, ModDetails)) + -- ^ (final flags, output filename, interface) +runPipeline' start_phase hsc_env env input_fn + maybe_loc foreign_os + = do + -- Execute the pipeline... + let state = PipeState{ hsc_env, maybe_loc, foreign_os = foreign_os, iface = Nothing } + (pipe_state, fp) <- evalP (pipeLoop start_phase input_fn) env state + return (pipeStateDynFlags pipe_state, fp, pipeStateModIface pipe_state) + +-- --------------------------------------------------------------------------- +-- outer pipeline loop + +-- | pipeLoop runs phases until we reach the stop phase +pipeLoop :: PhasePlus -> FilePath -> CompPipeline FilePath +pipeLoop phase input_fn = do + env <- getPipeEnv + dflags <- getDynFlags + -- See Note [Partial ordering on phases] + let happensBefore' = happensBefore dflags + stopPhase = stop_phase env + case phase of + RealPhase realPhase | realPhase `eqPhase` stopPhase -- All done + -> -- Sometimes, a compilation phase doesn't actually generate any output + -- (eg. the CPP phase when -fcpp is not turned on). If we end on this + -- stage, but we wanted to keep the output, then we have to explicitly + -- copy the file, remembering to prepend a {-# LINE #-} pragma so that + -- further compilation stages can tell what the original filename was. + case output_spec env of + Temporary _ -> + return input_fn + output -> + do pst <- getPipeState + final_fn <- liftIO $ getOutputFilename + stopPhase output (src_basename env) + dflags stopPhase (maybe_loc pst) + when (final_fn /= input_fn) $ do + let msg = ("Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'") + line_prag = Just ("{-# LINE 1 \"" ++ src_filename env ++ "\" #-}\n") + liftIO $ copyWithHeader dflags msg line_prag input_fn final_fn + return final_fn + + + | not (realPhase `happensBefore'` stopPhase) + -- Something has gone wrong. We'll try to cover all the cases when + -- this could happen, so if we reach here it is a panic. + -- eg. it might happen if the -C flag is used on a source file that + -- has {-# OPTIONS -fasm #-}. + -> panic ("pipeLoop: at phase " ++ show realPhase ++ + " but I wanted to stop at phase " ++ show stopPhase) + + _ + -> do liftIO $ debugTraceMsg dflags 4 + (text "Running phase" <+> ppr phase) + (next_phase, output_fn) <- runHookedPhase phase input_fn dflags + case phase of + HscOut {} -> do + -- We don't pass Opt_BuildDynamicToo to the backend + -- in DynFlags. + -- Instead it's run twice with flags accordingly set + -- per run. + let noDynToo = pipeLoop next_phase output_fn + let dynToo = do + setDynFlags $ gopt_unset dflags Opt_BuildDynamicToo + r <- pipeLoop next_phase output_fn + setDynFlags $ dynamicTooMkDynamicDynFlags dflags + -- TODO shouldn't ignore result: + _ <- pipeLoop phase input_fn + return r + ifGeneratingDynamicToo dflags dynToo noDynToo + _ -> pipeLoop next_phase output_fn + +runHookedPhase :: PhasePlus -> FilePath -> DynFlags + -> CompPipeline (PhasePlus, FilePath) +runHookedPhase pp input dflags = + lookupHook runPhaseHook runPhase dflags pp input dflags + +-- ----------------------------------------------------------------------------- +-- In each phase, we need to know into what filename to generate the +-- output. All the logic about which filenames we generate output +-- into is embodied in the following function. + +-- | Computes the next output filename after we run @next_phase@. +-- Like 'getOutputFilename', but it operates in the 'CompPipeline' monad +-- (which specifies all of the ambient information.) +phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath +phaseOutputFilename next_phase = do + PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv + PipeState{maybe_loc, hsc_env} <- getPipeState + let dflags = hsc_dflags hsc_env + liftIO $ getOutputFilename stop_phase output_spec + src_basename dflags next_phase maybe_loc + +-- | Computes the next output filename for something in the compilation +-- pipeline. This is controlled by several variables: +-- +-- 1. 'Phase': the last phase to be run (e.g. 'stopPhase'). This +-- is used to tell if we're in the last phase or not, because +-- in that case flags like @-o@ may be important. +-- 2. 'PipelineOutput': is this intended to be a 'Temporary' or +-- 'Persistent' build output? Temporary files just go in +-- a fresh temporary name. +-- 3. 'String': what was the basename of the original input file? +-- 4. 'DynFlags': the obvious thing +-- 5. 'Phase': the phase we want to determine the output filename of. +-- 6. @Maybe ModLocation@: the 'ModLocation' of the module we're +-- compiling; this can be used to override the default output +-- of an object file. (TODO: do we actually need this?) +getOutputFilename + :: Phase -> PipelineOutput -> String + -> DynFlags -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath +getOutputFilename stop_phase output basename dflags next_phase maybe_location + | is_last_phase, Persistent <- output = persistent_fn + | is_last_phase, SpecificFile <- output = case outputFile dflags of + Just f -> return f + Nothing -> + panic "SpecificFile: No filename" + | keep_this_output = persistent_fn + | Temporary lifetime <- output = newTempName dflags lifetime suffix + | otherwise = newTempName dflags TFL_CurrentModule + suffix + where + hcsuf = hcSuf dflags + 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 + + myPhaseInputExt HCc = hcsuf + myPhaseInputExt MergeForeign = osuf + myPhaseInputExt StopLn = osuf + myPhaseInputExt other = phaseInputExt other + + is_last_phase = next_phase `eqPhase` stop_phase + + -- sometimes, we keep output from intermediate stages + keep_this_output = + case next_phase of + As _ | keep_s -> True + LlvmOpt | keep_bc -> True + HCc | keep_hc -> True + HsPp _ | keep_hscpp -> True -- See #10869 + _other -> False + + suffix = myPhaseInputExt next_phase + + -- persistent object files get put in odir + persistent_fn + | StopLn <- next_phase = return odir_persistent + | otherwise = return persistent + + persistent = basename <.> suffix + + odir_persistent + | Just loc <- maybe_location = ml_obj_file loc + | 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 = platformMisc_llvmTarget $ platformMisc dflags + Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets $ llvmConfig 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. +-- +-- We must do things dynamically this way, because we often don't know +-- what the rest of the phases will be until part-way through the +-- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning +-- of a source file can change the latter stages of the pipeline from +-- taking the LLVM route to using the native code generator. +-- +runPhase :: PhasePlus -- ^ Run this phase + -> FilePath -- ^ name of the input file + -> DynFlags -- ^ for convenience, we pass the current dflags in + -> CompPipeline (PhasePlus, -- next phase to run + FilePath) -- output filename + + -- Invariant: the output filename always contains the output + -- Interesting case: Hsc when there is no recompilation to do + -- Then the output filename is still a .o file + + +------------------------------------------------------------------------------- +-- Unlit phase + +runPhase (RealPhase (Unlit sf)) input_fn dflags + = do + output_fn <- phaseOutputFilename (Cpp sf) + + let flags = [ -- The -h option passes the file name for unlit to + -- put in a #line directive + SysTools.Option "-h" + -- See Note [Don't normalise input filenames]. + , SysTools.Option $ escape input_fn + , SysTools.FileOption "" input_fn + , SysTools.FileOption "" output_fn + ] + + liftIO $ SysTools.runUnlit dflags flags + + return (RealPhase (Cpp sf), output_fn) + where + -- escape the characters \, ", and ', but don't try to escape + -- Unicode or anything else (so we don't use Util.charToC + -- here). If we get this wrong, then in + -- GHC.HsToCore.Coverage.isGoodTickSrcSpan where we check that the filename in + -- a SrcLoc is the same as the source filenaame, the two will + -- look bogusly different. See test: + -- libraries/hpc/tests/function/subdir/tough2.hs + escape ('\\':cs) = '\\':'\\': escape cs + escape ('\"':cs) = '\\':'\"': escape cs + escape ('\'':cs) = '\\':'\'': escape cs + escape (c:cs) = c : escape cs + escape [] = [] + +------------------------------------------------------------------------------- +-- Cpp phase : (a) gets OPTIONS out of file +-- (b) runs cpp if necessary + +runPhase (RealPhase (Cpp sf)) input_fn dflags0 + = do + src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn + (dflags1, unhandled_flags, warns) + <- liftIO $ parseDynamicFilePragma dflags0 src_opts + setDynFlags dflags1 + liftIO $ checkProcessArgsResult dflags1 unhandled_flags + + if not (xopt LangExt.Cpp dflags1) then do + -- we have to be careful to emit warnings only once. + unless (gopt Opt_Pp dflags1) $ + liftIO $ handleFlagWarnings dflags1 warns + + -- no need to preprocess CPP, just pass input file along + -- to the next phase of the pipeline. + return (RealPhase (HsPp sf), input_fn) + else do + output_fn <- phaseOutputFilename (HsPp sf) + liftIO $ doCpp dflags1 True{-raw-} + input_fn output_fn + -- re-read the pragmas now that we've preprocessed the file + -- See #2464,#3457 + src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn + (dflags2, unhandled_flags, warns) + <- liftIO $ parseDynamicFilePragma dflags0 src_opts + liftIO $ checkProcessArgsResult dflags2 unhandled_flags + unless (gopt Opt_Pp dflags2) $ + liftIO $ handleFlagWarnings dflags2 warns + -- the HsPp pass below will emit warnings + + setDynFlags dflags2 + + return (RealPhase (HsPp sf), output_fn) + +------------------------------------------------------------------------------- +-- HsPp phase + +runPhase (RealPhase (HsPp sf)) input_fn dflags + = do + if not (gopt Opt_Pp dflags) then + -- no need to preprocess, just pass input file along + -- to the next phase of the pipeline. + return (RealPhase (Hsc sf), input_fn) + else do + PipeEnv{src_basename, src_suffix} <- getPipeEnv + let orig_fn = src_basename <.> src_suffix + output_fn <- phaseOutputFilename (Hsc sf) + liftIO $ SysTools.runPp dflags + ( [ SysTools.Option orig_fn + , SysTools.Option input_fn + , SysTools.FileOption "" output_fn + ] + ) + + -- re-read pragmas now that we've parsed the file (see #3674) + src_opts <- liftIO $ getOptionsFromFile dflags output_fn + (dflags1, unhandled_flags, warns) + <- liftIO $ parseDynamicFilePragma dflags src_opts + setDynFlags dflags1 + liftIO $ checkProcessArgsResult dflags1 unhandled_flags + liftIO $ handleFlagWarnings dflags1 warns + + return (RealPhase (Hsc sf), output_fn) + +----------------------------------------------------------------------------- +-- Hsc phase + +-- Compilation of a single module, in "legacy" mode (_not_ under +-- the direction of the compilation manager). +runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0 + = do -- normal Hsc mode, not mkdependHS + + PipeEnv{ stop_phase=stop, + src_basename=basename, + src_suffix=suff } <- getPipeEnv + + -- we add the current directory (i.e. the directory in which + -- 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 = new_includes } + + setDynFlags dflags + + -- gather the imports and module name + (hspp_buf,mod_name,imps,src_imps) <- liftIO $ do + do + buf <- hGetStringBuffer input_fn + eimps <- getImports dflags buf input_fn (basename <.> suff) + case eimps of + Left errs -> throwErrors errs + Right (src_imps,imps,L _ mod_name) -> return + (Just buf, mod_name, imps, src_imps) + + -- Take -o into account if present + -- Very like -ohi, but we must *only* do this if we aren't linking + -- (If we're linking then the -o applies to the linked thing, not to + -- the object file for one module.) + -- Note the nasty duplication with the same computation in compileFile above + location <- getLocation src_flavour mod_name + + let o_file = ml_obj_file location -- The real object file + hi_file = ml_hi_file location + hie_file = ml_hie_file location + dest_file | writeInterfaceOnlyMode dflags + = hi_file + | otherwise + = o_file + + -- Figure out if the source has changed, for recompilation avoidance. + -- + -- Setting source_unchanged to True means that M.o (or M.hie) seems + -- to be up to date wrt M.hs; so no need to recompile unless imports have + -- changed (which the compiler itself figures out). + -- Setting source_unchanged to False tells the compiler that M.o is out of + -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless. + src_timestamp <- liftIO $ getModificationUTCTime (basename <.> suff) + + source_unchanged <- liftIO $ + if not (isStopLn stop) + -- SourceModified unconditionally if + -- (a) recompilation checker is off, or + -- (b) we aren't going all the way to .o file (e.g. ghc -S) + then return SourceModified + -- Otherwise look at file modification dates + else do dest_file_mod <- sourceModified dest_file src_timestamp + hie_file_mod <- if gopt Opt_WriteHie dflags + then sourceModified hie_file + src_timestamp + else pure False + if dest_file_mod || hie_file_mod + then return SourceModified + else return SourceUnmodified + + PipeState{hsc_env=hsc_env'} <- getPipeState + + -- Tell the finder cache about this module + mod <- liftIO $ addHomeModuleToFinder hsc_env' mod_name location + + -- Make the ModSummary to hand to hscMain + let + mod_summary = ModSummary { ms_mod = mod, + ms_hsc_src = src_flavour, + ms_hspp_file = input_fn, + ms_hspp_opts = dflags, + ms_hspp_buf = hspp_buf, + ms_location = location, + ms_hs_date = src_timestamp, + ms_obj_date = Nothing, + ms_parsed_mod = Nothing, + ms_iface_date = Nothing, + ms_hie_date = Nothing, + ms_textual_imps = imps, + ms_srcimps = src_imps } + + -- run the compiler! + let msg hsc_env _ what _ = oneShotMsg hsc_env what + (result, plugin_dflags) <- + liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env' + mod_summary source_unchanged Nothing (1,1) + + -- In the rest of the pipeline use the dflags with plugin info + setDynFlags plugin_dflags + + return (HscOut src_flavour mod_name result, + panic "HscOut doesn't have an input filename") + +runPhase (HscOut src_flavour mod_name result) _ dflags = do + location <- getLocation src_flavour mod_name + setModLocation location + + let o_file = ml_obj_file location -- The real object file + hsc_lang = hscTarget dflags + next_phase = hscPostBackendPhase src_flavour hsc_lang + + case result of + HscNotGeneratingCode _ _ -> + return (RealPhase StopLn, + panic "No output filename from Hsc when no-code") + HscUpToDate _ _ -> + do liftIO $ touchObjectFile dflags o_file + -- The .o file must have a later modification date + -- than the source file (else we wouldn't get Nothing) + -- but we touch it anyway, to keep 'make' happy (we think). + return (RealPhase StopLn, o_file) + HscUpdateBoot _ _ -> + do -- In the case of hs-boot files, generate a dummy .o-boot + -- stamp file for the benefit of Make + liftIO $ touchObjectFile dflags o_file + return (RealPhase StopLn, o_file) + HscUpdateSig _ _ -> + do -- We need to create a REAL but empty .o file + -- because we are going to attempt to put it in a library + PipeState{hsc_env=hsc_env'} <- getPipeState + let input_fn = expectJust "runPhase" (ml_hs_file location) + basename = dropExtension input_fn + liftIO $ compileEmptyStub dflags hsc_env' basename location mod_name + return (RealPhase StopLn, o_file) + HscRecomp { hscs_guts = cgguts, + hscs_mod_location = mod_location, + hscs_mod_details = mod_details, + hscs_partial_iface = partial_iface, + hscs_old_iface_hash = mb_old_iface_hash, + hscs_iface_dflags = iface_dflags } + -> do output_fn <- phaseOutputFilename next_phase + + PipeState{hsc_env=hsc_env'} <- getPipeState + + (outputFilename, mStub, foreign_files, caf_infos) <- liftIO $ + hscGenHardCode hsc_env' cgguts mod_location output_fn + + final_iface <- liftIO (mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface (Just caf_infos)) + let final_mod_details = {-# SCC updateModDetailsCafInfos #-} + updateModDetailsCafInfos caf_infos mod_details + setIface final_iface final_mod_details + + -- See Note [Writing interface files] + let if_dflags = dflags `gopt_unset` Opt_BuildDynamicToo + liftIO $ hscMaybeWriteIface if_dflags final_iface mb_old_iface_hash mod_location + + stub_o <- liftIO (mapM (compileStub hsc_env') mStub) + foreign_os <- liftIO $ + mapM (uncurry (compileForeign hsc_env')) foreign_files + setForeignOs (maybe [] return stub_o ++ foreign_os) + + return (RealPhase next_phase, outputFilename) + +----------------------------------------------------------------------------- +-- Cmm phase + +runPhase (RealPhase CmmCpp) input_fn dflags + = do output_fn <- phaseOutputFilename Cmm + liftIO $ doCpp dflags False{-not raw-} + input_fn output_fn + return (RealPhase Cmm, output_fn) + +runPhase (RealPhase Cmm) input_fn dflags + = do let hsc_lang = hscTarget dflags + let next_phase = hscPostBackendPhase HsSrcFile hsc_lang + output_fn <- phaseOutputFilename next_phase + PipeState{hsc_env} <- getPipeState + liftIO $ hscCompileCmmFile hsc_env input_fn output_fn + return (RealPhase next_phase, output_fn) + +----------------------------------------------------------------------------- +-- Cc phase + +runPhase (RealPhase cc_phase) input_fn dflags + | any (cc_phase `eqPhase`) [Cc, Ccxx, HCc, Cobjc, Cobjcxx] + = do + let platform = targetPlatform dflags + hcc = cc_phase `eqPhase` HCc + + let cmdline_include_paths = includePaths dflags + + -- HC files have the dependent packages stamped into them + pkgs <- if hcc then liftIO $ getHCFilePackages input_fn else return [] + + -- add package include paths even if we're just compiling .c + -- 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_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 + + -- pass -D or -optP to preprocessor when compiling foreign C files + -- (#16737). Doing it in this way is simpler and also enable the C + -- compiler to perform preprocessing and parsing in a single pass, + -- but it may introduce inconsistency if a different pgm_P is specified. + let more_preprocessor_opts = concat + [ ["-Xpreprocessor", i] + | not hcc + , i <- getOpts dflags opt_P + ] + + let gcc_extra_viac_flags = extraGccViaCFlags dflags + let pic_c_flags = picCCOpts dflags + + let verbFlags = getVerbFlags dflags + + -- cc-options are not passed when compiling .hc files. Our + -- hc code doesn't not #include any header files anyway, so these + -- options aren't necessary. + pkg_extra_cc_opts <- liftIO $ + if hcc + then return [] + else getPackageExtraCcOpts dflags pkgs + + framework_paths <- + if platformUsesFrameworks platform + then do pkgFrameworkPaths <- liftIO $ getPackageFrameworkPath dflags pkgs + let cmdlineFrameworkPaths = frameworkPaths dflags + return $ map ("-F"++) + (cmdlineFrameworkPaths ++ pkgFrameworkPaths) + else return [] + + let cc_opt | optLevel dflags >= 2 = [ "-O2" ] + | optLevel dflags >= 1 = [ "-O" ] + | otherwise = [] + + -- Decide next phase + let next_phase = As False + output_fn <- phaseOutputFilename next_phase + + let + more_hcc_opts = + -- on x86 the floating point regs have greater precision + -- than a double, which leads to unpredictable results. + -- By default, we turn this off with -ffloat-store unless + -- the user specified -fexcess-precision. + (if platformArch platform == ArchX86 && + not (gopt Opt_ExcessPrecision dflags) + then [ "-ffloat-store" ] + else []) ++ + + -- gcc's -fstrict-aliasing allows two accesses to memory + -- to be considered non-aliasing if they have different types. + -- This interacts badly with the C code we generate, which is + -- very weakly typed, being derived from C--. + ["-fno-strict-aliasing"] + + ghcVersionH <- liftIO $ getGhcVersionPathName dflags + + liftIO $ SysTools.runCc (phaseForeignLanguage cc_phase) dflags ( + [ SysTools.FileOption "" input_fn + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ] + ++ map SysTools.Option ( + pic_c_flags + + -- Stub files generated for foreign exports references the runIO_closure + -- and runNonIO_closure symbols, which are defined in the base package. + -- These symbols are imported into the stub.c file via RtsAPI.h, and the + -- way we do the import depends on whether we're currently compiling + -- the base package or not. + ++ (if platformOS platform == OSMinGW32 && + thisPackage dflags == baseUnitId + then [ "-DCOMPILING_BASE_PACKAGE" ] + else []) + + -- We only support SparcV9 and better because V8 lacks an atomic CAS + -- instruction. Note that the user can still override this + -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag + -- regardless of the ordering. + -- + -- This is a temporary hack. See #2872, commit + -- 5bd3072ac30216a505151601884ac88bf404c9f2 + ++ (if platformArch platform == ArchSPARC + then ["-mcpu=v9"] + else []) + + -- GCC 4.6+ doesn't like -Wimplicit when compiling C++. + ++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx) + then ["-Wimplicit"] + else []) + + ++ (if hcc + then gcc_extra_viac_flags ++ more_hcc_opts + else []) + ++ verbFlags + ++ [ "-S" ] + ++ cc_opt + ++ [ "-include", ghcVersionH ] + ++ framework_paths + ++ include_paths + ++ more_preprocessor_opts + ++ pkg_extra_cc_opts + )) + + return (RealPhase next_phase, output_fn) + +----------------------------------------------------------------------------- +-- As, SpitAs phase : Assembler + +-- This is for calling the assembler on a regular assembly file +runPhase (RealPhase (As with_cpp)) input_fn dflags + = do + -- LLVM from version 3.0 onwards doesn't support the OS X system + -- assembler, so we use clang as the assembler instead. (#5636) + let as_prog | hscTarget dflags == HscLlvm && + platformOS (targetPlatform dflags) == OSDarwin + = SysTools.runClang + | otherwise = SysTools.runAs + + let cmdline_include_paths = includePaths dflags + let pic_c_flags = picCCOpts dflags + + next_phase <- maybeMergeForeign + output_fn <- phaseOutputFilename next_phase + + -- we create directories for the object file, because it + -- might be a hierarchical module. + 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 $ do + withAtomicRename outputFilename $ \temp_outputFilename -> do + as_prog + dflags + (local_includes ++ global_includes + -- See Note [-fPIC for assembler] + ++ map SysTools.Option pic_c_flags + -- See Note [Produce big objects on Windows] + ++ [ SysTools.Option "-Wa,-mbig-obj" + | platformOS (targetPlatform dflags) == OSMinGW32 + , not $ target32Bit (targetPlatform dflags) + ] + + -- We only support SparcV9 and better because V8 lacks an atomic CAS + -- instruction so we have to make sure that the assembler accepts the + -- instruction set. Note that the user can still override this + -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag + -- regardless of the ordering. + -- + -- This is a temporary hack. + ++ (if platformArch (targetPlatform dflags) == ArchSPARC + then [SysTools.Option "-mcpu=v9"] + else []) + ++ (if any (ccInfo ==) [Clang, AppleClang, AppleClang51] + then [SysTools.Option "-Qunused-arguments"] + else []) + ++ [ SysTools.Option "-x" + , if with_cpp + then SysTools.Option "assembler-with-cpp" + else SysTools.Option "assembler" + , SysTools.Option "-c" + , SysTools.FileOption "" inputFilename + , SysTools.Option "-o" + , SysTools.FileOption "" temp_outputFilename + ]) + + liftIO $ debugTraceMsg dflags 4 (text "Running the assembler") + runAssembler input_fn output_fn + + return (RealPhase next_phase, output_fn) + + +----------------------------------------------------------------------------- +-- LlvmOpt phase +runPhase (RealPhase LlvmOpt) input_fn dflags + = do + output_fn <- phaseOutputFilename LlvmLlc + + liftIO $ SysTools.runLlvmOpt dflags + ( 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 + optIdx = max 0 $ min 2 $ optLevel dflags -- ensure we're in [0,2] + llvmOpts = case lookup optIdx $ llvmPasses $ llvmConfig 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 + next_phase <- if | fastLlvmPipeline dflags -> maybeMergeForeign + -- hidden debugging flag '-dno-llvm-mangler' to skip mangling + | gopt Opt_NoLlvmMangler dflags -> return (As False) + | otherwise -> return LlvmMangle + + output_fn <- phaseOutputFilename next_phase + + liftIO $ SysTools.runLlvmLlc dflags + ( optFlag + ++ defaultOptions + ++ [ SysTools.FileOption "" input_fn + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ] + ) + + return (RealPhase next_phase, output_fn) + where + -- 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 . concatMap words . snd + $ unzip (llvmOptions dflags) + + +----------------------------------------------------------------------------- +-- LlvmMangle phase + +runPhase (RealPhase LlvmMangle) input_fn dflags + = do + let next_phase = As False + output_fn <- phaseOutputFilename next_phase + liftIO $ llvmFixupAsm dflags input_fn output_fn + return (RealPhase next_phase, output_fn) + +----------------------------------------------------------------------------- +-- merge in stub objects + +runPhase (RealPhase MergeForeign) input_fn dflags + = do + PipeState{foreign_os} <- getPipeState + output_fn <- phaseOutputFilename StopLn + liftIO $ createDirectoryIfMissing True (takeDirectory output_fn) + if null foreign_os + then panic "runPhase(MergeForeign): no foreign objects" + else do + liftIO $ joinObjectFiles dflags (input_fn : foreign_os) output_fn + return (RealPhase StopLn, output_fn) + +-- warning suppression +runPhase (RealPhase other) _input_fn _dflags = + panic ("runPhase: don't know how to run phase " ++ show other) + +maybeMergeForeign :: CompPipeline Phase +maybeMergeForeign + = do + PipeState{foreign_os} <- getPipeState + if null foreign_os then return StopLn else return MergeForeign + +getLocation :: HscSource -> ModuleName -> CompPipeline ModLocation +getLocation src_flavour mod_name = do + dflags <- getDynFlags + + PipeEnv{ src_basename=basename, + src_suffix=suff } <- getPipeEnv + PipeState { maybe_loc=maybe_loc} <- getPipeState + case maybe_loc of + -- Build a ModLocation to pass to hscMain. + -- The source filename is rather irrelevant by now, but it's used + -- by hscMain for messages. hscMain also needs + -- the .hi and .o filenames. If we already have a ModLocation + -- then simply update the extensions of the interface and object + -- files to match the DynFlags, otherwise use the logic in Finder. + Just l -> return $ l + { ml_hs_file = Just $ basename <.> suff + , ml_hi_file = ml_hi_file l -<.> hiSuf dflags + , ml_obj_file = ml_obj_file l -<.> objectSuf dflags + } + _ -> do + location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff + + -- Boot-ify it if necessary + let location2 + | HsBootFile <- src_flavour = addBootSuffixLocnOut location1 + | otherwise = location1 + + + -- Take -ohi into account if present + -- This can't be done in mkHomeModuleLocation because + -- it only applies to the module being compiles + let ohi = outputHi dflags + location3 | Just fn <- ohi = location2{ ml_hi_file = fn } + | otherwise = location2 + + -- Take -o into account if present + -- Very like -ohi, but we must *only* do this if we aren't linking + -- (If we're linking then the -o applies to the linked thing, not to + -- the object file for one module.) + -- Note the nasty duplication with the same computation in compileFile + -- above + let expl_o_file = outputFile dflags + location4 | Just ofile <- expl_o_file + , isNoLink (ghcLink dflags) + = location3 { ml_obj_file = ofile } + | otherwise = location3 + return location4 + +----------------------------------------------------------------------------- +-- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file + +getHCFilePackages :: FilePath -> IO [InstalledUnitId] +getHCFilePackages filename = + Exception.bracket (openFile filename ReadMode) hClose $ \h -> do + l <- hGetLine h + case l of + '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest -> + return (map stringToInstalledUnitId (words rest)) + _other -> + return [] + +----------------------------------------------------------------------------- +-- Static linking, of .o files + +-- The list of packages passed to link is the list of packages on +-- which this program depends, as discovered by the compilation +-- manager. It is combined with the list of packages that the user +-- specifies on the command line with -package flags. +-- +-- In one-shot linking mode, we can't discover the package +-- dependencies (because we haven't actually done any compilation or +-- read any interface files), so the user must explicitly specify all +-- the packages. + +{- +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 path with commas +as separate options. +Buck, the build system, produces paths with commas in them. + +-Xlinker doesn't have this disadvantage and as far as I can tell +it is supported by both gcc and clang. Anecdotally nvcc supports +-Xlinker, but not -Wl. +-} + +linkBinary :: DynFlags -> [FilePath] -> [InstalledUnitId] -> IO () +linkBinary = linkBinary' False + +linkBinary' :: Bool -> DynFlags -> [FilePath] -> [InstalledUnitId] -> IO () +linkBinary' staticLink dflags o_files dep_packages = do + let platform = targetPlatform dflags + toolSettings' = toolSettings dflags + verbFlags = getVerbFlags dflags + output_fn = exeFileName staticLink dflags + + -- get the full list of packages to link with, by combining the + -- explicit packages with the auto packages and all of their + -- dependencies, and eliminating duplicates. + + full_output_fn <- if isAbsolute output_fn + then return output_fn + else do d <- getCurrentDirectory + return $ normalise (d </> output_fn) + pkg_lib_paths <- getPackageLibraryPath dflags dep_packages + let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths + get_pkg_lib_path_opts l + | osElfTarget (platformOS platform) && + dynLibLoader dflags == SystemDependent && + WayDyn `elem` ways dflags + = let libpath = if gopt Opt_RelativeDynlibPaths dflags + then "$ORIGIN" </> + (l `makeRelativeTo` full_output_fn) + else l + -- See Note [-Xlinker -rpath vs -Wl,-rpath] + rpath = if gopt Opt_RPath dflags + then ["-Xlinker", "-rpath", "-Xlinker", libpath] + else [] + -- Solaris 11's linker does not support -rpath-link option. It silently + -- ignores it and then complains about next option which is -l<some + -- dir> as being a directory and not expected object file, E.g + -- ld: elf error: file + -- /tmp/ghc-src/libraries/base/dist-install/build: + -- elf_begin: I/O error: region read: Is a directory + rpathlink = if (platformOS platform) == OSSolaris2 + then [] + else ["-Xlinker", "-rpath-link", "-Xlinker", l] + in ["-L" ++ l] ++ rpathlink ++ rpath + | osMachOTarget (platformOS platform) && + dynLibLoader dflags == SystemDependent && + WayDyn `elem` ways dflags && + gopt Opt_RPath dflags + = let libpath = if gopt Opt_RelativeDynlibPaths dflags + then "@loader_path" </> + (l `makeRelativeTo` full_output_fn) + else l + 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 = [] + | otherwise = if osSubsectionsViaSymbols (platformOS platform) + then ["-Wl,-dead_strip"] + else [] + let lib_paths = libraryPaths dflags + let lib_path_opts = map ("-L"++) lib_paths + + extraLinkObj <- mkExtraObjToLinkIntoBinary dflags + noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_packages + + let + (pre_hs_libs, post_hs_libs) + | gopt Opt_WholeArchiveHsLibs dflags + = if platformOS platform == OSDarwin + then (["-Wl,-all_load"], []) + -- OS X does not have a flag to turn off -all_load + else (["-Wl,--whole-archive"], ["-Wl,--no-whole-archive"]) + | otherwise + = ([],[]) + + pkg_link_opts <- do + (package_hs_libs, extra_libs, other_flags) <- getPackageLinkOpts dflags dep_packages + return $ if staticLink + then package_hs_libs -- If building an executable really means making a static + -- library (e.g. iOS), then we only keep the -l options for + -- HS packages, because libtool doesn't accept other options. + -- In the case of iOS these need to be added by hand to the + -- final link in Xcode. + else other_flags ++ dead_strip + ++ pre_hs_libs ++ package_hs_libs ++ post_hs_libs + ++ extra_libs + -- -Wl,-u,<sym> contained in other_flags + -- needs to be put before -l<package>, + -- otherwise Solaris linker fails linking + -- a binary with unresolved symbols in RTS + -- which are defined in base package + -- the reason for this is a note in ld(1) about + -- '-u' option: "The placement of this option + -- on the command line is significant. + -- This option must be placed before the library + -- that defines the symbol." + + -- frameworks + pkg_framework_opts <- getPkgFrameworkOpts dflags platform dep_packages + let framework_opts = getFrameworkOpts dflags platform + + -- probably _stub.o files + let extra_ld_inputs = ldInputs dflags + + rc_objs <- maybeCreateManifest dflags output_fn + + let link = if staticLink + then SysTools.runLibtool + else SysTools.runLink + link dflags ( + map SysTools.Option verbFlags + ++ [ SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ] + ++ libmLinkOpts + ++ map SysTools.Option ( + [] + + -- 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". + ++ (if platformOS platform == OSMinGW32 + then ["-Wl,--enable-auto-import"] + else []) + + -- '-no_compact_unwind' + -- C++/Objective-C exceptions cannot use optimised + -- stack unwinding code. The optimised form is the + -- default in Xcode 4 on at least x86_64, and + -- without this flag we're also seeing warnings + -- like + -- ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog + -- on x86. + ++ (if toolSettings_ldSupportsCompactUnwind toolSettings' && + not staticLink && + (platformOS platform == OSDarwin) && + case platformArch platform of + ArchX86 -> True + ArchX86_64 -> True + ArchARM {} -> True + ArchARM64 -> True + _ -> False + then ["-Wl,-no_compact_unwind"] + else []) + + -- '-Wl,-read_only_relocs,suppress' + -- ld gives loads of warnings like: + -- ld: warning: text reloc in _base_GHCziArr_unsafeArray_info to _base_GHCziArr_unsafeArray_closure + -- when linking any program. We're not sure + -- whether this is something we ought to fix, but + -- for now this flags silences them. + ++ (if platformOS platform == OSDarwin && + platformArch platform == ArchX86 && + not staticLink + then ["-Wl,-read_only_relocs,suppress"] + else []) + + ++ (if toolSettings_ldIsGnuLd toolSettings' && + not (gopt Opt_WholeArchiveHsLibs dflags) + then ["-Wl,--gc-sections"] + else []) + + ++ o_files + ++ lib_path_opts) + ++ extra_ld_inputs + ++ map SysTools.Option ( + rc_objs + ++ framework_opts + ++ pkg_lib_path_opts + ++ extraLinkObj:noteLinkObjs + ++ pkg_link_opts + ++ pkg_framework_opts + ++ (if platformOS platform == OSDarwin + then [ "-Wl,-dead_strip_dylibs" ] + else []) + )) + +exeFileName :: Bool -> DynFlags -> FilePath +exeFileName staticLink dflags + | Just s <- outputFile dflags = + case platformOS (targetPlatform dflags) of + OSMinGW32 -> s <?.> "exe" + _ -> if staticLink + then s <?.> "a" + else s + | otherwise = + if platformOS (targetPlatform dflags) == OSMinGW32 + then "main.exe" + else if staticLink + then "liba.a" + else "a.out" + where s <?.> ext | null (takeExtension s) = s <.> ext + | otherwise = s + +maybeCreateManifest + :: DynFlags + -> FilePath -- filename of executable + -> IO [FilePath] -- extra objects to embed, maybe +maybeCreateManifest dflags exe_filename + | platformOS (targetPlatform dflags) == OSMinGW32 && + gopt Opt_GenManifest dflags + = do let manifest_filename = exe_filename <.> "manifest" + + writeFile manifest_filename $ + "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"++ + " <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"++ + " <assemblyIdentity version=\"1.0.0.0\"\n"++ + " processorArchitecture=\"X86\"\n"++ + " name=\"" ++ dropExtension exe_filename ++ "\"\n"++ + " type=\"win32\"/>\n\n"++ + " <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"++ + " <security>\n"++ + " <requestedPrivileges>\n"++ + " <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n"++ + " </requestedPrivileges>\n"++ + " </security>\n"++ + " </trustInfo>\n"++ + "</assembly>\n" + + -- Windows will find the manifest file if it is named + -- foo.exe.manifest. However, for extra robustness, and so that + -- we can move the binary around, we can embed the manifest in + -- the binary itself using windres: + if not (gopt Opt_EmbedManifest dflags) then return [] else do + + rc_filename <- newTempName dflags TFL_CurrentModule "rc" + rc_obj_filename <- + newTempName dflags TFL_GhcSession (objectSuf dflags) + + writeFile rc_filename $ + "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n" + -- magic numbers :-) + -- show is a bit hackish above, but we need to escape the + -- backslashes in the path. + + runWindres dflags $ map SysTools.Option $ + ["--input="++rc_filename, + "--output="++rc_obj_filename, + "--output-format=coff"] + -- no FileOptions here: windres doesn't like seeing + -- backslashes, apparently + + removeFile manifest_filename + + return [rc_obj_filename] + | otherwise = return [] + + +linkDynLibCheck :: DynFlags -> [String] -> [InstalledUnitId] -> IO () +linkDynLibCheck dflags o_files dep_packages + = do + when (haveRtsOptsFlags dflags) $ do + putLogMsg dflags NoReason SevInfo noSrcSpan + (defaultUserStyle dflags) + (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$ + text " Call hs_init_ghc() from your main() function to set these options.") + + linkDynLib 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 <- concatMapM (collectArchives dflags) pkg_cfgs + + ar <- foldl mappend + <$> (Archive <$> mapM loadObj modules) + <*> mapM loadAr archives + + if toolSettings_ldIsGnuLd (toolSettings 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 + +doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO () +doCpp dflags raw input_fn output_fn = do + let hscpp_opts = picPOpts dflags + let cmdline_include_paths = includePaths dflags + + pkg_include_dirs <- getPackageIncludePath dflags [] + 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 + + let cpp_prog args | raw = SysTools.runCpp dflags args + | otherwise = SysTools.runCc Nothing dflags (SysTools.Option "-E" : args) + + let targetArch = stringEncodeArch $ platformArch $ targetPlatform dflags + targetOS = stringEncodeOS $ platformOS $ targetPlatform dflags + let target_defs = + [ "-D" ++ HOST_OS ++ "_BUILD_OS", + "-D" ++ HOST_ARCH ++ "_BUILD_ARCH", + "-D" ++ targetOS ++ "_HOST_OS", + "-D" ++ targetArch ++ "_HOST_ARCH" ] + -- remember, in code we *compile*, the HOST is the same our TARGET, + -- and BUILD is the same as our HOST. + + let sse_defs = + [ "-D__SSE__" | isSseEnabled dflags ] ++ + [ "-D__SSE2__" | isSse2Enabled dflags ] ++ + [ "-D__SSE4_2__" | isSse4_2Enabled dflags ] + + let avx_defs = + [ "-D__AVX__" | isAvxEnabled dflags ] ++ + [ "-D__AVX2__" | isAvx2Enabled dflags ] ++ + [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++ + [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++ + [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++ + [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ] + + backend_defs <- getBackendDefs dflags + + let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ] + -- Default CPP defines in Haskell source + ghcVersionH <- getGhcVersionPathName dflags + let hsSourceCppOpts = [ "-include", ghcVersionH ] + + -- MIN_VERSION macros + let uids = explicitPackages (pkgState dflags) + pkgs = catMaybes (map (lookupUnit dflags) uids) + mb_macro_include <- + if not (null pkgs) && gopt Opt_VersionMacros dflags + then do macro_stub <- newTempName dflags TFL_CurrentModule "h" + writeFile macro_stub (generatePackageVersionMacros pkgs) + -- Include version macros for every *exposed* package. + -- Without -hide-all-packages and with a package database + -- size of 1000 packages, it takes cpp an estimated 2 + -- milliseconds to process this file. See #10970 + -- comment 8. + return [SysTools.FileOption "-include" macro_stub] + else return [] + + cpp_prog ( map SysTools.Option verbFlags + ++ map SysTools.Option include_paths + ++ map SysTools.Option hsSourceCppOpts + ++ map SysTools.Option target_defs + ++ map SysTools.Option backend_defs + ++ map SysTools.Option th_defs + ++ map SysTools.Option hscpp_opts + ++ map SysTools.Option sse_defs + ++ map SysTools.Option avx_defs + ++ mb_macro_include + -- Set the language mode to assembler-with-cpp when preprocessing. This + -- alleviates some of the C99 macro rules relating to whitespace and the hash + -- operator, which we tend to abuse. Clang in particular is not very happy + -- about this. + ++ [ SysTools.Option "-x" + , SysTools.Option "assembler-with-cpp" + , SysTools.Option input_fn + -- We hackily use Option instead of FileOption here, so that the file + -- name is not back-slashed on Windows. cpp is capable of + -- dealing with / in filenames, so it works fine. Furthermore + -- if we put in backslashes, cpp outputs #line directives + -- with *double* backslashes. And that in turn means that + -- our error messages get double backslashes in them. + -- In due course we should arrange that the lexer deals + -- with these \\ escapes properly. + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ]) + +getBackendDefs :: DynFlags -> IO [String] +getBackendDefs dflags | hscTarget dflags == HscLlvm = do + llvmVer <- figureLlvmVersion dflags + return $ case fmap llvmVersionList llvmVer of + Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ] + Just (m:n:_) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ] + _ -> [] + where + format (major, minor) + | minor >= 100 = error "getBackendDefs: Unsupported minor version" + | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int + +getBackendDefs _ = + return [] + +-- --------------------------------------------------------------------------- +-- Macros (cribbed from Cabal) + +generatePackageVersionMacros :: [UnitInfo] -> String +generatePackageVersionMacros pkgs = concat + -- Do not add any C-style comments. See #3389. + [ generateMacros "" pkgname version + | pkg <- pkgs + , let version = packageVersion pkg + pkgname = map fixchar (packageNameString pkg) + ] + +fixchar :: Char -> Char +fixchar '-' = '_' +fixchar c = c + +generateMacros :: String -> String -> Version -> String +generateMacros prefix name version = + concat + ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n" + ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n" + ," (major1) < ",major1," || \\\n" + ," (major1) == ",major1," && (major2) < ",major2," || \\\n" + ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" + ,"\n\n" + ] + where + (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) + +-- --------------------------------------------------------------------------- +-- join object files into a single relocatable object file, using ld -r + +{- +Note [Produce big objects on Windows] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The Windows Portable Executable object format has a limit of 32k sections, which +we tend to blow through pretty easily. Thankfully, there is a "big object" +extension, which raises this limit to 2^32. However, it must be explicitly +enabled in the toolchain: + + * the assembler accepts the -mbig-obj flag, which causes it to produce a + bigobj-enabled COFF object. + + * the linker accepts the --oformat pe-bigobj-x86-64 flag. Despite what the name + suggests, this tells the linker to produce a bigobj-enabled COFF object, no a + PE executable. + +We must enable bigobj output in a few places: + + * When merging object files (GHC.Driver.Pipeline.joinObjectFiles) + + * When assembling (GHC.Driver.Pipeline.runPhase (RealPhase As ...)) + +Unfortunately the big object format is not supported on 32-bit targets so +none of this can be used in that case. +-} + +joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO () +joinObjectFiles dflags o_files output_fn = do + let toolSettings' = toolSettings dflags + ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings' + osInfo = platformOS (targetPlatform dflags) + ld_r args cc = SysTools.runLink dflags ([ + SysTools.Option "-nostdlib", + SysTools.Option "-Wl,-r" + ] + -- See Note [No PIE while linking] in DynFlags + ++ (if toolSettings_ccSupportsNoPie toolSettings' + then [SysTools.Option "-no-pie"] + else []) + + ++ (if any (cc ==) [Clang, AppleClang, AppleClang51] + then [] + else [SysTools.Option "-nodefaultlibs"]) + ++ (if osInfo == OSFreeBSD + then [SysTools.Option "-L/usr/lib"] + else []) + -- gcc on sparc sets -Wl,--relax implicitly, but + -- -r and --relax are incompatible for ld, so + -- disable --relax explicitly. + ++ (if platformArch (targetPlatform dflags) + `elem` [ArchSPARC, ArchSPARC64] + && ldIsGnuLd + then [SysTools.Option "-Wl,-no-relax"] + else []) + -- See Note [Produce big objects on Windows] + ++ [ SysTools.Option "-Wl,--oformat,pe-bigobj-x86-64" + | OSMinGW32 == osInfo + , not $ target32Bit (targetPlatform dflags) + ] + ++ map SysTools.Option ld_build_id + ++ [ SysTools.Option "-o", + SysTools.FileOption "" output_fn ] + ++ args) + + -- suppress the generation of the .note.gnu.build-id section, + -- which we don't need and sometimes causes ld to emit a + -- warning: + ld_build_id | toolSettings_ldSupportsBuildId toolSettings' = ["-Wl,--build-id=none"] + | otherwise = [] + + ccInfo <- getCompilerInfo dflags + if ldIsGnuLd + then do + script <- newTempName dflags TFL_CurrentModule "ldscript" + cwd <- getCurrentDirectory + let o_files_abs = map (\x -> "\"" ++ (cwd </> x) ++ "\"") o_files + writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")" + ld_r [SysTools.FileOption "" script] ccInfo + else if toolSettings_ldSupportsFilelist toolSettings' + then do + filelist <- newTempName dflags TFL_CurrentModule "filelist" + writeFile filelist $ unlines o_files + ld_r [SysTools.Option "-Wl,-filelist", + SysTools.FileOption "-Wl," filelist] ccInfo + else do + ld_r (map (SysTools.FileOption "") o_files) ccInfo + +-- ----------------------------------------------------------------------------- +-- Misc. + +writeInterfaceOnlyMode :: DynFlags -> Bool +writeInterfaceOnlyMode dflags = + gopt Opt_WriteInterface dflags && + HscNothing == hscTarget dflags + +-- | Figure out if a source file was modified after an output file (or if we +-- anyways need to consider the source file modified since the output is gone). +sourceModified :: FilePath -- ^ destination file we are looking for + -> UTCTime -- ^ last time of modification of source file + -> IO Bool -- ^ do we need to regenerate the output? +sourceModified dest_file src_timestamp = do + dest_file_exists <- doesFileExist dest_file + if not dest_file_exists + then return True -- Need to recompile + else do t2 <- getModificationUTCTime dest_file + return (t2 <= src_timestamp) + +-- | What phase to run after one of the backend code generators has run +hscPostBackendPhase :: HscSource -> HscTarget -> Phase +hscPostBackendPhase HsBootFile _ = StopLn +hscPostBackendPhase HsigFile _ = StopLn +hscPostBackendPhase _ hsc_lang = + case hsc_lang of + HscC -> HCc + HscAsm -> As False + HscLlvm -> LlvmOpt + HscNothing -> StopLn + HscInterpreted -> StopLn + +touchObjectFile :: DynFlags -> FilePath -> IO () +touchObjectFile dflags path = do + createDirectoryIfMissing True $ takeDirectory path + SysTools.touch dflags "Touching object file" path + +-- | Find out path to @ghcversion.h@ file +getGhcVersionPathName :: DynFlags -> IO FilePath +getGhcVersionPathName dflags = do + candidates <- case ghcVersionFile dflags of + Just path -> return [path] + Nothing -> (map (</> "ghcversion.h")) <$> + (getPackageIncludePath dflags [toInstalledUnitId rtsUnitId]) + + found <- filterM doesFileExist candidates + case found of + [] -> throwGhcExceptionIO (InstallationError + ("ghcversion.h missing; tried: " + ++ intercalate ", " candidates)) + (x:_) -> return x + +-- Note [-fPIC for assembler] +-- When compiling .c source file GHC's driver pipeline basically +-- does the following two things: +-- 1. ${CC} -S 'PIC_CFLAGS' source.c +-- 2. ${CC} -x assembler -c 'PIC_CFLAGS' source.S +-- +-- Why do we need to pass 'PIC_CFLAGS' both to C compiler and assembler? +-- Because on some architectures (at least sparc32) assembler also chooses +-- the relocation type! +-- Consider the following C module: +-- +-- /* pic-sample.c */ +-- int v; +-- void set_v (int n) { v = n; } +-- int get_v (void) { return v; } +-- +-- $ gcc -S -fPIC pic-sample.c +-- $ gcc -c pic-sample.s -o pic-sample.no-pic.o # incorrect binary +-- $ gcc -c -fPIC pic-sample.s -o pic-sample.pic.o # correct binary +-- +-- $ objdump -r -d pic-sample.pic.o > pic-sample.pic.o.od +-- $ objdump -r -d pic-sample.no-pic.o > pic-sample.no-pic.o.od +-- $ diff -u pic-sample.pic.o.od pic-sample.no-pic.o.od +-- +-- Most of architectures won't show any difference in this test, but on sparc32 +-- the following assembly snippet: +-- +-- sethi %hi(_GLOBAL_OFFSET_TABLE_-8), %l7 +-- +-- generates two kinds or relocations, only 'R_SPARC_PC22' is correct: +-- +-- 3c: 2f 00 00 00 sethi %hi(0), %l7 +-- - 3c: R_SPARC_PC22 _GLOBAL_OFFSET_TABLE_-0x8 +-- + 3c: R_SPARC_HI22 _GLOBAL_OFFSET_TABLE_-0x8 + +{- Note [Don't normalise input filenames] + +Summary + We used to normalise input filenames when starting the unlit phase. This + broke hpc in `--make` mode with imported literate modules (#2991). + +Introduction + 1) --main + When compiling a module with --main, GHC scans its imports to find out which + other modules it needs to compile too. It turns out that there is a small + difference between saying `ghc --make A.hs`, when `A` imports `B`, and + specifying both modules on the command line with `ghc --make A.hs B.hs`. In + the former case, the filename for B is inferred to be './B.hs' instead of + 'B.hs'. + + 2) unlit + When GHC compiles a literate haskell file, the source code first needs to go + through unlit, which turns it into normal Haskell source code. At the start + of the unlit phase, in `Driver.Pipeline.runPhase`, we call unlit with the + option `-h` and the name of the original file. We used to normalise this + filename using System.FilePath.normalise, which among other things removes + an initial './'. unlit then uses that filename in #line directives that it + inserts in the transformed source code. + + 3) SrcSpan + A SrcSpan represents a portion of a source code file. It has fields + linenumber, start column, end column, and also a reference to the file it + originated from. The SrcSpans for a literate haskell file refer to the + filename that was passed to unlit -h. + + 4) -fhpc + At some point during compilation with -fhpc, in the function + `GHC.HsToCore.Coverage.isGoodTickSrcSpan`, we compare the filename that a + `SrcSpan` refers to with the name of the file we are currently compiling. + For some reason I don't yet understand, they can sometimes legitimally be + different, and then hpc ignores that SrcSpan. + +Problem + When running `ghc --make -fhpc A.hs`, where `A.hs` imports the literate + module `B.lhs`, `B` is inferred to be in the file `./B.lhs` (1). At the + start of the unlit phase, the name `./B.lhs` is normalised to `B.lhs` (2). + Therefore the SrcSpans of `B` refer to the file `B.lhs` (3), but we are + still compiling `./B.lhs`. Hpc thinks these two filenames are different (4), + doesn't include ticks for B, and we have unhappy customers (#2991). + +Solution + Do not normalise `input_fn` when starting the unlit phase. + +Alternative solution + Another option would be to not compare the two filenames on equality, but to + use System.FilePath.equalFilePath. That function first normalises its + arguments. The problem is that by the time we need to do the comparison, the + filenames have been turned into FastStrings, probably for performance + reasons, so System.FilePath.equalFilePath can not be used directly. + +Archeology + The call to `normalise` was added in a commit called "Fix slash + direction on Windows with the new filePath code" (c9b6b5e8). The problem + that commit was addressing has since been solved in a different manner, in a + commit called "Fix the filename passed to unlit" (1eedbc6b). So the + `normalise` is no longer necessary. +-} diff --git a/compiler/GHC/Driver/Pipeline/Monad.hs b/compiler/GHC/Driver/Pipeline/Monad.hs new file mode 100644 index 0000000000..5831f923ea --- /dev/null +++ b/compiler/GHC/Driver/Pipeline/Monad.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE NamedFieldPuns #-} +-- | The CompPipeline monad and associated ops +-- +-- Defined in separate module so that it can safely be imported from Hooks +module GHC.Driver.Pipeline.Monad ( + CompPipeline(..), evalP + , PhasePlus(..) + , PipeEnv(..), PipeState(..), PipelineOutput(..) + , getPipeEnv, getPipeState, setDynFlags, setModLocation, setForeignOs, setIface + , pipeStateDynFlags, pipeStateModIface + ) where + +import GhcPrelude + +import MonadUtils +import Outputable +import GHC.Driver.Session +import GHC.Driver.Phases +import GHC.Driver.Types +import Module +import FileCleanup (TempFileLifetime) + +import Control.Monad + +newtype CompPipeline a = P { unP :: PipeEnv -> PipeState -> IO (PipeState, a) } + deriving (Functor) + +evalP :: CompPipeline a -> PipeEnv -> PipeState -> IO (PipeState, a) +evalP (P f) env st = f env st + +instance Applicative CompPipeline where + pure a = P $ \_env state -> return (state, a) + (<*>) = ap + +instance Monad CompPipeline where + P m >>= k = P $ \env state -> do (state',a) <- m env state + unP (k a) env state' + +instance MonadIO CompPipeline where + liftIO m = P $ \_env state -> do a <- m; return (state, a) + +data PhasePlus = RealPhase Phase + | HscOut HscSource ModuleName HscStatus + +instance Outputable PhasePlus where + ppr (RealPhase p) = ppr p + ppr (HscOut {}) = text "HscOut" + +-- ----------------------------------------------------------------------------- +-- The pipeline uses a monad to carry around various bits of information + +-- PipeEnv: invariant information passed down +data PipeEnv = PipeEnv { + stop_phase :: Phase, -- ^ Stop just before this phase + src_filename :: String, -- ^ basename of original input source + src_basename :: String, -- ^ basename of original input source + src_suffix :: String, -- ^ its extension + output_spec :: PipelineOutput -- ^ says where to put the pipeline output + } + +-- PipeState: information that might change during a pipeline run +data PipeState = PipeState { + hsc_env :: HscEnv, + -- ^ only the DynFlags change in the HscEnv. The DynFlags change + -- at various points, for example when we read the OPTIONS_GHC + -- pragmas in the Cpp phase. + maybe_loc :: Maybe ModLocation, + -- ^ the ModLocation. This is discovered during compilation, + -- in the Hsc phase where we read the module header. + foreign_os :: [FilePath], + -- ^ additional object files resulting from compiling foreign + -- code. They come from two sources: foreign stubs, and + -- add{C,Cxx,Objc,Objcxx}File from template haskell + iface :: Maybe (ModIface, ModDetails) + -- ^ Interface generated by HscOut phase. Only available after the + -- phase runs. + } + +pipeStateDynFlags :: PipeState -> DynFlags +pipeStateDynFlags = hsc_dflags . hsc_env + +pipeStateModIface :: PipeState -> Maybe (ModIface, ModDetails) +pipeStateModIface = iface + +data PipelineOutput + = Temporary TempFileLifetime + -- ^ Output should be to a temporary file: we're going to + -- run more compilation steps on this output later. + | Persistent + -- ^ We want a persistent file, i.e. a file in the current directory + -- derived from the input filename, but with the appropriate extension. + -- eg. in "ghc -c Foo.hs" the output goes into ./Foo.o. + | SpecificFile + -- ^ The output must go into the specific outputFile in DynFlags. + -- We don't store the filename in the constructor as it changes + -- when doing -dynamic-too. + deriving Show + +getPipeEnv :: CompPipeline PipeEnv +getPipeEnv = P $ \env state -> return (state, env) + +getPipeState :: CompPipeline PipeState +getPipeState = P $ \_env state -> return (state, state) + +instance HasDynFlags CompPipeline where + getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state)) + +setDynFlags :: DynFlags -> CompPipeline () +setDynFlags dflags = P $ \_env state -> + return (state{hsc_env= (hsc_env state){ hsc_dflags = dflags }}, ()) + +setModLocation :: ModLocation -> CompPipeline () +setModLocation loc = P $ \_env state -> + return (state{ maybe_loc = Just loc }, ()) + +setForeignOs :: [FilePath] -> CompPipeline () +setForeignOs os = P $ \_env state -> + return (state{ foreign_os = os }, ()) + +setIface :: ModIface -> ModDetails -> CompPipeline () +setIface iface details = P $ \_env state -> return (state{ iface = Just (iface, details) }, ()) diff --git a/compiler/GHC/Driver/Plugins.hs b/compiler/GHC/Driver/Plugins.hs new file mode 100644 index 0000000000..baa27a0b36 --- /dev/null +++ b/compiler/GHC/Driver/Plugins.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} + +-- | Definitions for writing /plugins/ for GHC. Plugins can hook into +-- several areas of the compiler. See the 'Plugin' type. These plugins +-- include type-checker plugins, source plugins, and core-to-core plugins. + +module GHC.Driver.Plugins ( + -- * Plugins + Plugin(..) + , defaultPlugin + , CommandLineOption + -- ** Recompilation checking + , purePlugin, impurePlugin, flagRecompile + , PluginRecompile(..) + + -- * Plugin types + -- ** Frontend plugins + , FrontendPlugin(..), defaultFrontendPlugin, FrontendPluginAction + -- ** Core plugins + -- | Core plugins allow plugins to register as a Core-to-Core pass. + , CorePlugin + -- ** Typechecker plugins + -- | Typechecker plugins allow plugins to provide evidence to the + -- typechecker. + , TcPlugin + -- ** Source plugins + -- | GHC offers a number of points where plugins can access and modify its + -- front-end (\"source\") representation. These include: + -- + -- - access to the parser result with 'parsedResultAction' + -- - access to the renamed AST with 'renamedResultAction' + -- - access to the typechecked AST with 'typeCheckResultAction' + -- - access to the Template Haskell splices with 'spliceRunAction' + -- - access to loaded interface files with 'interfaceLoadAction' + -- + , keepRenamedSource + -- ** Hole fit plugins + -- | hole fit plugins allow plugins to change the behavior of valid hole + -- fit suggestions + , HoleFitPluginR + + -- * Internal + , PluginWithArgs(..), plugins, pluginRecompile' + , LoadedPlugin(..), lpModuleName + , StaticPlugin(..) + , mapPlugins, withPlugins, withPlugins_ + ) where + +import GhcPrelude + +import {-# SOURCE #-} CoreMonad ( CoreToDo, CoreM ) +import qualified TcRnTypes +import TcRnTypes ( TcGblEnv, IfM, TcM, tcg_rn_decls, tcg_rn_exports ) +import TcHoleFitTypes ( HoleFitPluginR ) +import GHC.Hs +import GHC.Driver.Session +import GHC.Driver.Types +import GHC.Driver.Monad +import GHC.Driver.Phases +import Module ( ModuleName, Module(moduleName)) +import Fingerprint +import Data.List (sort) +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 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. +-- +-- Nonetheless, this API is preliminary and highly likely to change in +-- the future. +data Plugin = Plugin { + 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 :: TcPlugin + -- ^ An optional typechecker plugin, which may modify the + -- behaviour of the constraint solver. + , holeFitPlugin :: HoleFitPlugin + -- ^ An optional plugin to handle hole fits, which may re-order + -- or change the list of valid hole fits and refinement hole fits. + , dynflagsPlugin :: [CommandLineOption] -> DynFlags -> IO DynFlags + -- ^ An optional plugin to update 'DynFlags', right after + -- plugin loading. This can be used to register hooks + -- or tweak any field of 'DynFlags' before doing + -- actual work on a module. + -- + -- @since 8.10.1 + , 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 + -- GHC.Driver.Main 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 at 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 + -- GHC.Iface.Load 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://gitlab.haskell.org/ghc/ghc/wikis/extended-plugins-proposal + +data PluginWithArgs = PluginWithArgs + { paPlugin :: Plugin + -- ^ the actual callable plugin + , paArguments :: [CommandLineOption] + -- ^ command line arguments for the plugin + } + +-- | A plugin with its arguments. The result of loading the plugin. +data LoadedPlugin = LoadedPlugin + { lpPlugin :: PluginWithArgs + -- ^ the actual plugin together with its commandline arguments + , lpModule :: ModIface + -- ^ the module containing the plugin + } + +-- | A static plugin with its arguments. For registering compiled-in plugins +-- through the GHC API. +data StaticPlugin = StaticPlugin + { spPlugin :: PluginWithArgs + -- ^ the actual plugin together with its commandline arguments + } + +lpModuleName :: LoadedPlugin -> ModuleName +lpModuleName = moduleName . mi_module . lpModule + +pluginRecompile' :: PluginWithArgs -> IO PluginRecompile +pluginRecompile' (PluginWithArgs plugin args) = pluginRecompile plugin args + +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 + +type CorePlugin = [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +type TcPlugin = [CommandLineOption] -> Maybe TcRnTypes.TcPlugin +type HoleFitPlugin = [CommandLineOption] -> Maybe HoleFitPluginR + +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, except for marking that safe +-- inference has failed unless @-fplugin-trustworthy@ is passed. For +-- compatibility reason you should base all your plugin definitions on this +-- default value. +defaultPlugin :: Plugin +defaultPlugin = Plugin { + installCoreToDos = const return + , tcPlugin = const Nothing + , holeFitPlugin = const Nothing + , dynflagsPlugin = const return + , 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 () + +plugins :: DynFlags -> [PluginWithArgs] +plugins df = + map lpPlugin (cachedPlugins df) ++ + map spPlugin (staticPlugins df) + +-- | 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 go input (plugins df) + where + go arg (PluginWithArgs p opts) = transformation p opts arg + +mapPlugins :: DynFlags -> (Plugin -> [CommandLineOption] -> a) -> [a] +mapPlugins df f = map (\(PluginWithArgs p opts) -> f p opts) (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_ (\(PluginWithArgs p opts) -> transformation p opts input) + (plugins df) + +type FrontendPluginAction = [String] -> [(String, Maybe Phase)] -> Ghc () +data FrontendPlugin = FrontendPlugin { + frontend :: FrontendPluginAction + } +defaultFrontendPlugin :: FrontendPlugin +defaultFrontendPlugin = FrontendPlugin { frontend = \_ _ -> return () } diff --git a/compiler/GHC/Driver/Plugins.hs-boot b/compiler/GHC/Driver/Plugins.hs-boot new file mode 100644 index 0000000000..41a0c115d2 --- /dev/null +++ b/compiler/GHC/Driver/Plugins.hs-boot @@ -0,0 +1,10 @@ +-- The plugins datatype is stored in DynFlags, so it needs to be +-- exposed without importing all of its implementation. +module GHC.Driver.Plugins where + +import GhcPrelude () + +data Plugin + +data LoadedPlugin +data StaticPlugin diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs new file mode 100644 index 0000000000..4eb9ab2597 --- /dev/null +++ b/compiler/GHC/Driver/Session.hs @@ -0,0 +1,5939 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} + +------------------------------------------------------------------------------- +-- +-- | Dynamic flags +-- +-- Most flags are dynamic flags, which means they can change from compilation +-- to compilation using @OPTIONS_GHC@ pragmas, and in a multi-session GHC each +-- session can be using different dynamic flags. Dynamic flags can also be set +-- at the prompt in GHCi. +-- +-- (c) The University of Glasgow 2005 +-- +------------------------------------------------------------------------------- + +{-# OPTIONS_GHC -fno-cse #-} +-- -fno-cse is needed for GLOBAL_VAR's to behave properly +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Driver.Session ( + -- * Dynamic flags and associated configuration types + DumpFlag(..), + GeneralFlag(..), + WarningFlag(..), WarnReason(..), + Language(..), + PlatformConstants(..), + FatalMessager, LogAction, FlushOut(..), FlushErr(..), + ProfAuto(..), + glasgowExtsFlags, + warningGroups, warningHierarchies, + hasPprDebug, hasNoDebugOutput, hasNoStateHack, hasNoOptCoercion, + dopt, dopt_set, dopt_unset, + gopt, gopt_set, gopt_unset, setGeneralFlag', unSetGeneralFlag', + wopt, wopt_set, wopt_unset, + wopt_fatal, wopt_set_fatal, wopt_unset_fatal, + xopt, xopt_set, xopt_unset, + xopt_set_unlessExplSpec, + lang_set, + whenGeneratingDynamicToo, ifGeneratingDynamicToo, + whenCannotGenerateDynamicToo, + dynamicTooMkDynamicDynFlags, + dynamicOutputFile, + DynFlags(..), + FlagSpec(..), + HasDynFlags(..), ContainsDynFlags(..), + RtsOptsEnabled(..), + HscTarget(..), isObjectTarget, defaultObjectTarget, + targetRetainsAllBindings, + GhcMode(..), isOneShot, + GhcLink(..), isNoLink, + PackageFlag(..), PackageArg(..), ModRenaming(..), + packageFlagsChanged, + IgnorePackageFlag(..), TrustFlag(..), + PackageDBFlag(..), PkgDbRef(..), + Option(..), showOpt, + DynLibLoader(..), + fFlags, fLangFlags, xFlags, + wWarningFlags, + dynFlagDependencies, + makeDynFlagsConsistent, + positionIndependent, + optimisationFlags, + setFlagsFromEnvFile, + + Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays, + wayGeneralFlags, wayUnsetGeneralFlags, + + thisPackage, thisComponentId, thisUnitIdInsts, + + -- ** Log output + putLogMsg, + + -- ** Safe Haskell + SafeHaskellMode(..), + safeHaskellOn, safeHaskellModeEnabled, + safeImportsOn, safeLanguageOn, safeInferOn, + packageTrustOn, + safeDirectImpsReq, safeImplicitImpsReq, + unsafeFlags, unsafeFlagsForInfer, + + -- ** LLVM Targets + LlvmTarget(..), LlvmConfig(..), + + -- ** System tool settings and locations + Settings(..), + sProgramName, + sProjectVersion, + sGhcUsagePath, + sGhciUsagePath, + sToolDir, + sTopDir, + sTmpDir, + sGlobalPackageDatabasePath, + sLdSupportsCompactUnwind, + sLdSupportsBuildId, + sLdSupportsFilelist, + sLdIsGnuLd, + sGccSupportsNoPie, + sPgm_L, + sPgm_P, + sPgm_F, + sPgm_c, + sPgm_a, + sPgm_l, + sPgm_dll, + sPgm_T, + sPgm_windres, + sPgm_libtool, + sPgm_ar, + sPgm_ranlib, + sPgm_lo, + sPgm_lc, + sPgm_lcc, + sPgm_i, + sOpt_L, + sOpt_P, + sOpt_P_fingerprint, + sOpt_F, + sOpt_c, + sOpt_cxx, + sOpt_a, + sOpt_l, + sOpt_windres, + sOpt_lo, + sOpt_lc, + sOpt_lcc, + sOpt_i, + sExtraGccViaCFlags, + sTargetPlatformString, + sIntegerLibrary, + sIntegerLibraryType, + sGhcWithInterpreter, + sGhcWithNativeCodeGen, + sGhcWithSMP, + sGhcRTSWays, + sTablesNextToCode, + sLeadingUnderscore, + sLibFFI, + sGhcThreaded, + sGhcDebugged, + sGhcRtsWithLibdw, + IntegerLibrary(..), + GhcNameVersion(..), + FileSettings(..), + PlatformMisc(..), + settings, + programName, projectVersion, + ghcUsagePath, ghciUsagePath, topDir, tmpDir, + versionedAppDir, versionedFilePath, + extraGccViaCFlags, globalPackageDatabasePath, + pgm_L, pgm_P, pgm_F, pgm_c, pgm_a, pgm_l, pgm_dll, pgm_T, + 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_cxx, opt_a, opt_l, opt_i, + opt_P_signature, + opt_windres, opt_lo, opt_lc, opt_lcc, + tablesNextToCode, + + -- ** Manipulating DynFlags + addPluginModuleName, + defaultDynFlags, -- Settings -> DynFlags + defaultWays, + interpWays, + interpreterProfiled, interpreterDynamic, + initDynFlags, -- DynFlags -> IO DynFlags + defaultFatalMessager, + defaultLogAction, + defaultLogActionHPrintDoc, + defaultLogActionHPutStrDoc, + defaultFlushOut, + defaultFlushErr, + + getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a] + getVerbFlags, + updOptLevel, + setTmpDir, + setUnitId, + canonicalizeHomeModule, + canonicalizeModuleIfHome, + + -- ** Parsing DynFlags + parseDynamicFlagsCmdLine, + parseDynamicFilePragma, + parseDynamicFlagsFull, + + -- ** Available DynFlags + allNonDeprecatedFlags, + flagsAll, + flagsDynamic, + flagsPackage, + flagsForCompletion, + + supportedLanguagesAndExtensions, + languageExtensions, + + -- ** DynFlags C compiler options + picCCOpts, picPOpts, + + -- * Compiler configuration suitable for display to the user + compilerInfo, + + rtsIsProfiled, + dynamicGhc, + +#include "GHCConstantsHaskellExports.hs" + bLOCK_SIZE_W, + wORD_SIZE_IN_BITS, + wordAlignment, + tAG_MASK, + mAX_PTR_TAG, + tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD, + + unsafeGlobalDynFlags, setUnsafeGlobalDynFlags, + + -- * SSE and AVX + isSseEnabled, + isSse2Enabled, + isSse4_2Enabled, + isBmiEnabled, + isBmi2Enabled, + isAvxEnabled, + isAvx2Enabled, + isAvx512cdEnabled, + isAvx512erEnabled, + isAvx512fEnabled, + isAvx512pfEnabled, + + -- * Linker/compiler information + LinkerInfo(..), + CompilerInfo(..), + + -- * File cleanup + FilesToClean(..), emptyFilesToClean, + + -- * Include specifications + IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes, + + -- * SDoc + initSDocContext, + + -- * Make use of the Cmm CFG + CfgWeights(..), backendMaintainsCfg + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Platform +import GHC.UniqueSubdir (uniqueSubdir) +import PlatformConstants +import Module +import {-# SOURCE #-} GHC.Driver.Plugins +import {-# SOURCE #-} GHC.Driver.Hooks +import {-# SOURCE #-} PrelNames ( mAIN ) +import {-# SOURCE #-} GHC.Driver.Packages (PackageState, emptyPackageState, PackageDatabase) +import GHC.Driver.Phases ( Phase(..), phaseInputExt ) +import Config +import CliOption +import GHC.Driver.CmdLine hiding (WarnReason(..)) +import qualified GHC.Driver.CmdLine as Cmd +import Constants +import GhcNameVersion +import Panic +import qualified PprColour as Col +import Util +import Maybes +import MonadUtils +import qualified Pretty +import SrcLoc +import BasicTypes ( Alignment, alignmentOf, IntWithInf, treatZeroAsInf ) +import FastString +import Fingerprint +import FileSettings +import Outputable +import Settings +import ToolSettings + +import Foreign.C ( CInt(..) ) +import System.IO.Unsafe ( unsafeDupablePerformIO ) +import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessageAnn + , getCaretDiagnostic, DumpAction, TraceAction + , defaultDumpAction, defaultTraceAction ) +import Json +import SysTools.Terminal ( stderrSupportsAnsiColors ) +import SysTools.BaseDir ( expandToolDir, expandTopDir ) + +import System.IO.Unsafe ( unsafePerformIO ) +import Data.IORef +import Control.Arrow ((&&&)) +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Writer +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Except + +import Data.Ord +import Data.Bits +import Data.Char +import Data.Int +import Data.List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Word +import System.FilePath +import System.Directory +import System.Environment (lookupEnv) +import System.IO +import System.IO.Error +import Text.ParserCombinators.ReadP hiding (char) +import Text.ParserCombinators.ReadP as R + +import EnumSet (EnumSet) +import qualified EnumSet + +import GHC.Foreign (withCString, peekCString) +import qualified GHC.LanguageExtensions as LangExt + +#if GHC_STAGE >= 2 +-- used by SHARED_GLOBAL_VAR +import Foreign (Ptr) +#endif + +-- Note [Updating flag description in the User's Guide] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- If you modify anything in this file please make sure that your changes are +-- 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] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- The command line interface completion (in for example bash) is an easy way +-- for the developer to learn what flags are available from GHC. +-- GHC helps by separating which flags are available when compiling with GHC, +-- and which flags are available when using GHCi. +-- A flag is assumed to either work in both these modes, or only in one of them. +-- When adding or changing a flag, please consider for which mode the flag will +-- have effect, and annotate it accordingly. For Flags use defFlag, defGhcFlag, +-- defGhciFlag, and for FlagSpec use flagSpec or flagGhciSpec. + +-- Note [Adding a language extension] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- There are a few steps to adding (or removing) a language extension, +-- +-- * Adding the extension to GHC.LanguageExtensions +-- +-- The Extension type in libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs +-- is the canonical list of language extensions known by GHC. +-- +-- * Adding a flag to DynFlags.xFlags +-- +-- This is fairly self-explanatory. The name should be concise, memorable, +-- and consistent with any previous implementations of the similar idea in +-- other Haskell compilers. +-- +-- * Adding the flag to the documentation +-- +-- This is the same as any other flag. See +-- Note [Updating flag description in the User's Guide] +-- +-- * Adding the flag to Cabal +-- +-- The Cabal library has its own list of all language extensions supported +-- by all major compilers. This is the list that user code being uploaded +-- to Hackage is checked against to ensure language extension validity. +-- Consequently, it is very important that this list remains up-to-date. +-- +-- To this end, there is a testsuite test (testsuite/tests/driver/T4437.hs) +-- whose job it is to ensure these GHC's extensions are consistent with +-- Cabal. +-- +-- The recommended workflow is, +-- +-- 1. Temporarily add your new language extension to the +-- expectedGhcOnlyExtensions list in T4437 to ensure the test doesn't +-- break while Cabal is updated. +-- +-- 2. After your GHC change is accepted, submit a Cabal pull request adding +-- your new extension to Cabal's list (found in +-- Cabal/Language/Haskell/Extension.hs). +-- +-- 3. After your Cabal change is accepted, let the GHC developers know so +-- they can update the Cabal submodule and remove the extensions from +-- expectedGhcOnlyExtensions. +-- +-- * Adding the flag to the GHC Wiki +-- +-- There is a change log tracking language extension additions and removals +-- on the GHC wiki: https://gitlab.haskell.org/ghc/ghc/wikis/language-pragma-history +-- +-- See #4437 and #8176. + +-- ----------------------------------------------------------------------------- +-- DynFlags + +data DumpFlag +-- See Note [Updating flag description in the User's Guide] + + -- debugging flags + = Opt_D_dump_cmm + | Opt_D_dump_cmm_from_stg + | Opt_D_dump_cmm_raw + | Opt_D_dump_cmm_verbose_by_proc + -- All of the cmm subflags (there are a lot!) automatically + -- enabled if you run -ddump-cmm-verbose-by-proc + -- Each flag corresponds to exact stage of Cmm pipeline. + | Opt_D_dump_cmm_verbose + -- same as -ddump-cmm-verbose-by-proc but writes each stage + -- to a separate file (if used with -ddump-to-file) + | Opt_D_dump_cmm_cfg + | Opt_D_dump_cmm_cbe + | Opt_D_dump_cmm_switch + | Opt_D_dump_cmm_proc + | Opt_D_dump_cmm_sp + | Opt_D_dump_cmm_sink + | Opt_D_dump_cmm_caf + | Opt_D_dump_cmm_procmap + | Opt_D_dump_cmm_split + | Opt_D_dump_cmm_info + | Opt_D_dump_cmm_cps + -- end cmm subflags + | Opt_D_dump_cfg_weights -- ^ Dump the cfg used for block layout. + | Opt_D_dump_asm + | Opt_D_dump_asm_native + | Opt_D_dump_asm_liveness + | Opt_D_dump_asm_regalloc + | Opt_D_dump_asm_regalloc_stages + | Opt_D_dump_asm_conflicts + | Opt_D_dump_asm_stats + | Opt_D_dump_asm_expanded + | Opt_D_dump_llvm + | 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 + | Opt_D_dump_rule_rewrites + | Opt_D_dump_simpl_trace + | Opt_D_dump_occur_anal + | Opt_D_dump_parsed + | Opt_D_dump_parsed_ast + | Opt_D_dump_rn + | Opt_D_dump_rn_ast + | Opt_D_dump_simpl + | Opt_D_dump_simpl_iterations + | Opt_D_dump_spec + | Opt_D_dump_prep + | Opt_D_dump_stg -- CoreToStg output + | Opt_D_dump_stg_unarised -- STG after unarise + | Opt_D_dump_stg_final -- STG after stg2stg + | Opt_D_dump_call_arity + | Opt_D_dump_exitify + | Opt_D_dump_stranal + | Opt_D_dump_str_signatures + | Opt_D_dump_cpranal + | Opt_D_dump_cpr_signatures + | Opt_D_dump_tc + | Opt_D_dump_tc_ast + | Opt_D_dump_types + | Opt_D_dump_rules + | Opt_D_dump_cse + | Opt_D_dump_worker_wrapper + | Opt_D_dump_rn_trace + | Opt_D_dump_rn_stats + | Opt_D_dump_opt_cmm + | Opt_D_dump_simpl_stats + | Opt_D_dump_cs_trace -- Constraint solver in type checker + | Opt_D_dump_tc_trace + | Opt_D_dump_ec_trace -- Pattern match exhaustiveness checker + | Opt_D_dump_if_trace + | Opt_D_dump_vt_trace + | Opt_D_dump_splices + | Opt_D_th_dec_file + | Opt_D_dump_BCOs + | Opt_D_dump_ticked + | Opt_D_dump_rtti + | Opt_D_source_stats + | Opt_D_verbose_stg2stg + | Opt_D_dump_hi + | 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 + | Opt_D_dump_json + | Opt_D_ppr_debug + | 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] + + = Opt_DumpToFile -- ^ Append dump output to files instead of stdout. + | Opt_D_faststring_stats + | Opt_D_dump_minimal_imports + | Opt_DoCoreLinting + | Opt_DoStgLinting + | Opt_DoCmmLinting + | Opt_DoAsmLinting + | Opt_DoAnnotationLinting + | Opt_NoLlvmMangler -- hidden flag + | Opt_FastLlvm -- hidden flag + | Opt_NoTypeableBinds + + | Opt_WarnIsError -- -Werror; makes warnings fatal + | Opt_ShowWarnGroups -- Show the group a warning belongs to + | Opt_HideSourcePaths -- Hide module source/object paths + + | Opt_PrintExplicitForalls + | Opt_PrintExplicitKinds + | Opt_PrintExplicitCoercions + | Opt_PrintExplicitRuntimeReps + | Opt_PrintEqualityRelations + | Opt_PrintAxiomIncomps + | Opt_PrintUnicodeSyntax + | Opt_PrintExpandedSynonyms + | Opt_PrintPotentialInstances + | Opt_PrintTypecheckerElaboration + + -- optimisation opts + | Opt_CallArity + | Opt_Exitification + | Opt_Strictness + | Opt_LateDmdAnal -- #6087 + | Opt_KillAbsence + | Opt_KillOneShot + | Opt_FullLaziness + | Opt_FloatIn + | Opt_LateSpecialise + | Opt_Specialise + | Opt_SpecialiseAggressively + | Opt_CrossModuleSpecialise + | Opt_StaticArgumentTransformation + | Opt_CSE + | Opt_StgCSE + | Opt_StgLiftLams + | Opt_LiberateCase + | Opt_SpecConstr + | Opt_SpecConstrKeen + | Opt_DoLambdaEtaExpansion + | Opt_IgnoreAsserts + | Opt_DoEtaReduction + | Opt_CaseMerge + | Opt_CaseFolding -- Constant folding through case-expressions + | Opt_UnboxStrictFields + | Opt_UnboxSmallStrictFields + | Opt_DictsCheap + | Opt_EnableRewriteRules -- Apply rewrite rules during simplification + | Opt_EnableThSpliceWarnings -- Enable warnings for TH splices + | Opt_RegsGraph -- do graph coloring register allocation + | Opt_RegsIterative -- do iterative coalescing graph coloring register allocation + | Opt_PedanticBottoms -- Be picky about how we treat bottom + | Opt_LlvmTBAA -- Use LLVM TBAA infrastructure for improving AA (hidden flag) + | Opt_LlvmFillUndefWithGarbage -- Testing for undef bugs (hidden flag) + | 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 + | Opt_DmdTxDictSel -- use a special demand transformer for dictionary selectors + | Opt_Loopification -- See Note [Self-recursive tail calls] + | Opt_CfgBlocklayout -- ^ Use the cfg based block layout algorithm. + | Opt_WeightlessBlocklayout -- ^ Layout based on last instruction per block. + | 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 + | Opt_OmitInterfacePragmas + | Opt_ExposeAllUnfoldings + | Opt_WriteInterface -- forces .hi files to be written even with -fno-code + | Opt_WriteHie -- generate .hie files + + -- profiling opts + | Opt_AutoSccsOnIndividualCafs + | Opt_ProfCountEntries + + -- misc opts + | Opt_Pp + | Opt_ForceRecomp + | Opt_IgnoreOptimChanges + | Opt_IgnoreHpcChanges + | Opt_ExcessPrecision + | Opt_EagerBlackHoling + | Opt_NoHsMain + | Opt_SplitSections + | Opt_StgStats + | Opt_HideAllPackages + | Opt_HideAllPluginPackages + | Opt_PrintBindResult + | Opt_Haddock + | Opt_HaddockOptions + | Opt_BreakOnException + | Opt_BreakOnError + | Opt_PrintEvldWithShow + | Opt_PrintBindContents + | Opt_GenManifest + | Opt_EmbedManifest + | Opt_SharedImplib + | Opt_BuildingCabalPackage + | Opt_IgnoreDotGhci + | Opt_GhciSandbox + | Opt_GhciHistory + | Opt_GhciLeakCheck + | Opt_ValidateHie + | Opt_LocalGhciHistory + | Opt_NoIt + | Opt_HelpfulErrors + | Opt_DeferTypeErrors + | Opt_DeferTypedHoles + | Opt_DeferOutOfScopeVariables + | Opt_PIC -- ^ @-fPIC@ + | Opt_PIE -- ^ @-fPIE@ + | Opt_PICExecutable -- ^ @-pie@ + | Opt_ExternalDynamicRefs + | Opt_SccProfilingOn + | Opt_Ticky + | Opt_Ticky_Allocd + | Opt_Ticky_LNE + | Opt_Ticky_Dyn_Thunk + | Opt_RPath + | Opt_RelativeDynlibPaths + | Opt_Hpc + | Opt_FlatCache + | Opt_ExternalInterpreter + | Opt_OptimalApplicativeDo + | Opt_VersionMacros + | Opt_WholeArchiveHsLibs + -- 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 + | Opt_KeepCAFs + | Opt_KeepGoing + | Opt_ByteCode + + -- output style opts + | Opt_ErrorSpans -- Include full span info in error messages, + -- instead of just the start position. + | Opt_DeferDiagnostics + | Opt_DiagnosticsShowCaret -- Show snippets of offending code + | 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 + | Opt_SuppressVarKinds + -- Suppress module id prefixes on variables. + | Opt_SuppressModulePrefixes + -- Suppress type applications. + | Opt_SuppressTypeApplications + -- Suppress info such as arity and unfoldings on identifiers. + | Opt_SuppressIdInfo + -- Suppress separate type signatures in core, but leave types on + -- lambda bound vars + | Opt_SuppressUnfoldings + -- Suppress the details of even stable unfoldings + | Opt_SuppressTypeSignatures + -- Suppress unique ids on variables. + -- Except for uniques, as some simplifier phases introduce new + -- variables that have otherwise identical names. + | Opt_SuppressUniques + | Opt_SuppressStgExts + | 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 + | Opt_KeepTmpFiles + | Opt_KeepRawTokenStream + | Opt_KeepLlvmFiles + | Opt_KeepHiFiles + | Opt_KeepOFiles + + | Opt_BuildDynamicToo + + -- safe haskell flags + | Opt_DistrustAllPackages + | Opt_PackageTrust + | Opt_PluginTrustworthy + + | Opt_G_NoStateHack + | 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_StgLiftLams + , 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_LlvmFillUndefWithGarbage + , Opt_IrrefutableTuples + , Opt_CmmSink + , Opt_CmmElimCommonBlocks + , Opt_AsmShortcutting + , Opt_OmitYields + , Opt_FunToThunk + , Opt_DictsStrict + , Opt_DmdTxDictSel + , Opt_Loopification + , Opt_CfgBlocklayout + , Opt_WeightlessBlocklayout + , 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. +data WarnReason + = NoReason + -- | Warning was enabled with the flag + | Reason !WarningFlag + -- | Warning was made an error because of -Werror or -Werror=WarningFlag + | 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 #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 + +instance ToJson WarnReason where + json NoReason = JSNull + json (Reason wf) = JSString (show wf) + json (ErrReason Nothing) = JSString "Opt_WarnIsError" + json (ErrReason (Just wf)) = JSString (show wf) + +data WarningFlag = +-- See Note [Updating flag description in the User's Guide] + Opt_WarnDuplicateExports + | Opt_WarnDuplicateConstraints + | Opt_WarnRedundantConstraints + | Opt_WarnHiShadows + | Opt_WarnImplicitPrelude + | Opt_WarnIncompletePatterns + | Opt_WarnIncompleteUniPatterns + | Opt_WarnIncompletePatternsRecUpd + | Opt_WarnOverflowedLiterals + | Opt_WarnEmptyEnumerations + | Opt_WarnMissingFields + | Opt_WarnMissingImportList + | Opt_WarnMissingMethods + | Opt_WarnMissingSignatures + | Opt_WarnMissingLocalSignatures + | Opt_WarnNameShadowing + | Opt_WarnOverlappingPatterns + | Opt_WarnTypeDefaults + | Opt_WarnMonomorphism + | Opt_WarnUnusedTopBinds + | Opt_WarnUnusedLocalBinds + | Opt_WarnUnusedPatternBinds + | Opt_WarnUnusedImports + | Opt_WarnUnusedMatches + | Opt_WarnUnusedTypePatterns + | Opt_WarnUnusedForalls + | Opt_WarnUnusedRecordWildcards + | Opt_WarnRedundantRecordWildcards + | Opt_WarnWarningsDeprecations + | Opt_WarnDeprecatedFlags + | Opt_WarnMissingMonadFailInstances -- since 8.0 + | Opt_WarnSemigroup -- since 8.0 + | Opt_WarnDodgyExports + | Opt_WarnDodgyImports + | Opt_WarnOrphans + | Opt_WarnAutoOrphans + | Opt_WarnIdentities + | Opt_WarnTabs + | Opt_WarnUnrecognisedPragmas + | Opt_WarnDodgyForeignImports + | Opt_WarnUnusedDoBind + | Opt_WarnWrongDoBind + | Opt_WarnAlternativeLayoutRuleTransitional + | Opt_WarnUnsafe + | Opt_WarnSafe + | Opt_WarnTrustworthySafe + | Opt_WarnMissedSpecs + | Opt_WarnAllMissedSpecs + | Opt_WarnUnsupportedCallingConventions + | Opt_WarnUnsupportedLlvmVersion + | Opt_WarnMissedExtraSharedLib + | Opt_WarnInlineRuleShadowing + | Opt_WarnTypedHoles + | Opt_WarnPartialTypeSignatures + | Opt_WarnMissingExportedSignatures + | Opt_WarnUntickedPromotedConstructors + | Opt_WarnDerivingTypeable + | Opt_WarnDeferredTypeErrors + | Opt_WarnDeferredOutOfScopeVariables + | Opt_WarnNonCanonicalMonadInstances -- since 8.0 + | Opt_WarnNonCanonicalMonadFailInstances -- since 8.0, removed 8.8 + | Opt_WarnNonCanonicalMonoidInstances -- since 8.0 + | Opt_WarnMissingPatternSynonymSignatures -- since 8.0 + | Opt_WarnUnrecognisedWarningFlags -- since 8.0 + | Opt_WarnSimplifiableClassConstraints -- Since 8.2 + | 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 + | Opt_WarnSpaceAfterBang + | Opt_WarnMissingDerivingStrategies -- Since 8.8 + | Opt_WarnPrepositiveQualifiedModule -- Since TBD + | Opt_WarnUnusedPackages -- Since 8.10 + | Opt_WarnInferredSafeImports -- Since 8.10 + | Opt_WarnMissingSafeHaskellMode -- Since 8.10 + | Opt_WarnCompatUnqualifiedImports -- Since 8.10 + | Opt_WarnDerivingDefaults + deriving (Eq, Show, Enum) + +data Language = Haskell98 | Haskell2010 + deriving (Eq, Enum, Show) + +instance Outputable Language where + ppr = text . show + +-- | The various Safe Haskell modes +data SafeHaskellMode + = Sf_None -- ^ inferred unsafe + | Sf_Unsafe -- ^ declared and checked + | Sf_Trustworthy -- ^ declared and checked + | Sf_Safe -- ^ declared and checked + | Sf_SafeInferred -- ^ inferred as safe + | Sf_Ignore -- ^ @-fno-safe-haskell@ state + deriving (Eq) + +instance Show SafeHaskellMode where + show Sf_None = "None" + show Sf_Unsafe = "Unsafe" + show Sf_Trustworthy = "Trustworthy" + show Sf_Safe = "Safe" + show Sf_SafeInferred = "Safe-Inferred" + show Sf_Ignore = "Ignore" + +instance Outputable SafeHaskellMode where + ppr = text . show + +-- | Contains not only a collection of 'GeneralFlag's but also a plethora of +-- information relating to the compilation of a single file or GHC session +data DynFlags = DynFlags { + ghcMode :: GhcMode, + ghcLink :: GhcLink, + hscTarget :: HscTarget, + + -- formerly Settings + ghcNameVersion :: {-# UNPACK #-} !GhcNameVersion, + fileSettings :: {-# UNPACK #-} !FileSettings, + targetPlatform :: Platform, -- Filled in by SysTools + toolSettings :: {-# UNPACK #-} !ToolSettings, + platformMisc :: {-# UNPACK #-} !PlatformMisc, + platformConstants :: PlatformConstants, + rawSettings :: [(String, String)], + + integerLibrary :: IntegerLibrary, + -- ^ IntegerGMP or IntegerSimple. Set at configure time, but may be overridden + -- by GHC-API users. See Note [The integer library] in PrelNames + llvmConfig :: LlvmConfig, + -- ^ N.B. It's important that this field is lazy since we load the LLVM + -- configuration lazily. See Note [LLVM Configuration] in SysTools. + verbosity :: Int, -- ^ Verbosity level: see Note [Verbosity levels] + optLevel :: Int, -- ^ Optimisation level + debugLevel :: Int, -- ^ How much debug information to produce + simplPhases :: Int, -- ^ Number of simplifier phases + maxSimplIterations :: Int, -- ^ Max simplifier iterations + 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 + -- in --make mode, where Nothing ==> compile as + -- many in parallel as there are CPUs. + + enableTimeStats :: Bool, -- ^ Enable RTS timing statistics? + ghcHeapSize :: Maybe Int, -- ^ The heap size to set. + + maxRelevantBinds :: Maybe Int, -- ^ Maximum number of bindings from the type envt + -- 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 + maxPmCheckModels :: Int, -- ^ Soft limit on the number of models + -- the pattern match checker checks + -- a pattern against. A safe guard + -- against exponential blow-up. + simplTickFactor :: Int, -- ^ Multiplier for simplifier ticks + specConstrThreshold :: Maybe Int, -- ^ Threshold for SpecConstr + specConstrCount :: Maybe Int, -- ^ Max number of specialisations for any one function + specConstrRecursive :: Int, -- ^ Max number of specialisations for recursive types + -- Not optional; otherwise ForceSpecConstr can diverge. + binBlobThreshold :: Word, -- ^ Binary literals (e.g. strings) whose size is above + -- this threshold will be dumped in a binary file + -- by the assembler code generator (0 to disable) + liberateCaseThreshold :: Maybe Int, -- ^ Threshold for LiberateCase + floatLamArgs :: Maybe Int, -- ^ Arg count for lambda floating + -- See CoreMonad.FloatOutSwitches + + liftLamsRecArgs :: Maybe Int, -- ^ Maximum number of arguments after lambda lifting a + -- recursive function. + liftLamsNonRecArgs :: Maybe Int, -- ^ Maximum number of arguments after lambda lifting a + -- non-recursive function. + liftLamsKnown :: Bool, -- ^ Lambda lift even when this turns a known call + -- into an unknown call. + + cmmProcAlignment :: Maybe Int, -- ^ Align Cmm functions at this boundary or use default. + + historySize :: Int, -- ^ Simplification history size + + importPaths :: [FilePath], + mainModIs :: Module, + mainFunIs :: Maybe String, + reductionDepth :: IntWithInf, -- ^ Typechecker maximum stack depth + solverIterations :: IntWithInf, -- ^ Number of iterations in the constraints solver + -- Typically only 1 is needed + + thisInstalledUnitId :: InstalledUnitId, + thisComponentId_ :: Maybe ComponentId, + thisUnitIdInsts_ :: Maybe [(ModuleName, Module)], + + -- ways + ways :: [Way], -- ^ Way flags from the command line + buildTag :: String, -- ^ The global \"way\" (e.g. \"p\" for prof) + + -- For object splitting + splitInfo :: Maybe (String,Int), + + -- paths etc. + objectDir :: Maybe String, + dylibInstallName :: Maybe String, + hiDir :: Maybe String, + hieDir :: Maybe String, + stubDir :: Maybe String, + dumpDir :: Maybe String, + + objectSuf :: String, + hcSuf :: String, + hiSuf :: String, + hieSuf :: String, + + canGenerateDynamicToo :: IORef Bool, + dynObjectSuf :: String, + dynHiSuf :: String, + + outputFile :: Maybe String, + dynOutputFile :: Maybe String, + outputHi :: Maybe String, + dynLibLoader :: DynLibLoader, + + -- | This is set by 'GHC.Driver.Pipeline.runPipeline' based on where + -- its output is going. + dumpPrefix :: Maybe FilePath, + + -- | Override the 'dumpPrefix' set by 'GHC.Driver.Pipeline.runPipeline'. + -- Set by @-ddump-file-prefix@ + dumpPrefixForce :: Maybe FilePath, + + ldInputs :: [Option], + + includePaths :: IncludeSpecs, + libraryPaths :: [String], + frameworkPaths :: [String], -- used on darwin only + cmdlineFrameworks :: [String], -- ditto + + rtsOpts :: Maybe String, + rtsOptsEnabled :: RtsOptsEnabled, + rtsOptsSuggestions :: Bool, + + hpcDir :: String, -- ^ Path to store the .mix files + + -- Plugins + pluginModNames :: [ModuleName], + pluginModNameOpts :: [(ModuleName,String)], + frontendPluginOpts :: [String], + -- ^ the @-ffrontend-opt@ flags given on the command line, in *reverse* + -- order that they're specified on the command line. + cachedPlugins :: [LoadedPlugin], + -- ^ plugins dynamically 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 + -- 'GHC.Runtime.Loader.initializePlugins'. + staticPlugins :: [StaticPlugin], + -- ^ static plugins which do not need dynamic loading. These plugins are + -- intended to be added by GHC API users directly to this list. + -- + -- To add dynamically loaded plugins through the GHC API see + -- 'addPluginModuleName' instead. + + -- GHC API hooks + hooks :: Hooks, + + -- For ghc -M + depMakefile :: FilePath, + depIncludePkgDeps :: Bool, + depIncludeCppDeps :: Bool, + depExcludeMods :: [ModuleName], + depSuffixes :: [String], + + -- Package flags + packageDBFlags :: [PackageDBFlag], + -- ^ The @-package-db@ flags given on the command line, In + -- *reverse* order that they're specified on the command line. + -- This is intended to be applied with the list of "initial" + -- package databases derived from @GHC_PACKAGE_PATH@; see + -- 'getPackageConfRefs'. + + ignorePackageFlags :: [IgnorePackageFlag], + -- ^ The @-ignore-package@ flags from the command line. + -- In *reverse* order that they're specified on the command line. + packageFlags :: [PackageFlag], + -- ^ The @-package@ and @-hide-package@ flags from the command-line. + -- In *reverse* order that they're specified on the command line. + pluginPackageFlags :: [PackageFlag], + -- ^ The @-plugin-package-id@ flags from command line. + -- In *reverse* order that they're specified on the command line. + trustFlags :: [TrustFlag], + -- ^ The @-trust@ and @-distrust@ flags. + -- In *reverse* order that they're specified on the command line. + packageEnv :: Maybe FilePath, + -- ^ Filepath to the package environment file (if overriding default) + + pkgDatabase :: Maybe [PackageDatabase], + -- ^ Stack of package databases for the target platform. + -- + -- A "package database" is a misleading name as it is really a Unit + -- database (cf Note [The identifier lexicon]). + -- + -- This field is populated by `initPackages`. + -- + -- 'Nothing' means the databases have never been read from disk. If + -- `initPackages` is called again, it doesn't reload the databases from + -- disk. + + pkgState :: PackageState, + -- ^ Consolidated unit database built by 'initPackages' from the package + -- databases in 'pkgDatabase' and flags ('-ignore-package', etc.). + -- + -- It also contains mapping from module names to actual Modules. + + -- Temporary files + -- These have to be IORefs, because the defaultCleanupHandler needs to + -- know what to clean when an exception happens + filesToClean :: IORef FilesToClean, + dirsToClean :: IORef (Map FilePath FilePath), + -- The next available suffix to uniquely name a temp file, updated atomically + nextTempSuffix :: IORef Int, + + -- Names of files which were generated from -ddump-to-file; used to + -- track which ones we need to truncate because it's our first run + -- through + generatedDumps :: IORef (Set FilePath), + + -- hsc dynamic flags + dumpFlags :: EnumSet DumpFlag, + generalFlags :: EnumSet GeneralFlag, + warningFlags :: EnumSet WarningFlag, + fatalWarningFlags :: EnumSet WarningFlag, + -- Don't change this without updating extensionFlags: + language :: Maybe Language, + -- | Safe Haskell mode + safeHaskell :: SafeHaskellMode, + safeInfer :: Bool, + safeInferred :: Bool, + -- We store the location of where some extension and flags were turned on so + -- we can produce accurate error messages when Safe Haskell fails due to + -- them. + thOnLoc :: SrcSpan, + newDerivOnLoc :: SrcSpan, + overlapInstLoc :: SrcSpan, + incoherentOnLoc :: SrcSpan, + pkgTrustOnLoc :: SrcSpan, + warnSafeOnLoc :: SrcSpan, + warnUnsafeOnLoc :: SrcSpan, + trustworthyOnLoc :: SrcSpan, + -- Don't change this without updating extensionFlags: + -- Here we collect the settings of the language extensions + -- from the command line, the ghci config file and + -- from interactive :set / :seti commands. + extensions :: [OnOff LangExt.Extension], + -- extensionFlags should always be equal to + -- flattenExtensionFlags language extensions + -- LangExt.Extension is defined in libraries/ghc-boot so that it can be used + -- by template-haskell + extensionFlags :: EnumSet LangExt.Extension, + + -- Unfolding control + -- See Note [Discounts and thresholds] in CoreUnfold + ufCreationThreshold :: Int, + ufUseThreshold :: Int, + ufFunAppDiscount :: Int, + ufDictDiscount :: Int, + ufKeenessFactor :: Float, + ufDearOp :: Int, + ufVeryAggressive :: Bool, + + maxWorkerArgs :: Int, + + ghciHistSize :: Int, + + -- | MsgDoc output action: use "ErrUtils" instead of this if you can + log_action :: LogAction, + dump_action :: DumpAction, + trace_action :: TraceAction, + flushOut :: FlushOut, + flushErr :: FlushErr, + + ghcVersionFile :: Maybe FilePath, + haddockOptions :: Maybe String, + + -- | GHCi scripts specified by -ghci-script, in reverse order + ghciScripts :: [String], + + -- Output style options + pprUserLength :: Int, + pprCols :: Int, + + useUnicode :: Bool, + useColor :: OverridingBool, + canUseColor :: Bool, + colScheme :: Col.Scheme, + + -- | what kind of {-# SCC #-} to add automatically + profAuto :: ProfAuto, + + interactivePrint :: Maybe String, + + nextWrapperNum :: IORef (ModuleEnv Int), + + -- | Machine dependent flags (-m<blah> stuff) + sseVersion :: Maybe SseVersion, + bmiVersion :: Maybe BmiVersion, + avx :: Bool, + avx2 :: Bool, + avx512cd :: Bool, -- Enable AVX-512 Conflict Detection Instructions. + avx512er :: Bool, -- Enable AVX-512 Exponential and Reciprocal Instructions. + avx512f :: Bool, -- Enable AVX-512 instructions. + avx512pf :: Bool, -- Enable AVX-512 PreFetch Instructions. + + -- | Run-time linker information (what options we need, etc.) + rtldInfo :: IORef (Maybe LinkerInfo), + + -- | Run-time compiler information + rtccInfo :: IORef (Maybe CompilerInfo), + + -- Constants used to control the amount of optimization done. + + -- | Max size, in bytes, of inline array allocations. + maxInlineAllocSize :: Int, + + -- | Only inline memcpy if it generates no more than this many + -- pseudo (roughly: Cmm) instructions. + maxInlineMemcpyInsns :: Int, + + -- | Only inline memset if it generates no more than this many + -- pseudo (roughly: Cmm) instructions. + maxInlineMemsetInsns :: Int, + + -- | Reverse the order of error messages in GHC/GHCi + reverseErrors :: Bool, + + -- | Limit the maximum number of errors to show + maxErrors :: Maybe Int, + + -- | Unique supply configuration for testing build determinism + initialUnique :: Int, + uniqueIncrement :: Int, + + -- | Temporary: CFG Edge weights for fast iterations + cfgWeightInfo :: CfgWeights +} + +-- | Edge weights to use when generating a CFG from CMM +data CfgWeights + = CFGWeights + { uncondWeight :: Int + , condBranchWeight :: Int + , switchWeight :: Int + , callWeight :: Int + , likelyCondWeight :: Int + , unlikelyCondWeight :: Int + , infoTablePenalty :: Int + , backEdgeBonus :: Int + } + +defaultCfgWeights :: CfgWeights +defaultCfgWeights + = CFGWeights + { uncondWeight = 1000 + , condBranchWeight = 800 + , switchWeight = 1 + , callWeight = -10 + , likelyCondWeight = 900 + , unlikelyCondWeight = 300 + , infoTablePenalty = 300 + , backEdgeBonus = 400 + } + +parseCfgWeights :: String -> CfgWeights -> CfgWeights +parseCfgWeights s oldWeights = + foldl' (\cfg (n,v) -> update n v cfg) oldWeights assignments + where + assignments = map assignment $ settings s + update "uncondWeight" n w = + w {uncondWeight = n} + update "condBranchWeight" n w = + w {condBranchWeight = n} + update "switchWeight" n w = + w {switchWeight = n} + update "callWeight" n w = + w {callWeight = n} + update "likelyCondWeight" n w = + w {likelyCondWeight = n} + update "unlikelyCondWeight" n w = + w {unlikelyCondWeight = n} + update "infoTablePenalty" n w = + w {infoTablePenalty = n} + update "backEdgeBonus" n w = + w {backEdgeBonus = n} + update other _ _ + = panic $ other ++ + " is not a cfg weight parameter. " ++ + exampleString + settings s + | (s1,rest) <- break (== ',') s + , null rest + = [s1] + | (s1,rest) <- break (== ',') s + = s1 : settings (drop 1 rest) + + assignment as + | (name, _:val) <- break (== '=') as + = (name,read val) + | otherwise + = panic $ "Invalid cfg parameters." ++ exampleString + + exampleString = "Example parameters: uncondWeight=1000," ++ + "condBranchWeight=800,switchWeight=0,callWeight=300" ++ + ",likelyCondWeight=900,unlikelyCondWeight=300" ++ + ",infoTablePenalty=300,backEdgeBonus=400" + +backendMaintainsCfg :: DynFlags -> Bool +backendMaintainsCfg dflags = case (platformArch $ targetPlatform dflags) of + -- ArchX86 -- Should work but not tested so disabled currently. + ArchX86_64 -> True + _otherwise -> False + +class HasDynFlags m where + getDynFlags :: m DynFlags + +{- It would be desirable to have the more generalised + + instance (MonadTrans t, Monad m, HasDynFlags m) => HasDynFlags (t m) where + getDynFlags = lift getDynFlags + +instance definition. However, that definition would overlap with the +`HasDynFlags (GhcT m)` instance. Instead we define instances for a +couple of common Monad transformers explicitly. -} + +instance (Monoid a, Monad m, HasDynFlags m) => HasDynFlags (WriterT a m) where + getDynFlags = lift getDynFlags + +instance (Monad m, HasDynFlags m) => HasDynFlags (ReaderT a m) where + getDynFlags = lift getDynFlags + +instance (Monad m, HasDynFlags m) => HasDynFlags (MaybeT m) where + getDynFlags = lift getDynFlags + +instance (Monad m, HasDynFlags m) => HasDynFlags (ExceptT e m) where + getDynFlags = lift getDynFlags + +class ContainsDynFlags t where + extractDynFlags :: t -> DynFlags + +data ProfAuto + = NoProfAuto -- ^ no SCC annotations added + | ProfAutoAll -- ^ top-level and nested functions are annotated + | ProfAutoTop -- ^ top-level functions annotated only + | ProfAutoExports -- ^ exported functions annotated only + | ProfAutoCalls -- ^ annotate call-sites + deriving (Eq,Enum) + +data LlvmTarget = LlvmTarget + { lDataLayout :: String + , lCPU :: String + , lAttributes :: [String] + } + +-- | See Note [LLVM Configuration] in SysTools. +data LlvmConfig = LlvmConfig { llvmTargets :: [(String, LlvmTarget)] + , llvmPasses :: [(Int, String)] + } + +----------------------------------------------------------------------------- +-- Accessessors from 'DynFlags' + +-- | "unbuild" a 'Settings' from a 'DynFlags'. This shouldn't be needed in the +-- vast majority of code. But GHCi questionably uses this to produce a default +-- 'DynFlags' from which to compute a flags diff for printing. +settings :: DynFlags -> Settings +settings dflags = Settings + { sGhcNameVersion = ghcNameVersion dflags + , sFileSettings = fileSettings dflags + , sTargetPlatform = targetPlatform dflags + , sToolSettings = toolSettings dflags + , sPlatformMisc = platformMisc dflags + , sPlatformConstants = platformConstants dflags + , sRawSettings = rawSettings dflags + } + +programName :: DynFlags -> String +programName dflags = ghcNameVersion_programName $ ghcNameVersion dflags +projectVersion :: DynFlags -> String +projectVersion dflags = ghcNameVersion_projectVersion (ghcNameVersion dflags) +ghcUsagePath :: DynFlags -> FilePath +ghcUsagePath dflags = fileSettings_ghcUsagePath $ fileSettings dflags +ghciUsagePath :: DynFlags -> FilePath +ghciUsagePath dflags = fileSettings_ghciUsagePath $ fileSettings dflags +toolDir :: DynFlags -> Maybe FilePath +toolDir dflags = fileSettings_toolDir $ fileSettings dflags +topDir :: DynFlags -> FilePath +topDir dflags = fileSettings_topDir $ fileSettings dflags +tmpDir :: DynFlags -> String +tmpDir dflags = fileSettings_tmpDir $ fileSettings dflags +extraGccViaCFlags :: DynFlags -> [String] +extraGccViaCFlags dflags = toolSettings_extraGccViaCFlags $ toolSettings dflags +globalPackageDatabasePath :: DynFlags -> FilePath +globalPackageDatabasePath dflags = fileSettings_globalPackageDatabase $ fileSettings dflags +pgm_L :: DynFlags -> String +pgm_L dflags = toolSettings_pgm_L $ toolSettings dflags +pgm_P :: DynFlags -> (String,[Option]) +pgm_P dflags = toolSettings_pgm_P $ toolSettings dflags +pgm_F :: DynFlags -> String +pgm_F dflags = toolSettings_pgm_F $ toolSettings dflags +pgm_c :: DynFlags -> String +pgm_c dflags = toolSettings_pgm_c $ toolSettings dflags +pgm_a :: DynFlags -> (String,[Option]) +pgm_a dflags = toolSettings_pgm_a $ toolSettings dflags +pgm_l :: DynFlags -> (String,[Option]) +pgm_l dflags = toolSettings_pgm_l $ toolSettings dflags +pgm_dll :: DynFlags -> (String,[Option]) +pgm_dll dflags = toolSettings_pgm_dll $ toolSettings dflags +pgm_T :: DynFlags -> String +pgm_T dflags = toolSettings_pgm_T $ toolSettings dflags +pgm_windres :: DynFlags -> String +pgm_windres dflags = toolSettings_pgm_windres $ toolSettings dflags +pgm_libtool :: DynFlags -> String +pgm_libtool dflags = toolSettings_pgm_libtool $ toolSettings dflags +pgm_lcc :: DynFlags -> (String,[Option]) +pgm_lcc dflags = toolSettings_pgm_lcc $ toolSettings dflags +pgm_ar :: DynFlags -> String +pgm_ar dflags = toolSettings_pgm_ar $ toolSettings dflags +pgm_ranlib :: DynFlags -> String +pgm_ranlib dflags = toolSettings_pgm_ranlib $ toolSettings dflags +pgm_lo :: DynFlags -> (String,[Option]) +pgm_lo dflags = toolSettings_pgm_lo $ toolSettings dflags +pgm_lc :: DynFlags -> (String,[Option]) +pgm_lc dflags = toolSettings_pgm_lc $ toolSettings dflags +pgm_i :: DynFlags -> String +pgm_i dflags = toolSettings_pgm_i $ toolSettings dflags +opt_L :: DynFlags -> [String] +opt_L dflags = toolSettings_opt_L $ toolSettings dflags +opt_P :: DynFlags -> [String] +opt_P dflags = concatMap (wayOptP (targetPlatform dflags)) (ways dflags) + ++ toolSettings_opt_P (toolSettings 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) + , toolSettings_opt_P_fingerprint $ toolSettings dflags + ) + +opt_F :: DynFlags -> [String] +opt_F dflags= toolSettings_opt_F $ toolSettings dflags +opt_c :: DynFlags -> [String] +opt_c dflags = concatMap (wayOptc (targetPlatform dflags)) (ways dflags) + ++ toolSettings_opt_c (toolSettings dflags) +opt_cxx :: DynFlags -> [String] +opt_cxx dflags= toolSettings_opt_cxx $ toolSettings dflags +opt_a :: DynFlags -> [String] +opt_a dflags= toolSettings_opt_a $ toolSettings dflags +opt_l :: DynFlags -> [String] +opt_l dflags = concatMap (wayOptl (targetPlatform dflags)) (ways dflags) + ++ toolSettings_opt_l (toolSettings dflags) +opt_windres :: DynFlags -> [String] +opt_windres dflags= toolSettings_opt_windres $ toolSettings dflags +opt_lcc :: DynFlags -> [String] +opt_lcc dflags= toolSettings_opt_lcc $ toolSettings dflags +opt_lo :: DynFlags -> [String] +opt_lo dflags= toolSettings_opt_lo $ toolSettings dflags +opt_lc :: DynFlags -> [String] +opt_lc dflags= toolSettings_opt_lc $ toolSettings dflags +opt_i :: DynFlags -> [String] +opt_i dflags= toolSettings_opt_i $ toolSettings dflags + +tablesNextToCode :: DynFlags -> Bool +tablesNextToCode = platformMisc_tablesNextToCode . platformMisc + +-- | The directory for this version of ghc in the user's app directory +-- (typically something like @~/.ghc/x86_64-linux-7.6.3@) +-- +versionedAppDir :: DynFlags -> MaybeT IO FilePath +versionedAppDir dflags = do + -- Make sure we handle the case the HOME isn't set (see #11678) + appdir <- tryMaybeT $ getAppUserDataDirectory (programName dflags) + return $ appdir </> versionedFilePath dflags + +versionedFilePath :: DynFlags -> FilePath +versionedFilePath dflags = uniqueSubdir $ platformMini $ targetPlatform dflags + +-- | The target code type of the compilation (if any). +-- +-- Whenever you change the target, also make sure to set 'ghcLink' to +-- something sensible. +-- +-- 'HscNothing' can be used to avoid generating any output, however, note +-- that: +-- +-- * If a program uses Template Haskell the typechecker may need to run code +-- from an imported module. To facilitate this, code generation is enabled +-- for modules imported by modules that use template haskell. +-- See Note [-fno-code mode]. +-- +data HscTarget + = HscC -- ^ Generate C code. + | HscAsm -- ^ Generate assembly using the native code generator. + | HscLlvm -- ^ Generate assembly using the llvm code generator. + | HscInterpreted -- ^ Generate bytecode. (Requires 'LinkInMemory') + | HscNothing -- ^ Don't generate any code. See notes above. + deriving (Eq, Show) + +-- | Will this target result in an object file on the disk? +isObjectTarget :: HscTarget -> Bool +isObjectTarget HscC = True +isObjectTarget HscAsm = True +isObjectTarget HscLlvm = True +isObjectTarget _ = False + +-- | Does this target retain *all* top-level bindings for a module, +-- rather than just the exported bindings, in the TypeEnv and compiled +-- code (if any)? In interpreted mode we do this, so that GHCi can +-- call functions inside a module. In HscNothing mode we also do it, +-- so that Haddock can get access to the GlobalRdrEnv for a module +-- after typechecking it. +targetRetainsAllBindings :: HscTarget -> Bool +targetRetainsAllBindings HscInterpreted = True +targetRetainsAllBindings HscNothing = True +targetRetainsAllBindings _ = False + +-- | The 'GhcMode' tells us whether we're doing multi-module +-- compilation (controlled via the "GHC" API) or one-shot +-- (single-module) compilation. This makes a difference primarily to +-- the "Finder": in one-shot mode we look for interface files for +-- imported modules, but in multi-module mode we look for source files +-- in order to check whether they need to be recompiled. +data GhcMode + = CompManager -- ^ @\-\-make@, GHCi, etc. + | OneShot -- ^ @ghc -c Foo.hs@ + | MkDepend -- ^ @ghc -M@, see "Finder" for why we need this + deriving Eq + +instance Outputable GhcMode where + ppr CompManager = text "CompManager" + ppr OneShot = text "OneShot" + ppr MkDepend = text "MkDepend" + +isOneShot :: GhcMode -> Bool +isOneShot OneShot = True +isOneShot _other = False + +-- | What to do in the link step, if there is one. +data GhcLink + = NoLink -- ^ Don't link at all + | LinkBinary -- ^ Link object code into a binary + | LinkInMemory -- ^ Use the in-memory dynamic linker (works for both + -- bytecode and object code). + | LinkDynLib -- ^ Link objects into a dynamic lib (DLL on Windows, DSO on ELF platforms) + | LinkStaticLib -- ^ Link objects into a static lib + deriving (Eq, Show) + +isNoLink :: GhcLink -> Bool +isNoLink NoLink = True +isNoLink _ = False + +-- | We accept flags which make packages visible, but how they select +-- the package varies; this data type reflects what selection criterion +-- is used. +data PackageArg = + PackageArg String -- ^ @-package@, by 'PackageName' + | UnitIdArg UnitId -- ^ @-package-id@, by 'UnitId' + deriving (Eq, Show) +instance Outputable PackageArg where + ppr (PackageArg pn) = text "package" <+> text pn + ppr (UnitIdArg uid) = text "unit" <+> ppr uid + +-- | Represents the renaming that may be associated with an exposed +-- package, e.g. the @rns@ part of @-package "foo (rns)"@. +-- +-- Here are some example parsings of the package flags (where +-- a string literal is punned to be a 'ModuleName': +-- +-- * @-package foo@ is @ModRenaming True []@ +-- * @-package foo ()@ is @ModRenaming False []@ +-- * @-package foo (A)@ is @ModRenaming False [("A", "A")]@ +-- * @-package foo (A as B)@ is @ModRenaming False [("A", "B")]@ +-- * @-package foo with (A as B)@ is @ModRenaming True [("A", "B")]@ +data ModRenaming = ModRenaming { + modRenamingWithImplicit :: Bool, -- ^ Bring all exposed modules into scope? + modRenamings :: [(ModuleName, ModuleName)] -- ^ Bring module @m@ into scope + -- under name @n@. + } deriving (Eq) +instance Outputable ModRenaming where + ppr (ModRenaming b rns) = ppr b <+> parens (ppr rns) + +-- | Flags for manipulating the set of non-broken packages. +newtype IgnorePackageFlag = IgnorePackage String -- ^ @-ignore-package@ + deriving (Eq) + +-- | Flags for manipulating package trust. +data TrustFlag + = TrustPackage String -- ^ @-trust@ + | DistrustPackage String -- ^ @-distrust@ + deriving (Eq) + +-- | Flags for manipulating packages visibility. +data PackageFlag + = ExposePackage String PackageArg ModRenaming -- ^ @-package@, @-package-id@ + | HidePackage String -- ^ @-hide-package@ + deriving (Eq) -- NB: equality instance is used by packageFlagsChanged + +data PackageDBFlag + = PackageDB PkgDbRef + | NoUserPackageDB + | NoGlobalPackageDB + | ClearPackageDBs + deriving (Eq) + +packageFlagsChanged :: DynFlags -> DynFlags -> Bool +packageFlagsChanged idflags1 idflags0 = + packageFlags idflags1 /= packageFlags idflags0 || + ignorePackageFlags idflags1 /= ignorePackageFlags idflags0 || + pluginPackageFlags idflags1 /= pluginPackageFlags idflags0 || + trustFlags idflags1 /= trustFlags idflags0 || + packageDBFlags idflags1 /= packageDBFlags idflags0 || + packageGFlags idflags1 /= packageGFlags idflags0 + where + packageGFlags dflags = map (`gopt` dflags) + [ Opt_HideAllPackages + , Opt_HideAllPluginPackages + , Opt_AutoLinkPackages ] + +instance Outputable PackageFlag where + ppr (ExposePackage n arg rn) = text n <> braces (ppr arg <+> ppr rn) + ppr (HidePackage str) = text "-hide-package" <+> text str + +-- | The 'HscTarget' value corresponding to the default way to create +-- object files on the current platform. + +defaultHscTarget :: Platform -> PlatformMisc -> HscTarget +defaultHscTarget platform pMisc + | platformUnregisterised platform = HscC + | platformMisc_ghcWithNativeCodeGen pMisc = HscAsm + | otherwise = HscLlvm + +defaultObjectTarget :: DynFlags -> HscTarget +defaultObjectTarget dflags = defaultHscTarget + (targetPlatform dflags) + (platformMisc dflags) + +data DynLibLoader + = Deployable + | SystemDependent + deriving Eq + +data RtsOptsEnabled + = RtsOptsNone | RtsOptsIgnore | RtsOptsIgnoreAll | RtsOptsSafeOnly + | RtsOptsAll + deriving (Show) + +-- | Are we building with @-fPIE@ or @-fPIC@ enabled? +positionIndependent :: DynFlags -> Bool +positionIndependent dflags = gopt Opt_PIC dflags || gopt Opt_PIE dflags + +----------------------------------------------------------------------------- +-- Ways + +-- The central concept of a "way" is that all objects in a given +-- program must be compiled in the same "way". Certain options change +-- parameters of the virtual machine, eg. profiling adds an extra word +-- to the object header, so profiling objects cannot be linked with +-- non-profiling objects. + +-- After parsing the command-line options, we determine which "way" we +-- are building - this might be a combination way, eg. profiling+threaded. + +-- We then find the "build-tag" associated with this way, and this +-- becomes the suffix used to find .hi files and libraries used in +-- this compilation. + +data Way + = WayCustom String -- for GHC API clients building custom variants + | WayThreaded + | WayDebug + | WayProf + | WayEventLog + | WayDyn + deriving (Eq, Ord, Show) + +allowed_combination :: [Way] -> Bool +allowed_combination way = and [ x `allowedWith` y + | x <- way, y <- way, x < y ] + where + -- Note ordering in these tests: the left argument is + -- <= the right argument, according to the Ord instance + -- on Way above. + + -- dyn is allowed with everything + _ `allowedWith` WayDyn = True + WayDyn `allowedWith` _ = True + + -- debug is allowed with everything + _ `allowedWith` WayDebug = True + WayDebug `allowedWith` _ = True + + (WayCustom {}) `allowedWith` _ = True + WayThreaded `allowedWith` WayProf = True + WayThreaded `allowedWith` WayEventLog = True + WayProf `allowedWith` WayEventLog = True + _ `allowedWith` _ = False + +mkBuildTag :: [Way] -> String +mkBuildTag ways = concat (intersperse "_" (map wayTag ways)) + +wayTag :: Way -> String +wayTag (WayCustom xs) = xs +wayTag WayThreaded = "thr" +wayTag WayDebug = "debug" +wayTag WayDyn = "dyn" +wayTag WayProf = "p" +wayTag WayEventLog = "l" + +wayRTSOnly :: Way -> Bool +wayRTSOnly (WayCustom {}) = False +wayRTSOnly WayThreaded = True +wayRTSOnly WayDebug = True +wayRTSOnly WayDyn = False +wayRTSOnly WayProf = False +wayRTSOnly WayEventLog = True + +wayDesc :: Way -> String +wayDesc (WayCustom xs) = xs +wayDesc WayThreaded = "Threaded" +wayDesc WayDebug = "Debug" +wayDesc WayDyn = "Dynamic" +wayDesc WayProf = "Profiling" +wayDesc WayEventLog = "RTS Event Logging" + +-- Turn these flags on when enabling this way +wayGeneralFlags :: Platform -> Way -> [GeneralFlag] +wayGeneralFlags _ (WayCustom {}) = [] +wayGeneralFlags _ WayThreaded = [] +wayGeneralFlags _ WayDebug = [] +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 + -- the libraries need to be. HOWEVER, GHCi links objects into a + -- .so before loading the .so using the system linker. Since only + -- PIC objects can be linked into a .so, we have to compile even + -- modules of the main program with -fPIC when using -dynamic. +wayGeneralFlags _ WayProf = [Opt_SccProfilingOn] +wayGeneralFlags _ WayEventLog = [] + +-- Turn these flags off when enabling this way +wayUnsetGeneralFlags :: Platform -> Way -> [GeneralFlag] +wayUnsetGeneralFlags _ (WayCustom {}) = [] +wayUnsetGeneralFlags _ WayThreaded = [] +wayUnsetGeneralFlags _ WayDebug = [] +wayUnsetGeneralFlags _ WayDyn = [-- There's no point splitting + -- when we're going to be dynamically + -- linking. Plus it breaks compilation + -- on OSX x86. + Opt_SplitSections] +wayUnsetGeneralFlags _ WayProf = [] +wayUnsetGeneralFlags _ WayEventLog = [] + +wayOptc :: Platform -> Way -> [String] +wayOptc _ (WayCustom {}) = [] +wayOptc platform WayThreaded = case platformOS platform of + OSOpenBSD -> ["-pthread"] + OSNetBSD -> ["-pthread"] + _ -> [] +wayOptc _ WayDebug = [] +wayOptc _ WayDyn = [] +wayOptc _ WayProf = ["-DPROFILING"] +wayOptc _ WayEventLog = ["-DTRACING"] + +wayOptl :: Platform -> Way -> [String] +wayOptl _ (WayCustom {}) = [] +wayOptl platform WayThreaded = + case platformOS platform of + -- N.B. FreeBSD cc throws a warning if we pass -pthread without + -- actually using any pthread symbols. + OSFreeBSD -> ["-pthread", "-Wno-unused-command-line-argument"] + OSOpenBSD -> ["-pthread"] + OSNetBSD -> ["-pthread"] + _ -> [] +wayOptl _ WayDebug = [] +wayOptl _ WayDyn = [] +wayOptl _ WayProf = [] +wayOptl _ WayEventLog = [] + +wayOptP :: Platform -> Way -> [String] +wayOptP _ (WayCustom {}) = [] +wayOptP _ WayThreaded = [] +wayOptP _ WayDebug = [] +wayOptP _ WayDyn = [] +wayOptP _ WayProf = ["-DPROFILING"] +wayOptP _ WayEventLog = ["-DTRACING"] + +whenGeneratingDynamicToo :: MonadIO m => DynFlags -> m () -> m () +whenGeneratingDynamicToo dflags f = ifGeneratingDynamicToo dflags f (return ()) + +ifGeneratingDynamicToo :: MonadIO m => DynFlags -> m a -> m a -> m a +ifGeneratingDynamicToo dflags f g = generateDynamicTooConditional dflags f g g + +whenCannotGenerateDynamicToo :: MonadIO m => DynFlags -> m () -> m () +whenCannotGenerateDynamicToo dflags f + = ifCannotGenerateDynamicToo dflags f (return ()) + +ifCannotGenerateDynamicToo :: MonadIO m => DynFlags -> m a -> m a -> m a +ifCannotGenerateDynamicToo dflags f g + = generateDynamicTooConditional dflags g f g + +generateDynamicTooConditional :: MonadIO m + => DynFlags -> m a -> m a -> m a -> m a +generateDynamicTooConditional dflags canGen cannotGen notTryingToGen + = if gopt Opt_BuildDynamicToo dflags + then do let ref = canGenerateDynamicToo dflags + b <- liftIO $ readIORef ref + if b then canGen else cannotGen + else notTryingToGen + +dynamicTooMkDynamicDynFlags :: DynFlags -> DynFlags +dynamicTooMkDynamicDynFlags dflags0 + = let dflags1 = addWay' WayDyn dflags0 + dflags2 = dflags1 { + outputFile = dynOutputFile dflags1, + hiSuf = dynHiSuf dflags1, + objectSuf = dynObjectSuf dflags1 + } + dflags3 = updateWays dflags2 + dflags4 = gopt_unset dflags3 Opt_BuildDynamicToo + in dflags4 + +-- | Compute the path of the dynamic object corresponding to an object file. +dynamicOutputFile :: DynFlags -> FilePath -> FilePath +dynamicOutputFile dflags outputFile = dynOut outputFile + where + dynOut = flip addExtension (dynObjectSuf dflags) . dropExtension + +----------------------------------------------------------------------------- + +-- | Used by 'GHC.runGhc' to partially initialize a new 'DynFlags' value +initDynFlags :: DynFlags -> IO DynFlags +initDynFlags dflags = do + let -- We can't build with dynamic-too on Windows, as labels before + -- the fork point are different depending on whether we are + -- building dynamically or not. + platformCanGenerateDynamicToo + = platformOS (targetPlatform dflags) /= OSMinGW32 + refCanGenerateDynamicToo <- newIORef platformCanGenerateDynamicToo + refNextTempSuffix <- newIORef 0 + refFilesToClean <- newIORef emptyFilesToClean + refDirsToClean <- newIORef Map.empty + refGeneratedDumps <- newIORef Set.empty + refRtldInfo <- newIORef Nothing + refRtccInfo <- newIORef Nothing + wrapperNum <- newIORef emptyModuleEnv + canUseUnicode <- do let enc = localeEncoding + str = "‘’" + (withCString enc str $ \cstr -> + do str' <- peekCString enc cstr + return (str == str')) + `catchIOError` \_ -> return False + ghcNoUnicodeEnv <- lookupEnv "GHC_NO_UNICODE" + let useUnicode' = isNothing ghcNoUnicodeEnv && canUseUnicode + canUseColor <- stderrSupportsAnsiColors + maybeGhcColorsEnv <- lookupEnv "GHC_COLORS" + maybeGhcColoursEnv <- lookupEnv "GHC_COLOURS" + let adjustCols (Just env) = Col.parseScheme env + adjustCols Nothing = id + let (useColor', colScheme') = + (adjustCols maybeGhcColoursEnv . adjustCols maybeGhcColorsEnv) + (useColor dflags, colScheme dflags) + return dflags{ + canGenerateDynamicToo = refCanGenerateDynamicToo, + nextTempSuffix = refNextTempSuffix, + filesToClean = refFilesToClean, + dirsToClean = refDirsToClean, + generatedDumps = refGeneratedDumps, + nextWrapperNum = wrapperNum, + useUnicode = useUnicode', + useColor = useColor', + canUseColor = canUseColor, + colScheme = colScheme', + rtldInfo = refRtldInfo, + rtccInfo = refRtccInfo + } + +-- | 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 -> LlvmConfig -> DynFlags +defaultDynFlags mySettings llvmConfig = +-- See Note [Updating flag description in the User's Guide] + DynFlags { + ghcMode = CompManager, + ghcLink = LinkBinary, + hscTarget = defaultHscTarget (sTargetPlatform mySettings) (sPlatformMisc mySettings), + integerLibrary = sIntegerLibraryType mySettings, + verbosity = 0, + optLevel = 0, + debugLevel = 0, + simplPhases = 2, + maxSimplIterations = 4, + ruleCheck = Nothing, + inlineCheck = Nothing, + binBlobThreshold = 500000, -- 500K is a good default (see #16190) + maxRelevantBinds = Just 6, + maxValidHoleFits = Just 6, + maxRefHoleFits = Just 6, + refLevelHoleFits = Nothing, + maxUncoveredPatterns = 4, + maxPmCheckModels = 30, + simplTickFactor = 100, + specConstrThreshold = Just 2000, + specConstrCount = Just 3, + specConstrRecursive = 3, + liberateCaseThreshold = Just 2000, + floatLamArgs = Just 0, -- Default: float only if no fvs + liftLamsRecArgs = Just 5, -- Default: the number of available argument hardware registers on x86_64 + liftLamsNonRecArgs = Just 5, -- Default: the number of available argument hardware registers on x86_64 + liftLamsKnown = False, -- Default: don't turn known calls into unknown ones + cmmProcAlignment = Nothing, + + historySize = 20, + strictnessBefore = [], + + parMakeCount = Just 1, + + enableTimeStats = False, + ghcHeapSize = Nothing, + + importPaths = ["."], + mainModIs = mAIN, + mainFunIs = Nothing, + reductionDepth = treatZeroAsInf mAX_REDUCTION_DEPTH, + solverIterations = treatZeroAsInf mAX_SOLVER_ITERATIONS, + + thisInstalledUnitId = toInstalledUnitId mainUnitId, + thisUnitIdInsts_ = Nothing, + thisComponentId_ = Nothing, + + objectDir = Nothing, + dylibInstallName = Nothing, + hiDir = Nothing, + hieDir = Nothing, + stubDir = Nothing, + dumpDir = Nothing, + + objectSuf = phaseInputExt StopLn, + hcSuf = phaseInputExt HCc, + hiSuf = "hi", + hieSuf = "hie", + + canGenerateDynamicToo = panic "defaultDynFlags: No canGenerateDynamicToo", + dynObjectSuf = "dyn_" ++ phaseInputExt StopLn, + dynHiSuf = "dyn_hi", + + pluginModNames = [], + pluginModNameOpts = [], + frontendPluginOpts = [], + cachedPlugins = [], + staticPlugins = [], + hooks = emptyHooks, + + outputFile = Nothing, + dynOutputFile = Nothing, + outputHi = Nothing, + dynLibLoader = SystemDependent, + dumpPrefix = Nothing, + dumpPrefixForce = Nothing, + ldInputs = [], + includePaths = IncludeSpecs [] [], + libraryPaths = [], + frameworkPaths = [], + cmdlineFrameworks = [], + rtsOpts = Nothing, + rtsOptsEnabled = RtsOptsSafeOnly, + rtsOptsSuggestions = True, + + hpcDir = ".hpc", + + packageDBFlags = [], + packageFlags = [], + pluginPackageFlags = [], + ignorePackageFlags = [], + trustFlags = [], + packageEnv = Nothing, + pkgDatabase = Nothing, + pkgState = emptyPackageState, + ways = defaultWays mySettings, + buildTag = mkBuildTag (defaultWays mySettings), + splitInfo = Nothing, + + ghcNameVersion = sGhcNameVersion mySettings, + fileSettings = sFileSettings mySettings, + toolSettings = sToolSettings mySettings, + targetPlatform = sTargetPlatform mySettings, + platformMisc = sPlatformMisc mySettings, + platformConstants = sPlatformConstants mySettings, + rawSettings = sRawSettings mySettings, + + -- See Note [LLVM configuration]. + llvmConfig = llvmConfig, + + -- ghc -M values + depMakefile = "Makefile", + depIncludePkgDeps = False, + depIncludeCppDeps = False, + depExcludeMods = [], + depSuffixes = [], + -- end of ghc -M values + nextTempSuffix = panic "defaultDynFlags: No nextTempSuffix", + 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), + warningFlags = EnumSet.fromList standardWarnings, + fatalWarningFlags = EnumSet.empty, + ghciScripts = [], + language = Nothing, + safeHaskell = Sf_None, + safeInfer = True, + safeInferred = True, + thOnLoc = noSrcSpan, + newDerivOnLoc = noSrcSpan, + overlapInstLoc = noSrcSpan, + incoherentOnLoc = noSrcSpan, + pkgTrustOnLoc = noSrcSpan, + warnSafeOnLoc = noSrcSpan, + warnUnsafeOnLoc = noSrcSpan, + trustworthyOnLoc = noSrcSpan, + extensions = [], + extensionFlags = flattenExtensionFlags Nothing [], + + -- The ufCreationThreshold threshold must be reasonably high to + -- take account of possible discounts. + -- E.g. 450 is not enough in 'fulsom' for Interval.sqr to inline + -- into Csg.calc (The unfolding for sqr never makes it into the + -- interface file.) + ufCreationThreshold = 750, + ufUseThreshold = 60, + ufFunAppDiscount = 60, + -- Be fairly keen to inline a function if that means + -- we'll be able to pick the right method from a dictionary + ufDictDiscount = 30, + ufKeenessFactor = 1.5, + ufDearOp = 40, + ufVeryAggressive = False, + + maxWorkerArgs = 10, + + ghciHistSize = 50, -- keep a log of length 50 by default + + -- Logging + + log_action = defaultLogAction, + dump_action = defaultDumpAction, + trace_action = defaultTraceAction, + + flushOut = defaultFlushOut, + flushErr = defaultFlushErr, + pprUserLength = 5, + pprCols = 100, + useUnicode = False, + useColor = Auto, + canUseColor = False, + colScheme = Col.defaultScheme, + profAuto = NoProfAuto, + interactivePrint = Nothing, + nextWrapperNum = panic "defaultDynFlags: No nextWrapperNum", + sseVersion = Nothing, + bmiVersion = Nothing, + avx = False, + avx2 = False, + avx512cd = False, + avx512er = False, + avx512f = False, + avx512pf = False, + rtldInfo = panic "defaultDynFlags: no rtldInfo", + rtccInfo = panic "defaultDynFlags: no rtccInfo", + + maxInlineAllocSize = 128, + maxInlineMemcpyInsns = 32, + maxInlineMemsetInsns = 32, + + initialUnique = 0, + uniqueIncrement = 1, + + reverseErrors = False, + maxErrors = Nothing, + cfgWeightInfo = defaultCfgWeights + } + +defaultWays :: Settings -> [Way] +defaultWays settings = if pc_DYNAMIC_BY_DEFAULT (sPlatformConstants settings) + then [WayDyn] + else [] + +interpWays :: [Way] +interpWays + | dynamicGhc = [WayDyn] + | rtsIsProfiled = [WayProf] + | otherwise = [] + +interpreterProfiled :: DynFlags -> Bool +interpreterProfiled dflags + | gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags + | otherwise = rtsIsProfiled + +interpreterDynamic :: DynFlags -> Bool +interpreterDynamic dflags + | gopt Opt_ExternalInterpreter dflags = WayDyn `elem` ways dflags + | otherwise = dynamicGhc + +-------------------------------------------------------------------------- +-- +-- Note [JSON Error Messages] +-- +-- When the user requests the compiler output to be dumped as json +-- 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 +-- information to provide to the user but refactoring log_action is quite +-- invasive as it is called in many places. So, for now I left it alone +-- and we can refine its behaviour as users request different output. + +type FatalMessager = String -> IO () + +type LogAction = DynFlags + -> WarnReason + -> Severity + -> SrcSpan + -> PprStyle + -> MsgDoc + -> IO () + +defaultFatalMessager :: FatalMessager +defaultFatalMessager = hPutStrLn stderr + + +-- See Note [JSON Error Messages] +-- +jsonLogAction :: LogAction +jsonLogAction dflags reason severity srcSpan _style msg + = do + 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 +defaultLogAction dflags reason severity srcSpan style msg + = case severity of + SevOutput -> printOut msg style + SevDump -> printOut (msg $$ blankLine) style + SevInteractive -> putStrSDoc msg style + SevInfo -> printErrs msg style + SevFatal -> printErrs msg style + SevWarning -> printWarns + SevError -> printWarns + where + printOut = defaultLogActionHPrintDoc dflags stdout + printErrs = defaultLogActionHPrintDoc dflags stderr + putStrSDoc = defaultLogActionHPutStrDoc dflags stdout + -- Pretty print the warning flag, if any (#10752) + message = mkLocMessageAnn flagMsg severity srcSpan msg + + printWarns = do + hPutChar stderr '\n' + caretDiagnostic <- + if gopt Opt_DiagnosticsShowCaret dflags + then getCaretDiagnostic severity srcSpan + else pure empty + printErrs (message $+$ caretDiagnostic) + (setStyleColoured True style) + -- careful (#2302): printErrs prints in UTF-8, + -- whereas converting to string first and using + -- hPutStr would just emit the low 8 bits of + -- each unicode char. + + flagMsg = + case reason of + NoReason -> Nothing + Reason wflag -> do + spec <- flagSpecOf wflag + return ("-W" ++ flagSpecName spec ++ warnFlagGrp wflag) + ErrReason Nothing -> + return "-Werror" + ErrReason (Just wflag) -> do + spec <- flagSpecOf wflag + return $ + "-W" ++ flagSpecName spec ++ warnFlagGrp wflag ++ + ", -Werror=" ++ flagSpecName spec + + warnFlagGrp flag + | gopt Opt_ShowWarnGroups dflags = + case smallestGroups flag of + [] -> "" + groups -> " (in " ++ intercalate ", " (map ("-W"++) groups) ++ ")" + | otherwise = "" + +-- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline. +defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO () +defaultLogActionHPrintDoc dflags h d sty + = defaultLogActionHPutStrDoc dflags h (d $$ text "") sty + +defaultLogActionHPutStrDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO () +defaultLogActionHPutStrDoc dflags h d sty + -- Don't add a newline at the end, so that successive + -- calls to this log-action can output all on the same line + = printSDoc Pretty.PageMode dflags h sty d + +newtype FlushOut = FlushOut (IO ()) + +defaultFlushOut :: FlushOut +defaultFlushOut = FlushOut $ hFlush stdout + +newtype FlushErr = FlushErr (IO ()) + +defaultFlushErr :: FlushErr +defaultFlushErr = FlushErr $ hFlush stderr + +{- +Note [Verbosity levels] +~~~~~~~~~~~~~~~~~~~~~~~ + 0 | print errors & warnings only + 1 | minimal verbosity: print "compiling M ... done." for each module. + 2 | equivalent to -dshow-passes + 3 | equivalent to existing "ghc -v" + 4 | "ghc -v -ddump-most" + 5 | "ghc -v -ddump-all" +-} + +data OnOff a = On a + | Off a + deriving (Eq, Show) + +instance Outputable a => Outputable (OnOff a) where + ppr (On x) = text "On" <+> ppr x + ppr (Off x) = text "Off" <+> ppr x + +-- OnOffs accumulate in reverse order, so we use foldr in order to +-- process them in the right order +flattenExtensionFlags :: Maybe Language -> [OnOff LangExt.Extension] -> EnumSet LangExt.Extension +flattenExtensionFlags ml = foldr f defaultExtensionFlags + where f (On f) flags = EnumSet.insert f flags + f (Off f) flags = EnumSet.delete f flags + defaultExtensionFlags = EnumSet.fromList (languageExtensions ml) + +-- | The language extensions implied by the various language variants. +-- When updating this be sure to update the flag documentation in +-- @docs/users-guide/glasgow_exts.rst@. +languageExtensions :: Maybe Language -> [LangExt.Extension] + +languageExtensions Nothing + -- Nothing => the default case + = LangExt.NondecreasingIndentation -- This has been on by default for some time + : delete LangExt.DatatypeContexts -- The Haskell' committee decided to + -- remove datatype contexts from the + -- language: + -- http://www.haskell.org/pipermail/haskell-prime/2011-January/003335.html + (languageExtensions (Just Haskell2010)) + + -- NB: MonoPatBinds is no longer the default + +languageExtensions (Just Haskell98) + = [LangExt.ImplicitPrelude, + -- See Note [When is StarIsType enabled] + LangExt.StarIsType, + LangExt.CUSKs, + LangExt.MonomorphismRestriction, + LangExt.NPlusKPatterns, + LangExt.DatatypeContexts, + LangExt.TraditionalRecordSyntax, + LangExt.NondecreasingIndentation + -- strictly speaking non-standard, but we always had this + -- on implicitly before the option was added in 7.1, and + -- turning it off breaks code, so we're keeping it on for + -- backwards compatibility. Cabal uses -XHaskell98 by + -- default unless you specify another language. + ] + +languageExtensions (Just Haskell2010) + = [LangExt.ImplicitPrelude, + -- See Note [When is StarIsType enabled] + LangExt.StarIsType, + LangExt.CUSKs, + LangExt.MonomorphismRestriction, + LangExt.DatatypeContexts, + LangExt.TraditionalRecordSyntax, + LangExt.EmptyDataDecls, + LangExt.ForeignFunctionInterface, + LangExt.PatternGuards, + LangExt.DoAndIfThenElse, + LangExt.RelaxedPolyRec] + +hasPprDebug :: DynFlags -> Bool +hasPprDebug = dopt Opt_D_ppr_debug + +hasNoDebugOutput :: DynFlags -> Bool +hasNoDebugOutput = dopt Opt_D_no_debug_output + +hasNoStateHack :: DynFlags -> Bool +hasNoStateHack = gopt Opt_G_NoStateHack + +hasNoOptCoercion :: DynFlags -> Bool +hasNoOptCoercion = gopt Opt_G_NoOptCoercion + + +-- | Test whether a 'DumpFlag' is set +dopt :: DumpFlag -> DynFlags -> Bool +dopt f dflags = (f `EnumSet.member` dumpFlags dflags) + || (verbosity dflags >= 4 && enableIfVerbose f) + where enableIfVerbose Opt_D_dump_tc_trace = False + enableIfVerbose Opt_D_dump_rn_trace = False + enableIfVerbose Opt_D_dump_cs_trace = False + enableIfVerbose Opt_D_dump_if_trace = False + enableIfVerbose Opt_D_dump_vt_trace = False + enableIfVerbose Opt_D_dump_tc = False + enableIfVerbose Opt_D_dump_rn = False + enableIfVerbose Opt_D_dump_rn_stats = False + enableIfVerbose Opt_D_dump_hi_diffs = False + enableIfVerbose Opt_D_verbose_core2core = False + enableIfVerbose Opt_D_verbose_stg2stg = False + enableIfVerbose Opt_D_dump_splices = False + enableIfVerbose Opt_D_th_dec_file = False + enableIfVerbose Opt_D_dump_rule_firings = False + enableIfVerbose Opt_D_dump_rule_rewrites = False + enableIfVerbose Opt_D_dump_simpl_trace = False + enableIfVerbose Opt_D_dump_rtti = False + enableIfVerbose Opt_D_dump_inlinings = False + enableIfVerbose Opt_D_dump_core_stats = False + enableIfVerbose Opt_D_dump_asm_stats = False + enableIfVerbose Opt_D_dump_types = False + enableIfVerbose Opt_D_dump_simpl_iterations = False + enableIfVerbose Opt_D_dump_ticked = False + enableIfVerbose Opt_D_dump_view_pattern_commoning = False + enableIfVerbose Opt_D_dump_mod_cycles = False + enableIfVerbose Opt_D_dump_mod_map = False + enableIfVerbose Opt_D_dump_ec_trace = False + enableIfVerbose _ = True + +-- | Set a 'DumpFlag' +dopt_set :: DynFlags -> DumpFlag -> DynFlags +dopt_set dfs f = dfs{ dumpFlags = EnumSet.insert f (dumpFlags dfs) } + +-- | Unset a 'DumpFlag' +dopt_unset :: DynFlags -> DumpFlag -> DynFlags +dopt_unset dfs f = dfs{ dumpFlags = EnumSet.delete f (dumpFlags dfs) } + +-- | Test whether a 'GeneralFlag' is set +gopt :: GeneralFlag -> DynFlags -> Bool +gopt f dflags = f `EnumSet.member` generalFlags dflags + +-- | Set a 'GeneralFlag' +gopt_set :: DynFlags -> GeneralFlag -> DynFlags +gopt_set dfs f = dfs{ generalFlags = EnumSet.insert f (generalFlags dfs) } + +-- | Unset a 'GeneralFlag' +gopt_unset :: DynFlags -> GeneralFlag -> DynFlags +gopt_unset dfs f = dfs{ generalFlags = EnumSet.delete f (generalFlags dfs) } + +-- | Test whether a 'WarningFlag' is set +wopt :: WarningFlag -> DynFlags -> Bool +wopt f dflags = f `EnumSet.member` warningFlags dflags + +-- | Set a 'WarningFlag' +wopt_set :: DynFlags -> WarningFlag -> DynFlags +wopt_set dfs f = dfs{ warningFlags = EnumSet.insert f (warningFlags dfs) } + +-- | Unset a 'WarningFlag' +wopt_unset :: DynFlags -> WarningFlag -> DynFlags +wopt_unset dfs f = dfs{ warningFlags = EnumSet.delete f (warningFlags dfs) } + +-- | Test whether a 'WarningFlag' is set as fatal +wopt_fatal :: WarningFlag -> DynFlags -> Bool +wopt_fatal f dflags = f `EnumSet.member` fatalWarningFlags dflags + +-- | Mark a 'WarningFlag' as fatal (do not set the flag) +wopt_set_fatal :: DynFlags -> WarningFlag -> DynFlags +wopt_set_fatal dfs f + = dfs { fatalWarningFlags = EnumSet.insert f (fatalWarningFlags dfs) } + +-- | Mark a 'WarningFlag' as not fatal +wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags +wopt_unset_fatal dfs f + = dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) } + +-- | Test whether a 'LangExt.Extension' is set +xopt :: LangExt.Extension -> DynFlags -> Bool +xopt f dflags = f `EnumSet.member` extensionFlags dflags + +-- | Set a 'LangExt.Extension' +xopt_set :: DynFlags -> LangExt.Extension -> DynFlags +xopt_set dfs f + = let onoffs = On f : extensions dfs + in dfs { extensions = onoffs, + extensionFlags = flattenExtensionFlags (language dfs) onoffs } + +-- | Unset a 'LangExt.Extension' +xopt_unset :: DynFlags -> LangExt.Extension -> DynFlags +xopt_unset dfs f + = let onoffs = Off f : extensions dfs + in dfs { extensions = onoffs, + extensionFlags = flattenExtensionFlags (language dfs) onoffs } + +-- | Set or unset a 'LangExt.Extension', unless it has been explicitly +-- set or unset before. +xopt_set_unlessExplSpec + :: LangExt.Extension + -> (DynFlags -> LangExt.Extension -> DynFlags) + -> DynFlags -> DynFlags +xopt_set_unlessExplSpec ext setUnset dflags = + let referedExts = stripOnOff <$> extensions dflags + stripOnOff (On x) = x + stripOnOff (Off x) = x + in + if ext `elem` referedExts then dflags else setUnset dflags ext + +lang_set :: DynFlags -> Maybe Language -> DynFlags +lang_set dflags lang = + dflags { + language = lang, + extensionFlags = flattenExtensionFlags lang (extensions dflags) + } + +-- | Set the Haskell language standard to use +setLanguage :: Language -> DynP () +setLanguage l = upd (`lang_set` Just l) + +-- | Some modules have dependencies on others through the DynFlags rather than textual imports +dynFlagDependencies :: DynFlags -> [ModuleName] +dynFlagDependencies = pluginModNames + +-- | Is the -fpackage-trust mode on +packageTrustOn :: DynFlags -> Bool +packageTrustOn = gopt Opt_PackageTrust + +-- | Is Safe Haskell on in some way (including inference mode) +safeHaskellOn :: DynFlags -> Bool +safeHaskellOn dflags = safeHaskellModeEnabled dflags || safeInferOn dflags + +safeHaskellModeEnabled :: DynFlags -> Bool +safeHaskellModeEnabled dflags = safeHaskell dflags `elem` [Sf_Unsafe, Sf_Trustworthy + , Sf_Safe ] + + +-- | Is the Safe Haskell safe language in use +safeLanguageOn :: DynFlags -> Bool +safeLanguageOn dflags = safeHaskell dflags == Sf_Safe + +-- | Is the Safe Haskell safe inference mode active +safeInferOn :: DynFlags -> Bool +safeInferOn = safeInfer + +-- | Test if Safe Imports are on in some form +safeImportsOn :: DynFlags -> Bool +safeImportsOn dflags = safeHaskell dflags == Sf_Unsafe || + safeHaskell dflags == Sf_Trustworthy || + safeHaskell dflags == Sf_Safe + +-- | Set a 'Safe Haskell' flag +setSafeHaskell :: SafeHaskellMode -> DynP () +setSafeHaskell s = updM f + where f dfs = do + let sf = safeHaskell dfs + safeM <- combineSafeFlags sf s + case s of + Sf_Safe -> return $ dfs { safeHaskell = safeM, safeInfer = False } + -- leave safe inferrence on in Trustworthy mode so we can warn + -- if it could have been inferred safe. + Sf_Trustworthy -> do + l <- getCurLoc + return $ dfs { safeHaskell = safeM, trustworthyOnLoc = l } + -- leave safe inference on in Unsafe mode as well. + _ -> return $ dfs { safeHaskell = safeM } + +-- | Are all direct imports required to be safe for this Safe Haskell mode? +-- Direct imports are when the code explicitly imports a module +safeDirectImpsReq :: DynFlags -> Bool +safeDirectImpsReq d = safeLanguageOn d + +-- | Are all implicit imports required to be safe for this Safe Haskell mode? +-- Implicit imports are things in the prelude. e.g System.IO when print is used. +safeImplicitImpsReq :: DynFlags -> Bool +safeImplicitImpsReq d = safeLanguageOn d + +-- | Combine two Safe Haskell modes correctly. Used for dealing with multiple flags. +-- This makes Safe Haskell very much a monoid but for now I prefer this as I don't +-- want to export this functionality from the module but do want to export the +-- type constructors. +combineSafeFlags :: SafeHaskellMode -> SafeHaskellMode -> DynP SafeHaskellMode +combineSafeFlags a b | a == Sf_None = return b + | b == Sf_None = return a + | a == Sf_Ignore || b == Sf_Ignore = return Sf_Ignore + | a == b = return a + | otherwise = addErr errm >> pure a + where errm = "Incompatible Safe Haskell flags! (" + ++ show a ++ ", " ++ show b ++ ")" + +-- | A list of unsafe flags under Safe Haskell. Tuple elements are: +-- * name of the flag +-- * function to get srcspan that enabled the flag +-- * function to test if the flag is on +-- * function to turn the flag off +unsafeFlags, unsafeFlagsForInfer + :: [(String, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)] +unsafeFlags = [ ("-XGeneralizedNewtypeDeriving", newDerivOnLoc, + xopt LangExt.GeneralizedNewtypeDeriving, + flip xopt_unset LangExt.GeneralizedNewtypeDeriving) + , ("-XTemplateHaskell", thOnLoc, + xopt LangExt.TemplateHaskell, + flip xopt_unset LangExt.TemplateHaskell) + ] +unsafeFlagsForInfer = unsafeFlags + + +-- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order +getOpts :: DynFlags -- ^ 'DynFlags' to retrieve the options from + -> (DynFlags -> [a]) -- ^ Relevant record accessor: one of the @opt_*@ accessors + -> [a] -- ^ Correctly ordered extracted options +getOpts dflags opts = reverse (opts dflags) + -- We add to the options from the front, so we need to reverse the list + +-- | Gets the verbosity flag for the current verbosity level. This is fed to +-- other tools, so GHC-specific verbosity flags like @-ddump-most@ are not included +getVerbFlags :: DynFlags -> [String] +getVerbFlags dflags + | verbosity dflags >= 4 = ["-v"] + | otherwise = [] + +setObjectDir, setHiDir, setHieDir, setStubDir, setDumpDir, setOutputDir, + setDynObjectSuf, setDynHiSuf, + setDylibInstallName, + setObjectSuf, setHiSuf, setHieSuf, setHcSuf, parseDynLibLoaderMode, + setPgmP, addOptl, addOptc, addOptcxx, addOptP, + addCmdlineFramework, addHaddockOpts, addGhciScript, + setInteractivePrint + :: String -> DynFlags -> DynFlags +setOutputFile, setDynOutputFile, setOutputHi, setDumpPrefixForce + :: Maybe String -> DynFlags -> DynFlags + +setObjectDir f d = d { objectDir = Just f} +setHiDir f d = d { hiDir = Just f} +setHieDir f d = d { hieDir = Just f} +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). +setDumpDir f d = d { dumpDir = Just f} +setOutputDir f = setObjectDir f + . setHieDir f + . setHiDir f + . setStubDir f + . setDumpDir f +setDylibInstallName f d = d { dylibInstallName = Just f} + +setObjectSuf f d = d { objectSuf = f} +setDynObjectSuf f d = d { dynObjectSuf = f} +setHiSuf f d = d { hiSuf = f} +setHieSuf f d = d { hieSuf = f} +setDynHiSuf f d = d { dynHiSuf = f} +setHcSuf f d = d { hcSuf = f} + +setOutputFile f d = d { outputFile = f} +setDynOutputFile f d = d { dynOutputFile = f} +setOutputHi f d = d { outputHi = f} + +setJsonLogAction :: DynFlags -> DynFlags +setJsonLogAction d = d { log_action = jsonLogAction } + +thisComponentId :: DynFlags -> ComponentId +thisComponentId dflags = + case thisComponentId_ dflags of + Just cid -> cid + Nothing -> + case thisUnitIdInsts_ dflags of + Just _ -> + throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id") + Nothing -> ComponentId (unitIdFS (thisPackage dflags)) + +thisUnitIdInsts :: DynFlags -> [(ModuleName, Module)] +thisUnitIdInsts dflags = + case thisUnitIdInsts_ dflags of + Just insts -> insts + Nothing -> [] + +thisPackage :: DynFlags -> UnitId +thisPackage dflags = + case thisUnitIdInsts_ dflags of + Nothing -> default_uid + Just insts + | all (\(x,y) -> mkHoleModule x == y) insts + -> newUnitId (thisComponentId dflags) insts + | otherwise + -> default_uid + where + default_uid = DefiniteUnitId (DefUnitId (thisInstalledUnitId dflags)) + +parseUnitIdInsts :: String -> [(ModuleName, Module)] +parseUnitIdInsts str = case filter ((=="").snd) (readP_to_S parse str) of + [(r, "")] -> r + _ -> throwGhcException $ CmdLineError ("Can't parse -instantiated-with: " ++ str) + where parse = sepBy parseEntry (R.char ',') + parseEntry = do + n <- parseModuleName + _ <- R.char '=' + m <- parseModuleId + return (n, m) + +setUnitIdInsts :: String -> DynFlags -> DynFlags +setUnitIdInsts s d = + d { thisUnitIdInsts_ = Just (parseUnitIdInsts s) } + +setComponentId :: String -> DynFlags -> DynFlags +setComponentId s d = + d { thisComponentId_ = Just (ComponentId (fsLit s)) } + +addPluginModuleName :: String -> DynFlags -> DynFlags +addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) } + +clearPluginModuleNames :: DynFlags -> DynFlags +clearPluginModuleNames d = + d { pluginModNames = [] + , pluginModNameOpts = [] + , cachedPlugins = [] } + +addPluginModuleNameOption :: String -> DynFlags -> DynFlags +addPluginModuleNameOption optflag d = d { pluginModNameOpts = (mkModuleName m, option) : (pluginModNameOpts d) } + where (m, rest) = break (== ':') optflag + option = case rest of + [] -> "" -- should probably signal an error + (_:plug_opt) -> plug_opt -- ignore the ':' from break + +addFrontendPluginOption :: String -> DynFlags -> DynFlags +addFrontendPluginOption s d = d { frontendPluginOpts = s : frontendPluginOpts d } + +parseDynLibLoaderMode f d = + case splitAt 8 f of + ("deploy", "") -> d { dynLibLoader = Deployable } + ("sysdep", "") -> d { dynLibLoader = SystemDependent } + _ -> throwGhcException (CmdLineError ("Unknown dynlib loader: " ++ f)) + +setDumpPrefixForce f d = d { dumpPrefixForce = f} + +-- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"] +-- Config.hs should really use Option. +setPgmP f = alterToolSettings (\s -> s { toolSettings_pgm_P = (pgm, map Option args)}) + where (pgm:args) = words f +addOptl f = alterToolSettings (\s -> s { toolSettings_opt_l = f : toolSettings_opt_l s}) +addOptc f = alterToolSettings (\s -> s { toolSettings_opt_c = f : toolSettings_opt_c s}) +addOptcxx f = alterToolSettings (\s -> s { toolSettings_opt_cxx = f : toolSettings_opt_cxx s}) +addOptP f = alterToolSettings $ \s -> s + { toolSettings_opt_P = f : toolSettings_opt_P s + , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s) + } + -- See Note [Repeated -optP hashing] + where + fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss + + +setDepMakefile :: FilePath -> DynFlags -> DynFlags +setDepMakefile f d = d { depMakefile = f } + +setDepIncludeCppDeps :: Bool -> DynFlags -> DynFlags +setDepIncludeCppDeps b d = d { depIncludeCppDeps = b } + +setDepIncludePkgDeps :: Bool -> DynFlags -> DynFlags +setDepIncludePkgDeps b d = d { depIncludePkgDeps = b } + +addDepExcludeMod :: String -> DynFlags -> DynFlags +addDepExcludeMod m d + = d { depExcludeMods = mkModuleName m : depExcludeMods d } + +addDepSuffix :: FilePath -> DynFlags -> DynFlags +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} + +setInteractivePrint f d = d { interactivePrint = Just f} + +----------------------------------------------------------------------------- +-- Setting the optimisation level + +updOptLevel :: Int -> DynFlags -> DynFlags +-- ^ Sets the 'DynFlags' to be appropriate to the optimisation level +updOptLevel n dfs + = dfs2{ optLevel = final_n } + where + final_n = max 0 (min 2 n) -- Clamp to 0 <= n <= 2 + dfs1 = foldr (flip gopt_unset) dfs remove_gopts + dfs2 = foldr (flip gopt_set) dfs1 extra_gopts + + extra_gopts = [ f | (ns,f) <- optLevelFlags, final_n `elem` ns ] + remove_gopts = [ f | (ns,f) <- optLevelFlags, final_n `notElem` ns ] + +{- ********************************************************************** +%* * + DynFlags parser +%* * +%********************************************************************* -} + +-- ----------------------------------------------------------------------------- +-- Parsing the dynamic flags. + + +-- | Parse dynamic flags from a list of command line arguments. Returns +-- the parsed 'DynFlags', the left-over arguments, and a list of warnings. +-- Throws a 'UsageError' if errors occurred during parsing (such as unknown +-- flags or missing arguments). +parseDynamicFlagsCmdLine :: MonadIO m => DynFlags -> [Located String] + -> m (DynFlags, [Located String], [Warn]) + -- ^ Updated 'DynFlags', left-over arguments, and + -- list of warnings. +parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAll True + + +-- | Like 'parseDynamicFlagsCmdLine' but does not allow the package flags +-- (-package, -hide-package, -ignore-package, -hide-all-packages, -package-db). +-- Used to parse flags set in a modules pragma. +parseDynamicFilePragma :: MonadIO m => DynFlags -> [Located String] + -> m (DynFlags, [Located String], [Warn]) + -- ^ Updated 'DynFlags', left-over arguments, and + -- list of warnings. +parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamic False + + +-- | Parses the dynamically set flags for GHC. This is the most general form of +-- the dynamic flag parser that the other methods simply wrap. It allows +-- saying which flags are valid flags and indicating if we are parsing +-- arguments from the command line or from a file pragma. +parseDynamicFlagsFull :: MonadIO m + => [Flag (CmdLineP DynFlags)] -- ^ valid flags to match against + -> Bool -- ^ are the arguments from the command line? + -> DynFlags -- ^ current dynamic flags + -> [Located String] -- ^ arguments to parse + -> m (DynFlags, [Located String], [Warn]) +parseDynamicFlagsFull activeFlags cmdline dflags0 args = do + let ((leftover, errs, warns), dflags1) + = runCmdLine (processArgs activeFlags args) dflags0 + + -- See Note [Handling errors when parsing commandline flags] + unless (null errs) $ liftIO $ throwGhcExceptionIO $ errorsToGhcException $ + map ((showPpr dflags0 . getLoc &&& unLoc) . errMsg) $ errs + + -- check for disabled flags in safe haskell + let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1 + dflags3 = updateWays dflags2 + theWays = ways dflags3 + + unless (allowed_combination theWays) $ liftIO $ + throwGhcExceptionIO (CmdLineError ("combination not supported: " ++ + intercalate "/" (map wayDesc theWays))) + + let chooseOutput + | isJust (outputFile dflags3) -- Only iff user specified -o ... + , not (isJust (dynOutputFile dflags3)) -- but not -dyno + = return $ dflags3 { dynOutputFile = Just $ dynamicOutputFile dflags3 outFile } + | otherwise + = return dflags3 + where + outFile = fromJust $ outputFile dflags3 + dflags4 <- ifGeneratingDynamicToo dflags3 chooseOutput (return dflags3) + + let (dflags5, consistency_warnings) = makeDynFlagsConsistent dflags4 + + -- Set timer stats & heap size + when (enableTimeStats dflags5) $ liftIO enableTimingStats + case (ghcHeapSize dflags5) of + Just x -> liftIO (setHeapSize x) + _ -> return () + + liftIO $ setUnsafeGlobalDynFlags dflags5 + + let warns' = map (Warn Cmd.NoReason) (consistency_warnings ++ sh_warns) + + return (dflags5, leftover, warns' ++ warns) + +-- | Write an error or warning to the 'LogOutput'. +putLogMsg :: DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle + -> MsgDoc -> IO () +putLogMsg dflags = log_action dflags dflags + +updateWays :: DynFlags -> DynFlags +updateWays dflags + = let theWays = sort $ nub $ ways dflags + in dflags { + ways = theWays, + buildTag = mkBuildTag (filter (not . wayRTSOnly) theWays) + } + +-- | Check (and potentially disable) any extensions that aren't allowed +-- in safe mode. +-- +-- The bool is to indicate if we are parsing command line flags (false means +-- file pragma). This allows us to generate better warnings. +safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Located String]) +safeFlagCheck _ dflags | safeLanguageOn dflags = (dflagsUnset, warns) + where + -- Handle illegal flags under safe language. + (dflagsUnset, warns) = foldl' check_method (dflags, []) unsafeFlags + + check_method (df, warns) (str,loc,test,fix) + | test df = (fix df, warns ++ safeFailure (loc df) str) + | otherwise = (df, warns) + + safeFailure loc str + = [L loc $ str ++ " is not allowed in Safe Haskell; ignoring " + ++ str] + +safeFlagCheck cmdl dflags = + case (safeInferOn dflags) of + True | safeFlags -> (dflags', warn) + True -> (dflags' { safeInferred = False }, warn) + False -> (dflags', warn) + + where + -- dynflags and warn for when -fpackage-trust by itself with no safe + -- haskell flag + (dflags', warn) + | not (safeHaskellModeEnabled dflags) && not cmdl && packageTrustOn dflags + = (gopt_unset dflags Opt_PackageTrust, pkgWarnMsg) + | otherwise = (dflags, []) + + pkgWarnMsg = [L (pkgTrustOnLoc dflags') $ + "-fpackage-trust ignored;" ++ + " must be specified with a Safe Haskell flag"] + + -- Have we inferred Unsafe? See Note [GHC.Driver.Main . Safe Haskell Inference] + safeFlags = all (\(_,_,t,_) -> not $ t dflags) unsafeFlagsForInfer + + +{- ********************************************************************** +%* * + DynFlags specifications +%* * +%********************************************************************* -} + +-- | All dynamic flags option strings without the deprecated ones. +-- These are the user facing strings for enabling and disabling options. +allNonDeprecatedFlags :: [String] +allNonDeprecatedFlags = allFlagsDeps False + +-- | All flags with possibility to filter deprecated ones +allFlagsDeps :: Bool -> [String] +allFlagsDeps keepDeprecated = [ '-':flagName flag + | (deprecated, flag) <- flagsAllDeps + , keepDeprecated || not (isDeprecated deprecated)] + where isDeprecated Deprecated = True + isDeprecated _ = False + +{- + - Below we export user facing symbols for GHC dynamic flags for use with the + - GHC API. + -} + +-- All dynamic flags present in GHC. +flagsAll :: [Flag (CmdLineP DynFlags)] +flagsAll = map snd flagsAllDeps + +-- All dynamic flags present in GHC with deprecation information. +flagsAllDeps :: [(Deprecation, Flag (CmdLineP DynFlags))] +flagsAllDeps = package_flags_deps ++ dynamic_flags_deps + + +-- All dynamic flags, minus package flags, present in GHC. +flagsDynamic :: [Flag (CmdLineP DynFlags)] +flagsDynamic = map snd dynamic_flags_deps + +-- ALl package flags present in GHC. +flagsPackage :: [Flag (CmdLineP DynFlags)] +flagsPackage = map snd package_flags_deps + +----------------Helpers to make flags and keep deprecation information---------- + +type FlagMaker m = String -> OptKind m -> Flag m +type DynFlagMaker = FlagMaker (CmdLineP DynFlags) +data Deprecation = NotDeprecated | Deprecated deriving (Eq, Ord) + +-- Make a non-deprecated flag +make_ord_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags) + -> (Deprecation, Flag (CmdLineP DynFlags)) +make_ord_flag fm name kind = (NotDeprecated, fm name kind) + +-- Make a deprecated flag +make_dep_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags) -> String + -> (Deprecation, Flag (CmdLineP DynFlags)) +make_dep_flag fm name kind message = (Deprecated, + fm name $ add_dep_message kind message) + +add_dep_message :: OptKind (CmdLineP DynFlags) -> String + -> OptKind (CmdLineP DynFlags) +add_dep_message (NoArg f) message = NoArg $ f >> deprecate message +add_dep_message (HasArg f) message = HasArg $ \s -> f s >> deprecate message +add_dep_message (SepArg f) message = SepArg $ \s -> f s >> deprecate message +add_dep_message (Prefix f) message = Prefix $ \s -> f s >> deprecate message +add_dep_message (OptPrefix f) message = + OptPrefix $ \s -> f s >> deprecate message +add_dep_message (OptIntSuffix f) message = + OptIntSuffix $ \oi -> f oi >> deprecate message +add_dep_message (IntSuffix f) message = + IntSuffix $ \i -> f i >> deprecate message +add_dep_message (FloatSuffix f) message = + FloatSuffix $ \fl -> f fl >> deprecate message +add_dep_message (PassFlag f) message = + PassFlag $ \s -> f s >> deprecate message +add_dep_message (AnySuffix f) message = + AnySuffix $ \s -> f s >> deprecate message + +----------------------- The main flags themselves ------------------------------ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] +dynamic_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))] +dynamic_flags_deps = [ + make_dep_flag defFlag "n" (NoArg $ return ()) + "The -n flag is deprecated and no longer has any effect" + , make_ord_flag defFlag "cpp" (NoArg (setExtensionFlag LangExt.Cpp)) + , make_ord_flag defFlag "F" (NoArg (setGeneralFlag Opt_Pp)) + , (Deprecated, defFlag "#include" + (HasArg (\_s -> + deprecate ("-#include and INCLUDE pragmas are " ++ + "deprecated: They no longer have any effect")))) + , make_ord_flag defFlag "v" (OptIntSuffix setVerbosity) + + , make_ord_flag defGhcFlag "j" (OptIntSuffix + (\n -> case n of + Just n + | n > 0 -> upd (\d -> d { parMakeCount = Just n }) + | otherwise -> addErr "Syntax: -j[n] where n > 0" + Nothing -> upd (\d -> d { parMakeCount = Nothing }))) + -- When the number of parallel builds + -- is omitted, it is the same + -- as specifying that the number of + -- parallel builds is equal to the + -- result of getNumProcessors + , make_ord_flag defFlag "instantiated-with" (sepArg setUnitIdInsts) + , make_ord_flag defFlag "this-component-id" (sepArg setComponentId) + + -- RTS options ------------------------------------------------------------- + , make_ord_flag defFlag "H" (HasArg (\s -> upd (\d -> + d { ghcHeapSize = Just $ fromIntegral (decodeSize s)}))) + + , make_ord_flag defFlag "Rghc-timing" (NoArg (upd (\d -> + d { enableTimeStats = True }))) + + ------- ways --------------------------------------------------------------- + , make_ord_flag defGhcFlag "prof" (NoArg (addWay WayProf)) + , make_ord_flag defGhcFlag "eventlog" (NoArg (addWay WayEventLog)) + , make_ord_flag defGhcFlag "debug" (NoArg (addWay WayDebug)) + , make_ord_flag defGhcFlag "threaded" (NoArg (addWay WayThreaded)) + + , make_ord_flag defGhcFlag "ticky" + (NoArg (setGeneralFlag Opt_Ticky >> addWay WayDebug)) + + -- -ticky enables ticky-ticky code generation, and also implies -debug which + -- is required to get the RTS ticky support. + + ----- Linker -------------------------------------------------------- + , make_ord_flag defGhcFlag "static" (NoArg removeWayDyn) + , make_ord_flag defGhcFlag "dynamic" (NoArg (addWay WayDyn)) + , make_ord_flag defGhcFlag "rdynamic" $ noArg $ +#if defined(linux_HOST_OS) + addOptl "-rdynamic" +#elif defined(mingw32_HOST_OS) + addOptl "-Wl,--export-all-symbols" +#else + -- ignored for compat w/ gcc: + id +#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. + , make_ord_flag defFlag "pgmlo" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lo = (f,[]) } + , make_ord_flag defFlag "pgmlc" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lc = (f,[]) } + , make_ord_flag defFlag "pgmi" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_i = f } + , make_ord_flag defFlag "pgmL" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_L = f } + , make_ord_flag defFlag "pgmP" + (hasArg setPgmP) + , make_ord_flag defFlag "pgmF" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_F = f } + , make_ord_flag defFlag "pgmc" + $ hasArg $ \f -> alterToolSettings $ \s -> s + { toolSettings_pgm_c = f + , -- Don't pass -no-pie with -pgmc + -- (see #15319) + toolSettings_ccSupportsNoPie = False + } + , make_ord_flag defFlag "pgms" + (HasArg (\_ -> addWarn "Object splitting was removed in GHC 8.8")) + , make_ord_flag defFlag "pgma" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_a = (f,[]) } + , make_ord_flag defFlag "pgml" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_l = (f,[]) } + , make_ord_flag defFlag "pgmdll" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_dll = (f,[]) } + , make_ord_flag defFlag "pgmwindres" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_windres = f } + , make_ord_flag defFlag "pgmlibtool" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_libtool = f } + , make_ord_flag defFlag "pgmar" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_ar = f } + , make_ord_flag defFlag "pgmranlib" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_ranlib = f } + + + -- need to appear before -optl/-opta to be parsed as LLVM flags. + , make_ord_flag defFlag "optlo" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lo = f : toolSettings_opt_lo s } + , make_ord_flag defFlag "optlc" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lc = f : toolSettings_opt_lc s } + , make_ord_flag defFlag "opti" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_i = f : toolSettings_opt_i s } + , make_ord_flag defFlag "optL" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_L = f : toolSettings_opt_L s } + , make_ord_flag defFlag "optP" + (hasArg addOptP) + , make_ord_flag defFlag "optF" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_F = f : toolSettings_opt_F s } + , make_ord_flag defFlag "optc" + (hasArg addOptc) + , make_ord_flag defFlag "optcxx" + (hasArg addOptcxx) + , make_ord_flag defFlag "opta" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_a = f : toolSettings_opt_a s } + , make_ord_flag defFlag "optl" + (hasArg addOptl) + , make_ord_flag defFlag "optwindres" + $ hasArg $ \f -> + alterToolSettings $ \s -> s { toolSettings_opt_windres = f : toolSettings_opt_windres s } + + , make_ord_flag defGhcFlag "split-objs" + (NoArg $ addWarn "ignoring -split-objs") + + , make_ord_flag defGhcFlag "split-sections" + (noArgM (\dflags -> do + if platformHasSubsectionsViaSymbols (targetPlatform dflags) + then do addWarn $ + "-split-sections is not useful on this platform " ++ + "since it always uses subsections via symbols. Ignoring." + return dflags + else return (gopt_set dflags Opt_SplitSections))) + + -------- ghc -M ----------------------------------------------------- + , make_ord_flag defGhcFlag "dep-suffix" (hasArg addDepSuffix) + , make_ord_flag defGhcFlag "dep-makefile" (hasArg setDepMakefile) + , make_ord_flag defGhcFlag "include-cpp-deps" + (noArg (setDepIncludeCppDeps True)) + , make_ord_flag defGhcFlag "include-pkg-deps" + (noArg (setDepIncludePkgDeps True)) + , make_ord_flag defGhcFlag "exclude-module" (hasArg addDepExcludeMod) + + -------- Linking ---------------------------------------------------- + , make_ord_flag defGhcFlag "no-link" + (noArg (\d -> d { ghcLink=NoLink })) + , make_ord_flag defGhcFlag "shared" + (noArg (\d -> d { ghcLink=LinkDynLib })) + , make_ord_flag defGhcFlag "staticlib" + (noArg (\d -> d { ghcLink=LinkStaticLib })) + , make_ord_flag defGhcFlag "dynload" (hasArg parseDynLibLoaderMode) + , make_ord_flag defGhcFlag "dylib-install-name" (hasArg setDylibInstallName) + + ------- Libraries --------------------------------------------------- + , make_ord_flag defFlag "L" (Prefix addLibraryPath) + , make_ord_flag defFlag "l" (hasArg (addLdInputs . Option . ("-l" ++))) + + ------- Frameworks -------------------------------------------------- + -- -framework-path should really be -F ... + , make_ord_flag defFlag "framework-path" (HasArg addFrameworkPath) + , make_ord_flag defFlag "framework" (hasArg addCmdlineFramework) + + ------- Output Redirection ------------------------------------------ + , make_ord_flag defGhcFlag "odir" (hasArg setObjectDir) + , make_ord_flag defGhcFlag "o" (sepArg (setOutputFile . Just)) + , make_ord_flag defGhcFlag "dyno" + (sepArg (setDynOutputFile . Just)) + , make_ord_flag defGhcFlag "ohi" + (hasArg (setOutputHi . Just )) + , make_ord_flag defGhcFlag "osuf" (hasArg setObjectSuf) + , make_ord_flag defGhcFlag "dynosuf" (hasArg setDynObjectSuf) + , make_ord_flag defGhcFlag "hcsuf" (hasArg setHcSuf) + , make_ord_flag defGhcFlag "hisuf" (hasArg setHiSuf) + , make_ord_flag defGhcFlag "hiesuf" (hasArg setHieSuf) + , make_ord_flag defGhcFlag "dynhisuf" (hasArg setDynHiSuf) + , make_ord_flag defGhcFlag "hidir" (hasArg setHiDir) + , make_ord_flag defGhcFlag "hiedir" (hasArg setHieDir) + , make_ord_flag defGhcFlag "tmpdir" (hasArg setTmpDir) + , make_ord_flag defGhcFlag "stubdir" (hasArg setStubDir) + , make_ord_flag defGhcFlag "dumpdir" (hasArg setDumpDir) + , make_ord_flag defGhcFlag "outputdir" (hasArg setOutputDir) + , make_ord_flag defGhcFlag "ddump-file-prefix" + (hasArg (setDumpPrefixForce . Just)) + + , make_ord_flag defGhcFlag "dynamic-too" + (NoArg (setGeneralFlag Opt_BuildDynamicToo)) + + ------- Keeping temporary files ------------------------------------- + -- These can be singular (think ghc -c) or plural (think ghc --make) + , make_ord_flag defGhcFlag "keep-hc-file" + (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" + (NoArg (setGeneralFlag Opt_KeepSFiles)) + , make_ord_flag defGhcFlag "keep-llvm-file" + (NoArg $ setObjTarget HscLlvm >> setGeneralFlag Opt_KeepLlvmFiles) + , make_ord_flag defGhcFlag "keep-llvm-files" + (NoArg $ setObjTarget HscLlvm >> setGeneralFlag Opt_KeepLlvmFiles) + -- This only makes sense as plural + , make_ord_flag defGhcFlag "keep-tmp-files" + (NoArg (setGeneralFlag Opt_KeepTmpFiles)) + , make_ord_flag defGhcFlag "keep-hi-file" + (NoArg (setGeneralFlag Opt_KeepHiFiles)) + , make_ord_flag defGhcFlag "no-keep-hi-file" + (NoArg (unSetGeneralFlag Opt_KeepHiFiles)) + , make_ord_flag defGhcFlag "keep-hi-files" + (NoArg (setGeneralFlag Opt_KeepHiFiles)) + , make_ord_flag defGhcFlag "no-keep-hi-files" + (NoArg (unSetGeneralFlag Opt_KeepHiFiles)) + , make_ord_flag defGhcFlag "keep-o-file" + (NoArg (setGeneralFlag Opt_KeepOFiles)) + , make_ord_flag defGhcFlag "no-keep-o-file" + (NoArg (unSetGeneralFlag Opt_KeepOFiles)) + , make_ord_flag defGhcFlag "keep-o-files" + (NoArg (setGeneralFlag Opt_KeepOFiles)) + , make_ord_flag defGhcFlag "no-keep-o-files" + (NoArg (unSetGeneralFlag Opt_KeepOFiles)) + + ------- Miscellaneous ---------------------------------------------- + , make_ord_flag defGhcFlag "no-auto-link-packages" + (NoArg (unSetGeneralFlag Opt_AutoLinkPackages)) + , make_ord_flag defGhcFlag "no-hs-main" + (NoArg (setGeneralFlag Opt_NoHsMain)) + , make_ord_flag defGhcFlag "fno-state-hack" + (NoArg (setGeneralFlag Opt_G_NoStateHack)) + , make_ord_flag defGhcFlag "fno-opt-coercion" + (NoArg (setGeneralFlag Opt_G_NoOptCoercion)) + , make_ord_flag defGhcFlag "with-rtsopts" + (HasArg setRtsOpts) + , make_ord_flag defGhcFlag "rtsopts" + (NoArg (setRtsOptsEnabled RtsOptsAll)) + , make_ord_flag defGhcFlag "rtsopts=all" + (NoArg (setRtsOptsEnabled RtsOptsAll)) + , make_ord_flag defGhcFlag "rtsopts=some" + (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) + , make_ord_flag defGhcFlag "hpcdir" (SepArg setOptHpcDir) + , make_ord_flag defGhciFlag "ghci-script" (hasArg addGhciScript) + , make_ord_flag defGhciFlag "interactive-print" (hasArg setInteractivePrint) + , make_ord_flag defGhcFlag "ticky-allocd" + (NoArg (setGeneralFlag Opt_Ticky_Allocd)) + , make_ord_flag defGhcFlag "ticky-LNE" + (NoArg (setGeneralFlag Opt_Ticky_LNE)) + , make_ord_flag defGhcFlag "ticky-dyn-thunk" + (NoArg (setGeneralFlag Opt_Ticky_Dyn_Thunk)) + ------- recompilation checker -------------------------------------- + , make_dep_flag defGhcFlag "recomp" + (NoArg $ unSetGeneralFlag Opt_ForceRecomp) + "Use -fno-force-recomp instead" + , make_dep_flag defGhcFlag "no-recomp" + (NoArg $ setGeneralFlag Opt_ForceRecomp) "Use -fforce-recomp instead" + , make_ord_flag defFlag "fmax-errors" + (intSuffix (\n d -> d { maxErrors = Just (max 1 n) })) + , make_ord_flag defFlag "fno-max-errors" + (noArg (\d -> d { maxErrors = Nothing })) + , make_ord_flag defFlag "freverse-errors" + (noArg (\d -> d {reverseErrors = True} )) + , make_ord_flag defFlag "fno-reverse-errors" + (noArg (\d -> d {reverseErrors = False} )) + + ------ HsCpp opts --------------------------------------------------- + , make_ord_flag defFlag "D" (AnySuffix (upd . addOptP)) + , make_ord_flag defFlag "U" (AnySuffix (upd . addOptP)) + + ------- Include/Import Paths ---------------------------------------- + , make_ord_flag defFlag "I" (Prefix addIncludePath) + , make_ord_flag defFlag "i" (OptPrefix addImportPath) + + ------ Output style options ----------------------------------------- + , make_ord_flag defFlag "dppr-user-length" (intSuffix (\n d -> + d { pprUserLength = n })) + , make_ord_flag defFlag "dppr-cols" (intSuffix (\n d -> + d { pprCols = n })) + , make_ord_flag defFlag "fdiagnostics-color=auto" + (NoArg (upd (\d -> d { useColor = Auto }))) + , make_ord_flag defFlag "fdiagnostics-color=always" + (NoArg (upd (\d -> d { useColor = Always }))) + , make_ord_flag defFlag "fdiagnostics-color=never" + (NoArg (upd (\d -> d { useColor = Never }))) + + -- Suppress all that is suppressable in core dumps. + -- Except for uniques, as some simplifier phases introduce new variables that + -- have otherwise identical names. + , make_ord_flag defGhcFlag "dsuppress-all" + (NoArg $ do setGeneralFlag Opt_SuppressCoercions + setGeneralFlag Opt_SuppressVarKinds + setGeneralFlag Opt_SuppressModulePrefixes + setGeneralFlag Opt_SuppressTypeApplications + setGeneralFlag Opt_SuppressIdInfo + setGeneralFlag Opt_SuppressTicks + setGeneralFlag Opt_SuppressStgExts + setGeneralFlag Opt_SuppressTypeSignatures + setGeneralFlag Opt_SuppressTimestamps) + + ------ Debugging ---------------------------------------------------- + , make_ord_flag defGhcFlag "dstg-stats" + (NoArg (setGeneralFlag Opt_StgStats)) + + , make_ord_flag defGhcFlag "ddump-cmm" + (setDumpFlag Opt_D_dump_cmm) + , make_ord_flag defGhcFlag "ddump-cmm-from-stg" + (setDumpFlag Opt_D_dump_cmm_from_stg) + , make_ord_flag defGhcFlag "ddump-cmm-raw" + (setDumpFlag Opt_D_dump_cmm_raw) + , make_ord_flag defGhcFlag "ddump-cmm-verbose" + (setDumpFlag Opt_D_dump_cmm_verbose) + , make_ord_flag defGhcFlag "ddump-cmm-verbose-by-proc" + (setDumpFlag Opt_D_dump_cmm_verbose_by_proc) + , make_ord_flag defGhcFlag "ddump-cmm-cfg" + (setDumpFlag Opt_D_dump_cmm_cfg) + , make_ord_flag defGhcFlag "ddump-cmm-cbe" + (setDumpFlag Opt_D_dump_cmm_cbe) + , make_ord_flag defGhcFlag "ddump-cmm-switch" + (setDumpFlag Opt_D_dump_cmm_switch) + , make_ord_flag defGhcFlag "ddump-cmm-proc" + (setDumpFlag Opt_D_dump_cmm_proc) + , make_ord_flag defGhcFlag "ddump-cmm-sp" + (setDumpFlag Opt_D_dump_cmm_sp) + , make_ord_flag defGhcFlag "ddump-cmm-sink" + (setDumpFlag Opt_D_dump_cmm_sink) + , make_ord_flag defGhcFlag "ddump-cmm-caf" + (setDumpFlag Opt_D_dump_cmm_caf) + , make_ord_flag defGhcFlag "ddump-cmm-procmap" + (setDumpFlag Opt_D_dump_cmm_procmap) + , make_ord_flag defGhcFlag "ddump-cmm-split" + (setDumpFlag Opt_D_dump_cmm_split) + , make_ord_flag defGhcFlag "ddump-cmm-info" + (setDumpFlag Opt_D_dump_cmm_info) + , make_ord_flag defGhcFlag "ddump-cmm-cps" + (setDumpFlag Opt_D_dump_cmm_cps) + , make_ord_flag defGhcFlag "ddump-cfg-weights" + (setDumpFlag Opt_D_dump_cfg_weights) + , make_ord_flag defGhcFlag "ddump-core-stats" + (setDumpFlag Opt_D_dump_core_stats) + , make_ord_flag defGhcFlag "ddump-asm" + (setDumpFlag Opt_D_dump_asm) + , make_ord_flag defGhcFlag "ddump-asm-native" + (setDumpFlag Opt_D_dump_asm_native) + , make_ord_flag defGhcFlag "ddump-asm-liveness" + (setDumpFlag Opt_D_dump_asm_liveness) + , make_ord_flag defGhcFlag "ddump-asm-regalloc" + (setDumpFlag Opt_D_dump_asm_regalloc) + , make_ord_flag defGhcFlag "ddump-asm-conflicts" + (setDumpFlag Opt_D_dump_asm_conflicts) + , make_ord_flag defGhcFlag "ddump-asm-regalloc-stages" + (setDumpFlag Opt_D_dump_asm_regalloc_stages) + , make_ord_flag defGhcFlag "ddump-asm-stats" + (setDumpFlag Opt_D_dump_asm_stats) + , make_ord_flag defGhcFlag "ddump-asm-expanded" + (setDumpFlag Opt_D_dump_asm_expanded) + , make_ord_flag defGhcFlag "ddump-llvm" + (NoArg $ setObjTarget HscLlvm >> setDumpFlag' Opt_D_dump_llvm) + , make_ord_flag defGhcFlag "ddump-deriv" + (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" + (setDumpFlag Opt_D_dump_inlinings) + , make_ord_flag defGhcFlag "ddump-rule-firings" + (setDumpFlag Opt_D_dump_rule_firings) + , make_ord_flag defGhcFlag "ddump-rule-rewrites" + (setDumpFlag Opt_D_dump_rule_rewrites) + , make_ord_flag defGhcFlag "ddump-simpl-trace" + (setDumpFlag Opt_D_dump_simpl_trace) + , make_ord_flag defGhcFlag "ddump-occur-anal" + (setDumpFlag Opt_D_dump_occur_anal) + , make_ord_flag defGhcFlag "ddump-parsed" + (setDumpFlag Opt_D_dump_parsed) + , make_ord_flag defGhcFlag "ddump-parsed-ast" + (setDumpFlag Opt_D_dump_parsed_ast) + , make_ord_flag defGhcFlag "ddump-rn" + (setDumpFlag Opt_D_dump_rn) + , make_ord_flag defGhcFlag "ddump-rn-ast" + (setDumpFlag Opt_D_dump_rn_ast) + , make_ord_flag defGhcFlag "ddump-simpl" + (setDumpFlag Opt_D_dump_simpl) + , make_ord_flag defGhcFlag "ddump-simpl-iterations" + (setDumpFlag Opt_D_dump_simpl_iterations) + , make_ord_flag defGhcFlag "ddump-spec" + (setDumpFlag Opt_D_dump_spec) + , make_ord_flag defGhcFlag "ddump-prep" + (setDumpFlag Opt_D_dump_prep) + , make_ord_flag defGhcFlag "ddump-stg" + (setDumpFlag Opt_D_dump_stg) + , make_ord_flag defGhcFlag "ddump-stg-unarised" + (setDumpFlag Opt_D_dump_stg_unarised) + , make_ord_flag defGhcFlag "ddump-stg-final" + (setDumpFlag Opt_D_dump_stg_final) + , 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" + (setDumpFlag Opt_D_dump_str_signatures) + , make_ord_flag defGhcFlag "ddump-cpranal" + (setDumpFlag Opt_D_dump_cpranal) + , make_ord_flag defGhcFlag "ddump-cpr-signatures" + (setDumpFlag Opt_D_dump_cpr_signatures) + , make_ord_flag defGhcFlag "ddump-tc" + (setDumpFlag Opt_D_dump_tc) + , make_ord_flag defGhcFlag "ddump-tc-ast" + (setDumpFlag Opt_D_dump_tc_ast) + , make_ord_flag defGhcFlag "ddump-types" + (setDumpFlag Opt_D_dump_types) + , make_ord_flag defGhcFlag "ddump-rules" + (setDumpFlag Opt_D_dump_rules) + , make_ord_flag defGhcFlag "ddump-cse" + (setDumpFlag Opt_D_dump_cse) + , make_ord_flag defGhcFlag "ddump-worker-wrapper" + (setDumpFlag Opt_D_dump_worker_wrapper) + , make_ord_flag defGhcFlag "ddump-rn-trace" + (setDumpFlag Opt_D_dump_rn_trace) + , make_ord_flag defGhcFlag "ddump-if-trace" + (setDumpFlag Opt_D_dump_if_trace) + , make_ord_flag defGhcFlag "ddump-cs-trace" + (setDumpFlag Opt_D_dump_cs_trace) + , make_ord_flag defGhcFlag "ddump-tc-trace" + (NoArg (do setDumpFlag' Opt_D_dump_tc_trace + setDumpFlag' Opt_D_dump_cs_trace)) + , make_ord_flag defGhcFlag "ddump-ec-trace" + (setDumpFlag Opt_D_dump_ec_trace) + , make_ord_flag defGhcFlag "ddump-vt-trace" + (setDumpFlag Opt_D_dump_vt_trace) + , make_ord_flag defGhcFlag "ddump-splices" + (setDumpFlag Opt_D_dump_splices) + , make_ord_flag defGhcFlag "dth-dec-file" + (setDumpFlag Opt_D_th_dec_file) + + , make_ord_flag defGhcFlag "ddump-rn-stats" + (setDumpFlag Opt_D_dump_rn_stats) + , make_ord_flag defGhcFlag "ddump-opt-cmm" + (setDumpFlag Opt_D_dump_opt_cmm) + , make_ord_flag defGhcFlag "ddump-simpl-stats" + (setDumpFlag Opt_D_dump_simpl_stats) + , make_ord_flag defGhcFlag "ddump-bcos" + (setDumpFlag Opt_D_dump_BCOs) + , make_ord_flag defGhcFlag "dsource-stats" + (setDumpFlag Opt_D_source_stats) + , make_ord_flag defGhcFlag "dverbose-core2core" + (NoArg $ setVerbosity (Just 2) >> setVerboseCore2Core) + , make_ord_flag defGhcFlag "dverbose-stg2stg" + (setDumpFlag Opt_D_verbose_stg2stg) + , make_ord_flag defGhcFlag "ddump-hi" + (setDumpFlag Opt_D_dump_hi) + , make_ord_flag defGhcFlag "ddump-minimal-imports" + (NoArg (setGeneralFlag Opt_D_dump_minimal_imports)) + , make_ord_flag defGhcFlag "ddump-hpc" + (setDumpFlag Opt_D_dump_ticked) -- back compat + , make_ord_flag defGhcFlag "ddump-ticked" + (setDumpFlag Opt_D_dump_ticked) + , make_ord_flag defGhcFlag "ddump-mod-cycles" + (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" + (NoArg (setGeneralFlag Opt_DumpToFile)) + , make_ord_flag defGhcFlag "ddump-hi-diffs" + (setDumpFlag Opt_D_dump_hi_diffs) + , make_ord_flag defGhcFlag "ddump-rtti" + (setDumpFlag Opt_D_dump_rtti) + , make_ord_flag defGhcFlag "dcore-lint" + (NoArg (setGeneralFlag Opt_DoCoreLinting)) + , make_ord_flag defGhcFlag "dstg-lint" + (NoArg (setGeneralFlag Opt_DoStgLinting)) + , make_ord_flag defGhcFlag "dcmm-lint" + (NoArg (setGeneralFlag Opt_DoCmmLinting)) + , make_ord_flag defGhcFlag "dasm-lint" + (NoArg (setGeneralFlag Opt_DoAsmLinting)) + , make_ord_flag defGhcFlag "dannot-lint" + (NoArg (setGeneralFlag Opt_DoAnnotationLinting)) + , make_ord_flag defGhcFlag "dshow-passes" + (NoArg $ forceRecompile >> (setVerbosity $ Just 2)) + , make_ord_flag defGhcFlag "dfaststring-stats" + (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 "dno-typeable-binds" + (NoArg (setGeneralFlag Opt_NoTypeableBinds)) + , 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) + + ------ Machine dependent (-m<blah>) stuff --------------------------- + + , make_ord_flag defGhcFlag "msse" (noArg (\d -> + d { sseVersion = Just SSE1 })) + , make_ord_flag defGhcFlag "msse2" (noArg (\d -> + d { sseVersion = Just SSE2 })) + , make_ord_flag defGhcFlag "msse3" (noArg (\d -> + d { sseVersion = Just SSE3 })) + , make_ord_flag defGhcFlag "msse4" (noArg (\d -> + 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 -> + d { avx512cd = True })) + , make_ord_flag defGhcFlag "mavx512er" (noArg (\d -> + d { avx512er = True })) + , make_ord_flag defGhcFlag "mavx512f" (noArg (\d -> d { avx512f = True })) + , make_ord_flag defGhcFlag "mavx512pf" (noArg (\d -> + d { avx512pf = True })) + + ------ Warning opts ------------------------------------------------- + , make_ord_flag defFlag "W" (NoArg (mapM_ setWarningFlag minusWOpts)) + , make_ord_flag defFlag "Werror" + (NoArg (do { setGeneralFlag Opt_WarnIsError + ; mapM_ setFatalWarningFlag minusWeverythingOpts })) + , make_ord_flag defFlag "Wwarn" + (NoArg (do { unSetGeneralFlag Opt_WarnIsError + ; mapM_ unSetFatalWarningFlag minusWeverythingOpts })) + -- Opt_WarnIsError is still needed to pass -Werror + -- to CPP; see runCpp in SysTools + , make_dep_flag defFlag "Wnot" (NoArg (upd (\d -> + d {warningFlags = EnumSet.empty}))) + "Use -w or -Wno-everything instead" + , make_ord_flag defFlag "w" (NoArg (upd (\d -> + d {warningFlags = EnumSet.empty}))) + + -- New-style uniform warning sets + -- + -- Note that -Weverything > -Wall > -Wextra > -Wdefault > -Wno-everything + , make_ord_flag defFlag "Weverything" (NoArg (mapM_ + setWarningFlag minusWeverythingOpts)) + , make_ord_flag defFlag "Wno-everything" + (NoArg (upd (\d -> d {warningFlags = EnumSet.empty}))) + + , make_ord_flag defFlag "Wall" (NoArg (mapM_ + setWarningFlag minusWallOpts)) + , make_ord_flag defFlag "Wno-all" (NoArg (mapM_ + unSetWarningFlag minusWallOpts)) + + , make_ord_flag defFlag "Wextra" (NoArg (mapM_ + setWarningFlag minusWOpts)) + , make_ord_flag defFlag "Wno-extra" (NoArg (mapM_ + unSetWarningFlag minusWOpts)) + + , make_ord_flag defFlag "Wdefault" (NoArg (mapM_ + setWarningFlag standardWarnings)) + , make_ord_flag defFlag "Wno-default" (NoArg (mapM_ + unSetWarningFlag standardWarnings)) + + , make_ord_flag defFlag "Wcompat" (NoArg (mapM_ + setWarningFlag minusWcompatOpts)) + , make_ord_flag defFlag "Wno-compat" (NoArg (mapM_ + unSetWarningFlag minusWcompatOpts)) + + ------ Plugin flags ------------------------------------------------ + , make_ord_flag defGhcFlag "fplugin-opt" (hasArg addPluginModuleNameOption) + , make_ord_flag defGhcFlag "fplugin-trustworthy" + (NoArg (setGeneralFlag Opt_PluginTrustworthy)) + , make_ord_flag defGhcFlag "fplugin" (hasArg addPluginModuleName) + , make_ord_flag defGhcFlag "fclear-plugins" (noArg clearPluginModuleNames) + , make_ord_flag defGhcFlag "ffrontend-opt" (hasArg addFrontendPluginOption) + + ------ Optimisation flags ------------------------------------------ + , make_dep_flag defGhcFlag "Onot" (noArgM $ setOptLevel 0 ) + "Use -O0 instead" + , make_ord_flag defGhcFlag "O" (optIntSuffixM (\mb_n -> + setOptLevel (mb_n `orElse` 1))) + -- If the number is missing, use 1 + + , make_ord_flag defFlag "fbinary-blob-threshold" + (intSuffix (\n d -> d { binBlobThreshold = fromIntegral n })) + + , make_ord_flag defFlag "fmax-relevant-binds" + (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-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_dep_flag defGhcFlag "fllvm-pass-vectors-in-regs" + (noArg id) + "vectors registers are now passed in registers by default." + , make_ord_flag defFlag "fmax-uncovered-patterns" + (intSuffix (\n d -> d { maxUncoveredPatterns = n })) + , make_ord_flag defFlag "fmax-pmcheck-models" + (intSuffix (\n d -> d { maxPmCheckModels = n })) + , make_ord_flag defFlag "fsimplifier-phases" + (intSuffix (\n d -> d { simplPhases = n })) + , make_ord_flag defFlag "fmax-simplifier-iterations" + (intSuffix (\n d -> d { maxSimplIterations = n })) + , (Deprecated, defFlag "fmax-pmcheck-iterations" + (intSuffixM (\_ d -> + do { deprecate $ "use -fmax-pmcheck-models instead" + ; return d }))) + , make_ord_flag defFlag "fsimpl-tick-factor" + (intSuffix (\n d -> d { simplTickFactor = n })) + , make_ord_flag defFlag "fspec-constr-threshold" + (intSuffix (\n d -> d { specConstrThreshold = Just n })) + , make_ord_flag defFlag "fno-spec-constr-threshold" + (noArg (\d -> d { specConstrThreshold = Nothing })) + , make_ord_flag defFlag "fspec-constr-count" + (intSuffix (\n d -> d { specConstrCount = Just n })) + , make_ord_flag defFlag "fno-spec-constr-count" + (noArg (\d -> d { specConstrCount = Nothing })) + , make_ord_flag defFlag "fspec-constr-recursive" + (intSuffix (\n d -> d { specConstrRecursive = n })) + , make_ord_flag defFlag "fliberate-case-threshold" + (intSuffix (\n d -> d { liberateCaseThreshold = Just n })) + , make_ord_flag defFlag "fno-liberate-case-threshold" + (noArg (\d -> d { liberateCaseThreshold = Nothing })) + , 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" + (intSuffix (\n d -> d { solverIterations = treatZeroAsInf n })) + , (Deprecated, defFlag "fcontext-stack" + (intSuffixM (\n d -> + do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead" + ; return $ d { reductionDepth = treatZeroAsInf n } }))) + , (Deprecated, defFlag "ftype-function-depth" + (intSuffixM (\n d -> + do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead" + ; return $ d { reductionDepth = treatZeroAsInf n } }))) + , make_ord_flag defFlag "fstrictness-before" + (intSuffix (\n d -> d { strictnessBefore = n : strictnessBefore d })) + , make_ord_flag defFlag "ffloat-lam-args" + (intSuffix (\n d -> d { floatLamArgs = Just n })) + , make_ord_flag defFlag "ffloat-all-lams" + (noArg (\d -> d { floatLamArgs = Nothing })) + , make_ord_flag defFlag "fstg-lift-lams-rec-args" + (intSuffix (\n d -> d { liftLamsRecArgs = Just n })) + , make_ord_flag defFlag "fstg-lift-lams-rec-args-any" + (noArg (\d -> d { liftLamsRecArgs = Nothing })) + , make_ord_flag defFlag "fstg-lift-lams-non-rec-args" + (intSuffix (\n d -> d { liftLamsRecArgs = Just n })) + , make_ord_flag defFlag "fstg-lift-lams-non-rec-args-any" + (noArg (\d -> d { liftLamsRecArgs = Nothing })) + , make_ord_flag defFlag "fstg-lift-lams-known" + (noArg (\d -> d { liftLamsKnown = True })) + , make_ord_flag defFlag "fno-stg-lift-lams-known" + (noArg (\d -> d { liftLamsKnown = False })) + , make_ord_flag defFlag "fproc-alignment" + (intSuffix (\n d -> d { cmmProcAlignment = Just n })) + , make_ord_flag defFlag "fblock-layout-weights" + (HasArg (\s -> + upd (\d -> d { cfgWeightInfo = + parseCfgWeights s (cfgWeightInfo d)}))) + , make_ord_flag defFlag "fhistory-size" + (intSuffix (\n d -> d { historySize = n })) + , make_ord_flag defFlag "funfolding-creation-threshold" + (intSuffix (\n d -> d {ufCreationThreshold = n})) + , make_ord_flag defFlag "funfolding-use-threshold" + (intSuffix (\n d -> d {ufUseThreshold = n})) + , make_ord_flag defFlag "funfolding-fun-discount" + (intSuffix (\n d -> d {ufFunAppDiscount = n})) + , make_ord_flag defFlag "funfolding-dict-discount" + (intSuffix (\n d -> d {ufDictDiscount = n})) + , make_ord_flag defFlag "funfolding-keeness-factor" + (floatSuffix (\n d -> d {ufKeenessFactor = n})) + , make_ord_flag defFlag "fmax-worker-args" + (intSuffix (\n d -> d {maxWorkerArgs = n})) + , make_ord_flag defGhciFlag "fghci-hist-size" + (intSuffix (\n d -> d {ghciHistSize = n})) + , make_ord_flag defGhcFlag "fmax-inline-alloc-size" + (intSuffix (\n d -> d { maxInlineAllocSize = n })) + , make_ord_flag defGhcFlag "fmax-inline-memcpy-insns" + (intSuffix (\n d -> d { maxInlineMemcpyInsns = n })) + , make_ord_flag defGhcFlag "fmax-inline-memset-insns" + (intSuffix (\n d -> d { maxInlineMemsetInsns = n })) + , make_ord_flag defGhcFlag "dinitial-unique" + (intSuffix (\n d -> d { initialUnique = n })) + , make_ord_flag defGhcFlag "dunique-increment" + (intSuffix (\n d -> d { uniqueIncrement = n })) + + ------ Profiling ---------------------------------------------------- + + -- OLD profiling flags + , make_dep_flag defGhcFlag "auto-all" + (noArg (\d -> d { profAuto = ProfAutoAll } )) + "Use -fprof-auto instead" + , make_dep_flag defGhcFlag "no-auto-all" + (noArg (\d -> d { profAuto = NoProfAuto } )) + "Use -fno-prof-auto instead" + , make_dep_flag defGhcFlag "auto" + (noArg (\d -> d { profAuto = ProfAutoExports } )) + "Use -fprof-auto-exported instead" + , make_dep_flag defGhcFlag "no-auto" + (noArg (\d -> d { profAuto = NoProfAuto } )) + "Use -fno-prof-auto instead" + , make_dep_flag defGhcFlag "caf-all" + (NoArg (setGeneralFlag Opt_AutoSccsOnIndividualCafs)) + "Use -fprof-cafs instead" + , make_dep_flag defGhcFlag "no-caf-all" + (NoArg (unSetGeneralFlag Opt_AutoSccsOnIndividualCafs)) + "Use -fno-prof-cafs instead" + + -- NEW profiling flags + , make_ord_flag defGhcFlag "fprof-auto" + (noArg (\d -> d { profAuto = ProfAutoAll } )) + , make_ord_flag defGhcFlag "fprof-auto-top" + (noArg (\d -> d { profAuto = ProfAutoTop } )) + , make_ord_flag defGhcFlag "fprof-auto-exported" + (noArg (\d -> d { profAuto = ProfAutoExports } )) + , make_ord_flag defGhcFlag "fprof-auto-calls" + (noArg (\d -> d { profAuto = ProfAutoCalls } )) + , make_ord_flag defGhcFlag "fno-prof-auto" + (noArg (\d -> d { profAuto = NoProfAuto } )) + + ------ Compiler flags ----------------------------------------------- + + , make_ord_flag defGhcFlag "fasm" (NoArg (setObjTarget HscAsm)) + , make_ord_flag defGhcFlag "fvia-c" (NoArg + (deprecate $ "The -fvia-c flag does nothing; " ++ + "it will be removed in a future GHC release")) + , make_ord_flag defGhcFlag "fvia-C" (NoArg + (deprecate $ "The -fvia-C flag does nothing; " ++ + "it will be removed in a future GHC release")) + , make_ord_flag defGhcFlag "fllvm" (NoArg (setObjTarget HscLlvm)) + + , make_ord_flag defFlag "fno-code" (NoArg ((upd $ \d -> + d { ghcLink=NoLink }) >> setTarget HscNothing)) + , make_ord_flag defFlag "fbyte-code" + (noArgM $ \dflags -> do + setTarget HscInterpreted + pure $ gopt_set dflags Opt_ByteCode) + , make_ord_flag defFlag "fobject-code" $ NoArg $ do + dflags <- liftEwM getCmdLineState + setTarget $ defaultObjectTarget dflags + + , make_dep_flag defFlag "fglasgow-exts" + (NoArg enableGlasgowExts) "Use individual extensions instead" + , make_dep_flag defFlag "fno-glasgow-exts" + (NoArg disableGlasgowExts) "Use individual extensions instead" + , make_ord_flag defFlag "Wunused-binds" (NoArg enableUnusedBinds) + , make_ord_flag defFlag "Wno-unused-binds" (NoArg disableUnusedBinds) + , make_ord_flag defHiddenFlag "fwarn-unused-binds" (NoArg enableUnusedBinds) + , make_ord_flag defHiddenFlag "fno-warn-unused-binds" (NoArg + disableUnusedBinds) + + ------ Safe Haskell flags ------------------------------------------- + , make_ord_flag defFlag "fpackage-trust" (NoArg setPackageTrust) + , make_ord_flag defFlag "fno-safe-infer" (noArg (\d -> + d { safeInfer = False })) + , make_ord_flag defFlag "fno-safe-haskell" (NoArg (setSafeHaskell Sf_Ignore)) + + ------ position independent flags ---------------------------------- + , 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) + ] + ++ map (mkFlag turnOn "" setGeneralFlag ) negatableFlagsDeps + ++ map (mkFlag turnOff "no-" unSetGeneralFlag ) negatableFlagsDeps + ++ map (mkFlag turnOn "d" setGeneralFlag ) dFlagsDeps + ++ map (mkFlag turnOff "dno-" unSetGeneralFlag ) dFlagsDeps + ++ map (mkFlag turnOn "f" setGeneralFlag ) fFlagsDeps + ++ map (mkFlag turnOff "fno-" unSetGeneralFlag ) fFlagsDeps + ++ map (mkFlag turnOn "W" setWarningFlag ) wWarningFlagsDeps + ++ map (mkFlag turnOff "Wno-" unSetWarningFlag ) wWarningFlagsDeps + ++ map (mkFlag turnOn "Werror=" setWErrorFlag ) wWarningFlagsDeps + ++ map (mkFlag turnOn "Wwarn=" unSetFatalWarningFlag ) + wWarningFlagsDeps + ++ map (mkFlag turnOn "Wno-error=" unSetFatalWarningFlag ) + wWarningFlagsDeps + ++ map (mkFlag turnOn "fwarn-" setWarningFlag . hideFlag) + wWarningFlagsDeps + ++ map (mkFlag turnOff "fno-warn-" unSetWarningFlag . hideFlag) + wWarningFlagsDeps + ++ [ (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 + ++ map (mkFlag turnOff "XNo" unSetExtensionFlag) xFlagsDeps + ++ map (mkFlag turnOn "X" setLanguage ) languageFlagsDeps + ++ map (mkFlag turnOn "X" setSafeHaskell ) safeHaskellFlagsDeps + ++ [ make_dep_flag defFlag "XGenerics" + (NoArg $ return ()) + ("it does nothing; look into -XDefaultSignatures " ++ + "and -XDeriveGeneric for generic programming support.") + , make_dep_flag defFlag "XNoGenerics" + (NoArg $ return ()) + ("it does nothing; look into -XDefaultSignatures and " ++ + "-XDeriveGeneric for generic programming support.") ] + +-- | This is where we handle unrecognised warning flags. We only issue a warning +-- if -Wunrecognised-warning-flags is set. See #11429 for context. +unrecognisedWarning :: String -> Flag (CmdLineP DynFlags) +unrecognisedWarning prefix = defHiddenFlag prefix (Prefix action) + where + action :: String -> EwM (CmdLineP DynFlags) () + action flag = do + f <- wopt Opt_WarnUnrecognisedWarningFlags <$> liftEwM getCmdLineState + when f $ addFlagWarn Cmd.ReasonUnrecognisedFlag $ + "unrecognised warning flag: -" ++ prefix ++ flag + +-- See Note [Supporting CLI completion] +package_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))] +package_flags_deps = [ + ------- Packages ---------------------------------------------------- + make_ord_flag defFlag "package-db" + (HasArg (addPkgDbRef . PkgDbPath)) + , make_ord_flag defFlag "clear-package-db" (NoArg clearPkgDb) + , make_ord_flag defFlag "no-global-package-db" (NoArg removeGlobalPkgDb) + , make_ord_flag defFlag "no-user-package-db" (NoArg removeUserPkgDb) + , make_ord_flag defFlag "global-package-db" + (NoArg (addPkgDbRef GlobalPkgDb)) + , make_ord_flag defFlag "user-package-db" + (NoArg (addPkgDbRef UserPkgDb)) + -- backwards compat with GHC<=7.4 : + , make_dep_flag defFlag "package-conf" + (HasArg $ addPkgDbRef . PkgDbPath) "Use -package-db instead" + , make_dep_flag defFlag "no-user-package-conf" + (NoArg removeUserPkgDb) "Use -no-user-package-db instead" + , make_ord_flag defGhcFlag "package-name" (HasArg $ \name -> do + upd (setUnitId name)) + -- TODO: Since we JUST deprecated + -- -this-package-key, let's keep this + -- undeprecated for another cycle. + -- Deprecate this eventually. + -- deprecate "Use -this-unit-id instead") + , make_dep_flag defGhcFlag "this-package-key" (HasArg $ upd . setUnitId) + "Use -this-unit-id instead" + , make_ord_flag defGhcFlag "this-unit-id" (hasArg setUnitId) + , make_ord_flag defFlag "package" (HasArg exposePackage) + , make_ord_flag defFlag "plugin-package-id" (HasArg exposePluginPackageId) + , make_ord_flag defFlag "plugin-package" (HasArg exposePluginPackage) + , make_ord_flag defFlag "package-id" (HasArg exposePackageId) + , make_ord_flag defFlag "hide-package" (HasArg hidePackage) + , make_ord_flag defFlag "hide-all-packages" + (NoArg (setGeneralFlag Opt_HideAllPackages)) + , make_ord_flag defFlag "hide-all-plugin-packages" + (NoArg (setGeneralFlag Opt_HideAllPluginPackages)) + , make_ord_flag defFlag "package-env" (HasArg setPackageEnv) + , make_ord_flag defFlag "ignore-package" (HasArg ignorePackage) + , make_dep_flag defFlag "syslib" (HasArg exposePackage) "Use -package instead" + , make_ord_flag defFlag "distrust-all-packages" + (NoArg (setGeneralFlag Opt_DistrustAllPackages)) + , make_ord_flag defFlag "trust" (HasArg trustPackage) + , make_ord_flag defFlag "distrust" (HasArg distrustPackage) + ] + where + setPackageEnv env = upd $ \s -> s { packageEnv = Just env } + +-- | Make a list of flags for shell completion. +-- Filter all available flags into two groups, for interactive GHC vs all other. +flagsForCompletion :: Bool -> [String] +flagsForCompletion isInteractive + = [ '-':flagName flag + | flag <- flagsAll + , modeFilter (flagGhcMode flag) + ] + where + modeFilter AllModes = True + modeFilter OnlyGhci = isInteractive + modeFilter OnlyGhc = not isInteractive + modeFilter HiddenFlag = False + +type TurnOnFlag = Bool -- True <=> we are turning the flag on + -- False <=> we are turning the flag off +turnOn :: TurnOnFlag; turnOn = True +turnOff :: TurnOnFlag; turnOff = False + +data FlagSpec flag + = FlagSpec + { flagSpecName :: String -- ^ Flag in string form + , flagSpecFlag :: flag -- ^ Flag in internal form + , flagSpecAction :: (TurnOnFlag -> DynP ()) + -- ^ Extra action to run when the flag is found + -- Typically, emit a warning or error + , flagSpecGhcMode :: GhcFlagMode + -- ^ In which ghc mode the flag has effect + } + +-- | Define a new flag. +flagSpec :: String -> flag -> (Deprecation, FlagSpec flag) +flagSpec name flag = flagSpec' name flag nop + +-- | Define a new flag with an effect. +flagSpec' :: String -> flag -> (TurnOnFlag -> DynP ()) + -> (Deprecation, FlagSpec flag) +flagSpec' name flag act = (NotDeprecated, FlagSpec name flag act AllModes) + +-- | Define a new deprecated flag with an effect. +depFlagSpecOp :: String -> flag -> (TurnOnFlag -> DynP ()) -> String + -> (Deprecation, FlagSpec flag) +depFlagSpecOp name flag act dep = + (Deprecated, snd (flagSpec' name flag (\f -> act f >> deprecate dep))) + +-- | Define a new deprecated flag. +depFlagSpec :: String -> flag -> String + -> (Deprecation, FlagSpec flag) +depFlagSpec name flag dep = depFlagSpecOp name flag nop dep + +-- | Define a new deprecated flag with an effect where the deprecation message +-- depends on the flag value +depFlagSpecOp' :: String + -> flag + -> (TurnOnFlag -> DynP ()) + -> (TurnOnFlag -> String) + -> (Deprecation, FlagSpec flag) +depFlagSpecOp' name flag act dep = + (Deprecated, FlagSpec name flag (\f -> act f >> (deprecate $ dep f)) + AllModes) + +-- | Define a new deprecated flag where the deprecation message +-- depends on the flag value +depFlagSpec' :: String + -> flag + -> (TurnOnFlag -> String) + -> (Deprecation, FlagSpec flag) +depFlagSpec' name flag dep = depFlagSpecOp' name flag nop dep + + +-- | Define a new deprecated flag where the deprecation message +-- is shown depending on the flag value +depFlagSpecCond :: String + -> flag + -> (TurnOnFlag -> Bool) + -> String + -> (Deprecation, FlagSpec flag) +depFlagSpecCond name flag cond dep = + (Deprecated, FlagSpec name flag (\f -> when (cond f) $ deprecate dep) + AllModes) + +-- | Define a new flag for GHCi. +flagGhciSpec :: String -> flag -> (Deprecation, FlagSpec flag) +flagGhciSpec name flag = flagGhciSpec' name flag nop + +-- | Define a new flag for GHCi with an effect. +flagGhciSpec' :: String -> flag -> (TurnOnFlag -> DynP ()) + -> (Deprecation, FlagSpec flag) +flagGhciSpec' name flag act = (NotDeprecated, FlagSpec name flag act OnlyGhci) + +-- | Define a new flag invisible to CLI completion. +flagHiddenSpec :: String -> flag -> (Deprecation, FlagSpec flag) +flagHiddenSpec name flag = flagHiddenSpec' name flag nop + +-- | Define a new flag invisible to CLI completion with an effect. +flagHiddenSpec' :: String -> flag -> (TurnOnFlag -> DynP ()) + -> (Deprecation, FlagSpec flag) +flagHiddenSpec' name flag act = (NotDeprecated, FlagSpec name flag act + HiddenFlag) + +-- | Hide a 'FlagSpec' from being displayed in @--show-options@. +-- +-- This is for example useful for flags that are obsolete, but should not +-- (yet) be deprecated for compatibility reasons. +hideFlag :: (Deprecation, FlagSpec a) -> (Deprecation, FlagSpec a) +hideFlag (dep, fs) = (dep, fs { flagSpecGhcMode = HiddenFlag }) + +mkFlag :: TurnOnFlag -- ^ True <=> it should be turned on + -> String -- ^ The flag prefix + -> (flag -> DynP ()) -- ^ What to do when the flag is found + -> (Deprecation, FlagSpec flag) -- ^ Specification of + -- this particular flag + -> (Deprecation, Flag (CmdLineP DynFlags)) +mkFlag turn_on flagPrefix f (dep, (FlagSpec name flag extra_action mode)) + = (dep, + Flag (flagPrefix ++ name) (NoArg (f flag >> extra_action turn_on)) mode) + +deprecatedForExtension :: String -> TurnOnFlag -> String +deprecatedForExtension lang turn_on + = "use -X" ++ flag ++ + " or pragma {-# LANGUAGE " ++ flag ++ " #-} instead" + where + flag | turn_on = lang + | otherwise = "No" ++ lang + +useInstead :: String -> String -> TurnOnFlag -> String +useInstead prefix flag turn_on + = "Use " ++ prefix ++ no ++ flag ++ " instead" + where + no = if turn_on then "" else "no-" + +nop :: TurnOnFlag -> DynP () +nop _ = return () + +-- | Find the 'FlagSpec' for a 'WarningFlag'. +flagSpecOf :: WarningFlag -> Maybe (FlagSpec WarningFlag) +flagSpecOf flag = listToMaybe $ filter check wWarningFlags + where + check fs = flagSpecFlag fs == flag + +-- | These @-W\<blah\>@ flags can all be reversed with @-Wno-\<blah\>@ +wWarningFlags :: [FlagSpec WarningFlag] +wWarningFlags = map snd (sortBy (comparing fst) wWarningFlagsDeps) + +wWarningFlagsDeps :: [(Deprecation, FlagSpec WarningFlag)] +wWarningFlagsDeps = [ +-- 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 "alternative-layout-rule-transitional" + Opt_WarnAlternativeLayoutRuleTransitional, + depFlagSpec "auto-orphans" Opt_WarnAutoOrphans + "it has no effect", + flagSpec "cpp-undef" Opt_WarnCPPUndef, + flagSpec "unbanged-strict-patterns" Opt_WarnUnbangedStrictPatterns, + flagSpec "deferred-type-errors" Opt_WarnDeferredTypeErrors, + flagSpec "deferred-out-of-scope-variables" + Opt_WarnDeferredOutOfScopeVariables, + flagSpec "deprecations" Opt_WarnWarningsDeprecations, + flagSpec "deprecated-flags" Opt_WarnDeprecatedFlags, + flagSpec "deriving-defaults" Opt_WarnDerivingDefaults, + flagSpec "deriving-typeable" Opt_WarnDerivingTypeable, + flagSpec "dodgy-exports" Opt_WarnDodgyExports, + flagSpec "dodgy-foreign-imports" Opt_WarnDodgyForeignImports, + flagSpec "dodgy-imports" Opt_WarnDodgyImports, + flagSpec "empty-enumerations" Opt_WarnEmptyEnumerations, + depFlagSpec "duplicate-constraints" Opt_WarnDuplicateConstraints + "it is subsumed by -Wredundant-constraints", + flagSpec "redundant-constraints" Opt_WarnRedundantConstraints, + flagSpec "duplicate-exports" Opt_WarnDuplicateExports, + depFlagSpec "hi-shadowing" Opt_WarnHiShadows + "it is not used, and was never implemented", + flagSpec "inaccessible-code" Opt_WarnInaccessibleCode, + flagSpec "implicit-prelude" Opt_WarnImplicitPrelude, + depFlagSpec "implicit-kind-vars" Opt_WarnImplicitKindVars + "it is now an error", + flagSpec "incomplete-patterns" Opt_WarnIncompletePatterns, + flagSpec "incomplete-record-updates" Opt_WarnIncompletePatternsRecUpd, + flagSpec "incomplete-uni-patterns" Opt_WarnIncompleteUniPatterns, + flagSpec "inline-rule-shadowing" Opt_WarnInlineRuleShadowing, + 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, + flagSpec "missing-methods" Opt_WarnMissingMethods, + flagSpec "missing-monadfail-instances" Opt_WarnMissingMonadFailInstances, + flagSpec "semigroup" Opt_WarnSemigroup, + flagSpec "missing-signatures" Opt_WarnMissingSignatures, + depFlagSpec "missing-exported-sigs" Opt_WarnMissingExportedSignatures + "it is replaced by -Wmissing-exported-signatures", + flagSpec "missing-exported-signatures" Opt_WarnMissingExportedSignatures, + flagSpec "monomorphism-restriction" Opt_WarnMonomorphism, + flagSpec "name-shadowing" Opt_WarnNameShadowing, + flagSpec "noncanonical-monad-instances" + Opt_WarnNonCanonicalMonadInstances, + depFlagSpec "noncanonical-monadfail-instances" + Opt_WarnNonCanonicalMonadInstances + "fail is no longer a method of Monad", + flagSpec "noncanonical-monoid-instances" + Opt_WarnNonCanonicalMonoidInstances, + flagSpec "orphans" Opt_WarnOrphans, + flagSpec "overflowed-literals" Opt_WarnOverflowedLiterals, + flagSpec "overlapping-patterns" Opt_WarnOverlappingPatterns, + flagSpec "missed-specialisations" Opt_WarnMissedSpecs, + flagSpec "missed-specializations" Opt_WarnMissedSpecs, + flagSpec "all-missed-specialisations" Opt_WarnAllMissedSpecs, + flagSpec "all-missed-specializations" Opt_WarnAllMissedSpecs, + flagSpec' "safe" Opt_WarnSafe setWarnSafe, + flagSpec "trustworthy-safe" Opt_WarnTrustworthySafe, + flagSpec "inferred-safe-imports" Opt_WarnInferredSafeImports, + flagSpec "missing-safe-haskell-mode" Opt_WarnMissingSafeHaskellMode, + flagSpec "tabs" Opt_WarnTabs, + flagSpec "type-defaults" Opt_WarnTypeDefaults, + flagSpec "typed-holes" Opt_WarnTypedHoles, + flagSpec "partial-type-signatures" Opt_WarnPartialTypeSignatures, + flagSpec "unrecognised-pragmas" Opt_WarnUnrecognisedPragmas, + flagSpec' "unsafe" Opt_WarnUnsafe setWarnUnsafe, + flagSpec "unsupported-calling-conventions" + Opt_WarnUnsupportedCallingConventions, + flagSpec "unsupported-llvm-version" Opt_WarnUnsupportedLlvmVersion, + flagSpec "missed-extra-shared-lib" Opt_WarnMissedExtraSharedLib, + flagSpec "unticked-promoted-constructors" + Opt_WarnUntickedPromotedConstructors, + flagSpec "unused-do-bind" Opt_WarnUnusedDoBind, + flagSpec "unused-foralls" Opt_WarnUnusedForalls, + flagSpec "unused-imports" Opt_WarnUnusedImports, + flagSpec "unused-local-binds" Opt_WarnUnusedLocalBinds, + flagSpec "unused-matches" Opt_WarnUnusedMatches, + flagSpec "unused-pattern-binds" Opt_WarnUnusedPatternBinds, + flagSpec "unused-top-binds" Opt_WarnUnusedTopBinds, + flagSpec "unused-type-patterns" Opt_WarnUnusedTypePatterns, + flagSpec "unused-record-wildcards" Opt_WarnUnusedRecordWildcards, + flagSpec "redundant-record-wildcards" Opt_WarnRedundantRecordWildcards, + flagSpec "warnings-deprecations" Opt_WarnWarningsDeprecations, + flagSpec "wrong-do-bind" Opt_WarnWrongDoBind, + flagSpec "missing-pattern-synonym-signatures" + Opt_WarnMissingPatternSynonymSignatures, + flagSpec "missing-deriving-strategies" Opt_WarnMissingDerivingStrategies, + flagSpec "simplifiable-class-constraints" Opt_WarnSimplifiableClassConstraints, + flagSpec "missing-home-modules" Opt_WarnMissingHomeModules, + flagSpec "unrecognised-warning-flags" Opt_WarnUnrecognisedWarningFlags, + flagSpec "star-binder" Opt_WarnStarBinder, + flagSpec "star-is-type" Opt_WarnStarIsType, + depFlagSpec "missing-space-after-bang" Opt_WarnSpaceAfterBang + "bang patterns can no longer be written with a space", + flagSpec "partial-fields" Opt_WarnPartialFields, + flagSpec "prepositive-qualified-module" + Opt_WarnPrepositiveQualifiedModule, + flagSpec "unused-packages" Opt_WarnUnusedPackages, + flagSpec "compat-unqualified-imports" Opt_WarnCompatUnqualifiedImports + ] + +-- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@ +negatableFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)] +negatableFlagsDeps = [ + flagGhciSpec "ignore-dot-ghci" Opt_IgnoreDotGhci ] + +-- | These @-d\<blah\>@ flags can all be reversed with @-dno-\<blah\>@ +dFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)] +dFlagsDeps = [ +-- 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 "ppr-case-as-let" Opt_PprCaseAsLet, + depFlagSpec' "ppr-ticks" Opt_PprShowTicks + (\turn_on -> useInstead "-d" "suppress-ticks" (not turn_on)), + flagSpec "suppress-ticks" Opt_SuppressTicks, + depFlagSpec' "suppress-stg-free-vars" Opt_SuppressStgExts + (useInstead "-d" "suppress-stg-exts"), + flagSpec "suppress-stg-exts" Opt_SuppressStgExts, + 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 + ] + +-- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@ +fFlags :: [FlagSpec GeneralFlag] +fFlags = map snd fFlagsDeps + +fFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)] +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, + flagSpec "cmm-sink" Opt_CmmSink, + flagSpec "cse" Opt_CSE, + flagSpec "stg-cse" Opt_StgCSE, + flagSpec "stg-lift-lams" Opt_StgLiftLams, + flagSpec "cpr-anal" Opt_CprAnal, + flagSpec "defer-diagnostics" Opt_DeferDiagnostics, + flagSpec "defer-type-errors" Opt_DeferTypeErrors, + flagSpec "defer-typed-holes" Opt_DeferTypedHoles, + flagSpec "defer-out-of-scope-variables" Opt_DeferOutOfScopeVariables, + flagSpec "diagnostics-show-caret" Opt_DiagnosticsShowCaret, + flagSpec "dicts-cheap" Opt_DictsCheap, + flagSpec "dicts-strict" Opt_DictsStrict, + flagSpec "dmd-tx-dict-sel" Opt_DmdTxDictSel, + flagSpec "do-eta-reduction" Opt_DoEtaReduction, + flagSpec "do-lambda-eta-expansion" Opt_DoLambdaEtaExpansion, + flagSpec "eager-blackholing" Opt_EagerBlackHoling, + flagSpec "embed-manifest" Opt_EmbedManifest, + flagSpec "enable-rewrite-rules" Opt_EnableRewriteRules, + flagSpec "enable-th-splice-warnings" Opt_EnableThSpliceWarnings, + 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, + flagSpec "validate-ide-info" Opt_ValidateHie, + 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, + flagSpec "ignore-asserts" Opt_IgnoreAsserts, + flagSpec "ignore-interface-pragmas" Opt_IgnoreInterfacePragmas, + flagGhciSpec "implicit-import-qualified" Opt_ImplicitImportQualified, + flagSpec "irrefutable-tuples" Opt_IrrefutableTuples, + flagSpec "keep-going" Opt_KeepGoing, + 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-tbaa" Opt_LlvmTBAA, + flagHiddenSpec "llvm-fill-undef-with-garbage" Opt_LlvmFillUndefWithGarbage, + flagSpec "loopification" Opt_Loopification, + flagSpec "block-layout-cfg" Opt_CfgBlocklayout, + flagSpec "block-layout-weightless" Opt_WeightlessBlocklayout, + flagSpec "omit-interface-pragmas" Opt_OmitInterfacePragmas, + flagSpec "omit-yields" Opt_OmitYields, + flagSpec "optimal-applicative-do" Opt_OptimalApplicativeDo, + flagSpec "pedantic-bottoms" Opt_PedanticBottoms, + flagSpec "pre-inlining" Opt_SimplPreInlining, + flagGhciSpec "print-bind-contents" Opt_PrintBindContents, + flagGhciSpec "print-bind-result" Opt_PrintBindResult, + flagGhciSpec "print-evld-with-show" Opt_PrintEvldWithShow, + flagSpec "print-explicit-foralls" Opt_PrintExplicitForalls, + flagSpec "print-explicit-kinds" Opt_PrintExplicitKinds, + flagSpec "print-explicit-coercions" Opt_PrintExplicitCoercions, + flagSpec "print-explicit-runtime-reps" Opt_PrintExplicitRuntimeReps, + flagSpec "print-equality-relations" Opt_PrintEqualityRelations, + flagSpec "print-axiom-incomps" Opt_PrintAxiomIncomps, + flagSpec "print-unicode-syntax" Opt_PrintUnicodeSyntax, + flagSpec "print-expanded-synonyms" Opt_PrintExpandedSynonyms, + flagSpec "print-potential-instances" Opt_PrintPotentialInstances, + flagSpec "print-typechecker-elaboration" Opt_PrintTypecheckerElaboration, + flagSpec "prof-cafs" Opt_AutoSccsOnIndividualCafs, + flagSpec "prof-count-entries" Opt_ProfCountEntries, + flagSpec "regs-graph" Opt_RegsGraph, + flagSpec "regs-iterative" Opt_RegsIterative, + depFlagSpec' "rewrite-rules" Opt_EnableRewriteRules + (useInstead "-f" "enable-rewrite-rules"), + flagSpec "shared-implib" Opt_SharedImplib, + flagSpec "spec-constr" Opt_SpecConstr, + flagSpec "spec-constr-keen" Opt_SpecConstrKeen, + flagSpec "specialise" Opt_Specialise, + flagSpec "specialize" Opt_Specialise, + flagSpec "specialise-aggressively" Opt_SpecialiseAggressively, + flagSpec "specialize-aggressively" Opt_SpecialiseAggressively, + flagSpec "cross-module-specialise" Opt_CrossModuleSpecialise, + flagSpec "cross-module-specialize" Opt_CrossModuleSpecialise, + flagSpec "static-argument-transformation" Opt_StaticArgumentTransformation, + flagSpec "strictness" Opt_Strictness, + flagSpec "use-rpaths" Opt_RPath, + flagSpec "write-interface" Opt_WriteInterface, + flagSpec "write-ide-info" Opt_WriteHie, + flagSpec "unbox-small-strict-fields" Opt_UnboxSmallStrictFields, + flagSpec "unbox-strict-fields" Opt_UnboxStrictFields, + 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-loaded-modules" Opt_ShowLoadedModules, + flagSpec "whole-archive-hs-libs" Opt_WholeArchiveHsLibs, + flagSpec "keep-cafs" Opt_KeepCAFs + ] + ++ 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] +fLangFlags = map snd fLangFlagsDeps + +fLangFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)] +fLangFlagsDeps = [ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] + depFlagSpecOp' "th" LangExt.TemplateHaskell + checkTemplateHaskellOk + (deprecatedForExtension "TemplateHaskell"), + depFlagSpec' "fi" LangExt.ForeignFunctionInterface + (deprecatedForExtension "ForeignFunctionInterface"), + depFlagSpec' "ffi" LangExt.ForeignFunctionInterface + (deprecatedForExtension "ForeignFunctionInterface"), + depFlagSpec' "arrows" LangExt.Arrows + (deprecatedForExtension "Arrows"), + depFlagSpec' "implicit-prelude" LangExt.ImplicitPrelude + (deprecatedForExtension "ImplicitPrelude"), + depFlagSpec' "bang-patterns" LangExt.BangPatterns + (deprecatedForExtension "BangPatterns"), + depFlagSpec' "monomorphism-restriction" LangExt.MonomorphismRestriction + (deprecatedForExtension "MonomorphismRestriction"), + depFlagSpec' "mono-pat-binds" LangExt.MonoPatBinds + (deprecatedForExtension "MonoPatBinds"), + depFlagSpec' "extended-default-rules" LangExt.ExtendedDefaultRules + (deprecatedForExtension "ExtendedDefaultRules"), + depFlagSpec' "implicit-params" LangExt.ImplicitParams + (deprecatedForExtension "ImplicitParams"), + depFlagSpec' "scoped-type-variables" LangExt.ScopedTypeVariables + (deprecatedForExtension "ScopedTypeVariables"), + depFlagSpec' "allow-overlapping-instances" LangExt.OverlappingInstances + (deprecatedForExtension "OverlappingInstances"), + depFlagSpec' "allow-undecidable-instances" LangExt.UndecidableInstances + (deprecatedForExtension "UndecidableInstances"), + depFlagSpec' "allow-incoherent-instances" LangExt.IncoherentInstances + (deprecatedForExtension "IncoherentInstances") + ] + +supportedLanguages :: [String] +supportedLanguages = map (flagSpecName . snd) languageFlagsDeps + +supportedLanguageOverlays :: [String] +supportedLanguageOverlays = map (flagSpecName . snd) safeHaskellFlagsDeps + +supportedExtensions :: PlatformMini -> [String] +supportedExtensions targetPlatformMini = concatMap toFlagSpecNamePair xFlags + where + toFlagSpecNamePair flg + -- IMPORTANT! Make sure that `ghc --supported-extensions` omits + -- "TemplateHaskell"/"QuasiQuotes" when it's known not to work out of the + -- box. See also GHC #11102 and #16331 for more details about + -- the rationale + | isAIX, flagSpecFlag flg == LangExt.TemplateHaskell = [noName] + | isAIX, flagSpecFlag flg == LangExt.QuasiQuotes = [noName] + | otherwise = [name, noName] + where + isAIX = platformMini_os targetPlatformMini == OSAIX + noName = "No" ++ name + name = flagSpecName flg + +supportedLanguagesAndExtensions :: PlatformMini -> [String] +supportedLanguagesAndExtensions targetPlatformMini = + supportedLanguages ++ supportedLanguageOverlays ++ supportedExtensions targetPlatformMini + +-- | These -X<blah> flags cannot be reversed with -XNo<blah> +languageFlagsDeps :: [(Deprecation, FlagSpec Language)] +languageFlagsDeps = [ + flagSpec "Haskell98" Haskell98, + flagSpec "Haskell2010" Haskell2010 + ] + +-- | These -X<blah> flags cannot be reversed with -XNo<blah> +-- They are used to place hard requirements on what GHC Haskell language +-- features can be used. +safeHaskellFlagsDeps :: [(Deprecation, FlagSpec SafeHaskellMode)] +safeHaskellFlagsDeps = [mkF Sf_Unsafe, mkF Sf_Trustworthy, mkF Sf_Safe] + where mkF flag = flagSpec (show flag) flag + +-- | These -X<blah> flags can all be reversed with -XNo<blah> +xFlags :: [FlagSpec LangExt.Extension] +xFlags = map snd xFlagsDeps + +xFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)] +xFlagsDeps = [ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] +-- See Note [Adding a language extension] +-- Please keep the list of flags below sorted alphabetically + flagSpec "AllowAmbiguousTypes" LangExt.AllowAmbiguousTypes, + flagSpec "AlternativeLayoutRule" LangExt.AlternativeLayoutRule, + flagSpec "AlternativeLayoutRuleTransitional" + LangExt.AlternativeLayoutRuleTransitional, + flagSpec "Arrows" LangExt.Arrows, + 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, + flagSpec "CPP" LangExt.Cpp, + flagSpec "CUSKs" LangExt.CUSKs, + flagSpec "ConstrainedClassMethods" LangExt.ConstrainedClassMethods, + flagSpec "ConstraintKinds" LangExt.ConstraintKinds, + flagSpec "DataKinds" LangExt.DataKinds, + depFlagSpecCond "DatatypeContexts" LangExt.DatatypeContexts + id + ("It was widely considered a misfeature, " ++ + "and has been removed from the Haskell language."), + flagSpec "DefaultSignatures" LangExt.DefaultSignatures, + flagSpec "DeriveAnyClass" LangExt.DeriveAnyClass, + flagSpec "DeriveDataTypeable" LangExt.DeriveDataTypeable, + flagSpec "DeriveFoldable" LangExt.DeriveFoldable, + flagSpec "DeriveFunctor" LangExt.DeriveFunctor, + flagSpec "DeriveGeneric" LangExt.DeriveGeneric, + 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, + flagSpec "ExtendedDefaultRules" LangExt.ExtendedDefaultRules, + flagSpec "FlexibleContexts" LangExt.FlexibleContexts, + flagSpec "FlexibleInstances" LangExt.FlexibleInstances, + flagSpec "ForeignFunctionInterface" LangExt.ForeignFunctionInterface, + flagSpec "FunctionalDependencies" LangExt.FunctionalDependencies, + flagSpec "GADTSyntax" LangExt.GADTSyntax, + flagSpec "GADTs" LangExt.GADTs, + flagSpec "GHCForeignImportPrim" LangExt.GHCForeignImportPrim, + flagSpec' "GeneralizedNewtypeDeriving" LangExt.GeneralizedNewtypeDeriving + setGenDeriving, + flagSpec' "GeneralisedNewtypeDeriving" LangExt.GeneralizedNewtypeDeriving + setGenDeriving, + flagSpec "ImplicitParams" LangExt.ImplicitParams, + flagSpec "ImplicitPrelude" LangExt.ImplicitPrelude, + flagSpec "ImportQualifiedPost" LangExt.ImportQualifiedPost, + flagSpec "ImpredicativeTypes" LangExt.ImpredicativeTypes, + flagSpec' "IncoherentInstances" LangExt.IncoherentInstances + setIncoherentInsts, + flagSpec "TypeFamilyDependencies" LangExt.TypeFamilyDependencies, + flagSpec "InstanceSigs" LangExt.InstanceSigs, + flagSpec "ApplicativeDo" LangExt.ApplicativeDo, + flagSpec "InterruptibleFFI" LangExt.InterruptibleFFI, + flagSpec "JavaScriptFFI" LangExt.JavaScriptFFI, + flagSpec "KindSignatures" LangExt.KindSignatures, + flagSpec "LambdaCase" LangExt.LambdaCase, + flagSpec "LiberalTypeSynonyms" LangExt.LiberalTypeSynonyms, + flagSpec "MagicHash" LangExt.MagicHash, + flagSpec "MonadComprehensions" LangExt.MonadComprehensions, + depFlagSpec "MonadFailDesugaring" LangExt.MonadFailDesugaring + "MonadFailDesugaring is now the default behavior", + flagSpec "MonoLocalBinds" LangExt.MonoLocalBinds, + depFlagSpecCond "MonoPatBinds" LangExt.MonoPatBinds + id + "Experimental feature now removed; has no effect", + 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"), + flagSpec "NumDecimals" LangExt.NumDecimals, + depFlagSpecOp "OverlappingInstances" LangExt.OverlappingInstances + setOverlappingInsts + "instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS", + flagSpec "OverloadedLabels" LangExt.OverloadedLabels, + flagSpec "OverloadedLists" LangExt.OverloadedLists, + flagSpec "OverloadedStrings" LangExt.OverloadedStrings, + flagSpec "PackageImports" LangExt.PackageImports, + flagSpec "ParallelArrays" LangExt.ParallelArrays, + flagSpec "ParallelListComp" LangExt.ParallelListComp, + flagSpec "PartialTypeSignatures" LangExt.PartialTypeSignatures, + flagSpec "PatternGuards" LangExt.PatternGuards, + depFlagSpec' "PatternSignatures" LangExt.ScopedTypeVariables + (deprecatedForExtension "ScopedTypeVariables"), + 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, + flagSpec "RankNTypes" LangExt.RankNTypes, + flagSpec "RebindableSyntax" LangExt.RebindableSyntax, + depFlagSpec' "RecordPuns" LangExt.RecordPuns + (deprecatedForExtension "NamedFieldPuns"), + flagSpec "RecordWildCards" LangExt.RecordWildCards, + flagSpec "RecursiveDo" LangExt.RecursiveDo, + flagSpec "RelaxedLayout" LangExt.RelaxedLayout, + depFlagSpecCond "RelaxedPolyRec" LangExt.RelaxedPolyRec + not + "You can't turn off RelaxedPolyRec any more", + 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, + flagSpec' "TemplateHaskell" LangExt.TemplateHaskell + checkTemplateHaskellOk, + flagSpec "TemplateHaskellQuotes" LangExt.TemplateHaskellQuotes, + flagSpec "StandaloneKindSignatures" LangExt.StandaloneKindSignatures, + flagSpec "TraditionalRecordSyntax" LangExt.TraditionalRecordSyntax, + flagSpec "TransformListComp" LangExt.TransformListComp, + flagSpec "TupleSections" LangExt.TupleSections, + flagSpec "TypeApplications" LangExt.TypeApplications, + flagSpec "TypeInType" LangExt.TypeInType, + flagSpec "TypeFamilies" LangExt.TypeFamilies, + flagSpec "TypeOperators" LangExt.TypeOperators, + flagSpec "TypeSynonymInstances" LangExt.TypeSynonymInstances, + flagSpec "UnboxedTuples" LangExt.UnboxedTuples, + flagSpec "UnboxedSums" LangExt.UnboxedSums, + flagSpec "UndecidableInstances" LangExt.UndecidableInstances, + flagSpec "UndecidableSuperClasses" LangExt.UndecidableSuperClasses, + flagSpec "UnicodeSyntax" LangExt.UnicodeSyntax, + flagSpec "UnliftedFFITypes" LangExt.UnliftedFFITypes, + flagSpec "UnliftedNewtypes" LangExt.UnliftedNewtypes, + flagSpec "ViewPatterns" LangExt.ViewPatterns + ] + +defaultFlags :: Settings -> [GeneralFlag] +defaultFlags settings +-- See Note [Updating flag description in the User's Guide] + = [ Opt_AutoLinkPackages, + Opt_DiagnosticsShowCaret, + Opt_EmbedManifest, + Opt_FlatCache, + Opt_GenManifest, + Opt_GhciHistory, + Opt_GhciSandbox, + Opt_HelpfulErrors, + Opt_KeepHiFiles, + Opt_KeepOFiles, + Opt_OmitYields, + Opt_PrintBindContents, + Opt_ProfCountEntries, + Opt_RPath, + Opt_SharedImplib, + Opt_SimplPreInlining, + Opt_VersionMacros + ] + + ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns] + -- The default -O0 options + + ++ 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 + (OSDarwin, ArchX86_64) -> [Opt_PIC] + (OSOpenBSD, ArchX86_64) -> [Opt_PIC] -- Due to PIE support in + -- OpenBSD since 5.3 release + -- (1 May 2013) we need to + -- always generate PIC. See + -- #10597 for more + -- information. + _ -> [] + +-- General flags that are switched on/off when other general flags are switched +-- on +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 +impliedOffGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] +impliedOffGFlags = [(Opt_Strictness, turnOff, Opt_WorkerWrapper)] + +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) + , (LangExt.FlexibleInstances, turnOn, LangExt.TypeSynonymInstances) + , (LangExt.FunctionalDependencies, turnOn, LangExt.MultiParamTypeClasses) + , (LangExt.MultiParamTypeClasses, turnOn, LangExt.ConstrainedClassMethods) -- c.f. #7854 + , (LangExt.TypeFamilyDependencies, turnOn, LangExt.TypeFamilies) + + , (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) + + -- Standalone kind signatures are a replacement for CUSKs. + , (LangExt.StandaloneKindSignatures, turnOff, LangExt.CUSKs) + + -- AutoDeriveTypeable is not very useful without DeriveDataTypeable + , (LangExt.AutoDeriveTypeable, turnOn, LangExt.DeriveDataTypeable) + + -- We turn this on so that we can export associated type + -- type synonyms in subordinates (e.g. MyClass(type AssocType)) + , (LangExt.TypeFamilies, turnOn, LangExt.ExplicitNamespaces) + , (LangExt.TypeOperators, turnOn, LangExt.ExplicitNamespaces) + + , (LangExt.ImpredicativeTypes, turnOn, LangExt.RankNTypes) + + -- Record wild-cards implies field disambiguation + -- Otherwise if you write (C {..}) you may well get + -- stuff like " 'a' not in scope ", which is a bit silly + -- if the compiler has just filled in field 'a' of constructor 'C' + , (LangExt.RecordWildCards, turnOn, LangExt.DisambiguateRecordFields) + + , (LangExt.ParallelArrays, turnOn, LangExt.ParallelListComp) + + , (LangExt.JavaScriptFFI, turnOn, LangExt.InterruptibleFFI) + + , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFunctor) + , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFoldable) + + -- Duplicate record fields require field disambiguation + , (LangExt.DuplicateRecordFields, turnOn, LangExt.DisambiguateRecordFields) + + , (LangExt.TemplateHaskell, turnOn, LangExt.TemplateHaskellQuotes) + , (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 file is: +-- +-- docs/users_guide/using-optimisation.rst +-- +-- Make sure to note whether a flag is implied by -O0, -O or -O2. + +optLevelFlags :: [([Int], GeneralFlag)] +-- Default settings of flags, before any command-line overrides +optLevelFlags -- see Note [Documenting optimisation flags] + = [ ([0,1,2], Opt_DoLambdaEtaExpansion) + , ([0,1,2], Opt_DoEtaReduction) -- See Note [Eta-reduction in -O0] + , ([0,1,2], Opt_DmdTxDictSel) + , ([0,1,2], Opt_LlvmTBAA) + + , ([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) + , ([2], Opt_StgLiftLams) + + , ([1,2], Opt_EnableRewriteRules) + -- Off for -O0. Otherwise we desugar list literals + -- to 'build' but don't run the simplifier passes that + -- would rewrite them back to cons cells! This seems + -- silly, and matters for the GHCi debugger. + + , ([1,2], Opt_FloatIn) + , ([1,2], Opt_FullLaziness) + , ([1,2], Opt_IgnoreAsserts) + , ([1,2], Opt_Loopification) + , ([1,2], Opt_CfgBlocklayout) -- Experimental + + , ([1,2], Opt_Specialise) + , ([1,2], Opt_CrossModuleSpecialise) + , ([1,2], Opt_Strictness) + , ([1,2], Opt_UnboxSmallStrictFields) + , ([1,2], Opt_CprAnal) + , ([1,2], Opt_WorkerWrapper) + , ([1,2], Opt_SolveConstantDicts) + , ([1,2], Opt_NumConstantFolding) + + , ([2], Opt_LiberateCase) + , ([2], Opt_SpecConstr) +-- , ([2], Opt_RegsGraph) +-- RegsGraph suffers performance regression. See #7679 +-- , ([2], Opt_StaticArgumentTransformation) +-- Static Argument Transformation needs investigation. See #9374 + ] + + +-- ----------------------------------------------------------------------------- +-- Standard sets of warning options + +-- Note [Documenting warning flags] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- If you change the list of warning enabled by default +-- please remember to update the User's Guide. The relevant file is: +-- +-- docs/users_guide/using-warnings.rst + +-- | Warning groups. +-- +-- As all warnings are in the Weverything set, it is ignored when +-- displaying to the user which group a warning is in. +warningGroups :: [(String, [WarningFlag])] +warningGroups = + [ ("compat", minusWcompatOpts) + , ("unused-binds", unusedBindsFlags) + , ("default", standardWarnings) + , ("extra", minusWOpts) + , ("all", minusWallOpts) + , ("everything", minusWeverythingOpts) + ] + +-- | Warning group hierarchies, where there is an explicit inclusion +-- relation. +-- +-- Each inner list is a hierarchy of warning groups, ordered from +-- smallest to largest, where each group is a superset of the one +-- before it. +-- +-- Separating this from 'warningGroups' allows for multiple +-- hierarchies with no inherent relation to be defined. +-- +-- The special-case Weverything group is not included. +warningHierarchies :: [[String]] +warningHierarchies = hierarchies ++ map (:[]) rest + where + hierarchies = [["default", "extra", "all"]] + rest = filter (`notElem` "everything" : concat hierarchies) $ + map fst warningGroups + +-- | Find the smallest group in every hierarchy which a warning +-- belongs to, excluding Weverything. +smallestGroups :: WarningFlag -> [String] +smallestGroups flag = mapMaybe go warningHierarchies where + -- Because each hierarchy is arranged from smallest to largest, + -- the first group we find in a hierarchy which contains the flag + -- is the smallest. + go (group:rest) = fromMaybe (go rest) $ do + flags <- lookup group warningGroups + guard (flag `elem` flags) + pure (Just group) + go [] = Nothing + +-- | Warnings enabled unless specified otherwise +standardWarnings :: [WarningFlag] +standardWarnings -- see Note [Documenting warning flags] + = [ Opt_WarnOverlappingPatterns, + Opt_WarnWarningsDeprecations, + Opt_WarnDeprecatedFlags, + Opt_WarnDeferredTypeErrors, + Opt_WarnTypedHoles, + Opt_WarnDeferredOutOfScopeVariables, + Opt_WarnPartialTypeSignatures, + Opt_WarnUnrecognisedPragmas, + Opt_WarnDuplicateExports, + Opt_WarnDerivingDefaults, + Opt_WarnOverflowedLiterals, + Opt_WarnEmptyEnumerations, + Opt_WarnMissingFields, + Opt_WarnMissingMethods, + Opt_WarnWrongDoBind, + Opt_WarnUnsupportedCallingConventions, + Opt_WarnDodgyForeignImports, + Opt_WarnInlineRuleShadowing, + Opt_WarnAlternativeLayoutRuleTransitional, + Opt_WarnUnsupportedLlvmVersion, + Opt_WarnMissedExtraSharedLib, + Opt_WarnTabs, + Opt_WarnUnrecognisedWarningFlags, + Opt_WarnSimplifiableClassConstraints, + Opt_WarnStarBinder, + Opt_WarnInaccessibleCode, + Opt_WarnSpaceAfterBang + ] + +-- | Things you get with -W +minusWOpts :: [WarningFlag] +minusWOpts + = standardWarnings ++ + [ Opt_WarnUnusedTopBinds, + Opt_WarnUnusedLocalBinds, + Opt_WarnUnusedPatternBinds, + Opt_WarnUnusedMatches, + Opt_WarnUnusedForalls, + Opt_WarnUnusedImports, + Opt_WarnIncompletePatterns, + Opt_WarnDodgyExports, + Opt_WarnDodgyImports, + Opt_WarnUnbangedStrictPatterns + ] + +-- | Things you get with -Wall +minusWallOpts :: [WarningFlag] +minusWallOpts + = minusWOpts ++ + [ Opt_WarnTypeDefaults, + Opt_WarnNameShadowing, + Opt_WarnMissingSignatures, + Opt_WarnHiShadows, + Opt_WarnOrphans, + Opt_WarnUnusedDoBind, + Opt_WarnTrustworthySafe, + Opt_WarnUntickedPromotedConstructors, + Opt_WarnMissingPatternSynonymSignatures, + Opt_WarnUnusedRecordWildcards, + Opt_WarnRedundantRecordWildcards, + Opt_WarnStarIsType + ] + +-- | Things you get with -Weverything, i.e. *all* known warnings flags +minusWeverythingOpts :: [WarningFlag] +minusWeverythingOpts = [ toEnum 0 .. ] + +-- | Things you get with -Wcompat. +-- +-- This is intended to group together warnings that will be enabled by default +-- at some point in the future, so that library authors eager to make their +-- code future compatible to fix issues before they even generate warnings. +minusWcompatOpts :: [WarningFlag] +minusWcompatOpts + = [ Opt_WarnMissingMonadFailInstances + , Opt_WarnSemigroup + , Opt_WarnNonCanonicalMonoidInstances + , Opt_WarnStarIsType + , Opt_WarnCompatUnqualifiedImports + ] + +enableUnusedBinds :: DynP () +enableUnusedBinds = mapM_ setWarningFlag unusedBindsFlags + +disableUnusedBinds :: DynP () +disableUnusedBinds = mapM_ unSetWarningFlag unusedBindsFlags + +-- Things you get with -Wunused-binds +unusedBindsFlags :: [WarningFlag] +unusedBindsFlags = [ Opt_WarnUnusedTopBinds + , Opt_WarnUnusedLocalBinds + , Opt_WarnUnusedPatternBinds + ] + +enableGlasgowExts :: DynP () +enableGlasgowExts = do setGeneralFlag Opt_PrintExplicitForalls + mapM_ setExtensionFlag glasgowExtsFlags + +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 + , LangExt.DeriveDataTypeable + , LangExt.DeriveFoldable + , LangExt.DeriveFunctor + , LangExt.DeriveGeneric + , LangExt.DeriveTraversable + , LangExt.EmptyDataDecls + , LangExt.ExistentialQuantification + , LangExt.ExplicitNamespaces + , LangExt.FlexibleContexts + , LangExt.FlexibleInstances + , LangExt.ForeignFunctionInterface + , LangExt.FunctionalDependencies + , LangExt.GeneralizedNewtypeDeriving + , LangExt.ImplicitParams + , LangExt.KindSignatures + , LangExt.LiberalTypeSynonyms + , LangExt.MagicHash + , LangExt.MultiParamTypeClasses + , LangExt.ParallelListComp + , LangExt.PatternGuards + , LangExt.PostfixOperators + , LangExt.RankNTypes + , LangExt.RecursiveDo + , LangExt.ScopedTypeVariables + , LangExt.StandaloneDeriving + , LangExt.TypeOperators + , LangExt.TypeSynonymInstances + , LangExt.UnboxedTuples + , LangExt.UnicodeSyntax + , LangExt.UnliftedFFITypes ] + +foreign import ccall unsafe "rts_isProfiled" rtsIsProfiledIO :: IO CInt + +-- | Was the runtime system built with profiling enabled? +rtsIsProfiled :: Bool +rtsIsProfiled = unsafeDupablePerformIO rtsIsProfiledIO /= 0 + +-- Consult the RTS to find whether GHC itself has been built with +-- dynamic linking. This can't be statically known at compile-time, +-- because we build both the static and dynamic versions together with +-- -dynamic-too. +foreign import ccall unsafe "rts_isDynamic" rtsIsDynamicIO :: IO CInt + +dynamicGhc :: Bool +dynamicGhc = unsafeDupablePerformIO rtsIsDynamicIO /= 0 + +setWarnSafe :: Bool -> DynP () +setWarnSafe True = getCurLoc >>= \l -> upd (\d -> d { warnSafeOnLoc = l }) +setWarnSafe False = return () + +setWarnUnsafe :: Bool -> DynP () +setWarnUnsafe True = getCurLoc >>= \l -> upd (\d -> d { warnUnsafeOnLoc = l }) +setWarnUnsafe False = return () + +setPackageTrust :: DynP () +setPackageTrust = do + setGeneralFlag Opt_PackageTrust + l <- getCurLoc + upd $ \d -> d { pkgTrustOnLoc = l } + +setGenDeriving :: TurnOnFlag -> DynP () +setGenDeriving True = getCurLoc >>= \l -> upd (\d -> d { newDerivOnLoc = l }) +setGenDeriving False = return () + +setOverlappingInsts :: TurnOnFlag -> DynP () +setOverlappingInsts False = return () +setOverlappingInsts True = do + l <- getCurLoc + upd (\d -> d { overlapInstLoc = l }) + +setIncoherentInsts :: TurnOnFlag -> DynP () +setIncoherentInsts False = return () +setIncoherentInsts True = do + l <- getCurLoc + upd (\d -> d { incoherentOnLoc = l }) + +checkTemplateHaskellOk :: TurnOnFlag -> DynP () +checkTemplateHaskellOk _turn_on + = getCurLoc >>= \l -> upd (\d -> d { thOnLoc = l }) + +{- ********************************************************************** +%* * + DynFlags constructors +%* * +%********************************************************************* -} + +type DynP = EwM (CmdLineP DynFlags) + +upd :: (DynFlags -> DynFlags) -> DynP () +upd f = liftEwM (do dflags <- getCmdLineState + putCmdLineState $! f dflags) + +updM :: (DynFlags -> DynP DynFlags) -> DynP () +updM f = do dflags <- liftEwM getCmdLineState + dflags' <- f dflags + liftEwM $ putCmdLineState $! dflags' + +--------------- Constructor functions for OptKind ----------------- +noArg :: (DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +noArg fn = NoArg (upd fn) + +noArgM :: (DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags) +noArgM fn = NoArg (updM fn) + +hasArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +hasArg fn = HasArg (upd . fn) + +sepArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +sepArg fn = SepArg (upd . fn) + +intSuffix :: (Int -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +intSuffix fn = IntSuffix (\n -> upd (fn n)) + +intSuffixM :: (Int -> DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags) +intSuffixM fn = IntSuffix (\n -> updM (fn n)) + +floatSuffix :: (Float -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +floatSuffix fn = FloatSuffix (\n -> upd (fn n)) + +optIntSuffixM :: (Maybe Int -> DynFlags -> DynP DynFlags) + -> OptKind (CmdLineP DynFlags) +optIntSuffixM fn = OptIntSuffix (\mi -> updM (fn mi)) + +setDumpFlag :: DumpFlag -> OptKind (CmdLineP DynFlags) +setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag) + +-------------------------- +addWay :: Way -> DynP () +addWay w = upd (addWay' w) + +addWay' :: Way -> DynFlags -> DynFlags +addWay' w dflags0 = let platform = targetPlatform dflags0 + dflags1 = dflags0 { ways = w : ways dflags0 } + dflags2 = foldr setGeneralFlag' dflags1 + (wayGeneralFlags platform w) + dflags3 = foldr unSetGeneralFlag' dflags2 + (wayUnsetGeneralFlags platform w) + in dflags3 + +removeWayDyn :: DynP () +removeWayDyn = upd (\dfs -> dfs { ways = filter (WayDyn /=) (ways dfs) }) + +-------------------------- +setGeneralFlag, unSetGeneralFlag :: GeneralFlag -> DynP () +setGeneralFlag f = upd (setGeneralFlag' f) +unSetGeneralFlag f = upd (unSetGeneralFlag' f) + +setGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags +setGeneralFlag' f dflags = foldr ($) (gopt_set dflags f) deps + where + deps = [ if turn_on then setGeneralFlag' d + else unSetGeneralFlag' d + | (f', turn_on, d) <- impliedGFlags, f' == f ] + -- When you set f, set the ones it implies + -- NB: use setGeneralFlag recursively, in case the implied flags + -- implies further flags + +unSetGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags +unSetGeneralFlag' f dflags = foldr ($) (gopt_unset dflags f) deps + where + deps = [ if turn_on then setGeneralFlag' d + else unSetGeneralFlag' d + | (f', turn_on, d) <- impliedOffGFlags, f' == f ] + -- In general, when you un-set f, we don't un-set the things it implies. + -- There are however some exceptions, e.g., -fno-strictness implies + -- -fno-worker-wrapper. + -- + -- NB: use unSetGeneralFlag' recursively, in case the implied off flags + -- imply further flags. + +-------------------------- +setWarningFlag, unSetWarningFlag :: WarningFlag -> DynP () +setWarningFlag f = upd (\dfs -> wopt_set dfs f) +unSetWarningFlag f = upd (\dfs -> wopt_unset dfs f) + +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) +unSetExtensionFlag f = upd (unSetExtensionFlag' f) + +setExtensionFlag', unSetExtensionFlag' :: LangExt.Extension -> DynFlags -> DynFlags +setExtensionFlag' f dflags = foldr ($) (xopt_set dflags f) deps + where + deps = [ if turn_on then setExtensionFlag' d + else unSetExtensionFlag' d + | (f', turn_on, d) <- impliedXFlags, f' == f ] + -- When you set f, set the ones it implies + -- NB: use setExtensionFlag recursively, in case the implied flags + -- implies further flags + +unSetExtensionFlag' f dflags = xopt_unset dflags f + -- When you un-set f, however, we don't un-set the things it implies + -- (except for -fno-glasgow-exts, which is treated specially) + +-------------------------- +alterFileSettings :: (FileSettings -> FileSettings) -> DynFlags -> DynFlags +alterFileSettings f dynFlags = dynFlags { fileSettings = f (fileSettings dynFlags) } + +alterToolSettings :: (ToolSettings -> ToolSettings) -> DynFlags -> DynFlags +alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) } + +-------------------------- +setDumpFlag' :: DumpFlag -> DynP () +setDumpFlag' dump_flag + = do upd (\dfs -> dopt_set dfs dump_flag) + when want_recomp forceRecompile + where -- Certain dumpy-things are really interested in what's going + -- on during recompilation checking, so in those cases we + -- don't want to turn it off. + want_recomp = dump_flag `notElem` [Opt_D_dump_if_trace, + Opt_D_dump_hi_diffs, + Opt_D_no_debug_output] + +forceRecompile :: DynP () +-- Whenever we -ddump, force recompilation (by switching off the +-- recompilation checker), else you don't see the dump! However, +-- don't switch it off in --make mode, else *everything* gets +-- recompiled which probably isn't what you want +forceRecompile = do dfs <- liftEwM getCmdLineState + when (force_recomp dfs) (setGeneralFlag Opt_ForceRecomp) + where + force_recomp dfs = isOneShot (ghcMode dfs) + + +setVerboseCore2Core :: DynP () +setVerboseCore2Core = setDumpFlag' Opt_D_verbose_core2core + +setVerbosity :: Maybe Int -> DynP () +setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 }) + +setDebugLevel :: Maybe Int -> DynP () +setDebugLevel mb_n = upd (\dfs -> dfs{ debugLevel = mb_n `orElse` 2 }) + +data PkgDbRef + = GlobalPkgDb + | UserPkgDb + | PkgDbPath FilePath + deriving Eq + +addPkgDbRef :: PkgDbRef -> DynP () +addPkgDbRef p = upd $ \s -> + s { packageDBFlags = PackageDB p : packageDBFlags s } + +removeUserPkgDb :: DynP () +removeUserPkgDb = upd $ \s -> + s { packageDBFlags = NoUserPackageDB : packageDBFlags s } + +removeGlobalPkgDb :: DynP () +removeGlobalPkgDb = upd $ \s -> + s { packageDBFlags = NoGlobalPackageDB : packageDBFlags s } + +clearPkgDb :: DynP () +clearPkgDb = upd $ \s -> + s { packageDBFlags = ClearPackageDBs : packageDBFlags s } + +parsePackageFlag :: String -- the flag + -> ReadP PackageArg -- type of argument + -> String -- string to parse + -> PackageFlag +parsePackageFlag flag arg_parse str + = case filter ((=="").snd) (readP_to_S parse str) of + [(r, "")] -> r + _ -> throwGhcException $ CmdLineError ("Can't parse package flag: " ++ str) + where doc = flag ++ " " ++ str + parse = do + pkg_arg <- tok arg_parse + let mk_expose = ExposePackage doc pkg_arg + ( do _ <- tok $ string "with" + fmap (mk_expose . ModRenaming True) parseRns + <++ fmap (mk_expose . ModRenaming False) parseRns + <++ return (mk_expose (ModRenaming True []))) + parseRns = do _ <- tok $ R.char '(' + rns <- tok $ sepBy parseItem (tok $ R.char ',') + _ <- tok $ R.char ')' + return rns + parseItem = do + orig <- tok $ parseModuleName + (do _ <- tok $ string "as" + new <- tok $ parseModuleName + return (orig, new) + +++ + return (orig, orig)) + tok m = m >>= \x -> skipSpaces >> return x + +exposePackage, exposePackageId, hidePackage, + exposePluginPackage, exposePluginPackageId, + ignorePackage, + trustPackage, distrustPackage :: String -> DynP () +exposePackage p = upd (exposePackage' p) +exposePackageId p = + upd (\s -> s{ packageFlags = + parsePackageFlag "-package-id" parseUnitIdArg p : packageFlags s }) +exposePluginPackage p = + upd (\s -> s{ pluginPackageFlags = + parsePackageFlag "-plugin-package" parsePackageArg p : pluginPackageFlags s }) +exposePluginPackageId p = + upd (\s -> s{ pluginPackageFlags = + parsePackageFlag "-plugin-package-id" parseUnitIdArg p : pluginPackageFlags s }) +hidePackage p = + upd (\s -> s{ packageFlags = HidePackage p : packageFlags s }) +ignorePackage p = + upd (\s -> s{ ignorePackageFlags = IgnorePackage p : ignorePackageFlags s }) + +trustPackage p = exposePackage p >> -- both trust and distrust also expose a package + upd (\s -> s{ trustFlags = TrustPackage p : trustFlags s }) +distrustPackage p = exposePackage p >> + upd (\s -> s{ trustFlags = DistrustPackage p : trustFlags s }) + +exposePackage' :: String -> DynFlags -> DynFlags +exposePackage' p dflags + = dflags { packageFlags = + parsePackageFlag "-package" parsePackageArg p : packageFlags dflags } + +parsePackageArg :: ReadP PackageArg +parsePackageArg = + fmap PackageArg (munch1 (\c -> isAlphaNum c || c `elem` ":-_.")) + +parseUnitIdArg :: ReadP PackageArg +parseUnitIdArg = + fmap UnitIdArg parseUnitId + +setUnitId :: String -> DynFlags -> DynFlags +setUnitId p d = d { thisInstalledUnitId = stringToInstalledUnitId p } + +-- | Given a 'ModuleName' of a signature in the home library, find +-- out how it is instantiated. E.g., the canonical form of +-- A in @p[A=q[]:A]@ is @q[]:A@. +canonicalizeHomeModule :: DynFlags -> ModuleName -> Module +canonicalizeHomeModule dflags mod_name = + case lookup mod_name (thisUnitIdInsts dflags) of + 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 + +-- If we're linking a binary, then only targets that produce object +-- code are allowed (requests for other target types are ignored). +setTarget :: HscTarget -> DynP () +setTarget l = upd $ \ dfs -> + if ghcLink dfs /= LinkBinary || isObjectTarget l + then dfs{ hscTarget = l } + else dfs + +-- Changes the target only if we're compiling object code. This is +-- used by -fasm and -fllvm, which switch from one to the other, but +-- not from bytecode to object-code. The idea is that -fasm/-fllvm +-- can be safely used in an OPTIONS_GHC pragma. +setObjTarget :: HscTarget -> DynP () +setObjTarget l = updM set + where + set dflags + | isObjectTarget (hscTarget dflags) + = return $ dflags { hscTarget = l } + | otherwise = return dflags + +setOptLevel :: Int -> DynFlags -> DynP DynFlags +setOptLevel n dflags = return (updOptLevel n dflags) + +checkOptLevel :: Int -> DynFlags -> Either String DynFlags +checkOptLevel n dflags + | hscTarget dflags == HscInterpreted && n > 0 + = Left "-O conflicts with --interactive; -O ignored." + | otherwise + = Right dflags + +setMainIs :: String -> DynP () +setMainIs arg + | not (null main_fn) && isLower (head main_fn) + -- The arg looked like "Foo.Bar.baz" + = upd $ \d -> d { mainFunIs = Just main_fn, + mainModIs = mkModule mainUnitId (mkModuleName main_mod) } + + | isUpper (head arg) -- The arg looked like "Foo" or "Foo.Bar" + = upd $ \d -> d { mainModIs = mkModule mainUnitId (mkModuleName arg) } + + | otherwise -- The arg looked like "baz" + = upd $ \d -> d { mainFunIs = Just arg } + where + (main_mod, main_fn) = splitLongestPrefix arg (== '.') + +addLdInputs :: Option -> DynFlags -> DynFlags +addLdInputs p dflags = dflags{ldInputs = ldInputs dflags ++ [p]} + +-- ----------------------------------------------------------------------------- +-- Load dynflags from environment files. + +setFlagsFromEnvFile :: FilePath -> String -> DynP () +setFlagsFromEnvFile envfile content = do + setGeneralFlag Opt_HideAllPackages + parseEnvFile envfile content + +parseEnvFile :: FilePath -> String -> DynP () +parseEnvFile envfile = mapM_ parseEntry . lines + where + parseEntry str = case words str of + ("package-db": _) -> addPkgDbRef (PkgDbPath (envdir </> db)) + -- relative package dbs are interpreted relative to the env file + where envdir = takeDirectory envfile + db = drop 11 str + ["clear-package-db"] -> clearPkgDb + ["global-package-db"] -> addPkgDbRef GlobalPkgDb + ["user-package-db"] -> addPkgDbRef UserPkgDb + ["package-id", pkgid] -> exposePackageId pkgid + (('-':'-':_):_) -> return () -- comments + -- and the original syntax introduced in 7.10: + [pkgid] -> exposePackageId pkgid + [] -> return () + _ -> throwGhcException $ CmdLineError $ + "Can't parse environment file entry: " + ++ envfile ++ ": " ++ str + + +----------------------------------------------------------------------------- +-- Paths & Libraries + +addImportPath, addLibraryPath, addIncludePath, addFrameworkPath :: FilePath -> DynP () + +-- -i on its own deletes the import paths +addImportPath "" = upd (\s -> s{importPaths = []}) +addImportPath p = upd (\s -> s{importPaths = importPaths s ++ splitPathList p}) + +addLibraryPath p = + upd (\s -> s{libraryPaths = libraryPaths s ++ splitPathList p}) + +addIncludePath p = + upd (\s -> s{includePaths = + addGlobalInclude (includePaths s) (splitPathList p)}) + +addFrameworkPath p = + upd (\s -> s{frameworkPaths = frameworkPaths s ++ splitPathList p}) + +#if !defined(mingw32_HOST_OS) +split_marker :: Char +split_marker = ':' -- not configurable (ToDo) +#endif + +splitPathList :: String -> [String] +splitPathList s = filter notNull (splitUp s) + -- empty paths are ignored: there might be a trailing + -- ':' in the initial list, for example. Empty paths can + -- cause confusion when they are translated into -I options + -- for passing to gcc. + where +#if !defined(mingw32_HOST_OS) + splitUp xs = split split_marker xs +#else + -- Windows: 'hybrid' support for DOS-style paths in directory lists. + -- + -- That is, if "foo:bar:baz" is used, this interpreted as + -- consisting of three entries, 'foo', 'bar', 'baz'. + -- However, with "c:/foo:c:\\foo;x:/bar", this is interpreted + -- as 3 elts, "c:/foo", "c:\\foo", "x:/bar" + -- + -- Notice that no attempt is made to fully replace the 'standard' + -- split marker ':' with the Windows / DOS one, ';'. The reason being + -- that this will cause too much breakage for users & ':' will + -- work fine even with DOS paths, if you're not insisting on being silly. + -- So, use either. + splitUp [] = [] + splitUp (x:':':div:xs) | div `elem` dir_markers + = ((x:':':div:p): splitUp rs) + where + (p,rs) = findNextPath xs + -- we used to check for existence of the path here, but that + -- required the IO monad to be threaded through the command-line + -- parser which is quite inconvenient. The + splitUp xs = cons p (splitUp rs) + where + (p,rs) = findNextPath xs + + cons "" xs = xs + cons x xs = x:xs + + -- will be called either when we've consumed nought or the + -- "<Drive>:/" part of a DOS path, so splitting is just a Q of + -- finding the next split marker. + findNextPath xs = + case break (`elem` split_markers) xs of + (p, _:ds) -> (p, ds) + (p, xs) -> (p, xs) + + split_markers :: [Char] + split_markers = [':', ';'] + + dir_markers :: [Char] + dir_markers = ['/', '\\'] +#endif + +-- ----------------------------------------------------------------------------- +-- tmpDir, where we store temporary files. + +setTmpDir :: FilePath -> DynFlags -> DynFlags +setTmpDir dir = alterFileSettings $ \s -> s { fileSettings_tmpDir = normalise dir } + -- we used to fix /cygdrive/c/.. on Windows, but this doesn't + -- seem necessary now --SDM 7/2/2008 + +----------------------------------------------------------------------------- +-- RTS opts + +setRtsOpts :: String -> DynP () +setRtsOpts arg = upd $ \ d -> d {rtsOpts = Just arg} + +setRtsOptsEnabled :: RtsOptsEnabled -> DynP () +setRtsOptsEnabled arg = upd $ \ d -> d {rtsOptsEnabled = arg} + +----------------------------------------------------------------------------- +-- Hpc stuff + +setOptHpcDir :: String -> DynP () +setOptHpcDir arg = upd $ \ d -> d {hpcDir = arg} + +----------------------------------------------------------------------------- +-- Via-C compilation stuff + +-- There are some options that we need to pass to gcc when compiling +-- Haskell code via C, but are only supported by recent versions of +-- gcc. The configure script decides which of these options we need, +-- and puts them in the "settings" file in $topdir. The advantage of +-- having these in a separate file is that the file can be created at +-- install-time depending on the available gcc version, and even +-- re-generated later if gcc is upgraded. +-- +-- The options below are not dependent on the version of gcc, only the +-- platform. + +picCCOpts :: DynFlags -> [String] +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. + -- -mdynamic-no-pic: + -- Turn off PIC code generation. + -- -fno-common: + -- Don't generate "common" symbols - these are unwanted + -- in dynamic libraries. + + | gopt Opt_PIC dflags -> ["-fno-common", "-U__PIC__", "-D__PIC__"] + | otherwise -> ["-mdynamic-no-pic"] + OSMinGW32 -- no -fPIC for Windows + | gopt Opt_PIC dflags -> ["-U__PIC__", "-D__PIC__"] + | otherwise -> [] + _ + -- we need -fPIC for C files when we are compiling with -dynamic, + -- otherwise things like stub.c files don't get compiled + -- correctly. They need to reference data in the Haskell + -- objects, but can't without -fPIC. See + -- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/position-independent-code + | gopt Opt_PIC dflags || WayDyn `elem` ways dflags -> + ["-fPIC", "-U__PIC__", "-D__PIC__"] + -- gcc may be configured to have PIC on by default, let's be + -- explicit here, see #15847 + | otherwise -> ["-fno-PIC"] + + pieOpts + | gopt Opt_PICExecutable dflags = ["-pie"] + -- See Note [No PIE when linking] + | toolSettings_ccSupportsNoPie (toolSettings 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__"] + | otherwise = [] + +-- ----------------------------------------------------------------------------- +-- Compiler Info + +compilerInfo :: DynFlags -> [(String, String)] +compilerInfo dflags + = -- We always make "Project name" be first to keep parsing in + -- other languages simple, i.e. when looking for other fields, + -- you don't have to worry whether there is a leading '[' or not + ("Project name", cProjectName) + -- Next come the settings, so anything else can be overridden + -- in the settings file (as "lookup" uses the first match for the + -- key) + : map (fmap $ expandDirectories (topDir dflags) (toolDir dflags)) + (rawSettings dflags) + ++ [("Project version", projectVersion dflags), + ("Project Git commit id", cProjectGitCommitId), + ("Booter version", cBooterVersion), + ("Stage", cStage), + ("Build platform", cBuildPlatformString), + ("Host platform", cHostPlatformString), + ("Target platform", platformMisc_targetPlatformString $ platformMisc dflags), + ("Have interpreter", showBool $ platformMisc_ghcWithInterpreter $ platformMisc dflags), + ("Object splitting supported", showBool False), + ("Have native code generator", showBool $ platformMisc_ghcWithNativeCodeGen $ platformMisc dflags), + -- Whether or not we support @-dynamic-too@ + ("Support dynamic-too", showBool $ not isWindows), + -- Whether or not we support the @-j@ flag with @--make@. + ("Support parallel --make", "YES"), + -- Whether or not we support "Foo from foo-0.1-XXX:Foo" syntax in + -- installed package info. + ("Support reexported-modules", "YES"), + -- Whether or not we support extended @-package foo (Foo)@ syntax. + ("Support thinning and renaming package flags", "YES"), + -- Whether or not we support Backpack. + ("Support Backpack", "YES"), + -- If true, we require that the 'id' field in installed package info + -- match what is passed to the @-this-unit-id@ flag for modules + -- built in it + ("Requires unified installed package IDs", "YES"), + -- Whether or not we support the @-this-package-key@ flag. Prefer + -- "Uses unit IDs" over it. + ("Uses package keys", "YES"), + -- Whether or not we support the @-this-unit-id@ flag + ("Uses unit IDs", "YES"), + -- Whether or not GHC compiles libraries as dynamic by default + ("Dynamic by default", showBool $ dYNAMIC_BY_DEFAULT dflags), + -- Whether or not GHC was compiled using -dynamic + ("GHC Dynamic", showBool dynamicGhc), + -- Whether or not GHC was compiled using -prof + ("GHC Profiled", showBool rtsIsProfiled), + ("Debug on", showBool debugIsOn), + ("LibDir", topDir dflags), + -- The path of the global package database used by GHC + ("Global Package DB", globalPackageDatabasePath dflags) + ] + where + 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" + +bLOCK_SIZE_W :: DynFlags -> Int +bLOCK_SIZE_W dflags = bLOCK_SIZE dflags `quot` wORD_SIZE dflags + +wORD_SIZE_IN_BITS :: DynFlags -> Int +wORD_SIZE_IN_BITS dflags = wORD_SIZE dflags * 8 + +wordAlignment :: DynFlags -> Alignment +wordAlignment dflags = alignmentOf (wORD_SIZE dflags) + +tAG_MASK :: DynFlags -> Int +tAG_MASK dflags = (1 `shiftL` tAG_BITS dflags) - 1 + +mAX_PTR_TAG :: DynFlags -> Int +mAX_PTR_TAG = tAG_MASK + +-- Might be worth caching these in targetPlatform? +tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD :: DynFlags -> Integer +tARGET_MIN_INT dflags + = case platformWordSize (targetPlatform dflags) of + PW4 -> toInteger (minBound :: Int32) + PW8 -> toInteger (minBound :: Int64) +tARGET_MAX_INT dflags + = case platformWordSize (targetPlatform dflags) of + PW4 -> toInteger (maxBound :: Int32) + PW8 -> toInteger (maxBound :: Int64) +tARGET_MAX_WORD dflags + = case platformWordSize (targetPlatform dflags) of + PW4 -> toInteger (maxBound :: Word32) + PW8 -> toInteger (maxBound :: Word64) + + +{- ----------------------------------------------------------------------------- +Note [DynFlags consistency] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +There are a number of number of DynFlags configurations which either +do not make sense or lead to unimplemented or buggy codepaths in the +compiler. makeDynFlagsConsistent is responsible for verifying the validity +of a set of DynFlags, fixing any issues, and reporting them back to the +caller. + +GHCi and -O +--------------- + +When using optimization, the compiler can introduce several things +(such as unboxed tuples) into the intermediate code, which GHCi later +chokes on since the bytecode interpreter can't handle this (and while +this is arguably a bug these aren't handled, there are no plans to fix +it.) + +While the driver pipeline always checks for this particular erroneous +combination when parsing flags, we also need to check when we update +the flags; this is because API clients may parse flags but update the +DynFlags afterwords, before finally running code inside a session (see +T10052 and #10052). +-} + +-- | Resolve any internal inconsistencies in a set of 'DynFlags'. +-- Returns the consistent 'DynFlags' as well as a list of warnings +-- to report to the user. +makeDynFlagsConsistent :: DynFlags -> (DynFlags, [Located String]) +-- Whenever makeDynFlagsConsistent does anything, it starts over, to +-- ensure that a later change doesn't invalidate an earlier check. +-- Be careful not to introduce potential loops! +makeDynFlagsConsistent dflags + -- Disable -dynamic-too on Windows (#8228, #7134, #5987) + | os == OSMinGW32 && gopt Opt_BuildDynamicToo dflags + = let dflags' = gopt_unset dflags Opt_BuildDynamicToo + warn = "-dynamic-too is not supported on Windows" + in loop dflags' warn + | hscTarget dflags == HscC && + not (platformUnregisterised (targetPlatform dflags)) + = if platformMisc_ghcWithNativeCodeGen $ platformMisc dflags + then let dflags' = dflags { hscTarget = HscAsm } + warn = "Compiler not unregisterised, so using native code generator rather than compiling via C" + in loop dflags' warn + else let dflags' = dflags { hscTarget = HscLlvm } + warn = "Compiler not unregisterised, so using LLVM rather than compiling via C" + in loop dflags' warn + | gopt Opt_Hpc dflags && hscTarget dflags == HscInterpreted + = let dflags' = gopt_unset dflags Opt_Hpc + warn = "Hpc can't be used with byte-code interpreter. Ignoring -fhpc." + in loop dflags' warn + | hscTarget dflags `elem` [HscAsm, HscLlvm] && + platformUnregisterised (targetPlatform dflags) + = loop (dflags { hscTarget = HscC }) + "Compiler unregisterised, so compiling via C" + | hscTarget dflags == HscAsm && + not (platformMisc_ghcWithNativeCodeGen $ platformMisc 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) + = loop (gopt_set dflags Opt_PIC) + "Enabling -fPIC as it is always on for this platform" + | Left err <- checkOptLevel (optLevel dflags) dflags + = loop (updOptLevel 0 dflags) err + + | LinkInMemory <- ghcLink dflags + , not (gopt Opt_ExternalInterpreter dflags) + , rtsIsProfiled + , isObjectTarget (hscTarget dflags) + , WayProf `notElem` ways dflags + = loop dflags{ways = WayProf : ways dflags} + "Enabling -prof, because -fobject-code is enabled and GHCi is profiled" + + | otherwise = (dflags, []) + where loc = mkGeneralSrcSpan (fsLit "when making flags consistent") + loop updated_dflags warning + = case makeDynFlagsConsistent updated_dflags of + (dflags', ws) -> (dflags', L loc warning : ws) + platform = targetPlatform dflags + arch = platformArch platform + os = platformOS platform + + +-------------------------------------------------------------------------- +-- Do not use unsafeGlobalDynFlags! +-- +-- unsafeGlobalDynFlags is a hack, necessary because we need to be able +-- to show SDocs when tracing, but we don't always have DynFlags +-- available. +-- +-- Do not use it if you can help it. You may get the wrong value, or this +-- panic! + +-- | This is the value that 'unsafeGlobalDynFlags' takes before it is +-- initialized. +defaultGlobalDynFlags :: DynFlags +defaultGlobalDynFlags = + (defaultDynFlags settings llvmConfig) { verbosity = 2 } + where + settings = panic "v_unsafeGlobalDynFlags: settings not initialised" + llvmConfig = panic "v_unsafeGlobalDynFlags: llvmConfig not initialised" + +#if GHC_STAGE < 2 +GLOBAL_VAR(v_unsafeGlobalDynFlags, defaultGlobalDynFlags, DynFlags) +#else +SHARED_GLOBAL_VAR( v_unsafeGlobalDynFlags + , getOrSetLibHSghcGlobalDynFlags + , "getOrSetLibHSghcGlobalDynFlags" + , defaultGlobalDynFlags + , DynFlags ) +#endif + +unsafeGlobalDynFlags :: DynFlags +unsafeGlobalDynFlags = unsafePerformIO $ readIORef v_unsafeGlobalDynFlags + +setUnsafeGlobalDynFlags :: DynFlags -> IO () +setUnsafeGlobalDynFlags = writeIORef v_unsafeGlobalDynFlags + +-- ----------------------------------------------------------------------------- +-- SSE and AVX + +-- TODO: Instead of using a separate predicate (i.e. isSse2Enabled) to +-- check if SSE is enabled, we might have x86-64 imply the -msse2 +-- flag. + +data SseVersion = SSE1 + | SSE2 + | SSE3 + | SSE4 + | SSE42 + deriving (Eq, Ord) + +isSseEnabled :: DynFlags -> Bool +isSseEnabled dflags = case platformArch (targetPlatform dflags) of + ArchX86_64 -> True + ArchX86 -> True + _ -> False + +isSse2Enabled :: DynFlags -> Bool +isSse2Enabled dflags = case platformArch (targetPlatform dflags) of + -- We Assume SSE1 and SSE2 operations are available on both + -- x86 and x86_64. Historically we didn't default to SSE2 and + -- SSE1 on x86, which results in defacto nondeterminism for how + -- rounding behaves in the associated x87 floating point instructions + -- because variations in the spill/fpu stack placement of arguments for + -- operations would change the precision and final result of what + -- would otherwise be the same expressions with respect to single or + -- double precision IEEE floating point computations. + ArchX86_64 -> True + ArchX86 -> True + _ -> False + + +isSse4_2Enabled :: DynFlags -> Bool +isSse4_2Enabled dflags = sseVersion dflags >= Just SSE42 + +isAvxEnabled :: DynFlags -> Bool +isAvxEnabled dflags = avx dflags || avx2 dflags || avx512f dflags + +isAvx2Enabled :: DynFlags -> Bool +isAvx2Enabled dflags = avx2 dflags || avx512f dflags + +isAvx512cdEnabled :: DynFlags -> Bool +isAvx512cdEnabled dflags = avx512cd dflags + +isAvx512erEnabled :: DynFlags -> Bool +isAvx512erEnabled dflags = avx512er dflags + +isAvx512fEnabled :: DynFlags -> Bool +isAvx512fEnabled dflags = avx512f dflags + +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] + | UnknownLD + deriving Eq + +-- CompilerInfo tells us which C compiler we're using +data CompilerInfo + = GCC + | Clang + | AppleClang + | AppleClang51 + | UnknownCC + deriving Eq + +-- ----------------------------------------------------------------------------- +-- RTS hooks + +-- Convert sizes like "3.5M" into integers +decodeSize :: String -> Integer +decodeSize str + | c == "" = truncate n + | c == "K" || c == "k" = truncate (n * 1000) + | c == "M" || c == "m" = truncate (n * 1000 * 1000) + | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000) + | otherwise = throwGhcException (CmdLineError ("can't decode size: " ++ str)) + where (m, c) = span pred str + n = readRational m + pred c = isDigit c || c == '.' + +foreign import ccall unsafe "setHeapSize" setHeapSize :: Int -> IO () +foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO () + +-- ----------------------------------------------------------------------------- +-- Types for managing temporary files. +-- +-- these are here because FilesToClean is used in DynFlags + +-- | A collection of files that must be deleted before ghc exits. +-- The current collection +-- is stored in an IORef in DynFlags, 'filesToClean'. +data FilesToClean = FilesToClean { + ftcGhcSession :: !(Set FilePath), + -- ^ Files that will be deleted at the end of runGhc(T) + ftcCurrentModule :: !(Set FilePath) + -- ^ Files that will be deleted the next time + -- 'FileCleanup.cleanCurrentModuleTempFiles' is called, or otherwise at the + -- end of the session. + } + +-- | An empty FilesToClean +emptyFilesToClean :: FilesToClean +emptyFilesToClean = FilesToClean Set.empty Set.empty + + + +initSDocContext :: DynFlags -> PprStyle -> SDocContext +initSDocContext dflags style = SDC + { sdocStyle = style + , sdocColScheme = colScheme dflags + , sdocLastColour = Col.colReset + , sdocShouldUseColor = overrideWith (canUseColor dflags) (useColor dflags) + , sdocLineLength = pprCols dflags + , sdocCanUseUnicode = useUnicode dflags + , sdocHexWordLiterals = gopt Opt_HexWordLiterals dflags + , sdocDebugLevel = debugLevel dflags + , sdocPprDebug = dopt Opt_D_ppr_debug dflags + , sdocPrintUnicodeSyntax = gopt Opt_PrintUnicodeSyntax dflags + , sdocPrintCaseAsLet = gopt Opt_PprCaseAsLet dflags + , sdocPrintTypecheckerElaboration = gopt Opt_PrintTypecheckerElaboration dflags + , sdocPrintAxiomIncomps = gopt Opt_PrintAxiomIncomps dflags + , sdocPrintExplicitKinds = gopt Opt_PrintExplicitKinds dflags + , sdocPrintExplicitCoercions = gopt Opt_PrintExplicitCoercions dflags + , sdocPrintExplicitRuntimeReps = gopt Opt_PrintExplicitRuntimeReps dflags + , sdocPrintExplicitForalls = gopt Opt_PrintExplicitForalls dflags + , sdocPrintPotentialInstances = gopt Opt_PrintPotentialInstances dflags + , sdocPrintEqualityRelations = gopt Opt_PrintEqualityRelations dflags + , sdocSuppressTicks = gopt Opt_SuppressTicks dflags + , sdocSuppressTypeSignatures = gopt Opt_SuppressTypeSignatures dflags + , sdocSuppressTypeApplications = gopt Opt_SuppressTypeApplications dflags + , sdocSuppressIdInfo = gopt Opt_SuppressIdInfo dflags + , sdocSuppressCoercions = gopt Opt_SuppressCoercions dflags + , sdocSuppressUnfoldings = gopt Opt_SuppressUnfoldings dflags + , sdocSuppressVarKinds = gopt Opt_SuppressVarKinds dflags + , sdocSuppressUniques = gopt Opt_SuppressUniques dflags + , sdocSuppressModulePrefixes = gopt Opt_SuppressModulePrefixes dflags + , sdocSuppressStgExts = gopt Opt_SuppressStgExts dflags + , sdocErrorSpans = gopt Opt_ErrorSpans dflags + , sdocStarIsType = xopt LangExt.StarIsType dflags + , sdocImpredicativeTypes = xopt LangExt.ImpredicativeTypes dflags + , sdocDynFlags = dflags + } diff --git a/compiler/GHC/Driver/Session.hs-boot b/compiler/GHC/Driver/Session.hs-boot new file mode 100644 index 0000000000..c61d6b5297 --- /dev/null +++ b/compiler/GHC/Driver/Session.hs-boot @@ -0,0 +1,17 @@ +module GHC.Driver.Session where + +import GhcPrelude +import GHC.Platform +import {-# SOURCE #-} Outputable + +data DynFlags +data DumpFlag +data GeneralFlag + +targetPlatform :: DynFlags -> Platform +pprUserLength :: DynFlags -> Int +pprCols :: DynFlags -> Int +unsafeGlobalDynFlags :: DynFlags +hasPprDebug :: DynFlags -> Bool +hasNoDebugOutput :: DynFlags -> Bool +initSDocContext :: DynFlags -> PprStyle -> SDocContext diff --git a/compiler/GHC/Driver/Types.hs b/compiler/GHC/Driver/Types.hs new file mode 100644 index 0000000000..7fd8fe73c3 --- /dev/null +++ b/compiler/GHC/Driver/Types.hs @@ -0,0 +1,3268 @@ +{- +(c) The University of Glasgow, 2006 + +\section[GHC.Driver.Types]{Types for the per-module compiler} +-} + +{-# LANGUAGE CPP, ScopedTypeVariables #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} + +-- | Types for the per-module compiler +module GHC.Driver.Types ( + -- * compilation state + HscEnv(..), hscEPS, + FinderCache, FindResult(..), InstalledFindResult(..), + Target(..), TargetId(..), InputFileBuffer, pprTarget, pprTargetId, + HscStatus(..), + IServ(..), + + -- * ModuleGraph + ModuleGraph, emptyMG, mkModuleGraph, extendMG, mapMG, + mgModSummaries, mgElemModule, mgLookupModule, + needsTemplateHaskellOrQQ, mgBootModules, + + -- * Hsc monad + Hsc(..), runHsc, mkInteractiveHscEnv, runInteractiveHsc, + + -- * Information about modules + ModDetails(..), emptyModDetails, + ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC, + ImportedMods, ImportedBy(..), importedByUser, ImportedModsVal(..), SptEntry(..), + ForeignSrcLang(..), + phaseForeignLanguage, + + ModSummary(..), ms_imps, ms_installed_mod, ms_mod_name, ms_home_imps, + home_imps, ms_home_allimps, ms_home_srcimps, showModMsg, isBootSummary, + msHsFilePath, msHiFilePath, msObjFilePath, + SourceModified(..), isTemplateHaskellOrQQNonBoot, + + -- * Information about the module being compiled + -- (re-exported from GHC.Driver.Phases) + HscSource(..), isHsBootOrSig, isHsigFile, hscSourceString, + + + -- * State relating to modules in this package + HomePackageTable, HomeModInfo(..), emptyHomePackageTable, + lookupHpt, eltsHpt, filterHpt, allHpt, mapHpt, delFromHpt, + addToHpt, addListToHpt, lookupHptDirectly, listToHpt, + hptCompleteSigs, + hptInstances, hptRules, pprHPT, + + -- * State relating to known packages + ExternalPackageState(..), EpsStats(..), addEpsInStats, + PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable, + lookupIfaceByModule, emptyPartialModIface, emptyFullModIface, lookupHptByModule, + + PackageInstEnv, PackageFamInstEnv, PackageRuleBase, + PackageCompleteMatchMap, + + mkSOName, mkHsSOName, soExt, + + -- * Metaprogramming + MetaRequest(..), + MetaResult, -- data constructors not exported to ensure correct response type + metaRequestE, metaRequestP, metaRequestT, metaRequestD, metaRequestAW, + MetaHook, + + -- * Annotations + prepareAnnotations, + + -- * Interactive context + InteractiveContext(..), emptyInteractiveContext, + icPrintUnqual, icInScopeTTs, icExtendGblRdrEnv, + extendInteractiveContext, extendInteractiveContextWithIds, + substInteractiveContext, + setInteractivePrintName, icInteractiveModule, + InteractiveImport(..), setInteractivePackage, + mkPrintUnqualified, pprModulePrefix, + mkQualPackage, mkQualModule, pkgQual, + + -- * Interfaces + ModIface, PartialModIface, ModIface_(..), ModIfaceBackend(..), + mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache, + emptyIfaceWarnCache, mi_boot, mi_fix, + mi_semantic_module, + mi_free_holes, + renameFreeHoles, + + -- * Fixity + FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv, + + -- * TyThings and type environments + TyThing(..), tyThingAvailInfo, + tyThingTyCon, tyThingDataCon, tyThingConLike, + tyThingId, tyThingCoAxiom, tyThingParent_maybe, tyThingsTyCoVars, + implicitTyThings, implicitTyConThings, implicitClassThings, + isImplicitTyThing, + + TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv, + typeEnvFromEntities, mkTypeEnvWithImplicits, + extendTypeEnv, extendTypeEnvList, + extendTypeEnvWithIds, plusTypeEnv, + lookupTypeEnv, + typeEnvElts, typeEnvTyCons, typeEnvIds, typeEnvPatSyns, + typeEnvDataCons, typeEnvCoAxioms, typeEnvClasses, + + -- * MonadThings + MonadThings(..), + + -- * Information on imports and exports + WhetherHasOrphans, IsBootInterface, Usage(..), + Dependencies(..), noDependencies, + updNameCache, + IfaceExport, + + -- * Warnings + Warnings(..), WarningTxt(..), plusWarns, + + -- * Linker stuff + Linkable(..), isObjectLinkable, linkableObjs, + Unlinked(..), CompiledByteCode, + isObject, nameOfObject, isInterpretable, byteCodeOfObject, + + -- * Program coverage + HpcInfo(..), emptyHpcInfo, isHpcUsed, AnyHpcUsage, + + -- * Breakpoints + ModBreaks (..), emptyModBreaks, + + -- * Safe Haskell information + IfaceTrustInfo, getSafeMode, setSafeMode, noIfaceTrustInfo, + trustInfoToNum, numToTrustInfo, IsSafeImport, + + -- * result of the parser + HsParsedModule(..), + + -- * Compilation errors and warnings + SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr, + throwOneError, throwErrors, handleSourceError, + handleFlagWarnings, printOrThrowWarnings, + + -- * COMPLETE signature + CompleteMatch(..), CompleteMatchMap, + mkCompleteMatchMap, extendCompleteMatchMap + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.ByteCode.Types +import GHC.Runtime.Eval.Types ( Resume ) +import GHCi.Message ( Pipe ) +import GHCi.RemoteTypes +import GHC.ForeignSrcLang + +import UniqFM +import GHC.Hs +import RdrName +import Avail +import Module +import InstEnv ( InstEnv, ClsInst, identicalClsInstHead ) +import FamInstEnv +import CoreSyn ( CoreProgram, RuleBase, CoreRule ) +import Name +import NameEnv +import VarSet +import Var +import Id +import IdInfo ( IdDetails(..), RecSelParent(..)) +import Type + +import ApiAnnotation ( ApiAnns ) +import Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv ) +import Class +import TyCon +import CoAxiom +import ConLike +import DataCon +import PatSyn +import PrelNames ( gHC_PRIM, ioTyConName, printName, mkInteractiveModule ) +import TysWiredIn +import GHC.Driver.Packages hiding ( Version(..) ) +import GHC.Driver.CmdLine +import GHC.Driver.Session +import GHC.Runtime.Linker.Types ( DynLinker, Linkable(..), Unlinked(..), SptEntry(..) ) +import GHC.Driver.Phases ( Phase, HscSource(..), hscSourceString + , isHsBootOrSig, isHsigFile ) +import qualified GHC.Driver.Phases as Phase +import BasicTypes +import GHC.Iface.Syntax +import Maybes +import Outputable +import SrcLoc +import Unique +import UniqDFM +import FastString +import StringBuffer ( StringBuffer ) +import Fingerprint +import MonadUtils +import Bag +import Binary +import ErrUtils +import NameCache +import GHC.Platform +import Util +import UniqDSet +import GHC.Serialized ( Serialized ) +import qualified GHC.LanguageExtensions as LangExt + +import Foreign +import Control.Monad ( guard, liftM, ap ) +import Data.IORef +import Data.Time +import Exception +import System.FilePath +import Control.Concurrent +import System.Process ( ProcessHandle ) +import Control.DeepSeq +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Class + +-- ----------------------------------------------------------------------------- +-- Compilation state +-- ----------------------------------------------------------------------------- + +-- | Status of a compilation to hard-code +data HscStatus + -- | Nothing to do. + = HscNotGeneratingCode ModIface ModDetails + -- | Nothing to do because code already exists. + | HscUpToDate ModIface ModDetails + -- | Update boot file result. + | HscUpdateBoot ModIface ModDetails + -- | Generate signature file (backpack) + | HscUpdateSig ModIface ModDetails + -- | Recompile this module. + | HscRecomp + { hscs_guts :: CgGuts + -- ^ Information for the code generator. + , hscs_mod_location :: !ModLocation + -- ^ Module info + , hscs_mod_details :: !ModDetails + , hscs_partial_iface :: !PartialModIface + -- ^ Partial interface + , hscs_old_iface_hash :: !(Maybe Fingerprint) + -- ^ Old interface hash for this compilation, if an old interface file + -- exists. Pass to `hscMaybeWriteIface` when writing the interface to + -- avoid updating the existing interface when the interface isn't + -- changed. + , hscs_iface_dflags :: !DynFlags + -- ^ Generate final iface using this DynFlags. + -- FIXME (osa): I don't understand why this is necessary, but I spent + -- almost two days trying to figure this out and I couldn't .. perhaps + -- someone who understands this code better will remove this later. + } +-- Should HscStatus contain the HomeModInfo? +-- All places where we return a status we also return a HomeModInfo. + +-- ----------------------------------------------------------------------------- +-- The Hsc monad: Passing an environment and warning state + +newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages)) + deriving (Functor) + +instance Applicative Hsc where + pure a = Hsc $ \_ w -> return (a, w) + (<*>) = ap + +instance Monad Hsc where + Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w + case k a of + Hsc k' -> k' e w1 + +instance MonadIO Hsc where + liftIO io = Hsc $ \_ w -> do a <- io; return (a, w) + +instance HasDynFlags Hsc where + getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w) + +runHsc :: HscEnv -> Hsc a -> IO a +runHsc hsc_env (Hsc hsc) = do + (a, w) <- hsc hsc_env emptyBag + printOrThrowWarnings (hsc_dflags hsc_env) w + return a + +mkInteractiveHscEnv :: HscEnv -> HscEnv +mkInteractiveHscEnv hsc_env = hsc_env{ hsc_dflags = interactive_dflags } + where + interactive_dflags = ic_dflags (hsc_IC hsc_env) + +runInteractiveHsc :: HscEnv -> Hsc a -> IO a +-- A variant of runHsc that switches in the DynFlags from the +-- InteractiveContext before running the Hsc computation. +runInteractiveHsc hsc_env = runHsc (mkInteractiveHscEnv hsc_env) + +-- ----------------------------------------------------------------------------- +-- Source Errors + +-- When the compiler (GHC.Driver.Main) discovers errors, it throws an +-- exception in the IO monad. + +mkSrcErr :: ErrorMessages -> SourceError +mkSrcErr = SourceError + +srcErrorMessages :: SourceError -> ErrorMessages +srcErrorMessages (SourceError msgs) = msgs + +mkApiErr :: DynFlags -> SDoc -> GhcApiError +mkApiErr dflags msg = GhcApiError (showSDoc dflags msg) + +throwErrors :: MonadIO io => ErrorMessages -> io a +throwErrors = liftIO . throwIO . mkSrcErr + +throwOneError :: MonadIO io => ErrMsg -> io a +throwOneError = throwErrors . unitBag + +-- | A source error is an error that is caused by one or more errors in the +-- source code. A 'SourceError' is thrown by many functions in the +-- compilation pipeline. Inside GHC these errors are merely printed via +-- 'log_action', but API clients may treat them differently, for example, +-- insert them into a list box. If you want the default behaviour, use the +-- idiom: +-- +-- > handleSourceError printExceptionAndWarnings $ do +-- > ... api calls that may fail ... +-- +-- The 'SourceError's error messages can be accessed via 'srcErrorMessages'. +-- This list may be empty if the compiler failed due to @-Werror@ +-- ('Opt_WarnIsError'). +-- +-- See 'printExceptionAndWarnings' for more information on what to take care +-- of when writing a custom error handler. +newtype SourceError = SourceError ErrorMessages + +instance Show SourceError where + show (SourceError msgs) = unlines . map show . bagToList $ msgs + +instance Exception SourceError + +-- | Perform the given action and call the exception handler if the action +-- throws a 'SourceError'. See 'SourceError' for more information. +handleSourceError :: (ExceptionMonad m) => + (SourceError -> m a) -- ^ exception handler + -> m a -- ^ action to perform + -> m a +handleSourceError handler act = + gcatch act (\(e :: SourceError) -> handler e) + +-- | An error thrown if the GHC API is used in an incorrect fashion. +newtype GhcApiError = GhcApiError String + +instance Show GhcApiError where + show (GhcApiError msg) = msg + +instance Exception GhcApiError + +-- | Given a bag of warnings, turn them into an exception if +-- -Werror is enabled, or print them out otherwise. +printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO () +printOrThrowWarnings dflags warns = do + let (make_error, warns') = + mapAccumBagL + (\make_err warn -> + case isWarnMsgFatal dflags warn of + Nothing -> + (make_err, warn) + Just err_reason -> + (True, warn{ errMsgSeverity = SevError + , errMsgReason = ErrReason err_reason + })) + False warns + if make_error + then throwIO (mkSrcErr warns') + else printBagOfErrors dflags warns + +handleFlagWarnings :: DynFlags -> [Warn] -> IO () +handleFlagWarnings dflags warns = do + let warns' = filter (shouldPrintWarning dflags . warnReason) warns + + -- It would be nicer if warns :: [Located MsgDoc], but that + -- has circular import problems. + bag = listToBag [ mkPlainWarnMsg dflags loc (text warn) + | Warn _ (L loc warn) <- warns' ] + + printOrThrowWarnings dflags bag + +-- Given a warn reason, check to see if it's associated -W opt is enabled +shouldPrintWarning :: DynFlags -> GHC.Driver.CmdLine.WarnReason -> Bool +shouldPrintWarning dflags ReasonDeprecatedFlag + = wopt Opt_WarnDeprecatedFlags dflags +shouldPrintWarning dflags ReasonUnrecognisedFlag + = wopt Opt_WarnUnrecognisedWarningFlags dflags +shouldPrintWarning _ _ + = True + +{- +************************************************************************ +* * +\subsection{HscEnv} +* * +************************************************************************ +-} + +-- | HscEnv is like 'Session', except that some of the fields are immutable. +-- An HscEnv is used to compile a single module from plain Haskell source +-- code (after preprocessing) to either C, assembly or C--. It's also used +-- to store the dynamic linker state to allow for multiple linkers in the +-- same address space. +-- Things like the module graph don't change during a single compilation. +-- +-- Historical note: \"hsc\" used to be the name of the compiler binary, +-- when there was a separate driver and compiler. To compile a single +-- module, the driver would invoke hsc on the source code... so nowadays +-- we think of hsc as the layer of the compiler that deals with compiling +-- a single module. +data HscEnv + = HscEnv { + hsc_dflags :: DynFlags, + -- ^ The dynamic flag settings + + hsc_targets :: [Target], + -- ^ The targets (or roots) of the current session + + hsc_mod_graph :: ModuleGraph, + -- ^ The module graph of the current session + + hsc_IC :: InteractiveContext, + -- ^ The context for evaluating interactive statements + + hsc_HPT :: HomePackageTable, + -- ^ The home package table describes already-compiled + -- home-package modules, /excluding/ the module we + -- are compiling right now. + -- (In one-shot mode the current module is the only + -- home-package module, so hsc_HPT is empty. All other + -- modules count as \"external-package\" modules. + -- However, even in GHCi mode, hi-boot interfaces are + -- demand-loaded into the external-package table.) + -- + -- 'hsc_HPT' is not mutable because we only demand-load + -- external packages; the home package is eagerly + -- loaded, module by module, by the compilation manager. + -- + -- The HPT may contain modules compiled earlier by @--make@ + -- but not actually below the current module in the dependency + -- graph. + -- + -- (This changes a previous invariant: changed Jan 05.) + + hsc_EPS :: {-# UNPACK #-} !(IORef ExternalPackageState), + -- ^ Information about the currently loaded external packages. + -- This is mutable because packages will be demand-loaded during + -- a compilation run as required. + + hsc_NC :: {-# UNPACK #-} !(IORef NameCache), + -- ^ As with 'hsc_EPS', this is side-effected by compiling to + -- reflect sucking in interface files. They cache the state of + -- external interface files, in effect. + + hsc_FC :: {-# UNPACK #-} !(IORef FinderCache), + -- ^ The cached result of performing finding in the file system + + hsc_type_env_var :: Maybe (Module, IORef TypeEnv) + -- ^ Used for one-shot compilation only, to initialise + -- the 'IfGblEnv'. See 'TcRnTypes.tcg_type_env_var' for + -- 'TcRnTypes.TcGblEnv'. See also Note [hsc_type_env_var hack] + + , hsc_iserv :: MVar (Maybe IServ) + -- ^ interactive server process. Created the first + -- time it is needed. + + , hsc_dynLinker :: DynLinker + -- ^ dynamic linker. + + } + +-- Note [hsc_type_env_var hack] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- hsc_type_env_var is used to initialize tcg_type_env_var, and +-- eventually it is the mutable variable that is queried from +-- if_rec_types to get a TypeEnv. So, clearly, it's something +-- related to knot-tying (see Note [Tying the knot]). +-- hsc_type_env_var is used in two places: initTcRn (where +-- it initializes tcg_type_env_var) and initIfaceCheck +-- (where it initializes if_rec_types). +-- +-- But why do we need a way to feed a mutable variable in? Why +-- can't we just initialize tcg_type_env_var when we start +-- typechecking? The problem is we need to knot-tie the +-- EPS, and we may start adding things to the EPS before type +-- checking starts. +-- +-- Here is a concrete example. Suppose we are running +-- "ghc -c A.hs", and we have this file system state: +-- +-- A.hs-boot A.hi-boot **up to date** +-- B.hs B.hi **up to date** +-- A.hs A.hi **stale** +-- +-- The first thing we do is run checkOldIface on A.hi. +-- checkOldIface will call loadInterface on B.hi so it can +-- get its hands on the fingerprints, to find out if A.hi +-- needs recompilation. But loadInterface also populates +-- the EPS! And so if compilation turns out to be necessary, +-- as it is in this case, the thunks we put into the EPS for +-- B.hi need to have the correct if_rec_types mutable variable +-- to query. +-- +-- If the mutable variable is only allocated WHEN we start +-- typechecking, then that's too late: we can't get the +-- information to the thunks. So we need to pre-commit +-- to a type variable in 'hscIncrementalCompile' BEFORE we +-- check the old interface. +-- +-- This is all a massive hack because arguably checkOldIface +-- should not populate the EPS. But that's a refactor for +-- another day. + + +data IServ = IServ + { iservPipe :: Pipe + , iservProcess :: ProcessHandle + , iservLookupSymbolCache :: IORef (UniqFM (Ptr ())) + , iservPendingFrees :: [HValueRef] + } + +-- | Retrieve the ExternalPackageState cache. +hscEPS :: HscEnv -> IO ExternalPackageState +hscEPS hsc_env = readIORef (hsc_EPS hsc_env) + +-- | A compilation target. +-- +-- A target may be supplied with the actual text of the +-- module. If so, use this instead of the file contents (this +-- is for use in an IDE where the file hasn't been saved by +-- the user yet). +data Target + = Target { + targetId :: TargetId, -- ^ module or filename + targetAllowObjCode :: Bool, -- ^ object code allowed? + targetContents :: Maybe (InputFileBuffer, UTCTime) + -- ^ Optional in-memory buffer containing the source code GHC should + -- use for this target instead of reading it from disk. + -- + -- Since GHC version 8.10 modules which require preprocessors such as + -- Literate Haskell or CPP to run are also supported. + -- + -- If a corresponding source file does not exist on disk this will + -- result in a 'SourceError' exception if @targetId = TargetModule _@ + -- is used. However together with @targetId = TargetFile _@ GHC will + -- not complain about the file missing. + } + +data TargetId + = TargetModule ModuleName + -- ^ A module name: search for the file + | TargetFile FilePath (Maybe Phase) + -- ^ A filename: preprocess & parse it to find the module name. + -- If specified, the Phase indicates how to compile this file + -- (which phase to start from). Nothing indicates the starting phase + -- should be determined from the suffix of the filename. + deriving Eq + +type InputFileBuffer = StringBuffer + +pprTarget :: Target -> SDoc +pprTarget (Target id obj _) = + (if obj then char '*' else empty) <> pprTargetId id + +instance Outputable Target where + ppr = pprTarget + +pprTargetId :: TargetId -> SDoc +pprTargetId (TargetModule m) = ppr m +pprTargetId (TargetFile f _) = text f + +instance Outputable TargetId where + ppr = pprTargetId + +{- +************************************************************************ +* * +\subsection{Package and Module Tables} +* * +************************************************************************ +-} + +-- | Helps us find information about modules in the home package +type HomePackageTable = DModuleNameEnv HomeModInfo + -- Domain = modules in the home package that have been fully compiled + -- "home" unit id cached here for convenience + +-- | Helps us find information about modules in the imported packages +type PackageIfaceTable = ModuleEnv ModIface + -- Domain = modules in the imported packages + +-- | Constructs an empty HomePackageTable +emptyHomePackageTable :: HomePackageTable +emptyHomePackageTable = emptyUDFM + +-- | Constructs an empty PackageIfaceTable +emptyPackageIfaceTable :: PackageIfaceTable +emptyPackageIfaceTable = emptyModuleEnv + +pprHPT :: HomePackageTable -> SDoc +-- A bit arbitrary for now +pprHPT hpt = pprUDFM hpt $ \hms -> + vcat [ hang (ppr (mi_module (hm_iface hm))) + 2 (ppr (md_types (hm_details hm))) + | hm <- hms ] + +lookupHpt :: HomePackageTable -> ModuleName -> Maybe HomeModInfo +lookupHpt = lookupUDFM + +lookupHptDirectly :: HomePackageTable -> Unique -> Maybe HomeModInfo +lookupHptDirectly = lookupUDFM_Directly + +eltsHpt :: HomePackageTable -> [HomeModInfo] +eltsHpt = eltsUDFM + +filterHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> HomePackageTable +filterHpt = filterUDFM + +allHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool +allHpt = allUDFM + +mapHpt :: (HomeModInfo -> HomeModInfo) -> HomePackageTable -> HomePackageTable +mapHpt = mapUDFM + +delFromHpt :: HomePackageTable -> ModuleName -> HomePackageTable +delFromHpt = delFromUDFM + +addToHpt :: HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable +addToHpt = addToUDFM + +addListToHpt + :: HomePackageTable -> [(ModuleName, HomeModInfo)] -> HomePackageTable +addListToHpt = addListToUDFM + +listToHpt :: [(ModuleName, HomeModInfo)] -> HomePackageTable +listToHpt = listToUDFM + +lookupHptByModule :: HomePackageTable -> Module -> Maybe HomeModInfo +-- The HPT is indexed by ModuleName, not Module, +-- we must check for a hit on the right Module +lookupHptByModule hpt mod + = case lookupHpt hpt (moduleName mod) of + Just hm | mi_module (hm_iface hm) == mod -> Just hm + _otherwise -> Nothing + +-- | Information about modules in the package being compiled +data HomeModInfo + = HomeModInfo { + hm_iface :: !ModIface, + -- ^ The basic loaded interface file: every loaded module has one of + -- these, even if it is imported from another package + hm_details :: !ModDetails, + -- ^ Extra information that has been created from the 'ModIface' for + -- the module, typically during typechecking + hm_linkable :: !(Maybe Linkable) + -- ^ The actual artifact we would like to link to access things in + -- this module. + -- + -- 'hm_linkable' might be Nothing: + -- + -- 1. If this is an .hs-boot module + -- + -- 2. Temporarily during compilation if we pruned away + -- the old linkable because it was out of date. + -- + -- After a complete compilation ('GHC.load'), all 'hm_linkable' fields + -- in the 'HomePackageTable' will be @Just@. + -- + -- When re-linking a module ('GHC.Driver.Main.HscNoRecomp'), we construct the + -- 'HomeModInfo' by building a new 'ModDetails' from the old + -- 'ModIface' (only). + } + +-- | Find the 'ModIface' for a 'Module', searching in both the loaded home +-- and external package module information +lookupIfaceByModule + :: HomePackageTable + -> PackageIfaceTable + -> Module + -> Maybe ModIface +lookupIfaceByModule hpt pit mod + = case lookupHptByModule hpt mod of + Just hm -> Just (hm_iface hm) + Nothing -> lookupModuleEnv pit mod + +-- If the module does come from the home package, why do we look in the PIT as well? +-- (a) In OneShot mode, even home-package modules accumulate in the PIT +-- (b) Even in Batch (--make) mode, there is *one* case where a home-package +-- module is in the PIT, namely GHC.Prim when compiling the base package. +-- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package +-- of its own, but it doesn't seem worth the bother. + +hptCompleteSigs :: HscEnv -> [CompleteMatch] +hptCompleteSigs = hptAllThings (md_complete_sigs . hm_details) + +-- | Find all the instance declarations (of classes and families) from +-- the Home Package Table filtered by the provided predicate function. +-- Used in @tcRnImports@, to select the instances that are in the +-- transitive closure of imports from the currently compiled module. +hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst]) +hptInstances hsc_env want_this_module + = let (insts, famInsts) = unzip $ flip hptAllThings hsc_env $ \mod_info -> do + guard (want_this_module (moduleName (mi_module (hm_iface mod_info)))) + let details = hm_details mod_info + return (md_insts details, md_fam_insts details) + in (concat insts, concat famInsts) + +-- | Get rules from modules "below" this one (in the dependency sense) +hptRules :: HscEnv -> [(ModuleName, IsBootInterface)] -> [CoreRule] +hptRules = hptSomeThingsBelowUs (md_rules . hm_details) False + + +-- | Get annotations from modules "below" this one (in the dependency sense) +hptAnns :: HscEnv -> Maybe [(ModuleName, IsBootInterface)] -> [Annotation] +hptAnns hsc_env (Just deps) = hptSomeThingsBelowUs (md_anns . hm_details) False hsc_env deps +hptAnns hsc_env Nothing = hptAllThings (md_anns . hm_details) hsc_env + +hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a] +hptAllThings extract hsc_env = concatMap extract (eltsHpt (hsc_HPT hsc_env)) + +-- | Get things from modules "below" this one (in the dependency sense) +-- C.f Inst.hptInstances +hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> [(ModuleName, IsBootInterface)] -> [a] +hptSomeThingsBelowUs extract include_hi_boot hsc_env deps + | isOneShot (ghcMode (hsc_dflags hsc_env)) = [] + + | otherwise + = let hpt = hsc_HPT hsc_env + in + [ thing + | -- Find each non-hi-boot module below me + (mod, is_boot_mod) <- deps + , include_hi_boot || not is_boot_mod + + -- unsavoury: when compiling the base package with --make, we + -- sometimes try to look up RULES etc for GHC.Prim. GHC.Prim won't + -- be in the HPT, because we never compile it; it's in the EPT + -- instead. ToDo: clean up, and remove this slightly bogus filter: + , mod /= moduleName gHC_PRIM + + -- Look it up in the HPT + , let things = case lookupHpt hpt mod of + Just info -> extract info + Nothing -> pprTrace "WARNING in hptSomeThingsBelowUs" msg [] + msg = vcat [text "missing module" <+> ppr mod, + text "Probable cause: out-of-date interface files"] + -- This really shouldn't happen, but see #962 + + -- And get its dfuns + , thing <- things ] + + +{- +************************************************************************ +* * +\subsection{Metaprogramming} +* * +************************************************************************ +-} + +-- | The supported metaprogramming result types +data MetaRequest + = MetaE (LHsExpr GhcPs -> MetaResult) + | MetaP (LPat GhcPs -> MetaResult) + | MetaT (LHsType GhcPs -> MetaResult) + | MetaD ([LHsDecl GhcPs] -> MetaResult) + | MetaAW (Serialized -> MetaResult) + +-- | data constructors not exported to ensure correct result type +data MetaResult + = MetaResE { unMetaResE :: LHsExpr GhcPs } + | MetaResP { unMetaResP :: LPat GhcPs } + | MetaResT { unMetaResT :: LHsType GhcPs } + | MetaResD { unMetaResD :: [LHsDecl GhcPs] } + | MetaResAW { unMetaResAW :: Serialized } + +type MetaHook f = MetaRequest -> LHsExpr GhcTc -> f MetaResult + +metaRequestE :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LHsExpr GhcPs) +metaRequestE h = fmap unMetaResE . h (MetaE MetaResE) + +metaRequestP :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LPat GhcPs) +metaRequestP h = fmap unMetaResP . h (MetaP MetaResP) + +metaRequestT :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LHsType GhcPs) +metaRequestT h = fmap unMetaResT . h (MetaT MetaResT) + +metaRequestD :: Functor f => MetaHook f -> LHsExpr GhcTc -> f [LHsDecl GhcPs] +metaRequestD h = fmap unMetaResD . h (MetaD MetaResD) + +metaRequestAW :: Functor f => MetaHook f -> LHsExpr GhcTc -> f Serialized +metaRequestAW h = fmap unMetaResAW . h (MetaAW MetaResAW) + +{- +************************************************************************ +* * +\subsection{Dealing with Annotations} +* * +************************************************************************ +-} + +-- | Deal with gathering annotations in from all possible places +-- and combining them into a single 'AnnEnv' +prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv +prepareAnnotations hsc_env mb_guts = do + eps <- hscEPS hsc_env + let -- Extract annotations from the module being compiled if supplied one + mb_this_module_anns = fmap (mkAnnEnv . mg_anns) mb_guts + -- Extract dependencies of the module if we are supplied one, + -- otherwise load annotations from all home package table + -- entries regardless of dependency ordering. + home_pkg_anns = (mkAnnEnv . hptAnns hsc_env) $ fmap (dep_mods . mg_deps) mb_guts + other_pkg_anns = eps_ann_env eps + ann_env = foldl1' plusAnnEnv $ catMaybes [mb_this_module_anns, + Just home_pkg_anns, + Just other_pkg_anns] + return ann_env + +{- +************************************************************************ +* * +\subsection{The Finder cache} +* * +************************************************************************ +-} + +-- | The 'FinderCache' maps modules to the result of +-- searching for that module. It records the results of searching for +-- modules along the search path. On @:load@, we flush the entire +-- contents of this cache. +-- +type FinderCache = InstalledModuleEnv InstalledFindResult + +data InstalledFindResult + = InstalledFound ModLocation InstalledModule + | InstalledNoPackage InstalledUnitId + | InstalledNotFound [FilePath] (Maybe InstalledUnitId) + +-- | The result of searching for an imported module. +-- +-- NB: FindResult manages both user source-import lookups +-- (which can result in 'Module') as well as direct imports +-- for interfaces (which always result in 'InstalledModule'). +data FindResult + = Found ModLocation Module + -- ^ The module was found + | NoPackage UnitId + -- ^ The requested package was not found + | FoundMultiple [(Module, ModuleOrigin)] + -- ^ _Error_: both in multiple packages + + -- | Not found + | NotFound + { fr_paths :: [FilePath] -- Places where I looked + + , fr_pkg :: Maybe UnitId -- Just p => module is in this package's + -- manifest, but couldn't find + -- the .hi file + + , fr_mods_hidden :: [UnitId] -- Module is in these packages, + -- but the *module* is hidden + + , 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 + } + +{- +************************************************************************ +* * +\subsection{Symbol tables and Module details} +* * +************************************************************************ +-} + +{- Note [Interface file stages] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Interface files have two possible stages. + +* A partial stage built from the result of the core pipeline. +* A fully instantiated form. Which also includes fingerprints and + potentially information provided by backends. + +We can build a full interface file two ways: +* Directly from a partial one: + Then we omit backend information and mostly compute fingerprints. +* From a partial one + information produced by a backend. + Then we store the provided information and fingerprint both. +-} + +type PartialModIface = ModIface_ 'ModIfaceCore +type ModIface = ModIface_ 'ModIfaceFinal + +-- | Extends a PartialModIface with information which is either: +-- * Computed after codegen +-- * Or computed just before writing the iface to disk. (Hashes) +-- In order to fully instantiate it. +data ModIfaceBackend = ModIfaceBackend + { 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 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 + -- ^ Whether this module has family instances. See Note [The type family + -- instance consistency story]. + , mi_exp_hash :: !Fingerprint + -- ^ Hash of export list + , mi_orphan_hash :: !Fingerprint + -- ^ Hash for orphan rules, class and family instances combined + + -- Cached environments for easy lookup. These are computed (lazily) from + -- other fields and are not put into the interface file. + -- Not really produced by the backend but there is no need to create them + -- any earlier. + , mi_warn_fn :: !(OccName -> Maybe WarningTxt) + -- ^ Cached lookup for 'mi_warns' + , mi_fix_fn :: !(OccName -> Maybe Fixity) + -- ^ Cached lookup for 'mi_fixities' + , mi_hash_fn :: !(OccName -> Maybe (OccName, Fingerprint)) + -- ^ Cached lookup for 'mi_decls'. The @Nothing@ in 'mi_hash_fn' means that + -- the thing isn't in decls. It's useful to know that when seeing if we are + -- up to date wrt. the old interface. The 'OccName' is the parent of the + -- name, if it has one. + } + +data ModIfacePhase + = ModIfaceCore + -- ^ Partial interface built based on output of core pipeline. + | ModIfaceFinal + +-- | Selects a IfaceDecl representation. +-- For fully instantiated interfaces we also maintain +-- a fingerprint, which is used for recompilation checks. +type family IfaceDeclExts (phase :: ModIfacePhase) where + IfaceDeclExts 'ModIfaceCore = IfaceDecl + IfaceDeclExts 'ModIfaceFinal = (Fingerprint, IfaceDecl) + +type family IfaceBackendExts (phase :: ModIfacePhase) where + IfaceBackendExts 'ModIfaceCore = () + IfaceBackendExts 'ModIfaceFinal = ModIfaceBackend + + + +-- | A 'ModIface' plus a 'ModDetails' summarises everything we know +-- about a compiled module. The 'ModIface' is the stuff *before* linking, +-- and can be written out to an interface file. The 'ModDetails is after +-- linking and can be completely recovered from just the 'ModIface'. +-- +-- When we read an interface file, we also construct a 'ModIface' from it, +-- except that we explicitly make the 'mi_decls' and a few other fields empty; +-- as when reading we consolidate the declarations etc. into a number of indexed +-- maps and environments in the 'ExternalPackageState'. +data ModIface_ (phase :: ModIfacePhase) + = ModIface { + mi_module :: !Module, -- ^ Name of the module we are for + mi_sig_of :: !(Maybe Module), -- ^ Are we a sig of another mod? + + mi_hsc_src :: !HscSource, -- ^ Boot? Signature? + + mi_deps :: Dependencies, + -- ^ The dependencies of the module. This is + -- consulted for directly-imported modules, but not + -- for anything else (hence lazy) + + mi_usages :: [Usage], + -- ^ Usages; kept sorted so that it's easy to decide + -- whether to write a new iface file (changing usages + -- doesn't affect the hash of this module) + -- NOT STRICT! we read this field lazily from the interface file + -- It is *only* consulted by the recompilation checker + + mi_exports :: ![IfaceExport], + -- ^ Exports + -- Kept sorted by (mod,occ), to make version comparisons easier + -- Records the modules that are the declaration points for things + -- exported by this module, and the 'OccName's of those things + + + mi_used_th :: !Bool, + -- ^ Module required TH splices when it was compiled. + -- This disables recompilation avoidance (see #481). + + mi_fixities :: [(OccName,Fixity)], + -- ^ Fixities + -- NOT STRICT! we read this field lazily from the interface file + + mi_warns :: Warnings, + -- ^ Warnings + -- NOT STRICT! we read this field lazily from the interface file + + mi_anns :: [IfaceAnnotation], + -- ^ Annotations + -- NOT STRICT! we read this field lazily from the interface file + + + mi_decls :: [IfaceDeclExts phase], + -- ^ Type, class and variable declarations + -- The hash of an Id changes if its fixity or deprecations change + -- (as well as its type of course) + -- Ditto data constructors, class operations, except that + -- the hash of the parent class/tycon changes + + mi_globals :: !(Maybe GlobalRdrEnv), + -- ^ Binds all the things defined at the top level in + -- the /original source/ code for this module. which + -- is NOT the same as mi_exports, nor mi_decls (which + -- may contains declarations for things not actually + -- defined by the user). Used for GHCi and for inspecting + -- the contents of modules via the GHC API only. + -- + -- (We need the source file to figure out the + -- top-level environment, if we didn't compile this module + -- from source then this field contains @Nothing@). + -- + -- Strictly speaking this field should live in the + -- 'HomeModInfo', but that leads to more plumbing. + + -- Instance declarations and rules + mi_insts :: [IfaceClsInst], -- ^ Sorted class instance + mi_fam_insts :: [IfaceFamInst], -- ^ Sorted family instances + mi_rules :: [IfaceRule], -- ^ Sorted rules + + mi_hpc :: !AnyHpcUsage, + -- ^ True if this program uses Hpc at any point in the program. + + mi_trust :: !IfaceTrustInfo, + -- ^ Safe Haskell Trust information for this module. + + mi_trust_pkg :: !Bool, + -- ^ Do we require the package this module resides in be trusted + -- to trust this module? This is used for the situation where a + -- module is Safe (so doesn't require the package be trusted + -- itself) but imports some trustworthy modules from its own + -- package (which does require its own package be trusted). + -- See Note [Trust Own Package] in GHC.Rename.Names + 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. + + mi_final_exts :: !(IfaceBackendExts phase) + -- ^ Either `()` or `ModIfaceBackend` for + -- a fully instantiated interface. + } + +-- | Old-style accessor for whether or not the ModIface came from an hs-boot +-- file. +mi_boot :: ModIface -> Bool +mi_boot iface = mi_hsc_src iface == HsBootFile + +-- | Lookups up a (possibly cached) fixity from a 'ModIface'. If one cannot be +-- found, 'defaultFixity' is returned instead. +mi_fix :: ModIface -> OccName -> Fixity +mi_fix iface name = mi_fix_fn (mi_final_exts iface) name `orElse` defaultFixity + +-- | The semantic module for this interface; e.g., if it's a interface +-- for a signature, if 'mi_module' is @p[A=<A>]:A@, 'mi_semantic_module' +-- will be @<A>@. +mi_semantic_module :: ModIface_ a -> Module +mi_semantic_module iface = case mi_sig_of iface of + Nothing -> mi_module iface + Just mod -> mod + +-- | The "precise" free holes, e.g., the signatures that this +-- 'ModIface' depends on. +mi_free_holes :: ModIface -> UniqDSet ModuleName +mi_free_holes iface = + case splitModuleInsts (mi_module iface) of + (_, Just indef) + -- A mini-hack: we rely on the fact that 'renameFreeHoles' + -- drops things that aren't holes. + -> renameFreeHoles (mkUniqDSet cands) (indefUnitIdInsts (indefModuleUnitId indef)) + _ -> emptyUniqDSet + where + cands = map fst (dep_mods (mi_deps iface)) + +-- | Given a set of free holes, and a unit identifier, rename +-- the free holes according to the instantiation of the unit +-- identifier. For example, if we have A and B free, and +-- our unit identity is @p[A=<C>,B=impl:B]@, the renamed free +-- holes are just C. +renameFreeHoles :: UniqDSet ModuleName -> [(ModuleName, Module)] -> UniqDSet ModuleName +renameFreeHoles fhs insts = + unionManyUniqDSets (map lookup_impl (uniqDSetToList fhs)) + where + hmap = listToUFM insts + lookup_impl mod_name + | Just mod <- lookupUFM hmap mod_name = moduleFreeHoles mod + -- It wasn't actually a hole + | otherwise = emptyUniqDSet + +instance Binary ModIface where + put_ bh (ModIface { + mi_module = mod, + mi_sig_of = sig_of, + mi_hsc_src = hsc_src, + mi_deps = deps, + mi_usages = usages, + mi_exports = exports, + mi_used_th = used_th, + mi_fixities = fixities, + mi_warns = warns, + mi_anns = anns, + mi_decls = decls, + mi_insts = insts, + mi_fam_insts = fam_insts, + mi_rules = rules, + mi_hpc = hpc_info, + mi_trust = trust, + mi_trust_pkg = trust_pkg, + mi_complete_sigs = complete_sigs, + mi_doc_hdr = doc_hdr, + mi_decl_docs = decl_docs, + mi_arg_docs = arg_docs, + mi_final_exts = ModIfaceBackend { + 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_exp_hash = exp_hash, + mi_orphan_hash = orphan_hash + }}) = 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 + lazyPut bh usages + put_ bh exports + put_ bh exp_hash + put_ bh used_th + put_ bh fixities + lazyPut bh warns + lazyPut bh anns + put_ bh decls + put_ bh insts + put_ bh fam_insts + lazyPut bh rules + put_ bh orphan_hash + 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 + sig_of <- get bh + hsc_src <- get bh + 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 + usages <- {-# SCC "bin_usages" #-} lazyGet bh + exports <- {-# SCC "bin_exports" #-} get bh + exp_hash <- get bh + used_th <- get bh + fixities <- {-# SCC "bin_fixities" #-} get bh + warns <- {-# SCC "bin_warns" #-} lazyGet bh + anns <- {-# SCC "bin_anns" #-} lazyGet bh + decls <- {-# SCC "bin_tycldecls" #-} get bh + insts <- {-# SCC "bin_insts" #-} get bh + fam_insts <- {-# SCC "bin_fam_insts" #-} get bh + rules <- {-# SCC "bin_rules" #-} lazyGet bh + orphan_hash <- 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, + mi_hsc_src = hsc_src, + mi_deps = deps, + mi_usages = usages, + mi_exports = exports, + mi_used_th = used_th, + mi_anns = anns, + mi_fixities = fixities, + mi_warns = warns, + mi_decls = decls, + mi_globals = Nothing, + mi_insts = insts, + mi_fam_insts = fam_insts, + mi_rules = rules, + mi_hpc = hpc_info, + mi_trust = trust, + mi_trust_pkg = trust_pkg, + -- And build the cached values + mi_complete_sigs = complete_sigs, + mi_doc_hdr = doc_hdr, + mi_decl_docs = decl_docs, + mi_arg_docs = arg_docs, + mi_final_exts = ModIfaceBackend { + 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_exp_hash = exp_hash, + mi_orphan_hash = orphan_hash, + mi_warn_fn = mkIfaceWarnCache warns, + mi_fix_fn = mkIfaceFixCache fixities, + mi_hash_fn = mkIfaceHashCache decls + }}) + +-- | The original names declared of a certain module that are exported +type IfaceExport = AvailInfo + +emptyPartialModIface :: Module -> PartialModIface +emptyPartialModIface mod + = ModIface { mi_module = mod, + mi_sig_of = Nothing, + mi_hsc_src = HsSrcFile, + mi_deps = noDependencies, + mi_usages = [], + mi_exports = [], + mi_used_th = False, + mi_fixities = [], + mi_warns = NoWarnings, + mi_anns = [], + mi_insts = [], + mi_fam_insts = [], + mi_rules = [], + mi_decls = [], + mi_globals = Nothing, + mi_hpc = False, + mi_trust = noIfaceTrustInfo, + mi_trust_pkg = False, + mi_complete_sigs = [], + mi_doc_hdr = Nothing, + mi_decl_docs = emptyDeclDocMap, + mi_arg_docs = emptyArgDocMap, + mi_final_exts = () } + +emptyFullModIface :: Module -> ModIface +emptyFullModIface mod = + (emptyPartialModIface mod) + { mi_decls = [] + , mi_final_exts = ModIfaceBackend + { 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_exp_hash = fingerprint0, + mi_orphan_hash = fingerprint0, + mi_warn_fn = emptyIfaceWarnCache, + mi_fix_fn = emptyIfaceFixCache, + mi_hash_fn = emptyIfaceHashCache } } + +-- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface' +mkIfaceHashCache :: [(Fingerprint,IfaceDecl)] + -> (OccName -> Maybe (OccName, Fingerprint)) +mkIfaceHashCache pairs + = \occ -> lookupOccEnv env occ + where + env = foldl' add_decl emptyOccEnv pairs + add_decl env0 (v,d) = foldl' add env0 (ifaceDeclFingerprints v d) + where + add env0 (occ,hash) = extendOccEnv env0 occ (occ,hash) + +emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint) +emptyIfaceHashCache _occ = Nothing + + +-- | The 'ModDetails' is essentially a cache for information in the 'ModIface' +-- for home modules only. Information relating to packages will be loaded into +-- global environments in 'ExternalPackageState'. +data ModDetails + = ModDetails { + -- The next two fields are created by the typechecker + md_exports :: [AvailInfo], + md_types :: !TypeEnv, -- ^ Local type environment for this particular module + -- Includes Ids, TyCons, PatSyns + md_insts :: ![ClsInst], -- ^ 'DFunId's for the instances in this module + md_fam_insts :: ![FamInst], + 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_complete_sigs :: [CompleteMatch] + -- ^ Complete match pragmas for this module + } + +-- | Constructs an empty ModDetails +emptyModDetails :: ModDetails +emptyModDetails + = ModDetails { md_types = emptyTypeEnv, + md_exports = [], + md_insts = [], + md_rules = [], + md_fam_insts = [], + md_anns = [], + md_complete_sigs = [] } + +-- | Records the modules directly imported by a module for extracting e.g. +-- usage information, and also to give better error message +type ImportedMods = ModuleEnv [ImportedBy] + +-- | If a module was "imported" by the user, we associate it with +-- more detailed usage information 'ImportedModsVal'; a module +-- imported by the system only gets used for usage information. +data ImportedBy + = ImportedByUser ImportedModsVal + | ImportedBySystem + +importedByUser :: [ImportedBy] -> [ImportedModsVal] +importedByUser (ImportedByUser imv : bys) = imv : importedByUser bys +importedByUser (ImportedBySystem : bys) = importedByUser bys +importedByUser [] = [] + +data ImportedModsVal + = ImportedModsVal { + imv_name :: ModuleName, -- ^ The name the module is imported with + 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 + -- NB. BangPattern here: otherwise this leaks. (#15111) + imv_qualified :: Bool -- ^ whether this is a qualified import + } + +-- | A ModGuts is carried through the compiler, accumulating stuff as it goes +-- There is only one ModGuts at any time, the one for the module +-- being compiled right now. Once it is compiled, a 'ModIface' and +-- 'ModDetails' are extracted and the ModGuts is discarded. +data ModGuts + = ModGuts { + mg_module :: !Module, -- ^ Module being compiled + mg_hsc_src :: HscSource, -- ^ Whether it's an hs-boot module + mg_loc :: SrcSpan, -- ^ For error messages from inner passes + mg_exports :: ![AvailInfo], -- ^ What it exports + mg_deps :: !Dependencies, -- ^ What it depends on, directly or + -- otherwise + mg_usages :: ![Usage], -- ^ What was used? Used for interfaces. + + mg_used_th :: !Bool, -- ^ Did we run a TH splice? + mg_rdr_env :: !GlobalRdrEnv, -- ^ Top-level lexical environment + + -- These fields all describe the things **declared in this module** + mg_fix_env :: !FixityEnv, -- ^ Fixities declared in this module. + -- Used for creating interface files. + mg_tcs :: ![TyCon], -- ^ TyCons declared in this module + -- (includes TyCons for classes) + mg_insts :: ![ClsInst], -- ^ Class instances declared in this module + mg_fam_insts :: ![FamInst], + -- ^ Family instances declared in this module + mg_patsyns :: ![PatSyn], -- ^ Pattern synonyms declared in this module + mg_rules :: ![CoreRule], -- ^ Before the core pipeline starts, contains + -- 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, 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 + + -- The next two fields are unusual, because they give instance + -- environments for *all* modules in the home package, including + -- this module, rather than for *just* this module. + -- Reason: when looking up an instance we don't want to have to + -- look at each module in the home package in turn + mg_inst_env :: InstEnv, -- ^ Class instance environment for + -- /home-package/ modules (including this + -- one); c.f. 'tcg_inst_env' + mg_fam_inst_env :: FamInstEnv, -- ^ Type-family instance environment for + -- /home-package/ modules (including this + -- one); c.f. 'tcg_fam_inst_env' + + mg_safe_haskell :: SafeHaskellMode, -- ^ Safe Haskell mode + mg_trust_pkg :: Bool, -- ^ Do we need to trust our + -- own package for Safe Haskell? + -- See Note [Trust Own Package] + -- in GHC.Rename.Names + + 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: +-- +-- After simplification, the following fields change slightly: +-- mg_rules Orphan rules only (local ones now attached to binds) +-- mg_binds With rules attached + +--------------------------------------------------------- +-- The Tidy pass forks the information about this module: +-- * one lot goes to interface file generation (ModIface) +-- and later compilations (ModDetails) +-- * the other lot goes to code generation (CgGuts) + +-- | A restricted form of 'ModGuts' for code generation purposes +data CgGuts + = CgGuts { + cg_module :: !Module, + -- ^ Module being compiled + + cg_tycons :: [TyCon], + -- ^ Algebraic data types (including ones that started + -- life as classes); generate constructors and info + -- tables. Includes newtypes, just for the benefit of + -- External Core + + cg_binds :: CoreProgram, + -- ^ The tidied main bindings, including + -- previously-implicit bindings for record and class + -- selectors, and data constructor wrappers. But *not* + -- 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, FilePath)], + cg_dep_pkgs :: ![InstalledUnitId], -- ^ Dependent packages, used to + -- generate #includes for C code gen + cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information + cg_modBreaks :: !(Maybe ModBreaks), -- ^ Module breakpoints + cg_spt_entries :: [SptEntry] + -- ^ Static pointer table entries for static forms defined in + -- the module. + -- See Note [Grand plan for static forms] in StaticPtrTable + } + +----------------------------------- +-- | Foreign export stubs +data ForeignStubs + = NoStubs + -- ^ We don't have any stubs + | ForeignStubs SDoc SDoc + -- ^ There are some stubs. Parameters: + -- + -- 1) Header file prototypes for + -- "foreign exported" functions + -- + -- 2) C stubs to use when calling + -- "foreign exported" functions + +appendStubC :: ForeignStubs -> SDoc -> ForeignStubs +appendStubC NoStubs c_code = ForeignStubs empty c_code +appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code) + +{- +************************************************************************ +* * + The interactive context +* * +************************************************************************ + +Note [The interactive package] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Type, class, and value declarations at the command prompt are treated +as if they were defined in modules + interactive:Ghci1 + interactive:Ghci2 + ...etc... +with each bunch of declarations using a new module, all sharing a +common package 'interactive' (see Module.interactiveUnitId, and +PrelNames.mkInteractiveModule). + +This scheme deals well with shadowing. For example: + + ghci> data T = A + ghci> data T = B + ghci> :i A + data Ghci1.T = A -- Defined at <interactive>:2:10 + +Here we must display info about constructor A, but its type T has been +shadowed by the second declaration. But it has a respectable +qualified name (Ghci1.T), and its source location says where it was +defined. + +So the main invariant continues to hold, that in any session an +original name M.T only refers to one unique thing. (In a previous +iteration both the T's above were called :Interactive.T, albeit with +different uniques, which gave rise to all sorts of trouble.) + +The details are a bit tricky though: + + * The field ic_mod_index counts which Ghci module we've got up to. + It is incremented when extending ic_tythings + + * ic_tythings contains only things from the 'interactive' package. + + * Module from the 'interactive' package (Ghci1, Ghci2 etc) never go + in the Home Package Table (HPT). When you say :load, that's when we + extend the HPT. + + * The 'thisPackage' field of DynFlags is *not* set to 'interactive'. + It stays as 'main' (or whatever -this-unit-id says), and is the + package to which :load'ed modules are added to. + + * So how do we arrange that declarations at the command prompt get to + be in the 'interactive' package? Simply by setting the tcg_mod + field of the TcGblEnv to "interactive:Ghci1". This is done by the + call to initTc in initTcInteractive, which in turn get the module + from it 'icInteractiveModule' field of the interactive context. + + The 'thisPackage' field stays as 'main' (or whatever -this-unit-id says. + + * The main trickiness is that the type environment (tcg_type_env) and + fixity envt (tcg_fix_env), now contain entities from all the + interactive-package modules (Ghci1, Ghci2, ...) together, rather + than just a single module as is usually the case. So you can't use + "nameIsLocalOrFrom" to decide whether to look in the TcGblEnv vs + the HPT/PTE. This is a change, but not a problem provided you + know. + +* However, the tcg_binds, tcg_sigs, tcg_insts, tcg_fam_insts, etc fields + of the TcGblEnv, which collect "things defined in this module", all + refer to stuff define in a single GHCi command, *not* all the commands + so far. + + In contrast, tcg_inst_env, tcg_fam_inst_env, have instances from + all GhciN modules, which makes sense -- they are all "home package" + modules. + + +Note [Interactively-bound Ids in GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Ids bound by previous Stmts in GHCi are currently + a) GlobalIds, with + b) An External Name, like Ghci4.foo + See Note [The interactive package] above + c) A tidied type + + (a) They must be GlobalIds (not LocalIds) otherwise when we come to + compile an expression using these ids later, the byte code + generator will consider the occurrences to be free rather than + global. + + (b) Having an External Name is important because of Note + [GlobalRdrEnv shadowing] in RdrName + + (c) Their types are tidied. This is important, because :info may ask + to look at them, and :info expects the things it looks up to have + tidy types + +Where do interactively-bound Ids come from? + + - GHCi REPL Stmts e.g. + ghci> let foo x = x+1 + These start with an Internal Name because a Stmt is a local + construct, so the renamer naturally builds an Internal name for + each of its binders. Then in tcRnStmt they are externalised via + TcRnDriver.externaliseAndTidyId, so they get Names like Ghic4.foo. + + - Ids bound by the debugger etc have Names constructed by + GHC.Iface.Env.newInteractiveBinder; at the call sites it is followed by + mkVanillaGlobal or mkVanillaGlobalWithInfo. So again, they are + all Global, External. + + - TyCons, Classes, and Ids bound by other top-level declarations in + GHCi (eg foreign import, record selectors) also get External + Names, with Ghci9 (or 8, or 7, etc) as the module name. + + +Note [ic_tythings] +~~~~~~~~~~~~~~~~~~ +The ic_tythings field contains + * The TyThings declared by the user at the command prompt + (eg Ids, TyCons, Classes) + + * The user-visible Ids that arise from such things, which + *don't* come from 'implicitTyThings', notably: + - record selectors + - class ops + The implicitTyThings are readily obtained from the TyThings + but record selectors etc are not + +It does *not* contain + * DFunIds (they can be gotten from ic_instances) + * CoAxioms (ditto) + +See also Note [Interactively-bound Ids in GHCi] + +Note [Override identical instances in GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If you declare a new instance in GHCi that is identical to a previous one, +we simply override the previous one; we don't regard it as overlapping. +e.g. Prelude> data T = A | B + Prelude> instance Eq T where ... + Prelude> instance Eq T where ... -- This one overrides + +It's exactly the same for type-family instances. See #7102 +-} + +-- | Interactive context, recording information about the state of the +-- context in which statements are executed in a GHCi session. +data InteractiveContext + = InteractiveContext { + ic_dflags :: DynFlags, + -- ^ The 'DynFlags' used to evaluate interactive expressions + -- and statements. + + ic_mod_index :: Int, + -- ^ Each GHCi stmt or declaration brings some new things into + -- scope. We give them names like interactive:Ghci9.T, + -- where the ic_index is the '9'. The ic_mod_index is + -- incremented whenever we add something to ic_tythings + -- See Note [The interactive package] + + ic_imports :: [InteractiveImport], + -- ^ The GHCi top-level scope (ic_rn_gbl_env) is extended with + -- these imports + -- + -- This field is only stored here so that the client + -- can retrieve it with GHC.getContext. GHC itself doesn't + -- use it, but does reset it to empty sometimes (such + -- as before a GHC.load). The context is set with GHC.setContext. + + ic_tythings :: [TyThing], + -- ^ TyThings defined by the user, in reverse order of + -- definition (ie most recent at the front) + -- See Note [ic_tythings] + + ic_rn_gbl_env :: GlobalRdrEnv, + -- ^ The cached 'GlobalRdrEnv', built by + -- 'GHC.Runtime.Eval.setContext' and updated regularly + -- It contains everything in scope at the command line, + -- including everything in ic_tythings + + ic_instances :: ([ClsInst], [FamInst]), + -- ^ All instances and family instances created during + -- this session. These are grabbed en masse after each + -- update to be sure that proper overlapping is retained. + -- That is, rather than re-check the overlapping each + -- time we update the context, we just take the results + -- from the instance code that already does that. + + ic_fix_env :: FixityEnv, + -- ^ Fixities declared in let statements + + ic_default :: Maybe [Type], + -- ^ The current default types, set by a 'default' declaration + + ic_resume :: [Resume], + -- ^ The stack of breakpoint contexts + + ic_monad :: Name, + -- ^ The monad that GHCi is executing in + + ic_int_print :: Name, + -- ^ The function that is used for printing results + -- of expressions in ghci and -e mode. + + ic_cwd :: Maybe FilePath + -- virtual CWD of the program + } + +data InteractiveImport + = IIDecl (ImportDecl GhcPs) + -- ^ Bring the exports of a particular module + -- (filtered by an import decl) into scope + + | IIModule ModuleName + -- ^ Bring into scope the entire top-level envt of + -- of this module, including the things imported + -- into it. + + +-- | Constructs an empty InteractiveContext. +emptyInteractiveContext :: DynFlags -> InteractiveContext +emptyInteractiveContext dflags + = InteractiveContext { + ic_dflags = dflags, + ic_imports = [], + ic_rn_gbl_env = emptyGlobalRdrEnv, + ic_mod_index = 1, + ic_tythings = [], + ic_instances = ([],[]), + ic_fix_env = emptyNameEnv, + ic_monad = ioTyConName, -- IO monad by default + ic_int_print = printName, -- System.IO.print by default + ic_default = Nothing, + ic_resume = [], + ic_cwd = Nothing } + +icInteractiveModule :: InteractiveContext -> Module +icInteractiveModule (InteractiveContext { ic_mod_index = index }) + = mkInteractiveModule index + +-- | This function returns the list of visible TyThings (useful for +-- e.g. showBindings) +icInScopeTTs :: InteractiveContext -> [TyThing] +icInScopeTTs = ic_tythings + +-- | Get the PrintUnqualified function based on the flags and this InteractiveContext +icPrintUnqual :: DynFlags -> InteractiveContext -> PrintUnqualified +icPrintUnqual dflags InteractiveContext{ ic_rn_gbl_env = grenv } = + mkPrintUnqualified dflags grenv + +-- | extendInteractiveContext is called with new TyThings recently defined to update the +-- InteractiveContext to include them. Ids are easily removed when shadowed, +-- but Classes and TyCons are not. Some work could be done to determine +-- whether they are entirely shadowed, but as you could still have references +-- to them (e.g. instances for classes or values of the type for TyCons), it's +-- not clear whether removing them is even the appropriate behavior. +extendInteractiveContext :: InteractiveContext + -> [TyThing] + -> [ClsInst] -> [FamInst] + -> Maybe [Type] + -> FixityEnv + -> InteractiveContext +extendInteractiveContext ictxt new_tythings new_cls_insts new_fam_insts defaults fix_env + = ictxt { ic_mod_index = ic_mod_index ictxt + 1 + -- Always bump this; even instances should create + -- a new mod_index (#9426) + , 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 ) + -- we don't shadow old family instances (#7102), + -- so don't need to remove them here + , ic_default = 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] + (cls_insts, fam_insts) = ic_instances ictxt + old_cls_insts = filterOut (\i -> any (identicalClsInstHead i) new_cls_insts) cls_insts + +extendInteractiveContextWithIds :: InteractiveContext -> [Id] -> InteractiveContext +-- Just a specialised version +extendInteractiveContextWithIds ictxt new_ids + | null new_ids = ictxt + | otherwise = ictxt { ic_mod_index = ic_mod_index ictxt + 1 + , 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' +setInteractivePackage hsc_env + = hsc_env { hsc_dflags = (hsc_dflags hsc_env) + { thisInstalledUnitId = toInstalledUnitId interactiveUnitId } } + +setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext +setInteractivePrintName ic n = ic{ic_int_print = n} + + -- ToDo: should not add Ids to the gbl env here + +-- | Add TyThings to the GlobalRdrEnv, earlier ones in the list shadowing +-- later ones, and shadowing existing entries in the GlobalRdrEnv. +icExtendGblRdrEnv :: GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv +icExtendGblRdrEnv env tythings + = foldr add env tythings -- Foldr makes things in the front of + -- the list shadow things at the back + where + -- One at a time, to ensure each shadows the previous ones + add thing env + | is_sub_bndr thing + = env + | otherwise + = foldl' extendGlobalRdrEnv env1 (concatMap localGREsFromAvail avail) + where + env1 = shadowNames env (concatMap availNames avail) + avail = tyThingAvailInfo thing + + -- Ugh! The new_tythings may include record selectors, since they + -- are not implicit-ids, and must appear in the TypeEnv. But they + -- will also be brought into scope by the corresponding (ATyCon + -- tc). And we want the latter, because that has the correct + -- parent (#10520) + is_sub_bndr (AnId f) = case idDetails f of + RecSelId {} -> True + ClassOpId {} -> True + _ -> False + is_sub_bndr _ = False + +substInteractiveContext :: InteractiveContext -> TCvSubst -> InteractiveContext +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` 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 + ppr (IIDecl d) = ppr d + +{- +************************************************************************ +* * + Building a PrintUnqualified +* * +************************************************************************ + +Note [Printing original names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Deciding how to print names is pretty tricky. We are given a name +P:M.T, where P is the package name, M is the defining module, and T is +the occurrence name, and we have to decide in which form to display +the name given a GlobalRdrEnv describing the current scope. + +Ideally we want to display the name in the form in which it is in +scope. However, the name might not be in scope at all, and that's +where it gets tricky. Here are the cases: + + 1. T uniquely maps to P:M.T ---> "T" NameUnqual + 2. There is an X for which X.T + uniquely maps to P:M.T ---> "X.T" NameQual X + 3. There is no binding for "M.T" ---> "M.T" NameNotInScope1 + 4. Otherwise ---> "P:M.T" NameNotInScope2 + +(3) and (4) apply when the entity P:M.T is not in the GlobalRdrEnv at +all. In these cases we still want to refer to the name as "M.T", *but* +"M.T" might mean something else in the current scope (e.g. if there's +an "import X as M"), so to avoid confusion we avoid using "M.T" if +there's already a binding for it. Instead we write P:M.T. + +There's one further subtlety: in case (3), what if there are two +things around, P1:M.T and P2:M.T? Then we don't want to print both of +them as M.T! However only one of the modules P1:M and P2:M can be +exposed (say P2), so we use M.T for that, and P1:M.T for the other one. +This is handled by the qual_mod component of PrintUnqualified, inside +the (ppr mod) of case (3), in Name.pprModulePrefix + +Note [Printing unit ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the old days, original names were tied to PackageIds, which directly +corresponded to the entities that users wrote in Cabal files, and were perfectly +suitable for printing when we need to disambiguate packages. However, with +UnitId, the situation can be different: if the key is instantiated with +some holes, we should try to give the user some more useful information. +-} + +-- | Creates some functions that work out the best ways to format +-- names for the user according to a set of heuristics. +mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified +mkPrintUnqualified dflags env = QueryQualify qual_name + (mkQualModule dflags) + (mkQualPackage dflags) + where + qual_name mod occ + | [gre] <- unqual_gres + , right_name gre + = NameUnqual -- If there's a unique entity that's in scope + -- unqualified with 'occ' AND that entity is + -- the right one, then we can use the unqualified name + + | [] <- unqual_gres + , any is_name forceUnqualNames + , not (isDerivedOccName occ) + = NameUnqual -- Don't qualify names that come from modules + -- that come with GHC, often appear in error messages, + -- but aren't typically in scope. Doing this does not + -- cause ambiguity, and it reduces the amount of + -- qualification in error messages thus improving + -- readability. + -- + -- A motivating example is 'Constraint'. It's often not + -- in scope, but printing GHC.Prim.Constraint seems + -- overkill. + + | [gre] <- qual_gres + = NameQual (greQualModName gre) + + | null qual_gres + = if null (lookupGRE_RdrName (mkRdrQual (moduleName mod) occ) env) + then NameNotInScope1 + else NameNotInScope2 + + | otherwise + = NameNotInScope1 -- Can happen if 'f' is bound twice in the module + -- Eg f = True; g = 0; f = False + where + is_name :: Name -> Bool + is_name name = ASSERT2( isExternalName name, ppr name ) + nameModule name == mod && nameOccName name == occ + + forceUnqualNames :: [Name] + forceUnqualNames = + map tyConName [ constraintKindTyCon, heqTyCon, coercibleTyCon ] + ++ [ eqTyConName ] + + right_name gre = nameModule_maybe (gre_name gre) == Just mod + + unqual_gres = lookupGRE_RdrName (mkRdrUnqual occ) env + qual_gres = filter right_name (lookupGlobalRdrEnv env occ) + + -- we can mention a module P:M without the P: qualifier iff + -- "import M" would resolve unambiguously to P:M. (if P is the + -- current package we can just assume it is unqualified). + +-- | Creates a function for formatting modules based on two heuristics: +-- (1) if the module is the current module, don't qualify, and (2) if there +-- is only one exposed package which exports this module, don't qualify. +mkQualModule :: DynFlags -> QueryQualifyModule +mkQualModule dflags mod + | moduleUnitId mod == thisPackage dflags = False + + | [(_, pkgconfig)] <- lookup, + packageConfigId pkgconfig == moduleUnitId mod + -- this says: we are given a module P:M, is there just one exposed package + -- that exposes a module M, and is it package P? + = False + + | otherwise = True + where lookup = lookupModuleInAllPackages dflags (moduleName mod) + +-- | Creates a function for formatting packages based on two heuristics: +-- (1) don't qualify if the package in question is "main", and (2) only qualify +-- with a unit id if the package ID would be ambiguous. +mkQualPackage :: DynFlags -> QueryQualifyPackage +mkQualPackage dflags uid + | uid == mainUnitId || uid == interactiveUnitId + -- Skip the lookup if it's main, since it won't be in the package + -- database! + = False + | Just pkgid <- mb_pkgid + , searchPackageId dflags pkgid `lengthIs` 1 + -- this says: we are given a package pkg-0.1@MMM, are there only one + -- exposed packages whose package ID is pkg-0.1? + = False + | otherwise + = True + where mb_pkgid = fmap sourcePackageId (lookupUnit dflags uid) + +-- | A function which only qualifies package names if necessary; but +-- qualifies all other identifiers. +pkgQual :: DynFlags -> PrintUnqualified +pkgQual dflags = alwaysQualify { + queryQualifyPackage = mkQualPackage dflags + } + +{- +************************************************************************ +* * + Implicit TyThings +* * +************************************************************************ + +Note [Implicit TyThings] +~~~~~~~~~~~~~~~~~~~~~~~~ + DEFINITION: An "implicit" TyThing is one that does not have its own + IfaceDecl in an interface file. Instead, its binding in the type + environment is created as part of typechecking the IfaceDecl for + some other thing. + +Examples: + * All DataCons are implicit, because they are generated from the + IfaceDecl for the data/newtype. Ditto class methods. + + * Record selectors are *not* implicit, because they get their own + free-standing IfaceDecl. + + * Associated data/type families are implicit because they are + included in the IfaceDecl of the parent class. (NB: the + IfaceClass decl happens to use IfaceDecl recursively for the + associated types, but that's irrelevant here.) + + * Dictionary function Ids are not implicit. + + * Axioms for newtypes are implicit (same as above), but axioms + for data/type family instances are *not* implicit (like DFunIds). +-} + +-- | Determine the 'TyThing's brought into scope by another 'TyThing' +-- /other/ than itself. For example, Id's don't have any implicit TyThings +-- as they just bring themselves into scope, but classes bring their +-- dictionary datatype, type constructor and some selector functions into +-- scope, just for a start! + +-- N.B. the set of TyThings returned here *must* match the set of +-- names returned by GHC.Iface.Load.ifaceDeclImplicitBndrs, in the sense that +-- TyThing.getOccName should define a bijection between the two lists. +-- This invariant is used in GHC.Iface.Load.loadDecl (see note [Tricky iface loop]) +-- The order of the list does not matter. +implicitTyThings :: TyThing -> [TyThing] +implicitTyThings (AnId _) = [] +implicitTyThings (ACoAxiom _cc) = [] +implicitTyThings (ATyCon tc) = implicitTyConThings tc +implicitTyThings (AConLike cl) = implicitConLikeThings cl + +implicitConLikeThings :: ConLike -> [TyThing] +implicitConLikeThings (RealDataCon dc) + = dataConImplicitTyThings dc + +implicitConLikeThings (PatSynCon {}) + = [] -- Pattern synonyms have no implicit Ids; the wrapper and matcher + -- are not "implicit"; they are simply new top-level bindings, + -- and they have their own declaration in an interface file + -- Unless a record pat syn when there are implicit selectors + -- They are still not included here as `implicitConLikeThings` is + -- used by `tcTyClsDecls` whilst pattern synonyms are typed checked + -- by `tcTopValBinds`. + +implicitClassThings :: Class -> [TyThing] +implicitClassThings cl + = -- Does not include default methods, because those Ids may have + -- their own pragmas, unfoldings etc, not derived from the Class object + + -- associated types + -- No recursive call for the classATs, because they + -- are only the family decls; they have no implicit things + map ATyCon (classATs cl) ++ + + -- superclass and operation selectors + map AnId (classAllSelIds cl) + +implicitTyConThings :: TyCon -> [TyThing] +implicitTyConThings tc + = class_stuff ++ + -- fields (names of selectors) + + -- (possibly) implicit newtype axioms + -- or type family axioms + implicitCoTyCon tc ++ + + -- for each data constructor in order, + -- the constructor, worker, and (possibly) wrapper + [ thing | dc <- tyConDataCons tc + , thing <- AConLike (RealDataCon dc) : dataConImplicitTyThings dc ] + -- NB. record selectors are *not* implicit, they have fully-fledged + -- bindings that pass through the compilation pipeline as normal. + where + class_stuff = case tyConClass_maybe tc of + Nothing -> [] + Just cl -> implicitClassThings cl + +-- For newtypes and closed type families (only) add the implicit coercion tycon +implicitCoTyCon :: TyCon -> [TyThing] +implicitCoTyCon tc + | Just co <- newTyConCo_maybe tc = [ACoAxiom $ toBranchedAxiom co] + | Just co <- isClosedSynFamilyTyConWithAxiom_maybe tc + = [ACoAxiom co] + | otherwise = [] + +-- | Returns @True@ if there should be no interface-file declaration +-- for this thing on its own: either it is built-in, or it is part +-- of some other declaration, or it is generated implicitly by some +-- other declaration. +isImplicitTyThing :: TyThing -> Bool +isImplicitTyThing (AConLike cl) = case cl of + RealDataCon {} -> True + PatSynCon {} -> False +isImplicitTyThing (AnId id) = isImplicitId id +isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc +isImplicitTyThing (ACoAxiom ax) = isImplicitCoAxiom ax + +-- | tyThingParent_maybe x returns (Just p) +-- when pprTyThingInContext should print a declaration for p +-- (albeit with some "..." in it) when asked to show x +-- It returns the *immediate* parent. So a datacon returns its tycon +-- but the tycon could be the associated type of a class, so it in turn +-- might have a parent. +tyThingParent_maybe :: TyThing -> Maybe TyThing +tyThingParent_maybe (AConLike cl) = case cl of + RealDataCon dc -> Just (ATyCon (dataConTyCon dc)) + PatSynCon{} -> Nothing +tyThingParent_maybe (ATyCon tc) = case tyConAssoc_maybe tc of + Just tc -> Just (ATyCon tc) + Nothing -> Nothing +tyThingParent_maybe (AnId id) = case idDetails id of + RecSelId { sel_tycon = RecSelData tc } -> + Just (ATyCon tc) + ClassOpId cls -> + Just (ATyCon (classTyCon cls)) + _other -> Nothing +tyThingParent_maybe _other = Nothing + +tyThingsTyCoVars :: [TyThing] -> TyCoVarSet +tyThingsTyCoVars tts = + unionVarSets $ map ttToVarSet tts + where + ttToVarSet (AnId id) = tyCoVarsOfType $ idType id + ttToVarSet (AConLike cl) = case cl of + RealDataCon dc -> tyCoVarsOfType $ dataConRepType dc + PatSynCon{} -> emptyVarSet + ttToVarSet (ATyCon tc) + = case tyConClass_maybe tc of + Just cls -> (mkVarSet . fst . classTvsFds) cls + Nothing -> tyCoVarsOfType $ tyConKind tc + ttToVarSet (ACoAxiom _) = emptyVarSet + +-- | The Names that a TyThing should bring into scope. Used to build +-- the GlobalRdrEnv for the InteractiveContext. +tyThingAvailInfo :: TyThing -> [AvailInfo] +tyThingAvailInfo (ATyCon t) + = case tyConClass_maybe t of + Just c -> [AvailTC n (n : map getName (classMethods c) + ++ map getName (classATs c)) + [] ] + where n = getName c + Nothing -> [AvailTC n (n : map getName dcs) flds] + where n = getName t + dcs = tyConDataCons t + flds = tyConFieldLabels t +tyThingAvailInfo (AConLike (PatSynCon p)) + = map avail ((getName p) : map flSelector (patSynFieldLabels p)) +tyThingAvailInfo t + = [avail (getName t)] + +{- +************************************************************************ +* * + TypeEnv +* * +************************************************************************ +-} + +-- | A map from 'Name's to 'TyThing's, constructed by typechecking +-- local declarations or interface files +type TypeEnv = NameEnv TyThing + +emptyTypeEnv :: TypeEnv +typeEnvElts :: TypeEnv -> [TyThing] +typeEnvTyCons :: TypeEnv -> [TyCon] +typeEnvCoAxioms :: TypeEnv -> [CoAxiom Branched] +typeEnvIds :: TypeEnv -> [Id] +typeEnvPatSyns :: TypeEnv -> [PatSyn] +typeEnvDataCons :: TypeEnv -> [DataCon] +typeEnvClasses :: TypeEnv -> [Class] +lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing + +emptyTypeEnv = emptyNameEnv +typeEnvElts env = nameEnvElts env +typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env] +typeEnvCoAxioms env = [ax | ACoAxiom ax <- typeEnvElts env] +typeEnvIds env = [id | AnId id <- typeEnvElts env] +typeEnvPatSyns env = [ps | AConLike (PatSynCon ps) <- typeEnvElts env] +typeEnvDataCons env = [dc | AConLike (RealDataCon dc) <- typeEnvElts env] +typeEnvClasses env = [cl | tc <- typeEnvTyCons env, + Just cl <- [tyConClass_maybe tc]] + +mkTypeEnv :: [TyThing] -> TypeEnv +mkTypeEnv things = extendTypeEnvList emptyTypeEnv things + +mkTypeEnvWithImplicits :: [TyThing] -> TypeEnv +mkTypeEnvWithImplicits things = + mkTypeEnv things + `plusNameEnv` + mkTypeEnv (concatMap implicitTyThings things) + +typeEnvFromEntities :: [Id] -> [TyCon] -> [FamInst] -> TypeEnv +typeEnvFromEntities ids tcs famInsts = + mkTypeEnv ( map AnId ids + ++ map ATyCon all_tcs + ++ concatMap implicitTyConThings all_tcs + ++ map (ACoAxiom . toBranchedAxiom . famInstAxiom) famInsts + ) + where + all_tcs = tcs ++ famInstsRepTyCons famInsts + +lookupTypeEnv = lookupNameEnv + +-- Extend the type environment +extendTypeEnv :: TypeEnv -> TyThing -> TypeEnv +extendTypeEnv env thing = extendNameEnv env (getName thing) thing + +extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv +extendTypeEnvList env things = foldl' extendTypeEnv env things + +extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv +extendTypeEnvWithIds env ids + = extendNameEnvList env [(getName id, AnId id) | id <- ids] + +plusTypeEnv :: TypeEnv -> TypeEnv -> TypeEnv +plusTypeEnv env1 env2 = plusNameEnv env1 env2 + +-- | Find the 'TyThing' for the given 'Name' by using all the resources +-- at our disposal: the compiled modules in the 'HomePackageTable' and the +-- compiled modules in other packages that live in 'PackageTypeEnv'. Note +-- that this does NOT look up the 'TyThing' in the module being compiled: you +-- have to do that yourself, if desired +lookupType :: DynFlags + -> HomePackageTable + -> PackageTypeEnv + -> Name + -> Maybe TyThing + +lookupType dflags hpt pte name + | isOneShot (ghcMode dflags) -- in one-shot, we don't use the HPT + = lookupNameEnv pte name + | otherwise + = case lookupHptByModule hpt mod of + Just hm -> lookupNameEnv (md_types (hm_details hm)) name + Nothing -> lookupNameEnv pte name + where + mod = ASSERT2( isExternalName name, ppr name ) + if isHoleName name + then mkModule (thisPackage dflags) (moduleName (nameModule name)) + else nameModule name + +-- | As 'lookupType', but with a marginally easier-to-use interface +-- if you have a 'HscEnv' +lookupTypeHscEnv :: HscEnv -> Name -> IO (Maybe TyThing) +lookupTypeHscEnv hsc_env name = do + eps <- readIORef (hsc_EPS hsc_env) + return $! lookupType dflags hpt (eps_PTE eps) name + where + dflags = hsc_dflags hsc_env + hpt = hsc_HPT hsc_env + +-- | Get the 'TyCon' from a 'TyThing' if it is a type constructor thing. Panics otherwise +tyThingTyCon :: HasDebugCallStack => TyThing -> TyCon +tyThingTyCon (ATyCon tc) = tc +tyThingTyCon other = pprPanic "tyThingTyCon" (ppr other) + +-- | Get the 'CoAxiom' from a 'TyThing' if it is a coercion axiom thing. Panics otherwise +tyThingCoAxiom :: HasDebugCallStack => TyThing -> CoAxiom Branched +tyThingCoAxiom (ACoAxiom ax) = ax +tyThingCoAxiom other = pprPanic "tyThingCoAxiom" (ppr other) + +-- | Get the 'DataCon' from a 'TyThing' if it is a data constructor thing. Panics otherwise +tyThingDataCon :: HasDebugCallStack => TyThing -> DataCon +tyThingDataCon (AConLike (RealDataCon dc)) = dc +tyThingDataCon other = pprPanic "tyThingDataCon" (ppr other) + +-- | Get the 'ConLike' from a 'TyThing' if it is a data constructor thing. +-- Panics otherwise +tyThingConLike :: HasDebugCallStack => TyThing -> ConLike +tyThingConLike (AConLike dc) = dc +tyThingConLike other = pprPanic "tyThingConLike" (ppr other) + +-- | Get the 'Id' from a 'TyThing' if it is a id *or* data constructor thing. Panics otherwise +tyThingId :: HasDebugCallStack => TyThing -> Id +tyThingId (AnId id) = id +tyThingId (AConLike (RealDataCon dc)) = dataConWrapId dc +tyThingId other = pprPanic "tyThingId" (ppr other) + +{- +************************************************************************ +* * +\subsection{MonadThings and friends} +* * +************************************************************************ +-} + +-- | Class that abstracts out the common ability of the monads in GHC +-- to lookup a 'TyThing' in the monadic environment by 'Name'. Provides +-- a number of related convenience functions for accessing particular +-- kinds of 'TyThing' +class Monad m => MonadThings m where + lookupThing :: Name -> m TyThing + + lookupId :: Name -> m Id + lookupId = liftM tyThingId . lookupThing + + lookupDataCon :: Name -> m DataCon + lookupDataCon = liftM tyThingDataCon . lookupThing + + lookupTyCon :: Name -> m TyCon + lookupTyCon = liftM tyThingTyCon . lookupThing + +-- Instance used in GHC.HsToCore.Quote +instance MonadThings m => MonadThings (ReaderT s m) where + lookupThing = lift . lookupThing + +{- +************************************************************************ +* * +\subsection{Auxiliary types} +* * +************************************************************************ + +These types are defined here because they are mentioned in ModDetails, +but they are mostly elaborated elsewhere +-} + +------------------ Warnings ------------------------- +-- | Warning information for a module +data Warnings + = NoWarnings -- ^ Nothing deprecated + | WarnAll WarningTxt -- ^ Whole module deprecated + | WarnSome [(OccName,WarningTxt)] -- ^ Some specific things deprecated + + -- Only an OccName is needed because + -- (1) a deprecation always applies to a binding + -- defined in the module in which the deprecation appears. + -- (2) deprecations are only reported outside the defining module. + -- this is important because, otherwise, if we saw something like + -- + -- {-# DEPRECATED f "" #-} + -- f = ... + -- h = f + -- g = let f = undefined in f + -- + -- we'd need more information than an OccName to know to say something + -- about the use of f in h but not the use of the locally bound f in g + -- + -- however, because we only report about deprecations from the outside, + -- and a module can only export one value called f, + -- an OccName suffices. + -- + -- this is in contrast with fixity declarations, where we need to map + -- a Name to its fixity declaration. + deriving( Eq ) + +instance Binary Warnings where + put_ bh NoWarnings = putByte bh 0 + put_ bh (WarnAll t) = do + putByte bh 1 + put_ bh t + put_ bh (WarnSome ts) = do + putByte bh 2 + put_ bh ts + + get bh = do + h <- getByte bh + case h of + 0 -> return NoWarnings + 1 -> do aa <- get bh + return (WarnAll aa) + _ -> do aa <- get bh + return (WarnSome aa) + +-- | Constructs the cache for the 'mi_warn_fn' field of a 'ModIface' +mkIfaceWarnCache :: Warnings -> OccName -> Maybe WarningTxt +mkIfaceWarnCache NoWarnings = \_ -> Nothing +mkIfaceWarnCache (WarnAll t) = \_ -> Just t +mkIfaceWarnCache (WarnSome pairs) = lookupOccEnv (mkOccEnv pairs) + +emptyIfaceWarnCache :: OccName -> Maybe WarningTxt +emptyIfaceWarnCache _ = Nothing + +plusWarns :: Warnings -> Warnings -> Warnings +plusWarns d NoWarnings = d +plusWarns NoWarnings d = d +plusWarns _ (WarnAll t) = WarnAll t +plusWarns (WarnAll t) _ = WarnAll t +plusWarns (WarnSome v1) (WarnSome v2) = WarnSome (v1 ++ v2) + +-- | Creates cached lookup for the 'mi_fix_fn' field of 'ModIface' +mkIfaceFixCache :: [(OccName, Fixity)] -> OccName -> Maybe Fixity +mkIfaceFixCache pairs + = \n -> lookupOccEnv env n + where + env = mkOccEnv pairs + +emptyIfaceFixCache :: OccName -> Maybe Fixity +emptyIfaceFixCache _ = Nothing + +-- | Fixity environment mapping names to their fixities +type FixityEnv = NameEnv FixItem + +-- | Fixity information for an 'Name'. We keep the OccName in the range +-- so that we can generate an interface from it +data FixItem = FixItem OccName Fixity + +instance Outputable FixItem where + ppr (FixItem occ fix) = ppr fix <+> ppr occ + +emptyFixityEnv :: FixityEnv +emptyFixityEnv = emptyNameEnv + +lookupFixity :: FixityEnv -> Name -> Fixity +lookupFixity env n = case lookupNameEnv env n of + Just (FixItem _ fix) -> fix + Nothing -> defaultFixity + +{- +************************************************************************ +* * +\subsection{WhatsImported} +* * +************************************************************************ +-} + +-- | Records whether a module has orphans. An \"orphan\" is one of: +-- +-- * An instance declaration in a module other than the definition +-- module for one of the type constructors or classes in the instance head +-- +-- * A transformation rule in a module other than the one defining +-- the function in the head of the rule +-- +type WhetherHasOrphans = Bool + +-- | Does this module define family instances? +type WhetherHasFamInst = Bool + +-- | Did this module originate from a *-boot file? +type IsBootInterface = Bool + +-- | Dependency information about ALL modules and packages below this one +-- in the import hierarchy. +-- +-- Invariant: the dependencies of a module @M@ never includes @M@. +-- +-- Invariant: none of the lists contain duplicates. +data Dependencies + = Deps { dep_mods :: [(ModuleName, IsBootInterface)] + -- ^ All home-package modules transitively below this one + -- I.e. modules that this one imports, or that are in the + -- dep_mods of those directly-imported modules + + , dep_pkgs :: [(InstalledUnitId, Bool)] + -- ^ All packages transitively below this module + -- I.e. packages to which this module's direct imports belong, + -- or that are in the dep_pkgs of those modules + -- The bool indicates if the package is required to be + -- trusted when the module is imported as a safe import + -- (Safe Haskell). See Note [Tracking Trust Transitively] in GHC.Rename.Names + + , dep_orphs :: [Module] + -- ^ Transitive closure of orphan modules (whether + -- home or external pkg). + -- + -- (Possible optimization: don't include family + -- instance orphans as they are anyway included in + -- 'dep_finsts'. But then be careful about code + -- which relies on dep_orphs having the complete list!) + -- This does NOT include us, unlike 'imp_orphs'. + + , dep_finsts :: [Module] + -- ^ Transitive closure of depended upon modules which + -- contain family instances (whether home or external). + -- 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 GHC.Iface.Utils.addFingerprints + -- See 'TcRnTypes.ImportAvails' for details on dependencies. + +instance Binary Dependencies where + put_ bh deps = do put_ bh (dep_mods deps) + 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_plgins = pl }) + +noDependencies :: Dependencies +noDependencies = Deps [] [] [] [] [] + +-- | Records modules for which changes may force recompilation of this module +-- See wiki: https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance +-- +-- This differs from Dependencies. A module X may be in the dep_mods of this +-- module (via an import chain) but if we don't use anything from X it won't +-- appear in our Usage +data Usage + -- | Module from another package + = UsagePackageModule { + usg_mod :: Module, + -- ^ External package module depended on + usg_mod_hash :: Fingerprint, + -- ^ Cached module fingerprint + usg_safe :: IsSafeImport + -- ^ Was this module imported as a safe import + } + -- | Module from the current package + | UsageHomeModule { + usg_mod_name :: ModuleName, + -- ^ Name of the module + usg_mod_hash :: Fingerprint, + -- ^ Cached module fingerprint + usg_entities :: [(OccName,Fingerprint)], + -- ^ Entities we depend on, sorted by occurrence name and fingerprinted. + -- NB: usages are for parent names only, e.g. type constructors + -- but not the associated data constructors. + usg_exports :: Maybe Fingerprint, + -- ^ Fingerprint for the export list of this module, + -- if we directly imported it (and hence we depend on its export list) + usg_safe :: IsSafeImport + -- ^ Was this module imported as a safe import + } -- ^ Module from the current package + -- | A file upon which the module depends, e.g. a CPP #include, or using TH's + -- 'addDependentFile' + | UsageFile { + usg_file_path :: FilePath, + -- ^ External file dependency. From a CPP #include or TH + -- addDependentFile. Should be absolute. + usg_file_hash :: Fingerprint + -- ^ 'Fingerprint' of the file contents. + + -- Note: We don't consider things like modification timestamps + -- here, because there's no reason to recompile if the actual + -- contents don't change. This previously lead to odd + -- recompilation behaviors; see #8114 + } + -- | A requirement which was merged into this one. + | UsageMergedRequirement { + usg_mod :: Module, + usg_mod_hash :: Fingerprint + } + deriving( Eq ) + -- The export list field is (Just v) if we depend on the export list: + -- i.e. we imported the module directly, whether or not we + -- enumerated the things we imported, or just imported + -- everything + -- We need to recompile if M's exports change, because + -- if the import was import M, we might now have a name clash + -- in the importing module. + -- if the import was import M(x) M might no longer export x + -- The only way we don't depend on the export list is if we have + -- import M() + -- And of course, for modules that aren't imported directly we don't + -- depend on their export lists + +instance Binary Usage where + put_ bh usg@UsagePackageModule{} = do + putByte bh 0 + put_ bh (usg_mod usg) + put_ bh (usg_mod_hash usg) + put_ bh (usg_safe usg) + + put_ bh usg@UsageHomeModule{} = do + putByte bh 1 + put_ bh (usg_mod_name usg) + put_ bh (usg_mod_hash usg) + put_ bh (usg_exports usg) + put_ bh (usg_entities usg) + put_ bh (usg_safe usg) + + put_ bh usg@UsageFile{} = do + putByte bh 2 + put_ bh (usg_file_path usg) + put_ bh (usg_file_hash usg) + + put_ bh usg@UsageMergedRequirement{} = do + putByte bh 3 + put_ bh (usg_mod usg) + put_ bh (usg_mod_hash usg) + + get bh = do + h <- getByte bh + case h of + 0 -> do + nm <- get bh + mod <- get bh + safe <- get bh + return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe } + 1 -> do + nm <- get bh + mod <- get bh + exps <- get bh + ents <- get bh + safe <- get bh + return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod, + usg_exports = exps, usg_entities = ents, usg_safe = safe } + 2 -> do + fp <- get bh + hash <- get bh + return UsageFile { usg_file_path = fp, usg_file_hash = hash } + 3 -> do + mod <- get bh + hash <- get bh + return UsageMergedRequirement { usg_mod = mod, usg_mod_hash = hash } + i -> error ("Binary.get(Usage): " ++ show i) + +{- +************************************************************************ +* * + The External Package State +* * +************************************************************************ +-} + +type PackageTypeEnv = TypeEnv +type PackageRuleBase = RuleBase +type PackageInstEnv = InstEnv +type PackageFamInstEnv = FamInstEnv +type PackageAnnEnv = AnnEnv +type PackageCompleteMatchMap = CompleteMatchMap + +-- | Information about other packages that we have slurped in by reading +-- their interface files +data ExternalPackageState + = EPS { + eps_is_boot :: !(ModuleNameEnv (ModuleName, IsBootInterface)), + -- ^ In OneShot mode (only), home-package modules + -- accumulate in the external package state, and are + -- sucked in lazily. For these home-pkg modules + -- (only) we need to record which are boot modules. + -- We set this field after loading all the + -- explicitly-imported interfaces, but before doing + -- anything else + -- + -- The 'ModuleName' part is not necessary, but it's useful for + -- debug prints, and it's convenient because this field comes + -- direct from 'TcRnTypes.imp_dep_mods' + + eps_PIT :: !PackageIfaceTable, + -- ^ The 'ModIface's for modules in external packages + -- whose interfaces we have opened. + -- The declarations in these interface files are held in the + -- 'eps_decls', 'eps_inst_env', 'eps_fam_inst_env' and 'eps_rules' + -- fields of this record, not in the 'mi_decls' fields of the + -- interface we have sucked in. + -- + -- What /is/ in the PIT is: + -- + -- * The Module + -- + -- * Fingerprint info + -- + -- * Its exports + -- + -- * Fixities + -- + -- * Deprecations and warnings + + eps_free_holes :: InstalledModuleEnv (UniqDSet ModuleName), + -- ^ Cache for 'mi_free_holes'. Ordinarily, we can rely on + -- the 'eps_PIT' for this information, EXCEPT that when + -- we do dependency analysis, we need to look at the + -- 'Dependencies' of our imports to determine what their + -- precise free holes are ('moduleFreeHolesPrecise'). We + -- don't want to repeatedly reread in the interface + -- for every import, so cache it here. When the PIT + -- gets filled in we can drop these entries. + + eps_PTE :: !PackageTypeEnv, + -- ^ Result of typechecking all the external package + -- interface files we have sucked in. The domain of + -- the mapping is external-package modules + + eps_inst_env :: !PackageInstEnv, -- ^ The total 'InstEnv' accumulated + -- from all the external-package modules + eps_fam_inst_env :: !PackageFamInstEnv,-- ^ The total 'FamInstEnv' accumulated + -- from all the external-package modules + eps_rule_base :: !PackageRuleBase, -- ^ The total 'RuleEnv' 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, + -- ^ The total 'CompleteMatchMap' accumulated + -- from all the external-package modules + + eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv), -- ^ The family instances accumulated from external + -- packages, keyed off the module that declared them + + eps_stats :: !EpsStats -- ^ Stastics about what was loaded from external packages + } + +-- | Accumulated statistics about what we are putting into the 'ExternalPackageState'. +-- \"In\" means stuff that is just /read/ from interface files, +-- \"Out\" means actually sucked in and type-checked +data EpsStats = EpsStats { n_ifaces_in + , n_decls_in, n_decls_out + , n_rules_in, n_rules_out + , n_insts_in, n_insts_out :: !Int } + +addEpsInStats :: EpsStats -> Int -> Int -> Int -> EpsStats +-- ^ Add stats for one newly-read interface +addEpsInStats stats n_decls n_insts n_rules + = stats { n_ifaces_in = n_ifaces_in stats + 1 + , n_decls_in = n_decls_in stats + n_decls + , n_insts_in = n_insts_in stats + n_insts + , n_rules_in = n_rules_in stats + n_rules } + +{- +Names in a NameCache are always stored as a Global, and have the SrcLoc +of their binding locations. + +Actually that's not quite right. When we first encounter the original +name, we might not be at its binding site (e.g. we are reading an +interface file); so we give it 'noSrcLoc' then. Later, when we find +its binding site, we fix it up. +-} + +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 + = case platformOS platform of + OSMinGW32 -> root <.> soExt platform + _ -> ("lib" ++ root) <.> soExt platform + +mkHsSOName :: Platform -> FilePath -> FilePath +mkHsSOName platform root = ("lib" ++ root) <.> soExt platform + +soExt :: Platform -> FilePath +soExt platform + = case platformOS platform of + OSDarwin -> "dylib" + OSMinGW32 -> "dll" + _ -> "so" + +{- +************************************************************************ +* * + The module graph and ModSummary type + A ModSummary is a node in the compilation manager's + dependency graph, and it's also passed to hscMain +* * +************************************************************************ +-} + +-- | A ModuleGraph contains all the nodes from the home package (only). +-- There will be a node for each source module, plus a node for each hi-boot +-- module. +-- +-- The graph is not necessarily stored in topologically-sorted order. Use +-- 'GHC.topSortModuleGraph' and 'Digraph.flattenSCC' to achieve this. +data ModuleGraph = ModuleGraph + { mg_mss :: [ModSummary] + , mg_non_boot :: ModuleEnv ModSummary + -- a map of all non-boot ModSummaries keyed by Modules + , mg_boot :: ModuleSet + -- a set of boot Modules + , mg_needs_th_or_qq :: !Bool + -- does any of the modules in mg_mss require TemplateHaskell or + -- QuasiQuotes? + } + +-- | Determines whether a set of modules requires Template Haskell or +-- Quasi Quotes +-- +-- Note that if the session's 'DynFlags' enabled Template Haskell when +-- 'depanal' was called, then each module in the returned module graph will +-- have Template Haskell enabled whether it is actually needed or not. +needsTemplateHaskellOrQQ :: ModuleGraph -> Bool +needsTemplateHaskellOrQQ mg = mg_needs_th_or_qq mg + +-- | Map a function 'f' over all the 'ModSummaries'. +-- To preserve invariants 'f' can't change the isBoot status. +mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph +mapMG f mg@ModuleGraph{..} = mg + { mg_mss = map f mg_mss + , mg_non_boot = mapModuleEnv f mg_non_boot + } + +mgBootModules :: ModuleGraph -> ModuleSet +mgBootModules ModuleGraph{..} = mg_boot + +mgModSummaries :: ModuleGraph -> [ModSummary] +mgModSummaries = mg_mss + +mgElemModule :: ModuleGraph -> Module -> Bool +mgElemModule ModuleGraph{..} m = elemModuleEnv m mg_non_boot + +-- | Look up a ModSummary in the ModuleGraph +mgLookupModule :: ModuleGraph -> Module -> Maybe ModSummary +mgLookupModule ModuleGraph{..} m = lookupModuleEnv mg_non_boot m + +emptyMG :: ModuleGraph +emptyMG = ModuleGraph [] emptyModuleEnv emptyModuleSet False + +isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool +isTemplateHaskellOrQQNonBoot ms = + (xopt LangExt.TemplateHaskell (ms_hspp_opts ms) + || xopt LangExt.QuasiQuotes (ms_hspp_opts ms)) && + not (isBootSummary ms) + +-- | Add a ModSummary to ModuleGraph. Assumes that the new ModSummary is +-- not an element of the ModuleGraph. +extendMG :: ModuleGraph -> ModSummary -> ModuleGraph +extendMG ModuleGraph{..} ms = ModuleGraph + { mg_mss = ms:mg_mss + , mg_non_boot = if isBootSummary ms + then mg_non_boot + else extendModuleEnv mg_non_boot (ms_mod ms) ms + , mg_boot = if isBootSummary ms + then extendModuleSet mg_boot (ms_mod ms) + else mg_boot + , mg_needs_th_or_qq = mg_needs_th_or_qq || isTemplateHaskellOrQQNonBoot ms + } + +mkModuleGraph :: [ModSummary] -> ModuleGraph +mkModuleGraph = foldr (flip extendMG) emptyMG + +-- | A single node in a 'ModuleGraph'. The nodes of the module graph +-- are one of: +-- +-- * A regular Haskell source module +-- * A hi-boot source module +-- +data ModSummary + = ModSummary { + ms_mod :: Module, + -- ^ Identity of the module + ms_hsc_src :: HscSource, + -- ^ The module source either plain Haskell or hs-boot + ms_location :: ModLocation, + -- ^ Location of the various files belonging to the module + ms_hs_date :: UTCTime, + -- ^ Timestamp of source file + ms_obj_date :: Maybe UTCTime, + -- ^ Timestamp of object, if we have one + ms_iface_date :: Maybe UTCTime, + -- ^ Timestamp of hi file, if we *only* are typechecking (it is + -- 'Nothing' otherwise. + -- See Note [Recompilation checking in -fno-code mode] and #9243 + ms_hie_date :: Maybe UTCTime, + -- ^ Timestamp of hie file, if we have one + ms_srcimps :: [(Maybe FastString, Located ModuleName)], + -- ^ Source imports of the module + ms_textual_imps :: [(Maybe FastString, Located ModuleName)], + -- ^ Non-source imports of the module from the module *text* + ms_parsed_mod :: Maybe HsParsedModule, + -- ^ The parsed, nonrenamed source, if we have it. This is also + -- used to support "inline module syntax" in Backpack files. + ms_hspp_file :: FilePath, + -- ^ Filename of preprocessed source file + ms_hspp_opts :: DynFlags, + -- ^ Cached flags from @OPTIONS@, @INCLUDE@ and @LANGUAGE@ + -- pragmas in the modules source code + ms_hspp_buf :: Maybe StringBuffer + -- ^ The actual preprocessed source, if we have it + } + +ms_installed_mod :: ModSummary -> InstalledModule +ms_installed_mod = fst . splitModuleInsts . ms_mod + +ms_mod_name :: ModSummary -> ModuleName +ms_mod_name = moduleName . ms_mod + +ms_imps :: ModSummary -> [(Maybe FastString, Located ModuleName)] +ms_imps ms = + ms_textual_imps ms ++ + map mk_additional_import (dynFlagDependencies (ms_hspp_opts ms)) + where + mk_additional_import mod_nm = (Nothing, noLoc mod_nm) + +home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName] +home_imps imps = [ lmodname | (mb_pkg, lmodname) <- imps, + isLocal mb_pkg ] + where isLocal Nothing = True + isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special + isLocal _ = False + +ms_home_allimps :: ModSummary -> [ModuleName] +ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms) + +-- | Like 'ms_home_imps', but for SOURCE imports. +ms_home_srcimps :: ModSummary -> [Located ModuleName] +ms_home_srcimps = home_imps . ms_srcimps + +-- | All of the (possibly) home module imports from a +-- 'ModSummary'; that is to say, each of these module names +-- could be a home import if an appropriately named file +-- existed. (This is in contrast to package qualified +-- imports, which are guaranteed not to be home imports.) +ms_home_imps :: ModSummary -> [Located ModuleName] +ms_home_imps = home_imps . ms_imps + +-- The ModLocation contains both the original source filename and the +-- filename of the cleaned-up source file after all preprocessing has been +-- done. The point is that the summariser will have to cpp/unlit/whatever +-- all files anyway, and there's no point in doing this twice -- just +-- park the result in a temp file, put the name of it in the location, +-- and let @compile@ read from that file on the way back up. + +-- The ModLocation is stable over successive up-sweeps in GHCi, wheres +-- the ms_hs_date and imports can, of course, change + +msHsFilePath, msHiFilePath, msObjFilePath :: ModSummary -> FilePath +msHsFilePath ms = expectJust "msHsFilePath" (ml_hs_file (ms_location ms)) +msHiFilePath ms = ml_hi_file (ms_location ms) +msObjFilePath ms = ml_obj_file (ms_location ms) + +msDynObjFilePath :: ModSummary -> DynFlags -> FilePath +msDynObjFilePath ms dflags = dynamicOutputFile dflags (msObjFilePath ms) + +-- | Did this 'ModSummary' originate from a hs-boot file? +isBootSummary :: ModSummary -> Bool +isBootSummary ms = ms_hsc_src ms == HsBootFile + +instance Outputable ModSummary where + ppr ms + = sep [text "ModSummary {", + nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)), + text "ms_mod =" <+> ppr (ms_mod ms) + <> text (hscSourceString (ms_hsc_src ms)) <> comma, + text "ms_textual_imps =" <+> ppr (ms_textual_imps ms), + text "ms_srcimps =" <+> ppr (ms_srcimps ms)]), + char '}' + ] + +showModMsg :: DynFlags -> HscTarget -> Bool -> ModSummary -> String +showModMsg dflags target recomp mod_summary = showSDoc dflags $ + if gopt Opt_HideSourcePaths dflags + then text mod_str + else hsep $ + [ text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' ') + , char '(' + , text (op $ msHsFilePath mod_summary) <> char ',' + ] ++ + if gopt Opt_BuildDynamicToo dflags + then [ text obj_file <> char ',' + , text dyn_file + , char ')' + ] + else [ text obj_file, char ')' ] + where + op = normalise + mod = moduleName (ms_mod mod_summary) + mod_str = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary) + dyn_file = op $ msDynObjFilePath mod_summary dflags + obj_file = case target of + HscInterpreted | recomp -> "interpreted" + HscNothing -> "nothing" + _ -> (op $ msObjFilePath mod_summary) + +{- +************************************************************************ +* * +\subsection{Recompilation} +* * +************************************************************************ +-} + +-- | Indicates whether a given module's source has been modified since it +-- was last compiled. +data SourceModified + = SourceModified + -- ^ the source has been modified + | SourceUnmodified + -- ^ the source has not been modified. Compilation may or may + -- not be necessary, depending on whether any dependencies have + -- changed since we last compiled. + | SourceUnmodifiedAndStable + -- ^ the source has not been modified, and furthermore all of + -- its (transitive) dependencies are up to date; it definitely + -- does not need to be recompiled. This is important for two + -- reasons: (a) we can omit the version check in checkOldIface, + -- and (b) if the module used TH splices we don't need to force + -- recompilation. + +{- +************************************************************************ +* * +\subsection{Hpc Support} +* * +************************************************************************ +-} + +-- | Information about a modules use of Haskell Program Coverage +data HpcInfo + = HpcInfo + { hpcInfoTickCount :: Int + , hpcInfoHash :: Int + } + | NoHpcInfo + { hpcUsed :: AnyHpcUsage -- ^ Is hpc used anywhere on the module \*tree\*? + } + +-- | This is used to signal if one of my imports used HPC instrumentation +-- even if there is no module-local HPC usage +type AnyHpcUsage = Bool + +emptyHpcInfo :: AnyHpcUsage -> HpcInfo +emptyHpcInfo = NoHpcInfo + +-- | Find out if HPC is used by this module or any of the modules +-- it depends upon +isHpcUsed :: HpcInfo -> AnyHpcUsage +isHpcUsed (HpcInfo {}) = True +isHpcUsed (NoHpcInfo { hpcUsed = used }) = used + +{- +************************************************************************ +* * +\subsection{Safe Haskell Support} +* * +************************************************************************ + +This stuff here is related to supporting the Safe Haskell extension, +primarily about storing under what trust type a module has been compiled. +-} + +-- | Is an import a safe import? +type IsSafeImport = Bool + +-- | Safe Haskell information for 'ModIface' +-- Simply a wrapper around SafeHaskellMode to sepperate iface and flags +newtype IfaceTrustInfo = TrustInfo SafeHaskellMode + +getSafeMode :: IfaceTrustInfo -> SafeHaskellMode +getSafeMode (TrustInfo x) = x + +setSafeMode :: SafeHaskellMode -> IfaceTrustInfo +setSafeMode = TrustInfo + +noIfaceTrustInfo :: IfaceTrustInfo +noIfaceTrustInfo = setSafeMode Sf_None + +trustInfoToNum :: IfaceTrustInfo -> Word8 +trustInfoToNum it + = case getSafeMode it of + Sf_None -> 0 + Sf_Unsafe -> 1 + Sf_Trustworthy -> 2 + Sf_Safe -> 3 + Sf_SafeInferred -> 4 + Sf_Ignore -> 0 + +numToTrustInfo :: Word8 -> IfaceTrustInfo +numToTrustInfo 0 = setSafeMode Sf_None +numToTrustInfo 1 = setSafeMode Sf_Unsafe +numToTrustInfo 2 = setSafeMode Sf_Trustworthy +numToTrustInfo 3 = setSafeMode Sf_Safe +numToTrustInfo 4 = setSafeMode Sf_SafeInferred +numToTrustInfo n = error $ "numToTrustInfo: bad input number! (" ++ show n ++ ")" + +instance Outputable IfaceTrustInfo where + ppr (TrustInfo Sf_None) = text "none" + ppr (TrustInfo Sf_Ignore) = text "none" + ppr (TrustInfo Sf_Unsafe) = text "unsafe" + ppr (TrustInfo Sf_Trustworthy) = text "trustworthy" + ppr (TrustInfo Sf_Safe) = text "safe" + ppr (TrustInfo Sf_SafeInferred) = text "safe-inferred" + +instance Binary IfaceTrustInfo where + put_ bh iftrust = putByte bh $ trustInfoToNum iftrust + get bh = getByte bh >>= (return . numToTrustInfo) + +{- +************************************************************************ +* * +\subsection{Parser result} +* * +************************************************************************ +-} + +data HsParsedModule = HsParsedModule { + hpm_module :: Located HsModule, + hpm_src_files :: [FilePath], + -- ^ extra source files (e.g. from #includes). The lexer collects + -- these from '# <file> <line>' pragmas, which the C preprocessor + -- leaves behind. These files and their timestamps are stored in + -- the .hi file, so that we can force recompilation if any of + -- them change (#3589) + hpm_annotations :: ApiAnns + -- See note [Api annotations] in ApiAnnotation.hs + } + +{- +************************************************************************ +* * +\subsection{Linkable stuff} +* * +************************************************************************ + +This stuff is in here, rather than (say) in Linker.hs, because the Linker.hs +stuff is the *dynamic* linker, and isn't present in a stage-1 compiler +-} + +isObjectLinkable :: Linkable -> Bool +isObjectLinkable l = not (null unlinked) && all isObject unlinked + where unlinked = linkableUnlinked l + -- A linkable with no Unlinked's is treated as a BCO. We can + -- generate a linkable with no Unlinked's as a result of + -- compiling a module in HscNothing mode, and this choice + -- happens to work well with checkStability in module GHC. + +linkableObjs :: Linkable -> [FilePath] +linkableObjs l = [ f | DotO f <- linkableUnlinked l ] + +------------------------------------------- + +-- | Is this an actual file on disk we can link in somehow? +isObject :: Unlinked -> Bool +isObject (DotO _) = True +isObject (DotA _) = True +isObject (DotDLL _) = True +isObject _ = False + +-- | Is this a bytecode linkable with no file on disk? +isInterpretable :: Unlinked -> Bool +isInterpretable = not . isObject + +-- | Retrieve the filename of the linkable if possible. Panic if it is a byte-code object +nameOfObject :: Unlinked -> FilePath +nameOfObject (DotO fn) = fn +nameOfObject (DotA fn) = fn +nameOfObject (DotDLL fn) = fn +nameOfObject other = pprPanic "nameOfObject" (ppr other) + +-- | Retrieve the compiled byte-code if possible. Panic if it is a file-based linkable +byteCodeOfObject :: Unlinked -> CompiledByteCode +byteCodeOfObject (BCOs bc _) = bc +byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other) + + +------------------------------------------- + +-- | A list of conlikes which represents a complete pattern match. +-- These arise from @COMPLETE@ signatures. + +-- See Note [Implementation of COMPLETE signatures] +data CompleteMatch = CompleteMatch { + completeMatchConLikes :: [Name] + -- ^ The ConLikes that form a covering family + -- (e.g. Nothing, Just) + , completeMatchTyCon :: Name + -- ^ The TyCon that they cover (e.g. Maybe) + } + +instance Outputable CompleteMatch where + ppr (CompleteMatch cl ty) = text "CompleteMatch:" <+> ppr cl + <+> dcolon <+> ppr ty + +-- | A map keyed by the 'completeMatchTyCon'. + +-- See Note [Implementation of COMPLETE signatures] +type CompleteMatchMap = UniqFM [CompleteMatch] + +mkCompleteMatchMap :: [CompleteMatch] -> CompleteMatchMap +mkCompleteMatchMap = extendCompleteMatchMap emptyUFM + +extendCompleteMatchMap :: CompleteMatchMap -> [CompleteMatch] + -> CompleteMatchMap +extendCompleteMatchMap = foldl' insertMatch + where + insertMatch :: CompleteMatchMap -> CompleteMatch -> CompleteMatchMap + insertMatch ufm c@(CompleteMatch _ t) = addToUFM_C (++) ufm t [c] + +{- +Note [Implementation of COMPLETE signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A COMPLETE signature represents a set of conlikes (i.e., constructors or +pattern synonyms) such that if they are all pattern-matched against in a +function, it gives rise to a total function. An example is: + + newtype Boolean = Boolean Int + pattern F, T :: Boolean + pattern F = Boolean 0 + pattern T = Boolean 1 + {-# COMPLETE F, T #-} + + -- This is a total function + booleanToInt :: Boolean -> Int + booleanToInt F = 0 + booleanToInt T = 1 + +COMPLETE sets are represented internally in GHC with the CompleteMatch data +type. For example, {-# COMPLETE F, T #-} would be represented as: + + CompleteMatch { complateMatchConLikes = [F, T] + , completeMatchTyCon = Boolean } + +Note that GHC was able to infer the completeMatchTyCon (Boolean), but for the +cases in which it's ambiguous, you can also explicitly specify it in the source +language by writing this: + + {-# COMPLETE F, T :: Boolean #-} + +For efficiency purposes, GHC collects all of the CompleteMatches that it knows +about into a CompleteMatchMap, which is a map that is keyed by the +completeMatchTyCon. In other words, you could have a multiple COMPLETE sets +for the same TyCon: + + {-# COMPLETE F, T1 :: Boolean #-} + {-# COMPLETE F, T2 :: Boolean #-} + +And looking up the values in the CompleteMatchMap associated with Boolean +would give you [CompleteMatch [F, T1] Boolean, CompleteMatch [F, T2] Boolean]. +dsGetCompleteMatches in GHC.HsToCore.Quote accomplishes this lookup. + +Also see Note [Typechecking Complete Matches] in TcBinds for a more detailed +explanation for how GHC ensures that all the conlikes in a COMPLETE set are +consistent. +-} + +-- | Foreign language of the phase if the phase deals with a foreign code +phaseForeignLanguage :: Phase -> Maybe ForeignSrcLang +phaseForeignLanguage phase = case phase of + Phase.Cc -> Just LangC + Phase.Ccxx -> Just LangCxx + Phase.Cobjc -> Just LangObjc + Phase.Cobjcxx -> Just LangObjcxx + Phase.HCc -> Just LangC + Phase.As _ -> Just LangAsm + Phase.MergeForeign -> Just RawObject + _ -> Nothing + +------------------------------------------- + +-- Take care, this instance only forces to the degree necessary to +-- avoid major space leaks. +instance (NFData (IfaceBackendExts (phase :: ModIfacePhase)), NFData (IfaceDeclExts (phase :: ModIfacePhase))) => NFData (ModIface_ phase) where + rnf (ModIface f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 + f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23) = + rnf f1 `seq` rnf f2 `seq` f3 `seq` f4 `seq` f5 `seq` f6 `seq` rnf f7 `seq` f8 `seq` + f9 `seq` rnf f10 `seq` rnf f11 `seq` f12 `seq` rnf f13 `seq` rnf f14 `seq` rnf f15 `seq` + rnf f16 `seq` f17 `seq` rnf f18 `seq` rnf f19 `seq` f20 `seq` f21 `seq` f22 `seq` rnf f23 diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index fc290737ca..ec888766a7 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -21,8 +21,8 @@ module GHC.HsToCore ( import GhcPrelude import GHC.HsToCore.Usage -import DynFlags -import HscTypes +import GHC.Driver.Session +import GHC.Driver.Types import GHC.Hs import TcRnTypes import TcRnMonad ( finalSafeMode, fixSafeInstances ) @@ -70,7 +70,7 @@ import GHC.HsToCore.Docs import Data.List import Data.IORef import Control.Monad( when ) -import Plugins ( LoadedPlugin(..) ) +import GHC.Driver.Plugins ( LoadedPlugin(..) ) {- ************************************************************************ diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs index a6bbe4ca54..124427578d 100644 --- a/compiler/GHC/HsToCore/Binds.hs +++ b/compiler/GHC/HsToCore/Binds.hs @@ -68,7 +68,7 @@ import Maybes import OrdList import Bag import BasicTypes -import DynFlags +import GHC.Driver.Session import FastString import Util import UniqSet( nonDetEltsUniqSet ) diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index ace0b27b4e..a87d46bbcc 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -23,7 +23,7 @@ import Type import GHC.Hs import Module import Outputable -import DynFlags +import GHC.Driver.Session import ConLike import Control.Monad import SrcLoc @@ -38,7 +38,7 @@ import Id import VarSet import Data.List import FastString -import HscTypes +import GHC.Driver.Types import TyCon import BasicTypes import MonadUtils diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index f400a1fdf1..b627d6e841 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -49,7 +49,7 @@ import CoreSyn import CoreUtils import MkCore -import DynFlags +import GHC.Driver.Session import CostCentre import Id import MkId diff --git a/compiler/GHC/HsToCore/Foreign/Call.hs b/compiler/GHC/HsToCore/Foreign/Call.hs index abbc9f3f79..ce39cf4d3c 100644 --- a/compiler/GHC/HsToCore/Foreign/Call.hs +++ b/compiler/GHC/HsToCore/Foreign/Call.hs @@ -45,7 +45,7 @@ import TysWiredIn import BasicTypes import Literal import PrelNames -import DynFlags +import GHC.Driver.Session import Outputable import Util diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs index de14f6ee12..dc569bdbfa 100644 --- a/compiler/GHC/HsToCore/Foreign/Decl.hs +++ b/compiler/GHC/HsToCore/Foreign/Decl.hs @@ -41,7 +41,7 @@ import TcType import GHC.Cmm.Expr import GHC.Cmm.Utils -import HscTypes +import GHC.Driver.Types import ForeignCall import TysWiredIn import TysPrim @@ -50,11 +50,11 @@ import BasicTypes import SrcLoc import Outputable import FastString -import DynFlags +import GHC.Driver.Session import GHC.Platform import OrdList import Util -import Hooks +import GHC.Driver.Hooks import Encoding import Data.Maybe diff --git a/compiler/GHC/HsToCore/GuardedRHSs.hs b/compiler/GHC/HsToCore/GuardedRHSs.hs index 94821ec68e..37a7cd591b 100644 --- a/compiler/GHC/HsToCore/GuardedRHSs.hs +++ b/compiler/GHC/HsToCore/GuardedRHSs.hs @@ -24,7 +24,7 @@ import CoreSyn import CoreUtils (bindNonRec) import BasicTypes (Origin(FromSource)) -import DynFlags +import GHC.Driver.Session import GHC.HsToCore.PmCheck (needToRunPmCheck, addTyCsDs, addPatTmCs, addScrutTmCs) import GHC.HsToCore.Monad import GHC.HsToCore.Utils diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs index a8ed3bbcb3..0411542d78 100644 --- a/compiler/GHC/HsToCore/ListComp.hs +++ b/compiler/GHC/HsToCore/ListComp.hs @@ -26,7 +26,7 @@ import MkCore import GHC.HsToCore.Monad -- the monadery used in the desugarer import GHC.HsToCore.Utils -import DynFlags +import GHC.Driver.Session import CoreUtils import Id import Type diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs index 16bf73aab8..0542fd5e7e 100644 --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -28,7 +28,7 @@ import GhcPrelude import {-#SOURCE#-} GHC.HsToCore.Expr (dsLExpr, dsSyntaxExpr) import BasicTypes ( Origin(..) ) -import DynFlags +import GHC.Driver.Session import GHC.Hs import TcHsSyn import TcEvidence diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs index 350a5ed8eb..2fdb1a3dd5 100644 --- a/compiler/GHC/HsToCore/Match/Literal.hs +++ b/compiler/GHC/HsToCore/Match/Literal.hs @@ -50,7 +50,7 @@ import SrcLoc import Data.Ratio import Outputable import BasicTypes -import DynFlags +import GHC.Driver.Session import Util import FastString import qualified GHC.LanguageExtensions as LangExt diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs index 4dc7590a47..b13a7f3304 100644 --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -64,7 +64,7 @@ import GHC.IfaceToCore import TcMType ( checkForLevPolyX, formatLevPolyErr ) import PrelNames import RdrName -import HscTypes +import GHC.Driver.Types import Bag import BasicTypes ( Origin ) import DataCon @@ -79,7 +79,7 @@ import Type import UniqSupply import Name import NameEnv -import DynFlags +import GHC.Driver.Session import ErrUtils import FastString import UniqFM ( lookupWithDefaultUFM ) diff --git a/compiler/GHC/HsToCore/PmCheck.hs b/compiler/GHC/HsToCore/PmCheck.hs index ce81b8b587..2a7d70abd2 100644 --- a/compiler/GHC/HsToCore/PmCheck.hs +++ b/compiler/GHC/HsToCore/PmCheck.hs @@ -30,7 +30,7 @@ import GHC.HsToCore.PmCheck.Ppr import BasicTypes (Origin, isGenerated) import CoreSyn (CoreExpr, Expr(Var,App)) import FastString (unpackFS, lengthFS) -import DynFlags +import GHC.Driver.Session import GHC.Hs import TcHsSyn import Id diff --git a/compiler/GHC/HsToCore/PmCheck/Oracle.hs b/compiler/GHC/HsToCore/PmCheck/Oracle.hs index ab0f8ccc29..c0722249d8 100644 --- a/compiler/GHC/HsToCore/PmCheck/Oracle.hs +++ b/compiler/GHC/HsToCore/PmCheck/Oracle.hs @@ -29,7 +29,7 @@ import GhcPrelude import GHC.HsToCore.PmCheck.Types -import DynFlags +import GHC.Driver.Session import Outputable import ErrUtils import Util diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index 292cb4dca0..e9d7a2ca50 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -59,7 +59,7 @@ import Unique import BasicTypes import Outputable import Bag -import DynFlags +import GHC.Driver.Session import FastString import ForeignCall import Util @@ -69,7 +69,7 @@ import TcEvidence import Control.Monad.Trans.Reader import Control.Monad.Trans.Class import Class -import HscTypes ( MonadThings ) +import GHC.Driver.Types ( MonadThings ) import DataCon import Var import GHC.HsToCore.Binds diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs index f771608a94..b83d310e0a 100644 --- a/compiler/GHC/HsToCore/Usage.hs +++ b/compiler/GHC/HsToCore/Usage.hs @@ -13,8 +13,8 @@ module GHC.HsToCore.Usage ( import GhcPrelude -import DynFlags -import HscTypes +import GHC.Driver.Session +import GHC.Driver.Types import TcRnTypes import Name import NameSet @@ -25,8 +25,8 @@ import UniqSet import UniqFM import Fingerprint import Maybes -import Packages -import Finder +import GHC.Driver.Packages +import GHC.Driver.Finder import Control.Monad (filterM) import Data.List diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs index 3c95e55b19..953225e912 100644 --- a/compiler/GHC/HsToCore/Utils.hs +++ b/compiler/GHC/HsToCore/Utils.hs @@ -77,7 +77,7 @@ import Name( isInternalName ) import Outputable import SrcLoc import Util -import DynFlags +import GHC.Driver.Session import FastString import qualified GHC.LanguageExtensions as LangExt diff --git a/compiler/GHC/Iface/Binary.hs b/compiler/GHC/Iface/Binary.hs index af0e9bfac6..c5850f1eaf 100644 --- a/compiler/GHC/Iface/Binary.hs +++ b/compiler/GHC/Iface/Binary.hs @@ -38,10 +38,10 @@ import GhcPrelude import TcRnMonad import PrelInfo ( isKnownKeyName, lookupKnownKeyName ) import GHC.Iface.Env -import HscTypes +import GHC.Driver.Types import Module import Name -import DynFlags +import GHC.Driver.Session import UniqFM import UniqSupply import Panic diff --git a/compiler/GHC/Iface/Env.hs b/compiler/GHC/Iface/Env.hs index fcb1e2dcfb..687989f0a6 100644 --- a/compiler/GHC/Iface/Env.hs +++ b/compiler/GHC/Iface/Env.hs @@ -25,7 +25,7 @@ module GHC.Iface.Env ( import GhcPrelude import TcRnMonad -import HscTypes +import GHC.Driver.Types import Type import Var import Name diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index 690aa323c9..edeeaf651e 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -28,7 +28,7 @@ import ConLike ( conLikeName ) import GHC.HsToCore ( deSugarExpr ) import FieldLabel import GHC.Hs -import HscTypes +import GHC.Driver.Types import Module ( ModuleName, ml_hs_file ) import MonadUtils ( concatMapM, liftIO ) import Name ( Name, nameSrcSpan, setNameLoc ) diff --git a/compiler/GHC/Iface/Ext/Utils.hs b/compiler/GHC/Iface/Ext/Utils.hs index eba14f190a..007634bae6 100644 --- a/compiler/GHC/Iface/Ext/Utils.hs +++ b/compiler/GHC/Iface/Ext/Utils.hs @@ -7,7 +7,7 @@ module GHC.Iface.Ext.Utils where import GhcPrelude import CoreMap -import DynFlags ( DynFlags ) +import GHC.Driver.Session ( DynFlags ) import FastString ( FastString, mkFastString ) import GHC.Iface.Type import Name hiding (varName) diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index c11d4b3e4f..cde0e8c9e2 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -40,10 +40,10 @@ import {-# SOURCE #-} GHC.IfaceToCore ( tcIfaceDecl, tcIfaceRules, tcIfaceInst, tcIfaceFamInst , tcIfaceAnnotations, tcIfaceCompleteSigs ) -import DynFlags +import GHC.Driver.Session import GHC.Iface.Syntax import GHC.Iface.Env -import HscTypes +import GHC.Driver.Types import BasicTypes hiding (SuccessFlag(..)) import TcRnMonad @@ -65,7 +65,7 @@ import Avail import Module import Maybes import ErrUtils -import Finder +import GHC.Driver.Finder import UniqFM import SrcLoc import Outputable @@ -74,11 +74,11 @@ import Panic import Util import FastString import Fingerprint -import Hooks +import GHC.Driver.Hooks import FieldLabel import GHC.Iface.Rename import UniqDSet -import Plugins +import GHC.Driver.Plugins import Control.Monad import Control.Exception @@ -863,7 +863,7 @@ Note [Home module load error] If the sought-for interface is in the current package (as determined by -package-name flag) then it jolly well should already be in the HPT because we process home-package modules in dependency order. (Except -in one-shot mode; see notes with hsc_HPT decl in HscTypes). +in one-shot mode; see notes with hsc_HPT decl in GHC.Driver.Types). It is possible (though hard) to get this error through user behaviour. * Suppose package P (modules P1, P2) depends on package Q (modules Q1, diff --git a/compiler/GHC/Iface/Load.hs-boot b/compiler/GHC/Iface/Load.hs-boot index e3dce1d68f..a2af2a1a9a 100644 --- a/compiler/GHC/Iface/Load.hs-boot +++ b/compiler/GHC/Iface/Load.hs-boot @@ -2,7 +2,7 @@ module GHC.Iface.Load where import Module (Module) import TcRnMonad (IfM) -import HscTypes (ModIface) +import GHC.Driver.Types (ModIface) import Outputable (SDoc) loadSysInterface :: SDoc -> Module -> IfM lcl ModIface diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs index 693f9068c4..3cadf15e80 100644 --- a/compiler/GHC/Iface/Rename.hs +++ b/compiler/GHC/Iface/Rename.hs @@ -21,7 +21,7 @@ import GhcPrelude import SrcLoc import Outputable -import HscTypes +import GHC.Driver.Types import Module import UniqFM import Avail @@ -38,13 +38,13 @@ import BasicTypes -- a bit vexing import {-# SOURCE #-} GHC.Iface.Load -import DynFlags +import GHC.Driver.Session import qualified Data.Traversable as T import Bag import Data.IORef -import NameShape +import GHC.Types.Name.Shape import GHC.Iface.Env tcRnMsgMaybe :: IO (Either ErrorMessages a) -> TcM a diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs index c831d09c7f..cea861de27 100644 --- a/compiler/GHC/Iface/Syntax.hs +++ b/compiler/GHC/Iface/Syntax.hs @@ -403,10 +403,10 @@ ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName] -- *Excludes* the 'main' name, but *includes* the implicitly-bound names -- Deeply revolting, because it has to predict what gets bound, -- especially the question of whether there's a wrapper for a datacon --- See Note [Implicit TyThings] in HscTypes +-- See Note [Implicit TyThings] in GHC.Driver.Types -- N.B. the set of names returned here *must* match the set of --- TyThings returned by HscTypes.implicitTyThings, in the sense that +-- TyThings returned by GHC.Driver.Types.implicitTyThings, in the sense that -- TyThing.getOccName should define a bijection between the two lists. -- This invariant is used in GHC.Iface.Load.loadDecl (see note [Tricky iface loop]) -- The order of the list does not matter. @@ -1741,7 +1741,7 @@ not happen. Here's the one that bit me: data DynFlags = DF ... PackageState ... module Packages where - import DynFlags + import GHC.Driver.Session data PackageState = PS ... lookupModule (df :: DynFlags) = case df of diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index 3d08b139b5..49a5a29856 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -17,7 +17,7 @@ module GHC.Iface.Tidy ( import GhcPrelude import TcRnTypes -import DynFlags +import GHC.Driver.Session import CoreSyn import CoreUnfold import CoreFVs @@ -53,7 +53,7 @@ import DataCon import TyCon import Class import Module -import HscTypes +import GHC.Driver.Types import Maybes import UniqSupply import Outputable diff --git a/compiler/GHC/Iface/Utils.hs b/compiler/GHC/Iface/Utils.hs index bf221bd88c..83f46bd774 100644 --- a/compiler/GHC/Iface/Utils.hs +++ b/compiler/GHC/Iface/Utils.hs @@ -83,9 +83,9 @@ import InstEnv import FamInstEnv import TcRnMonad import GHC.Hs -import HscTypes -import Finder -import DynFlags +import GHC.Driver.Types +import GHC.Driver.Finder +import GHC.Driver.Session import VarEnv import Var import Name @@ -108,7 +108,7 @@ import Binary import Fingerprint import Exception import UniqSet -import Packages +import GHC.Driver.Packages import GHC.HsToCore.Docs import Control.Monad @@ -120,7 +120,7 @@ import Data.Ord import Data.IORef import System.Directory import System.FilePath -import Plugins ( PluginRecompile(..), PluginWithArgs(..), LoadedPlugin(..), +import GHC.Driver.Plugins ( PluginRecompile(..), PluginWithArgs(..), LoadedPlugin(..), pluginRecompile', plugins ) --Qualified import so we can define a Semigroup instance diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index aa74a16284..589843e404 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -38,7 +38,7 @@ import Coercion import CoAxiom import TyCoRep -- needs to build types & coercions in a knot import TyCoSubst ( substTyCoVars ) -import HscTypes +import GHC.Driver.Types import Annotations import InstEnv import FamInstEnv @@ -70,7 +70,7 @@ import UniqSupply import Outputable import Maybes import SrcLoc -import DynFlags +import GHC.Driver.Session import Util import FastString import BasicTypes hiding ( SuccessFlag(..) ) @@ -128,14 +128,14 @@ a Name for another entity defined in A.hi. How do we get the internal TyCons to MATCH the ones that we just constructed during typechecking: the knot is thus tied through if_rec_types. - 2) retypecheckLoop in GhcMake: We are retypechecking a + 2) retypecheckLoop in GHC.Driver.Make: We are retypechecking a mutually recursive cluster of hi files, in order to ensure that all of the references refer to each other correctly. In this case, the knot is tied through the HPT passed in, which contains all of the interfaces we are in the process of typechecking. - 3) genModDetails in HscMain: We are typechecking an + 3) genModDetails in GHC.Driver.Main: We are typechecking an old interface to generate the ModDetails. In this case, we do the same thing as (2) and pass in an HPT with the HomeModInfo being generated to tie knots. diff --git a/compiler/GHC/IfaceToCore.hs-boot b/compiler/GHC/IfaceToCore.hs-boot index 4a888f51f7..521a32d93f 100644 --- a/compiler/GHC/IfaceToCore.hs-boot +++ b/compiler/GHC/IfaceToCore.hs-boot @@ -9,7 +9,7 @@ import TcRnTypes ( IfL ) import InstEnv ( ClsInst ) import FamInstEnv ( FamInst ) import CoreSyn ( CoreRule ) -import HscTypes ( CompleteMatch ) +import GHC.Driver.Types ( CompleteMatch ) import Annotations ( Annotation ) tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing diff --git a/compiler/GHC/Llvm/Types.hs b/compiler/GHC/Llvm/Types.hs index 61c2b2cb86..f8ca0c826c 100644 --- a/compiler/GHC/Llvm/Types.hs +++ b/compiler/GHC/Llvm/Types.hs @@ -14,7 +14,7 @@ import Data.Char import Data.Int import Numeric -import DynFlags +import GHC.Driver.Session import FastString import Outputable import Unique diff --git a/compiler/GHC/Plugins.hs b/compiler/GHC/Plugins.hs new file mode 100644 index 0000000000..6b3115bbcc --- /dev/null +++ b/compiler/GHC/Plugins.hs @@ -0,0 +1,132 @@ +{-# 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 +-- plugin for GHC. So authors of plugins can probably get away simply +-- with saying "import GHC.Plugins". +-- +-- Particularly interesting modules for plugin writers include +-- "CoreSyn" and "CoreMonad". +module GHC.Plugins( + module GHC.Driver.Plugins, + module RdrName, module OccName, module Name, module Var, module Id, module IdInfo, + module CoreMonad, module CoreSyn, module Literal, module DataCon, + module CoreUtils, module MkCore, module CoreFVs, module CoreSubst, + module Rules, module Annotations, + module GHC.Driver.Session, module GHC.Driver.Packages, + module Module, module Type, module TyCon, module Coercion, + module TysWiredIn, module GHC.Driver.Types, module BasicTypes, + 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, + + -- * Getting 'Name's + thNameToGhcName + ) where + +-- Plugin stuff itself +import GHC.Driver.Plugins + +-- Variable naming +import RdrName +import OccName hiding ( varName {- conflicts with Var.varName -} ) +import Name hiding ( varName {- reexport from OccName, conflicts with Var.varName -} ) +import Var +import Id hiding ( lazySetIdInfo, setIdExported, setIdNotExported {- all three conflict with Var -} ) +import IdInfo + +-- Core +import CoreMonad +import CoreSyn +import Literal +import DataCon +import CoreUtils +import MkCore +import CoreFVs +import CoreSubst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst ) + -- These names are also exported by Type + +-- Core "extras" +import Rules +import Annotations + +-- Pipeline-related stuff +import GHC.Driver.Session +import GHC.Driver.Packages + +-- Important GHC types +import Module +import Type hiding {- conflict with CoreSubst -} + ( substTy, extendTvSubst, extendTvSubstList, isInScope ) +import Coercion hiding {- conflict with CoreSubst -} + ( substCo ) +import TyCon +import TysWiredIn +import GHC.Driver.Types +import BasicTypes hiding ( Version {- conflicts with Packages.Version -} ) + +-- Collections and maps +import VarSet +import VarEnv +import NameSet +import NameEnv +import UniqSet +import UniqFM +-- Conflicts with UniqFM: +--import LazyUniqFM +import FiniteMap + +-- Common utilities +import Util +import GHC.Serialized +import SrcLoc +import Outputable +import UniqSupply +import Unique ( Unique, Uniquable(..) ) +import FastString +import Data.Maybe + +import GHC.Iface.Env ( lookupOrigIO ) +import GhcPrelude +import MonadUtils ( mapMaybeM ) +import GHC.ThToHs ( 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 { hsc_env <- getHscEnv + ; Just <$> liftIO (lookupOrigIO hsc_env rdr_mod rdr_occ) } + | otherwise = return Nothing diff --git a/compiler/GHC/Rename/Binds.hs b/compiler/GHC/Rename/Binds.hs index 888b8ce62d..a9a3653e0d 100644 --- a/compiler/GHC/Rename/Binds.hs +++ b/compiler/GHC/Rename/Binds.hs @@ -44,7 +44,7 @@ import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, extendTyVarEnvFVRn , checkDupRdrNames, warnUnusedLocalBinds , checkUnusedRecordWildcard , checkDupAndShadowedNames, bindLocalNamesFV ) -import DynFlags +import GHC.Driver.Session import Module import Name import NameEnv diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs index d300761a68..8e24004653 100644 --- a/compiler/GHC/Rename/Env.hs +++ b/compiler/GHC/Rename/Env.hs @@ -50,7 +50,7 @@ import GHC.Iface.Load ( loadInterfaceForName, loadSrcInterface_maybe ) import GHC.Iface.Env import GHC.Hs import RdrName -import HscTypes +import GHC.Driver.Types import TcEnv import TcRnMonad import RdrHsSyn ( filterCTuple, setRdrNameSpace ) @@ -71,7 +71,7 @@ import Outputable import UniqSet ( uniqSetAny ) import Util import Maybes -import DynFlags +import GHC.Driver.Session import FastString import Control.Monad import ListSetOps ( minusList ) diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs index 70b466ef2b..baadf419ad 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -44,7 +44,7 @@ import GHC.Rename.Unbound ( reportUnboundName ) import GHC.Rename.Splice ( rnBracket, rnSpliceExpr, checkThLocalName ) import GHC.Rename.Types import GHC.Rename.Pat -import DynFlags +import GHC.Driver.Session import PrelNames import BasicTypes diff --git a/compiler/GHC/Rename/Fixity.hs b/compiler/GHC/Rename/Fixity.hs index 74b886f49c..4c55bb3e53 100644 --- a/compiler/GHC/Rename/Fixity.hs +++ b/compiler/GHC/Rename/Fixity.hs @@ -21,7 +21,7 @@ import GhcPrelude import GHC.Iface.Load import GHC.Hs import RdrName -import HscTypes +import GHC.Driver.Types import TcRnMonad import Name import NameEnv diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index b666b89875..48208dba46 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -34,7 +34,7 @@ module GHC.Rename.Names ( import GhcPrelude -import DynFlags +import GHC.Driver.Session import TyCoPpr import GHC.Hs import TcEnv @@ -50,7 +50,7 @@ import NameEnv import NameSet import Avail import FieldLabel -import HscTypes +import GHC.Driver.Types import RdrName import RdrHsSyn ( setRdrNameSpace ) import Outputable @@ -86,7 +86,7 @@ import System.IO Note [Tracking Trust Transitively] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we import a package as well as checking that the direct imports are safe -according to the rules outlined in the Note [HscMain . Safe Haskell Trust Check] +according to the rules outlined in the Note [Safe Haskell Trust Check] in GHC.Driver.Main we must also check that these rules hold transitively for all dependent modules and packages. Doing this without caching any trust information would be very slow as we would need to touch all packages and interface files a module depends @@ -111,7 +111,7 @@ the plusImportAvails function that is a union operation for the ImportAvails type. This gives us in an ImportAvails structure all packages required to be trusted for the module we are currently compiling. Checking that these packages are still trusted (and that direct imports are trusted) is done in -HscMain.checkSafeImports. +GHC.Driver.Main.checkSafeImports. See the note below, [Trust Own Package] for a corner case in this method and how its handled. @@ -543,7 +543,7 @@ created by its bindings. Note [Top-level Names in Template Haskell decl quotes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also: Note [Interactively-bound Ids in GHCi] in HscTypes +See also: Note [Interactively-bound Ids in GHCi] in GHC.Driver.Types Note [Looking up Exact RdrNames] in GHC.Rename.Env Consider a Template Haskell declaration quotation like this: diff --git a/compiler/GHC/Rename/Source.hs b/compiler/GHC/Rename/Source.hs index 934c346971..9bb577f48b 100644 --- a/compiler/GHC/Rename/Source.hs +++ b/compiler/GHC/Rename/Source.hs @@ -43,7 +43,7 @@ import TcRnMonad import ForeignCall ( CCallTarget(..) ) import Module -import HscTypes ( Warnings(..), plusWarns ) +import GHC.Driver.Types ( Warnings(..), plusWarns ) import PrelNames ( applicativeClassName, pureAName, thenAName , monadClassName, returnMName, thenMName , semigroupClassName, sappendName @@ -58,9 +58,9 @@ import Bag import BasicTypes ( pprRuleName, TypeOrKind(..) ) import FastString import SrcLoc -import DynFlags +import GHC.Driver.Session import Util ( debugIsOn, filterOut, lengthExceeds, partitionWith ) -import HscTypes ( HscEnv, hsc_dflags ) +import GHC.Driver.Types ( HscEnv, hsc_dflags ) import ListSetOps ( findDupsEq, removeDups, equivClasses ) import Digraph ( SCC, flattenSCC, flattenSCCs, Node(..) , stronglyConnCompFromEdgedVerticesUniq ) diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs index 9a60a071c5..12496a9fb8 100644 --- a/compiler/GHC/Rename/Splice.hs +++ b/compiler/GHC/Rename/Splice.hs @@ -40,11 +40,11 @@ import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr ) import TcEnv ( checkWellStaged ) import THNames ( liftName ) -import DynFlags +import GHC.Driver.Session import FastString import ErrUtils ( dumpIfSet_dyn_printer, DumpFormat (..) ) import TcEnv ( tcMetaTy ) -import Hooks +import GHC.Driver.Hooks import THNames ( quoteExpName, quotePatName, quoteDecName, quoteTypeName , decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, ) diff --git a/compiler/GHC/Rename/Types.hs b/compiler/GHC/Rename/Types.hs index 05df4865ec..ed65453c64 100644 --- a/compiler/GHC/Rename/Types.hs +++ b/compiler/GHC/Rename/Types.hs @@ -36,7 +36,7 @@ import GhcPrelude import {-# SOURCE #-} GHC.Rename.Splice( rnSpliceType ) -import DynFlags +import GHC.Driver.Session import GHC.Hs import GHC.Rename.Doc ( rnLHsDoc, rnMbLHsDoc ) import GHC.Rename.Env diff --git a/compiler/GHC/Rename/Unbound.hs b/compiler/GHC/Rename/Unbound.hs index f8b33aa748..1e494331e4 100644 --- a/compiler/GHC/Rename/Unbound.hs +++ b/compiler/GHC/Rename/Unbound.hs @@ -20,7 +20,7 @@ where import GhcPrelude import RdrName -import HscTypes +import GHC.Driver.Types import TcRnMonad import Name import Module @@ -29,7 +29,7 @@ import Outputable import PrelNames ( mkUnboundName, isUnboundName, getUnique) import Util import Maybes -import DynFlags +import GHC.Driver.Session import FastString import Data.List import Data.Function ( on ) diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs index 29705c56f0..11cbb745bc 100644 --- a/compiler/GHC/Rename/Utils.hs +++ b/compiler/GHC/Rename/Utils.hs @@ -37,7 +37,7 @@ import GhcPrelude import GHC.Hs import RdrName -import HscTypes +import GHC.Driver.Types import TcEnv import TcRnMonad import Name @@ -49,7 +49,7 @@ import Outputable import Util import BasicTypes ( TopLevelFlag(..) ) import ListSetOps ( removeDups ) -import DynFlags +import GHC.Driver.Session import FastString import Control.Monad import Data.List diff --git a/compiler/GHC/Runtime/Debugger.hs b/compiler/GHC/Runtime/Debugger.hs index 9443ff9421..177a83ea8b 100644 --- a/compiler/GHC/Runtime/Debugger.hs +++ b/compiler/GHC/Runtime/Debugger.hs @@ -21,8 +21,8 @@ import GHC.Runtime.Heap.Inspect import GHC.Runtime.Interpreter import GHCi.RemoteTypes -import GhcMonad -import HscTypes +import GHC.Driver.Monad +import GHC.Driver.Types import Id import GHC.Iface.Syntax ( showToHeader ) import GHC.Iface.Env ( newInteractiveBinder ) @@ -36,7 +36,7 @@ import Outputable import PprTyThing import ErrUtils import MonadUtils -import DynFlags +import GHC.Driver.Session import Exception import Control.Monad diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index 666b80cc88..c960b1c8c6 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -53,10 +53,10 @@ import GHC.Runtime.Eval.Types import GHC.Runtime.Interpreter as GHCi import GHCi.Message import GHCi.RemoteTypes -import GhcMonad -import HscMain +import GHC.Driver.Monad +import GHC.Driver.Main import GHC.Hs -import HscTypes +import GHC.Driver.Types import InstEnv import GHC.Iface.Env ( newInteractiveBinder ) import FamInstEnv ( FamInst ) @@ -77,7 +77,7 @@ import RdrName import VarEnv import GHC.ByteCode.Types import GHC.Runtime.Linker as Linker -import DynFlags +import GHC.Driver.Session import Unique import UniqSupply import MonadUtils diff --git a/compiler/GHC/Runtime/Heap/Inspect.hs b/compiler/GHC/Runtime/Heap/Inspect.hs index de6f9a7af3..7842afcc5d 100644 --- a/compiler/GHC/Runtime/Heap/Inspect.hs +++ b/compiler/GHC/Runtime/Heap/Inspect.hs @@ -29,7 +29,7 @@ import GhcPrelude import GHC.Runtime.Interpreter as GHCi import GHCi.RemoteTypes -import HscTypes +import GHC.Driver.Types import DataCon import Type @@ -54,7 +54,7 @@ import BasicTypes ( Boxity(..) ) import TysPrim import PrelNames import TysWiredIn -import DynFlags +import GHC.Driver.Session import Outputable as Ppr import GHC.Char import GHC.Exts.Heap diff --git a/compiler/GHC/Runtime/Heap/Layout.hs b/compiler/GHC/Runtime/Heap/Layout.hs index b7899ecc1b..8ef91ae741 100644 --- a/compiler/GHC/Runtime/Heap/Layout.hs +++ b/compiler/GHC/Runtime/Heap/Layout.hs @@ -47,7 +47,7 @@ module GHC.Runtime.Heap.Layout ( import GhcPrelude import BasicTypes( ConTagZ ) -import DynFlags +import GHC.Driver.Session import Outputable import GHC.Platform import FastString diff --git a/compiler/GHC/Runtime/Interpreter.hs b/compiler/GHC/Runtime/Interpreter.hs index 9eadacca1c..8524e92cdc 100644 --- a/compiler/GHC/Runtime/Interpreter.hs +++ b/compiler/GHC/Runtime/Interpreter.hs @@ -58,17 +58,17 @@ import GHCi.RemoteTypes import GHCi.ResolvedBCO import GHCi.BreakArray (BreakArray) import Fingerprint -import HscTypes +import GHC.Driver.Types import UniqFM import Panic -import DynFlags +import GHC.Driver.Session import ErrUtils import Outputable import Exception import BasicTypes import FastString import Util -import Hooks +import GHC.Driver.Hooks import Control.Concurrent import Control.Monad diff --git a/compiler/GHC/Runtime/Linker.hs b/compiler/GHC/Runtime/Linker.hs index fb409bd75b..3dcdce34d1 100644 --- a/compiler/GHC/Runtime/Linker.hs +++ b/compiler/GHC/Runtime/Linker.hs @@ -38,16 +38,16 @@ import GHC.ByteCode.Linker import GHC.ByteCode.Asm import GHC.ByteCode.Types import TcRnMonad -import Packages -import DriverPhases -import Finder -import HscTypes +import GHC.Driver.Packages as Packages +import GHC.Driver.Phases +import GHC.Driver.Finder +import GHC.Driver.Types import Name import NameEnv import Module import ListSetOps import GHC.Runtime.Linker.Types (DynLinker(..), LinkerUnitId, PersistentLinkerState(..)) -import DynFlags +import GHC.Driver.Session import BasicTypes import Outputable import Panic diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs index 0156b16044..15d0b7d5dc 100644 --- a/compiler/GHC/Runtime/Loader.hs +++ b/compiler/GHC/Runtime/Loader.hs @@ -21,12 +21,12 @@ module GHC.Runtime.Loader ( ) where import GhcPrelude -import DynFlags +import GHC.Driver.Session import GHC.Runtime.Linker ( linkModule, getHValue ) import GHC.Runtime.Interpreter ( wormhole ) import SrcLoc ( noSrcSpan ) -import Finder ( findPluginModule, cannotFindModule ) +import GHC.Driver.Finder ( findPluginModule, cannotFindModule ) import TcRnMonad ( initTcInteractive, initIfaceTcRn ) import GHC.Iface.Load ( loadPluginInterface ) import RdrName ( RdrName, ImportSpec(..), ImpDeclSpec(..) @@ -34,10 +34,10 @@ import RdrName ( RdrName, ImportSpec(..), ImpDeclSpec(..) , gre_name, mkRdrQual ) import OccName ( OccName, mkVarOcc ) import GHC.Rename.Names ( gresFromAvails ) -import Plugins +import GHC.Driver.Plugins import PrelNames ( pluginTyConName, frontendPluginTyConName ) -import HscTypes +import GHC.Driver.Types import GHCi.RemoteTypes ( HValue ) import Type ( Type, eqType, mkTyConTy ) import TyCoPpr ( pprTyThingCategory ) @@ -50,7 +50,7 @@ import FastString import ErrUtils import Outputable import Exception -import Hooks +import GHC.Driver.Hooks import Control.Monad ( when, unless ) import Data.Maybe ( mapMaybe ) diff --git a/compiler/GHC/Stg/Lift.hs b/compiler/GHC/Stg/Lift.hs index 0f1a4ccbcb..a0223707d7 100644 --- a/compiler/GHC/Stg/Lift.hs +++ b/compiler/GHC/Stg/Lift.hs @@ -20,7 +20,7 @@ where import GhcPrelude import BasicTypes -import DynFlags +import GHC.Driver.Session import Id import GHC.Stg.FVs ( annBindingFreeVars ) import GHC.Stg.Lift.Analysis diff --git a/compiler/GHC/Stg/Lift/Analysis.hs b/compiler/GHC/Stg/Lift/Analysis.hs index 881d0340a5..b85c460f10 100644 --- a/compiler/GHC/Stg/Lift/Analysis.hs +++ b/compiler/GHC/Stg/Lift/Analysis.hs @@ -24,7 +24,7 @@ import GhcPrelude import BasicTypes import Demand -import DynFlags +import GHC.Driver.Session import Id import GHC.Runtime.Heap.Layout ( WordOff ) import GHC.Stg.Syntax diff --git a/compiler/GHC/Stg/Lift/Monad.hs b/compiler/GHC/Stg/Lift/Monad.hs index 5dd7ab8d65..8cc84172d2 100644 --- a/compiler/GHC/Stg/Lift/Monad.hs +++ b/compiler/GHC/Stg/Lift/Monad.hs @@ -26,7 +26,7 @@ import GhcPrelude import BasicTypes import CostCentre ( isCurrentCCS, dontCareCCS ) -import DynFlags +import GHC.Driver.Session import FastString import Id import Name diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs index d2a0b8980e..48d77d0903 100644 --- a/compiler/GHC/Stg/Lint.hs +++ b/compiler/GHC/Stg/Lint.hs @@ -41,7 +41,7 @@ import GhcPrelude import GHC.Stg.Syntax -import DynFlags +import GHC.Driver.Session import Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList ) import BasicTypes ( TopLevelFlag(..), isTopLevel ) import CostCentre ( isCurrentCCS ) diff --git a/compiler/GHC/Stg/Pipeline.hs b/compiler/GHC/Stg/Pipeline.hs index 4b6a36536f..457466291d 100644 --- a/compiler/GHC/Stg/Pipeline.hs +++ b/compiler/GHC/Stg/Pipeline.hs @@ -25,7 +25,7 @@ import GHC.Stg.CSE ( stgCse ) import GHC.Stg.Lift ( stgLiftLams ) import Module ( Module ) -import DynFlags +import GHC.Driver.Session import ErrUtils import UniqSupply import Outputable diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs index 5f52784cb8..eee0e6c6b2 100644 --- a/compiler/GHC/Stg/Syntax.hs +++ b/compiler/GHC/Stg/Syntax.hs @@ -69,14 +69,14 @@ import Data.ByteString ( ByteString ) import Data.Data ( Data ) import Data.List ( intersperse ) import DataCon -import DynFlags +import GHC.Driver.Session import ForeignCall ( ForeignCall ) import Id import VarSet import Literal ( Literal, literalType ) import Module ( Module ) import Outputable -import Packages ( isDllName ) +import GHC.Driver.Packages ( isDllName ) import GHC.Platform import PprCore ( {- instances -} ) import PrimOp ( PrimOp, PrimCall ) diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs index d83e8fbc7b..e5aaf7f5b6 100644 --- a/compiler/GHC/StgToCmm.hs +++ b/compiler/GHC/StgToCmm.hs @@ -30,10 +30,10 @@ import GHC.Cmm import GHC.Cmm.CLabel import GHC.Stg.Syntax -import DynFlags +import GHC.Driver.Session import ErrUtils -import HscTypes +import GHC.Driver.Types import CostCentre import Id import IdInfo diff --git a/compiler/GHC/StgToCmm/ArgRep.hs b/compiler/GHC/StgToCmm/ArgRep.hs index 436b37fced..bd9abbfdea 100644 --- a/compiler/GHC/StgToCmm/ArgRep.hs +++ b/compiler/GHC/StgToCmm/ArgRep.hs @@ -24,7 +24,7 @@ import Id ( Id ) import TyCon ( PrimRep(..), primElemRepSizeB ) import BasicTypes ( RepArity ) import Constants ( wORD64_SIZE ) -import DynFlags +import GHC.Driver.Session import Outputable import FastString diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs index 089fec789c..eb0d01ba62 100644 --- a/compiler/GHC/StgToCmm/Bind.hs +++ b/compiler/GHC/StgToCmm/Bind.hs @@ -48,7 +48,7 @@ import VarSet import BasicTypes import Outputable import FastString -import DynFlags +import GHC.Driver.Session import Control.Monad diff --git a/compiler/GHC/StgToCmm/CgUtils.hs b/compiler/GHC/StgToCmm/CgUtils.hs index 58c46f8fa2..095e9c37df 100644 --- a/compiler/GHC/StgToCmm/CgUtils.hs +++ b/compiler/GHC/StgToCmm/CgUtils.hs @@ -24,7 +24,7 @@ import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Utils import GHC.Cmm.CLabel -import DynFlags +import GHC.Driver.Session import Outputable -- ----------------------------------------------------------------------------- diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs index b171e7a1fb..d42a7f4764 100644 --- a/compiler/GHC/StgToCmm/Closure.hs +++ b/compiler/GHC/StgToCmm/Closure.hs @@ -85,7 +85,7 @@ import TyCon import GHC.Types.RepType import BasicTypes import Outputable -import DynFlags +import GHC.Driver.Session import Util import Data.Coerce (coerce) diff --git a/compiler/GHC/StgToCmm/DataCon.hs b/compiler/GHC/StgToCmm/DataCon.hs index eb7f9223d7..2f7e350d83 100644 --- a/compiler/GHC/StgToCmm/DataCon.hs +++ b/compiler/GHC/StgToCmm/DataCon.hs @@ -37,7 +37,7 @@ import GHC.Runtime.Heap.Layout import CostCentre import Module import DataCon -import DynFlags +import GHC.Driver.Session import FastString import Id import GHC.Types.RepType (countConRepArgs) diff --git a/compiler/GHC/StgToCmm/Env.hs b/compiler/GHC/StgToCmm/Env.hs index b2c1371840..a0c49e69ee 100644 --- a/compiler/GHC/StgToCmm/Env.hs +++ b/compiler/GHC/StgToCmm/Env.hs @@ -36,7 +36,7 @@ import GHC.Cmm.CLabel import GHC.Cmm.BlockId import GHC.Cmm.Expr import GHC.Cmm.Utils -import DynFlags +import GHC.Driver.Session import Id import GHC.Cmm.Graph import Name diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs index 95c8f7defb..589cb770d6 100644 --- a/compiler/GHC/StgToCmm/Expr.hs +++ b/compiler/GHC/StgToCmm/Expr.hs @@ -38,7 +38,7 @@ import GHC.Cmm hiding ( succ ) import GHC.Cmm.Info import CoreSyn import DataCon -import DynFlags ( mAX_PTR_TAG ) +import GHC.Driver.Session ( mAX_PTR_TAG ) import ForeignCall import Id import PrimOp diff --git a/compiler/GHC/StgToCmm/ExtCode.hs b/compiler/GHC/StgToCmm/ExtCode.hs index 2679ce4992..40472245ed 100644 --- a/compiler/GHC/StgToCmm/ExtCode.hs +++ b/compiler/GHC/StgToCmm/ExtCode.hs @@ -47,7 +47,7 @@ import GHC.Cmm.CLabel import GHC.Cmm.Graph import GHC.Cmm.BlockId -import DynFlags +import GHC.Driver.Session import FastString import Module import UniqFM diff --git a/compiler/GHC/StgToCmm/Foreign.hs b/compiler/GHC/StgToCmm/Foreign.hs index b2302a175a..04b8478c0f 100644 --- a/compiler/GHC/StgToCmm/Foreign.hs +++ b/compiler/GHC/StgToCmm/Foreign.hs @@ -37,7 +37,7 @@ import GHC.Types.RepType import GHC.Cmm.CLabel import GHC.Runtime.Heap.Layout import ForeignCall -import DynFlags +import GHC.Driver.Session import Maybes import Outputable import UniqSupply diff --git a/compiler/GHC/StgToCmm/Heap.hs b/compiler/GHC/StgToCmm/Heap.hs index 0656cb2a08..d1b1752fd3 100644 --- a/compiler/GHC/StgToCmm/Heap.hs +++ b/compiler/GHC/StgToCmm/Heap.hs @@ -45,7 +45,7 @@ import CostCentre import IdInfo( CafInfo(..), mayHaveCafRefs ) import Id ( Id ) import Module -import DynFlags +import GHC.Driver.Session import FastString( mkFastString, fsLit ) import Panic( sorry ) diff --git a/compiler/GHC/StgToCmm/Hpc.hs b/compiler/GHC/StgToCmm/Hpc.hs index 219285efbe..d52ff3fa93 100644 --- a/compiler/GHC/StgToCmm/Hpc.hs +++ b/compiler/GHC/StgToCmm/Hpc.hs @@ -18,8 +18,8 @@ import GHC.Cmm.CLabel import Module import GHC.Cmm.Utils import GHC.StgToCmm.Utils -import HscTypes -import DynFlags +import GHC.Driver.Types +import GHC.Driver.Session import Control.Monad diff --git a/compiler/GHC/StgToCmm/Layout.hs b/compiler/GHC/StgToCmm/Layout.hs index 9139c36f0b..1438077fd5 100644 --- a/compiler/GHC/StgToCmm/Layout.hs +++ b/compiler/GHC/StgToCmm/Layout.hs @@ -52,7 +52,7 @@ import GHC.Stg.Syntax import Id import TyCon ( PrimRep(..), primRepSizeB ) import BasicTypes ( RepArity ) -import DynFlags +import GHC.Driver.Session import Module import Util diff --git a/compiler/GHC/StgToCmm/Monad.hs b/compiler/GHC/StgToCmm/Monad.hs index 34709f3d67..ce01ffdb29 100644 --- a/compiler/GHC/StgToCmm/Monad.hs +++ b/compiler/GHC/StgToCmm/Monad.hs @@ -63,7 +63,7 @@ import GhcPrelude hiding( sequence, succ ) import GHC.Cmm import GHC.StgToCmm.Closure -import DynFlags +import GHC.Driver.Session import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Graph as CmmGraph import GHC.Cmm.BlockId diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs index 63cb5a532f..d9ab05eebb 100644 --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -35,7 +35,7 @@ import GHC.StgToCmm.Ticky import GHC.StgToCmm.Heap import GHC.StgToCmm.Prof ( costCentreFrom ) -import DynFlags +import GHC.Driver.Session import GHC.Platform import BasicTypes import GHC.Cmm.BlockId diff --git a/compiler/GHC/StgToCmm/Prof.hs b/compiler/GHC/StgToCmm/Prof.hs index 068b768073..86f20a71b9 100644 --- a/compiler/GHC/StgToCmm/Prof.hs +++ b/compiler/GHC/StgToCmm/Prof.hs @@ -36,7 +36,7 @@ import GHC.Cmm.Utils import GHC.Cmm.CLabel import CostCentre -import DynFlags +import GHC.Driver.Session import FastString import Module import Outputable diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs index 22f91518f3..4257f02886 100644 --- a/compiler/GHC/StgToCmm/Ticky.hs +++ b/compiler/GHC/StgToCmm/Ticky.hs @@ -126,7 +126,7 @@ import FastString import Outputable import Util -import DynFlags +import GHC.Driver.Session -- Turgid imports for showTypeCategory import PrelNames diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs index 3611a64f75..310bf70a7c 100644 --- a/compiler/GHC/StgToCmm/Utils.hs +++ b/compiler/GHC/StgToCmm/Utils.hs @@ -73,7 +73,7 @@ import Digraph import Util import Unique import UniqSupply (MonadUnique(..)) -import DynFlags +import GHC.Driver.Session import FastString import Outputable import GHC.Types.RepType diff --git a/compiler/GHC/Types/Name/Shape.hs b/compiler/GHC/Types/Name/Shape.hs new file mode 100644 index 0000000000..aa1879220f --- /dev/null +++ b/compiler/GHC/Types/Name/Shape.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE CPP #-} + +module GHC.Types.Name.Shape( + NameShape(..), + emptyNameShape, + mkNameShape, + extendNameShape, + nameShapeExports, + substNameShape, + maybeSubstNameShape, + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Outputable +import GHC.Driver.Types +import Module +import UniqFM +import Avail +import FieldLabel + +import Name +import NameEnv +import TcRnMonad +import Util +import GHC.Iface.Env + +import Control.Monad + +-- Note [NameShape] +-- ~~~~~~~~~~~~~~~~ +-- When we write a declaration in a signature, e.g., data T, we +-- ascribe to it a *name variable*, e.g., {m.T}. This +-- name variable may be substituted with an actual original +-- name when the signature is implemented (or even if we +-- merge the signature with one which reexports this entity +-- from another module). + +-- When we instantiate a signature m with a module M, +-- we also need to substitute over names. To do so, we must +-- compute the *name substitution* induced by the *exports* +-- of the module in question. A NameShape represents +-- such a name substitution for a single module instantiation. +-- The "shape" in the name comes from the fact that the computation +-- of a name substitution is essentially the *shaping pass* from +-- Backpack'14, but in a far more restricted form. + +-- The name substitution for an export list is easy to explain. If we are +-- filling the module variable <m>, given an export N of the form +-- M.n or {m'.n} (where n is an OccName), the induced name +-- substitution is from {m.n} to N. So, for example, if we have +-- A=impl:B, and the exports of impl:B are impl:B.f and +-- impl:C.g, then our name substitution is {A.f} to impl:B.f +-- and {A.g} to impl:C.g + + + + +-- The 'NameShape' type is defined in TcRnTypes, because TcRnTypes +-- needs to refer to NameShape, and having TcRnTypes import +-- NameShape (even by SOURCE) would cause a large number of +-- modules to be pulled into the DynFlags cycle. +{- +data NameShape = NameShape { + ns_mod_name :: ModuleName, + ns_exports :: [AvailInfo], + ns_map :: OccEnv Name + } +-} + +-- NB: substitution functions need 'HscEnv' since they need the name cache +-- to allocate new names if we change the 'Module' of a 'Name' + +-- | Create an empty 'NameShape' (i.e., the renaming that +-- would occur with an implementing module with no exports) +-- for a specific hole @mod_name@. +emptyNameShape :: ModuleName -> NameShape +emptyNameShape mod_name = NameShape mod_name [] emptyOccEnv + +-- | Create a 'NameShape' corresponding to an implementing +-- module for the hole @mod_name@ that exports a list of 'AvailInfo's. +mkNameShape :: ModuleName -> [AvailInfo] -> NameShape +mkNameShape mod_name as = + NameShape mod_name as $ mkOccEnv $ do + a <- as + n <- availName a : availNamesWithSelectors a + return (occName n, n) + +-- | Given an existing 'NameShape', merge it with a list of 'AvailInfo's +-- with Backpack style mix-in linking. This is used solely when merging +-- signatures together: we successively merge the exports of each +-- signature until we have the final, full exports of the merged signature. +-- +-- What makes this operation nontrivial is what we are supposed to do when +-- we want to merge in an export for M.T when we already have an existing +-- export {H.T}. What should happen in this case is that {H.T} should be +-- unified with @M.T@: we've determined a more *precise* identity for the +-- export at 'OccName' @T@. +-- +-- Note that we don't do unrestricted unification: only name holes from +-- @ns_mod_name ns@ are flexible. This is because we have a much more +-- restricted notion of shaping than in Backpack'14: we do shaping +-- *as* we do type-checking. Thus, once we shape a signature, its +-- exports are *final* and we're not allowed to refine them further, +extendNameShape :: HscEnv -> NameShape -> [AvailInfo] -> IO (Either SDoc NameShape) +extendNameShape hsc_env ns as = + case uAvailInfos (ns_mod_name ns) (ns_exports ns) as of + Left err -> return (Left err) + Right nsubst -> do + as1 <- mapM (liftIO . substNameAvailInfo hsc_env nsubst) (ns_exports ns) + as2 <- mapM (liftIO . substNameAvailInfo hsc_env nsubst) as + let new_avails = mergeAvails as1 as2 + return . Right $ ns { + ns_exports = new_avails, + -- TODO: stop repeatedly rebuilding the OccEnv + ns_map = mkOccEnv $ do + a <- new_avails + n <- availName a : availNames a + return (occName n, n) + } + +-- | The export list associated with this 'NameShape' (i.e., what +-- the exports of an implementing module which induces this 'NameShape' +-- would be.) +nameShapeExports :: NameShape -> [AvailInfo] +nameShapeExports = ns_exports + +-- | Given a 'Name', substitute it according to the 'NameShape' implied +-- substitution, i.e. map @{A.T}@ to @M.T@, if the implementing module +-- exports @M.T@. +substNameShape :: NameShape -> Name -> Name +substNameShape ns n | nameModule n == ns_module ns + , Just n' <- lookupOccEnv (ns_map ns) (occName n) + = n' + | otherwise + = n + +-- | Like 'substNameShape', but returns @Nothing@ if no substitution +-- works. +maybeSubstNameShape :: NameShape -> Name -> Maybe Name +maybeSubstNameShape ns n + | nameModule n == ns_module ns + = lookupOccEnv (ns_map ns) (occName n) + | otherwise + = Nothing + +-- | The 'Module' of any 'Name's a 'NameShape' has action over. +ns_module :: NameShape -> Module +ns_module = mkHoleModule . ns_mod_name + +{- +************************************************************************ +* * + Name substitutions +* * +************************************************************************ +-} + +-- | Substitution on @{A.T}@. We enforce the invariant that the +-- 'nameModule' of keys of this map have 'moduleUnitId' @hole@ +-- (meaning that if we have a hole substitution, the keys of the map +-- are never affected.) Alternatively, this is isomorphic to +-- @Map ('ModuleName', 'OccName') 'Name'@. +type ShNameSubst = NameEnv Name + +-- NB: In this module, we actually only ever construct 'ShNameSubst' +-- at a single 'ModuleName'. But 'ShNameSubst' is more convenient to +-- work with. + +-- | Substitute names in a 'Name'. +substName :: ShNameSubst -> Name -> Name +substName env n | Just n' <- lookupNameEnv env n = n' + | otherwise = n + +-- | Substitute names in an 'AvailInfo'. This has special behavior +-- for type constructors, where it is sufficient to substitute the 'availName' +-- to induce a substitution on 'availNames'. +substNameAvailInfo :: HscEnv -> ShNameSubst -> AvailInfo -> IO AvailInfo +substNameAvailInfo _ env (Avail n) = return (Avail (substName env n)) +substNameAvailInfo hsc_env env (AvailTC n ns fs) = + let mb_mod = fmap nameModule (lookupNameEnv env n) + in AvailTC (substName env n) + <$> mapM (initIfaceLoad hsc_env . setNameModule mb_mod) ns + <*> mapM (setNameFieldSelector hsc_env mb_mod) fs + +-- | Set the 'Module' of a 'FieldSelector' +setNameFieldSelector :: HscEnv -> Maybe Module -> FieldLabel -> IO FieldLabel +setNameFieldSelector _ Nothing f = return f +setNameFieldSelector hsc_env mb_mod (FieldLabel l b sel) = do + sel' <- initIfaceLoad hsc_env $ setNameModule mb_mod sel + return (FieldLabel l b sel') + +{- +************************************************************************ +* * + AvailInfo merging +* * +************************************************************************ +-} + +-- | Merges to 'AvailInfo' lists together, assuming the 'AvailInfo's have +-- already been unified ('uAvailInfos'). +mergeAvails :: [AvailInfo] -> [AvailInfo] -> [AvailInfo] +mergeAvails as1 as2 = + let mkNE as = mkNameEnv [(availName a, a) | a <- as] + in nameEnvElts (plusNameEnv_C plusAvail (mkNE as1) (mkNE as2)) + +{- +************************************************************************ +* * + AvailInfo unification +* * +************************************************************************ +-} + +-- | Unify two lists of 'AvailInfo's, given an existing substitution @subst@, +-- with only name holes from @flexi@ unifiable (all other name holes rigid.) +uAvailInfos :: ModuleName -> [AvailInfo] -> [AvailInfo] -> Either SDoc ShNameSubst +uAvailInfos flexi as1 as2 = -- pprTrace "uAvailInfos" (ppr as1 $$ ppr as2) $ + let mkOE as = listToUFM $ do a <- as + n <- availNames a + return (nameOccName n, a) + in foldM (\subst (a1, a2) -> uAvailInfo flexi subst a1 a2) emptyNameEnv + (eltsUFM (intersectUFM_C (,) (mkOE as1) (mkOE as2))) + -- Edward: I have to say, this is pretty clever. + +-- | Unify two 'AvailInfo's, given an existing substitution @subst@, +-- with only name holes from @flexi@ unifiable (all other name holes rigid.) +uAvailInfo :: ModuleName -> ShNameSubst -> AvailInfo -> AvailInfo + -> Either SDoc ShNameSubst +uAvailInfo flexi subst (Avail n1) (Avail n2) = uName flexi subst n1 n2 +uAvailInfo flexi subst (AvailTC n1 _ _) (AvailTC n2 _ _) = uName flexi subst n1 n2 +uAvailInfo _ _ a1 a2 = Left $ text "While merging export lists, could not combine" + <+> ppr a1 <+> text "with" <+> ppr a2 + <+> parens (text "one is a type, the other is a plain identifier") + +-- | Unify two 'Name's, given an existing substitution @subst@, +-- with only name holes from @flexi@ unifiable (all other name holes rigid.) +uName :: ModuleName -> ShNameSubst -> Name -> Name -> Either SDoc ShNameSubst +uName flexi subst n1 n2 + | n1 == n2 = Right subst + | isFlexi n1 = uHoleName flexi subst n1 n2 + | isFlexi n2 = uHoleName flexi subst n2 n1 + | otherwise = Left (text "While merging export lists, could not unify" + <+> ppr n1 <+> text "with" <+> ppr n2 $$ extra) + where + isFlexi n = isHoleName n && moduleName (nameModule n) == flexi + extra | isHoleName n1 || isHoleName n2 + = text "Neither name variable originates from the current signature." + | otherwise + = empty + +-- | Unify a name @h@ which 'isHoleName' with another name, given an existing +-- substitution @subst@, with only name holes from @flexi@ unifiable (all +-- other name holes rigid.) +uHoleName :: ModuleName -> ShNameSubst -> Name {- hole name -} -> Name + -> Either SDoc ShNameSubst +uHoleName flexi subst h n = + ASSERT( isHoleName h ) + case lookupNameEnv subst h of + Just n' -> uName flexi subst n' n + -- Do a quick check if the other name is substituted. + Nothing | Just n' <- lookupNameEnv subst n -> + ASSERT( isHoleName n ) uName flexi subst h n' + | otherwise -> + Right (extendNameEnv subst h n) |