From: simonpj <unknown>
Date: Thu, 1 Nov 2001 10:33:58 +0000 (+0000)
Subject: [project @ 2001-11-01 10:33:58 by simonpj]
X-Git-Tag: Approximately_9120_patches~656
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=883d5ca94bba6c5ba57db221b8d8f5e82a6453e7;p=ghc-hetmet.git

[project @ 2001-11-01 10:33:58 by simonpj]
----------------------------------
	Fix a bug in Simplify.mkDupableAlt
	----------------------------------

	[This is the HEAD commit; I've fixed
	 the branch separately.]

This fixes a funResultTy panic that Koen encountered.

The reason was that the simplifier was doing a
case-of-case where the result had a polymorphic type.
This in turn showed up because of a newtype (now
transparent) with a forall inside it.

The fix is very easy; can't think how I got it wrong
in the first place.
---

diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs
index a1a4694..0877888 100644
--- a/ghc/compiler/coreSyn/CoreUtils.lhs
+++ b/ghc/compiler/coreSyn/CoreUtils.lhs
@@ -32,7 +32,7 @@ module CoreUtils (
 	hashExpr,
 
 	-- Equality
-	cheapEqExpr, eqExpr, applyTypeToArgs
+	cheapEqExpr, eqExpr, applyTypeToArgs, applyTypeToArg
     ) where
 
 #include "HsVersions.h"
@@ -59,7 +59,8 @@ import NewDemand	( appIsBottom )
 import Type		( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, splitFunTy,
 			  applyTys, isUnLiftedType, seqType, mkUTy, mkTyVarTy,
 			  splitForAllTy_maybe, isForAllTy, splitNewType_maybe, 
-			  splitTyConApp_maybe, eqType, funResultTy, applyTy
+			  splitTyConApp_maybe, eqType, funResultTy, applyTy,
+			  funResultTy, applyTy
 			)
 import TyCon		( tyConArity )
 import TysWiredIn	( boolTy, trueDataCon, falseDataCon )
@@ -113,17 +114,24 @@ mkPiType v ty | isId v    = (case idLBVarInfo v of
 \end{code}
 
 \begin{code}
--- The first argument is just for debugging
+applyTypeToArg :: Type -> CoreExpr -> Type
+applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
+applyTypeToArg fun_ty other_arg     = funResultTy fun_ty
+
 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
+-- A more efficient version of applyTypeToArg 
+-- when we have several args
+-- The first argument is just for debugging
 applyTypeToArgs e op_ty [] = op_ty
 
 applyTypeToArgs e op_ty (Type ty : args)
   =	-- Accumulate type arguments so we can instantiate all at once
-    applyTypeToArgs e (applyTys op_ty tys) rest_args
+    go [ty] args
   where
-    (tys, rest_args)        = go [ty] args
-    go tys (Type ty : args) = go (ty:tys) args
-    go tys rest_args	    = (reverse tys, rest_args)
+    go rev_tys (Type ty : args) = go (ty:rev_tys) args
+    go rev_tys rest_args        = applyTypeToArgs e op_ty' rest_args
+			 	where
+				  op_ty' = applyTys op_ty (reverse rev_tys)
 
 applyTypeToArgs e op_ty (other_arg : args)
   = case (splitFunTy_maybe op_ty) of
diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index 33400a1..0d95dbe 100644
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -40,7 +40,7 @@ import CoreUtils	( exprIsDupable, exprIsTrivial, needsCaseBinding,
 			  exprIsConApp_maybe, mkPiType, findAlt, 
 			  exprType, coreAltsType, exprIsValue, 
 			  exprOkForSpeculation, exprArity, findDefault,
-			  mkCoerce, mkSCC, mkInlineMe, mkAltExpr
+			  mkCoerce, mkSCC, mkInlineMe, mkAltExpr, applyTypeToArg
 			)
 import Rules		( lookupRule )
 import BasicTypes	( isMarkedStrict )
@@ -1552,10 +1552,14 @@ mkDupableCont env ty (ApplyTo _ arg se cont)
 	--	==>
 	--		let a = ...arg... 
 	--		in [...hole...] a
-    mkDupableCont env (funResultTy ty) cont 		`thenSmpl` \ (floats, cont') ->
+    simplExpr (setInScope se env) arg			`thenSmpl` \ arg' ->
+
+    mkDupableCont env (applyTypeToArg ty arg') cont	`thenSmpl` \ (floats, cont') ->
+	-- It's possible (albeit unusual) that arg is a type 
+	-- argument, if the alternatives have a for-all type; 
+	-- hence the applyTypeToArg
     addFloats env floats				$ \ env ->
 
-    simplExpr (setInScope se env) arg			`thenSmpl` \ arg' ->
     if exprIsDupable arg' then
 	returnSmpl (emptyFloats env, ApplyTo OkToDup arg' (zapSubstEnv se) cont')
     else