From: simonpj@microsoft.com Date: Thu, 15 Oct 2009 12:28:10 +0000 (+0000) Subject: Fix Trac #959: a long-standing bug in instantiating otherwise-unbound type variables X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=388e3356f71daffa62f1d4157e1e07e4c68f218a Fix Trac #959: a long-standing bug in instantiating otherwise-unbound type variables DO NOT MERGE TO GHC 6.12 branch (Reason: interface file format change.) The typechecker needs to instantiate otherwise-unconstraint type variables to an appropriately-kinded constant type, but we didn't have a supply of arbitrarily-kinded tycons for this purpose. Now we do. The details are described in Note [Any types] in TysPrim. The fundamental change is that there is a new sort of TyCon, namely AnyTyCon, defined in TyCon. Ter's a small change to interface-file binary format, because the new AnyTyCons have to be serialised. I tided up the handling of uniques a bit too, so that mkUnique is not exported, so that we can see all the different name spaces in one module. --- diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index b12a07f..3a2338e 100644 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@ -98,7 +98,6 @@ import BasicTypes import UniqFM import UniqSet import FastString -import FastTypes import Outputable import Binary import Data.Char @@ -304,22 +303,24 @@ mkClsOccFS = mkOccNameFS clsName OccEnvs are used mainly for the envts in ModIfaces. +Note [The Unique of an OccName] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ They are efficient, because FastStrings have unique Int# keys. We assume -this key is less than 2^24, so we can make a Unique using +this key is less than 2^24, and indeed FastStrings are allocated keys +sequentially starting at 0. + +So we can make a Unique using mkUnique ns key :: Unique where 'ns' is a Char reprsenting the name space. This in turn makes it easy to build an OccEnv. \begin{code} instance Uniquable OccName where - getUnique (OccName ns fs) - = mkUnique char (iBox (uniqueOfFS fs)) - where -- See notes above about this getUnique function - char = case ns of - VarName -> 'i' - DataName -> 'd' - TvName -> 'v' - TcClsName -> 't' + -- See Note [The Unique of an OccName] + getUnique (OccName VarName fs) = mkVarOccUnique fs + getUnique (OccName DataName fs) = mkDataOccUnique fs + getUnique (OccName TvName fs) = mkTvOccUnique fs + getUnique (OccName TcClsName fs) = mkTcOccUnique fs newtype OccEnv a = A (UniqFM a) diff --git a/compiler/basicTypes/Unique.lhs b/compiler/basicTypes/Unique.lhs index aecd372..1ef0ca8 100644 --- a/compiler/basicTypes/Unique.lhs +++ b/compiler/basicTypes/Unique.lhs @@ -25,7 +25,6 @@ module Unique ( pprUnique, - mkUnique, -- Used in UniqSupply mkUniqueGrimily, -- Used in UniqSupply only! getKey, getKeyFastInt, -- Used in Var, UniqFM, Name only! @@ -47,6 +46,9 @@ module Unique ( mkPreludeTyConUnique, mkPreludeClassUnique, mkPArrDataConUnique, + mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique, + mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique, + mkBuiltinUnique, mkPseudoUniqueC, mkPseudoUniqueD, @@ -93,7 +95,6 @@ Now come the functions which construct uniques from their pieces, and vice versa The stuff about unique *supplies* is handled further down this module. \begin{code} -mkUnique :: Char -> Int -> Unique -- Builds a unique from pieces unpkUnique :: Unique -> (Char, Int) -- The reverse mkUniqueGrimily :: Int -> Unique -- A trap-door for UniqSupply @@ -131,6 +132,9 @@ newTagUnique u c = mkUnique c i where (_,i) = unpkUnique u -- and as long as the Char fits in 8 bits, which we assume anyway! +mkUnique :: Char -> Int -> Unique -- Builds a unique from pieces +-- NOT EXPORTED, so that we can see all the Chars that +-- are used in this one module mkUnique c i = MkUnique (tag `bitOrFastInt` bits) where @@ -340,8 +344,7 @@ isTupleKey u = case unpkUnique u of mkPrimOpIdUnique op = mkUnique '9' op mkPreludeMiscIdUnique i = mkUnique '0' i --- No numbers left anymore, so I pick something different for the character --- tag +-- No numbers left anymore, so I pick something different for the character tag mkPArrDataConUnique a = mkUnique ':' (2*a) -- The "tyvar uniques" print specially nicely: a, b, c, etc. @@ -358,5 +361,18 @@ mkPseudoUniqueC i = mkUnique 'C' i -- used for getUnique on Regs mkPseudoUniqueD i = mkUnique 'D' i -- used in NCG for getUnique on RealRegs mkPseudoUniqueE i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs mkPseudoUniqueH i = mkUnique 'H' i -- used in NCG spiller to create spill VirtualRegs + +mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique +mkRegSingleUnique = mkUnique 'R' +mkRegSubUnique = mkUnique 'S' +mkRegPairUnique = mkUnique 'P' +mkRegClassUnique = mkUnique 'L' + +mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique +-- See Note [The Unique of an OccName] in OccName +mkVarOccUnique fs = mkUnique 'i' (iBox (uniqueOfFS fs)) +mkDataOccUnique fs = mkUnique 'd' (iBox (uniqueOfFS fs)) +mkTvOccUnique fs = mkUnique 'v' (iBox (uniqueOfFS fs)) +mkTcOccUnique fs = mkUnique 'c' (iBox (uniqueOfFS fs)) \end{code} diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 7f752f8..515ac85 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -31,13 +31,13 @@ import MkCore import CoreUtils import CoreFVs -import TcHsSyn ( mkArbitraryType ) -- Mis-placed? import TcType +import TysPrim ( anyTypeOfKind ) import CostCentre import Module import Id import MkId ( seqId ) -import Var ( Var, TyVar ) +import Var ( Var, TyVar, tyVarKind ) import VarSet import Rules import VarEnv @@ -192,8 +192,9 @@ dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds) -- see if it has any impact; it is on by default = -- Note [Abstracting over tyvars only] do { core_prs <- ds_lhs_binds NoSccs binds - ; arby_env <- mkArbitraryTypeEnv tyvars exports - ; let (lg_binds, core_prs') = mapAndUnzip do_one core_prs + ; + ; let arby_env = mkArbitraryTypeEnv tyvars exports + (lg_binds, core_prs') = mapAndUnzip do_one core_prs bndrs = mkVarSet (map fst core_prs) add_lets | core_prs `lengthExceeds` 10 = add_some @@ -265,8 +266,8 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds) ; let mk_bind ((tyvars, global, local, prags), n) -- locals!!n == local = -- Need to make fresh locals to bind in the selector, -- because some of the tyvars will be bound to 'Any' - do { ty_args <- mapM mk_ty_arg all_tyvars - ; let substitute = substTyWith all_tyvars ty_args + do { let ty_args = map mk_ty_arg all_tyvars + substitute = substTyWith all_tyvars ty_args ; locals' <- newSysLocalsDs (map substitute local_tys) ; tup_id <- newSysLocalDs (substitute tup_ty) ; mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global @@ -281,7 +282,7 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds) ; return ((global', rhs) : spec_binds) } where mk_ty_arg all_tyvar - | all_tyvar `elem` tyvars = return (mkTyVarTy all_tyvar) + | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar | otherwise = dsMkArbitraryType all_tyvar ; export_binds_s <- mapM mk_bind (exports `zip` [0..]) @@ -344,9 +345,9 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing } | otherwise -> do - { f_body <- fix_up (Let mono_bind (Var mono_id)) + { let f_body = fix_up (Let mono_bind (Var mono_id)) - ; let local_poly = setIdNotExported poly_id + local_poly = setIdNotExported poly_id -- Very important to make the 'f' non-exported, -- else it won't be inlined! spec_id = mkLocalId spec_name spec_ty @@ -367,9 +368,9 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind where -- Bind to Any any of all_ptvs that aren't -- relevant for this particular function - fix_up body | null void_tvs = return body - | otherwise = do { void_tys <- mapM dsMkArbitraryType void_tvs - ; return (mkTyApps (mkLams void_tvs body) void_tys) } + fix_up body | null void_tvs = body + | otherwise = mkTyApps (mkLams void_tvs body) $ + map dsMkArbitraryType void_tvs void_tvs = all_tvs \\ tvs @@ -383,27 +384,24 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind 2 (ppr spec_expr) -mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> DsM (TyVarEnv Type) +mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> TyVarEnv Type -- If any of the tyvars is missing from any of the lists in -- the second arg, return a binding in the result mkArbitraryTypeEnv tyvars exports = go emptyVarEnv exports where - go env [] = return env + go env [] = env go env ((ltvs, _, _, _) : exports) - = do { env' <- foldlM extend env [tv | tv <- tyvars - , not (tv `elem` ltvs) - , not (tv `elemVarEnv` env)] - ; go env' exports } + = go env' exports + where + env' = foldl extend env [tv | tv <- tyvars + , not (tv `elem` ltvs) + , not (tv `elemVarEnv` env)] - extend env tv = do { ty <- dsMkArbitraryType tv - ; return (extendVarEnv env tv ty) } + extend env tv = extendVarEnv env tv (dsMkArbitraryType tv) - -dsMkArbitraryType :: TcTyVar -> DsM Type -dsMkArbitraryType tv = mkArbitraryType warn tv - where - warn span msg = putSrcSpanDs span (warnDs msg) +dsMkArbitraryType :: TcTyVar -> Type +dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv) \end{code} Note [Unused spec binders] diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index ffbba4a..b04e6e1 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -883,6 +883,7 @@ instance Binary IfaceType where put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14 put_ bh (IfaceTyConApp IfaceUbxTupleKindTc []) = putByte bh 15 put_ bh (IfaceTyConApp IfaceArgTypeKindTc []) = putByte bh 16 + put_ bh (IfaceTyConApp (IfaceAnyTc k) []) = do { putByte bh 17; put_ bh k } -- Generic cases @@ -918,6 +919,7 @@ instance Binary IfaceType where 14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc []) 15 -> return (IfaceTyConApp IfaceUbxTupleKindTc []) 16 -> return (IfaceTyConApp IfaceArgTypeKindTc []) + 17 -> do { k <- get bh; return (IfaceTyConApp (IfaceAnyTc k) []) } 18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) } _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) } @@ -937,6 +939,7 @@ instance Binary IfaceTyCon where put_ bh IfaceArgTypeKindTc = putByte bh 10 put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar } put_ bh (IfaceTc ext) = do { putByte bh 12; put_ bh ext } + put_ bh (IfaceAnyTc k) = do { putByte bh 13; put_ bh k } get bh = do h <- getByte bh @@ -952,7 +955,8 @@ instance Binary IfaceTyCon where 9 -> return IfaceUbxTupleKindTc 10 -> return IfaceArgTypeKindTc 11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) } - _ -> do { ext <- get bh; return (IfaceTc ext) } + 12 -> do { ext <- get bh; return (IfaceTc ext) } + _ -> do { k <- get bh; return (IfaceAnyTc k) } instance Binary IfacePredType where put_ bh (IfaceClassP aa ab) = do diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs index 1688344..2db1908 100644 --- a/compiler/iface/IfaceType.lhs +++ b/compiler/iface/IfaceType.lhs @@ -68,32 +68,41 @@ data IfacePredType -- NewTypes are handled as ordinary TyConApps type IfaceContext = [IfacePredType] --- NB: If you add a data constructor, remember to add a case to --- IfaceSyn.eqIfTc! data IfaceTyCon -- Abbreviations for common tycons with known names = IfaceTc Name -- The common case | IfaceIntTc | IfaceBoolTc | IfaceCharTc | IfaceListTc | IfacePArrTc | IfaceTupTc Boxity Arity + | IfaceAnyTc IfaceKind -- Used for AnyTyCon (see Note [Any Types] in TysPrim) | IfaceLiftedTypeKindTc | IfaceOpenTypeKindTc | IfaceUnliftedTypeKindTc | IfaceUbxTupleKindTc | IfaceArgTypeKindTc - deriving( Eq ) ifaceTyConName :: IfaceTyCon -> Name -ifaceTyConName IfaceIntTc = intTyConName -ifaceTyConName IfaceBoolTc = boolTyConName -ifaceTyConName IfaceCharTc = charTyConName -ifaceTyConName IfaceListTc = listTyConName -ifaceTyConName IfacePArrTc = parrTyConName -ifaceTyConName (IfaceTupTc bx ar) = getName (tupleTyCon bx ar) +ifaceTyConName IfaceIntTc = intTyConName +ifaceTyConName IfaceBoolTc = boolTyConName +ifaceTyConName IfaceCharTc = charTyConName +ifaceTyConName IfaceListTc = listTyConName +ifaceTyConName IfacePArrTc = parrTyConName +ifaceTyConName (IfaceTupTc bx ar) = getName (tupleTyCon bx ar) ifaceTyConName IfaceLiftedTypeKindTc = liftedTypeKindTyConName ifaceTyConName IfaceOpenTypeKindTc = openTypeKindTyConName ifaceTyConName IfaceUnliftedTypeKindTc = unliftedTypeKindTyConName ifaceTyConName IfaceUbxTupleKindTc = ubxTupleKindTyConName ifaceTyConName IfaceArgTypeKindTc = argTypeKindTyConName -ifaceTyConName (IfaceTc ext) = ext +ifaceTyConName (IfaceTc ext) = ext +ifaceTyConName (IfaceAnyTc kind) = pprPanic "ifaceTyConName" (ppr (IfaceAnyTc kind)) + -- Note [The Name of an IfaceAnyTc] \end{code} +Note [The Name of an IfaceAnyTc] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It isn't easy to get the Name of an IfaceAnyTc in a pure way. What you +really need to do is to transform it to a TyCon, and get the Name of that. +But doing so needs the monad. + +In fact, ifaceTyConName is only used for instances and rules, and we don't +expect to instantiate those at these (internal-ish) Any types, so rather +than solve this potential problem now, I'm going to defer it until it happens! %************************************************************************ %* * @@ -312,6 +321,7 @@ toIfaceType (PredTy st) = toIfaceTyCon :: TyCon -> IfaceTyCon toIfaceTyCon tc | isTupleTyCon tc = IfaceTupTc (tupleTyConBoxity tc) (tyConArity tc) + | isAnyTyCon tc = IfaceAnyTc (toIfaceKind (tyConKind tc)) | otherwise = toIfaceTyCon_name (tyConName tc) toIfaceTyCon_name :: Name -> IfaceTyCon @@ -323,7 +333,8 @@ toIfaceTyCon_name nm toIfaceWiredInTyCon :: TyCon -> Name -> IfaceTyCon toIfaceWiredInTyCon tc nm - | isTupleTyCon tc = IfaceTupTc (tupleTyConBoxity tc) (tyConArity tc) + | isTupleTyCon tc = IfaceTupTc (tupleTyConBoxity tc) (tyConArity tc) + | isAnyTyCon tc = IfaceAnyTc (toIfaceKind (tyConKind tc)) | nm == intTyConName = IfaceIntTc | nm == boolTyConName = IfaceBoolTc | nm == charTyConName = IfaceCharTc diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 7db9551..6a55957 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -37,6 +37,7 @@ import Class import TyCon import DataCon import TysWiredIn +import TysPrim ( anyTyConOfKind ) import Var ( TyVar ) import qualified Var import VarEnv @@ -1122,6 +1123,8 @@ tcIfaceTyCon IfaceCharTc = tcWiredInTyCon charTyCon tcIfaceTyCon IfaceListTc = tcWiredInTyCon listTyCon tcIfaceTyCon IfacePArrTc = tcWiredInTyCon parrTyCon tcIfaceTyCon (IfaceTupTc bx ar) = tcWiredInTyCon (tupleTyCon bx ar) +tcIfaceTyCon (IfaceAnyTc kind) = do { tc_kind <- tcIfaceType kind + ; tcWiredInTyCon (anyTyConOfKind tc_kind) } tcIfaceTyCon (IfaceTc name) = do { thing <- tcIfaceGlobal name ; return (check_tc (tyThingTyCon thing)) } where diff --git a/compiler/nativeGen/Reg.hs b/compiler/nativeGen/Reg.hs index 1da72c4..422ea24 100644 --- a/compiler/nativeGen/Reg.hs +++ b/compiler/nativeGen/Reg.hs @@ -125,8 +125,8 @@ data RealReg instance Uniquable RealReg where getUnique reg = case reg of - RealRegSingle i -> mkUnique 'S' i - RealRegPair r1 r2 -> mkUnique 'P' (r1 * 65536 + r2) + RealRegSingle i -> mkRegSingleUnique i + RealRegPair r1 r2 -> mkRegPairUnique (r1 * 65536 + r2) instance Outputable RealReg where ppr reg diff --git a/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs b/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs index c3c1148..6d31220 100644 --- a/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs +++ b/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs @@ -57,11 +57,11 @@ data Reg -- | so we can put regs in UniqSets instance Uniquable Reg where getUnique (Reg c i) - = mkUnique 'R' + = mkRegSingleUnique $ fromEnum c * 1000 + i getUnique (RegSub s (Reg c i)) - = mkUnique 'S' + = mkRegSubUnique $ fromEnum s * 10000 + fromEnum c * 1000 + i getUnique (RegSub _ (RegSub _ _)) diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs index b7b7475..15fbb59 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs @@ -436,15 +436,15 @@ isStoreReg ss instance Uniquable Store where getUnique (SReg r) | RegReal (RealRegSingle i) <- r - = mkUnique 'R' i + = mkRegSingleUnique i | RegReal (RealRegPair r1 r2) <- r - = mkUnique 'P' (r1 * 65535 + r2) + = mkRegPairUnique (r1 * 65535 + r2) | otherwise = error "RegSpillClean.getUnique: found virtual reg during spill clean, only real regs expected." - getUnique (SSlot i) = mkUnique 'S' i + getUnique (SSlot i) = mkRegSubUnique i -- [SLPJ] I hope "SubUnique" is ok instance Outputable Store where ppr (SSlot i) = text "slot" <> int i diff --git a/compiler/nativeGen/RegClass.hs b/compiler/nativeGen/RegClass.hs index 8b6b2d4..4bb300f 100644 --- a/compiler/nativeGen/RegClass.hs +++ b/compiler/nativeGen/RegClass.hs @@ -21,9 +21,9 @@ data RegClass instance Uniquable RegClass where - getUnique RcInteger = mkUnique 'L' 0 - getUnique RcFloat = mkUnique 'L' 1 - getUnique RcDouble = mkUnique 'L' 2 + getUnique RcInteger = mkRegClassUnique 0 + getUnique RcFloat = mkRegClassUnique 1 + getUnique RcDouble = mkRegClassUnique 2 instance Outputable RegClass where ppr RcInteger = Outputable.text "I" diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 67e79e2..bc08660 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -923,7 +923,8 @@ addrPrimTyConKey, arrayPrimTyConKey, boolTyConKey, byteArrayPrimTyConKey, listTyConKey, foreignObjPrimTyConKey, weakPrimTyConKey, mutableArrayPrimTyConKey, mutableByteArrayPrimTyConKey, orderingTyConKey, mVarPrimTyConKey, ratioTyConKey, rationalTyConKey, - realWorldTyConKey, stablePtrPrimTyConKey, stablePtrTyConKey :: Unique + realWorldTyConKey, stablePtrPrimTyConKey, stablePtrTyConKey, + anyTyConKey :: Unique addrPrimTyConKey = mkPreludeTyConUnique 1 arrayPrimTyConKey = mkPreludeTyConUnique 3 boolTyConKey = mkPreludeTyConUnique 4 @@ -956,10 +957,7 @@ rationalTyConKey = mkPreludeTyConUnique 33 realWorldTyConKey = mkPreludeTyConUnique 34 stablePtrPrimTyConKey = mkPreludeTyConUnique 35 stablePtrTyConKey = mkPreludeTyConUnique 36 - -anyPrimTyConKey, anyPrimTyCon1Key :: Unique -anyPrimTyConKey = mkPreludeTyConUnique 37 -anyPrimTyCon1Key = mkPreludeTyConUnique 38 +anyTyConKey = mkPreludeTyConUnique 37 statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey, mutVarPrimTyConKey, ioTyConKey, diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs index c69bea1..4e1576f 100644 --- a/compiler/prelude/TysPrim.lhs +++ b/compiler/prelude/TysPrim.lhs @@ -1,9 +1,13 @@ % % (c) The AQUA Project, Glasgow University, 1994-1998 % + + \section[TysPrim]{Wired-in knowledge about primitive types} \begin{code} +-- | This module defines TyCons that can't be expressed in Haskell. +-- They are all, therefore, wired-in TyCons. C.f module TysWiredIn module TysPrim( alphaTyVars, betaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar, alphaTy, betaTy, gammaTy, deltaTy, @@ -41,20 +45,21 @@ module TysPrim( int64PrimTyCon, int64PrimTy, word64PrimTyCon, word64PrimTy, - anyPrimTyCon, anyPrimTy, anyPrimTyCon1, mkAnyPrimTyCon + -- * Any + anyTyCon, anyType, anyTyConOfKind, anyTypeOfKind ) where #include "HsVersions.h" import Var ( TyVar, mkTyVar ) import Name ( Name, BuiltInSyntax(..), mkInternalName, mkWiredInName ) +import OccName ( mkTcOcc ) import OccName ( mkTyVarOccFS, mkTcOccFS ) -import TyCon ( TyCon, mkPrimTyCon, mkLiftedPrimTyCon ) +import TyCon ( TyCon, mkPrimTyCon, mkLiftedPrimTyCon, mkAnyTyCon ) import Type import SrcLoc -import Unique ( mkAlphaTyVarUnique, pprUnique ) +import Unique ( mkAlphaTyVarUnique ) import PrelNames -import StaticFlags import FastString import Outputable @@ -94,7 +99,7 @@ primTyCons , wordPrimTyCon , word32PrimTyCon , word64PrimTyCon - , anyPrimTyCon, anyPrimTyCon1 + , anyTyCon ] mkPrimTc :: FastString -> Unique -> TyCon -> Name @@ -104,7 +109,7 @@ mkPrimTc fs unique tycon (ATyCon tycon) -- Relevant TyCon UserSyntax -- None are built-in syntax -charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, anyPrimTyConName, anyPrimTyCon1Name :: Name +charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName :: Name charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon intPrimTyConName = mkPrimTc (fsLit "Int#") intPrimTyConKey intPrimTyCon int32PrimTyConName = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon @@ -129,8 +134,6 @@ stableNamePrimTyConName = mkPrimTc (fsLit "StableName#") stableNamePrimTyC bcoPrimTyConName = mkPrimTc (fsLit "BCO#") bcoPrimTyConKey bcoPrimTyCon weakPrimTyConName = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPrimTyCon threadIdPrimTyConName = mkPrimTc (fsLit "ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon -anyPrimTyConName = mkPrimTc (fsLit "Any") anyPrimTyConKey anyPrimTyCon -anyPrimTyCon1Name = mkPrimTc (fsLit "Any1") anyPrimTyCon1Key anyPrimTyCon1 \end{code} %************************************************************************ @@ -182,6 +185,115 @@ openBetaTy = mkTyVarTy openBetaTyVar %************************************************************************ %* * + Any +%* * +%************************************************************************ + +Note [Any types] +~~~~~~~~~~~~~~~~ +The type constructor Any::* has these properties + + * It is defined in module GHC.Prim, and exported so that it is + available to users. For this reason it's treated like any other + primitive type: + - has a fixed unique, anyTyConKey, + - lives in the global name cache + - built with TyCon.PrimTyCon + + * It is lifted, and hence represented by a pointer + + * It is inhabited by at least one value, namely bottom + + * You can unsafely coerce any lifted type to Ayny, and back. + + * It does not claim to be a *data* type, and that's important for + the code generator, because the code gen may *enter* a data value + but never enters a function value. + + * It is used to instantiate otherwise un-constrained type variables of kind * + For example length Any [] + See Note [Strangely-kinded void TyCons] + +In addition, we have a potentially-infinite family of types, one for +each kind /other than/ *, needed to instantiate otherwise +un-constrained type variables of kinds other than *. This is a bit +like tuples; there is a potentially-infinite family. They have slightly +different characteristics to Any::*: + + * They are built with TyCon.AnyTyCon + * They have non-user-writable names like "Any(*->*)" + * They are not exported by GHC.Prim + * They are uninhabited (of course; not kind *) + * They have a unique derived from their OccName (see Note [Uniques of Any]) + * Their Names do not live in the global name cache + +Note [Uniques of Any] +~~~~~~~~~~~~~~~~~~~~~ +Although Any(*->*), say, doesn't have a binding site, it still needs +to have a Unique. Unlike tuples (which are also an infinite family) +there is no convenient way to index them, so we use the Unique from +their OccName instead. That should be unique! (But in principle we +must take care: it does not include the module/package.) + +Note [Strangely-kinded void TyCons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See Trac #959 for more examples + +When the type checker finds a type variable with no binding, which +means it can be instantiated with an arbitrary type, it usually +instantiates it to Void. Eg. + + length [] +===> + length Any (Nil Any) + +But in really obscure programs, the type variable might have a kind +other than *, so we need to invent a suitably-kinded type. + +This commit uses + Any for kind * + Any(*->*) for kind *->* + etc + +\begin{code} +anyTyConName :: Name +anyTyConName = mkPrimTc (fsLit "Any") anyTyConKey anyTyCon + +anyTyCon :: TyCon +anyTyCon = mkLiftedPrimTyCon anyTyConName liftedTypeKind 0 PtrRep + +anyType :: Type +anyType = mkTyConApp anyTyCon [] + +anyTypeOfKind :: Kind -> Type +anyTypeOfKind kind + | isLiftedTypeKind kind = anyType + | otherwise = mkTyConApp (mk_any_tycon kind) [] + +anyTyConOfKind :: Kind -> TyCon +anyTyConOfKind kind + | isLiftedTypeKind kind = anyTyCon + | otherwise = mk_any_tycon kind + +mk_any_tycon :: Kind -> TyCon +mk_any_tycon kind -- Kind other than * + = tycon + where + -- Derive the name from the kind, thus: + -- Any(*->*), Any(*->*->*) + -- These are names that can't be written by the user, + -- and are not allocated in the global name cache + str = "Any" ++ showSDoc (pprParendKind kind) + + occ = mkTcOcc str + uniq = getUnique occ -- See Note [Uniques of Any] + name = mkWiredInName gHC_PRIM occ uniq (ATyCon tycon) UserSyntax + tycon = mkAnyTyCon name kind +\end{code} + + +%************************************************************************ +%* * \subsection[TysPrim-basic]{Basic primitive types (@Char#@, @Int#@, etc.)} %* * %************************************************************************ @@ -294,54 +406,6 @@ defined in \tr{TysWiredIn.lhs}, not here. %************************************************************************ %* * - Any -%* * -%************************************************************************ - -The type constructor Any is type to which you can unsafely coerce any -lifted type, and back. - - * It is lifted, and hence represented by a pointer - - * It does not claim to be a *data* type, and that's important for - the code generator, because the code gen may *enter* a data value - but never enters a function value. - -It's also used to instantiate un-constrained type variables after type -checking. For example - length Any [] -Annoyingly, we sometimes need Anys of other kinds, such as (*->*) etc. -This is a bit like tuples. We define a couple of useful ones here, -and make others up on the fly. If any of these others end up being exported -into interface files, we'll get a crash; at least until we add interface-file -syntax to support them. - -\begin{code} -anyPrimTy :: Type -anyPrimTy = mkTyConApp anyPrimTyCon [] - -anyPrimTyCon :: TyCon -- Kind * -anyPrimTyCon = mkLiftedPrimTyCon anyPrimTyConName liftedTypeKind 0 PtrRep - -anyPrimTyCon1 :: TyCon -- Kind *->* -anyPrimTyCon1 = mkLiftedPrimTyCon anyPrimTyCon1Name kind 0 PtrRep - where - kind = mkArrowKind liftedTypeKind liftedTypeKind - -mkAnyPrimTyCon :: Unique -> Kind -> TyCon --- Grotesque hack alert: the client gives the unique; so equality won't work -mkAnyPrimTyCon unique kind - = WARN( opt_PprStyle_Debug, ptext (sLit "Urk! Inventing strangely-kinded Any TyCon:") <+> ppr unique <+> ppr kind ) - -- See Note [Strangely-kinded void TyCons] in TcHsSyn - tycon - where - name = mkPrimTc (mkFastString ("Any" ++ showSDoc (pprUnique unique))) unique tycon - tycon = mkLiftedPrimTyCon name kind 0 PtrRep -\end{code} - - -%************************************************************************ -%* * \subsection[TysPrim-arrays]{The primitive array types} %* * %************************************************************************ diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index 83c3f45..cf54f26 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -3,12 +3,9 @@ % \section[TysWiredIn]{Wired-in knowledge about {\em non-primitive} types} -This module tracks the ``state interface'' document, ``GHC prelude: -types and operations.'' - \begin{code} -- | This module is about types that can be defined in Haskell, but which --- must be wired into the compiler nonetheless. +-- must be wired into the compiler nonetheless. C.f module TysPrim module TysWiredIn ( -- * All wired in things wiredInTyCons, @@ -329,6 +326,7 @@ unboxedPairDataCon :: DataCon unboxedPairDataCon = tupleCon Unboxed 2 \end{code} + %************************************************************************ %* * \subsection[TysWiredIn-boxed-prim]{The ``boxed primitive'' types (@Char@, @Int@, etc)} diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs index b2d7257..b5484a4 100644 --- a/compiler/stgSyn/CoreToStg.lhs +++ b/compiler/stgSyn/CoreToStg.lhs @@ -437,7 +437,7 @@ mkStgAltType bndr alts | isUnLiftedTyCon tc -> PrimAlt tc | isHiBootTyCon tc -> look_for_better_tycon | isAlgTyCon tc -> AlgAlt tc - | otherwise -> ASSERT( _is_poly_alt_tycon tc ) + | otherwise -> ASSERT2( _is_poly_alt_tycon tc, ppr tc ) PolyAlt Nothing -> PolyAlt diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 299d70f..de572ba 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -16,8 +16,6 @@ module TcHsSyn ( nlHsIntLit, shortCutLit, hsOverLitName, - mkArbitraryType, -- Put this elsewhere? - -- re-exported from TcMonad TcId, TcIdSet, TcDictBinds, @@ -39,7 +37,6 @@ import TcType import TcMType import TysPrim import TysWiredIn -import TyCon import DataCon import Name import Var @@ -52,7 +49,6 @@ import SrcLoc import Util import Bag import Outputable -import FastString \end{code} \begin{code} @@ -1012,76 +1008,7 @@ zonkTypeZapping ty -- mutable tyvar to a fresh immutable one. So the mutable store -- plays the role of an environment. If we come across a mutable -- type variable that isn't so bound, it must be completely free. - zonk_unbound_tyvar tv = do { ty <- mkArbitraryType warn tv + zonk_unbound_tyvar tv = do { let ty = anyTypeOfKind (tyVarKind tv) ; writeMetaTyVar tv ty ; return ty } - where - warn span msg = setSrcSpan span (addWarnTc msg) - - -{- Note [Strangely-kinded void TyCons] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - See Trac #959 for more examples - -When the type checker finds a type variable with no binding, which -means it can be instantiated with an arbitrary type, it usually -instantiates it to Void. Eg. - - length [] -===> - length Void (Nil Void) - -But in really obscure programs, the type variable might have a kind -other than *, so we need to invent a suitably-kinded type. - -This commit uses - Void for kind * - List for kind *->* - Tuple for kind *->...*->* - -which deals with most cases. (Previously, it only dealt with -kind *.) - -In the other cases, it just makes up a TyCon with a suitable kind. If -this gets into an interface file, anyone reading that file won't -understand it. This is fixable (by making the client of the interface -file make up a TyCon too) but it is tiresome and never happens, so I -am leaving it. - -Meanwhile I have now fixed GHC to emit a civilized warning. - -} - -mkArbitraryType :: (SrcSpan -> SDoc -> TcRnIf g l a) -- How to complain - -> TcTyVar - -> TcRnIf g l Type -- Used by desugarer too --- Make up an arbitrary type whose kind is the same as the tyvar. --- We'll use this to instantiate the (unbound) tyvar. --- --- Also used by the desugarer; hence the (tiresome) parameter --- to use when generating a warning -mkArbitraryType warn tv - | liftedTypeKind `isSubKind` kind -- The vastly common case - = return anyPrimTy - | eqKind kind (tyConKind anyPrimTyCon1) -- @*->*@ - = return (mkTyConApp anyPrimTyCon1 []) -- No tuples this size - | all isLiftedTypeKind args -- @*-> ... ->*->*@ - , isLiftedTypeKind res -- Horrible hack to make less use - = return (mkTyConApp tup_tc []) -- of mkAnyPrimTyCon - | otherwise - = do { _ <- warn (getSrcSpan tv) msg - ; return (mkTyConApp (mkAnyPrimTyCon (getUnique tv) kind) []) } - -- Same name as the tyvar, apart from making it start with a colon (sigh) - -- I dread to think what will happen if this gets out into an - -- interface file. Catastrophe likely. Major sigh. - where - kind = tyVarKind tv - (args,res) = splitKindFunTys kind - tup_tc = tupleTyCon Boxed (length args) - - msg = vcat [ hang (ptext (sLit "Inventing strangely-kinded Any TyCon")) - 2 (ptext (sLit "of kind") <+> quotes (ppr kind)) - , nest 2 (ptext (sLit "from an instantiation of type variable") <+> quotes (ppr tv)) - , ptext (sLit "This warning can be suppressed by a type signature fixing") <+> quotes (ppr tv) - , nest 2 (ptext (sLit "but is harmless without -O (and usually harmless anyway).")) - , ptext (sLit "See http://hackage.haskell.org/trac/ghc/ticket/959 for details") ] -\end{code} +\end{code} \ No newline at end of file diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index bb21536..6f8803c 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -20,13 +20,14 @@ module TyCon( mkClassTyCon, mkFunTyCon, mkPrimTyCon, - mkVoidPrimTyCon, + mkKindTyCon, mkLiftedPrimTyCon, mkTupleTyCon, mkSynTyCon, mkSuperKindTyCon, mkCoercionTyCon, mkForeignTyCon, + mkAnyTyCon, -- ** Predicates on TyCons isAlgTyCon, @@ -37,7 +38,7 @@ module TyCon( isSynTyCon, isClosedSynTyCon, isOpenSynTyCon, isSuperKindTyCon, isCoercionTyCon, isCoercionTyCon_maybe, - isForeignTyCon, + isForeignTyCon, isAnyTyCon, isInjectiveTyCon, isDataTyCon, isProductTyCon, isEnumerationTyCon, @@ -103,7 +104,7 @@ import Data.List( elemIndex ) %************************************************************************ \begin{code} --- | Represents type constructors. Type constructors are introduced by things such as: +-- | TyCons represent type constructors. Type constructors are introduced by things such as: -- -- 1) Data declarations: @data Foo = ...@ creates the @Foo@ type constructor of kind @*@ -- @@ -150,6 +151,7 @@ data TyCon -- that doesn't mean it's a true GADT; only that the "where" -- form was used. This field is used only to guide -- pretty-printing + algTcStupidTheta :: [PredType], -- ^ The \"stupid theta\" for the data type (always empty for GADTs). -- A \"stupid theta\" is the context to the left of an algebraic type -- declaration, e.g. @Eq a@ in the declaration @data Eq a => T a ...@. @@ -198,17 +200,19 @@ data TyCon tyConUnique :: Unique, tyConName :: Name, tyConKind :: Kind, - tyConArity :: Arity, -- SLPJ Oct06: I'm not sure what the significance - -- of the arity of a primtycon is! + tyConArity :: Arity, -- SLPJ Oct06: I'm not sure what the significance + -- of the arity of a primtycon is! + + primTyConRep :: PrimRep, -- ^ Many primitive tycons are unboxed, but some are + -- boxed (represented by pointers). This 'PrimRep' holds + -- that information. + -- Only relevant if tyConKind = * - primTyConRep :: PrimRep, - -- ^ Many primitive tycons are unboxed, but some are - -- boxed (represented by pointers). This 'PrimRep' holds - -- that information + isUnLifted :: Bool, -- ^ Most primitive tycons are unlifted (may not contain bottom) + -- but foreign-imported ones may be lifted - isUnLifted :: Bool, -- ^ Most primitive tycons are unlifted (may not contain bottom) - -- but foreign-imported ones may be lifted - tyConExtName :: Maybe FastString -- ^ @Just e@ for foreign-imported types, holds the name of the imported thing + tyConExtName :: Maybe FastString -- ^ @Just e@ for foreign-imported types, + -- holds the name of the imported thing } -- | Type coercions, such as @(~)@, @sym@, @trans@, @left@ and @right@. @@ -226,6 +230,19 @@ data TyCon -- the kind as a pair of types: @(ta, tc)@ } + -- | Any types. Like tuples, this is a potentially-infinite family of TyCons + -- one for each distinct Kind. They have no values at all. + -- Because there are infinitely many of them (like tuples) they are + -- defined in GHC.Prim and have names like "Any(*->*)". + -- Their Unique is derived from the OccName. + -- See Note [Any types] in TysPrim + | AnyTyCon { + tyConUnique :: Unique, + tyConName :: Name, + tyConKind :: Kind -- Never = *; that is done via PrimTyCon + -- See Note [Any types] in TysPrim + } + -- | Super-kinds. These are "kinds-of-kinds" and are never seen in Haskell source programs. -- There are only two super-kinds: TY (aka "box"), which is the super-kind of kinds that -- construct types eventually, and CO (aka "diamond"), which is the super-kind of kinds @@ -643,10 +660,10 @@ mkPrimTyCon :: Name -> Kind -> Arity -> PrimRep -> TyCon mkPrimTyCon name kind arity rep = mkPrimTyCon' name kind arity rep True --- | Create the special void 'TyCon' which is unlifted and has 'VoidRep' -mkVoidPrimTyCon :: Name -> Kind -> Arity -> TyCon -mkVoidPrimTyCon name kind arity - = mkPrimTyCon' name kind arity VoidRep True +-- | Kind constructors +mkKindTyCon :: Name -> Kind -> TyCon +mkKindTyCon name kind + = mkPrimTyCon' name kind 0 VoidRep True -- | Create a lifted primitive 'TyCon' such as @RealWorld@ mkLiftedPrimTyCon :: Name -> Kind -> Arity -> PrimRep -> TyCon @@ -688,6 +705,12 @@ mkCoercionTyCon name arity kindRule coKindFun = kindRule } +mkAnyTyCon :: Name -> Kind -> TyCon +mkAnyTyCon name kind + = AnyTyCon { tyConName = name, + tyConKind = kind, + tyConUnique = nameUnique name } + -- | Create a super-kind 'TyCon' mkSuperKindTyCon :: Name -> TyCon -- Super kinds always have arity zero mkSuperKindTyCon name @@ -907,6 +930,11 @@ isSuperKindTyCon :: TyCon -> Bool isSuperKindTyCon (SuperKindTyCon {}) = True isSuperKindTyCon _ = False +-- | Is this an AnyTyCon? +isAnyTyCon :: TyCon -> Bool +isAnyTyCon (AnyTyCon {}) = True +isAnyTyCon _ = False + -- | Attempt to pull a 'TyCon' apart into the arity and 'coKindFun' of -- a coercion 'TyCon'. Returns @Nothing@ if the 'TyCon' is not of the -- appropriate kind diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index 5c29087..c1670f6 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -304,14 +304,11 @@ funTyCon = mkFunTyCon funTyConName (mkArrowKinds [argTypeKind, openTypeKind] lif tySuperKindTyCon = mkSuperKindTyCon tySuperKindTyConName coSuperKindTyCon = mkSuperKindTyCon coSuperKindTyConName -liftedTypeKindTyCon = mkKindTyCon liftedTypeKindTyConName -openTypeKindTyCon = mkKindTyCon openTypeKindTyConName -unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName -ubxTupleKindTyCon = mkKindTyCon ubxTupleKindTyConName -argTypeKindTyCon = mkKindTyCon argTypeKindTyConName - -mkKindTyCon :: Name -> TyCon -mkKindTyCon name = mkVoidPrimTyCon name tySuperKind 0 +liftedTypeKindTyCon = mkKindTyCon liftedTypeKindTyConName tySuperKind +openTypeKindTyCon = mkKindTyCon openTypeKindTyConName tySuperKind +unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName tySuperKind +ubxTupleKindTyCon = mkKindTyCon ubxTupleKindTyConName tySuperKind +argTypeKindTyCon = mkKindTyCon argTypeKindTyConName tySuperKind -------------------------- -- ... and now their names diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs index dcef9d8..ea647c7 100644 --- a/compiler/vectorise/VectUtils.hs +++ b/compiler/vectorise/VectUtils.hs @@ -98,7 +98,7 @@ mkBuiltinTyConApps get_tc tys ty mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2] voidType :: VM Type -voidType = mkBuiltinTyConApp voidTyCon [] +voidType = mkBuiltinTyConApp VectMonad.voidTyCon [] mkWrapType :: Type -> VM Type mkWrapType ty = mkBuiltinTyConApp wrapTyCon [ty]