Commit 9d17028f authored by Edward Z. Yang's avatar Edward Z. Yang

Record full FieldLabel in ifConFields.

Summary:
The previous implementation tried to be "efficient" by
storing field names once in IfaceConDecls, and only just
enough information for us to reconstruct the FieldLabel.
But this came at a bit of code complexity cost.

This patch undos the optimization, instead storing a full
FieldLabel at each data constructor.  Consequently, this fixes
bugs #12699 and #13250.
Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>

Test Plan: validate

Reviewers: adamgundry, bgamari, austin

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D3174
parent 93ffcb02
......@@ -509,11 +509,9 @@ rnIfaceTyConParent (IfDataInstance n tc args)
rnIfaceTyConParent IfNoParent = pure IfNoParent
rnIfaceConDecls :: Rename IfaceConDecls
rnIfaceConDecls (IfDataTyCon ds b fs)
rnIfaceConDecls (IfDataTyCon ds)
= IfDataTyCon <$> mapM rnIfaceConDecl ds
<*> return b
<*> return fs
rnIfaceConDecls (IfNewTyCon d b fs) = IfNewTyCon <$> rnIfaceConDecl d <*> return b <*> return fs
rnIfaceConDecls (IfNewTyCon d) = IfNewTyCon <$> rnIfaceConDecl d
rnIfaceConDecls (IfAbstractTyCon b) = pure (IfAbstractTyCon b)
rnIfaceConDecl :: Rename IfaceConDecl
......@@ -524,10 +522,7 @@ rnIfaceConDecl d = do
con_eq_spec <- mapM rnIfConEqSpec (ifConEqSpec d)
con_ctxt <- mapM rnIfaceType (ifConCtxt d)
con_arg_tys <- mapM rnIfaceType (ifConArgTys d)
-- TODO: It seems like we really should rename the field labels, but this
-- breaks due to tcIfaceDataCons projecting back to the field's OccName and
-- then looking up it up in the name cache. See #12699.
--con_fields <- mapM rnIfaceGlobal (ifConFields d)
con_fields <- mapM rnFieldLabel (ifConFields d)
let rnIfaceBang (IfUnpackCo co) = IfUnpackCo <$> rnIfaceCo co
rnIfaceBang bang = pure bang
con_stricts <- mapM rnIfaceBang (ifConStricts d)
......@@ -536,7 +531,7 @@ rnIfaceConDecl d = do
, ifConEqSpec = con_eq_spec
, ifConCtxt = con_ctxt
, ifConArgTys = con_arg_tys
--, ifConFields = con_fields -- See TODO above
, ifConFields = con_fields
, ifConStricts = con_stricts
}
......
......@@ -27,7 +27,6 @@ module IfaceSyn (
-- Misc
ifaceDeclImplicitBndrs, visibleIfConDecls,
ifaceConDeclFields,
ifaceDeclFingerprints,
-- Free Names
......@@ -70,7 +69,6 @@ import Lexeme (isLexSym)
import Control.Monad
import System.IO.Unsafe
import Data.List (find)
import Data.Maybe (isJust)
infixl 3 &&&
......@@ -209,15 +207,15 @@ data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr]
-- See Note [Storing compatibility] in CoAxiom
data IfaceConDecls
= IfAbstractTyCon HowAbstract -- c.f TyCon.AbstractTyCon
| IfDataTyCon [IfaceConDecl] Bool [FieldLabelString] -- Data type decls
| IfNewTyCon IfaceConDecl Bool [FieldLabelString] -- Newtype decls
= IfAbstractTyCon HowAbstract -- c.f TyCon.AbstractTyCon
| IfDataTyCon [IfaceConDecl] -- Data type decls
| IfNewTyCon IfaceConDecl -- Newtype decls
-- For IfDataTyCon and IfNewTyCon we store:
-- * the data constructor(s);
-- * a boolean indicating whether DuplicateRecordFields was enabled
-- at the definition site; and
-- * a list of field labels.
-- The field labels are stored individually in the IfaceConDecl
-- (there is some redundancy here, because a field label may occur
-- in multiple IfaceConDecls and represent the same field label)
data IfaceConDecl
= IfCon {
......@@ -235,7 +233,7 @@ data IfaceConDecl
ifConEqSpec :: IfaceEqSpec, -- Equality constraints
ifConCtxt :: IfaceContext, -- Non-stupid context
ifConArgTys :: [IfaceType], -- Arg types
ifConFields :: [IfaceTopBndr], -- ...ditto... (field labels)
ifConFields :: [FieldLabel], -- ...ditto... (field labels)
ifConStricts :: [IfaceBang],
-- Empty (meaning all lazy),
-- or 1-1 corresp with arg tys
......@@ -370,18 +368,8 @@ See [http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoid
visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
visibleIfConDecls (IfAbstractTyCon {}) = []
visibleIfConDecls (IfDataTyCon cs _ _) = cs
visibleIfConDecls (IfNewTyCon c _ _) = [c]
ifaceConDeclFields :: IfaceConDecls -> [FieldLbl OccName]
ifaceConDeclFields x = case x of
IfAbstractTyCon {} -> []
IfDataTyCon cons is_over labels -> map (help cons is_over) labels
IfNewTyCon con is_over labels -> map (help [con] is_over) labels
where
help (dc:_) is_over lbl =
mkFieldLabelOccs lbl (occName $ ifConName dc) is_over
help [] _ _ = error "ifaceConDeclFields: data type has no constructors!"
visibleIfConDecls (IfDataTyCon cs) = cs
visibleIfConDecls (IfNewTyCon c) = [c]
ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName]
-- *Excludes* the 'main' name, but *includes* the implicitly-bound names
......@@ -398,8 +386,8 @@ ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName]
ifaceDeclImplicitBndrs (IfaceData {ifName = tc_name, ifCons = cons })
= case cons of
IfAbstractTyCon {} -> []
IfNewTyCon cd _ _ -> mkNewTyCoOcc (occName tc_name) : ifaceConDeclImplicitBndrs cd
IfDataTyCon cds _ _ -> concatMap ifaceConDeclImplicitBndrs cds
IfNewTyCon cd -> mkNewTyCoOcc (occName tc_name) : ifaceConDeclImplicitBndrs cd
IfDataTyCon cds -> concatMap ifaceConDeclImplicitBndrs cds
ifaceDeclImplicitBndrs (IfaceClass { ifCtxt = sc_ctxt
, ifName = cls_tc_name
......@@ -430,7 +418,8 @@ ifaceDeclImplicitBndrs (IfaceClass { ifCtxt = sc_ctxt
ifaceDeclImplicitBndrs _ = []
ifaceConDeclImplicitBndrs :: IfaceConDecl -> [OccName]
ifaceConDeclImplicitBndrs (IfCon { ifConWrapper = has_wrapper, ifConName = con_name })
ifaceConDeclImplicitBndrs (IfCon {
ifConWrapper = has_wrapper, ifConName = con_name })
= [occName con_name, work_occ] ++ wrap_occs
where
con_occ = occName con_name
......@@ -716,12 +705,11 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
add_bars [] = Outputable.empty
add_bars (c:cs) = sep ((equals <+> c) : map (vbar <+>) cs)
ok_con dc = showSub ss dc || any (showSub ss) (ifConFields dc)
ok_con dc = showSub ss dc || any (showSub ss . flSelector) (ifConFields dc)
show_con dc
| ok_con dc = Just $ pprIfaceConDecl ss gadt_style fls tycon binders parent dc
| ok_con dc = Just $ pprIfaceConDecl ss gadt_style tycon binders parent dc
| otherwise = Nothing
fls = ifaceConDeclFields condecls
pp_nd = case condecls of
IfAbstractTyCon how ->
......@@ -942,12 +930,11 @@ isVanillaIfaceConDecl (IfCon { ifConExTvs = ex_tvs
= (null ex_tvs) && (null eq_spec) && (null ctxt)
pprIfaceConDecl :: ShowSub -> Bool
-> [FieldLbl OccName]
-> IfaceTopBndr
-> [IfaceTyConBinder]
-> IfaceTyConParent
-> IfaceConDecl -> SDoc
pprIfaceConDecl ss gadt_style fls tycon tc_binders parent
pprIfaceConDecl ss gadt_style tycon tc_binders parent
(IfCon { ifConName = name, ifConInfix = is_infix,
ifConExTvs = ex_tvs,
ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,
......@@ -995,18 +982,15 @@ pprIfaceConDecl ss gadt_style fls tycon tc_binders parent
pp_field_args = braces $ sep $ punctuate comma $ ppr_trim $
zipWith maybe_show_label fields tys_w_strs
maybe_show_label :: IfaceTopBndr -> (IfaceBang, IfaceType) -> Maybe SDoc
maybe_show_label sel bty
maybe_show_label :: FieldLabel -> (IfaceBang, IfaceType) -> Maybe SDoc
maybe_show_label lbl bty
| showSub ss sel =
Just (pprPrefixIfDeclBndr how_much lbl <+> dcolon <+> pprBangTy bty)
Just (pprPrefixIfDeclBndr how_much occ <+> dcolon <+> pprBangTy bty)
| otherwise =
Nothing
where
-- IfaceConDecl contains the name of the selector function, so
-- we have to look up the field label (in case
-- DuplicateRecordFields was used for the definition)
lbl = maybe (occName sel) (mkVarOccFS . flLabel)
$ find (\ fl -> flSelector fl == occName sel) fls
sel = flSelector lbl
occ = mkVarOccFS (flLabel lbl)
mk_user_con_res_ty :: IfaceEqSpec -> ([IfaceTvBndr], SDoc)
-- See Note [Result type of a data family GADT]
......@@ -1327,8 +1311,8 @@ freeNamesDM (Just (GenericDM ty)) = freeNamesIfType ty
freeNamesDM _ = emptyNameSet
freeNamesIfConDecls :: IfaceConDecls -> NameSet
freeNamesIfConDecls (IfDataTyCon c _ _) = fnList freeNamesIfConDecl c
freeNamesIfConDecls (IfNewTyCon c _ _) = freeNamesIfConDecl c
freeNamesIfConDecls (IfDataTyCon c) = fnList freeNamesIfConDecl c
freeNamesIfConDecls (IfNewTyCon c) = freeNamesIfConDecl c
freeNamesIfConDecls _ = emptyNameSet
freeNamesIfConDecl :: IfaceConDecl -> NameSet
......@@ -1336,6 +1320,7 @@ freeNamesIfConDecl c
= freeNamesIfTyVarBndrs (ifConExTvs c) &&&
freeNamesIfContext (ifConCtxt c) &&&
fnList freeNamesIfType (ifConArgTys c) &&&
mkNameSet (map flSelector (ifConFields c)) &&&
fnList freeNamesIfType (map snd (ifConEqSpec c)) -- equality constraints
freeNamesIfKind :: IfaceType -> NameSet
......@@ -1733,14 +1718,14 @@ instance Binary IfaceAxBranch where
instance Binary IfaceConDecls where
put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d
put_ bh (IfDataTyCon cs b fs) = putByte bh 1 >> put_ bh cs >> put_ bh b >> put_ bh fs
put_ bh (IfNewTyCon c b fs) = putByte bh 2 >> put_ bh c >> put_ bh b >> put_ bh fs
put_ bh (IfDataTyCon cs) = putByte bh 1 >> put_ bh cs
put_ bh (IfNewTyCon c) = putByte bh 2 >> put_ bh c
get bh = do
h <- getByte bh
case h of
0 -> liftM IfAbstractTyCon $ get bh
1 -> liftM3 IfDataTyCon (get bh) (get bh) (get bh)
2 -> liftM3 IfNewTyCon (get bh) (get bh) (get bh)
1 -> liftM IfDataTyCon (get bh)
2 -> liftM IfNewTyCon (get bh)
_ -> error "Binary(IfaceConDecls).get: Invalid IfaceConDecls"
instance Binary IfaceConDecl where
......@@ -1753,7 +1738,7 @@ instance Binary IfaceConDecl where
put_ bh a6
put_ bh a7
put_ bh (length a8)
mapM_ (putIfaceTopBndr bh) a8
mapM_ (put_ bh) a8
put_ bh a9
put_ bh a10
get bh = do
......@@ -1765,7 +1750,7 @@ instance Binary IfaceConDecl where
a6 <- get bh
a7 <- get bh
n_fields <- get bh
a8 <- replicateM n_fields (getIfaceTopBndr bh)
a8 <- replicateM n_fields (get bh)
a9 <- get bh
a10 <- get bh
return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
......
......@@ -501,7 +501,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
, not (isHoleModule semantic_mod) = global_hash_fn name
| otherwise = return (snd (lookupOccEnv local_env (getOccName name)
`orElse` pprPanic "urk! lookup local fingerprint"
(ppr name)))
(ppr name $$ ppr local_env)))
-- This panic indicates that we got the dependency
-- analysis wrong, because we needed a fingerprint for
-- an entity that wasn't in the environment. To debug
......@@ -1589,7 +1589,7 @@ tyConToIfaceDecl env tycon
ifCType = Nothing,
ifRoles = tyConRoles tycon,
ifCtxt = [],
ifCons = IfDataTyCon [] False [],
ifCons = IfDataTyCon [],
ifGadtSyntax = False,
ifParent = IfNoParent })
where
......@@ -1623,10 +1623,10 @@ tyConToIfaceDecl env tycon
ifaceConDecls (NewTyCon { data_con = con }) flds = IfNewTyCon (ifaceConDecl con) (ifaceOverloaded flds) (ifaceFields flds)
ifaceConDecls (DataTyCon { data_cons = cons }) flds = IfDataTyCon (map ifaceConDecl cons) (ifaceOverloaded flds) (ifaceFields flds)
ifaceConDecls (TupleTyCon { data_con = con }) _ = IfDataTyCon [ifaceConDecl con] False []
ifaceConDecls (SumTyCon { data_cons = cons }) flds = IfDataTyCon (map ifaceConDecl cons) (ifaceOverloaded flds) (ifaceFields flds)
ifaceConDecls (NewTyCon { data_con = con }) flds = IfNewTyCon (ifaceConDecl con)
ifaceConDecls (DataTyCon { data_cons = cons }) flds = IfDataTyCon (map ifaceConDecl cons)
ifaceConDecls (TupleTyCon { data_con = con }) _ = IfDataTyCon [ifaceConDecl con]
ifaceConDecls (SumTyCon { data_cons = cons }) flds = IfDataTyCon (map ifaceConDecl cons)
ifaceConDecls (AbstractTyCon distinct) _ = IfAbstractTyCon distinct
-- The AbstractTyCon case happens when a TyCon has been trimmed
-- during tidying.
......@@ -1643,7 +1643,7 @@ tyConToIfaceDecl env tycon
ifConEqSpec = map (to_eq_spec . eqSpecPair) eq_spec,
ifConCtxt = tidyToIfaceContext con_env2 theta,
ifConArgTys = map (tidyToIfaceType con_env2) arg_tys,
ifConFields = map flSelector (dataConFieldLabels data_con),
ifConFields = dataConFieldLabels data_con,
ifConStricts = map (toIfaceBang con_env2)
(dataConImplBangs data_con),
ifConSrcStricts = map toIfaceSrcBang
......@@ -1669,7 +1669,6 @@ tyConToIfaceDecl env tycon
ifaceOverloaded flds = case dFsEnvElts flds of
fl:_ -> flIsOverloaded fl
[] -> False
ifaceFields flds = map flLabel $ dFsEnvElts flds
classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl)
classToIfaceDecl env clas
......
......@@ -805,21 +805,19 @@ tcIfaceDataCons :: Name -> TyCon -> [TyConBinder] -> IfaceConDecls -> IfL AlgTyC
tcIfaceDataCons tycon_name tycon tc_tybinders if_cons
= case if_cons of
IfAbstractTyCon dis -> return (AbstractTyCon dis)
IfDataTyCon cons _ _ -> do { field_lbls <- mapM (traverse lookupIfaceTop) (ifaceConDeclFields if_cons)
; data_cons <- mapM (tc_con_decl field_lbls) cons
; return (mkDataTyConRhs data_cons) }
IfNewTyCon con _ _ -> do { field_lbls <- mapM (traverse lookupIfaceTop) (ifaceConDeclFields if_cons)
; data_con <- tc_con_decl field_lbls con
; mkNewTyConRhs tycon_name tycon data_con }
IfDataTyCon cons -> do { data_cons <- mapM tc_con_decl cons
; return (mkDataTyConRhs data_cons) }
IfNewTyCon con -> do { data_con <- tc_con_decl con
; mkNewTyConRhs tycon_name tycon data_con }
where
univ_tv_bndrs :: [TyVarBinder]
univ_tv_bndrs = mkDataConUnivTyVarBinders tc_tybinders
tc_con_decl field_lbls (IfCon { ifConInfix = is_infix,
tc_con_decl (IfCon { ifConInfix = is_infix,
ifConExTvs = ex_bndrs,
ifConName = dc_name,
ifConCtxt = ctxt, ifConEqSpec = spec,
ifConArgTys = args, ifConFields = my_lbls,
ifConArgTys = args, ifConFields = lbl_names,
ifConStricts = if_stricts,
ifConSrcStricts = if_src_stricts})
= -- Universally-quantified tyvars are shared with
......@@ -841,16 +839,6 @@ tcIfaceDataCons tycon_name tycon tc_tybinders if_cons
-- the type itself; hence inside forkM
; return (eq_spec, theta, arg_tys, stricts) }
-- Look up the field labels for this constructor; note that
-- they should be in the same order as my_lbls!
; let lbl_names = map find_lbl my_lbls
find_lbl x = case find (\ fl -> flSelector fl == x) field_lbls of
Just fl -> fl
Nothing -> pprPanic "TcIface.find_lbl" not_found
where
not_found = text "missing:" <+> ppr (occName x)
$$ text "known labels:" <+> ppr field_lbls
-- Remember, tycon is the representation tycon
; let orig_res_ty = mkFamilyTyConApp tycon
(substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec))
......
unit p where
signature A where
newtype F a = F { mkF :: a }
unit q where
module A where
newtype F a = F { mkF :: a }
unit r where
dependency p[A=q:A]
[1 of 3] Processing p
[1 of 1] Compiling A[sig] ( p/A.hsig, nothing )
[2 of 3] Processing q
Instantiating q
[1 of 1] Compiling A ( q/A.hs, T13250.out/q/A.o )
[3 of 3] Processing r
Instantiating r
[1 of 1] Including p[A=q:A]
Instantiating p[A=q:A]
[1 of 1] Compiling A[sig] ( p/A.hsig, T13250.out/p/p-HVmFlcYSefiK5n1aDP1v7x/A.o )
......@@ -47,4 +47,5 @@ test('bkp52', normal, backpack_compile, [''])
test('T13149', expect_broken(13149), backpack_compile, [''])
test('T13214', normal, backpack_compile, [''])
test('T13250', normal, backpack_compile, [''])
test('T13323', normal, backpack_compile, [''])
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