X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fprelude%2FPrelRules.lhs;h=dff38e666ae8ce5b38e52716d7b25158ca5a602d;hb=d2cca44eae15bbbd3b86889448e796bc785dfa52;hp=bdf3627bcb0c259b446ad8e4a14e6ea09adf5cba;hpb=41cd7a86fa1748718faac4e12f359b7fa61c088b;p=ghc-hetmet.git diff --git a/ghc/compiler/prelude/PrelRules.lhs b/ghc/compiler/prelude/PrelRules.lhs index bdf3627..dff38e6 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,44 +17,29 @@ module PrelRules ( primOpRule, builtinRules ) where #include "HsVersions.h" import CoreSyn -import Rules ( ProtoCoreRule(..) ) -import Id ( idUnfolding, mkWildId, isDataConId_maybe ) +import Id ( mkWildId ) import Literal ( Literal(..), isLitLitLit, mkMachInt, mkMachWord - , inIntRange, inWordRange, literalType + , 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 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 @@ -197,12 +186,12 @@ cmpOp cmp name l1 l2 negOp name (MachFloat f) = Just (name, mkFloatVal (-f)) negOp name (MachDouble d) = Just (name, mkDoubleVal (-d)) -negOp name l@(MachInt i) = intResult name (ppr l) (-i) +negOp name l@(MachInt i) = intResult name (-i) negOp name l = Nothing -------------------------- intOp2 op name l1@(MachInt i1) l2@(MachInt i2) - = intResult name (ppr l1 <+> ppr l2) (i1 `op` i2) + = intResult name (i1 `op` i2) intOp2 op name l1 l2 = Nothing -- Could find LitLit intOp2Z op name (MachInt i1) (MachInt i2) @@ -212,8 +201,7 @@ intOp2Z op name l1 l2 = Nothing -- LitLit or zero dividend -------------------------- -- Integer is not an instance of Bits, so we operate on Word64 wordBitOp2 op name l1@(MachWord w1) l2@(MachWord w2) - = wordResult name (ppr l1 <+> ppr l2) - ((fromIntegral::Word64->Integer) (fromIntegral w1 `op` fromIntegral w2)) + = Just (name, mkWordVal ((fromIntegral::Word64->Integer) (fromIntegral w1 `op` fromIntegral w2))) wordBitOp2 op name l1 l2 = Nothing -- Could find LitLit wordOp2Z op name (MachWord w1) (MachWord w2) @@ -276,31 +264,14 @@ do_lit_eq is_eq name lit expr val_if_neq | is_eq = falseVal | otherwise = trueVal --- TODO: Merge intResult/wordResult -intResult name pp_args result - | not (inIntRange result) - -- Better tell the user that we've overflowed... - -- ..not that it stops us from actually folding! - - = pprTrace "Warning:" (text "Integer overflow in:" <+> ppr name <+> pp_args) - Just (name, mkIntVal (squashInt result)) - - | otherwise - = Just (name, mkIntVal result) - -wordResult name pp_args result - | not (inWordRange result) - -- Better tell the user that we've overflowed... - -- ..not that it stops us from actually folding! - - = pprTrace "Warning:" (text "Word overflow in:" <+> ppr name <+> pp_args) - Just (name, mkWordVal (squashInt result)) - - | otherwise - = Just (name, mkWordVal result) - -squashInt :: Integer -> Integer -- Squash into Int range -squashInt i = toInteger ((fromInteger i)::Int) +-- Note that we *don't* warn the user about overflow. It's not done at +-- 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... :-( +intResult :: RuleName -> Integer -> Maybe (RuleName, CoreExpr) +intResult name result + = Just (name, mkIntVal (toInteger ((fromInteger result)::Int))) \end{code} @@ -314,26 +285,33 @@ squashInt i = toInteger ((fromInteger i)::Int) 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} @@ -444,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),