X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fprelude%2FPrelRules.lhs;h=59562a2b2982b58892f2eb677298082e0538d68e;hp=4ca4462e50230ca9c18ad236f89be3594d10a468;hb=7fc01c4671980ea3c66d549c0ece4d82fd3f5ade;hpb=ca10c79f28cfc0c29d02d0f2c0ea111093bd2b37

diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs
index 4ca4462..59562a2 100644
--- a/compiler/prelude/PrelRules.lhs
+++ b/compiler/prelude/PrelRules.lhs
@@ -12,7 +12,6 @@ ToDo:
    (i1 + i2) only if it results	in a valid Float.
 
 \begin{code}
-
 {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
 
 module PrelRules ( primOpRules, builtinRules ) where
@@ -20,27 +19,18 @@ 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
@@ -437,13 +427,41 @@ mkDoubleVal d = Lit (convFloating (MachDouble d))
 %*									*
 %************************************************************************
 
+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)
+tagToEnumRule _ [Type ty, _]
+  | not (is_enum_ty ty)	  -- 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
+    is_enum_ty ty = case splitTyConApp_maybe ty of
+                       Just (tc, _) -> isEnumerationTyCon tc
+		       Nothing      -> False
+
 tagToEnumRule _ [Type ty, Lit (MachInt i)]
   = ASSERT( isEnumerationTyCon tycon ) 
     case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of
-
-
 	[]	  -> Nothing	-- Abstract type
 	(dc:rest) -> ASSERT( null rest )
 		     Just (Var (dataConWorkId dc))
@@ -455,6 +473,7 @@ tagToEnumRule _ [Type ty, Lit (MachInt i)]
 tagToEnumRule _ _ = Nothing
 \end{code}
 
+
 For dataToTag#, we can reduce if either 
 	
 	(a) the argument is a constructor
@@ -523,7 +542,8 @@ builtinRules
 
 ---------------------------------------------------
 -- 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,
@@ -580,3 +600,4 @@ match_inline _ (Type _ : e : _)
 
 match_inline _ _ = Nothing
 \end{code}
+