Commit 34d933d6 authored by Ben Gamari's avatar Ben Gamari Committed by Ben Gamari

Clean up handling of known-key Names in interface files

Previously BinIface had some dedicated logic for handling tuple names in
the symbol table. As it turns out, this logic was essentially dead code
as it was superceded by the special handling of known-key things. Here
we cull the tuple code-path and use the known-key codepath for all
tuple-ish things.

This had a surprising number of knock-on effects,

 * constraint tuple datacons had to be made known-key (previously they
   were not)

 * IfaceTopBndr was changed from being a synonym of OccName to a
   synonym of Name (since we now need to be able to deserialize Names
   directly from interface files)

 * the change to IfaceTopBndr complicated fingerprinting, since we need
   to ensure that we don't go looking for the fingerprint of the thing
   we are currently fingerprinting in the fingerprint environment (see
   notes in MkIface). Handling this required distinguishing between
   binding and non-binding Name occurrences in the Binary serializers.

 * the original name cache logic which previously lived in IfaceEnv has
   been moved to a new NameCache module

 * I ripped tuples and sums out of knownKeyNames since they introduce a
   very large number of entries. During interface file deserialization
   we use static functions (defined in the new KnownUniques module) to
   map from a Unique to a known-key Name (the Unique better correspond
   to a known-key name!) When we need to do an original name cache
   lookup we rely on the parser implemented in isBuiltInOcc_maybe.

 * HscMain.allKnownKeyNames was folded into PrelInfo.knownKeyNames.

 * Lots of comments were sprinkled about describing the new scheme.

Updates haddock submodule.

Test Plan: Validate

Reviewers: niteria, simonpj, austin, hvr

Reviewed By: simonpj

Subscribers: simonmar, niteria, thomie

Differential Revision: https://phabricator.haskell.org/D2467

GHC Trac Issues: #12532, #12415
parent 1cccb646
......@@ -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
......
......@@ -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
......
module Name where
import {-# SOURCE #-} Module
data Name
nameModule :: Name -> Module
{-# 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
......@@ -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
......
......@@ -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
......
......@@ -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 \
......
{-# 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
......@@ -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