X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FLiberateCase.lhs;h=afda3b3fecf92affd04a14a94c5efbad5679c90a;hb=36d207aa8c9cedbf58e739178971292048bd41d0;hp=c29a5b9c68f0eff66461e461450815bbeb882d36;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git

diff --git a/compiler/simplCore/LiberateCase.lhs b/compiler/simplCore/LiberateCase.lhs
index c29a5b9..afda3b3 100644
--- a/compiler/simplCore/LiberateCase.lhs
+++ b/compiler/simplCore/LiberateCase.lhs
@@ -81,6 +81,15 @@ Similarly drop:
 
 Would like to pass n along unboxed.
 	
+Note [Scrutinee with cast]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this:
+    f = \ t -> case (v `cast` co) of
+	         V a b -> a : f t
+
+Exactly the same optimistaion (unrolling one call to f) will work here, 
+despite the cast.  See mk_alt_env in the Case branch of libCase.
+
 
 To think about (Apr 94)
 ~~~~~~~~~~~~~~
@@ -225,6 +234,7 @@ libCase env (Lit lit)		= Lit lit
 libCase env (Type ty)		= Type ty
 libCase env (App fun arg)       = App (libCase env fun) (libCase env arg)
 libCase env (Note note body)    = Note note (libCase env body)
+libCase env (Cast e co)         = Cast (libCase env e) co
 
 libCase env (Lam binder body)
   = Lam binder (libCase (addBinders env [binder]) body)
@@ -237,10 +247,10 @@ libCase env (Let bind body)
 libCase env (Case scrut bndr ty alts)
   = Case (libCase env scrut) bndr ty (map (libCaseAlt env_alts) alts)
   where
-    env_alts = addBinders env_with_scrut [bndr]
-    env_with_scrut = case scrut of
-		  	Var scrut_var -> addScrutedVar env scrut_var
-			other	      -> env
+    env_alts = addBinders (mk_alt_env scrut) [bndr]
+    mk_alt_env (Var scrut_var) = addScrutedVar env scrut_var
+    mk_alt_env (Cast scrut _)  = mk_alt_env scrut	-- Note [Scrutinee with cast]
+    mk_alt_env otehr	       = env
 
 libCaseAlt env (con,args,rhs) = (con, args, libCase (addBinders env args) rhs)
 \end{code}