Make SpecConstr work better for nested functions

[ghc-hetmet.git] / compiler / specialise / SpecConstr.lhs

diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index e6908ec..9d1ba01 100644 (file)
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -22,7 +22,7 @@ import DataCon                ( dataConRepArity, isVanillaDataCon )
 import Type            ( tyConAppArgs, tyVarsOfTypes )
 import Unify           ( coreRefineTys )
 import Id              ( Id, idName, idType, isDataConWorkId_maybe, 
-                         mkUserLocal, mkSysLocal )
+                         mkUserLocal, mkSysLocal, idUnfolding )
 import Var             ( Var )
 import VarEnv
 import VarSet
@@ -98,6 +98,8 @@ of n is needed (else we'd avoid the eval but pay more for re-boxing n).
 So in this case we want that the *only* uses of n are in case statements.
 
 
+Note [Good arguments]
+~~~~~~~~~~~~~~~~~~~~~
 So we look for
 
 * A self-recursive function.  Ignore mutual recursion for now, 
@@ -441,7 +443,10 @@ scBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, ScUsage, CoreBind)
 scBind env (Rec [(fn,rhs)])
   | notNull val_bndrs
   = scExpr env_fn_body body            `thenUs` \ (usg, body') ->
-    specialise env fn bndrs body usg   `thenUs` \ (rules, spec_prs) ->
+    specialise env fn bndrs body' usg  `thenUs` \ (rules, spec_prs) ->
+       -- Note body': the specialised copies should be based on the 
+       --             optimised version of the body, in case there were
+       --             nested functions inside.
     let
        SCU { calls = calls, occs = occs } = usg
     in
@@ -510,6 +515,7 @@ specialise env fn bndrs body (SCU {calls=calls, occs=occs})
 
 ---------------------
 good_arg :: ConstrEnv -> IdEnv ArgOcc -> (CoreBndr, CoreArg) -> Bool
+-- See Note [Good arguments] above
 good_arg con_env arg_occs (bndr, arg)
   = case is_con_app_maybe con_env arg of       
        Just _ ->  bndr_usg_ok arg_occs bndr arg
@@ -638,10 +644,20 @@ argsToPats env us args = mapAccumL (argToPat env) us args
 \begin{code}
 is_con_app_maybe :: ConstrEnv -> CoreExpr -> Maybe ConValue
 is_con_app_maybe env (Var v)
-  = lookupVarEnv env v
-       -- You might think we could look in the idUnfolding here
-       -- but that doesn't take account of which branch of a 
-       -- case we are in, which is the whole point
+  = case lookupVarEnv env v of
+       Just stuff -> Just stuff
+               -- You might think we could look in the idUnfolding here
+               -- but that doesn't take account of which branch of a 
+               -- case we are in, which is the whole point
+
+       Nothing | isCheapUnfolding unf
+               -> is_con_app_maybe env (unfoldingTemplate unf)
+               where
+                 unf = idUnfolding v
+               -- However we do want to consult the unfolding as well,
+               -- for let-bound constructors!
+
+       other  -> Nothing
 
 is_con_app_maybe env (Lit lit)
   = Just (CV (LitAlt lit) [])