Do not quantify over the function itself in a RULE
authorSimon Peyton Jones <simonpj@microsoft.com>
Tue, 7 Apr 2015 13:01:39 +0000 (14:01 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Tue, 7 Apr 2015 14:10:37 +0000 (15:10 +0100)
We were erroneously quantifying over the function when it
had a dictionary type. A bit pathological, but possible.

This fixes Trac #10251

compiler/deSugar/DsBinds.hs
testsuite/tests/deSugar/should_compile/T10251.hs [new file with mode: 0644]
testsuite/tests/deSugar/should_compile/all.T

index 488ffa3..c2d21bd 100644 (file)
@@ -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 (file)
index 0000000..afca7fb
--- /dev/null
@@ -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
+-}
index ac8f95c..956f951 100644 (file)
@@ -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, [''])