summaryrefslogtreecommitdiff
path: root/compiler/GHC/Iface
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Iface')
-rw-r--r--compiler/GHC/Iface/Ext/Ast.hs5
-rw-r--r--compiler/GHC/Iface/Recomp.hs11
-rw-r--r--compiler/GHC/Iface/Syntax.hs7
-rw-r--r--compiler/GHC/Iface/Tidy.hs23
4 files changed, 39 insertions, 7 deletions
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 8f97f51833..685bc31bbe 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -1718,6 +1718,11 @@ instance HiePass p => ToHie (SigContext (LocatedA (Sig (GhcPass p)))) where
InlineSig _ name _ ->
[ toHie $ (C Use) name
]
+ SpecRecSig _ name act ->
+ [ toHie $ (C Use) name
+ -- TODO: activation
+ -- , toHie $ act
+ ]
SpecSig _ name typs _ ->
[ toHie $ (C Use) name
, toHie $ map (TS (ResolvedScopes [])) typs
diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs
index 0d001e94d9..73ba71240f 100644
--- a/compiler/GHC/Iface/Recomp.hs
+++ b/compiler/GHC/Iface/Recomp.hs
@@ -1035,9 +1035,14 @@ addFingerprints hsc_env iface0
-- See Note [Identity versus semantic module]
| semantic_mod /= this_mod
, 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 local_env)))
+ | otherwise = do
+ let fp = lookupOccEnv local_env (getOccName name) `orElse`
+ (pprTrace "urk! lookup local fingerprint"
+ (ppr (nameModule name) $$ ppr name $$ ppr local_env)
+ -- TODO: ???
+ (undefined, fingerprint0)
+ )
+ return $ snd fp
-- 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
diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs
index f57fefd4e7..d48d547dc7 100644
--- a/compiler/GHC/Iface/Syntax.hs
+++ b/compiler/GHC/Iface/Syntax.hs
@@ -358,6 +358,7 @@ data IfaceInfoItem
| HsUnfold Bool -- True <=> isStrongLoopBreaker is true
IfaceUnfolding -- See Note [Expose recursive functions]
| HsInlineable
+ | HsSpecRec Activation
| HsNoCafRefs
| HsLFInfo IfaceLFInfo
| HsTagSig TagSig
@@ -1517,6 +1518,7 @@ instance Outputable IfaceInfoItem where
<> colon <+> ppr unf
ppr (HsInline prag) = text "Inline:" <+> ppr prag
ppr (HsInlineable) = text "HasInlineable:True"
+ ppr (HsSpecRec act) = text "SpecRec:" <> ppr act
ppr (HsArity arity) = text "Arity:" <+> int arity
ppr (HsDmdSig str) = text "Strictness:" <+> ppr str
ppr (HsCprSig cpr) = text "CPR:" <+> ppr cpr
@@ -2287,7 +2289,8 @@ instance Binary IfaceInfoItem where
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
- put_ bh (HsInlineable) = putByte bh 9
+ put_ bh (HsInlineable) = putByte bh 9
+ put_ bh (HsSpecRec act) = putByte bh 10 >> put_ bh act
get bh = do
h <- getByte bh
@@ -2303,6 +2306,7 @@ instance Binary IfaceInfoItem where
7 -> HsLFInfo <$> get bh
8 -> HsTagSig <$> get bh
9 -> pure HsInlineable
+ 10 -> HsSpecRec <$> get bh
_ -> error "Binary:IfaceInfoItem - Invalid byte"
instance Binary IfaceUnfolding where
@@ -2713,6 +2717,7 @@ instance NFData IfaceInfoItem where
HsLFInfo lf_info -> lf_info `seq` () -- TODO: seq further?
HsTagSig sig -> sig `seq` ()
HsInlineable -> ()
+ HsSpecRec act -> rnf act
instance NFData IfGuidance where
rnf = \case
diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs
index cb5458899a..b19e3c531c 100644
--- a/compiler/GHC/Iface/Tidy.hs
+++ b/compiler/GHC/Iface/Tidy.hs
@@ -384,6 +384,8 @@ tidyProgram opts (ModGuts { mg_module = mod
(unfold_env, tidy_occ_env) <- chooseExternalIds opts mod all_binds imp_rules
let (trimmed_binds, trimmed_rules) = findExternalRules opts all_binds imp_rules unfold_env
+ -- pprTraceM "trimmed_binds" (ppr $ bindersOfBinds trimmed_binds)
+
(tidy_env, tidy_binds) <- tidyTopBinds unfold_env boot_exports tidy_occ_env trimmed_binds
-- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.
@@ -652,7 +654,9 @@ chooseExternalIds :: TidyOpts
chooseExternalIds opts mod binds imp_id_rules
= do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env
+ -- ; pprTraceM "unfoldEnv" (ppr unfold_env1)
; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders
+ -- ; pprTraceM "internals" (ppr internal_ids)
; tidy_internal internal_ids unfold_env1 occ_env1 }
where
name_cache = opt_name_cache opts
@@ -717,7 +721,9 @@ chooseExternalIds opts mod binds imp_id_rules
search [] unfold_env occ_env = return (unfold_env, occ_env)
search ((idocc,referrer) : rest) unfold_env occ_env
- | idocc `elemVarEnv` unfold_env = search rest unfold_env occ_env
+ | idocc `elemVarEnv` unfold_env =
+ -- pprTrace "search.1" (ppr idocc <+> ppr referrer) $
+ search rest unfold_env occ_env
| otherwise = do
(occ_env', name') <- tidyTopName mod name_cache (Just referrer) occ_env idocc
let
@@ -733,6 +739,11 @@ chooseExternalIds opts mod binds imp_id_rules
referrer' | isExportedId refined_id = refined_id
| otherwise = referrer
--
+ -- pprTraceM "search.2"
+ -- (ppr idocc <+> ppr referrer $$
+ -- text "show:" <> ppr show_unfold $$
+ -- text "name',external:" <> ppr (name', isExternalName name')
+ -- )
search (zip new_ids (repeat referrer') ++ rest) unfold_env' occ_env'
tidy_internal :: [Id] -> UnfoldEnv -> TidyOccEnv
@@ -762,6 +773,7 @@ addExternal opts id
loop_breaker = isStrongLoopBreaker (occInfo idinfo)
bottoming_fn = isDeadEndSig (dmdSigInfo idinfo)
inlineable = inlineableInfo idinfo
+ spec_rec = specRecInfo idinfo
-- Stuff to do with the Id's unfolding
-- We leave the unfolding there even if there is a worker
@@ -776,6 +788,7 @@ addExternal opts id
-- source is an inline rule
|| inlineable
+ || isJust spec_rec
|| not dont_inline
where
@@ -1033,7 +1046,11 @@ findExternalRules opts binds imp_id_rules unfold_env
where
stuff@(binds', bndr_set, needed_fvs, rules)
= trim_binds binds
- needed bndr = isExportedId bndr || bndr `elemVarSet` needed_fvs
+ shows_unf bndr = case lookupVarEnv unfold_env bndr of
+ Just (name, show_unf)
+ | isExternalName name || show_unf -> True
+ _ -> False
+ needed bndr = isExportedId bndr || bndr `elemVarSet` needed_fvs || shows_unf bndr
bndrs = bindersOf bind
rhss = rhssOfBind bind
@@ -1281,7 +1298,7 @@ tidyTopIdInfo rhs_tidy_env name rhs_ty orig_rhs tidy_rhs idinfo show_unfold
Nothing -> False
Just (arity, _, _) -> not (isDeadEndAppSig id_sig arity)
- prag_info = mkPragInfo (inlinePragInfo idinfo) (inlineableInfo idinfo)
+ prag_info = mkPragInfo (inlinePragInfo idinfo) (inlineableInfo idinfo) (specRecInfo idinfo)
--------- Unfolding ------------
-- Force unfold_info (hence bangs), otherwise the old unfolding
-- is retained during code generation. See #22071
View Lorry Controller Status