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

diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs
index 67eb06f..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,31 +19,25 @@ module PrelRules ( primOpRules, builtinRules ) where
 #include "HsVersions.h"
 
 import CoreSyn
-import MkCore		( mkWildCase )
-import Id		( idUnfolding )
-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, exprIsConApp_maybe )
-import Type		( tyConAppTyCon, coreEqType )
+import CoreUtils	( cheapEqExpr )
+import CoreUnfold	( exprIsConApp_maybe )
+import Type
 import OccName		( occNameFS )
-import PrelNames	( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey,
-			  eqStringName, unpackCStringIdKey, inlineIdName )
+import PrelNames
 import Maybes		( orElse )
 import Name		( Name, nameOccName )
 import Outputable
 import FastString
 import StaticFlags      ( opt_SimplExcessPrecision )
+import Constants
+
 import Data.Bits as Bits
 import Data.Word	( Word )
 \end{code}
@@ -290,7 +283,9 @@ floatOp2 _ _ _ = Nothing
 floatOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal
           -> Maybe (Expr CoreBndr)
 floatOp2Z op (MachFloat f1) (MachFloat f2)
-  | f2 /= 0   = Just (mkFloatVal (f1 `op` f2))
+  | (f1 /= 0 || f2 > 0)  -- see Note [negative zero]
+  && f2 /= 0             -- avoid NaN and Infinity/-Infinity
+  = Just (mkFloatVal (f1 `op` f2))
 floatOp2Z _ _ _ = Nothing
 
 --------------------------
@@ -303,7 +298,13 @@ doubleOp2 _ _ _ = Nothing
 doubleOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal
            -> Maybe (Expr CoreBndr)
 doubleOp2Z op (MachDouble f1) (MachDouble f2)
-  | f2 /= 0   = Just (mkDoubleVal (f1 `op` f2))
+  | (f1 /= 0 || f2 > 0)  -- see Note [negative zero]
+  && f2 /= 0             -- avoid NaN and Infinity/-Infinity
+  = Just (mkDoubleVal (f1 `op` f2))
+  -- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to
+  -- zero, but we might want to preserve the negative zero here which
+  -- is representable in Float/Double but not in (normalised)
+  -- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead?
 doubleOp2Z _ _ _ = Nothing
 
 
@@ -336,9 +337,9 @@ litEq op_name is_eq
 		   ru_fn = op_name, 
 		   ru_nargs = 2, ru_try = rule_fn }]
   where
-    rule_fn [Lit lit, expr] = do_lit_eq lit expr
-    rule_fn [expr, Lit lit] = do_lit_eq lit expr
-    rule_fn _    	    = Nothing
+    rule_fn _ [Lit lit, expr] = do_lit_eq lit expr
+    rule_fn _ [expr, Lit lit] = do_lit_eq lit expr
+    rule_fn _ _    	      = Nothing
     
     do_lit_eq lit expr
       = Just (mkWildCase expr (literalType lit) boolTy
@@ -353,14 +354,14 @@ litEq op_name is_eq
 -- runtime either, and compilation of completely harmless things like
 --    ((124076834 :: Word32) + (2147483647 :: Word32))
 -- would yield a warning. Instead we simply squash the value into the
--- Int range, but not in a way suitable for cross-compiling... :-(
+-- *target* Int/Word range.
 intResult :: Integer -> Maybe CoreExpr
 intResult result
-  = Just (mkIntVal (toInteger (fromInteger result :: Int)))
+  = Just (mkIntVal (toInteger (fromInteger result :: TargetInt)))
 
 wordResult :: Integer -> Maybe CoreExpr
 wordResult result
-  = Just (mkWordVal (toInteger (fromInteger result :: Word)))
+  = Just (mkWordVal (toInteger (fromInteger result :: TargetWord)))
 \end{code}
 
 
@@ -371,7 +372,9 @@ wordResult result
 %************************************************************************
 
 \begin{code}
-mkBasicRule :: Name -> Int -> ([CoreExpr] -> Maybe CoreExpr) -> [CoreRule]
+mkBasicRule :: Name -> Int
+            -> (IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr)
+            -> [CoreRule]
 -- Gives the Rule the same name as the primop itself
 mkBasicRule op_name n_args rule_fn
   = [BuiltinRule { ru_name = occNameFS (nameOccName op_name),
@@ -383,16 +386,16 @@ oneLit :: Name -> (Literal -> Maybe CoreExpr)
 oneLit op_name test
   = mkBasicRule op_name 1 rule_fn
   where
-    rule_fn [Lit l1] = test (convFloating l1)
-    rule_fn _        = Nothing
+    rule_fn _ [Lit l1] = test (convFloating l1)
+    rule_fn _ _        = Nothing
 
 twoLits :: Name -> (Literal -> Literal -> Maybe CoreExpr)
 	-> [CoreRule]
 twoLits op_name test 
   = mkBasicRule op_name 2 rule_fn
   where
-    rule_fn [Lit l1, Lit l2] = test (convFloating l1) (convFloating l2)
-    rule_fn _                = Nothing
+    rule_fn _ [Lit l1, Lit l2] = test (convFloating l1) (convFloating l2)
+    rule_fn _ _                = Nothing
 
 -- When excess precision is not requested, cut down the precision of the
 -- Rational value to that of Float/Double. We confuse host architecture
@@ -424,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 :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
-tagToEnumRule [Type ty, Lit (MachInt i)]
+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))
@@ -439,27 +470,28 @@ tagToEnumRule [Type ty, Lit (MachInt i)]
     tag   = fromInteger i
     tycon = tyConAppTyCon ty
 
-tagToEnumRule _ = Nothing
+tagToEnumRule _ _ = Nothing
 \end{code}
 
+
 For dataToTag#, we can reduce if either 
 	
 	(a) the argument is a constructor
 	(b) the argument is a variable whose unfolding is a known constructor
 
 \begin{code}
-dataToTagRule :: [Expr CoreBndr] -> Maybe (Arg CoreBndr)
-dataToTagRule [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag]
+dataToTagRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Arg CoreBndr)
+dataToTagRule _ [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag]
   | tag_to_enum `hasKey` tagToEnumKey
   , ty1 `coreEqType` ty2
   = Just tag	-- dataToTag (tagToEnum x)   ==>   x
 
-dataToTagRule [_, val_arg]
-  | Just (dc,_) <- exprIsConApp_maybe val_arg
+dataToTagRule id_unf [_, val_arg]
+  | Just (dc,_,_) <- exprIsConApp_maybe id_unf val_arg
   = ASSERT( not (isNewTyCon (dataConTyCon dc)) )
     Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))
 
