%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-\section[CoreUtils]{Utility functions on @Core@ syntax}
+
+Utility functions on @Core@ syntax
\begin{code}
module CoreUtils (
-- Equality
cheapEqExpr, tcEqExpr, tcEqExprX, applyTypeToArgs, applyTypeToArg,
- dataConInstPat, dataConOccInstPat
+ dataConOrigInstPat, dataConRepInstPat, dataConRepFSInstPat
) where
#include "HsVersions.h"
-
-import GLAEXTS -- For `xori`
-
import CoreSyn
-import CoreFVs ( exprFreeVars )
-import PprCore ( pprCoreExpr )
-import Var ( Var, TyVar, CoVar, isCoVar, tyVarKind, setVarUnique,
- mkCoVar, mkTyVar, mkCoVar )
-import OccName ( OccName, occNameFS, mkVarOcc )
-import VarSet ( unionVarSet )
+import CoreFVs
+import PprCore
+import Var
+import SrcLoc
+import VarSet
import VarEnv
-import Name ( hashName, mkSysTvName )
+import Name
#if mingw32_TARGET_OS
-import Packages ( isDllName )
+import Packages
#endif
-import Literal ( hashLiteral, literalType, litIsDupable,
- litIsTrivial, isZeroLit, Literal( MachLabel ) )
-import DataCon ( DataCon, dataConRepArity, eqSpecPreds,
- isVanillaDataCon, dataConTyCon, dataConRepArgTys,
- dataConUnivTyVars, dataConExTyVars, dataConEqSpec )
-import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
-import Id ( Id, idType, globalIdDetails, idNewStrictness,
- mkWildId, idArity, idName, idUnfolding, idInfo,
- isOneShotBndr, isStateHackType, isDataConWorkId_maybe, mkSysLocal,
- isDataConWorkId, isBottomingId, isDictId
- )
-import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo )
-import NewDemand ( appIsBottom )
-import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
- splitFunTy, tcEqTypeX,
- applyTys, isUnLiftedType, seqType, mkTyVarTy,
- splitForAllTy_maybe, isForAllTy, splitRecNewType_maybe,
- splitTyConApp_maybe, coreEqType, funResultTy, applyTy,
- substTyWith, mkPredTy
- )
-import Coercion ( Coercion, mkTransCoercion, coercionKind,
- splitNewTypeRepCo_maybe, mkSymCoercion, mkLeftCoercion,
- mkRightCoercion, decomposeCo, coercionKindPredTy,
- splitCoercionKind, mkEqPred )
-import TyCon ( tyConArity )
-import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
-import CostCentre ( CostCentre )
-import BasicTypes ( Arity )
-import PackageConfig ( PackageId )
-import Unique ( Unique )
+import Literal
+import DataCon
+import PrimOp
+import Id
+import IdInfo
+import NewDemand
+import Type
+import Coercion
+import TyCon
+import TysWiredIn
+import CostCentre
+import BasicTypes
+import PackageConfig
+import Unique
import Outputable
-import DynFlags ( DynFlags, DynFlag(Opt_DictsCheap), dopt )
-import TysPrim ( alphaTy ) -- Debugging only
-import Util ( equalLength, lengthAtLeast, foldl2 )
-import FastString ( mkFastString )
+import DynFlags
+import TysPrim
+import FastString
+import Maybes
+import Util
+
+import GHC.Exts -- For `xori`
\end{code}
\begin{code}
mkCoerce :: Coercion -> CoreExpr -> CoreExpr
mkCoerce co (Cast expr co2)
- = ASSERT(let { (from_ty, to_ty) = coercionKind co;
- (from_ty2, to_ty2) = coercionKind co2} in
+ = ASSERT(let { (from_ty, _to_ty) = coercionKind co;
+ (_from_ty2, to_ty2) = coercionKind co2} in
from_ty `coreEqType` to_ty2 )
mkCoerce (mkTransCoercion co2 co) expr
exprOkForSpeculation :: CoreExpr -> Bool
exprOkForSpeculation (Lit _) = True
exprOkForSpeculation (Type _) = True
+ -- Tick boxes are *not* suitable for speculation
exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
+ && not (isTickBoxOp v)
exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
exprOkForSpeculation (Cast e co) = exprOkForSpeculation e
exprOkForSpeculation other_expr
-- A worry: what if an Id's unfolding is just itself:
-- then we could get an infinite loop...
-exprIsHNF (Lit l) = True
-exprIsHNF (Type ty) = True -- Types are honorary Values;
- -- we don't mind copying them
-exprIsHNF (Lam b e) = isRuntimeVar b || exprIsHNF e
-exprIsHNF (Note _ e) = exprIsHNF e
-exprIsHNF (Cast e co) = exprIsHNF e
+exprIsHNF (Lit l) = True
+exprIsHNF (Type ty) = True -- Types are honorary Values;
+ -- we don't mind copying them
+exprIsHNF (Lam b e) = isRuntimeVar b || exprIsHNF e
+exprIsHNF (Note _ e) = exprIsHNF e
+exprIsHNF (Cast e co) = exprIsHNF e
exprIsHNF (App e (Type _)) = exprIsHNF e
exprIsHNF (App e a) = app_is_value e [a]
-exprIsHNF other = False
+exprIsHNF other = False
-- There is at least one value argument
app_is_value (Var fun) args
\end{code}
\begin{code}
--- deep applies a TyConApp coercion as a substitution to a reflexive coercion
--- deepCast t [a1,...,an] co corresponds to deep(t, [a1,...,an], co) from
--- FC paper
-deepCast :: Type -> [TyVar] -> Coercion -> Coercion
-deepCast ty tyVars co
- = ASSERT( let {(lty, rty) = coercionKind co;
- Just (tc1, lArgs) = splitTyConApp_maybe lty;
- Just (tc2, rArgs) = splitTyConApp_maybe rty}
- in
- tc1 == tc2 && length lArgs == length rArgs &&
- length lArgs == length tyVars )
- substTyWith tyVars coArgs ty
- where
- -- coArgs = [right (left (left co)), right (left co), right co]
- coArgs = decomposeCo (length tyVars) co
-
--- This goes here to avoid circularity between DataCon and Id
-dataConInstPat :: [Unique] -- A long enough list of uniques, at least one for each binder
- -> DataCon
- -> [Type] -- Types to instantiate the universally quantified tyvars
- -> ([TyVar], [CoVar], [Id]) -- Return instantiated variables
--- dataConInstPat us con inst_tys returns a triple (ex_tvs, co_tvs, arg_ids),
+-- These InstPat functions go here to avoid circularity between DataCon and Id
+dataConRepInstPat = dataConInstPat dataConRepArgTys (repeat (FSLIT("ipv")))
+dataConRepFSInstPat = dataConInstPat dataConRepArgTys
+dataConOrigInstPat = dataConInstPat dc_arg_tys (repeat (FSLIT("ipv")))
+ where
+ dc_arg_tys dc = map mkPredTy (dataConTheta dc) ++ dataConOrigArgTys dc
+ -- Remember to include the existential dictionaries
+
+dataConInstPat :: (DataCon -> [Type]) -- function used to find arg tys
+ -> [FastString] -- A long enough list of FSs to use for names
+ -> [Unique] -- An equally long list of uniques, at least one for each binder
+ -> DataCon
+ -> [Type] -- Types to instantiate the universally quantified tyvars
+ -> ([TyVar], [CoVar], [Id]) -- Return instantiated variables
+-- dataConInstPat arg_fun fss us con inst_tys returns a triple
+-- (ex_tvs, co_tvs, arg_ids),
--
-- ex_tvs are intended to be used as binders for existential type args
--
-- of these vars have been instantiated by the inst_tys and the ex_tys
--
-- arg_ids are indended to be used as binders for value arguments, including
--- dicts, and have their types instantiated with inst_tys and ex_tys
+-- dicts, and their types have been instantiated with inst_tys and ex_tys
--
-- Example.
-- The following constructor T1
-- ...
--
-- has representation type
--- forall a. forall a1. forall a2. forall b. (a :=: (a1,a2)) =>
+-- forall a. forall a1. forall b. (a :=: (a1,b)) =>
-- Int -> b -> T a
--
--- dataConInstPat us T1 (a1',a2') will return
+-- dataConInstPat fss us T1 (a1',b') will return
--
--- ([a1'', a2'', b''],[c :: (a1',a2'):=:(a1'',a2'')],[x :: Int,y :: b''])
+-- ([a1'', b''], [c :: (a1', b'):=:(a1'', b'')], [x :: Int, y :: b''])
--
--- where the double-primed variables are created from the unique list input
-dataConInstPat uniqs con inst_tys
- = dataConOccInstPat uniqs occs con inst_tys
- where
- -- dataConOccInstPat doesn't actually make use of the OccName directly for
- -- existential and coercion variable binders, so it is right to just
- -- use the VarName namespace for all of the OccNames
- occs = mk_occs 1
- mk_occs n = mkVarOcc ("ipv" ++ show n) : mk_occs (n+1)
-
-dataConOccInstPat :: [Unique] -- A long enough list of uniques, at least one for each binder
- -> [OccName] -- An equally long list of OccNames to use
- -> DataCon
- -> [Type] -- Types to instantiate the universally quantified tyvars
- -> ([TyVar], [CoVar], [Id]) -- Return instantiated variables
--- This function actually does the job specified in the comment for
--- dataConInstPat, but uses the specified list of OccNames. This is
--- is necessary for use in e.g. tcIfaceDataAlt
-dataConOccInstPat uniqs occs con inst_tys
+-- where the double-primed variables are created with the FastStrings and
+-- Uniques given as fss and us
+dataConInstPat arg_fun fss uniqs con inst_tys
= (ex_bndrs, co_bndrs, id_bndrs)
where
univ_tvs = dataConUnivTyVars con
ex_tvs = dataConExTyVars con
- arg_tys = dataConRepArgTys con
+ arg_tys = arg_fun con
eq_spec = dataConEqSpec con
eq_preds = eqSpecPreds eq_spec
n_ex = length ex_tvs
n_co = length eq_spec
- n_id = length arg_tys
- -- split the Uniques and OccNames
+ -- split the Uniques and FastStrings
(ex_uniqs, uniqs') = splitAt n_ex uniqs
(co_uniqs, id_uniqs) = splitAt n_co uniqs'
- (ex_occs, occs') = splitAt n_ex occs
- (co_occs, id_occs) = splitAt n_co occs'
+ (ex_fss, fss') = splitAt n_ex fss
+ (co_fss, id_fss) = splitAt n_co fss'
- -- make existential type variables
- mk_ex_var uniq occ var = mkTyVar new_name kind
+ -- Make existential type variables
+ ex_bndrs = zipWith3 mk_ex_var ex_uniqs ex_fss ex_tvs
+ mk_ex_var uniq fs var = mkTyVar new_name kind
where
- new_name = mkSysTvName uniq (occNameFS occ)
+ new_name = mkSysTvName uniq fs
kind = tyVarKind var
- ex_bndrs = zipWith3 mk_ex_var ex_uniqs ex_occs ex_tvs
-
- -- make the instantiation substitution
- inst_subst = substTyWith (univ_tvs ++ ex_tvs) (inst_tys ++ map mkTyVarTy ex_bndrs)
+ -- Make the instantiating substitution
+ subst = zipOpenTvSubst (univ_tvs ++ ex_tvs) (inst_tys ++ map mkTyVarTy ex_bndrs)
- -- make new coercion vars, instantiating kind
- mk_co_var uniq occ eq_pred = mkCoVar new_name (inst_subst (mkPredTy eq_pred))
+ -- Make new coercion vars, instantiating kind
+ co_bndrs = zipWith3 mk_co_var co_uniqs co_fss eq_preds
+ mk_co_var uniq fs eq_pred = mkCoVar new_name co_kind
where
- new_name = mkSysTvName uniq (occNameFS occ)
-
- co_bndrs = zipWith3 mk_co_var co_uniqs co_occs eq_preds
+ new_name = mkSysTvName uniq fs
+ co_kind = substTy subst (mkPredTy eq_pred)
-- make value vars, instantiating types
- mk_id_var uniq occ ty = mkUserLocal occ uniq (inst_subst ty) noSrcLoc
- id_bndrs = zipWith3 mk_id_var id_uniqs id_occs arg_tys
+ mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcLoc
+ id_bndrs = zipWith3 mk_id_var id_uniqs id_fss arg_tys
exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
-- Returns (Just (dc, [x1..xn])) if the argument expression is
-- a constructor application of the form (dc x1 .. xn)
-
exprIsConApp_maybe (Cast expr co)
- = -- Maybe this is over the top, but here we try to turn
- -- coerce (S,T) ( x, y )
- -- effectively into
- -- ( coerce S x, coerce T y )
- -- This happens in anger in PrelArrExts which has a coerce
- -- case coerce memcpy a b of
- -- (# r, s #) -> ...
- -- where the memcpy is in the IO monad, but the call is in
- -- the (ST s) monad
+ = -- Here we do the PushC reduction rule as described in the FC paper
case exprIsConApp_maybe expr of {
- Nothing -> Nothing ;
- Just (dc, args) ->
-
- let (from_ty, to_ty) = coercionKind co in
-
+ Nothing -> Nothing ;
+ Just (dc, dc_args) ->
+
+ -- The transformation applies iff we have
+ -- (C e1 ... en) `cast` co
+ -- where co :: (T t1 .. tn) :=: (T s1 ..sn)
+ -- That is, with a T at the top of both sides
+ -- The left-hand one must be a T, because exprIsConApp returned True
+ -- but the right-hand one might not be. (Though it usually will.)
+
+ let (from_ty, to_ty) = coercionKind co
+ (from_tc, from_tc_arg_tys) = splitTyConApp from_ty
+ -- The inner one must be a TyConApp
+ in
case splitTyConApp_maybe to_ty of {
Nothing -> Nothing ;
- Just (tc, tc_arg_tys) | tc /= dataConTyCon dc -> Nothing
- -- | not (isVanillaDataCon dc) -> Nothing
- | otherwise ->
- -- Type constructor must match datacon
-
- case splitTyConApp_maybe from_ty of {
- Nothing -> Nothing ;
- Just (tc', tc_arg_tys') | tc /= tc' -> Nothing
- -- Both sides of coercion must have the same type constructor
- | otherwise ->
-
+ Just (to_tc, to_tc_arg_tys)
+ | from_tc /= to_tc -> Nothing
+ -- These two Nothing cases are possible; we might see
+ -- (C x y) `cast` (g :: T a ~ S [a]),
+ -- where S is a type function. In fact, exprIsConApp
+ -- will probably not be called in such circumstances,
+ -- but there't nothing wrong with it
+
+ | otherwise ->
let
- -- here we do the PushC reduction rule as described in the FC paper
- arity = tyConArity tc
- n_ex_tvs = length dc_ex_tyvars
+ tc_arity = tyConArity from_tc
- (univ_args, rest) = splitAt arity args
- (ex_args, val_args) = splitAt n_ex_tvs rest
+ (univ_args, rest1) = splitAt tc_arity dc_args
+ (ex_args, rest2) = splitAt n_ex_tvs rest1
+ (co_args, val_args) = splitAt n_cos rest2
arg_tys = dataConRepArgTys dc
- dc_tyvars = dataConUnivTyVars dc
+ dc_univ_tyvars = dataConUnivTyVars dc
dc_ex_tyvars = dataConExTyVars dc
-
- deep arg_ty = deepCast arg_ty dc_tyvars co
-
- -- first we appropriately cast the value arguments
- arg_cos = map deep arg_tys
- new_val_args = zipWith mkCoerce (map deep arg_tys) val_args
-
- -- then we cast the existential coercion arguments
- orig_tvs = dc_tyvars ++ dc_ex_tyvars
- gammas = decomposeCo arity co
- new_tys = gammas ++ (map (\ (Type t) -> t) ex_args)
- theta = substTyWith orig_tvs new_tys
- cast_ty tv (Type ty)
- | isCoVar tv
- , (ty1, ty2) <- splitCoercionKind (tyVarKind tv)
- = Type $ mkTransCoercion (mkSymCoercion (theta ty1))
- (mkTransCoercion ty (theta ty2))
- | otherwise
- = Type ty
- new_ex_args = zipWith cast_ty dc_ex_tyvars ex_args
+ dc_eq_spec = dataConEqSpec dc
+ dc_tyvars = dc_univ_tyvars ++ dc_ex_tyvars
+ n_ex_tvs = length dc_ex_tyvars
+ n_cos = length dc_eq_spec
+
+ -- Make the "theta" from Fig 3 of the paper
+ gammas = decomposeCo tc_arity co
+ new_tys = gammas ++ map (\ (Type t) -> t) ex_args
+ theta = zipOpenTvSubst dc_tyvars new_tys
+
+ -- First we cast the existential coercion arguments
+ cast_co (tv,ty) (Type co) = Type $ mkSymCoercion (substTyVar theta tv)
+ `mkTransCoercion` co
+ `mkTransCoercion` (substTy theta ty)
+ new_co_args = zipWith cast_co dc_eq_spec co_args
+ -- ...and now value arguments
+ new_val_args = zipWith cast_arg arg_tys val_args
+ cast_arg arg_ty arg = mkCoerce (substTy theta arg_ty) arg
+
in
- ASSERT( all isTypeArg (take arity args) )
- ASSERT( equalLength val_args arg_tys )
- Just (dc, map Type tc_arg_tys ++ new_ex_args ++ new_val_args)
- }}}
+ ASSERT( length univ_args == tc_arity )
+ ASSERT( from_tc == dataConTyCon dc )
+ ASSERT( and (zipWith coreEqType [t | Type t <- univ_args] from_tc_arg_tys) )
+ ASSERT( all isTypeArg (univ_args ++ ex_args) )
+ ASSERT2( equalLength val_args arg_tys, ppr dc $$ ppr dc_tyvars $$ ppr dc_ex_tyvars $$ ppr arg_tys $$ ppr dc_args $$ ppr univ_args $$ ppr ex_args $$ ppr val_args $$ ppr arg_tys )
+
+ Just (dc, map Type to_tc_arg_tys ++ ex_args ++ new_co_args ++ new_val_args)
+ }}
+
+{-
+-- We do not want to tell the world that we have a
+-- Cons, to *stop* Case of Known Cons, which removes
+-- the TickBox.
+exprIsConApp_maybe (Note (TickBox {}) expr)
+ = Nothing
+exprIsConApp_maybe (Note (BinaryTickBox {}) expr)
+ = Nothing
+-}
exprIsConApp_maybe (Note _ expr)
= exprIsConApp_maybe expr
Lam lam_tv (eta_expand n us2 (App expr (Type (mkTyVarTy lam_tv))) (substTyWith [tv] [mkTyVarTy lam_tv] ty'))
where
- lam_tv = mkTyVar (mkSysTvName uniq FSLIT("etaT")) (tyVarKind tv)
- (uniq:us2) = us
-
+ lam_tv = setVarName tv (mkSysTvName uniq FSLIT("etaT"))
+ -- Using tv as a base retains its tyvar/covar-ness
+ (uniq:us2) = us
; Nothing ->
case splitFunTy_maybe ty of {
case splitNewTypeRepCo_maybe ty of {
Just(ty1,co) ->
- mkCoerce co (eta_expand n us (mkCoerce (mkSymCoercion co) expr) ty1) ;
+ mkCoerce (mkSymCoercion co) (eta_expand n us (mkCoerce co expr) ty1) ;
Nothing ->
-- We have an expression of arity > 0, but its type isn't a function
exprIsBig (Var v) = False
exprIsBig (Type t) = False
exprIsBig (App f a) = exprIsBig f || exprIsBig a
+exprIsBig (Cast e _) = exprIsBig e -- Hopefully coercions are not too big!
exprIsBig other = True
\end{code}
noteSize (SCC cc) = cc `seq` 1
noteSize InlineMe = 1
noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations
-
+
varSize :: Var -> Int
varSize b | isTyVar b = 1
| otherwise = seqType (idType b) `seq`
-- expressions may hash to the different Ints
--
-- The emphasis is on a crude, fast hash, rather than on high precision
+--
+-- We must be careful that \x.x and \y.y map to the same hash code,
+-- (at least if we want the above invariant to be true)
hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt
| otherwise = hash
where
- hash = abs (hash_expr e) -- Negative numbers kill UniqFM
-
-hash_expr (Note _ e) = hash_expr e
-hash_expr (Cast e co) = hash_expr e
-hash_expr (Let (NonRec b r) e) = hashId b
-hash_expr (Let (Rec ((b,r):_)) e) = hashId b
-hash_expr (Case _ b _ _) = hashId b
-hash_expr (App f e) = hash_expr f * fast_hash_expr e
-hash_expr (Var v) = hashId v
-hash_expr (Lit lit) = hashLiteral lit
-hash_expr (Lam b _) = hashId b
-hash_expr (Type t) = trace "hash_expr: type" 1 -- Shouldn't happen
-
-fast_hash_expr (Var v) = hashId v
-fast_hash_expr (Lit lit) = hashLiteral lit
-fast_hash_expr (App f (Type _)) = fast_hash_expr f
-fast_hash_expr (App f a) = fast_hash_expr a
-fast_hash_expr (Lam b _) = hashId b
-fast_hash_expr other = 1
-
-hashId :: Id -> Int
-hashId id = hashName (idName id)
+ hash = abs (hash_expr (1,emptyVarEnv) e) -- Negative numbers kill UniqFM
+
+type HashEnv = (Int, VarEnv Int) -- Hash code for bound variables
+
+hash_expr :: HashEnv -> CoreExpr -> Int
+hash_expr env (Note _ e) = hash_expr env e
+hash_expr env (Cast e co) = hash_expr env e
+hash_expr env (Var v) = hashVar env v
+hash_expr env (Lit lit) = hashLiteral lit
+hash_expr env (App f e) = hash_expr env f * fast_hash_expr env e
+hash_expr env (Let (NonRec b r) e) = hash_expr (extend_env env b) e * fast_hash_expr env r
+hash_expr env (Let (Rec ((b,r):_)) e) = hash_expr (extend_env env b) e
+hash_expr env (Case e _ _ _) = hash_expr env e
+hash_expr env (Lam b e) = hash_expr (extend_env env b) e
+hash_expr env (Type t) = fast_hash_type env t
+
+fast_hash_expr env (Var v) = hashVar env v
+fast_hash_expr env (Type t) = fast_hash_type env t
+fast_hash_expr env (Lit lit) = hashLiteral lit
+fast_hash_expr env (Cast e co) = fast_hash_expr env e
+fast_hash_expr env (Note n e) = fast_hash_expr env e
+fast_hash_expr env (App f a) = fast_hash_expr env a -- A bit idiosyncratic ('a' not 'f')!
+fast_hash_expr env other = 1
+
+fast_hash_type :: HashEnv -> Type -> Int
+fast_hash_type env ty
+ | Just tv <- getTyVar_maybe ty = hashVar env tv
+ | Just (tc,_) <- splitTyConApp_maybe ty = hashName (tyConName tc)
+ | otherwise = 1
+
+extend_env :: HashEnv -> Var -> (Int, VarEnv Int)
+extend_env (n,env) b = (n+1, extendVarEnv env b n)
+
+hashVar :: HashEnv -> Var -> Int
+hashVar (_,env) v = lookupVarEnv env v `orElse` hashName (idName v)
\end{code}
%************************************************************************
projects / ghc-hetmet.git / blobdiff