[Git][ghc/ghc][wip/ttg/types/basic] 2 commits: IfaceOverlapFlag introduced
Hassan Al-Awwadi (@hassan.awwadi)
gitlab at gitlab.haskell.org
Mon Oct 28 13:49:13 UTC 2024
Hassan Al-Awwadi pushed to branch wip/ttg/types/basic at Glasgow Haskell Compiler / GHC
Commits:
e49bd65c by Hassan Al-Awwadi at 2024-10-28T14:47:37+01:00
IfaceOverlapFlag introduced
this felt like the principled thing to do because we want interface file generation to only deal with simple types.
- - - - -
f940806f by Hassan Al-Awwadi at 2024-10-28T14:48:45+01:00
whitespace
- - - - -
6 changed files:
- compiler/GHC/CoreToIface.hs
- compiler/GHC/Hs/OverlapPragma.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/IfaceToCore.hs
- utils/check-exact/ExactPrint.hs
Changes:
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -41,7 +41,9 @@ module GHC.CoreToIface
, toIfaceCon
, toIfaceApp
, toIfaceVar
- -- * InlinePragma
+ -- * Pragmas
+ , toIfaceOverlapFlag
+ , toIfaceOverlapMode
, toIfaceActivation
, toIfaceInlineSpec
, toIfaceInlinePragma
@@ -89,6 +91,7 @@ import GHC.Types.Cpr ( topCprSig )
import GHC.Hs.Extension ( GhcPass )
import GHC.Hs.InlinePragma
+import GHC.Hs.OverlapPragma
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -671,14 +674,18 @@ toIfaceVar v
noinline_id | isConstraintKind (typeKind ty) = noinlineConstraintIdName
| otherwise = noinlineIdName
---------------------
-toIfaceActivation :: Activation (GhcPass p) -> IfaceActivation
-toIfaceActivation (AlwaysActive _ ) = IfAlwaysActive
-toIfaceActivation (ActiveBefore src phase ) = IfActiveBefore src phase
-toIfaceActivation (ActiveAfter src phase) = IfActiveAfter src phase
-toIfaceActivation (FinalActive _ ) = IfFinalActive
-toIfaceActivation (NeverActive _ ) = IfNeverActive
-toIfaceActivation (XActivation impossible) = dataConCantHappen impossible
+{-
+************************************************************************
+* *
+ Conversion of Pragmas
+* *
+************************************************************************
+-}
+
+toIfaceInlinePragma :: InlinePragma (GhcPass p) -> IfaceInlinePragma
+toIfaceInlinePragma (InlinePragma s a b c)
+ = IfInlinePragma (inl_txt s) (toIfaceInlineSpec a) (inl_arr s) (toIfaceActivation b) c
+toIfaceInlinePragma (XCInlinePragma impossible) = dataConCantHappen impossible
toIfaceInlineSpec :: InlineSpec (GhcPass p) -> IfaceInlineSpec
toIfaceInlineSpec (Inline src) = IfInline src
@@ -688,10 +695,25 @@ toIfaceInlineSpec (Opaque src) = IfOpaque src
toIfaceInlineSpec (NoUserInlinePrag _) = IfNoUserInlinePrag
toIfaceInlineSpec (XInlineSpec impossible) = dataConCantHappen impossible
-toIfaceInlinePragma :: InlinePragma (GhcPass p) -> IfaceInlinePragma
-toIfaceInlinePragma (InlinePragma s a b c)
- = IfInlinePragma (inl_txt s) (toIfaceInlineSpec a) (inl_arr s) (toIfaceActivation b) c
-toIfaceInlinePragma (XCInlinePragma impossible) = dataConCantHappen impossible
+toIfaceActivation :: Activation (GhcPass p) -> IfaceActivation
+toIfaceActivation (AlwaysActive _ ) = IfAlwaysActive
+toIfaceActivation (ActiveBefore src phase ) = IfActiveBefore src phase
+toIfaceActivation (ActiveAfter src phase) = IfActiveAfter src phase
+toIfaceActivation (FinalActive _ ) = IfFinalActive
+toIfaceActivation (NeverActive _ ) = IfNeverActive
+toIfaceActivation (XActivation impossible) = dataConCantHappen impossible
+
+toIfaceOverlapFlag :: OverlapFlag -> IfaceOverlapFlag
+toIfaceOverlapFlag (OverlapFlag overlap safe)
+ = IfOverlapFlag (toIfaceOverlapMode overlap) safe
+
+toIfaceOverlapMode :: OverlapMode (GhcPass p) -> IfaceOverlapMode
+toIfaceOverlapMode (NoOverlap sourceText) = IfNoOverlap sourceText
+toIfaceOverlapMode (Overlappable sourceText) = IfOverlappable sourceText
+toIfaceOverlapMode (Overlapping sourceText) = IfOverlapping sourceText
+toIfaceOverlapMode (Overlaps sourceText) = IfOverlaps sourceText
+toIfaceOverlapMode (Incoherent sourceText) = IfIncoherent sourceText
+toIfaceOverlapMode (XOverlapMode (NonCanonical sourceText)) = IfNonCanonical sourceText
---------------------
toIfaceLFInfo :: Name -> LambdaFormInfo -> IfaceLFInfo
=====================================
compiler/GHC/Hs/OverlapPragma.hs
=====================================
@@ -84,33 +84,6 @@ instance Outputable (OverlapMode (GhcPass p)) where
instance Outputable OverlapFlag where
ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag)
--- might want to make an explicit IfaceOverlapMode, I guess
-instance Binary (OverlapMode (GhcPass p)) where
- put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s
- put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s
- put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s
- put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s
- put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s
- put_ bh (XOverlapMode (NonCanonical s)) = putByte bh 5 >> put_ bh s
- get bh = do
- h <- getByte bh
- case h of
- 0 -> (get bh) >>= \s -> return $ NoOverlap s
- 1 -> (get bh) >>= \s -> return $ Overlaps s
- 2 -> (get bh) >>= \s -> return $ Incoherent s
- 3 -> (get bh) >>= \s -> return $ Overlapping s
- 4 -> (get bh) >>= \s -> return $ Overlappable s
- 5 -> (get bh) >>= \s -> return $ XOverlapMode (NonCanonical s)
- _ -> panic ("get OverlapMode" ++ show h)
-
-
-instance Binary OverlapFlag where
- put_ bh flag = do put_ bh (overlapMode flag)
- put_ bh (isSafeOverlap flag)
- get bh = do
- h <- get bh
- b <- get bh
- return OverlapFlag { overlapMode = h, isSafeOverlap = b }
------------------------
=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -427,7 +427,7 @@ instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag
, is_warn = warn })
= assert (cls_name == className cls) $
IfaceClsInst { ifDFun = idName dfun_id
- , ifOFlag = oflag
+ , ifOFlag = toIfaceOverlapFlag oflag
, ifInstCls = cls_name
, ifInstTys = ifaceRoughMatchTcs $ tail rough_tcs
-- N.B. Drop the class name from the rough match template
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -18,6 +18,7 @@ module GHC.Iface.Syntax (
IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
IfaceWarnings(..), IfaceWarningTxt(..), IfaceStringLiteral(..),
IfaceDefault(..), IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..),
+ IfaceOverlapFlag(..), IfaceOverlapMode(..),
IfaceClassBody(..), IfaceBooleanFormula(..),
IfaceInlinePragma(..), IfaceInlineSpec(..), IfaceActivation(..),
IfaceBang(..),
@@ -36,6 +37,9 @@ module GHC.Iface.Syntax (
-- Misc
ifaceDeclImplicitBndrs, visibleIfConDecls,
ifaceDeclFingerprints,
+
+ fromIfaceOverlapFlag,
+ fromIfaceOverlapMode,
fromIfaceBooleanFormula,
fromIfaceActivation,
fromIfaceInlineSpec,
@@ -342,7 +346,7 @@ data IfaceClsInst
= IfaceClsInst { ifInstCls :: IfExtName, -- See comments with
ifInstTys :: [Maybe IfaceTyCon], -- the defn of ClsInst
ifDFun :: IfExtName, -- The dfun
- ifOFlag :: OverlapFlag, -- Overlap flag
+ ifOFlag :: IfaceOverlapFlag, -- Overlap flag
ifInstOrph :: IsOrphan, -- See Note [Orphans] in GHC.Core.InstEnv
ifInstWarn :: Maybe IfaceWarningTxt }
-- Warning emitted when the instance is used
@@ -355,6 +359,33 @@ data IfaceClsInst
-- If this instance decl is *used*, we'll record a usage on the dfun;
-- and if the head does not change it won't be used if it wasn't before
+
+
+data IfaceOverlapFlag
+ = IfOverlapFlag { ifOverlapMode :: IfaceOverlapMode
+ , ifisSafeOverlap :: Bool
+ }
+
+fromIfaceOverlapFlag :: IfaceOverlapFlag -> OverlapFlag
+fromIfaceOverlapFlag (IfOverlapFlag overlap safe)
+ = OverlapFlag (fromIfaceOverlapMode overlap) safe
+
+data IfaceOverlapMode
+ = IfNoOverlap SourceText
+ | IfOverlappable SourceText
+ | IfOverlapping SourceText
+ | IfOverlaps SourceText
+ | IfIncoherent SourceText
+ | IfNonCanonical SourceText
+
+fromIfaceOverlapMode :: IfaceOverlapMode -> OverlapMode (GhcPass p)
+fromIfaceOverlapMode (IfNoOverlap sourceText) = NoOverlap sourceText
+fromIfaceOverlapMode (IfOverlappable sourceText) = Overlappable sourceText
+fromIfaceOverlapMode (IfOverlapping sourceText) = Overlapping sourceText
+fromIfaceOverlapMode (IfOverlaps sourceText) = Overlaps sourceText
+fromIfaceOverlapMode (IfIncoherent sourceText) = Incoherent sourceText
+fromIfaceOverlapMode (IfNonCanonical sourceText) = XOverlapMode (NonCanonical sourceText)
+
-- The ifFamInstTys field of IfaceFamInst contains a list of the rough
-- match types
data IfaceFamInst
@@ -1476,7 +1507,7 @@ instance Outputable IfaceClsInst where
ppr (IfaceClsInst { ifDFun = dfun_id, ifOFlag = flag
, ifInstCls = cls, ifInstTys = mb_tcs
, ifInstOrph = orph })
- = hang (text "instance" <+> ppr flag
+ = hang (text "instance" <+> ppr (fromIfaceOverlapFlag flag)
<+> (if isOrphan orph then text "[orphan]" else Outputable.empty)
<+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs))
2 (equals <+> ppr dfun_id)
@@ -2453,6 +2484,34 @@ instance Binary IfaceClsInst where
warn <- get bh
return (IfaceClsInst cls tys dfun flag orph warn)
+instance Binary IfaceOverlapFlag where
+ put_ bh flag = do put_ bh (ifOverlapMode flag)
+ put_ bh (ifisSafeOverlap flag)
+ get bh = do
+ h <- get bh
+ b <- get bh
+ return IfOverlapFlag { ifOverlapMode = h, ifisSafeOverlap = b }
+
+instance Binary IfaceOverlapMode where
+ put_ bh (IfNoOverlap s) = putByte bh 0 >> put_ bh s
+ put_ bh (IfOverlaps s) = putByte bh 1 >> put_ bh s
+ put_ bh (IfIncoherent s) = putByte bh 2 >> put_ bh s
+ put_ bh (IfOverlapping s) = putByte bh 3 >> put_ bh s
+ put_ bh (IfOverlappable s) = putByte bh 4 >> put_ bh s
+ put_ bh (IfNonCanonical s) = putByte bh 5 >> put_ bh s
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> (get bh) >>= \s -> return $ IfNoOverlap s
+ 1 -> (get bh) >>= \s -> return $ IfOverlaps s
+ 2 -> (get bh) >>= \s -> return $ IfIncoherent s
+ 3 -> (get bh) >>= \s -> return $ IfOverlapping s
+ 4 -> (get bh) >>= \s -> return $ IfOverlappable s
+ 5 -> (get bh) >>= \s -> return $ IfNonCanonical s
+ _ -> panic ("get OverlapMode" ++ show h)
+
+
+
instance Binary IfaceFamInst where
put_ bh (IfaceFamInst fam tys name orph) = do
put_ bh fam
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -1266,7 +1266,7 @@ tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag
fmap tyThingId (tcIfaceImplicit dfun_name)
; let mb_tcs' = map tcRoughTyCon mb_tcs
warn = fmap fromIfaceWarningTxt iface_warn
- ; return (mkImportedClsInst cls mb_tcs' dfun_name dfun oflag orph warn) }
+ ; return (mkImportedClsInst cls mb_tcs' dfun_name dfun (fromIfaceOverlapFlag oflag) orph warn) }
tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -2118,13 +2118,13 @@ instance ExactPrint (RuleDecl GhcPs) where
markActivationL :: (Monad m, Monoid w)
- => a -> Lens a ActivationAnn -> Activation -> EP w m a
+ => a -> Lens a ActivationAnn -> Activation (GhcPass p) -> EP w m a
markActivationL a l act = do
new <- markActivation (view l a) act
return (set l new a)
markActivation :: (Monad m, Monoid w)
- => ActivationAnn -> Activation -> EP w m ActivationAnn
+ => ActivationAnn -> Activation (GhcPass p) -> EP w m ActivationAnn
markActivation (ActivationAnn o c t v) act = do
case act of
ActiveBefore src phase -> do
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1a7812a525017f46958e555b08e75765a6e7545c...f940806f888655821a79d482873617ff00cbbc38
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1a7812a525017f46958e555b08e75765a6e7545c...f940806f888655821a79d482873617ff00cbbc38
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/20241028/f172c2f9/attachment-0001.html>
More information about the ghc-commits
mailing list