[project @ 2000-08-31 19:55:46 by simonpj]

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

diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs
index 64ddad2..5e9736b 100644 (file)
--- a/ghc/compiler/coreSyn/CoreUtils.lhs
+++ b/ghc/compiler/coreSyn/CoreUtils.lhs
@@ -8,6 +8,7 @@ module CoreUtils (
        -- Construction
        mkNote, mkInlineMe, mkSCC, mkCoerce,
        bindNonRec, mkIfThenElse, mkAltExpr,
+        mkPiType,
 
        -- Properties of expressions
        exprType, coreAltsType, exprArity,
@@ -41,7 +42,7 @@ import Var            ( Var, isId, isTyVar )
 import VarSet
 import VarEnv
 import Name            ( isLocallyDefined, hashName )
-import Literal         ( Literal, hashLiteral, literalType )
+import Literal         ( Literal, hashLiteral, literalType, litIsDupable )
 import DataCon         ( DataCon, dataConRepArity )
 import PrimOp          ( primOpOkForSpeculation, primOpIsCheap, 
                          primOpIsDupable )
@@ -85,13 +86,7 @@ exprType (Case _ _ alts)        = coreAltsType alts
 exprType (Note (Coerce ty _) e) = ty  -- **! should take usage from e
 exprType (Note (TermUsg u) e)   = mkUsgTy u (unUsgTy (exprType e))
 exprType (Note other_note e)    = exprType e
-exprType (Lam binder expr)
-  | isId binder    = (case idLBVarInfo binder of
-                       IsOneShotLambda -> mkUsgTy UsOnce
-                       otherwise       -> id) $
-                     idType binder `mkFunTy` exprType expr
-  | isTyVar binder = mkForAllTy binder (exprType expr)
-
+exprType (Lam binder expr)      = mkPiType binder (exprType expr)
 exprType e@(App _ _)
   = case collectArgs e of
        (fun, args) -> applyTypeToArgs e (exprType fun) args
@@ -102,6 +97,20 @@ coreAltsType :: [CoreAlt] -> Type
 coreAltsType ((_,_,rhs) : _) = exprType rhs
 \end{code}
 
+@mkPiType@ makes a (->) type or a forall type, depending on whether
+it is given a type variable or a term variable.  We cleverly use the
+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
+                               IsOneShotLambda -> mkUsgTy UsOnce
+                               otherwise       -> id) $
+                            mkFunTy (idType v) ty
+             | isTyVar v = mkForAllTy v ty
+\end{code}
+
 \begin{code}
 -- The first argument is just for debugging
 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
@@ -262,7 +271,7 @@ exprIsTrivial other                = False
 \begin{code}
 exprIsDupable (Type _)      = True
 exprIsDupable (Var v)       = True
-exprIsDupable (Lit lit)      = True
+exprIsDupable (Lit lit)      = litIsDupable lit
 exprIsDupable (Note _ e)     = exprIsDupable e
 exprIsDupable expr          
   = go expr 0
@@ -561,11 +570,11 @@ exprEtaExpandArity :: CoreExpr -> Int     -- The number of args the thing can be ap
 -- Hence "generous" arity
 
 exprEtaExpandArity e
-  = go e
+  = go e `max` 0       -- Never go -ve!
   where
     go (Var v)                                 = idArity v
     go (App f (Type _))                        = go f
-    go (App f a)  | exprIsCheap a      = (go f - 1) `max` 0    -- Never go -ve!
+    go (App f a)  | exprIsCheap a      = go f - 1
     go (Lam x e)  | isId x             = go e + 1
                  | otherwise           = go e
     go (Note n e) | ok_note n          = go e