Commit 00b530d5 authored by Edward Z. Yang's avatar Edward Z. Yang

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: default avatarEdward 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
parent 887485a4
-- | 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
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
module Module where
import FastString
data Module
data ModuleName
data UnitId
newtype ComponentId = ComponentId FastString
moduleName :: Module -> ModuleName
moduleUnitId :: Module -> UnitId
unitIdString :: UnitId -> String
......@@ -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
......
......@@ -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,
......
......@@ -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
......
......@@ -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
......
module IfaceEnv where
import Module
import OccName
import TcRnMonad
import Name
import SrcLoc
newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
......@@ -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
......
This diff is collapsed.
module LoadIface where
import Module (Module)
import TcRnMonad (IfM)
import HscTypes (ModIface)
import Outputable (SDoc)
loadSysInterface :: SDoc -> Module -> IfM lcl ModIface
This diff is collapsed.
This diff is collapsed.
......@@ -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 }
......
This diff is collapsed.
......@@ -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 $
......
This diff is collapsed.
......@@ -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
......
......@@ -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'
......@@ -2279,6 +2326,11 @@ data Usage
-- here, because there's no reason to recompile if the actual
-- contents don't change. This previously lead to odd
-- recompilation behaviors; see #8114
}