-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
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
isSpecPragmaId, isRecordSelector,
isPrimitiveId_maybe, isDataConId_maybe,
- isConstantId, isBottomingId, idAppIsBottom,
+ isConstantId, isConstantId_maybe, isBottomingId, idAppIsBottom,
isExportedId, isUserExportedId,
mayHaveNoBinding,
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
)
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,
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
)
import IdInfo ( vanillaIdInfo, mkIdInfo,
exactArity, setUnfoldingInfo, setCafInfo,
- setArityInfo, setInlinePragInfo,
+ setArityInfo, setInlinePragInfo, setSpecInfo,
mkStrictnessInfo, setStrictnessInfo,
IdFlavour(..), InlinePragInfo(..), CafInfo(..), IdInfo
)
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,
= 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
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}
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,
-- Core rules
CoreRules(..), -- Representation needed by friends
CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only
+ RuleName,
emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules
) where
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}
= 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
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)
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}
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
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 )
-> 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
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
------------
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
| 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
= 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
-- 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
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
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}
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
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)
-- "_" => 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
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))
--- /dev/null
+%
+% (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)
+
+ | otherwise
+ = ASSERT( s1 && s2 ) -- Both should be signed
+ Just (name, mkIntVal result)
+ where
+ result = i1 `op` i2
+
+intOp2Z op name (MachInt i1 s1) (MachInt i2 s2)
+ | i2 == 0 = Nothing -- Don't do it if the dividend < 0
+ | otherwise = Just (name, mkIntVal (i1 `op` i2))
+
+
+--------------------------
+floatOp2 op name (MachFloat f1) (MachFloat f2)
+ = Just (name, mkFloatVal (f1 `op` f2))
+
+floatOp2Z op name (MachFloat f1) (MachFloat f2)
+ | f1 /= 0 = Just (name, mkFloatVal (f1 `op` f2))
+ | otherwise = Nothing
+
+
+--------------------------
+doubleOp2 op name (MachDouble f1) (MachDouble f2)
+ = Just (name, mkDoubleVal (f1 `op` f2))
+
+doubleOp2Z op name (MachDouble f1) (MachDouble f2)
+ | f1 /= 0 = Just (name, mkDoubleVal (f1 `op` f2))
+ | otherwise = Nothing
+
+
+--------------------------
+ -- This stuff turns
+ -- n ==# 3#
+ -- into
+ -- case n of
+ -- 3# -> True
+ -- m -> False
+ --
+ -- This is a Good Thing, because it allows case-of case things
+ -- to happen, and case-default absorption to happen. For
+ -- example:
+ --
+ -- if (n ==# 3#) || (n ==# 4#) then e1 else e2
+ -- will transform to
+ -- case n of
+ -- 3# -> e1
+ -- 4# -> e1
+ -- m -> e2
+ -- (modulo the usual precautions to avoid duplicating e1)
+
+litVar :: Bool -- True <=> equality, False <=> inequality
+ -> RuleName
+ -> RuleFun
+litVar is_eq name [Con (Literal lit) _, Var var] = do_lit_var is_eq name lit var
+litVar is_eq name [Var var, Con (Literal lit) _] = do_lit_var is_eq name lit var
+litVar is_eq name other = Nothing
+
+do_lit_var is_eq name lit var
+ = Just (name, Case (Var var) var [(Literal lit, [], val_if_eq),
+ (DEFAULT, [], val_if_neq)])
+ where
+ val_if_eq | is_eq = trueVal
+ | otherwise = falseVal
+ val_if_neq | is_eq = falseVal
+ | otherwise = trueVal
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Vaguely generic functions
+%* *
+%************************************************************************
+
+\begin{code}
+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
+
+twoLits :: (Literal -> Literal -> Maybe (RuleName, CoreExpr)) -> RuleFun
+twoLits rule [Con (Literal l1) _, Con (Literal l2) _] = rule l1 l2
+twoLits rule other = Nothing
+
+oneLit :: (Literal -> Maybe (RuleName, CoreExpr)) -> RuleFun
+oneLit rule [Con (Literal l1) _] = rule l1
+oneLit rule other = Nothing
+
+
+trueVal = Con (DataCon trueDataCon) []
+falseVal = Con (DataCon falseDataCon) []
+mkIntVal i = Con (Literal (mkMachInt i)) []
+mkCharVal c = Con (Literal (MachChar c)) []
+mkWordVal w = Con (Literal (mkMachWord w)) []
+mkFloatVal f = Con (Literal (MachFloat f)) []
+mkDoubleVal d = Con (Literal (MachDouble d)) []
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Special rules for seq, tagToEnum, dataToTag}
+%* *
+%************************************************************************
+
+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 (SLIT("Seq"), mkIntVal 1)
+seqRule other = Nothing
+\end{code}
+
+
+\begin{code}
+tagToEnumRule [Type ty, Con (Literal (MachInt i _)) _]
+ = ASSERT( isEnumerationTyCon tycon )
+ Just (SLIT("TagToEnum"), Con (DataCon dc) [])
+ where
+ tag = fromInteger i
+ constrs = tyConDataCons tycon
+ (dc:_) = [ dc | dc <- constrs, tag == dataConTag dc - fIRST_TAG ]
+ (Just (tycon,_)) = splitTyConApp_maybe ty
+
+tagToEnumRule other = Nothing
+\end{code}
+
+For dataToTag#, we can reduce if either
+
+ (a) the argument is a constructor
+ (b) the argument is a variable whose unfolding is a known constructor
+
+\begin{code}
+dataToTagRule [_, val_arg]
+ = case val_arg of
+ Con (DataCon dc) _ -> yes dc
+ Var x -> case maybeUnfoldingTemplate (getIdUnfolding x) of
+ Just (Con (DataCon dc) _) -> yes dc
+ other -> Nothing
+ other -> Nothing
+ where
+ yes dc = ASSERT( not (isNewTyCon (dataConTyCon dc)) )
+ Just (SLIT("DataToTag"),
+ mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))
+
+dataToTagRule other = Nothing
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Built in rules}
+%* *
+%************************************************************************
+
+\begin{code}
+builtinRules :: [ProtoCoreRule]
+builtinRules
+ = [ ProtoCoreRule False unpackCStringFoldrId
+ (BuiltinRule match_append_lit_str)
+ ]
+
+
+-- unpack "foo" c (unpack "baz" c n) = unpack "foobaz" c n
+
+match_append_lit_str [Type ty1,
+ Con (Literal (MachStr s1)) [],
+ c1,
+ Var unpk `App` Type ty2
+ `App` Con (Literal (MachStr s2)) []
+ `App` c2
+ `App` n
+ ]
+ | unpk == unpackCStringFoldrId &&
+ c1 `cheapEqExpr` c2
+ = ASSERT( ty1 == ty2 )
+ Just (SLIT("AppendLitString"),
+ Var unpk `App` Type ty1
+ `App` Con (Literal (MachStr (s1 _APPEND_ s2))) []
+ `App` c1
+ `App` n)
+
+match_append_lit_str other = Nothing
+\end{code}
\begin{code}
module PrimOp (
PrimOp(..), allThePrimOps,
- primOpType, primOpSig, primOpUsg,
- mkPrimOpIdName, primOpRdrName, primOpTag,
+ primOpType, primOpSig, primOpUsg, primOpArity,
+ mkPrimOpIdName, primOpRdrName, primOpTag, primOpOcc,
commutableOp,
UsageAnn(..), mkUsgTy
)
import Unique ( Unique, mkPrimOpIdUnique )
+import BasicTypes ( Arity )
import PrelMods ( pREL_GHC, pREL_GHC_Name )
import Outputable
import Util ( assoc, zipWithEqual )
\end{code}
\begin{code}
+primOpArity :: PrimOp -> Arity
+primOpArity op
+ = case (primOpInfo op) of
+ Monadic occ ty -> 1
+ Dyadic occ ty -> 2
+ Compare occ ty -> 2
+ GenPrimOp occ tyvars arg_tys res_ty -> length arg_tys
+
primOpType :: PrimOp -> Type -- you may want to use primOpSig instead
primOpType op
= case (primOpInfo op) of
-- String literals
, (varQual pREL_PACK_Name SLIT("packCString#"), packCStringIdKey)
- , (varQual pREL_PACK_Name SLIT("unpackCString#"), unpackCStringIdKey)
- , (varQual pREL_PACK_Name SLIT("unpackNBytes#"), unpackCString2IdKey)
- , (varQual pREL_PACK_Name SLIT("unpackAppendCString#"), unpackCStringAppendIdKey)
- , (varQual pREL_PACK_Name SLIT("unpackFoldrCString#"), unpackCStringFoldrIdKey)
-- Folds and builds; introduced by desugaring list comprehensions
+ , (varQual pREL_BASE_Name SLIT("unpackNBytes#"), unpackCString2IdKey)
+ , (varQual pREL_BASE_Name SLIT("unpackCString#"), unpackCStringIdKey)
+ , (varQual pREL_BASE_Name SLIT("unpackAppendCString#"), unpackCStringAppendIdKey)
+ , (varQual pREL_BASE_Name SLIT("unpackFoldrCString#"), unpackCStringFoldrIdKey)
+
, (varQual pREL_BASE_Name SLIT("foldr"), foldrIdKey)
, (varQual pREL_BASE_Name SLIT("build"), buildIdKey)
]
NamedThing(..), OccName
)
import TyCon ( TyCon, isDataTyCon )
-import PrimOp ( PrimOp(..) )
import PrelInfo ( unpackCStringId, unpackCString2Id, addr2IntegerId )
+import PrelRules ( builtinRules )
import Type ( Type, splitAlgTyConApp_maybe,
isUnLiftedType,
tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars,
better_rules <- simplRules ru_us rules binds
- let (binds1, rule_base) = prepareRuleBase binds better_rules
+ let all_rules = builtinRules ++ better_rules
+ -- Here is where we add in the built-in rules
+
+ let (binds1, rule_base) = prepareRuleBase binds all_rules
-- Do the main business
(stats, processed_binds) <- doCorePasses zeroSimplCount cp_us binds1
= returnSmpl rule -- No need to fiddle with imported rules
| otherwise
= simplBinders bndrs $ \ bndrs' ->
- mapSmpl simplExpr args `thenSmpl` \ args' ->
+ mapSmpl simpl_arg args `thenSmpl` \ args' ->
simplExpr rhs `thenSmpl` \ rhs' ->
returnSmpl (ProtoCoreRule is_local id (Rule name bndrs' args' rhs'))
+
+simpl_arg e
+-- I've seen rules in which a LHS like
+-- augment g (build h)
+-- turns into
+-- augment (\a. g a) (build h)
+-- So it's a help to eta-reduce the args as we simplify them.
+-- Otherwise we don't match when given an argument like
+-- (\a. h a a)
+ = simplExpr e `thenSmpl` \ e' ->
+ returnSmpl (etaCoreExpr e')
\end{code}
%************************************************************************
-- case (eqChar# x 'a') of ...
-- ==>
-- case (case x of 'a' -> True; other -> False) of ...
- case tryPrimOp op args2 of
+
+ case tryPrimOp op args2 of
Just e' -> zapSubstEnv (simplExprF e' cont2)
Nothing -> rebuild (Con (PrimOp op) args2) cont2
+
simplExprF (Con con@(DataCon _) args) cont
= simplConArgs args $ \ args' ->
rebuild (Con con args') cont
else
-- Try rules first
case lookupRule in_scope var args' of
- Just (rule_name, rule_rhs, rule_args) ->
+ Just (rule_name, rule_rhs) ->
tick (RuleFired rule_name) `thenSmpl_`
- zapSubstEnv (simplExprF rule_rhs (pushArgs emptySubstEnv rule_args cont'))
+ zapSubstEnv (simplExprF rule_rhs cont')
-- See note above about zapping the substitution here
Nothing -> rebuild (mkApps (Var var) args') cont'
rebuild expr (InlinePlease cont)
= rebuild (Note InlineCall expr) cont
--- Case of known constructor or literal
-rebuild expr@(Con con args) (Select _ bndr alts se cont)
- | conOkForAlt con -- Knocks out PrimOps and NoRepLits
- = knownCon expr con args bndr alts se cont
-
-
----------------------------------------------------------
--- The other Select cases
-
rebuild scrut (Select _ bndr alts se cont)
- | -- Check that the RHSs are all the same, and
- -- don't use the binders in the alternatives
- -- This test succeeds rapidly in the common case of
- -- a single DEFAULT alternative
- all (cheapEqExpr rhs1) other_rhss && all binders_unused alts
-
- -- Check that the scrutinee can be let-bound instead of case-bound
- && ( exprOkForSpeculation scrut
- -- OK not to evaluate it
- -- This includes things like (==# a# b#)::Bool
- -- so that we simplify
- -- case ==# a# b# of { True -> x; False -> x }
- -- to just
- -- x
- -- This particular example shows up in default methods for
- -- comparision operations (e.g. in (>=) for Int.Int32)
- || exprIsValue scrut -- It's already evaluated
- || var_demanded_later scrut -- It'll be demanded later
-
--- || not opt_SimplPedanticBottoms) -- Or we don't care!
--- We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
--- but that breaks badly for the dataToTag# primop, which relies on a case to evaluate
--- its argument: case x of { y -> dataToTag# y }
--- Here we must *not* discard the case, because dataToTag# just fetches the tag from
--- the info pointer. So we'll be pedantic all the time, and see if that gives any
--- other problems
- )
-
--- && opt_SimplDoCaseElim
--- [June 99; don't test this flag. The code generator dies if it sees
--- case (\x.e) of f -> ...
--- so better to always do it
-
- -- Get rid of the case altogether
- -- See the extensive notes on case-elimination below
- -- Remember to bind the binder though!
- = tick (CaseElim bndr) `thenSmpl_` (
- setSubstEnv se $
- simplBinder bndr $ \ bndr' ->
- completeBinding bndr bndr' False False scrut $
- simplExprF rhs1 cont)
-
- | otherwise
= rebuild_case scrut bndr alts se cont
- where
- (rhs1:other_rhss) = [rhs | (_,_,rhs) <- alts]
- binders_unused (_, bndrs, _) = all isDeadBinder bndrs
- var_demanded_later (Var v) = isStrict (getIdDemandInfo bndr) -- It's going to be evaluated later
- var_demanded_later other = False
\end{code}
Case elimination [see the code above]
Blob of helper functions for the "case-of-something-else" situation.
\begin{code}
+
+---------------------------------------------------------
+-- Case of known constructor or literal
+
+rebuild_case scrut@(Con con args) bndr alts se cont
+ | conOkForAlt con -- Knocks out PrimOps and NoRepLits
+ = knownCon scrut con args bndr alts se cont
+
+---------------------------------------------------------
+-- Eliminate the case if possible
+
+rebuild_case scrut bndr alts se cont
+ | -- Check that the RHSs are all the same, and
+ -- don't use the binders in the alternatives
+ -- This test succeeds rapidly in the common case of
+ -- a single DEFAULT alternative
+ all (cheapEqExpr rhs1) other_rhss && all binders_unused alts
+
+ -- Check that the scrutinee can be let-bound instead of case-bound
+ && ( exprOkForSpeculation scrut
+ -- OK not to evaluate it
+ -- This includes things like (==# a# b#)::Bool
+ -- so that we simplify
+ -- case ==# a# b# of { True -> x; False -> x }
+ -- to just
+ -- x
+ -- This particular example shows up in default methods for
+ -- comparision operations (e.g. in (>=) for Int.Int32)
+ || exprIsValue scrut -- It's already evaluated
+ || var_demanded_later scrut -- It'll be demanded later
+
+-- || not opt_SimplPedanticBottoms) -- Or we don't care!
+-- We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
+-- but that breaks badly for the dataToTag# primop, which relies on a case to evaluate
+-- its argument: case x of { y -> dataToTag# y }
+-- Here we must *not* discard the case, because dataToTag# just fetches the tag from
+-- the info pointer. So we'll be pedantic all the time, and see if that gives any
+-- other problems
+ )
+
+-- && opt_SimplDoCaseElim
+-- [June 99; don't test this flag. The code generator dies if it sees
+-- case (\x.e) of f -> ...
+-- so better to always do it
+
+ -- Get rid of the case altogether
+ -- See the extensive notes on case-elimination above
+ -- Remember to bind the binder though!
+ = tick (CaseElim bndr) `thenSmpl_` (
+ setSubstEnv se $
+ simplBinder bndr $ \ bndr' ->
+ completeBinding bndr bndr' False False scrut $
+ simplExprF rhs1 cont)
+
+ where
+ (rhs1:other_rhss) = [rhs | (_,_,rhs) <- alts]
+ binders_unused (_, bndrs, _) = all isDeadBinder bndrs
+
+ var_demanded_later (Var v) = isStrict (getIdDemandInfo bndr) -- It's going to be evaluated later
+ var_demanded_later other = False
+
---------------------------------------------------------
-- Case of something else
\begin{code}
module Rules (
- RuleBase, prepareRuleBase, lookupRule,
+ RuleBase, prepareRuleBase, lookupRule, addRule,
addIdSpecialisations,
ProtoCoreRule(..), pprProtoCoreRule,
orphanRule
#include "HsVersions.h"
import CoreSyn -- All of it
+import Const ( Con(..), Literal(..) )
import OccurAnal ( occurAnalyseExpr, tagBinders, UsageDetails )
import BinderInfo ( markMany )
import CoreFVs ( exprFreeVars, idRuleVars, ruleSomeLhsFreeVars )
import CoreUnfold ( isCheapUnfolding, unfoldingTemplate )
-import CoreUtils ( eqExpr )
+import CoreUtils ( eqExpr, cheapEqExpr )
import PprCore ( pprCoreRule )
import Subst ( Subst, InScopeSet, substBndr, lookupSubst, extendSubst,
mkSubst, substEnv, setSubstEnv, emptySubst, isInScope,
%************************************************************************
\begin{code}
-matchRules :: InScopeSet -> [CoreRule] -> [CoreExpr] -> Maybe (FAST_STRING, CoreExpr, [CoreExpr])
+matchRules :: InScopeSet -> [CoreRule] -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
-- See comments on matchRule
matchRules in_scope [] args = Nothing
matchRules in_scope (rule:rules) args
Nothing -> matchRules in_scope rules args
-matchRule :: InScopeSet -> CoreRule -> [CoreExpr] -> Maybe (FAST_STRING, CoreExpr, [CoreExpr])
+matchRule :: InScopeSet -> CoreRule -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
--- If (matchRule rule args) returns Just (name,rhs,args')
+-- If (matchRule rule args) returns Just (name,rhs)
-- then (f args) matches the rule, and the corresponding
--- rewritten RHS is (rhs args').
+-- rewritten RHS is rhs
--
-- The bndrs and rhs is occurrence-analysed
--
-- map (f.g) x) -- rhs
--
-- Then the call: matchRule the_rule [e1,map e2 e3]
--- = Just ("map/map", \f,g,x -> rhs, [e1,e2,e3])
+-- = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3)
--
-- Any 'surplus' arguments in the input are simply put on the end
-- of the output.
-- (\x->E) matches (\x->F x)
+matchRule in_scope rule@(BuiltinRule match_fn) args = match_fn args
+
matchRule in_scope rule@(Rule rn tpl_vars tpl_args rhs) args
= go tpl_args args emptySubst
-- We used to use the in_scope set, but I don't think that's necessary
go (tpl_arg:tpl_args) (arg:args) subst = match tpl_arg arg tpl_var_set (go tpl_args args) subst
-- Two easy ways to terminate
- go [] [] subst = Just (rn, mkLams tpl_vars rhs, mk_result_args subst tpl_vars)
- go [] args subst = Just (rn, mkLams tpl_vars rhs, mk_result_args subst tpl_vars ++ args)
+ go [] [] subst = Just (rn, app_match subst (mkLams tpl_vars rhs) tpl_vars)
+ go [] args subst = Just (rn, app_match subst (mkLams tpl_vars rhs) tpl_vars `mkApps` args)
-- One tiresome way to terminate: check for excess unmatched
-- template arguments
- go tpl_args [] subst = Nothing -- Failure
+ go tpl_args [] subst = Nothing -- Failure
+ -----------------------
+ app_match subst fn vs = foldl go fn vs
+ where
+ senv = substEnv subst
+ go fn v = case lookupSubstEnv senv v of
+ Just (DoneEx ex) -> fn `App` ex
+ Just (DoneTy ty) -> fn `App` Type ty
+ -- Substitution should bind them all!
+
+
+ -----------------------
{- The code below tries to match even if there are more
template args than real args.
eta_complete other vars = Nothing
-}
- -----------------------
- mk_result_args subst vs = map go vs
- where
- senv = substEnv subst
- go v = case lookupSubstEnv senv v of
- Just (DoneEx ex) -> ex
- Just (DoneTy ty) -> Type ty
- -- Substitution should bind them all!
-
zapOccInfo bndr | isTyVar bndr = bndr
| otherwise = zapLamIdInfo bndr
-- We make no check for rules that unify without one dominating
-- the other. Arguably this would be a bug.
+addRule id (Rules rules rhs_fvs) rule@(BuiltinRule _)
+ = Rules (rule:rules) rhs_fvs
+ -- Put it at the start for lack of anything better
+
addRule id (Rules rules rhs_fvs) (Rule str tpl_vars tpl_args rhs)
= Rules (insert rules) (rhs_fvs `unionVarSet` new_rhs_fvs)
where
pprProtoCoreRule (ProtoCoreRule _ fn rule) = pprCoreRule (Just fn) rule
-lookupRule :: InScopeSet -> Id -> [CoreExpr] -> Maybe (FAST_STRING, CoreExpr, [CoreExpr])
+lookupRule :: InScopeSet -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
lookupRule in_scope fn args
= case getIdSpecialisation fn of
Rules rules _ -> matchRules in_scope rules args
-- so that the opportunity to apply the rule isn't lost too soon
prepareRuleBase :: [CoreBind] -> [ProtoCoreRule] -> ([CoreBind], RuleBase)
-prepareRuleBase binds rules
+prepareRuleBase binds all_rules
= (map zap_bind binds, (imported_rule_ids, rule_lhs_fvs))
where
- (rule_ids, rule_lhs_fvs) = foldr add_rule (emptyVarSet, emptyVarSet) rules
+ (rule_ids, rule_lhs_fvs) = foldr add_rule (emptyVarSet, emptyVarSet) all_rules
imported_rule_ids = filterVarSet (not . isLocallyDefined) rule_ids
-- rule_fvs is the set of all variables mentioned in rules
addRuleToId id rule = setIdSpecialisation id (addRule id (getIdSpecialisation id) rule)
\end{code}
-
import PrimOp ( PrimOp(..) )
import Id ( Id, mkId, mkVanillaId,
- isPrimitiveId_maybe, isDataConId_maybe
+ isDataConId_maybe
)
import IdInfo
import DataCon ( dataConSig, dataConArgTys )
returnTc (Var id)
tcCoreExpr (UfCon con args)
- = tcUfCon con `thenTc` \ con' ->
- mapTc tcCoreExpr args `thenTc` \ args' ->
- returnTc (Con con' args')
+ = mapTc tcCoreExpr args `thenTc` \ args' ->
+ tcUfCon con args'
tcCoreExpr (UfTuple name args)
- = tcUfDataCon name `thenTc` \ con ->
+ = -- See notes with tcUfCon (UfDataCon ...)
+ tcVar name `thenTc` \ con_id ->
mapTc tcCoreExpr args `thenTc` \ args' ->
let
-- Put the missing type arguments back in
con_args = map (Type . unUsgTy . coreExprType) args' ++ args'
in
- returnTc (Con con con_args)
+ returnTc (mkApps (Var con_id) con_args)
tcCoreExpr (UfLam bndr body)
= tcCoreLamBndr bndr $ \ bndr' ->
tcCoreNote UfInlineCall = returnTc InlineCall
--- rationalTy isn't built in so, we have to construct it
--- (the "ty" part of the incoming literal is simply bottom)
-tcUfCon (UfLitCon (NoRepRational lit _))
- = tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
- let
- rational_ty = mkSynTy rational_tycon []
- in
- returnTc (Literal (NoRepRational lit rational_ty))
-
--- Similarly for integers and strings, except that they are wired in
-tcUfCon (UfLitCon (NoRepInteger lit _))
- = returnTc (Literal (NoRepInteger lit integerTy))
-tcUfCon (UfLitCon (NoRepStr lit _))
- = returnTc (Literal (NoRepStr lit stringTy))
-
-tcUfCon (UfLitCon other_lit)
- = returnTc (Literal other_lit)
+----------------------------------
+tcUfCon (UfLitCon lit) args
+ = ASSERT( null args)
+ tcUfLit lit `thenTc` \ lit ->
+ returnTc (Con (Literal lit) [])
-- The dreaded lit-lits are also similar, except here the type
-- is read in explicitly rather than being implicit
-tcUfCon (UfLitLitCon lit ty)
- = tcHsType ty `thenTc` \ ty' ->
- returnTc (Literal (MachLitLit lit ty'))
-
-tcUfCon (UfDataCon name) = tcUfDataCon name
-
-tcUfCon (UfPrimOp name)
- = tcVar name `thenTc` \ op_id ->
- case isPrimitiveId_maybe op_id of
- Just op -> returnTc (PrimOp op)
- Nothing -> failWithTc (badPrimOp name)
-
-tcUfCon (UfCCallOp str is_dyn casm gc)
- = case is_dyn of
- True ->
- tcGetUnique `thenNF_Tc` \ u ->
- returnTc (PrimOp (CCallOp (Right u) casm gc cCallConv))
- False -> returnTc (PrimOp (CCallOp (Left str) casm gc cCallConv))
-
-tcUfDataCon name
+tcUfCon (UfLitLitCon lit ty) args
+ = ASSERT( null args )
+ tcHsType ty `thenTc` \ ty' ->
+ returnTc (Con (Literal (MachLitLit lit ty')) [])
+
+-- Primops are reverse-engineered
+-- into applications of their Ids. In this way, any
+-- RULES that apply to the Id will work when this thing is unfolded.
+-- It's a bit of a hack, but it works nicely
+-- Can't do it for datacons, because the data con Id doesn't necessarily
+-- have the same type as the data con (existentials)
+
+tcUfCon (UfPrimOp name) args = tcVar name `thenTc` \ op_id ->
+ returnTc (mkApps (Var op_id) args)
+
+tcUfCon (UfDataCon name) args
= tcVar name `thenTc` \ con_id ->
case isDataConId_maybe con_id of
- Just con -> returnTc (DataCon con)
+ Just con -> returnTc (mkConApp con args)
Nothing -> failWithTc (badCon name)
+
+tcUfCon (UfCCallOp str is_dyn casm gc) args
+ | is_dyn = tcGetUnique `thenNF_Tc` \ u ->
+ returnTc (Con (PrimOp (CCallOp (Right u) casm gc cCallConv)) args)
+ | otherwise = returnTc (Con (PrimOp (CCallOp (Left str) casm gc cCallConv)) args)
+
+----------------------------------
+tcUfLit (NoRepRational lit _)
+ = -- rationalTy isn't built in so, we have to construct it
+ -- (the "ty" part of the incoming literal is simply bottom)
+ tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
+ let
+ rational_ty = mkSynTy rational_tycon []
+ in
+ returnTc (NoRepRational lit rational_ty)
+
+-- Similarly for integers and strings, except that they are wired in
+tcUfLit (NoRepInteger lit _) = returnTc (NoRepInteger lit integerTy)
+tcUfLit (NoRepStr lit _) = returnTc (NoRepStr lit stringTy)
+tcUfLit other_lit = returnTc other_lit
\end{code}
\begin{code}
"foldr/cons" forall k z x xs. foldr k z (x:xs) = k x (foldr k z xs)
"foldr/nil" forall k z. foldr k z [] = z
+
+"augment/build" forall (g::forall b. (a->b->b) -> b -> b)
+ (h::forall b. (a->b->b) -> b -> b) .
+ augment g (build h) = build (\c n -> g c (h c n))
+"augment/nil" forall (g::forall b. (a->b->b) -> b -> b) .
+ augment g [] = build g
#-}
+
+-- This rule is true, but not (I think) useful:
+-- augment g (augment h t) = augment (\cn -> g c (h c n)) t
\end{code}
leInt (I# x) (I# y) = x <=# y
\end{code}
+
+%********************************************************
+%* *
+\subsection{Unpacking C strings}
+%* *
+%********************************************************
+
+This code is needed for virtually all programs, since it's used for
+unpacking the strings of error messages.
+
+\begin{code}
+unpackCString# :: Addr# -> [Char]
+{-# INLINE unpackCString# #-}
+unpackCString# a = build (unpackFoldrCString# a)
+
+unpackCStringList# :: Addr# -> [Char]
+unpackCStringList# addr
+ = unpack 0#
+ where
+ unpack nh
+ | ch `eqChar#` '\0'# = []
+ | otherwise = C# ch : unpack (nh +# 1#)
+ where
+ ch = indexCharOffAddr# addr nh
+
+unpackAppendCString# :: Addr# -> [Char] -> [Char]
+unpackAppendCString# addr rest
+ = unpack 0#
+ where
+ unpack nh
+ | ch `eqChar#` '\0'# = rest
+ | otherwise = C# ch : unpack (nh +# 1#)
+ where
+ ch = indexCharOffAddr# addr nh
+
+unpackFoldrCString# :: Addr# -> (Char -> a -> a) -> a -> a
+unpackFoldrCString# addr f z
+ = unpack 0#
+ where
+ unpack nh
+ | ch `eqChar#` '\0'# = z
+ | otherwise = C# ch `f` unpack (nh +# 1#)
+ where
+ ch = indexCharOffAddr# addr nh
+
+unpackNBytes# :: Addr# -> Int# -> [Char]
+ -- This one is called by the compiler to unpack literal
+ -- strings with NULs in them; rare. It's strict!
+ -- We don't try to do list deforestation for this one
+
+unpackNBytes# _addr 0# = []
+unpackNBytes# addr len# = unpack [] (len# -# 1#)
+ where
+ unpack acc i#
+ | i# <# 0# = acc
+ | otherwise =
+ case indexCharOffAddr# addr i# of
+ ch -> unpack (C# ch : acc) (i# -# 1#)
+
+{-# RULES
+"unpack-list" forall a . unpackFoldrCString# a (:) [] = unpackCStringList# a
+"unpack-append" forall a n . unpackFoldrCString# a (:) n = unpackAppendCString# a n
+
+-- There's a built-in rule (in PrelRules.lhs) for
+-- unpackFoldr "foo" c (unpackFoldr "baz" c n) = unpackFoldr "foobaz" c n
+
+ #-}
+\end{code}
---------------------------------------------------------------------------
__interface PrelPack 1 where
-__export PrelPack packCStringzh unpackCStringzh unpackNByteszh unpackAppendCStringzh unpackFoldrCStringzh ;
+__export PrelPack packCStringzh ;
1 packCStringzh :: [PrelBase.Char] -> PrelGHC.ByteArrayzh ;
-1 unpackCStringzh :: PrelGHC.Addrzh -> [PrelBase.Char] ;
-1 unpackNByteszh :: PrelGHC.Addrzh -> PrelGHC.Intzh -> [PrelBase.Char] ;
-1 unpackAppendCStringzh :: PrelGHC.Addrzh -> [PrelBase.Char] -> [PrelBase.Char] ;
-1 unpackFoldrCStringzh :: __forall [a] => PrelGHC.Addrzh -> (PrelBase.Char -> a -> a) -> a -> a ;
sequence of bytes into a list of @Char@s:
\begin{code}
-unpackCString :: Addr{- ptr. to NUL terminated string-} -> [Char]
+unpackCString :: Addr -> [Char]
unpackCString a@(A# addr)
| a == nullAddr = []
| otherwise = unpackCString# addr
+unpackNBytes :: Addr -> Int -> [Char]
+unpackNBytes (A# addr) (I# l) = unpackNBytes# addr l
+
unpackCStringST :: Addr{- ptr. to NUL terminated string-} -> ST s [Char]
unpackCStringST a@(A# addr)
| a == nullAddr = return []
where
ch = indexCharOffAddr# addr nh
-unpackCString# :: Addr# -> [Char]
-unpackCString# addr
- = unpack 0#
- where
- unpack nh
- | ch `eqChar#` '\0'# = []
- | otherwise = C# ch : unpack (nh +# 1#)
- where
- ch = indexCharOffAddr# addr nh
-
-unpackNBytes :: Addr -> Int -> [Char]
-unpackNBytes (A# addr) (I# l) = unpackNBytes# addr l
-
unpackNBytesST :: Addr -> Int -> ST s [Char]
unpackNBytesST (A# addr) (I# l) = unpackNBytesAccST# addr l []
unpackNBytesAccST :: Addr -> Int -> [Char] -> ST s [Char]
unpackNBytesAccST (A# addr) (I# l) rest = unpackNBytesAccST# addr l rest
-unpackNBytes# :: Addr# -> Int# -> [Char]
- -- This one is called by the compiler to unpack literal strings with NULs in them; rare.
- -- It's strict!
-unpackNBytes# _addr 0# = []
-unpackNBytes# addr len# = unpack [] (len# -# 1#)
- where
- unpack acc i#
- | i# <# 0# = acc
- | otherwise =
- case indexCharOffAddr# addr i# of
- ch -> unpack (C# ch : acc) (i# -# 1#)
-
unpackNBytesST# :: Addr# -> Int# -> ST s [Char]
unpackNBytesST# addr# l# = unpackNBytesAccST# addr# l# []
\end{code}
-%********************************************************
-%* *
-\subsection{Misc}
-%* *
-%********************************************************
-
-The compiler may emit these two
-
-\begin{code}
-unpackAppendCString# :: Addr# -> [Char] -> [Char]
-unpackAppendCString# addr rest
- = unpack 0#
- where
- unpack nh
- | ch `eqChar#` '\0'# = rest
- | otherwise = C# ch : unpack (nh +# 1#)
- where
- ch = indexCharOffAddr# addr nh
-
-unpackFoldrCString# :: Addr# -> (Char -> a -> a) -> a -> a
-unpackFoldrCString# addr f z
- = unpack 0#
- where
- unpack nh
- | ch `eqChar#` '\0'# = z
- | otherwise = C# ch `f` unpack (nh +# 1#)
- where
- ch = indexCharOffAddr# addr nh
-\end{code}
projects / ghc-hetmet.git / commitdiff