-dataToTagRule _ = Nothing
+dataToTagRule _ _ = Nothing
 \end{code}
 
 %************************************************************************
@@ -510,17 +542,18 @@ builtinRules
 
 ---------------------------------------------------
 -- The rule is this:
--- 	unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)  =  unpackFoldrCString# "foobaz" c n
-
-match_append_lit :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
-match_append_lit [Type ty1,
-		   Lit (MachStr s1),
-		   c1,
-		   Var unpk `App` Type ty2 
-		  	    `App` Lit (MachStr s2)
-		  	    `App` c2
-		  	    `App` 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,
+		    Lit (MachStr s1),
+		    c1,
+		    Var unpk `App` Type ty2 
+		  	     `App` Lit (MachStr s2)
+		  	     `App` c2
+		  	     `App` n
+		   ]
   | unpk `hasKey` unpackCStringFoldrIdKey && 
     c1 `cheapEqExpr` c2
   = ASSERT( ty1 `coreEqType` ty2 )
@@ -529,26 +562,26 @@ match_append_lit [Type ty1,
 		   `App` c1
 		   `App` n)
 
-match_append_lit _ = Nothing
+match_append_lit _ _ = Nothing
 
 ---------------------------------------------------
 -- The rule is this:
 -- 	eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
 
-match_eq_string :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
-match_eq_string [Var unpk1 `App` Lit (MachStr s1),
-		 Var unpk2 `App` Lit (MachStr s2)]
+match_eq_string :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
+match_eq_string _ [Var unpk1 `App` Lit (MachStr s1),
+		   Var unpk2 `App` Lit (MachStr s2)]
   | unpk1 `hasKey` unpackCStringIdKey,
     unpk2 `hasKey` unpackCStringIdKey
   = Just (if s1 == s2 then trueVal else falseVal)
 
-match_eq_string _ = Nothing
+match_eq_string _ _ = Nothing
 
 
 ---------------------------------------------------
 -- The rule is this:
 --	inline f_ty (f a b c) = <f's unfolding> a b c
--- (if f has an unfolding)
+-- (if f has an unfolding, EVEN if it's a loop breaker)
 --
 -- It's important to allow the argument to 'inline' to have args itself
 -- (a) because its more forgiving to allow the programmer to write
@@ -558,11 +591,13 @@ match_eq_string _ = Nothing
 --     programmer can't avoid
 --
 -- Also, don't forget about 'inline's type argument!
-match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
-match_inline (Type _ : e : _)
+match_inline :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
+match_inline _ (Type _ : e : _)
   | (Var f, args1) <- collectArgs e,
-    Just unf <- maybeUnfoldingTemplate (idUnfolding f)
+    Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)
+    	     -- Ignore the IdUnfoldingFun here!
   = Just (mkApps unf args1)
 
-match_inline _ = Nothing
+match_inline _ _ = Nothing
 \end{code}
+