summaryrefslogtreecommitdiff
path: root/compiler/GHC/Iface
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Iface')
-rw-r--r--compiler/GHC/Iface/Make.hs11
-rw-r--r--compiler/GHC/Iface/Syntax.hs15
-rw-r--r--compiler/GHC/Iface/Tidy.hs31
3 files changed, 39 insertions, 18 deletions
diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs
index 28ddcac422..c0471cd413 100644
--- a/compiler/GHC/Iface/Make.hs
+++ b/compiler/GHC/Iface/Make.hs
@@ -159,16 +159,19 @@ mkFullIface hsc_env partial_iface mb_cg_infos = do
updateDecl :: [IfaceDecl] -> Maybe CgInfos -> [IfaceDecl]
updateDecl decls Nothing = decls
-updateDecl decls (Just CgInfos{ cgNonCafs = NonCaffySet non_cafs, cgLFInfos = lf_infos }) = map update_decl decls
+updateDecl decls (Just CgInfos{ cgNonCafs = NonCaffySet non_cafs, cgLFInfos = lf_infos, cgTagSigs = tag_sigs })
+ = map update_decl decls
where
update_decl (IfaceId nm ty details infos)
| let not_caffy = elemNameSet nm non_cafs
, let mb_lf_info = lookupNameEnv lf_infos nm
- , warnPprTrace (isNothing mb_lf_info) "Name without LFInfo" (ppr nm) True
+ , let sig = lookupNameEnv tag_sigs nm
+ , warnPprTrace (isNothing mb_lf_info) "updateDecl" (text "Name without LFInfo:" <+> ppr nm) True
-- Only allocate a new IfaceId if we're going to update the infos
- , isJust mb_lf_info || not_caffy
+ , isJust mb_lf_info || not_caffy || isJust sig
= IfaceId nm ty details $
- (if not_caffy then (HsNoCafRefs :) else id)
+ (if not_caffy then (HsNoCafRefs :) else id) $
+ (if isJust sig then (HsTagSig (fromJust sig):) else id) $
(case mb_lf_info of
Nothing -> infos -- LFInfos not available when building .cmm files
Just lf_info -> HsLFInfo (toIfaceLFInfo nm lf_info) : infos)
diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs
index 39f0bd5336..c735a2f94f 100644
--- a/compiler/GHC/Iface/Syntax.hs
+++ b/compiler/GHC/Iface/Syntax.hs
@@ -67,6 +67,7 @@ import GHC.Types.Var( VarBndr(..), binderVar, tyVarSpecToBinders )
import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisArgFlag )
import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..))
import GHC.Builtin.Types ( constraintKindTyConName )
+import GHC.Stg.InferTags.TagSig
import GHC.Utils.Lexeme (isLexSym)
import GHC.Utils.Fingerprint
@@ -352,6 +353,7 @@ data IfaceInfoItem
| HsNoCafRefs
| HsLevity -- Present <=> never representation-polymorphic
| HsLFInfo IfaceLFInfo
+ | HsTagSig TagSig
-- NB: Specialisations and rules come in separately and are
-- only later attached to the Id. Partial reason: some are orphans.
@@ -380,6 +382,7 @@ data IfaceUnfolding
data IfaceIdDetails
= IfVanillaId
+ | IfStrictWorkerId [CbvMark]
| IfRecSelId (Either IfaceTyCon IfaceDecl) Bool
| IfDFunId
@@ -1459,6 +1462,7 @@ instance Outputable IfaceConAlt where
------------------
instance Outputable IfaceIdDetails where
ppr IfVanillaId = Outputable.empty
+ ppr (IfStrictWorkerId dmd) = text "StrWork" <> parens (ppr dmd)
ppr (IfRecSelId tc b) = text "RecSel" <+> ppr tc
<+> if b
then text "<naughty>"
@@ -1476,6 +1480,7 @@ instance Outputable IfaceInfoItem where
ppr HsNoCafRefs = text "HasNoCafRefs"
ppr HsLevity = text "Never levity-polymorphic"
ppr (HsLFInfo lf_info) = text "LambdaFormInfo:" <+> ppr lf_info
+ ppr (HsTagSig tag_sig) = text "TagSig:" <+> ppr tag_sig
instance Outputable IfaceJoinInfo where
ppr IfaceNotJoinPoint = empty
@@ -2223,12 +2228,14 @@ instance Binary IfaceAnnotation where
instance Binary IfaceIdDetails where
put_ bh IfVanillaId = putByte bh 0
put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b
- put_ bh IfDFunId = putByte bh 2
+ put_ bh (IfStrictWorkerId dmds) = putByte bh 2 >> put_ bh dmds
+ put_ bh IfDFunId = putByte bh 3
get bh = do
h <- getByte bh
case h of
0 -> return IfVanillaId
1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) }
+ 2 -> do { dmds <- get bh; return (IfStrictWorkerId dmds) }
_ -> return IfDFunId
instance Binary IfaceInfoItem where
@@ -2240,6 +2247,7 @@ instance Binary IfaceInfoItem where
put_ bh HsLevity = putByte bh 5
put_ bh (HsCprSig cpr) = putByte bh 6 >> put_ bh cpr
put_ bh (HsLFInfo lf_info) = putByte bh 7 >> put_ bh lf_info
+ put_ bh (HsTagSig sig) = putByte bh 8 >> put_ bh sig
get bh = do
h <- getByte bh
@@ -2253,7 +2261,8 @@ instance Binary IfaceInfoItem where
4 -> return HsNoCafRefs
5 -> return HsLevity
6 -> HsCprSig <$> get bh
- _ -> HsLFInfo <$> get bh
+ 7 -> HsLFInfo <$> get bh
+ _ -> HsTagSig <$> get bh
instance Binary IfaceUnfolding where
put_ bh (IfCoreUnfold s e) = do
@@ -2586,6 +2595,7 @@ instance NFData IfaceBang where
instance NFData IfaceIdDetails where
rnf = \case
IfVanillaId -> ()
+ IfStrictWorkerId dmds -> dmds `seqList` ()
IfRecSelId (Left tycon) b -> rnf tycon `seq` rnf b
IfRecSelId (Right decl) b -> rnf decl `seq` rnf b
IfDFunId -> ()
@@ -2600,6 +2610,7 @@ instance NFData IfaceInfoItem where
HsLevity -> ()
HsCprSig cpr -> cpr `seq` ()
HsLFInfo lf_info -> lf_info `seq` () -- TODO: seq further?
+ HsTagSig sig -> sig `seq` ()
instance NFData IfaceUnfolding where
rnf = \case
diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs
index b1a079205e..c453cc5336 100644
--- a/compiler/GHC/Iface/Tidy.hs
+++ b/compiler/GHC/Iface/Tidy.hs
@@ -365,6 +365,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
, mg_foreign_files = foreign_files
, mg_hpc_info = hpc_info
, mg_modBreaks = modBreaks
+ , mg_boot_exports = boot_exports
})
= Err.withTiming logger
@@ -384,7 +385,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
; let uf_opts = unfoldingOpts dflags
; (tidy_env, tidy_binds)
- <- tidyTopBinds uf_opts unfold_env tidy_occ_env trimmed_binds
+ <- tidyTopBinds uf_opts unfold_env boot_exports tidy_occ_env trimmed_binds
-- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.
; (spt_entries, tidy_binds') <-
@@ -1180,39 +1181,41 @@ tidyTopName mod name_cache maybe_ref occ_env id
tidyTopBinds :: UnfoldingOpts
-> UnfoldEnv
+ -> NameSet
-> TidyOccEnv
-> CoreProgram
-> IO (TidyEnv, CoreProgram)
-tidyTopBinds uf_opts unfold_env init_occ_env binds
+tidyTopBinds uf_opts unfold_env boot_exports init_occ_env binds
= do let result = tidy init_env binds
seqBinds (snd result) `seq` return result
-- This seqBinds avoids a spike in space usage (see #13564)
where
init_env = (init_occ_env, emptyVarEnv)
- tidy = mapAccumL (tidyTopBind uf_opts unfold_env)
+ tidy = mapAccumL (tidyTopBind uf_opts unfold_env boot_exports)
------------------------
tidyTopBind :: UnfoldingOpts
-> UnfoldEnv
+ -> NameSet
-> TidyEnv
-> CoreBind
-> (TidyEnv, CoreBind)
-tidyTopBind uf_opts unfold_env
+tidyTopBind uf_opts unfold_env boot_exports
(occ_env,subst1) (NonRec bndr rhs)
= (tidy_env2, NonRec bndr' rhs')
where
Just (name',show_unfold) = lookupVarEnv unfold_env bndr
- (bndr', rhs') = tidyTopPair uf_opts show_unfold tidy_env2 name' (bndr, rhs)
+ (bndr', rhs') = tidyTopPair uf_opts show_unfold boot_exports tidy_env2 name' (bndr, rhs)
subst2 = extendVarEnv subst1 bndr bndr'
tidy_env2 = (occ_env, subst2)
-tidyTopBind uf_opts unfold_env (occ_env, subst1) (Rec prs)
+tidyTopBind uf_opts unfold_env boot_exports (occ_env, subst1) (Rec prs)
= (tidy_env2, Rec prs')
where
- prs' = [ tidyTopPair uf_opts show_unfold tidy_env2 name' (id,rhs)
+ prs' = [ tidyTopPair uf_opts show_unfold boot_exports tidy_env2 name' (id,rhs)
| (id,rhs) <- prs,
let (name',show_unfold) =
expectJust "tidyTopBind" $ lookupVarEnv unfold_env id
@@ -1226,6 +1229,7 @@ tidyTopBind uf_opts unfold_env (occ_env, subst1) (Rec prs)
-----------------------------------------------------------
tidyTopPair :: UnfoldingOpts
-> Bool -- show unfolding
+ -> NameSet
-> TidyEnv -- The TidyEnv is used to tidy the IdInfo
-- It is knot-tied: don't look at it!
-> Name -- New name
@@ -1237,14 +1241,17 @@ tidyTopPair :: UnfoldingOpts
-- group, a variable late in the group might be mentioned
-- in the IdInfo of one early in the group
-tidyTopPair uf_opts show_unfold rhs_tidy_env name' (bndr, rhs)
- = (bndr1, rhs1)
+tidyTopPair uf_opts show_unfold boot_exports rhs_tidy_env name' (bndr, rhs)
+ = -- pprTrace "tidyTop" (ppr name' <+> ppr details <+> ppr rhs) $
+ (bndr1, rhs1)
+
where
+ !cbv_bndr = tidyCbvInfoTop boot_exports bndr rhs
bndr1 = mkGlobalId details name' ty' idinfo'
- details = idDetails bndr -- Preserve the IdDetails
- ty' = tidyTopType (idType bndr)
+ details = idDetails cbv_bndr -- Preserve the IdDetails
+ ty' = tidyTopType (idType cbv_bndr)
rhs1 = tidyExpr rhs_tidy_env rhs
- idinfo' = tidyTopIdInfo uf_opts rhs_tidy_env name' rhs rhs1 (idInfo bndr)
+ idinfo' = tidyTopIdInfo uf_opts rhs_tidy_env name' rhs rhs1 (idInfo cbv_bndr)
show_unfold
-- tidyTopIdInfo creates the final IdInfo for top-level
View Lorry Controller Status