Consider variables with conlike unfoldings interesting

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

diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index f32d5b1..2940814 100644 (file)
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -42,6 +42,7 @@ import CoreSyn
 import PprCore         ()      -- Instances
 import OccurAnal
 import CoreSubst hiding( substTy )
+import CoreFVs         ( exprFreeVars )
 import CoreUtils
 import Id
 import DataCon
@@ -54,6 +55,7 @@ import TcType         ( tcSplitDFunTy )
 import Type 
 import Coercion
 import PrelNames
+import VarEnv           ( mkInScopeSet )
 import Bag
 import Util
 import FastTypes
@@ -119,6 +121,7 @@ mkCoreUnfolding top_lvl expr arity guidance
                    uf_arity      = arity,
                    uf_is_top     = top_lvl,
                    uf_is_value   = exprIsHNF expr,
+                    uf_is_conlike = exprIsConLike expr,
                    uf_is_cheap   = exprIsCheap expr,
                    uf_expandable = exprIsExpandable expr,
                    uf_guidance   = guidance }
@@ -956,10 +959,10 @@ interestingArg e = go e 0
                                                --    data constructors here
        | idArity v > n    = ValueArg   -- Catches (eg) primops with arity but no unfolding
        | n > 0            = NonTrivArg -- Saturated or unknown call
-       | evald_unfolding   = ValueArg  -- n==0; look for a value
+       | conlike_unfolding = ValueArg  -- n==0; look for an interesting unfolding
        | otherwise        = TrivArg    -- n==0, no useful unfolding
        where
-         evald_unfolding = isEvaldUnfolding (idUnfolding v)
+         conlike_unfolding = isConLikeUnfolding (idUnfolding v)
 
     go (Type _)          _ = TrivArg
     go (App fn (Type _)) n = go fn n    
@@ -1070,7 +1073,8 @@ exprIsConApp_maybe (Cast expr co)
     let dump_doc = vcat [ppr dc,      ppr dc_univ_tyvars, ppr dc_ex_tyvars,
                          ppr arg_tys, ppr dc_args,        ppr _dc_univ_args,
                          ppr ex_args, ppr val_args]
-    ASSERT2( coreEqType from_ty (mkTyConApp dc_tc _dc_univ_args), dump_doc )
+    in
+    ASSERT2( coreEqType _from_ty (mkTyConApp dc_tc _dc_univ_args), dump_doc )
     ASSERT2( all isTypeArg (ex_args ++ co_args), dump_doc )
     ASSERT2( equalLength val_args arg_tys, dump_doc )
 #endif
@@ -1110,6 +1114,9 @@ exprIsConApp_maybe expr
     analyse _ _ = Nothing
 
     -----------
+    in_scope = mkInScopeSet (exprFreeVars expr)
+
+    -----------
     beta (Lam v body) pairs (arg : args) 
         | isTypeArg arg
         = beta body ((v,arg):pairs) args 
@@ -1118,12 +1125,13 @@ exprIsConApp_maybe expr
        = Nothing
 
     beta fun pairs args
-        = case analyse (substExpr (mkOpenSubst pairs) fun) args of
+        = case analyse (substExpr subst fun) args of
            Nothing  -> -- pprTrace "Bale out! exprIsConApp_maybe" doc $
                        Nothing
            Just ans -> -- pprTrace "Woo-hoo! exprIsConApp_maybe" doc $
                         Just ans
         where
+          subst = mkOpenSubst in_scope pairs
          -- doc = vcat [ppr fun, ppr expr, ppr pairs, ppr args]