summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSimon Peyton Jones <simonpj@microsoft.com>2021-08-15 14:26:34 +0100
committerKrzysztof Gogolewski <krzysztof.gogolewski@tweag.io>2021-08-15 16:43:25 +0200
commitf1541c311aa09d3c53b30a864ae0944a875645bb (patch)
treee0b5f848d82c7a8268e6aa6c23a41664d2081dff
parente3cc019c3046dee1fca2faa3b8a544a043515d81 (diff)
downloadhaskell-wip/T20200.tar.gz
Use the right InScopeSet for findBestwip/T20200
This is the right thing to do, easy to do, and fixes a second not-in-scope crash in #20200 (see !6302) The problem occurs in the findBest test, which compares two RULES. Repro case in simplCore/should_compile/T20200a
-rw-r--r--compiler/GHC/Core/Rules.hs43
-rw-r--r--testsuite/tests/simplCore/should_compile/T20200a.hs8
-rw-r--r--testsuite/tests/simplCore/should_compile/all.T1
3 files changed, 30 insertions, 22 deletions
diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs
index 9c7f083e46..139050a2b2 100644
--- a/compiler/GHC/Core/Rules.hs
+++ b/compiler/GHC/Core/Rules.hs
@@ -391,11 +391,11 @@ lookupRule :: RuleOpts -> InScopeEnv
-- See Note [Extra args in rule matching]
-- See comments on matchRule
-lookupRule opts in_scope is_active fn args rules
+lookupRule opts rule_env@(in_scope,_) is_active fn args rules
= -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $
case go [] rules of
[] -> Nothing
- (m:ms) -> Just (findBest (fn,args') m ms)
+ (m:ms) -> Just (findBest in_scope (fn,args') m ms)
where
rough_args = map roughTopName args
@@ -408,7 +408,7 @@ lookupRule opts in_scope is_active fn args rules
go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)]
go ms [] = ms
go ms (r:rs)
- | Just e <- matchRule opts in_scope is_active fn args' rough_args r
+ | Just e <- matchRule opts rule_env is_active fn args' rough_args r
= go ((r,mkTicks ticks e):ms) rs
| otherwise
= -- pprTrace "match failed" (ppr r $$ ppr args $$
@@ -418,16 +418,16 @@ lookupRule opts in_scope is_active fn args rules
-- , isCheapUnfolding unf] )
go ms rs
-findBest :: (Id, [CoreExpr])
+findBest :: InScopeSet -> (Id, [CoreExpr])
-> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr)
-- All these pairs matched the expression
-- Return the pair the most specific rule
-- The (fn,args) is just for overlap reporting
-findBest _ (rule,ans) [] = (rule,ans)
-findBest target (rule1,ans1) ((rule2,ans2):prs)
- | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs
- | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs
+findBest _ _ (rule,ans) [] = (rule,ans)
+findBest in_scope target (rule1,ans1) ((rule2,ans2):prs)
+ | isMoreSpecific in_scope rule1 rule2 = findBest in_scope target (rule1,ans1) prs
+ | isMoreSpecific in_scope rule2 rule1 = findBest in_scope target (rule2,ans2) prs
| debugIsOn = let pp_rule rule
= ifPprDebug (ppr rule)
(doubleQuotes (ftext (ruleName rule)))
@@ -437,12 +437,12 @@ findBest target (rule1,ans1) ((rule2,ans2):prs)
<+> sep (map ppr args)
, text "Rule 1:" <+> pp_rule rule1
, text "Rule 2:" <+> pp_rule rule2]) $
- findBest target (rule1,ans1) prs
- | otherwise = findBest target (rule1,ans1) prs
+ findBest in_scope target (rule1,ans1) prs
+ | otherwise = findBest in_scope target (rule1,ans1) prs
where
(fn,args) = target
-isMoreSpecific :: CoreRule -> CoreRule -> Bool
+isMoreSpecific :: InScopeSet -> CoreRule -> CoreRule -> Bool
-- This tests if one rule is more specific than another
-- We take the view that a BuiltinRule is less specific than
-- anything else, because we want user-define rules to "win"
@@ -453,17 +453,16 @@ isMoreSpecific :: CoreRule -> CoreRule -> Bool
-- {-# RULES "truncate/Double->Int" truncate = double2Int #-}
-- double2Int :: Double -> Int
-- We want the specific RULE to beat the built-in class-op rule
-isMoreSpecific (BuiltinRule {}) _ = False
-isMoreSpecific (Rule {}) (BuiltinRule {}) = True
-isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 })
- (Rule { ru_bndrs = bndrs2, ru_args = args2
- , ru_name = rule_name2, ru_rhs = rhs })
- = isJust (matchN (in_scope, id_unfolding_fun) rule_name2 bndrs2 args2 args1 rhs)
+isMoreSpecific _ (BuiltinRule {}) _ = False
+isMoreSpecific _ (Rule {}) (BuiltinRule {}) = True
+isMoreSpecific in_scope (Rule { ru_bndrs = bndrs1, ru_args = args1 })
+ (Rule { ru_bndrs = bndrs2, ru_args = args2
+ , ru_name = rule_name2, ru_rhs = rhs2 })
+ = isJust (matchN (full_in_scope, id_unfolding_fun)
+ rule_name2 bndrs2 args2 args1 rhs2)
where
id_unfolding_fun _ = NoUnfolding -- Don't expand in templates
- in_scope = mkInScopeSet (mkVarSet bndrs1)
- -- Actually we should probably include the free vars
- -- of rule1's args, but I can't be bothered
+ full_in_scope = in_scope `extendInScopeSetList` bndrs1
noBlackList :: Activation -> Bool
noBlackList _ = False -- Nothing is black listed
@@ -520,12 +519,12 @@ matchRule opts rule_env _is_active fn args _rough_args
Nothing -> Nothing
Just expr -> Just expr
-matchRule _ in_scope is_active _ args rough_args
+matchRule _ rule_env is_active _ args rough_args
(Rule { ru_name = rule_name, ru_act = act, ru_rough = tpl_tops
, ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs })
| not (is_active act) = Nothing
| ruleCantMatch tpl_tops rough_args = Nothing
- | otherwise = matchN in_scope rule_name tpl_vars tpl_args args rhs
+ | otherwise = matchN rule_env rule_name tpl_vars tpl_args args rhs
-- | Initialize RuleOpts from DynFlags
diff --git a/testsuite/tests/simplCore/should_compile/T20200a.hs b/testsuite/tests/simplCore/should_compile/T20200a.hs
new file mode 100644
index 0000000000..41f36d4e4f
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T20200a.hs
@@ -0,0 +1,8 @@
+module T20200a where
+
+import qualified Data.Map.Strict as Map
+
+f :: [Maybe (Int, Bool)]
+f = map Just
+ $ Map.keys
+ $ Map.fromListWith (||) []
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 28e5cb4fc9..03039e8f8c 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -373,3 +373,4 @@ test('T20174', normal, compile, [''])
test('T16373', normal, compile, [''])
test('T20112', normal, multimod_compile, ['T20112', '-O -v0 -g1'])
test('T20200', normal, compile, [''])
+test('T20200a', normal, compile, ['-O2'])