diff options
| author | Edward Z. Yang <ezyang@cs.stanford.edu> | 2015-10-10 12:01:14 -0700 |
|---|---|---|
| committer | Edward Z. Yang <ezyang@cs.stanford.edu> | 2016-10-08 00:20:34 -0700 |
| commit | 00b530d5402aaa37e4085ecdcae0ae54454736c1 (patch) | |
| tree | 2d2963db4abdbcba9c12aea13a26e29e718e4778 /compiler | |
| parent | 887485a45ae55e81b26b6412b6f9dcf6a497f044 (diff) | |
| download | haskell-00b530d5402aaa37e4085ecdcae0ae54454736c1.tar.gz | |
The Backpack patch.
Summary:
This patch implements Backpack for GHC. It's a big patch but I've tried quite
hard to keep things, by-in-large, self-contained.
The user facing specification for Backpack can be found at:
https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst
A guide to the implementation can be found at:
https://github.com/ezyang/ghc-proposals/blob/backpack-impl/proposals/0000-backpack-impl.rst
Has a submodule update for Cabal, as well as a submodule update
for filepath to handle more strict checking of cabal-version.
Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>
Test Plan: validate
Reviewers: simonpj, austin, simonmar, bgamari, goldfire
Subscribers: thomie, mpickering
Differential Revision: https://phabricator.haskell.org/D1482
Diffstat (limited to 'compiler')
40 files changed, 4357 insertions, 588 deletions
diff --git a/compiler/backpack/BkpSyn.hs b/compiler/backpack/BkpSyn.hs new file mode 100644 index 0000000000..ae03324b34 --- /dev/null +++ b/compiler/backpack/BkpSyn.hs @@ -0,0 +1,77 @@ +-- | This is the syntax for bkp files which are parsed in 'ghc --backpack' +-- mode. This syntax is used purely for testing purposes. + +module BkpSyn ( + -- * Backpack abstract syntax + HsUnitId(..), + LHsUnitId, + HsModuleSubst, + LHsModuleSubst, + HsModuleId(..), + LHsModuleId, + HsComponentId(..), + LHsUnit, HsUnit(..), + LHsUnitDecl, HsUnitDecl(..), + HsDeclType(..), + IncludeDecl(..), + LRenaming, Renaming(..), + ) where + +import HsSyn +import RdrName +import SrcLoc +import Outputable +import Module +import PackageConfig + +{- +************************************************************************ +* * + 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 HsDeclType = ModuleD | SignatureD +data HsUnitDecl n + = DeclD HsDeclType (Located ModuleName) (Maybe (Located (HsModule RdrName))) + | IncludeD (IncludeDecl n) +type LHsUnitDecl n = Located (HsUnitDecl n) + +-- | An include of another unit +data IncludeDecl n = IncludeDecl { + idUnitId :: LHsUnitId n, + idModRenaming :: Maybe [ LRenaming ] + } + +-- | Rename a module from one name to another. The identity renaming +-- means that the module should be brought into scope. +data Renaming = Renaming { renameFrom :: ModuleName, renameTo :: ModuleName } +type LRenaming = Located Renaming diff --git a/compiler/backpack/DriverBkp.hs b/compiler/backpack/DriverBkp.hs new file mode 100644 index 0000000000..25d2d9252a --- /dev/null +++ b/compiler/backpack/DriverBkp.hs @@ -0,0 +1,777 @@ +{-# 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 DriverBkp (doBackpack) where + +#include "HsVersions.h" + +-- In a separate module because it hooks into the parser. +import BkpSyn + +import GHC hiding (Failed, Succeeded) +import Packages +import Parser +import Lexer +import GhcMonad +import DynFlags +import TcRnMonad +import TcRnDriver +import Module +import HscTypes +import StringBuffer +import FastString +import ErrUtils +import SrcLoc +import HscMain +import UniqFM +import UniqDFM +import Outputable +import Maybes +import HeaderInfo +import MkIface +import GhcMake +import UniqDSet +import PrelNames +import BasicTypes hiding (SuccessFlag(..)) +import Finder +import Util + +import qualified GHC.LanguageExtensions as LangExt + +import Data.List +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 / DriverPipeline + 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 span err -> do + liftIO $ throwOneError (mkPlainErrMsg dflags span err) + 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 + +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 SignatureD (L _ modname) _) = unitUniqDSet modname + get_reqs (DeclD ModuleD _ _) = emptyUniqDSet + get_reqs (IncludeD (IncludeDecl (L _ hsuid) _)) = + unitIdFreeHoles (convertHsUnitId hsuid) + +-- | Tiny enum for all types of Backpack operations we may do. +data SessionType = ExeSession | TcSession | 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`. + (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 = insts, + thisPackage = + case session_type of + TcSession -> newUnitId cid insts + -- No hash passed if no instances + _ | null insts -> newSimpleUnitId cid + | otherwise -> newHashedUnitId 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, + -- Synthesized the flags + packageFlags = packageFlags dflags ++ map (\(uid0, rn) -> + let uid = unwireUnitId dflags (improveUnitId (getPackageConfigMap 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 (unitIdComponentId mainUnitId) [] 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 + +-- Invariant: this NEVER returns HashedUnitId +hsunitDeps :: HsUnit HsComponentId -> [(UnitId, ModRenaming)] +hsunitDeps unit = concatMap get_dep (hsunitBody unit) + where + get_dep (L _ (IncludeD (IncludeDecl (L _ hsuid) mb_lrn))) = [(convertHsUnitId hsuid, go mb_lrn)] + where go Nothing = ModRenaming True [] + go (Just lrns) = ModRenaming False (map convRn lrns) + where convRn (L _ (Renaming from to)) = (from, to) + get_dep _ = [] + +buildUnit :: SessionType -> ComponentId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM () +buildUnit session cid insts lunit = do + let deps_w_rns = hsunitDeps (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 GhcMake!! + forM_ (zip [1..] deps0) $ \(i, dep) -> + case session of + TcSession -> return () + _ -> compileInclude (length deps0) (i, dep) + + dflags <- getDynFlags + -- IMPROVE IT + let deps = map (improveUnitId (getPackageConfigMap 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 <- 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) + cand_compat_pn = PackageName compat_fs + compat_pn = case session of + TcSession -> cand_compat_pn + _ | [] <- insts -> cand_compat_pn + | otherwise -> PackageName compat_fs + + return InstalledPackageInfo { + -- Stub data + abiHash = "", + sourcePackageId = SourcePackageId compat_fs, + packageName = compat_pn, + packageVersion = makeVersion [0], + unitId = thisPackage dflags, + 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 (unwireUnitId dflags) + $ deps ++ [ moduleUnitId mod + | (_, mod) <- insts + , not (isHoleModule mod) ], + ldOptions = case session of + TcSession -> [] + _ -> obj_files, + importDirs = [ hi_dir ], + exposed = False, + -- nope + hsLibraries = [], + extraLibraries = [], + extraGHCiLibraries = [], + 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 (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)) + +addPackage :: GhcMonad m => PackageConfig -> m () +addPackage pkg = do + dflags0 <- GHC.getSessionDynFlags + case pkgDatabase dflags0 of + Nothing -> panic "addPackage: called too early" + Just pkgs -> do let dflags = dflags0 { pkgDatabase = + Just (pkgs ++ [("(in memory " ++ showSDoc dflags0 (ppr (unitId pkg)) ++ ")", [pkg])]) } + _ <- GHC.setSessionDynFlags dflags + -- By this time, the global ref has probably already + -- been forced, in which case doing this isn't actually + -- going to do you any good. + -- dflags <- GHC.getSessionDynFlags + -- liftIO $ setUnsafeGlobalDynFlags dflags + return () + +-- Precondition: UnitId is NOT HashedUnitId +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 lookupPackage dflags uid of + Nothing -> do + case splitUnitIdInsts uid of + (_, Just insts) -> + innerBkpM $ compileUnit (unitIdComponentId uid) insts + _ -> 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 :: PprStyle +backpackStyle = + mkUserStyle + (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 dflags (ppr pk) backpackStyle + +-- | 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 dflags (ppr uid) backpackStyle + +-- ---------------------------------------------------------------------------- +-- 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 + } + + 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 GhcMake.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 GhcMake 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 dt lmodname mb_hsmod)) = do + let hsc_src = case dt of + ModuleD -> HsSrcFile + SignatureD -> HsigFile + 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 (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) + 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_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 = (Map.empty, 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 RdrName)) + -> 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) -> throwOneError 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 RdrName) + -> BkpM ModSummary +hsModuleToModSummary pn hsc_src modname + hsmod@(L loc (HsModule _ _ imps _ _ _)) = do + hsc_env <- getSession + -- Sort of the same deal as in DriverPipeline'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 -> addBootSuffixLocn location0 + _ -> location0 + -- This duplicates a pile of logic in GhcMake + env <- getBkpEnv + time <- liftIO $ getModificationUTCTime (bkp_filename env) + hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_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 = (Map.empty, 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 + } diff --git a/compiler/backpack/NameShape.hs b/compiler/backpack/NameShape.hs new file mode 100644 index 0000000000..568d700b94 --- /dev/null +++ b/compiler/backpack/NameShape.hs @@ -0,0 +1,281 @@ +{-# LANGUAGE CPP #-} + +module NameShape( + NameShape(..), + emptyNameShape, + mkNameShape, + extendNameShape, + nameShapeExports, + substNameShape, + ) where + +#include "HsVersions.h" + +import Outputable +import HscTypes +import Module +import UniqFM +import Avail +import FieldLabel + +import Name +import NameEnv +import TcRnMonad +import Util +import ListSetOps +import IfaceEnv + +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 : availNames 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 + +-- | 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.) Alternately, this is ismorphic 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 p n) = return (Avail p (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)) + +-- | Join two 'AvailInfo's together. +plusAvail :: AvailInfo -> AvailInfo -> AvailInfo +plusAvail a1 a2 + | debugIsOn && availName a1 /= availName a2 + = pprPanic "RnEnv.plusAvail names differ" (hsep [ppr a1,ppr a2]) +plusAvail a1@(Avail {}) (Avail {}) = a1 +plusAvail (AvailTC _ [] []) a2@(AvailTC {}) = a2 +plusAvail a1@(AvailTC {}) (AvailTC _ [] []) = a1 +plusAvail (AvailTC n1 (s1:ss1) fs1) (AvailTC n2 (s2:ss2) fs2) + = case (n1==s1, n2==s2) of -- Maintain invariant the parent is first + (True,True) -> AvailTC n1 (s1 : (ss1 `unionLists` ss2)) + (fs1 `unionLists` fs2) + (True,False) -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2))) + (fs1 `unionLists` fs2) + (False,True) -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2)) + (fs1 `unionLists` fs2) + (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2)) + (fs1 `unionLists` fs2) +plusAvail (AvailTC n1 ss1 fs1) (AvailTC _ [] fs2) + = AvailTC n1 ss1 (fs1 `unionLists` fs2) +plusAvail (AvailTC n1 [] fs1) (AvailTC _ ss2 fs2) + = AvailTC n1 ss2 (fs1 `unionLists` fs2) +plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2]) + +{- +************************************************************************ +* * + 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) diff --git a/compiler/backpack/RnModIface.hs b/compiler/backpack/RnModIface.hs new file mode 100644 index 0000000000..536f0b03ef --- /dev/null +++ b/compiler/backpack/RnModIface.hs @@ -0,0 +1,614 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} + +-- | This module implements interface renaming, which is +-- used to rewrite interface files on the fly when we +-- are doing indefinite typechecking and need instantiations +-- of modules which do not necessarily exist yet. + +module RnModIface( + rnModIface, + rnModExports, + ) where + +#include "HsVersions.h" + +import Outputable +import HscTypes +import Module +import UniqFM +import Avail +import IfaceSyn +import FieldLabel +import Var + +import Name +import TcRnMonad +import Util +import Fingerprint +import BasicTypes + +-- a bit vexing +import {-# SOURCE #-} LoadIface +import DynFlags + +import qualified Data.Traversable as T + +import NameShape +import IfaceEnv + +-- | What we have a generalized ModIface, which corresponds to +-- a module that looks like p[A=<A>]:B. We need a *specific* ModIface, e.g. +-- p[A=q():A]:B (or maybe even p[A=<B>]:B) which we load +-- up (either to merge it, or to just use during typechecking). +-- +-- Suppose we have: +-- +-- p[A=<A>]:M ==> p[A=q():A]:M +-- +-- Substitute all occurrences of <A> with q():A (renameHoleModule). +-- Then, for any Name of form {A.T}, replace the Name with +-- the Name according to the exports of the implementing module. +-- This works even for p[A=<B>]:M, since we just read in the +-- exports of B.hi, which is assumed to be ready now. +-- +-- This function takes an optional 'NameShape', which can be used +-- to further refine the identities in this interface: suppose +-- we read a declaration for {H.T} but we actually know that this +-- should be Foo.T; then we'll also rename this (this is used +-- when loading an interface to merge it into a requirement.) +rnModIface :: HscEnv -> [(ModuleName, Module)] -> Maybe NameShape + -> ModIface -> IO ModIface +rnModIface hsc_env insts nsubst iface = do + initRnIface hsc_env iface insts nsubst $ do + mod <- rnModule (mi_module iface) + sig_of <- case mi_sig_of iface of + Nothing -> return Nothing + Just x -> fmap Just (rnModule x) + exports <- mapM rnAvailInfo (mi_exports iface) + decls <- mapM rnIfaceDecl' (mi_decls iface) + insts <- mapM rnIfaceClsInst (mi_insts iface) + fams <- mapM rnIfaceFamInst (mi_fam_insts iface) + -- TODO: + -- mi_rules + -- mi_vect_info (LOW PRIORITY) + return iface { mi_module = mod + , mi_sig_of = sig_of + , mi_insts = insts + , mi_fam_insts = fams + , mi_exports = exports + , mi_decls = decls } + +-- | Rename just the exports of a 'ModIface'. Useful when we're doing +-- shaping prior to signature merging. +rnModExports :: HscEnv -> [(ModuleName, Module)] -> ModIface -> IO [AvailInfo] +rnModExports hsc_env insts iface + = initRnIface hsc_env iface insts Nothing + $ mapM rnAvailInfo (mi_exports iface) + +{- +************************************************************************ +* * + ModIface substitution +* * +************************************************************************ +-} + +-- | Initialize the 'ShIfM' monad. +initRnIface :: HscEnv -> ModIface -> [(ModuleName, Module)] -> Maybe NameShape + -> ShIfM a -> IO a +initRnIface hsc_env iface insts nsubst do_this = + let hsubst = listToUFM insts + rn_mod = renameHoleModule (hsc_dflags hsc_env) hsubst + env = ShIfEnv { + sh_if_module = rn_mod (mi_module iface), + sh_if_semantic_module = rn_mod (mi_semantic_module iface), + sh_if_hole_subst = listToUFM insts, + sh_if_shape = nsubst + } + in initTcRnIf 'c' hsc_env env () do_this + +-- | Environment for 'ShIfM' monads. +data ShIfEnv = ShIfEnv { + -- What we are renaming the ModIface to. It assumed that + -- the original mi_module of the ModIface is + -- @generalizeModule (mi_module iface)@. + sh_if_module :: Module, + -- The semantic module that we are renaming to + sh_if_semantic_module :: Module, + -- Cached hole substitution, e.g. + -- @sh_if_hole_subst == listToUFM . unitIdInsts . moduleUnitId . sh_if_module@ + sh_if_hole_subst :: ShHoleSubst, + -- An optional name substitution to be applied when renaming + -- the names in the interface. If this is 'Nothing', then + -- we just load the target interface and look at the export + -- list to determine the renaming. + sh_if_shape :: Maybe NameShape + } + +getHoleSubst :: ShIfM ShHoleSubst +getHoleSubst = fmap sh_if_hole_subst getGblEnv + +type ShIfM = TcRnIf ShIfEnv () +type Rename a = a -> ShIfM a + + +rnModule :: Rename Module +rnModule mod = do + hmap <- getHoleSubst + dflags <- getDynFlags + return (renameHoleModule dflags hmap mod) + +rnAvailInfo :: Rename AvailInfo +rnAvailInfo (Avail p n) = Avail p <$> rnIfaceGlobal n +rnAvailInfo (AvailTC n ns fs) = do + -- Why don't we rnIfaceGlobal the availName itself? It may not + -- actually be exported by the module it putatively is from, in + -- which case we won't be able to tell what the name actually + -- is. But for the availNames they MUST be exported, so they + -- will rename fine. + ns' <- mapM rnIfaceGlobal ns + fs' <- mapM rnFieldLabel fs + case ns' ++ map flSelector fs' of + [] -> panic "rnAvailInfoEmpty AvailInfo" + (rep:rest) -> ASSERT2( all ((== nameModule rep) . nameModule) rest, ppr rep $$ hcat (map ppr rest) ) do + n' <- setNameModule (Just (nameModule rep)) n + return (AvailTC n' ns' fs') + +rnFieldLabel :: Rename FieldLabel +rnFieldLabel (FieldLabel l b sel) = do + sel' <- rnIfaceGlobal sel + return (FieldLabel l b sel') + + + + +-- | The key function. This gets called on every Name embedded +-- inside a ModIface. Our job is to take a Name from some +-- generalized unit ID p[A=<A>, B=<B>], and change +-- it to the correct name for a (partially) instantiated unit +-- ID, e.g. p[A=q[]:A, B=<B>]. +-- +-- There are two important things to do: +-- +-- If a hole is substituted with a real module implementation, +-- we need to look at that actual implementation to determine what +-- the true identity of this name should be. We'll do this by +-- loading that module's interface and looking at the mi_exports. +-- +-- However, there is one special exception: when we are loading +-- the interface of a requirement. In this case, we may not have +-- the "implementing" interface, because we are reading this +-- interface precisely to "merge it in". +-- +-- External case: +-- p[A=<B>]:A (and thisUnitId is something else) +-- We are loading this in order to determine B.hi! So +-- don't load B.hi to find the exports. +-- +-- Local case: +-- p[A=<A>]:A (and thisUnitId is p[A=<A>]) +-- This should not happen, because the rename is not necessary +-- in this case, but if it does we shouldn't load A.hi! +-- +-- Compare me with 'tcIfaceGlobal'! + +-- In effect, this function needs compute the name substitution on the +-- fly. What it has is the name that we would like to substitute. +-- If the name is not a hole name {M.x} (e.g. isHoleModule) then +-- no renaming can take place (although the inner hole structure must +-- be updated to account for the hole module renaming.) +rnIfaceGlobal :: Name -> ShIfM Name +rnIfaceGlobal n = do + hsc_env <- getTopEnv + let dflags = hsc_dflags hsc_env + iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv + mb_nsubst <- fmap sh_if_shape getGblEnv + hmap <- getHoleSubst + let m = nameModule n + m' = renameHoleModule dflags hmap m + case () of + -- Did we encounter {A.T} while renaming p[A=<B>]:A? If so, + -- do NOT assume B.hi is available. + -- In this case, rename {A.T} to {B.T} but don't look up exports. + _ | m' == iface_semantic_mod + , isHoleModule m' + -- NB: this could be Nothing for computeExports, we have + -- nothing to say. + -> do fmap (case mb_nsubst of + Nothing -> id + Just nsubst -> substNameShape nsubst) + $ setNameModule (Just m') n + -- Fastpath: we are renaming p[H=<H>]:A.T, in which case the + -- export list is irrelevant. + | not (isHoleModule m) + -> setNameModule (Just m') n + -- The substitution was from <A> to p[]:A. + -- But this does not mean {A.T} goes to p[]:A.T: + -- p[]:A may reexport T from somewhere else. Do the name + -- substitution. Furthermore, we need + -- to make sure we pick the accurate name NOW, + -- or we might accidentally reject a merge. + | otherwise + -> do -- Make sure we look up the local interface if substitution + -- went from <A> to <B>. + let m'' = if isHoleModule m' + -- Pull out the local guy!! + then mkModule (thisPackage dflags) (moduleName m') + else m' + iface <- liftIO . initIfaceCheck (text "rnIfaceGlobal") hsc_env + $ loadSysInterface (text "rnIfaceGlobal") m'' + let nsubst = mkNameShape (moduleName m) (mi_exports iface) + return (substNameShape nsubst n) + +-- PILES AND PILES OF BOILERPLATE + +-- | Rename an 'IfaceClsInst', with special handling for an associated +-- dictionary function. +rnIfaceClsInst :: Rename IfaceClsInst +rnIfaceClsInst cls_inst = do + n <- rnIfaceGlobal (ifInstCls cls_inst) + tys <- mapM rnMaybeIfaceTyCon (ifInstTys cls_inst) + + hmap <- getHoleSubst + dflags <- getDynFlags + + -- Note [Bogus DFun renamings] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Every 'IfaceClsInst' is associated with a DFun; in fact, when + -- we are typechecking only, it is the ONLY place a DFun Id + -- can appear. This DFun must refer to a DFun that is defined + -- elsewhere in the 'ModIface'. + -- + -- Unfortunately, DFuns are not exported (don't appear in + -- mi_exports), so we can't look at the exports (as we do in + -- rnIfaceGlobal) to rename it. + -- + -- We have to rename it to *something*. So what we do depends + -- on the situation: + -- + -- * If the instance wasn't defined in a signature, the DFun + -- have a name like p[A=<A>]:B.$fShowFoo. This is the + -- easy case: just apply the module substitution to the + -- unit id and go our merry way. + -- + -- * If the instance was defined in a signature, we are in + -- an interesting situation. Suppose we are instantiating + -- the signature: + -- + -- signature H where + -- instance F T -- {H.$fxFT} + -- module H where + -- instance F T where ... -- p[]:H.$fFT + -- + -- In an ideal world, we would map {H.$fxFT} to p[]:H.$fFT. + -- But we have no idea what the correct DFun is: the OccNames + -- don't match up. Nor do we really want to wire up {H.$fxFT} + -- to p[]:H.$fFT: we'd rather have it point at the DFun + -- from the *signature's* interface, and use that type to + -- find the actual instance we want to compare against. + -- + -- So, to handle this case, we have to do several things: + -- + -- * In 'rnIfaceClsInst', we just blindly rename the + -- the identifier to something that looks vaguely plausible. + -- In the instantiating case, we just map {H.$fxFT} + -- to p[]:H.$fxFT. In the merging case, we map + -- {H.$fxFT} to {H2.$fxFT}. + -- + -- * In 'lookupIfaceTop', we arrange for the top-level DFun + -- to be assigned the very same identifier we picked + -- during renaming (p[]:H.$fxFT) + -- + -- * Finally, in 'tcIfaceInstWithDFunTypeEnv', we make sure + -- to grab the correct 'TyThing' for the DFun directly + -- from the local type environment (which was constructed + -- using 'Name's from 'lookupIfaceTop'). + -- + -- It's all a bit of a giant Rube Goldberg machine, but it + -- seems to work! Note that the name we pick here doesn't + -- really matter, since we throw it out shortly after + -- (for merging, we rename all of the DFuns so that they + -- are unique; for instantiation, the final interface never + -- mentions DFuns since they are implicitly exported.) The + -- important thing is that it's consistent everywhere. + + iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv + let m = renameHoleModule dflags hmap $ nameModule (ifDFun cls_inst) + -- Doublecheck that this DFun was, indeed, locally defined. + MASSERT2( iface_semantic_mod == m, ppr iface_semantic_mod <+> ppr m ) + dfun <- setNameModule (Just m) (ifDFun cls_inst) + return cls_inst { ifInstCls = n + , ifInstTys = tys + , ifDFun = dfun + } + +rnMaybeIfaceTyCon :: Rename (Maybe IfaceTyCon) +rnMaybeIfaceTyCon Nothing = return Nothing +rnMaybeIfaceTyCon (Just tc) = Just <$> rnIfaceTyCon tc + +rnIfaceFamInst :: Rename IfaceFamInst +rnIfaceFamInst d = do + fam <- rnIfaceGlobal (ifFamInstFam d) + tys <- mapM rnMaybeIfaceTyCon (ifFamInstTys d) + axiom <- rnIfaceGlobal (ifFamInstAxiom d) + return d { ifFamInstFam = fam, ifFamInstTys = tys, ifFamInstAxiom = axiom } + +rnIfaceDecl' :: Rename (Fingerprint, IfaceDecl) +rnIfaceDecl' (fp, decl) = (,) fp <$> rnIfaceDecl decl + +rnIfaceDecl :: Rename IfaceDecl +rnIfaceDecl d@IfaceId{} = do + ty <- rnIfaceType (ifType d) + details <- rnIfaceIdDetails (ifIdDetails d) + info <- rnIfaceIdInfo (ifIdInfo d) + return d { ifType = ty + , ifIdDetails = details + , ifIdInfo = info + } +rnIfaceDecl d@IfaceData{} = do + binders <- mapM rnIfaceTyConBinder (ifBinders d) + ctxt <- mapM rnIfaceType (ifCtxt d) + cons <- rnIfaceConDecls (ifCons d) + parent <- rnIfaceTyConParent (ifParent d) + return d { ifBinders = binders + , ifCtxt = ctxt + , ifCons = cons + , ifParent = parent + } +rnIfaceDecl d@IfaceSynonym{} = do + binders <- mapM rnIfaceTyConBinder (ifBinders d) + syn_kind <- rnIfaceType (ifResKind d) + syn_rhs <- rnIfaceType (ifSynRhs d) + return d { ifBinders = binders + , ifResKind = syn_kind + , ifSynRhs = syn_rhs + } +rnIfaceDecl d@IfaceFamily{} = do + binders <- mapM rnIfaceTyConBinder (ifBinders d) + fam_kind <- rnIfaceType (ifResKind d) + fam_flav <- rnIfaceFamTyConFlav (ifFamFlav d) + return d { ifBinders = binders + , ifResKind = fam_kind + , ifFamFlav = fam_flav + } +rnIfaceDecl d@IfaceClass{} = do + ctxt <- mapM rnIfaceType (ifCtxt d) + binders <- mapM rnIfaceTyConBinder (ifBinders d) + ats <- mapM rnIfaceAT (ifATs d) + sigs <- mapM rnIfaceClassOp (ifSigs d) + return d { ifCtxt = ctxt + , ifBinders = binders + , ifATs = ats + , ifSigs = sigs + } +rnIfaceDecl d@IfaceAxiom{} = do + tycon <- rnIfaceTyCon (ifTyCon d) + ax_branches <- mapM rnIfaceAxBranch (ifAxBranches d) + return d { ifTyCon = tycon + , ifAxBranches = ax_branches + } +rnIfaceDecl d@IfacePatSyn{} = do + let rnPat (n, b) = (,) <$> rnIfaceGlobal n <*> pure b + pat_matcher <- rnPat (ifPatMatcher d) + pat_builder <- T.traverse rnPat (ifPatBuilder d) + pat_univ_bndrs <- mapM rnIfaceForAllBndr (ifPatUnivBndrs d) + pat_ex_bndrs <- mapM rnIfaceForAllBndr (ifPatExBndrs d) + pat_prov_ctxt <- mapM rnIfaceType (ifPatProvCtxt d) + pat_req_ctxt <- mapM rnIfaceType (ifPatReqCtxt d) + pat_args <- mapM rnIfaceType (ifPatArgs d) + pat_ty <- rnIfaceType (ifPatTy d) + return d { ifPatMatcher = pat_matcher + , ifPatBuilder = pat_builder + , ifPatUnivBndrs = pat_univ_bndrs + , ifPatExBndrs = pat_ex_bndrs + , ifPatProvCtxt = pat_prov_ctxt + , ifPatReqCtxt = pat_req_ctxt + , ifPatArgs = pat_args + , ifPatTy = pat_ty + } + +rnIfaceFamTyConFlav :: Rename IfaceFamTyConFlav +rnIfaceFamTyConFlav (IfaceClosedSynFamilyTyCon (Just (n, axs))) + = IfaceClosedSynFamilyTyCon . Just <$> ((,) <$> rnIfaceGlobal n + <*> mapM rnIfaceAxBranch axs) +rnIfaceFamTyConFlav flav = pure flav + +rnIfaceAT :: Rename IfaceAT +rnIfaceAT (IfaceAT decl mb_ty) + = IfaceAT <$> rnIfaceDecl decl <*> T.traverse rnIfaceType mb_ty + +rnIfaceTyConParent :: Rename IfaceTyConParent +rnIfaceTyConParent (IfDataInstance n tc args) + = IfDataInstance <$> rnIfaceGlobal n + <*> rnIfaceTyCon tc + <*> rnIfaceTcArgs args +rnIfaceTyConParent IfNoParent = pure IfNoParent + +rnIfaceConDecls :: Rename IfaceConDecls +rnIfaceConDecls (IfDataTyCon ds b fs) + = IfDataTyCon <$> mapM rnIfaceConDecl ds + <*> return b + <*> return fs +rnIfaceConDecls (IfNewTyCon d b fs) = IfNewTyCon <$> rnIfaceConDecl d <*> return b <*> return fs +rnIfaceConDecls (IfAbstractTyCon b) = pure (IfAbstractTyCon b) + +rnIfaceConDecl :: Rename IfaceConDecl +rnIfaceConDecl d = do + con_ex_tvs <- mapM rnIfaceForAllBndr (ifConExTvs d) + let rnIfConEqSpec (n,t) = (,) n <$> rnIfaceType t + con_eq_spec <- mapM rnIfConEqSpec (ifConEqSpec d) + con_ctxt <- mapM rnIfaceType (ifConCtxt d) + con_arg_tys <- mapM rnIfaceType (ifConArgTys d) + let rnIfaceBang (IfUnpackCo co) = IfUnpackCo <$> rnIfaceCo co + rnIfaceBang bang = pure bang + con_stricts <- mapM rnIfaceBang (ifConStricts d) + return d { ifConExTvs = con_ex_tvs + , ifConEqSpec = con_eq_spec + , ifConCtxt = con_ctxt + , ifConArgTys = con_arg_tys + , ifConStricts = con_stricts + } + +rnIfaceClassOp :: Rename IfaceClassOp +rnIfaceClassOp (IfaceClassOp n ty dm) = IfaceClassOp n <$> rnIfaceType ty <*> rnMaybeDefMethSpec dm + +rnMaybeDefMethSpec :: Rename (Maybe (DefMethSpec IfaceType)) +rnMaybeDefMethSpec (Just (GenericDM ty)) = Just . GenericDM <$> rnIfaceType ty +rnMaybeDefMethSpec mb = return mb + +rnIfaceAxBranch :: Rename IfaceAxBranch +rnIfaceAxBranch d = do + ty_vars <- mapM rnIfaceTvBndr (ifaxbTyVars d) + lhs <- rnIfaceTcArgs (ifaxbLHS d) + rhs <- rnIfaceType (ifaxbRHS d) + return d { ifaxbTyVars = ty_vars + , ifaxbLHS = lhs + , ifaxbRHS = rhs } + +rnIfaceIdInfo :: Rename IfaceIdInfo +rnIfaceIdInfo NoInfo = pure NoInfo +rnIfaceIdInfo (HasInfo is) = HasInfo <$> mapM rnIfaceInfoItem is + +rnIfaceInfoItem :: Rename IfaceInfoItem +rnIfaceInfoItem (HsUnfold lb if_unf) + = HsUnfold lb <$> rnIfaceUnfolding if_unf +rnIfaceInfoItem i + = pure i + +rnIfaceUnfolding :: Rename IfaceUnfolding +rnIfaceUnfolding (IfCoreUnfold stable if_expr) + = IfCoreUnfold stable <$> rnIfaceExpr if_expr +rnIfaceUnfolding (IfCompulsory if_expr) + = IfCompulsory <$> rnIfaceExpr if_expr +rnIfaceUnfolding (IfInlineRule arity unsat_ok boring_ok if_expr) + = IfInlineRule arity unsat_ok boring_ok <$> rnIfaceExpr if_expr +rnIfaceUnfolding (IfDFunUnfold bs ops) + = IfDFunUnfold <$> rnIfaceBndrs bs <*> mapM rnIfaceExpr ops + +rnIfaceExpr :: Rename IfaceExpr +rnIfaceExpr (IfaceLcl name) = pure (IfaceLcl name) +rnIfaceExpr (IfaceExt gbl) = IfaceExt <$> rnIfaceGlobal gbl +rnIfaceExpr (IfaceType ty) = IfaceType <$> rnIfaceType ty +rnIfaceExpr (IfaceCo co) = IfaceCo <$> rnIfaceCo co +rnIfaceExpr (IfaceTuple sort args) = IfaceTuple sort <$> rnIfaceExprs args +rnIfaceExpr (IfaceLam lam_bndr expr) + = IfaceLam <$> rnIfaceLamBndr lam_bndr <*> rnIfaceExpr expr +rnIfaceExpr (IfaceApp fun arg) + = IfaceApp <$> rnIfaceExpr fun <*> rnIfaceExpr arg +rnIfaceExpr (IfaceCase scrut case_bndr alts) + = IfaceCase <$> rnIfaceExpr scrut + <*> pure case_bndr + <*> mapM rnIfaceAlt alts +rnIfaceExpr (IfaceECase scrut ty) + = IfaceECase <$> rnIfaceExpr scrut <*> rnIfaceType ty +rnIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body) + = IfaceLet <$> (IfaceNonRec <$> rnIfaceLetBndr bndr <*> rnIfaceExpr rhs) + <*> rnIfaceExpr body +rnIfaceExpr (IfaceLet (IfaceRec pairs) body) + = IfaceLet <$> (IfaceRec <$> mapM (\(bndr, rhs) -> + (,) <$> rnIfaceLetBndr bndr + <*> rnIfaceExpr rhs) pairs) + <*> rnIfaceExpr body +rnIfaceExpr (IfaceCast expr co) + = IfaceCast <$> rnIfaceExpr expr <*> rnIfaceCo co +rnIfaceExpr (IfaceLit lit) = pure (IfaceLit lit) +rnIfaceExpr (IfaceFCall cc ty) = IfaceFCall cc <$> rnIfaceType ty +rnIfaceExpr (IfaceTick tickish expr) = IfaceTick tickish <$> rnIfaceExpr expr + +rnIfaceBndrs :: Rename [IfaceBndr] +rnIfaceBndrs = mapM rnIfaceBndr + +rnIfaceBndr :: Rename IfaceBndr +rnIfaceBndr (IfaceIdBndr (fs, ty)) = IfaceIdBndr <$> ((,) fs <$> rnIfaceType ty) +rnIfaceBndr (IfaceTvBndr tv_bndr) = IfaceIdBndr <$> rnIfaceTvBndr tv_bndr + +rnIfaceTvBndr :: Rename IfaceTvBndr +rnIfaceTvBndr (fs, kind) = (,) fs <$> rnIfaceType kind + +rnIfaceTyConBinder :: Rename IfaceTyConBinder +rnIfaceTyConBinder (TvBndr tv vis) = TvBndr <$> rnIfaceTvBndr tv <*> pure vis + +rnIfaceAlt :: Rename IfaceAlt +rnIfaceAlt (conalt, names, rhs) + = (,,) <$> rnIfaceConAlt conalt <*> pure names <*> rnIfaceExpr rhs + +rnIfaceConAlt :: Rename IfaceConAlt +rnIfaceConAlt (IfaceDataAlt data_occ) = IfaceDataAlt <$> rnIfaceGlobal data_occ +rnIfaceConAlt alt = pure alt + +rnIfaceLetBndr :: Rename IfaceLetBndr +rnIfaceLetBndr (IfLetBndr fs ty info) + = IfLetBndr fs <$> rnIfaceType ty <*> rnIfaceIdInfo info + +rnIfaceLamBndr :: Rename IfaceLamBndr +rnIfaceLamBndr (bndr, oneshot) = (,) <$> rnIfaceBndr bndr <*> pure oneshot + +rnIfaceCo :: Rename IfaceCoercion +rnIfaceCo (IfaceReflCo role ty) = IfaceReflCo role <$> rnIfaceType ty +rnIfaceCo (IfaceFunCo role co1 co2) + = IfaceFunCo role <$> rnIfaceCo co1 <*> rnIfaceCo co2 +rnIfaceCo (IfaceTyConAppCo role tc cos) + = IfaceTyConAppCo role <$> rnIfaceTyCon tc <*> mapM rnIfaceCo cos +rnIfaceCo (IfaceAppCo co1 co2) + = IfaceAppCo <$> rnIfaceCo co1 <*> rnIfaceCo co2 +rnIfaceCo (IfaceForAllCo bndr co1 co2) + = IfaceForAllCo <$> rnIfaceTvBndr bndr <*> rnIfaceCo co1 <*> rnIfaceCo co2 +rnIfaceCo (IfaceCoVarCo lcl) = IfaceCoVarCo <$> pure lcl +rnIfaceCo (IfaceAxiomInstCo n i cs) + = IfaceAxiomInstCo <$> rnIfaceGlobal n <*> pure i <*> mapM rnIfaceCo cs +rnIfaceCo (IfaceUnivCo s r t1 t2) + = IfaceUnivCo s r <$> rnIfaceType t1 <*> rnIfaceType t2 +rnIfaceCo (IfaceSymCo c) + = IfaceSymCo <$> rnIfaceCo c +rnIfaceCo (IfaceTransCo c1 c2) + = IfaceTransCo <$> rnIfaceCo c1 <*> rnIfaceCo c2 +rnIfaceCo (IfaceInstCo c1 c2) + = IfaceInstCo <$> rnIfaceCo c1 <*> rnIfaceCo c2 +rnIfaceCo (IfaceNthCo d c) = IfaceNthCo d <$> rnIfaceCo c +rnIfaceCo (IfaceLRCo lr c) = IfaceLRCo lr <$> rnIfaceCo c +rnIfaceCo (IfaceSubCo c) = IfaceSubCo <$> rnIfaceCo c +rnIfaceCo (IfaceAxiomRuleCo ax cos) + = IfaceAxiomRuleCo ax <$> mapM rnIfaceCo cos +rnIfaceCo (IfaceKindCo c) = IfaceKindCo <$> rnIfaceCo c +rnIfaceCo (IfaceCoherenceCo c1 c2) = IfaceCoherenceCo <$> rnIfaceCo c1 <*> rnIfaceCo c2 + +rnIfaceTyCon :: Rename IfaceTyCon +rnIfaceTyCon (IfaceTyCon n info) + = IfaceTyCon <$> rnIfaceGlobal n <*> pure info + +rnIfaceExprs :: Rename [IfaceExpr] +rnIfaceExprs = mapM rnIfaceExpr + +rnIfaceIdDetails :: Rename IfaceIdDetails +rnIfaceIdDetails (IfRecSelId (Left tc) b) = IfRecSelId <$> fmap Left (rnIfaceTyCon tc) <*> pure b +rnIfaceIdDetails (IfRecSelId (Right decl) b) = IfRecSelId <$> fmap Right (rnIfaceDecl decl) <*> pure b +rnIfaceIdDetails details = pure details + +rnIfaceType :: Rename IfaceType +rnIfaceType (IfaceTyVar n) = pure (IfaceTyVar n) +rnIfaceType (IfaceAppTy t1 t2) + = IfaceAppTy <$> rnIfaceType t1 <*> rnIfaceType t2 +rnIfaceType (IfaceLitTy l) = return (IfaceLitTy l) +rnIfaceType (IfaceFunTy t1 t2) + = IfaceFunTy <$> rnIfaceType t1 <*> rnIfaceType t2 +rnIfaceType (IfaceDFunTy t1 t2) + = IfaceDFunTy <$> rnIfaceType t1 <*> rnIfaceType t2 +rnIfaceType (IfaceTupleTy s i tks) + = IfaceTupleTy s i <$> rnIfaceTcArgs tks +rnIfaceType (IfaceTyConApp tc tks) + = IfaceTyConApp <$> rnIfaceTyCon tc <*> rnIfaceTcArgs tks +rnIfaceType (IfaceForAllTy tv t) + = IfaceForAllTy <$> rnIfaceForAllBndr tv <*> rnIfaceType t +rnIfaceType (IfaceCoercionTy co) + = IfaceCoercionTy <$> rnIfaceCo co +rnIfaceType (IfaceCastTy ty co) + = IfaceCastTy <$> rnIfaceType ty <*> rnIfaceCo co + +rnIfaceForAllBndr :: Rename IfaceForAllBndr +rnIfaceForAllBndr (TvBndr tv vis) = TvBndr <$> rnIfaceTvBndr tv <*> pure vis + +rnIfaceTcArgs :: Rename IfaceTcArgs +rnIfaceTcArgs (ITC_Invis t ts) = ITC_Invis <$> rnIfaceType t <*> rnIfaceTcArgs ts +rnIfaceTcArgs (ITC_Vis t ts) = ITC_Vis <$> rnIfaceType t <*> rnIfaceTcArgs ts +rnIfaceTcArgs ITC_Nil = pure ITC_Nil diff --git a/compiler/basicTypes/Module.hs b/compiler/basicTypes/Module.hs index c0e90804ac..7057db019f 100644 --- a/compiler/basicTypes/Module.hs +++ b/compiler/basicTypes/Module.hs @@ -21,18 +21,53 @@ module Module moduleNameString, moduleNameSlashes, moduleNameColons, moduleStableString, + moduleFreeHoles, + moduleIsDefinite, mkModuleName, mkModuleNameFS, stableModuleNameCmp, -- * The UnitId type - UnitId, - fsToUnitId, + ComponentId(..), + UnitId(..), unitIdFS, - stringToUnitId, + unitIdKey, + unitIdComponentId, + IndefUnitId(..), + HashedUnitId(..), + ShHoleSubst, + + unitIdIsDefinite, unitIdString, + unitIdFreeHoles, + + newUnitId, + newIndefUnitId, + newSimpleUnitId, + newHashedUnitId, + hashUnitId, + fsToUnitId, + stringToUnitId, stableUnitIdCmp, + -- * HOLE renaming + renameHoleUnitId, + renameHoleModule, + renameHoleUnitId', + renameHoleModule', + + -- * Generalization + splitModuleInsts, + splitUnitIdInsts, + generalizeIndefUnitId, + + -- * Parsers + parseModuleName, + parseUnitId, + parseComponentId, + parseModuleId, + parseModSubst, + -- * Wired-in UnitIds -- $wired_in_packages primUnitId, @@ -44,7 +79,7 @@ module Module dphParUnitId, mainUnitId, thisGhcUnitId, - holeUnitId, isHoleModule, + isHoleModule, interactiveUnitId, isInteractiveModule, wiredInUnitIds, @@ -53,10 +88,19 @@ module Module moduleUnitId, moduleName, pprModule, mkModule, + mkHoleModule, stableModuleCmp, HasModule(..), ContainsModule(..), + -- * Virgin modules + VirginModule, + VirginUnitId, + VirginModuleEnv, + + -- * Hole module + HoleModule, + -- * The ModuleLocation type ModLocation(..), addBootSuffix, addBootSuffix_maybe, addBootSuffixLocn, @@ -84,17 +128,29 @@ import Outputable import Unique import UniqFM import UniqDFM +import UniqDSet import FastString import Binary import Util import Data.List import Data.Ord -import {-# SOURCE #-} Packages -import GHC.PackageDb (BinaryStringRep(..), DbModuleRep(..), DbModule(..)) - +import GHC.PackageDb (BinaryStringRep(..), DbUnitIdModuleRep(..), DbModule(..), DbUnitId(..)) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BS +import qualified Data.ByteString.Char8 as BS.Char8 +import System.IO.Unsafe +import Foreign.Ptr (castPtr) +import GHC.Fingerprint +import Encoding + +import qualified Text.ParserCombinators.ReadP as Parse +import Text.ParserCombinators.ReadP (ReadP, (<++)) +import Data.Char (isAlphaNum) import Control.DeepSeq import Data.Coerce import Data.Data +import Data.Function import Data.Map (Map) import Data.Set (Set) import qualified Data.Map as Map @@ -102,9 +158,12 @@ import qualified Data.Set as Set import qualified FiniteMap as Map import System.FilePath +import {-# SOURCE #-} DynFlags (DynFlags) +import {-# SOURCE #-} Packages (componentIdString, improveUnitId, PackageConfigMap, getPackageConfigMap) + -- Note [The identifier lexicon] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Package keys, installed package IDs, ABI hashes, package names, +-- Unit IDs, installed package IDs, ABI hashes, package names, -- versions, there are a *lot* of different identifiers for closely -- related things. What do they all mean? Here's what. (See also -- https://ghc.haskell.org/trac/ghc/wiki/Commentary/Packages/Concepts ) @@ -323,12 +382,38 @@ moduleNameColons = dots_to_colons . moduleNameString -} -- | A Module is a pair of a 'UnitId' and a 'ModuleName'. +-- +-- Module variables (i.e. @<H>@) which can be instantiated to a +-- specific module at some later point in time are represented +-- with 'moduleUnitId' set to 'holeUnitId' (this allows us to +-- avoid having to make 'moduleUnitId' a partial operation.) +-- data Module = Module { moduleUnitId :: !UnitId, -- pkg-1.0 moduleName :: !ModuleName -- A.B.C } deriving (Eq, Ord) +-- | Calculate the free holes of a 'Module'. If this set is non-empty, +-- this module was defined in an indefinite library that had required +-- signatures. +-- +-- If a module has free holes, that means that substitutions can operate on it; +-- if it has no free holes, substituting over a module has no effect. +moduleFreeHoles :: Module -> UniqDSet ModuleName +moduleFreeHoles m + | isHoleModule m = unitUniqDSet (moduleName m) + | otherwise = unitIdFreeHoles (moduleUnitId m) + +-- | A 'Module' is definite if it has no free holes. +moduleIsDefinite :: Module -> Bool +moduleIsDefinite = isEmptyUniqDSet . moduleFreeHoles + +-- | Create a module variable at some 'ModuleName'. +-- See Note [Representation of module/name variables] +mkHoleModule :: ModuleName -> Module +mkHoleModule = mkModule holeUnitId + instance Uniquable Module where getUnique (Module p n) = getUnique (unitIdFS p `appendFS` moduleNameFS n) @@ -360,21 +445,20 @@ mkModule :: UnitId -> ModuleName -> Module mkModule = Module pprModule :: Module -> SDoc -pprModule mod@(Module p n) = - pprPackagePrefix p mod <> pprModuleName n - -pprPackagePrefix :: UnitId -> Module -> SDoc -pprPackagePrefix p mod = getPprStyle doc +pprModule mod@(Module p n) = getPprStyle doc where - doc sty - | codeStyle sty = - if p == mainUnitId + doc sty + | codeStyle sty = + (if p == mainUnitId then empty -- never qualify the main package in code - else ztext (zEncodeFS (unitIdFS p)) <> char '_' - | qualModule sty mod = ppr (moduleUnitId mod) <> char ':' - -- the PrintUnqualified tells us which modules have to - -- be qualified with package names - | otherwise = empty + else ztext (zEncodeFS (unitIdFS p)) <> char '_') + <> pprModuleName n + | qualModule sty mod = + if isHoleModule mod + then angleBrackets (pprModuleName n) + else ppr (moduleUnitId mod) <> char ':' <> pprModuleName n + | otherwise = + pprModuleName n class ContainsModule t where extractModule :: t -> Module @@ -382,9 +466,49 @@ class ContainsModule t where class HasModule m where getModule :: m Module -instance DbModuleRep UnitId ModuleName Module where +instance DbUnitIdModuleRep ComponentId UnitId ModuleName Module where fromDbModule (DbModule uid mod_name) = mkModule uid mod_name - toDbModule mod = DbModule (moduleUnitId mod) (moduleName mod) + fromDbModule (DbModuleVar mod_name) = mkHoleModule mod_name + fromDbUnitId (DbUnitId { dbUnitIdComponentId = cid, dbUnitIdInsts = insts }) + = newUnitId cid insts + fromDbUnitId (DbHashedUnitId cid hash) + = newHashedUnitId cid (fmap mkFastStringByteString hash) + -- GHC never writes to the database, so it's not needed + toDbModule = error "toDbModule: not implemented" + toDbUnitId = error "toDbUnitId: not implemented" + +{- +************************************************************************ +* * +\subsection{ComponentId} +* * +************************************************************************ +-} + +-- | A 'ComponentId' consists of the package name, package version, component +-- ID, the transitive dependencies of the component, and other information to +-- uniquely identify the source code and build configuration of a component. +-- +-- This used to be known as an 'InstalledPackageId', but a package can contain +-- multiple components and a 'ComponentId' uniquely identifies a component +-- within a package. When a package only has one component, the 'ComponentId' +-- coincides with the 'InstalledPackageId' +newtype ComponentId = ComponentId FastString deriving (Eq, Ord) + +instance BinaryStringRep ComponentId where + fromStringRep = ComponentId . mkFastStringByteString + toStringRep (ComponentId s) = fastStringToByteString s + +instance Uniquable ComponentId where + getUnique (ComponentId n) = getUnique n + +instance Outputable ComponentId where + ppr cid@(ComponentId fs) = + getPprStyle $ \sty -> + sdocWithDynFlags $ \dflags -> + case componentIdString dflags cid of + Just str | not (debugStyle sty) -> text str + _ -> ftext fs {- ************************************************************************ @@ -394,15 +518,271 @@ instance DbModuleRep UnitId ModuleName Module where ************************************************************************ -} --- | A string which uniquely identifies a package. For wired-in packages, --- it is just the package name, but for user compiled packages, it is a hash. --- ToDo: when the key is a hash, we can do more clever things than store --- the hex representation and hash-cons those strings. -newtype UnitId = PId FastString deriving Eq - -- here to avoid module loops with PackageConfig +-- | A unit identifier uniquely identifies a library (e.g., +-- a package) in GHC. In the absence of Backpack, unit identifiers +-- are just strings ('SimpleUnitId'); however, if a library is +-- parametrized over some signatures, these identifiers need +-- more structure. +data UnitId + = AnIndefUnitId {-# UNPACK #-} !IndefUnitId + | AHashedUnitId {-# UNPACK #-} !HashedUnitId + deriving (Typeable) + +unitIdFS :: UnitId -> FastString +unitIdFS (AnIndefUnitId x) = indefUnitIdFS x +unitIdFS (AHashedUnitId x) = hashedUnitIdFS x + +unitIdKey :: UnitId -> Unique +unitIdKey (AnIndefUnitId x) = indefUnitIdKey x +unitIdKey (AHashedUnitId x) = hashedUnitIdKey x + +unitIdComponentId :: UnitId -> ComponentId +unitIdComponentId (AnIndefUnitId x) = indefUnitIdComponentId x +unitIdComponentId (AHashedUnitId x) = hashedUnitIdComponentId x + +-- | A non-hashed unit identifier identifies an indefinite +-- library (with holes) which has been *on-the-fly* instantiated +-- with a substitution 'unitIdInsts_'. These unit identifiers +-- are recorded in interface files and installed package +-- database entries for indefinite libraries. We can substitute +-- over these identifiers. +-- +-- A non-hashed unit identifier pretty-prints to something like +-- @p[H=<H>,A=aimpl:A>]@ (@p@ is the 'ComponentId', and the +-- brackets enclose the module substitution). +data IndefUnitId + = IndefUnitId { + -- | A private, uniquely identifying representation of + -- a UnitId. This string is completely private to GHC + -- and is just used to get a unique; in particular, we don't use it for + -- symbols (indefinite libraries are not compiled). + indefUnitIdFS :: FastString, + -- | Cached unique of 'unitIdFS'. + indefUnitIdKey :: Unique, + -- | The component identity of the indefinite library that + -- is being instantiated. + indefUnitIdComponentId :: !ComponentId, + -- | The sorted (by 'ModuleName') instantiations of this library. + indefUnitIdInsts :: ![(ModuleName, Module)], + -- | A cache of the free module variables of 'unitIdInsts'. + -- This lets us efficiently tell if a 'UnitId' has been + -- fully instantiated (free module variables are empty) + -- and whether or not a substitution can have any effect. + indefUnitIdFreeHoles :: UniqDSet ModuleName + } deriving (Typeable) + +-- | A hashed unit identifier identifies an indefinite library which has +-- been fully instantiated, compiled and installed to the package database. +-- The ONLY source of hashed unit identifiers is the package database and +-- the @-this-unit-id@ flag: if a non-hashed unit id is substituted into one +-- with no holes, you don't necessarily get a hashed unit id: a hashed unit +-- id means *you have actual code*. To promote a fully instantiated unit +-- identifier into a hashed unit identifier, you have to look it up in the +-- package database. +-- +-- Hashed unit identifiers don't record the full instantiation tree, +-- making them a bit more efficient to work with. This is possible +-- because substituting over a hashed unit id is always a no-op +-- (no free module variables) +-- +-- Hashed unit identifiers look something like @p+af23SAj2dZ219@ +data HashedUnitId = + HashedUnitId { + -- | The full hashed unit identifier, including the component id + -- and the hash. + hashedUnitIdFS :: FastString, + -- | Cached unique of 'unitIdFS'. + hashedUnitIdKey :: Unique, + -- | The component identifier of the hashed unit identifier. + hashedUnitIdComponentId :: !ComponentId + } + deriving (Typeable) + +instance Eq IndefUnitId where + u1 == u2 = indefUnitIdKey u1 == indefUnitIdKey u2 + +instance Ord IndefUnitId where + u1 `compare` u2 = indefUnitIdFS u1 `compare` indefUnitIdFS u2 + +instance Outputable HashedUnitId where + ppr uid = + if hashedUnitIdComponentId uid == ComponentId (hashedUnitIdFS uid) + then ppr (hashedUnitIdComponentId uid) + else ftext (hashedUnitIdFS uid) + +instance Outputable IndefUnitId where + ppr uid = + -- getPprStyle $ \sty -> + ppr cid <> + (if not (null insts) -- pprIf + then + -- TODO: Print an instantiation if (1) we would not have qualified + -- the module and (2) the module name and module agree + let -- is_wanted (mod_name, mod) = qualModule sty mod + -- || mod_name /= moduleName mod + (wanted, unwanted) = (insts, []) + {- + -- This was more annoying than helpful + | debugStyle sty = (insts, []) + | otherwise = partition is_wanted insts + -} + in brackets (hsep + (punctuate comma $ + [ ppr modname <> text "=" <> ppr m + | (modname, m) <- wanted] ++ + if not (null unwanted) then [text "..."] else [])) + else empty) + where + cid = indefUnitIdComponentId uid + insts = indefUnitIdInsts uid + +{- +newtype DefiniteUnitId = DefiniteUnitId HashedUnitId + deriving (Eq, Ord, Outputable, Typeable) + +newtype InstalledUnitId = InstalledUnitId HashedUnitId + deriving (Eq, Ord, Outputable, Typeable) +-} + +-- | A 'VirginModule' is a 'Module' which contains a 'VirginUnitId'. +type VirginModule = Module + +-- | A virgin unit id is either a 'HashedUnitId', +-- or a 'UnitId' whose instantiation all have the form @A=<A>@. +-- Intuitively, virgin unit identifiers are those which are recorded +-- in the installed package database and can be read off disk. +type VirginUnitId = UnitId + +-- | A map keyed off of 'VirginModule' +type VirginModuleEnv elt = ModuleEnv elt + +-- | A hole module is a 'Module' representing a required +-- signature that we are going to merge in. The unit id +-- of such a hole module is guaranteed to be equipped with +-- an instantiation. +type HoleModule = (IndefUnitId, ModuleName) + +-- Note [UnitId to HashedUnitId improvement] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Just because a UnitId is definite (has no holes) doesn't +-- mean it's necessarily a HashedUnitId; it could just be +-- that over the course of renaming UnitIds on the fly +-- while typechecking an indefinite library, we +-- ended up with a fully instantiated unit id with no hash, +-- since we haven't built it yet. This is fine. +-- +-- However, if there is a hashed unit id for this instantiation +-- in the package database, we *better use it*, because +-- that hashed unit id may be lurking in another interface, +-- and chaos will ensue if we attempt to compare the two +-- (the unitIdFS for a UnitId never corresponds to a Cabal-provided +-- hash of a compiled instantiated library). +-- +-- There is one last niggle which is not currently fixed: +-- improvement based on the package database means that +-- we might end up developing on a package that is not transitively +-- depended upon by the packages the user specified directly +-- via command line flags. This could lead to strange and +-- difficult to understand bugs if those instantiations are +-- out of date. The fix is that GHC has to be a bit more +-- careful about what instantiated packages get put in the package database. +-- I haven't implemented this yet. + +-- | Retrieve the set of free holes of a 'UnitId'. +unitIdFreeHoles :: UnitId -> UniqDSet ModuleName +unitIdFreeHoles (AnIndefUnitId x) = indefUnitIdFreeHoles x +-- Hashed unit ids are always fully instantiated +unitIdFreeHoles (AHashedUnitId _) = emptyUniqDSet + +instance Show UnitId where + show = unitIdString + +-- | A 'UnitId' is definite if it has no free holes. +unitIdIsDefinite :: UnitId -> Bool +unitIdIsDefinite = isEmptyUniqDSet . unitIdFreeHoles + +-- | Generate a uniquely identifying 'FastString' for a unit +-- identifier. This is a one-way function. You can rely on one special +-- property: if a unit identifier is in most general form, its 'FastString' +-- coincides with its 'ComponentId'. This hash is completely internal +-- to GHC and is not used for symbol names or file paths. +hashUnitId :: ComponentId -> [(ModuleName, Module)] -> FastString +hashUnitId (ComponentId fs_cid) sorted_holes + -- Make the special-case work. + | all (\(mod_name, m) -> mkHoleModule mod_name == m) sorted_holes = fs_cid +hashUnitId cid sorted_holes = + mkFastStringByteString + . fingerprintUnitId (toStringRep cid) + $ rawHashUnitId sorted_holes + +rawHashUnitId :: [(ModuleName, Module)] -> Fingerprint +rawHashUnitId sorted_holes = + fingerprintByteString + . BS.concat $ do + (m, b) <- sorted_holes + [ toStringRep m, BS.Char8.singleton ' ', + fastStringToByteString (unitIdFS (moduleUnitId b)), BS.Char8.singleton ':', + toStringRep (moduleName b), BS.Char8.singleton '\n'] + +fingerprintByteString :: BS.ByteString -> Fingerprint +fingerprintByteString bs = unsafePerformIO + . BS.unsafeUseAsCStringLen bs + $ \(p,l) -> fingerprintData (castPtr p) l + +fingerprintUnitId :: BS.ByteString -> Fingerprint -> BS.ByteString +fingerprintUnitId prefix (Fingerprint a b) + = BS.concat + $ [ prefix + , BS.Char8.singleton '-' + , BS.Char8.pack (toBase62Padded a) + , BS.Char8.pack (toBase62Padded b) ] + +-- | Create a new, externally provided hashed unit id from +-- a hash. +newHashedUnitId :: ComponentId -> Maybe FastString -> UnitId +newHashedUnitId cid@(ComponentId cid_fs) (Just fs) + = rawNewHashedUnitId cid (cid_fs `appendFS` mkFastString "+" `appendFS` fs) +newHashedUnitId cid@(ComponentId cid_fs) Nothing + = rawNewHashedUnitId cid cid_fs + +-- | Smart constructor for 'HashedUnitId'; input 'FastString' +-- is assumed to be the FULL identifying string for this +-- UnitId (e.g., it contains the 'ComponentId'). +rawNewHashedUnitId :: ComponentId -> FastString -> UnitId +rawNewHashedUnitId cid fs = AHashedUnitId $ HashedUnitId { + hashedUnitIdFS = fs, + hashedUnitIdKey = getUnique fs, + hashedUnitIdComponentId = cid + } + +-- | Create a new, un-hashed unit identifier. +newUnitId :: ComponentId -> [(ModuleName, Module)] -> UnitId +newUnitId cid [] = newSimpleUnitId cid -- TODO: this indicates some latent bug... +newUnitId cid insts = AnIndefUnitId $ newIndefUnitId cid insts + +newIndefUnitId :: ComponentId -> [(ModuleName, Module)] -> IndefUnitId +newIndefUnitId cid insts = + IndefUnitId { + indefUnitIdComponentId = cid, + indefUnitIdInsts = sorted_insts, + indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), + indefUnitIdFS = fs, + indefUnitIdKey = getUnique fs + } + where + fs = hashUnitId cid sorted_insts + sorted_insts = sortBy (stableModuleNameCmp `on` fst) insts + + +pprUnitId :: UnitId -> SDoc +pprUnitId (AHashedUnitId uid) = ppr uid +pprUnitId (AnIndefUnitId uid) = ppr uid + +instance Eq UnitId where + uid1 == uid2 = unitIdKey uid1 == unitIdKey uid2 instance Uniquable UnitId where - getUnique pid = getUnique (unitIdFS pid) + getUnique = unitIdKey instance Ord UnitId where nm1 `compare` nm2 = stableUnitIdCmp nm1 nm2 @@ -421,28 +801,58 @@ stableUnitIdCmp :: UnitId -> UnitId -> Ordering stableUnitIdCmp p1 p2 = unitIdFS p1 `compare` unitIdFS p2 instance Outputable UnitId where - ppr pk = getPprStyle $ \sty -> sdocWithDynFlags $ \dflags -> - case unitIdPackageIdString dflags pk of - Nothing -> ftext (unitIdFS pk) - Just pkg -> text pkg - -- Don't bother qualifying if it's wired in! - <> (if qualPackage sty pk && not (pk `elem` wiredInUnitIds) - then char '@' <> ftext (unitIdFS pk) - else empty) + ppr pk = pprUnitId pk +-- Performance: would prefer to have a NameCache like thing instance Binary UnitId where - put_ bh pid = put_ bh (unitIdFS pid) - get bh = do { fs <- get bh; return (fsToUnitId fs) } + put_ bh (AHashedUnitId uid) + | cid == ComponentId fs = do + putByte bh 0 + put_ bh fs + | otherwise = do + putByte bh 2 + put_ bh cid + put_ bh fs + where + cid = hashedUnitIdComponentId uid + fs = hashedUnitIdFS uid + put_ bh (AnIndefUnitId uid) = do + putByte bh 1 + put_ bh cid + put_ bh insts + where + cid = indefUnitIdComponentId uid + insts = indefUnitIdInsts uid + get bh = do b <- getByte bh + case b of + 0 -> fmap fsToUnitId (get bh) + 1 -> do + cid <- get bh + insts <- get bh + return (newUnitId cid insts) + _ -> do + cid <- get bh + fs <- get bh + return (rawNewHashedUnitId cid fs) instance BinaryStringRep UnitId where - fromStringRep = fsToUnitId . mkFastStringByteString - toStringRep = fastStringToByteString . unitIdFS + fromStringRep bs = rawNewHashedUnitId (fromStringRep cid) (mkFastStringByteString bs) + where cid = BS.Char8.takeWhile (/='+') bs + -- GHC doesn't write to database + toStringRep = error "BinaryStringRep UnitId: not implemented" -fsToUnitId :: FastString -> UnitId -fsToUnitId = PId +instance Binary ComponentId where + put_ bh (ComponentId fs) = put_ bh fs + get bh = do { fs <- get bh; return (ComponentId fs) } -unitIdFS :: UnitId -> FastString -unitIdFS (PId fs) = fs +-- | Create a new simple unit identifier (no holes) from a 'ComponentId'. +newSimpleUnitId :: ComponentId -> UnitId +newSimpleUnitId (ComponentId fs) = fsToUnitId fs + +-- | Create a new simple unit identifier from a 'FastString'. Internally, +-- this is primarily used to specify wired-in unit identifiers. +fsToUnitId :: FastString -> UnitId +fsToUnitId fs = rawNewHashedUnitId (ComponentId fs) fs stringToUnitId :: String -> UnitId stringToUnitId = fsToUnitId . mkFastString @@ -450,6 +860,126 @@ stringToUnitId = fsToUnitId . mkFastString unitIdString :: UnitId -> String unitIdString = unpackFS . unitIdFS +{- +************************************************************************ +* * + Hole substitutions +* * +************************************************************************ +-} + +-- | Substitution on module variables, mapping module names to module +-- identifiers. +type ShHoleSubst = ModuleNameEnv Module + +-- | Substitutes holes in a 'Module'. NOT suitable for being called +-- directly on a 'nameModule', see Note [Representation of module/name variable]. +-- @p[A=<A>]:B@ maps to @p[A=q():A]:B@ with @A=q():A@; +-- similarly, @<A>@ maps to @q():A@. +renameHoleModule :: DynFlags -> ShHoleSubst -> Module -> Module +renameHoleModule dflags = renameHoleModule' (getPackageConfigMap dflags) + +-- | Substitutes holes in a 'UnitId', suitable for renaming when +-- an include occurs; see Note [Representation of module/name variable]. +-- +-- @p[A=<A>]@ maps to @p[A=<B>]@ with @A=<B>@. +renameHoleUnitId :: DynFlags -> ShHoleSubst -> UnitId -> UnitId +renameHoleUnitId dflags = renameHoleUnitId' (getPackageConfigMap dflags) + +-- | Like 'renameHoleModule', but requires only 'PackageConfigMap' +-- so it can be used by "Packages". +renameHoleModule' :: PackageConfigMap -> ShHoleSubst -> Module -> Module +renameHoleModule' pkg_map env m + | not (isHoleModule m) = + let uid = renameHoleUnitId' pkg_map env (moduleUnitId m) + in mkModule uid (moduleName m) + | Just m' <- lookupUFM env (moduleName m) = m' + -- NB m = <Blah>, that's what's in scope. + | otherwise = m + +-- | Like 'renameHoleUnitId, but requires only 'PackageConfigMap' +-- so it can be used by "Packages". +renameHoleUnitId' :: PackageConfigMap -> ShHoleSubst -> UnitId -> UnitId +renameHoleUnitId' pkg_map env uid = + case uid of + (AnIndefUnitId + IndefUnitId{ indefUnitIdComponentId = cid + , indefUnitIdInsts = insts + , indefUnitIdFreeHoles = fh }) + -> if isNullUFM (intersectUFM_C const (udfmToUfm fh) env) + then uid + -- Functorially apply the substitution to the instantiation, + -- then check the 'PackageConfigMap' to see if there is + -- a compiled version of this 'UnitId' we can improve to. + -- See Note [UnitId to HashedUnitId] improvement + else improveUnitId pkg_map $ + newUnitId cid + (map (\(k,v) -> (k, renameHoleModule' pkg_map env v)) insts) + _ -> uid + +-- | Given a possibly on-the-fly instantiated module, split it into +-- a 'Module' that we definitely can find on-disk, as well as an +-- instantiation if we need to instantiate it on the fly. If the +-- instantiation is @Nothing@ no on-the-fly renaming is needed. +splitModuleInsts :: Module -> (VirginModule, Maybe [(ModuleName, Module)]) +splitModuleInsts m = + let (uid, mb_insts) = splitUnitIdInsts (moduleUnitId m) + in (mkModule uid (moduleName m), mb_insts) + +-- | See 'splitModuleInsts'. +splitUnitIdInsts :: UnitId -> (VirginUnitId, Maybe [(ModuleName, Module)]) +splitUnitIdInsts (AnIndefUnitId iuid) = + (AnIndefUnitId (generalizeIndefUnitId iuid), Just (indefUnitIdInsts iuid)) +splitUnitIdInsts uid = (uid, Nothing) + +generalizeIndefUnitId :: IndefUnitId -> IndefUnitId +generalizeIndefUnitId IndefUnitId{ indefUnitIdComponentId = cid + , indefUnitIdInsts = insts } = + newIndefUnitId cid (map (\(m,_) -> (m, mkHoleModule m)) insts) + +parseModuleName :: ReadP ModuleName +parseModuleName = fmap mkModuleName + $ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.") + +parseUnitId :: ReadP UnitId +parseUnitId = parseFullUnitId <++ parseHashedUnitId <++ parseSimpleUnitId + where + parseFullUnitId = do cid <- parseComponentId + insts <- parseModSubst + return (newUnitId cid insts) + parseHashedUnitId = do cid <- parseComponentId + _ <- Parse.char '+' + hash <- Parse.munch1 isAlphaNum + return (newHashedUnitId cid (Just (mkFastString hash))) + parseSimpleUnitId = do cid <- parseComponentId + return (newSimpleUnitId cid) + +parseComponentId :: ReadP ComponentId +parseComponentId = (ComponentId . mkFastString) `fmap` Parse.munch1 abi_char + where abi_char c = isAlphaNum c || c `elem` "-_." + +parseModuleId :: ReadP Module +parseModuleId = parseModuleVar <++ parseModule + where + parseModuleVar = do + _ <- Parse.char '<' + modname <- parseModuleName + _ <- Parse.char '>' + return (mkHoleModule modname) + parseModule = do + uid <- parseUnitId + _ <- Parse.char ':' + modname <- parseModuleName + return (mkModule uid modname) + +parseModSubst :: ReadP [(ModuleName, Module)] +parseModSubst = Parse.between (Parse.char '[') (Parse.char ']') + . flip Parse.sepBy (Parse.char ',') + $ do k <- parseModuleName + _ <- Parse.char '=' + v <- parseModuleId + return (k, v) + -- ----------------------------------------------------------------------------- -- $wired_in_packages @@ -497,12 +1027,34 @@ mainUnitId = fsToUnitId (fsLit "main") -- | This is a fake package id used to provide identities to any un-implemented -- signatures. The set of hole identities is global over an entire compilation. +-- Don't use this directly: use 'mkHoleModule' or 'isHoleModule' instead. +-- See Note [Representation of module/name variables] holeUnitId :: UnitId holeUnitId = fsToUnitId (fsLit "hole") isInteractiveModule :: Module -> Bool isInteractiveModule mod = moduleUnitId mod == interactiveUnitId +-- Note [Representation of module/name variables] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- In our ICFP'16, we use <A> to represent module holes, and {A.T} to represent +-- name holes. This could have been represented by adding some new cases +-- to the core data types, but this would have made the existing 'nameModule' +-- and 'moduleUnitId' partial, which would have required a lot of modifications +-- to existing code. +-- +-- Instead, we adopted the following encoding scheme: +-- +-- <A> ===> hole:A +-- {A.T} ===> hole:A.T +-- +-- This encoding is quite convenient, but it is also a bit dangerous too, +-- because if you have a 'hole:A' you need to know if it's actually a +-- 'Module' or just a module stored in a 'Name'; these two cases must be +-- treated differently when doing substitutions. 'renameHoleModule' +-- and 'renameHoleUnitId' assume they are NOT operating on a +-- 'Name'; 'NameShape' handles name substitutions exclusively. + isHoleModule :: Module -> Bool isHoleModule mod = moduleUnitId mod == holeUnitId @@ -526,6 +1078,7 @@ wiredInUnitIds = [ primUnitId, -- | A map keyed off of 'Module's newtype ModuleEnv elt = ModuleEnv (Map NDModule elt) + {- Note [ModuleEnv performance and determinism] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/basicTypes/Module.hs-boot b/compiler/basicTypes/Module.hs-boot index d8b7a61e11..4cb35caa2f 100644 --- a/compiler/basicTypes/Module.hs-boot +++ b/compiler/basicTypes/Module.hs-boot @@ -1,8 +1,11 @@ module Module where +import FastString data Module data ModuleName data UnitId +newtype ComponentId = ComponentId FastString + moduleName :: Module -> ModuleName moduleUnitId :: Module -> UnitId unitIdString :: UnitId -> String diff --git a/compiler/basicTypes/Name.hs b/compiler/basicTypes/Name.hs index d1b05f3bac..bcb4309586 100644 --- a/compiler/basicTypes/Name.hs +++ b/compiler/basicTypes/Name.hs @@ -531,7 +531,12 @@ pprExternal sty uniq mod occ is_wired is_builtin pprNameSpaceBrief (occNameSpace occ), pprUnique uniq]) | BuiltInSyntax <- is_builtin = ppr_occ_name occ -- Never qualify builtin syntax - | otherwise = pprModulePrefix sty mod occ <> ppr_occ_name occ + | otherwise = + if isHoleModule mod + then case qualName sty mod occ of + NameUnqual -> ppr_occ_name occ + _ -> braces (ppr (moduleName mod) <> dot <> ppr_occ_name occ) + else pprModulePrefix sty mod occ <> ppr_occ_name occ where pp_mod = sdocWithDynFlags $ \dflags -> if gopt Opt_SuppressModulePrefixes dflags diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index 6a6c012d1d..72d2f9b2ec 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -111,16 +111,21 @@ mkDependencies mkUsedNames :: TcGblEnv -> NameSet mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus -mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath] -> IO [Usage] -mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files +mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath] -> [(Module, Fingerprint)] -> IO [Usage] +mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files merged = do eps <- hscEPS hsc_env hashes <- mapM getFileHash dependent_files let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod dir_imp_mods used_names - let usages = mod_usages ++ [ UsageFile { usg_file_path = f + usages = mod_usages ++ [ UsageFile { usg_file_path = f , usg_file_hash = hash } | (f, hash) <- zip dependent_files hashes ] + ++ [ UsageMergedRequirement + { usg_mod = mod, + usg_mod_hash = hash + } + | (mod, hash) <- merged ] usages `seqList` return usages -- seq the list of Usages returned: occasionally these -- don't get evaluated for a while and we can end up hanging on to @@ -265,7 +270,8 @@ deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts) deSugar hsc_env mod_loc - tcg_env@(TcGblEnv { tcg_mod = mod, + tcg_env@(TcGblEnv { tcg_mod = id_mod, + tcg_semantic_mod = mod, tcg_src = hsc_src, tcg_type_env = type_env, tcg_imports = imports, @@ -276,6 +282,7 @@ deSugar hsc_env tcg_fix_env = fix_env, tcg_inst_env = inst_env, tcg_fam_inst_env = fam_inst_env, + tcg_merged = merged, tcg_warns = warns, tcg_anns = anns, tcg_binds = binds, @@ -359,7 +366,10 @@ deSugar hsc_env ; used_th <- readIORef tc_splice_used ; dep_files <- readIORef dependent_files ; safe_mode <- finalSafeMode dflags tcg_env - ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names dep_files + ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names dep_files merged + -- id_mod /= mod when we are processing an hsig, but hsigs + -- never desugared and compiled (there's no code!) + ; MASSERT ( id_mod == mod ) ; let mod_guts = ModGuts { mg_module = mod, diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index b41c23a125..67f0aa623f 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -133,6 +133,7 @@ Library cbits/genSym.c hs-source-dirs: + backpack basicTypes cmm codeGen @@ -159,6 +160,10 @@ Library vectorise Exposed-Modules: + DriverBkp + BkpSyn + NameShape + RnModIface Avail BasicTypes ConLike @@ -423,6 +428,7 @@ Library TcPat TcPatSyn TcRnDriver + TcBackpack TcRnMonad TcRnTypes TcRules diff --git a/compiler/iface/IfaceEnv.hs b/compiler/iface/IfaceEnv.hs index ff2f648a4a..96bd36ff33 100644 --- a/compiler/iface/IfaceEnv.hs +++ b/compiler/iface/IfaceEnv.hs @@ -11,6 +11,7 @@ module IfaceEnv ( extendIfaceIdEnv, extendIfaceTyVarEnv, tcIfaceLclId, tcIfaceTyVar, lookupIfaceVar, lookupIfaceTyVar, extendIfaceEnvs, + setNameModule, ifaceExportNames, @@ -174,6 +175,12 @@ externaliseName mod name ns' = ns { nsNames = extendNameCache (nsNames ns) mod occ name' } in (ns', name') } +-- | Set the 'Module' of a 'Name'. +setNameModule :: Maybe Module -> Name -> TcRnIf m n Name +setNameModule Nothing n = return n +setNameModule (Just m) n = + newGlobalBinder m (nameOccName n) (nameSrcSpan n) + {- ************************************************************************ * * @@ -330,8 +337,25 @@ extendIfaceEnvs tcvs thing_inside lookupIfaceTop :: OccName -> IfL Name -- Look up a top-level name from the current Iface module -lookupIfaceTop occ - = do { env <- getLclEnv; lookupOrig (if_mod env) occ } +lookupIfaceTop occ = do + lcl_env <- getLclEnv + -- NB: this is a semantic module, see + -- Note [Identity versus semantic module] + mod <- getIfModule + case if_nsubst lcl_env of + -- NOT substNameShape because 'getIfModule' returns the + -- renamed module (d'oh!) + Just nsubst -> + case lookupOccEnv (ns_map nsubst) occ of + Just n' -> + -- I thought this would be help but it turns out + -- n' doesn't have any useful information. Drat! + -- return (setNameLoc n' (nameSrcSpan n)) + return n' + -- This case can occur when we encounter a DFun; + -- see Note [Bogus DFun renamings] + Nothing -> lookupOrig mod occ + _ -> lookupOrig mod occ newIfaceName :: OccName -> IfL Name newIfaceName occ diff --git a/compiler/iface/IfaceEnv.hs-boot b/compiler/iface/IfaceEnv.hs-boot new file mode 100644 index 0000000000..025c3711a0 --- /dev/null +++ b/compiler/iface/IfaceEnv.hs-boot @@ -0,0 +1,9 @@ +module IfaceEnv where + +import Module +import OccName +import TcRnMonad +import Name +import SrcLoc + +newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs index 689452f859..8a45dd55be 100644 --- a/compiler/iface/IfaceSyn.hs +++ b/compiler/iface/IfaceSyn.hs @@ -51,7 +51,6 @@ import ForeignCall import Annotations( AnnPayload, AnnTarget ) import BasicTypes import Outputable -import FastString import Module import SrcLoc import Fingerprint @@ -126,7 +125,7 @@ data IfaceDecl ifName :: IfaceTopBndr, -- Name of the class TyCon ifRoles :: [Role], -- Roles ifBinders :: [IfaceTyConBinder], - ifFDs :: [FunDep FastString], -- Functional dependencies + ifFDs :: [FunDep IfLclName], -- Functional dependencies ifATs :: [IfaceAT], -- Associated type families ifSigs :: [IfaceClassOp], -- Method signatures ifMinDef :: BooleanFormula IfLclName -- Minimal complete definition diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs index c5c3538284..4e1fea068e 100644 --- a/compiler/iface/LoadIface.hs +++ b/compiler/iface/LoadIface.hs @@ -24,7 +24,9 @@ module LoadIface ( findAndReadIface, readIface, -- Used when reading the module's old interface loadDecls, -- Should move to TcIface and be renamed initExternalPackageState, + moduleFreeHolesPrecise, + pprModIfaceSimple, ifaceStats, pprModIface, showIface ) where @@ -69,6 +71,8 @@ import FastString import Fingerprint import Hooks import FieldLabel +import RnModIface +import UniqDSet import Control.Monad import Data.IORef @@ -352,11 +356,7 @@ loadPluginInterface doc mod_name -- | A wrapper for 'loadInterface' that throws an exception if it fails loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface loadInterfaceWithException doc mod_name where_from - = do { mb_iface <- loadInterface doc mod_name where_from - ; dflags <- getDynFlags - ; case mb_iface of - Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (showSDoc dflags err)) - Succeeded iface -> return iface } + = withException (loadInterface doc mod_name where_from) ------------------ loadInterface :: SDoc -> Module -> WhereFrom @@ -375,6 +375,12 @@ loadInterface :: SDoc -> Module -> WhereFrom -- is no longer used loadInterface doc_str mod from + | isHoleModule mod + -- Hole modules get special treatment + = do dflags <- getDynFlags + -- Redo search for our local hole module + loadInterface doc_str (mkModule (thisPackage dflags) (moduleName mod)) from + | otherwise = do { -- Read the state (eps,hpt) <- getEpsAndHpt ; gbl_env <- getGblEnv @@ -402,7 +408,7 @@ loadInterface doc_str mod from WARN( hi_boot_file && fmap fst (if_rec_types gbl_env) == Just mod, ppr mod ) - findAndReadIface doc_str mod hi_boot_file + computeInterface doc_str hi_boot_file mod ; case read_result of { Failed err -> do { let fake_iface = emptyModIface mod @@ -423,12 +429,11 @@ loadInterface doc_str mod from -- But this is no longer valid because thNameToGhcName allows users to -- cause the system to load arbitrary interfaces (by supplying an appropriate -- Template Haskell original-name). - Succeeded (iface, file_path) -> - + Succeeded (iface, loc) -> let - loc_doc = text file_path + loc_doc = text loc in - initIfaceLcl mod loc_doc (mi_boot iface) $ do + initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $ do -- Load the new ModIface into the External Package State -- Even home-package interfaces loaded by loadInterface @@ -464,7 +469,8 @@ loadInterface doc_str mod from } ; updateEps_ $ \ eps -> - if elemModuleEnv mod (eps_PIT eps) then eps else + if elemModuleEnv mod (eps_PIT eps) || is_external_sig dflags iface + then eps else eps { eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface, eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls, @@ -495,6 +501,91 @@ loadInterface doc_str mod from ; return (Succeeded final_iface) }}}} +-- | Returns @True@ if a 'ModIface' comes from an external package. +-- In this case, we should NOT load it into the EPS; the entities +-- should instead come from the local merged signature interface. +is_external_sig :: DynFlags -> ModIface -> Bool +is_external_sig dflags iface = + -- It's a signature iface... + mi_semantic_module iface /= mi_module iface && + -- and it's not from the local package + moduleUnitId (mi_module iface) /= thisPackage dflags + +-- | This is an improved version of 'findAndReadIface' which can also +-- handle the case when a user requests @p[A=<B>]:M@ but we only +-- have an interface for @p[A=<A>]:M@ (the indefinite interface. +-- If we are not trying to build code, we load the interface we have, +-- *instantiating it* according to how the holes are specified. +-- (Of course, if we're actually building code, this is a hard error.) +-- +-- In the presence of holes, 'computeInterface' has an important invariant: +-- to load module M, its set of transitively reachable requirements must +-- have an up-to-date local hi file for that requirement. Note that if +-- we are loading the interface of a requirement, this does not +-- apply to the requirement itself; e.g., @p[A=<A>]:A@ does not require +-- A.hi to be up-to-date (and indeed, we MUST NOT attempt to read A.hi, unless +-- we are actually typechecking p.) +computeInterface :: + SDoc -> IsBootInterface -> Module + -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath)) +computeInterface doc_str hi_boot_file mod0 = do + MASSERT( not (isHoleModule mod0) ) + dflags <- getDynFlags + case splitModuleInsts mod0 of + (imod, Just insts) | not (unitIdIsDefinite (thisPackage dflags)) -> do + r <- findAndReadIface doc_str imod hi_boot_file + case r of + Succeeded (iface0, path) -> do + hsc_env <- getTopEnv + r <- liftIO (rnModIface hsc_env insts Nothing iface0) + return (Succeeded (r, path)) + Failed err -> return (Failed err) + (mod, _) -> + findAndReadIface doc_str mod hi_boot_file + +-- | Compute the signatures which must be compiled in order to +-- load the interface for a 'Module'. The output of this function +-- is always a subset of 'moduleFreeHoles'; it is more precise +-- because in signature @p[A=<A>,B=<B>]:B@, although the free holes +-- are A and B, B might not depend on A at all! +-- +-- If this is invoked on a signature, this does NOT include the +-- signature itself; e.g. precise free module holes of +-- @p[A=<A>,B=<B>]:B@ never includes B. +moduleFreeHolesPrecise + :: SDoc -> Module + -> TcRnIf gbl lcl (MaybeErr MsgDoc (UniqDSet ModuleName)) +moduleFreeHolesPrecise doc_str mod + | moduleIsDefinite mod = return (Succeeded emptyUniqDSet) + | otherwise = + case splitModuleInsts mod of + (imod, Just insts) -> do + traceIf (text "Considering whether to load" <+> ppr mod <+> + text "to compute precise free module holes") + (eps, hpt) <- getEpsAndHpt + dflags <- getDynFlags + case tryEpsAndHpt dflags eps hpt `firstJust` tryDepsCache eps imod insts of + Just r -> return (Succeeded r) + Nothing -> readAndCache imod insts + (_, Nothing) -> return (Succeeded emptyUniqDSet) + where + tryEpsAndHpt dflags eps hpt = + fmap mi_free_holes (lookupIfaceByModule dflags hpt (eps_PIT eps) mod) + tryDepsCache eps imod insts = + case lookupModuleEnv (eps_free_holes eps) imod of + Just ifhs -> Just (renameFreeHoles ifhs insts) + _otherwise -> Nothing + readAndCache imod insts = do + mb_iface <- findAndReadIface (text "moduleFreeHolesPrecise" <+> doc_str) imod False + case mb_iface of + Succeeded (iface, _) -> do + let ifhs = mi_free_holes iface + -- Cache it + updateEps_ (\eps -> + eps { eps_free_holes = extendModuleEnv (eps_free_holes eps) imod ifhs }) + return (Succeeded (renameFreeHoles ifhs insts)) + Failed err -> return (Failed err) + wantHiBootFile :: DynFlags -> ExternalPackageState -> Module -> WhereFrom -> MaybeErr MsgDoc IsBootInterface -- Figure out whether we want Foo.hi or Foo.hi-boot @@ -678,7 +769,7 @@ This actually happened with P=base, Q=ghc-prim, via the AMP warnings. See Trac #8320. -} -findAndReadIface :: SDoc -> Module +findAndReadIface :: SDoc -> VirginModule -> IsBootInterface -- True <=> Look for a .hi-boot file -- False <=> Look for .hi file -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath)) @@ -687,7 +778,6 @@ findAndReadIface :: SDoc -> Module -- It *doesn't* add an error to the monad, because -- sometimes it's ok to fail... see notes with loadInterface - findAndReadIface doc_str mod hi_boot_file = do traceIf (sep [hsep [text "Reading", if hi_boot_file @@ -710,7 +800,6 @@ findAndReadIface doc_str mod hi_boot_file mb_found <- liftIO (findExactModule hsc_env mod) case mb_found of Found loc mod -> do - -- Found file, so read it let file_path = addBootSuffix_maybe hi_boot_file (ml_hi_file loc) @@ -740,7 +829,11 @@ findAndReadIface doc_str mod hi_boot_file -- Don't forget to fill in the package name... checkBuildDynamicToo (Succeeded (iface, filePath)) = do dflags <- getDynFlags - whenGeneratingDynamicToo dflags $ withDoDynamicToo $ do + -- Indefinite interfaces are ALWAYS non-dynamic, and + -- that's OK. + let is_definite_iface = moduleIsDefinite (mi_module iface) + when is_definite_iface $ + whenGeneratingDynamicToo dflags $ withDoDynamicToo $ do let ref = canGenerateDynamicToo dflags dynFilePath = addBootSuffix_maybe hi_boot_file $ replaceExtension filePath (dynHiSuf dflags) @@ -759,7 +852,7 @@ findAndReadIface doc_str mod hi_boot_file -- @readIface@ tries just the one file. -readIface :: Module -> FilePath +readIface :: VirginModule -> FilePath -> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface) -- Failed err <=> file not found, or unreadable, or illegible -- Succeeded iface <=> successfully found and parsed @@ -791,6 +884,7 @@ initExternalPackageState = EPS { eps_is_boot = emptyUFM, eps_PIT = emptyPackageIfaceTable, + eps_free_holes = emptyModuleEnv, eps_PTE = emptyTypeEnv, eps_inst_env = emptyInstEnv, eps_fam_inst_env = emptyFamInstEnv, @@ -868,6 +962,11 @@ showIface hsc_env filename = do let dflags = hsc_dflags hsc_env log_action dflags dflags NoReason SevDump noSrcSpan defaultDumpStyle (pprModIface iface) +-- Show a ModIface but don't display details; suitable for ModIfaces stored in +-- the EPT. +pprModIfaceSimple :: ModIface -> SDoc +pprModIfaceSimple iface = ppr (mi_module iface) $$ pprDeps (mi_deps iface) $$ nest 2 (vcat (map pprExport (mi_exports iface))) + pprModIface :: ModIface -> SDoc -- Show a ModIface pprModIface iface @@ -935,6 +1034,8 @@ pprUsage usage@UsageHomeModule{} pprUsage usage@UsageFile{} = hsep [text "addDependentFile", doubleQuotes (text (usg_file_path usage))] +pprUsage usage@UsageMergedRequirement{} + = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)] pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc pprUsageImport usage usg_mod' diff --git a/compiler/iface/LoadIface.hs-boot b/compiler/iface/LoadIface.hs-boot new file mode 100644 index 0000000000..ff2b3efb1a --- /dev/null +++ b/compiler/iface/LoadIface.hs-boot @@ -0,0 +1,7 @@ +module LoadIface where +import Module (Module) +import TcRnMonad (IfM) +import HscTypes (ModIface) +import Outputable (SDoc) + +loadSysInterface :: SDoc -> Module -> IfM lcl ModIface diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index 8115583e32..3ab898e682 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -19,6 +19,7 @@ module MkIface ( checkOldIface, -- See if recompilation is required, by -- comparing version information RecompileRequired(..), recompileRequired, + mkIfaceExports, tyThingToIfaceDecl -- Converting things to their Iface equivalents ) where @@ -165,10 +166,12 @@ mkIfaceTc :: HscEnv -> IO (ModIface, Bool) mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details tc_result@TcGblEnv{ tcg_mod = this_mod, + tcg_semantic_mod = semantic_mod, tcg_src = hsc_src, tcg_imports = imports, tcg_rdr_env = rdr_env, tcg_fix_env = fix_env, + tcg_merged = merged, tcg_warns = warns, tcg_hpc = other_hpc_info, tcg_th_splice_used = tc_splice_used, @@ -180,7 +183,7 @@ mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details let hpc_info = emptyHpcInfo other_hpc_info used_th <- readIORef tc_splice_used dep_files <- (readIORef dependent_files) - usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names dep_files + usages <- mkUsageInfo hsc_env semantic_mod (imp_mods imports) used_names dep_files merged mkIface_ hsc_env maybe_old_fingerprint this_mod hsc_src used_th deps rdr_env @@ -212,7 +215,8 @@ mkIface_ hsc_env maybe_old_fingerprint -- to expose in the interface = do - let entities = typeEnvElts type_env + let semantic_mod = canonicalizeHomeModule (hsc_dflags hsc_env) (moduleName this_mod) + entities = typeEnvElts type_env decls = [ tyThingToIfaceDecl entity | entity <- entities, let name = getName entity, @@ -220,8 +224,12 @@ mkIface_ hsc_env maybe_old_fingerprint -- No implicit Ids and class tycons in the interface file not (isWiredInName name), -- Nor wired-in things; the compiler knows about them anyhow - nameIsLocalOrFrom this_mod name ] + nameIsLocalOrFrom semantic_mod name ] -- Sigh: see Note [Root-main Id] in TcRnDriver + -- NB: ABSOLUTELY need to check against semantic_mod, + -- because all of the names in an hsig p[H=<H>]:H + -- are going to be for <H>, not the former id! + -- See Note [Identity versus semantic module] fixities = sortBy (comparing fst) [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env] @@ -235,11 +243,14 @@ mkIface_ hsc_env maybe_old_fingerprint iface_vect_info = flattenVectInfo vect_info trust_info = setSafeMode safe_mode annotations = map mkIfaceAnnotation anns - sig_of = getSigOf dflags (moduleName this_mod) intermediate_iface = ModIface { mi_module = this_mod, - mi_sig_of = sig_of, + -- Need to record this because it depends on the -instantiated-with flag + -- which could change + mi_sig_of = if semantic_mod == this_mod + then Nothing + else Just semantic_mod, mi_hsc_src = hsc_src, mi_deps = deps, mi_usages = usages, @@ -349,21 +360,32 @@ writeIfaceFile dflags hi_file_path new_iface mkHashFun :: HscEnv -- needed to look up versions -> ExternalPackageState -- ditto - -> (Name -> Fingerprint) -mkHashFun hsc_env eps - = \name -> - let - mod = ASSERT2( isExternalName name, ppr name ) nameModule name - occ = nameOccName name - iface = lookupIfaceByModule dflags hpt pit mod `orElse` - pprPanic "lookupVers2" (ppr mod <+> ppr occ) - in - snd (mi_hash_fn iface occ `orElse` - pprPanic "lookupVers1" (ppr mod <+> ppr occ)) + -> (Name -> IO Fingerprint) +mkHashFun hsc_env eps name + | isHoleModule orig_mod + = lookup (mkModule (thisPackage dflags) (moduleName orig_mod)) + | otherwise + = lookup orig_mod where dflags = hsc_dflags hsc_env - hpt = hsc_HPT hsc_env - pit = eps_PIT eps + hpt = hsc_HPT hsc_env + pit = eps_PIT eps + occ = nameOccName name + orig_mod = nameModule name + lookup mod = do + MASSERT2( isExternalName name, ppr name ) + iface <- case lookupIfaceByModule dflags hpt pit mod of + Just iface -> return iface + Nothing -> do + -- This can occur when we're writing out ifaces for + -- requirements; we didn't do any /real/ typechecking + -- so there's no guarantee everything is loaded. + -- Kind of a heinous hack. + iface <- initIfaceLoad hsc_env . withException + $ loadInterface (text "lookupVers2") mod ImportBySystem + return iface + return $ snd (mi_hash_fn iface occ `orElse` + pprPanic "lookupVers1" (ppr mod <+> ppr occ)) -- --------------------------------------------------------------------------- -- Compute fingerprints for the interface @@ -385,6 +407,8 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- visible about the declaration that a client can depend on. -- see IfaceDeclABI below. declABI :: IfaceDecl -> IfaceDeclABI + -- TODO: I'm not sure if this should be semantic_mod or this_mod. + -- See also Note [Identity versus semantic module] declABI decl = (this_mod, decl, extras) where extras = declExtras fix_fn ann_fn non_orph_rules non_orph_insts non_orph_fis decl @@ -398,7 +422,10 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n localOccs = map (getUnique . getParent . getOccName) - . filter ((== this_mod) . name_module) + -- NB: names always use semantic module, so + -- filtering must be on the semantic module! + -- See Note [Identity versus semantic module] + . filter ((== semantic_mod) . name_module) . nonDetEltsUFM -- It's OK to use nonDetEltsUFM as localOccs is only -- used to construct the edges and @@ -434,10 +461,16 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- wired-in names don't have fingerprints | otherwise = ASSERT2( isExternalName name, ppr name ) - let hash | nameModule name /= this_mod = global_hash_fn name - | otherwise = snd (lookupOccEnv local_env (getOccName name) + let hash | nameModule name /= semantic_mod = global_hash_fn name + -- Get it from the REAL interface!! + -- This will trigger when we compile an hsig file + -- and we know a backing impl for it. + -- See Note [Identity versus semantic module] + | semantic_mod /= this_mod + , not (isHoleModule semantic_mod) = global_hash_fn name + | otherwise = return (snd (lookupOccEnv local_env (getOccName name) `orElse` pprPanic "urk! lookup local fingerprint" - (ppr name)) -- (undefined,fingerprint0)) + (ppr name))) -- This panic indicates that we got the dependency -- analysis wrong, because we needed a fingerprint for -- an entity that wasn't in the environment. To debug @@ -445,7 +478,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- pprTraces below, run the compile again, and inspect -- the output and the generated .hi file with -- --show-iface. - in put_ bh hash + in hash >>= put_ bh -- take a strongly-connected group of declarations and compute -- its fingerprint. @@ -591,6 +624,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls where this_mod = mi_module iface0 + semantic_mod = mi_semantic_module iface0 dflags = hsc_dflags hsc_env this_pkg = thisPackage dflags (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph (mi_insts iface0) @@ -1038,9 +1072,8 @@ checkVersions hsc_env mod_summary iface ; recomp <- checkFlagHash hsc_env iface ; if recompileRequired recomp then return (recomp, Nothing) else do { - ; if getSigOf (hsc_dflags hsc_env) (moduleName (mi_module iface)) - /= mi_sig_of iface - then return (RecompBecause "sig-of changed", Nothing) else do { + ; recomp <- checkHsig mod_summary iface + ; if recompileRequired recomp then return (recomp, Nothing) else do { ; recomp <- checkDependencies hsc_env mod_summary iface ; if recompileRequired recomp then return (recomp, Just iface) else do { @@ -1067,6 +1100,18 @@ checkVersions hsc_env mod_summary iface mod_deps :: DModuleNameEnv (ModuleName, IsBootInterface) mod_deps = mkModDeps (dep_mods (mi_deps iface)) +-- | Check if an hsig file needs recompilation because its +-- implementing module has changed. +checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired +checkHsig mod_summary iface = do + dflags <- getDynFlags + let outer_mod = ms_mod mod_summary + inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod) + MASSERT( thisPackage dflags == moduleUnitId outer_mod ) + case inner_mod == mi_semantic_module iface of + True -> up_to_date (text "implementing module unchanged") + False -> return (RecompBecause "implementing module changed") + -- | Check the flags haven't changed checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired checkFlagHash hsc_env iface = do @@ -1146,7 +1191,6 @@ needInterface mod continue -- import and it's been deleted Succeeded iface -> continue iface - -- | Given the usage information extracted from the old -- M.hi file for the module being compiled, figure out -- whether M needs to be recompiled. @@ -1162,6 +1206,11 @@ checkModUsage _this_pkg UsagePackageModule{ -- recompile. This is safe but may entail more recompilation when -- a dependent package has changed. +checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash } + = needInterface mod $ \iface -> do + let reason = moduleNameString (moduleName mod) ++ " changed (raw)" + checkModuleFingerprint reason old_mod_hash (mi_mod_hash iface) + checkModUsage this_pkg UsageHomeModule{ usg_mod_name = mod_name, usg_mod_hash = old_mod_hash, diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs index 5b31b7a46d..024cd7b732 100644 --- a/compiler/iface/TcIface.hs +++ b/compiler/iface/TcIface.hs @@ -11,6 +11,8 @@ Type checking of type signatures in interface files module TcIface ( tcLookupImported_maybe, importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, + typecheckIfacesForMerging, + typecheckIfaceForInstantiate, tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules, tcIfaceVectInfo, tcIfaceAnnotations, tcIfaceExpr, -- Desired by HERMIT (Trac #7683) @@ -68,6 +70,7 @@ import Util import FastString import BasicTypes hiding ( SuccessFlag(..) ) import ListSetOps +import GHC.Fingerprint import Data.List import Control.Monad @@ -146,7 +149,7 @@ knots are tied through the EPS. No problem! typecheckIface :: ModIface -- Get the decls from here -> IfG ModDetails typecheckIface iface - = initIfaceLcl (mi_module iface) (text "typecheckIface") (mi_boot iface) $ do + = initIfaceLcl (mi_semantic_module iface) (text "typecheckIface") (mi_boot iface) $ do { -- Get the right set of decls and rules. If we are compiling without -O -- we discard pragmas before typechecking, so that we don't "see" -- information that we shouldn't. From a versioning point of view @@ -167,7 +170,7 @@ typecheckIface iface ; anns <- tcIfaceAnnotations (mi_anns iface) -- Vectorisation information - ; vect_info <- tcIfaceVectInfo (mi_module iface) type_env (mi_vect_info iface) + ; vect_info <- tcIfaceVectInfo (mi_semantic_module iface) type_env (mi_vect_info iface) -- Exports ; exports <- ifaceExportNames (mi_exports iface) @@ -191,6 +194,151 @@ typecheckIface iface {- ************************************************************************ * * + Typechecking for merging +* * +************************************************************************ +-} + +-- | Returns true if an 'IfaceDecl' is for @data T@ (an abstract data type) +isAbstractIfaceDecl :: IfaceDecl -> Bool +isAbstractIfaceDecl IfaceData{ ifCons = IfAbstractTyCon _ } = True +isAbstractIfaceDecl _ = False + +-- | Merge two 'IfaceDecl's together, preferring a non-abstract one. If +-- both are non-abstract we pick one arbitrarily (and check for consistency +-- later.) +mergeIfaceDecl :: IfaceDecl -> IfaceDecl -> IfaceDecl +mergeIfaceDecl d1 d2 + | isAbstractIfaceDecl d1 = d2 + | isAbstractIfaceDecl d2 = d1 + -- It doesn't matter; we'll check for consistency later when + -- we merge, see 'mergeSignatures' + | otherwise = d1 + +-- | Merge two 'OccEnv's of 'IfaceDecl's by 'OccName'. +mergeIfaceDecls :: OccEnv IfaceDecl -> OccEnv IfaceDecl -> OccEnv IfaceDecl +mergeIfaceDecls = plusOccEnv_C mergeIfaceDecl + +-- | This is a very interesting function. Like typecheckIface, we want +-- to type check an interface file into a ModDetails. However, the use-case +-- for these ModDetails is different: we want to compare all of the +-- ModDetails to ensure they define compatible declarations, and then +-- merge them together. So in particular, we have to take a different +-- strategy for knot-tying: we first speculatively merge the declarations +-- to get the "base" truth for what we believe the types will be +-- (this is "type computation.") Then we read everything in and check +-- for compatibility. +-- +-- Consider this example: +-- +-- H :: [ data A; type B = A ] +-- H :: [ type A = C; data C ] +-- H :: [ type A = (); data B; type C = B; ] +-- +-- We attempt to make a type synonym cycle, which is solved if we +-- take the hint that @type A = ()@. But actually we can and should +-- reject this: the 'Name's of C and () are different, so the declarations +-- of A are incompatible. (Thus there's no problem if we pick a +-- particular declaration of 'A' over another.) +-- +-- Here's another one: +-- +-- H :: [ data Int; type B = Int; ] +-- H :: [ type Int=C; data C ] +-- H :: [ export Int; data B; type C = B; ] +-- +-- We'll properly reject this too: a reexport of Int is a data +-- constructor, whereas type Int=C is a type synonym: incompatible +-- types. +-- +-- Perhaps the renamer is too fussy when it comes to ambiguity (requiring +-- original names to match, rather than just the types after type synonym +-- expansion) to match, but that's what we have for Haskell today. +typecheckIfacesForMerging :: Module -> [ModIface] -> IORef TypeEnv -> IfM lcl (TypeEnv, [ModDetails]) +typecheckIfacesForMerging mod ifaces tc_env_var = + -- cannot be boot (False) + initIfaceLcl mod (text "typecheckIfacesForMerging") False $ do + ignore_prags <- goptM Opt_IgnoreInterfacePragmas + -- Build the initial environment + -- NB: Don't include dfuns here, because we don't want to + -- serialize them out. See Note [Bogus DFun renamings] + let mk_decl_env decls + = mkOccEnv [ (ifName decl, decl) + | decl <- decls + , case decl of + IfaceId { ifIdDetails = IfDFunId } -> False -- exclude DFuns + _ -> True ] + decl_envs = map (mk_decl_env . map snd . mi_decls) ifaces + :: [OccEnv IfaceDecl] + decl_env = foldl' mergeIfaceDecls emptyOccEnv decl_envs + :: OccEnv IfaceDecl + -- TODO: change loadDecls to accept w/o Fingerprint + names_w_things <- loadDecls ignore_prags (map (\x -> (fingerprint0, x)) + (occEnvElts decl_env)) + let global_type_env = mkNameEnv names_w_things + writeMutVar tc_env_var global_type_env + + -- OK, now typecheck each ModIface using this environment + details <- forM ifaces $ \iface -> do + -- DO NOT load these decls into the mutable variable: we did + -- that already! + decls <- loadDecls ignore_prags (mi_decls iface) + let type_env = mkNameEnv decls + -- But note that we use this type_env to typecheck references to DFun + -- in 'IfaceInst' + insts <- mapM (tcIfaceInstWithDFunTypeEnv type_env) (mi_insts iface) + fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) + rules <- tcIfaceRules ignore_prags (mi_rules iface) + anns <- tcIfaceAnnotations (mi_anns iface) + vect_info <- tcIfaceVectInfo (mi_semantic_module iface) type_env (mi_vect_info iface) + exports <- ifaceExportNames (mi_exports iface) + return $ ModDetails { md_types = type_env + , md_insts = insts + , md_fam_insts = fam_insts + , md_rules = rules + , md_anns = anns + , md_vect_info = vect_info + , md_exports = exports + } + return (global_type_env, details) + +-- | Typecheck a signature 'ModIface' under the assumption that we have +-- instantiated it under some implementation (recorded in 'mi_semantic_module') +-- and want to check if the implementation fills the signature. +-- +-- This needs to operate slightly differently than 'typecheckIface' +-- because (1) we have a 'NameShape', from the exports of the +-- implementing module, which we will use to give our top-level +-- declarations the correct 'Name's even when the implementor +-- provided them with a reexport, and (2) we have to deal with +-- DFun silliness (see Note [Bogus DFun renamings]) +typecheckIfaceForInstantiate :: NameShape -> ModIface -> IfM lcl ModDetails +typecheckIfaceForInstantiate nsubst iface = + initIfaceLclWithSubst (mi_semantic_module iface) + (text "typecheckIfaceForInstantiate") + (mi_boot iface) nsubst $ do + ignore_prags <- goptM Opt_IgnoreInterfacePragmas + decls <- loadDecls ignore_prags (mi_decls iface) + let type_env = mkNameEnv decls + -- See Note [Bogus DFun renamings] + insts <- mapM (tcIfaceInstWithDFunTypeEnv type_env) (mi_insts iface) + fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) + rules <- tcIfaceRules ignore_prags (mi_rules iface) + anns <- tcIfaceAnnotations (mi_anns iface) + vect_info <- tcIfaceVectInfo (mi_semantic_module iface) type_env (mi_vect_info iface) + exports <- ifaceExportNames (mi_exports iface) + return $ ModDetails { md_types = type_env + , md_insts = insts + , md_fam_insts = fam_insts + , md_rules = rules + , md_anns = anns + , md_vect_info = vect_info + , md_exports = exports + } + +{- +************************************************************************ +* * Type and class declarations * * ************************************************************************ @@ -704,6 +852,24 @@ tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs ; return (mkImportedInstance cls mb_tcs' dfun_name dfun oflag orph) } +-- | Typecheck an 'IfaceClsInst', but rather than using 'tcIfaceGlobal', +-- resolve the 'ifDFun' using a passed in 'TypeEnv'. +-- +-- Why do we do it this way? See Note [Bogus DFun renamings] +tcIfaceInstWithDFunTypeEnv :: TypeEnv -> IfaceClsInst -> IfL ClsInst +tcIfaceInstWithDFunTypeEnv tenv + (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag + , ifInstCls = cls, ifInstTys = mb_tcs + , ifInstOrph = orph }) + = do { dfun <- case lookupTypeEnv tenv dfun_name of + Nothing -> pprPanic "tcIfaceInstWithDFunTypeEnv" + (ppr dfun_name $$ ppr tenv) + Just (AnId dfun) -> return dfun + Just tything -> pprPanic "tcIfaceInstWithDFunTypeEnv" + (ppr dfun_name <+> ppr tything) + ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs + ; return (mkImportedInstance cls mb_tcs' dfun_name dfun oflag orph) } + tcIfaceFamInst :: IfaceFamInst -> IfL FamInst tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs , ifFamInstAxiom = axiom_name } ) diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 6e61d20dc8..30493f123e 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -144,7 +144,8 @@ compileOne' m_tc_result mHscMessage case (status, hsc_lang) of (HscUpToDate, _) -> - ASSERT( isJust maybe_old_linkable || isNoLink (ghcLink dflags) ) + -- TODO recomp014 triggers this assert. What's going on?! + -- ASSERT( isJust maybe_old_linkable || isNoLink (ghcLink dflags) ) return hmi0 { hm_linkable = maybe_old_linkable } (HscNotGeneratingCode, HscNothing) -> let mb_linkable = if isHsBootOrSig src_flavour @@ -989,6 +990,7 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0 ms_location = location, ms_hs_date = src_timestamp, ms_obj_date = Nothing, + ms_parsed_mod = Nothing, ms_iface_date = Nothing, ms_textual_imps = imps, ms_srcimps = src_imps } diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index b78d665e42..69fb8b814d 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -53,8 +53,8 @@ module DynFlags ( wWarningFlags, dynFlagDependencies, tablesNextToCode, mkTablesNextToCode, - SigOf, getSigOf, makeDynFlagsConsistent, + thisUnitIdComponentId, Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays, wayGeneralFlags, wayUnsetGeneralFlags, @@ -97,6 +97,7 @@ module DynFlags ( setTmpDir, setUnitId, interpretPackageEnv, + canonicalizeHomeModule, -- ** Parsing DynFlags parseDynamicFlagsCmdLine, @@ -164,7 +165,6 @@ import CmdLineParser import Constants import Panic import Util -import UniqFM import Maybes import MonadUtils import qualified Pretty @@ -334,6 +334,7 @@ data DumpFlag | Opt_D_dump_occur_anal | Opt_D_dump_parsed | Opt_D_dump_rn + | Opt_D_dump_shape | Opt_D_dump_simpl | Opt_D_dump_simpl_iterations | Opt_D_dump_spec @@ -642,11 +643,6 @@ instance Show SafeHaskellMode where instance Outputable SafeHaskellMode where ppr = text . show -type SigOf = ModuleNameEnv Module - -getSigOf :: DynFlags -> ModuleName -> Maybe Module -getSigOf dflags n = lookupUFM (sigOf dflags) n - -- | 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 { @@ -654,8 +650,6 @@ data DynFlags = DynFlags { ghcLink :: GhcLink, hscTarget :: HscTarget, settings :: Settings, - -- See Note [Signature parameters in TcGblEnv and DynFlags] - sigOf :: SigOf, -- ^ Compiling an hs-boot against impl. verbosity :: Int, -- ^ Verbosity level: see Note [Verbosity levels] optLevel :: Int, -- ^ Optimisation level debugLevel :: Int, -- ^ How much debug information to produce @@ -694,7 +688,9 @@ data DynFlags = DynFlags { solverIterations :: IntWithInf, -- ^ Number of iterations in the constraints solver -- Typically only 1 is needed - thisPackage :: UnitId, -- ^ key of package currently being compiled + thisPackage :: UnitId, -- ^ unit id of package currently being compiled. + -- Not properly initialized until initPackages + thisUnitIdInsts :: [(ModuleName, Module)], -- ways ways :: [Way], -- ^ Way flags from the command line @@ -1159,8 +1155,11 @@ isNoLink _ = False -- is used. data PackageArg = PackageArg String -- ^ @-package@, by 'PackageName' - | UnitIdArg String -- ^ @-package-id@, by 'UnitId' + | 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)"@. @@ -1178,6 +1177,8 @@ data ModRenaming = ModRenaming { 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@ @@ -1197,6 +1198,10 @@ data PackageFlag -- NB: equality instance is used by InteractiveUI to test if -- package flags have changed. +instance Outputable PackageFlag where + ppr (ExposePackage n arg rn) = text n <> braces (ppr arg <+> ppr rn) + ppr (HidePackage str) = text "-hide-package" <+> text str + defaultHscTarget :: Platform -> HscTarget defaultHscTarget = defaultObjectTarget @@ -1452,7 +1457,6 @@ defaultDynFlags mySettings = ghcMode = CompManager, ghcLink = LinkBinary, hscTarget = defaultHscTarget (sTargetPlatform mySettings), - sigOf = emptyUFM, verbosity = 0, optLevel = 0, debugLevel = 0, @@ -1484,6 +1488,7 @@ defaultDynFlags mySettings = solverIterations = treatZeroAsInf mAX_SOLVER_ITERATIONS, thisPackage = mainUnitId, + thisUnitIdInsts = [], objectDir = Nothing, dylibInstallName = Nothing, @@ -1782,6 +1787,7 @@ dopt f dflags = (fromEnum f `IntSet.member` dumpFlags dflags) enableIfVerbose Opt_D_dump_vt_trace = False enableIfVerbose Opt_D_dump_tc = False enableIfVerbose Opt_D_dump_rn = False + enableIfVerbose Opt_D_dump_shape = False enableIfVerbose Opt_D_dump_rn_stats = False enableIfVerbose Opt_D_dump_hi_diffs = False enableIfVerbose Opt_D_verbose_core2core = False @@ -1997,26 +2003,29 @@ setOutputFile f d = d { outputFile = f} setDynOutputFile f d = d { dynOutputFile = f} setOutputHi f d = d { outputHi = f} -parseSigOf :: String -> SigOf -parseSigOf str = case filter ((=="").snd) (readP_to_S parse str) of +parseUnitIdInsts :: String -> [(ModuleName, Module)] +parseUnitIdInsts str = case filter ((=="").snd) (readP_to_S parse str) of [(r, "")] -> r - _ -> throwGhcException $ CmdLineError ("Can't parse -sig-of: " ++ str) - where parse = listToUFM <$> sepBy parseEntry (R.char ',') + _ -> throwGhcException $ CmdLineError ("Can't parse -instantiated-with: " ++ str) + where parse = sepBy parseEntry (R.char ',') parseEntry = do - n <- tok $ parseModuleName - -- ToDo: deprecate this 'is' syntax? - tok $ ((string "is" >> return ()) +++ (R.char '=' >> return ())) - m <- tok $ parseModule + n <- parseModuleName + _ <- R.char '=' + m <- parseModuleId return (n, m) - parseModule = do - pk <- munch1 (\c -> isAlphaNum c || c `elem` "-_.") - _ <- R.char ':' - m <- parseModuleName - return (mkModule (stringToUnitId pk) m) - tok m = skipSpaces >> m -setSigOf :: String -> DynFlags -> DynFlags -setSigOf s d = d { sigOf = parseSigOf s } +setUnitIdInsts :: String -> DynFlags -> DynFlags +setUnitIdInsts s d = updateWithInsts (parseUnitIdInsts s) d + +updateWithInsts :: [(ModuleName, Module)] -> DynFlags -> DynFlags +updateWithInsts insts d = + -- Overwrite the instances, the instances are "indefinite" + d { thisPackage = + if not (null insts) && all (\(x,y) -> mkHoleModule x == y) insts + then newUnitId (unitIdComponentId (thisPackage d)) insts + else thisPackage d + , thisUnitIdInsts = insts + } addPluginModuleName :: String -> DynFlags -> DynFlags addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) } @@ -2358,7 +2367,7 @@ dynamic_flags_deps = [ -- as specifing that the number of -- parallel builds is equal to the -- result of getNumProcessors - , make_ord_flag defFlag "sig-of" (sepArg setSigOf) + , make_ord_flag defFlag "instantiated-with" (sepArg setUnitIdInsts) -- RTS options ------------------------------------------------------------- , make_ord_flag defFlag "H" (HasArg (\s -> upd (\d -> @@ -2719,6 +2728,8 @@ dynamic_flags_deps = [ (setDumpFlag Opt_D_dump_worker_wrapper) , make_ord_flag defGhcFlag "ddump-rn-trace" (setDumpFlag Opt_D_dump_rn_trace) + , make_ord_flag defGhcFlag "ddump-shape" + (setDumpFlag Opt_D_dump_shape) , make_ord_flag defGhcFlag "ddump-if-trace" (setDumpFlag Opt_D_dump_if_trace) , make_ord_flag defGhcFlag "ddump-cs-trace" @@ -4280,22 +4291,18 @@ removeGlobalPkgConf = upd $ \s -> s { extraPkgConfs = filter isNotGlobal . extra clearPkgConf :: DynP () clearPkgConf = upd $ \s -> s { extraPkgConfs = const [] } -parseModuleName :: ReadP ModuleName -parseModuleName = fmap mkModuleName - $ munch1 (\c -> isAlphaNum c || c `elem` "_.") - parsePackageFlag :: String -- the flag - -> (String -> PackageArg) -- type of argument + -> ReadP PackageArg -- type of argument -> String -- string to parse -> PackageFlag -parsePackageFlag flag constr str +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 <- tok $ munch1 (\c -> isAlphaNum c || c `elem` ":-_.") - let mk_expose = ExposePackage doc (constr pkg) + 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 @@ -4320,13 +4327,13 @@ exposePackage, exposePackageId, hidePackage, exposePackage p = upd (exposePackage' p) exposePackageId p = upd (\s -> s{ packageFlags = - parsePackageFlag "-package-id" UnitIdArg p : packageFlags s }) + parsePackageFlag "-package-id" parseUnitIdArg p : packageFlags s }) exposePluginPackage p = upd (\s -> s{ pluginPackageFlags = - parsePackageFlag "-plugin-package" PackageArg p : pluginPackageFlags s }) + parsePackageFlag "-plugin-package" parsePackageArg p : pluginPackageFlags s }) exposePluginPackageId p = upd (\s -> s{ pluginPackageFlags = - parsePackageFlag "-plugin-package-id" UnitIdArg p : pluginPackageFlags s }) + parsePackageFlag "-plugin-package-id" parseUnitIdArg p : pluginPackageFlags s }) hidePackage p = upd (\s -> s{ packageFlags = HidePackage p : packageFlags s }) ignorePackage p = @@ -4340,10 +4347,38 @@ distrustPackage p = exposePackage p >> exposePackage' :: String -> DynFlags -> DynFlags exposePackage' p dflags = dflags { packageFlags = - parsePackageFlag "-package" PackageArg p : packageFlags dflags } + 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 + + +thisUnitIdComponentId :: DynFlags -> ComponentId +thisUnitIdComponentId = unitIdComponentId . thisPackage setUnitId :: String -> DynFlags -> DynFlags -setUnitId p s = s{ thisPackage = stringToUnitId p } +setUnitId p d = + updateWithInsts (thisUnitIdInsts d) $ d{ thisPackage = uid } + where + uid = + case filter ((=="").snd) (readP_to_S parseUnitId p) of + [(r, "")] -> r + _ -> throwGhcException $ CmdLineError ("Can't parse component id: " ++ 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 + -- ----------------------------------------------------------------------------- -- | Find the package environment (if one exists) diff --git a/compiler/main/Finder.hs b/compiler/main/Finder.hs index 446cdf87e5..e813e9e52c 100644 --- a/compiler/main/Finder.hs +++ b/compiler/main/Finder.hs @@ -86,7 +86,7 @@ removeFromFinderCache :: IORef FinderCache -> Module -> IO () removeFromFinderCache ref key = atomicModifyIORef' ref $ \c -> (delModuleEnv c key, ()) -lookupFinderCache :: IORef FinderCache -> Module -> IO (Maybe FindResult) +lookupFinderCache :: IORef FinderCache -> VirginModule -> IO (Maybe FindResult) lookupFinderCache ref key = do c <- readIORef ref return $! lookupModuleEnv c key @@ -131,7 +131,7 @@ findPluginModule hsc_env mod_name = -- reading the interface for a module mentioned by another interface, -- for example (a "system import"). -findExactModule :: HscEnv -> Module -> IO FindResult +findExactModule :: HscEnv -> VirginModule -> IO FindResult findExactModule hsc_env mod = let dflags = hsc_dflags hsc_env in if moduleUnitId mod == thisPackage dflags @@ -205,7 +205,7 @@ findLookupResult hsc_env r = case r of , fr_mods_hidden = [] , fr_suggestions = suggest }) -modLocationCache :: HscEnv -> Module -> IO FindResult -> IO FindResult +modLocationCache :: HscEnv -> VirginModule -> IO FindResult -> IO FindResult modLocationCache hsc_env mod do_this = do m <- lookupFinderCache (hsc_FC hsc_env) mod case m of @@ -281,7 +281,7 @@ findHomeModule hsc_env mod_name = -- | Search for a module in external packages only. -findPackageModule :: HscEnv -> Module -> IO FindResult +findPackageModule :: HscEnv -> VirginModule -> IO FindResult findPackageModule hsc_env mod = do let dflags = hsc_dflags hsc_env @@ -298,7 +298,7 @@ findPackageModule hsc_env mod = do -- the 'PackageConfig' must be consistent with the unit id in the 'Module'. -- The redundancy is to avoid an extra lookup in the package state -- for the appropriate config. -findPackageModule_ :: HscEnv -> Module -> PackageConfig -> IO FindResult +findPackageModule_ :: HscEnv -> VirginModule -> PackageConfig -> IO FindResult findPackageModule_ hsc_env mod pkg_conf = ASSERT( moduleUnitId mod == packageConfigId pkg_conf ) modLocationCache hsc_env mod $ diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index 0adee6e738..998d68c11a 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -14,12 +14,18 @@ -- ----------------------------------------------------------------------------- module GhcMake( depanal, - load, LoadHowMuch(..), + load, load', LoadHowMuch(..), topSortModuleGraph, ms_home_srcimps, ms_home_imps, + IsBoot(..), + summariseModule, + hscSourceToIsBoot, + findExtraSigImports, + implicitRequirements, + noModError, cyclicModuleErr ) where @@ -40,6 +46,7 @@ import HscTypes import Module import TcIface ( typecheckIface ) import TcRnMonad ( initIfaceCheck ) +import HscMain import Bag ( listToBag ) import BasicTypes @@ -55,9 +62,14 @@ import SrcLoc import StringBuffer import SysTools import UniqFM +import UniqDSet +import TcBackpack +import Packages +import UniqSet import Util import qualified GHC.LanguageExtensions as LangExt import NameEnv +import TcRnDriver (findExtraSigImports, implicitRequirements) import Data.Either ( rights, partitionEithers ) import qualified Data.Map as Map @@ -153,6 +165,14 @@ data LoadHowMuch load :: GhcMonad m => LoadHowMuch -> m SuccessFlag load how_much = do mod_graph <- depanal [] False + load' how_much (Just batchMsg) mod_graph + +-- | 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 @@ -297,7 +317,7 @@ load how_much = do setSession hsc_env{ hsc_HPT = emptyHomePackageTable } (upsweep_ok, modsUpswept) - <- upsweep_fn pruned_hpt stable_mods cleanup mg + <- 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. @@ -741,16 +761,20 @@ parUpsweep :: GhcMonad m => Int -- ^ The number of workers we wish to run in parallel + -> Maybe Messager -> HomePackageTable -> ([ModuleName],[ModuleName]) -> (HscEnv -> IO ()) -> [SCC ModSummary] -> m (SuccessFlag, [ModSummary]) -parUpsweep n_jobs old_hpt stable_mods cleanup sccs = do +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 @@ -840,7 +864,7 @@ parUpsweep n_jobs old_hpt stable_mods cleanup sccs = do -- 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 cleanup + lcl_dflags mHscMessage cleanup par_sem hsc_env_var old_hpt_var stable_mods mod_idx (length sccs) @@ -939,6 +963,8 @@ parUpsweep_one -- ^ 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 @@ -955,7 +981,7 @@ parUpsweep_one -- ^ The total number of modules -> IO SuccessFlag -- ^ The result of this compile -parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags cleanup par_sem +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 @@ -1070,7 +1096,7 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags cleanup par_sem map (moduleName . fst) loop -- Compile the module. - mod_info <- upsweep_mod lcl_hsc_env'' old_hpt stable_mods + mod_info <- upsweep_mod lcl_hsc_env'' mHscMessage old_hpt stable_mods lcl_mod mod_index num_mods return (Just mod_info) @@ -1122,7 +1148,8 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags cleanup par_sem -- There better had not be any cyclic groups here -- we check for them. upsweep :: GhcMonad m - => HomePackageTable -- ^ HPT from last time round (pruned) + => Maybe Messager + -> HomePackageTable -- ^ HPT from last time round (pruned) -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability) -> (HscEnv -> IO ()) -- ^ How to clean up unwanted tmp files -> [SCC ModSummary] -- ^ Mods to do (the worklist) @@ -1134,23 +1161,28 @@ upsweep -- 2. The 'HscEnv' in the monad has an updated HPT -- 3. A list of modules which succeeded loading. -upsweep old_hpt stable_mods cleanup sccs = do +upsweep mHscMessage old_hpt stable_mods cleanup sccs = do + dflags <- getSessionDynFlags (res, done) <- upsweep' old_hpt [] sccs 1 (length sccs) + (unitIdsToCheck dflags) done_holes return (res, reverse done) where + done_holes = emptyUniqSet upsweep' _old_hpt done - [] _ _ - = return (Succeeded, 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:_) _ _ + (CyclicSCC ms:_) _ _ _ _ = do dflags <- getSessionDynFlags liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms) return (Failed, done) upsweep' old_hpt done - (AcyclicSCC mod:mods) mod_index nmods + (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))) @@ -1158,6 +1190,18 @@ upsweep old_hpt stable_mods cleanup sccs = do 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) @@ -1178,7 +1222,7 @@ upsweep old_hpt stable_mods cleanup sccs = do mb_mod_info <- handleSourceError (\err -> do logger mod (Just err); return Nothing) $ do - mod_info <- liftIO $ upsweep_mod hsc_env2 old_hpt stable_mods + 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) @@ -1212,7 +1256,16 @@ upsweep old_hpt stable_mods cleanup sccs = do hsc_env4 <- liftIO $ reTypecheckLoop hsc_env3 mod done' setSession hsc_env4 - upsweep' old_hpt1 done' mods (mod_index+1) nmods + 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 insts) -> uid : concatMap (goUnitId . moduleUnitId . snd) insts + _ -> [] maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime) maybeGetIfaceDate dflags location @@ -1226,13 +1279,14 @@ maybeGetIfaceDate dflags location -- | 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 -> ([ModuleName],[ModuleName]) -> ModSummary -> Int -- index of module -> Int -- total number of modules -> IO HomeModInfo -upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods +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 @@ -1285,13 +1339,13 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo compile_it mb_linkable src_modified = - compileOne hsc_env summary' mod_index nmods + 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 hsc_env summary' mod_index nmods + compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods Nothing mb_linkable src_modified -- With the HscNothing target we create empty linkables to avoid @@ -1510,7 +1564,9 @@ topSortModuleGraph topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph where - (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes summaries + -- 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 @@ -1662,15 +1718,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots summs <- loop (concatMap calcDeps rootSummariesOk) root_map return summs where - -- When we're compiling a signature file, we have an implicit - -- dependency on what-ever the signature's implementation is. - -- (But not when we're type checking!) - calcDeps summ - | HsigFile <- ms_hsc_src summ - , Just m <- getSigOf (hsc_dflags hsc_env) (moduleName (ms_mod summ)) - , moduleUnitId m == thisPackage (hsc_dflags hsc_env) - = (noLoc (moduleName m), NotBoot) : msDeps summ - | otherwise = msDeps summ + calcDeps = msDeps dflags = hsc_dflags hsc_env roots = hsc_targets hsc_env @@ -1691,7 +1739,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots (L rootLoc modl) obj_allowed maybe_buf excl_mods case maybe_summary of - Nothing -> return $ Left $ packageModErr dflags modl + Nothing -> return $ Left $ moduleNotFoundErr dflags modl Just s -> return s rootLoc = mkGeneralSrcSpan (fsLit "<command line>") @@ -1865,12 +1913,17 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf hi_timestamp <- maybeGetIfaceDate dflags location + extra_sig_imports <- findExtraSigImports hsc_env hsc_src mod_name + required_by_imports <- implicitRequirements hsc_env the_imps + return (ModSummary { ms_mod = mod, ms_hsc_src = hsc_src, ms_location = location, ms_hspp_file = hspp_fn, ms_hspp_opts = dflags', ms_hspp_buf = Just buf, - ms_srcimps = srcimps, ms_textual_imps = the_imps, + ms_parsed_mod = Nothing, + ms_srcimps = srcimps, + ms_textual_imps = the_imps ++ extra_sig_imports ++ required_by_imports, ms_hs_date = src_timestamp, ms_iface_date = hi_timestamp, ms_obj_date = obj_timestamp }) @@ -2003,14 +2056,18 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) hi_timestamp <- maybeGetIfaceDate dflags location + extra_sig_imports <- findExtraSigImports hsc_env hsc_src mod_name + required_by_imports <- implicitRequirements hsc_env the_imps + return (Just (Right (ModSummary { ms_mod = mod, ms_hsc_src = hsc_src, ms_location = location, ms_hspp_file = hspp_fn, ms_hspp_opts = dflags', ms_hspp_buf = Just buf, + ms_parsed_mod = Nothing, ms_srcimps = srcimps, - ms_textual_imps = the_imps, + ms_textual_imps = the_imps ++ extra_sig_imports ++ required_by_imports, ms_hs_date = src_timestamp, ms_iface_date = hi_timestamp, ms_obj_date = obj_timestamp }))) @@ -2070,10 +2127,10 @@ noHsFileErr :: DynFlags -> SrcSpan -> String -> ErrMsg noHsFileErr dflags loc path = mkPlainErrMsg dflags loc $ text "Can't find" <+> text path -packageModErr :: DynFlags -> ModuleName -> ErrMsg -packageModErr dflags mod +moduleNotFoundErr :: DynFlags -> ModuleName -> ErrMsg +moduleNotFoundErr dflags mod = mkPlainErrMsg dflags noSrcSpan $ - text "module" <+> quotes (ppr mod) <+> text "is a package module" + text "module" <+> quotes (ppr mod) <+> text "cannot be found locally" multiRootsErr :: DynFlags -> [ModSummary] -> IO () multiRootsErr _ [] = panic "multiRootsErr" diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 5e14e77117..cd8b56843f 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -79,6 +79,8 @@ module HscMain , hscSimpleIface', hscNormalIface' , oneShotMsg , hscFileFrontEnd, genericHscFrontend, dumpIfaceStats + , ioMsgMaybe + , showModuleIndex ) where #ifdef GHCI @@ -135,6 +137,7 @@ import InstEnv import FamInstEnv import Fingerprint ( Fingerprint ) import Hooks +import TcEnv import Maybes import DynFlags @@ -342,7 +345,9 @@ 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 = {-# SCC "Parser" #-} +hscParse' mod_summary + | Just r <- ms_parsed_mod mod_summary = return r + | otherwise = {-# SCC "Parser" #-} withTiming getDynFlags (text "Parser"<+>brackets (ppr $ ms_mod mod_summary)) (const ()) $ do @@ -359,8 +364,11 @@ hscParse' mod_summary = {-# SCC "Parser" #-} 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 parseModule (mkPState dflags buf loc) of + case unP parseMod (mkPState dflags buf loc) of PFailed span err -> liftIO $ throwOneError (mkPlainErrMsg dflags span err) @@ -417,7 +425,7 @@ type RenamedStuff = hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule -> IO (TcGblEnv, RenamedStuff) hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do - tc_result <- tcRnModule' hsc_env mod_summary True rdr_module + tc_result <- hscTypecheck True mod_summary (Just rdr_module) -- This 'do' is in the Maybe monad! let rn_info = do decl <- tcg_rn_decls tc_result @@ -428,6 +436,31 @@ hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do return (tc_result, rn_info) +hscTypecheck :: Bool -- ^ Keep renamed source? + -> ModSummary -> Maybe HsParsedModule + -> Hsc TcGblEnv +hscTypecheck keep_rn mod_summary mb_rdr_module = do + hsc_env <- getHscEnv + let hsc_src = ms_hsc_src mod_summary + dflags = hsc_dflags hsc_env + outer_mod = ms_mod mod_summary + inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod) + src_filename = ms_hspp_file mod_summary + real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1 + MASSERT( moduleUnitId outer_mod == thisPackage dflags ) + 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' hsc_env mod_summary keep_rn hpm + if hsc_src == HsigFile + then do (iface, _, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 Nothing + ioMsgMaybe $ + tcRnMergeSignatures hsc_env (tcg_top_loc tc_result0) iface + else return tc_result0 + -- wrapper around tcRnModule to handle safe haskell extras tcRnModule' :: HscEnv -> ModSummary -> Bool -> HsParsedModule -> Hsc TcGblEnv @@ -689,11 +722,12 @@ hscIncrementalCompile always_do_basic_recompilation_check m_tc_result -- to retypecheck but the resulting interface is exactly -- the same.) Right (FrontendTypecheck tc_result, mb_old_hash) -> do - (status, hmi, no_change) <- - if hscTarget dflags /= HscNothing && - ms_hsc_src mod_summary == HsSrcFile - then finish hsc_env mod_summary tc_result mb_old_hash - else finishTypecheckOnly hsc_env mod_summary tc_result mb_old_hash + (status, hmi, no_change) + <- case ms_hsc_src mod_summary of + HsSrcFile | hscTarget dflags /= HscNothing -> + finish hsc_env mod_summary tc_result mb_old_hash + _ -> + finishTypecheckOnly hsc_env mod_summary tc_result mb_old_hash liftIO $ hscMaybeWriteIface dflags (hm_iface hmi) no_change mod_summary return (status, hmi) @@ -803,11 +837,7 @@ batchMsg hsc_env mod_index recomp mod_summary = -- | Given a 'ModSummary', parses and typechecks it, returning the -- 'TcGblEnv' resulting from type-checking. hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv -hscFileFrontEnd mod_summary = do - hpm <- hscParse' mod_summary - hsc_env <- getHscEnv - tcg_env <- tcRnModule' hsc_env mod_summary False hpm - return tcg_env +hscFileFrontEnd mod_summary = hscTypecheck False mod_summary Nothing -------------------------------------------------------------- -- Safe Haskell diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index 127775e822..c2d2938b45 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -73,6 +73,9 @@ module HscTypes ( -- * Interfaces ModIface(..), mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache, emptyIfaceWarnCache, mi_boot, mi_fix, + mi_semantic_module, + mi_free_holes, + renameFreeHoles, -- * Fixity FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv, @@ -139,9 +142,9 @@ import ByteCodeTypes import InteractiveEvalTypes ( Resume ) import GHCi.Message ( Pipe ) import GHCi.RemoteTypes -import UniqFM #endif +import UniqFM import HsSyn import RdrName import Avail @@ -191,6 +194,7 @@ import Binary import ErrUtils import Platform import Util +import UniqDSet import GHC.Serialized ( Serialized ) import Foreign @@ -770,9 +774,13 @@ prepareAnnotations hsc_env mb_guts = do -- Although the @FinderCache@ range is 'FindResult' for convenience, -- in fact it will only ever contain 'Found' or 'NotFound' entries. -- -type FinderCache = ModuleEnv FindResult +type FinderCache = VirginModuleEnv FindResult -- | 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 'VirginModule'). data FindResult = Found ModLocation Module -- ^ The module was found @@ -936,6 +944,42 @@ mi_boot iface = mi_hsc_src iface == HsBootFile mi_fix :: ModIface -> OccName -> Fixity mi_fix iface name = mi_fix_fn 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 -> 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 insts) + -- A mini-hack: we rely on the fact that 'renameFreeHoles' + -- drops things that aren't holes. + -> renameFreeHoles (mkUniqDSet cands) insts + _ -> 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, @@ -964,6 +1008,7 @@ instance Binary ModIface where mi_trust = trust, mi_trust_pkg = trust_pkg }) = do put_ bh mod + put_ bh sig_of put_ bh hsc_src put_ bh iface_hash put_ bh mod_hash @@ -987,10 +1032,10 @@ instance Binary ModIface where put_ bh hpc_info put_ bh trust put_ bh trust_pkg - put_ bh sig_of get bh = do - mod_name <- get bh + mod <- get bh + sig_of <- get bh hsc_src <- get bh iface_hash <- get bh mod_hash <- get bh @@ -1014,9 +1059,8 @@ instance Binary ModIface where hpc_info <- get bh trust <- get bh trust_pkg <- get bh - sig_of <- get bh return (ModIface { - mi_module = mod_name, + mi_module = mod, mi_sig_of = sig_of, mi_hsc_src = hsc_src, mi_iface_hash = iface_hash, @@ -1997,7 +2041,10 @@ lookupType dflags hpt pte name Just hm -> lookupNameEnv (md_types (hm_details hm)) name Nothing -> lookupNameEnv pte name where - mod = ASSERT2( isExternalName name, ppr name ) nameModule name + 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' @@ -2280,6 +2327,11 @@ data Usage -- 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 @@ -2314,6 +2366,11 @@ instance Binary Usage where 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 @@ -2334,6 +2391,10 @@ instance Binary Usage where 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) {- @@ -2388,6 +2449,16 @@ data ExternalPackageState -- -- * Deprecations and warnings + eps_free_holes :: ModuleEnv (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 @@ -2519,6 +2590,9 @@ data ModSummary -- ^ 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, @@ -2577,24 +2651,12 @@ showModMsg dflags target recomp mod_summary HscInterpreted | recomp -> text "interpreted" HscNothing -> text "nothing" - _ | HsigFile == ms_hsc_src mod_summary -> text "nothing" - | otherwise -> text (normalise $ msObjFilePath mod_summary), + _ -> text (normalise $ msObjFilePath mod_summary), char ')'] where mod = moduleName (ms_mod mod_summary) mod_str = showPpr dflags mod - ++ hscSourceString' dflags mod (ms_hsc_src mod_summary) - --- | Variant of hscSourceString which prints more information for signatures. --- This can't live in DriverPhases because this would cause a module loop. -hscSourceString' :: DynFlags -> ModuleName -> HscSource -> String -hscSourceString' _ _ HsSrcFile = "" -hscSourceString' _ _ HsBootFile = "[boot]" -hscSourceString' dflags mod HsigFile = - "[" ++ (maybe "abstract sig" - (("sig of "++).showPpr dflags) - (getSigOf dflags mod)) ++ "]" - -- NB: -sig-of could be missing if we're just typechecking + ++ hscSourceString (ms_hsc_src mod_summary) {- ************************************************************************ diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs index cda8f7f12c..f16c902a7e 100644 --- a/compiler/main/PackageConfig.hs +++ b/compiler/main/PackageConfig.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, RecordWildCards, MultiParamTypeClasses #-} +{-# LANGUAGE CPP, RecordWildCards, FlexibleInstances, MultiParamTypeClasses #-} -- | -- Package configuration information: essentially the interface to Cabal, with @@ -11,6 +11,7 @@ module PackageConfig ( -- * UnitId packageConfigId, + expandedPackageConfigId, -- * The PackageConfig type: information about a package PackageConfig, @@ -40,9 +41,11 @@ import Unique -- which is similar to a subset of the InstalledPackageInfo type from Cabal. type PackageConfig = InstalledPackageInfo + ComponentId SourcePackageId PackageName Module.UnitId + Module.UnitId Module.ModuleName Module.Module @@ -50,14 +53,9 @@ type PackageConfig = InstalledPackageInfo -- feature, but ghc doesn't currently have convenient support for any -- other compact string types, e.g. plain ByteString or Text. -newtype ComponentId = ComponentId FastString deriving (Eq, Ord) newtype SourcePackageId = SourcePackageId FastString deriving (Eq, Ord) newtype PackageName = PackageName FastString deriving (Eq, Ord) -instance BinaryStringRep ComponentId where - fromStringRep = ComponentId . mkFastStringByteString - toStringRep (ComponentId s) = fastStringToByteString s - instance BinaryStringRep SourcePackageId where fromStringRep = SourcePackageId . mkFastStringByteString toStringRep (SourcePackageId s) = fastStringToByteString s @@ -66,18 +64,12 @@ instance BinaryStringRep PackageName where fromStringRep = PackageName . mkFastStringByteString toStringRep (PackageName s) = fastStringToByteString s -instance Uniquable ComponentId where - getUnique (ComponentId n) = getUnique n - instance Uniquable SourcePackageId where getUnique (SourcePackageId n) = getUnique n instance Uniquable PackageName where getUnique (PackageName n) = getUnique n -instance Outputable ComponentId where - ppr (ComponentId str) = ftext str - instance Outputable SourcePackageId where ppr (SourcePackageId str) = ftext str @@ -125,7 +117,6 @@ pprPackageConfig InstalledPackageInfo {..} = where field name body = text name <> colon <+> nest 4 body - -- ----------------------------------------------------------------------------- -- UnitId (package names, versions and dep hash) @@ -140,3 +131,9 @@ pprPackageConfig InstalledPackageInfo {..} = -- | Get the GHC 'UnitId' right out of a Cabalish 'PackageConfig' packageConfigId :: PackageConfig -> UnitId packageConfigId = unitId + +expandedPackageConfigId :: PackageConfig -> UnitId +expandedPackageConfigId p = + case instantiatedWith p of + [] -> packageConfigId p + _ -> newUnitId (unitIdComponentId (packageConfigId p)) (instantiatedWith p) diff --git a/compiler/main/PackageConfig.hs-boot b/compiler/main/PackageConfig.hs-boot new file mode 100644 index 0000000000..c65bf472a4 --- /dev/null +++ b/compiler/main/PackageConfig.hs-boot @@ -0,0 +1,7 @@ +module PackageConfig where +import FastString +import {-# SOURCE #-} Module +import GHC.PackageDb +newtype PackageName = PackageName FastString +newtype SourcePackageId = SourcePackageId FastString +type PackageConfig = InstalledPackageInfo ComponentId SourcePackageId PackageName UnitId ModuleName Module diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs index 0c91af284d..3003e015b6 100644 --- a/compiler/main/Packages.hs +++ b/compiler/main/Packages.hs @@ -1,13 +1,14 @@ -- (c) The University of Glasgow, 2006 -{-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns #-} +{-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns, FlexibleContexts #-} -- | Package manipulation module Packages ( module PackageConfig, -- * Reading the package config, and processing cmdline args - PackageState(preloadPackages, explicitPackages), + PackageState(preloadPackages, explicitPackages, requirementContext), + PackageConfigMap, emptyPackageState, initPackages, readPackageConfigs, @@ -18,8 +19,13 @@ module Packages ( -- * Querying the package config lookupPackage, + lookupPackage', + lookupPackageName, + lookupComponentId, + improveUnitId, searchPackageId, getPackageDetails, + componentIdString, listVisibleModuleNames, lookupModuleInAllPackages, lookupModuleWithSuggestions, @@ -35,13 +41,14 @@ module Packages ( getPackageExtraCcOpts, getPackageFrameworkPath, getPackageFrameworks, + getPackageConfigMap, getPreloadPackagesAnd, collectIncludeDirs, collectLibraryPaths, collectLinkOpts, packageHsLibs, -- * Utils - unitIdPackageIdString, + unwireUnitId, pprFlag, pprPackages, pprPackagesSimple, @@ -66,9 +73,8 @@ import Maybes import System.Environment ( getEnv ) import FastString -import ErrUtils ( debugTraceMsg, MsgDoc ) +import ErrUtils ( debugTraceMsg, MsgDoc, printInfoForUser ) import Exception -import Unique import System.Directory import System.FilePath as FilePath @@ -78,6 +84,8 @@ import Data.Char ( toUpper ) import Data.List as List import Data.Map (Map) import Data.Set (Set) +import Data.Maybe (mapMaybe) +import Data.Monoid (First(..)) #if __GLASGOW_HASKELL__ > 710 import Data.Semigroup ( Semigroup ) import qualified Data.Semigroup as Semigroup @@ -234,14 +242,57 @@ originEmpty _ = False type UnitIdMap = UniqDFM -- | 'UniqFM' map from 'UnitId' to 'PackageConfig' -type PackageConfigMap = UnitIdMap PackageConfig +-- (newtyped so we can put it in boot.) +newtype PackageConfigMap = PackageConfigMap { unPackageConfigMap :: UnitIdMap PackageConfig } + +-- | '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 HoleModule) + -- ^ 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.) + } --- | 'UniqFM' map from 'UnitId' to (1) whether or not all modules which --- are exposed should be dumped into scope, (2) any custom renamings that --- should also be apply, and (3) what package name is associated with the --- key, if it might be hidden -type VisibilityMap = - UnitIdMap (Bool, [(ModuleName, ModuleName)], FastString) +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 Monoid UnitVisibility where + mempty = UnitVisibility + { uv_expose_all = False + , uv_renamings = [] + , uv_package_name = First Nothing + , uv_requirements = Map.empty + , uv_explicit = False + } + mappend uv1 uv2 + = UnitVisibility + { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2 + , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2 + , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2) + , uv_requirements = Map.unionWith Set.union (uv_requirements uv1) (uv_requirements uv2) + , uv_explicit = uv_explicit uv1 || uv_explicit uv2 + } -- | Map from 'ModuleName' to 'Module' to all the origins of the bindings -- in scope. The 'PackageConf' is not cached, mostly for convenience reasons @@ -257,6 +308,14 @@ data PackageState = PackageState { -- may have the 'exposed' flag be 'False'.) pkgIdMap :: PackageConfigMap, + -- | 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 UnitId UnitId, + -- | 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. @@ -272,30 +331,65 @@ data PackageState = PackageState { moduleToPkgConfAll :: !ModuleToPkgConfAll, -- | A map, like 'moduleToPkgConfAll', but controlling plugin visibility. - pluginModuleToPkgConfAll :: !ModuleToPkgConfAll + pluginModuleToPkgConfAll :: !ModuleToPkgConfAll, + + -- | 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 [HoleModule] } emptyPackageState :: PackageState emptyPackageState = PackageState { pkgIdMap = emptyPackageConfigMap, + packageNameMap = Map.empty, + unwireMap = Map.empty, preloadPackages = [], explicitPackages = [], moduleToPkgConfAll = Map.empty, - pluginModuleToPkgConfAll = Map.empty + pluginModuleToPkgConfAll = Map.empty, + requirementContext = Map.empty } type InstalledPackageIndex = Map UnitId PackageConfig -- | Empty package configuration map emptyPackageConfigMap :: PackageConfigMap -emptyPackageConfigMap = emptyUDFM +emptyPackageConfigMap = PackageConfigMap emptyUDFM --- | Find the package we know about with the given key (e.g. @foo_HASH@), if any +-- | Find the package we know about with the given unit id, if any lookupPackage :: DynFlags -> UnitId -> Maybe PackageConfig -lookupPackage dflags = lookupPackage' (pkgIdMap (pkgState dflags)) +lookupPackage dflags = lookupPackage' (isIndefinite dflags) (pkgIdMap (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 'PackageConfigMap' rather than a 'DynFlags' (so it can +-- be used while we're initializing 'DynFlags' +lookupPackage' :: Bool -> PackageConfigMap -> UnitId -> Maybe PackageConfig +lookupPackage' False (PackageConfigMap pkg_map) uid = lookupUDFM pkg_map uid +lookupPackage' True (PackageConfigMap pkg_map) uid = + case splitUnitIdInsts uid of + (iuid, Just insts) -> + fmap (renamePackage (PackageConfigMap pkg_map) insts) + (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 PackageConfig +lookupComponentId dflags (ComponentId cid_fs) = lookupUDFM pkg_map cid_fs + where + PackageConfigMap pkg_map = pkgIdMap (pkgState dflags) -lookupPackage' :: PackageConfigMap -> UnitId -> Maybe PackageConfig -lookupPackage' = lookupUDFM +-- | 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 -> [PackageConfig] @@ -305,9 +399,12 @@ searchPackageId dflags pid = filter ((pid ==) . sourcePackageId) -- | Extends the package configuration map with a list of package configs. extendPackageConfigMap :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap -extendPackageConfigMap pkg_map new_pkgs - = foldl add pkg_map new_pkgs - where add pkg_map p = addToUDFM pkg_map (packageConfigId p) p +extendPackageConfigMap (PackageConfigMap pkg_map) new_pkgs + = PackageConfigMap (foldl add pkg_map new_pkgs) + -- We also add the expanded version of the packageConfigId, so that + -- 'improveUnitId' can find it. + where add pkg_map p = addToUDFM (addToUDFM pkg_map (expandedPackageConfigId p) p) + (packageConfigId p) p -- | Looks up the package with the given id in the package state, panicing if it is -- not found @@ -320,7 +417,9 @@ getPackageDetails dflags pid = -- does not imply that the exposed-modules of the package are available -- (they may have been thinned or renamed). listPackageConfigMap :: DynFlags -> [PackageConfig] -listPackageConfigMap dflags = eltsUDFM (pkgIdMap (pkgState dflags)) +listPackageConfigMap dflags = eltsUDFM pkg_map + where + PackageConfigMap pkg_map = pkgIdMap (pkgState dflags) -- ---------------------------------------------------------------------------- -- Loading the package db files and building up the package state @@ -346,11 +445,10 @@ initPackages dflags0 = do Nothing -> readPackageConfigs dflags Just db -> return $ map (\(p, pkgs) -> (p, setBatchPackageFlags dflags pkgs)) db - (pkg_state, preload, this_pkg) + (pkg_state, preload) <- mkPackageState dflags pkg_db [] return (dflags{ pkgDatabase = Just pkg_db, - pkgState = pkg_state, - thisPackage = this_pkg }, + pkgState = pkg_state }, preload) -- ----------------------------------------------------------------------------- @@ -522,19 +620,25 @@ applyTrustFlag dflags unusable pkgs flag = -- we trust all matching packages. Maybe should only trust first one? -- and leave others the same or set them untrusted TrustPackage str -> - case selectPackages (matchingStr str) pkgs unusable of + case selectPackages (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 (matchingStr str) pkgs unusable of + case selectPackages (PackageArg str) pkgs unusable of Left ps -> trustFlagErr dflags flag ps Right (ps,qs) -> return (map distrust ps ++ qs) where distrust p = p {trusted=False} +-- | 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 + -> PackageConfigMap -> UnusablePackages -> Bool -- if False, if you expose a package, it implicitly hides -- any previously exposed packages with the same name @@ -543,16 +647,46 @@ applyPackageFlag -> PackageFlag -- flag to apply -> IO VisibilityMap -- Now exposed -applyPackageFlag dflags unusable no_hide_others pkgs vm flag = +applyPackageFlag dflags pkg_db unusable no_hide_others pkgs vm flag = case flag of ExposePackage _ arg (ModRenaming b rns) -> - case selectPackages (matching arg) pkgs unusable of + case findPackages pkg_db arg pkgs unusable of Left ps -> packageFlagErr dflags flag ps - Right (p:_,_) -> return vm' + Right (p:_) -> return vm' where n = fsPackageName p - vm' = addToUDFM_C edit vm_cleared (packageConfigId p) (b, rns, n) - edit (b, rns, n) (b', rns', _) = (b || b', rns ++ rns', n) + + -- 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 insts) -> + let cid = unitIdComponentId uid + local = [ Map.singleton + (moduleName mod) + (Set.singleton $ (newIndefUnitId cid insts, mod_name)) + | (mod_name, mod) <- insts + , isHoleModule mod ] + recurse = [ collectHoles (moduleUnitId mod) + | (_, mod) <- insts ] + 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 @@ -574,29 +708,74 @@ applyPackageFlag dflags unusable no_hide_others pkgs vm flag = -- -hide-all-packages/-hide-all-plugin-packages depending on what -- flag is in question. vm_cleared | no_hide_others = vm - | otherwise = filterUDFM_Directly - (\k (_,_,n') -> k == getUnique (packageConfigId p) - || n /= n') 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 selectPackages (matchingStr str) pkgs unusable of - Left ps -> packageFlagErr dflags flag ps - Right (ps,_) -> return vm' - where vm' = delListFromUDFM vm (map packageConfigId ps) - -selectPackages :: (PackageConfig -> Bool) -> [PackageConfig] + case findPackages 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 :: PackageConfigMap -> PackageArg -> [PackageConfig] + -> UnusablePackages + -> Either [(PackageConfig, UnusablePackageReason)] + [PackageConfig] +findPackages 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 (sortByVersion (reverse 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_insts) = splitUnitIdInsts uid + in if iuid == packageConfigId p + then Just (case mb_insts of + Nothing -> p + Just insts -> renamePackage pkg_db insts p) + else Nothing + +selectPackages :: PackageArg -> [PackageConfig] -> UnusablePackages -> Either [(PackageConfig, UnusablePackageReason)] ([PackageConfig], [PackageConfig]) -selectPackages matches pkgs unusable - = let (ps,rest) = partition matches pkgs +selectPackages arg pkgs unusable + = let matches = matching arg + (ps,rest) = partition matches pkgs in if null ps then Left (filter (matches.fst) (Map.elems unusable)) -- NB: packages from later package databases are LATER -- in the list. We want to prefer the latest package. else Right (sortByVersion (reverse ps), rest) +-- | Rename a 'PackageConfig' according to some module instantiation. +renamePackage :: PackageConfigMap -> [(ModuleName, Module)] + -> PackageConfig -> PackageConfig +renamePackage pkg_map insts conf = + let hsubst = listToUFM insts + smod = renameHoleModule' pkg_map hsubst + suid = renameHoleUnitId' pkg_map hsubst + new_uid = suid (unitId conf) + in conf { + unitId = new_uid, + depends = map suid (depends conf), + 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 -> PackageConfig -> Bool @@ -604,12 +783,12 @@ matchingStr str p = str == sourcePackageIdString p || str == packageNameString p -matchingId :: String -> PackageConfig -> Bool -matchingId str p = str == unitIdString (packageConfigId p) +matchingId :: UnitId -> PackageConfig -> Bool +matchingId uid p = uid == packageConfigId p matching :: PackageArg -> PackageConfig -> Bool matching (PackageArg str) = matchingStr str -matching (UnitIdArg str) = matchingId str +matching (UnitIdArg uid) = matchingId uid sortByVersion :: [PackageConfig] -> [PackageConfig] sortByVersion = sortBy (flip (comparing packageVersion)) @@ -712,7 +891,7 @@ findWiredInPackages dflags pkgs vis_map = do let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] all_exposed_ps = [ p | p <- all_ps - , elemUDFM (packageConfigId p) vis_map ] in + , Map.member (packageConfigId p) vis_map ] in case all_exposed_ps of [] -> case all_ps of [] -> notfound @@ -766,7 +945,8 @@ findWiredInPackages dflags pkgs vis_map = do where upd_pkg pkg | unitId pkg `elem` wired_in_ids = pkg { - unitId = stringToUnitId (packageNameString pkg) + unitId = let PackageName fs = packageName pkg + in fsToUnitId fs } | otherwise = pkg @@ -786,9 +966,9 @@ findWiredInPackages dflags pkgs vis_map = do updateVisibilityMap :: WiredPackagesMap -> VisibilityMap -> VisibilityMap updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (Map.toList wiredInMap) - where f vm (from, to) = case lookupUDFM vis_map from of + where f vm (from, to) = case Map.lookup from vis_map of Nothing -> vm - Just r -> addToUDFM vm to r + Just r -> Map.insert to r (Map.delete from vm) -- ---------------------------------------------------------------------------- @@ -797,6 +977,10 @@ type IsShadowed = Bool data UnusablePackageReason = IgnoredWithFlag | MissingDependencies IsShadowed [UnitId] +instance Outputable UnusablePackageReason where + ppr IgnoredWithFlag = text "[ignored with flag]" + ppr (MissingDependencies b uids) = + brackets (if b then text "shadowed" else empty <+> ppr uids) type UnusablePackages = Map UnitId (PackageConfig, UnusablePackageReason) @@ -876,9 +1060,7 @@ mkPackageState -> [(FilePath, [PackageConfig])] -- initial databases -> [UnitId] -- preloaded packages -> IO (PackageState, - [UnitId], -- new packages to preload - UnitId) -- this package, might be modified if the current - -- package is a wired-in package. + [UnitId]) -- new packages to preload mkPackageState dflags dbs preload0 = do -- Compute the unit id @@ -938,6 +1120,8 @@ mkPackageState dflags dbs preload0 = do let other_flags = reverse (packageFlags dflags) ignore_flags = reverse (ignorePackageFlags dflags) + debugTraceMsg dflags 2 $ + text "package flags" <+> ppr other_flags let merge (pkg_map, prev_unusable) (db_path, db) = do debugTraceMsg dflags 2 $ @@ -1004,6 +1188,7 @@ mkPackageState dflags dbs preload0 = do -- or not packages are visible or not) pkgs1 <- foldM (applyTrustFlag dflags unusable) (Map.elems pkg_map1) (reverse (trustFlags dflags)) + let prelim_pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs1 -- -- Calculate the initial set of packages, prior to any package flags. @@ -1019,18 +1204,28 @@ mkPackageState dflags dbs preload0 = do then emptyUDFM else foldl' calcInitial emptyUDFM pkgs1 vis_map1 = foldUDFM (\p vm -> - if exposed p - then addToUDFM vm (packageConfigId p) - (True, [], fsPackageName 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) + 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) - emptyUDFM initial + Map.empty initial -- -- 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 unusable + vis_map2 <- foldM (applyPackageFlag dflags prelim_pkg_db unusable (gopt Opt_HideAllPackages dflags) pkgs1) vis_map1 other_flags @@ -1040,6 +1235,7 @@ mkPackageState dflags dbs preload0 = do -- package arguments we need to key against the old versions. -- (pkgs2, wired_map) <- findWiredInPackages dflags pkgs1 vis_map2 + let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs2 -- Update the visibility map, so we treat wired packages as visible. let vis_map = updateVisibilityMap wired_map vis_map2 @@ -1049,15 +1245,15 @@ mkPackageState dflags dbs preload0 = do case pluginPackageFlags dflags of -- common case; try to share the old vis_map [] | not hide_plugin_pkgs -> return vis_map - | otherwise -> return emptyUDFM + | otherwise -> return Map.empty _ -> do let plugin_vis_map1 - | hide_plugin_pkgs = emptyUDFM + | 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 unusable + <- foldM (applyPackageFlag dflags prelim_pkg_db unusable (gopt Opt_HideAllPluginPackages dflags) pkgs1) plugin_vis_map1 (reverse (pluginPackageFlags dflags)) @@ -1078,16 +1274,24 @@ mkPackageState dflags dbs preload0 = do -- should contain at least rts & base, which is why we pretend that -- the command line contains -package rts & -package base. -- - let preload1 = [ let key = unitId p - in fromMaybe key (Map.lookup key wired_map) - | f <- other_flags, p <- get_exposed f ] + -- 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) - get_exposed (ExposePackage _ a _) = take 1 . sortByVersion - . filter (matching a) - $ pkgs1 - get_exposed _ = [] + let pkgname_map = foldl add Map.empty pkgs2 + where add pn_map p + = Map.insert (packageName p) (unitIdComponentId (packageConfigId 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 pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs2 let preload2 = preload1 @@ -1095,7 +1299,7 @@ mkPackageState dflags dbs preload0 = do -- add base & rts to the preload packages basicLinkedPackages | gopt Opt_AutoLinkPackages dflags - = filter (flip elemUDFM pkg_db) + = filter (flip elemUDFM (unPackageConfigMap pkg_db)) [baseUnitId, rtsUnitId] | otherwise = [] -- but in any case remove the current package from the set of @@ -1108,42 +1312,58 @@ mkPackageState dflags dbs preload0 = do dep_preload <- closeDeps dflags pkg_db (zip preload3 (repeat Nothing)) let new_dep_preload = filter (`notElem` preload0) dep_preload + let mod_map = mkModuleToPkgConfAll dflags pkg_db vis_map + when (dopt Opt_D_dump_mod_map dflags) $ + printInfoForUser (dflags { pprCols = 200 }) + alwaysQualify (pprModuleMap mod_map) + -- Force pstate to avoid leaking the dflags0 passed to mkPackageState let !pstate = PackageState{ preloadPackages = dep_preload, - explicitPackages = foldUDFM (\pkg xs -> - if elemUDFM (packageConfigId pkg) vis_map - then packageConfigId pkg : xs - else xs) [] pkg_db, + explicitPackages = explicit_pkgs, pkgIdMap = pkg_db, - moduleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db vis_map, - pluginModuleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db plugin_vis_map + moduleToPkgConfAll = mod_map, + pluginModuleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db plugin_vis_map, + packageNameMap = pkgname_map, + unwireMap = Map.fromList [ (v,k) | (k,v) <- Map.toList wired_map ], + requirementContext = req_ctx } - return (pstate, new_dep_preload, this_package) + return (pstate, new_dep_preload) +-- | 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 = + fromMaybe uid (Map.lookup uid (unwireMap (pkgState dflags))) -- ----------------------------------------------------------------------------- -- | 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. + mkModuleToPkgConfAll :: DynFlags -> PackageConfigMap -> VisibilityMap -> ModuleToPkgConfAll mkModuleToPkgConfAll dflags pkg_db vis_map = - foldl' extend_modmap emptyMap (eltsUDFM pkg_db) + Map.foldlWithKey extend_modmap emptyMap vis_map where emptyMap = Map.empty sing pk m _ = Map.singleton (mkModule pk m) addListTo = foldl' merge merge m (k, v) = MapStrict.insertWith (Map.unionWith mappend) k v m setOrigins m os = fmap (const os) m - extend_modmap modmap pkg = addListTo modmap theBindings + extend_modmap modmap uid + UnitVisibility { uv_expose_all = b, uv_renamings = rns } + = addListTo modmap theBindings where + pkg = pkg_lookup uid + theBindings :: [(ModuleName, Map Module ModuleOrigin)] - theBindings | Just (b,rns,_) <- lookupUDFM vis_map (packageConfigId pkg) - = newBindings b rns - | otherwise = newBindings False [] + theBindings = newBindings b rns newBindings :: Bool -> [(ModuleName, ModuleName)] @@ -1177,7 +1397,8 @@ mkModuleToPkgConfAll dflags pkg_db vis_map = hiddens = [(m, sing pk m pkg ModHidden) | m <- hidden_mods] pk = packageConfigId pkg - pkg_lookup = expectJust "mkModuleToPkgConf" . lookupPackage' pkg_db + pkg_lookup uid = lookupPackage' (isIndefinite dflags) pkg_db uid + `orElse` pprPanic "pkg_lookup" (ppr uid) exposed_mods = exposedModules pkg hidden_mods = hiddenModules pkg @@ -1349,7 +1570,7 @@ lookupModuleWithSuggestions' dflags mod_map m mb_pn | originVisible origin -> (hidden_pkg, hidden_mod, x:exposed) | otherwise -> (x:hidden_pkg, hidden_mod, exposed) - pkg_lookup = expectJust "lookupModuleWithSuggestions" . lookupPackage dflags + pkg_lookup p = lookupPackage dflags p `orElse` pprPanic "lookupModuleWithSuggestions" (ppr p <+> ppr m) mod_pkg = pkg_lookup . moduleUnitId -- Filters out origins which are not associated with the given package @@ -1403,7 +1624,7 @@ getPreloadPackagesAnd dflags pkgids = preload = preloadPackages state pairs = zip pkgids (repeat Nothing) in do - all_pkgs <- throwErr dflags (foldM (add_package pkg_map) preload pairs) + all_pkgs <- throwErr dflags (foldM (add_package dflags pkg_map) preload pairs) return (map (getPackageDetails dflags) all_pkgs) -- Takes a list of packages, and returns the list with dependencies included, @@ -1413,7 +1634,7 @@ closeDeps :: DynFlags -> [(UnitId, Maybe UnitId)] -> IO [UnitId] closeDeps dflags pkg_map ps - = throwErr dflags (closeDepsErr pkg_map ps) + = throwErr dflags (closeDepsErr dflags pkg_map ps) throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a throwErr dflags m @@ -1421,20 +1642,22 @@ throwErr dflags m Failed e -> throwGhcExceptionIO (CmdLineError (showSDoc dflags e)) Succeeded r -> return r -closeDepsErr :: PackageConfigMap +closeDepsErr :: DynFlags + -> PackageConfigMap -> [(UnitId,Maybe UnitId)] -> MaybeErr MsgDoc [UnitId] -closeDepsErr pkg_map ps = foldM (add_package pkg_map) [] ps +closeDepsErr dflags pkg_map ps = foldM (add_package dflags pkg_map) [] ps -- internal helper -add_package :: PackageConfigMap +add_package :: DynFlags + -> PackageConfigMap -> [UnitId] -> (UnitId,Maybe UnitId) -> MaybeErr MsgDoc [UnitId] -add_package pkg_db ps (p, mb_parent) +add_package dflags pkg_db ps (p, mb_parent) | p `elem` ps = return ps -- Check if we've already added this package | otherwise = - case lookupPackage' pkg_db p of + case lookupPackage' (isIndefinite dflags) pkg_db p of Nothing -> Failed (missingPackageMsg p <> missingDependencyMsg mb_parent) Just pkg -> do @@ -1443,7 +1666,7 @@ add_package pkg_db ps (p, mb_parent) return (p : ps') where add_unit_key ps key - = add_package pkg_db ps (key, Just p) + = add_package dflags pkg_db ps (key, Just p) missingPackageMsg :: Outputable pkgid => pkgid -> SDoc missingPackageMsg p = text "unknown package:" <+> ppr p @@ -1455,10 +1678,9 @@ missingDependencyMsg (Just parent) -- ----------------------------------------------------------------------------- -unitIdPackageIdString :: DynFlags -> UnitId -> Maybe String -unitIdPackageIdString dflags pkg_key - | pkg_key == mainUnitId = Just "main" - | otherwise = fmap sourcePackageIdString (lookupPackage dflags pkg_key) +componentIdString :: DynFlags -> ComponentId -> Maybe String +componentIdString dflags cid = + fmap sourcePackageIdString (lookupComponentId dflags cid) -- | Will the 'Name' come from a dynamically linked library? isDllName :: DynFlags -> UnitId -> Module -> Name -> Bool @@ -1516,14 +1738,29 @@ pprPackagesSimple = pprPackagesWith pprIPI in e <> t <> text " " <> ftext i -- | Show the mapping of modules to where they come from. -pprModuleMap :: DynFlags -> SDoc -pprModuleMap dflags = - vcat (map pprLine (Map.toList (moduleToPkgConfAll (pkgState dflags)))) +pprModuleMap :: ModuleToPkgConfAll -> 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 :: PackageConfig -> FastString fsPackageName = mkFastString . packageNameString + +-- | Given a fully instantiated 'UnitId', improve it into a +-- 'HashedUnitId' if we can find it in the package database. +improveUnitId :: PackageConfigMap -> UnitId -> UnitId +improveUnitId pkg_map uid = + -- Do NOT lookup indefinite ones, they won't be useful! + case lookupPackage' False pkg_map uid of + Nothing -> uid + Just pkg -> packageConfigId pkg -- use the hashed version! + +-- | Retrieve the 'PackageConfigMap' from 'DynFlags'; used +-- in the @hs-boot@ loop-breaker. +getPackageConfigMap :: DynFlags -> PackageConfigMap +getPackageConfigMap = pkgIdMap . pkgState diff --git a/compiler/main/Packages.hs-boot b/compiler/main/Packages.hs-boot index 1197fadb57..c05d392ce1 100644 --- a/compiler/main/Packages.hs-boot +++ b/compiler/main/Packages.hs-boot @@ -1,7 +1,9 @@ module Packages where --- Well, this is kind of stupid... -import {-# SOURCE #-} Module (UnitId) -import {-# SOURCE #-} DynFlags (DynFlags) +import {-# SOURCE #-} DynFlags(DynFlags) +import {-# SOURCE #-} Module(ComponentId, UnitId) data PackageState -unitIdPackageIdString :: DynFlags -> UnitId -> Maybe String +data PackageConfigMap emptyPackageState :: PackageState +componentIdString :: DynFlags -> ComponentId -> Maybe String +improveUnitId :: PackageConfigMap -> UnitId -> UnitId +getPackageConfigMap :: DynFlags -> PackageConfigMap diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 361fa0be6a..6800fab57e 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -615,6 +615,12 @@ data Token | ITstock | ITanyclass + -- Backpack tokens + | ITunit + | ITsignature + | ITdependency + | ITrequires + -- Pragmas, see note [Pragma source text] in BasicTypes | ITinline_prag SourceText InlineSpec RuleMatchInfo | ITspec_prag SourceText -- SPECIALISE @@ -825,6 +831,10 @@ reservedWordsFM = listToUFM $ ( "prim", ITprimcallconv, xbit FfiBit), ( "javascript", ITjavascriptcallconv, xbit FfiBit), + ( "unit", ITunit, 0 ), + ( "dependency", ITdependency, 0 ), + ( "signature", ITsignature, 0 ), + ( "rec", ITrec, xbit ArrowsBit .|. xbit RecursiveDoBit), ( "proc", ITproc, xbit ArrowsBit) diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 4cab083484..d72aabd2e7 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -22,7 +22,7 @@ -- buffer = stringToStringBuffer str -- parseState = mkPState flags buffer location -- @ -module Parser (parseModule, parseImport, parseStatement, +module Parser (parseModule, parseSignature, parseImport, parseStatement, parseBackpack, parseDeclaration, parseExpression, parsePattern, parseTypeSignature, parseStmt, parseIdentifier, @@ -41,6 +41,8 @@ import HsSyn -- compiler/main import HscTypes ( IsBootInterface, WarningTxt(..) ) import DynFlags +import BkpSyn +import PackageConfig -- compiler/utils import OrdList @@ -371,6 +373,10 @@ output it generates. 'stock' { L _ ITstock } -- for DerivingStrategies extension 'anyclass' { L _ ITanyclass } -- for DerivingStrategies extension + 'unit' { L _ ITunit } + 'signature' { L _ ITsignature } + 'dependency' { L _ ITdependency } + '{-# INLINE' { L _ (ITinline_prag _ _ _) } -- INLINE or INLINABLE '{-# SPECIALISE' { L _ (ITspec_prag _) } '{-# SPECIALISE_INLINE' { L _ (ITspec_inline_prag _ _) } @@ -487,6 +493,7 @@ TH_QQUASIQUOTE { L _ (ITqQuasiQuote _) } -- Exported parsers %name parseModule module +%name parseSignature signature %name parseImport importdecl %name parseStatement stmt %name parseDeclaration topdecl @@ -496,6 +503,7 @@ TH_QQUASIQUOTE { L _ (ITqQuasiQuote _) } %name parseStmt maybe_stmt %name parseIdentifier identifier %name parseType ctype +%name parseBackpack backpack %partial parseHeader header %% @@ -510,6 +518,92 @@ identifier :: { Located RdrName } [mj AnnOpenP $1,mu AnnRarrow $2,mj AnnCloseP $3] } ----------------------------------------------------------------------------- +-- Backpack stuff + +backpack :: { [LHsUnit PackageName] } + : implicit_top units close { fromOL $2 } + | '{' units '}' { fromOL $2 } + +units :: { OrdList (LHsUnit PackageName) } + : units ';' unit { $1 `appOL` unitOL $3 } + | units ';' { $1 } + | unit { unitOL $1 } + +unit :: { LHsUnit PackageName } + : 'unit' pkgname 'where' unitbody + { sL1 $1 $ HsUnit { hsunitName = $2 + , hsunitBody = fromOL $4 } } + +unitid :: { LHsUnitId PackageName } + : pkgname { sL1 $1 $ HsUnitId $1 [] } + | pkgname '[' msubsts ']' { sLL $1 $> $ HsUnitId $1 (fromOL $3) } + +msubsts :: { OrdList (LHsModuleSubst PackageName) } + : msubsts ',' msubst { $1 `appOL` unitOL $3 } + | msubsts ',' { $1 } + | msubst { unitOL $1 } + +msubst :: { LHsModuleSubst PackageName } + : modid '=' moduleid { sLL $1 $> $ ($1, $3) } + | modid VARSYM modid VARSYM { sLL $1 $> $ ($1, sLL $2 $> $ HsModuleVar $3) } + +moduleid :: { LHsModuleId PackageName } + : VARSYM modid VARSYM { sLL $1 $> $ HsModuleVar $2 } + | unitid ':' modid { sLL $1 $> $ HsModuleId $1 $3 } + +pkgname :: { Located PackageName } + : STRING { sL1 $1 $ PackageName (getSTRING $1) } + | litpkgname { sL1 $1 $ PackageName (unLoc $1) } + +litpkgname_segment :: { Located FastString } + : VARID { sL1 $1 $ getVARID $1 } + | CONID { sL1 $1 $ getCONID $1 } + | special_id { $1 } + +litpkgname :: { Located FastString } + : litpkgname_segment { $1 } + -- a bit of a hack, means p - b is parsed same as p-b, enough for now. + | litpkgname_segment '-' litpkgname { sLL $1 $> $ appendFS (unLoc $1) (consFS '-' (unLoc $3)) } + +mayberns :: { Maybe [LRenaming] } + : {- empty -} { Nothing } + | '(' rns ')' { Just (fromOL $2) } + +rns :: { OrdList LRenaming } + : rns ',' rn { $1 `appOL` unitOL $3 } + | rns ',' { $1 } + | rn { unitOL $1 } + +rn :: { LRenaming } + : modid 'as' modid { sLL $1 $> $ Renaming (unLoc $1) (unLoc $3) } + | modid { sL1 $1 $ Renaming (unLoc $1) (unLoc $1) } + +unitbody :: { OrdList (LHsUnitDecl PackageName) } + : '{' unitdecls '}' { $2 } + | vocurly unitdecls close { $2 } + +unitdecls :: { OrdList (LHsUnitDecl PackageName) } + : unitdecls ';' unitdecl { $1 `appOL` unitOL $3 } + | unitdecls ';' { $1 } + | unitdecl { unitOL $1 } + +unitdecl :: { LHsUnitDecl PackageName } + : maybedocheader 'module' modid maybemodwarning maybeexports 'where' body + -- XXX not accurate + { sL1 $2 $ DeclD ModuleD $3 (Just (sL1 $2 (HsModule (Just $3) $5 (fst $ snd $7) (snd $ snd $7) $4 $1))) } + | maybedocheader 'signature' modid maybemodwarning maybeexports 'where' body + { sL1 $2 $ DeclD SignatureD $3 (Just (sL1 $2 (HsModule (Just $3) $5 (fst $ snd $7) (snd $ snd $7) $4 $1))) } + -- NB: MUST have maybedocheader here, otherwise shift-reduce conflict + -- will prevent us from parsing both forms. + | maybedocheader 'module' modid + { sL1 $2 $ DeclD ModuleD $3 Nothing } + | maybedocheader 'signature' modid + { sL1 $2 $ DeclD SignatureD $3 Nothing } + | 'dependency' unitid mayberns + { sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $2 + , idModRenaming = $3 }) } + +----------------------------------------------------------------------------- -- Module Header -- The place for module deprecation is really too restrictive, but if it @@ -519,6 +613,14 @@ identifier :: { Located RdrName } -- either, and DEPRECATED is only expected to be used by people who really -- know what they are doing. :-) +signature :: { Located (HsModule RdrName) } + : maybedocheader 'signature' modid maybemodwarning maybeexports 'where' body + {% fileSrcSpan >>= \ loc -> + ams (L loc (HsModule (Just $3) $5 (fst $ snd $7) + (snd $ snd $7) $4 $1) + ) + ([mj AnnModule $2, mj AnnWhere $6] ++ fst $7) } + module :: { Located (HsModule RdrName) } : maybedocheader 'module' modid maybemodwarning maybeexports 'where' body {% fileSrcSpan >>= \ loc -> @@ -539,6 +641,9 @@ maybedocheader :: { Maybe LHsDocString } missing_module_keyword :: { () } : {- empty -} {% pushModuleContext } +implicit_top :: { () } + : {- empty -} {% pushModuleContext } + maybemodwarning :: { Maybe (Located WarningTxt) } : '{-# DEPRECATED' strings '#-}' {% ajs (Just (sLL $1 $> $ DeprecatedTxt (sL1 $1 (getDEPRECATED_PRAGs $1)) (snd $ unLoc $2))) @@ -585,6 +690,10 @@ header :: { Located (HsModule RdrName) } {% fileSrcSpan >>= \ loc -> ams (L loc (HsModule (Just $3) $5 $7 [] $4 $1 )) [mj AnnModule $2,mj AnnWhere $6] } + | maybedocheader 'signature' modid maybemodwarning maybeexports 'where' header_body + {% fileSrcSpan >>= \ loc -> + ams (L loc (HsModule (Just $3) $5 $7 [] $4 $1 + )) [mj AnnModule $2,mj AnnWhere $6] } | header_body2 {% fileSrcSpan >>= \ loc -> return (L loc (HsModule Nothing Nothing $1 [] Nothing @@ -3093,6 +3202,9 @@ special_id | 'group' { sL1 $1 (fsLit "group") } | 'stock' { sL1 $1 (fsLit "stock") } | 'anyclass' { sL1 $1 (fsLit "anyclass") } + | 'unit' { sL1 $1 (fsLit "unit") } + | 'dependency' { sL1 $1 (fsLit "dependency") } + | 'signature' { sL1 $1 (fsLit "signature") } special_sym :: { Located FastString } special_sym : '!' {% ams (sL1 $1 (fsLit "!")) [mj AnnBang $1] } diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs index b1cb7fe064..d41e9ef48e 100644 --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -208,40 +208,16 @@ newTopSrcBinder (L loc rdr_name) -- module name, we we get a confusing "M.T is not in scope" error later ; stage <- getStage - ; env <- getGblEnv ; if isBrackStage stage then -- We are inside a TH bracket, so make an *Internal* name -- See Note [Top-level Names in Template Haskell decl quotes] in RnNames do { uniq <- newUnique ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) } - else case tcg_impl_rdr_env env of - Just gr -> - -- We're compiling --sig-of, so resolve with respect to this - -- module. - -- See Note [Signature parameters in TcGblEnv and DynFlags] - do { case lookupGlobalRdrEnv gr (rdrNameOcc rdr_name) of - -- Be sure to override the loc so that we get accurate - -- information later - [GRE{ gre_name = n }] -> do - -- NB: Just adding this line will not work: - -- addUsedGRE True gre - -- see Note [Signature lazy interface loading] for - -- more details. - return (setNameLoc n loc) - _ -> do - { -- NB: cannot use reportUnboundName rdr_name - -- because it looks up in the wrong RdrEnv - -- ToDo: more helpful error messages - ; addErr (unknownNameErr (pprNonVarNameSpace - (occNameSpace (rdrNameOcc rdr_name))) rdr_name) - ; return (mkUnboundNameRdr rdr_name) - } - } - Nothing -> - -- Normal case + else do { this_mod <- getModule ; traceRn (text "newTopSrcBinder" <+> (ppr this_mod $$ ppr rdr_name $$ ppr loc)) - ; newGlobalBinder this_mod (rdrNameOcc rdr_name) loc } } + ; newGlobalBinder this_mod (rdrNameOcc rdr_name) loc } + } {- ********************************************************* @@ -1216,6 +1192,14 @@ data HsSigCtxt | RoleAnnotCtxt NameSet -- A role annotation, with the names of all types -- in the group +instance Outputable HsSigCtxt where + ppr (TopSigCtxt ns) = text "TopSigCtxt" <+> ppr ns + ppr (LocalBindCtxt ns) = text "LocalBindCtxt" <+> ppr ns + ppr (ClsDeclCtxt n) = text "ClsDeclCtxt" <+> ppr n + ppr (InstDeclCtxt ns) = text "InstDeclCtxt" <+> ppr ns + ppr (HsBootCtxt ns) = text "HsBootCtxt" <+> ppr ns + ppr (RoleAnnotCtxt ns) = text "RoleAnnotCtxt" <+> ppr ns + lookupSigOccRn :: HsSigCtxt -> Sig RdrName -> Located RdrName -> RnM (Located Name) @@ -1398,7 +1382,7 @@ lookupFixity is a bit strange. * Nested local fixity decls are put in the local fixity env, which we find with getFixtyEnv -* Imported fixities are found in the HIT or PIT +* Imported fixities are found in the PIT * Top-level fixity decls in this module may be for Names that are either Global (constructors, class operations) diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index 6b4942f41f..e1258a3d0d 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -12,6 +12,7 @@ module RnNames ( gresFromAvails, calculateAvails, reportUnusedNames, + plusAvail, checkConName ) where @@ -153,7 +154,10 @@ with yes we have gone with no for now. rnImports :: [LImportDecl RdrName] -> RnM ([LImportDecl Name], GlobalRdrEnv, ImportAvails, AnyHpcUsage) rnImports imports = do - this_mod <- getModule + tcg_env <- getGblEnv + -- NB: want an identity module here, because it's OK for a signature + -- module to import from its implementor + let this_mod = tcg_mod tcg_env let (source, ordinary) = partition is_source_import imports is_source_import d = ideclSource (unLoc d) stuff1 <- mapAndReportM (rnImportDecl this_mod) ordinary @@ -811,7 +815,8 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) -- NB: the AvailTC can have fields as well as data constructors (Trac #12127) combine (name1, a1@(AvailTC p1 _ _), mp1) (name2, a2@(AvailTC p2 _ _), mp2) - = ASSERT( name1 == name2 && isNothing mp1 && isNothing mp2 ) + = ASSERT2( name1 == name2 && isNothing mp1 && isNothing mp2 + , ppr name1 <+> ppr name2 <+> ppr mp1 <+> ppr mp2 ) if p1 == name1 then (name1, a1, Just p2) else (name1, a2, Just p1) combine x y = pprPanic "filterImports/combine" (ppr x $$ ppr y) diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs index 84f1f4b71a..f2d3ef014d 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -65,7 +65,6 @@ import Outputable import qualified GHC.LanguageExtensions as LangExt import Control.Monad( unless ) -import Data.Maybe( isJust ) {- ************************************************************************ @@ -699,13 +698,7 @@ addLocalInst (home_ie, my_insts) ispec | isGHCi = deleteFromInstEnv home_ie ispec | otherwise = home_ie - -- If we're compiling sig-of and there's an external duplicate - -- instance, silently ignore it (that's the instance we're - -- implementing!) NB: we still count local duplicate instances - -- as errors. - -- See Note [Signature files and type class instances] - global_ie | isJust (tcg_sig_of tcg_env) = emptyInstEnv - | otherwise = eps_inst_env eps + global_ie = eps_inst_env eps inst_envs = InstEnvs { ie_global = global_ie , ie_local = home_ie' , ie_visible = tcVisibleOrphanMods tcg_env } diff --git a/compiler/typecheck/TcBackpack.hs b/compiler/typecheck/TcBackpack.hs new file mode 100644 index 0000000000..be24423123 --- /dev/null +++ b/compiler/typecheck/TcBackpack.hs @@ -0,0 +1,552 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +module TcBackpack ( + findExtraSigImports', + findExtraSigImports, + implicitRequirements', + implicitRequirements, + checkUnitId, + tcRnCheckUnitId, + tcRnMergeSignatures, + mergeSignatures, + tcRnInstantiateSignature, + instantiateSignature, +) where + +import Packages +import DynFlags +import HsSyn +import RdrName +import TcRnMonad +import InstEnv +import FamInstEnv +import Inst +import TcIface +import TcMType +import TcType +import TcSimplify +import LoadIface +import RnNames +import ErrUtils +import Id +import Module +import Name +import NameEnv +import NameSet +import Avail +import SrcLoc +import HscTypes +import Outputable +import Type +import FastString +import Maybes +import TcEnv +import Var +import PrelNames +import qualified Data.Map as Map + +import Finder +import UniqDSet +import NameShape +import TcErrors +import TcUnify +import RnModIface +import Util + +import Control.Monad +import Data.List (find, foldl') + +import {-# SOURCE #-} TcRnDriver + +#include "HsVersions.h" + +-- | Given a 'ModDetails' of an instantiated signature (note that the +-- 'ModDetails' must be knot-tied consistently with the actual implementation) +-- and a 'GlobalRdrEnv' constructed from the implementor of this interface, +-- verify that the actual implementation actually matches the original +-- interface. +-- +-- Note that it is already assumed that the implementation *exports* +-- a sufficient set of entities, since otherwise the renaming and then +-- typechecking of the signature 'ModIface' would have failed. +checkHsigIface :: TcGblEnv -> GlobalRdrEnv -> ModDetails -> TcRn () +checkHsigIface tcg_env gr + ModDetails { md_insts = sig_insts, md_fam_insts = sig_fam_insts, + md_types = sig_type_env, md_exports = sig_exports } = do + traceTc "checkHsigIface" $ vcat + [ ppr sig_type_env, ppr sig_insts, ppr sig_exports ] + mapM_ check_export (map availName sig_exports) + unless (null sig_fam_insts) $ + panic ("TcRnDriver.checkHsigIface: Cannot handle family " ++ + "instances in hsig files yet...") + -- Delete instances so we don't look them up when + -- checking instance satisfiability + -- TODO: this should not be necessary + tcg_env <- getGblEnv + setGblEnv tcg_env { tcg_inst_env = emptyInstEnv, + tcg_fam_inst_env = emptyFamInstEnv, + tcg_insts = [], + tcg_fam_insts = [] } $ do + mapM_ check_inst sig_insts + failIfErrsM + where + -- NB: the Names in sig_type_env are bogus. Let's say we have H.hsig + -- in package p that defines T; and we implement with himpl:H. Then the + -- Name is p[himpl:H]:H.T, NOT himplH:H.T. That's OK but we just + -- have to look up the right name. + sig_type_occ_env = mkOccEnv + . map (\t -> (nameOccName (getName t), t)) + $ nameEnvElts sig_type_env + dfun_names = map getName sig_insts + check_export name + -- Skip instances, we'll check them later + | name `elem` dfun_names = return () + -- See if we can find the type directly in the hsig ModDetails + -- TODO: need to special case wired in names + | Just sig_thing <- lookupOccEnv sig_type_occ_env (nameOccName name) = do + -- NB: We use tcLookupImported_maybe because we want to EXCLUDE + -- tcg_env (TODO: but maybe this isn't relevant anymore). + r <- tcLookupImported_maybe name + case r of + Failed err -> addErr err + Succeeded real_thing -> checkBootDeclM False sig_thing real_thing + -- The hsig did NOT define this function; that means it must + -- be a reexport. In this case, make sure the 'Name' of the + -- reexport matches the 'Name exported here. + | [GRE { gre_name = name' }] <- lookupGlobalRdrEnv gr (nameOccName name) = + when (name /= name') $ do + -- See Note [Error reporting bad reexport] + -- TODO: Actually this error swizzle doesn't work + let p (L _ ie) = name `elem` ieNames ie + loc = case tcg_rn_exports tcg_env of + Just es | Just e <- find p es + -- TODO: maybe we can be a little more + -- precise here and use the Located + -- info for the *specific* name we matched. + -> getLoc e + _ -> nameSrcSpan name + addErrAt loc + (badReexportedBootThing False name name') + -- This should actually never happen, but whatever... + | otherwise = + addErrAt (nameSrcSpan name) + (missingBootThing False name "exported by") + +-- Note [Error reporting bad reexport] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- NB: You want to be a bit careful about what location you report on reexports. +-- If the name was declared in the hsig file, 'nameSrcSpan name' is indeed the +-- correct source location. However, if it was *reexported*, obviously the name +-- is not going to have the right location. In this case, we need to grovel in +-- tcg_rn_exports to figure out where the reexport came from. + + + +-- | Checks if a 'ClsInst' is "defined". In general, for hsig files we can't +-- assume that the implementing file actually implemented the instances (they +-- may be reexported from elsewhere). Where should we look for the instances? +-- We do the same as we would otherwise: consult the EPS. This isn't perfect +-- (we might conclude the module exports an instance when it doesn't, see +-- #9422), but we will never refuse to compile something. +check_inst :: ClsInst -> TcM () +check_inst sig_inst = do + -- TODO: This could be very well generalized to support instance + -- declarations in boot files. + tcg_env <- getGblEnv + -- NB: Have to tug on the interface, not necessarily + -- tugged... but it didn't work? + mapM_ tcLookupImported_maybe (nameSetElemsStable (orphNamesOfClsInst sig_inst)) + -- Based off of 'simplifyDeriv' + let ty = idType (instanceDFunId sig_inst) + skol_info = InstSkol + -- Based off of tcSplitDFunTy + (tvs, theta, pred) = + case tcSplitForAllTys ty of { (tvs, rho) -> + case splitFunTys rho of { (theta, pred) -> + (tvs, theta, pred) }} + origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst + (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize + (cts, tclvl) <- pushTcLevelM $ do + wanted <- newWanted origin + (Just TypeLevel) + (substTy skol_subst pred) + givens <- forM theta $ \given -> do + loc <- getCtLocM origin (Just TypeLevel) + let given_pred = substTy skol_subst given + new_ev <- newEvVar given_pred + return CtGiven { ctev_pred = given_pred + -- Doesn't matter, make something up + , ctev_evar = new_ev + , ctev_loc = loc + } + return $ wanted : givens + unsolved <- simplifyWantedsTcM cts + + (implic, _) <- buildImplicationFor tclvl skol_info tvs_skols [] unsolved + reportAllUnsolved (mkImplicWC implic) + +-- | Return this list of requirement interfaces that need to be merged +-- to form @mod_name@, or @[]@ if this is not a requirement. +requirementMerges :: DynFlags -> ModuleName -> [HoleModule] +requirementMerges dflags mod_name = + fromMaybe [] (Map.lookup mod_name (requirementContext (pkgState dflags))) + +-- | For a module @modname@ of type 'HscSource', determine the list +-- of extra "imports" of other requirements which should be considered part of +-- the import of the requirement, because it transitively depends on those +-- requirements by imports of modules from other packages. The situation +-- is something like this: +-- +-- package p where +-- signature A +-- signature B +-- import A +-- +-- package q where +-- include p +-- signature A +-- signature B +-- +-- Although q's B does not directly import A, we still have to make sure we +-- process A first, because the merging process will cause B to indirectly +-- import A. This function finds the TRANSITIVE closure of all such imports +-- we need to make. +findExtraSigImports' :: HscEnv + -> HscSource + -> ModuleName + -> IO (UniqDSet ModuleName) +findExtraSigImports' hsc_env HsigFile modname = + fmap unionManyUniqDSets (forM reqs $ \(iuid, mod_name) -> + (initIfaceLoad hsc_env + . withException + $ moduleFreeHolesPrecise (text "findExtraSigImports") + (mkModule (AnIndefUnitId iuid) mod_name))) + where + reqs = requirementMerges (hsc_dflags hsc_env) modname + +findExtraSigImports' _ _ _ = return emptyUniqDSet + +-- | 'findExtraSigImports', but in a convenient form for "GhcMake" and +-- "TcRnDriver". +findExtraSigImports :: HscEnv -> HscSource -> ModuleName + -> IO [(Maybe FastString, Located ModuleName)] +findExtraSigImports hsc_env hsc_src modname = do + extra_requirements <- findExtraSigImports' hsc_env hsc_src modname + return [ (Nothing, noLoc mod_name) + | mod_name <- uniqDSetToList extra_requirements ] + +-- A version of 'implicitRequirements'' which is more friendly +-- for "GhcMake" and "TcRnDriver". +implicitRequirements :: HscEnv + -> [(Maybe FastString, Located ModuleName)] + -> IO [(Maybe FastString, Located ModuleName)] +implicitRequirements hsc_env normal_imports + = do mns <- implicitRequirements' hsc_env normal_imports + return [ (Nothing, noLoc mn) | mn <- mns ] + +-- Given a list of 'import M' statements in a module, figure out +-- any extra implicit requirement imports they may have. For +-- example, if they 'import M' and M resolves to p[A=<B>], then +-- they actually also import the local requirement B. +implicitRequirements' :: HscEnv + -> [(Maybe FastString, Located ModuleName)] + -> IO [ModuleName] +implicitRequirements' hsc_env normal_imports + = fmap concat $ + forM normal_imports $ \(mb_pkg, L _ imp) -> do + found <- findImportedModule hsc_env imp mb_pkg + case found of + Found _ mod | thisPackage dflags /= moduleUnitId mod -> + return (uniqDSetToList (moduleFreeHoles mod)) + _ -> return [] + where dflags = hsc_dflags hsc_env + +-- | Given a 'UnitId', make sure it is well typed. This is because +-- unit IDs come from Cabal, which does not know if things are well-typed or +-- not; a component may have been filled with implementations for the holes +-- that don't actually fulfill the requirements. +-- +-- INVARIANT: the UnitId is NOT a HashedUnitId +checkUnitId :: UnitId -> TcM () +checkUnitId uid = do + case splitUnitIdInsts uid of + (_, Just insts) -> + forM_ insts $ \(mod_name, mod) -> + -- NB: direct hole instantiations are well-typed by construction + -- (because we FORCE things to be merged in), so don't check them + when (not (isHoleModule mod)) $ do + checkUnitId (moduleUnitId mod) + _ <- addErrCtxt (text "while checking that" <+> ppr mod + <+> text "implements signature" <+> ppr mod_name <+> text "in" + <+> ppr uid) $ + mod `checkImplements` (newIndefUnitId (unitIdComponentId uid) insts, mod_name) + return () + _ -> return () -- if it's hashed, must be well-typed + +-- | Top-level driver for signature instantiation (run when compiling +-- an @hsig@ file.) +tcRnCheckUnitId :: + HscEnv -> UnitId -> + IO (Messages, Maybe ()) +tcRnCheckUnitId hsc_env uid = + withTiming (pure dflags) + (text "Check unit id" <+> ppr uid) + (const ()) $ + initTc hsc_env + HsigFile -- bogus + False + mAIN -- bogus + (realSrcLocSpan (mkRealSrcLoc (fsLit loc_str) 0 0)) -- bogus + $ checkUnitId uid + where + dflags = hsc_dflags hsc_env + loc_str = "Command line argument: -unit-id " ++ showSDoc dflags (ppr uid) + +-- TODO: Maybe lcl_iface0 should be pre-renamed to the right thing? Unclear... + +-- | Top-level driver for signature merging (run after typechecking +-- an @hsig@ file). +tcRnMergeSignatures :: HscEnv -> RealSrcSpan -> ModIface + -> IO (Messages, Maybe TcGblEnv) +tcRnMergeSignatures hsc_env real_loc iface = + withTiming (pure dflags) + (text "Signature merging" <+> brackets (ppr this_mod)) + (const ()) $ + initTc hsc_env HsigFile False this_mod real_loc $ + mergeSignatures iface + where + dflags = hsc_dflags hsc_env + this_mod = mi_module iface + +-- Note [Blank hsigs for all requirements] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- One invariant that a client of GHC must uphold is that there +-- must be an hsig file for every requirement (according to +-- @-this-unit-id@); this ensures that for every interface +-- file (hi), there is a source file (hsig), which helps grease +-- the wheels of recompilation avoidance which assumes that +-- source files always exist. + +-- | Given a local 'ModIface', merge all inherited requirements +-- from 'requirementMerges' into this signature, producing +-- a final 'TcGblEnv' that matches the local signature and +-- all required signatures. +mergeSignatures :: ModIface -> TcRn TcGblEnv +mergeSignatures lcl_iface0 = do + -- The lcl_iface0 is the ModIface for the local hsig + -- file, which is guaranteed to exist, see + -- Note [Blank hsigs for all requirements] + hsc_env <- getTopEnv + dflags <- getDynFlags + tcg_env <- getGblEnv + let outer_mod = tcg_mod tcg_env + inner_mod = tcg_semantic_mod tcg_env + + -- STEP 1: Figure out all of the external signature interfaces + -- we are going to merge in. + let reqs = requirementMerges dflags (moduleName (tcg_mod tcg_env)) + + -- STEP 2: Read in the RAW forms of all of these interfaces + ireq_ifaces <- forM reqs $ \(iuid, mod_name) -> + fmap fst + . withException + . flip (findAndReadIface (text "mergeSignatures")) False + -- Blegh, temporarily violated invariant that hashed unit + -- ids are definite + $ mkModule (newSimpleUnitId (indefUnitIdComponentId iuid)) mod_name + + -- STEP 3: Get the unrenamed exports of all these interfaces, and + -- dO shaping on them. + let extend_ns nsubst as = liftIO $ extendNameShape hsc_env nsubst as + gen_subst nsubst ((iuid, _), ireq_iface) = do + let insts = indefUnitIdInsts iuid + as1 <- liftIO $ rnModExports hsc_env insts ireq_iface + mb_r <- extend_ns nsubst as1 + case mb_r of + Left err -> failWithTc err + Right nsubst' -> return nsubst' + nsubst0 = mkNameShape (moduleName inner_mod) (mi_exports lcl_iface0) + nsubst <- foldM gen_subst nsubst0 (zip reqs ireq_ifaces) + let exports = nameShapeExports nsubst + tcg_env <- return tcg_env { + tcg_rdr_env = mkGlobalRdrEnv (gresFromAvails Nothing exports), + tcg_exports = exports, + tcg_dus = usesOnly (availsToNameSetWithSelectors exports) + } + + -- STEP 4: Rename the interfaces + ext_ifaces <- forM (zip reqs ireq_ifaces) $ \((iuid, _), ireq_iface) -> + liftIO (rnModIface hsc_env (indefUnitIdInsts iuid) (Just nsubst) ireq_iface) + lcl_iface <- liftIO $ rnModIface hsc_env (thisUnitIdInsts dflags) (Just nsubst) lcl_iface0 + let ifaces = lcl_iface : ext_ifaces + + -- STEP 5: Typecheck the interfaces + let type_env_var = tcg_type_env_var tcg_env + -- NB: This is a bit tricky. Ordinarily, the way we would do this is + -- use tcExtendGlobalEnv to put all of the things that we believe are + -- going to be "the real TyThings" (type_env) into the type environment, so that + -- when we typecheck the rest of the interfaces they get knot-tied + -- to those. But tcExtendGlobalEnv is a bit too strict, and forces thunks + -- before they are ready. + (type_env, detailss) <- initIfaceTcRn $ + typecheckIfacesForMerging inner_mod ifaces type_env_var + -- Something very subtle but important about type_env: + -- it contains NO dfuns. The dfuns are inside detailss, + -- and the names are complete nonsense. We'll unwind this + -- in the rest of this function. + let infos = zip ifaces detailss + -- Make sure we serialize these out! + setGblEnv tcg_env { + tcg_tcs = typeEnvTyCons type_env, + tcg_patsyns = typeEnvPatSyns type_env, + tcg_type_env = type_env + } $ do + tcg_env <- getGblEnv + + -- STEP 6: Check for compatibility/merge things + tcg_env <- (\x -> foldM x tcg_env infos) + $ \tcg_env (iface, details) -> do + let check_ty sig_thing + -- We'll check these with the parent + | isImplicitTyThing sig_thing + = return () + -- These aren't in the type environment; checked + -- when merging instances + | AnId id <- sig_thing + , isDFunId id + = return () + | Just thing <- lookupTypeEnv type_env (getName sig_thing) + = checkBootDeclM False sig_thing thing + | otherwise + = panic "mergeSignatures check_ty" + mapM_ check_ty (typeEnvElts (md_types details)) + -- DFunId + let merge_inst (insts, inst_env) inst + -- TODO: It would be good if, when there IS an + -- existing interface, we check that the types + -- match up. + | memberInstEnv inst_env inst + = (insts, inst_env) + | otherwise + = (inst:insts, extendInstEnv inst_env inst) + (insts, inst_env) = foldl' merge_inst + (tcg_insts tcg_env, tcg_inst_env tcg_env) + (md_insts details) + avails = plusImportAvails (tcg_imports tcg_env) + (calculateAvails dflags iface False False) + return tcg_env { + tcg_inst_env = inst_env, + tcg_insts = insts, + tcg_imports = avails, + tcg_merged = + if outer_mod == mi_module iface + -- Don't add ourselves! + then tcg_merged tcg_env + else (mi_module iface, mi_mod_hash iface) : tcg_merged tcg_env + } + + -- Rename and add dfuns to type_env + dfun_insts <- forM (tcg_insts tcg_env) $ \inst -> do + n <- newDFunName (is_cls inst) (is_tys inst) (nameSrcSpan (is_dfun_name inst)) + let dfun = setVarName (is_dfun inst) n + return (dfun, inst { is_dfun_name = n, is_dfun = dfun }) + tcg_env <- return tcg_env { + tcg_insts = map snd dfun_insts, + tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) (map fst dfun_insts) + } + + return tcg_env + +-- | Top-level driver for signature instantiation (run when compiling +-- an @hsig@ file.) +tcRnInstantiateSignature :: + HscEnv -> Module -> RealSrcSpan -> + IO (Messages, Maybe TcGblEnv) +tcRnInstantiateSignature hsc_env this_mod real_loc = + withTiming (pure dflags) + (text "Signature instantiation"<+>brackets (ppr this_mod)) + (const ()) $ + initTc hsc_env HsigFile False this_mod real_loc $ instantiateSignature + where + dflags = hsc_dflags hsc_env + +-- | Check if module implements a signature. (The signature is +-- always un-hashed, which is why its components are specified +-- explicitly.) +checkImplements :: Module -> HoleModule -> TcRn TcGblEnv +checkImplements impl_mod (uid, mod_name) = do + let cid = indefUnitIdComponentId uid + insts = indefUnitIdInsts uid + + -- STEP 1: Load the implementing interface, and make a RdrEnv + -- for its exports + impl_iface <- initIfaceTcRn $ + loadSysInterface (text "checkImplements 1") impl_mod + let impl_gr = mkGlobalRdrEnv + (gresFromAvails Nothing (mi_exports impl_iface)) + nsubst = mkNameShape (moduleName impl_mod) (mi_exports impl_iface) + + -- STEP 2: Load the *unrenamed, uninstantiated* interface for + -- the ORIGINAL signature. We are going to eventually rename it, + -- but we must proceed slowly, because it is NOT known if the + -- instantiation is correct. + let isig_mod = mkModule (newSimpleUnitId cid) mod_name + mb_isig_iface <- findAndReadIface (text "checkImplements 2") isig_mod False + isig_iface <- case mb_isig_iface of + Succeeded (iface, _) -> return iface + Failed err -> failWithTc $ + hang (text "Could not find hi interface for signature" <+> + quotes (ppr isig_mod) <> colon) 4 err + + -- STEP 3: Check that the implementing interface exports everything + -- we need. (Notice we IGNORE the Modules in the AvailInfos.) + forM_ (concatMap (map occName . availNames) (mi_exports isig_iface)) $ \occ -> + case lookupGlobalRdrEnv impl_gr occ of + [] -> addErr $ quotes (ppr occ) + <+> text "is exported by the hsig file, but not exported the module" + <+> quotes (ppr impl_mod) + _ -> return () + failIfErrsM + + -- STEP 4: Now that the export is complete, rename the interface... + hsc_env <- getTopEnv + sig_iface <- liftIO $ rnModIface hsc_env insts (Just nsubst) isig_iface + + -- STEP 5: ...and typecheck it. (Note that in both cases, the nsubst + -- lets us determine how top-level identifiers should be handled.) + sig_details <- initIfaceTcRn $ typecheckIfaceForInstantiate nsubst sig_iface + + -- STEP 6: Check that it's sufficient + tcg_env <- getGblEnv + checkHsigIface tcg_env impl_gr sig_details + + -- STEP 7: Make sure we have the right exports and imports, + -- in case we're going to serialize this out (only relevant + -- if we're actually instantiating). + dflags <- getDynFlags + let avails = calculateAvails dflags + impl_iface False{- safe -} False{- boot -} + return tcg_env { + tcg_exports = mi_exports sig_iface, + tcg_imports = tcg_imports tcg_env `plusImportAvails` avails + } + +-- | Given 'tcg_mod', instantiate a 'ModIface' from the indefinite +-- library to use the actual implementations of the relevant entities, +-- checking that the implementation matches the signature. +instantiateSignature :: TcRn TcGblEnv +instantiateSignature = do + tcg_env <- getGblEnv + dflags <- getDynFlags + let outer_mod = tcg_mod tcg_env + inner_mod = tcg_semantic_mod tcg_env + -- TODO: setup the local RdrEnv so the error messages look a little better. + -- But this information isn't stored anywhere. Should we RETYPECHECK + -- the local one just to get the information? Hmm... + MASSERT( moduleUnitId outer_mod == thisPackage dflags ) + inner_mod `checkImplements` + (newIndefUnitId (thisUnitIdComponentId dflags) + (thisUnitIdInsts dflags), moduleName outer_mod) diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs index b8a5c28036..779f9edc05 100644 --- a/compiler/typecheck/TcEnv.hs +++ b/compiler/typecheck/TcEnv.hs @@ -155,7 +155,9 @@ tcLookupGlobal name Nothing -> -- Should it have been in the local envt? - if nameIsLocalOrFrom (tcg_mod env) name + -- (NB: use semantic mod here, since names never use + -- identity module, see Note [Identity versus semantic module].) + if nameIsLocalOrFrom (tcg_semantic_mod env) name then notFound name -- Internal names can happen in GHCi else diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index d4f82bffdf..ff51891b8a 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -10,6 +10,8 @@ https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/TypeChecker {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} module TcRnDriver ( #ifdef GHCI @@ -25,6 +27,19 @@ module TcRnDriver ( tcRnGetInfo, tcRnModule, tcRnModuleTcRnM, tcTopSrcDecls, + rnTopSrcDecls, + checkBootDecl, checkHiBootIface', + findExtraSigImports, + implicitRequirements, + checkUnitId, + mergeSignatures, + tcRnMergeSignatures, + instantiateSignature, + tcRnInstantiateSignature, + -- More private... + badReexportedBootThing, + checkBootDeclM, + missingBootThing, ) where #ifdef GHCI @@ -73,8 +88,8 @@ import TcType import TcSimplify import TcTyClsDecls import TcTypeable ( mkTypeableBinds ) +import TcBackpack import LoadIface -import TidyPgm ( mkBootModDetailsTc ) import RnNames import RnEnv import RnSource @@ -158,120 +173,7 @@ tcRnModule hsc_env hsc_src save_rn_syntax = (mAIN, srcLocSpan (srcSpanStart loc)) --- To be called at the beginning of renaming hsig files. --- If we're processing a signature, load up the RdrEnv --- specified by sig-of so that --- when we process top-level bindings, we pull in the right --- original names. We also need to add in dependencies from --- the implementation (orphans, family instances, packages), --- similar to how rnImportDecl handles things. --- ToDo: Handle SafeHaskell -tcRnSignature :: DynFlags -> HscSource -> TcRn TcGblEnv -tcRnSignature dflags hsc_src - = do { tcg_env <- getGblEnv ; - case tcg_sig_of tcg_env of { - Just sof - | hsc_src /= HsigFile -> do - { addErr (text "Illegal -sig-of specified for non hsig") - ; return tcg_env - } - | otherwise -> do - { sig_iface <- initIfaceTcRn $ loadSysInterface (text "sig-of") sof - ; let { gr = mkGlobalRdrEnv - (gresFromAvails Nothing (mi_exports sig_iface)) - ; avails = calculateAvails dflags - sig_iface False{- safe -} False{- boot -} } - ; return (tcg_env - { tcg_impl_rdr_env = Just gr - , tcg_imports = tcg_imports tcg_env `plusImportAvails` avails - }) - } ; - Nothing - | HsigFile <- hsc_src - , HscNothing <- hscTarget dflags -> do - { return tcg_env - } - | HsigFile <- hsc_src -> do - { addErr (text "Missing -sig-of for hsig") - ; failM } - | otherwise -> return tcg_env - } - } -checkHsigIface :: HscEnv -> TcGblEnv -> TcRn () -checkHsigIface hsc_env tcg_env - = case tcg_impl_rdr_env tcg_env of - Just gr -> do { sig_details <- liftIO $ mkBootModDetailsTc hsc_env tcg_env - ; checkHsigIface' gr sig_details - } - Nothing -> return () - -checkHsigIface' :: GlobalRdrEnv -> ModDetails -> TcRn () -checkHsigIface' gr - ModDetails { md_insts = sig_insts, md_fam_insts = sig_fam_insts, - md_types = sig_type_env, md_exports = sig_exports} - = do { traceTc "checkHsigIface" $ vcat - [ ppr sig_type_env, ppr sig_insts, ppr sig_exports ] - ; mapM_ check_export sig_exports - ; unless (null sig_fam_insts) $ - panic ("TcRnDriver.checkHsigIface: Cannot handle family " ++ - "instances in hsig files yet...") - ; mapM_ check_inst sig_insts - ; failIfErrsM - } - where - check_export sig_avail - -- Skip instances, we'll check them later - | name `elem` dfun_names = return () - | otherwise = do - { -- Lookup local environment only (don't want to accidentally pick - -- up the backing copy.) We consult tcg_type_env because we want - -- to pick up wired in names too (which get dropped by the iface - -- creation process); it's OK for a signature file to mention - -- a wired in name. - env <- getGblEnv - ; case lookupNameEnv (tcg_type_env env) name of - Nothing - -- All this means is no local definition is available: but we - -- could have created the export this way: - -- - -- module ASig(f) where - -- import B(f) - -- - -- In this case, we have to just lookup the identifier in - -- the backing implementation and make sure it matches. - | [GRE { gre_name = name' }] - <- lookupGlobalRdrEnv gr (nameOccName name) - , name == name' -> return () - -- TODO: Possibly give a different error if the identifier - -- is exported, but it's a different original name - | otherwise -> addErrAt (nameSrcSpan name) - (missingBootThing False name "exported by") - Just sig_thing -> do { - -- We use tcLookupImported_maybe because we want to EXCLUDE - -- tcg_env. - ; r <- tcLookupImported_maybe name - ; case r of - Failed err -> addErr err - Succeeded real_thing -> checkBootDeclM False sig_thing real_thing - }} - where - name = availName sig_avail - - dfun_names = map getName sig_insts - - -- In general, for hsig files we can't assume that the implementing - -- file actually implemented the instances (they may be reexported - -- from elsewhere). Where should we look for the instances? We do - -- the same as we would otherwise: consult the EPS. This isn't - -- perfect (we might conclude the module exports an instance - -- when it doesn't, see #9422), but we will never refuse to compile - -- something - check_inst :: ClsInst -> TcM () - check_inst sig_inst - = do eps <- getEps - when (not (memberInstEnv (eps_inst_env eps) sig_inst)) $ - addErrTc (instMisMatch False sig_inst) tcRnModuleTcRnM :: HscEnv -> HscSource @@ -290,16 +192,13 @@ tcRnModuleTcRnM hsc_env hsc_src }) (this_mod, prel_imp_loc) = setSrcSpan loc $ - do { let { dflags = hsc_dflags hsc_env - ; explicit_mod_hdr = isJust maybe_mod } ; - - tcg_env <- tcRnSignature dflags hsc_src ; - setGblEnv tcg_env $ do { + do { let { explicit_mod_hdr = isJust maybe_mod } ; -- Load the hi-boot interface for this module, if any -- We do this now so that the boot_names can be passed -- to tcTyAndClassDecls, because the boot_names are -- automatically considered to be loop breakers + tcg_env <- getGblEnv ; boot_info <- tcHiBootIface hsc_src this_mod ; setGblEnv (tcg_env { tcg_self_boot = boot_info }) $ do { @@ -312,8 +211,22 @@ tcRnModuleTcRnM hsc_env hsc_src when (notNull prel_imports) $ addWarn (Reason Opt_WarnImplicitPrelude) (implicitPreludeWarn) ; + -- TODO This is a little skeevy; maybe handle a bit more directly + let { simplifyImport (L _ idecl) = (fmap sl_fs (ideclPkgQual idecl), ideclName idecl) } ; + raw_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src (moduleName this_mod) ; + raw_req_imports <- liftIO $ + implicitRequirements hsc_env (map simplifyImport (prel_imports ++ import_decls)) ; + let { mkImport (Nothing, L _ mod_name) = noLoc $ (simpleImportDecl mod_name) { + ideclHiding = Just (False, noLoc []) + } ; + mkImport _ = panic "mkImport" } ; + + let { all_imports = prel_imports ++ import_decls + ++ map mkImport (raw_sig_imports ++ raw_req_imports) } ; + + -- OK now finally rename the imports tcg_env <- {-# SCC "tcRnImports" #-} - tcRnImports hsc_env (prel_imports ++ import_decls) ; + tcRnImports hsc_env all_imports ; -- If the whole module is warned about or deprecated -- (via mod_deprec) record that in tcg_warns. If we do thereby add @@ -347,21 +260,6 @@ tcRnModuleTcRnM hsc_env hsc_src -- Must be done after processing the exports tcg_env <- checkHiBootIface tcg_env boot_info ; - -- Compare the hsig tcg_env with the real thing - checkHsigIface hsc_env tcg_env ; - - -- Nub out type class instances now that we've checked them, - -- if we're compiling an hsig with sig-of. - -- See Note [Signature files and type class instances] - tcg_env <- (case tcg_sig_of tcg_env of - Just _ -> return tcg_env { - tcg_inst_env = emptyInstEnv, - tcg_fam_inst_env = emptyFamInstEnv, - tcg_insts = [], - tcg_fam_insts = [] - } - Nothing -> return tcg_env) ; - -- The new type env is already available to stuff slurped from -- interface files, via TcEnv.setGlobalTypeEnv -- It's important that this includes the stuff in checkHiBootIface, @@ -381,7 +279,7 @@ tcRnModuleTcRnM hsc_env hsc_src -- Dump output and return tcDump tcg_env ; return tcg_env - }}}}} + }}}} implicitPreludeWarn :: SDoc implicitPreludeWarn @@ -697,10 +595,7 @@ tcRnHsBootDecls hsc_src decls -- are written into the interface file. ; let { type_env0 = tcg_type_env gbl_env ; type_env1 = extendTypeEnvWithIds type_env0 val_ids - -- Don't add the dictionaries for hsig, we don't actually want - -- to /define/ the instance - ; type_env2 | HsigFile <- hsc_src = type_env1 - | otherwise = extendTypeEnvWithIds type_env1 dfun_ids + ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids ; dfun_ids = map iDFunId inst_infos } @@ -909,7 +804,8 @@ checkHiBootIface' boot_dfun_ty = idType boot_dfun boot_dfun_name = idName boot_dfun --- This has to compare the TyThing from the .hi-boot file to the TyThing +-- In general, to perform these checks we have to +-- compare the TyThing from the .hi-boot file to the TyThing -- in the current source file. We must be careful to allow alpha-renaming -- where appropriate, and also the boot declaration is allowed to omit -- constructors and class methods. @@ -921,7 +817,7 @@ checkHiBootIface' checkBootDeclM :: Bool -- ^ True <=> an hs-boot file (could also be a sig) -> TyThing -> TyThing -> TcM () checkBootDeclM is_boot boot_thing real_thing - = whenIsJust (checkBootDecl boot_thing real_thing) $ \ err -> + = whenIsJust (checkBootDecl is_boot boot_thing real_thing) $ \ err -> addErrAt (nameSrcSpan (getName boot_thing)) (bootMisMatch is_boot err real_thing boot_thing) @@ -929,20 +825,20 @@ checkBootDeclM is_boot boot_thing real_thing -- code. Returns @Nothing@ on success or @Just "some helpful info for user"@ -- failure. If the difference will be apparent to the user, @Just empty@ is -- perfectly suitable. -checkBootDecl :: TyThing -> TyThing -> Maybe SDoc +checkBootDecl :: Bool -> TyThing -> TyThing -> Maybe SDoc -checkBootDecl (AnId id1) (AnId id2) +checkBootDecl _ (AnId id1) (AnId id2) = ASSERT(id1 == id2) check (idType id1 `eqType` idType id2) (text "The two types are different") -checkBootDecl (ATyCon tc1) (ATyCon tc2) - = checkBootTyCon tc1 tc2 +checkBootDecl is_boot (ATyCon tc1) (ATyCon tc2) + = checkBootTyCon is_boot tc1 tc2 -checkBootDecl (AConLike (RealDataCon dc1)) (AConLike (RealDataCon _)) +checkBootDecl _ (AConLike (RealDataCon dc1)) (AConLike (RealDataCon _)) = pprPanic "checkBootDecl" (ppr dc1) -checkBootDecl _ _ = Just empty -- probably shouldn't happen +checkBootDecl _ _ _ = Just empty -- probably shouldn't happen -- | Combines two potential error messages andThenCheck :: Maybe SDoc -> Maybe SDoc -> Maybe SDoc @@ -984,8 +880,8 @@ checkSuccess :: Maybe SDoc checkSuccess = Nothing ---------------- -checkBootTyCon :: TyCon -> TyCon -> Maybe SDoc -checkBootTyCon tc1 tc2 +checkBootTyCon :: Bool -> TyCon -> TyCon -> Maybe SDoc +checkBootTyCon is_boot tc1 tc2 | not (eqType (tyConKind tc1) (tyConKind tc2)) = Just $ text "The types have different kinds" -- First off, check the kind @@ -1018,7 +914,7 @@ checkBootTyCon tc1 tc2 op_ty2 = funResultTy rho_ty2 eqAT (ATI tc1 def_ats1) (ATI tc2 def_ats2) - = checkBootTyCon tc1 tc2 `andThenCheck` + = checkBootTyCon is_boot tc1 tc2 `andThenCheck` check (eqATDef def_ats1 def_ats2) (text "The associated type defaults differ") @@ -1053,6 +949,11 @@ checkBootTyCon tc1 tc2 check (roles1 == roles2) roles_msg `andThenCheck` check (eqTypeX env syn_rhs1 syn_rhs2) empty -- nothing interesting to say + -- Type synonyms for hs-boot are questionable, so they + -- are not supported at the moment + | not is_boot && isAbstractTyCon tc1 && isTypeSynonymTyCon tc2 + = check (roles1 == roles2) roles_msg + | Just fam_flav1 <- famTyConFlav_maybe tc1 , Just fam_flav2 <- famTyConFlav_maybe tc2 = ASSERT(tc1 == tc2) @@ -1156,6 +1057,14 @@ missingBootThing is_boot name what <+> text "file, but not" <+> text what <+> text "the module" +badReexportedBootThing :: Bool -> Name -> Name -> SDoc +badReexportedBootThing is_boot name name' + = withPprStyle (mkUserStyle alwaysQualify AllTheWay) $ vcat + [ text "The" <+> (if is_boot then text "hs-boot" else text "hsig") + <+> text "file (re)exports" <+> quotes (ppr name) + , text "but the implementing module exports a different identifier" <+> quotes (ppr name') + ] + bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> SDoc bootMisMatch is_boot extra_info real_thing boot_thing = vcat [ppr real_thing <+> diff --git a/compiler/typecheck/TcRnDriver.hs-boot b/compiler/typecheck/TcRnDriver.hs-boot new file mode 100644 index 0000000000..8302926337 --- /dev/null +++ b/compiler/typecheck/TcRnDriver.hs-boot @@ -0,0 +1,11 @@ +module TcRnDriver where + +import Type (TyThing) +import TcRnTypes (TcM) +import Outputable (SDoc) +import Name (Name) + +checkBootDeclM :: Bool -- ^ True <=> an hs-boot file (could also be a sig) + -> TyThing -> TyThing -> TcM () +missingBootThing :: Bool -> Name -> String -> SDoc +badReexportedBootThing :: Bool -> Name -> Name -> SDoc diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index 6d949a993a..e2d4da1e9c 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -46,7 +46,7 @@ module TcRnMonad( debugTc, -- * Typechecker global environment - setModule, getIsGHCi, getGHCiMonad, getInteractivePrintName, + getIsGHCi, getGHCiMonad, getInteractivePrintName, tcIsHsBootOrSig, tcSelfBootInfo, getGlobalRdrEnv, getRdrEnvs, getImports, getFixityEnv, extendFixityEnv, getRecFieldEnv, @@ -119,12 +119,15 @@ module TcRnMonad( initIfaceTcRn, initIfaceCheck, initIfaceLcl, + initIfaceLclWithSubst, initIfaceLoad, getIfModule, failIfM, forkM_maybe, forkM, + withException, + -- * Types etc. module TcRnTypes, module IOEnv @@ -165,6 +168,7 @@ import Panic import Util import Annotations import BasicTypes( TopLevelFlag ) +import Maybes import qualified GHC.LanguageExtensions as LangExt @@ -240,9 +244,11 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this #endif /* GHCI */ tcg_mod = mod, + tcg_semantic_mod = + if thisPackage dflags == moduleUnitId mod + then canonicalizeHomeModule dflags (moduleName mod) + else mod, tcg_src = hsc_src, - tcg_sig_of = getSigOf dflags (moduleName mod), - tcg_impl_rdr_env = Nothing, tcg_rdr_env = emptyGlobalRdrEnv, tcg_fix_env = emptyNameEnv, tcg_field_env = emptyNameEnv, @@ -264,7 +270,12 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this tcg_dus = emptyDUs, tcg_rn_imports = [], - tcg_rn_exports = maybe_rn_syntax [], + tcg_rn_exports = + if hsc_src == HsigFile + -- Always retain renamed syntax, so that we can give + -- better errors. (TODO: how?) + then Just [] + else maybe_rn_syntax [], tcg_rn_decls = maybe_rn_syntax emptyRnGroup, tcg_tr_module = Nothing, tcg_binds = emptyLHsBinds, @@ -280,6 +291,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this tcg_fords = [], tcg_vects = [], tcg_patsyns = [], + tcg_merged = [], tcg_dfun_n = dfun_n_var, tcg_keep = keep_var, tcg_doc_hdr = Nothing, @@ -289,6 +301,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this tcg_safeInfer = infer_var, tcg_dependent_files = dependent_files_var, tcg_tc_plugins = [], + tcg_top_loc = loc, tcg_static_wc = static_wc_var } ; lcl_env = TcLclEnv { @@ -516,6 +529,16 @@ getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable) getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env) ; return (eps, hsc_HPT env) } +-- | A convenient wrapper for taking a @MaybeErr MsgDoc a@ and throwing +-- an exception if it is an error. +withException :: TcRnIf gbl lcl (MaybeErr MsgDoc a) -> TcRnIf gbl lcl a +withException do_this = do + r <- do_this + dflags <- getDynFlags + case r of + Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (showSDoc dflags err)) + Succeeded result -> return result + {- ************************************************************************ * * @@ -719,9 +742,6 @@ traceOptIf flag doc ************************************************************************ -} -setModule :: Module -> TcRn a -> TcRn a -setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside - getIsGHCi :: TcRn Bool getIsGHCi = do { mod <- getModule ; return (isInteractiveModule mod) } @@ -1619,6 +1639,7 @@ mkIfLclEnv mod loc boot = IfLclEnv { if_mod = mod, if_loc = loc, if_boot = boot, + if_nsubst = Nothing, if_tv_env = emptyFsEnv, if_id_env = emptyFsEnv } @@ -1628,9 +1649,18 @@ mkIfLclEnv mod loc boot initIfaceTcRn :: IfG a -> TcRn a initIfaceTcRn thing_inside = do { tcg_env <- getGblEnv + ; dflags <- getDynFlags + ; let mod = tcg_semantic_mod tcg_env + -- When we are instantiating a signature, we DEFINITELY + -- do not want to knot tie. + is_instantiate = unitIdIsDefinite (thisPackage dflags) && + not (null (thisUnitIdInsts dflags)) ; let { if_env = IfGblEnv { if_doc = text "initIfaceTcRn", - if_rec_types = Just (tcg_mod tcg_env, get_type_env) + if_rec_types = + if is_instantiate + then Nothing + else Just (mod, get_type_env) } ; get_type_env = readTcRef (tcg_type_env_var tcg_env) } ; setEnvs (if_env, ()) thing_inside } @@ -1664,6 +1694,13 @@ initIfaceLcl :: Module -> SDoc -> Bool -> IfL a -> IfM lcl a initIfaceLcl mod loc_doc hi_boot_file thing_inside = setLclEnv (mkIfLclEnv mod loc_doc hi_boot_file) thing_inside +-- | Initialize interface typechecking, but with a 'NameShape' +-- to apply when typechecking top-level 'OccName's (see +-- 'lookupIfaceTop') +initIfaceLclWithSubst :: Module -> SDoc -> Bool -> NameShape -> IfL a -> IfM lcl a +initIfaceLclWithSubst mod loc_doc hi_boot_file nsubst thing_inside + = setLclEnv ((mkIfLclEnv mod loc_doc hi_boot_file) { if_nsubst = Just nsubst }) thing_inside + getIfModule :: IfL Module getIfModule = do { env <- getLclEnv; return (if_mod env) } diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 6d956fe963..2a55b695e8 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -125,7 +125,8 @@ module TcRnTypes( -- Misc other types TcId, TcIdSet, - Hole(..), holeOcc + Hole(..), holeOcc, + NameShape(..) ) where @@ -171,6 +172,7 @@ import Outputable import ListSetOps import FastString import qualified GHC.LanguageExtensions as LangExt +import Fingerprint import Control.Monad (ap, liftM, msum) #if __GLASGOW_HASKELL__ > 710 @@ -188,6 +190,34 @@ import GHCi.RemoteTypes import qualified Language.Haskell.TH as TH #endif +-- | A 'NameShape' is a substitution on 'Name's that can be used +-- to refine the identities of a hole while we are renaming interfaces +-- (see 'RnModIface'). Specifically, a 'NameShape' for +-- 'ns_module_name' @A@, defines a mapping from @{A.T}@ +-- (for some 'OccName' @T@) to some arbitrary other 'Name'. +-- +-- The most intruiging thing about a 'NameShape', however, is +-- how it's constructed. A 'NameShape' is *implied* by the +-- exported 'AvailInfo's of the implementor of an interface: +-- if an implementor of signature @<H>@ exports @M.T@, you implicitly +-- define a substitution from @{H.T}@ to @M.T@. So a 'NameShape' +-- is computed from the list of 'AvailInfo's that are exported +-- by the implementation of a module, or successively merged +-- together by the export lists of signatures which are joining +-- together. +-- +-- It's not the most obvious way to go about doing this, but it +-- does seem to work! +-- +-- NB: Can't boot this and put it in NameShape because then we +-- start pulling in too many DynFlags things. +data NameShape = NameShape { + ns_mod_name :: ModuleName, + ns_exports :: [AvailInfo], + ns_map :: OccEnv Name + } + + {- ************************************************************************ * * @@ -274,6 +304,8 @@ data IfLclEnv -- The module for the current IfaceDecl -- So if we see f = \x -> x -- it means M.f = \x -> x, where M is the if_mod + -- NB: This is a semantic module, see + -- Note [Identity versus semantic module] if_mod :: Module, -- Whether or not the IfaceDecl came from a boot @@ -288,6 +320,8 @@ data IfLclEnv -- .hi file, or GHCi state, or ext core -- plus which bit is currently being examined + if_nsubst :: Maybe NameShape, + if_tv_env :: FastStringEnv TyVar, -- Nested tyvar bindings if_id_env :: FastStringEnv Id -- Nested id binding } @@ -381,6 +415,42 @@ data DsMetaVal data FrontendResult = FrontendTypecheck TcGblEnv +-- Note [Identity versus semantic module] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- When typechecking an hsig file, it is convenient to keep track +-- of two different "this module" identifiers: +-- +-- - The IDENTITY module is simply thisPackage + the module +-- name; i.e. it uniquely *identifies* the interface file +-- we're compiling. For example, p[A=<A>]:A is an +-- identity module identifying the requirement named A +-- from library p. +-- +-- - The SEMANTIC module, which is the actual module that +-- this signature is intended to represent (e.g. if +-- we have a identity module p[A=base:Data.IORef]:A, +-- then the semantic module is base:Data.IORef) +-- +-- Which one should you use? +-- +-- - In the desugarer and later phases of compilation, +-- identity and semantic modules coincide, since we never compile +-- signatures (we just generate blank object files for +-- hsig files.) +-- +-- - For any code involving Names, we want semantic modules. +-- See lookupIfaceTop in IfaceEnv, mkIface and addFingerprints +-- in MkIface, and tcLookupGlobal in TcEnv +-- +-- - When reading interfaces, we want the identity module to +-- identify the specific interface we want (such interfaces +-- should never be loaded into the EPS). However, if a +-- hole module <A> is requested, we look for A.hi +-- in the home library we are compiling. (See LoadIface.) +-- Similarly, in RnNames we check for self-imports using +-- identity modules, to allow signatures to import their implementor. + + -- | 'TcGblEnv' describes the top-level of the module at the -- point at which the typechecker is finished work. -- It is this structure that is handed on to the desugarer @@ -389,13 +459,10 @@ data FrontendResult data TcGblEnv = TcGblEnv { tcg_mod :: Module, -- ^ Module being compiled + tcg_semantic_mod :: Module, -- ^ If a signature, the backing module + -- See also Note [Identity versus semantic module] tcg_src :: HscSource, -- ^ What kind of module (regular Haskell, hs-boot, hsig) - tcg_sig_of :: Maybe Module, - -- ^ Are we being compiled as a signature of an implementation? - tcg_impl_rdr_env :: Maybe GlobalRdrEnv, - -- ^ Environment used only during -sig-of for resolving top level - -- bindings. See Note [Signature parameters in TcGblEnv and DynFlags] tcg_rdr_env :: GlobalRdrEnv, -- ^ Top level envt; used during renaming tcg_default :: Maybe [Type], @@ -482,6 +549,10 @@ data TcGblEnv tcg_dfun_n :: TcRef OccSet, -- ^ Allows us to choose unique DFun names. + tcg_merged :: [(Module, Fingerprint)], + -- ^ The requirements we merged with; we always have to recompile + -- if any of these changed. + -- The next fields accumulate the payload of the module -- The binds, rules and foreign-decl fields are collected -- initially in un-zonked form and are finally zonked in tcRnSrcDecls @@ -559,63 +630,22 @@ data TcGblEnv tcg_tc_plugins :: [TcPluginSolver], -- ^ A list of user-defined plugins for the constraint solver. + tcg_top_loc :: RealSrcSpan, + -- ^ The RealSrcSpan this module came from + tcg_static_wc :: TcRef WantedConstraints -- ^ Wanted constraints of static forms. } +-- NB: topModIdentity, not topModSemantic! +-- Definition sites of orphan identities will be identity modules, not semantic +-- modules. tcVisibleOrphanMods :: TcGblEnv -> ModuleSet tcVisibleOrphanMods tcg_env = mkModuleSet (tcg_mod tcg_env : imp_orphs (tcg_imports tcg_env)) --- Note [Signature parameters in TcGblEnv and DynFlags] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- When compiling signature files, we need to know which implementation --- we've actually linked against the signature. There are three seemingly --- redundant places where this information is stored: in DynFlags, there --- is sigOf, and in TcGblEnv, there is tcg_sig_of and tcg_impl_rdr_env. --- Here's the difference between each of them: --- --- * DynFlags.sigOf is global per invocation of GHC. If we are compiling --- with --make, there may be multiple signature files being compiled; in --- which case this parameter is a map from local module name to implementing --- Module. --- --- * HscEnv.tcg_sig_of is global per the compilation of a single file, so --- it is simply the result of looking up tcg_mod in the DynFlags.sigOf --- parameter. It's setup in TcRnMonad.initTc. This prevents us --- from having to repeatedly do a lookup in DynFlags.sigOf. --- --- * HscEnv.tcg_impl_rdr_env is a RdrEnv that lets us look up names --- according to the sig-of module. It's setup in TcRnDriver.tcRnSignature. --- Here is an example showing why we need this map: --- --- module A where --- a = True --- --- module ASig where --- import B --- a :: Bool --- --- module B where --- b = False --- --- When we compile ASig --sig-of main:A, the default --- global RdrEnv (tcg_rdr_env) has an entry for b, but not for a --- (we never imported A). So we have to look in a different environment --- to actually get the original name. --- --- By the way, why do we need to do the lookup; can't we just use A:a --- as the name directly? Well, if A is reexporting the entity from another --- module, then the original name needs to be the real original name: --- --- module C where --- a = True --- --- module A(a) where --- import C - instance ContainsModule TcGblEnv where - extractModule env = tcg_mod env + extractModule env = tcg_semantic_mod env type RecFieldEnv = NameEnv [FieldLabel] -- Maps a constructor name *in this module* @@ -2875,6 +2905,9 @@ data CtOrigin -- the user should never see this one, -- unlesss ImpredicativeTypes is on, where all -- bets are off + | InstProvidedOrigin Module ClsInst + -- Skolem variable arose when we were testing if an instance + -- is solvable or not. -- | A thing that can be stored for error message generation only. -- It is stored with a function to zonk and tidy the thing. @@ -3069,6 +3102,11 @@ pprCtOrigin (ProvCtxtOrigin PSB{ psb_id = (L _ name) }) = hang (ctoHerald <+> text "the \"provided\" constraints claimed by") 2 (text "the signature of" <+> quotes (ppr name)) +pprCtOrigin (InstProvidedOrigin mod cls_inst) + = vcat [ text "arising when attempting to show that" + , ppr cls_inst + , text "is provided by" <+> quotes (ppr mod)] + pprCtOrigin simple_origin = ctoHerald <+> pprCtO simple_origin diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 552426bd71..4731e5737c 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -1279,7 +1279,8 @@ tcLookupTh name Just thing -> return (AGlobal thing); Nothing -> - if nameIsLocalOrFrom (tcg_mod gbl_env) name + -- EZY: I don't think this choice matters, no TH in signatures! + if nameIsLocalOrFrom (tcg_semantic_mod gbl_env) name then -- It's defined in this module failWithTc (notInEnv name) @@ -1968,6 +1969,7 @@ reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do usageToModule _ (UsageFile {}) = Nothing usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m + usageToModule _ (UsageMergedRequirement { usg_mod = m }) = Just m ------------------------------ mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type diff --git a/compiler/types/InstEnv.hs b/compiler/types/InstEnv.hs index 6e6e45b655..d537af3e0a 100644 --- a/compiler/types/InstEnv.hs +++ b/compiler/types/InstEnv.hs @@ -446,6 +446,10 @@ classInstances (InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = -- | Checks for an exact match of ClsInst in the instance environment. -- We use this when we do signature checking in TcRnDriver +-- TODO: This will report that Show [Foo] is a member of an +-- instance environment containing Show a => Show [a], even if +-- Show Foo is not in the environment. Could try to make this +-- a bit more precise. memberInstEnv :: InstEnv -> ClsInst -> Bool memberInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm } ) = maybe False (\(ClsIE items) -> any (identicalClsInstHead ins_item) items) diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs index 472af2201e..764d99f8c7 100644 --- a/compiler/utils/Outputable.hs +++ b/compiler/utils/Outputable.hs @@ -178,7 +178,7 @@ type QueryQualifyName = Module -> OccName -> QualifyName type QueryQualifyModule = Module -> Bool -- | For a given package, we need to know whether to print it with --- the unit id to disambiguate it. +-- the component id to disambiguate it. type QueryQualifyPackage = UnitId -> Bool -- See Note [Printing original names] in HscTypes |