Commit 388e3356 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

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.
parent c173e8d1
......@@ -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)
......
......@@ -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}
......@@ -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]
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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 _ _))
......
......@@ -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
......
......@@ -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"
......
......@@ -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,
......
%
% (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}
%************************************************************************
......@@ -180,6 +183,115 @@ openBetaTy = mkTyVarTy openBetaTyVar
\end{code}
%************************************************************************
%* *
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.)}
......@@ -292,54 +404,6 @@ Note: the ``state-pairing'' types are not truly primitive, so they are
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}
......
......@@ -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,
......