Commit 288f681e authored by Simon Marlow's avatar Simon Marlow Committed by Ben Gamari
Browse files

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
parent 0136906c
......@@ -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` []
......
-- {-# 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
{-# 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
module B ( TypeClass(..) ) where
import A
class Show a => TypeClass a where
getSize :: a -> IO Int
getSize a = toTypedData (show a)
printA :: a -> IO ()
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
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
test('T15970', [extra_files(['A1.hs', 'A2.hs', 'B.hs', 'C.hs'])],
run_command, ['$MAKE -s --no-print-directory T15970'])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment