diff options
| -rw-r--r-- | compiler/deSugar/DsBinds.hs | 43 | ||||
| -rw-r--r-- | testsuite/tests/deSugar/should_compile/T10251.hs | 41 | ||||
| -rw-r--r-- | testsuite/tests/deSugar/should_compile/all.T | 1 |
3 files changed, 68 insertions, 17 deletions
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index 488ffa3544..c2d21bd9fb 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -569,37 +569,46 @@ decomposeRuleLhs orig_bndrs orig_lhs -- See Note [Unused spec binders] = Left (vcat (map dead_msg unbound)) - | Var fn_var <- fun - , not (fn_var `elemVarSet` orig_bndr_set) + | Just (fn_id, args) <- decompose fun2 args2 + , let extra_dict_bndrs = mk_extra_dict_bndrs fn_id args = -- pprTrace "decmposeRuleLhs" (vcat [ ptext (sLit "orig_bndrs:") <+> ppr orig_bndrs -- , ptext (sLit "orig_lhs:") <+> ppr orig_lhs -- , ptext (sLit "lhs1:") <+> ppr lhs1 - -- , ptext (sLit "bndrs1:") <+> ppr bndrs1 - -- , ptext (sLit "fn_var:") <+> ppr fn_var + -- , ptext (sLit "extra_dict_bndrs:") <+> ppr extra_dict_bndrs + -- , ptext (sLit "fn_id:") <+> ppr fn_id -- , ptext (sLit "args:") <+> ppr args]) $ - Right (bndrs1, fn_var, args) - - | Case scrut bndr ty [(DEFAULT, _, body)] <- fun - , isDeadBinder bndr -- Note [Matching seqId] - , let args' = [Type (idType bndr), Type ty, scrut, body] - = Right (bndrs1, seqId, args' ++ args) + Right (orig_bndrs ++ extra_dict_bndrs, fn_id, args) | otherwise = Left bad_shape_msg where - lhs1 = drop_dicts orig_lhs - lhs2 = simpleOptExpr lhs1 -- See Note [Simplify rule LHS] - (fun,args) = collectArgs lhs2 + lhs1 = drop_dicts orig_lhs + lhs2 = simpleOptExpr lhs1 -- See Note [Simplify rule LHS] + (fun2,args2) = collectArgs lhs2 + lhs_fvs = exprFreeVars lhs2 unbound = filterOut (`elemVarSet` lhs_fvs) orig_bndrs - bndrs1 = orig_bndrs ++ extra_dict_bndrs orig_bndr_set = mkVarSet orig_bndrs -- Add extra dict binders: Note [Free dictionaries] - extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d) - | d <- varSetElems (lhs_fvs `delVarSetList` orig_bndrs) - , isDictId d ] + mk_extra_dict_bndrs fn_id args + = [ mkLocalId (localiseName (idName d)) (idType d) + | d <- varSetElems (exprsFreeVars args `delVarSetList` (fn_id : orig_bndrs)) + -- fn_id: do not quantify over the function itself, which may + -- itself be a dictionary (in pathological cases, Trac #10251) + , isDictId d ] + + decompose (Var fn_id) args + | not (fn_id `elemVarSet` orig_bndr_set) + = Just (fn_id, args) + + decompose (Case scrut bndr ty [(DEFAULT, _, body)]) args + | isDeadBinder bndr -- Note [Matching seqId] + , let args' = [Type (idType bndr), Type ty, scrut, body] + = Just (seqId, args' ++ args) + + decompose _ _ = Nothing bad_shape_msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar")) 2 (vcat [ text "Optimised lhs:" <+> ppr lhs2 diff --git a/testsuite/tests/deSugar/should_compile/T10251.hs b/testsuite/tests/deSugar/should_compile/T10251.hs new file mode 100644 index 0000000000..afca7fb9c7 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T10251.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -O #-} +module T10251 where + +data D = D +data E = E + +class Storable a where + poke2 :: a -> E +instance Storable D where + poke2 = poke2 -- undefined + +class Foo a where +instance Foo D where + +class (Foo t, Storable t) => FooStorable t where + +instance FooStorable D where + {-# SPECIALIZE instance FooStorable D #-} + +{-# SPECIALIZE bug :: D -> E #-} + +bug + :: FooStorable t + => t + -> E +bug = poke2 +{- +sf 9160 # ghc -c -fforce-recomp -Wall B.hs + +ghc: panic! (the 'impossible' happened) + (GHC version 7.10.1 for x86_64-unknown-linux): + Template variable unbound in rewrite rule + $fFooStorableD_XU + [$fFooStorableD_XU] + [$fFooStorableD_XU] + [] + [] + +Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug +-} diff --git a/testsuite/tests/deSugar/should_compile/all.T b/testsuite/tests/deSugar/should_compile/all.T index ac8f95c0c2..956f951151 100644 --- a/testsuite/tests/deSugar/should_compile/all.T +++ b/testsuite/tests/deSugar/should_compile/all.T @@ -103,3 +103,4 @@ test('T5252Take2', test('T2431', normal, compile, ['-ddump-simpl -dsuppress-uniques']) test('T7669', normal, compile, ['']) test('T8470', normal, compile, ['']) +test('T10251', normal, compile, ['']) |