X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCorePrep.lhs;fp=ghc%2Fcompiler%2FcoreSyn%2FCorePrep.lhs;h=925a51f6acf03d0c5f660d5f7dfbe774dc816766;hb=23f40f0e9be6d4aa5cf9ea31d73f4013f8e7b4bd;hp=1602a07b8673eec22758ac6560a84dc6e3073a7a;hpb=9b6858cb53438a2651ab00202582b13f95036058;p=ghc-hetmet.git

diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs
index 1602a07..925a51f 100644
--- a/ghc/compiler/coreSyn/CorePrep.lhs
+++ b/ghc/compiler/coreSyn/CorePrep.lhs
@@ -407,12 +407,14 @@ corePrepExprFloat env expr@(Lam _ _)
   where
     (bndrs,body) = collectBinders expr
 
-corePrepExprFloat env (Case scrut bndr alts)
+-- gaw 2004
+corePrepExprFloat env (Case scrut bndr ty alts)
   = corePrepExprFloat env scrut		`thenUs` \ (floats1, scrut1) ->
     deLamFloat scrut1			`thenUs` \ (floats2, scrut2) ->
     cloneBndr env bndr			`thenUs` \ (env', bndr') ->
     mapUs (sat_alt env') alts		`thenUs` \ alts' ->
-    returnUs (floats1 `appendFloats` floats2 , Case scrut2 bndr' alts')
+-- gaw 2004
+    returnUs (floats1 `appendFloats` floats2 , Case scrut2 bndr' ty alts')
   where
     sat_alt env (con, bs, rhs)
 	  = cloneBndrs env bs		`thenUs` \ (env', bs') ->
@@ -585,7 +587,8 @@ mkBinds (Floats _ binds) body
   | otherwise	  = deLam body		`thenUs` \ body' ->
 		    returnUs (foldrOL mk_bind body' binds)
   where
-    mk_bind (FloatCase bndr rhs _) body = Case rhs bndr [(DEFAULT, [], body)]
+-- gaw 2004
+    mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
     mk_bind (FloatLet bind)        body = Let bind body
 
 etaExpandRhs bndr rhs