From: simonpj@microsoft.com Date: Wed, 18 Oct 2006 11:56:58 +0000 (+0000) Subject: Add the primitive type Any, and use it for Dynamics X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=c128930dc98c73e2459a4610539fee73ca941247 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 --- diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs index 8f62bc7..e631989 100644 --- a/compiler/codeGen/ClosureInfo.lhs +++ b/compiler/codeGen/ClosureInfo.lhs @@ -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. diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 9fb2eaf..8ed9719 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -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")) diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 2f17fe7..7518111 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -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 diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index bccf84f..9ff85fa 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -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 diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs index 1ec7721..908cbaa 100644 --- a/compiler/prelude/TysPrim.lhs +++ b/compiler/prelude/TysPrim.lhs @@ -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} %************************************************************************ @@ -263,6 +268,52 @@ 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} %* * %************************************************************************ diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index 436b121..d224d7b 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -40,7 +40,6 @@ module TysWiredIn ( unboxedPairTyCon, unboxedPairDataCon, unitTy, - voidTy, -- parallel arrays mkPArrTy, @@ -308,22 +307,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 charTyCon = pcNonRecDataTyCon charTyConName [] [charDataCon] diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index a8d691c..6e17466 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -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} diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 3ae5c3e..eb0474b 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -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