Commit c128930d authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

Add the primitive type Any, and use it for Dynamics

GHC's code generator can only enter a closure if it's guaranteed
not to be a function.  In the Dynamic module, we were using the 
type (forall a.a) as the type to which the dynamic type was unsafely
cast:
	type Obj = forall a.a

Gut alas this polytype was sometimes instantiated to (), something 
like this (it only bit when profiling was enabled)
	let y::() = dyn ()
	in (y `cast` ..) p q
As a result, an ASSERT in ClosureInfo fired (hooray).

I've tided this up by making a new, primitive, lifted type Any, and
arranging that Dynamic uses Any, thus:
	type Obj = ANy

While I was at it, I also arranged that when the type checker instantiates 
un-constrained type variables, it now instantiates them to Any, not ()
	e.g.  length Any []

[There remains a Horrible Hack when we want Any-like things at arbitrary 
kinds.  This essentially never happens, but see comments with 
TysPrim.mkAnyPrimTyCon.]

Anyway, this fixes Trac #905
parent 5e41a5af
......@@ -257,12 +257,12 @@ mkLFThunk thunk_ty top fvs upd_flag
(might_be_a_function thunk_ty)
might_be_a_function :: Type -> Bool
-- Return False only if we are *sure* it's a data type
-- Look through newtypes etc as much as poss
might_be_a_function ty
| Just (tc,_) <- splitTyConApp_maybe (repType ty),
not (isFunTyCon tc) && not (isAbstractTyCon tc) = False
-- don't forget to check for abstract types, which might
-- be functions too.
| otherwise = True
= case splitTyConApp_maybe (repType ty) of
Just (tc, _) -> not (isDataTyCon tc)
Nothing -> True
\end{code}
@mkConLFInfo@ is similar, for constructors.
......
......@@ -28,6 +28,7 @@ import HsSyn -- lots of things
import CoreSyn -- lots of things
import CoreUtils
import TcHsSyn ( mkArbitraryType ) -- Mis-placed?
import OccurAnal
import CostCentre
import Module
......@@ -178,7 +179,7 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
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 voidTy
-- some of the tyvars will be bound to 'Any'
do { locals' <- newSysLocalsDs (map substitute local_tys)
; tup_id <- newSysLocalDs (substitute tup_ty)
; mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local core_bind)
......@@ -191,7 +192,7 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
; returnDs ((global', rhs) : spec_binds) }
where
mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
| otherwise = voidTy
| otherwise = mkArbitraryType all_tyvar
ty_args = map mk_ty_arg all_tyvars
substitute = substTyWith all_tyvars ty_args
......@@ -266,11 +267,11 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
(mkVarApps (Var spec_id) bndrs)
}
where
-- Bind to voidTy any of all_ptvs that aren't
-- Bind to Any any of all_ptvs that aren't
-- relevant for this particular function
fix_up body | null void_tvs = body
| otherwise = mkTyApps (mkLams void_tvs body)
(map (const voidTy) void_tvs)
(map mkArbitraryType void_tvs)
void_tvs = all_tvs \\ tvs
msg = hang (ptext SLIT("Specialisation too complicated to desugar; ignored"))
......
......@@ -1076,17 +1076,6 @@ tyThingToIfaceDecl (ATyCon tycon)
= IfaceForeign { ifName = getOccName tycon,
ifExtName = tyConExtName tycon }
| isPrimTyCon tycon || isFunTyCon tycon
-- Needed in GHCi for ':info Int#', for example
= IfaceData { ifName = getOccName tycon,
ifTyVars = toIfaceTvBndrs (take (tyConArity tycon) alphaTyVars),
ifCtxt = [],
ifCons = IfAbstractTyCon,
ifGadtSyntax = False,
ifGeneric = False,
ifRec = NonRecursive,
ifFamInst = Nothing }
| otherwise = pprPanic "toIfaceDecl" (ppr tycon)
where
tyvars = tyConTyVars tycon
......
......@@ -60,7 +60,7 @@ import Unique ( Unique, Uniquable(..), hasKey,
mkTupleTyConUnique
)
import BasicTypes ( Boxity(..), Arity )
import Name ( Name, mkInternalName, mkExternalName, nameModule )
import Name ( Name, mkInternalName, mkExternalName )
import SrcLoc ( noSrcLoc )
import FastString
\end{code}
......@@ -758,6 +758,10 @@ rationalTyConKey = mkPreludeTyConUnique 33
realWorldTyConKey = mkPreludeTyConUnique 34
stablePtrPrimTyConKey = mkPreludeTyConUnique 35
stablePtrTyConKey = mkPreludeTyConUnique 36
anyPrimTyConKey = mkPreludeTyConUnique 37
anyPrimTyCon1Key = mkPreludeTyConUnique 38
statePrimTyConKey = mkPreludeTyConUnique 50
stableNamePrimTyConKey = mkPreludeTyConUnique 51
stableNameTyConKey = mkPreludeTyConUnique 52
......@@ -798,7 +802,7 @@ eitherTyConKey = mkPreludeTyConUnique 84
-- Super Kinds constructors
tySuperKindTyConKey = mkPreludeTyConUnique 85
coSuperKindTyConKey = mkPreludeTyConUnique 86
coSuperKindTyConKey = mkPreludeTyConUnique 86
-- Kind constructors
liftedTypeKindTyConKey = mkPreludeTyConUnique 87
......
......@@ -39,7 +39,9 @@ module TysPrim(
word32PrimTyCon, word32PrimTy,
int64PrimTyCon, int64PrimTy,
word64PrimTyCon, word64PrimTy
word64PrimTyCon, word64PrimTy,
anyPrimTyCon, anyPrimTy, anyPrimTyCon1, mkAnyPrimTyCon
) where
#include "HsVersions.h"
......@@ -52,11 +54,11 @@ import TyCon ( TyCon, mkPrimTyCon, mkLiftedPrimTyCon,
import Type ( mkTyConApp, mkTyConTy, mkTyVarTys, mkTyVarTy,
unliftedTypeKind,
liftedTypeKind, openTypeKind,
Kind, mkArrowKinds,
Kind, mkArrowKinds, mkArrowKind,
TyThing(..)
)
import SrcLoc ( noSrcLoc )
import Unique ( mkAlphaTyVarUnique )
import Unique ( mkAlphaTyVarUnique, pprUnique )
import PrelNames
import FastString ( FastString, mkFastString )
import Outputable
......@@ -97,6 +99,7 @@ primTyCons
, wordPrimTyCon
, word32PrimTyCon
, word64PrimTyCon
, anyPrimTyCon, anyPrimTyCon1
]
mkPrimTc :: FastString -> Unique -> TyCon -> Name
......@@ -130,6 +133,8 @@ stableNamePrimTyConName = mkPrimTc FSLIT("StableName#") stableNamePrimTyCo
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 anyPrimTyCon
\end{code}
%************************************************************************
......@@ -261,6 +266,52 @@ 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
lenth 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 = 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 uniq kind
= pprTrace "Urk! Inventing strangely-kinded Any TyCon:" (ppr uniq <+> ppr kind)
tycon
where
name = mkPrimTc (mkFastString ("Any" ++ showSDoc (pprUnique uniq))) uniq tycon
tycon = mkLiftedPrimTyCon name kind 0 PtrRep
\end{code}
%************************************************************************
%* *
\subsection[TysPrim-arrays]{The primitive array types}
......
......@@ -40,7 +40,6 @@ module TysWiredIn (
unboxedPairTyCon, unboxedPairDataCon,
unitTy,
voidTy,
-- parallel arrays
mkPArrTy,
......@@ -307,22 +306,6 @@ unboxedPairDataCon = tupleCon Unboxed 2
%* *
%************************************************************************
\begin{code}
-- The Void type is represented as a data type with no constructors
-- It's a built in type (i.e. there's no way to define it in Haskell;
-- the nearest would be
--
-- data Void = -- No constructors!
--
-- ) It's lifted; there is only one value of this
-- type, namely "void", whose semantics is just bottom.
--
-- Haskell 98 drops the definition of a Void type, so we just 'simulate'
-- voidTy using ().
voidTy = unitTy
\end{code}
\begin{code}
charTy = mkTyConTy charTyCon
......
......@@ -15,6 +15,7 @@ module TcHsSyn (
mkHsAppTy, mkSimpleHsAlt,
nlHsIntLit, mkVanillaTuplePat,
mkArbitraryType, -- Put this elsewhere?
-- re-exported from TcMonad
TcId, TcIdSet, TcDictBinds,
......@@ -920,24 +921,22 @@ mkArbitraryType :: TcTyVar -> Type
-- Make up an arbitrary type whose kind is the same as the tyvar.
-- We'll use this to instantiate the (unbound) tyvar.
mkArbitraryType tv
| liftedTypeKind `isSubKind` kind = voidTy -- The vastly common case
| liftedTypeKind `isSubKind` kind = anyPrimTy -- The vastly common case
| otherwise = mkTyConApp tycon []
where
kind = tyVarKind tv
(args,res) = splitKindFunTys kind
tycon | eqKind kind (tyConKind listTyCon) -- *->*
= listTyCon -- No tuples this size
tycon | eqKind kind (tyConKind anyPrimTyCon1) -- *->*
= anyPrimTyCon1 -- No tuples this size
| all isLiftedTypeKind args && isLiftedTypeKind res
= tupleTyCon Boxed (length args) -- *-> ... ->*->*
-- Horrible hack to make less use of mkAnyPrimTyCon
| otherwise
= pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $
mkPrimTyCon tc_name kind 0 VoidRep
= 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.
tc_name = mkInternalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc
\end{code}
......@@ -73,7 +73,6 @@ import Class
import BasicTypes
import Name
import PrelNames
import Maybe
import Maybes
import Outputable
import FastString
......@@ -546,8 +545,8 @@ isAlgTyCon (TupleTyCon {}) = True
isAlgTyCon other = False
isDataTyCon :: TyCon -> Bool
-- isDataTyCon returns True for data types that are represented by
-- heap-allocated constructors.
-- isDataTyCon returns True for data types that are definitely
-- represented by heap-allocated constructors.
-- These are srcutinised by Core-level @case@ expressions, and they
-- get info tables allocated for them.
-- True for all @data@ types
......@@ -559,7 +558,7 @@ isDataTyCon tc@(AlgTyCon {algTcRhs = rhs})
DataTyCon {} -> True
OpenNewTyCon -> False
NewTyCon {} -> False
AbstractTyCon -> pprPanic "isDataTyCon" (ppr tc)
AbstractTyCon -> False -- We don't know, so return False
isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity
isDataTyCon other = False
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment