#include "HsVersions.h"
import CoreSyn
-import Id ( mkWildId )
+import Id ( mkWildId, isPrimOpId_maybe )
import Literal ( Literal(..), mkMachInt, mkMachWord
, literalType
, word2IntLit, int2WordLit
, float2DoubleLit, double2FloatLit
)
import PrimOp ( PrimOp(..), primOpOcc )
-import TysWiredIn ( trueDataConId, falseDataConId )
+-- gaw 2004
+import TysWiredIn ( boolTy, trueDataConId, falseDataConId )
import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon )
import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG )
import CoreUtils ( cheapEqExpr, exprIsConApp_maybe )
-import Type ( tyConAppTyCon, eqType )
+import Type ( tyConAppTyCon, coreEqType )
import OccName ( occNameUserString)
import PrelNames ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey,
eqStringName, unpackCStringIdKey )
litEq is_eq other = Nothing
do_lit_eq is_eq lit expr
- = Just (Case expr (mkWildId (literalType lit))
+ = Just (Case expr (mkWildId (literalType lit)) boolTy
[(DEFAULT, [], val_if_neq),
(LitAlt lit, [], val_if_eq)])
where
(b) the argument is a variable whose unfolding is a known constructor
\begin{code}
-dataToTagRule [_, val_arg]
- = case exprIsConApp_maybe val_arg of
- Just (dc,_) -> ASSERT( not (isNewTyCon (dataConTyCon dc)) )
- Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))
+dataToTagRule [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag]
+ | Just TagToEnumOp <- isPrimOpId_maybe tag_to_enum
+ , ty1 `coreEqType` ty2
+ = Just tag -- dataToTag (tagToEnum x) ==> x
- other -> Nothing
+dataToTagRule [_, val_arg]
+ | Just (dc,_) <- exprIsConApp_maybe val_arg
+ = ASSERT( not (isNewTyCon (dataConTyCon dc)) )
+ Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))
dataToTagRule other = Nothing
\end{code}
]
| unpk `hasKey` unpackCStringFoldrIdKey &&
c1 `cheapEqExpr` c2
- = ASSERT( ty1 `eqType` ty2 )
+ = ASSERT( ty1 `coreEqType` ty2 )
Just (Var unpk `App` Type ty1
`App` Lit (MachStr (s1 `appendFS` s2))
`App` c1