Move error-ids to MkCore (from PrelRules)

[ghc-hetmet.git] / compiler / prelude / PrelRules.lhs

diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs
index 4ca4462..59562a2 100644 (file)
--- 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}
+