Skip to content

GitLab

Commit bbad4f6b authored by Edward Z. Yang's avatar Edward Z. Yang
Browse files

Delete ShPackageKey for now. 


Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>
parent 614ce4b0
Hide whitespace changes
Inline Side-by-side
compiler/backpack/ShPackageKey.hs deleted 100644 → 0
View file @ 614ce4b0
{-# LANGUAGE CPP #-}
module ShPackageKey(
ShFreeHoles,
calcModuleFreeHoles,
newPackageKey,
newPackageKeyWithScope,
lookupPackageKey,
generalizeHoleModule,
canonicalizeModule,
pprPackageKey
) where
#include "HsVersions.h"
import Module
import Packages
import Encoding
import FastString
import UniqFM
import UniqSet
import Outputable
import Util
import DynFlags
import System.IO.Unsafe ( unsafePerformIO )
import Control.Monad
import Data.IORef
import GHC.Fingerprint
import Data.List
import Data.Function
-- NB: didn't put this in Module, that seems a bit too low in the
-- hierarchy, need to refer to DynFlags
{-
************************************************************************
* *
Package Keys
* *
************************************************************************
-}
-- Note: [PackageKey cache]
-- ~~~~~~~~~~~~~~~~~~~~~~~~
-- The built-in PackageKey type (used by Module, Name, etc)
-- records the instantiation of the package as an MD5 hash
-- which is not reversible without some extra information.
-- However, the shape merging process requires us to be able
-- to substitute Module occurrences /inside/ the package key.
--
-- Thus, we maintain the invariant: for every PackageKey
-- in our system, either:
--
-- 1. It is in the installed package database (lookupPackage)
-- so we can lookup the recorded instantiatedWith
-- 2. We've recorded the associated mapping in the
-- PackageKeyCache.
--
-- A PackageKey can be expanded into a ShPackageKey which has
-- the instance mapping. In the mapping, we don't bother
-- expanding a 'Module'; depending on 'shPackageKeyFreeHoles',
-- it may not be necessary to do a substitution (you only
-- need to drill down when substituing HOLE:H if H is in scope.
-- Note: [Module name in scope set]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Similar to InScopeSet, ShFreeHoles is an optimization that
-- allows us to avoid expanding a PackageKey into an ShPackageKey
-- if there isn't actually anything in the module expression that
-- we can substitute.
-- | Given a Name or Module, the 'ShFreeHoles' contains the set
-- of free variables, i.e. HOLE:A modules, which may be substituted.
-- If this set is empty no substitutions are possible.
type ShFreeHoles = UniqSet ModuleName
-- | Calculate the free holes of a 'Module'.
calcModuleFreeHoles :: DynFlags -> Module -> IO ShFreeHoles
calcModuleFreeHoles dflags m
| modulePackageKey m == holePackageKey = return (unitUniqSet (moduleName m))
| otherwise = do
shpk <- lookupPackageKey dflags (modulePackageKey m)
return $ case shpk of
ShDefinitePackageKey{} -> emptyUniqSet
ShPackageKey{ shPackageKeyFreeHoles = in_scope } -> in_scope
-- | Calculate the free holes of the hole map @[('ModuleName', 'Module')]@.
calcInstsFreeHoles :: DynFlags -> [(ModuleName, Module)] -> IO ShFreeHoles
calcInstsFreeHoles dflags insts =
fmap unionManyUniqSets (mapM (calcModuleFreeHoles dflags . snd) insts)
-- | Given a 'UnitName', a 'LibraryName', and sorted mapping of holes to
-- their implementations, compute the 'PackageKey' associated with it, as well
-- as the recursively computed 'ShFreeHoles' of holes that may be substituted.
newPackageKeyWithScope :: DynFlags
-> UnitName
-> LibraryName
-> [(ModuleName, Module)]
-> IO (PackageKey, ShFreeHoles)
newPackageKeyWithScope dflags pn vh insts = do
fhs <- calcInstsFreeHoles dflags insts
pk <- newPackageKey' dflags (ShPackageKey pn vh insts fhs)
return (pk, fhs)
-- | Given a 'UnitName' and sorted mapping of holes to
-- their implementations, compute the 'PackageKey' associated with it.
-- (Analogous to 'newGlobalBinder').
newPackageKey :: DynFlags
-> UnitName
-> LibraryName
-> [(ModuleName, Module)]
-> IO PackageKey
newPackageKey dflags pn vh insts = do
(pk, _) <- newPackageKeyWithScope dflags pn vh insts
return pk
-- | Given a 'ShPackageKey', compute the 'PackageKey' associated with it.
-- This function doesn't calculate the 'ShFreeHoles', because it is
-- provided with 'ShPackageKey'.
newPackageKey' :: DynFlags -> ShPackageKey -> IO PackageKey
newPackageKey' _ (ShDefinitePackageKey pk) = return pk
newPackageKey' dflags
shpk@(ShPackageKey pn vh insts fhs) = do
ASSERTM( fmap (==fhs) (calcInstsFreeHoles dflags insts) )
let pk = mkPackageKey pn vh insts
pkt_var = pkgKeyCache dflags
pk_cache <- readIORef pkt_var
let consistent pk_cache = maybe True (==shpk) (lookupUFM pk_cache pk)
MASSERT( consistent pk_cache )
when (not (elemUFM pk pk_cache)) $
atomicModifyIORef' pkt_var (\pk_cache ->
-- Could race, but it's guaranteed to be the same
ASSERT( consistent pk_cache ) (addToUFM pk_cache pk shpk, ()))
return pk
-- | Given a 'PackageKey', reverse lookup the 'ShPackageKey' associated
-- with it. This only gives useful information for keys which are
-- created using 'newPackageKey' or the associated functions, or that are
-- already in the installed package database, since we generally cannot reverse
-- MD5 hashes.
lookupPackageKey :: DynFlags
-> PackageKey
-> IO ShPackageKey
lookupPackageKey dflags pk
| pk `elem` wiredInPackageKeys
|| pk == mainPackageKey
|| pk == holePackageKey
= return (ShDefinitePackageKey pk)
| otherwise = do
let pkt_var = pkgKeyCache dflags
pk_cache <- readIORef pkt_var
case lookupUFM pk_cache pk of
Just r -> return r
_ -> return (ShDefinitePackageKey pk)
pprPackageKey :: PackageKey -> SDoc
pprPackageKey pk = sdocWithDynFlags $ \dflags ->
-- name cache is a memotable
let shpk = unsafePerformIO (lookupPackageKey dflags pk)
in case shpk of
shpk@ShPackageKey{} ->
ppr (shPackageKeyUnitName shpk) <>
parens (hsep
(punctuate comma [ ppUnless (moduleName m == modname)
(ppr modname <+> text "->")
<+> ppr m
| (modname, m) <- shPackageKeyInsts shpk]))
<> ifPprDebug (braces (ftext (packageKeyFS pk)))
ShDefinitePackageKey pk -> ftext (packageKeyFS pk)
-- NB: newPackageKey and lookupPackageKey are mutually recursive; this
-- recursion is guaranteed to bottom out because you can't set up cycles
-- of PackageKeys.
{-
************************************************************************
* *
Package key hashing
* *
************************************************************************
-}
-- | Generates a 'PackageKey'. Don't call this directly; you probably
-- want to cache the result.
mkPackageKey :: UnitName
-> LibraryName
-> [(ModuleName, Module)] -- hole instantiations
-> PackageKey
mkPackageKey (UnitName fsUnitName)
(LibraryName fsLibraryName) unsorted_holes =
-- NB: don't use concatFS here, it's not much of an improvement
fingerprintPackageKey . fingerprintString $
unpackFS fsUnitName ++ "\n" ++
unpackFS fsLibraryName ++ "\n" ++
concat [ moduleNameString m
++ " " ++ packageKeyString (modulePackageKey b)
++ ":" ++ moduleNameString (moduleName b) ++ "\n"
| (m, b) <- sortBy (stableModuleNameCmp `on` fst) unsorted_holes]
-- | Generalize a 'Module' into one where all the holes are indefinite.
-- @p(A -> ...):C@ generalizes to @p(A -> HOLE:A):C@. Useful when
-- you need to figure out if you've already type-checked the generalized
-- version of this module, so you don't have to do the whole rigamarole.
generalizeHoleModule :: DynFlags -> Module -> IO Module
generalizeHoleModule dflags m = do
pk <- generalizeHolePackageKey dflags (modulePackageKey m)
return (mkModule pk (moduleName m))
-- | Generalize a 'PackageKey' into one where all the holes are indefinite.
-- @p(A -> q():A) generalizes to p(A -> HOLE:A)@.
generalizeHolePackageKey :: DynFlags -> PackageKey -> IO PackageKey
generalizeHolePackageKey dflags pk = do
shpk <- lookupPackageKey dflags pk
case shpk of
ShDefinitePackageKey _ -> return pk
ShPackageKey { shPackageKeyUnitName = pn,
shPackageKeyLibraryName = vh,
shPackageKeyInsts = insts0 }
-> let insts = map (\(x, _) -> (x, mkModule holePackageKey x)) insts0
in newPackageKey dflags pn vh insts
-- | Canonicalize a 'Module' so that it uniquely identifies a module.
-- For example, @p(A -> M):A@ canonicalizes to @M@. Useful for making
-- sure the interface you've loaded as the right @mi_module@.
canonicalizeModule :: DynFlags -> Module -> IO Module
canonicalizeModule dflags m = do
let pk = modulePackageKey m
shpk <- lookupPackageKey dflags pk
return $ case shpk of
ShPackageKey { shPackageKeyInsts = insts }
| Just m' <- lookup (moduleName m) insts -> m'
_ -> m
fingerprintPackageKey :: Fingerprint -> PackageKey
fingerprintPackageKey (Fingerprint a b)
= stringToPackageKey (toBase62Padded a ++ toBase62Padded b)
-- See Note [Base 62 encoding 128-bit integers]
compiler/ghc.cabal.in
View file @ bbad4f6b
......@@ -497,7 +497,6 @@ Library
Vectorise
Hoopl.Dataflow
Hoopl
ShPackageKey
-- CgInfoTbls used in ghci/DebuggerUtils
-- CgHeapery mkVirtHeapOffsets used in ghci
......
compiler/main/DynFlags.hs
View file @ bbad4f6b
......@@ -100,10 +100,6 @@ module DynFlags (
parseDynamicFilePragma,
parseDynamicFlagsFull,
-- ** Package key cache
PackageKeyCache,
ShPackageKey(..),
-- ** Available DynFlags
allFlags,
flagsAll,
......@@ -181,8 +177,6 @@ import Foreign.C ( CInt(..) )
import System.IO.Unsafe ( unsafeDupablePerformIO )
#endif
import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessage )
import UniqFM
import UniqSet
import System.IO.Unsafe ( unsafePerformIO )
import Data.IORef
......@@ -666,29 +660,6 @@ type SigOf = Map ModuleName Module
getSigOf :: DynFlags -> ModuleName -> Maybe Module
getSigOf dflags n = Map.lookup n (sigOf dflags)
-- NameCache updNameCache
type PackageKeyEnv = UniqFM
type PackageKeyCache = PackageKeyEnv ShPackageKey
-- | An elaborated representation of a 'PackageKey', which records
-- all of the components that go into the hashed 'PackageKey'.
data ShPackageKey
= ShPackageKey {
shPackageKeyUnitName :: !UnitName,
shPackageKeyLibraryName :: !LibraryName,
shPackageKeyInsts :: ![(ModuleName, Module)],
shPackageKeyFreeHoles :: UniqSet ModuleName
}
| ShDefinitePackageKey {
shPackageKey :: !PackageKey
}
deriving Eq
instance Outputable ShPackageKey where
ppr (ShPackageKey pn vh insts fh)
= ppr pn <+> ppr vh <+> ppr insts <+> parens (ppr fh)
ppr (ShDefinitePackageKey pk) = ppr pk
-- | 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 {
......@@ -734,9 +705,6 @@ data DynFlags = DynFlags {
-- Typically only 1 is needed
thisPackage :: PackageKey, -- ^ key of package currently being compiled
thisLibraryName :: LibraryName,
-- ^ the version hash which identifies the textual
-- package being compiled.
-- ways
ways :: [Way], -- ^ Way flags from the command line
......@@ -823,7 +791,6 @@ data DynFlags = DynFlags {
-- Packages.initPackages
pkgDatabase :: Maybe [PackageConfig],
pkgState :: PackageState,
pkgKeyCache :: {-# UNPACK #-} !(IORef PackageKeyCache),
-- Temporary files
-- These have to be IORefs, because the defaultCleanupHandler needs to
......@@ -1473,7 +1440,6 @@ defaultDynFlags mySettings =
solverIterations = treatZeroAsInf mAX_SOLVER_ITERATIONS,
thisPackage = mainPackageKey,
thisLibraryName = LibraryName nilFS,
objectDir = Nothing,
dylibInstallName = Nothing,
......@@ -1519,7 +1485,6 @@ defaultDynFlags mySettings =
pkgDatabase = Nothing,
-- This gets filled in with GHC.setSessionDynFlags
pkgState = emptyPackageState,
pkgKeyCache = v_unsafePkgKeyCache,
ways = defaultWays mySettings,
buildTag = mkBuildTag (defaultWays mySettings),
rtsBuildTag = mkBuildTag (defaultWays mySettings),
......@@ -2768,7 +2733,6 @@ package_flags = [
upd (setPackageKey name)
deprecate "Use -this-package-key instead")
, defGhcFlag "this-package-key" (hasArg setPackageKey)
, defGhcFlag "library-name" (hasArg setLibraryName)
, defFlag "package-id" (HasArg exposePackageId)
, defFlag "package" (HasArg exposePackage)
, defFlag "package-key" (HasArg exposePackageKey)
......@@ -3773,9 +3737,6 @@ exposePackage' p dflags
setPackageKey :: String -> DynFlags -> DynFlags
setPackageKey p s = s{ thisPackage = stringToPackageKey p }
setLibraryName :: String -> DynFlags -> DynFlags
setLibraryName v s = s{ thisLibraryName = LibraryName (mkFastString v) }
-- -----------------------------------------------------------------------------
-- | Find the package environment (if one exists)
--
......@@ -4266,8 +4227,6 @@ unsafeGlobalDynFlags = unsafePerformIO $ readIORef v_unsafeGlobalDynFlags
setUnsafeGlobalDynFlags :: DynFlags -> IO ()
setUnsafeGlobalDynFlags = writeIORef v_unsafeGlobalDynFlags
GLOBAL_VAR(v_unsafePkgKeyCache, emptyUFM, PackageKeyCache)
-- -----------------------------------------------------------------------------
-- SSE and AVX
......
compiler/main/PackageConfig.hs
View file @ bbad4f6b
......@@ -12,18 +12,13 @@ module PackageConfig (
-- * PackageKey
packageConfigId,
-- * LibraryName
LibraryName(..),
-- * The PackageConfig type: information about a package
PackageConfig,
InstalledPackageInfo(..),
InstalledPackageId(..),
SourcePackageId(..),
PackageName(..),
UnitName(..),
Version(..),
packageUnitName,
defaultPackageConfig,
installedPackageIdString,
sourcePackageIdString,
......@@ -59,8 +54,6 @@ type PackageConfig = InstalledPackageInfo
newtype InstalledPackageId = InstalledPackageId FastString deriving (Eq, Ord)
newtype SourcePackageId = SourcePackageId FastString deriving (Eq, Ord)
newtype PackageName = PackageName FastString deriving (Eq, Ord)
newtype UnitName = UnitName FastString deriving (Eq, Ord)
newtype LibraryName = LibraryName FastString deriving (Eq, Ord)
instance BinaryStringRep InstalledPackageId where
fromStringRep = InstalledPackageId . mkFastStringByteString
......@@ -74,10 +67,6 @@ instance BinaryStringRep PackageName where
fromStringRep = PackageName . mkFastStringByteString
toStringRep (PackageName s) = fastStringToByteString s
instance BinaryStringRep LibraryName where
fromStringRep = LibraryName . mkFastStringByteString
toStringRep (LibraryName s) = fastStringToByteString s
instance Uniquable InstalledPackageId where
getUnique (InstalledPackageId n) = getUnique n
......@@ -90,12 +79,6 @@ instance Uniquable PackageName where
instance Outputable InstalledPackageId where
ppr (InstalledPackageId str) = ftext str
instance Outputable UnitName where
ppr (UnitName str) = ftext str
instance Outputable LibraryName where
ppr (LibraryName str) = ftext str
instance Outputable SourcePackageId where
ppr (SourcePackageId str) = ftext str
......@@ -188,7 +171,3 @@ pprPackageConfig InstalledPackageInfo {..} =
-- | Get the GHC 'PackageKey' right out of a Cabalish 'PackageConfig'
packageConfigId :: PackageConfig -> PackageKey
packageConfigId = packageKey
packageUnitName :: PackageConfig -> UnitName
packageUnitName pkg = let PackageName fs = packageName pkg
in UnitName fs
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment