[project @ 2002-03-04 17:01:26 by simonmar]

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

diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs
index 2cd4249..ab99d49 100644 (file)
--- a/ghc/compiler/coreSyn/CoreUtils.lhs
+++ b/ghc/compiler/coreSyn/CoreUtils.lhs
@@ -8,7 +8,7 @@ module CoreUtils (
        -- Construction
        mkNote, mkInlineMe, mkSCC, mkCoerce,
        bindNonRec, needsCaseBinding,
-       mkIfThenElse, mkAltExpr, mkPiType,
+       mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
 
        -- Taking expressions apart
        findDefault, findAlt, hasDefault,
@@ -32,7 +32,7 @@ module CoreUtils (
        hashExpr,
 
        -- Equality
-       cheapEqExpr, eqExpr, applyTypeToArgs
+       cheapEqExpr, eqExpr, applyTypeToArgs, applyTypeToArg
     ) where
 
 #include "HsVersions.h"
@@ -48,18 +48,18 @@ import Name         ( hashName )
 import Literal         ( hashLiteral, literalType, litIsDupable, isZeroLit )
 import DataCon         ( DataCon, dataConRepArity, dataConArgTys, isExistentialDataCon, dataConTyCon )
 import PrimOp          ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
-import Id              ( Id, idType, globalIdDetails, idNewStrictness, idLBVarInfo, 
+import Id              ( Id, idType, globalIdDetails, idNewStrictness, 
                          mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda,
                          isDataConId_maybe, mkSysLocal, isDataConId, isBottomingId
                        )
-import IdInfo          ( LBVarInfo(..),  
-                         GlobalIdDetails(..),
+import IdInfo          ( GlobalIdDetails(..),
                          megaSeqIdInfo )
 import NewDemand       ( appIsBottom )
 import Type            ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, splitFunTy,
-                         applyTys, isUnLiftedType, seqType, mkUTy, mkTyVarTy,
+                         applyTys, isUnLiftedType, seqType, mkTyVarTy,
                          splitForAllTy_maybe, isForAllTy, splitNewType_maybe, 
-                         splitTyConApp_maybe, eqType, funResultTy, applyTy
+                         splitTyConApp_maybe, eqType, funResultTy, applyTy,
+                         funResultTy, applyTy
                        )
 import TyCon           ( tyConArity )
 import TysWiredIn      ( boolTy, trueDataCon, falseDataCon )
@@ -68,6 +68,7 @@ import BasicTypes     ( Arity )
 import Unique          ( Unique )
 import Outputable
 import TysPrim         ( alphaTy )     -- Debugging only
+import Util             ( equalLength, lengthAtLeast )
 \end{code}
 
 
@@ -103,26 +104,35 @@ lbvarinfo field to figure out the right annotation for the arrove in
 case of a term variable.
 
 \begin{code}
-mkPiType :: Var -> Type -> Type                -- The more polymorphic version doesn't work...
-mkPiType v ty | isId v    = (case idLBVarInfo v of
-                               LBVarInfo u -> mkUTy u
-                               otherwise   -> id) $
-                            mkFunTy (idType v) ty
-             | isTyVar v = mkForAllTy v ty
+mkPiType  :: Var   -> Type -> Type     -- The more polymorphic version
+mkPiTypes :: [Var] -> Type -> Type     --    doesn't work...
+
+mkPiTypes vs ty = foldr mkPiType ty vs
+
+mkPiType v ty
+   | isId v    = mkFunTy (idType v) ty
+   | otherwise = mkForAllTy v ty
 \end{code}
 
 \begin{code}
--- The first argument is just for debugging
+applyTypeToArg :: Type -> CoreExpr -> Type
+applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
+applyTypeToArg fun_ty other_arg     = funResultTy fun_ty
+
 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
+-- A more efficient version of applyTypeToArg 
+-- when we have several args
+-- The first argument is just for debugging
 applyTypeToArgs e op_ty [] = op_ty
 
 applyTypeToArgs e op_ty (Type ty : args)
   =    -- Accumulate type arguments so we can instantiate all at once
-    applyTypeToArgs e (applyTys op_ty tys) rest_args
+    go [ty] args
   where
-    (tys, rest_args)        = go [ty] args
-    go tys (Type ty : args) = go (ty:tys) args
-    go tys rest_args       = (reverse tys, rest_args)
+    go rev_tys (Type ty : args) = go (ty:rev_tys) args
+    go rev_tys rest_args        = applyTypeToArgs e op_ty' rest_args
+                               where
+                                 op_ty' = applyTys op_ty (reverse rev_tys)
 
 applyTypeToArgs e op_ty (other_arg : args)
   = case (splitFunTy_maybe op_ty) of
@@ -623,7 +633,7 @@ exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr)
        new_val_args     = zipWith mk_coerce to_arg_tys val_args
     in
     ASSERT( all isTypeArg (take arity args) )
-    ASSERT( length val_args == length to_arg_tys )
+    ASSERT( equalLength val_args to_arg_tys )
     Just (dc, map Type tc_arg_tys ++ new_val_args)
     }}
 
@@ -644,7 +654,7 @@ exprIsConApp_maybe expr = analyse (collectArgs expr)
   where
     analyse (Var fun, args)
        | Just con <- isDataConId_maybe fun,
-         length args >= dataConRepArity con
+         args `lengthAtLeast` dataConRepArity con
                -- Might be > because the arity excludes type args
        = Just (con,args)
 
@@ -853,7 +863,7 @@ eta_expand n us expr ty
        case splitFunTy_maybe ty of {
          Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty)
                                where
-                                  arg1       = mkSysLocal SLIT("eta") uniq arg_ty
+                                  arg1       = mkSysLocal FSLIT("eta") uniq arg_ty
                                   (uniq:us2) = us
                                   
        ; Nothing ->
@@ -906,7 +916,6 @@ exprArity e = go e
              go _                         = 0
 \end{code}
 
-
 %************************************************************************
 %*                                                                     *
 \subsection{Equality}
@@ -961,7 +970,7 @@ eqExpr e1 e2
     eq env (Let (NonRec v1 r1) e1)
           (Let (NonRec v2 r2) e2)   = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
     eq env (Let (Rec ps1) e1)
-          (Let (Rec ps2) e2)        = length ps1 == length ps2 &&
+          (Let (Rec ps2) e2)        = equalLength ps1 ps2 &&
                                       and (zipWith eq_rhs ps1 ps2) &&
                                       eq env' e1 e2
                                     where
@@ -969,7 +978,7 @@ eqExpr e1 e2
                                       eq_rhs (_,r1) (_,r2) = eq env' r1 r2
     eq env (Case e1 v1 a1)
           (Case e2 v2 a2)           = eq env e1 e2 &&
-                                      length a1 == length a2 &&
+                                      equalLength a1 a2 &&
                                       and (zipWith (eq_alt env') a1 a2)
                                     where
                                       env' = extendVarEnv env v1 v2
@@ -1005,7 +1014,7 @@ coreBindsSize bs = foldr ((+) . bindSize) 0 bs
 exprSize :: CoreExpr -> Int
        -- A measure of the size of the expressions
        -- It also forces the expression pretty drastically as a side effect
-exprSize (Var v)       = varSize v 
+exprSize (Var v)       = v `seq` 1
 exprSize (Lit lit)     = lit `seq` 1
 exprSize (App f a)     = exprSize f + exprSize a
 exprSize (Lam b e)     = varSize b + exprSize e