From 5ab261bb3fd75f45a4f219f1399be84208e12463 Mon Sep 17 00:00:00 2001 From: simonpj Date: Fri, 14 Sep 2001 15:51:43 +0000 Subject: [PATCH 1/1] [project @ 2001-09-14 15:51:41 by simonpj] -------------------------- Add a rule-check pass (special request by Manuel) -------------------------- DO NOT merge with stable The flag -frule-check foo will report all sites at which RULES whose name starts with "foo.." might apply, but in fact the arguments don't match so the rule doesn't apply. The pass is run right after all the core-to-core passes. (Next thing to do: make the core-to-core script external, so you can fiddle with it. Meanwhile, the core-to-core script is in DriverState.builCoreToDo so you can move the CoreDoRuleCheck line around if you want. The format of the report is experimental: Manuel, feel free to fiddle with it. Most of the code is in specialise/Rules.lhs Incidental changes ~~~~~~~~~~~~~~~~~~ Change BuiltinRule so that the rule name is accessible without actually successfully applying the rule. This change affects quite a few files in a trivial way. --- ghc/compiler/coreSyn/CoreFVs.lhs | 8 +- ghc/compiler/coreSyn/CoreSyn.lhs | 16 +- ghc/compiler/coreSyn/CoreTidy.lhs | 2 +- ghc/compiler/coreSyn/CoreUnfold.lhs | 13 +- ghc/compiler/coreSyn/PprCore.lhs | 4 +- ghc/compiler/coreSyn/Subst.lhs | 2 +- ghc/compiler/main/CmdLineOpts.lhs | 2 + ghc/compiler/main/DriverFlags.hs | 5 +- ghc/compiler/main/DriverState.hs | 8 +- ghc/compiler/main/MkIface.lhs | 2 +- ghc/compiler/prelude/PrelRules.lhs | 307 ++++++++++++++++----------------- ghc/compiler/prelude/primops.txt | 44 ++++- ghc/compiler/simplCore/OccurAnal.lhs | 2 +- ghc/compiler/simplCore/SimplCore.lhs | 16 +- ghc/compiler/simplCore/SimplMonad.lhs | 6 +- ghc/compiler/specialise/Rules.lhs | 140 +++++++++++++-- 16 files changed, 375 insertions(+), 202 deletions(-) diff --git a/ghc/compiler/coreSyn/CoreFVs.lhs b/ghc/compiler/coreSyn/CoreFVs.lhs index 1c30217..2a1a122 100644 --- a/ghc/compiler/coreSyn/CoreFVs.lhs +++ b/ghc/compiler/coreSyn/CoreFVs.lhs @@ -160,7 +160,7 @@ make the whole module an orphan module, which is bad. \begin{code} ruleLhsFreeNames :: IdCoreRule -> NameSet -ruleLhsFreeNames (fn, BuiltinRule _) = unitNameSet (varName fn) +ruleLhsFreeNames (fn, BuiltinRule _ _) = unitNameSet (varName fn) ruleLhsFreeNames (fn, Rule _ tpl_vars tpl_args rhs) = addOneToNameSet (exprsFreeNames tpl_args `del_binders` tpl_vars) (varName fn) @@ -201,14 +201,14 @@ del_binders names bndrs = foldl (\s b -> delFromNameSet s (varName b)) names bnd \begin{code} ruleRhsFreeVars :: CoreRule -> VarSet -ruleRhsFreeVars (BuiltinRule _) = noFVs +ruleRhsFreeVars (BuiltinRule _ _) = noFVs ruleRhsFreeVars (Rule str tpl_vars tpl_args rhs) = rule_fvs isLocalVar emptyVarSet where rule_fvs = addBndrs tpl_vars (expr_fvs rhs) ruleSomeFreeVars :: InterestingVarFun -> CoreRule -> VarSet -ruleSomeFreeVars interesting (BuiltinRule _) = noFVs +ruleSomeFreeVars interesting (BuiltinRule _ _) = noFVs ruleSomeFreeVars interesting (Rule _ tpl_vars tpl_args rhs) = rule_fvs interesting emptyVarSet where @@ -218,7 +218,7 @@ ruleSomeFreeVars interesting (Rule _ tpl_vars tpl_args rhs) ruleLhsFreeIds :: CoreRule -> VarSet -- This finds all the free Ids on the LHS of the rule -- *including* imported ids -ruleLhsFreeIds (BuiltinRule _) = noFVs +ruleLhsFreeIds (BuiltinRule _ _) = noFVs ruleLhsFreeIds (Rule _ tpl_vars tpl_args rhs) = foldl delVarSet (exprsSomeFreeVars isId tpl_args) tpl_vars \end{code} diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index 2c89f6e..83ef923 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -44,7 +44,7 @@ module CoreSyn ( IdCoreRule, RuleName, emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules, - isBuiltinRule + isBuiltinRule, ruleName ) where #include "HsVersions.h" @@ -174,11 +174,15 @@ data CoreRule CoreExpr -- RHS | BuiltinRule -- Built-in rules are used for constant folding - -- and suchlike. It has no free variables. - ([CoreExpr] -> Maybe (RuleName, CoreExpr)) + RuleName -- and suchlike. It has no free variables. + ([CoreExpr] -> Maybe CoreExpr) -isBuiltinRule (BuiltinRule _) = True -isBuiltinRule _ = False +isBuiltinRule (BuiltinRule _ _) = True +isBuiltinRule _ = False + +ruleName :: CoreRule -> RuleName +ruleName (Rule n _ _ _) = n +ruleName (BuiltinRule n _) = n \end{code} @@ -568,7 +572,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 +seq_rules (BuiltinRule _ _ : rules) = seq_rules rules \end{code} diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index d1b9205..55b0085 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -541,7 +541,7 @@ tidyIdRules env ((fn,rule) : rules) ((tidyVarOcc env fn, rule) : rules) tidyRule :: TidyEnv -> CoreRule -> CoreRule -tidyRule env rule@(BuiltinRule _) = rule +tidyRule env rule@(BuiltinRule _ _) = rule tidyRule env (Rule name vars tpl_args rhs) = tidyBndrs env vars =: \ (env', vars) -> map (tidyExpr env') tpl_args =: \ tpl_args -> diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index 6853b96..e96e741 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -530,11 +530,14 @@ callSiteInline dflags black_listed inline_call occ id arg_infos interesting_cont = case idUnfolding id of { NoUnfolding -> Nothing ; OtherCon cs -> Nothing ; - CompulsoryUnfolding unf_template | black_listed -> Nothing - | otherwise -> Just unf_template ; - -- Constructors have compulsory unfoldings, but - -- may have rules, in which case they are - -- black listed till later + + CompulsoryUnfolding unf_template -> Just unf_template ; + -- CompulsoryUnfolding => there is no top-level binding + -- for these things, so we must inline it. + -- Only a couple of primop-like things have + -- compulsory unfoldings (see MkId.lhs). + -- We don't allow them to be black-listed + CoreUnfolding unf_template is_top is_value is_cheap guidance -> let diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 19fb641..96c0499 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -373,8 +373,8 @@ pprIdCoreRule :: IdCoreRule -> SDoc pprIdCoreRule (id,rule) = pprCoreRule (ppr id) rule pprCoreRule :: SDoc -> CoreRule -> SDoc -pprCoreRule pp_fn (BuiltinRule _) - = ifPprDebug (ptext SLIT("A built in rule")) +pprCoreRule pp_fn (BuiltinRule name _) + = ifPprDebug (ptext SLIT("Built in rule") <+> doubleQuotes (ptext name)) pprCoreRule pp_fn (Rule name tpl_vars tpl_args rhs) = doubleQuotes (ptext name) <+> diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs index aa60c04..f228274 100644 --- a/ghc/compiler/coreSyn/Subst.lhs +++ b/ghc/compiler/coreSyn/Subst.lhs @@ -807,7 +807,7 @@ substRules subst (Rules rules rhs_fvs) where new_rules = Rules (map do_subst rules) (substVarSet subst rhs_fvs) - do_subst rule@(BuiltinRule _) = rule + do_subst rule@(BuiltinRule _ _) = rule do_subst (Rule name tpl_vars lhs_args rhs) = Rule name tpl_vars' (map (substExpr subst') lhs_args) diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 33d9320..2be4ce5 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -201,6 +201,8 @@ data CoreToDo -- These are diff core-to-core passes, | CoreDoCPResult | CoreDoGlomBinds | CoreCSE + | CoreDoRuleCheck String -- Check for non-application of rules + -- matching this string | CoreDoNothing -- useful when building up lists of these things \end{code} diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs index 333b230..8326c3e 100644 --- a/ghc/compiler/main/DriverFlags.hs +++ b/ghc/compiler/main/DriverFlags.hs @@ -1,7 +1,7 @@ {-# OPTIONS -#include "hschooks.h" #-} ----------------------------------------------------------------------------- --- $Id: DriverFlags.hs,v 1.69 2001/09/06 15:43:35 simonpj Exp $ +-- $Id: DriverFlags.hs,v 1.70 2001/09/14 15:51:42 simonpj Exp $ -- -- Driver flags -- @@ -272,6 +272,9 @@ static_flags = , ( "fmax-simplifier-iterations", Prefix (writeIORef v_MaxSimplifierIterations . read) ) + , ( "frule-check", + SepArg (\s -> writeIORef v_RuleCheck (Just s)) ) + , ( "fusagesp" , NoArg (do writeIORef v_UsageSPInf True add v_Opt_C "-fusagesp-on") ) diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs index 20946fa..c192cad 100644 --- a/ghc/compiler/main/DriverState.hs +++ b/ghc/compiler/main/DriverState.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverState.hs,v 1.56 2001/09/04 16:35:02 sewardj Exp $ +-- $Id: DriverState.hs,v 1.57 2001/09/14 15:51:42 simonpj Exp $ -- -- Settings for the driver -- @@ -149,6 +149,7 @@ GLOBAL_VAR(v_UsageSPInf, False, Bool) -- Off by default GLOBAL_VAR(v_Strictness, True, Bool) GLOBAL_VAR(v_CPR, True, Bool) GLOBAL_VAR(v_CSE, True, Bool) +GLOBAL_VAR(v_RuleCheck, Nothing, Maybe String) -- these are the static flags you get without -O. hsc_minusNoO_flags = @@ -188,6 +189,7 @@ buildCoreToDo = do strictness <- readIORef v_Strictness cpr <- readIORef v_CPR cse <- readIORef v_CSE + rule_check <- readIORef v_RuleCheck if opt_level == 0 then return [ @@ -308,7 +310,9 @@ buildCoreToDo = do CoreDoSimplify (isAmongSimpl [ MaxSimplifierIterations max_iter -- No -finline-phase: allow all Ids to be inlined now - ]) + ]), + + case rule_check of { Just pat -> CoreDoRuleCheck pat; Nothing -> CoreDoNothing } ] buildStgToDo :: IO [ StgToDo ] diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 98a160f..9ba3a2f 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -310,7 +310,7 @@ ifaceInstance dfun_id -- and this instance decl wouldn't get imported into a module -- that mentioned T but not Tibble. -ifaceRule (id, BuiltinRule _) +ifaceRule (id, BuiltinRule _ _) = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule id) ifaceRule (id, Rule name bndrs args rhs) diff --git a/ghc/compiler/prelude/PrelRules.lhs b/ghc/compiler/prelude/PrelRules.lhs index fd73bc8..94e4ddb 100644 --- a/ghc/compiler/prelude/PrelRules.lhs +++ b/ghc/compiler/prelude/PrelRules.lhs @@ -15,7 +15,7 @@ ToDo: {-# OPTIONS -optc-DNON_POSIX_SOURCE #-} -module PrelRules ( primOpRule, builtinRules ) where +module PrelRules ( primOpRules, builtinRules ) where #include "HsVersions.h" @@ -51,116 +51,119 @@ import CmdLineOpts ( opt_SimplExcessPrecision ) \begin{code} -primOpRule :: PrimOp -> Maybe CoreRule -primOpRule op = fmap BuiltinRule (primop_rule op) +primOpRules :: PrimOp -> [CoreRule] +primOpRules op = primop_rule op where op_name = _PK_ (occNameUserString (primOpOcc op)) op_name_case = op_name _APPEND_ SLIT("->case") + -- A useful shorthand + one_rule rule_fn = [BuiltinRule op_name rule_fn] + -- ToDo: something for integer-shift ops? -- NotOp - primop_rule AddrNullOp = Just nullAddrRule - primop_rule SeqOp = Just seqRule - primop_rule TagToEnumOp = Just tagToEnumRule - primop_rule DataToTagOp = Just dataToTagRule + primop_rule AddrNullOp = one_rule nullAddrRule + primop_rule SeqOp = one_rule seqRule + primop_rule TagToEnumOp = one_rule tagToEnumRule + primop_rule DataToTagOp = one_rule dataToTagRule -- Int operations - primop_rule IntAddOp = Just (twoLits (intOp2 (+) op_name)) - primop_rule IntSubOp = Just (twoLits (intOp2 (-) op_name)) - primop_rule IntMulOp = Just (twoLits (intOp2 (*) op_name)) - primop_rule IntQuotOp = Just (twoLits (intOp2Z quot op_name)) - primop_rule IntRemOp = Just (twoLits (intOp2Z rem op_name)) - primop_rule IntNegOp = Just (oneLit (negOp op_name)) + primop_rule IntAddOp = one_rule (twoLits (intOp2 (+))) + primop_rule IntSubOp = one_rule (twoLits (intOp2 (-))) + primop_rule IntMulOp = one_rule (twoLits (intOp2 (*))) + primop_rule IntQuotOp = one_rule (twoLits (intOp2Z quot)) + primop_rule IntRemOp = one_rule (twoLits (intOp2Z rem)) + primop_rule IntNegOp = one_rule (oneLit negOp) -- Word operations #if __GLASGOW_HASKELL__ >= 500 - primop_rule WordAddOp = Just (twoLits (wordOp2 (+) op_name)) - primop_rule WordSubOp = Just (twoLits (wordOp2 (-) op_name)) - primop_rule WordMulOp = Just (twoLits (wordOp2 (*) op_name)) + primop_rule WordAddOp = one_rule (twoLits (wordOp2 (+))) + primop_rule WordSubOp = one_rule (twoLits (wordOp2 (-))) + primop_rule WordMulOp = one_rule (twoLits (wordOp2 (*))) #endif - primop_rule WordQuotOp = Just (twoLits (wordOp2Z quot op_name)) - primop_rule WordRemOp = Just (twoLits (wordOp2Z rem op_name)) + primop_rule WordQuotOp = one_rule (twoLits (wordOp2Z quot)) + primop_rule WordRemOp = one_rule (twoLits (wordOp2Z rem)) #if __GLASGOW_HASKELL__ >= 407 - primop_rule AndOp = Just (twoLits (wordBitOp2 (.&.) op_name)) - primop_rule OrOp = Just (twoLits (wordBitOp2 (.|.) op_name)) - primop_rule XorOp = Just (twoLits (wordBitOp2 xor op_name)) + primop_rule AndOp = one_rule (twoLits (wordBitOp2 (.&.))) + primop_rule OrOp = one_rule (twoLits (wordBitOp2 (.|.))) + primop_rule XorOp = one_rule (twoLits (wordBitOp2 xor)) #endif -- coercions - primop_rule Word2IntOp = Just (oneLit (litCoerce word2IntLit op_name)) - primop_rule Int2WordOp = Just (oneLit (litCoerce int2WordLit op_name)) - primop_rule Narrow8IntOp = Just (oneLit (litCoerce narrow8IntLit op_name)) - primop_rule Narrow16IntOp = Just (oneLit (litCoerce narrow16IntLit op_name)) - primop_rule Narrow32IntOp = Just (oneLit (litCoerce narrow32IntLit op_name)) - primop_rule Narrow8WordOp = Just (oneLit (litCoerce narrow8WordLit op_name)) - primop_rule Narrow16WordOp = Just (oneLit (litCoerce narrow16WordLit op_name)) - primop_rule Narrow32WordOp = Just (oneLit (litCoerce narrow32WordLit op_name)) - primop_rule OrdOp = Just (oneLit (litCoerce char2IntLit op_name)) - primop_rule ChrOp = Just (oneLit (litCoerce int2CharLit op_name)) - primop_rule Float2IntOp = Just (oneLit (litCoerce float2IntLit op_name)) - primop_rule Int2FloatOp = Just (oneLit (litCoerce int2FloatLit op_name)) - primop_rule Double2IntOp = Just (oneLit (litCoerce double2IntLit op_name)) - primop_rule Int2DoubleOp = Just (oneLit (litCoerce int2DoubleLit op_name)) + primop_rule Word2IntOp = one_rule (oneLit (litCoerce word2IntLit)) + primop_rule Int2WordOp = one_rule (oneLit (litCoerce int2WordLit)) + primop_rule Narrow8IntOp = one_rule (oneLit (litCoerce narrow8IntLit)) + primop_rule Narrow16IntOp = one_rule (oneLit (litCoerce narrow16IntLit)) + primop_rule Narrow32IntOp = one_rule (oneLit (litCoerce narrow32IntLit)) + primop_rule Narrow8WordOp = one_rule (oneLit (litCoerce narrow8WordLit)) + primop_rule Narrow16WordOp = one_rule (oneLit (litCoerce narrow16WordLit)) + primop_rule Narrow32WordOp = one_rule (oneLit (litCoerce narrow32WordLit)) + primop_rule OrdOp = one_rule (oneLit (litCoerce char2IntLit)) + primop_rule ChrOp = one_rule (oneLit (litCoerce int2CharLit)) + primop_rule Float2IntOp = one_rule (oneLit (litCoerce float2IntLit)) + primop_rule Int2FloatOp = one_rule (oneLit (litCoerce int2FloatLit)) + primop_rule Double2IntOp = one_rule (oneLit (litCoerce double2IntLit)) + primop_rule Int2DoubleOp = one_rule (oneLit (litCoerce int2DoubleLit)) -- SUP: Not sure what the standard says about precision in the following 2 cases - primop_rule Float2DoubleOp = Just (oneLit (litCoerce float2DoubleLit op_name)) - primop_rule Double2FloatOp = Just (oneLit (litCoerce double2FloatLit op_name)) + primop_rule Float2DoubleOp = one_rule (oneLit (litCoerce float2DoubleLit)) + primop_rule Double2FloatOp = one_rule (oneLit (litCoerce double2FloatLit)) -- Float - primop_rule FloatAddOp = Just (twoLits (floatOp2 (+) op_name)) - primop_rule FloatSubOp = Just (twoLits (floatOp2 (-) op_name)) - primop_rule FloatMulOp = Just (twoLits (floatOp2 (*) op_name)) - primop_rule FloatDivOp = Just (twoLits (floatOp2Z (/) op_name)) - primop_rule FloatNegOp = Just (oneLit (negOp op_name)) + primop_rule FloatAddOp = one_rule (twoLits (floatOp2 (+))) + primop_rule FloatSubOp = one_rule (twoLits (floatOp2 (-))) + primop_rule FloatMulOp = one_rule (twoLits (floatOp2 (*))) + primop_rule FloatDivOp = one_rule (twoLits (floatOp2Z (/))) + primop_rule FloatNegOp = one_rule (oneLit negOp) -- Double - primop_rule DoubleAddOp = Just (twoLits (doubleOp2 (+) op_name)) - primop_rule DoubleSubOp = Just (twoLits (doubleOp2 (-) op_name)) - primop_rule DoubleMulOp = Just (twoLits (doubleOp2 (*) op_name)) - primop_rule DoubleDivOp = Just (twoLits (doubleOp2Z (/) op_name)) - primop_rule DoubleNegOp = Just (oneLit (negOp op_name)) + primop_rule DoubleAddOp = one_rule (twoLits (doubleOp2 (+))) + primop_rule DoubleSubOp = one_rule (twoLits (doubleOp2 (-))) + primop_rule DoubleMulOp = one_rule (twoLits (doubleOp2 (*))) + primop_rule DoubleDivOp = one_rule (twoLits (doubleOp2Z (/))) + primop_rule DoubleNegOp = one_rule (oneLit negOp) -- Relational operators - primop_rule IntEqOp = Just (relop (==) `or_rule` litEq True op_name_case) - primop_rule IntNeOp = Just (relop (/=) `or_rule` litEq False op_name_case) - primop_rule CharEqOp = Just (relop (==) `or_rule` litEq True op_name_case) - primop_rule CharNeOp = Just (relop (/=) `or_rule` litEq False op_name_case) - - primop_rule IntGtOp = Just (relop (>)) - primop_rule IntGeOp = Just (relop (>=)) - primop_rule IntLeOp = Just (relop (<=)) - primop_rule IntLtOp = Just (relop (<)) - - primop_rule CharGtOp = Just (relop (>)) - primop_rule CharGeOp = Just (relop (>=)) - primop_rule CharLeOp = Just (relop (<=)) - primop_rule CharLtOp = Just (relop (<)) - - primop_rule FloatGtOp = Just (relop (>)) - primop_rule FloatGeOp = Just (relop (>=)) - primop_rule FloatLeOp = Just (relop (<=)) - primop_rule FloatLtOp = Just (relop (<)) - primop_rule FloatEqOp = Just (relop (==)) - primop_rule FloatNeOp = Just (relop (/=)) - - primop_rule DoubleGtOp = Just (relop (>)) - primop_rule DoubleGeOp = Just (relop (>=)) - primop_rule DoubleLeOp = Just (relop (<=)) - primop_rule DoubleLtOp = Just (relop (<)) - primop_rule DoubleEqOp = Just (relop (==)) - primop_rule DoubleNeOp = Just (relop (/=)) - - primop_rule WordGtOp = Just (relop (>)) - primop_rule WordGeOp = Just (relop (>=)) - primop_rule WordLeOp = Just (relop (<=)) - primop_rule WordLtOp = Just (relop (<)) - primop_rule WordEqOp = Just (relop (==)) - primop_rule WordNeOp = Just (relop (/=)) - - primop_rule other = Nothing - - - relop cmp = twoLits (cmpOp (\ord -> ord `cmp` EQ) op_name) + 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 IntGtOp = one_rule (relop (>)) + primop_rule IntGeOp = one_rule (relop (>=)) + primop_rule IntLeOp = one_rule (relop (<=)) + primop_rule IntLtOp = one_rule (relop (<)) + + primop_rule CharGtOp = one_rule (relop (>)) + primop_rule CharGeOp = one_rule (relop (>=)) + primop_rule CharLeOp = one_rule (relop (<=)) + primop_rule CharLtOp = one_rule (relop (<)) + + primop_rule FloatGtOp = one_rule (relop (>)) + primop_rule FloatGeOp = one_rule (relop (>=)) + primop_rule FloatLeOp = one_rule (relop (<=)) + primop_rule FloatLtOp = one_rule (relop (<)) + primop_rule FloatEqOp = one_rule (relop (==)) + primop_rule FloatNeOp = one_rule (relop (/=)) + + primop_rule DoubleGtOp = one_rule (relop (>)) + primop_rule DoubleGeOp = one_rule (relop (>=)) + primop_rule DoubleLeOp = one_rule (relop (<=)) + primop_rule DoubleLtOp = one_rule (relop (<)) + primop_rule DoubleEqOp = one_rule (relop (==)) + primop_rule DoubleNeOp = one_rule (relop (/=)) + + primop_rule WordGtOp = one_rule (relop (>)) + primop_rule WordGeOp = one_rule (relop (>=)) + primop_rule WordLeOp = one_rule (relop (<=)) + primop_rule WordLtOp = one_rule (relop (<)) + primop_rule WordEqOp = one_rule (relop (==)) + primop_rule WordNeOp = one_rule (relop (/=)) + + primop_rule other = [] + + + relop cmp = twoLits (cmpOp (\ord -> ord `cmp` EQ)) -- Cunning. cmpOp compares the values to give an Ordering. -- It applies its argument to that ordering value to turn -- the ordering into a boolean value. (`cmp` EQ) is just the job. @@ -179,17 +182,17 @@ why we have the catch-all Nothing case. \begin{code} -------------------------- -litCoerce :: (Literal -> Literal) -> RuleName -> Literal -> Maybe (RuleName, CoreExpr) -litCoerce fn name lit | isLitLitLit lit = Nothing - | otherwise = Just (name, Lit (fn lit)) +litCoerce :: (Literal -> Literal) -> Literal -> Maybe CoreExpr +litCoerce fn lit | isLitLitLit lit = Nothing + | otherwise = Just (Lit (fn lit)) -------------------------- -cmpOp :: (Ordering -> Bool) -> FAST_STRING -> Literal -> Literal -> Maybe (RuleName, CoreExpr) -cmpOp cmp name l1 l2 +cmpOp :: (Ordering -> Bool) -> Literal -> Literal -> Maybe CoreExpr +cmpOp cmp l1 l2 = go l1 l2 where - done res | cmp res = Just (name, trueVal) - | otherwise = Just (name, falseVal) + done res | cmp res = Just trueVal + | otherwise = Just falseVal -- These compares are at different types go (MachChar i1) (MachChar i2) = done (i1 `compare` i2) @@ -203,58 +206,57 @@ cmpOp cmp name l1 l2 -------------------------- -negOp name (MachFloat f) = Just (name, mkFloatVal (-f)) -negOp name (MachDouble d) = Just (name, mkDoubleVal (-d)) -negOp name (MachInt i) = intResult name (-i) -negOp name l = Nothing +negOp (MachFloat f) = Just (mkFloatVal (-f)) +negOp (MachDouble d) = Just (mkDoubleVal (-d)) +negOp (MachInt i) = intResult (-i) +negOp l = Nothing -------------------------- -intOp2 op name (MachInt i1) (MachInt i2) - = intResult name (i1 `op` i2) -intOp2 op name l1 l2 = Nothing -- Could find LitLit +intOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` i2) +intOp2 op l1 l2 = Nothing -- Could find LitLit -intOp2Z op name (MachInt i1) (MachInt i2) - | i2 /= 0 = Just (name, mkIntVal (i1 `op` i2)) -intOp2Z op name l1 l2 = Nothing -- LitLit or zero dividend +intOp2Z op (MachInt i1) (MachInt i2) + | i2 /= 0 = Just (mkIntVal (i1 `op` i2)) +intOp2Z op l1 l2 = Nothing -- LitLit or zero dividend -------------------------- #if __GLASGOW_HASKELL__ >= 500 -wordOp2 op name (MachWord w1) (MachWord w2) - = wordResult name (w1 `op` w2) -wordOp2 op name l1 l2 = Nothing -- Could find LitLit +wordOp2 op (MachWord w1) (MachWord w2) + = wordResult (w1 `op` w2) +wordOp2 op l1 l2 = Nothing -- Could find LitLit #endif -wordOp2Z op name (MachWord w1) (MachWord w2) - | w2 /= 0 = Just (name, mkWordVal (w1 `op` w2)) -wordOp2Z op name l1 l2 = Nothing -- LitLit or zero dividend +wordOp2Z op (MachWord w1) (MachWord w2) + | w2 /= 0 = Just (mkWordVal (w1 `op` w2)) +wordOp2Z op l1 l2 = Nothing -- LitLit or zero dividend #if __GLASGOW_HASKELL__ >= 500 -wordBitOp2 op name l1@(MachWord w1) l2@(MachWord w2) - = Just (name, mkWordVal (w1 `op` w2)) +wordBitOp2 op l1@(MachWord w1) l2@(MachWord w2) + = Just (mkWordVal (w1 `op` w2)) #else -- Integer is not an instance of Bits, so we operate on Word64 -wordBitOp2 op name l1@(MachWord w1) l2@(MachWord w2) - = Just (name, mkWordVal ((fromIntegral::Word64->Integer) (fromIntegral w1 `op` fromIntegral w2))) +wordBitOp2 op l1@(MachWord w1) l2@(MachWord w2) + = Just (mkWordVal ((fromIntegral::Word64->Integer) (fromIntegral w1 `op` fromIntegral w2))) #endif -wordBitOp2 op name l1 l2 = Nothing -- Could find LitLit +wordBitOp2 op l1 l2 = Nothing -- Could find LitLit -------------------------- -floatOp2 op name (MachFloat f1) (MachFloat f2) - = Just (name, mkFloatVal (f1 `op` f2)) -floatOp2 op name l1 l2 = Nothing +floatOp2 op (MachFloat f1) (MachFloat f2) + = Just (mkFloatVal (f1 `op` f2)) +floatOp2 op l1 l2 = Nothing -floatOp2Z op name (MachFloat f1) (MachFloat f2) - | f2 /= 0 = Just (name, mkFloatVal (f1 `op` f2)) -floatOp2Z op name l1 l2 = Nothing +floatOp2Z op (MachFloat f1) (MachFloat f2) + | f2 /= 0 = Just (mkFloatVal (f1 `op` f2)) +floatOp2Z op l1 l2 = Nothing -------------------------- -doubleOp2 op name (MachDouble f1) (MachDouble f2) - = Just (name, mkDoubleVal (f1 `op` f2)) -doubleOp2 op name l1 l2 = Nothing +doubleOp2 op (MachDouble f1) (MachDouble f2) + = Just (mkDoubleVal (f1 `op` f2)) +doubleOp2 op l1 l2 = Nothing -doubleOp2Z op name (MachDouble f1) (MachDouble f2) - | f2 /= 0 = Just (name, mkDoubleVal (f1 `op` f2)) -doubleOp2Z op name l1 l2 = Nothing +doubleOp2Z op (MachDouble f1) (MachDouble f2) + | f2 /= 0 = Just (mkDoubleVal (f1 `op` f2)) +doubleOp2Z op l1 l2 = Nothing -------------------------- @@ -278,16 +280,15 @@ doubleOp2Z op name l1 l2 = Nothing -- (modulo the usual precautions to avoid duplicating e1) litEq :: Bool -- True <=> equality, False <=> inequality - -> RuleName - -> RuleFun -litEq is_eq name [Lit lit, expr] = do_lit_eq is_eq name lit expr -litEq is_eq name [expr, Lit lit] = do_lit_eq is_eq name lit expr -litEq is_eq name other = Nothing - -do_lit_eq is_eq name lit expr - = Just (name, Case expr (mkWildId (literalType lit)) - [(DEFAULT, [], val_if_neq), - (LitAlt lit, [], val_if_eq)]) + -> RuleFun +litEq is_eq [Lit lit, expr] = do_lit_eq is_eq lit expr +litEq is_eq [expr, Lit lit] = do_lit_eq is_eq lit expr +litEq is_eq other = Nothing + +do_lit_eq is_eq lit expr + = Just (Case expr (mkWildId (literalType lit)) + [(DEFAULT, [], val_if_neq), + (LitAlt lit, [], val_if_eq)]) where val_if_eq | is_eq = trueVal | otherwise = falseVal @@ -299,14 +300,14 @@ do_lit_eq is_eq name lit expr -- ((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))) +intResult :: Integer -> Maybe CoreExpr +intResult result + = Just (mkIntVal (toInteger (fromInteger result :: Int))) #if __GLASGOW_HASKELL__ >= 500 -wordResult :: RuleName -> Integer -> Maybe (RuleName, CoreExpr) -wordResult name result - = Just (name, mkWordVal (toInteger (fromInteger result :: Word))) +wordResult :: Integer -> Maybe CoreExpr +wordResult result + = Just (mkWordVal (toInteger (fromInteger result :: Word))) #endif \end{code} @@ -318,16 +319,16 @@ wordResult name result %************************************************************************ \begin{code} -type RuleFun = [CoreExpr] -> Maybe (RuleName, CoreExpr) +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 (RuleName, CoreExpr)) -> RuleFun +twoLits :: (Literal -> Literal -> Maybe CoreExpr) -> RuleFun twoLits rule [Lit l1, Lit l2] = rule (convFloating l1) (convFloating l2) twoLits rule _ = Nothing -oneLit :: (Literal -> Maybe (RuleName, CoreExpr)) -> RuleFun +oneLit :: (Literal -> Maybe CoreExpr) -> RuleFun oneLit rule [Lit l1] = rule (convFloating l1) oneLit rule _ = Nothing @@ -351,7 +352,7 @@ mkDoubleVal d = Lit (convFloating (MachDouble d)) \end{code} \begin{code} -nullAddrRule _ = Just(SLIT("nullAddr"), Lit(nullAddrLit)) +nullAddrRule _ = Just(Lit nullAddrLit) \end{code} @@ -416,7 +417,7 @@ NB: If we ever do case-floating, we have an extra worry: 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 [Type ty, arg] | exprIsValue arg = Just (mkIntVal 1) seqRule other = Nothing \end{code} @@ -429,7 +430,7 @@ tagToEnumRule [Type ty, Lit (MachInt i)] [] -> Nothing -- Abstract type (dc:rest) -> ASSERT( null rest ) - Just (SLIT("TagToEnum"), Var (dataConId dc)) + Just (Var (dataConId dc)) where correct_tag dc = (dataConTag dc - fIRST_TAG) == tag tag = fromInteger i @@ -447,8 +448,7 @@ For dataToTag#, we can reduce if either dataToTagRule [_, val_arg] = case exprIsConApp_maybe val_arg of Just (dc,_) -> ASSERT( not (isNewTyCon (dataConTyCon dc)) ) - Just (SLIT("DataToTag"), - mkIntVal (toInteger (dataConTag dc - fIRST_TAG))) + Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG))) other -> Nothing @@ -465,7 +465,7 @@ dataToTagRule other = Nothing builtinRules :: [(Name, CoreRule)] -- Rules for non-primops that can't be expressed using a RULE pragma builtinRules - = [ (unpackCStringFoldrName, BuiltinRule match_append_lit_str) + = [ (unpackCStringFoldrName, BuiltinRule SLIT("AppendLitString") match_append_lit_str) ] @@ -483,8 +483,7 @@ match_append_lit_str [Type ty1, | unpk `hasKey` unpackCStringFoldrIdKey && c1 `cheapEqExpr` c2 = ASSERT( ty1 `eqType` ty2 ) - Just (SLIT("AppendLitString"), - Var unpk `App` Type ty1 + Just (Var unpk `App` Type ty1 `App` Lit (MachStr (s1 _APPEND_ s2)) `App` c1 `App` n) diff --git a/ghc/compiler/prelude/primops.txt b/ghc/compiler/prelude/primops.txt index e1d6bda..4268859 100644 --- a/ghc/compiler/prelude/primops.txt +++ b/ghc/compiler/prelude/primops.txt @@ -1,5 +1,5 @@ ----------------------------------------------------------------------- --- $Id: primops.txt,v 1.25 2001/08/17 17:18:53 apt Exp $ +-- $Id: primops.txt,v 1.26 2001/09/14 15:51:42 simonpj Exp $ -- -- Primitive Operations -- @@ -284,7 +284,6 @@ defaults - @@ -532,6 +531,32 @@ defaults + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -598,10 +623,17 @@ defaults + + + + + + + @@ -1112,7 +1144,7 @@ section "The word size story." {Haskell98 specifies that signed integers (type {\tt Int}) must contain at least 30 bits. GHC always implements {\tt Int} using the primitive type {\tt Int\#}, whose size equals the {\tt MachDeps.h} constant {\tt WORD\_SIZE\_IN\_BITS}. This - is normally set based on the {\tt config.h} parameter {\tt 4}, + is normally set based on the {\tt config.h} parameter {\tt SIZEOF\_LONG}, i.e., 32 bits on 32-bit machines, 64 bits on 64-bit machines. However, it can also be explicitly set to a smaller number, e.g., 31 bits, to allow the possibility of using tag bits. Currently GHC itself has only 32-bit and 64-bit variants, @@ -1127,7 +1159,7 @@ section "The word size story." and a range of conversions. The 8-bit and 16-bit sizes are always represented as {\tt Int\#} and {\tt Word\#}, and the operations implemented in terms of the the primops on these types, with suitable range restrictions on the results - (using the {\tt Narrow$n$Int\#} and {\tt Narrow$n$Word\#} families of primops. + (using the {\tt narrow$n$Int\#} and {\tt narrow$n$Word\#} families of primops. The 32-bit sizes are represented using {\tt Int\#} and {\tt Word\#} when {\tt WORD\_SIZE\_IN\_BITS} $\geq$ 32; otherwise, these are represented using distinct primitive types {\tt Int32\#} @@ -2278,14 +2310,14 @@ primop BlockAsyncExceptionsOp "blockAsyncExceptions#" GenPrimOp (State# RealWorld -> (# State# RealWorld, a #)) -> (State# RealWorld -> (# State# RealWorld, a #)) with - strictness = { \ arity -> StrictnessInfo [wwLazy] False } + strictness = { \ arity -> StrictnessInfo [wwLazy, wwPrim] False } out_of_line = True primop UnblockAsyncExceptionsOp "unblockAsyncExceptions#" GenPrimOp (State# RealWorld -> (# State# RealWorld, a #)) -> (State# RealWorld -> (# State# RealWorld, a #)) with - strictness = { \ arity -> StrictnessInfo [wwLazy] False } + strictness = { \ arity -> StrictnessInfo [wwLazy, wwPrim] False } out_of_line = True ------------------------------------------------------------------------ diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index 3a57ab2..f6b2292 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -69,7 +69,7 @@ occurAnalyseGlobalExpr expr snd (occurAnalyseExpr (\_ -> False) expr) occurAnalyseRule :: CoreRule -> CoreRule -occurAnalyseRule rule@(BuiltinRule _) = rule +occurAnalyseRule rule@(BuiltinRule _ _) = rule occurAnalyseRule (Rule str tpl_vars tpl_args rhs) -- Add occ info to tpl_vars, rhs = Rule str tpl_vars' tpl_args rhs' diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 5ef10cd..39811e7 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -12,7 +12,6 @@ import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), SwitchResult(..), intSwitchSet, DynFlags, DynFlag(..), dopt, dopt_CoreToDo ) -import CoreLint ( showPass, endPass ) import CoreSyn import CoreFVs ( ruleRhsFreeVars ) import HscTypes ( PersistentCompilerState(..), @@ -20,7 +19,8 @@ import HscTypes ( PersistentCompilerState(..), ) import CSE ( cseProgram ) import Rules ( RuleBase, emptyRuleBase, ruleBaseFVs, ruleBaseIds, - extendRuleBaseList, addRuleBaseFVs, pprRuleBase ) + extendRuleBaseList, addRuleBaseFVs, pprRuleBase, + ruleCheckProgram ) import Module ( moduleEnvElts ) import CoreUnfold import PprCore ( pprCoreBindings, pprCoreExpr ) @@ -29,7 +29,8 @@ import CoreUtils ( coreBindsSize ) import Simplify ( simplTopBinds, simplExpr ) import SimplUtils ( simplBinders ) import SimplMonad -import ErrUtils ( dumpIfSet, dumpIfSet_dyn ) +import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass ) +import CoreLint ( endPass ) import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) import Id ( idName, isDataConWrapId, setIdLocalExported, isImplicitId ) @@ -171,6 +172,8 @@ doCorePass dfs rb us binds CoreDoUSPInf = _scc_ "CoreUsageSPInf" noStats dfs (doUsageSPInf dfs us binds) doCorePass dfs rb us binds CoreDoGlomBinds = noStats dfs (glomBinds dfs binds) +doCorePass dfs rb us binds (CoreDoRuleCheck pat) + = noStats dfs (ruleCheck dfs pat binds) doCorePass dfs rb us binds CoreDoNothing = noStats dfs (return binds) @@ -178,8 +181,13 @@ printCore binds = do dumpIfSet True "Print Core" (pprCoreBindings binds) return binds +ruleCheck dflags pat binds = do showPass dflags "RuleCheck" + printDump (ruleCheckProgram pat binds) + return binds + -- most passes return no stats and don't change rules noStats dfs thing = do { binds <- thing; return (zeroSimplCount dfs, binds) } + \end{code} @@ -304,7 +312,7 @@ which without simplification looked like: This doesn't match unless you do eta reduction on the build argument. \begin{code} -simplRule rule@(id, BuiltinRule _) +simplRule rule@(id, BuiltinRule _ _) = returnSmpl rule simplRule rule@(id, Rule name bndrs args rhs) = simplBinders bndrs $ \ bndrs' -> diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs index 70112ed..6d0bd98 100644 --- a/ghc/compiler/simplCore/SimplMonad.lhs +++ b/ghc/compiler/simplCore/SimplMonad.lhs @@ -633,14 +633,12 @@ getBlackList dflags env us sc = (seBlackList env, us, sc) noInlineBlackList :: SimplM BlackList -- Inside inlinings, black list anything that is in scope or imported. - -- except for things that must be unfolded (Compulsory) - -- and data con wrappers. The latter is a hack, like the one in + -- except for data con wrappers. The exception is a hack, like the one in -- SimplCore.simplRules, to make wrappers inline in rule LHSs. -- We may as well do the same here. noInlineBlackList dflags env us sc = (blacklisted,us,sc) where blacklisted v = - not (isCompulsoryUnfolding (idUnfolding v)) && - not (isDataConWrapId v) && + not (isDataConWrapId v) && (v `isInScope` (seSubst env) || isGlobalId v) -- NB: An earlier version omitted the last clause; this meant -- that even inlinings *completely within* an INLINE didn't happen. diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs index 4535aab..b3e305e 100644 --- a/ghc/compiler/specialise/Rules.lhs +++ b/ghc/compiler/specialise/Rules.lhs @@ -8,7 +8,7 @@ module Rules ( RuleBase, emptyRuleBase, extendRuleBase, extendRuleBaseList, addRuleBaseFVs, ruleBaseIds, ruleBaseFVs, - pprRuleBase, + pprRuleBase, ruleCheckProgram, lookupRule, addRule, addIdSpecialisations ) where @@ -22,7 +22,7 @@ import CoreUnfold ( isCheapUnfolding, unfoldingTemplate ) import CoreUtils ( eqExpr ) import PprCore ( pprCoreRule ) import Subst ( Subst, InScopeSet, mkInScopeSet, lookupSubst, extendSubst, - substEnv, setSubstEnv, emptySubst, isInScope, + substEnv, setSubstEnv, emptySubst, isInScope, emptyInScopeSet, bindSubstList, unBindSubstList, substInScope, uniqAway ) import Id ( Id, idUnfolding, idSpecialisation, setIdSpecialisation ) @@ -35,6 +35,8 @@ import qualified TcType ( match ) import Outputable import Maybe ( isJust, isNothing, fromMaybe ) import Util ( sortLt ) +import Bag +import List ( isPrefixOf ) \end{code} @@ -134,7 +136,10 @@ matchRule :: InScopeSet -> CoreRule -> [CoreExpr] -> Maybe (RuleName, CoreExpr) -- (\x->E) matches (\x->F x) -matchRule in_scope rule@(BuiltinRule match_fn) args = match_fn args +matchRule in_scope rule@(BuiltinRule name match_fn) args + = case match_fn args of + Just expr -> Just (name,expr) + Nothing -> Nothing matchRule in_scope rule@(Rule rn tpl_vars tpl_args rhs) args = go tpl_args args emptySubst @@ -395,7 +400,11 @@ match_ty ty1 ty2 tpl_vars kont subst %************************************************************************ \begin{code} -addRule :: CoreRules -> Id -> CoreRule -> CoreRules +addRule :: Id -> CoreRules -> CoreRule -> CoreRules + +-- Add a new rule to an existing bunch of rules. +-- The rules are for the given Id; the Id argument is needed only +-- so that we can exclude the Id from its own RHS free-var set -- Insert the new rule just before a rule that is *less specific* -- than the new one; or at the end if there isn't such a one. @@ -405,11 +414,11 @@ addRule :: CoreRules -> Id -> CoreRule -> CoreRules -- We make no check for rules that unify without one dominating -- the other. Arguably this would be a bug. -addRule (Rules rules rhs_fvs) id rule@(BuiltinRule _) +addRule id (Rules rules rhs_fvs) rule@(BuiltinRule _ _) = Rules (rule:rules) rhs_fvs -- Put it at the start for lack of anything better -addRule (Rules rules rhs_fvs) id rule +addRule id (Rules rules rhs_fvs) rule = Rules (insertRule rules new_rule) (rhs_fvs `unionVarSet` new_rhs_fvs) where new_rule = occurAnalyseRule rule @@ -437,14 +446,13 @@ addIdSpecialisations :: Id -> [CoreRule] -> Id addIdSpecialisations id rules = setIdSpecialisation id new_specs where - new_specs = foldr add (idSpecialisation id) rules - add rule rules = addRule rules id rule + new_specs = foldl (addRule id) (idSpecialisation id) rules \end{code} %************************************************************************ %* * -\subsection{Preparing the rule base +\subsection{Looking up a rule} %* * %************************************************************************ @@ -458,6 +466,118 @@ lookupRule in_scope fn args %************************************************************************ %* * +\subsection{Checking a program for failing rule applications} +%* * +%************************************************************************ + +----------------------------------------------------- + Game plan +----------------------------------------------------- + +We want to know what sites have rules that could have fired but didn't. +This pass runs over the tree (without changing it) and reports such. + +NB: we assume that this follows a run of the simplifier, so every Id +occurrence (including occurrences of imported Ids) is decorated with +all its (active) rules. No need to construct a rule base or anything +like that. + +\begin{code} +ruleCheckProgram :: String -> [CoreBind] -> SDoc +-- Report partial matches for rules beginning +-- with the specified string +ruleCheckProgram rule_pat binds + | isEmptyBag results + = text "Rule check results: no rule application sites" + | otherwise + = vcat [text "Rule check results:", + line, + vcat [ p $$ line | p <- bagToList results ] + ] + where + results = unionManyBags (map (ruleCheckBind rule_pat) binds) + line = text (take 20 (repeat '-')) + +type RuleCheckEnv = String -- Pattern + +ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc + -- The Bag returned has one SDoc for each call site found +ruleCheckBind env (NonRec b r) = ruleCheck env r +ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (b,r) <- prs] + +ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc +ruleCheck env (Var v) = emptyBag +ruleCheck env (Lit l) = emptyBag +ruleCheck env (Type ty) = emptyBag +ruleCheck env (App f a) = ruleCheckApp env (App f a) [] +ruleCheck env (Note n e) = ruleCheck env e +ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e +ruleCheck env (Lam b e) = ruleCheck env e +ruleCheck env (Case e _ as) = ruleCheck env e `unionBags` + unionManyBags [ruleCheck env r | (_,_,r) <- as] + +ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as) +ruleCheckApp env (Var f) as = ruleCheckFun env f as +ruleCheckApp env other as = ruleCheck env other + +ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc +ruleCheckFun env fun args + = ruleAppCheck match fun args + where + match rule_name = env `isPrefixOf` _UNPK_ rule_name +\end{code} + +\begin{code} +ruleAppCheck :: (RuleName -> Bool) -> Id -> [CoreExpr] -> Bag SDoc +-- Produce a report for all rules matching the predicate +-- saying why it doesn't match the specified application + +ruleAppCheck name_match fn args + | null name_match_rules = emptyBag + | otherwise = unitBag (ruleAppCheck_help fn args name_match_rules) + where + name_match_rules = case idSpecialisation fn of + Rules rules _ -> filter match rules + match rule = name_match (ruleName rule) + +ruleAppCheck_help :: Id -> [CoreExpr] -> [CoreRule] -> SDoc +ruleAppCheck_help fn args rules + = -- The rules match the pattern, so we want to print something + vcat [text "Expression:" <+> ppr (mkApps (Var fn) args), + vcat (map check_rule rules)] + where + n_args = length args + i_args = args `zip` [1::Int ..] + + check_rule rule = rule_herald rule <> colon <+> rule_info rule + + rule_herald (BuiltinRule name _) = text "Builtin rule" <+> doubleQuotes (ptext name) + rule_herald (Rule name _ _ _) = text "Rule" <+> doubleQuotes (ptext name) + + rule_info rule + | Just (name,_) <- matchRule emptyInScopeSet rule args + = text "matches (which is very peculiar!)" + + rule_info (BuiltinRule name fn) = text "does not match" + + rule_info (Rule name rule_bndrs rule_args _) + | n_args < n_rule_args = text "too few arguments" + | n_mismatches == n_rule_args = text "no arguments match" + | n_mismatches == 0 = text "all arguments match (considered individually), but the rule as a whole does not" + | otherwise = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)" + where + n_rule_args = length rule_args + n_mismatches = length mismatches + mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args, + not (isJust (match_fn rule_arg arg))] + + bndr_set = mkVarSet rule_bndrs + match_fn rule_arg arg = match rule_arg arg bndr_set (\s -> Just ()) emptySubst +\end{code} + + +%************************************************************************ +%* * \subsection{Getting the rules ready} %* * %************************************************************************ @@ -492,7 +612,7 @@ extendRuleBase (RuleBase rule_ids rule_fvs) (id, rule) = RuleBase (extendVarSet rule_ids new_id) (rule_fvs `unionVarSet` extendVarSet lhs_fvs id) where - new_id = setIdSpecialisation id (addRule old_rules id rule) + new_id = setIdSpecialisation id (addRule id old_rules rule) old_rules = idSpecialisation (fromMaybe id (lookupVarSet rule_ids id)) -- Get the old rules from rule_ids if the Id is already there, but -- 1.7.10.4