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

diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs
index 67eb06f..4ca4462 100644
--- a/compiler/prelude/PrelRules.lhs
+++ b/compiler/prelude/PrelRules.lhs
@@ -21,7 +21,7 @@ module PrelRules ( primOpRules, builtinRules ) where
 
 import CoreSyn
 import MkCore		( mkWildCase )
-import Id		( idUnfolding )
+import Id		( realIdUnfolding )
 import Literal		( Literal(..), mkMachInt, mkMachWord
 			, literalType
 			, word2IntLit, int2WordLit
@@ -35,7 +35,8 @@ import PrimOp		( PrimOp(..), tagToEnumKey )
 import TysWiredIn	( boolTy, trueDataConId, falseDataConId )
 import TyCon		( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon )
 import DataCon		( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG )
-import CoreUtils	( cheapEqExpr, exprIsConApp_maybe )
+import CoreUtils	( cheapEqExpr )
+import CoreUnfold	( exprIsConApp_maybe )
 import Type		( tyConAppTyCon, coreEqType )
 import OccName		( occNameFS )
 import PrelNames	( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey,
@@ -45,6 +46,8 @@ 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 +293,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 +308,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 +347,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 +364,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 +382,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 +396,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
@@ -425,8 +438,8 @@ mkDoubleVal d = Lit (convFloating (MachDouble d))
 %************************************************************************
 
 \begin{code}
-tagToEnumRule :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
-tagToEnumRule [Type ty, Lit (MachInt i)]
+tagToEnumRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
+tagToEnumRule _ [Type ty, Lit (MachInt i)]
   = ASSERT( isEnumerationTyCon tycon ) 
     case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of
 
@@ -439,7 +452,7 @@ 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 
@@ -448,18 +461,18 @@ For dataToTag#, we can reduce if either
 	(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}
 
 %************************************************************************
@@ -512,15 +525,15 @@ 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
-		  ]
+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 +542,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 +571,12 @@ 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}