Commit 91c6b1f5 authored by Ben Gamari's avatar Ben Gamari Committed by Ben Gamari

Generate Typeable info at definition sites

This is the second attempt at merging D757.

This patch implements the idea floated in Trac #9858, namely that we
should generate type-representation information at the data type
declaration site, rather than when solving a Typeable constraint.

However, this turned out quite a bit harder than I expected. I still
think it's the right thing to do, and it's done now, but it was quite
a struggle.

See particularly

 * Note [Grand plan for Typeable] in TcTypeable (which is a new module)
 * Note [The overall promotion story] in DataCon (clarifies existing
stuff)

The most painful bit was that to generate Typeable instances (ie
TyConRepName bindings) for every TyCon is tricky for types in ghc-prim
etc:

 * We need to have enough data types around to *define* a TyCon
 * Many of these types are wired-in

Also, to minimise the code generated for each data type, I wanted to
generate pure data, not CAFs with unpackCString# stuff floating about.

Performance
~~~~~~~~~~~
Three perf/compiler tests start to allocate quite a bit more. This isn't
surprising, because they all allocate zillions of data types, with
practically no other code, esp. T1969

 * T1969:    GHC allocates 19% more
 * T4801:    GHC allocates 13% more
 * T5321FD:  GHC allocates 13% more
 * T9675:    GHC allocates 11% more
 * T783:     GHC allocates 11% more
 * T5642:    GHC allocates 10% more

I'm treating this as acceptable. The payoff comes in Typeable-heavy
code.

Remaining to do
~~~~~~~~~~~~~~~

 * I think that "TyCon" and "Module" are over-generic names to use for
   the runtime type representations used in GHC.Typeable. Better might
be
   "TrTyCon" and "TrModule". But I have not yet done this

 * Add more info the the "TyCon" e.g. source location where it was
   defined

 * Use the new "Module" type to help with Trac Trac #10068

 * It would be possible to generate TyConRepName (ie Typeable
   instances) selectively rather than all the time. We'd need to persist
   the information in interface files. Lacking a motivating reason I
have
   not done this, but it would not be difficult.

Refactoring
~~~~~~~~~~~
As is so often the case, I ended up refactoring more than I intended.
In particular

 * In TyCon, a type *family* (whether type or data) is repesented by a
   FamilyTyCon
     * a algebraic data type (including data/newtype instances) is
       represented by AlgTyCon This wasn't true before; a data family
       was represented as an AlgTyCon. There are some corresponding
       changes in IfaceSyn.

     * Also get rid of the (unhelpfully named) tyConParent.

 * In TyCon define 'Promoted', isomorphic to Maybe, used when things are
   optionally promoted; and use it elsewhere in GHC.

 * Cleanup handling of knownKeyNames

 * Each TyCon, including promoted TyCons, contains its TyConRepName, if
   it has one. This is, in effect, the name of its Typeable instance.

Updates haddock submodule

Test Plan: Let Harbormaster validate

Reviewers: austin, hvr, goldfire

Subscribers: goldfire, thomie

Differential Revision: https://phabricator.haskell.org/D1404

