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.
{-# 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)
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!
<