Fix recompilation bug with default class methods (#15970)

If a module uses a class, then it can instantiate the class and
thereby use its default methods, so we must include the default
methods when calculating the fingerprint for the class.

Test Plan:
New unit test: driver/T15970

Before:

```
=====> T15970(normal) 1 of 1 [0, 0, 0]
cd "T15970.run" && $MAKE -s --no-print-directory T15970
Wrong exit code for T15970()(expected 0 , actual 2 )
Stdout ( T15970 ):
Makefile:13: recipe for target 'T15970' failed
Stderr ( T15970 ):
C.o:function Main_zdfTypeClassMyDataType1_info: error: undefined
reference to 'A_toTypedData2_closure'
C.o:function Main_main1_info: error: undefined reference to
'A_toTypedData2_closure'
C.o(.data+0x298): error: undefined reference to 'A_toTypedData2_closure'
C.o(.data+0x480): error: undefined reference to 'A_toTypedData2_closure'
collect2: error: ld returned 1 exit status
`gcc' failed in phase `Linker'. (Exit code: 1)
```

After: test passes.

Reviewers: bgamari, simonpj, erikd, watashi, afarmer

Subscribers: rwbarton, carter

GHC Trac Issues: #15970

Differential Revision: https://phabricator.haskell.org/D5394

(cherry picked from commit 288f681e06accbae690c46eb8a6e997fa9e5f56a)

7 files changed, 134 insertions, 13 deletions

diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index 8381a5975b..32c825cff5 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -460,8 +460,18 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
        -- See also Note [Identity versus semantic module]
        declABI decl = (this_mod, decl, extras)
         where extras = declExtras fix_fn ann_fn non_orph_rules non_orph_insts
-                                  non_orph_fis decl
-
+                                  non_orph_fis top_lvl_name_env decl
+
+       -- This is used for looking up the Name of a default method
+       -- from its OccName. See Note [default method Name]
+       top_lvl_name_env =
+         mkOccEnv [ (nameOccName nm, nm)
+                  | IfaceId { ifName = nm } <- new_decls ]
+
+       -- Dependency edges between declarations in the current module.
+       -- This is computed by finding the free external names of each
+       -- declaration, including IfaceDeclExtras (things that a
+       -- declaration implicitly depends on).
        edges :: [ Node Unique IfaceDeclABI ]
        edges = [ DigraphNode abi (getUnique (getOccName decl)) out
                | decl <- new_decls
@@ -858,6 +868,12 @@ data IfaceDeclExtras
                                 -- See Note [Orphans] in InstEnv
        [AnnPayload]             -- Annotations of the type itself
        [IfaceIdExtras]          -- For each class method: fixity, RULES and annotations
+       [IfExtName]              -- Default methods. If a module
+                                -- mentions a class, then it can
+                                -- instantiate the class and thereby
+                                -- use the default methods, so we must
+                                -- include these in the fingerprint of
+                                -- a class.
 
   | IfaceSynonymExtras (Maybe Fixity) [AnnPayload]
 
@@ -893,8 +909,9 @@ freeNamesDeclExtras (IfaceIdExtras id_extras)
   = freeNamesIdExtras id_extras
 freeNamesDeclExtras (IfaceDataExtras  _ insts _ subs)
   = unionNameSets (mkNameSet insts : map freeNamesIdExtras subs)
-freeNamesDeclExtras (IfaceClassExtras _ insts _ subs)
-  = unionNameSets (mkNameSet insts : map freeNamesIdExtras subs)
+freeNamesDeclExtras (IfaceClassExtras _ insts _ subs defms)
+  = unionNameSets $
+      mkNameSet insts : mkNameSet defms : map freeNamesIdExtras subs
 freeNamesDeclExtras (IfaceSynonymExtras _ _)
   = emptyNameSet
 freeNamesDeclExtras (IfaceFamilyExtras _ insts _)
@@ -912,8 +929,9 @@ instance Outputable IfaceDeclExtras where
   ppr (IfaceFamilyExtras fix finsts anns) = vcat [ppr fix, ppr finsts, ppr anns]
   ppr (IfaceDataExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns,
                                                 ppr_id_extras_s stuff]
-  ppr (IfaceClassExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns,
-                                                 ppr_id_extras_s stuff]
+  ppr (IfaceClassExtras fix insts anns stuff defms) =
+    vcat [ppr fix, ppr_insts insts, ppr anns,
+          ppr_id_extras_s stuff, ppr defms]
 
 ppr_insts :: [IfaceInstABI] -> SDoc
 ppr_insts _ = text "<insts>"
@@ -931,8 +949,13 @@ instance Binary IfaceDeclExtras where
    putByte bh 1; put_ bh extras
   put_ bh (IfaceDataExtras fix insts anns cons) = do
    putByte bh 2; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh cons
-  put_ bh (IfaceClassExtras fix insts anns methods) = do
-   putByte bh 3; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh methods
+  put_ bh (IfaceClassExtras fix insts anns methods defms) = do
+   putByte bh 3
+   put_ bh fix
+   put_ bh insts
+   put_ bh anns
+   put_ bh methods
+   put_ bh defms
   put_ bh (IfaceSynonymExtras fix anns) = do
    putByte bh 4; put_ bh fix; put_ bh anns
   put_ bh (IfaceFamilyExtras fix finsts anns) = do
@@ -948,10 +971,11 @@ declExtras :: (OccName -> Maybe Fixity)
            -> OccEnv [IfaceRule]
            -> OccEnv [IfaceClsInst]
            -> OccEnv [IfaceFamInst]
+           -> OccEnv IfExtName          -- lookup default method names
            -> IfaceDecl
            -> IfaceDeclExtras
 
-declExtras fix_fn ann_fn rule_env inst_env fi_env decl
+declExtras fix_fn ann_fn rule_env inst_env fi_env dm_env decl
   = case decl of
       IfaceId{} -> IfaceIdExtras (id_extras n)
       IfaceData{ifCons=cons} ->
@@ -961,13 +985,18 @@ declExtras fix_fn ann_fn rule_env inst_env fi_env decl
                         (ann_fn n)
                         (map (id_extras . occName . ifConName) (visibleIfConDecls cons))
       IfaceClass{ifBody = IfConcreteClass { ifSigs=sigs, ifATs=ats }} ->
-                     IfaceClassExtras (fix_fn n)
-                        (map ifDFun $ (concatMap at_extras ats)
+                     IfaceClassExtras (fix_fn n) insts (ann_fn n) meths defms
+          where
+            insts = (map ifDFun $ (concatMap at_extras ats)
                                     ++ lookupOccEnvL inst_env n)
                            -- Include instances of the associated types
                            -- as well as instances of the class (Trac #5147)
-                        (ann_fn n)
-                        [id_extras (getOccName op) | IfaceClassOp op _ _ <- sigs]
+            meths = [id_extras (getOccName op) | IfaceClassOp op _ _ <- sigs]
+            -- Names of all the default methods (see Note [default method Name])
+            defms = [ dmName
+                    | IfaceClassOp bndr _ (Just _) <- sigs
+                    , let dmOcc = mkDefaultMethodOcc (nameOccName bndr)
+                    , Just dmName <- [lookupOccEnv dm_env dmOcc] ]
       IfaceSynonym{} -> IfaceSynonymExtras (fix_fn n)
                                            (ann_fn n)
       IfaceFamily{} -> IfaceFamilyExtras (fix_fn n)
@@ -980,6 +1009,29 @@ declExtras fix_fn ann_fn rule_env inst_env fi_env decl
         at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (getOccName decl)
 
 
+{- Note [default method Name] (see also #15970)
+
+The Names for the default methods aren't available in the IfaceSyn.
+
+* We originally start with a DefMethInfo from the class, contain a
+  Name for the default method
+
+* We turn that into IfaceSyn as a DefMethSpec which lacks a Name
+  entirely. Why? Because the Name can be derived from the method name
+  (in TcIface), so doesn't need to be serialised into the interface
+  file.
+
+But now we have to get the Name back, because the class declaration's
+fingerprint needs to depend on it (this was the bug in #15970).  This
+is done in a slightly convoluted way:
+
+* Then, in addFingerprints we build a map that maps OccNames to Names
+
+* We pass that map to declExtras which laboriously looks up in the map
+  (using the derived occurrence name) to recover the Name we have just
+  thrown away.
+-}
+
 lookupOccEnvL :: OccEnv [v] -> OccName -> [v]
 lookupOccEnvL env k = lookupOccEnv env k `orElse` []
 
diff --git a/testsuite/tests/driver/T15970/A1.hs b/testsuite/tests/driver/T15970/A1.hs
new file mode 100644
index 0000000000..cf71ad664f
--- /dev/null
+++ b/testsuite/tests/driver/T15970/A1.hs
@@ -0,0 +1,13 @@
+-- {-# OPTIONS_GHC -fno-full-laziness #-}
+module A (toTypedData, toTypedDataNoDef) where
+
+toTypedData :: String -> IO Int
+toTypedData s = wrapPrint "yoyo" $ toTypedDataNoDef s
+
+wrapPrint :: String -> IO Int -> IO Int
+wrapPrint s act = do
+    putStrLn s
+    act
+
+toTypedDataNoDef  :: String -> IO Int
+toTypedDataNoDef s = return $ length s
diff --git a/testsuite/tests/driver/T15970/A2.hs b/testsuite/tests/driver/T15970/A2.hs
new file mode 100644
index 0000000000..9d6b545a06
--- /dev/null
+++ b/testsuite/tests/driver/T15970/A2.hs
@@ -0,0 +1,13 @@
+{-# OPTIONS_GHC -fno-full-laziness #-}
+module A (toTypedData, toTypedDataNoDef) where
+
+toTypedData :: String -> IO Int
+toTypedData s = wrapPrint "yoyo" $ toTypedDataNoDef s
+
+wrapPrint :: String -> IO Int -> IO Int
+wrapPrint s act = do
+    putStrLn s
+    act
+
+toTypedDataNoDef  :: String -> IO Int
+toTypedDataNoDef s = return $ length s
diff --git a/testsuite/tests/driver/T15970/B.hs b/testsuite/tests/driver/T15970/B.hs
new file mode 100644
index 0000000000..8516f66429
--- /dev/null
+++ b/testsuite/tests/driver/T15970/B.hs
@@ -0,0 +1,9 @@
+module B ( TypeClass(..) ) where
+
+import A
+
+class Show a => TypeClass a where
+    getSize :: a -> IO Int
+    getSize a = toTypedData (show a)
+
+    printA :: a -> IO ()
diff --git a/testsuite/tests/driver/T15970/C.hs b/testsuite/tests/driver/T15970/C.hs
new file mode 100644
index 0000000000..4d0e713547
--- /dev/null
+++ b/testsuite/tests/driver/T15970/C.hs
@@ -0,0 +1,15 @@
+module Main where
+
+import B
+
+data MyDataType = MyDataType String Int deriving Show
+
+instance TypeClass MyDataType where
+    printA = putStrLn . show
+
+main :: IO ()
+main = do
+    let myValue = MyDataType "haha" 99
+    sz <- getSize myValue
+    putStrLn $ show sz
+    printA myValue
diff --git a/testsuite/tests/driver/T15970/Makefile b/testsuite/tests/driver/T15970/Makefile
new file mode 100644
index 0000000000..08973c1cb1
--- /dev/null
+++ b/testsuite/tests/driver/T15970/Makefile
@@ -0,0 +1,17 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+clean:
+	rm -f *.o *.hi
+	rm -f A.hs C
+
+# Changing something that a default method depends on should force
+# recompilation of a module that instantiates the class.
+
+T15970: clean
+	cp A1.hs A.hs
+	'$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -O2 C.hs
+	sleep 1
+	cp A2.hs A.hs
+	'$(TEST_HC)' $(TEST_HC_OPTS) --make -v0 -O2 C.hs
diff --git a/testsuite/tests/driver/T15970/all.T b/testsuite/tests/driver/T15970/all.T
new file mode 100644
index 0000000000..5c496f07d5
--- /dev/null
+++ b/testsuite/tests/driver/T15970/all.T
@@ -0,0 +1,2 @@
+test('T15970', [extra_files(['A1.hs', 'A2.hs', 'B.hs', 'C.hs'])],
+               run_command, ['$MAKE -s --no-print-directory T15970'])