(i1 + i2) only if it results in a valid Float.
\begin{code}
-
{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
module PrelRules ( primOpRules, builtinRules ) where
#include "HsVersions.h"
import CoreSyn
-import MkCore ( mkWildCase )
-import Id ( realIdUnfolding )
-import Literal ( Literal(..), mkMachInt, mkMachWord
- , literalType
- , word2IntLit, int2WordLit
- , narrow8IntLit, narrow16IntLit, narrow32IntLit
- , narrow8WordLit, narrow16WordLit, narrow32WordLit
- , char2IntLit, int2CharLit
- , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
- , float2DoubleLit, double2FloatLit, litFitsInChar
- )
+import MkCore
+import Id
+import Literal
import PrimOp ( PrimOp(..), tagToEnumKey )
-import TysWiredIn ( boolTy, trueDataConId, falseDataConId )
+import TysWiredIn
import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon )
import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG )
import CoreUtils ( cheapEqExpr )
import CoreUnfold ( exprIsConApp_maybe )
-import Type ( tyConAppTyCon, coreEqType )
+import Type
import OccName ( occNameFS )
-import PrelNames ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey,
- eqStringName, unpackCStringIdKey, inlineIdName )
+import PrelNames
import Maybes ( orElse )
import Name ( Name, nameOccName )
import Outputable
%* *
%************************************************************************
+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
+
+We used to make this check in the type inference engine, but it's quite
+ugly to do so, because the delayed constraint solving means that we don't
+really know what's going on until the end. It's very much a corner case
+because we don't expect the user to call tagToEnum# at all; we merely
+generate calls in derived instances of Enum. So we compromise: a
+rewrite rule rewrites a bad instance of tagToEnum# to an error call,
+and emits a warning.
+
\begin{code}
tagToEnumRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
+-- If data T a = A | B | C
+-- then tag2Enum# (T ty) 2# --> B ty
tagToEnumRule _ [Type ty, Lit (MachInt i)]
- = ASSERT( isEnumerationTyCon tycon )
- case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of
-
-
+ | Just (tycon, tc_args) <- splitTyConApp_maybe ty
+ , isEnumerationTyCon tycon
+ = case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of
[] -> Nothing -- Abstract type
(dc:rest) -> ASSERT( null rest )
- Just (Var (dataConWorkId dc))
+ Just (mkTyApps (Var (dataConWorkId dc)) tc_args)
+ | otherwise -- See Note [tagToEnum#]
+ = WARN( True, ptext (sLit "tagToEnum# on non-enumeration type") <+> ppr ty )
+ Just (mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type")
where
correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
- tag = fromInteger i
- tycon = tyConAppTyCon ty
+ tag = fromInteger i
tagToEnumRule _ _ = Nothing
\end{code}
+
For dataToTag#, we can reduce if either
(a) the argument is a constructor
---------------------------------------------------
-- The rule is this:
--- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) = unpackFoldrCString# "foobaz" c n
+-- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)
+-- = unpackFoldrCString# "foobaz" c n
match_append_lit :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
match_append_lit _ [Type ty1,
match_inline _ _ = Nothing
\end{code}
+