Commit fdf86568 authored by Simon Peyton Jones's avatar Simon Peyton Jones

This BIG PATCH contains most of the work for the New Coercion Representation

See the paper "Practical aspects of evidence based compilation in System FC"

* Coercion becomes a data type, distinct from Type

* Coercions become value-level things, rather than type-level things,
  (although the value is zero bits wide, like the State token)
  A consequence is that a coerion abstraction increases the arity by 1
  (just like a dictionary abstraction)

* There is a new constructor in CoreExpr, namely Coercion, to inject
  coercions into terms
parent a52ff761
......@@ -18,7 +18,7 @@ module DataCon (
dataConName, dataConIdentity, dataConTag, dataConTyCon,
dataConOrigTyCon, dataConUserType,
dataConUnivTyVars, dataConExTyVars, dataConAllTyVars,
dataConEqSpec, eqSpecPreds, dataConEqTheta, dataConDictTheta,
dataConEqSpec, eqSpecPreds, dataConTheta,
dataConStupidTheta,
dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,
dataConInstOrigArgTys, dataConRepArgTys,
......@@ -31,7 +31,7 @@ module DataCon (
-- ** Predicates on DataCons
isNullarySrcDataCon, isNullaryRepDataCon, isTupleCon, isUnboxedTupleCon,
isVanillaDataCon, classDataCon,
isVanillaDataCon, classDataCon, dataConCannotMatch,
-- * Splitting product types
splitProductType_maybe, splitProductType, deepSplitProductType,
......@@ -41,6 +41,7 @@ module DataCon (
#include "HsVersions.h"
import Type
import Unify
import Coercion
import TyCon
import Class
......@@ -57,7 +58,6 @@ import Module
import qualified Data.Data as Data
import Data.Char
import Data.Word
import Data.List ( partition )
\end{code}
......@@ -256,8 +256,7 @@ data DataCon
-- dcUnivTyVars = [a]
-- dcExTyVars = [x,y]
-- dcEqSpec = [a~(x,y)]
-- dcEqTheta = [x~y]
-- dcDictTheta = [Ord x]
-- dcOtherTheta = [x~y, Ord x]
-- dcOrigArgTys = [a,List b]
-- dcRepTyCon = T
......@@ -265,7 +264,7 @@ data DataCon
-- Its type is of form
-- forall a1..an . t1 -> ... tm -> T a1..an
-- No existentials, no coercions, nothing.
-- That is: dcExTyVars = dcEqSpec = dcEqTheta = dcDictTheta = []
-- That is: dcExTyVars = dcEqSpec = dcOtherTheta = []
-- NB 1: newtypes always have a vanilla data con
-- NB 2: a vanilla constructor can still be declared in GADT-style
-- syntax, provided its type looks like the above.
......@@ -300,8 +299,8 @@ data DataCon
-- In GADT form, this is *exactly* what the programmer writes, even if
-- the context constrains only universally quantified variables
-- MkT :: forall a b. (a ~ b, Ord b) => a -> T a b
dcEqTheta :: ThetaType, -- The *equational* constraints
dcDictTheta :: ThetaType, -- The *type-class and implicit-param* constraints
dcOtherTheta :: ThetaType, -- The other constraints in the data con's type
-- *other than* those in the dcEqSpec
dcStupidTheta :: ThetaType, -- The context of the data type declaration
-- data Eq a => T a = ...
......@@ -338,9 +337,9 @@ data DataCon
-- length = 0 (if not a record) or dataConSourceArity.
-- Constructor representation
dcRepArgTys :: [Type], -- Final, representation argument types,
-- after unboxing and flattening,
-- and *including* existential dictionaries
dcRepArgTys :: [Type], -- Final, representation argument types,
-- after unboxing and flattening,
-- and *including* all existential evidence args
dcRepStrictness :: [StrictnessMark],
-- One for each *representation* *value* argument
......@@ -519,8 +518,8 @@ mkDataCon name declared_infix
dcVanilla = is_vanilla, dcInfix = declared_infix,
dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs,
dcEqSpec = eq_spec,
dcOtherTheta = theta,
dcStupidTheta = stupid_theta,
dcEqTheta = eq_theta, dcDictTheta = dict_theta,
dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty,
dcRepTyCon = rep_tycon,
dcRepArgTys = rep_arg_tys,
......@@ -536,10 +535,9 @@ mkDataCon name declared_infix
-- The 'arg_stricts' passed to mkDataCon are simply those for the
-- source-language arguments. We add extra ones for the
-- dictionary arguments right here.
(eq_theta,dict_theta) = partition isEqPred theta
dict_tys = mkPredTys dict_theta
real_arg_tys = dict_tys ++ orig_arg_tys
real_stricts = map mk_dict_strict_mark dict_theta ++ arg_stricts
full_theta = eqSpecPreds eq_spec ++ theta
real_arg_tys = mkPredTys full_theta ++ orig_arg_tys
real_stricts = map mk_dict_strict_mark full_theta ++ arg_stricts
-- Representation arguments and demands
-- To do: eliminate duplication with MkId
......@@ -547,11 +545,6 @@ mkDataCon name declared_infix
tag = assoc "mkDataCon" (tyConDataCons rep_tycon `zip` [fIRST_TAG..]) con
ty = mkForAllTys univ_tvs $ mkForAllTys ex_tvs $
mkFunTys (mkPredTys (eqSpecPreds eq_spec)) $
mkFunTys (mkPredTys eq_theta) $
-- NB: the dict args are already in rep_arg_tys
-- because they might be flattened..
-- but the equality predicates are not
mkFunTys rep_arg_tys $
mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
......@@ -611,13 +604,10 @@ dataConAllTyVars (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs })
dataConEqSpec :: DataCon -> [(TyVar,Type)]
dataConEqSpec = dcEqSpec
-- | The equational constraints on the data constructor type
dataConEqTheta :: DataCon -> ThetaType
dataConEqTheta = dcEqTheta
-- | The type class and implicit parameter contsraints on the data constructor type
dataConDictTheta :: DataCon -> ThetaType
dataConDictTheta = dcDictTheta
-- | The *full* constraints on the constructor type
dataConTheta :: DataCon -> ThetaType
dataConTheta (MkData { dcEqSpec = eq_spec, dcOtherTheta = theta })
= eqSpecPreds eq_spec ++ theta
-- | Get the Id of the 'DataCon' worker: a function that is the "actual"
-- constructor and has no top level binding in the program. The type may
......@@ -666,10 +656,10 @@ dataConFieldType con label
dataConStrictMarks :: DataCon -> [HsBang]
dataConStrictMarks = dcStrictMarks
-- | Strictness of /existential/ arguments only
-- | Strictness of evidence arguments to the wrapper function
dataConExStricts :: DataCon -> [HsBang]
-- Usually empty, so we don't bother to cache this
dataConExStricts dc = map mk_dict_strict_mark $ dcDictTheta dc
dataConExStricts dc = map mk_dict_strict_mark $ (dcOtherTheta dc)
-- | Source-level arity of the data constructor
dataConSourceArity :: DataCon -> Arity
......@@ -705,10 +695,10 @@ dataConRepStrictness dc = dcRepStrictness dc
--
-- 4) The /original/ result type of the 'DataCon'
dataConSig :: DataCon -> ([TyVar], ThetaType, [Type], Type)
dataConSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec,
dcEqTheta = eq_theta, dcDictTheta = dict_theta,
dataConSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs,
dcEqSpec = eq_spec, dcOtherTheta = theta,
dcOrigArgTys = arg_tys, dcOrigResTy = res_ty})
= (univ_tvs ++ ex_tvs, eqSpecPreds eq_spec ++ eq_theta ++ dict_theta, arg_tys, res_ty)
= (univ_tvs ++ ex_tvs, eqSpecPreds eq_spec ++ theta, arg_tys, res_ty)
-- | The \"full signature\" of the 'DataCon' returns, in order:
--
......@@ -725,11 +715,11 @@ dataConSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_
--
-- 6) The original result type of the 'DataCon'
dataConFullSig :: DataCon
-> ([TyVar], [TyVar], [(TyVar,Type)], ThetaType, ThetaType, [Type], Type)
dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec,
dcEqTheta = eq_theta, dcDictTheta = dict_theta,
-> ([TyVar], [TyVar], [(TyVar,Type)], ThetaType, [Type], Type)
dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs,
dcEqSpec = eq_spec, dcOtherTheta = theta,
dcOrigArgTys = arg_tys, dcOrigResTy = res_ty})
= (univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, res_ty)
= (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty)
dataConOrigResTy :: DataCon -> Type
dataConOrigResTy dc = dcOrigResTy dc
......@@ -754,11 +744,10 @@ dataConUserType :: DataCon -> Type
-- mentions the family tycon, not the internal one.
dataConUserType (MkData { dcUnivTyVars = univ_tvs,
dcExTyVars = ex_tvs, dcEqSpec = eq_spec,
dcEqTheta = eq_theta, dcDictTheta = dict_theta, dcOrigArgTys = arg_tys,
dcOtherTheta = theta, dcOrigArgTys = arg_tys,
dcOrigResTy = res_ty })
= mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $
mkFunTys (mkPredTys eq_theta) $
mkFunTys (mkPredTys dict_theta) $
mkFunTys (mkPredTys theta) $
mkFunTys arg_tys $
res_ty
......@@ -841,6 +830,24 @@ classDataCon clas = case tyConDataCons (classTyCon clas) of
[] -> panic "classDataCon"
\end{code}
\begin{code}
dataConCannotMatch :: [Type] -> DataCon -> Bool
-- Returns True iff the data con *definitely cannot* match a
-- scrutinee of type (T tys)
-- where T is the type constructor for the data con
--
dataConCannotMatch tys con
| null eq_spec = False -- Common
| all isTyVarTy tys = False -- Also common
| otherwise
= typesCantMatch (map (substTyVar subst . fst) eq_spec)
(map snd eq_spec)
where
dc_tvs = dataConUnivTyVars con
eq_spec = dataConEqSpec con
subst = zipTopTvSubst dc_tvs tys
\end{code}
%************************************************************************
%* *
\subsection{Splitting products}
......
......@@ -23,7 +23,7 @@
-- * 'Var.Var': see "Var#name_types"
module Id (
-- * The main types
Id, DictId,
Var, Id, isId,
-- ** Simple construction
mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo,
......@@ -34,8 +34,7 @@ module Id (
-- ** Taking an Id apart
idName, idType, idUnique, idInfo, idDetails,
isId, idPrimRep,
recordSelectorFieldLabel,
idPrimRep, recordSelectorFieldLabel,
-- ** Modifying an Id
setIdName, setIdUnique, Id.setIdType,
......@@ -46,7 +45,8 @@ module Id (
-- ** Predicates on Ids
isImplicitId, isDeadBinder, isDictId, isStrictId,
isImplicitId, isDeadBinder,
isStrictId,
isExportedId, isLocalId, isGlobalId,
isRecordSelector, isNaughtyRecordSelector,
isClassOpId_maybe, isDFunId, dfunNSilent,
......@@ -57,6 +57,9 @@ module Id (
isTickBoxOp, isTickBoxOp_maybe,
hasNoBinding,
-- ** Evidence variables
DictId, isDictId, isEvVar, evVarPred,
-- ** Inline pragma stuff
idInlinePragma, setInlinePragma, modifyInlinePragma,
idInlineActivation, setInlineActivation, idRuleMatchInfo,
......@@ -95,8 +98,8 @@ import IdInfo
import BasicTypes
-- Imported and re-exported
import Var( Var, Id, DictId,
idInfo, idDetails, globaliseId,
import Var( Var, Id, DictId, EvVar,
idInfo, idDetails, globaliseId, varType,
isId, isLocalId, isGlobalId, isExportedId )
import qualified Var
......@@ -372,10 +375,6 @@ idDataCon :: Id -> DataCon
-- INVARIANT: @idDataCon (dataConWrapId d) = d@: remember, 'dataConWrapId' can return either the wrapper or the worker
idDataCon id = isDataConId_maybe id `orElse` pprPanic "idDataCon" (ppr id)
isDictId :: Id -> Bool
isDictId id = isDictTy (idType id)
hasNoBinding :: Id -> Bool
-- ^ Returns @True@ of an 'Id' which may not have a
-- binding, even though it is defined in this module.
......@@ -446,6 +445,26 @@ isTickBoxOp_maybe id =
_ -> Nothing
\end{code}
%************************************************************************
%* *
Evidence variables
%* *
%************************************************************************
\begin{code}
isEvVar :: Var -> Bool
isEvVar var = isPredTy (varType var)
isDictId :: Id -> Bool
isDictId id = isDictTy (idType id)
evVarPred :: EvVar -> PredType
evVarPred var
= case splitPredTy_maybe (varType var) of
Just pred -> pred
Nothing -> pprPanic "evVarPred" (ppr var <+> ppr (varType var))
\end{code}
%************************************************************************
%* *
\subsection{IdInfo stuff}
......
......@@ -10,7 +10,7 @@ Haskell. [WDP 94/11])
\begin{code}
module IdInfo (
-- * The IdDetails type
IdDetails(..), pprIdDetails,
IdDetails(..), pprIdDetails, coVarDetails,
-- * The IdInfo type
IdInfo, -- Abstract
......@@ -141,6 +141,9 @@ data IdDetails
-- implemented with a newtype, so it might be bad
-- to be strict on this dictionary
coVarDetails :: IdDetails
coVarDetails = VanillaId
instance Outputable IdDetails where
ppr = pprIdDetails
......
......@@ -4,5 +4,7 @@ import Outputable
data IdInfo
data IdDetails
vanillaIdInfo :: IdInfo
coVarDetails :: IdDetails
pprIdDetails :: IdDetails -> SDoc
\end{code}
\ No newline at end of file
This diff is collapsed.
......@@ -32,7 +32,7 @@
module Var (
-- * The main data type and synonyms
Var, TyVar, CoVar, Id, DictId, DFunId, EvVar, EvId, IpId,
Var, TyVar, CoVar, TyCoVar, Id, DictId, DFunId, EvVar, EvId, IpId,
-- ** Taking 'Var's apart
varName, varUnique, varType,
......@@ -41,34 +41,25 @@ module Var (
setVarName, setVarUnique, setVarType,
-- ** Constructing, taking apart, modifying 'Id's
mkGlobalVar, mkLocalVar, mkExportedLocalVar,
mkGlobalVar, mkLocalVar, mkExportedLocalVar, mkCoVar,
idInfo, idDetails,
lazySetIdInfo, setIdDetails, globaliseId,
setIdExported, setIdNotExported,
-- ** Predicates
isCoVar, isId, isTyCoVar, isTyVar, isTcTyVar,
isId, isTyVar, isTcTyVar,
isLocalVar, isLocalId,
isGlobalId, isExportedId,
mustHaveLocalBinding,
-- ** Constructing 'TyVar's
mkTyVar, mkTcTyVar, mkWildCoVar,
mkTyVar, mkTcTyVar,
-- ** Taking 'TyVar's apart
tyVarName, tyVarKind, tcTyVarDetails, setTcTyVarDetails,
-- ** Modifying 'TyVar's
setTyVarName, setTyVarUnique, setTyVarKind,
-- ** Constructing 'CoVar's
mkCoVar,
-- ** Taking 'CoVar's apart
coVarName,
-- ** Modifying 'CoVar's
setCoVarUnique, setCoVarName
setTyVarName, setTyVarUnique, setTyVarKind
) where
......@@ -77,8 +68,7 @@ module Var (
import {-# SOURCE #-} TypeRep( Type, Kind )
import {-# SOURCE #-} TcType( TcTyVarDetails, pprTcTyVarDetails )
import {-# SOURCE #-} IdInfo( IdDetails, IdInfo, pprIdDetails )
import {-# SOURCE #-} TypeRep( isCoercionKind )
import {-# SOURCE #-} IdInfo( IdDetails, IdInfo, coVarDetails, vanillaIdInfo, pprIdDetails )
import Name hiding (varName)
import Unique
......@@ -100,7 +90,7 @@ import Data.Data
-- large number of SOURCE imports of Id.hs :-(
\begin{code}
type EvVar = Var -- An evidence variable: dictionary or equality constraint
type EvVar = Var -- An evidence variable: dictionary or equality constraint
-- Could be an DictId or a CoVar
type Id = Var -- A term-level identifier
......@@ -110,9 +100,10 @@ type DictId = EvId -- A dictionary variable
type IpId = EvId -- A term-level implicit parameter
type TyVar = Var
type CoVar = TyVar -- A coercion variable is simply a type
type CoVar = Id -- A coercion variable is simply an Id
-- variable of kind @ty1 ~ ty2@. Hence its
-- 'varType' is always @PredTy (EqPred t1 t2)@
type TyCoVar = TyVar -- Something that is a type OR coercion variable.
\end{code}
%************************************************************************
......@@ -136,8 +127,7 @@ data Var
realUnique :: FastInt, -- Key for fast comparison
-- Identical to the Unique in the name,
-- cached here for speed
varType :: Kind, -- ^ The type or kind of the 'Var' in question
isCoercionVar :: Bool
varType :: Kind -- ^ The type or kind of the 'Var' in question
}
| TcTyVar { -- Used only during type inference
......@@ -187,9 +177,8 @@ instance Outputable Var where
ppr var = ppr (varName var) <+> ifPprDebug (brackets (ppr_debug var))
ppr_debug :: Var -> SDoc
ppr_debug (TyVar { isCoercionVar = False }) = ptext (sLit "tv")
ppr_debug (TyVar { isCoercionVar = True }) = ptext (sLit "co")
ppr_debug (TcTyVar {tc_tv_details = d}) = pprTcTyVarDetails d
ppr_debug (TyVar {}) = ptext (sLit "tv")
ppr_debug (TcTyVar {tc_tv_details = d}) = pprTcTyVarDetails d
ppr_debug (Id { idScope = s, id_details = d }) = ppr_id_scope s <> pprIdDetails d
ppr_id_scope :: IdScope -> SDoc
......@@ -270,11 +259,9 @@ setTyVarKind tv k = tv {varType = k}
\begin{code}
mkTyVar :: Name -> Kind -> TyVar
mkTyVar name kind = ASSERT( not (isCoercionKind kind ) )
TyVar { varName = name
mkTyVar name kind = TyVar { varName = name
, realUnique = getKeyFastInt (nameUnique name)
, varType = kind
, isCoercionVar = False
}
mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar
......@@ -294,36 +281,6 @@ setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar
setTcTyVarDetails tv details = tv { tc_tv_details = details }
\end{code}
%************************************************************************
%* *
\subsection{Coercion variables}
%* *
%************************************************************************
\begin{code}
coVarName :: CoVar -> Name
coVarName = varName
setCoVarUnique :: CoVar -> Unique -> CoVar
setCoVarUnique = setVarUnique
setCoVarName :: CoVar -> Name -> CoVar
setCoVarName = setVarName
mkCoVar :: Name -> Kind -> CoVar
mkCoVar name kind = ASSERT( isCoercionKind kind )
TyVar { varName = name
, realUnique = getKeyFastInt (nameUnique name)
, varType = kind
, isCoercionVar = True
}
mkWildCoVar :: Kind -> TyVar
-- ^ Create a type variable that is never referred to, so its unique doesn't
-- matter
mkWildCoVar = mkCoVar (mkSysTvName (mkBuiltinUnique 1) (fsLit "co_wild"))
\end{code}
%************************************************************************
%* *
\subsection{Ids}
......@@ -349,6 +306,10 @@ mkLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id
mkLocalVar details name ty info
= mk_id name ty (LocalId NotExported) details info
mkCoVar :: Name -> Type -> CoVar
-- Coercion variables have no IdInfo
mkCoVar name ty = mk_id name ty (LocalId NotExported) coVarDetails vanillaIdInfo
-- | Exported 'Var's will not be removed as dead code
mkExportedLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id
mkExportedLocalVar details name ty info
......@@ -394,20 +355,11 @@ setIdNotExported id = ASSERT( isLocalId id )
%************************************************************************
\begin{code}
isTyCoVar :: Var -> Bool -- True of both type and coercion variables
isTyCoVar (TyVar {}) = True
isTyCoVar (TcTyVar {}) = True
isTyCoVar _ = False
isTyVar :: Var -> Bool -- True of both type variables only
isTyVar v@(TyVar {}) = not (isCoercionVar v)
isTyVar :: Var -> Bool -- True of both type variables only
isTyVar (TyVar {}) = True
isTyVar (TcTyVar {}) = True
isTyVar _ = False
isCoVar :: Var -> Bool -- Only works after type checking (sigh)
isCoVar v@(TyVar {}) = isCoercionVar v
isCoVar _ = False
isTcTyVar :: Var -> Bool
isTcTyVar (TcTyVar {}) = True
isTcTyVar _ = False
......
......@@ -6,7 +6,7 @@
\begin{code}
module VarEnv (
-- * Var, Id and TyVar environments (maps)
VarEnv, IdEnv, TyVarEnv,
VarEnv, IdEnv, TyVarEnv, CoVarEnv,
-- ** Manipulating these environments
emptyVarEnv, unitVarEnv, mkVarEnv,
......@@ -29,7 +29,7 @@ module VarEnv (
emptyInScopeSet, mkInScopeSet, delInScopeSet,
extendInScopeSet, extendInScopeSetList, extendInScopeSetSet,
getInScopeVars, lookupInScope, lookupInScope_Directly,
unionInScope, elemInScopeSet, uniqAway,
unionInScope, elemInScopeSet, uniqAway,
-- * The RnEnv2 type
RnEnv2,
......@@ -343,6 +343,7 @@ emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv)
type VarEnv elt = UniqFM elt
type IdEnv elt = VarEnv elt
type TyVarEnv elt = VarEnv elt
type CoVarEnv elt = VarEnv elt
emptyVarEnv :: VarEnv a
mkVarEnv :: [(Var, a)] -> VarEnv a
......
......@@ -6,7 +6,7 @@
\begin{code}
module VarSet (
-- * Var, Id and TyVar set types
VarSet, IdSet, TyVarSet,
VarSet, IdSet, TyVarSet, TyCoVarSet, CoVarSet,
-- ** Manipulating these sets
emptyVarSet, unitVarSet, mkVarSet,
......@@ -22,7 +22,7 @@ module VarSet (
#include "HsVersions.h"
import Var ( Var, TyVar, Id )
import Var ( Var, TyVar, CoVar, TyCoVar, Id )
import Unique
import UniqSet
\end{code}
......@@ -37,6 +37,8 @@ import UniqSet
type VarSet = UniqSet Var
type IdSet = UniqSet Id
type TyVarSet = UniqSet TyVar
type TyCoVarSet = UniqSet TyCoVar
type CoVarSet = UniqSet CoVar
emptyVarSet :: VarSet
intersectVarSet :: VarSet -> VarSet -> VarSet
......
{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
-- Norman likes local bindings
-- If this module lives on I'd like to get rid of this flag in due course
module CmmCPS (
-- | Converts C-- with full proceedures and parameters
-- to a CPS transformed C-- with the stack made manifest.
......
......@@ -29,6 +29,7 @@ import BasicTypes
import Unique
import Outputable
import FastString
import Pair
\end{code}
%************************************************************************
......@@ -79,11 +80,13 @@ exprArity e = go e
go (Lam x e) | isId x = go e + 1
| otherwise = go e
go (Note n e) | notSccNote n = go e
go (Cast e co) = go e `min` length (typeArity (snd (coercionKind co)))
-- Note [exprArity invariant]
go (Cast e co) = go e `min` length (typeArity (pSnd (coercionKind co)))
-- Note [exprArity invariant]
go (App e (Type _)) = go e
go (App f a) | exprIsTrivial a = (go f - 1) `max` 0
-- See Note [exprArity for applications]
-- NB: coercions count as a value argument
go _ = 0
......@@ -549,7 +552,7 @@ arityType cheap_fn (Lam x e)
| isId x = arityLam x (arityType cheap_fn e)
| otherwise = arityType cheap_fn e
-- Applications; decrease arity
-- Applications; decrease arity, except for types
arityType cheap_fn (App fun (Type _))
= arityType cheap_fn fun
arityType cheap_fn (App fun arg )
......@@ -663,14 +666,14 @@ etaExpand n orig_expr
-- Strip off existing lambdas and casts
-- Note [Eta expansion and SCCs]
go 0 expr = expr
go n (Lam v body) | isTyCoVar v = Lam v (go n body)
| otherwise = Lam v (go (n-1) body)
go n (Lam v body) | isTyVar v = Lam v (go n body)
| otherwise = Lam v (go (n-1) body)
go n (Cast expr co) = Cast (go n expr) co
go n expr = -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, ppr etas]) $
etaInfoAbs etas (etaInfoApp subst' expr etas)
where
in_scope = mkInScopeSet (exprFreeVars expr)
(in_scope', etas) = mkEtaWW n in_scope (exprType expr)
(in_scope', etas) = mkEtaWW n orig_expr in_scope (exprType expr)
subst' = mkEmptySubst in_scope'
-- Wrapper Unwrapper
......@@ -685,10 +688,10 @@ instance Outputable EtaInfo where
pushCoercion :: Coercion -> [EtaInfo] -> [EtaInfo]
pushCoercion co1 (EtaCo co2 : eis)
| isIdentityCoercion co = eis
| otherwise = EtaCo co : eis
| isReflCo co = eis
| otherwise = EtaCo co : eis
where
co = co1 `mkTransCoercion` co2
co = co1 `mkTransCo` co2
pushCoercion co eis = EtaCo co : eis
......@@ -696,7 +699,7 @@ pushCoercion co eis = EtaCo co : eis
etaInfoAbs :: [EtaInfo] -> CoreExpr -> CoreExpr
etaInfoAbs [] expr = expr
etaInfoAbs (EtaVar v : eis) expr = Lam v (etaInfoAbs eis expr)
etaInfoAbs (EtaCo co : eis) expr = Cast (etaInfoAbs eis expr) (mkSymCoercion co)
etaInfoAbs (EtaCo co : eis) expr = Cast (etaInfoAbs eis expr) (mkSymCo co)
--------------
etaInfoApp :: Subst -> CoreExpr -> [EtaInfo] -> CoreExpr
......@@ -704,15 +707,12 @@ etaInfoApp :: Subst -> CoreExpr -> [EtaInfo] -> CoreExpr
-- ((substExpr s e) `appliedto` eis)
etaInfoApp subst (Lam v1 e) (EtaVar v2 : eis)
= etaInfoApp subst' e eis
where
subst' | isTyCoVar v1 = CoreSubst.extendTvSubst subst v1 (mkTyVarTy v2)
| otherwise = CoreSubst.extendIdSubst subst v1 (Var v2)
= etaInfoApp (CoreSubst.extendSubstWithVar subst v1 v2) e eis
etaInfoApp subst (Cast e co1) eis
= etaInfoApp subst e (pushCoercion co' eis)
where
co' = CoreSubst.substTy subst co1
co' = CoreSubst.substCo subst co1
etaInfoApp subst (Case e b _ alts) eis
= Case (subst_expr subst e) b1 (coreAltsType alts') alts'
......@@ -739,24 +739,24 @@ etaInfoApp subst e eis
go e (EtaCo co : eis) = go (Cast e co) eis
--------------
mkEtaWW :: Arity -> InScopeSet -> Type
mkEtaWW :: Arity -> CoreExpr -> InScopeSet -> Type
-> (InScopeSet, [EtaInfo])
-- EtaInfo contains fresh variables,
-- not free in the incoming CoreExpr
-- Outgoing InScopeSet includes the EtaInfo vars
-- and the original free vars
mkEtaWW orig_n in_scope orig_ty
mkEtaWW orig_n orig_expr in_scope orig_ty
= go orig_n empty_subst orig_ty []
where
empty_subst = mkTvSubst in_scope emptyTvSubstEnv
empty_subst = TvSubst in_scope emptyTvSubstEnv
go n subst ty eis -- See Note [exprArity invariant]
| n == 0
= (getTvInScope subst, reverse eis)
| Just (tv,ty') <- splitForAllTy_maybe ty
, let (subst', tv') = substTyVarBndr subst tv
, let (subst', tv') = Type.substTyVarBndr subst tv
-- Avoid free vars of the original expression
= go n subst' ty' (EtaVar tv' : eis)
......@@ -772,11 +772,11 @@ mkEtaWW orig_n in_scope orig_ty
-- eta_expand 1 e T
-- We want to get
-- coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
go n subst ty' (EtaCo (Type.substTy subst co) : eis)
go n subst ty' (EtaCo co : eis)
| otherwise -- We have an expression of arity > 0,
-- but its type isn't a function.
= WARN( True, ppr orig_n <+> ppr orig_ty )
= WARN( True, (ppr orig_n <+> ppr orig_ty) $$ ppr orig_expr )
(getTvInScope subst, reverse eis)
-- This *can* legitmately happen:
-- e.g. coerce Int (\x. x) Essentially the programmer is
......
......@@ -49,6 +49,7 @@ import Name
import VarSet
import Var
import TcType
import Coercion
import Util
import BasicTypes( Activation )
import Outputable
......@@ -179,12 +180,13 @@ addBndrs bndrs fv = foldr addBndr fv bndrs
expr_fvs :: CoreExpr -> FV
expr_fvs (Type ty) = someVars (tyVarsOfType ty)
expr_fvs (Coercion co) = someVars (tyCoVarsOfCo co)
expr_fvs (Var var) = oneVar var
expr_fvs (Lit _) = noVars
expr_fvs (Note _ expr) = expr_fvs expr
expr_fvs (App fun arg) = expr_fvs fun `union` expr_fvs arg
expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body)