X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fspecialise%2FSpecConstr.lhs;h=9d1ba01027ce033dd6182a6b4619eb5f68a7835e;hb=68e468f00761339cb268e3f8e8e3124d1aaccadc;hp=e6908ec3f1f6c8e8b0450ee53b8ea96cb0d0a2ea;hpb=e923340fea0fea85f55600b8ee709f1cf8b62803;p=ghc-hetmet.git

diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index e6908ec..9d1ba01 100644
--- 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) [])