[Git][ghc/ghc][master] When forcing a `ModIface`, force the `MINIMAL` pragmas in class definitions
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Jun 14 11:03:05 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
b852a5b6 by Gergo ERDI at 2023-06-14T07:02:42-04:00
When forcing a `ModIface`, force the `MINIMAL` pragmas in class definitions
Fixes #23486
- - - - -
4 changed files:
- compiler/GHC/Data/BooleanFormula.hs
- compiler/GHC/Iface/Decl.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/IfaceToCore.hs
Changes:
=====================================
compiler/GHC/Data/BooleanFormula.hs
=====================================
@@ -24,8 +24,7 @@ import Data.Data
import GHC.Utils.Monad
import GHC.Utils.Outputable
-import GHC.Utils.Binary
-import GHC.Parser.Annotation ( LocatedL, noLocA )
+import GHC.Parser.Annotation ( LocatedL )
import GHC.Types.SrcLoc
import GHC.Types.Unique
import GHC.Types.Unique.Set
@@ -243,22 +242,3 @@ pprBooleanFormulaNormal = go
go (Or []) = keyword $ text "FALSE"
go (Or xs) = fsep $ intersperse vbar (map (go . unLoc) xs)
go (Parens x) = parens (go $ unLoc x)
-
-
-----------------------------------------------------------------------
--- Binary
-----------------------------------------------------------------------
-
-instance Binary a => Binary (BooleanFormula a) where
- put_ bh (Var x) = putByte bh 0 >> put_ bh x
- put_ bh (And xs) = putByte bh 1 >> put_ bh (unLoc <$> xs)
- put_ bh (Or xs) = putByte bh 2 >> put_ bh (unLoc <$> xs)
- put_ bh (Parens x) = putByte bh 3 >> put_ bh (unLoc x)
-
- get bh = do
- h <- getByte bh
- case h of
- 0 -> Var <$> get bh
- 1 -> And . fmap noLocA <$> get bh
- 2 -> Or . fmap noLocA <$> get bh
- _ -> Parens . noLocA <$> get bh
=====================================
compiler/GHC/Iface/Decl.hs
=====================================
@@ -1,5 +1,6 @@
{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE LambdaCase #-}
{-
(c) The University of Glasgow 2006-2008
@@ -12,6 +13,7 @@
module GHC.Iface.Decl
( coAxiomToIfaceDecl
, tyThingToIfaceDecl -- Converting things to their Iface equivalents
+ , toIfaceBooleanFormula
)
where
@@ -38,12 +40,14 @@ import GHC.Types.Var
import GHC.Types.Name
import GHC.Types.Basic
import GHC.Types.TyThing
+import GHC.Types.SrcLoc
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import GHC.Data.FastString
import GHC.Data.Maybe
+import GHC.Data.BooleanFormula
import Data.List ( findIndex, mapAccumL )
@@ -284,7 +288,7 @@ classToIfaceDecl env clas
ifClassCtxt = tidyToIfaceContext env1 sc_theta,
ifATs = map toIfaceAT clas_ats,
ifSigs = map toIfaceClassOp op_stuff,
- ifMinDef = fmap getOccFS (classMinimalDef clas)
+ ifMinDef = toIfaceBooleanFormula $ fmap getOccFS (classMinimalDef clas)
}
(env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)
@@ -332,3 +336,10 @@ tidyTyConBinders = mapAccumL tidyTyConBinder
tidyTyVar :: TidyEnv -> TyVar -> FastString
tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv)
+
+toIfaceBooleanFormula :: BooleanFormula IfLclName -> IfaceBooleanFormula
+toIfaceBooleanFormula = \case
+ Var nm -> IfVar nm
+ And bfs -> IfAnd (map (toIfaceBooleanFormula . unLoc) bfs)
+ Or bfs -> IfOr (map (toIfaceBooleanFormula . unLoc) bfs)
+ Parens bf -> IfParens (toIfaceBooleanFormula . unLoc $ bf)
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -17,7 +17,7 @@ module GHC.Iface.Syntax (
IfaceIdInfo, IfaceIdDetails(..), IfaceUnfolding(..), IfGuidance(..),
IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..),
- IfaceClassBody(..),
+ IfaceClassBody(..), IfaceBooleanFormula(..),
IfaceBang(..),
IfaceSrcBang(..), SrcUnpackedness(..), SrcStrictness(..),
IfaceAxBranch(..),
@@ -32,6 +32,7 @@ module GHC.Iface.Syntax (
-- Misc
ifaceDeclImplicitBndrs, visibleIfConDecls,
ifaceDeclFingerprints,
+ fromIfaceBooleanFormula,
-- Free Names
freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst,
@@ -66,12 +67,13 @@ import GHC.Types.Annotations( AnnPayload, AnnTarget )
import GHC.Types.Basic
import GHC.Unit.Module
import GHC.Types.SrcLoc
-import GHC.Data.BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue )
+import GHC.Data.BooleanFormula ( BooleanFormula(..), pprBooleanFormula, isTrue )
import GHC.Types.Var( VarBndr(..), binderVar, tyVarSpecToBinders, visArgTypeLike )
import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisForAllTyFlag )
import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..))
import GHC.Builtin.Types ( constraintKindTyConName )
import GHC.Stg.InferTags.TagSig
+import GHC.Parser.Annotation (noLocA)
import GHC.Utils.Lexeme (isLexSym)
import GHC.Utils.Fingerprint
@@ -191,9 +193,22 @@ data IfaceClassBody
ifClassCtxt :: IfaceContext, -- Super classes
ifATs :: [IfaceAT], -- Associated type families
ifSigs :: [IfaceClassOp], -- Method signatures
- ifMinDef :: BooleanFormula IfLclName -- Minimal complete definition
+ ifMinDef :: IfaceBooleanFormula -- Minimal complete definition
}
+data IfaceBooleanFormula
+ = IfVar IfLclName
+ | IfAnd [IfaceBooleanFormula]
+ | IfOr [IfaceBooleanFormula]
+ | IfParens IfaceBooleanFormula
+
+fromIfaceBooleanFormula :: IfaceBooleanFormula -> BooleanFormula IfLclName
+fromIfaceBooleanFormula = \case
+ IfVar nm -> Var nm
+ IfAnd ibfs -> And (map (noLocA . fromIfaceBooleanFormula) ibfs)
+ IfOr ibfs -> Or (map (noLocA . fromIfaceBooleanFormula) ibfs)
+ IfParens ibf -> Parens (noLocA . fromIfaceBooleanFormula $ ibf)
+
data IfaceTyConParent
= IfNoParent
| IfDataInstance
@@ -930,7 +945,7 @@ pprIfaceDecl ss (IfaceClass { ifName = clas
, pprClassStandaloneKindSig ss clas (mkIfaceTyConKind binders constraintIfaceKind)
, text "class" <+> pprIfaceDeclHead suppress_bndr_sig context ss clas binders <+> pprFundeps fds <+> pp_where
, nest 2 (vcat [ vcat asocs, vcat dsigs
- , ppShowAllSubs ss (pprMinDef minDef)])]
+ , ppShowAllSubs ss (pprMinDef $ fromIfaceBooleanFormula minDef)])]
where
pp_where = ppShowRhs ss $ ppUnless (null sigs && null ats) (text "where")
@@ -2038,6 +2053,20 @@ instance Binary IfaceDecl where
ifBody = IfAbstractClass })
_ -> panic (unwords ["Unknown IfaceDecl tag:", show h])
+instance Binary IfaceBooleanFormula where
+ put_ bh = \case
+ IfVar a1 -> putByte bh 0 >> put_ bh a1
+ IfAnd a1 -> putByte bh 1 >> put_ bh a1
+ IfOr a1 -> putByte bh 2 >> put_ bh a1
+ IfParens a1 -> putByte bh 3 >> put_ bh a1
+
+ get bh = do
+ getByte bh >>= \case
+ 0 -> IfVar <$> get bh
+ 1 -> IfAnd <$> get bh
+ 2 -> IfOr <$> get bh
+ _ -> IfParens <$> get bh
+
{- Note [Lazy deserialization of IfaceId]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The use of lazyPut and lazyGet in the IfaceId Binary instance is
@@ -2650,7 +2679,14 @@ instance NFData IfaceAxBranch where
instance NFData IfaceClassBody where
rnf = \case
IfAbstractClass -> ()
- IfConcreteClass f1 f2 f3 f4 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` ()
+ IfConcreteClass f1 f2 f3 f4 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` ()
+
+instance NFData IfaceBooleanFormula where
+ rnf = \case
+ IfVar f1 -> rnf f1
+ IfAnd f1 -> rnf f1
+ IfOr f1 -> rnf f1
+ IfParens f1 -> rnf f1
instance NFData IfaceAT where
rnf (IfaceAT f1 f2) = rnf f1 `seq` rnf f2
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -44,6 +44,7 @@ import GHC.Driver.Config.Core.Lint ( initLintConfig )
import GHC.Builtin.Types.Literals(typeNatCoAxiomRules)
import GHC.Builtin.Types
+import GHC.Iface.Decl (toIfaceBooleanFormula)
import GHC.Iface.Syntax
import GHC.Iface.Load
import GHC.Iface.Env
@@ -290,7 +291,7 @@ mergeIfaceDecl d1 d2
(mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops2 ])
in d1 { ifBody = (ifBody d1) {
ifSigs = ops,
- ifMinDef = BF.mkOr [noLocA bf1, noLocA bf2]
+ ifMinDef = toIfaceBooleanFormula . BF.mkOr . map (noLocA . fromIfaceBooleanFormula) $ [bf1, bf2]
}
} `withRolesFrom` d2
-- It doesn't matter; we'll check for consistency later when
@@ -773,7 +774,7 @@ tc_iface_decl _parent ignore_prags
ifBody = IfConcreteClass {
ifClassCtxt = rdr_ctxt,
ifATs = rdr_ats, ifSigs = rdr_sigs,
- ifMinDef = mindef_occ
+ ifMinDef = if_mindef
}})
= bindIfaceTyConBinders binders $ \ binders' -> do
{ traceIf (text "tc-iface-class1" <+> ppr tc_name)
@@ -782,6 +783,7 @@ tc_iface_decl _parent ignore_prags
; sigs <- mapM tc_sig rdr_sigs
; fds <- mapM tc_fd rdr_fds
; traceIf (text "tc-iface-class3" <+> ppr tc_name)
+ ; let mindef_occ = fromIfaceBooleanFormula if_mindef
; mindef <- traverse (lookupIfaceTop . mkVarOccFS) mindef_occ
; cls <- fixM $ \ cls -> do
{ ats <- mapM (tc_at cls) rdr_ats
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b852a5b662aaad6d651734ffd16852beedf7e99a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b852a5b662aaad6d651734ffd16852beedf7e99a
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230614/2908532a/attachment-0001.html>
More information about the ghc-commits
mailing list