Fix the bug that source rules of primops shadowed builtin rules: let
extendRuleBase take the old rules from the id passed as the argument
when the id is absent in RuleBase.
I hope this is correct: I don't know what difference can be between
the id passed as extendRuleBase's argument and the id found in RuleBase.
Also use standard isJust, isNothing instead of non-standard
Maybes.maybeToBool.
import qualified Unify ( match )
import Outputable
import qualified Unify ( match )
import Outputable
-import Maybes ( maybeToBool )
+import Maybe ( isJust, isNothing, fromMaybe )
import Util ( sortLt )
\end{code}
import Util ( sortLt )
\end{code}
mk_result_args subst done)
Nothing -> Nothing -- Failure
where
mk_result_args subst done)
Nothing -> Nothing -- Failure
where
- (done, leftovers) = partition (\v -> maybeToBool (lookupSubstEnv subst_env v))
+ (done, leftovers) = partition (\v -> isJust (lookupSubstEnv subst_env v))
(map zapOccInfo tpl_vars)
-- Zap the occ info
subst_env = substEnv subst
(map zapOccInfo tpl_vars)
-- Zap the occ info
subst_env = substEnv subst
subst' = bindSubstList subst vs1 vs2
-- The unBindSubst relies on no shadowing in the template
subst' = bindSubstList subst vs1 vs2
-- The unBindSubst relies on no shadowing in the template
- not_in_subst v = not (maybeToBool (lookupSubst subst v))
+ not_in_subst v = isNothing (lookupSubst subst v)
bug_msg = sep [ppr vs1, ppr vs2]
----------------------------------------
bug_msg = sep [ppr vs1, ppr vs2]
----------------------------------------
go (rule:rules) | new_is_more_specific rule = (new_rule:rule:rules)
| otherwise = rule : go rules
go (rule:rules) | new_is_more_specific rule = (new_rule:rule:rules)
| otherwise = rule : go rules
- new_is_more_specific rule = maybeToBool (matchRule tpl_var_set rule tpl_args)
+ new_is_more_specific rule = isJust (matchRule tpl_var_set rule tpl_args)
addIdSpecialisations :: Id -> [CoreRule] -> Id
addIdSpecialisations id rules
addIdSpecialisations :: Id -> [CoreRule] -> Id
addIdSpecialisations id rules
(rule_fvs `unionVarSet` extendVarSet lhs_fvs id)
where
new_id = setIdSpecialisation id (addRule old_rules id rule)
(rule_fvs `unionVarSet` extendVarSet lhs_fvs id)
where
new_id = setIdSpecialisation id (addRule old_rules id rule)
- old_rules = case lookupVarSet rule_ids id of
- Nothing -> emptyCoreRules
- Just id' -> idSpecialisation id'
-
+ old_rules = idSpecialisation (fromMaybe id (lookupVarSet rule_ids id))
lhs_fvs = ruleLhsFreeIds rule
-- Finds *all* the free Ids of the LHS, not just
-- locally defined ones!!
lhs_fvs = ruleLhsFreeIds rule
-- Finds *all* the free Ids of the LHS, not just
-- locally defined ones!!