diff options
| author | simonpj@microsoft.com <unknown> | 2009-01-02 14:28:51 +0000 |
|---|---|---|
| committer | simonpj@microsoft.com <unknown> | 2009-01-02 14:28:51 +0000 |
| commit | 9ffadf219cbc4f8ec57264786df936a3cee88aec (patch) | |
| tree | 3749e71fbf549d19e2b47ee615ef11129d0d292a | |
| parent | 24a5fdb5fe20290cbb9b58b2901e8d2fd651d3f3 (diff) | |
| download | haskell-9ffadf219cbc4f8ec57264786df936a3cee88aec.tar.gz | |
Make record selectors into ordinary functions
This biggish patch addresses Trac #2670. The main effect is to make
record selectors into ordinary functions, whose unfoldings appear in
interface files, in contrast to their previous existence as magic
"implicit Ids". This means that the usual machinery of optimisation,
analysis, and inlining applies to them, which was failing before when
the selector was somewhat complicated. (Which it can be when
strictness annotations, unboxing annotations, and GADTs are involved.)
The change involves the following points
* Changes in Var.lhs to the representation of Var. Now a LocalId can
have an IdDetails as well as a GlobalId. In particular, the
information that an Id is a record selector is kept in the
IdDetails. While compiling the current module, the record selector
*must* be a LocalId, so that it participates properly in compilation
(free variables etc).
This led me to change the (hidden) representation of Var, so that there
is now only one constructor for Id, not two.
* The IdDetails is persisted into interface files, so that an
importing module can see which Ids are records selectors.
* In TcTyClDecls, we generate the record-selector bindings in renamed,
but not typechecked form. In this way, we can get the typechecker
to add all the types and so on, which is jolly helpful especially
when GADTs or type families are involved. Just like derived
instance declarations.
This is the big new chunk of 180 lines of code (much of which is
commentary). A call to the same function, mkAuxBinds, is needed in
TcInstDcls for associated types.
* The typechecker therefore has to pin the correct IdDetails on to
the record selector, when it typechecks it. There was a neat way
to do this, by adding a new sort of signature to HsBinds.Sig, namely
IdSig. This contains an Id (with the correct Name, Type, and IdDetails);
the type checker uses it as the binder for the final binding. This
worked out rather easily.
* Record selectors are no longer "implicit ids", which entails changes to
IfaceSyn.ifaceDeclSubBndrs
HscTypes.implicitTyThings
TidyPgm.getImplicitBinds
(These three functions must agree.)
* MkId.mkRecordSelectorId is deleted entirely, some 300+ lines (incl
comments) of very error prone code. Happy days.
* A TyCon no longer contains the list of record selectors:
algTcSelIds is gone
The renamer is unaffected, including the way that import and export of
record selectors is handled.
Other small things
* IfaceSyn.ifaceDeclSubBndrs had a fragile test for whether a data
constructor had a wrapper. I've replaced that with an explicit flag
in the interface file. More robust I hope.
* I renamed isIdVar to isId, which touched a few otherwise-unrelated files.
40 files changed, 803 insertions, 929 deletions
diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index df8af8e221..d8fdfb55ae 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -318,7 +318,6 @@ data DataCon dcOrigArgTys :: [Type], -- Original argument types -- (before unboxing and flattening of strict fields) dcOrigResTy :: Type, -- Original result type, as seen by the user - -- INVARIANT: mentions only dcUnivTyVars -- NB: for a data instance, the original user result type may -- differ from the DataCon's representation TyCon. Example -- data instance T [a] where MkT :: a -> T [a] @@ -636,8 +635,10 @@ dataConFieldLabels = dcFields -- | Extract the type for any given labelled field of the 'DataCon' dataConFieldType :: DataCon -> FieldLabel -> Type -dataConFieldType con label = expectJust "unexpected label" $ - lookup label (dcFields con `zip` dcOrigArgTys con) +dataConFieldType con label + = case lookup label (dcFields con `zip` dcOrigArgTys con) of + Just ty -> ty + Nothing -> pprPanic "dataConFieldType" (ppr con <+> ppr label) -- | The strictness markings decided on by the compiler. Does not include those for -- existential dictionaries. The list is in one-to-one correspondence with the arity of the 'DataCon' @@ -726,7 +727,7 @@ dataConUserType :: DataCon -> Type -- -- rather than: -- --- > T :: forall a c. forall b. (c=[a]) => a -> b -> T c +-- > T :: forall a c. forall b. (c~[a]) => a -> b -> T c -- -- NB: If the constructor is part of a data instance, the result type -- mentions the family tycon, not the internal one. diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs index d87e45b811..74fd2cffef 100644 --- a/compiler/basicTypes/Id.lhs +++ b/compiler/basicTypes/Id.lhs @@ -27,14 +27,14 @@ module Id ( -- ** Simple construction mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo, - mkLocalId, mkLocalIdWithInfo, + mkLocalId, mkLocalIdWithInfo, mkExportedLocalId, mkSysLocal, mkSysLocalM, mkUserLocal, mkUserLocalM, mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal, - mkWorkerId, mkExportedLocalId, + mkWorkerId, -- ** Taking an Id apart - idName, idType, idUnique, idInfo, - isId, globalIdDetails, idPrimRep, + idName, idType, idUnique, idInfo, idDetails, + isId, idPrimRep, recordSelectorFieldLabel, -- ** Modifying an Id @@ -104,8 +104,13 @@ import CoreSyn ( CoreRule, Unfolding ) import IdInfo import BasicTypes + +-- Imported and re-exported +import Var( Id, DictId, + idInfo, idDetails, globaliseId, + isId, isLocalId, isGlobalId, isExportedId ) import qualified Var -import Var + import TyCon import Type import TcType @@ -156,26 +161,19 @@ idName :: Id -> Name idName = Var.varName idUnique :: Id -> Unique -idUnique = varUnique +idUnique = Var.varUnique idType :: Id -> Kind -idType = varType - -idInfo :: Id -> IdInfo -idInfo = varIdInfo +idType = Var.varType idPrimRep :: Id -> PrimRep idPrimRep id = typePrimRep (idType id) -globalIdDetails :: Id -> GlobalIdDetails -globalIdDetails = globalIdVarDetails - - setIdName :: Id -> Name -> Id -setIdName = setVarName +setIdName = Var.setVarName setIdUnique :: Id -> Unique -> Id -setIdUnique = setVarUnique +setIdUnique = Var.setVarUnique -- | Not only does this set the 'Id' 'Type', it also evaluates the type to try and -- reduce space usage @@ -183,10 +181,10 @@ setIdType :: Id -> Type -> Id setIdType id ty = seqType ty `seq` Var.setVarType id ty setIdExported :: Id -> Id -setIdExported = setIdVarExported +setIdExported = Var.setIdExported setIdNotExported :: Id -> Id -setIdNotExported = setIdVarNotExported +setIdNotExported = Var.setIdNotExported localiseId :: Id -> Id -- Make an with the same unique and type as the @@ -199,11 +197,8 @@ localiseId id where name = idName id -globaliseId :: GlobalIdDetails -> Id -> Id -globaliseId = globaliseIdVar - lazySetIdInfo :: Id -> IdInfo -> Id -lazySetIdInfo = lazySetVarIdInfo +lazySetIdInfo = Var.lazySetIdInfo setIdInfo :: Id -> IdInfo -> Id setIdInfo id info = seqIdInfo info `seq` (lazySetIdInfo id info) @@ -240,8 +235,8 @@ Anyway, we removed it in March 2008. \begin{code} -- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal" -mkGlobalId :: GlobalIdDetails -> Name -> Type -> IdInfo -> Id -mkGlobalId = mkGlobalIdVar +mkGlobalId :: IdDetails -> Name -> Type -> IdInfo -> Id +mkGlobalId = Var.mkGlobalVar -- | Make a global 'Id' without any extra information at all mkVanillaGlobal :: Name -> Type -> Id @@ -249,7 +244,7 @@ mkVanillaGlobal name ty = mkVanillaGlobalWithInfo name ty vanillaIdInfo -- | Make a global 'Id' with no global information but some generic 'IdInfo' mkVanillaGlobalWithInfo :: Name -> Type -> IdInfo -> Id -mkVanillaGlobalWithInfo = mkGlobalId VanillaGlobal +mkVanillaGlobalWithInfo = mkGlobalId VanillaId -- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal" @@ -257,16 +252,18 @@ mkLocalId :: Name -> Type -> Id mkLocalId name ty = mkLocalIdWithInfo name ty vanillaIdInfo mkLocalIdWithInfo :: Name -> Type -> IdInfo -> Id -mkLocalIdWithInfo = mkLocalIdVar +mkLocalIdWithInfo name ty info = Var.mkLocalVar VanillaId name ty info -- Note [Free type variables] --- | Create a local 'Id' that is marked as exported. This prevents things attached to it from being removed as dead code. +-- | Create a local 'Id' that is marked as exported. +-- This prevents things attached to it from being removed as dead code. mkExportedLocalId :: Name -> Type -> Id -mkExportedLocalId name ty = mkExportedLocalIdVar name ty vanillaIdInfo +mkExportedLocalId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo -- Note [Free type variables] --- | Create a system local 'Id'. These are local 'Id's (see "Var#globalvslocal") that are created by the compiler out of thin air +-- | Create a system local 'Id'. These are local 'Id's (see "Var#globalvslocal") +-- that are created by the compiler out of thin air mkSysLocal :: FastString -> Unique -> Type -> Id mkSysLocal fs uniq ty = mkLocalId (mkSystemVarName uniq fs) ty @@ -311,29 +308,6 @@ mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys %************************************************************************ %* * -\subsection{Basic predicates on @Id@s} -%* * -%************************************************************************ - -\begin{code} -isId :: Id -> Bool -isId = isIdVar - --- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal" -isLocalId :: Id -> Bool -isLocalId = isLocalIdVar - --- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal" -isGlobalId :: Id -> Bool -isGlobalId = isGlobalIdVar - --- | Determines whether an 'Id' is marked as exported and hence will not be considered dead code -isExportedId :: Id -> Bool -isExportedId = isExportedIdVar -\end{code} - -%************************************************************************ -%* * \subsection{Special Ids} %* * %************************************************************************ @@ -342,8 +316,8 @@ isExportedId = isExportedIdVar -- | If the 'Id' is that for a record selector, extract the 'sel_tycon' and label. Panic otherwise recordSelectorFieldLabel :: Id -> (TyCon, FieldLabel) recordSelectorFieldLabel id - = case globalIdDetails id of - RecordSelId { sel_tycon = tycon, sel_label = lbl } -> (tycon,lbl) + = case Var.idDetails id of + RecSelId { sel_tycon = tycon } -> (tycon, idName id) _ -> panic "recordSelectorFieldLabel" isRecordSelector :: Id -> Bool @@ -357,44 +331,44 @@ isPrimOpId_maybe :: Id -> Maybe PrimOp isFCallId_maybe :: Id -> Maybe ForeignCall isDataConWorkId_maybe :: Id -> Maybe DataCon -isRecordSelector id = case globalIdDetails id of - RecordSelId {} -> True +isRecordSelector id = case Var.idDetails id of + RecSelId {} -> True _ -> False -isNaughtyRecordSelector id = case globalIdDetails id of - RecordSelId { sel_naughty = n } -> n +isNaughtyRecordSelector id = case Var.idDetails id of + RecSelId { sel_naughty = n } -> n _ -> False -isClassOpId_maybe id = case globalIdDetails id of +isClassOpId_maybe id = case Var.idDetails id of ClassOpId cls -> Just cls _other -> Nothing -isPrimOpId id = case globalIdDetails id of +isPrimOpId id = case Var.idDetails id of PrimOpId _ -> True _ -> False -isPrimOpId_maybe id = case globalIdDetails id of +isPrimOpId_maybe id = case Var.idDetails id of PrimOpId op -> Just op _ -> Nothing -isFCallId id = case globalIdDetails id of +isFCallId id = case Var.idDetails id of FCallId _ -> True _ -> False -isFCallId_maybe id = case globalIdDetails id of +isFCallId_maybe id = case Var.idDetails id of FCallId call -> Just call _ -> Nothing -isDataConWorkId id = case globalIdDetails id of +isDataConWorkId id = case Var.idDetails id of DataConWorkId _ -> True _ -> False -isDataConWorkId_maybe id = case globalIdDetails id of +isDataConWorkId_maybe id = case Var.idDetails id of DataConWorkId con -> Just con _ -> Nothing isDataConId_maybe :: Id -> Maybe DataCon -isDataConId_maybe id = case globalIdDetails id of +isDataConId_maybe id = case Var.idDetails id of DataConWorkId con -> Just con DataConWrapId con -> Just con _ -> Nothing @@ -417,7 +391,7 @@ hasNoBinding :: Id -> Bool -- they aren't any more. Instead, we inject a binding for -- them at the CorePrep stage. -- EXCEPT: unboxed tuples, which definitely have no binding -hasNoBinding id = case globalIdDetails id of +hasNoBinding id = case Var.idDetails id of PrimOpId _ -> True -- See Note [Primop wrappers] FCallId _ -> True DataConWorkId dc -> isUnboxedTupleCon dc @@ -428,11 +402,10 @@ isImplicitId :: Id -> Bool -- declarations, so we don't need to put its signature in an interface -- file, even if it's mentioned in some other interface unfolding. isImplicitId id - = case globalIdDetails id of - RecordSelId {} -> True + = case Var.idDetails id of FCallId _ -> True + ClassOpId _ -> True PrimOpId _ -> True - ClassOpId _ -> True DataConWorkId _ -> True DataConWrapId _ -> True -- These are are implied by their type or class decl; @@ -469,13 +442,13 @@ isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr) \begin{code} isTickBoxOp :: Id -> Bool isTickBoxOp id = - case globalIdDetails id of + case Var.idDetails id of TickBoxOpId _ -> True _ -> False isTickBoxOp_maybe :: Id -> Maybe TickBoxOp isTickBoxOp_maybe id = - case globalIdDetails id of + case Var.idDetails id of TickBoxOpId tick -> Just tick _ -> Nothing \end{code} diff --git a/compiler/basicTypes/IdInfo.lhs b/compiler/basicTypes/IdInfo.lhs index 26fe4531ae..07cc181349 100644 --- a/compiler/basicTypes/IdInfo.lhs +++ b/compiler/basicTypes/IdInfo.lhs @@ -9,8 +9,8 @@ Haskell. [WDP 94/11]) \begin{code} module IdInfo ( - -- * The GlobalIdDetails type - GlobalIdDetails(..), notGlobalId, -- Not abstract + -- * The IdDetails type + IdDetails(..), pprIdDetails, -- * The IdInfo type IdInfo, -- Abstract @@ -234,31 +234,23 @@ seqNewDemandInfo (Just dmd) = seqDemand dmd %************************************************************************ %* * -\subsection{GlobalIdDetails} + IdDetails %* * %************************************************************************ -This type is here (rather than in Id.lhs) mainly because there's -an IdInfo.hi-boot, but no Id.hi-boot, and GlobalIdDetails is imported -(recursively) by Var.lhs. - \begin{code} --- | Information pertaining to global 'Id's. See "Var#globalvslocal" for the distinction --- between global and local in this context -data GlobalIdDetails - = VanillaGlobal -- ^ The 'Id' is imported from elsewhere or is a default method 'Id' +-- | The 'IdDetails' of an 'Id' give stable, and necessary, +-- information about the Id. +data IdDetails + = VanillaId -- | The 'Id' for a record selector - | RecordSelId + | RecSelId { sel_tycon :: TyCon -- ^ For a data type family, this is the /instance/ 'TyCon' -- not the family 'TyCon' - , sel_label :: FieldLabel , sel_naughty :: Bool -- True <=> a "naughty" selector which can't actually exist, for example @x@ in: - -- - -- > data T = forall a. MkT { x :: a } - } - -- See Note [Naughty record selectors] - -- with MkId.mkRecordSelectorId + -- data T = forall a. MkT { x :: a } + } -- See Note [Naughty record selectors] in TcTyClsDecls | DataConWorkId DataCon -- ^ The 'Id' is for a data constructor /worker/ | DataConWrapId DataCon -- ^ The 'Id' is for a data constructor /wrapper/ @@ -275,25 +267,29 @@ data GlobalIdDetails | TickBoxOpId TickBoxOp -- ^ The 'Id' is for a HPC tick box (both traditional and binary) - | NotGlobalId -- ^ Used as a convenient extra return value from 'globalIdDetails' - --- | An entirely unhelpful 'GlobalIdDetails' -notGlobalId :: GlobalIdDetails -notGlobalId = NotGlobalId - -instance Outputable GlobalIdDetails where - ppr NotGlobalId = ptext (sLit "[***NotGlobalId***]") - ppr VanillaGlobal = ptext (sLit "[GlobalId]") - ppr (DataConWorkId _) = ptext (sLit "[DataCon]") - ppr (DataConWrapId _) = ptext (sLit "[DataConWrapper]") - ppr (ClassOpId _) = ptext (sLit "[ClassOp]") - ppr (PrimOpId _) = ptext (sLit "[PrimOp]") - ppr (FCallId _) = ptext (sLit "[ForeignCall]") - ppr (TickBoxOpId _) = ptext (sLit "[TickBoxOp]") - ppr (RecordSelId {}) = ptext (sLit "[RecSel]") + | DFunId -- ^ A dictionary function. We don't use this in an essential way, + -- currently, but it's kind of nice that we can keep track of + -- which Ids are DFuns, across module boundaries too + + +instance Outputable IdDetails where + ppr = pprIdDetails + +pprIdDetails :: IdDetails -> SDoc +pprIdDetails VanillaId = empty +pprIdDetails (RecSelId {}) = ptext (sLit "[RecSel]") +pprIdDetails (DataConWorkId _) = ptext (sLit "[DataCon]") +pprIdDetails (DataConWrapId _) = ptext (sLit "[DataConWrapper]") +pprIdDetails (ClassOpId _) = ptext (sLit "[ClassOp]") +pprIdDetails (PrimOpId _) = ptext (sLit "[PrimOp]") +pprIdDetails (FCallId _) = ptext (sLit "[ForeignCall]") +pprIdDetails (TickBoxOpId _) = ptext (sLit "[TickBoxOp]") +pprIdDetails DFunId = ptext (sLit "[DFunId]") \end{code} + + %************************************************************************ %* * \subsection{The main IdInfo type} diff --git a/compiler/basicTypes/IdInfo.lhs-boot b/compiler/basicTypes/IdInfo.lhs-boot index 90cf36f90b..4195156f27 100644 --- a/compiler/basicTypes/IdInfo.lhs-boot +++ b/compiler/basicTypes/IdInfo.lhs-boot @@ -1,9 +1,8 @@ \begin{code} module IdInfo where - +import Outputable data IdInfo -data GlobalIdDetails +data IdDetails -notGlobalId :: GlobalIdDetails -seqIdInfo :: IdInfo -> () +pprIdDetails :: IdDetails -> SDoc \end{code}
\ No newline at end of file diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index be838351ba..1fe712b285 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -24,7 +24,6 @@ module MkId ( mkDictSelId, mkDataConIds, - mkRecordSelId, mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId, mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody, @@ -39,7 +38,7 @@ module MkId ( mkRuntimeErrorApp, rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, - pAT_ERROR_ID, eRROR_ID, + pAT_ERROR_ID, eRROR_ID, rEC_SEL_ERROR_ID, unsafeCoerceName ) where @@ -50,7 +49,6 @@ import Rules import TysPrim import TysWiredIn import PrelRules -import Unify import Type import TypeRep import Coercion @@ -67,10 +65,9 @@ import PrimOp import ForeignCall import DataCon import Id -import Var ( Var, TyVar, mkCoVar) +import Var ( Var, TyVar, mkCoVar, mkExportedLocalVar ) import IdInfo import NewDemand -import DmdAnal import CoreSyn import Unique import Maybes @@ -113,6 +110,7 @@ wiredInIds nO_METHOD_BINDING_ERROR_ID, pAT_ERROR_ID, rEC_CON_ERROR_ID, + rEC_SEL_ERROR_ID, lazyId ] ++ ghcPrimIds @@ -280,24 +278,14 @@ mkDataConIds wrap_name wkr_name data_con nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo `setArityInfo` 1 -- Arity 1 `setUnfoldingInfo` newtype_unf - newtype_unf = -- The assertion below is no longer correct: - -- there may be a dict theta rather than a singleton orig_arg_ty - -- ASSERT( isVanillaDataCon data_con && - -- isSingleton orig_arg_tys ) - -- - -- No existentials on a newtype, but it can have a context - -- e.g. newtype Eq a => T a = MkT (...) + id_arg1 = mkTemplateLocal 1 (head orig_arg_tys) + newtype_unf = ASSERT2( isVanillaDataCon data_con && + isSingleton orig_arg_tys, ppr data_con ) + -- Note [Newtype datacons] mkCompulsoryUnfolding $ mkLams wrap_tvs $ Lam id_arg1 $ - wrapNewTypeBody tycon res_ty_args - (Var id_arg1) + wrapNewTypeBody tycon res_ty_args (Var id_arg1) - id_arg1 = mkTemplateLocal 1 - (if null orig_arg_tys - then ASSERT(not (null $ dataConDictTheta data_con)) - mkPredTy $ head (dataConDictTheta data_con) - else head orig_arg_tys - ) ----------- Wrapper -------------- -- We used to include the stupid theta in the wrapper's args @@ -396,301 +384,106 @@ mkLocals i tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n) n = length tys \end{code} +Note [Newtype datacons] +~~~~~~~~~~~~~~~~~~~~~~~ +The "data constructor" for a newtype should always be vanilla. At one +point this wasn't true, because the newtype arising from + class C a => D a +looked like + newtype T:D a = D:D (C a) +so the data constructor for T:C had a single argument, namely the +predicate (C a). But now we treat that as an ordinary argument, not +part of the theta-type, so all is well. + %************************************************************************ %* * -\subsection{Record selectors} +\subsection{Dictionary selectors} %* * %************************************************************************ -We're going to build a record selector unfolding that looks like this: - - data T a b c = T1 { ..., op :: a, ...} - | T2 { ..., op :: a, ...} - | T3 - - sel = /\ a b c -> \ d -> case d of - T1 ... x ... -> x - T2 ... x ... -> x - other -> error "..." - -Similarly for newtypes - - newtype N a = MkN { unN :: a->a } - - unN :: N a -> a -> a - unN n = coerce (a->a) n - -We need to take a little care if the field has a polymorphic type: - - data R = R { f :: forall a. a->a } - -Then we want - - f :: forall a. R -> a -> a - f = /\ a \ r = case r of - R f -> f a - -(not f :: R -> forall a. a->a, which gives the type inference mechanism -problems at call sites) - -Similarly for (recursive) newtypes - - newtype N = MkN { unN :: forall a. a->a } - - unN :: forall b. N -> b -> b - unN = /\b -> \n:N -> (coerce (forall a. a->a) n) - +Selecting a field for a dictionary. If there is just one field, then +there's nothing to do. -Note [Naughty record selectors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A "naughty" field is one for which we can't define a record -selector, because an existential type variable would escape. For example: - data T = forall a. MkT { x,y::a } -We obviously can't define - x (MkT v _) = v -Nevertheless we *do* put a RecordSelId into the type environment -so that if the user tries to use 'x' as a selector we can bleat -helpfully, rather than saying unhelpfully that 'x' is not in scope. -Hence the sel_naughty flag, to identify record selectors that don't really exist. +Dictionary selectors may get nested forall-types. Thus: -In general, a field is naughty if its type mentions a type variable that -isn't in the result type of the constructor. + class Foo a where + op :: forall b. Ord b => a -> b -> b -Note [GADT record selectors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For GADTs, we require that all constructors with a common field 'f' have the same -result type (modulo alpha conversion). [Checked in TcTyClsDecls.checkValidTyCon] -E.g. - data T where - T1 { f :: Maybe a } :: T [a] - T2 { f :: Maybe a, y :: b } :: T [a] +Then the top-level type for op is -and now the selector takes that result type as its argument: - f :: forall a. T [a] -> Maybe a + op :: forall a. Foo a => + forall b. Ord b => + a -> b -> b -Details: the "real" types of T1,T2 are: - T1 :: forall r a. (r~[a]) => a -> T r - T2 :: forall r a b. (r~[a]) => a -> b -> T r +This is unlike ordinary record selectors, which have all the for-alls +at the outside. When dealing with classes it's very convenient to +recover the original type signature from the class op selector. -So the selector loooks like this: - f :: forall a. T [a] -> Maybe a - f (a:*) (t:T [a]) - = case t of - T1 c (g:[a]~[c]) (v:Maybe c) -> v `cast` Maybe (right (sym g)) - T2 c d (g:[a]~[c]) (v:Maybe c) (w:d) -> v `cast` Maybe (right (sym g)) +\begin{code} +mkDictSelId :: Bool -- True <=> don't include the unfolding + -- Little point on imports without -O, because the + -- dictionary itself won't be visible + -> Name -> Class -> Id +mkDictSelId no_unf name clas + = mkGlobalId (ClassOpId clas) name sel_ty info + where + sel_ty = mkForAllTys tyvars (mkFunTy (idType dict_id) (idType the_arg_id)) + -- We can't just say (exprType rhs), because that would give a type + -- C a -> C a + -- for a single-op class (after all, the selector is the identity) + -- But it's type must expose the representation of the dictionary + -- to get (say) C a -> (a -> a) -Note the forall'd tyvars of the selector are just the free tyvars -of the result type; there may be other tyvars in the constructor's -type (e.g. 'b' in T2). + info = noCafIdInfo + `setArityInfo` 1 + `setAllStrictnessInfo` Just strict_sig + `setUnfoldingInfo` (if no_unf then noUnfolding + else mkImplicitUnfolding rhs) -Note the need for casts in the result! + -- We no longer use 'must-inline' on record selectors. They'll + -- inline like crazy if they scrutinise a constructor -Note [Selector running example] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's OK to combine GADTs and type families. Here's a running example: + -- The strictness signature is of the form U(AAAVAAAA) -> T + -- where the V depends on which item we are selecting + -- It's worth giving one, so that absence info etc is generated + -- even if the selector isn't inlined + strict_sig = mkStrictSig (mkTopDmdType [arg_dmd] TopRes) + arg_dmd | isNewTyCon tycon = evalDmd + | otherwise = Eval (Prod [ if the_arg_id == id then evalDmd else Abs + | id <- arg_ids ]) - data instance T [a] where - T1 { fld :: b } :: T [Maybe b] + tycon = classTyCon clas + [data_con] = tyConDataCons tycon + tyvars = dataConUnivTyVars data_con + arg_tys = {- ASSERT( isVanillaDataCon data_con ) -} dataConRepArgTys data_con + eq_theta = dataConEqTheta data_con + the_arg_id = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` arg_ids) name -The representation type looks like this - data :R7T a where - T1 { fld :: b } :: :R7T (Maybe b) + pred = mkClassPred clas (mkTyVarTys tyvars) + dict_id = mkTemplateLocal 1 $ mkPredTy pred + (eq_ids,n) = mkCoVarLocals 2 $ mkPredTys eq_theta + arg_ids = mkTemplateLocalsNum n arg_tys -and there's coercion from the family type to the representation type - :CoR7T a :: T [a] ~ :R7T a + mkCoVarLocals i [] = ([],i) + mkCoVarLocals i (x:xs) = let (ys,j) = mkCoVarLocals (i+1) xs + y = mkCoVar (mkSysTvName (mkBuiltinUnique i) (fsLit "dc_co")) x + in (y:ys,j) -The selector we want for fld looks like this: + rhs = mkLams tyvars (Lam dict_id rhs_body) + rhs_body | isNewTyCon tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id) + | otherwise = Case (Var dict_id) dict_id (idType the_arg_id) + [(DataAlt data_con, eq_ids ++ arg_ids, Var the_arg_id)] +\end{code} - fld :: forall b. T [Maybe b] -> b - fld = /\b. \(d::T [Maybe b]). - case d `cast` :CoR7T (Maybe b) of - T1 (x::b) -> x -The scrutinee of the case has type :R7T (Maybe b), which can be -gotten by appying the eq_spec to the univ_tvs of the data con. +%************************************************************************ +%* * + Boxing and unboxing +%* * +%************************************************************************ \begin{code} -mkRecordSelId :: TyCon -> FieldLabel -> Id -mkRecordSelId tycon field_label - -- Assumes that all fields with the same field label have the same type - = sel_id - where - -- Because this function gets called by implicitTyThings, we need to - -- produce the OccName of the Id without doing any suspend type checks. - -- (see the note [Tricky iface loop]). - -- A suspended type-check is sometimes necessary to compute field_ty, - -- so we need to make sure that we suspend anything that depends on field_ty. - - -- the overall result - sel_id = mkGlobalId sel_id_details field_label theType theInfo - - -- check whether the type is naughty: this thunk does not get forced - -- until the type is actually needed - field_ty = dataConFieldType con1 field_label - is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tv_set) - - -- it's important that this doesn't force the if - (theType, theInfo) = if is_naughty - -- Escapist case here for naughty constructors - -- We give it no IdInfo, and a type of - -- forall a.a (never looked at) - then (forall_a_a, noCafIdInfo) - -- otherwise do the real case - else (selector_ty, info) - - sel_id_details = RecordSelId { sel_tycon = tycon, - sel_label = field_label, - sel_naughty = is_naughty } - -- For a data type family, the tycon is the *instance* TyCon - - -- for naughty case - forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar) - - -- real case starts here: - data_cons = tyConDataCons tycon - data_cons_w_field = filter has_field data_cons -- Can't be empty! - has_field con = field_label `elem` dataConFieldLabels con - - con1 = ASSERT( not (null data_cons_w_field) ) head data_cons_w_field - (univ_tvs, _, eq_spec, _, _, _, data_ty) = dataConFullSig con1 - -- For a data type family, the data_ty (and hence selector_ty) mentions - -- only the family TyCon, not the instance TyCon - data_tv_set = tyVarsOfType data_ty - data_tvs = varSetElems data_tv_set - - -- _Very_ tiresomely, the selectors are (unnecessarily!) overloaded over - -- just the dictionaries in the types of the constructors that contain - -- the relevant field. [The Report says that pattern matching on a - -- constructor gives the same constraints as applying it.] Urgh. - -- - -- However, not all data cons have all constraints (because of - -- BuildTyCl.mkDataConStupidTheta). So we need to find all the data cons - -- involved in the pattern match and take the union of their constraints. - stupid_dict_tys = mkPredTys (dataConsStupidTheta data_cons_w_field) - n_stupid_dicts = length stupid_dict_tys - - (field_tyvars,pre_field_theta,field_tau) = tcSplitSigmaTy field_ty - field_theta = filter (not . isEqPred) pre_field_theta - field_dict_tys = mkPredTys field_theta - n_field_dict_tys = length field_dict_tys - -- If the field has a universally quantified type we have to - -- be a bit careful. Suppose we have - -- data R = R { op :: forall a. Foo a => a -> a } - -- Then we can't give op the type - -- op :: R -> forall a. Foo a => a -> a - -- because the typechecker doesn't understand foralls to the - -- right of an arrow. The "right" type to give it is - -- op :: forall a. Foo a => R -> a -> a - -- But then we must generate the right unfolding too: - -- op = /\a -> \dfoo -> \ r -> - -- case r of - -- R op -> op a dfoo - -- Note that this is exactly the type we'd infer from a user defn - -- op (R op) = op - - selector_ty :: Type - selector_ty = mkForAllTys data_tvs $ mkForAllTys field_tyvars $ - mkFunTys stupid_dict_tys $ mkFunTys field_dict_tys $ - mkFunTy data_ty field_tau - - arity = 1 + n_stupid_dicts + n_field_dict_tys - - (strict_sig, rhs_w_str) = dmdAnalTopRhs sel_rhs - -- Use the demand analyser to work out strictness. - -- With all this unpackery it's not easy! - - info = noCafIdInfo - `setCafInfo` caf_info - `setArityInfo` arity - `setUnfoldingInfo` unfolding - `setAllStrictnessInfo` Just strict_sig - - unfolding = mkImplicitUnfolding rhs_w_str - - -- Allocate Ids. We do it a funny way round because field_dict_tys is - -- almost always empty. Also note that we use max_dict_tys - -- rather than n_dict_tys, because the latter gives an infinite loop: - -- n_dict tys depends on the_alts, which depens on arg_ids, which - -- depends on arity, which depends on n_dict tys. Sigh! Mega sigh! - stupid_dict_ids = mkTemplateLocalsNum 1 stupid_dict_tys - max_stupid_dicts = length (tyConStupidTheta tycon) - field_dict_base = max_stupid_dicts + 1 - field_dict_ids = mkTemplateLocalsNum field_dict_base field_dict_tys - dict_id_base = field_dict_base + n_field_dict_tys - data_id = mkTemplateLocal dict_id_base data_ty - scrut_id = mkTemplateLocal (dict_id_base+1) scrut_ty - arg_base = dict_id_base + 2 - - the_alts :: [CoreAlt] - the_alts = map mk_alt data_cons_w_field -- Already sorted by data-con - no_default = length data_cons == length data_cons_w_field -- No default needed - - default_alt | no_default = [] - | otherwise = [(DEFAULT, [], error_expr)] - - -- The default branch may have CAF refs, because it calls recSelError etc. - caf_info | no_default = NoCafRefs - | otherwise = MayHaveCafRefs - - sel_rhs = mkLams data_tvs $ mkLams field_tyvars $ - mkLams stupid_dict_ids $ mkLams field_dict_ids $ - Lam data_id $ mk_result sel_body - - scrut_ty_args = substTyVars (mkTopTvSubst eq_spec) univ_tvs - scrut_ty = mkTyConApp tycon scrut_ty_args - scrut = unwrapFamInstScrut tycon scrut_ty_args (Var data_id) - -- First coerce from the type family to the representation type - - -- NB: A newtype always has a vanilla DataCon; no existentials etc - -- data_tys will simply be the dataConUnivTyVars - sel_body | isNewTyCon tycon = unwrapNewTypeBody tycon scrut_ty_args scrut - | otherwise = Case scrut scrut_id field_ty (default_alt ++ the_alts) - - mk_result poly_result = mkVarApps (mkVarApps poly_result field_tyvars) field_dict_ids - -- We pull the field lambdas to the top, so we need to - -- apply them in the body. For example: - -- data T = MkT { foo :: forall a. a->a } - -- - -- foo :: forall a. T -> a -> a - -- foo = /\a. \t:T. case t of { MkT f -> f a } - - mk_alt data_con - = mkReboxingAlt rebox_uniqs data_con (ex_tvs ++ co_tvs ++ arg_vs) rhs - where - -- get pattern binders with types appropriately instantiated - arg_uniqs = map mkBuiltinUnique [arg_base..] - (ex_tvs, co_tvs, arg_vs) = dataConOrigInstPat arg_uniqs data_con - scrut_ty_args - - rebox_base = arg_base + length ex_tvs + length co_tvs + length arg_vs - rebox_uniqs = map mkBuiltinUnique [rebox_base..] - - -- data T :: *->* where T1 { fld :: Maybe b } -> T [b] - -- Hence T1 :: forall a b. (a~[b]) => b -> T a - -- fld :: forall b. T [b] -> Maybe b - -- fld = /\b.\(t:T[b]). case t of - -- T1 b' (c : [b]=[b']) (x:Maybe b') - -- -> x `cast` Maybe (sym (right c)) - - -- Generate the cast for the result - -- See Note [GADT record selectors] for why a cast is needed - in_scope_tvs = ex_tvs ++ co_tvs ++ data_tvs - reft = matchRefine in_scope_tvs (map (mkSymCoercion . mkTyVarTy) co_tvs) - rhs = case refineType reft (idType the_arg_id) of - Nothing -> Var the_arg_id - Just (co, data_ty) -> ASSERT2( data_ty `tcEqType` field_ty, - ppr data_con $$ ppr data_ty $$ ppr field_ty ) - Cast (Var the_arg_id) co - - field_vs = filter (not . isPredTy . idType) arg_vs - the_arg_id = assoc "mkRecordSelId:mk_alt" - (field_lbls `zip` field_vs) field_label - field_lbls = dataConFieldLabels data_con - - error_expr = mkRuntimeErrorApp rEC_SEL_ERROR_ID field_ty full_msg - full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id]) - -- unbox a product type... -- we will recurse into newtypes, casting along the way, and unbox at the -- first product data constructor we find. e.g. @@ -824,87 +617,6 @@ mkReboxingAlt us con args rhs %************************************************************************ %* * -\subsection{Dictionary selectors} -%* * -%************************************************************************ - -Selecting a field for a dictionary. If there is just one field, then -there's nothing to do. - -Dictionary selectors may get nested forall-types. Thus: - - class Foo a where - op :: forall b. Ord b => a -> b -> b - -Then the top-level type for op is - - op :: forall a. Foo a => - forall b. Ord b => - a -> b -> b - -This is unlike ordinary record selectors, which have all the for-alls -at the outside. When dealing with classes it's very convenient to -recover the original type signature from the class op selector. - -\begin{code} -mkDictSelId :: Bool -- True <=> don't include the unfolding - -- Little point on imports without -O, because the - -- dictionary itself won't be visible - -> Name -> Class -> Id -mkDictSelId no_unf name clas - = mkGlobalId (ClassOpId clas) name sel_ty info - where - sel_ty = mkForAllTys tyvars (mkFunTy (idType dict_id) (idType the_arg_id)) - -- We can't just say (exprType rhs), because that would give a type - -- C a -> C a - -- for a single-op class (after all, the selector is the identity) - -- But it's type must expose the representation of the dictionary - -- to get (say) C a -> (a -> a) - - info = noCafIdInfo - `setArityInfo` 1 - `setAllStrictnessInfo` Just strict_sig - `setUnfoldingInfo` (if no_unf then noUnfolding - else mkImplicitUnfolding rhs) - - -- We no longer use 'must-inline' on record selectors. They'll - -- inline like crazy if they scrutinise a constructor - - -- The strictness signature is of the form U(AAAVAAAA) -> T - -- where the V depends on which item we are selecting - -- It's worth giving one, so that absence info etc is generated - -- even if the selector isn't inlined - strict_sig = mkStrictSig (mkTopDmdType [arg_dmd] TopRes) - arg_dmd | isNewTyCon tycon = evalDmd - | otherwise = Eval (Prod [ if the_arg_id == id then evalDmd else Abs - | id <- arg_ids ]) - - tycon = classTyCon clas - [data_con] = tyConDataCons tycon - tyvars = dataConUnivTyVars data_con - arg_tys = {- ASSERT( isVanillaDataCon data_con ) -} dataConRepArgTys data_con - eq_theta = dataConEqTheta data_con - the_arg_id = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` arg_ids) name - - pred = mkClassPred clas (mkTyVarTys tyvars) - dict_id = mkTemplateLocal 1 $ mkPredTy pred - (eq_ids,n) = mkCoVarLocals 2 $ mkPredTys eq_theta - arg_ids = mkTemplateLocalsNum n arg_tys - - mkCoVarLocals i [] = ([],i) - mkCoVarLocals i (x:xs) = let (ys,j) = mkCoVarLocals (i+1) xs - y = mkCoVar (mkSysTvName (mkBuiltinUnique i) (fsLit "dc_co")) x - in (y:ys,j) - - rhs = mkLams tyvars (Lam dict_id rhs_body) - rhs_body | isNewTyCon tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id) - | otherwise = Case (Var dict_id) dict_id (idType the_arg_id) - [(DataAlt data_con, eq_ids ++ arg_ids, Var the_arg_id)] -\end{code} - - -%************************************************************************ -%* * Wrapping and unwrapping newtypes and type families %* * %************************************************************************ @@ -1091,37 +803,9 @@ mkDictFunId :: Name -- Name to use for the dict fun; -> Id mkDictFunId dfun_name inst_tyvars dfun_theta clas inst_tys - = mkExportedLocalId dfun_name dfun_ty + = mkExportedLocalVar DFunId dfun_name dfun_ty vanillaIdInfo where dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys) - -{- 1 dec 99: disable the Mark Jones optimisation for the sake - of compatibility with Hugs. - See `types/InstEnv' for a discussion related to this. - - (class_tyvars, sc_theta, _, _) = classBigSig clas - not_const (clas, tys) = not (isEmptyVarSet (tyVarsOfTypes tys)) - sc_theta' = substClasses (zipTopTvSubst class_tyvars inst_tys) sc_theta - dfun_theta = case inst_decl_theta of - [] -> [] -- If inst_decl_theta is empty, then we don't - -- want to have any dict arguments, so that we can - -- expose the constant methods. - - other -> nub (inst_decl_theta ++ filter not_const sc_theta') - -- Otherwise we pass the superclass dictionaries to - -- the dictionary function; the Mark Jones optimisation. - -- - -- NOTE the "nub". I got caught by this one: - -- class Monad m => MonadT t m where ... - -- instance Monad m => MonadT (EnvT env) m where ... - -- Here, the inst_decl_theta has (Monad m); but so - -- does the sc_theta'! - -- - -- NOTE the "not_const". I got caught by this one too: - -- class Foo a => Baz a b where ... - -- instance Wob b => Baz T b where.. - -- Now sc_theta' has Foo T --} \end{code} @@ -1307,7 +991,7 @@ mkRuntimeErrorId :: Name -> Id mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy runtimeErrorTy :: Type -runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy) +runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy) \end{code} \begin{code} diff --git a/compiler/basicTypes/Var.lhs b/compiler/basicTypes/Var.lhs index 4f1ed2e1a6..c1a93707f1 100644 --- a/compiler/basicTypes/Var.lhs +++ b/compiler/basicTypes/Var.lhs @@ -28,21 +28,22 @@ module Var ( -- * The main data type Var, - -- ** Constructing 'Var's - mkLocalIdVar, mkExportedLocalIdVar, mkGlobalIdVar, - -- ** Taking 'Var's apart - varName, varUnique, varType, varIdInfo, globalIdVarDetails, + varName, varUnique, varType, -- ** Modifying 'Var's setVarName, setVarUnique, setVarType, - setIdVarExported, setIdVarNotExported, - globaliseIdVar, lazySetVarIdInfo, + + -- ** Constructing, taking apart, modifying 'Id's + mkGlobalVar, mkLocalVar, mkExportedLocalVar, + idInfo, idDetails, + lazySetIdInfo, setIdDetails, globaliseId, + setIdExported, setIdNotExported, -- ** Predicates - isCoVar, isIdVar, isTyVar, isTcTyVar, - isLocalVar, isLocalIdVar, - isGlobalIdVar, isExportedIdVar, + isCoVar, isId, isTyVar, isTcTyVar, + isLocalVar, isLocalId, + isGlobalId, isExportedId, mustHaveLocalBinding, -- * Type variable data type @@ -77,8 +78,7 @@ module Var ( import {-# SOURCE #-} TypeRep( Type, Kind ) import {-# SOURCE #-} TcType( TcTyVarDetails, pprTcTyVarDetails ) -import {-# SOURCE #-} IdInfo( GlobalIdDetails, notGlobalId, - IdInfo ) +import {-# SOURCE #-} IdInfo( IdDetails, IdInfo, pprIdDetails ) import {-# SOURCE #-} TypeRep( isCoercionKind ) import Name hiding (varName) @@ -122,25 +122,22 @@ data Var varType :: Kind, tcTyVarDetails :: TcTyVarDetails } - | GlobalId { -- Used for imported Ids, dict selectors etc - -- See Note [GlobalId/LocalId] below - varName :: !Name, -- Always an External or WiredIn Name - realUnique :: FastInt, - varType :: Type, - idInfo_ :: IdInfo, - gblDetails :: GlobalIdDetails } - - | LocalId { -- Used for locally-defined Ids - -- See Note [GlobalId/LocalId] below + | Id { varName :: !Name, realUnique :: FastInt, varType :: Type, - idInfo_ :: IdInfo, - lclDetails :: LocalIdDetails } + idScope :: IdScope, + idDetails :: IdDetails, -- Stable, doesn't change + idInfo :: IdInfo } -- Unstable, updated by simplifier -data LocalIdDetails +data IdScope -- See Note [GlobalId/LocalId] + = GlobalId + | LocalId ExportFlag + +data ExportFlag = NotExported -- ^ Not exported: may be discarded as dead code. | Exported -- ^ Exported: kept alive + \end{code} Note [GlobalId/LocalId] @@ -162,13 +159,17 @@ After CoreTidy, top-level LocalIds are turned into GlobalIds \begin{code} instance Outputable Var where - ppr var = ppr (varName var) <+> ifPprDebug (brackets extra) - where - extra = case var of - GlobalId {} -> ptext (sLit "gid") - LocalId {} -> ptext (sLit "lid") - TyVar {} -> ptext (sLit "tv") - TcTyVar {tcTyVarDetails = details} -> pprTcTyVarDetails details + ppr var = ppr (varName var) <+> ifPprDebug (brackets (ppr_debug var)) + +ppr_debug :: Var -> SDoc +ppr_debug (TyVar {}) = ptext (sLit "tv") +ppr_debug (TcTyVar {tcTyVarDetails = d}) = pprTcTyVarDetails d +ppr_debug (Id { idScope = s, idDetails = d }) = ppr_id_scope s <> pprIdDetails d + +ppr_id_scope :: IdScope -> SDoc +ppr_id_scope GlobalId = ptext (sLit "gid") +ppr_id_scope (LocalId Exported) = ptext (sLit "lidx") +ppr_id_scope (LocalId NotExported) = ptext (sLit "lid") instance Show Var where showsPrec p var = showsPrecSDoc p (ppr var) @@ -207,33 +208,6 @@ setVarName var new_name setVarType :: Id -> Type -> Id setVarType id ty = id { varType = ty } - -setIdVarExported :: Var -> Var --- ^ Exports the given local 'Id'. Can also be called on global 'Id's, such as data constructors --- and class operations, which are born as global 'Id's and automatically exported -setIdVarExported id@(LocalId {}) = id { lclDetails = Exported } -setIdVarExported other_id = ASSERT( isIdVar other_id ) other_id - -setIdVarNotExported :: Id -> Id --- ^ We can only do this to LocalIds -setIdVarNotExported id = ASSERT( isLocalIdVar id ) id { lclDetails = NotExported } - -globaliseIdVar :: GlobalIdDetails -> Var -> Var --- ^ If it's a local, make it global -globaliseIdVar details id = GlobalId { varName = varName id, - realUnique = realUnique id, - varType = varType id, - idInfo_ = varIdInfo id, - gblDetails = details } - --- | Extract 'Id' information from the 'Var' if it represents a global or local 'Id', otherwise panic -varIdInfo :: Var -> IdInfo -varIdInfo (GlobalId {idInfo_ = info}) = info -varIdInfo (LocalId {idInfo_ = info}) = info -varIdInfo other_var = pprPanic "idInfo" (ppr other_var) - -lazySetVarIdInfo :: Var -> IdInfo -> Var -lazySetVarIdInfo id info = id { idInfo_ = info } \end{code} @@ -322,12 +296,57 @@ mkWildCoVar = mkCoVar (mkSysTvName (mkBuiltinUnique 1) (fsLit "co_wild")) %************************************************************************ \begin{code} - -- These synonyms are here and not in Id because otherwise we need a very -- large number of SOURCE imports of Id.hs :-( type Id = Var type DictId = Var +-- The next three have a 'Var' suffix even though they always build +-- Ids, becuase Id.lhs uses 'mkGlobalId' etc with different types +mkGlobalVar :: IdDetails -> Name -> Type -> IdInfo -> Id +mkGlobalVar details name ty info + = mk_id name ty GlobalId details info + +mkLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id +mkLocalVar details name ty info + = mk_id name ty (LocalId NotExported) details info + +-- | Exported 'Var's will not be removed as dead code +mkExportedLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id +mkExportedLocalVar details name ty info + = mk_id name ty (LocalId Exported) details info + +mk_id :: Name -> Type -> IdScope -> IdDetails -> IdInfo -> Id +mk_id name ty scope details info + = Id { varName = name, + realUnique = getKeyFastInt (nameUnique name), + varType = ty, + idScope = scope, + idDetails = details, + idInfo = info } + +------------------- +lazySetIdInfo :: Id -> IdInfo -> Var +lazySetIdInfo id info = id { idInfo = info } + +setIdDetails :: Id -> IdDetails -> Id +setIdDetails id details = id { idDetails = details } + +globaliseId :: Id -> Id +-- ^ If it's a local, make it global +globaliseId id = id { idScope = GlobalId } + +setIdExported :: Id -> Id +-- ^ Exports the given local 'Id'. Can also be called on global 'Id's, such as data constructors +-- and class operations, which are born as global 'Id's and automatically exported +setIdExported id@(Id { idScope = LocalId {} }) = id { idScope = LocalId Exported } +setIdExported id@(Id { idScope = GlobalId }) = id +setIdExported tv = pprPanic "setIdExported" (ppr tv) + +setIdNotExported :: Id -> Id +-- ^ We can only do this to LocalIds +setIdNotExported id = ASSERT( isLocalId id ) + id { idScope = LocalId NotExported } \end{code} %************************************************************************ @@ -337,33 +356,6 @@ type DictId = Var %************************************************************************ \begin{code} --- | For an explanation of global vs. local 'Var's, see "Var#globalvslocal" -mkGlobalIdVar :: GlobalIdDetails -> Name -> Type -> IdInfo -> Var -mkGlobalIdVar details name ty info - = GlobalId { varName = name, - realUnique = getKeyFastInt (nameUnique name), -- Cache the unique - varType = ty, - gblDetails = details, - idInfo_ = info } - -mkLocalIdVar' :: Name -> Type -> LocalIdDetails -> IdInfo -> Var -mkLocalIdVar' name ty details info - = LocalId { varName = name, - realUnique = getKeyFastInt (nameUnique name), -- Cache the unique - varType = ty, - lclDetails = details, - idInfo_ = info } - --- | For an explanation of global vs. local 'Var's, see "Var#globalvslocal" -mkLocalIdVar :: Name -> Type -> IdInfo -> Var -mkLocalIdVar name ty info = mkLocalIdVar' name ty NotExported info - --- | Exported 'Var's will not be removed as dead code -mkExportedLocalIdVar :: Name -> Type -> IdInfo -> Var -mkExportedLocalIdVar name ty info = mkLocalIdVar' name ty Exported info -\end{code} - -\begin{code} isTyVar :: Var -> Bool isTyVar (TyVar {}) = True isTyVar (TcTyVar {}) = True @@ -373,14 +365,13 @@ isTcTyVar :: Var -> Bool isTcTyVar (TcTyVar {}) = True isTcTyVar _ = False -isIdVar :: Var -> Bool -isIdVar (LocalId {}) = True -isIdVar (GlobalId {}) = True -isIdVar _ = False +isId :: Var -> Bool +isId (Id {}) = True +isId _ = False -isLocalIdVar :: Var -> Bool -isLocalIdVar (LocalId {}) = True -isLocalIdVar _ = False +isLocalId :: Var -> Bool +isLocalId (Id { idScope = LocalId _ }) = True +isLocalId _ = False isCoVar :: Var -> Bool isCoVar (v@(TyVar {})) = isCoercionVar v @@ -391,8 +382,11 @@ isCoVar _ = False -- These are the variables that we need to pay attention to when finding free -- variables, or doing dependency analysis. isLocalVar :: Var -> Bool -isLocalVar (GlobalId {}) = False -isLocalVar _ = True +isLocalVar v = not (isGlobalId v) + +isGlobalId :: Var -> Bool +isGlobalId (Id { idScope = GlobalId }) = True +isGlobalId _ = False -- | 'mustHaveLocalBinding' returns @True@ of 'Id's and 'TyVar's -- that must have a binding in this module. The converse @@ -402,23 +396,9 @@ isLocalVar _ = True mustHaveLocalBinding :: Var -> Bool mustHaveLocalBinding var = isLocalVar var -isGlobalIdVar :: Var -> Bool -isGlobalIdVar (GlobalId {}) = True -isGlobalIdVar _ = False - -- | 'isExportedIdVar' means \"don't throw this away\" -isExportedIdVar :: Var -> Bool -isExportedIdVar (GlobalId {}) = True -isExportedIdVar (LocalId {lclDetails = details}) - = case details of - Exported -> True - _ -> False -isExportedIdVar _ = False -\end{code} - -\begin{code} -globalIdVarDetails :: Var -> GlobalIdDetails --- ^ Find the global 'Id' information if the 'Var' is a global 'Id', otherwise returns 'notGlobalId' -globalIdVarDetails (GlobalId {gblDetails = details}) = details -globalIdVarDetails _ = notGlobalId +isExportedId :: Var -> Bool +isExportedId (Id { idScope = GlobalId }) = True +isExportedId (Id { idScope = LocalId Exported}) = True +isExportedId _ = False \end{code} diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index 79e25a2be0..1b3a9d7b68 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -25,7 +25,7 @@ module CoreSyn ( mkConApp, mkTyBind, varToCoreExpr, varsToCoreExprs, - isTyVar, isIdVar, cmpAltCon, cmpAlt, ltAlt, + isTyVar, isId, cmpAltCon, cmpAlt, ltAlt, -- ** Simple 'Expr' access functions and predicates bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, @@ -704,7 +704,7 @@ mkTyBind tv ty = NonRec tv (Type ty) -- | Convert a binder into either a 'Var' or 'Type' 'Expr' appropriately varToCoreExpr :: CoreBndr -> Expr b -varToCoreExpr v | isIdVar v = Var v +varToCoreExpr v | isId v = Var v | otherwise = Type (mkTyVarTy v) varsToCoreExprs :: [CoreBndr] -> [Expr b] @@ -777,8 +777,8 @@ collectTyBinders expr collectValBinders expr = go [] expr where - go ids (Lam b e) | isIdVar b = go (b:ids) e - go ids body = (reverse ids, body) + go ids (Lam b e) | isId b = go (b:ids) e + go ids body = (reverse ids, body) \end{code} \begin{code} @@ -816,7 +816,7 @@ at runtime. Similarly isRuntimeArg. \begin{code} -- | Will this variable exist at runtime? isRuntimeVar :: Var -> Bool -isRuntimeVar = isIdVar +isRuntimeVar = isId -- | Will this argument expression exist at runtime? isRuntimeArg :: CoreExpr -> Bool @@ -834,7 +834,7 @@ isTypeArg _ = False -- | The number of binders that bind values rather than types valBndrCount :: [CoreBndr] -> Int -valBndrCount = count isIdVar +valBndrCount = count isId -- | The number of argument expressions that are values rather than types at their top level valArgCount :: [Arg b] -> Int diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index d7ec4c718e..38513af2b4 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -309,7 +309,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr | fun `hasKey` buildIdKey = buildSize | fun `hasKey` augmentIdKey = augmentSize | otherwise - = case globalIdDetails fun of + = case idDetails fun of DataConWorkId dc -> conSizeN dc (valArgCount args) FCallId _ -> sizeN opt_UF_DearOp @@ -684,7 +684,7 @@ slow-down). The motivation was test eyeball/inline1.hs; but that seems to work ok now. Note [Lone variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~ The "lone-variable" case is important. I spent ages messing about with unsatisfactory varaints, but this is nice. The idea is that if a variable appears all alone diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 44ca27a9ab..25224a6e4d 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -498,10 +498,10 @@ exprIsCheap other_expr -- Applications and variables go (Var _) [] = True -- Just a type application of a variable -- (f t1 t2 t3) counts as WHNF go (Var f) args - = case globalIdDetails f of - RecordSelId {} -> go_sel args - ClassOpId _ -> go_sel args - PrimOpId op -> go_primop op args + = case idDetails f of + RecSelId {} -> go_sel args + ClassOpId _ -> go_sel args + PrimOpId op -> go_primop op args DataConWorkId _ -> go_pap args _ | length args < idArity f -> go_pap args @@ -578,7 +578,7 @@ exprOkForSpeculation (Note _ e) = exprOkForSpeculation e exprOkForSpeculation (Cast e _) = exprOkForSpeculation e exprOkForSpeculation other_expr = case collectArgs other_expr of - (Var f, args) -> spec_ok (globalIdDetails f) args + (Var f, args) -> spec_ok (idDetails f) args _ -> False where diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs index 717d3d8d93..ab1f12be25 100644 --- a/compiler/coreSyn/MkExternalCore.lhs +++ b/compiler/coreSyn/MkExternalCore.lhs @@ -136,7 +136,7 @@ make_exp (Var v) = do let vName = Var.varName v isLocal <- isALocal vName return $ - case globalIdVarDetails v of + case idDetails v of FCallId (CCall (CCallSpec (StaticTarget nm) callconv _)) -> C.External (unpackFS nm) (showSDoc (ppr callconv)) (make_ty (varType v)) FCallId (CCall (CCallSpec DynamicTarget callconv _)) diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index d641a9e833..1504ab9b58 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -250,7 +250,7 @@ pprCoreBinder :: BindingSite -> Var -> SDoc pprCoreBinder LetBind binder | isTyVar binder = pprKindedTyVarBndr binder | otherwise - = vcat [sig, pprIdDetails binder, pragmas] + = vcat [sig, pprIdExtras binder, pragmas] where sig = pprTypedBinder binder pragmas = ppIdInfo binder (idInfo binder) @@ -326,10 +326,12 @@ pprIdBndrInfo info \begin{code} -pprIdDetails :: Id -> SDoc -pprIdDetails id | isGlobalId id = ppr (globalIdDetails id) - | isExportedId id = ptext (sLit "[Exported]") - | otherwise = empty +pprIdExtras :: Id -> SDoc +pprIdExtras id = pp_scope <> ppr (idDetails id) + where + pp_scope | isGlobalId id = ptext (sLit "GblId") + | isExportedId id = ptext (sLit "LclIdX") + | otherwise = ptext (sLit "LclId") ppIdInfo :: Id -> IdInfo -> SDoc ppIdInfo _ info diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs index 712eec05aa..64c1917cf9 100644 --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -16,7 +16,6 @@ import Linker import RtClosureInspect import HscTypes -import IdInfo import Id import Name import Var hiding ( varName ) @@ -117,7 +116,7 @@ bindSuspensions t = do (t', stuff) <- liftIO $ foldTerm (nameSuspensionsAndGetInfos availNames_var) t let (names, tys, hvals) = unzip3 stuff (tys', skol_vars) = unzip $ map skolemiseTy tys - let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo + let ids = [ mkVanillaGlobal name ty | (name,ty) <- zip names tys'] new_ic = extendInteractiveContext ictxt ids (unionVarSets skol_vars) liftIO $ extendLinkEnv (zip names hvals) @@ -199,7 +198,7 @@ showTerm term = do name <- newGrimName userName let ictxt = hsc_IC hsc_env tmp_ids = ic_tmp_ids ictxt - id = mkGlobalId VanillaGlobal name ty vanillaIdInfo + id = mkVanillaGlobal name ty new_ic = ictxt { ic_tmp_ids = id : tmp_ids } return (hsc_env {hsc_IC = new_ic }, name) diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 83273f0ca6..702e736584 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -426,12 +426,18 @@ type LSig name = Located (Sig name) data Sig name -- Signatures and pragmas = -- An ordinary type signature -- f :: Num a => a -> a - TypeSig (Located name) -- A bog-std type signature - (LHsType name) + TypeSig (Located name) (LHsType name) + + -- A type signature in generated code, notably the code + -- generated for record selectors. We simply record + -- the desired Id itself, replete with its name, type + -- and IdDetails. Otherwise it's just like a type + -- signature: there should be an accompanying binding + | IdSig Id -- An ordinary fixity declaration -- infixl *** 8 - | FixSig (FixitySig name) -- Fixity declaration + | FixSig (FixitySig name) -- An inline pragma -- {#- INLINE f #-} @@ -511,10 +517,17 @@ isFixityLSig :: LSig name -> Bool isFixityLSig (L _ (FixSig {})) = True isFixityLSig _ = False -isVanillaLSig :: LSig name -> Bool +isVanillaLSig :: LSig name -> Bool -- User type signatures +-- A badly-named function, but it's part of the GHCi (used +-- by Haddock) so I don't want to change it gratuitously. isVanillaLSig (L _(TypeSig {})) = True isVanillaLSig _ = False +isTypeLSig :: LSig name -> Bool -- Type signatures +isTypeLSig (L _(TypeSig {})) = True +isTypeLSig (L _(IdSig {})) = True +isTypeLSig _ = False + isSpecLSig :: LSig name -> Bool isSpecLSig (L _(SpecSig {})) = True isSpecLSig _ = False @@ -536,6 +549,7 @@ isInlineLSig _ = False hsSigDoc :: Sig name -> SDoc hsSigDoc (TypeSig {}) = ptext (sLit "type signature") +hsSigDoc (IdSig {}) = ptext (sLit "id signature") hsSigDoc (SpecSig {}) = ptext (sLit "SPECIALISE pragma") hsSigDoc (InlineSig {}) = ptext (sLit "INLINE pragma") hsSigDoc (SpecInstSig {}) = ptext (sLit "SPECIALISE instance pragma") @@ -547,6 +561,7 @@ Signature equality is used when checking for duplicate signatures \begin{code} eqHsSig :: Eq a => LSig a -> LSig a -> Bool eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2 +eqHsSig (L _ (IdSig n1)) (L _ (IdSig n2)) = n1 == n2 eqHsSig (L _ (TypeSig n1 _)) (L _ (TypeSig n2 _)) = unLoc n1 == unLoc n2 eqHsSig (L _ (InlineSig n1 _)) (L _ (InlineSig n2 _)) = unLoc n1 == unLoc n2 -- For specialisations, we don't have equality over @@ -561,6 +576,7 @@ instance (OutputableBndr name) => Outputable (Sig name) where ppr_sig :: OutputableBndr name => Sig name -> SDoc ppr_sig (TypeSig var ty) = pprVarSig (unLoc var) ty +ppr_sig (IdSig id) = pprVarSig id (varType id) ppr_sig (FixSig fix_sig) = ppr fix_sig ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec var ty inl) ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> ppr var) diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 9926b95d24..7a274011b7 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -579,12 +579,9 @@ instance Binary Activation where return (ActiveAfter ab) instance Binary StrictnessMark where - put_ bh MarkedStrict = do - putByte bh 0 - put_ bh MarkedUnboxed = do - putByte bh 1 - put_ bh NotMarkedStrict = do - putByte bh 2 + put_ bh MarkedStrict = putByte bh 0 + put_ bh MarkedUnboxed = putByte bh 1 + put_ bh NotMarkedStrict = putByte bh 2 get bh = do h <- getByte bh case h of @@ -593,10 +590,8 @@ instance Binary StrictnessMark where _ -> do return NotMarkedStrict instance Binary Boxity where - put_ bh Boxed = do - putByte bh 0 - put_ bh Unboxed = do - putByte bh 1 + put_ bh Boxed = putByte bh 0 + put_ bh Unboxed = putByte bh 1 get bh = do h <- getByte bh case h of @@ -1096,6 +1091,18 @@ instance Binary IfaceBinding where _ -> do ac <- get bh return (IfaceRec ac) +instance Binary IfaceIdDetails where + put_ bh IfVanillaId = putByte bh 0 + put_ bh (IfRecSelId b) = do { putByte bh 1; put_ bh b } + put_ bh IfDFunId = putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> return IfVanillaId + 1 -> do a <- get bh + return (IfRecSelId a) + _ -> return IfDFunId + instance Binary IfaceIdInfo where put_ bh NoInfo = putByte bh 0 put_ bh (HasInfo i) = do @@ -1174,10 +1181,11 @@ instance Binary IfaceNote where -- when de-serialising. instance Binary IfaceDecl where - put_ bh (IfaceId name ty idinfo) = do + put_ bh (IfaceId name ty details idinfo) = do putByte bh 0 put_ bh (occNameFS name) put_ bh ty + put_ bh details put_ bh idinfo put_ _ (IfaceForeign _ _) = error "Binary.put_(IfaceDecl): IfaceForeign" @@ -1210,11 +1218,12 @@ instance Binary IfaceDecl where get bh = do h <- getByte bh case h of - 0 -> do name <- get bh - ty <- get bh - idinfo <- get bh + 0 -> do name <- get bh + ty <- get bh + details <- get bh + idinfo <- get bh occ <- return $! mkOccNameFS varName name - return (IfaceId occ ty idinfo) + return (IfaceId occ ty details idinfo) 1 -> error "Binary.get(TyClDecl): ForeignType" 2 -> do a1 <- get bh @@ -1299,7 +1308,7 @@ instance Binary IfaceConDecls where return (IfNewTyCon aa) instance Binary IfaceConDecl where - put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9) = do + put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do put_ bh a1 put_ bh a2 put_ bh a3 @@ -1309,6 +1318,7 @@ instance Binary IfaceConDecl where put_ bh a7 put_ bh a8 put_ bh a9 + put_ bh a10 get bh = do a1 <- get bh a2 <- get bh a3 <- get bh @@ -1318,7 +1328,8 @@ instance Binary IfaceConDecl where a7 <- get bh a8 <- get bh a9 <- get bh - return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9) + a10 <- get bh + return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) instance Binary IfaceClassOp where put_ bh (IfaceClassOp n def ty) = do diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index b8c04d3c4c..9213afd4ce 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -79,9 +79,8 @@ buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn ; tycon <- fixM (\ tycon_rec -> do { parent <- mkParentInfo mb_family tc_name tvs tycon_rec ; let { tycon = mkAlgTyCon tc_name kind tvs stupid_theta rhs - fields parent is_rec want_generics gadt_syn - ; kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind - ; fields = mkTyConSelIds tycon rhs + parent is_rec want_generics gadt_syn + ; kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind } ; return tycon }) @@ -234,14 +233,6 @@ mkDataConStupidTheta tycon arg_tys univ_tvs arg_tyvars = tyVarsOfTypes arg_tys in_arg_tys pred = not $ isEmptyVarSet $ tyVarsOfPred pred `intersectVarSet` arg_tyvars - ------------------------------------------------------- -mkTyConSelIds :: TyCon -> AlgTyConRhs -> [Id] -mkTyConSelIds tycon rhs - = [ mkRecordSelId tycon fld - | fld <- nub (concatMap dataConFieldLabels (visibleDataCons rhs)) ] - -- We'll check later that fields with the same name - -- from different constructors have the same type. \end{code} @@ -269,20 +260,11 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec let { rec_tycon = classTyCon rec_clas ; op_tys = [ty | (_,_,ty) <- sig_stuff] + ; op_names = [op | (op,_,_) <- sig_stuff] ; op_items = [ (mkDictSelId no_unf op_name rec_clas, dm_info) | (op_name, dm_info, _) <- sig_stuff ] } -- Build the selector id and default method id - ; dict_con <- buildDataCon datacon_name - False -- Not declared infix - (map (const NotMarkedStrict) op_tys) - [{- No labelled fields -}] - tvs [{- no existentials -}] - [{- No GADT equalities -}] sc_theta - op_tys - (mkTyConApp rec_tycon (mkTyVarTys tvs)) - rec_tycon - ; let n_value_preds = count (not . isEqPred) sc_theta all_value_preds = n_value_preds == length sc_theta -- We only make selectors for the *value* superclasses, @@ -307,6 +289,23 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec -- i.e. exactly one operation or superclass taken together -- See note [Class newtypes and equality predicates] + -- We play a bit fast and loose by treating the superclasses + -- as ordinary arguments. That means that in the case of + -- class C a => D a + -- we don't get a newtype with no arguments! + args = sc_sel_names ++ op_names + arg_tys = map mkPredTy sc_theta ++ op_tys + + ; dict_con <- buildDataCon datacon_name + False -- Not declared infix + (map (const NotMarkedStrict) args) + [{- No fields -}] + tvs [{- no existentials -}] + [{- No GADT equalities -}] [{- No theta -}] + arg_tys + (mkTyConApp rec_tycon (mkTyVarTys tvs)) + rec_tycon + ; rhs <- if use_newtype then mkNewTyConRhs tycon_name rec_tycon dict_con else return (mkDataTyConRhs [dict_con]) diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 7ef13a37e1..78b925f9e2 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -9,7 +9,7 @@ module IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..), IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..), - IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), + IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), IfaceIdDetails(..), IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, IfaceInst(..), IfaceFamInst(..), @@ -56,9 +56,10 @@ infixl 3 &&& \begin{code} data IfaceDecl - = IfaceId { ifName :: OccName, - ifType :: IfaceType, - ifIdInfo :: IfaceIdInfo } + = IfaceId { ifName :: OccName, + ifType :: IfaceType, + ifIdDetails :: IfaceIdDetails, + ifIdInfo :: IfaceIdInfo } | IfaceData { ifName :: OccName, -- Type constructor ifTyVars :: [IfaceTvBndr], -- Type variables @@ -126,6 +127,7 @@ visibleIfConDecls (IfNewTyCon c) = [c] data IfaceConDecl = IfCon { ifConOcc :: OccName, -- Constructor name + ifConWrapper :: Bool, -- True <=> has a wrapper ifConInfix :: Bool, -- True <=> declared infix ifConUnivTvs :: [IfaceTvBndr], -- Universal tyvars ifConExTvs :: [IfaceTvBndr], -- Existential tyvars @@ -174,6 +176,16 @@ data IfaceAnnotation type IfaceAnnTarget = AnnTarget OccName +-- We only serialise the IdDetails of top-level Ids, and even then +-- we only need a very limited selection. Notably, none of the +-- implicit ones are needed here, becuase they are not put it +-- interface files + +data IfaceIdDetails + = IfVanillaId + | IfRecSelId Bool + | IfDFunId + data IfaceIdInfo = NoInfo -- When writing interface file without -O | HasInfo [IfaceInfoItem] -- Has info, and here it is @@ -347,28 +359,22 @@ ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon} = [] -- Newtype ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, ifCons = IfNewTyCon ( - IfCon { ifConOcc = con_occ, - ifConFields = fields - }), + IfCon { ifConOcc = con_occ }), ifFamInst = famInst}) - = -- fields (names of selectors) - fields ++ - -- implicit coerion and (possibly) family instance coercion + = -- implicit coerion and (possibly) family instance coercion (mkNewTyCoOcc tc_occ) : (famInstCo famInst tc_occ) ++ - -- data constructor and worker (newtypes don't have a wrapper) + -- data constructor and worker (newtypes don't have a wrapper) [con_occ, mkDataConWorkerOcc con_occ] ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, ifCons = IfDataTyCon cons, ifFamInst = famInst}) - = -- fields (names of selectors) - nub (concatMap ifConFields cons) -- Eliminate duplicate fields - -- (possibly) family instance coercion; - -- there is no implicit coercion for non-newtypes - ++ famInstCo famInst tc_occ - -- for each data constructor in order, - -- data constructor, worker, and (possibly) wrapper + = -- (possibly) family instance coercion; + -- there is no implicit coercion for non-newtypes + famInstCo famInst tc_occ + -- for each data constructor in order, + -- data constructor, worker, and (possibly) wrapper ++ concatMap dc_occs cons where dc_occs con_decl @@ -379,10 +385,8 @@ ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, wrap_occ = mkDataConWrapperOcc con_occ -- Id namespace work_occ = mkDataConWorkerOcc con_occ -- Id namespace strs = ifConStricts con_decl - has_wrapper = any isMarkedStrict strs -- See MkId.mkDataConIds (sigh) - || not (null . ifConEqSpec $ con_decl) - || isJust famInst - -- ToDo: may miss strictness in existential dicts + has_wrapper = ifConWrapper con_decl -- This is the reason for + -- having the ifConWrapper field! ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, ifSigs = sigs, ifATs = ats }) @@ -428,8 +432,10 @@ instance Outputable IfaceDecl where ppr = pprIfaceDecl pprIfaceDecl :: IfaceDecl -> SDoc -pprIfaceDecl (IfaceId {ifName = var, ifType = ty, ifIdInfo = info}) +pprIfaceDecl (IfaceId {ifName = var, ifType = ty, + ifIdDetails = details, ifIdInfo = info}) = sep [ ppr var <+> dcolon <+> ppr ty, + nest 2 (ppr details), nest 2 (ppr info) ] pprIfaceDecl (IfaceForeign {ifName = tycon}) @@ -495,12 +501,13 @@ pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext (sLit " |")) pprIfaceConDecl :: OccName -> IfaceConDecl -> SDoc pprIfaceConDecl tc - (IfCon { ifConOcc = name, ifConInfix = is_infix, + (IfCon { ifConOcc = name, ifConInfix = is_infix, ifConWrapper = has_wrap, ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs, ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys, ifConStricts = strs, ifConFields = fields }) = sep [main_payload, if is_infix then ptext (sLit "Infix") else empty, + if has_wrap then ptext (sLit "HasWrapper") else empty, if null strs then empty else nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr strs)), if null fields then empty @@ -641,6 +648,12 @@ instance Outputable IfaceConAlt where -- IfaceTupleAlt is handled by the case-alternative printer ------------------ +instance Outputable IfaceIdDetails where + ppr IfVanillaId = empty + ppr (IfRecSelId b) = ptext (sLit "RecSel") + <> if b then ptext (sLit "<naughty>") else empty + ppr IfDFunId = ptext (sLit "DFunId") + instance Outputable IfaceIdInfo where ppr NoInfo = empty ppr (HasInfo is) = ptext (sLit "{-") <+> fsep (map ppr is) <+> ptext (sLit "-}") @@ -666,7 +679,7 @@ instance Outputable IfaceInfoItem where -- fingerprinting the instance, so DFuns are not dependencies. freeNamesIfDecl :: IfaceDecl -> NameSet -freeNamesIfDecl (IfaceId _s t i) = +freeNamesIfDecl (IfaceId _s t _d i) = freeNamesIfType t &&& freeNamesIfIdInfo i freeNamesIfDecl IfaceForeign{} = diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index 8cd88efa5d..27f6cdda06 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -127,7 +127,7 @@ loadInterfaceForName doc name -- | An 'IfM' function to load the home interface for a wired-in thing, -- so that we're sure that we see its instance declarations and rules --- See Note [Loading instances] +-- See Note [Loading instances for wired-in things] in TcIface loadWiredInHomeIface :: Name -> IfM lcl () loadWiredInHomeIface name = ASSERT( isWiredInName name ) @@ -153,27 +153,6 @@ loadInterfaceWithException doc mod_name where_from Succeeded iface -> return iface } \end{code} -Note [Loading instances] -~~~~~~~~~~~~~~~~~~~~~~~~ -We need to make sure that we have at least *read* the interface files -for any module with an instance decl or RULE that we might want. - -* If the instance decl is an orphan, we have a whole separate mechanism - (loadOprhanModules) - -* If the instance decl not an orphan, then the act of looking at the - TyCon or Class will force in the defining module for the - TyCon/Class, and hence the instance decl - -* BUT, if the TyCon is a wired-in TyCon, we don't really need its interface; - but we must make sure we read its interface in case it has instances or - rules. That is what LoadIface.loadWiredInHomeInterface does. It's called - from TcIface.{tcImportDecl, checkWiredInTyCon, ifCHeckWiredInThing} - -All of this is done by the type checker. The renamer plays no role. -(It used to, but no longer.) - - %********************************************************* %* * diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 4976e1fc8f..22c1756e00 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1271,9 +1271,10 @@ tyThingToIfaceDecl :: TyThing -> IfaceDecl -- Reason: Iface stuff uses OccNames, and the conversion here does -- not do tidying on the way tyThingToIfaceDecl (AnId id) - = IfaceId { ifName = getOccName id, - ifType = toIfaceType (idType id), - ifIdInfo = info } + = IfaceId { ifName = getOccName id, + ifType = toIfaceType (idType id), + ifIdDetails = toIfaceIdDetails (idDetails id), + ifIdInfo = info } where info = case toIfaceIdInfo (idInfo id) of [] -> NoInfo @@ -1351,6 +1352,7 @@ tyThingToIfaceDecl (ATyCon tycon) ifaceConDecl data_con = IfCon { ifConOcc = getOccName (dataConName data_con), ifConInfix = dataConIsInfix data_con, + ifConWrapper = isJust (dataConWrapId_maybe data_con), ifConUnivTvs = toIfaceTvBndrs (dataConUnivTyVars data_con), ifConExTvs = toIfaceTvBndrs (dataConExTyVars data_con), ifConEqSpec = to_eq_spec (dataConEqSpec data_con), @@ -1442,6 +1444,13 @@ toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id)) | otherwise = HasInfo [HsInline inline_prag] -------------------------- +toIfaceIdDetails :: IdDetails -> IfaceIdDetails +toIfaceIdDetails VanillaId = IfVanillaId +toIfaceIdDetails DFunId = IfVanillaId +toIfaceIdDetails (RecSelId { sel_naughty = n }) = IfRecSelId n +toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other) + IfVanillaId -- Unexpected + toIfaceIdInfo :: IdInfo -> [IfaceInfoItem] toIfaceIdInfo id_info = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 28b03119ac..af43f979b4 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -19,6 +19,7 @@ import LoadIface import IfaceEnv import BuildTyCl import TcRnMonad +import TcType ( tcSplitSigmaTy ) import Type import TypeRep import HscTypes @@ -108,8 +109,9 @@ tcImportDecl :: Name -> TcM TyThing -- Entry point for *source-code* uses of importDecl tcImportDecl name | Just thing <- wiredInNameTyThing_maybe name - = do { initIfaceTcRn (loadWiredInHomeIface name) - -- See Note [Loading instances] in LoadIface + = do { when (needWiredInHomeIface thing) + (initIfaceTcRn (loadWiredInHomeIface name)) + -- See Note [Loading instances for wired-in things] ; return thing } | otherwise = do { traceIf (text "tcImportDecl" <+> ppr name) @@ -118,26 +120,6 @@ tcImportDecl name Succeeded thing -> return thing Failed err -> failWithTc err } -checkWiredInTyCon :: TyCon -> TcM () --- Ensure that the home module of the TyCon (and hence its instances) --- are loaded. See See Note [Loading instances] in LoadIface --- It might not be a wired-in tycon (see the calls in TcUnify), --- in which case this is a no-op. -checkWiredInTyCon tc - | not (isWiredInName tc_name) - = return () - | otherwise - = do { mod <- getModule - ; ASSERT( isExternalName tc_name ) - unless (mod == nameModule tc_name) - (initIfaceTcRn (loadWiredInHomeIface tc_name)) - -- Don't look for (non-existent) Float.hi when - -- compiling Float.lhs, which mentions Float of course - -- A bit yukky to call initIfaceTcRn here - } - where - tc_name = tyConName tc - importDecl :: Name -> IfM lcl (MaybeErr Message TyThing) -- Get the TyThing for this Name from an interface file -- It's not a wired-in thing -- the caller caught that @@ -168,6 +150,83 @@ importDecl name %************************************************************************ %* * + Checks for wired-in things +%* * +%************************************************************************ + +Note [Loading instances for wired-in things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to make sure that we have at least *read* the interface files +for any module with an instance decl or RULE that we might want. + +* If the instance decl is an orphan, we have a whole separate mechanism + (loadOprhanModules) + +* If the instance decl not an orphan, then the act of looking at the + TyCon or Class will force in the defining module for the + TyCon/Class, and hence the instance decl + +* BUT, if the TyCon is a wired-in TyCon, we don't really need its interface; + but we must make sure we read its interface in case it has instances or + rules. That is what LoadIface.loadWiredInHomeInterface does. It's called + from TcIface.{tcImportDecl, checkWiredInTyCon, ifCheckWiredInThing} + +* HOWEVER, only do this for TyCons. There are no wired-in Classes. There + are some wired-in Ids, but we don't want to load their interfaces. For + example, Control.Exception.Base.recSelError is wired in, but that module + is compiled late in the base library, and we don't want to force it to + load before it's been compiled! + +All of this is done by the type checker. The renamer plays no role. +(It used to, but no longer.) + + +\begin{code} +checkWiredInTyCon :: TyCon -> TcM () +-- Ensure that the home module of the TyCon (and hence its instances) +-- are loaded. See Note [Loading instances for wired-in things] +-- It might not be a wired-in tycon (see the calls in TcUnify), +-- in which case this is a no-op. +checkWiredInTyCon tc + | not (isWiredInName tc_name) + = return () + | otherwise + = do { mod <- getModule + ; ASSERT( isExternalName tc_name ) + when (mod /= nameModule tc_name) + (initIfaceTcRn (loadWiredInHomeIface tc_name)) + -- Don't look for (non-existent) Float.hi when + -- compiling Float.lhs, which mentions Float of course + -- A bit yukky to call initIfaceTcRn here + } + where + tc_name = tyConName tc + +ifCheckWiredInThing :: TyThing -> IfL () +-- Even though we are in an interface file, we want to make +-- sure the instances of a wired-in thing are loaded (imagine f :: Double -> Double) +-- Ditto want to ensure that RULES are loaded too +-- See Note [Loading instances for wired-in things] +ifCheckWiredInThing thing + = do { mod <- getIfModule + -- Check whether we are typechecking the interface for this + -- very module. E.g when compiling the base library in --make mode + -- we may typecheck GHC.Base.hi. At that point, GHC.Base is not in + -- the HPT, so without the test we'll demand-load it into the PIT! + -- C.f. the same test in checkWiredInTyCon above + ; let name = getName thing + ; ASSERT2( isExternalName name, ppr name ) + when (needWiredInHomeIface thing && mod /= nameModule name) + (loadWiredInHomeIface name) } + +needWiredInHomeIface :: TyThing -> Bool +-- Only for TyCons; see Note [Loading instances for wired-in things] +needWiredInHomeIface (ATyCon {}) = True +needWiredInHomeIface _ = False +\end{code} + +%************************************************************************ +%* * Type-checking a complete interface %* * %************************************************************************ @@ -355,11 +414,13 @@ tcIfaceDecl :: Bool -- True <=> discard IdInfo on IfaceId bindings -> IfaceDecl -> IfL TyThing -tcIfaceDecl ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, ifIdInfo = info}) +tcIfaceDecl ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, + ifIdDetails = details, ifIdInfo = info}) = do { name <- lookupIfaceTop occ_name ; ty <- tcIfaceType iface_type + ; details <- tcIdDetails ty details ; info <- tcIdInfo ignore_prags name ty info - ; return (AnId (mkVanillaGlobalWithInfo name ty info)) } + ; return (AnId (mkGlobalId details name ty info)) } tcIfaceDecl _ (IfaceData {ifName = occ_name, ifTyVars = tv_bndrs, @@ -914,6 +975,17 @@ do_one (IfaceRec pairs) thing_inside %************************************************************************ \begin{code} +tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails +tcIdDetails _ IfVanillaId = return VanillaId +tcIdDetails _ IfDFunId = return DFunId +tcIdDetails ty (IfRecSelId naughty) + = return (RecSelId { sel_tycon = tc, sel_naughty = naughty }) + where + (_, _, tau) = tcSplitSigmaTy ty + tc = tyConAppTyCon (funArgTy tau) + -- A bit fragile. Relies on the selector type looking like + -- forall abc. (stupid-context) => T a b c -> blah + tcIdInfo :: Bool -> Name -> Type -> IfaceIdInfo -> IfL IdInfo tcIdInfo ignore_prags name ty info | ignore_prags = return vanillaIdInfo @@ -1016,7 +1088,7 @@ tcIfaceGlobal :: Name -> IfL TyThing tcIfaceGlobal name | Just thing <- wiredInNameTyThing_maybe name -- Wired-in things include TyCons, DataCons, and Ids - = do { ifCheckWiredInThing name; return thing } + = do { ifCheckWiredInThing thing; return thing } | otherwise = do { env <- getGblEnv ; case if_rec_types env of { -- Note [Tying the knot] @@ -1059,22 +1131,6 @@ tcIfaceGlobal name -- Because if M.hs also has M.hs-boot, M.T will *already be* in the HPT, but in its -- emasculated form (e.g. lacking data constructors). -ifCheckWiredInThing :: Name -> IfL () --- Even though we are in an interface file, we want to make --- sure the instances of a wired-in thing are loaded (imagine f :: Double -> Double) --- Ditto want to ensure that RULES are loaded too --- See Note [Loading instances] in LoadIface -ifCheckWiredInThing name - = do { mod <- getIfModule - -- Check whether we are typechecking the interface for this - -- very module. E.g when compiling the base library in --make mode - -- we may typecheck GHC.Base.hi. At that point, GHC.Base is not in - -- the HPT, so without the test we'll demand-load it into the PIT! - -- C.f. the same test in checkWiredInTyCon above - ; ASSERT2( isExternalName name, ppr name ) - unless (mod == nameModule name) - (loadWiredInHomeIface name) } - tcIfaceTyCon :: IfaceTyCon -> IfL TyCon tcIfaceTyCon IfaceIntTc = tcWiredInTyCon intTyCon tcIfaceTyCon IfaceBoolTc = tcWiredInTyCon boolTyCon @@ -1101,7 +1157,7 @@ tcIfaceTyCon IfaceUbxTupleKindTc = return ubxTupleKindTyCon -- sure the instances and RULES of this tycon are loaded -- Imagine: f :: Double -> Double tcWiredInTyCon :: TyCon -> IfL TyCon -tcWiredInTyCon tc = do { ifCheckWiredInThing (tyConName tc) +tcWiredInTyCon tc = do { ifCheckWiredInThing (ATyCon tc) ; return tc } tcIfaceClass :: Name -> IfL Class diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 18cac804b6..a6ff043922 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -1293,14 +1293,13 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod) implicitTyThings :: TyThing -> [TyThing] -- For data and newtype declarations: -implicitTyThings (ATyCon tc) = - -- fields (names of selectors) - map AnId (tyConSelIds tc) ++ - -- (possibly) implicit coercion and family coercion - -- depending on whether it's a newtype or a family instance or both +implicitTyThings (ATyCon tc) + = -- fields (names of selectors) + -- (possibly) implicit coercion and family coercion + -- depending on whether it's a newtype or a family instance or both implicitCoTyCon tc ++ - -- for each data constructor in order, - -- the contructor, worker, and (possibly) wrapper + -- for each data constructor in order, + -- the contructor, worker, and (possibly) wrapper concatMap (extras_plus . ADataCon) (tyConDataCons tc) implicitTyThings (AClass cl) diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 9fe7504163..b4d49c9268 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -523,8 +523,7 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do e_fs = fsLit "e" e_name = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span e_tyvar = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol) - exn_id = Id.mkGlobalId VanillaGlobal exn_name (mkTyVarTy e_tyvar) - vanillaIdInfo + exn_id = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar) new_tyvars = unitVarSet e_tyvar ictxt0 = hsc_IC hsc_env @@ -575,8 +574,7 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do -- _result in scope at any time. let result_name = mkInternalName (getUnique result_fs) (mkVarOccFS result_fs) span - result_id = Id.mkGlobalId VanillaGlobal result_name result_ty - vanillaIdInfo + result_id = Id.mkVanillaGlobal result_name result_ty -- for each Id we're about to bind in the local envt: -- - skolemise the type variables in its type, so they can't @@ -610,7 +608,7 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do loc = nameSrcSpan (idName id) name = mkInternalName uniq occ loc ty = idType id - new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id) + new_id = Id.mkVanillaGlobalWithInfo name ty (idInfo id) return new_id rttiEnvironment :: HscEnv -> IO HscEnv diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 82021b8133..f7644f67eb 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -4,7 +4,8 @@ \section{Tidying up Core} \begin{code} -module TidyPgm( mkBootModDetailsDs, mkBootModDetailsTc, tidyProgram ) where +module TidyPgm( mkBootModDetailsDs, mkBootModDetailsTc, + tidyProgram, globaliseAndTidyId ) where #include "HsVersions.h" @@ -18,11 +19,11 @@ import CoreTidy import PprCore import CoreLint import CoreUtils +import Class ( classSelIds ) import VarEnv import VarSet import Var import Id -import Class import IdInfo import InstEnv import NewDemand @@ -134,7 +135,7 @@ mkBootModDetails hsc_env exports type_env insts fam_insts = do { let dflags = hsc_dflags hsc_env ; showPass dflags "Tidy [hoot] type env" - ; let { insts' = tidyInstances tidyExternalId insts + ; let { insts' = tidyInstances globaliseAndTidyId insts ; dfun_ids = map instanceDFunId insts' ; type_env1 = tidyBootTypeEnv (availsToNameSet exports) type_env ; type_env' = extendTypeEnvWithIds type_env1 dfun_ids @@ -161,7 +162,7 @@ tidyBootTypeEnv exports type_env -- because we don't tidy the OccNames, and if we don't remove -- the non-exported ones we'll get many things with the -- same name in the interface file, giving chaos. - final_ids = [ tidyExternalId id + final_ids = [ globaliseAndTidyId id | id <- typeEnvIds type_env , isLocalId id , keep_it id ] @@ -172,13 +173,17 @@ tidyBootTypeEnv exports type_env keep_it id = isExportedId id || idName id `elemNameSet` exports -tidyExternalId :: Id -> Id + +globaliseAndTidyId :: Id -> Id -- Takes an LocalId with an External Name, --- makes it into a GlobalId with VanillaIdInfo, and tidies its type --- (NB: vanillaIdInfo makes a conservative assumption about Caf-hood.) -tidyExternalId id - = ASSERT2( isLocalId id && isExternalName (idName id), ppr id ) - mkVanillaGlobal (idName id) (tidyTopType (idType id)) +-- makes it into a GlobalId +-- * unchanged Name (might be Internal or External) +-- * unchanged details +-- * VanillaIdInfo (makes a conservative assumption about Caf-hood) +globaliseAndTidyId id + = Id.setIdType (globaliseId id) tidy_type + where + tidy_type = tidyTopType (idType id) \end{code} @@ -476,21 +481,11 @@ It's much safer just to inject them right at the end, after tidying. \begin{code} getImplicitBinds :: TypeEnv -> [CoreBind] getImplicitBinds type_env - = map get_defn (concatMap implicit_con_ids (typeEnvTyCons type_env) - ++ concatMap other_implicit_ids (typeEnvElts type_env)) - -- Put the constructor wrappers first, because - -- other implicit bindings (notably the fromT functions arising - -- from generics) use the constructor wrappers. At least that's - -- what External Core likes + = map get_defn (concatMap implicit_ids (typeEnvElts type_env)) where - implicit_con_ids tc = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc) - - other_implicit_ids (ATyCon tc) = filter (not . isNaughtyRecordSelector) (tyConSelIds tc) - -- The "naughty" ones are not real functions at all - -- They are there just so we can get decent error messages - -- See Note [Naughty record selectors] in MkId.lhs - other_implicit_ids (AClass cl) = classSelIds cl - other_implicit_ids _other = [] + implicit_ids (ATyCon tc) = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc) + implicit_ids (AClass cls) = classSelIds cls + implicit_ids _ = [] get_defn :: Id -> CoreBind get_defn id = NonRec id (unfoldingTemplate (idUnfolding id)) @@ -791,10 +786,7 @@ tidyTopPair ext_ids rhs_tidy_env caf_info name' (bndr, rhs) = (bndr', rhs') where bndr' = mkGlobalId details name' ty' idinfo' - -- Preserve the GlobalIdDetails of existing global-ids - details = case globalIdDetails bndr of - NotGlobalId -> VanillaGlobal - old_details -> old_details + details = idDetails bndr -- Preserve the IdDetails ty' = tidyTopType (idType bndr) rhs' = tidyExpr rhs_tidy_env rhs idinfo = idInfo bndr diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index 80530b9398..a279b4b689 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -223,7 +223,6 @@ pcTyCon is_enum is_rec name tyvars cons tyvars [] -- No stupid theta (DataTyCon cons is_enum) - [] -- No record selectors NoParentTyCon is_rec True -- All the wired-in tycons have generics diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index e52e3f1cb5..0dcd42168e 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -718,6 +718,8 @@ renameSigs mb_names ok_sig sigs renameSig :: Maybe NameSet -> Sig RdrName -> RnM (Sig Name) -- FixitySig is renamed elsewhere. +renameSig _ (IdSig x) + = return (IdSig x) -- Actually this never occurs renameSig mb_names sig@(TypeSig v ty) = do { new_v <- lookupSigOccRn mb_names sig v ; new_ty <- rnHsSigType (quotes (ppr v)) ty diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs index 9b90220155..d4aef90725 100644 --- a/compiler/simplCore/CSE.lhs +++ b/compiler/simplCore/CSE.lhs @@ -342,7 +342,7 @@ extendSubst (CS cs in_scope sub) x y = CS cs in_scope (extendVarEnv sub x y) addBinder :: CSEnv -> Id -> (CSEnv, Id) addBinder (CS cs in_scope sub) v | not (v `elemInScopeSet` in_scope) = (CS cs (extendInScopeSet in_scope v) sub, v) - | isIdVar v = (CS cs (extendInScopeSet in_scope v') (extendVarEnv sub v v'), v') + | isId v = (CS cs (extendInScopeSet in_scope v') (extendVarEnv sub v v'), v') | otherwise = WARN( True, ppr v ) (CS emptyUFM in_scope sub, v) -- This last case is the unusual situation where we have shadowing of diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs index 1146c77031..36e3d4de70 100644 --- a/compiler/simplCore/FloatIn.lhs +++ b/compiler/simplCore/FloatIn.lhs @@ -373,7 +373,7 @@ noFloatIntoRhs (AnnLam b _) = not (is_one_shot b) noFloatIntoRhs rhs = exprIsHNF (deAnnotate' rhs) -- We'd just float right back out again... is_one_shot :: Var -> Bool -is_one_shot b = isIdVar b && isOneShotBndr b +is_one_shot b = isId b && isOneShotBndr b \end{code} diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs index 270ce17095..6f48272a9f 100644 --- a/compiler/simplCore/SetLevels.lhs +++ b/compiler/simplCore/SetLevels.lhs @@ -525,7 +525,7 @@ lvlBind top_lvl ctxt_lvl env (AnnRec pairs) new_rhss <- mapM (lvlExpr ctxt_lvl new_env) rhss return (Rec ([TB b dest_lvl | b <- new_bndrs] `zip` new_rhss), new_env) - | isSingleton pairs && count isIdVar abs_vars > 1 + | isSingleton pairs && count isId abs_vars > 1 = do -- Special case for self recursion where there are -- several variables carried around: build a local loop: -- poly_f = \abs_vars. \lam_vars . letrec f = \lam_vars. rhs in f lam_vars @@ -605,7 +605,7 @@ lvlLamBndrs lvl bndrs [] bndrs where go old_lvl bumped_major rev_lvld_bndrs (bndr:bndrs) - | isIdVar bndr && -- Go to the next major level if this is a value binder, + | isId bndr && -- Go to the next major level if this is a value binder, not bumped_major && -- and we havn't already gone to the next level (one jump per group) not (isOneShotLambda bndr) -- and it isn't a one-shot lambda = go new_lvl True (TB bndr new_lvl : rev_lvld_bndrs) bndrs @@ -647,7 +647,7 @@ isFunction :: CoreExprWithFVs -> Bool -- We may only want to do this if there are sufficiently few free -- variables. We certainly only want to do it for values, and not for -- constructors. So the simple thing is just to look for lambdas -isFunction (_, AnnLam b e) | isIdVar b = True +isFunction (_, AnnLam b e) | isId b = True | otherwise = isFunction e isFunction (_, AnnNote _ e) = isFunction e isFunction _ = False @@ -765,10 +765,10 @@ maxIdLevel (_, lvl_env,_,id_env) var_set Nothing -> [in_var]) max_out out_var lvl - | isIdVar out_var = case lookupVarEnv lvl_env out_var of + | isId out_var = case lookupVarEnv lvl_env out_var of Just lvl' -> maxLvl lvl' lvl Nothing -> lvl - | otherwise = lvl -- Ignore tyvars in *maxIdLevel* + | otherwise = lvl -- Ignore tyvars in *maxIdLevel* lookupVar :: LevelEnv -> Id -> LevelledExpr lookupVar (_, _, _, id_env) v = case lookupVarEnv id_env v of @@ -808,7 +808,7 @@ abstractVars dest_lvl (_, lvl_env, _, id_env) fvs -- We are going to lambda-abstract, so nuke any IdInfo, -- and add the tyvars of the Id (if necessary) - zap v | isIdVar v = WARN( workerExists (idWorkerInfo v) || + zap v | isId v = WARN( workerExists (idWorkerInfo v) || not (isEmptySpecInfo (idSpecialisation v)), text "absVarsOf: discarding info on" <+> ppr v ) setIdInfo v vanillaIdInfo @@ -823,7 +823,7 @@ absVarsOf :: IdEnv ([Var], LevelledExpr) -> Var -> [Var] -- we must look in x's type -- And similarly if x is a coercion variable. absVarsOf id_env v - | isIdVar v = [av2 | av1 <- lookup_avs v + | isId v = [av2 | av1 <- lookup_avs v , av2 <- add_tyvars av1] | isCoVar v = add_tyvars v | otherwise = [v] @@ -871,7 +871,7 @@ cloneVar :: TopLevelFlag -> LevelEnv -> Id -> Level -> Level -> LvlM (LevelEnv, cloneVar TopLevel env v _ _ = return (env, v) -- Don't clone top level things cloneVar NotTopLevel env@(_,_,subst,_) v ctxt_lvl dest_lvl - = ASSERT( isIdVar v ) do + = ASSERT( isId v ) do us <- getUniqueSupplyM let (subst', v1) = cloneIdBndr subst us v @@ -883,7 +883,7 @@ cloneRecVars :: TopLevelFlag -> LevelEnv -> [Id] -> Level -> Level -> LvlM (Leve cloneRecVars TopLevel env vs _ _ = return (env, vs) -- Don't clone top level things cloneRecVars NotTopLevel env@(_,_,subst,_) vs ctxt_lvl dest_lvl - = ASSERT( all isIdVar vs ) do + = ASSERT( all isId vs ) do us <- getUniqueSupplyM let (subst', vs1) = cloneRecIdBndrs subst us vs diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index 98ef348be7..d6aecc4b39 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -43,7 +43,7 @@ import FloatOut ( floatOutwards ) import FamInstEnv import Id import DataCon -import TyCon ( tyConSelIds, tyConDataCons ) +import TyCon ( tyConDataCons ) import Class ( classSelIds ) import BasicTypes ( CompilerPhase, isActive ) import VarSet diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs index d11dc7565f..d8c63b6cb7 100644 --- a/compiler/stgSyn/CoreToStg.lhs +++ b/compiler/stgSyn/CoreToStg.lhs @@ -523,7 +523,7 @@ coreToStgApp _ f args = do -- two regardless. res_ty = exprType (mkApps (Var f) args) - app = case globalIdDetails f of + app = case idDetails f of DataConWorkId dc | saturated -> StgConApp dc args' PrimOpId op -> ASSERT( saturated ) StgOpApp (StgPrimOp op) args' res_ty diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index 198e80bacc..917c624280 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -267,7 +267,7 @@ dmdAnal sigs dmd (Case scrut case_bndr ty [alt@(DataAlt dc,bndrs,rhs)]) -- The insight is, of course, that a demand on y is a demand on the -- scrutinee, so we need to `both` it with the scrut demand - alt_dmd = Eval (Prod [idNewDemandInfo b | b <- bndrs', isIdVar b]) + alt_dmd = Eval (Prod [idNewDemandInfo b | b <- bndrs', isId b]) scrut_dmd = alt_dmd `both` idNewDemandInfo case_bndr' @@ -747,7 +747,7 @@ annotateLamIdBndr :: DmdType -- Demand type of body annotateLamIdBndr dmd_ty@(DmdType fv ds res) id -- For lambdas we add the demand to the argument demands -- Only called for Ids - = ASSERT( isIdVar id ) + = ASSERT( isId id ) (DmdType fv' (hacked_dmd:ds) res, setIdNewDemandInfo id hacked_dmd) where (fv', dmd) = removeFV fv id res diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs index 5143eea08e..9f19dc35b1 100644 --- a/compiler/stranal/WorkWrap.lhs +++ b/compiler/stranal/WorkWrap.lhs @@ -283,7 +283,7 @@ splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs -- which is very annoying. get_one_shots :: Expr Var -> [Bool] get_one_shots (Lam b e) - | isIdVar b = isOneShotLambda b : get_one_shots e + | isId b = isOneShotLambda b : get_one_shots e | otherwise = get_one_shots e get_one_shots (Note _ e) = get_one_shots e get_one_shots _ = noOneShotInfo diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs index 0bde744385..a7050dc0d0 100644 --- a/compiler/stranal/WwLib.lhs +++ b/compiler/stranal/WwLib.lhs @@ -23,7 +23,7 @@ import TysWiredIn ( tupleCon ) import Type import Coercion ( mkSymCoercion, splitNewTypeRepCo_maybe ) import BasicTypes ( Boxity(..) ) -import Var ( Var, isIdVar ) +import Var ( Var, isId ) import UniqSupply import Unique import Util ( zipWithEqual ) @@ -127,13 +127,13 @@ mkWwBodies fun_ty demands res_info one_shots -- Don't do CPR if the worker doesn't have any value arguments -- Then the worker is just a constant, so we don't want to unbox it. ; (wrap_fn_cpr, work_fn_cpr, _cpr_res_ty) - <- if any isIdVar work_args then + <- if any isId work_args then mkWWcpr res_ty res_info else return (id, id, res_ty) ; let (work_lam_args, work_call_args) = mkWorkerArgs work_args res_ty - ; return ([idNewDemandInfo v | v <- work_call_args, isIdVar v], + ; return ([idNewDemandInfo v | v <- work_call_args, isId v], Note InlineMe . wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var, mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args) } -- We use an INLINE unconditionally, even if the wrapper turns out to be @@ -169,7 +169,7 @@ mkWorkerArgs :: [Var] -> ([Var], -- Lambda bound args [Var]) -- Args at call site mkWorkerArgs args res_ty - | any isIdVar args || not (isUnLiftedType res_ty) + | any isId args || not (isUnLiftedType res_ty) = (args, args) | otherwise = (args ++ [voidArgId], args ++ [realWorldPrimId]) diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index b4c0d1afa8..c67eeef915 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -98,7 +98,7 @@ tcHsBootSigs :: HsValBinds Name -> TcM [Id] -- signatures in it. The renamer checked all this tcHsBootSigs (ValBindsOut binds sigs) = do { checkTc (null binds) badBootDeclErr - ; mapM (addLocM tc_boot_sig) (filter isVanillaLSig sigs) } + ; mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) } where tc_boot_sig (TypeSig (L _ name) ty) = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty @@ -151,7 +151,7 @@ tcValBinds _ (ValBindsIn binds _) _ tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside = do { -- Typecheck the signature ; let { prag_fn = mkPragFun sigs - ; ty_sigs = filter isVanillaLSig sigs + ; ty_sigs = filter isTypeLSig sigs ; sig_fn = mkTcSigFun ty_sigs } ; poly_ids <- checkNoErrs (mapAndRecoverM tcTySig ty_sigs) @@ -428,8 +428,7 @@ tcPrag :: TcId -> Sig Name -> TcM Prag tcPrag poly_id (SpecSig _ hs_ty inl) = tcSpecPrag poly_id hs_ty inl tcPrag poly_id (SpecInstSig hs_ty) = tcSpecPrag poly_id hs_ty defaultInlineSpec tcPrag _ (InlineSig _ inl) = return (InlinePrag inl) -tcPrag _ (FixSig {}) = panic "tcPrag FixSig" -tcPrag _ (TypeSig {}) = panic "tcPrag TypeSig" +tcPrag _ sig = pprPanic "tcPrag" (ppr sig) tcSpecPrag :: TcId -> LHsType Name -> InlineSpec -> TcM Prag @@ -1045,8 +1044,10 @@ mkTcSigFun :: [LSig Name] -> TcSigFun -- Precondition: no duplicates mkTcSigFun sigs = lookupNameEnv env where - env = mkNameEnv [(name, hsExplicitTvs lhs_ty) - | L _ (TypeSig (L _ name) lhs_ty) <- sigs] + env = mkNameEnv (mapCatMaybes mk_pair sigs) + mk_pair (L _ (TypeSig (L _ name) lhs_ty)) = Just (name, hsExplicitTvs lhs_ty) + mk_pair (L _ (IdSig id)) = Just (idName id, []) + mk_pair _ = Nothing -- The scoped names are the ones explicitly mentioned -- in the HsForAll. (There may be more in sigma_ty, because -- of nested type synonyms. See Note [More instantiated than scoped].) @@ -1100,6 +1101,8 @@ tcTySig (L span (TypeSig (L _ name) ty)) = setSrcSpan span $ do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty ; return (mkLocalId name sigma_ty) } +tcTySig (L _ (IdSig id)) + = return id tcTySig s = pprPanic "tcTySig" (ppr s) ------------------- diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 8c37e08705..14f9541f29 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -126,11 +126,8 @@ tcLookupGlobal name }}}}} tcLookupField :: Name -> TcM Id -- Returns the selector Id -tcLookupField name = do - thing <- tcLookup name -- Note [Record field lookup] - case thing of - AGlobal (AnId id) -> return id - thing -> wrongThingErr "field name" thing name +tcLookupField name + = tcLookupId name -- Note [Record field lookup] {- Note [Record field lookup] ~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 3048174bef..7d3b0120e0 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -321,14 +321,15 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls ; let { (local_info, at_tycons_s) = unzip local_info_tycons - ; at_idx_tycon = concat at_tycons_s ++ idx_tycons + ; at_idx_tycons = concat at_tycons_s ++ idx_tycons ; clas_decls = filter (isClassDecl.unLoc) tycl_decls - ; implicit_things = concatMap implicitTyThings at_idx_tycon + ; implicit_things = concatMap implicitTyThings at_idx_tycons + ; aux_binds = mkAuxBinds at_idx_tycons } -- (2) Add the tycons of indexed types and their implicit -- tythings to the global environment - ; tcExtendGlobalEnv (at_idx_tycon ++ implicit_things) $ do { + ; tcExtendGlobalEnv (at_idx_tycons ++ implicit_things) $ do { -- (3) Instances from generic class declarations ; generic_inst_info <- getGenericInstances clas_decls @@ -340,7 +341,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls -- c) local family instance decls ; addInsts local_info $ do { ; addInsts generic_inst_info $ do { - ; addFamInsts at_idx_tycon $ do { + ; addFamInsts at_idx_tycons $ do { -- (4) Compute instances from "deriving" clauses; -- This stuff computes a context for the derived instance @@ -352,13 +353,11 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls -- more errors still ; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls inst_decls deriv_decls - ; addInsts deriv_inst_info $ do { - - ; gbl_env <- getGblEnv + ; gbl_env <- addInsts deriv_inst_info getGblEnv ; return (gbl_env, generic_inst_info ++ deriv_inst_info ++ local_info, - deriv_binds) - }}}}}} + aux_binds `plusHsValBinds` deriv_binds) + }}}}} where -- Make sure that toplevel type instance are not for associated types. -- !!!TODO: Need to perform this check for the TyThing of type functions, diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 6d2d34ab1a..cc7d63dbf6 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -98,6 +98,7 @@ import IdInfo import {- Kind parts of -} Type import BasicTypes import Foreign.Ptr( Ptr ) +import TidyPgm ( globaliseAndTidyId ) #endif import FastString @@ -306,10 +307,12 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- Typecheck them all together so that -- any mutually recursive types are done right - tcg_env <- tcTyAndClassDecls emptyModDetails rn_decls ; - -- Make the new type env available to stuff slurped from interface files + -- Just discard the auxiliary bindings; they are generated + -- only for Haskell source code, and should already be in Core + (tcg_env, _aux_binds) <- tcTyAndClassDecls emptyModDetails rn_decls ; setGblEnv tcg_env $ do { + -- Make the new type env available to stuff slurped from interface files -- Now the core bindings core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ; @@ -486,7 +489,7 @@ tcRnHsBootDecls decls -- Typecheck type/class decls ; traceTc (text "Tc2") - ; tcg_env <- tcTyAndClassDecls emptyModDetails tycl_decls + ; (tcg_env, aux_binds) <- tcTyAndClassDecls emptyModDetails tycl_decls ; setGblEnv tcg_env $ do { -- Typecheck instance decls @@ -506,11 +509,18 @@ tcRnHsBootDecls decls -- Make the final type-env -- Include the dfun_ids so that their type sigs - -- are written into the interface file + -- are written into the interface file. + -- And similarly the aux_ids from aux_binds ; let { type_env0 = tcg_type_env gbl_env ; type_env1 = extendTypeEnvWithIds type_env0 val_ids ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids - ; dfun_ids = map iDFunId inst_infos } + ; type_env3 = extendTypeEnvWithIds type_env1 aux_ids + ; dfun_ids = map iDFunId inst_infos + ; aux_ids = case aux_binds of + ValBindsOut _ sigs -> [id | L _ (IdSig id) <- sigs] + _ -> panic "tcRnHsBoodDecls" + } + ; setGlobalTypeEnv gbl_env type_env2 }}}} @@ -787,7 +797,7 @@ tcTopSrcDecls boot_details -- The latter come in via tycl_decls traceTc (text "Tc2") ; - tcg_env <- tcTyAndClassDecls boot_details tycl_decls ; + (tcg_env, aux_binds) <- tcTyAndClassDecls boot_details tycl_decls ; -- If there are any errors, tcTyAndClassDecls fails here setGblEnv tcg_env $ do { @@ -798,8 +808,7 @@ tcTopSrcDecls boot_details <- tcInstDecls1 tycl_decls inst_decls deriv_decls; setGblEnv tcg_env $ do { - -- Foreign import declarations next. No zonking necessary - -- here; we can tuck them straight into the global environment. + -- Foreign import declarations next. traceTc (text "Tc4") ; (fi_ids, fi_decls) <- tcForeignImports foreign_decls ; tcExtendGlobalValEnv fi_ids $ do { @@ -809,25 +818,27 @@ tcTopSrcDecls boot_details default_tys <- tcDefaults default_decls ; updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do { + -- Now GHC-generated derived bindings, generics, and selectors + -- Do not generate warnings from compiler-generated code; + -- hence the use of discardWarnings + (tc_aux_binds, tcl_env) <- discardWarnings (tcTopBinds aux_binds) ; + (tc_deriv_binds, tcl_env) <- setLclTypeEnv tcl_env $ + discardWarnings (tcTopBinds deriv_binds) ; + -- Value declarations next - -- We also typecheck any extra binds that came out - -- of the "deriving" process (deriv_binds) traceTc (text "Tc5") ; - (tc_val_binds, tcl_env) <- tcTopBinds val_binds ; - setLclTypeEnv tcl_env $ do { - - -- Now GHC-generated derived bindings and generics. - -- Do not generate warnings from compiler-generated code. - (tc_deriv_binds, tcl_env) <- discardWarnings $ - tcTopBinds deriv_binds ; + (tc_val_binds, tcl_env) <- setLclTypeEnv tcl_env $ + tcTopBinds val_binds; -- Second pass over class and instance declarations, traceTc (text "Tc6") ; - (inst_binds, tcl_env) <- setLclTypeEnv tcl_env $ tcInstDecls2 tycl_decls inst_infos ; - showLIE (text "after instDecls2") ; + (inst_binds, tcl_env) <- setLclTypeEnv tcl_env $ + tcInstDecls2 tycl_decls inst_infos ; + showLIE (text "after instDecls2") ; + + setLclTypeEnv tcl_env $ do { -- Environment doesn't change now -- Foreign exports - -- They need to be zonked, so we return them traceTc (text "Tc7") ; (foe_binds, foe_decls) <- tcForeignExports foreign_decls ; @@ -842,6 +853,7 @@ tcTopSrcDecls boot_details tcg_env <- getGblEnv ; let { all_binds = tc_val_binds `unionBags` tc_deriv_binds `unionBags` + tc_aux_binds `unionBags` inst_binds `unionBags` foe_binds; @@ -1016,8 +1028,9 @@ tcRnStmt hsc_env ictxt rdr_stmt mapM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ; traceTc (text "tcs 1") ; - let { global_ids = map globaliseAndTidy zonked_ids } ; - + let { global_ids = map globaliseAndTidyId zonked_ids } ; + -- Note [Interactively-bound Ids in GHCi] + {- --------------------------------------------- At one stage I removed any shadowed bindings from the type_env; they are inaccessible but might, I suppose, cause a space leak if we leave them there. @@ -1046,12 +1059,6 @@ tcRnStmt hsc_env ictxt rdr_stmt where bad_unboxed id = addErr (sep [ptext (sLit "GHCi can't bind a variable of unlifted type:"), nest 2 (ppr id <+> dcolon <+> ppr (idType id))]) - -globaliseAndTidy :: Id -> Id -globaliseAndTidy id -- Note [Interactively-bound Ids in GHCi] - = Id.setIdType (globaliseId VanillaGlobal id) tidy_type - where - tidy_type = tidyTopType (idType id) \end{code} Note [Interactively-bound Ids in GHCi] diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 9a03acb0e3..af4d320564 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -872,7 +872,7 @@ reifyThing (AGlobal (AnId id)) = do { ty <- reifyType (idType id) ; fix <- reifyFixity (idName id) ; let v = reifyName id - ; case globalIdDetails id of + ; case idDetails id of ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix) _ -> return (TH.VarI v ty Nothing fix) } diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 2d68a6e3b8..18be4c37f0 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -7,7 +7,7 @@ TcTyClsDecls: Typecheck type and class declarations \begin{code} module TcTyClsDecls ( - tcTyAndClassDecls, tcFamInstDecl + tcTyAndClassDecls, tcFamInstDecl, mkAuxBinds ) where #include "HsVersions.h" @@ -25,6 +25,7 @@ import TcClassDcl import TcHsType import TcMType import TcType +import TysWiredIn ( unitTy ) import FunDeps import Type import Generics @@ -32,6 +33,8 @@ import Class import TyCon import DataCon import Id +import MkId ( rEC_SEL_ERROR_ID ) +import IdInfo import Var import VarSet import Name @@ -46,7 +49,10 @@ import ListSetOps import Digraph import DynFlags import FastString +import Unique ( mkBuiltinUnique ) +import BasicTypes +import Bag import Data.List import Control.Monad ( mplus ) \end{code} @@ -133,8 +139,9 @@ indeed type families). I think. \begin{code} tcTyAndClassDecls :: ModDetails -> [LTyClDecl Name] - -> TcM TcGblEnv -- Input env extended by types and classes - -- and their implicit Ids,DataCons + -> TcM (TcGblEnv, -- Input env extended by types and classes + -- and their implicit Ids,DataCons + HsValBinds Name) -- Renamed bindings for record selectors -- Fails if there are any errors tcTyAndClassDecls boot_details allDecls @@ -199,11 +206,13 @@ tcTyAndClassDecls boot_details allDecls -- NB: All associated types and their implicit things will be added a -- second time here. This doesn't matter as the definitions are -- the same. - ; let { implicit_things = concatMap implicitTyThings alg_tyclss } + ; let { implicit_things = concatMap implicitTyThings alg_tyclss + ; aux_binds = mkAuxBinds alg_tyclss } ; traceTc ((text "Adding" <+> ppr alg_tyclss) $$ (text "and" <+> ppr implicit_things)) - ; tcExtendGlobalEnv implicit_things getGblEnv - }} + ; env <- tcExtendGlobalEnv implicit_things getGblEnv + ; return (env, aux_binds) } + } where -- Pull associated types out of class declarations, to tie them into the -- knot above. @@ -230,7 +239,7 @@ mkGlobalThings decls things %************************************************************************ %* * -\subsection{Type checking family instances} + Type checking family instances %* * %************************************************************************ @@ -360,7 +369,7 @@ tcFamInstDecl1 d = pprPanic "tcFamInstDecl1" (ppr d) -- * Here we check that a type instance matches its kind signature, but we do -- not check whether there is a pattern for each type index; the latter -- check is only required for type synonym instances. --- + kcIdxTyPats :: TyClDecl Name -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a) -- ^^kinded tvs ^^kinded ty pats ^^res kind @@ -853,8 +862,9 @@ tcConDecl unbox_strict existential_ok rep_tycon res_tmpl -- Data types -- In this case orig_res_ty = T (e,e) tcResultType :: ([TyVar], Type) -- Template for result type; e.g. - -- data T a b c = ... gives ([a,b,c], T a b) - -> [TyVar] -- where MkT :: forall a b c. ... + -- data instance T [a] b c = ... + -- gives template ([a,b,c], T [a] b c) + -> [TyVar] -- where MkT :: forall x y z. ... -> ResType Name -> TcM ([TyVar], -- Universal [TyVar], -- Existential (distinct OccNames from univs) @@ -879,6 +889,7 @@ tcResultType (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty) -- b b~z -- z -- Existentials are the leftover type vars: [x,y] + -- So we return ([a,b,z], [x,y], [a~(x,y),b~z], T [(x,y)] z z) = do { res_ty' <- tcHsKindedType res_ty ; let Just subst = tcMatchTy (mkVarSet tmpl_tvs) res_tmpl res_ty' @@ -952,9 +963,10 @@ But it's the *argument* type that matters. This is fine: data S = MkS S !Int because Int is non-recursive. + %************************************************************************ %* * -\subsection{Dependency analysis} + Validity checking %* * %************************************************************************ @@ -1175,9 +1187,175 @@ checkValidClass cls -- forall has an (Eq a) constraint. Whereas in general, each constraint -- in the context of a for-all must mention at least one quantified -- type variable. What a mess! +\end{code} + + +%************************************************************************ +%* * + Building record selectors +%* * +%************************************************************************ + +\begin{code} +mkAuxBinds :: [TyThing] -> HsValBinds Name +mkAuxBinds ty_things + = ValBindsOut [(NonRecursive, b) | b <- binds] sigs + where + (sigs, binds) = unzip rec_sels + rec_sels = map mkRecSelBind [ (tc,fld) + | ATyCon tc <- ty_things + , fld <- tyConFields tc ] ---------------------------------------------------------------------- +mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name) +mkRecSelBind (tycon, sel_name) + = (L loc (IdSig sel_id), unitBag (L loc sel_bind)) + where + loc = getSrcSpan tycon + sel_id = Var.mkLocalVar rec_details sel_name sel_ty vanillaIdInfo + rec_details = RecSelId { sel_tycon = tycon, sel_naughty = is_naughty } + + -- Find a representative constructor, con1 + all_cons = tyConDataCons tycon + cons_w_field = [ con | con <- all_cons + , sel_name `elem` dataConFieldLabels con ] + con1 = ASSERT( not (null cons_w_field) ) head cons_w_field + + -- Selector type; Note [Polymorphic selectors] + field_ty = dataConFieldType con1 sel_name + (field_tvs, field_theta, field_tau) + | is_naughty = ([], [], unitTy) + | otherwise = tcSplitSigmaTy field_ty + data_ty = dataConOrigResTy con1 + data_tvs = tyVarsOfType data_ty + is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tvs) + sel_ty = mkForAllTys (varSetElems data_tvs ++ field_tvs) $ + mkPhiTy (dataConStupidTheta con1) $ -- Urgh! + mkPhiTy field_theta $ -- Urgh! + mkFunTy data_ty field_tau + + -- Make the binding: sel (C2 { fld = x }) = x + -- sel (C7 { fld = x }) = x + -- where cons_w_field = [C2,C7] + sel_bind = mkFunBind sel_lname (map mk_match cons_w_field ++ deflt) + mk_match con = mkSimpleMatch [L loc (mk_sel_pat con)] + (L loc match_body) + mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields) + rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing } + rec_field = HsRecField { hsRecFieldId = sel_lname + , hsRecFieldArg = nlVarPat field_var + , hsRecPun = False } + match_body | is_naughty = ExplicitTuple [] Boxed + | otherwise = HsVar field_var + sel_lname = L loc sel_name + field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc + + -- Add catch-all default case unless the case is exhaustive + -- We do this explicitly so that we get a nice error message that + -- mentions this particular record selector + deflt | length cons_w_field == length all_cons = [] + | otherwise = [mkSimpleMatch [nlWildPat] + (nlHsApp (nlHsVar (getName rEC_SEL_ERROR_ID)) + (nlHsLit msg_lit))] + msg_lit = HsStringPrim $ mkFastString $ + occNameString (getOccName sel_name) + +--------------- +tyConFields :: TyCon -> [FieldLabel] +tyConFields tc + | isAlgTyCon tc = nub (concatMap dataConFieldLabels (tyConDataCons tc)) + | otherwise = [] +\end{code} + +Note [Polymorphic selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When a record has a polymorphic field, we pull the foralls out to the front. + data T = MkT { f :: forall a. [a] -> a } +Then f :: forall a. T -> [a] -> a +NOT f :: T -> forall a. [a] -> a + +This is horrid. It's only needed in deeply obscure cases, which I hate. +The only case I know is test tc163, which is worth looking at. It's far +from clear that this test should succeed at all! + +Note [Naughty record selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A "naughty" field is one for which we can't define a record +selector, because an existential type variable would escape. For example: + data T = forall a. MkT { x,y::a } +We obviously can't define + x (MkT v _) = v +Nevertheless we *do* put a RecSelId into the type environment +so that if the user tries to use 'x' as a selector we can bleat +helpfully, rather than saying unhelpfully that 'x' is not in scope. +Hence the sel_naughty flag, to identify record selectors that don't really exist. + +In general, a field is naughty if its type mentions a type variable that +isn't in the result type of the constructor. + +We make a dummy binding for naughty selectors, so that they can be treated +uniformly, apart from their sel_naughty field. The function is never called. + +Note [GADT record selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For GADTs, we require that all constructors with a common field 'f' have the same +result type (modulo alpha conversion). [Checked in TcTyClsDecls.checkValidTyCon] +E.g. + data T where + T1 { f :: Maybe a } :: T [a] + T2 { f :: Maybe a, y :: b } :: T [a] + +and now the selector takes that result type as its argument: + f :: forall a. T [a] -> Maybe a + +Details: the "real" types of T1,T2 are: + T1 :: forall r a. (r~[a]) => a -> T r + T2 :: forall r a b. (r~[a]) => a -> b -> T r + +So the selector loooks like this: + f :: forall a. T [a] -> Maybe a + f (a:*) (t:T [a]) + = case t of + T1 c (g:[a]~[c]) (v:Maybe c) -> v `cast` Maybe (right (sym g)) + T2 c d (g:[a]~[c]) (v:Maybe c) (w:d) -> v `cast` Maybe (right (sym g)) + +Note the forall'd tyvars of the selector are just the free tyvars +of the result type; there may be other tyvars in the constructor's +type (e.g. 'b' in T2). + +Note the need for casts in the result! + +Note [Selector running example] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's OK to combine GADTs and type families. Here's a running example: + + data instance T [a] where + T1 { fld :: b } :: T [Maybe b] + +The representation type looks like this + data :R7T a where + T1 { fld :: b } :: :R7T (Maybe b) + +and there's coercion from the family type to the representation type + :CoR7T a :: T [a] ~ :R7T a + +The selector we want for fld looks like this: + + fld :: forall b. T [Maybe b] -> b + fld = /\b. \(d::T [Maybe b]). + case d `cast` :CoR7T (Maybe b) of + T1 (x::b) -> x + +The scrutinee of the case has type :R7T (Maybe b), which can be +gotten by appying the eq_spec to the univ_tvs of the data con. + +%************************************************************************ +%* * + Error messages +%* * +%************************************************************************ + +\begin{code} resultTypeMisMatch :: Name -> DataCon -> DataCon -> SDoc resultTypeMisMatch field_name con1 con2 = vcat [sep [ptext (sLit "Constructors") <+> ppr con1 <+> ptext (sLit "and") <+> ppr con2, @@ -1313,13 +1491,6 @@ badFamInstDecl tc_name quotes (ppr tc_name) , nest 2 (parens $ ptext (sLit "Use -XTypeFamilies to allow indexed type families")) ] -{- -badGadtIdxTyDecl :: Name -> SDoc -badGadtIdxTyDecl tc_name - = vcat [ ptext (sLit "Illegal generalised algebraic data declaration for") <+> - quotes (ppr tc_name) - , nest 2 (parens $ ptext (sLit "Family instances can not yet use GADT declarations")) ] --} tooManyParmsErr :: Located Name -> SDoc tooManyParmsErr tc_name = ptext (sLit "Family instance has too many parameters:") <+> diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index fdd21be02b..120e1b95e6 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -55,7 +55,6 @@ module TyCon( tyConTyVars, tyConDataCons, tyConDataCons_maybe, tyConSingleDataCon_maybe, tyConFamilySize, - tyConSelIds, tyConStupidTheta, tyConArity, tyConClass_maybe, @@ -146,8 +145,6 @@ data TyCon -- -- Note that it does /not/ scope over the data constructors. - algTcSelIds :: [Id], -- ^ The record selectors of this type (possibly emptys) - algTcGadtSyntax :: Bool, -- ^ Was the data type declared with GADT syntax? If so, -- that doesn't mean it's a true GADT; only that the "where" -- form was used. This field is used only to guide @@ -574,13 +571,12 @@ mkAlgTyCon :: Name -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars'. Arity is inferred from the length of this list -> [PredType] -- ^ Stupid theta: see 'algTcStupidTheta' -> AlgTyConRhs -- ^ Information about dat aconstructors - -> [Id] -- ^ Selector 'Id's -> TyConParent -> RecFlag -- ^ Is the 'TyCon' recursive? -> Bool -- ^ Does it have generic functions? See 'hasGenerics' -> Bool -- ^ Was the 'TyCon' declared with GADT syntax? -> TyCon -mkAlgTyCon name kind tyvars stupid rhs sel_ids parent is_rec gen_info gadt_syn +mkAlgTyCon name kind tyvars stupid rhs parent is_rec gen_info gadt_syn = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, @@ -589,7 +585,6 @@ mkAlgTyCon name kind tyvars stupid rhs sel_ids parent is_rec gen_info gadt_syn tyConTyVars = tyvars, algTcStupidTheta = stupid, algTcRhs = rhs, - algTcSelIds = sel_ids, algTcParent = ASSERT( okParent name parent ) parent, algTcRec = is_rec, algTcGadtSyntax = gadt_syn, @@ -599,7 +594,7 @@ mkAlgTyCon name kind tyvars stupid rhs sel_ids parent is_rec gen_info gadt_syn -- | Simpler specialization of 'mkAlgTyCon' for classes mkClassTyCon :: Name -> Kind -> [TyVar] -> AlgTyConRhs -> Class -> RecFlag -> TyCon mkClassTyCon name kind tyvars rhs clas is_rec = - mkAlgTyCon name kind tyvars [] rhs [] (ClassTyCon clas) is_rec False False + mkAlgTyCon name kind tyvars [] rhs (ClassTyCon clas) is_rec False False mkTupleTyCon :: Name -> Kind -- ^ Kind of the resulting 'TyCon' @@ -1013,11 +1008,6 @@ tyConFamilySize (AlgTyCon {algTcRhs = OpenTyCon {}}) = 0 tyConFamilySize (TupleTyCon {}) = 1 tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other) --- | Extract the record selector 'Id's from an algebraic 'TyCon' and returns the empty list otherwise -tyConSelIds :: TyCon -> [Id] -tyConSelIds (AlgTyCon {algTcSelIds = fs}) = fs -tyConSelIds _ = [] - -- | Extract an 'AlgTyConRhs' with information about data constructors from an algebraic or tuple -- 'TyCon'. Panics for any other sort of 'TyCon' algTyConRhs :: TyCon -> AlgTyConRhs diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs index 6a8f89366f..7aef39b6b9 100644 --- a/compiler/vectorise/VectUtils.hs +++ b/compiler/vectorise/VectUtils.hs @@ -56,8 +56,8 @@ collectAnnTypeBinders expr = go [] expr collectAnnValBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann) collectAnnValBinders expr = go [] expr where - go bs (_, AnnLam b e) | isIdVar b = go (b:bs) e - go bs e = (reverse bs, e) + go bs (_, AnnLam b e) | isId b = go (b:bs) e + go bs e = (reverse bs, e) isAnnTypeArg :: AnnExpr b ann -> Bool isAnnTypeArg (_, AnnType _) = True |