From: simonpj Date: Mon, 3 Apr 2000 09:52:30 +0000 (+0000) Subject: [project @ 2000-04-03 09:52:28 by simonpj] X-Git-Tag: Approximately_9120_patches~4863 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=e4b0fab5a594c4ea29ddecdf216b4887420f26a4;p=ghc-hetmet.git [project @ 2000-04-03 09:52:28 by simonpj] * Make it so that recursive newtype declarations don't send GHC into an infinite loop. newtype T = MkT T This happened because Type.repType looked throught newtypes, and that never stopped! Now TcTyDecls.mkNewTyConRep does the job more carefully, and the result is cached in the TyCon itself. * Improve the handling of type signatures & pragmas. Previously a mis-placed (say) SPECIALISE instance pragmas could be silently ignored. Both these changes involved moving quite a lot of stuff between modules. --- diff --git a/ghc/compiler/absCSyn/CStrings.lhs b/ghc/compiler/absCSyn/CStrings.lhs index 628b540..0b543d4 100644 --- a/ghc/compiler/absCSyn/CStrings.lhs +++ b/ghc/compiler/absCSyn/CStrings.lhs @@ -2,7 +2,8 @@ This module deals with printing C string literals \begin{code} module CStrings( - CLabelString, isCLabelString, + CLabelString, isCLabelString, pprCLabelString, + cSEP, pp_cSEP, stringToC, charToC, pprFSInCStyle, @@ -19,6 +20,8 @@ import Outputable \begin{code} type CLabelString = FAST_STRING -- A C label, completely unencoded +pprCLabelString lbl = ptext lbl + isCLabelString :: CLabelString -> Bool -- Checks to see if this is a valid C label isCLabelString lbl = all ok (_UNPK_ lbl) diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index 4c147c4..3bcf942 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -38,7 +38,7 @@ import CmdLineOpts ( opt_SccProfilingOn, opt_EmitCExternDecls, opt_GranMacros ) import CostCentre ( pprCostCentreDecl, pprCostCentreStackDecl ) import Costs ( costs, addrModeCosts, CostRes(..), Side(..) ) -import CStrings ( stringToC ) +import CStrings ( stringToC, pprCLabelString ) import FiniteMap ( addToFM, emptyFM, lookupFM, FiniteMap ) import Literal ( Literal(..) ) import TyCon ( tyConDataCons ) @@ -328,7 +328,7 @@ pprAbsC stmt@(CCallTypedef is_tdef (CCall op_str is_asm may_gc cconv) results ar ccall_fun_ty = case op_str of DynamicTarget u -> ptext SLIT("_ccall_fun_ty") <> ppr u - StaticTarget x -> ptext x + StaticTarget x -> pprCLabelString x ccall_res_ty = case non_void_results of diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs index 47ad787..9641a04 100644 --- a/ghc/compiler/basicTypes/BasicTypes.lhs +++ b/ghc/compiler/basicTypes/BasicTypes.lhs @@ -121,7 +121,6 @@ negatePrecedence = 6 data NewOrData = NewType -- "newtype Blah ..." | DataType -- "data Blah ..." - | EnumType -- Enumeration; all constructors are nullary deriving( Eq ) -- Needed because Demand derives Eq \end{code} diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index bbdb46a..b5e120a 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -14,6 +14,8 @@ module Name ( mkTopName, mkIPName, mkDerivedName, mkGlobalName, mkKnownKeyGlobal, mkWiredInIdName, mkWiredInTyConName, + mkUnboundName, isUnboundName, + maybeWiredInIdName, maybeWiredInTyConName, isWiredInName, hashName, @@ -48,7 +50,7 @@ import RdrName ( RdrName, mkRdrQual, mkRdrUnqual, rdrNameOcc, rdrNameModule ) import CmdLineOpts ( opt_PprStyle_NoPrags, opt_OmitInterfacePragmas, opt_EnsureSplittableC ) import SrcLoc ( noSrcLoc, mkBuiltinSrcLoc, SrcLoc ) -import Unique ( pprUnique, Unique, Uniquable(..), u2i ) +import Unique ( pprUnique, Unique, Uniquable(..), unboundKey, u2i ) import Outputable import GlaExts \end{code} @@ -170,6 +172,16 @@ mkDerivedName :: (OccName -> OccName) mkDerivedName f name uniq = name {n_uniq = uniq, n_occ = f (n_occ name)} +-- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly +-- during compiler debugging. +mkUnboundName :: RdrName -> Name +mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc + +isUnboundName :: Name -> Bool +isUnboundName name = getUnique name == unboundKey +\end{code} + +\begin{code} -- When we renumber/rename things, we need to be -- able to change a Name's Unique to match the cached -- one in the thing it's the name of. If you know what I mean. diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index 35722fa..6170b1b 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -39,6 +39,7 @@ import TysWiredIn ( unitDataConId, stringTy, unboxedPairDataCon, mkUnboxedTupleTy, unboxedTupleCon ) +import CStrings ( CLabelString ) import Unique ( Unique ) import VarSet ( varSetElems ) import Outputable @@ -80,7 +81,7 @@ follows: \end{verbatim} \begin{code} -dsCCall :: FAST_STRING -- C routine to invoke +dsCCall :: CLabelString -- C routine to invoke -> [CoreExpr] -- Arguments (desugared) -> Bool -- True <=> might cause Haskell GC -> Bool -- True <=> really a "_casm_" diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index 49dc371..16f135f 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -14,19 +14,21 @@ import {-# SOURCE #-} HsExpr ( pprExpr, HsExpr ) import {-# SOURCE #-} HsMatches ( pprMatches, Match, pprGRHSs, GRHSs ) -- friends: -import HsTypes ( HsType ) +import HsTypes ( HsType, cmpHsType ) import HsImpExp ( IE(..), ieName ) import CoreSyn ( CoreExpr ) import PprCore () -- Instances for Outputable --others: import Id ( Id ) -import NameSet ( NameSet, nameSetToList ) +import Name ( Name, isUnboundName ) +import NameSet ( NameSet, elemNameSet, nameSetToList ) import BasicTypes ( RecFlag(..), Fixity ) import Outputable import Bag import SrcLoc ( SrcLoc ) import Var ( TyVar ) +import Util ( thenCmp ) \end{code} %************************************************************************ @@ -272,21 +274,45 @@ type DeprecTxt = FAST_STRING -- reason/explanation for deprecation \end{code} \begin{code} +okBindSig :: NameSet -> Sig Name -> Bool +okBindSig ns (ClassOpSig _ _ _ _ _) = False +okBindSig ns sig = sigForThisGroup ns sig + +okClsDclSig :: NameSet -> Sig Name -> Bool +okClsDclSig ns (Sig _ _ _) = False +okClsDclSig ns sig = sigForThisGroup ns sig + +okInstDclSig :: NameSet -> Sig Name -> Bool +okInstDclSig ns (Sig _ _ _) = False +okInstDclSig ns (FixSig _) = False +okInstDclSig ns (SpecInstSig _ _) = True +okInstDclSig ns sig = sigForThisGroup ns sig + +sigForThisGroup ns sig + = case sigName sig of + Nothing -> False + Just n | isUnboundName n -> True -- Don't complain about an unbound name again + | otherwise -> n `elemNameSet` ns + sigsForMe :: (name -> Bool) -> [Sig name] -> [Sig name] sigsForMe f sigs = filter sig_for_me sigs where - sig_for_me (Sig n _ _) = f n - sig_for_me (ClassOpSig n _ _ _ _) = f n - sig_for_me (SpecSig n _ _) = f n - sig_for_me (InlineSig n _ _) = f n - sig_for_me (NoInlineSig n _ _) = f n - sig_for_me (SpecInstSig _ _) = False - sig_for_me (FixSig (FixitySig n _ _)) = f n - sig_for_me - (DeprecSig (Deprecation (IEModuleContents _) _) _) = False - sig_for_me - (DeprecSig (Deprecation d _) _) = f (ieName d) + sig_for_me sig = case sigName sig of + Nothing -> False + Just n -> f n + +sigName :: Sig name -> Maybe name +sigName (Sig n _ _) = Just n +sigName (ClassOpSig n _ _ _ _) = Just n +sigName (SpecSig n _ _) = Just n +sigName (InlineSig n _ _) = Just n +sigName (NoInlineSig n _ _) = Just n +sigName (FixSig (FixitySig n _ _)) = Just n +sigName (DeprecSig (Deprecation d _) _) = case d of + IEModuleContents _ -> Nothing + other -> Just (ieName d) +sigName other = Nothing isFixitySig :: Sig name -> Bool isFixitySig (FixSig _) = True @@ -307,6 +333,17 @@ isPragSig other = False \end{code} \begin{code} +hsSigDoc (Sig _ _ loc) = (SLIT("type signature"),loc) +hsSigDoc (ClassOpSig _ _ _ _ loc) = (SLIT("class-method type signature"), loc) +hsSigDoc (SpecSig _ _ loc) = (SLIT("SPECIALISE pragma"),loc) +hsSigDoc (InlineSig _ _ loc) = (SLIT("INLINE pragma"),loc) +hsSigDoc (NoInlineSig _ _ loc) = (SLIT("NOINLINE pragma"),loc) +hsSigDoc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc) +hsSigDoc (FixSig (FixitySig _ _ loc)) = (SLIT("fixity declaration"), loc) +hsSigDoc (DeprecSig _ loc) = (SLIT("DEPRECATED pragma"), loc) +\end{code} + +\begin{code} instance (Outputable name) => Outputable (Sig name) where ppr sig = ppr_sig sig @@ -349,3 +386,41 @@ ppr_phase Nothing = empty ppr_phase (Just n) = int n \end{code} +Checking for distinct signatures; oh, so boring + + +\begin{code} +cmpHsSig :: Sig Name -> Sig Name -> Ordering +cmpHsSig (Sig n1 _ _) (Sig n2 _ _) = n1 `compare` n2 +cmpHsSig (DeprecSig (Deprecation ie1 _) _) + (DeprecSig (Deprecation ie2 _) _) = cmp_ie ie1 ie2 +cmpHsSig (InlineSig n1 _ _) (InlineSig n2 _ _) = n1 `compare` n2 +cmpHsSig (NoInlineSig n1 _ _) (NoInlineSig n2 _ _) = n1 `compare` n2 + +cmpHsSig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = cmpHsType compare ty1 ty2 +cmpHsSig (SpecSig n1 ty1 _) (SpecSig n2 ty2 _) + = -- may have many specialisations for one value; + -- but not ones that are exactly the same... + thenCmp (n1 `compare` n2) (cmpHsType compare ty1 ty2) + +cmpHsSig other_1 other_2 -- Tags *must* be different + | (sig_tag other_1) _LT_ (sig_tag other_2) = LT + | otherwise = GT + +cmp_ie :: IE Name -> IE Name -> Ordering +cmp_ie (IEVar n1 ) (IEVar n2 ) = n1 `compare` n2 +cmp_ie (IEThingAbs n1 ) (IEThingAbs n2 ) = n1 `compare` n2 +cmp_ie (IEThingAll n1 ) (IEThingAll n2 ) = n1 `compare` n2 +-- Hmmm... +cmp_ie (IEThingWith n1 _) (IEThingWith n2 _) = n1 `compare` n2 +cmp_ie (IEModuleContents _ ) (IEModuleContents _ ) = EQ + +sig_tag (Sig n1 _ _) = (ILIT(1) :: FAST_INT) +sig_tag (SpecSig n1 _ _) = ILIT(2) +sig_tag (InlineSig n1 _ _) = ILIT(3) +sig_tag (NoInlineSig n1 _ _) = ILIT(4) +sig_tag (SpecInstSig _ _) = ILIT(5) +sig_tag (FixSig _) = ILIT(6) +sig_tag (DeprecSig _ _) = ILIT(7) +sig_tag _ = panic# "tag(RnBinds)" +\end{code} diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 6b7b509..fe95b3c 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -31,7 +31,7 @@ import Var ( TyVar ) -- others: import PprType import {-# SOURCE #-} FunDeps ( pprFundeps ) -import CStrings ( CLabelString ) +import CStrings ( CLabelString, pprCLabelString ) import Outputable import SrcLoc ( SrcLoc ) import Util @@ -413,13 +413,11 @@ extNameStatic :: ExtName -> CLabelString extNameStatic (ExtName f _) = f extNameStatic Dynamic = panic "staticExtName: Dynamic - shouldn't ever happen." - instance Outputable ExtName where ppr Dynamic = ptext SLIT("dynamic") ppr (ExtName nm mb_mod) = case mb_mod of { Nothing -> empty; Just m -> doubleQuotes (ptext m) } <+> - doubleQuotes (ptext nm) - + doubleQuotes (pprCLabelString nm) \end{code} %************************************************************************ diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 356b460..17b23a7 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -23,6 +23,7 @@ import PprType ( pprType, pprParendType ) import Type ( Type ) import Var ( TyVar, Id ) import DataCon ( DataCon ) +import CStrings ( CLabelString, pprCLabelString ) import SrcLoc ( SrcLoc ) \end{code} @@ -137,7 +138,7 @@ data HsExpr id pat (HsExpr id pat) -- (typechecked, of course) (ArithSeqInfo id pat) - | HsCCall FAST_STRING -- call into the C world; string is + | HsCCall CLabelString -- call into the C world; string is [HsExpr id pat] -- the C function; exprs are the -- arguments to pass. Bool -- True <=> might cause Haskell @@ -337,8 +338,8 @@ ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendExpr e ppr_expr (HsCCall fun args _ is_asm result_ty) = hang (if is_asm - then ptext SLIT("_casm_ ``") <> ptext fun <> ptext SLIT("''") - else ptext SLIT("_ccall_") <+> ptext fun) + then ptext SLIT("_casm_ ``") <> pprCLabelString fun <> ptext SLIT("''") + else ptext SLIT("_ccall_") <+> pprCLabelString fun) 4 (sep (map pprParendExpr args)) ppr_expr (HsSCC lbl expr) diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 6a48b1f..b16df06 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -43,6 +43,7 @@ import Type ( Type, mkForAllTys, mkForAllTy, mkFunTy, mkFunTys, mkTyVarTys, ) import Unique ( Unique, mkPrimOpIdUnique ) import BasicTypes ( Arity ) +import CStrings ( CLabelString, pprCLabelString ) import PrelMods ( pREL_GHC, pREL_GHC_Name ) import Outputable import Util ( assoc, zipWithEqual ) @@ -2395,7 +2396,7 @@ data CCall CallConv -- calling convention to use. data CCallTarget - = StaticTarget FAST_STRING -- An "unboxed" ccall# to `fn'. + = StaticTarget CLabelString -- An "unboxed" ccall# to `fn'. | DynamicTarget Unique -- First argument (an Addr#) is the function pointer -- (unique is used to generate a 'typedef' to cast -- the function pointer if compiling the ccall# down to @@ -2432,5 +2433,5 @@ pprCCallOp (CCall fun is_casm may_gc cconv) ppr_fun = case fun of DynamicTarget _ -> text "\"\"" - StaticTarget fn -> ptext fn + StaticTarget fn -> pprCLabelString fn \end{code} diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index a8bcf25..565f66e 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -86,7 +86,7 @@ import Module ( Module, mkPrelModule ) import Name ( mkWiredInTyConName, mkWiredInIdName, mkSrcOccFS, mkWorkerOcc, dataName ) import DataCon ( DataCon, StrictnessMark(..), mkDataCon, dataConId ) import Var ( TyVar, tyVarKind ) -import TyCon ( TyCon, ArgVrcs, mkAlgTyCon, mkSynTyCon, mkTupleTyCon ) +import TyCon ( TyCon, AlgTyConFlavour(..), ArgVrcs, mkAlgTyCon, mkSynTyCon, mkTupleTyCon ) import BasicTypes ( Arity, NewOrData(..), RecFlag(..) ) import Type ( Type, mkTyConTy, mkTyConApp, mkSigmaTy, mkTyVarTys, mkArrowKinds, boxedTypeKind, unboxedTypeKind, @@ -104,13 +104,12 @@ alpha_tyvar = [alphaTyVar] alpha_ty = [alphaTy] alpha_beta_tyvars = [alphaTyVar, betaTyVar] -pcRecDataTyCon, pcNonRecDataTyCon, pcNonRecNewTyCon +pcRecDataTyCon, pcNonRecDataTyCon :: Unique{-TyConKey-} -> Module -> FAST_STRING -> [TyVar] -> ArgVrcs -> [DataCon] -> TyCon -pcRecDataTyCon = pcTyCon DataType Recursive -pcNonRecDataTyCon = pcTyCon DataType NonRecursive -pcNonRecNewTyCon = pcTyCon NewType NonRecursive +pcRecDataTyCon = pcTyCon DataTyCon Recursive +pcNonRecDataTyCon = pcTyCon DataTyCon NonRecursive pcTyCon new_or_data is_rec key mod str tyvars argvrcs cons = tycon @@ -121,7 +120,6 @@ pcTyCon new_or_data is_rec key mod str tyvars argvrcs cons argvrcs cons [] -- No derivings - Nothing -- Not a dictionary new_or_data is_rec @@ -157,6 +155,7 @@ pcDataCon wrap_key mod str tyvars context arg_tys tycon wrap_id = mkDataConWrapId data_con \end{code} + %************************************************************************ %* * \subsection[TysWiredIn-tuples]{The tuple types} @@ -521,7 +520,7 @@ primitive counterpart. \begin{code} boolTy = mkTyConTy boolTyCon -boolTyCon = pcTyCon EnumType NonRecursive boolTyConKey +boolTyCon = pcTyCon EnumTyCon NonRecursive boolTyConKey pREL_BASE SLIT("Bool") [] [] [falseDataCon, trueDataCon] falseDataCon = pcDataCon falseDataConKey pREL_BASE SLIT("False") [] [] [] boolTyCon diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index aefb9ec..abd60a0 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -21,19 +21,19 @@ module RnBinds ( import {-# SOURCE #-} RnSource ( rnHsSigType ) import HsSyn -import HsBinds ( sigsForMe ) +import HsBinds ( sigsForMe, cmpHsSig, sigName, hsSigDoc ) import RdrHsSyn import RnHsSyn import RnMonad import RnExpr ( rnMatch, rnGRHSs, rnPat, checkPrecMatch ) -import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupGlobalOccRn, +import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupGlobalOccRn, lookupOccRn, warnUnusedLocalBinds, mapFvRn, FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV, unknownNameErr ) import CmdLineOpts ( opt_WarnMissingSigs ) import Digraph ( stronglyConnComp, SCC(..) ) -import Name ( OccName, Name, nameOccName ) +import Name ( OccName, Name, nameOccName, mkUnboundName, isUnboundName ) import NameSet import RdrName ( RdrName, rdrNameOcc ) import BasicTypes ( RecFlag(..), TopLevelFlag(..) ) @@ -173,24 +173,18 @@ rnTopMonoBinds EmptyMonoBinds sigs rnTopMonoBinds mbinds sigs = mapRn lookupBndrRn binder_rdr_names `thenRn` \ binder_names -> + renameSigs (okBindSig (mkNameSet binder_names)) sigs `thenRn` \ (siglist, sig_fvs) -> let - binder_set = mkNameSet binder_names - binder_occ_fm = listToFM [(nameOccName x,x) | x <- binder_names] + type_sig_vars = [n | Sig n _ _ <- siglist] + un_sigd_binders | opt_WarnMissingSigs = binder_names `minusList` type_sig_vars + | otherwise = [] in - renameSigs opt_WarnMissingSigs binder_set - (lookupSigOccRn binder_occ_fm) sigs `thenRn` \ (siglist, sig_fvs) -> + mapRn_ (addWarnRn.missingSigWarn) un_sigd_binders `thenRn_` + rn_mono_binds siglist mbinds `thenRn` \ (final_binds, bind_fvs) -> returnRn (final_binds, bind_fvs `plusFV` sig_fvs) where binder_rdr_names = map fst (bagToList (collectMonoBinders mbinds)) - --- the names appearing in the sigs have to be bound by --- this group's binders. -lookupSigOccRn binder_occ_fm rdr_name - = case lookupFM binder_occ_fm (rdrNameOcc rdr_name) of - Nothing -> failWithRn (mkUnboundName rdr_name) - (unknownNameErr rdr_name) - Just x -> returnRn x \end{code} %************************************************************************ @@ -233,26 +227,15 @@ rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds bindLocatedLocalsRn (text "a binding group") mbinders_w_srclocs $ \ new_mbinders -> let - binder_set = mkNameSet new_mbinders - binder_occ_fm = listToFM [(nameOccName x,x) | x <- new_mbinders] - - -- Weed out the fixity declarations that do not - -- apply to any of the binders in this group. - (sigs_for_me, fixes_not_for_me) = partition forLocalBind sigs - - forLocalBind (FixSig sig@(FixitySig name _ _ )) = - isJust (lookupFM binder_occ_fm (rdrNameOcc name)) - forLocalBind _ = True + binder_set = mkNameSet new_mbinders in -- Rename the signatures - renameSigs False binder_set - (lookupSigOccRn binder_occ_fm) sigs_for_me `thenRn` \ (siglist, sig_fvs) -> + renameSigs (okBindSig binder_set) sigs `thenRn` \ (siglist, sig_fvs) -> -- Report the fixity declarations in this group that -- don't refer to any of the group's binders. -- Then install the fixity declarations that do apply here -- Notice that they scope over thing_inside too - mapRn_ (unknownSigErr) fixes_not_for_me `thenRn_` let fixity_sigs = [(name,sig) | FixSig sig@(FixitySig name _ _) <- siglist ] in @@ -483,32 +466,29 @@ At the moment we don't gather free-var info from the types in signatures. We'd only need this if we wanted to report unused tyvars. \begin{code} -renameSigs :: Bool -- True => warn if (required) type signatures are missing. - -> NameSet -- Set of names bound in this group - -> (RdrName -> RnMS Name) +renameSigs :: (RenamedSig -> Bool) -- OK-sig predicate -> [RdrNameSig] - -> RnMS ([RenamedSig], FreeVars) -- List of Sig constructors + -> RnMS ([RenamedSig], FreeVars) + +renameSigs ok_sig [] = returnRn ([], emptyFVs) -- Common shortcut -renameSigs sigs_required binders lookup_occ_nm sigs +renameSigs ok_sig sigs = -- Rename the signatures - mapFvRn (renameSig lookup_occ_nm) sigs `thenRn` \ (sigs', fvs) -> + mapFvRn renameSig sigs `thenRn` \ (sigs', fvs) -> -- Check for (a) duplicate signatures -- (b) signatures for things not in this group - -- (c) optionally, bindings with no signature let - (goodies, dups) = removeDups cmp_sig (sigsForMe (not . isUnboundName) sigs') - not_this_group = sigsForMe (not . (`elemNameSet` binders)) goodies - type_sig_vars = [n | Sig n _ _ <- goodies] - un_sigd_binders | sigs_required = nameSetToList binders `minusList` type_sig_vars - | otherwise = [] + in_scope = filter is_in_scope sigs' + is_in_scope sig = case sigName sig of + Just n -> not (isUnboundName n) + Nothing -> True + (not_dups, dups) = removeDups cmpHsSig in_scope + (goods, bads) = partition ok_sig not_dups in - mapRn_ dupSigDeclErr dups `thenRn_` - mapRn_ unknownSigErr not_this_group `thenRn_` - mapRn_ (addWarnRn.missingSigWarn) un_sigd_binders `thenRn_` - returnRn (sigs', fvs) - -- bad ones and all: - -- we need bindings of *some* sort for every name + mapRn_ unknownSigErr bads `thenRn_` + mapRn_ dupSigDeclErr dups `thenRn_` + returnRn (goods, fvs) -- We use lookupOccRn in the signatures, which is a little bit unsatisfactory -- because this won't work for: @@ -519,43 +499,43 @@ renameSigs sigs_required binders lookup_occ_nm sigs -- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.) -- Doesn't seem worth much trouble to sort this. -renameSig :: (RdrName -> RnMS Name) -> Sig RdrName -> RnMS (Sig Name, FreeVars) +renameSig :: Sig RdrName -> RnMS (Sig Name, FreeVars) -renameSig lookup_occ_nm (Sig v ty src_loc) +renameSig (Sig v ty src_loc) = pushSrcLocRn src_loc $ - lookup_occ_nm v `thenRn` \ new_v -> + lookupOccRn v `thenRn` \ new_v -> rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs) -> returnRn (Sig new_v new_ty src_loc, fvs `addOneFV` new_v) -renameSig _ (SpecInstSig ty src_loc) +renameSig (SpecInstSig ty src_loc) = pushSrcLocRn src_loc $ rnHsSigType (text "A SPECIALISE instance pragma") ty `thenRn` \ (new_ty, fvs) -> returnRn (SpecInstSig new_ty src_loc, fvs) -renameSig lookup_occ_nm (SpecSig v ty src_loc) +renameSig (SpecSig v ty src_loc) = pushSrcLocRn src_loc $ - lookup_occ_nm v `thenRn` \ new_v -> + lookupOccRn v `thenRn` \ new_v -> rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs) -> returnRn (SpecSig new_v new_ty src_loc, fvs `addOneFV` new_v) -renameSig lookup_occ_nm (FixSig (FixitySig v fix src_loc)) +renameSig (FixSig (FixitySig v fix src_loc)) = pushSrcLocRn src_loc $ - lookup_occ_nm v `thenRn` \ new_v -> + lookupOccRn v `thenRn` \ new_v -> returnRn (FixSig (FixitySig new_v fix src_loc), unitFV new_v) -renameSig lookup_occ_nm (DeprecSig (Deprecation ie txt) src_loc) +renameSig (DeprecSig (Deprecation ie txt) src_loc) = pushSrcLocRn src_loc $ - renameIE lookup_occ_nm ie `thenRn` \ (new_ie, fvs) -> + renameIE lookupOccRn ie `thenRn` \ (new_ie, fvs) -> returnRn (DeprecSig (Deprecation new_ie txt) src_loc, fvs) -renameSig lookup_occ_nm (InlineSig v p src_loc) +renameSig (InlineSig v p src_loc) = pushSrcLocRn src_loc $ - lookup_occ_nm v `thenRn` \ new_v -> + lookupOccRn v `thenRn` \ new_v -> returnRn (InlineSig new_v p src_loc, unitFV new_v) -renameSig lookup_occ_nm (NoInlineSig v p src_loc) +renameSig (NoInlineSig v p src_loc) = pushSrcLocRn src_loc $ - lookup_occ_nm v `thenRn` \ new_v -> + lookupOccRn v `thenRn` \ new_v -> returnRn (NoInlineSig new_v p src_loc, unitFV new_v) \end{code} @@ -582,43 +562,6 @@ renameIE lookup_occ_nm (IEModuleContents m) = returnRn (IEModuleContents m, emptyFVs) \end{code} -Checking for distinct signatures; oh, so boring - - -\begin{code} -cmp_sig :: RenamedSig -> RenamedSig -> Ordering -cmp_sig (Sig n1 _ _) (Sig n2 _ _) = n1 `compare` n2 -cmp_sig (DeprecSig (Deprecation ie1 _) _) - (DeprecSig (Deprecation ie2 _) _) = cmp_ie ie1 ie2 -cmp_sig (InlineSig n1 _ _) (InlineSig n2 _ _) = n1 `compare` n2 -cmp_sig (NoInlineSig n1 _ _) (NoInlineSig n2 _ _) = n1 `compare` n2 -cmp_sig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = cmpHsType compare ty1 ty2 -cmp_sig (SpecSig n1 ty1 _) (SpecSig n2 ty2 _) - = -- may have many specialisations for one value; - -- but not ones that are exactly the same... - thenCmp (n1 `compare` n2) (cmpHsType compare ty1 ty2) - -cmp_sig other_1 other_2 -- Tags *must* be different - | (sig_tag other_1) _LT_ (sig_tag other_2) = LT - | otherwise = GT - -cmp_ie :: IE Name -> IE Name -> Ordering -cmp_ie (IEVar n1 ) (IEVar n2 ) = n1 `compare` n2 -cmp_ie (IEThingAbs n1 ) (IEThingAbs n2 ) = n1 `compare` n2 -cmp_ie (IEThingAll n1 ) (IEThingAll n2 ) = n1 `compare` n2 --- Hmmm... -cmp_ie (IEThingWith n1 _) (IEThingWith n2 _) = n1 `compare` n2 -cmp_ie (IEModuleContents _ ) (IEModuleContents _ ) = EQ - -sig_tag (Sig n1 _ _) = (ILIT(1) :: FAST_INT) -sig_tag (SpecSig n1 _ _) = ILIT(2) -sig_tag (InlineSig n1 _ _) = ILIT(3) -sig_tag (NoInlineSig n1 _ _) = ILIT(4) -sig_tag (SpecInstSig _ _) = ILIT(5) -sig_tag (FixSig _) = ILIT(6) -sig_tag (DeprecSig _ _) = ILIT(7) -sig_tag _ = panic# "tag(RnBinds)" -\end{code} %************************************************************************ %* * @@ -632,24 +575,14 @@ dupSigDeclErr (sig:sigs) addErrRn (sep [ptext SLIT("Duplicate") <+> ptext what_it_is <> colon, ppr sig]) where - (what_it_is, loc) = sig_doc sig + (what_it_is, loc) = hsSigDoc sig unknownSigErr sig = pushSrcLocRn loc $ - addErrRn (sep [ptext SLIT("Misplaced"), - ptext what_it_is <> colon, + addErrRn (sep [ptext SLIT("Misplaced") <+> ptext what_it_is <> colon, ppr sig]) where - (what_it_is, loc) = sig_doc sig - -sig_doc (Sig _ _ loc) = (SLIT("type signature"),loc) -sig_doc (ClassOpSig _ _ _ _ loc) = (SLIT("class-method type signature"), loc) -sig_doc (SpecSig _ _ loc) = (SLIT("SPECIALISE pragma"),loc) -sig_doc (InlineSig _ _ loc) = (SLIT("INLINE pragma"),loc) -sig_doc (NoInlineSig _ _ loc) = (SLIT("NOINLINE pragma"),loc) -sig_doc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc) -sig_doc (FixSig (FixitySig _ _ loc)) = (SLIT("fixity declaration"), loc) -sig_doc (DeprecSig _ loc) = (SLIT("DEPRECATED pragma"), loc) + (what_it_is, loc) = hsSigDoc sig missingSigWarn var = sep [ptext SLIT("definition but no type signature for"), quotes (ppr var)] diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index cdaff2e..adc5a06 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -21,7 +21,7 @@ import HsTypes ( getTyVarName, replaceTyVarName ) import RnMonad import Name ( Name, Provenance(..), ExportFlag(..), NamedThing(..), ImportReason(..), getSrcLoc, - mkLocalName, mkImportedLocalName, mkGlobalName, + mkLocalName, mkImportedLocalName, mkGlobalName, mkUnboundName, mkIPName, isSystemName, nameOccName, setNameModule, nameModule, pprOccName, isLocallyDefined, nameUnique, nameOccName, diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 1d0f35f..ac646e9 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -39,7 +39,7 @@ import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ) import Name ( Name, OccName, NamedThing(..), isLocallyDefinedName, nameModule, nameOccName, - decode, mkLocalName + decode, mkLocalName, mkUnboundName ) import Module ( Module, ModuleName, ModuleHiMap, SearchPath, WhereFrom, mkModuleHiMaps, moduleName, mkVanillaModule, mkSearchPath @@ -431,14 +431,6 @@ emptyIfaces = Ifaces { iImpModInfo = emptyFM, iDeprecs = emptyNameEnv } --- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly --- during compiler debugging. -mkUnboundName :: RdrName -> Name -mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc - -isUnboundName :: Name -> Bool -isUnboundName name = getUnique name == unboundKey - builtins :: FiniteMap (ModuleName,OccName) Name builtins = bagToFM ( diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index abf4150..9897fd8 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -200,15 +200,13 @@ rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas let -- First process the class op sigs, then the fixity sigs. (op_sigs, non_op_sigs) = partition isClassOpSig sigs - (fix_sigs, non_sigs) = partition isFixitySig non_op_sigs in checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_` mapFvRn (rn_op cname' clas_tyvar_names fds') op_sigs `thenRn` \ (sigs', sig_fvs) -> - mapRn_ (unknownSigErr) non_sigs `thenRn_` let binders = mkNameSet [ nm | (ClassOpSig nm _ _ _ _) <- sigs' ] in - renameSigs False binders lookupOccRn fix_sigs `thenRn` \ (fixs', fix_fvs) -> + renameSigs (okClsDclSig binders) non_op_sigs `thenRn` \ (non_ops', fix_fvs) -> -- Check the methods checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_` @@ -221,7 +219,7 @@ rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas -- for instance decls. ASSERT(isNoClassPragmas pragmas) - returnRn (TyClD (ClassDecl context' cname' tyvars' fds' (fixs' ++ sigs') mbinds' + returnRn (TyClD (ClassDecl context' cname' tyvars' fds' (non_ops' ++ sigs') mbinds' NoClassPragmas tname' dname' dwname' snames' src_loc), sig_fvs `plusFV` fix_fvs `plusFV` @@ -299,30 +297,13 @@ rnDecl (InstD (InstDecl inst_ty mbinds uprags dfun_rdr_name src_loc)) ) `thenRn` \ (mbinds', meth_fvs) -> let binders = mkNameSet (map fst (bagToList (collectMonoBinders mbinds'))) - - -- Delete sigs (&report) sigs that aren't allowed inside an - -- instance decl: - -- - -- + type signatures - -- + fixity decls - -- - (ok_sigs, not_ok_idecl_sigs) = partition okInInstDecl uprags - - okInInstDecl (FixSig _) = False - okInInstDecl (Sig _ _ _) = False - okInInstDecl _ = True - in - -- You can't have fixity decls & type signatures - -- within an instance declaration. - mapRn_ unknownSigErr not_ok_idecl_sigs `thenRn_` - -- Rename the prags and signatures. -- Note that the type variables are not in scope here, -- so that instance Eq a => Eq (T a) where -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-} -- works OK. - renameSigs False binders lookupOccRn ok_sigs `thenRn` \ (new_uprags, prag_fvs) -> + renameSigs (okInstDclSig binders) uprags `thenRn` \ (new_uprags, prag_fvs) -> getModeRn `thenRn` \ mode -> (case mode of diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index e243c2b..6e2d065 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -677,13 +677,14 @@ mkStgApp env fn args ty Just fn' -> fn' saturate :: Id -> [StgArg] -> Type -> ([StgArg] -> Type -> UniqSM StgExpr) -> UniqSM StgExpr + -- The type should be the type of (id args) saturate fn args ty thing_inside | excess_arity == 0 -- Saturated, so nothing to do = thing_inside args ty | otherwise -- An unsaturated constructor or primop; eta expand it - = ASSERT2( excess_arity > 0 && excess_arity <= length extra_arg_tys, - ppr fn <+> ppr args <+> ppr excess_arity ) + = ASSERT2( excess_arity > 0 && excess_arity <= length arg_tys, + ppr fn <+> ppr args <+> ppr excess_arity <+> parens (ppr ty) <+> ppr arg_tys ) mapUs newStgVar extra_arg_tys `thenUs` \ arg_vars -> thing_inside (args ++ map StgVarArg arg_vars) final_res_ty `thenUs` \ body -> returnUs (StgLam ty arg_vars body) diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs index a4490cf..3e83e22 100644 --- a/ghc/compiler/stranal/StrictAnal.lhs +++ b/ghc/compiler/stranal/StrictAnal.lhs @@ -19,7 +19,6 @@ import Id ( idType, setIdStrictness, setInlinePragma, ) import IdInfo ( InlinePragInfo(..) ) import CoreLint ( beginPass, endPass ) -import Type ( splitRepFunTys ) import ErrUtils ( dumpIfSet ) import SaAbsInt import SaLib diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 7ffce22..f0eb0be 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -31,6 +31,7 @@ import TcEnv ( TcId, ValueEnv, TcTyThing(..), tcAddImportedIdInfo, tcExtendLocalValEnv ) import TcBinds ( tcBindWithSigs, tcSpecSigs ) +import TcTyDecls ( mkNewTyConRep ) import TcUnify ( unifyKinds ) import TcMonad import TcMonoType ( kcHsType, tcHsTopType, tcExtendTopTyVarScope, @@ -59,7 +60,7 @@ import Type ( Type, ThetaType, ClassContext, ) import Var ( tyVarKind, TyVar ) import VarSet ( mkVarSet, emptyVarSet ) -import TyCon ( mkAlgTyCon ) +import TyCon ( AlgTyConFlavour(..), mkClassTyCon ) import Unique ( Unique, Uniquable(..) ) import Util import Maybes ( seqMaybe ) @@ -173,8 +174,8 @@ tcClassDecl1 rec_env rec_inst_mapper rec_vrcs dict_component_tys = sc_tys ++ op_tys new_or_data = case dict_component_tys of - [_] -> NewType - other -> DataType + [_] -> NewTyCon (mkNewTyConRep tycon) + other -> DataTyCon dict_con = mkDataCon datacon_name [notMarkedStrict | _ <- dict_component_tys] @@ -192,16 +193,13 @@ tcClassDecl1 rec_env rec_inst_mapper rec_vrcs ppr tycon_name) tycon_name - tycon = mkAlgTyCon tycon_name - class_kind - tyvars - [] -- No context - argvrcs - [dict_con] -- Constructors - [] -- No derivings - (Just clas) -- Yes! It's a dictionary - new_or_data - NonRecursive + tycon = mkClassTyCon tycon_name + class_kind + tyvars + argvrcs + dict_con -- Constructors + clas -- Yes! It's a dictionary + new_or_data in returnTc clas \end{code} diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 1778c8e..de9c9b0 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -31,7 +31,7 @@ import CoreUtils ( exprType ) import CoreUnfold import CoreLint ( lintUnfolding ) import WorkWrap ( mkWrapper ) -import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) ) +import PrimOp ( PrimOp(..) ) import Id ( Id, mkId, mkVanillaId, isDataConWrapId_maybe diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 4508cb0..a1711a2 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -7,7 +7,7 @@ module TcTyDecls ( tcTyDecl, kcTyDecl, tcConDecl, - mkImplicitDataBinds + mkImplicitDataBinds, mkNewTyConRep ) where #include "HsVersions.h" @@ -32,22 +32,24 @@ import TcUnify ( unifyKind ) import Class ( Class ) import DataCon ( DataCon, dataConSig, mkDataCon, isNullaryDataCon, dataConFieldLabels, dataConId, dataConWrapId, - markedStrict, notMarkedStrict, markedUnboxed + markedStrict, notMarkedStrict, markedUnboxed, dataConRepType ) import MkId ( mkDataConId, mkDataConWrapId, mkRecordSelId ) import FieldLabel import Var ( Id, TyVar ) import Name ( Name, isLocallyDefined, OccName, NamedThing(..), nameUnique ) import Outputable -import TyCon ( TyCon, ArgVrcs, mkSynTyCon, mkAlgTyCon, - isSynTyCon, tyConDataCons, isNewTyCon +import TyCon ( TyCon, AlgTyConFlavour(..), ArgVrcs, mkSynTyCon, mkAlgTyCon, + tyConDataCons, tyConTyVars, + isSynTyCon, isNewTyCon ) -import Type ( getTyVar, tyVarsOfTypes, +import Type ( getTyVar, tyVarsOfTypes, splitFunTy, applyTys, mkTyConApp, mkTyVarTys, mkForAllTys, mkFunTy, - mkTyVarTy, splitForAllTys, isForAllTy, + mkTyVarTy, splitForAllTys, isForAllTy, splitAlgTyConApp_maybe, mkArrowKind, mkArrowKinds, boxedTypeKind, isUnboxedType, Type, ThetaType, classesOfPreds ) +import TysWiredIn ( unitTy ) import Var ( tyVarKind ) import VarSet ( intersectVarSet, isEmptyVarSet ) import Util ( equivClasses ) @@ -137,10 +139,10 @@ tcTyDecl is_rec rec_vrcs (TyData data_or_new context tycon_name tyvar_names con_ let -- Construct the tycon - real_data_or_new = case data_or_new of - NewType -> NewType - DataType | all isNullaryDataCon data_cons -> EnumType - | otherwise -> DataType + flavour = case data_or_new of + NewType -> NewTyCon (mkNewTyConRep tycon) + DataType | all isNullaryDataCon data_cons -> EnumTyCon + | otherwise -> DataTyCon argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcTyDecl: argvrcs:" $ ppr tycon_name) tycon_name @@ -148,8 +150,7 @@ tcTyDecl is_rec rec_vrcs (TyData data_or_new context tycon_name tyvar_names con_ tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt' argvrcs data_cons derived_classes - Nothing -- Not a dictionary - real_data_or_new is_rec + flavour is_rec in returnTc tycon where @@ -160,6 +161,27 @@ tcTyDecl is_rec rec_vrcs (TyData data_or_new context tycon_name tyvar_names con_ returnTc clas \end{code} +\begin{code} +mkNewTyConRep :: TyCon -> Type +-- Find the representation type for this newtype TyCon +-- The trick is to to deal correctly with recursive newtypes +-- such as newtype T = MkT T + +mkNewTyConRep tc + = mkForAllTys tvs (loop [] (mkTyConApp tc (mkTyVarTys tvs))) + where + tvs = tyConTyVars tc + loop tcs ty = case splitAlgTyConApp_maybe ty of { + Nothing -> ty ; + Just (tc, tys, data_cons) | not (isNewTyCon tc) -> ty + | tc `elem` tcs -> unitTy + | otherwise -> + + case splitFunTy (applyTys (dataConRepType (head data_cons)) tys) of + (rep_ty, _) -> loop (tc:tcs) rep_ty + } +\end{code} + %************************************************************************ %* * diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 6c6efaf..1ca3393 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -5,14 +5,15 @@ \begin{code} module TyCon( - TyCon, KindCon, SuperKindCon, ArgVrcs, + TyCon, KindCon, SuperKindCon, ArgVrcs, AlgTyConFlavour(..), isFunTyCon, isUnLiftedTyCon, isBoxedTyCon, isProductTyCon, isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isEnumerationTyCon, isTupleTyCon, isUnboxedTupleTyCon, - isRecursiveTyCon, + isRecursiveTyCon, newTyConRep, mkAlgTyCon, + mkClassTyCon, mkFunTyCon, mkPrimTyCon, mkTupleTyCon, @@ -84,9 +85,9 @@ data TyCon tyConKind :: Kind, tyConArity :: Arity, - tyConTyVars :: [TyVar], - dataTyConTheta :: [(Class,[Type])], - dataTyConArgVrcs :: ArgVrcs, + tyConTyVars :: [TyVar], + tyConArgVrcs :: ArgVrcs, + algTyConTheta :: [(Class,[Type])], dataCons :: [DataCon], -- Its data constructors, with fully polymorphic types @@ -96,14 +97,16 @@ data TyCon -- (b) in a quest for fast compilation we don't import -- the constructors - dataTyConDerivings :: [Class], -- Classes which have derived instances + algTyConDerivings :: [Class], -- Classes which have derived instances - dataTyConClass_maybe :: (Maybe Class), -- Nothing for ordinary types; + algTyConFlavour :: AlgTyConFlavour, + algTyConRec :: RecFlag, -- Tells whether the data type is part of + -- a mutually-recursive group or not + + algTyConClass_maybe :: Maybe Class -- Nothing for ordinary types; -- Just c for the type constructor -- for dictionaries of class c. - algTyConFlavour :: NewOrData, - algTyConRec :: RecFlag -- Tells whether the data type is part of - -- a mutually-recursive group or not + } | PrimTyCon { -- Primitive types; cannot be defined in Haskell @@ -112,7 +115,7 @@ data TyCon tyConName :: Name, tyConKind :: Kind, tyConArity :: Arity, - primTyConArgVrcs :: ArgVrcs, + tyConArgVrcs :: ArgVrcs, primTyConRep :: PrimRep } @@ -137,7 +140,7 @@ data TyCon synTyConDefn :: Type, -- Right-hand side, mentioning these type vars. -- Acts as a template for the expansion when -- the tycon is applied to some types. - synTyConArgVrcs :: ArgVrcs + tyConArgVrcs :: ArgVrcs } | KindCon { -- Type constructor at the kind level @@ -155,6 +158,22 @@ data TyCon type ArgVrcs = [(Bool,Bool)] -- Tyvar variance info: [(occPos,occNeg)] -- *NB*: this is tyvar variance info, *not* -- termvar usage info. + +data AlgTyConFlavour + = DataTyCon -- Data type + | EnumTyCon -- Special sort of enumeration type + | NewTyCon Type -- Newtype, with its *ultimate* representation type + -- By 'ultimate' I mean that the rep type is not itself + -- a newtype or type synonym. + + -- The rep type has explicit for-alls for the tyvars of + -- the TyCon. Thus: + -- newtype T a = MkT [(a,Int)] + -- The rep type is forall a. [(a,Int)] + -- + -- The rep type isn't entirely simple: + -- for a recursive newtype we pick () as the rep type + -- newtype T = MkT T \end{code} %************************************************************************ @@ -194,22 +213,39 @@ mkFunTyCon name kind tyConArity = 2 } -mkAlgTyCon name kind tyvars theta argvrcs cons derivs maybe_clas flavour rec +mkAlgTyCon name kind tyvars theta argvrcs cons derivs flavour rec = AlgTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConKind = kind, - tyConArity = length tyvars, - tyConTyVars = tyvars, - dataTyConTheta = theta, - dataTyConArgVrcs = argvrcs, - dataCons = cons, - dataTyConDerivings = derivs, - dataTyConClass_maybe = maybe_clas, - algTyConFlavour = flavour, - algTyConRec = rec + tyConName = name, + tyConUnique = nameUnique name, + tyConKind = kind, + tyConArity = length tyvars, + tyConTyVars = tyvars, + tyConArgVrcs = argvrcs, + algTyConTheta = theta, + dataCons = cons, + algTyConDerivings = derivs, + algTyConClass_maybe = Nothing, + algTyConFlavour = flavour, + algTyConRec = rec } +mkClassTyCon name kind tyvars argvrcs con clas flavour + = AlgTyCon { + tyConName = name, + tyConUnique = nameUnique name, + tyConKind = kind, + tyConArity = length tyvars, + tyConTyVars = tyvars, + tyConArgVrcs = argvrcs, + algTyConTheta = [], + dataCons = [con], + algTyConDerivings = [], + algTyConClass_maybe = Just clas, + algTyConFlavour = flavour, + algTyConRec = NonRecursive + } + + mkTupleTyCon name kind arity tyvars con boxed = TupleTyCon { tyConUnique = nameUnique name, @@ -227,7 +263,7 @@ mkPrimTyCon name kind arity arg_vrcs rep tyConUnique = nameUnique name, tyConKind = kind, tyConArity = arity, - primTyConArgVrcs = arg_vrcs, + tyConArgVrcs = arg_vrcs, primTyConRep = rep } @@ -239,7 +275,7 @@ mkSynTyCon name kind arity tyvars rhs argvrcs tyConArity = arity, tyConTyVars = tyvars, synTyConDefn = rhs, - synTyConArgVrcs = argvrcs + tyConArgVrcs = argvrcs } setTyConName tc name = tc {tyConName = name, tyConUnique = nameUnique name} @@ -269,13 +305,16 @@ isAlgTyCon other = False -- isDataTyCon returns False for @newtype@ and for unboxed tuples isDataTyCon (AlgTyCon {algTyConFlavour = new_or_data}) = case new_or_data of - NewType -> False + NewTyCon _ -> False other -> True isDataTyCon (TupleTyCon {tyConBoxed = True}) = True isDataTyCon other = False -isNewTyCon (AlgTyCon {algTyConFlavour = NewType}) = True -isNewTyCon other = False +isNewTyCon (AlgTyCon {algTyConFlavour = NewTyCon _}) = True +isNewTyCon other = False + +newTyConRep (AlgTyCon {algTyConFlavour = NewTyCon rep}) = Just rep +newTyConRep other = Nothing -- A "product" tycon -- has *one* constructor, @@ -291,8 +330,8 @@ isProductTyCon other = False isSynTyCon (SynTyCon {}) = True isSynTyCon _ = False -isEnumerationTyCon (AlgTyCon {algTyConFlavour = EnumType}) = True -isEnumerationTyCon other = False +isEnumerationTyCon (AlgTyCon {algTyConFlavour = EnumTyCon}) = True +isEnumerationTyCon other = False -- The unit tycon isn't classed as a tuple tycon isTupleTyCon (TupleTyCon {tyConArity = arity, tyConBoxed = True}) = arity >= 2 @@ -328,13 +367,13 @@ tyConPrimRep _ = PtrRep \begin{code} tyConDerivings :: TyCon -> [Class] -tyConDerivings (AlgTyCon {dataTyConDerivings = derivs}) = derivs -tyConDerivings other = [] +tyConDerivings (AlgTyCon {algTyConDerivings = derivs}) = derivs +tyConDerivings other = [] \end{code} \begin{code} tyConTheta :: TyCon -> [(Class, [Type])] -tyConTheta (AlgTyCon {dataTyConTheta = theta}) = theta +tyConTheta (AlgTyCon {algTyConTheta = theta}) = theta -- should ask about anything else \end{code} @@ -346,10 +385,10 @@ actually computed (in another file). tyConArgVrcs_maybe :: TyCon -> Maybe ArgVrcs tyConArgVrcs_maybe (FunTyCon {} ) = Just [(False,True),(True,False)] -tyConArgVrcs_maybe (AlgTyCon {dataTyConArgVrcs = oi}) = Just oi -tyConArgVrcs_maybe (PrimTyCon {primTyConArgVrcs = oi}) = Just oi +tyConArgVrcs_maybe (AlgTyCon {tyConArgVrcs = oi}) = Just oi +tyConArgVrcs_maybe (PrimTyCon {tyConArgVrcs = oi}) = Just oi tyConArgVrcs_maybe (TupleTyCon {tyConArity = arity }) = Just (replicate arity (True,False)) -tyConArgVrcs_maybe (SynTyCon {synTyConArgVrcs = oi }) = Just oi +tyConArgVrcs_maybe (SynTyCon {tyConArgVrcs = oi }) = Just oi tyConArgVrcs_maybe _ = Nothing \end{code} @@ -371,8 +410,8 @@ maybeTyConSingleCon tc = pprPanic "maybeTyConSingleCon: unexpected tycon " $ \begin{code} tyConClass_maybe :: TyCon -> Maybe Class -tyConClass_maybe (AlgTyCon {dataTyConClass_maybe = maybe_cls}) = maybe_cls -tyConClass_maybe other_tycon = Nothing +tyConClass_maybe (AlgTyCon {algTyConClass_maybe = maybe_cls}) = maybe_cls +tyConClass_maybe other_tycon = Nothing \end{code} diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 9d15297..4fdb337 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -96,7 +96,7 @@ import NameSet import Class ( classTyCon, Class ) import TyCon ( TyCon, isUnboxedTupleTyCon, isUnLiftedTyCon, - isFunTyCon, isDataTyCon, isNewTyCon, + isFunTyCon, isDataTyCon, isNewTyCon, newTyConRep, isAlgTyCon, isSynTyCon, tyConArity, tyConKind, tyConDataCons, getSynTyConDefn, tyConPrimRep, tyConClass_maybe @@ -429,41 +429,17 @@ interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs. repType looks through (a) for-alls, and (b) newtypes -in addition to synonyms. It's useful in the back end where we're not + (c) synonyms +It's useful in the back end where we're not interested in newtypes anymore. \begin{code} repType :: Type -> Type -repType (NoteTy _ ty) = repType ty -repType (ForAllTy _ ty) = repType ty -repType (TyConApp tc tys) | isNewTyCon tc = repType (new_type_rep tc tys) -repType other_ty = other_ty - - -typePrimRep :: Type -> PrimRep -typePrimRep ty = case splitTyConApp_maybe (repType ty) of - Just (tc, ty_args) -> tyConPrimRep tc - other -> PtrRep - -splitNewType_maybe :: Type -> Maybe Type --- Find the representation of a newtype, if it is one --- Looks through multiple levels of newtype -splitNewType_maybe (NoteTy _ ty) = splitNewType_maybe ty -splitNewType_maybe (TyConApp tc tys) | isNewTyCon tc = case splitNewType_maybe rep_ty of - Just rep_ty' -> Just rep_ty' - Nothing -> Just rep_ty - where - rep_ty = new_type_rep tc tys - -splitNewType_maybe other = Nothing - -new_type_rep :: TyCon -> [Type] -> Type --- The representation type for (T t1 .. tn), where T is a newtype --- Looks through one layer only -new_type_rep tc tys - = ASSERT( isNewTyCon tc ) - case splitFunTy_maybe (applyTys (dataConRepType (head (tyConDataCons tc))) tys) of - Just (rep_ty, _) -> rep_ty +repType (ForAllTy _ ty) = repType ty +repType (NoteTy _ ty) = repType ty +repType ty = case splitNewType_maybe ty of + Just ty' -> repType ty' -- Still re-apply repType in case of for-all + Nothing -> ty splitRepFunTys :: Type -> ([Type], Type) -- Like splitFunTys, but looks through newtypes and for-alls @@ -471,6 +447,25 @@ splitRepFunTys ty = split [] (repType ty) where split args (FunTy arg res) = split (arg:args) (repType res) split args ty = (reverse args, ty) + +typePrimRep :: Type -> PrimRep +typePrimRep ty = case repType ty of + TyConApp tc _ -> tyConPrimRep tc + FunTy _ _ -> PtrRep + AppTy _ _ -> PtrRep -- ?? + TyVarTy _ -> PtrRep + +splitNewType_maybe :: Type -> Maybe Type +-- Find the representation of a newtype, if it is one +-- Looks through multiple levels of newtype, but does not look through for-alls +splitNewType_maybe (NoteTy _ ty) = splitNewType_maybe ty +splitNewType_maybe (TyConApp tc tys) = case newTyConRep tc of + Just rep_ty -> ASSERT( length tys == tyConArity tc ) + -- The assert should hold because repType should + -- only be applied to *types* (of kind *) + Just (applyTys rep_ty tys) + Nothing -> Nothing +splitNewType_maybe other = Nothing \end{code} diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index 586f44e..1f23e5e 100644 --- a/ghc/compiler/utils/Outputable.lhs +++ b/ghc/compiler/utils/Outputable.lhs @@ -346,7 +346,7 @@ printDoc mode hdl doc showDocWith :: Mode -> Doc -> String showDocWith mode doc - = fullRender PageMode 100 1.5 put "" doc + = fullRender mode 100 1.5 put "" doc where put (Chr c) s = c:s put (Str s1) s2 = s1 ++ s2