X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUtils.lhs;h=146f8cfd736236df6c3299bd199c0984fb6753a8;hb=d5e78cc70dc29cb59687156486e2acaaa444c029;hp=38e4a11759d74f49429881768a3f546f207fa0d6;hpb=522c8ebea4546658b4a5ee6727a0cab64fd72e8b;p=ghc-hetmet.git

diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 38e4a11..146f8cf 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -1,7 +1,9 @@
 %
+% (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 (
@@ -38,57 +40,38 @@ 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}
 
 
@@ -637,6 +620,10 @@ 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 (TickBox {}) _)
+	                   = False
+exprIsHNF (Note (BinaryTickBox {}) _)
+	                   = False
 exprIsHNF (Note _ e) 	   = exprIsHNF e
 exprIsHNF (Cast e co)      = exprIsHNF e
 exprIsHNF (App e (Type _)) = exprIsHNF e
@@ -817,6 +804,14 @@ exprIsConApp_maybe (Cast expr co)
     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
@@ -1137,7 +1132,8 @@ eta_expand n us expr ty
 
               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 ->
   
@@ -1200,6 +1196,9 @@ exprArity e = go e
 	      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
@@ -1317,6 +1316,8 @@ exprSize (Type t)        = seqType t `seq` 1
 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
@@ -1462,6 +1463,8 @@ rhsIsStatic this_pkg rhs = is_static False rhs
   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