Commit 5ca77490 authored by simonpj's avatar simonpj
Browse files

[project @ 2000-01-04 17:40:46 by simonpj]

This commit arranges that literal strings will fuse
nicely, by expressing them as an application of build.

* NoRepStr is now completely redundant, though I havn't removed it yet.

* The unpackStr stuff moves from PrelPack to PrelBase.

* There's a new form of Rule, a BuiltinRule, for rules that
  can't be expressed in Haskell.  The string-fusion rule is one
  such.  It's defined in prelude/PrelRules.lhs.

* PrelRules.lhs also contains a great deal of code that
  implements constant folding.  In due course this will replace
  ConFold.lhs, but for the moment it simply duplicates it.
parent a8b0e4a2
add types/InstEnv, InstEnv.hi-boot
add coreSyn/CoreRules.*
add coreSyn/CoreTidy.lhs
add coreSyn/CoreFVs.lhs
remove coreSyn/FreeVars.lhs
add coreSyn/Subst.*
remove simplCore/MagicUFs.*
remove specialise/SpecEnv.*
ToDo
~~~~
* Test effect of eta-expanding past (case x of ..)
* Bottom strictness isn't right. Should be (eg) SSX, not just X.
* Enumeration types in worker/wrapper for strictness analysis
* Use (!) types in data cons to unbox.
* Check constant folding
* .hi file isn't updated if the only change is to the exports.
For example, UgenAll.lhs re-exports all of U_binding.hs; when a data type
decl in the latter changes, the .hi file for the former isn't updated.
I think this happens when a module exports another mdodule thus:
module UgenAll( module U_binding, ... ) where
* This should be reported as an error:
data T k = MkT (k Int#)
* Bogus report of overlapped pattern for
f (R {field = [c]}) = 1
f (R {}) = 2
This shows up for TyCon.maybeTyConSingleCon
* > module Main( main ) where
> f :: String -> Int
> f "=<" = 0
> f "=" = 0
> g :: [Char] -> Int
> g ['=','<'] = 0
> g ['='] = 0
> main = return ()
For ``f'' the following is reported.
tmp.lhs:4:
Pattern match(es) are overlapped in the definition of function `f'
"=" = ...
There are no complaints for definition for ``g''.
* Without -O I don't think we need change the module version
if the usages change; I forget why it changes even with -O
* Record selectors for existential type; no good! What to do?
Record update doesn't make sense either.
Need to be careful when figuring out strictness, and when generating
worker-wrapper split.
Also when deriving.
* Consructor re-use via CSE
Notes on module dependencies
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -32,7 +32,7 @@ module Id (
isSpecPragmaId, isRecordSelector,
isPrimitiveId_maybe, isDataConId_maybe,
isConstantId, isBottomingId, idAppIsBottom,
isConstantId, isConstantId_maybe, isBottomingId, idAppIsBottom,
isExportedId, isUserExportedId,
mayHaveNoBinding,
......@@ -217,6 +217,10 @@ isConstantId id = case idFlavour id of
ConstantId _ -> True
other -> False
isConstantId_maybe id = case idFlavour id of
ConstantId const -> Just const
other -> Nothing
isSpecPragmaId id = case idFlavour id of
SpecPragmaId -> True
other -> False
......
......@@ -39,6 +39,8 @@ import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy,
)
import TysWiredIn ( boolTy, charTy, mkListTy )
import PrelMods ( pREL_ERR, pREL_GHC )
import PrelRules ( primOpRule )
import Rules ( addRule )
import Type ( Type, ThetaType,
mkDictTy, mkTyConApp, mkTyVarTys, mkFunTys, mkFunTy, mkSigmaTy,
isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfTypes,
......@@ -59,7 +61,7 @@ import Name ( mkDerivedName, mkWiredInIdName, mkLocalName,
Name, NamedThing(..),
)
import OccName ( mkSrcVarOcc )
import PrimOp ( PrimOp(DataToTagOp), primOpSig, mkPrimOpIdName )
import PrimOp ( PrimOp(DataToTagOp), primOpSig, mkPrimOpIdName, primOpArity, primOpStrictness )
import Demand ( wwStrict )
import DataCon ( DataCon, StrictnessMark(..), dataConStrictMarks, dataConFieldLabels,
dataConArgTys, dataConSig, dataConRawArgTys
......@@ -70,7 +72,7 @@ import Id ( idType, mkId,
)
import IdInfo ( vanillaIdInfo, mkIdInfo,
exactArity, setUnfoldingInfo, setCafInfo,
setArityInfo, setInlinePragInfo,
setArityInfo, setInlinePragInfo, setSpecInfo,
mkStrictnessInfo, setStrictnessInfo,
IdFlavour(..), InlinePragInfo(..), CafInfo(..), IdInfo
)
......@@ -422,6 +424,20 @@ mkPrimitiveId prim_op
info = mkIdInfo (ConstantId (PrimOp prim_op))
`setUnfoldingInfo` unfolding
-- Not yet...
-- `setSpecInfo` rules
-- `setArityInfo` exactArity arity
-- `setStrictnessInfo` strict_info
arity = primOpArity prim_op
(dmds, result_bot) = primOpStrictness prim_op
strict_info = mkStrictnessInfo (take arity dmds, result_bot)
-- primOpStrictness can return an infinite list of demands
-- (cheap hack) but Ids mustn't have such things.
-- What a mess.
rules = addRule id emptyCoreRules (primOpRule prim_op)
unfolding = mkCompulsoryUnfolding rhs
-- The mkCompulsoryUnfolding says that this Id absolutely
-- must be inlined. It's only used for primitives,
......
......@@ -144,6 +144,7 @@ rulesSomeFreeVars interesting (Rules rules _)
= foldr (unionVarSet . ruleSomeFreeVars interesting) emptyVarSet rules
ruleSomeFreeVars :: InterestingVarFun -> CoreRule -> IdOrTyVarSet
ruleSomeFreeVars interesting (BuiltinRule _) = noFVs
ruleSomeFreeVars interesting (Rule _ tpl_vars tpl_args rhs)
= rule_fvs interesting emptyVarSet
where
......@@ -151,6 +152,7 @@ ruleSomeFreeVars interesting (Rule _ tpl_vars tpl_args rhs)
foldr (union . expr_fvs) (expr_fvs rhs) tpl_args
ruleSomeLhsFreeVars :: InterestingVarFun -> CoreRule -> IdOrTyVarSet
ruleSomeLhsFreeVars fn (BuiltinRule _) = noFVs
ruleSomeLhsFreeVars fn (Rule _ tpl_vars tpl_args rhs)
= foldl delVarSet (exprsSomeFreeVars fn tpl_args) tpl_vars
\end{code}
......
......@@ -11,7 +11,7 @@ module CoreSyn (
mkLets, mkLams,
mkApps, mkTyApps, mkValApps, mkVarApps,
mkLit, mkStringLit, mkConApp, mkPrimApp, mkNote,
mkLit, mkStringLit, mkStringLitFS, mkConApp, mkPrimApp, mkNote,
bindNonRec, mkIfThenElse, varToCoreExpr,
bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, isDeadBinder, isTyVar, isId,
......@@ -34,6 +34,7 @@ module CoreSyn (
-- Core rules
CoreRules(..), -- Representation needed by friends
CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only
RuleName,
emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules
) where
......@@ -46,8 +47,9 @@ import VarEnv
import Id ( mkWildId, getIdOccInfo, idInfo )
import Type ( Type, UsageAnn, mkTyVarTy, isUnLiftedType, seqType )
import IdInfo ( OccInfo(..), megaSeqIdInfo )
import Const ( Con(..), DataCon, Literal(NoRepStr), PrimOp )
import Const ( Con(..), DataCon, Literal(MachStr), mkMachInt, PrimOp )
import TysWiredIn ( trueDataCon, falseDataCon )
import ThinAir ( unpackCStringId, unpackCString2Id, addr2IntegerId )
import VarSet
import Outputable
\end{code}
......@@ -118,12 +120,18 @@ data CoreRules
= Rules [CoreRule]
IdOrTyVarSet -- Locally-defined free vars of RHSs
type RuleName = FAST_STRING
data CoreRule
= Rule FAST_STRING -- Rule name
= Rule RuleName
[CoreBndr] -- Forall'd variables
[CoreExpr] -- LHS args
CoreExpr -- RHS
| BuiltinRule -- Built-in rules are used for constant folding
-- and suchlike. It has no free variables.
([CoreExpr] -> Maybe (RuleName, CoreExpr))
emptyCoreRules :: CoreRules
emptyCoreRules = Rules [] emptyVarSet
......@@ -184,16 +192,32 @@ mkTyApps f args = foldl (\ e a -> App e (Type a)) f args
mkValApps f args = foldl (\ e a -> App e a) f args
mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
mkLit :: Literal -> Expr b
mkStringLit :: String -> Expr b
mkConApp :: DataCon -> [Arg b] -> Expr b
mkPrimApp :: PrimOp -> [Arg b] -> Expr b
mkLit :: Literal -> Expr b
mkStringLit :: String -> Expr b
mkStringLitFS :: FAST_STRING -> Expr b
mkConApp :: DataCon -> [Arg b] -> Expr b
mkPrimApp :: PrimOp -> [Arg b] -> Expr b
mkLit lit = Con (Literal lit) []
mkStringLit str = Con (Literal (NoRepStr (_PK_ str) stringTy)) []
mkConApp con args = Con (DataCon con) args
mkPrimApp op args = Con (PrimOp op) args
mkStringLit str = mkStringLitFS (_PK_ str)
mkStringLitFS str
| any is_NUL (_UNPK_ str)
= -- Must cater for NULs in literal string
mkApps (Var unpackCString2Id)
[mkLit (MachStr str),
mkLit (mkMachInt (toInteger (_LENGTH_ str)))]
| otherwise
= -- No NULs in the string
App (Var unpackCStringId) (mkLit (MachStr str))
where
is_NUL c = c == '\0'
varToCoreExpr :: CoreBndr -> CoreExpr
varToCoreExpr v | isId v = Var v
| otherwise = Type (mkTyVarTy v)
......@@ -430,6 +454,7 @@ seqRules (Rules rules fvs) = seq_rules rules `seq` seqVarSet fvs
seq_rules [] = ()
seq_rules (Rule fs bs es e : rules) = seqBndrs bs `seq` seqExprs (e:es) `seq` seq_rules rules
seq_rules (BuiltinRule _ : rules) = seq_rules rules
\end{code}
\begin{code}
......
......@@ -252,6 +252,7 @@ tidyRules env (Rules rules fvs)
tidy_set_elem var new_set = extendVarSet new_set (tidyVarOcc env var)
tidyRule :: TidyEnv -> CoreRule -> CoreRule
tidyRule env rule@(BuiltinRule _) = rule
tidyRule env (Rule name vars tpl_args rhs)
= (Rule name vars' (map (tidyExpr env') tpl_args) (tidyExpr env' rhs))
where
......
......@@ -49,7 +49,8 @@ import OccurAnal ( occurAnalyseGlobalExpr )
import BinderInfo ( )
import CoreUtils ( coreExprType, exprIsTrivial, exprIsValue, exprIsCheap )
import Id ( Id, idType, idUnique, isId, getIdWorkerInfo,
getIdSpecialisation, getInlinePragma, getIdUnfolding
getIdSpecialisation, getInlinePragma, getIdUnfolding,
isConstantId_maybe
)
import VarSet
import Name ( isLocallyDefined )
......@@ -277,7 +278,7 @@ sizeExpr :: Int -- Bomb out if it gets bigger than this
-> CoreExpr
-> ExprSize
sizeExpr (I# bOMB_OUT_SIZE) args expr
sizeExpr (I# bOMB_OUT_SIZE) top_args expr
= size_up expr
where
size_up (Type t) = sizeZero -- Types cost nothing
......@@ -288,7 +289,7 @@ sizeExpr (I# bOMB_OUT_SIZE) args expr
size_up (App fun (Type t)) = size_up fun
size_up (App fun arg) = size_up_app fun [arg]
size_up (Con con args) = foldr (addSize . size_up)
size_up (Con con args) = foldr (addSize . nukeScrutDiscount . size_up)
(size_up_con con args)
args
......@@ -324,16 +325,25 @@ sizeExpr (I# bOMB_OUT_SIZE) args expr
------------
size_up_app (App fun arg) args = size_up_app fun (arg:args)
size_up_app fun args = foldr (addSize . nukeScrutDiscount . size_up)
(size_up_fun fun)
(size_up_fun fun args)
args
-- A function application with at least one value argument
-- so if the function is an argument give it an arg-discount
-- Also behave specially if the function is a build
size_up_fun (Var fun) | idUnique fun == buildIdKey = buildSize
| idUnique fun == augmentIdKey = augmentSize
| fun `is_elem` args = scrutArg fun `addSize` sizeOne
size_up_fun other = size_up other
-- Also if the function is a constant Id (constr or primop)
-- compute discounts as if it were actually a Con; in the early
-- stages these constructors and primops may not yet be inlined
size_up_fun (Var fun) args | idUnique fun == buildIdKey = buildSize
| idUnique fun == augmentIdKey = augmentSize
| fun `is_elem` top_args = scrutArg fun `addSize` fun_size
| otherwise = fun_size
where
fun_size = case isConstantId_maybe fun of
Just con -> size_up_con con args
Nothing -> sizeOne
size_up_fun other args = size_up other
------------
size_up_alt (con, bndrs, rhs) = size_up rhs
......@@ -353,8 +363,8 @@ sizeExpr (I# bOMB_OUT_SIZE) args expr
| otherwise = opt_UF_DearOp
-- We want to record if we're case'ing, or applying, an argument
arg_discount (Var v) | v `is_elem` args = scrutArg v
arg_discount other = sizeZero
arg_discount (Var v) | v `is_elem` top_args = scrutArg v
arg_discount other = sizeZero
------------
is_elem :: Id -> [Id] -> Bool
......@@ -529,7 +539,11 @@ callSiteInline black_listed inline_call occ id arg_infos interesting_cont
= case getIdUnfolding id of {
NoUnfolding -> Nothing ;
OtherCon _ -> Nothing ;
CompulsoryUnfolding unf_template -> Just unf_template ;
CompulsoryUnfolding unf_template | black_listed -> Nothing
| otherwise -> Just unf_template ;
-- Primops have compulsory unfoldings, but
-- may have rules, in which case they are
-- black listed till later
CoreUnfolding unf_template is_top is_cheap _ guidance ->
let
......@@ -701,7 +715,7 @@ blackListed rule_vars (Just 0)
-- local inlinings first. For example in fish/Main.hs
-- it's advantageous to inline scale_vec2 before inlining
-- wrappers from PrelNum that make it look big.
not (isLocallyDefined v) -- This seems best at the moment
not (isLocallyDefined v) || normal_case rule_vars 0 v -- This seems best at the moment
blackListed rule_vars (Just phase)
= \v -> normal_case rule_vars phase v
......
......@@ -27,11 +27,12 @@ import Var ( IdOrTyVar, isId, isTyVar )
import VarSet
import VarEnv
import Name ( isLocallyDefined, hashName )
import Const ( Con, isWHNFCon, conIsTrivial, conIsCheap, conIsDupable,
conType, conOkForSpeculation, conStrictness, hashCon
import Const ( Con(..), isWHNFCon, conIsTrivial, conIsCheap, conIsDupable,
conType, hashCon
)
import PrimOp ( primOpOkForSpeculation, primOpStrictness )
import Id ( Id, idType, setIdType, idUnique, idAppIsBottom,
getIdArity, idName,
getIdArity, idName, isPrimitiveId_maybe,
getIdSpecialisation, setIdSpecialisation,
getInlinePragma, setInlinePragma,
getIdUnfolding, setIdUnfolding, idInfo
......@@ -249,14 +250,32 @@ exprOkForSpeculation :: CoreExpr -> Bool
exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
exprOkForSpeculation (Con con args)
= conOkForSpeculation con &&
and (zipWith ok (filter isValArg args) (fst (conStrictness con)))
exprOkForSpeculation (Con (Literal _) args) = True
exprOkForSpeculation (Con (DataCon _) args) = True
-- The strictness of the constructor has already
-- been expressed by its "wrapper", so we don't need
-- to take the arguments into account
exprOkForSpeculation (Con (PrimOp op) args)
= prim_op_ok_for_spec op args
exprOkForSpeculation (App fun arg) -- Might be application of a primop
= go fun [arg]
where
ok arg demand | isLazy demand = True
| otherwise = exprOkForSpeculation arg
go (App fun arg) args = go fun (arg:args)
go (Var v) args = case isPrimitiveId_maybe v of
Just op -> prim_op_ok_for_spec op args
Nothing -> False
go other args = False
exprOkForSpeculation other = False -- Conservative
prim_op_ok_for_spec op args
= primOpOkForSpeculation op &&
and (zipWith ok (filter isValArg args) (fst (primOpStrictness op)))
where
ok arg demand | isLazy demand = True
| otherwise = exprOkForSpeculation arg
\end{code}
......
......@@ -374,13 +374,16 @@ pprIfaceCoreRules :: CoreRules -> SDoc
pprIfaceCoreRules (Rules rules _) = vcat (map (pprCoreRule Nothing) rules)
pprCoreRule :: Maybe Id -> CoreRule -> SDoc
pprCoreRule maybe_fn (BuiltinRule _)
= ifPprDebug (ptext SLIT("A built in rule"))
pprCoreRule maybe_fn (Rule name tpl_vars tpl_args rhs)
= doubleQuotes (ptext name) <+>
sep [
ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
nest 4 (pp_fn <+> sep (map pprIfaceArg tpl_args)),
nest 4 (ptext SLIT("=") <+> pprIfaceUnfolding rhs)
]
] <+> semi
where
pp_fn = case maybe_fn of
Just id -> ppr id
......
......@@ -526,6 +526,7 @@ substRules subst (Rules rules rhs_fvs)
new_rules = Rules (map do_subst rules)
(subst_fvs (substEnv subst) rhs_fvs)
do_subst rule@(BuiltinRule _) = rule
do_subst (Rule name tpl_vars lhs_args rhs)
= Rule name tpl_vars'
(map (substExpr subst') lhs_args)
......
......@@ -157,32 +157,11 @@ dsExpr (HsLitOut (HsString s) _)
-- "_" => build (\ c n -> c 'c' n) -- LATER
-- "str" ==> build (\ c n -> foldr charTy T c n "str")
{- LATER:
dsExpr (HsLitOut (HsString str) _)
= newTyVarsDs [alphaTyVar] `thenDs` \ [new_tyvar] ->
let
new_ty = mkTyVarTy new_tyvar
in
newSysLocalsDs [
charTy `mkFunTy` (new_ty `mkFunTy` new_ty),
new_ty,
mkForallTy [alphaTyVar]
((charTy `mkFunTy` (alphaTy `mkFunTy` alphaTy))
`mkFunTy` (alphaTy `mkFunTy` alphaTy))
] `thenDs` \ [c,n,g] ->
returnDs (mkBuild charTy new_tyvar c n g (
foldl App
(CoTyApp (CoTyApp (Var foldrId) charTy) new_ty) *** ensure non-prim type ***
[VarArg c,VarArg n,LitArg (NoRepStr str)]))
-}
-- otherwise, leave it as a NoRepStr;
-- the Core-to-STG pass will wrap it in an application of "unpackCStringId".
dsExpr (HsLitOut (HsString str) _)
= returnDs (mkLit (NoRepStr str stringTy))
= returnDs (mkStringLitFS str)
dsExpr (HsLitOut (HsLitLit str) ty)
| isUnLiftedType ty
......
......@@ -212,10 +212,10 @@ ifaceRules if_hdl rules emitted
return ()
where
orphan_rule_pretties = [ pprCoreRule (Just fn) rule <+> semi
orphan_rule_pretties = [ pprCoreRule (Just fn) rule
| ProtoCoreRule _ fn rule <- rules
]
local_id_pretties = [ pprCoreRule (Just fn) rule <+> semi
local_id_pretties = [ pprCoreRule (Just fn) rule
| fn <- varSetElems emitted,
rule <- rulesRules (getIdSpecialisation fn),
all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[ConFold]{Constant Folder}
ToDo:
check boundaries before folding, e.g. we can fold the Float addition
(i1 + i2) only if it results in a valid Float.
\begin{code}
module PrelRules ( primOpRule, builtinRules ) where
#include "HsVersions.h"
import CoreSyn
import Rules ( ProtoCoreRule(..) )
import Id ( getIdUnfolding )
import Const ( mkMachInt, mkMachWord, Literal(..), Con(..) )
import PrimOp ( PrimOp(..), primOpOcc )
import TysWiredIn ( trueDataCon, falseDataCon )
import TyCon ( tyConDataCons, isEnumerationTyCon, isNewTyCon )
import DataCon ( dataConTag, dataConTyCon, fIRST_TAG )
import CoreUnfold ( maybeUnfoldingTemplate )
import CoreUtils ( exprIsValue, cheapEqExpr )
import Type ( splitTyConApp_maybe )
import OccName ( occNameUserString)
import ThinAir ( unpackCStringFoldrId )
import Maybes ( maybeToBool )
import Char ( ord, chr )
import Outputable
#if __GLASGOW_HASKELL__ >= 404
import GlaExts ( fromInt )
#endif
\end{code}
\begin{code}
primOpRule :: PrimOp -> CoreRule
primOpRule op
= BuiltinRule (primop_rule op)
where
op_name = _PK_ (occNameUserString (primOpOcc op))
op_name_case = op_name _APPEND_ SLIT("case")
-- ToDo: something for integer-shift ops?
-- NotOp
-- Int2WordOp -- SIGH: these two cause trouble in unfoldery
-- Int2AddrOp -- as we can't distinguish unsigned literals in interfaces (ToDo?)
primop_rule SeqOp = seqRule
primop_rule TagToEnumOp = tagToEnumRule
primop_rule DataToTagOp = dataToTagRule
-- Addr operations
primop_rule Addr2IntOp = oneLit (addr2IntOp op_name)
-- Char operations
primop_rule OrdOp = oneLit (chrOp op_name)
-- Int/Word operations
primop_rule IntAddOp = twoLits (intOp2 (+) op_name)
primop_rule IntSubOp = twoLits (intOp2 (-) op_name)
primop_rule IntMulOp = twoLits (intOp2 (*) op_name)
primop_rule IntQuotOp = twoLits (intOp2Z quot op_name)
primop_rule IntRemOp = twoLits (intOp2Z rem op_name)
primop_rule IntNegOp = oneLit (negOp op_name)
primop_rule ChrOp = oneLit (intCoerce (mkCharVal . chr) op_name)
primop_rule Int2FloatOp = oneLit (intCoerce mkFloatVal op_name)
primop_rule Int2DoubleOp = oneLit (intCoerce mkDoubleVal op_name)
primop_rule Word2IntOp = oneLit (intCoerce mkIntVal op_name)
primop_rule Int2WordOp = oneLit (intCoerce mkWordVal op_name)
-- Float
primop_rule FloatAddOp = twoLits (floatOp2 (+) op_name)
primop_rule FloatSubOp = twoLits (floatOp2 (-) op_name)
primop_rule FloatMulOp = twoLits (floatOp2 (*) op_name)
primop_rule FloatDivOp = twoLits (floatOp2Z (/) op_name)
primop_rule FloatNegOp = oneLit (negOp op_name)
-- Double
primop_rule DoubleAddOp = twoLits (doubleOp2 (+) op_name)
primop_rule DoubleSubOp = twoLits (doubleOp2 (-) op_name)
primop_rule DoubleMulOp = twoLits (doubleOp2 (*) op_name)
primop_rule DoubleDivOp = twoLits (doubleOp2Z (/) op_name)
-- Relational operators
primop_rule IntEqOp = relop (==) op_name `or_rule` litVar True op_name_case
primop_rule IntNeOp = relop (/=) op_name `or_rule` litVar False op_name_case
primop_rule CharEqOp = relop (==) op_name `or_rule` litVar True op_name_case
primop_rule CharNeOp = relop (/=) op_name `or_rule` litVar False op_name_case
primop_rule IntGtOp = relop (>) op_name
primop_rule IntGeOp = relop (>=) op_name
primop_rule IntLeOp = relop (<=) op_name
primop_rule IntLtOp = relop (<) op_name
primop_rule CharGtOp = relop (>) op_name
primop_rule CharGeOp = relop (>=) op_name
primop_rule CharLeOp = relop (<=) op_name
primop_rule CharLtOp = relop (<) op_name
primop_rule FloatGtOp = relop (>) op_name
primop_rule FloatGeOp = relop (>=) op_name
primop_rule FloatLeOp = relop (<=) op_name
primop_rule FloatLtOp = relop (<) op_name
primop_rule FloatEqOp = relop (==) op_name
primop_rule FloatNeOp = relop (/=) op_name
primop_rule DoubleGtOp = relop (>) op_name
primop_rule DoubleGeOp = relop (>=) op_name
primop_rule DoubleLeOp = relop (<=) op_name
primop_rule DoubleLtOp = relop (<) op_name
primop_rule DoubleEqOp = relop (==) op_name
primop_rule DoubleNeOp = relop (/=) op_name
primop_rule WordGtOp = relop (>) op_name
primop_rule WordGeOp = relop (>=) op_name
primop_rule WordLeOp = relop (<=) op_name
primop_rule WordLtOp = relop (<) op_name
primop_rule WordEqOp = relop (==) op_name
primop_rule WordNeOp = relop (/=) op_name
primop_rule other = \args -> Nothing
\end{code}
%************************************************************************
%* *
\subsection{Doing the business}
%* *
%************************************************************************
\begin{code}
--------------------------
intCoerce :: Num a => (a -> CoreExpr) -> RuleName -> Literal -> Maybe (RuleName, CoreExpr)
intCoerce fn name (MachInt i _) = Just (name, fn (fromInteger i))
--------------------------
relop cmp name = twoLits (\l1 l2 -> Just (name, if l1 `cmp` l2 then trueVal else falseVal))
--------------------------
negOp name (MachFloat f) = Just (name, mkFloatVal (-f))
negOp name (MachDouble d) = Just (name, mkDoubleVal (-d))
negOp name (MachInt i _) = Just (name, mkIntVal (-i))
chrOp name (MachChar c) = Just (name, mkIntVal (fromInt (ord c)))
addr2IntOp name (MachAddr i) = Just (name, mkIntVal i)
--------------------------
intOp2 op name l1@(MachInt i1 s1) l2@(MachInt i2 s2)
| (result > fromInt maxInt) || (result < fromInt minInt)
-- Better tell the user that we've overflowed...
-- ..not that it stops us from actually folding!
= pprTrace "Warning:" (text "Integer overflow in expression: " <>
ppr name <+> ppr l1 <+> ppr l2) $
Just (name, mkIntVal result)
<