[Git][ghc/ghc][wip/ghc-fat-interface] wip sharing
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Thu Aug 11 12:39:09 UTC 2022
Matthew Pickering pushed to branch wip/ghc-fat-interface at Glasgow Haskell Compiler / GHC
Commits:
8441b77c by Matthew Pickering at 2022-08-11T12:39:16+01:00
wip sharing
- - - - -
8 changed files:
- compiler/GHC/CoreToIface.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Unit/Module/FatIface.hs
- compiler/GHC/Unit/Module/ModIface.hs
Changes:
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -443,15 +443,12 @@ toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id))
toIfaceTopBndr :: Id -> IfaceTopBndrInfo
toIfaceTopBndr id
- = IfTopBndr get_name
- (toIfaceType (idType id))
- (toIfaceIdInfo (idInfo id))
- (toIfaceIdDetails (idDetails id))
+ = if isExternalName name
+ then IfGblTopBndr name
+ else IfLclTopBndr (occNameFS (getOccName id)) (toIfaceType (idType id))
+ (toIfaceIdInfo (idInfo id)) (toIfaceIdDetails (idDetails id))
where
name = getName id
- get_name = if isExternalName name
- then Right (getName name)
- else Left (getOccFS name)
toIfaceIdDetails :: IdDetails -> IfaceIdDetails
toIfaceIdDetails VanillaId = IfVanillaId
@@ -592,9 +589,22 @@ toIfaceBind :: Bind Id -> IfaceBinding IfaceLetBndr
toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r)
toIfaceBind (Rec prs) = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs]
-toIfaceTopBind :: Bind Id -> IfaceBinding IfaceTopBndrInfo
-toIfaceTopBind (NonRec b r) = IfaceNonRec (toIfaceTopBndr b) (toIfaceExpr r)
-toIfaceTopBind (Rec prs) = IfaceRec [(toIfaceTopBndr b, toIfaceExpr r) | (b,r) <- prs]
+toIfaceTopBind :: Bind Id -> IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo
+toIfaceTopBind b =
+ case b of
+ NonRec b r -> uncurry IfaceNonRec (do_one (b, r))
+ Rec prs -> IfaceRec (map do_one prs)
+ where
+ do_one (b, rhs) =
+ let top_bndr = toIfaceTopBndr b
+ rhs' = case top_bndr of
+ -- Use the existing unfolding for a global binder if we store that anyway.
+ IfGblTopBndr {} -> if already_has_unfolding b then IfUseUnfoldingRhs else IfRhs (toIfaceExpr rhs)
+ -- Local binders will have had unfoldings trimmed
+ IfLclTopBndr {} -> IfRhs (toIfaceExpr rhs)
+ in (top_bndr, rhs')
+
+ already_has_unfolding b = hasCoreUnfolding (realIdUnfolding b)
---------------------
toIfaceAlt :: CoreAlt -> IfaceAlt
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -3858,6 +3858,7 @@ impliedGFlags = [(Opt_DeferTypeErrors, turnOn, Opt_DeferTypedHoles)
,(Opt_DoLinearCoreLinting, turnOn, Opt_DoCoreLinting)
,(Opt_Strictness, turnOn, Opt_WorkerWrapper)
,(Opt_WriteFatInterface, turnOn, Opt_WriteInterface)
+ ,(Opt_ByteCodeAndObjectCode, turnOn, Opt_WriteFatInterface)
] ++ validHoleFitsImpliedGFlags
-- General flags that are switched on/off when other general flags are switched
=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -269,7 +269,7 @@ mkIface_ hsc_env
semantic_mod = homeModuleNameInstantiation home_unit (moduleName this_mod)
entities = typeEnvElts type_env
show_linear_types = xopt LangExt.LinearTypes (hsc_dflags hsc_env)
- -- MP: TODO
+
extra_decls = if gopt Opt_WriteFatInterface dflags then Just [ toIfaceTopBind b | b <- core_prog ]
else Nothing
decls = [ tyThingToIfaceDecl show_linear_types entity
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -1202,7 +1202,7 @@ addFingerprints hsc_env iface0
[(getOccName d, e) | e@(_, d) <- decls_w_hashes]
-- TODO: MP implement sorting here
- sorted_extra_decls :: Maybe [IfaceBinding IfaceTopBndrInfo]
+ sorted_extra_decls :: Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
sorted_extra_decls = mi_extra_decls iface0
-- the flag hash depends on:
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -14,7 +14,7 @@ module GHC.Iface.Syntax (
IfaceDecl(..), IfaceFamTyConFlav(..), IfaceClassOp(..), IfaceAT(..),
IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec,
IfaceExpr(..), IfaceAlt(..), IfaceLetBndr(..), IfaceJoinInfo(..), IfaceBinding,
- IfaceBindingX(..), IfaceConAlt(..),
+ IfaceBindingX(..), IfaceMaybeRhs(..), IfaceConAlt(..),
IfaceIdInfo, IfaceIdDetails(..), IfaceUnfolding(..),
IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..),
@@ -593,7 +593,16 @@ data IfaceBindingX r b
-- See Note [IdInfo on nested let-bindings]
data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo IfaceJoinInfo
-data IfaceTopBndrInfo = IfTopBndr (Either IfLclName IfaceTopBndr) IfaceType IfaceIdInfo IfaceIdDetails
+data IfaceTopBndrInfo = IfLclTopBndr IfLclName IfaceType IfaceIdInfo IfaceIdDetails | IfGblTopBndr IfaceTopBndr
+
+ {-
+ IfTopBndr { top_bndr_name :: Either IfLclName IfaceTopBndr
+ , top_bndr_type :: IfaceType
+ , top_bndr_id_info :: IfaceIdInfo
+ , top_bndr_iface_details :: IfaceIdDetails
+ ]-}
+
+data IfaceMaybeRhs = IfUseUnfoldingRhs | IfRhs IfaceExpr
data IfaceJoinInfo = IfaceNotJoinPoint
| IfaceJoinPoint JoinArity
@@ -719,7 +728,12 @@ instance (Outputable r, Outputable b) => Outputable (IfaceBindingX r b) where
ppr_bind (b, r) = ppr b <+> equals <+> ppr r
instance Outputable IfaceTopBndrInfo where
- ppr (IfTopBndr n _ _ _) = ppr (either ppr (ppr . getOccName) n)
+ ppr (IfLclTopBndr lcl_name _ _ _) = ppr lcl_name
+ ppr (IfGblTopBndr gbl) = ppr gbl
+
+instance Outputable IfaceMaybeRhs where
+ ppr IfUseUnfoldingRhs = text "<unfolding>"
+ ppr (IfRhs ie) = ppr ie
{-
Note [Minimal complete definition]
@@ -2501,16 +2515,36 @@ instance Binary IfaceLetBndr where
return (IfLetBndr a b c d)
instance Binary IfaceTopBndrInfo where
- put_ bh (IfTopBndr a b c d) = do
- put_ bh a
- put_ bh b
- put_ bh c
- put_ bh d
- get bh = do a <- get bh
- b <- get bh
- c <- get bh
- d <- get bh
- return (IfTopBndr a b c d)
+ put_ bh (IfLclTopBndr lcl ty info dets) = do
+ putByte bh 0
+ put_ bh lcl
+ put_ bh ty
+ put_ bh info
+ put_ bh dets
+ put_ bh (IfGblTopBndr gbl) = do
+ putByte bh 1
+ put_ bh gbl
+ get bh = do
+ tag <- getByte bh
+ case tag of
+ 0 -> IfLclTopBndr <$> get bh <*> get bh <*> get bh <*> get bh
+ 1 -> IfGblTopBndr <$> get bh
+ _ -> pprPanic "IfaceTopBndrInfo" (intWithCommas tag)
+
+instance Binary IfaceMaybeRhs where
+ put_ bh IfUseUnfoldingRhs = putByte bh 0
+ put_ bh (IfRhs e) = do
+ putByte bh 1
+ put_ bh e
+
+ get bh = do
+ b <- getByte bh
+ case b of
+ 0 -> return IfUseUnfoldingRhs
+ 1 -> IfRhs <$> get bh
+ _ -> pprPanic "IfaceMaybeRhs" (intWithCommas b)
+
+
instance Binary IfaceJoinInfo where
put_ bh IfaceNotJoinPoint = putByte bh 0
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -901,7 +901,7 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = name
tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm)
; return (nm, idType id, b) }
-tcTopIfaceBindings :: IORef TypeEnv -> [IfaceBinding IfaceTopBndrInfo]
+tcTopIfaceBindings :: IORef TypeEnv -> [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
-> IfL [CoreBind]
tcTopIfaceBindings ty_var ver_decls
= do
@@ -911,31 +911,30 @@ tcTopIfaceBindings ty_var ver_decls
extendIfaceIdEnv all_ids $ mapM (tc_iface_bindings) int
-tcTopBinders :: IfaceBinding IfaceTopBndrInfo -> IfL (IfaceBinding Id)
+tcTopBinders :: IfaceBindingX a IfaceTopBndrInfo -> IfL (IfaceBindingX a Id)
tcTopBinders = traverse mk_top_id
-tc_iface_bindings :: IfaceBinding Id -> IfL CoreBind
+tc_iface_bindings :: IfaceBindingX IfaceMaybeRhs Id -> IfL CoreBind
tc_iface_bindings (IfaceNonRec b rhs) = do
- NonRec b <$> tcIfaceExpr rhs
+ rhs' <- tc_iface_binding b rhs
+ return $ NonRec b rhs'
tc_iface_bindings (IfaceRec bs) = do
- rs <- mapM (\(b, rhs) -> (b,) <$> tcIfaceExpr rhs) bs
+ rs <- mapM (\(b, rhs) -> (b,) <$> tc_iface_binding b rhs) bs
return (Rec rs)
+tc_iface_binding :: Id -> IfaceMaybeRhs -> IfL CoreExpr
+tc_iface_binding i IfUseUnfoldingRhs = return (unfoldingTemplate $ realIdUnfolding i)
+tc_iface_binding _ (IfRhs rhs) = tcIfaceExpr rhs
+
mk_top_id :: IfaceTopBndrInfo -> IfL Id
-mk_top_id (IfTopBndr raw_name iface_type _info details) = do
- case raw_name of
- Left lcl -> do
- name <- newIfaceName (mkVarOccFS lcl)
- ty <- tcIfaceType iface_type
- details <- tcIdDetails ty details
- info <- tcIdInfo False TopLevel name ty []
- let new_id = (mkGlobalId details name ty info)
- return new_id
- Right name -> do
- ty <- tcIfaceType iface_type
- details <- tcIdDetails ty details
- info <- tcIdInfo False TopLevel name ty []
- return (mkGlobalId details name ty info)
+mk_top_id (IfGblTopBndr gbl_name) = tcIfaceExtId gbl_name
+mk_top_id (IfLclTopBndr raw_name iface_type info details) = do
+ name <- newIfaceName (mkVarOccFS raw_name)
+ ty <- tcIfaceType iface_type
+ info' <- tcIdInfo False TopLevel name ty info
+ details' <- tcIdDetails ty details
+ let new_id = mkGlobalId details' name ty info'
+ return new_id
tcIfaceDecls :: Bool
-> [(Fingerprint, IfaceDecl)]
=====================================
compiler/GHC/Unit/Module/FatIface.hs
=====================================
@@ -6,7 +6,7 @@ import GHC.Unit.Module.Location
import GHC.Iface.Syntax
import GHC.Utils.Binary
-data FatIface = FatIface { fi_bindings :: [IfaceBinding IfaceTopBndrInfo]
+data FatIface = FatIface { fi_bindings :: [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
, fi_module :: Module
, fi_mod_location :: ModLocation
}
=====================================
compiler/GHC/Unit/Module/ModIface.hs
=====================================
@@ -200,7 +200,7 @@ data ModIface_ (phase :: ModIfacePhase)
-- Ditto data constructors, class operations, except that
-- the hash of the parent class/tycon changes
- mi_extra_decls :: Maybe [IfaceBinding IfaceTopBndrInfo],
+ mi_extra_decls :: Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo],
-- ^ Extra variable definitions which are **NOT** exposed but when
-- combined with mi_decls allows us to restart code generation.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8441b77c7558a86bf4cb2274a64287a6bfde4168
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8441b77c7558a86bf4cb2274a64287a6bfde4168
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/20220811/6f9ab4bd/attachment-0001.html>
More information about the ghc-commits
mailing list