diff options
Diffstat (limited to 'compiler')
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 |