X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fprelude%2FPrelRules.lhs;h=8b3f2d9256b3bb09c0a250a132dc0c1a558ff257;hb=e6dff21dfefdae928aa1577a294595865f8c22f6;hp=4e502568d178626d219cec28c1c30e8438f6f1f9;hpb=d781517f7a6f2db7d7a009f96376378d050c02ab;p=ghc-hetmet.git

diff --git a/ghc/compiler/prelude/PrelRules.lhs b/ghc/compiler/prelude/PrelRules.lhs
index 4e50256..8b3f2d9 100644
--- a/ghc/compiler/prelude/PrelRules.lhs
+++ b/ghc/compiler/prelude/PrelRules.lhs
@@ -3,6 +3,10 @@
 %
 \section[ConFold]{Constant Folder}
 
+Conceptually, constant folding should be parameterized with the kind
+of target machine to get identical behaviour during compilation time
+and runtime. We cheat a little bit here...
+
 ToDo:
    check boundaries before folding, e.g. we can fold the Float addition
    (i1 + i2) only if it results	in a valid Float.
@@ -13,43 +17,29 @@ module PrelRules ( primOpRule, builtinRules ) where
 #include "HsVersions.h"
 
 import CoreSyn
-import Rules		( ProtoCoreRule(..) )
-import Id		( idUnfolding, mkWildId, isDataConId_maybe )
-import Literal		( Literal(..), isLitLitLit, mkMachInt, mkMachWord, literalType
+import Id		( mkWildId )
+import Literal		( Literal(..), isLitLitLit, mkMachInt, mkMachWord
+			, literalType
 			, word2IntLit, int2WordLit, char2IntLit, int2CharLit
 			, float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
 			, addr2IntLit, int2AddrLit, float2DoubleLit, double2FloatLit
 			)
-import RdrName		( RdrName )
 import PrimOp		( PrimOp(..), primOpOcc )
 import TysWiredIn	( trueDataConId, falseDataConId )
 import TyCon		( tyConDataConsIfAvailable, isEnumerationTyCon, isNewTyCon )
-import DataCon		( DataCon, dataConTag, dataConRepArity, dataConTyCon, dataConId, fIRST_TAG )
-import CoreUnfold	( maybeUnfoldingTemplate )
+import DataCon		( dataConTag, dataConTyCon, dataConId, fIRST_TAG )
 import CoreUtils	( exprIsValue, cheapEqExpr, exprIsConApp_maybe )
-import Type		( splitTyConApp_maybe )
+import Type		( tyConAppTyCon )
 import OccName		( occNameUserString)
-import PrelNames	( unpackCStringFoldr_RDR )
-import Unique		( unpackCStringFoldrIdKey, hasKey )
-import Maybes		( maybeToBool )
-import Char		( ord, chr )
+import PrelNames	( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey )
+import Name		( Name )
 import Bits		( Bits(..) )
-import PrelAddr		( wordToInt )
 import Word		( Word64 )
 import Outputable
-
-#if __GLASGOW_HASKELL__ > 405
-import PrelAddr ( intToWord )
-#else
-import PrelAddr ( Word(..) )
-import PrelGHC  ( int2Word# )
-intToWord :: Int -> Word
-intToWord (I# i#) = W# (int2Word# i#)
-#endif
+import CmdLineOpts      ( opt_SimplExcessPrecision )
 \end{code}
 
 
-
 \begin{code}
 primOpRule :: PrimOp -> CoreRule
 primOpRule op 
@@ -295,26 +285,33 @@ intResult name result
 type RuleFun = [CoreExpr] -> Maybe (RuleName, CoreExpr)
 
 or_rule :: RuleFun -> RuleFun -> RuleFun
-or_rule r1 r2 args = case r1 args of
-		   Just stuff -> Just stuff
-		   Nothing    -> r2 args
+or_rule r1 r2 args = maybe (r2 args) Just (r1 args) -- i.e.: r1 args `mplus` r2 args
 
 twoLits :: (Literal -> Literal -> Maybe (RuleName, CoreExpr)) -> RuleFun
-twoLits rule [Lit l1, Lit l2] = rule l1 l2
+twoLits rule [Lit l1, Lit l2] = rule (convFloating l1) (convFloating l2)
 twoLits rule other	      = Nothing
 
 oneLit :: (Literal -> Maybe (RuleName, CoreExpr)) -> RuleFun
-oneLit rule [Lit l1] = rule l1
+oneLit rule [Lit l1] = rule (convFloating l1)
 oneLit rule other    = Nothing
 
+-- When excess precision is not requested, cut down the precision of the
+-- Rational value to that of Float/Double. We confuse host architecture
+-- and target architecture here, but it's convenient (and wrong :-).
+convFloating :: Literal -> Literal
+convFloating (MachFloat  f) | not opt_SimplExcessPrecision =
+   MachFloat  (toRational ((fromRational f) :: Float ))
+convFloating (MachDouble d) | not opt_SimplExcessPrecision =
+   MachDouble (toRational ((fromRational d) :: Double))
+convFloating l = l
+
 
 trueVal       = Var trueDataConId
 falseVal      = Var falseDataConId
 mkIntVal    i = Lit (mkMachInt  i)
 mkWordVal   w = Lit (mkMachWord w)
-mkCharVal   c = Lit (MachChar   c)
-mkFloatVal  f = Lit (MachFloat  f)
-mkDoubleVal d = Lit (MachDouble d)
+mkFloatVal  f = Lit (convFloating (MachFloat  f))
+mkDoubleVal d = Lit (convFloating (MachDouble d))
 \end{code}
 
 						
@@ -395,8 +392,8 @@ tagToEnumRule [Type ty, Lit (MachInt i)]
 		     Just (SLIT("TagToEnum"), Var (dataConId dc))
   where 
     correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
-    tag = fromInteger i
-    (Just (tycon,_)) = splitTyConApp_maybe ty
+    tag   = fromInteger i
+    tycon = tyConAppTyCon ty
 
 tagToEnumRule other = Nothing
 \end{code}
@@ -425,14 +422,15 @@ dataToTagRule other = Nothing
 %************************************************************************
 
 \begin{code}
-builtinRules :: [(RdrName, CoreRule)]
+builtinRules :: [(Name, CoreRule)]
 -- Rules for non-primops that can't be expressed using a RULE pragma
 builtinRules
-  = [ (unpackCStringFoldr_RDR, BuiltinRule match_append_lit_str)
+  = [ (unpackCStringFoldrName, BuiltinRule match_append_lit_str)
     ]
 
 
--- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)  =  unpackFoldrCString# "foobaz" c n
+-- The rule is this:
+-- 	unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)  =  unpackFoldrCString# "foobaz" c n
 
 match_append_lit_str [Type ty1,
 		      Lit (MachStr s1),