GHC Trac Issues: #9858
parent 59e728bc
......@@ -32,7 +32,7 @@ import Unique
import Util
import Name
import BasicTypes
import {-# SOURCE #-} TypeRep (Type, ThetaType)
import TypeRep (Type, ThetaType)
import Var
import Type (mkTyConApp)
......
......@@ -35,7 +35,8 @@ module DataCon (
dataConSrcBangs,
dataConSourceArity, dataConRepArity, dataConRepRepArity,
dataConIsInfix,
dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds,
dataConWorkId, dataConWrapId, dataConWrapId_maybe,
dataConImplicitTyThings,
dataConRepStrictness, dataConImplBangs, dataConBoxer,
splitDataProductType_maybe,
......@@ -46,16 +47,18 @@ module DataCon (
isBanged, isMarkedStrict, eqHsBang, isSrcStrict, isSrcUnpacked,
-- ** Promotion related functions
promoteKind, promoteDataCon, promoteDataCon_maybe
promoteDataCon, promoteDataCon_maybe,
promoteType, promoteKind,
isPromotableType, computeTyConPromotability,
) where
#include "HsVersions.h"
import {-# SOURCE #-} MkId( DataConBoxer )
import Type
import ForeignCall( CType )
import TypeRep( Type(..) ) -- Used in promoteType
import PrelNames( liftedTypeKindTyConKey )
import ForeignCall( CType )
import Coercion
import Kind
import Unify
......@@ -72,11 +75,11 @@ import BasicTypes
import FastString
import Module
import VarEnv
import NameSet
import Binary
import qualified Data.Data as Data
import qualified Data.Typeable
import Data.Maybe
import Data.Char
import Data.Word
import Data.List( mapAccumL, find )
......@@ -399,8 +402,8 @@ data DataCon
-- Used for Template Haskell and 'deriving' only
-- The actual fixity is stored elsewhere
dcPromoted :: Maybe TyCon -- The promoted TyCon if this DataCon is promotable
-- See Note [Promoted data constructors] in TyCon
dcPromoted :: Promoted TyCon -- The promoted TyCon if this DataCon is promotable
-- See Note [Promoted data constructors] in TyCon
}
deriving Data.Typeable.Typeable
......@@ -671,7 +674,9 @@ isMarkedStrict _ = True -- All others are strict
-- | Build a new data constructor
mkDataCon :: Name
-> Bool -- ^ Is the constructor declared infix?
-> [HsSrcBang] -- ^ Strictness/unpack annotations, from user
-> Promoted TyConRepName -- ^ Whether promoted, and if so the TyConRepName
-- for the promoted TyCon
-> [HsSrcBang] -- ^ Strictness/unpack annotations, from user
-> [FieldLabel] -- ^ Field labels for the constructor,
-- if it is a record, otherwise empty
-> [TyVar] -- ^ Universally quantified type variables
......@@ -688,7 +693,7 @@ mkDataCon :: Name
-> DataCon
-- Can get the tag from the TyCon
mkDataCon name declared_infix
mkDataCon name declared_infix prom_info
arg_stricts -- Must match orig_arg_tys 1-1
fields
univ_tvs ex_tvs
......@@ -733,15 +738,12 @@ mkDataCon name declared_infix
mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
mb_promoted -- See Note [Promoted data constructors] in TyCon
| isJust (promotableTyCon_maybe rep_tycon)
-- The TyCon is promotable only if all its datacons
-- are, so the promoteType for prom_kind should succeed
= Just (mkPromotedDataCon con name (getUnique name) prom_kind roles)
| otherwise
= Nothing
prom_kind = promoteType (dataConUserType con)
roles = map (const Nominal) (univ_tvs ++ ex_tvs) ++
map (const Representational) orig_arg_tys
= case prom_info of
NotPromoted -> NotPromoted
Promoted rep_nm -> Promoted (mkPromotedDataCon con name rep_nm prom_kind prom_roles)
prom_kind = promoteType (dataConUserType con)
prom_roles = map (const Nominal) (univ_tvs ++ ex_tvs) ++
map (const Representational) orig_arg_tys
eqSpecPreds :: [(TyVar,Type)] -> ThetaType
eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv) ty | (tv,ty) <- spec ]
......@@ -824,11 +826,13 @@ dataConWrapId dc = case dcRep dc of
-- | Find all the 'Id's implicitly brought into scope by the data constructor. Currently,
-- the union of the 'dataConWorkId' and the 'dataConWrapId'
dataConImplicitIds :: DataCon -> [Id]
dataConImplicitIds (MkData { dcWorkId = work, dcRep = rep})
= case rep of
NoDataConRep -> [work]
DCR { dcr_wrap_id = wrap } -> [wrap,work]
dataConImplicitTyThings :: DataCon -> [TyThing]
dataConImplicitTyThings (MkData { dcWorkId = work, dcRep = rep })
= [AnId work] ++ wrap_ids
where
wrap_ids = case rep of
NoDataConRep -> []
DCR { dcr_wrap_id = wrap } -> [AnId wrap]
-- | The labels for the fields of this particular 'DataCon'
dataConFieldLabels :: DataCon -> [FieldLabel]
......@@ -1073,60 +1077,112 @@ dataConCannotMatch tys con
{-
************************************************************************
* *
Building an algebraic data type
Promotion
These functions are here becuase
- isPromotableTyCon calls dataConFullSig
- mkDataCon calls promoteType
- It's nice to keep the promotion stuff together
* *
************************************************************************
buildAlgTyCon is here because it is called from TysWiredIn, which in turn
depends on DataCon, but not on BuildTyCl.
-}
buildAlgTyCon :: Name
-> [TyVar] -- ^ Kind variables and type variables
-> [Role]
-> Maybe CType
-> ThetaType -- ^ Stupid theta
-> AlgTyConRhs
-> RecFlag
-> Bool -- ^ True <=> this TyCon is promotable
-> Bool -- ^ True <=> was declared in GADT syntax
-> TyConParent
-> TyCon
buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs
is_rec is_promotable gadt_syn parent
= tc
where
kind = mkPiKinds ktvs liftedTypeKind
-- tc and mb_promoted_tc are mutually recursive
tc = mkAlgTyCon tc_name kind ktvs roles cType stupid_theta
rhs parent is_rec gadt_syn
mb_promoted_tc
Note [The overall promotion story]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Here is the overall plan.
* Compared to a TyCon T, the promoted 'T has
same Name (and hence Unique)
same TyConRepName
In future the two will collapse into one anyhow.
* Compared to a DataCon K, the promoted 'K (a type constructor) has
same Name (and hence Unique)
But it has a fresh TyConRepName; after all, the DataCon doesn't have
a TyConRepName at all. (See Note [Grand plan for Typeable] in TcTypeable
for TyConRepName.)
Why does 'K have the same unique as K? It's acceptable because we don't
mix types and terms, so we won't get them confused. And it's helpful mainly
so that we know when to print 'K as a qualified name in error message. The
PrintUnqualified stuff depends on whether K is lexically in scope.. but 'K
never is!
* It follows that the tick-mark (eg 'K) is not part of the Occ name of
either promoted data constructors or type constructors. Instead,
pretty-printing: the pretty-printer prints a tick in front of
- promoted DataCons (always)
- promoted TyCons (with -dppr-debug)
See TyCon.pprPromotionQuote
* For a promoted data constructor K, the pipeline goes like this:
User writes (in a type): K or 'K
Parser produces OccName: K{tc} or K{d}, respectively
Renamer makes Name: M.K{d}_r62 (i.e. same unique as DataCon K)
and K{tc} has been turned into K{d}
provided it was unambiguous
Typechecker makes TyCon: PromotedDataCon MK{d}_r62
Note [Checking whether a group is promotable]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We only want to promote a TyCon if all its data constructors
are promotable; it'd be very odd to promote some but not others.
mb_promoted_tc
| is_promotable = Just (mkPromotedTyCon tc (promoteKind kind))
| otherwise = Nothing
But the data constructors may mention this or other TyCons.
{-
************************************************************************
* *
Promoting of data types to the kind level
* *
************************************************************************
So we treat the recursive uses as all OK (ie promotable) and
do one pass to check that each TyCon is promotable.
These two 'promoted..' functions are here because
* They belong together
* 'promoteDataCon' depends on DataCon stuff
Currently type synonyms are not promotable, though that
could change.
-}
promoteDataCon :: DataCon -> TyCon
promoteDataCon (MkData { dcPromoted = Just tc }) = tc
promoteDataCon (MkData { dcPromoted = Promoted tc }) = tc
promoteDataCon dc = pprPanic "promoteDataCon" (ppr dc)
promoteDataCon_maybe :: DataCon -> Maybe TyCon
promoteDataCon_maybe :: DataCon -> Promoted TyCon
promoteDataCon_maybe (MkData { dcPromoted = mb_tc }) = mb_tc
computeTyConPromotability :: NameSet -> TyCon -> Bool
computeTyConPromotability rec_tycons tc
= isAlgTyCon tc -- Only algebraic; not even synonyms
-- (we could reconsider the latter)
&& ok_kind (tyConKind tc)
&& case algTyConRhs tc of
DataTyCon { data_cons = cs } -> all ok_con cs
TupleTyCon { data_con = c } -> ok_con c
NewTyCon { data_con = c } -> ok_con c
AbstractTyCon {} -> False
where
ok_kind kind = all isLiftedTypeKind args && isLiftedTypeKind res
where -- Checks for * -> ... -> * -> *
(args, res) = splitKindFunTys kind
-- See Note [Promoted data constructors] in TyCon
ok_con con = all (isLiftedTypeKind . tyVarKind) ex_tvs
&& null eq_spec -- No constraints
&& null theta
&& all (isPromotableType rec_tycons) orig_arg_tys
where
(_, ex_tvs, eq_spec, theta, orig_arg_tys, _) = dataConFullSig con
isPromotableType :: NameSet -> Type -> Bool
-- Must line up with promoteType
-- But the function lives here because we must treat the
-- *recursive* tycons as promotable
isPromotableType rec_tcs con_arg_ty
= go con_arg_ty
where
go (TyConApp tc tys) = tys `lengthIs` tyConArity tc
&& (tyConName tc `elemNameSet` rec_tcs
|| isPromotableTyCon tc)
&& all go tys
go (FunTy arg res) = go arg && go res
go (TyVarTy {}) = True
go _ = False
{-
Note [Promoting a Type to a Kind]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -1156,7 +1212,7 @@ promoteType ty
kvs = [ mkKindVar (tyVarName tv) superKind | tv <- tvs ]
env = zipVarEnv tvs kvs
go (TyConApp tc tys) | Just prom_tc <- promotableTyCon_maybe tc
go (TyConApp tc tys) | Promoted prom_tc <- promotableTyCon_maybe tc
= mkTyConApp prom_tc (map go tys)
go (FunTy arg res) = mkArrowKind (go arg) (go res)
go (TyVarTy tv) | Just kv <- lookupVarEnv env tv
......@@ -1208,3 +1264,41 @@ splitDataProductType_maybe ty
= Just (tycon, ty_args, con, dataConInstArgTys con ty_args)
| otherwise
= Nothing
{-
************************************************************************
* *
Building an algebraic data type
* *
************************************************************************
buildAlgTyCon is here because it is called from TysWiredIn, which can
depend on this module, but not on BuildTyCl.
-}
buildAlgTyCon :: Name
-> [TyVar] -- ^ Kind variables and type variables
-> [Role]
-> Maybe CType
-> ThetaType -- ^ Stupid theta
-> AlgTyConRhs
-> RecFlag
-> Bool -- ^ True <=> this TyCon is promotable
-> Bool -- ^ True <=> was declared in GADT syntax
-> AlgTyConFlav
-> TyCon
buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs
is_rec is_promotable gadt_syn parent
= tc
where
kind = mkPiKinds ktvs liftedTypeKind
-- tc and mb_promoted_tc are mutually recursive
tc = mkAlgTyCon tc_name kind ktvs roles cType stupid_theta
rhs parent is_rec gadt_syn
mb_promoted_tc
mb_promoted_tc
| is_promotable = Promoted (mkPromotedTyCon tc (promoteKind kind))
| otherwise = NotPromoted
......@@ -72,6 +72,7 @@ module OccName (
mkPReprTyConOcc,
mkPADFunOcc,
mkRecFldSelOcc,
mkTyConRepUserOcc, mkTyConRepSysOcc,
-- ** Deconstruction
occNameFS, occNameString, occNameSpace,
......@@ -586,7 +587,8 @@ mkDataConWrapperOcc, mkWorkerOcc,
mkGenR, mkGen1R, mkGenRCo,
mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc,
mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,
mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc
mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
mkTyConRepUserOcc, mkTyConRepSysOcc
:: OccName -> OccName
-- These derived variables have a prefix that no Haskell value could have
......@@ -609,11 +611,24 @@ mkNewTyCoOcc = mk_simple_deriv tcName "NTCo:" -- Coercion for newtypes
mkInstTyCoOcc = mk_simple_deriv tcName "TFCo:" -- Coercion for type functions
mkEqPredCoOcc = mk_simple_deriv tcName "$co"
-- used in derived instances
-- Used in derived instances
mkCon2TagOcc = mk_simple_deriv varName "$con2tag_"
mkTag2ConOcc = mk_simple_deriv varName "$tag2con_"
mkMaxTagOcc = mk_simple_deriv varName "$maxtag_"
-- TyConRepName stuff; see Note [Grand plan for Typeable] in TcTypeable
-- incluing the wrinkle about mkSpecialTyConRepName
mkTyConRepSysOcc occ = mk_simple_deriv varName prefix occ
where
prefix | isDataOcc occ = "$tc'"
| otherwise = "$tc"
mkTyConRepUserOcc occ = mk_simple_deriv varName prefix occ
where
-- *User-writable* prefix, for types in gHC_TYPES
prefix | isDataOcc occ = "tc'"
| otherwise = "tc"
-- Generic deriving mechanism
-- | Generate a module-unique name, to be used e.g. while generating new names
......
......@@ -48,10 +48,13 @@ module Unique (
mkPreludeTyConUnique, mkPreludeClassUnique,
mkPArrDataConUnique,
mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique,
mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique,
mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique,
mkCostCentreUnique,
tyConRepNameUnique,
dataConWorkerUnique, dataConRepNameUnique,
mkBuiltinUnique,
mkPseudoUniqueD,
mkPseudoUniqueE,
......@@ -99,9 +102,10 @@ unpkUnique :: Unique -> (Char, Int) -- The reverse
mkUniqueGrimily :: Int -> Unique -- A trap-door for UniqSupply
getKey :: Unique -> Int -- for Var
incrUnique :: Unique -> Unique
deriveUnique :: Unique -> Int -> Unique
newTagUnique :: Unique -> Char -> Unique
incrUnique :: Unique -> Unique
stepUnique :: Unique -> Int -> Unique
deriveUnique :: Unique -> Int -> Unique
newTagUnique :: Unique -> Char -> Unique
mkUniqueGrimily = MkUnique
......@@ -109,9 +113,11 @@ mkUniqueGrimily = MkUnique
getKey (MkUnique x) = x
incrUnique (MkUnique i) = MkUnique (i + 1)
stepUnique (MkUnique i) n = MkUnique (i + n)
-- deriveUnique uses an 'X' tag so that it won't clash with
-- any of the uniques produced any other way
-- SPJ says: this looks terribly smelly to me!
deriveUnique (MkUnique i) delta = mkUnique 'X' (i + delta)
-- newTagUnique changes the "domain" of a unique to a different char
......@@ -305,14 +311,19 @@ mkPArrDataConUnique :: Int -> Unique
mkAlphaTyVarUnique i = mkUnique '1' i
mkPreludeClassUnique i = mkUnique '2' i
-- Prelude type constructors occupy *three* slots.
-- The first is for the tycon itself; the latter two
-- are for the generic to/from Ids. See TysWiredIn.mk_tc_gen_info.
--------------------------------------------------
-- Wired-in data constructor keys occupy *three* slots:
-- * u: the DataCon itself
-- * u+1: its worker Id
-- * u+2: the TyConRepName of the promoted TyCon
-- Prelude data constructors are too simple to need wrappers.
mkPreludeTyConUnique i = mkUnique '3' (3*i)
mkTupleTyConUnique Boxed a = mkUnique '4' (3*a)
mkTupleTyConUnique Unboxed a = mkUnique '5' (3*a)
mkCTupleTyConUnique a = mkUnique 'k' (3*a)
mkPreludeTyConUnique i = mkUnique '3' (3*i)
mkTupleTyConUnique Boxed a = mkUnique '4' (3*a)
mkTupleTyConUnique Unboxed a = mkUnique '5' (3*a)
mkCTupleTyConUnique a = mkUnique 'k' (3*a)
tyConRepNameUnique :: Unique -> Unique
tyConRepNameUnique u = incrUnique u
-- Data constructor keys occupy *two* slots. The first is used for the
-- data constructor itself and its wrapper function (the function that
......@@ -320,10 +331,22 @@ mkCTupleTyConUnique a = mkUnique 'k' (3*a)
-- used for the worker function (the function that builds the constructor
-- representation).
mkPreludeDataConUnique i = mkUnique '6' (2*i) -- Must be alphabetic
mkTupleDataConUnique Boxed a = mkUnique '7' (2*a) -- ditto (*may* be used in C labels)
mkTupleDataConUnique Unboxed a = mkUnique '8' (2*a)
--------------------------------------------------
-- Wired-in data constructor keys occupy *three* slots:
-- * u: the DataCon itself
-- * u+1: its worker Id
-- * u+2: the TyConRepName of the promoted TyCon
-- Prelude data constructors are too simple to need wrappers.
mkPreludeDataConUnique i = mkUnique '6' (3*i) -- Must be alphabetic
mkTupleDataConUnique Boxed a = mkUnique '7' (3*a) -- ditto (*may* be used in C labels)
mkTupleDataConUnique Unboxed a = mkUnique '8' (3*a)
dataConRepNameUnique, dataConWorkerUnique :: Unique -> Unique
dataConWorkerUnique u = incrUnique u
dataConRepNameUnique u = stepUnique u 2
--------------------------------------------------
mkPrimOpIdUnique op = mkUnique '9' op
mkPreludeMiscIdUnique i = mkUnique '0' i
......
......@@ -126,12 +126,12 @@ mkCoreLets binds body = foldr mkCoreLet body binds
-- | Construct an expression which represents the application of one expression
-- to the other
mkCoreApp :: CoreExpr -> CoreExpr -> CoreExpr
mkCoreApp :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
-- Respects the let/app invariant by building a case expression where necessary
-- See CoreSyn Note [CoreSyn let/app invariant]
mkCoreApp fun (Type ty) = App fun (Type ty)
mkCoreApp fun (Coercion co) = App fun (Coercion co)
mkCoreApp fun arg = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg )
mkCoreApp _ fun (Type ty) = App fun (Type ty)
mkCoreApp _ fun (Coercion co) = App fun (Coercion co)
mkCoreApp d fun arg = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg $$ d )
mk_val_app fun arg arg_ty res_ty
where
fun_ty = exprType fun
......
......@@ -44,10 +44,11 @@ import TyCon
import TcEvidence
import TcType
import Type
import Kind (returnsConstraintKind)
import Kind( isKind )
import Coercion hiding (substCo)
import TysWiredIn ( eqBoxDataCon, coercibleDataCon, mkListTy
, mkBoxedTupleTy, charTy, typeNatKind, typeSymbolKind )
, mkBoxedTupleTy, charTy
, typeNatKind, typeSymbolKind )
import Id
import MkId(proxyHashId)
import Class
......@@ -70,15 +71,12 @@ import FastString
import Util
import MonadUtils
import Control.Monad(liftM,when)
import Fingerprint(Fingerprint(..), fingerprintString)
{-
************************************************************************
{-**********************************************************************
* *
\subsection[dsMonoBinds]{Desugaring a @MonoBinds@}
Desugaring a MonoBinds
* *
************************************************************************
-}
**********************************************************************-}
dsTopLHsBinds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
dsTopLHsBinds binds = ds_lhs_binds binds
......@@ -815,7 +813,7 @@ dsHsWrapper (WpCompose c1 c2) e = do { e1 <- dsHsWrapper c2 e
; dsHsWrapper c1 e1 }
dsHsWrapper (WpFun c1 c2 t1 _) e = do { x <- newSysLocalDs t1
; e1 <- dsHsWrapper c1 (Var x)
; e2 <- dsHsWrapper c2 (e `mkCoreAppDs` e1)
; e2 <- dsHsWrapper c2 (mkCoreAppDs (text "dsHsWrapper") e e1)
; return (Lam x e2) }
dsHsWrapper (WpCast co) e = ASSERT(tcCoercionRole co == Representational)
dsTcCoercion co (mkCastDs e)
......@@ -853,154 +851,145 @@ sccEvBinds bs = stronglyConnCompFromEdgedVertices edges
= (b, var, varSetElems (evVarsOfTerm term))
---------------------------------------
{-**********************************************************************
* *
Desugaring EvTerms
* *
**********************************************************************-}
dsEvTerm :: EvTerm -> DsM CoreExpr
dsEvTerm (EvId v) = return (Var v)
dsEvTerm (EvId v) = return (Var v)
dsEvTerm (EvCallStack cs) = dsEvCallStack cs
dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev
dsEvTerm (EvLit (EvNum n)) = mkIntegerExpr n
dsEvTerm (EvLit (EvStr s)) = mkStringExprFS s
dsEvTerm (EvCast tm co)
= do { tm' <- dsEvTerm tm
; dsTcCoercion co $ mkCastDs tm' }
-- 'v' is always a lifted evidence variable so it is
-- unnecessary to call varToCoreExpr v here.
-- 'v' is always a lifted evidence variable so it is
-- unnecessary to call varToCoreExpr v here.
dsEvTerm (EvDFunApp df tys tms)
= return (Var df `mkTyApps` tys `mkApps` (map Var tms))
dsEvTerm (EvDFunApp df tys tms) = return (Var df `mkTyApps` tys `mkApps` (map Var tms))
dsEvTerm (EvCoercion (TcCoVarCo v)) = return (Var v) -- See Note [Simple coercions]
dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox
dsEvTerm (EvSuperClass d n)
= do { d' <- dsEvTerm d
; let (cls, tys) = getClassPredTys (exprType d')
sc_sel_id = classSCSelId cls n -- Zero-indexed
; return $ Var sc_sel_id `mkTyApps` tys `App` d' }
dsEvTerm (EvDelayedError ty msg) = return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg]
dsEvTerm (EvDelayedError ty msg)
= return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg]
where
errorId = tYPE_ERROR_ID
litMsg = Lit (MachStr (fastStringToByteString msg))
dsEvTerm (EvLit l) =
case l of
EvNum n -> mkIntegerExpr n
EvStr s -> mkStringExprFS s
dsEvTerm (EvCallStack cs) = dsEvCallStack cs
dsEvTerm (EvTypeable ev) = dsEvTypeable ev
dsEvTypeable :: EvTypeable -> DsM CoreExpr
dsEvTypeable ev =
do tyCl <- dsLookupTyCon typeableClassName
typeRepTc <- dsLookupTyCon typeRepTyConName
let tyRepType = mkTyConApp typeRepTc []
(ty, rep) <-
case ev of
EvTypeableTyCon tc ks ->
do ctr <- dsLookupGlobalId mkPolyTyConAppName
mkTyCon <- dsLookupGlobalId mkTyConName
dflags <- getDynFlags