From c938c386fe84f9203c992bb35508c7a5b35bb22c Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Wed, 16 Aug 2006 20:31:56 +0000 Subject: [PATCH] Add ad-hoc typing checks for tagToEnum# The problem with tagToEnum# is that it is not overloaded (in the Haskell sense) but you are only supposed to apply it to a TyCon that is an enumeration (isEnumerationTyCon). The Real Way to do this is to have some special kind of type constraint for the purpose, but that is wild overkill. So this patch adds a small rather ad-hoc check to TcExpr.instFun. Crude, simple, but it works fine. Fixes Trac #786 Test is tcfail164 --- compiler/prelude/PrelRules.lhs | 4 +-- compiler/prelude/PrimOp.lhs | 10 +++++++ compiler/typecheck/TcExpr.lhs | 65 +++++++++++++++++++++++++++++++++------- 3 files changed, 67 insertions(+), 12 deletions(-) diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index ae26f84..8bdaeb3 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -30,7 +30,7 @@ import Literal ( Literal(..), mkMachInt, mkMachWord , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit , float2DoubleLit, double2FloatLit ) -import PrimOp ( PrimOp(..), primOpOcc ) +import PrimOp ( PrimOp(..), primOpOcc, tagToEnumKey ) import TysWiredIn ( boolTy, trueDataConId, falseDataConId ) import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon ) import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG ) @@ -386,7 +386,7 @@ For dataToTag#, we can reduce if either \begin{code} dataToTagRule [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] - | Just TagToEnumOp <- isPrimOpId_maybe tag_to_enum + | tag_to_enum `hasKey` tagToEnumKey , ty1 `coreEqType` ty2 = Just tag -- dataToTag (tagToEnum x) ==> x diff --git a/compiler/prelude/PrimOp.lhs b/compiler/prelude/PrimOp.lhs index a650352..dae8bee 100644 --- a/compiler/prelude/PrimOp.lhs +++ b/compiler/prelude/PrimOp.lhs @@ -9,6 +9,8 @@ module PrimOp ( primOpType, primOpSig, primOpTag, maxPrimOpTag, primOpOcc, + tagToEnumKey, + primOpOutOfLine, primOpNeedsWrapper, primOpOkForSpeculation, primOpIsCheap, primOpIsDupable, @@ -27,6 +29,7 @@ import TyCon ( TyCon, isPrimTyCon, tyConPrimRep, PrimRep(..) ) import Type ( Type, mkForAllTys, mkFunTy, mkFunTys, tyConAppTyCon, typePrimRep ) import BasicTypes ( Arity, Boxity(..) ) +import Unique ( Unique, mkPrimOpIdUnique ) import Outputable import FastTypes \end{code} @@ -84,6 +87,13 @@ allThePrimOps = #include "primop-list.hs-incl" \end{code} +\begin{code} +tagToEnumKey :: Unique +tagToEnumKey = mkPrimOpIdUnique (primOpTag TagToEnumOp) +\end{code} + + + %************************************************************************ %* * \subsection[PrimOp-info]{The essential info about each @PrimOp@} diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index e897420..c26d74d 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -37,31 +37,34 @@ import TcArrows ( tcProc ) import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, TcMatchCtxt(..) ) import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) import TcPat ( tcOverloadedLit, badFieldCon ) -import TcMType ( tcInstTyVars, newFlexiTyVarTy, newBoxyTyVars, readFilledBox, - tcInstBoxyTyVar, tcInstTyVar ) +import TcMType ( tcInstTyVars, newFlexiTyVarTy, newBoxyTyVars, readFilledBox, zonkTcTypes ) import TcType ( TcType, TcSigmaType, TcRhoType, BoxySigmaType, BoxyRhoType, ThetaType, - mkTyVarTys, mkFunTys, tcMultiSplitSigmaTy, tcSplitFunTysN, + mkTyVarTys, mkFunTys, + tcMultiSplitSigmaTy, tcSplitFunTysN, tcSplitTyConApp_maybe, isSigmaTy, mkFunTy, mkTyConApp, isLinearPred, - exactTyVarsOfType, exactTyVarsOfTypes, mkTyVarTy, - zipTopTvSubst, zipOpenTvSubst, substTys, substTyVar, lookupTyVar + exactTyVarsOfType, exactTyVarsOfTypes, + zipTopTvSubst, zipOpenTvSubst, substTys, substTyVar ) import Kind ( argTypeKind ) -import Id ( idType, idName, recordSelectorFieldLabel, isRecordSelector, - isNaughtyRecordSelector, isDataConId_maybe ) +import Id ( Id, idType, idName, recordSelectorFieldLabel, + isRecordSelector, isNaughtyRecordSelector, isDataConId_maybe ) import DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks, dataConSourceArity, dataConWrapId, isVanillaDataCon, dataConTyVars, dataConOrigArgTys ) import Name ( Name ) -import TyCon ( FieldLabel, tyConStupidTheta, tyConDataCons ) +import TyCon ( FieldLabel, tyConStupidTheta, tyConDataCons, isEnumerationTyCon ) import Type ( substTheta, substTy ) import Var ( TyVar, tyVarKind ) import VarSet ( emptyVarSet, elemVarSet, unionVarSet ) import TysWiredIn ( boolTy, parrTyCon, tupleTyCon ) import PrelNames ( enumFromName, enumFromThenName, enumFromToName, enumFromThenToName, - enumFromToPName, enumFromThenToPName, negateName + enumFromToPName, enumFromThenToPName, negateName, + hasKey ) +import PrimOp ( tagToEnumKey ) + import DynFlags import StaticFlags ( opt_NoMethodSharing ) import HscTypes ( TyThing(..) ) @@ -252,6 +255,7 @@ tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty tc_args arg1_ty' [arg1_ty, arg2_ty] = do { boxyUnify arg1_ty' arg1_ty ; tcArg lop (arg2, arg2_ty, 2) } + tc_args arg1_ty' other = panic "tcExpr SectionR" \end{code} \begin{code} @@ -761,7 +765,10 @@ instFun fun_id qtvs qtv_tys [] = return (HsVar fun_id) -- Common short cut instFun fun_id qtvs qtv_tys tv_theta_prs - = do { let subst = zipOpenTvSubst qtvs qtv_tys + = do { -- Horrid check for tagToEnum; see Note [tagToEnum#] + checkBadTagToEnumCall fun_id qtv_tys + + ; let subst = zipOpenTvSubst qtvs qtv_tys ty_theta_prs' = map subst_pr tv_theta_prs subst_pr (tvs, theta) = (map (substTyVar subst) tvs, substTheta subst theta) @@ -873,6 +880,44 @@ tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no) $ \end{code} +Note [tagToEnum#] +~~~~~~~~~~~~~~~~~ +Nasty check to ensure that tagToEnum# is applied to a type that is an +enumeration TyCon. Unification may refine the type later, but this +check won't see that, alas. It's crude but it works. + +Here's are two cases that should fail + f :: forall a. a + f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable + + g :: Int + g = tagToEnum# 0 -- Int is not an enumeration + + +\begin{code} +checkBadTagToEnumCall :: Id -> [TcType] -> TcM () +checkBadTagToEnumCall fun_id tys + | fun_id `hasKey` tagToEnumKey + = do { tys' <- zonkTcTypes tys + ; checkTc (ok tys') (tagToEnumError tys') + } + | otherwise -- Vastly common case + = return () + where + ok [] = False + ok (ty:tys) = case tcSplitTyConApp_maybe ty of + Just (tc,_) -> isEnumerationTyCon tc + Nothing -> False + +tagToEnumError tys + = hang (ptext SLIT("Bad call to tagToEnum#") <+> at_type) + 2 (vcat [ptext SLIT("Specify the type by giving a type signature"), + ptext SLIT("e.g. (tagToEnum# x) :: Bool")]) + where + at_type | null tys = empty -- Probably never happens + | otherwise = ptext SLIT("at type") <+> ppr (head tys) +\end{code} + %************************************************************************ %* * \subsection{@tcId@ typchecks an identifier occurrence} -- 1.7.10.4