More import tidying and fixing the stage 2 build

[ghc-hetmet.git] / compiler / coreSyn / CoreUtils.lhs

diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 27813a2..b0de6f2 100644 (file)
--- 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}
 
 
@@ -633,15 +616,15 @@ exprIsHNF (Var v)         -- NB: There are no value args at this point
        -- 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
@@ -762,16 +745,21 @@ exprIsConApp_maybe (Cast expr co)
        -- 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
+    let (from_ty, to_ty)          = coercionKind co
+       (from_tc, from_tc_arg_tys) = splitTyConApp from_ty
                -- The inner one must be a TyConApp
     in
-    ASSERT( from_tc == dataConTyCon dc )
-
     case splitTyConApp_maybe to_ty of {
        Nothing -> Nothing ;
-       Just (to_tc, _to_tc_arg_tys) | from_tc /= to_tc  -> Nothing
-                                    | 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
        tc_arity = tyConArity from_tc
 
@@ -804,10 +792,12 @@ exprIsConApp_maybe (Cast expr co)
 
     in
     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, univ_args ++ ex_args ++ new_co_args ++ new_val_args)
+    Just (dc, map Type to_tc_arg_tys ++ ex_args ++ new_co_args ++ new_val_args)
     }}
 
 exprIsConApp_maybe (Note _ expr)
@@ -1233,6 +1223,7 @@ exprIsBig (Lit _)      = False
 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}