----------------------------------
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.
- cheapEqExpr, eqExpr, applyTypeToArgs
+ cheapEqExpr, eqExpr, applyTypeToArgs, applyTypeToArg
) where
#include "HsVersions.h"
) where
#include "HsVersions.h"
import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, splitFunTy,
applyTys, isUnLiftedType, seqType, mkUTy, mkTyVarTy,
splitForAllTy_maybe, isForAllTy, splitNewType_maybe,
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 )
)
import TyCon ( tyConArity )
import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
--- 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
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 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
- (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
applyTypeToArgs e op_ty (other_arg : args)
= case (splitFunTy_maybe op_ty) of
exprIsConApp_maybe, mkPiType, findAlt,
exprType, coreAltsType, exprIsValue,
exprOkForSpeculation, exprArity, findDefault,
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 )
)
import Rules ( lookupRule )
import BasicTypes ( isMarkedStrict )
-- ==>
-- let a = ...arg...
-- in [...hole...] a
-- ==>
-- 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 ->
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
if exprIsDupable arg' then
returnSmpl (emptyFloats env, ApplyTo OkToDup arg' (zapSubstEnv se) cont')
else