[commit: ghc] ghc-7.10: Do not quantify over the function itself in a RULE (211cc28)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-7.10
Link       : http://ghc.haskell.org/trac/ghc/changeset/211cc28688c9424105c204f535ff54033a2c657e/ghc

>---------------------------------------------------------------

commit 211cc28688c9424105c204f535ff54033a2c657e
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Tue Apr 7 14:01:39 2015 +0100

    Do not quantify over the function itself in a RULE
    
    We were erroneously quantifying over the function when it
    had a dictionary type. A bit pathological, but possible.
    
    This fixes Trac #10251
    
    (cherry picked from commit cfb60421a43f23e75ead85d99cec207a156f9312)


>---------------------------------------------------------------

211cc28688c9424105c204f535ff54033a2c657e
 compiler/deSugar/DsBinds.hs                      | 43 ++++++++++++++----------
 testsuite/tests/deSugar/should_compile/T10251.hs | 41 ++++++++++++++++++++++
 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 76b53ac..51679a8 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -603,37 +603,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 0000000..afca7fb
--- /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 ac8f95c..956f951 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, [''])