%
+% (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 (
#include "HsVersions.h"
-
-import GLAEXTS -- For `xori`
-
import CoreSyn
-import CoreFVs ( exprFreeVars )
-import PprCore ( pprCoreExpr )
-import Var ( Var, TyVar, CoVar, tyVarKind, mkCoVar, mkTyVar )
-import OccName ( mkVarOccFS )
-import SrcLoc ( noSrcLoc )
-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,
- dataConTyCon, dataConRepArgTys,
- dataConUnivTyVars, dataConExTyVars, dataConEqSpec,
- dataConOrigArgTys, dataConTheta )
-import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
-import Id ( Id, idType, globalIdDetails, idNewStrictness,
- mkWildId, idArity, idName, idUnfolding, idInfo,
- isOneShotBndr, isStateHackType,
- isDataConWorkId_maybe, mkSysLocal, mkUserLocal,
- 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,
- splitTyConApp_maybe, splitTyConApp, coreEqType, funResultTy, applyTy,
- substTyWith, mkPredTy, zipOpenTvSubst, substTy, substTyVar
- )
-import Coercion ( Coercion, mkTransCoercion, coercionKind,
- splitNewTypeRepCo_maybe, mkSymCoercion,
- decomposeCo, coercionKindPredTy )
-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 ( FastString )
+import DynFlags
+import TysPrim
+import FastString
+import Util
+
+import GHC.Exts -- For `xori`
\end{code}
-- 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
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
-- We ignore InlineMe notes in case we have
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)
+ lam_tv = setVarName tv (mkSysTvName uniq FSLIT("etaT"))
+ -- Using tv as a base retains its tyvar/covar-ness
(uniq:us2) = us
; Nothing ->
go (Var v) = idArity v
go (Lam x e) | isId x = go e + 1
| otherwise = go e
+ go (Note (TickBox {}) _) = 0
+ go (Note (BinaryTickBox {}) _)
+ = 0
go (Note n e) = go e
go (Cast e _) = go e
go (App e (Type t)) = go e
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
+noteSize (TickBox m n) = m `seq` n `seq` 1
+noteSize (BinaryTickBox m t e) = m `seq` t `seq` e `seq` 1
varSize :: Var -> Int
varSize b | isTyVar b = 1
is_static False (Lam b e) = isRuntimeVar b || is_static False e
is_static in_arg (Note (SCC _) e) = False
+ is_static in_arg (Note (TickBox {}) e) = False
+ is_static in_arg (Note (BinaryTickBox {}) e) = False
is_static in_arg (Note _ e) = is_static in_arg e
is_static in_arg (Cast e co) = is_static in_arg e