#include "HsVersions.h"
import CoreSyn
-import Id ( mkWildId )
-import Literal ( Literal(..), isLitLitLit, mkMachInt, mkMachWord
+import Id ( mkWildId, isPrimOpId_maybe )
+import Literal ( Literal(..), mkMachInt, mkMachWord
, literalType
, word2IntLit, int2WordLit
, narrow8IntLit, narrow16IntLit, narrow32IntLit
, narrow8WordLit, narrow16WordLit, narrow32WordLit
, char2IntLit, int2CharLit
, float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
- , nullAddrLit, float2DoubleLit, double2FloatLit
+ , float2DoubleLit, double2FloatLit
)
import PrimOp ( PrimOp(..), primOpOcc )
-import TysWiredIn ( trueDataConId, falseDataConId )
-import TyCon ( tyConDataConsIfAvailable, isEnumerationTyCon, isNewTyCon )
-import DataCon ( dataConTag, dataConTyCon, dataConId, fIRST_TAG )
-import CoreUtils ( exprIsValue, cheapEqExpr, exprIsConApp_maybe )
-import Type ( tyConAppTyCon, eqType )
-import OccName ( occNameUserString)
-import PrelNames ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey )
+import TysWiredIn ( boolTy, trueDataConId, falseDataConId )
+import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon )
+import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG )
+import CoreUtils ( cheapEqExpr, exprIsConApp_maybe )
+import Type ( tyConAppTyCon, coreEqType )
+import OccName ( occNameFS )
+import PrelNames ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey,
+ eqStringName, unpackCStringIdKey )
+import Maybes ( orElse )
import Name ( Name )
-import Bits ( Bits(..) )
+import Outputable
+import FastString
+import StaticFlags ( opt_SimplExcessPrecision )
+
+import DATA_BITS ( Bits(..) )
#if __GLASGOW_HASKELL__ >= 500
-import Word ( Word )
+import DATA_WORD ( Word )
#else
-import Word ( Word64 )
+import DATA_WORD ( Word64 )
#endif
-import Outputable
-import CmdLineOpts ( opt_SimplExcessPrecision )
\end{code}
\begin{code}
-primOpRules :: PrimOp -> [CoreRule]
-primOpRules op = primop_rule op
+primOpRules :: PrimOp -> Name -> [CoreRule]
+primOpRules op op_name = primop_rule op
where
- op_name = _PK_ (occNameUserString (primOpOcc op))
- op_name_case = op_name _APPEND_ SLIT("->case")
+ rule_name = occNameFS (primOpOcc op)
+ rule_name_case = rule_name `appendFS` FSLIT("->case")
-- A useful shorthand
- one_rule rule_fn = [BuiltinRule op_name rule_fn]
+ one_rule rule_fn = [BuiltinRule { ru_name = rule_name,
+ ru_fn = op_name,
+ ru_try = rule_fn }]
+ case_rule rule_fn = [BuiltinRule { ru_name = rule_name_case,
+ ru_fn = op_name,
+ ru_try = rule_fn }]
-- ToDo: something for integer-shift ops?
-- NotOp
- primop_rule AddrNullOp = one_rule nullAddrRule
- primop_rule SeqOp = one_rule seqRule
primop_rule TagToEnumOp = one_rule tagToEnumRule
primop_rule DataToTagOp = one_rule dataToTagRule
primop_rule DoubleNegOp = one_rule (oneLit negOp)
-- Relational operators
- primop_rule IntEqOp = [BuiltinRule op_name (relop (==)), BuiltinRule op_name_case (litEq True)]
- primop_rule IntNeOp = [BuiltinRule op_name (relop (/=)), BuiltinRule op_name_case (litEq False)]
- primop_rule CharEqOp = [BuiltinRule op_name (relop (==)), BuiltinRule op_name_case (litEq True)]
- primop_rule CharNeOp = [BuiltinRule op_name (relop (/=)), BuiltinRule op_name_case (litEq False)]
+ primop_rule IntEqOp = one_rule (relop (==)) ++ case_rule (litEq True)
+ primop_rule IntNeOp = one_rule (relop (/=)) ++ case_rule (litEq False)
+ primop_rule CharEqOp = one_rule (relop (==)) ++ case_rule (litEq True)
+ primop_rule CharNeOp = one_rule (relop (/=)) ++ case_rule (litEq False)
primop_rule IntGtOp = one_rule (relop (>))
primop_rule IntGeOp = one_rule (relop (>=))
%* *
%************************************************************************
- IMPORTANT NOTE
-
-In all these operations we might find a LitLit as an operand; that's
-why we have the catch-all Nothing case.
+ToDo: the reason these all return Nothing is because there used to be
+the possibility of an argument being a litlit. Litlits are now gone,
+so this could be cleaned up.
\begin{code}
--------------------------
litCoerce :: (Literal -> Literal) -> Literal -> Maybe CoreExpr
-litCoerce fn lit | isLitLitLit lit = Nothing
- | otherwise = Just (Lit (fn lit))
+litCoerce fn lit = Just (Lit (fn lit))
--------------------------
cmpOp :: (Ordering -> Bool) -> Literal -> Literal -> Maybe CoreExpr
--------------------------
-negOp (MachFloat f) = Just (mkFloatVal (-f))
-negOp (MachDouble d) = Just (mkDoubleVal (-d))
-negOp (MachInt i) = intResult (-i)
-negOp l = Nothing
+negOp (MachFloat 0.0) = Nothing -- can't represent -0.0 as a Rational
+negOp (MachFloat f) = Just (mkFloatVal (-f))
+negOp (MachDouble 0.0) = Nothing
+negOp (MachDouble d) = Just (mkDoubleVal (-d))
+negOp (MachInt i) = intResult (-i)
+negOp l = Nothing
--------------------------
intOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` i2)
litEq is_eq other = Nothing
do_lit_eq is_eq lit expr
- = Just (Case expr (mkWildId (literalType lit))
+ = Just (Case expr (mkWildId (literalType lit)) boolTy
[(DEFAULT, [], val_if_neq),
(LitAlt lit, [], val_if_eq)])
where
\begin{code}
type RuleFun = [CoreExpr] -> Maybe CoreExpr
-or_rule :: RuleFun -> RuleFun -> RuleFun
-or_rule r1 r2 args = maybe (r2 args) Just (r1 args) -- i.e.: r1 args `mplus` r2 args
-
twoLits :: (Literal -> Literal -> Maybe CoreExpr) -> RuleFun
twoLits rule [Lit l1, Lit l2] = rule (convFloating l1) (convFloating l2)
twoLits rule _ = Nothing
mkDoubleVal d = Lit (convFloating (MachDouble d))
\end{code}
-\begin{code}
-nullAddrRule _ = Just(Lit nullAddrLit)
-\end{code}
-
%************************************************************************
%* *
%* *
%************************************************************************
-In the parallel world, we use _seq_ to control the order in which
-certain expressions will be evaluated. Operationally, the expression
-``_seq_ a b'' evaluates a and then evaluates b. We have an inlining
-for _seq_ which translates _seq_ to:
-
- _seq_ = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y }
-
-Now, we know that the seq# primitive will never return 0#, but we
-don't let the simplifier know that. We also use a special error
-value, parError#, which is *not* a bottoming Id, so as far as the
-simplifier is concerned, we have to evaluate seq# a before we know
-whether or not y will be evaluated.
-
-If we didn't have the extra case, then after inlining the compiler might
-see:
- f p q = case seq# p of { _ -> p+q }
-
-If it sees that, it can see that f is strict in q, and hence it might
-evaluate q before p! The "0# ->" case prevents this happening.
-By having the parError# branch we make sure that anything in the
-other branch stays there!
-
-This is fine, but we'd like to get rid of the extraneous code. Hence,
-we *do* let the simplifier know that seq# is strict in its argument.
-As a result, we hope that `a' will be evaluated before seq# is called.
-At this point, we have a very special and magical simpification which
-says that ``seq# a'' can be immediately simplified to `1#' if we
-know that `a' is already evaluated.
-
-NB: If we ever do case-floating, we have an extra worry:
-
- case a of
- a' -> let b' = case seq# a of { True -> b; False -> parError# }
- in case b' of ...
-
- =>
-
- case a of
- a' -> let b' = case True of { True -> b; False -> parError# }
- in case b' of ...
-
- =>
-
- case a of
- a' -> let b' = b
- in case b' of ...
-
- =>
-
- case a of
- a' -> case b of ...
-
-The second case must never be floated outside of the first!
-
-\begin{code}
-seqRule [Type ty, arg] | exprIsValue arg = Just (mkIntVal 1)
-seqRule other = Nothing
-\end{code}
-
-
\begin{code}
tagToEnumRule [Type ty, Lit (MachInt i)]
= ASSERT( isEnumerationTyCon tycon )
- case filter correct_tag (tyConDataConsIfAvailable tycon) of
+ case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of
[] -> Nothing -- Abstract type
(dc:rest) -> ASSERT( null rest )
- Just (Var (dataConId dc))
+ Just (Var (dataConWorkId dc))
where
correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
tag = fromInteger i
(b) the argument is a variable whose unfolding is a known constructor
\begin{code}
-dataToTagRule [_, val_arg]
- = case exprIsConApp_maybe val_arg of
- Just (dc,_) -> ASSERT( not (isNewTyCon (dataConTyCon dc)) )
- Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))
+dataToTagRule [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag]
+ | Just TagToEnumOp <- isPrimOpId_maybe tag_to_enum
+ , ty1 `coreEqType` ty2
+ = Just tag -- dataToTag (tagToEnum x) ==> x
- other -> Nothing
+dataToTagRule [_, val_arg]
+ | Just (dc,_) <- exprIsConApp_maybe val_arg
+ = ASSERT( not (isNewTyCon (dataConTyCon dc)) )
+ Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))
dataToTagRule other = Nothing
\end{code}
%************************************************************************
\begin{code}
-builtinRules :: [(Name, CoreRule)]
+builtinRules :: [CoreRule]
-- Rules for non-primops that can't be expressed using a RULE pragma
builtinRules
- = [ (unpackCStringFoldrName, BuiltinRule SLIT("AppendLitString") match_append_lit_str)
+ = [ BuiltinRule FSLIT("AppendLitString") unpackCStringFoldrName match_append_lit,
+ BuiltinRule FSLIT("EqString") eqStringName match_eq_string
]
-- The rule is this:
-- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) = unpackFoldrCString# "foobaz" c n
-match_append_lit_str [Type ty1,
- Lit (MachStr s1),
- c1,
- Var unpk `App` Type ty2
- `App` Lit (MachStr s2)
- `App` c2
- `App` n
- ]
+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 `eqType` ty2 )
+ = ASSERT( ty1 `coreEqType` ty2 )
Just (Var unpk `App` Type ty1
- `App` Lit (MachStr (s1 _APPEND_ s2))
+ `App` Lit (MachStr (s1 `appendFS` s2))
`App` c1
`App` n)
-match_append_lit_str other = Nothing
+match_append_lit other = Nothing
+
+-- The rule is this:
+-- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
+
+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 other = Nothing
\end{code}
projects / ghc-hetmet.git / blobdiff