diff options
33 files changed, 962 insertions, 649 deletions
diff --git a/compiler/backpack/RnModIface.hs b/compiler/backpack/RnModIface.hs index b90edd90ad..0bf7c9678f 100644 --- a/compiler/backpack/RnModIface.hs +++ b/compiler/backpack/RnModIface.hs @@ -241,6 +241,18 @@ rnIfaceGlobal n = do let nsubst = mkNameShape (moduleName m) (mi_exports iface) return (substNameShape nsubst n) +-- | Rename a DFun name. Here is where we ensure that DFuns have the correct +-- module as described in Note [Bogus DFun renamings]. +rnIfaceDFun :: Name -> ShIfM Name +rnIfaceDFun name = do + hmap <- getHoleSubst + dflags <- getDynFlags + iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv + let m = renameHoleModule dflags hmap $ nameModule name + -- Doublecheck that this DFun was, indeed, locally defined. + MASSERT2( iface_semantic_mod == m, ppr iface_semantic_mod <+> ppr m ) + setNameModule (Just m) name + -- PILES AND PILES OF BOILERPLATE -- | Rename an 'IfaceClsInst', with special handling for an associated @@ -250,9 +262,6 @@ 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 @@ -312,12 +321,7 @@ rnIfaceClsInst cls_inst = do -- 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) + dfun <- rnIfaceDFun (ifDFun cls_inst) return cls_inst { ifInstCls = n , ifInstTys = tys , ifDFun = dfun @@ -339,56 +343,71 @@ rnIfaceDecl' (fp, decl) = (,) fp <$> rnIfaceDecl decl rnIfaceDecl :: Rename IfaceDecl rnIfaceDecl d@IfaceId{} = do + name <- case ifIdDetails d of + IfDFunId -> rnIfaceDFun (ifName d) + _ -> rnIfaceGlobal (ifName d) ty <- rnIfaceType (ifType d) details <- rnIfaceIdDetails (ifIdDetails d) info <- rnIfaceIdInfo (ifIdInfo d) - return d { ifType = ty + return d { ifName = name + , ifType = ty , ifIdDetails = details , ifIdInfo = info } rnIfaceDecl d@IfaceData{} = do + name <- rnIfaceGlobal (ifName d) binders <- mapM rnIfaceTyConBinder (ifBinders d) ctxt <- mapM rnIfaceType (ifCtxt d) cons <- rnIfaceConDecls (ifCons d) parent <- rnIfaceTyConParent (ifParent d) - return d { ifBinders = binders + return d { ifName = name + , ifBinders = binders , ifCtxt = ctxt , ifCons = cons , ifParent = parent } rnIfaceDecl d@IfaceSynonym{} = do + name <- rnIfaceGlobal (ifName d) binders <- mapM rnIfaceTyConBinder (ifBinders d) syn_kind <- rnIfaceType (ifResKind d) syn_rhs <- rnIfaceType (ifSynRhs d) - return d { ifBinders = binders + return d { ifName = name + , ifBinders = binders , ifResKind = syn_kind , ifSynRhs = syn_rhs } rnIfaceDecl d@IfaceFamily{} = do + name <- rnIfaceGlobal (ifName d) binders <- mapM rnIfaceTyConBinder (ifBinders d) fam_kind <- rnIfaceType (ifResKind d) fam_flav <- rnIfaceFamTyConFlav (ifFamFlav d) - return d { ifBinders = binders + return d { ifName = name + , ifBinders = binders , ifResKind = fam_kind , ifFamFlav = fam_flav } rnIfaceDecl d@IfaceClass{} = do + name <- rnIfaceGlobal (ifName d) ctxt <- mapM rnIfaceType (ifCtxt d) binders <- mapM rnIfaceTyConBinder (ifBinders d) ats <- mapM rnIfaceAT (ifATs d) sigs <- mapM rnIfaceClassOp (ifSigs d) - return d { ifCtxt = ctxt + return d { ifName = name + , ifCtxt = ctxt , ifBinders = binders , ifATs = ats , ifSigs = sigs } rnIfaceDecl d@IfaceAxiom{} = do + name <- rnIfaceGlobal (ifName d) tycon <- rnIfaceTyCon (ifTyCon d) ax_branches <- mapM rnIfaceAxBranch (ifAxBranches d) - return d { ifTyCon = tycon + return d { ifName = name + , ifTyCon = tycon , ifAxBranches = ax_branches } rnIfaceDecl d@IfacePatSyn{} = do + name <- rnIfaceGlobal (ifName d) let rnPat (n, b) = (,) <$> rnIfaceGlobal n <*> pure b pat_matcher <- rnPat (ifPatMatcher d) pat_builder <- T.traverse rnPat (ifPatBuilder d) @@ -398,7 +417,8 @@ rnIfaceDecl d@IfacePatSyn{} = do pat_req_ctxt <- mapM rnIfaceType (ifPatReqCtxt d) pat_args <- mapM rnIfaceType (ifPatArgs d) pat_ty <- rnIfaceType (ifPatTy d) - return d { ifPatMatcher = pat_matcher + return d { ifName = name + , ifPatMatcher = pat_matcher , ifPatBuilder = pat_builder , ifPatUnivBndrs = pat_univ_bndrs , ifPatExBndrs = pat_ex_bndrs @@ -435,23 +455,33 @@ rnIfaceConDecls (IfAbstractTyCon b) = pure (IfAbstractTyCon b) rnIfaceConDecl :: Rename IfaceConDecl rnIfaceConDecl d = do + con_name <- rnIfaceGlobal (ifConName d) 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) + -- TODO: It seems like we really should rename the field labels, but this + -- breaks due to tcIfaceDataCons projecting back to the field's OccName and + -- then looking up it up in the name cache. See #12699. + --con_fields <- mapM rnIfaceGlobal (ifConFields d) let rnIfaceBang (IfUnpackCo co) = IfUnpackCo <$> rnIfaceCo co rnIfaceBang bang = pure bang con_stricts <- mapM rnIfaceBang (ifConStricts d) - return d { ifConExTvs = con_ex_tvs + return d { ifConName = con_name + , ifConExTvs = con_ex_tvs , ifConEqSpec = con_eq_spec , ifConCtxt = con_ctxt , ifConArgTys = con_arg_tys + --, ifConFields = con_fields -- See TODO above , ifConStricts = con_stricts } rnIfaceClassOp :: Rename IfaceClassOp -rnIfaceClassOp (IfaceClassOp n ty dm) = IfaceClassOp n <$> rnIfaceType ty <*> rnMaybeDefMethSpec dm +rnIfaceClassOp (IfaceClassOp n ty dm) = + IfaceClassOp <$> rnIfaceGlobal n + <*> rnIfaceType ty + <*> rnMaybeDefMethSpec dm rnMaybeDefMethSpec :: Rename (Maybe (DefMethSpec IfaceType)) rnMaybeDefMethSpec (Just (GenericDM ty)) = Just . GenericDM <$> rnIfaceType ty diff --git a/compiler/basicTypes/Name.hs b/compiler/basicTypes/Name.hs index bcb4309586..ab44b3e30a 100644 --- a/compiler/basicTypes/Name.hs +++ b/compiler/basicTypes/Name.hs @@ -484,10 +484,13 @@ instance Data Name where ************************************************************************ -} +-- | Assumes that the 'Name' is a non-binding one. See +-- 'IfaceSyn.putIfaceTopBndr' and 'IfaceSyn.getIfaceTopBndr' for serializing +-- binding 'Name's. See 'UserData' for the rationale for this distinction. instance Binary Name where put_ bh name = case getUserData bh of - UserData{ ud_put_name = put_name } -> put_name bh name + UserData{ ud_put_nonbinding_name = put_name } -> put_name bh name get bh = case getUserData bh of diff --git a/compiler/basicTypes/Name.hs-boot b/compiler/basicTypes/Name.hs-boot index 313db26e5c..c4eeca4d68 100644 --- a/compiler/basicTypes/Name.hs-boot +++ b/compiler/basicTypes/Name.hs-boot @@ -1,7 +1,3 @@ module Name where -import {-# SOURCE #-} Module - data Name - -nameModule :: Name -> Module diff --git a/compiler/basicTypes/NameCache.hs b/compiler/basicTypes/NameCache.hs new file mode 100644 index 0000000000..589c7c4e3b --- /dev/null +++ b/compiler/basicTypes/NameCache.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} + +-- | The Name Cache +module NameCache + ( lookupOrigNameCache + , extendOrigNameCache + , extendNameCache + , initNameCache + , NameCache(..), OrigNameCache + ) where + +import Module +import Name +import UniqSupply +import TysWiredIn +import Util +import Outputable +import PrelNames + +#include "HsVersions.h" + +{- + +Note [The Name Cache] +~~~~~~~~~~~~~~~~~~~~~ +The Name Cache makes sure that, during any invocation of GHC, each +External Name "M.x" has one, and only one globally-agreed Unique. + +* The first time we come across M.x we make up a Unique and record that + association in the Name Cache. + +* When we come across "M.x" again, we look it up in the Name Cache, + and get a hit. + +The functions newGlobalBinder, allocateGlobalBinder do the main work. +When you make an External name, you should probably be calling one +of them. + + +Note [Built-in syntax and the OrigNameCache] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Built-in syntax like tuples and unboxed sums are quite ubiquitous. To lower +their cost we use two tricks, + + a. We specially encode tuple and sum Names in interface files' symbol tables + to avoid having to look up their names while loading interface files. + Namely these names are encoded as by their Uniques. We know how to get from + a Unique back to the Name which it represents via the mapping defined in + the SumTupleUniques module. See Note [Symbol table representation of names] + in BinIface and for details. + + b. We don't include them in the Orig name cache but instead parse their + OccNames (in isBuiltInOcc_maybe) to avoid bloating the name cache with + them. + +Why is the second measure necessary? Good question; afterall, 1) the parser +emits built-in syntax directly as Exact RdrNames, and 2) built-in syntax never +needs to looked-up during interface loading due to (a). It turns out that there +are two reasons why we might look up an Orig RdrName for built-in syntax, + + * If you use setRdrNameSpace on an Exact RdrName it may be + turned into an Orig RdrName. + + * Template Haskell turns a BuiltInSyntax Name into a TH.NameG + (DsMeta.globalVar), and parses a NameG into an Orig RdrName + (Convert.thRdrName). So, e.g. $(do { reify '(,); ... }) will + go this route (Trac #8954). + +-} + +-- | Per-module cache of original 'OccName's given 'Name's +type OrigNameCache = ModuleEnv (OccEnv Name) + +lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name +lookupOrigNameCache nc mod occ + | mod == gHC_TYPES || mod == gHC_PRIM || mod == gHC_TUPLE + , Just name <- isBuiltInOcc_maybe occ + = -- See Note [Known-key names], 3(c) in PrelNames + -- Special case for tuples; there are too many + -- of them to pre-populate the original-name cache + Just name + + | otherwise + = case lookupModuleEnv nc mod of + Nothing -> Nothing + Just occ_env -> lookupOccEnv occ_env occ + +extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache +extendOrigNameCache nc name + = ASSERT2( isExternalName name, ppr name ) + extendNameCache nc (nameModule name) (nameOccName name) name + +extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache +extendNameCache nc mod occ name + = extendModuleEnvWith combine nc mod (unitOccEnv occ name) + where + combine _ occ_env = extendOccEnv occ_env occ name + +-- | The NameCache makes sure that there is just one Unique assigned for +-- each original name; i.e. (module-name, occ-name) pair and provides +-- something of a lookup mechanism for those names. +data NameCache + = NameCache { nsUniqs :: !UniqSupply, + -- ^ Supply of uniques + nsNames :: !OrigNameCache + -- ^ Ensures that one original name gets one unique + } + +-- | Return a function to atomically update the name cache. +initNameCache :: UniqSupply -> [Name] -> NameCache +initNameCache us names + = NameCache { nsUniqs = us, + nsNames = initOrigNames names } + +initOrigNames :: [Name] -> OrigNameCache +initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names diff --git a/compiler/basicTypes/Unique.hs b/compiler/basicTypes/Unique.hs index 6db4d8a97c..e24d56b8c7 100644 --- a/compiler/basicTypes/Unique.hs +++ b/compiler/basicTypes/Unique.hs @@ -42,9 +42,6 @@ module Unique ( -- [the Oh-So-Wonderful Haskell module system wins again...] mkAlphaTyVarUnique, mkPrimOpIdUnique, - mkTupleTyConUnique, mkTupleDataConUnique, - mkSumTyConUnique, mkSumDataConUnique, - mkCTupleTyConUnique, mkPreludeMiscIdUnique, mkPreludeDataConUnique, mkPreludeTyConUnique, mkPreludeClassUnique, mkPArrDataConUnique, mkCoVarUnique, @@ -53,13 +50,16 @@ module Unique ( mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique, mkCostCentreUnique, - tyConRepNameUnique, - dataConWorkerUnique, dataConRepNameUnique, - mkBuiltinUnique, mkPseudoUniqueD, mkPseudoUniqueE, - mkPseudoUniqueH + mkPseudoUniqueH, + + -- ** Deriving uniques + -- *** From TyCon name uniques + tyConRepNameUnique, + -- *** From DataCon name uniques + dataConWorkerUnique, dataConRepNameUnique ) where #include "HsVersions.h" @@ -91,6 +91,8 @@ Fast comparison is everything on @Uniques@: -- The type of unique identifiers that are used in many places in GHC -- for fast ordering and equality tests. You should generate these with -- the functions from the 'UniqSupply' module +-- +-- These are sometimes also referred to as \"keys\" in comments in GHC. newtype Unique = MkUnique Int {- @@ -319,18 +321,18 @@ Allocation of unique supply characters: d desugarer f AbsC flattener g SimplStg + k constraint tuple tycons + m constraint tuple datacons n Native codegen r Hsc name cache s simplifier + z anonymous sums -} mkAlphaTyVarUnique :: Int -> Unique mkPreludeClassUnique :: Int -> Unique mkPreludeTyConUnique :: Int -> Unique -mkTupleTyConUnique :: Boxity -> Arity -> Unique -mkCTupleTyConUnique :: Arity -> Unique mkPreludeDataConUnique :: Arity -> Unique -mkTupleDataConUnique :: Boxity -> Arity -> Unique mkPrimOpIdUnique :: Int -> Unique mkPreludeMiscIdUnique :: Int -> Unique mkPArrDataConUnique :: Int -> Unique @@ -345,9 +347,6 @@ mkPreludeClassUnique i = mkUnique '2' i -- * u: the TyCon itself -- * u+1: the TyConRepName of the TyCon mkPreludeTyConUnique i = mkUnique '3' (2*i) -mkTupleTyConUnique Boxed a = mkUnique '4' (2*a) -mkTupleTyConUnique Unboxed a = mkUnique '5' (2*a) -mkCTupleTyConUnique a = mkUnique 'k' (2*a) tyConRepNameUnique :: Unique -> Unique tyConRepNameUnique u = incrUnique u @@ -366,30 +365,6 @@ tyConRepNameUnique u = incrUnique u -- Prelude data constructors are too simple to need wrappers. mkPreludeDataConUnique i = mkUnique '6' (3*i) -- Must be alphabetic -mkTupleDataConUnique Boxed a = mkUnique '7' (3*a) -- ditto (*may* be used in C labels) -mkTupleDataConUnique Unboxed a = mkUnique '8' (3*a) - --------------------------------------------------- --- Sum arities start from 2. The encoding is a bit funny: we break up the --- integral part into bitfields for the arity and alternative index (which is --- taken to be 0xff in the case of the TyCon) --- --- TyCon for sum of arity k: --- 00000000 kkkkkkkk 11111111 --- DataCon for sum of arity k and alternative n: --- 00000000 kkkkkkkk nnnnnnnn - -mkSumTyConUnique :: Arity -> Unique -mkSumTyConUnique arity = - ASSERT(arity < 0xff) - mkUnique 'z' (arity `shiftL` 8 .|. 0xff) - -mkSumDataConUnique :: ConTagZ -> Arity -> Unique -mkSumDataConUnique alt arity - | alt >= arity - = panic ("mkSumDataConUnique: " ++ show alt ++ " >= " ++ show arity) - | otherwise - = mkUnique 'z' (arity `shiftL` 8 + alt) {- skip the tycon -} -------------------------------------------------- dataConRepNameUnique, dataConWorkerUnique :: Unique -> Unique diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index ec02e1b481..721adff0bd 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -198,6 +198,7 @@ Library NameSet OccName RdrName + NameCache SrcLoc UniqSupply Unique @@ -308,6 +309,7 @@ Library HsTypes HsUtils BinIface + BinFingerprint BuildTyCl IfaceEnv IfaceSyn @@ -357,6 +359,7 @@ Library RdrHsSyn ApiAnnotation ForeignCall + KnownUniques PrelInfo PrelNames PrelRules diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 38eae0eee1..91a0277e03 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -434,6 +434,7 @@ compiler_stage2_dll0_MODULES = \ Bag \ BasicTypes \ Binary \ + BinFingerprint \ BooleanFormula \ BufWrite \ Class \ @@ -487,12 +488,14 @@ compiler_stage2_dll0_MODULES = \ HsUtils \ HscTypes \ IOEnv \ + NameCache \ Id \ IdInfo \ IfaceSyn \ IfaceType \ InstEnv \ Kind \ + KnownUniques \ Lexeme \ ListSetOps \ Literal \ diff --git a/compiler/iface/BinFingerprint.hs b/compiler/iface/BinFingerprint.hs new file mode 100644 index 0000000000..bbf45d7d0c --- /dev/null +++ b/compiler/iface/BinFingerprint.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE CPP #-} + +-- | Computing fingerprints of values serializeable with GHC's "Binary" module. +module BinFingerprint + ( -- * Computing fingerprints + fingerprintBinMem + , computeFingerprint + , putNameLiterally + ) where + +#include "HsVersions.h" + +import Fingerprint +import Binary +import Name +import Panic +import Util + +fingerprintBinMem :: BinHandle -> IO Fingerprint +fingerprintBinMem bh = withBinBuffer bh f + where + f bs = + -- we need to take care that we force the result here + -- lest a reference to the ByteString may leak out of + -- withBinBuffer. + let fp = fingerprintByteString bs + in fp `seq` return fp + +computeFingerprint :: (Binary a) + => (BinHandle -> Name -> IO ()) + -> a + -> IO Fingerprint +computeFingerprint put_nonbinding_name a = do + bh <- fmap set_user_data $ openBinMem (3*1024) -- just less than a block + put_ bh a + fp <- fingerprintBinMem bh + return fp + where + set_user_data bh = + setUserData bh $ newWriteState put_nonbinding_name putNameLiterally putFS + +-- | Used when we want to fingerprint a structure without depending on the +-- fingerprints of external Names that it refers to. +putNameLiterally :: BinHandle -> Name -> IO () +putNameLiterally bh name = ASSERT( isExternalName name ) do + put_ bh $! nameModule name + put_ bh $! nameOccName name diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 588909130b..3de647d415 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -21,14 +21,9 @@ module BinIface ( #include "HsVersions.h" import TcRnMonad -import TyCon -import ConLike -import PrelInfo ( knownKeyNames ) -import Id ( idName, isDataConWorkId_maybe ) -import TysWiredIn +import PrelInfo ( isKnownKeyName, lookupKnownKeyName ) import IfaceEnv import HscTypes -import BasicTypes import Module import Name import DynFlags @@ -41,11 +36,11 @@ import ErrUtils import FastMutInt import Unique import Outputable +import NameCache import Platform import FastString import Constants import Util -import DataCon import Data.Bits import Data.Char @@ -204,10 +199,11 @@ writeBinIface dflags hi_path mod_iface = do -- Put the main thing, bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab) + (putName bin_dict bin_symtab) (putFastString bin_dict) put_ bh mod_iface - -- Write the symtab pointer at the fornt of the file + -- Write the symtab pointer at the front of the file symtab_p <- tellBin bh -- This is where the symtab will start putAt bh symtab_p_p symtab_p -- Fill in the placeholder seekBin bh symtab_p -- Seek back to the end of the file @@ -292,65 +288,33 @@ serialiseName bh name _ = do -- Note [Symbol table representation of names] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- --- An occurrence of a name in an interface file is serialized as a single 32-bit word. --- The format of this word is: +-- An occurrence of a name in an interface file is serialized as a single 32-bit +-- word. The format of this word is: -- 00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx -- A normal name. x is an index into the symbol table --- 01xxxxxx xxyyyyyy yyyyyyyy yyyyyyyyyy +-- 10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy -- A known-key name. x is the Unique's Char, y is the int part --- 100xxyyz zzzzzzzz zzzzzzzz zzzzzzzz --- A tuple name: --- x is the tuple sort (00b ==> boxed, 01b ==> unboxed, 10b ==> constraint) --- y is the thing (00b ==> tycon, 01b ==> datacon, 10b ==> datacon worker) --- z is the arity -- --- 10100xxx xxxxxxxx xxxxxxxx xxxxxxxx --- A sum tycon name: --- x is the arity --- 10101xxx xxxxxxxx xxyyyyyy yyyyyyyy --- A sum datacon name: --- x is the arity --- y is the alternative --- 10110xxx xxxxxxxx xxyyyyyy yyyyyyyy --- worker --- 11xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx --- An implicit parameter TyCon name. x is an index into the FastString *dictionary* --- --- Note that we have to have special representation for tuples, sums, and IP --- TyCons because they form an "infinite" family and hence are not recorded --- explicitly in wiredInTyThings or basicKnownKeyNames. +-- During serialization we check for known-key things using isKnownKeyName. +-- During deserialization we use lookupKnownKeyName to get from the unique back +-- to its corresponding Name. -knownKeyNamesMap :: UniqFM Name -knownKeyNamesMap = listToUFM_Directly [(nameUnique n, n) | n <- knownKeyNames] -- See Note [Symbol table representation of names] putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO () putName _dict BinSymbolTable{ bin_symtab_map = symtab_map_ref, - bin_symtab_next = symtab_next } bh name - | name `elemUFM` knownKeyNamesMap + bin_symtab_next = symtab_next } + bh name + | isKnownKeyName name , let (c, u) = unpkUnique (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits = -- ASSERT(u < 2^(22 :: Int)) - put_ bh (0x40000000 .|. (fromIntegral (ord c) `shiftL` 22) .|. (fromIntegral u :: Word32)) + put_ bh (0x80000000 + .|. (fromIntegral (ord c) `shiftL` 22) + .|. (fromIntegral u :: Word32)) + | otherwise - = case wiredInNameTyThing_maybe name of - Just (ATyCon tc) - | Just sort <- tyConTuple_maybe tc -> putTupleName_ bh tc sort 0 - | isUnboxedSumTyCon tc -> putSumTyConName_ bh tc - Just (AConLike (RealDataCon dc)) - | let tc = dataConTyCon dc - , Just sort <- tyConTuple_maybe tc -> putTupleName_ bh tc sort 1 - | isUnboxedSumCon dc -> putSumDataConName_ bh dc - Just (AnId x) - | Just dc <- isDataConWorkId_maybe x - , let tc = dataConTyCon dc - , Just sort <- tyConTuple_maybe tc -> putTupleName_ bh tc sort 2 - Just (AnId x) - | Just dc <- isDataConWorkId_maybe x - , isUnboxedSumCon dc - -> putSumWorkerId_ bh dc - _ -> do - symtab_map <- readIORef symtab_map_ref + = do symtab_map <- readIORef symtab_map_ref case lookupUFM symtab_map name of Just (off,_) -> put_ bh (fromIntegral off :: Word32) Nothing -> do @@ -361,41 +325,6 @@ putName _dict BinSymbolTable{ $! addToUFM symtab_map name (off,name) put_ bh (fromIntegral off :: Word32) -putTupleName_ :: BinHandle -> TyCon -> TupleSort -> Word32 -> IO () -putTupleName_ bh tc tup_sort thing_tag - = ASSERT(arity < 2^(25 :: Int)) - put_ bh (0x80000000 .|. (sort_tag `shiftL` 27) .|. (thing_tag `shiftL` 25) .|. arity) - where - (sort_tag, arity) = case tup_sort of - BoxedTuple -> (0, fromIntegral (tyConArity tc)) - UnboxedTuple -> (1, fromIntegral (tyConArity tc `div` 2)) - -- See Note [Unboxed tuple RuntimeRep vars] in TyCon - ConstraintTuple -> pprPanic "putTupleName:ConstraintTuple" (ppr tc) - -putSumTyConName_ :: BinHandle -> TyCon -> IO () -putSumTyConName_ bh tc - = ASSERT(arity < 2^(27 :: Int)) - put_ bh (0xA0000000 .|. arity) - where - arity = (fromIntegral (tyConArity tc) `div` 2) :: Word32 - -putSumDataConName_ :: BinHandle -> DataCon -> IO () -putSumDataConName_ bh dc - = ASSERT(arity < 2^(13 :: Int) && alt < 2^(14 :: Int)) - put_ bh (0xA8000000 .|. (arity `shiftL` 14) .|. alt) - where - tc = dataConTyCon dc - alt = fromIntegral (dataConTag dc) - arity = (fromIntegral (tyConArity tc) `div` 2) :: Word32 - -putSumWorkerId_ :: BinHandle -> DataCon -> IO () -putSumWorkerId_ bh dc - = put_ bh (0xB0000000 .|. (arity `shiftL` 14) .|. alt) - where - tc = dataConTyCon dc - alt = fromIntegral (dataConTag dc) - arity = (fromIntegral (tyConArity tc) `div` 2) :: Word32 - -- See Note [Symbol table representation of names] getSymtabName :: NameCacheUpdater -> Dictionary -> SymbolTable @@ -405,58 +334,17 @@ getSymtabName _ncu _dict symtab bh = do case i .&. 0xC0000000 of 0x00000000 -> return $! symtab ! fromIntegral i - 0x40000000 -> + 0x80000000 -> let tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22)) ix = fromIntegral i .&. 0x003FFFFF + u = mkUnique tag ix in - return $! case lookupUFM_Directly knownKeyNamesMap (mkUnique tag ix) of - Nothing -> pprPanic "getSymtabName:unknown known-key unique" (ppr i) + return $! case lookupKnownKeyName u of + Nothing -> pprPanic "getSymtabName:unknown known-key unique" + (ppr i $$ ppr (unpkUnique u)) Just n -> n - 0x80000000 -> - case i .&. 0x20000000 of - 0x00000000 -> - let - dc = tupleDataCon sort arity - sort = case (i .&. 0x18000000) `shiftR` 27 of - 0 -> Boxed - 1 -> Unboxed - _ -> pprPanic "getSymtabName:unknown tuple sort" (ppr i) - arity = fromIntegral (i .&. 0x01FFFFFF) - in - return $! case ( (i .&. 0x06FFFFFF) `shiftR` 25 ) of - 0 -> tyConName (tupleTyCon sort arity) - 1 -> dataConName dc - 2 -> idName (dataConWorkId dc) - _ -> pprPanic "getSymtabName:unknown tuple thing" (ppr i) - - 0x20000000 -> - return $! case ((i .&. 0x18000000) `shiftR` 27) of - 0 -> tyConName $ sumTyCon ( fromIntegral (i .&. 0x7ffffff) ) - 1 -> let - alt = - -- first (least significant) 14 bits - fromIntegral (i .&. 0b11111111111111) - arity = - -- next 13 bits - fromIntegral ((i `shiftR` 14) .&. 0b1111111111111) - in - ASSERT( arity >= alt ) - dataConName (sumDataCon alt arity) - 2 -> let - alt = - -- first (least significant) 14 bits - fromIntegral (i .&. 0b11111111111111) - arity = - -- next 13 bits - fromIntegral ((i `shiftR` 14) .&. 0b1111111111111) - in - ASSERT( arity >= alt ) - idName (dataConWorkId (sumDataCon alt arity)) - - _ -> pprPanic "getSymtabName:unknown sum sort" (ppr i) - _ -> pprPanic "getSyntabName:unknown `tuple or sum` tag" (ppr i) _ -> pprPanic "getSymtabName:unknown name tag" (ppr i) data BinSymbolTable = BinSymbolTable { diff --git a/compiler/iface/FlagChecker.hs b/compiler/iface/FlagChecker.hs index b3f3758746..10cfae6eeb 100644 --- a/compiler/iface/FlagChecker.hs +++ b/compiler/iface/FlagChecker.hs @@ -13,6 +13,7 @@ import HscTypes import Module import Name import Fingerprint +import BinFingerprint -- import Outputable import qualified Data.IntSet as IntSet @@ -21,7 +22,8 @@ import System.FilePath (normalise) -- | Produce a fingerprint of a @DynFlags@ value. We only base -- the finger print on important fields in @DynFlags@ so that -- the recompilation checker can use this fingerprint. -fingerprintDynFlags :: DynFlags -> Module -> (BinHandle -> Name -> IO ()) +fingerprintDynFlags :: DynFlags -> Module + -> (BinHandle -> Name -> IO ()) -> IO Fingerprint fingerprintDynFlags dflags@DynFlags{..} this_mod nameio = diff --git a/compiler/iface/IfaceEnv.hs b/compiler/iface/IfaceEnv.hs index 96bd36ff33..46bc0e9905 100644 --- a/compiler/iface/IfaceEnv.hs +++ b/compiler/iface/IfaceEnv.hs @@ -16,15 +16,13 @@ module IfaceEnv ( ifaceExportNames, -- Name-cache stuff - allocateGlobalBinder, - initNameCache, updNameCache, - mkNameCacheUpdater, NameCacheUpdater(..) + allocateGlobalBinder, updNameCache, + mkNameCacheUpdater, NameCacheUpdater(..), ) where #include "HsVersions.h" import TcRnMonad -import TysWiredIn import HscTypes import Type import Var @@ -34,10 +32,9 @@ import Module import FastString import FastStringEnv import IfaceType -import PrelNames ( gHC_TYPES, gHC_PRIM, gHC_TUPLE ) +import NameCache import UniqSupply import SrcLoc -import Util import Outputable import Data.List ( partition ) @@ -49,20 +46,7 @@ import Data.List ( partition ) * * ********************************************************* -Note [The Name Cache] -~~~~~~~~~~~~~~~~~~~~~ -The Name Cache makes sure that, during any invocation of GHC, each -External Name "M.x" has one, and only one globally-agreed Unique. - -* The first time we come across M.x we make up a Unique and record that - association in the Name Cache. - -* When we come across "M.x" again, we look it up in the Name Cache, - and get a hit. - -The functions newGlobalBinder, allocateGlobalBinder do the main work. -When you make an External name, you should probably be calling one -of them. +See Also: Note [The Name Cache] in NameCache -} newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name @@ -136,6 +120,28 @@ allocateGlobalBinder name_supply mod occ loc ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo] ifaceExportNames exports = return exports +-- | A function that atomically updates the name cache given a modifier +-- function. The second result of the modifier function will be the result +-- of the IO action. +newtype NameCacheUpdater + = NCU { updateNameCache :: forall c. (NameCache -> (NameCache, c)) -> IO c } + +mkNameCacheUpdater :: TcRnIf a b NameCacheUpdater +mkNameCacheUpdater = do { hsc_env <- getTopEnv + ; return (NCU (updNameCacheIO hsc_env)) } + +updNameCache :: (NameCache -> (NameCache, c)) -> TcRnIf a b c +updNameCache upd_fn = do { hsc_env <- getTopEnv + ; liftIO $ updNameCacheIO hsc_env upd_fn } + +{- +************************************************************************ +* * + Name cache access +* * +************************************************************************ +-} + -- | Look up the 'Name' for a given 'Module' and 'OccName'. -- Consider alternately using 'lookupIfaceTop' if you're in the 'IfL' monad -- and 'Module' is simply that of the 'ModIface' you are typechecking. @@ -148,7 +154,7 @@ lookupOrig mod occ -- which does some stuff that modifies the name cache -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..) mod `seq` occ `seq` return () --- ; traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ) + ; traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ) ; updNameCache $ \name_cache -> case lookupOrigNameCache (nsNames name_cache) mod occ of { @@ -184,92 +190,6 @@ setNameModule (Just m) n = {- ************************************************************************ * * - Name cache access -* * -************************************************************************ - -See Note [The Name Cache] above. - -Note [Built-in syntax and the OrigNameCache] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Built-in syntax like tuples and unboxed sums are quite ubiquitous. To lower -their cost we use two tricks, - - b. We specially encode tuple Names in interface files' symbols tables to avoid - having to look up their names at all while loading interface files. See - Note [Symbol table representation of names] in BinIface for details. - - a. We don't include them in the Orig name cache but instead parse their - OccNames (in isBuiltInOcc_maybe) to avoid bloating the name cache with - them. - -Why is the second measure necessary? Good question; afterall, 1) the parser -emits built-in syntax directly as Exact RdrNames, and 2) built-in syntax never -needs to looked-up during interface loading due to (a). It turns out that there -are two reasons why we might look up an Orig RdrName for built-in syntax, - - * If you use setRdrNameSpace on an Exact RdrName it may be - turned into an Orig RdrName. - - * Template Haskell turns a BuiltInSyntax Name into a TH.NameG - (DsMeta.globalVar), and parses a NameG into an Orig RdrName - (Convert.thRdrName). So, e.g. $(do { reify '(,); ... }) will - go this route (Trac #8954). - --} - -lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name -lookupOrigNameCache nc mod occ - | mod == gHC_TYPES || mod == gHC_PRIM || mod == gHC_TUPLE - , Just name <- isBuiltInOcc_maybe occ - = -- See Note [Known-key names], 3(c) in PrelNames - -- Special case for tuples; there are too many - -- of them to pre-populate the original-name cache - Just name - - | otherwise - = case lookupModuleEnv nc mod of - Nothing -> Nothing - Just occ_env -> lookupOccEnv occ_env occ - -extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache -extendOrigNameCache nc name - = ASSERT2( isExternalName name, ppr name ) - extendNameCache nc (nameModule name) (nameOccName name) name - -extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache -extendNameCache nc mod occ name - = extendModuleEnvWith combine nc mod (unitOccEnv occ name) - where - combine _ occ_env = extendOccEnv occ_env occ name - -updNameCache :: (NameCache -> (NameCache, c)) -> TcRnIf a b c -updNameCache upd_fn = do { hsc_env <- getTopEnv - ; liftIO $ updNameCacheIO hsc_env upd_fn } - --- | A function that atomically updates the name cache given a modifier --- function. The second result of the modifier function will be the result --- of the IO action. -newtype NameCacheUpdater - = NCU { updateNameCache :: forall c. (NameCache -> (NameCache, c)) -> IO c } - --- | Return a function to atomically update the name cache. -mkNameCacheUpdater :: TcRnIf a b NameCacheUpdater -mkNameCacheUpdater = do { hsc_env <- getTopEnv - ; return (NCU (updNameCacheIO hsc_env)) } - -initNameCache :: UniqSupply -> [Name] -> NameCache -initNameCache us names - = NameCache { nsUniqs = us, - nsNames = initOrigNames names } - -initOrigNames :: [Name] -> OrigNameCache -initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names - -{- -************************************************************************ -* * Type variables and local Ids * * ************************************************************************ @@ -335,27 +255,10 @@ extendIfaceEnvs tcvs thing_inside ************************************************************************ -} +-- | Look up a top-level name from the current Iface module lookupIfaceTop :: OccName -> IfL Name --- Look up a top-level name from the current Iface module -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 +lookupIfaceTop occ + = do { env <- getLclEnv; lookupOrig (if_mod env) occ } newIfaceName :: OccName -> IfL Name newIfaceName occ diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs index 8a45dd55be..81d905de0b 100644 --- a/compiler/iface/IfaceSyn.hs +++ b/compiler/iface/IfaceSyn.hs @@ -20,6 +20,10 @@ module IfaceSyn ( IfaceAxBranch(..), IfaceTyConParent(..), + -- * Binding names + IfaceTopBndr, + putIfaceTopBndr, getIfaceTopBndr, + -- Misc ifaceDeclImplicitBndrs, visibleIfConDecls, ifaceConDeclFields, @@ -37,6 +41,7 @@ module IfaceSyn ( #include "HsVersions.h" import IfaceType +import BinFingerprint import CoreSyn( IsOrphan ) import PprCore() -- Printing DFunArgs import Demand @@ -78,15 +83,29 @@ infixl 3 &&& ************************************************************************ -} -type IfaceTopBndr = OccName - -- It's convenient to have an OccName in the IfaceSyn, although in each +-- | A binding top-level 'Name' in an interface file (e.g. the name of an +-- 'IfaceDecl'). +type IfaceTopBndr = Name + -- It's convenient to have an Name in the IfaceSyn, although in each -- case the namespace is implied by the context. However, having an - -- OccNames makes things like ifaceDeclImplicitBndrs and ifaceDeclFingerprints - -- very convenient. + -- Name makes things like ifaceDeclImplicitBndrs and ifaceDeclFingerprints + -- very convenient. Moreover, having the key of the binder means that + -- we can encode known-key things cleverly in the symbol table. See Note + -- [Symbol table representation of Names] -- -- We don't serialise the namespace onto the disk though; rather we -- drop it when serialising and add it back in when deserialising. +getIfaceTopBndr :: BinHandle -> IO IfaceTopBndr +getIfaceTopBndr bh = get bh + +putIfaceTopBndr :: BinHandle -> IfaceTopBndr -> IO () +putIfaceTopBndr bh name = + case getUserData bh of + UserData{ ud_put_binding_name = put_binding_name } -> + --pprTrace "putIfaceTopBndr" (ppr name) $ + put_binding_name bh name + data IfaceDecl = IfaceId { ifName :: IfaceTopBndr, ifType :: IfaceType, @@ -202,7 +221,7 @@ data IfaceConDecls data IfaceConDecl = IfCon { - ifConOcc :: IfaceTopBndr, -- Constructor name + ifConName :: IfaceTopBndr, -- Constructor name ifConWrapper :: Bool, -- True <=> has a wrapper ifConInfix :: Bool, -- True <=> declared infix @@ -350,7 +369,8 @@ ifaceConDeclFields x = case x of IfDataTyCon cons is_over labels -> map (help cons is_over) labels IfNewTyCon con is_over labels -> map (help [con] is_over) labels where - help (dc:_) is_over lbl = mkFieldLabelOccs lbl (ifConOcc dc) is_over + help (dc:_) is_over lbl = + mkFieldLabelOccs lbl (occName $ ifConName dc) is_over help [] _ _ = error "ifaceConDeclFields: data type has no constructors!" ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName] @@ -365,14 +385,16 @@ ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName] -- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop]) -- The order of the list does not matter. -ifaceDeclImplicitBndrs (IfaceData {ifName = tc_occ, ifCons = cons }) +ifaceDeclImplicitBndrs (IfaceData {ifName = tc_name, ifCons = cons }) = case cons of IfAbstractTyCon {} -> [] - IfNewTyCon cd _ _ -> mkNewTyCoOcc tc_occ : ifaceConDeclImplicitBndrs cd + IfNewTyCon cd _ _ -> mkNewTyCoOcc (occName tc_name) : ifaceConDeclImplicitBndrs cd IfDataTyCon cds _ _ -> concatMap ifaceConDeclImplicitBndrs cds -ifaceDeclImplicitBndrs (IfaceClass { ifCtxt = sc_ctxt, ifName = cls_tc_occ - , ifSigs = sigs, ifATs = ats }) +ifaceDeclImplicitBndrs (IfaceClass { ifCtxt = sc_ctxt + , ifName = cls_tc_name + , ifSigs = sigs + , ifATs = ats }) = -- (possibly) newtype coercion co_occs ++ -- data constructor (DataCon namespace) @@ -380,12 +402,13 @@ ifaceDeclImplicitBndrs (IfaceClass { ifCtxt = sc_ctxt, ifName = cls_tc_occ -- no wrapper (class dictionaries never have a wrapper) [dc_occ, dcww_occ] ++ -- associated types - [ifName at | IfaceAT at _ <- ats ] ++ + [occName (ifName at) | IfaceAT at _ <- ats ] ++ -- superclass selectors [mkSuperDictSelOcc n cls_tc_occ | n <- [1..n_ctxt]] ++ -- operation selectors - [op | IfaceClassOp op _ _ <- sigs] + [occName op | IfaceClassOp op _ _ <- sigs] where + cls_tc_occ = occName cls_tc_name n_ctxt = length sc_ctxt n_sigs = length sigs co_occs | is_newtype = [mkNewTyCoOcc cls_tc_occ] @@ -397,9 +420,10 @@ ifaceDeclImplicitBndrs (IfaceClass { ifCtxt = sc_ctxt, ifName = cls_tc_occ ifaceDeclImplicitBndrs _ = [] ifaceConDeclImplicitBndrs :: IfaceConDecl -> [OccName] -ifaceConDeclImplicitBndrs (IfCon { ifConWrapper = has_wrapper, ifConOcc = con_occ }) - = [con_occ, work_occ] ++ wrap_occs +ifaceConDeclImplicitBndrs (IfCon { ifConWrapper = has_wrapper, ifConName = con_name }) + = [occName con_name, work_occ] ++ wrap_occs where + con_occ = occName con_name work_occ = mkDataConWorkerOcc con_occ -- Id namespace wrap_occs | has_wrapper = [mkDataConWrapperOcc con_occ] -- Id namespace | otherwise = [] @@ -413,7 +437,7 @@ ifaceConDeclImplicitBndrs (IfCon { ifConWrapper = has_wrapper, ifConOcc = con_oc -- declaration with the name of the binder. (#5614, #7215) ifaceDeclFingerprints :: Fingerprint -> IfaceDecl -> [(OccName,Fingerprint)] ifaceDeclFingerprints hash decl - = (ifName decl, hash) : + = (getOccName decl, hash) : [ (occ, computeFingerprint' (hash,occ)) | occ <- ifaceDeclImplicitBndrs decl ] where @@ -527,14 +551,23 @@ pprAxBranch pp_tc (IfaceAxBranch { ifaxbTyVars = tvs instance Outputable IfaceAnnotation where ppr (IfaceAnnotation target value) = ppr target <+> colon <+> ppr value +instance NamedThing IfaceClassOp where + getName (IfaceClassOp n _ _) = n + instance HasOccName IfaceClassOp where - occName (IfaceClassOp n _ _) = n + occName = getOccName + +instance NamedThing IfaceConDecl where + getName = ifConName instance HasOccName IfaceConDecl where - occName = ifConOcc + occName = getOccName + +instance NamedThing IfaceDecl where + getName = ifName instance HasOccName IfaceDecl where - occName = ifName + occName = getOccName instance Outputable IfaceDecl where ppr = pprIfaceDecl showAll @@ -548,6 +581,7 @@ filtering of method signatures. Instead we just check if anything at all is filtered and hide it in that case. -} +-- TODO: Kill this and Note [Printing IfaceDecl binders] data ShowSub = ShowSub { ss_ppr_bndr :: OccName -> SDoc -- Pretty-printer for binders in IfaceDecl @@ -647,7 +681,7 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype, pp_roles | is_data_instance = empty | otherwise = pprRoles (== Representational) - (pprPrefixIfDeclBndr ss tycon) + (pprPrefixIfDeclBndr ss (occName tycon)) binders roles -- Don't display roles for data family instances (yet) -- See discussion on Trac #8672. @@ -675,7 +709,7 @@ pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs , ifRoles = roles , ifFDs = fds, ifMinDef = minDef , ifBinders = binders }) - = vcat [ pprRoles (== Nominal) (pprPrefixIfDeclBndr ss clas) binders roles + = vcat [ pprRoles (== Nominal) (pprPrefixIfDeclBndr ss (occName clas)) binders roles , text "class" <+> pprIfaceDeclHead context ss clas binders Nothing <+> pprFundeps fds <+> pp_where , nest 2 (vcat [ vcat asocs, vcat dsigs @@ -749,7 +783,7 @@ pprIfaceDecl ss (IfaceFamily { ifName = tycon pp_branches (IfaceClosedSynFamilyTyCon (Just (ax, brs))) = hang (text "where") - 2 (vcat (map (pprAxBranch (pprPrefixIfDeclBndr ss tycon)) brs) + 2 (vcat (map (pprAxBranch (pprPrefixIfDeclBndr ss (occName tycon))) brs) $$ ppShowIface ss (text "axiom" <+> ppr ax)) pp_branches _ = Outputable.empty @@ -775,7 +809,7 @@ pprIfaceDecl _ (IfacePatSyn { ifName = name, pprIfaceDecl ss (IfaceId { ifName = var, ifType = ty, ifIdDetails = details, ifIdInfo = info }) - = vcat [ hang (pprPrefixIfDeclBndr ss var <+> dcolon) + = vcat [ hang (pprPrefixIfDeclBndr ss (occName var) <+> dcolon) 2 (pprIfaceSigmaType ty) , ppShowIface ss (ppr details) , ppShowIface ss (ppr info) ] @@ -801,10 +835,10 @@ pprRoles suppress_if tyCon bndrs roles text "type role" <+> tyCon <+> hsep (map ppr froles) pprInfixIfDeclBndr, pprPrefixIfDeclBndr :: ShowSub -> OccName -> SDoc -pprInfixIfDeclBndr (ShowSub { ss_ppr_bndr = ppr_bndr }) occ - = pprInfixVar (isSymOcc occ) (ppr_bndr occ) -pprPrefixIfDeclBndr (ShowSub { ss_ppr_bndr = ppr_bndr }) occ - = parenSymOcc occ (ppr_bndr occ) +pprInfixIfDeclBndr (ShowSub { ss_ppr_bndr = ppr_bndr }) name + = pprInfixVar (isSymOcc name) (ppr_bndr name) +pprPrefixIfDeclBndr (ShowSub { ss_ppr_bndr = ppr_bndr }) name + = parenSymOcc name (ppr_bndr name) instance Outputable IfaceClassOp where ppr = pprIfaceClassOp showAll @@ -817,7 +851,7 @@ pprIfaceClassOp ss (IfaceClassOp n ty dm) = text "default" <+> pp_sig n dm_ty | otherwise = empty - pp_sig n ty = pprPrefixIfDeclBndr ss n <+> dcolon <+> pprIfaceSigmaType ty + pp_sig n ty = pprPrefixIfDeclBndr ss (occName n) <+> dcolon <+> pprIfaceSigmaType ty instance Outputable IfaceAT where ppr = pprIfaceAT showAll @@ -841,14 +875,14 @@ pprIfaceTyConParent (IfDataInstance _ tc tys) let ftys = stripInvisArgs dflags tys in pprIfaceTypeApp tc ftys -pprIfaceDeclHead :: IfaceContext -> ShowSub -> OccName +pprIfaceDeclHead :: IfaceContext -> ShowSub -> Name -> [IfaceTyConBinder] -- of the tycon, for invisible-suppression -> Maybe IfaceKind -> SDoc pprIfaceDeclHead context ss tc_occ bndrs m_res_kind = sdocWithDynFlags $ \ dflags -> sep [ pprIfaceContextArr context - , pprPrefixIfDeclBndr ss tc_occ + , pprPrefixIfDeclBndr ss (occName tc_occ) <+> pprIfaceTyConBinders (suppressIfaceInvisibles dflags bndrs bndrs) , maybe empty (\res_kind -> dcolon <+> pprIfaceType res_kind) m_res_kind ] @@ -865,19 +899,19 @@ pprIfaceConDecl :: ShowSub -> Bool -> IfaceTyConParent -> IfaceConDecl -> SDoc pprIfaceConDecl ss gadt_style fls tycon tc_binders parent - (IfCon { ifConOcc = name, ifConInfix = is_infix, + (IfCon { ifConName = name, ifConInfix = is_infix, ifConExTvs = ex_tvs, ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys, ifConStricts = stricts, ifConFields = fields }) | gadt_style = pp_prefix_con <+> dcolon <+> ppr_ty | not (null fields) = pp_prefix_con <+> pp_field_args | is_infix - , [ty1, ty2] <- pp_args = sep [ty1, pprInfixIfDeclBndr ss name, ty2] + , [ty1, ty2] <- pp_args = sep [ty1, pprInfixIfDeclBndr ss (occName name), ty2] | otherwise = pp_prefix_con <+> sep pp_args where tys_w_strs :: [(IfaceBang, IfaceType)] tys_w_strs = zip stricts arg_tys - pp_prefix_con = pprPrefixIfDeclBndr ss name + pp_prefix_con = pprPrefixIfDeclBndr ss (occName name) (univ_tvs, pp_res_ty) = mk_user_con_res_ty eq_spec ppr_ty = pprIfaceForAllPart (map tv_to_forall_bndr univ_tvs ++ ex_tvs) @@ -906,16 +940,18 @@ pprIfaceConDecl ss gadt_style fls tycon tc_binders parent pp_field_args :: SDoc -- Braces form: { x :: !Maybe a, y :: Int } pp_field_args = braces $ sep $ punctuate comma $ ppr_trim $ - map maybe_show_label (zip fields tys_w_strs) + zipWith maybe_show_label fields tys_w_strs - maybe_show_label (sel,bty) + maybe_show_label :: IfaceTopBndr -> (IfaceBang, IfaceType) -> Maybe SDoc + maybe_show_label sel bty | showSub ss sel = Just (pprPrefixIfDeclBndr ss lbl <+> dcolon <+> pprBangTy bty) | otherwise = Nothing where -- IfaceConDecl contains the name of the selector function, so -- we have to look up the field label (in case -- DuplicateRecordFields was used for the definition) - lbl = maybe sel (mkVarOccFS . flLabel) $ find (\ fl -> flSelector fl == sel) fls + lbl = maybe (occName sel) (mkVarOccFS . flLabel) + $ find (\ fl -> flSelector fl == occName sel) fls mk_user_con_res_ty :: IfaceEqSpec -> ([IfaceTvBndr], SDoc) -- See Note [Result type of a data family GADT] @@ -930,7 +966,7 @@ pprIfaceConDecl ss gadt_style fls tycon tc_binders parent con_univ_tvs = filterOut done_univ_tv (map ifTyConBinderTyVar tc_binders) ppr_tc_app gadt_subst dflags - = pprPrefixIfDeclBndr ss tycon + = pprPrefixIfDeclBndr ss (occName tycon) <+> sep [ pprParendIfaceType (substIfaceTyVar gadt_subst tv) | (tv,_kind) <- map ifTyConBinderTyVar $ @@ -1434,19 +1470,26 @@ to take account of the use of the data constructor PS in the pattern match. Binary instances * * ************************************************************************ + +Note that there is a bit of subtlety here when we encode names. While +IfaceTopBndrs is really just a synonym for Name, we need to take care to +encode them with {get,put}IfaceTopBndr. The difference becomes important when +we go to fingerprint an IfaceDecl. See Note [Fingerprinting IfaceDecls] for +details. + -} instance Binary IfaceDecl where put_ bh (IfaceId name ty details idinfo) = do putByte bh 0 - put_ bh (occNameFS name) + putIfaceTopBndr bh name put_ bh ty put_ bh details put_ bh idinfo put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) = do putByte bh 2 - put_ bh (occNameFS a1) + putIfaceTopBndr bh a1 put_ bh a2 put_ bh a3 put_ bh a4 @@ -1458,7 +1501,7 @@ instance Binary IfaceDecl where put_ bh (IfaceSynonym a1 a2 a3 a4 a5) = do putByte bh 3 - put_ bh (occNameFS a1) + putIfaceTopBndr bh a1 put_ bh a2 put_ bh a3 put_ bh a4 @@ -1466,7 +1509,7 @@ instance Binary IfaceDecl where put_ bh (IfaceFamily a1 a2 a3 a4 a5 a6) = do putByte bh 4 - put_ bh (occNameFS a1) + putIfaceTopBndr bh a1 put_ bh a2 put_ bh a3 put_ bh a4 @@ -1476,7 +1519,7 @@ instance Binary IfaceDecl where put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7 a8) = do putByte bh 5 put_ bh a1 - put_ bh (occNameFS a2) + putIfaceTopBndr bh a2 put_ bh a3 put_ bh a4 put_ bh a5 @@ -1486,14 +1529,14 @@ instance Binary IfaceDecl where put_ bh (IfaceAxiom a1 a2 a3 a4) = do putByte bh 6 - put_ bh (occNameFS a1) + putIfaceTopBndr bh a1 put_ bh a2 put_ bh a3 put_ bh a4 - put_ bh (IfacePatSyn name a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do + put_ bh (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do putByte bh 7 - put_ bh (occNameFS name) + putIfaceTopBndr bh a1 put_ bh a2 put_ bh a3 put_ bh a4 @@ -1512,10 +1555,9 @@ instance Binary IfaceDecl where ty <- get bh details <- get bh idinfo <- get bh - occ <- return $! mkVarOccFS name - return (IfaceId occ ty details idinfo) + return (IfaceId name ty details idinfo) 1 -> error "Binary.get(TyClDecl): ForeignType" - 2 -> do a1 <- get bh + 2 -> do a1 <- getIfaceTopBndr bh a2 <- get bh a3 <- get bh a4 <- get bh @@ -1524,40 +1566,35 @@ instance Binary IfaceDecl where a7 <- get bh a8 <- get bh a9 <- get bh - occ <- return $! mkTcOccFS a1 - return (IfaceData occ a2 a3 a4 a5 a6 a7 a8 a9) - 3 -> do a1 <- get bh + return (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) + 3 -> do a1 <- getIfaceTopBndr bh a2 <- get bh a3 <- get bh a4 <- get bh a5 <- get bh - occ <- return $! mkTcOccFS a1 - return (IfaceSynonym occ a2 a3 a4 a5) - 4 -> do a1 <- get bh + return (IfaceSynonym a1 a2 a3 a4 a5) + 4 -> do a1 <- getIfaceTopBndr bh a2 <- get bh a3 <- get bh a4 <- get bh a5 <- get bh a6 <- get bh - occ <- return $! mkTcOccFS a1 - return (IfaceFamily occ a2 a3 a4 a5 a6) + return (IfaceFamily a1 a2 a3 a4 a5 a6) 5 -> do a1 <- get bh - a2 <- get bh + a2 <- getIfaceTopBndr bh a3 <- get bh a4 <- get bh a5 <- get bh a6 <- get bh a7 <- get bh a8 <- get bh - occ <- return $! mkClsOccFS a2 - return (IfaceClass a1 occ a3 a4 a5 a6 a7 a8) - 6 -> do a1 <- get bh + return (IfaceClass a1 a2 a3 a4 a5 a6 a7 a8) + 6 -> do a1 <- getIfaceTopBndr bh a2 <- get bh a3 <- get bh a4 <- get bh - occ <- return $! mkTcOccFS a1 - return (IfaceAxiom occ a2 a3 a4) - 7 -> do a1 <- get bh + return (IfaceAxiom a1 a2 a3 a4) + 7 -> do a1 <- getIfaceTopBndr bh a2 <- get bh a3 <- get bh a4 <- get bh @@ -1568,8 +1605,7 @@ instance Binary IfaceDecl where a9 <- get bh a10 <- get bh a11 <- get bh - occ <- return $! mkDataOccFS a1 - return (IfacePatSyn occ a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) + return (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) _ -> panic (unwords ["Unknown IfaceDecl tag:", show h]) instance Binary IfaceFamTyConFlav where @@ -1592,15 +1628,14 @@ instance Binary IfaceFamTyConFlav where instance Binary IfaceClassOp where put_ bh (IfaceClassOp n ty def) = do - put_ bh (occNameFS n) + putIfaceTopBndr bh n put_ bh ty put_ bh def get bh = do - n <- get bh + n <- getIfaceTopBndr bh ty <- get bh def <- get bh - occ <- return $! mkVarOccFS n - return (IfaceClassOp occ ty def) + return (IfaceClassOp n ty def) instance Binary IfaceAT where put_ bh (IfaceAT dec defs) = do @@ -1642,25 +1677,27 @@ instance Binary IfaceConDecls where instance Binary IfaceConDecl where put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do - put_ bh a1 + putIfaceTopBndr bh a1 put_ bh a2 put_ bh a3 put_ bh a4 put_ bh a5 put_ bh a6 put_ bh a7 - put_ bh a8 + put_ bh (length a8) + mapM_ (putIfaceTopBndr bh) a8 put_ bh a9 put_ bh a10 get bh = do - a1 <- get bh + a1 <- getIfaceTopBndr bh a2 <- get bh a3 <- get bh a4 <- get bh a5 <- get bh a6 <- get bh a7 <- get bh - a8 <- get bh + n_fields <- get bh + a8 <- replicateM n_fields (getIfaceTopBndr bh) a9 <- get bh a10 <- get bh return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs index 97f288f7ba..48bc316d0a 100644 --- a/compiler/iface/LoadIface.hs +++ b/compiler/iface/LoadIface.hs @@ -141,8 +141,10 @@ importDecl name -- Now look it up again; this time we should find it { eps <- getEps ; case lookupTypeEnv (eps_PTE eps) name of - Just thing -> return (Succeeded thing) - Nothing -> return $ Failed (ifPprDebug (found_things_msg eps) $$ not_found_msg) + Just thing -> return $ Succeeded thing + Nothing -> let doc = ifPprDebug (found_things_msg eps $$ empty) + $$ not_found_msg + in return $ Failed doc }}} where nd_doc = text "Need decl for" <+> ppr name @@ -653,7 +655,7 @@ loadDecl :: Bool -- Don't load pragmas into the decl pool loadDecl ignore_prags (_version, decl) = do { -- Populate the name cache with final versions of all -- the names associated with the decl - main_name <- lookupIfaceTop (ifName decl) + let main_name = ifName decl -- Typecheck the thing, lazily -- NB. Firstly, the laziness is there in case we never need the diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index 0c2c8a4831..12980e4524 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -59,6 +59,7 @@ Basic idea: #include "HsVersions.h" import IfaceSyn +import BinFingerprint import LoadIface import FlagChecker @@ -390,6 +391,32 @@ mkHashFun hsc_env eps name -- --------------------------------------------------------------------------- -- Compute fingerprints for the interface +{- +Note [Fingerprinting IfaceDecls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The general idea here is that we first examine the 'IfaceDecl's and determine +the recursive groups of them. We then walk these groups in dependency order, +serializing each contained 'IfaceDecl' to a "Binary" buffer which we then +hash using MD5 to produce a fingerprint for the group. + +However, the serialization that we use is a bit funny: we override the @putName@ +operation with our own which serializes the hash of a 'Name' instead of the +'Name' itself. This ensures that the fingerprint of a decl changes if anything +in its transitive closure changes. This trick is why we must be careful about +traversing in dependency order: we need to ensure that we have hashes for +everything referenced by the decl which we are fingerprinting. + +Moreover, we need to be careful to distinguish between serialization of binding +Names (e.g. the ifName field of a IfaceDecl) and non-binding (e.g. the ifInstCls +field of a IfaceClsInst): only in the non-binding case should we include the +fingerprint; in the binding case we shouldn't since it is merely the name of the +thing that we are currently fingerprinting. +-} + +-- | Add fingerprints for top-level declarations to a 'ModIface'. +-- +-- See Note [Fingerprinting IfaceDecls] addFingerprints :: HscEnv -> Maybe Fingerprint -- the old fingerprint, if any @@ -414,14 +441,15 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls non_orph_fis decl edges :: [(IfaceDeclABI, Unique, [Unique])] - edges = [ (abi, getUnique (ifName decl), out) + edges = [ (abi, getUnique (getOccName decl), out) | decl <- new_decls , let abi = declABI decl , let out = localOccs $ freeNamesDeclABI abi ] name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n - localOccs = map (getUnique . getParent . getOccName) + localOccs = + map (getUnique . getParent . getOccName) -- NB: names always use semantic module, so -- filtering must be on the semantic module! -- See Note [Identity versus semantic module] @@ -432,7 +460,8 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- stronglyConnCompFromEdgedVertices is deterministic -- even with non-deterministic order of edges as -- explained in Note [Deterministic SCC] in Digraph. - where getParent occ = lookupOccEnv parent_map occ `orElse` occ + where getParent :: OccName -> OccName + getParent occ = lookupOccEnv parent_map occ `orElse` occ -- maps OccNames to their parents in the current module. -- e.g. a reference to a constructor must be turned into a reference @@ -441,20 +470,22 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls parent_map = foldr extend emptyOccEnv new_decls where extend d env = extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ] - where n = ifName d + where n = getOccName d -- strongly-connected groups of declarations, in dependency order - groups = stronglyConnCompFromEdgedVerticesUniq edges + groups :: [SCC IfaceDeclABI] + groups = + stronglyConnCompFromEdgedVerticesUniq edges global_hash_fn = mkHashFun hsc_env eps - -- how to output Names when generating the data to fingerprint. + -- How to output Names when generating the data to fingerprint. -- Here we want to output the fingerprint for each top-level -- Name, whether it comes from the current module or another -- module. In this way, the fingerprint for a declaration will -- change if the fingerprint for anything it refers to (transitively) -- changes. - mk_put_name :: (OccEnv (OccName,Fingerprint)) + mk_put_name :: OccEnv (OccName,Fingerprint) -> BinHandle -> Name -> IO () mk_put_name local_env bh name | isWiredInName name = putNameLiterally bh name @@ -552,7 +583,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- interface into EPS, you will see a duplicate orphan instance. orphan_hash <- computeFingerprint (mk_put_name local_env) - (map ifDFun orph_insts, orph_rules, orph_fis) + (map ifDFun orph_insts, orph_rules, orph_fis) -- the export list hash doesn't depend on the fingerprints of -- the Names it mentions, only the Names themselves, hence putNameLiterally. @@ -568,7 +599,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- put the declarations in a canonical order, sorted by OccName let sorted_decls = Map.elems $ Map.fromList $ - [(ifName d, e) | e@(_, d) <- decls_w_hashes] + [(getOccName d, e) | e@(_, d) <- decls_w_hashes] -- the flag hash depends on: -- - (some of) dflags @@ -741,8 +772,8 @@ abiDecl :: IfaceDeclABI -> IfaceDecl abiDecl (_, decl, _) = decl cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering -cmp_abiNames abi1 abi2 = ifName (abiDecl abi1) `compare` - ifName (abiDecl abi2) +cmp_abiNames abi1 abi2 = getOccName (abiDecl abi1) `compare` + getOccName (abiDecl abi2) freeNamesDeclABI :: IfaceDeclABI -> NameSet freeNamesDeclABI (_mod, decl, extras) = @@ -819,7 +850,7 @@ declExtras fix_fn ann_fn rule_env inst_env fi_env decl (map ifFamInstAxiom (lookupOccEnvL fi_env n) ++ map ifDFun (lookupOccEnvL inst_env n)) (ann_fn n) - (map (id_extras . ifConOcc) (visibleIfConDecls cons)) + (map (id_extras . occName . ifConName) (visibleIfConDecls cons)) IfaceClass{ifSigs=sigs, ifATs=ats} -> IfaceClassExtras (fix_fn n) (map ifDFun $ (concatMap at_extras ats) @@ -827,7 +858,7 @@ declExtras fix_fn ann_fn rule_env inst_env fi_env decl -- Include instances of the associated types -- as well as instances of the class (Trac #5147) (ann_fn n) - [id_extras op | IfaceClassOp op _ _ <- sigs] + [id_extras (getOccName op) | IfaceClassOp op _ _ <- sigs] IfaceSynonym{} -> IfaceSynonymExtras (fix_fn n) (ann_fn n) IfaceFamily{} -> IfaceFamilyExtras (fix_fn n) @@ -835,22 +866,14 @@ declExtras fix_fn ann_fn rule_env inst_env fi_env decl (ann_fn n) _other -> IfaceOtherDeclExtras where - n = ifName decl + n = getOccName decl id_extras occ = IdExtras (fix_fn occ) (lookupOccEnvL rule_env occ) (ann_fn occ) - at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (ifName decl) + at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (getOccName decl) lookupOccEnvL :: OccEnv [v] -> OccName -> [v] lookupOccEnvL env k = lookupOccEnv env k `orElse` [] --- used when we want to fingerprint a structure without depending on the --- fingerprints of external Names that it refers to. -putNameLiterally :: BinHandle -> Name -> IO () -putNameLiterally bh name = ASSERT( isExternalName name ) - do - put_ bh $! nameModule name - put_ bh $! nameOccName name - {- -- for testing: use the md5sum command to generate fingerprints and -- compare the results against our built-in version. @@ -1341,7 +1364,7 @@ idToIfaceDecl :: Id -> IfaceDecl -- We can't tidy it here, locally, because it may have -- free variables in its type or IdInfo idToIfaceDecl id - = IfaceId { ifName = getOccName id, + = IfaceId { ifName = getName id, ifType = toIfaceType (idType id), ifIdDetails = toIfaceIdDetails (idDetails id), ifIdInfo = toIfaceIdInfo (idInfo id) } @@ -1349,7 +1372,7 @@ idToIfaceDecl id -------------------------- dataConToIfaceDecl :: DataCon -> IfaceDecl dataConToIfaceDecl dataCon - = IfaceId { ifName = getOccName dataCon, + = IfaceId { ifName = getName dataCon, ifType = toIfaceType (dataConUserType dataCon), ifIdDetails = IfVanillaId, ifIdInfo = NoInfo } @@ -1357,7 +1380,7 @@ dataConToIfaceDecl dataCon -------------------------- patSynToIfaceDecl :: PatSyn -> IfaceDecl patSynToIfaceDecl ps - = IfacePatSyn { ifName = getOccName . getName $ ps + = IfacePatSyn { ifName = getName $ ps , ifPatMatcher = to_if_pr (patSynMatcher ps) , ifPatBuilder = fmap to_if_pr (patSynBuilder ps) , ifPatIsInfix = patSynIsInfix ps @@ -1383,7 +1406,7 @@ coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl -- conveniently be) built in tidy form coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches , co_ax_role = role }) - = IfaceAxiom { ifName = name + = IfaceAxiom { ifName = getName ax , ifTyCon = toIfaceTyCon tycon , ifRole = role , ifAxBranches = map (coAxBranchToIfaceBranch tycon @@ -1391,7 +1414,6 @@ coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches branch_list } where branch_list = fromBranches branches - name = getOccName ax -- 2nd parameter is the list of branch LHSs, for conversion from incompatible branches -- to incompatible indices @@ -1433,7 +1455,7 @@ tyConToIfaceDecl env tycon | Just syn_rhs <- synTyConRhs_maybe tycon = ( tc_env1 - , IfaceSynonym { ifName = getOccName tycon, + , IfaceSynonym { ifName = getName tycon, ifRoles = tyConRoles tycon, ifSynRhs = if_syn_type syn_rhs, ifBinders = if_binders, @@ -1442,7 +1464,7 @@ tyConToIfaceDecl env tycon | Just fam_flav <- famTyConFlav_maybe tycon = ( tc_env1 - , IfaceFamily { ifName = getOccName tycon, + , IfaceFamily { ifName = getName tycon, ifResVar = if_res_var, ifFamFlav = to_if_fam_flav fam_flav, ifBinders = if_binders, @@ -1452,7 +1474,7 @@ tyConToIfaceDecl env tycon | isAlgTyCon tycon = ( tc_env1 - , IfaceData { ifName = getOccName tycon, + , IfaceData { ifName = getName tycon, ifBinders = if_binders, ifResKind = if_res_kind, ifCType = tyConCType tycon, @@ -1467,7 +1489,7 @@ tyConToIfaceDecl env tycon -- just about to pretty-print them, not because we are going -- to put them into interface files = ( env - , IfaceData { ifName = getOccName tycon, + , IfaceData { ifName = getName tycon, ifBinders = if_binders, ifResKind = if_res_kind, ifCType = Nothing, @@ -1520,15 +1542,14 @@ tyConToIfaceDecl env tycon -- (Tuple declarations are not serialised into interface files.) ifaceConDecl data_con - = IfCon { ifConOcc = getOccName (dataConName data_con), + = IfCon { ifConName = dataConName data_con, ifConInfix = dataConIsInfix data_con, ifConWrapper = isJust (dataConWrapId_maybe data_con), ifConExTvs = map toIfaceForAllBndr ex_bndrs', ifConEqSpec = map (to_eq_spec . eqSpecPair) eq_spec, ifConCtxt = tidyToIfaceContext con_env2 theta, ifConArgTys = map (tidyToIfaceType con_env2) arg_tys, - ifConFields = map (nameOccName . flSelector) - (dataConFieldLabels data_con), + ifConFields = map flSelector (dataConFieldLabels data_con), ifConStricts = map (toIfaceBang con_env2) (dataConImplBangs data_con), ifConSrcStricts = map toIfaceSrcBang @@ -1569,7 +1590,7 @@ classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl) classToIfaceDecl env clas = ( env1 , IfaceClass { ifCtxt = tidyToIfaceContext env1 sc_theta, - ifName = getOccName tycon, + ifName = getName tycon, ifRoles = tyConRoles (classTyCon clas), ifBinders = toIfaceTyVarBinders tc_binders, ifFDs = map toIfaceFD clas_fds, @@ -1591,7 +1612,7 @@ classToIfaceDecl env clas toIfaceClassOp (sel_id, def_meth) = ASSERT( sel_tyvars == binderVars tc_binders ) - IfaceClassOp (getOccName sel_id) + IfaceClassOp (getName sel_id) (tidyToIfaceType env1 op_ty) (fmap toDmSpec def_meth) where diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs index 0794a9ee67..eba52e4890 100644 --- a/compiler/iface/TcIface.hs +++ b/compiler/iface/TcIface.hs @@ -263,7 +263,7 @@ typecheckIfacesForMerging mod ifaces tc_env_var = -- 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) + = mkOccEnv [ (getOccName decl, decl) | decl <- decls , case decl of IfaceId { ifIdDetails = IfDFunId } -> False -- exclude DFuns @@ -420,10 +420,10 @@ mkSelfBootInfo iface mds = do -- NB: This is computed DIRECTLY from the ModIface rather -- than from the ModDetails, so that we can query 'sb_tcs' -- WITHOUT forcing the contents of the interface. - tcs <- mapM (lookupOrig (mi_module iface) . ifName) - . filter isIfaceTyCon - . map snd - $ mi_decls iface + let tcs = map ifName + . filter isIfaceTyCon + . map snd + $ mi_decls iface return $ SelfBoot { sb_mds = mds , sb_tcs = mkNameSet tcs } where @@ -498,15 +498,14 @@ tc_iface_decl :: Maybe Class -- ^ For associated type/data family declarations -> Bool -- ^ True <=> discard IdInfo on IfaceId bindings -> IfaceDecl -> IfL TyThing -tc_iface_decl _ ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, +tc_iface_decl _ ignore_prags (IfaceId {ifName = name, ifType = iface_type, ifIdDetails = details, ifIdInfo = info}) - = do { name <- lookupIfaceTop occ_name - ; ty <- tcIfaceType iface_type + = do { ty <- tcIfaceType iface_type ; details <- tcIdDetails ty details ; info <- tcIdInfo ignore_prags name ty info ; return (AnId (mkGlobalId details name ty info)) } -tc_iface_decl _ _ (IfaceData {ifName = occ_name, +tc_iface_decl _ _ (IfaceData {ifName = tc_name, ifCType = cType, ifBinders = binders, ifResKind = res_kind, @@ -515,8 +514,7 @@ tc_iface_decl _ _ (IfaceData {ifName = occ_name, ifCons = rdr_cons, ifParent = mb_parent }) = bindIfaceTyConBinders_AT binders $ \ binders' -> do - { tc_name <- lookupIfaceTop occ_name - ; res_kind' <- tcIfaceType res_kind + { res_kind' <- tcIfaceType res_kind ; tycon <- fixM $ \ tycon -> do { stupid_theta <- tcIfaceCtxt ctxt @@ -539,14 +537,13 @@ tc_iface_decl _ _ (IfaceData {ifName = occ_name, ; lhs_tys <- tcIfaceTcArgs arg_tys ; return (DataFamInstTyCon ax_unbr fam_tc lhs_tys) } -tc_iface_decl _ _ (IfaceSynonym {ifName = occ_name, +tc_iface_decl _ _ (IfaceSynonym {ifName = tc_name, ifRoles = roles, ifSynRhs = rhs_ty, ifBinders = binders, ifResKind = res_kind }) = bindIfaceTyConBinders_AT binders $ \ binders' -> do - { tc_name <- lookupIfaceTop occ_name - ; res_kind' <- tcIfaceType res_kind -- Note [Synonym kind loop] + { res_kind' <- tcIfaceType res_kind -- Note [Synonym kind loop] ; rhs <- forkM (mk_doc tc_name) $ tcIfaceType rhs_ty ; let tycon = mkSynonymTyCon tc_name binders' res_kind' roles rhs @@ -554,14 +551,13 @@ tc_iface_decl _ _ (IfaceSynonym {ifName = occ_name, where mk_doc n = text "Type synonym" <+> ppr n -tc_iface_decl parent _ (IfaceFamily {ifName = occ_name, +tc_iface_decl parent _ (IfaceFamily {ifName = tc_name, ifFamFlav = fam_flav, ifBinders = binders, ifResKind = res_kind, ifResVar = res, ifFamInj = inj }) = bindIfaceTyConBinders_AT binders $ \ binders' -> do - { tc_name <- lookupIfaceTop occ_name - ; res_kind' <- tcIfaceType res_kind -- Note [Synonym kind loop] + { res_kind' <- tcIfaceType res_kind -- Note [Synonym kind loop] ; rhs <- forkM (mk_doc tc_name) $ tc_fam_flav tc_name fam_flav ; res_name <- traverse (newIfaceName . mkTyVarOccFS) res @@ -585,7 +581,7 @@ tc_iface_decl parent _ (IfaceFamily {ifName = occ_name, (text "IfaceBuiltInSynFamTyCon in interface file") tc_iface_decl _parent ignore_prags - (IfaceClass {ifCtxt = rdr_ctxt, ifName = tc_occ, + (IfaceClass {ifCtxt = rdr_ctxt, ifName = tc_name, ifRoles = roles, ifBinders = binders, ifFDs = rdr_fds, @@ -594,17 +590,16 @@ tc_iface_decl _parent ignore_prags -- ToDo: in hs-boot files we should really treat abstract classes specially, -- as we do abstract tycons = bindIfaceTyConBinders binders $ \ binders' -> do - { tc_name <- lookupIfaceTop tc_occ - ; traceIf (text "tc-iface-class1" <+> ppr tc_occ) + { traceIf (text "tc-iface-class1" <+> ppr tc_name) ; ctxt <- mapM tc_sc rdr_ctxt - ; traceIf (text "tc-iface-class2" <+> ppr tc_occ) + ; traceIf (text "tc-iface-class2" <+> ppr tc_name) ; sigs <- mapM tc_sig rdr_sigs ; fds <- mapM tc_fd rdr_fds - ; traceIf (text "tc-iface-class3" <+> ppr tc_occ) + ; traceIf (text "tc-iface-class3" <+> ppr tc_name) ; mindef <- traverse (lookupIfaceTop . mkVarOccFS) mindef_occ ; cls <- fixM $ \ cls -> do { ats <- mapM (tc_at cls) rdr_ats - ; traceIf (text "tc-iface-class4" <+> ppr tc_occ) + ; traceIf (text "tc-iface-class4" <+> ppr tc_name) ; buildClass tc_name binders' roles ctxt fds ats sigs mindef } ; return (ATyCon (classTyCon cls)) } where @@ -618,9 +613,8 @@ tc_iface_decl _parent ignore_prags -- so we must not pull on T too eagerly. See Trac #5970 tc_sig :: IfaceClassOp -> IfL TcMethInfo - tc_sig (IfaceClassOp occ rdr_ty dm) - = do { op_name <- lookupIfaceTop occ - ; let doc = mk_op_doc op_name rdr_ty + tc_sig (IfaceClassOp op_name rdr_ty dm) + = do { let doc = mk_op_doc op_name rdr_ty ; op_ty <- forkM (doc <+> text "ty") $ tcIfaceType rdr_ty -- Must be done lazily for just the same reason as the -- type of a data con; to avoid sucking in types that @@ -659,10 +653,9 @@ tc_iface_decl _parent ignore_prags ; tvs2' <- mapM tcIfaceTyVar tvs2 ; return (tvs1', tvs2') } -tc_iface_decl _ _ (IfaceAxiom { ifName = ax_occ, ifTyCon = tc +tc_iface_decl _ _ (IfaceAxiom { ifName = tc_name, ifTyCon = tc , ifAxBranches = branches, ifRole = role }) - = do { tc_name <- lookupIfaceTop ax_occ - ; tc_tycon <- tcIfaceTyCon tc + = do { tc_tycon <- tcIfaceTyCon tc ; tc_branches <- tc_ax_branches branches ; let axiom = CoAxiom { co_ax_unique = nameUnique tc_name , co_ax_name = tc_name @@ -672,7 +665,7 @@ tc_iface_decl _ _ (IfaceAxiom { ifName = ax_occ, ifTyCon = tc , co_ax_implicit = False } ; return (ACoAxiom axiom) } -tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name +tc_iface_decl _ _ (IfacePatSyn{ ifName = name , ifPatMatcher = if_matcher , ifPatBuilder = if_builder , ifPatIsInfix = is_infix @@ -683,8 +676,7 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name , ifPatArgs = args , ifPatTy = pat_ty , ifFieldLabels = field_labels }) - = do { name <- lookupIfaceTop occ_name - ; traceIf (text "tc_iface_decl" <+> ppr name) + = do { traceIf (text "tc_iface_decl" <+> ppr name) ; matcher <- tc_pr if_matcher ; builder <- fmapMaybeM tc_pr if_builder ; bindIfaceForAllBndrs univ_bndrs $ \univ_tvs -> do @@ -744,15 +736,15 @@ tcIfaceDataCons tycon_name tycon tc_tybinders if_cons tc_con_decl field_lbls (IfCon { ifConInfix = is_infix, ifConExTvs = ex_bndrs, - ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec, + ifConName = dc_name, + ifConCtxt = ctxt, ifConEqSpec = spec, ifConArgTys = args, ifConFields = my_lbls, ifConStricts = if_stricts, ifConSrcStricts = if_src_stricts}) = -- Universally-quantified tyvars are shared with -- parent TyCon, and are alrady in scope bindIfaceForAllBndrs ex_bndrs $ \ ex_tv_bndrs -> do - { traceIf (text "Start interface-file tc_con_decl" <+> ppr occ) - ; dc_name <- lookupIfaceTop occ + { traceIf (text "Start interface-file tc_con_decl" <+> ppr dc_name) -- Read the context and argument types, but lazily for two reasons -- (a) to avoid looking tugging on a recursive use of @@ -771,9 +763,9 @@ tcIfaceDataCons tycon_name tycon tc_tybinders if_cons -- Look up the field labels for this constructor; note that -- they should be in the same order as my_lbls! ; let lbl_names = map find_lbl my_lbls - find_lbl x = case find (\ fl -> nameOccName (flSelector fl) == x) field_lbls of + find_lbl x = case find (\ fl -> flSelector fl == x) field_lbls of Just fl -> fl - Nothing -> error $ "find_lbl missing " ++ occNameString x + Nothing -> error $ "find_lbl missing " ++ occNameString (occName x) -- Remember, tycon is the representation tycon ; let orig_res_ty = mkFamilyTyConApp tycon diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index ae6ad7d068..141f59f299 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -98,7 +98,6 @@ import ConLike import Control.Concurrent #endif -import THNames ( templateHaskellNames ) import Module import Packages import RdrName @@ -111,7 +110,7 @@ import SrcLoc import TcRnDriver import TcIface ( typecheckIface ) import TcRnMonad -import IfaceEnv ( initNameCache ) +import NameCache ( initNameCache ) import LoadIface ( ifaceStats, initExternalPackageState ) import PrelInfo import MkIface @@ -144,7 +143,6 @@ import DynFlags import ErrUtils import Outputable -import UniqFM import NameEnv import HscStats ( ppSourceStats ) import HscTypes @@ -178,7 +176,7 @@ newHscEnv :: DynFlags -> IO HscEnv newHscEnv dflags = do eps_var <- newIORef initExternalPackageState us <- mkSplitUniqSupply 'r' - nc_var <- newIORef (initNameCache us allKnownKeyNames) + nc_var <- newIORef (initNameCache us knownKeyNames) fc_var <- newIORef emptyInstalledModuleEnv #ifdef GHCI iserv_mvar <- newMVar Nothing @@ -197,39 +195,6 @@ newHscEnv dflags = do #endif } - -allKnownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta, -allKnownKeyNames -- where templateHaskellNames are defined - | debugIsOn - , not (isNullUFM badNamesEnv) - = panic ("badAllKnownKeyNames:\n" ++ badNamesStr) - -- NB: We can't use ppr here, because this is sometimes evaluated in a - -- context where there are no DynFlags available, leading to a cryptic - -- "<<details unavailable>>" error. (This seems to happen only in the - -- stage 2 compiler, for reasons I [Richard] have no clue of.) - - | otherwise - = all_names - where - all_names = knownKeyNames - ++ templateHaskellNames - - namesEnv = foldl (\m n -> extendNameEnv_Acc (:) singleton m n n) - emptyUFM all_names - badNamesEnv = filterNameEnv (\ns -> length ns > 1) namesEnv - badNamesPairs = nonDetUFMToList badNamesEnv - -- It's OK to use nonDetUFMToList here because the ordering only affects - -- the message when we get a panic - badNamesStrs = map pairToStr badNamesPairs - badNamesStr = unlines badNamesStrs - - pairToStr (uniq, ns) = " " ++ - show uniq ++ - ": [" ++ - intercalate ", " (map (occNameString . nameOccName) ns) ++ - "]" - - -- ----------------------------------------------------------------------------- getWarnings :: Hsc WarningMessages diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index f1c253f414..b5f86db4e6 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -101,7 +101,7 @@ module HscTypes ( -- * Information on imports and exports WhetherHasOrphans, IsBootInterface, Usage(..), Dependencies(..), noDependencies, - NameCache(..), OrigNameCache, updNameCacheIO, + updNameCacheIO, IfaceExport, -- * Warnings @@ -151,7 +151,7 @@ import Avail import Module import InstEnv ( InstEnv, ClsInst, identicalClsInstHead ) import FamInstEnv -import CoreSyn ( CoreProgram, RuleBase ) +import CoreSyn ( CoreProgram, RuleBase, CoreRule, CoreVect ) import Name import NameEnv import NameSet @@ -178,13 +178,11 @@ import DynFlags import DriverPhases ( Phase, HscSource(..), isHsBootOrSig, hscSourceString ) import BasicTypes import IfaceSyn -import CoreSyn ( CoreRule, CoreVect ) import Maybes import Outputable import SrcLoc import Unique import UniqDFM -import UniqSupply import FastString import StringBuffer ( StringBuffer ) import Fingerprint @@ -192,6 +190,7 @@ import MonadUtils import Bag import Binary import ErrUtils +import NameCache import Platform import Util import UniqDSet @@ -2510,25 +2509,12 @@ interface file); so we give it 'noSrcLoc' then. Later, when we find its binding site, we fix it up. -} --- | The NameCache makes sure that there is just one Unique assigned for --- each original name; i.e. (module-name, occ-name) pair and provides --- something of a lookup mechanism for those names. -data NameCache - = NameCache { nsUniqs :: !UniqSupply, - -- ^ Supply of uniques - nsNames :: !OrigNameCache - -- ^ Ensures that one original name gets one unique - } - updNameCacheIO :: HscEnv -> (NameCache -> (NameCache, c)) -- The updating function -> IO c updNameCacheIO hsc_env upd_fn = atomicModifyIORef' (hsc_NC hsc_env) upd_fn --- | Per-module cache of original 'OccName's given 'Name's -type OrigNameCache = ModuleEnv (OccEnv Name) - mkSOName :: Platform -> FilePath -> FilePath mkSOName platform root = case platformOS platform of diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs index 5bd94e3cae..e59a3896f3 100644 --- a/compiler/main/TidyPgm.hs +++ b/compiler/main/TidyPgm.hs @@ -43,6 +43,7 @@ import BasicTypes import Name hiding (varName) import NameSet import NameEnv +import NameCache import Avail import IfaceEnv import TcEnv diff --git a/compiler/prelude/KnownUniques.hs b/compiler/prelude/KnownUniques.hs new file mode 100644 index 0000000000..2dc6f8388d --- /dev/null +++ b/compiler/prelude/KnownUniques.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE CPP #-} + +-- | This is where we define a mapping from Uniques to their associated +-- known-key Names for things associated with tuples and sums. We use this +-- mapping while deserializing known-key Names in interface file symbol tables, +-- which are encoded as their Unique. See Note [Symbol table representation of +-- names] for details. +-- + +module KnownUniques + ( -- * Looking up known-key names + knownUniqueName + + -- * Getting the 'Unique's of 'Name's + -- ** Anonymous sums + , mkSumTyConUnique + , mkSumDataConUnique + -- ** Tuples + -- *** Vanilla + , mkTupleTyConUnique + , mkTupleDataConUnique + -- *** Constraint + , mkCTupleTyConUnique + , mkCTupleDataConUnique + ) where + +#include "HsVersions.h" + +import TysWiredIn +import TyCon +import DataCon +import Id +import BasicTypes +import Outputable +import Unique +import Name +import Util + +import Data.Bits +import Data.Maybe + +-- | Get the 'Name' associated with a known-key 'Unique'. +knownUniqueName :: Unique -> Maybe Name +knownUniqueName u = + case tag of + 'z' -> Just $ getUnboxedSumName n + '4' -> Just $ getTupleTyConName Boxed n + '5' -> Just $ getTupleTyConName Unboxed n + '7' -> Just $ getTupleDataConName Boxed n + '8' -> Just $ getTupleDataConName Unboxed n + 'k' -> Just $ getCTupleTyConName n + 'm' -> Just $ getCTupleDataConUnique n + _ -> Nothing + where + (tag, n) = unpkUnique u + +-------------------------------------------------- +-- Anonymous sums +-- +-- Sum arities start from 2. The encoding is a bit funny: we break up the +-- integral part into bitfields for the arity and alternative index (which is +-- taken to be 0xff in the case of the TyCon) +-- +-- TyCon for sum of arity k: +-- 00000000 kkkkkkkk 11111111 +-- DataCon for sum of arity k and alternative n (zero-based): +-- 00000000 kkkkkkkk nnnnnnnn + +mkSumTyConUnique :: Arity -> Unique +mkSumTyConUnique arity = + ASSERT(arity < 0xff) + mkUnique 'z' (arity `shiftL` 8 .|. 0xff) + +mkSumDataConUnique :: ConTagZ -> Arity -> Unique +mkSumDataConUnique alt arity + | alt >= arity + = panic ("mkSumDataConUnique: " ++ show alt ++ " >= " ++ show arity) + | otherwise + = mkUnique 'z' (arity `shiftL` 8 + alt) {- skip the tycon -} + +getUnboxedSumName :: Int -> Name +getUnboxedSumName n = + case n .&. 0xff of + 0xff -> tyConName $ sumTyCon arity + alt -> dataConName $ sumDataCon (alt + 1) arity + where arity = n `shiftR` 8 + +-- Note [Uniques for tuple type and data constructors] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Wired-in type constructor keys occupy *two* slots: +-- * u: the TyCon itself +-- * u+1: the TyConRepName of the TyCon +-- +-- Wired-in tuple data constructor keys occupy *three* slots: +-- * u: the DataCon itself +-- * u+1: its worker Id +-- * u+2: the TyConRepName of the promoted TyCon + +-------------------------------------------------- +-- Constraint tuples + +mkCTupleTyConUnique :: Arity -> Unique +mkCTupleTyConUnique a = mkUnique 'k' (2*a) + +mkCTupleDataConUnique :: Arity -> Unique +mkCTupleDataConUnique a = mkUnique 'm' (3*a) + +getCTupleTyConName :: Int -> Name +getCTupleTyConName n = + case n `divMod` 2 of + (arity, 0) -> cTupleTyConName arity + (arity, 1) -> mkPrelTyConRepName $ cTupleTyConName arity + _ -> panic "getCTupleTyConName: impossible" + +getCTupleDataConUnique :: Int -> Name +getCTupleDataConUnique n = + case n `divMod` 3 of + (arity, 0) -> cTupleDataConName arity + (_arity, 1) -> panic "getCTupleDataConName: no worker" + (arity, 2) -> mkPrelTyConRepName $ cTupleDataConName arity + _ -> panic "getCTupleDataConName: impossible" + +-------------------------------------------------- +-- Normal tuples + +mkTupleDataConUnique :: Boxity -> Arity -> Unique +mkTupleDataConUnique Boxed a = mkUnique '7' (3*a) -- may be used in C labels +mkTupleDataConUnique Unboxed a = mkUnique '8' (3*a) + +mkTupleTyConUnique :: Boxity -> Arity -> Unique +mkTupleTyConUnique Boxed a = mkUnique '4' (2*a) +mkTupleTyConUnique Unboxed a = mkUnique '5' (2*a) + +getTupleTyConName :: Boxity -> Int -> Name +getTupleTyConName boxity n = + case n `divMod` 2 of + (arity, 0) -> tyConName $ tupleTyCon boxity arity + (arity, 1) -> fromMaybe (panic "getTupleTyConName") + $ tyConRepName_maybe $ tupleTyCon boxity arity + _ -> panic "getTupleTyConName: impossible" + +getTupleDataConName :: Boxity -> Int -> Name +getTupleDataConName boxity n = + case n `divMod` 3 of + (arity, 0) -> dataConName $ tupleDataCon boxity arity + (arity, 1) -> idName $ dataConWorkId $ tupleDataCon boxity arity + (arity, 2) -> fromMaybe (panic "getTupleDataCon") + $ tyConRepName_maybe $ promotedTupleDataCon boxity arity + _ -> panic "getTupleDataConName: impossible" diff --git a/compiler/prelude/KnownUniques.hs-boot b/compiler/prelude/KnownUniques.hs-boot new file mode 100644 index 0000000000..eeb478526d --- /dev/null +++ b/compiler/prelude/KnownUniques.hs-boot @@ -0,0 +1,17 @@ +module KnownUniques where + +import Unique +import Name +import BasicTypes + +-- Needed by TysWiredIn +knownUniqueName :: Unique -> Maybe Name + +mkSumTyConUnique :: Arity -> Unique +mkSumDataConUnique :: ConTagZ -> Arity -> Unique + +mkCTupleTyConUnique :: Arity -> Unique +mkCTupleDataConUnique :: Arity -> Unique + +mkTupleTyConUnique :: Boxity -> Arity -> Unique +mkTupleDataConUnique :: Boxity -> Arity -> Unique diff --git a/compiler/prelude/PrelInfo.hs b/compiler/prelude/PrelInfo.hs index 52493b40f5..59a998093a 100644 --- a/compiler/prelude/PrelInfo.hs +++ b/compiler/prelude/PrelInfo.hs @@ -1,31 +1,54 @@ {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -\section[PrelInfo]{The @PrelInfo@ interface to the compiler's prelude knowledge} -} {-# LANGUAGE CPP #-} + +-- | The @PrelInfo@ interface to the compiler's prelude knowledge. +-- +-- This module serves as the central gathering point for names which the +-- compiler knows something about. This includes functions for, +-- +-- * discerning whether a 'Name' is known-key +-- +-- * given a 'Unique', looking up its corresponding known-key 'Name' +-- +-- See Note [Known-key names] and Note [About wired-in things] for information +-- about the two types of prelude things in GHC. +-- module PrelInfo ( + -- * Known-key names + isKnownKeyName, + lookupKnownKeyName, + + -- ** Internal use + -- | 'knownKeyNames' is exported to seed the original name cache only; + -- if you find yourself wanting to look at it you might consider using + -- 'lookupKnownKeyName' or 'isKnownKeyName'. + knownKeyNames, + + -- * Miscellaneous wiredInIds, ghcPrimIds, primOpRules, builtinRules, ghcPrimExports, - knownKeyNames, primOpId, - -- Random other things + -- * Random other things maybeCharLikeCon, maybeIntLikeCon, - -- Class categories + -- * Class categories isNumericClass, isStandardClass ) where #include "HsVersions.h" -import Constants ( mAX_TUPLE_SIZE ) -import BasicTypes ( Boxity(..) ) +import KnownUniques + import ConLike ( ConLike(..) ) +import THNames ( templateHaskellNames ) import PrelNames import PrelRules import Avail @@ -33,16 +56,22 @@ import PrimOp import DataCon import Id import Name +import NameEnv import MkId import TysPrim import TysWiredIn import HscTypes import Class import TyCon +import UniqFM import Util +import Panic import {-# SOURCE #-} TcTypeNats ( typeNatTyCons ) +import Control.Applicative ((<|>)) +import Data.List ( intercalate ) import Data.Array +import Data.Maybe {- ************************************************************************ @@ -51,8 +80,8 @@ import Data.Array * * ************************************************************************ -Notes about wired in things -~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [About wired-in things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * Wired-in things are Ids\/TyCons that are completely known to the compiler. They are global values in GHC, (e.g. listTyCon :: TyCon). @@ -61,6 +90,7 @@ Notes about wired in things (E.g. listTyConName contains listTyCon. * The name cache is initialised with (the names of) all wired-in things + (except tuples and sums; see Note [Known-]) * The type environment itself contains no wired in things. The type checker sees if the Name is wired in before looking up the name in @@ -77,47 +107,91 @@ knownKeyNames :: [Name] -- you get a Name with the correct known key -- (See Note [Known-key names] in PrelNames) knownKeyNames - = concat [ tycon_kk_names funTyCon - , concatMap tycon_kk_names primTyCons - - , concatMap tycon_kk_names wiredInTyCons - -- Does not include tuples - - , concatMap tycon_kk_names typeNatTyCons - - , concatMap (tycon_kk_names . tupleTyCon Boxed) [2..mAX_TUPLE_SIZE] -- Yuk - - , cTupleTyConNames - -- Constraint tuples are known-key but not wired-in - -- They can't show up in source code, but can appear - -- in interface files - - , map idName wiredInIds - , map (idName . primOpId) allThePrimOps - , basicKnownKeyNames ] - + | debugIsOn + , Just badNamesStr <- knownKeyNamesOkay all_names + = panic ("badAllKnownKeyNames:\n" ++ badNamesStr) + -- NB: We can't use ppr here, because this is sometimes evaluated in a + -- context where there are no DynFlags available, leading to a cryptic + -- "<<details unavailable>>" error. (This seems to happen only in the + -- stage 2 compiler, for reasons I [Richard] have no clue of.) + | otherwise + = all_names + where + all_names = + concat [ wired_tycon_kk_names funTyCon + , concatMap wired_tycon_kk_names primTyCons + + , concatMap wired_tycon_kk_names wiredInTyCons + -- Does not include tuples + + , concatMap wired_tycon_kk_names typeNatTyCons + + , map idName wiredInIds + , map (idName . primOpId) allThePrimOps + , basicKnownKeyNames + , templateHaskellNames + ] + -- All of the names associated with a wired-in TyCon. + -- This includes the TyCon itself, its DataCons and promoted TyCons. + wired_tycon_kk_names :: TyCon -> [Name] + wired_tycon_kk_names tc = + tyConName tc : (rep_names tc ++ implicits) + where implicits = concatMap thing_kk_names (implicitTyConThings tc) + + wired_datacon_kk_names :: DataCon -> [Name] + wired_datacon_kk_names dc = + dataConName dc : rep_names (promoteDataCon dc) + + thing_kk_names :: TyThing -> [Name] + thing_kk_names (ATyCon tc) = wired_tycon_kk_names tc + thing_kk_names (AConLike (RealDataCon dc)) = wired_datacon_kk_names dc + thing_kk_names thing = [getName thing] + + -- The TyConRepName for a known-key TyCon has a known key, + -- but isn't itself an implicit thing. Yurgh. + -- NB: if any of the wired-in TyCons had record fields, the record + -- field names would be in a similar situation. Ditto class ops. + -- But it happens that there aren't any + rep_names tc = case tyConRepName_maybe tc of + Just n -> [n] + Nothing -> [] + +-- | Check the known-key names list of consistency. +knownKeyNamesOkay :: [Name] -> Maybe String +knownKeyNamesOkay all_names + | null badNamesPairs + = Nothing + | otherwise + = Just badNamesStr where - -- All of the names associated with a known-key thing. - -- This includes TyCons, DataCons and promoted TyCons. - tycon_kk_names :: TyCon -> [Name] - tycon_kk_names tc = tyConName tc : (rep_names tc ++ concatMap thing_kk_names (implicitTyConThings tc)) - - datacon_kk_names dc - = dataConName dc : rep_names (promoteDataCon dc) - - thing_kk_names :: TyThing -> [Name] - thing_kk_names (ATyCon tc) = tycon_kk_names tc - thing_kk_names (AConLike (RealDataCon dc)) = datacon_kk_names dc - thing_kk_names thing = [getName thing] - - -- The TyConRepName for a known-key TyCon has a known key, - -- but isn't itself an implicit thing. Yurgh. - -- NB: if any of the wired-in TyCons had record fields, the record - -- field names would be in a similar situation. Ditto class ops. - -- But it happens that there aren't any - rep_names tc = case tyConRepName_maybe tc of - Just n -> [n] - Nothing -> [] + namesEnv = foldl (\m n -> extendNameEnv_Acc (:) singleton m n n) + emptyUFM all_names + badNamesEnv = filterNameEnv (\ns -> length ns > 1) namesEnv + badNamesPairs = nonDetUFMToList badNamesEnv + -- It's OK to use nonDetUFMToList here because the ordering only affects + -- the message when we get a panic + badNamesStrs = map pairToStr badNamesPairs + badNamesStr = unlines badNamesStrs + + pairToStr (uniq, ns) = " " ++ + show uniq ++ + ": [" ++ + intercalate ", " (map (occNameString . nameOccName) ns) ++ + "]" + +-- | Given a 'Unique' lookup its associated 'Name' if it corresponds to a +-- known-key thing. +lookupKnownKeyName :: Unique -> Maybe Name +lookupKnownKeyName u = + knownUniqueName u <|> lookupUFM knownKeysMap u + +-- | Is a 'Name' known-key? +isKnownKeyName :: Name -> Bool +isKnownKeyName n = + isJust (knownUniqueName $ nameUnique n) || elemUFM n knownKeysMap + +knownKeysMap :: UniqFM Name +knownKeysMap = listToUFM [ (nameUnique n, n) | n <- knownKeyNames ] {- We let a lot of "non-standard" values be visible, so that we can make @@ -142,7 +216,7 @@ primOpId op = primOpIds ! primOpTag op {- ************************************************************************ * * -\subsection{Export lists for pseudo-modules (GHC.Prim)} + Export lists for pseudo-modules (GHC.Prim) * * ************************************************************************ @@ -160,7 +234,7 @@ ghcPrimExports {- ************************************************************************ * * -\subsection{Built-in keys} + Built-in keys * * ************************************************************************ @@ -174,7 +248,7 @@ maybeIntLikeCon con = con `hasKey` intDataConKey {- ************************************************************************ * * -\subsection{Class predicates} + Class predicates * * ************************************************************************ -} diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs index 558619a9db..41c9e36304 100644 --- a/compiler/prelude/PrelNames.hs +++ b/compiler/prelude/PrelNames.hs @@ -73,33 +73,44 @@ This is accomplished through a combination of mechanisms: stuff gets the right Unique, and is why it is so important to place your known-key names in the appropriate lists. - 3. For "infinite families" of known-key names (i.e. tuples), we have - to be extra careful. Because there are an infinite number of + 3. For "infinite families" of known-key names (i.e. tuples and sums), we + have to be extra careful. Because there are an infinite number of these things, we cannot add them to the list of known-key names used to initialise the OrigNameCache. Instead, we have to - rely on never having to look them up in that cache. + rely on never having to look them up in that cache. See + Note [Infinite families of known-key names] for details. - This is accomplished through a variety of mechanisms: - a) The parser recognises them specially and generates an - Exact Name (hence not looked up in the orig-name cache) +Note [Infinite families of known-key names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - b) The known infinite families of names are specially - serialised by BinIface.putName, with that special treatment - detected when we read back to ensure that we get back to the - correct uniques. +Infinite families of known-key things (e.g. tuples and sums) pose a tricky +problem: we can't add them to the knownKeyNames finite map which we use to +ensure that, e.g., a reference to (,) gets assigned the right unique (if this +doesn't sound familiar see Note [Known-key names] above). - Most of the infinite families cannot occur in source code, - so mechanisms (a,b) sufficies to ensure that they always have - the right Unique. In particular, implicit param TyCon names, - constraint tuples and Any TyCons cannot be mentioned by the - user. +We instead handle tuples and sums separately from the "vanilla" known-key +things, - c) IfaceEnv.lookupOrigNameCache uses isBuiltInOcc_maybe to map - built-in syntax directly onto the corresponding name, rather - than trying to find it in the original-name cache. + a) The parser recognises them specially and generates an Exact Name (hence not + looked up in the orig-name cache) - See also Note [Built-in syntax and the OrigNameCache] + b) The known infinite families of names are specially serialised by + BinIface.putName, with that special treatment detected when we read back to + ensure that we get back to the correct uniques. See Note [Symbol table + representation of names] in BinIface and Note [How tuples work] in + TysWiredIn. + +Most of the infinite families cannot occur in source code, so mechanisms (a) and (b) +suffice to ensure that they always have the right Unique. In particular, +implicit param TyCon names, constraint tuples and Any TyCons cannot be mentioned +by the user. For those things that *can* appear in source programs, + + c) IfaceEnv.lookupOrigNameCache uses isBuiltInOcc_maybe to map built-in syntax + directly onto the corresponding name, rather than trying to find it in the + original-name cache. + + See also Note [Built-in syntax and the OrigNameCache] -} {-# LANGUAGE CPP #-} diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs index b334967009..a954f0472f 100644 --- a/compiler/prelude/TysWiredIn.hs +++ b/compiler/prelude/TysWiredIn.hs @@ -73,7 +73,9 @@ module TysWiredIn ( unitTyCon, unitDataCon, unitDataConId, unitTy, unitTyConKey, pairTyCon, unboxedUnitTyCon, unboxedUnitDataCon, + -- ** Constraint tuples cTupleTyConName, cTupleTyConNames, isCTupleTyConName, + cTupleDataConName, cTupleDataConNames, -- * Any anyTyCon, anyTy, anyTypeOfKind, @@ -127,6 +129,7 @@ import {-# SOURCE #-} MkId( mkDataConWorkId, mkDictSelId ) -- friends: import PrelNames import TysPrim +import {-# SOURCE #-} KnownUniques -- others: import CoAxiom @@ -195,12 +198,13 @@ names in PrelNames, so they use wTcQual, wDataQual, etc -- See also Note [Known-key names] wiredInTyCons :: [TyCon] -wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because - -- it's defined in GHC.Base, and there's only - -- one of it. We put it in wiredInTyCons so - -- that it'll pre-populate the name cache, so - -- the special case in lookupOrigNameCache - -- doesn't need to look out for it +wiredInTyCons = [ -- Units are not treated like other tuples, because then + -- are defined in GHC.Base, and there's only a few of them. We + -- put them in wiredInTyCons so that they will pre-populate + -- the name cache, so the parser in isBuiltInOcc_maybe doesn't + -- need to look out for them. + unitTyCon + , unboxedUnitTyCon , anyTyCon , boolTyCon , charTyCon @@ -523,15 +527,21 @@ pcDataConWithFixity' declared_infix dc_name wrk_key rri tyvars ex_tyvars arg_tys no_bang = HsSrcBang Nothing NoSrcUnpack NoSrcStrict - modu = ASSERT( isExternalName dc_name ) - nameModule dc_name - dc_occ = nameOccName dc_name - wrk_occ = mkDataConWorkerOcc dc_occ - wrk_name = mkWiredInName modu wrk_occ wrk_key - (AnId (dataConWorkId data_con)) UserSyntax + wrk_name = mkDataConWorkerName data_con wrk_key prom_info = mkPrelTyConRepName dc_name +mkDataConWorkerName :: DataCon -> Unique -> Name +mkDataConWorkerName data_con wrk_key = + mkWiredInName modu wrk_occ wrk_key + (AnId (dataConWorkId data_con)) UserSyntax + where + modu = ASSERT( isExternalName dc_name ) + nameModule dc_name + dc_name = dataConName data_con + dc_occ = nameOccName dc_name + wrk_occ = mkDataConWorkerOcc dc_occ + -- used for RuntimeRep and friends pcSpecialDataCon :: Name -> [Type] -> TyCon -> RuntimeRepInfo -> DataCon pcSpecialDataCon dc_name arg_tys tycon rri @@ -623,6 +633,11 @@ Note [How tuples work] See also Note [Known-key names] in PrelNames between BoxedTuple and ConstraintTuple (same OccName!), so tuples are not serialised into interface files using OccNames at all. +* Serialization to interface files works via the usual mechanism for known-key + things: instead of serializing the OccName we just serialize the key. During + deserialization we lookup the Name associated with the unique with the logic + in KnownUniques. See Note [Symbol table representation of names] for details. + Note [One-tuples] ~~~~~~~~~~~~~~~~~ GHC supports both boxed and unboxed one-tuples: @@ -650,27 +665,51 @@ decl in GHC.Classes, so I think this part may not work properly. But it's unused I think. -} --- | Built in syntax isn't "in scope" so these OccNames map to wired-in Names +-- | Built-in syntax isn't "in scope" so these OccNames map to wired-in Names -- with BuiltInSyntax. However, this should only be necessary while resolving -- names produced by Template Haskell splices since we take care to encode -- built-in syntax names specially in interface files. See -- Note [Symbol table representation of names]. +-- +-- Moreover, there is no need to include names of things that the user can't +-- write (e.g. type representation bindings like $tc(,,,)). isBuiltInOcc_maybe :: OccName -> Maybe Name isBuiltInOcc_maybe occ = case name of "[]" -> Just $ choose_ns listTyConName nilDataConName ":" -> Just consDataConName + "[::]" -> Just parrTyConName + + -- boxed tuple data/tycon "()" -> Just $ tup_name Boxed 0 - "(##)" -> Just $ tup_name Unboxed 0 _ | Just rest <- "(" `stripPrefix` name , (commas, rest') <- BS.span (==',') rest , ")" <- rest' -> Just $ tup_name Boxed (1+BS.length commas) + + -- unboxed tuple data/tycon + "(##)" -> Just $ tup_name Unboxed 0 _ | Just rest <- "(#" `stripPrefix` name , (commas, rest') <- BS.span (==',') rest , "#)" <- rest' -> Just $ tup_name Unboxed (1+BS.length commas) + + -- unboxed sum tycon + _ | Just rest <- "(#" `stripPrefix` name + , (pipes, rest') <- BS.span (=='|') rest + , "#)" <- rest' + -> Just $ tyConName $ sumTyCon (1+BS.length pipes) + + -- unboxed sum datacon + _ | Just rest <- "(#" `stripPrefix` name + , (pipes1, rest') <- BS.span (=='|') rest + , Just rest'' <- "_" `stripPrefix` rest' + , (pipes2, rest''') <- BS.span (=='|') rest'' + , "#)" <- rest''' + -> let arity = BS.length pipes1 + BS.length pipes2 + alt = BS.length pipes1 + 1 + in Just $ dataConName $ sumDataCon alt arity _ -> Nothing where -- TODO: Drop when bytestring 0.10.8 can be assumed @@ -725,7 +764,6 @@ cTupleTyConName :: Arity -> Name cTupleTyConName arity = mkExternalName (mkCTupleTyConUnique arity) gHC_CLASSES (mkCTupleOcc tcName arity) noSrcSpan - -- The corresponding DataCon does not have a known-key name cTupleTyConNames :: [Name] cTupleTyConNames = map cTupleTyConName (0 : [2..mAX_CTUPLE_SIZE]) @@ -740,6 +778,14 @@ isCTupleTyConName n nameModule n == gHC_CLASSES && n `elemNameSet` cTupleTyConNameSet +cTupleDataConName :: Arity -> Name +cTupleDataConName arity + = mkExternalName (mkCTupleDataConUnique arity) gHC_CLASSES + (mkCTupleOcc dataName arity) noSrcSpan + +cTupleDataConNames :: [Name] +cTupleDataConNames = map cTupleDataConName (0 : [2..mAX_CTUPLE_SIZE]) + tupleTyCon :: Boxity -> Arity -> TyCon tupleTyCon sort i | i > mAX_TUPLE_SIZE = fst (mk_tuple sort i) -- Build one specially tupleTyCon Boxed i = fst (boxedTupleArr ! i) diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs index 853f5be149..a12607bd84 100644 --- a/compiler/simplCore/CoreMonad.hs +++ b/compiler/simplCore/CoreMonad.hs @@ -79,6 +79,7 @@ import Maybes import UniqSupply import UniqFM ( UniqFM, mapUFM, filterUFM ) import MonadUtils +import NameCache import SrcLoc import ListSetOps ( runs ) import Data.List diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 8b95c1b876..7b0d34d871 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -816,8 +816,17 @@ checkBootDeclM :: Bool -- ^ True <=> an hs-boot file (could also be a sig) -> TyThing -> TyThing -> TcM () checkBootDeclM is_boot boot_thing real_thing = whenIsJust (checkBootDecl is_boot boot_thing real_thing) $ \ err -> - addErrAt (nameSrcSpan (getName boot_thing)) + addErrAt span (bootMisMatch is_boot err real_thing boot_thing) + where + -- Here we use the span of the boot thing or, if it doesn't have a sensible + -- span, that of the real thing, + span + | let span = nameSrcSpan (getName boot_thing) + , isGoodSrcSpan span + = span + | otherwise + = nameSrcSpan (getName real_thing) -- | Compares the two things for equivalence between boot-file and normal -- code. Returns @Nothing@ on success or @Just "some helpful info for user"@ diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index c3814cd908..61e1ee8cd1 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -29,25 +29,23 @@ module Binary seekBy, tellBin, castBin, + isEOFBin, + withBinBuffer, writeBinMem, readBinMem, - fingerprintBinMem, - computeFingerprint, - - isEOFBin, - putAt, getAt, - -- for writing instances: + -- * For writing instances putByte, getByte, - -- lazy Bin I/O + -- * Lazy Binary I/O lazyGet, lazyPut, + -- * User data UserData(..), getUserData, setUserData, newReadState, newWriteState, putDictionary, getDictionary, putFS, @@ -105,6 +103,17 @@ getUserData bh = bh_usr bh setUserData :: BinHandle -> UserData -> BinHandle setUserData bh us = bh { bh_usr = us } +-- | Get access to the underlying buffer. +-- +-- It is quite important that no references to the 'ByteString' leak out of the +-- continuation lest terrible things happen. +withBinBuffer :: BinHandle -> (ByteString -> IO a) -> IO a +withBinBuffer (BinMem _ ix_r _ arr_r) action = do + arr <- readIORef arr_r + ix <- readFastMutInt ix_r + withForeignPtr arr $ \ptr -> + BS.unsafePackCStringLen (castPtr ptr, ix) >>= action + --------------------------------------------------------------- -- Bin @@ -200,23 +209,6 @@ readBinMem filename = do writeFastMutInt sz_r filesize return (BinMem noUserData ix_r sz_r arr_r) -fingerprintBinMem :: BinHandle -> IO Fingerprint -fingerprintBinMem (BinMem _ ix_r _ arr_r) = do - arr <- readIORef arr_r - ix <- readFastMutInt ix_r - withForeignPtr arr $ \p -> fingerprintData p ix - -computeFingerprint :: Binary a - => (BinHandle -> Name -> IO ()) - -> a - -> IO Fingerprint - -computeFingerprint put_name a = do - bh <- openBinMem (3*1024) -- just less than a block - bh <- return $ setUserData bh $ newWriteState put_name putFS - put_ bh a - fingerprintBinMem bh - -- expand the size of the array to include a specified offset expandBin :: BinHandle -> Int -> IO () expandBin (BinMem _ _ sz_r arr_r) off = do @@ -614,6 +606,25 @@ lazyGet bh = do -- UserData -- ----------------------------------------------------------------------------- +-- | Information we keep around during interface file +-- serialization/deserialization. Namely we keep the functions for serializing +-- and deserializing 'Name's and 'FastString's. We do this because we actually +-- use serialization in two distinct settings, +-- +-- * When serializing interface files themselves +-- +-- * When computing the fingerprint of an IfaceDecl (which we computing by +-- hashing its Binary serialization) +-- +-- These two settings have different needs while serializing Names: +-- +-- * Names in interface files are serialized via a symbol table (see Note +-- [Symbol table representation of names] in BinIface). +-- +-- * During fingerprinting a binding Name is serialized as the OccName and a +-- non-binding Name is serialized as the fingerprint of the thing they +-- represent. See Note [Fingerprinting IfaceDecls] for further discussion. +-- data UserData = UserData { -- for *deserialising* only: @@ -621,27 +632,36 @@ data UserData = ud_get_fs :: BinHandle -> IO FastString, -- for *serialising* only: - ud_put_name :: BinHandle -> Name -> IO (), + ud_put_nonbinding_name :: BinHandle -> Name -> IO (), + -- ^ serialize a non-binding 'Name' (e.g. a reference to another + -- binding). + ud_put_binding_name :: BinHandle -> Name -> IO (), + -- ^ serialize a binding 'Name' (e.g. the name of an IfaceDecl) ud_put_fs :: BinHandle -> FastString -> IO () } -newReadState :: (BinHandle -> IO Name) +newReadState :: (BinHandle -> IO Name) -- ^ how to deserialize 'Name's -> (BinHandle -> IO FastString) -> UserData newReadState get_name get_fs = UserData { ud_get_name = get_name, ud_get_fs = get_fs, - ud_put_name = undef "put_name", + ud_put_nonbinding_name = undef "put_nonbinding_name", + ud_put_binding_name = undef "put_binding_name", ud_put_fs = undef "put_fs" } -newWriteState :: (BinHandle -> Name -> IO ()) +newWriteState :: (BinHandle -> Name -> IO ()) + -- ^ how to serialize non-binding 'Name's + -> (BinHandle -> Name -> IO ()) + -- ^ how to serialize binding 'Name's -> (BinHandle -> FastString -> IO ()) -> UserData -newWriteState put_name put_fs +newWriteState put_nonbinding_name put_binding_name put_fs = UserData { ud_get_name = undef "get_name", ud_get_fs = undef "get_fs", - ud_put_name = put_name, + ud_put_nonbinding_name = put_nonbinding_name, + ud_put_binding_name = put_binding_name, ud_put_fs = put_fs } diff --git a/compiler/utils/Fingerprint.hsc b/compiler/utils/Fingerprint.hsc index ed4cd6fff7..f797654e0c 100644 --- a/compiler/utils/Fingerprint.hsc +++ b/compiler/utils/Fingerprint.hsc @@ -11,19 +11,25 @@ -- ---------------------------------------------------------------------------- module Fingerprint ( - Fingerprint(..), fingerprint0, readHexFingerprint, + fingerprintByteString, + -- * Re-exported from GHC.Fingerprint + Fingerprint(..), fingerprint0, fingerprintData, fingerprintString, - -- Re-exported from GHC.Fingerprint getFileHash ) where #include "md5.h" ##include "HsVersions.h" +import Foreign +import GHC.IO import Numeric ( readHex ) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BS + import GHC.Fingerprint -- useful for parsing the output of 'md5sum', should we want to do that. @@ -32,3 +38,8 @@ readHexFingerprint s = Fingerprint w1 w2 where (s1,s2) = splitAt 16 s [(w1,"")] = readHex s1 [(w2,"")] = readHex (take 16 s2) + +-- this can move to GHC.Fingerprint in GHC 8.6 +fingerprintByteString :: BS.ByteString -> Fingerprint +fingerprintByteString bs = unsafeDupablePerformIO $ + BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> fingerprintData (castPtr ptr) len diff --git a/ghc/Main.hs b/ghc/Main.hs index f8049d668c..79e29b52a6 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -62,7 +62,8 @@ import LoadIface ( loadUserInterface ) import Module ( mkModuleName ) import Finder ( findImportedModule, cannotFindModule ) import TcRnMonad ( initIfaceCheck ) -import Binary ( openBinMem, put_, fingerprintBinMem ) +import Binary ( openBinMem, put_ ) +import BinFingerprint ( fingerprintBinMem ) -- Standard Haskell libraries import System.IO diff --git a/libraries/base/GHC/Fingerprint.hs b/libraries/base/GHC/Fingerprint.hs index 7b7f5c7115..d01128056e 100644 --- a/libraries/base/GHC/Fingerprint.hs +++ b/libraries/base/GHC/Fingerprint.hs @@ -56,7 +56,6 @@ fingerprintData buf len = do c_MD5Final pdigest pctxt peek (castPtr pdigest :: Ptr Fingerprint) --- This is duplicated in compiler/utils/Fingerprint.hsc fingerprintString :: String -> Fingerprint fingerprintString str = unsafeDupablePerformIO $ withArrayLen word8s $ \len p -> diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index cf08465740..c93fe0295e 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -586,7 +586,7 @@ test('T5837', # 2014-12-08: 115905208 Constraint solver perf improvements (esp kick-out) # 2016-04-06: 24199320 (x86/Linux, 64-bit machine) TypeInType - (wordsize(64), 42445672, 10)]) + (wordsize(64), 41832056, 10)]) # sample: 3926235424 (amd64/Linux, 15/2/2012) # 2012-10-02 81879216 # 2012-09-20 87254264 amd64/Linux @@ -606,6 +606,7 @@ test('T5837', # 2016-03-18 48507272 Mac, accept small regression in exchange # for other optimisations # 2016-09-15 42445672 Linux; fixing #12422 + # 2016-09-25 41832056 amd64/Linux, Rework handling of names (D2469) ], compile_fail,['-freduction-depth=50']) diff --git a/testsuite/tests/perf/space_leaks/all.T b/testsuite/tests/perf/space_leaks/all.T index 301029cf58..092bc1bf46 100644 --- a/testsuite/tests/perf/space_leaks/all.T +++ b/testsuite/tests/perf/space_leaks/all.T @@ -64,13 +64,14 @@ test('T4029', # 2016-07-13: 92 (amd64/Linux) Changes to tidyType # 2016-09-01: 71 (amd64/Linux) Restore w/w limit (#11565) stats_num_field('max_bytes_used', - [(wordsize(64), 21648488, 5)]), + [(wordsize(64), 20325248, 5)]), # 2016-02-26: 24071720 (amd64/Linux) INITIAL # 2016-04-21: 25542832 (amd64/Linux) # 2016-05-23: 25247216 (amd64/Linux) Use -G1 # 2016-07-13: 27575416 (amd64/Linux) Changes to tidyType # 2016-07-20: 22920616 (amd64/Linux) Fix laziness of instance matching # 2016-09-01: 21648488 (amd64/Linux) Restore w/w limit (#11565) + # 2016-10-13: 20325248 (amd64/Linux) Creep (downwards, yay!) extra_hc_opts('+RTS -G1 -RTS' ), ], ghci_script, diff --git a/testsuite/tests/typecheck/should_fail/T12035j.stderr b/testsuite/tests/typecheck/should_fail/T12035j.stderr index c05966ea09..7086785d6d 100644 --- a/testsuite/tests/typecheck/should_fail/T12035j.stderr +++ b/testsuite/tests/typecheck/should_fail/T12035j.stderr @@ -1,5 +1,5 @@ -T12035.hs:3:1: error: +T12035.hs-boot:2:1: error: Type constructor âTâ has conflicting definitions in the module and its hs-boot file Main module: type T = Bool diff --git a/utils/haddock b/utils/haddock -Subproject d73b286cb39ad9d02bee4b1a104e817783ceb19 +Subproject a5a51f99f42c7ee5e3bb4aeddf601b5f20a8813 |