[Git][ghc/ghc][wip/T17521] Lint tags of top-level unlifted bindings
Jaro Reinders (@Noughtmare)
gitlab at gitlab.haskell.org
Mon Aug 14 14:45:30 UTC 2023
Jaro Reinders pushed to branch wip/T17521 at Glasgow Haskell Compiler / GHC
Commits:
9511029d by Jaro Reinders at 2023-08-14T16:43:24+02:00
Lint tags of top-level unlifted bindings
- - - - -
3 changed files:
- compiler/GHC/Stg/InferTags/Rewrite.hs
- compiler/GHC/Stg/Lint.hs
- compiler/GHC/Stg/Pipeline.hs
Changes:
=====================================
compiler/GHC/Stg/InferTags/Rewrite.hs
=====================================
@@ -325,15 +325,15 @@ rewriteTop (StgTopLifted bind) = do
rewriteBinds :: TopLevelFlag -> InferStgBinding -> RM (TgStgBinding)
rewriteBinds _top_flag (StgNonRec v rhs) = do
(!rhs) <- rewriteRhs v rhs
- return $! (StgNonRec (fst v) rhs)
+ return $! (StgNonRec (rewriteId' v) rhs)
rewriteBinds top_flag b@(StgRec binds) =
-- Bring sigs of binds into scope for all rhss
withBind top_flag b $ do
(rhss) <- mapM (uncurry rewriteRhs) binds
- return $! (mkRec rhss)
- where
- mkRec :: [TgStgRhs] -> TgStgBinding
- mkRec rhss = StgRec (zip (map (fst . fst) binds) rhss)
+ return $! StgRec (zip (map (rewriteId' . fst) binds) rhss)
+
+rewriteId' :: (Id, TagSig) -> Id
+rewriteId' (v, tag) = setIdTagSig v tag
-- Rewrite a RHS
rewriteRhs :: (Id,TagSig) -> InferStgRhs
=====================================
compiler/GHC/Stg/Lint.hs
=====================================
@@ -130,6 +130,7 @@ import GHC.Core.Multiplicity (scaledThing)
import GHC.Settings (Platform)
import GHC.Core.TyCon (primRepCompatible, primRepsCompatible)
import GHC.Utils.Panic.Plain (panic)
+import GHC.Stg.InferTags.TagSig
lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)
=> Platform
@@ -139,11 +140,12 @@ lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)
-> [Var] -- ^ extra vars in scope from GHCi
-> Module -- ^ module being compiled
-> Bool -- ^ have we run Unarise yet?
+ -> Bool -- ^ have we inferred tags yet?
-> String -- ^ who produced the STG?
-> [GenStgTopBinding a]
-> IO ()
-lintStgTopBindings platform logger diag_opts opts extra_vars this_mod unarised whodunit binds
+lintStgTopBindings platform logger diag_opts opts extra_vars this_mod unarised tagged whodunit binds
= {-# SCC "StgLint" #-}
case initL platform diag_opts this_mod unarised opts top_level_binds (lint_binds binds) of
Nothing ->
@@ -172,7 +174,7 @@ lintStgTopBindings platform logger diag_opts opts extra_vars this_mod unarised w
addInScopeVars binders $
lint_binds binds
- lint_bind (StgTopLifted bind) = lintStgBinds TopLevel bind
+ lint_bind (StgTopLifted bind) = lintStgBinds TopLevel tagged bind
lint_bind (StgTopStringLit v _) = return [v]
lintStgArg :: StgArg -> LintM ()
@@ -184,14 +186,14 @@ lintStgVar id = checkInScope id
lintStgBinds
:: (OutputablePass a, BinderP a ~ Id)
- => TopLevelFlag -> GenStgBinding a -> LintM [Id] -- Returns the binders
-lintStgBinds top_lvl (StgNonRec binder rhs) = do
- lint_binds_help top_lvl (binder,rhs)
+ => TopLevelFlag -> Bool -> GenStgBinding a -> LintM [Id] -- Returns the binders
+lintStgBinds top_lvl tagged (StgNonRec binder rhs) = do
+ lint_binds_help top_lvl tagged (binder,rhs)
return [binder]
-lintStgBinds top_lvl (StgRec pairs)
+lintStgBinds top_lvl tagged (StgRec pairs)
= addInScopeVars binders $ do
- mapM_ (lint_binds_help top_lvl) pairs
+ mapM_ (lint_binds_help top_lvl tagged) pairs
return binders
where
binders = [b | (b,_) <- pairs]
@@ -199,14 +201,17 @@ lintStgBinds top_lvl (StgRec pairs)
lint_binds_help
:: (OutputablePass a, BinderP a ~ Id)
=> TopLevelFlag
+ -> Bool
-> (Id, GenStgRhs a)
-> LintM ()
-lint_binds_help top_lvl (binder, rhs)
+lint_binds_help top_lvl tagged (binder, rhs)
= addLoc (RhsOf binder) $ do
when (isTopLevel top_lvl) (checkNoCurrentCCS rhs)
lintStgRhs rhs
opts <- getStgPprOpts
-- Check binder doesn't have unlifted type or it's a join point
+ -- Or binder is unlifted (not unboxed) and it is a fully evaluated
+ -- constructor
checkL ( isJoinId binder
|| not (isUnliftedType (idType binder))
|| isTopLevel top_lvl
@@ -214,6 +219,15 @@ lint_binds_help top_lvl (binder, rhs)
&& case rhs of StgRhsCon{} -> True; _ -> False)
(mkUnliftedTyMsg opts binder rhs)
+ -- check that top-level unlifted bindings are properly tagged
+ when (tagged && isTopLevel top_lvl && mightBeUnliftedType (idType binder)) $
+ checkL ( idTagSig_maybe binder == Just (TagSig TagProper)
+ -- Data-con workers are not always properly tagged when compiled for
+ -- the bytecode interpreter.
+ -- See Note [Tag inference for interpreted code] in GHC.Stg.InferTags
+ || isDataConWorkId binder)
+ (mkUntaggedMsg binder)
+
-- | Top-level bindings can't inherit the cost centre stack from their
-- (static) allocation site.
checkNoCurrentCCS
@@ -284,13 +298,15 @@ lintStgExpr (StgOpApp _ args _) =
mapM_ lintStgArg args
lintStgExpr (StgLet _ binds body) = do
- binders <- lintStgBinds NotTopLevel binds
+ -- Tag inference may have run, but that does not matter for non-top-level binders
+ binders <- lintStgBinds NotTopLevel False binds
addLoc (BodyOfLet binders) $
addInScopeVars binders $
lintStgExpr body
lintStgExpr (StgLetNoEscape _ binds body) = do
- binders <- lintStgBinds NotTopLevel binds
+ -- Tag inference may have run, but that does not matter for non-top-level binders
+ binders <- lintStgBinds NotTopLevel False binds
addLoc (BodyOfLet binders) $
addInScopeVars binders $
lintStgExpr body
@@ -576,3 +592,10 @@ mkUnliftedTyMsg opts binder rhs
text "has unlifted type" <+> quotes (ppr (idType binder)))
$$
(text "RHS:" <+> pprStgRhs opts rhs)
+
+mkUntaggedMsg :: Id -> SDoc
+mkUntaggedMsg binder
+ = (text "Top-level unlifted binder" <+> quotes (ppr binder) <+>
+ text "is not properly tagged")
+ $$
+ (text "TagSig:" <+> quotes (ppr (idTagSig_maybe binder)))
=====================================
compiler/GHC/Stg/Pipeline.hs
=====================================
@@ -74,7 +74,7 @@ stg2stg :: Logger
-> IO ([(CgStgTopBinding,IdSet)], StgCgInfos) -- output program
stg2stg logger extra_vars opts this_mod binds
= do { dump_when Opt_D_dump_stg_from_core "Initial STG:" binds
- ; stg_linter False "StgFromCore" binds
+ ; stg_linter False False "StgFromCore" binds
; showPass logger "Stg2Stg"
-- Do the main business!
; binds' <- runStgM 'g' $
@@ -93,18 +93,18 @@ stg2stg logger extra_vars opts this_mod binds
; let (binds_sorted_with_fvs, imp_fvs) = unzip (depSortWithAnnotStgPgm this_mod binds')
-- See Note [Tag inference for interactive contexts]
; (cg_binds, cg_infos) <- inferTags (stgPipeline_pprOpts opts) (stgPipeline_forBytecode opts) logger this_mod binds_sorted_with_fvs
- ; stg_linter False "StgCodeGen" cg_binds
+ ; stg_linter False True "StgCodeGen" cg_binds
; pure (zip cg_binds imp_fvs, cg_infos)
}
where
- stg_linter :: (BinderP a ~ Id, OutputablePass a) => Bool -> String -> [GenStgTopBinding a] -> IO ()
- stg_linter unarised
+ stg_linter :: (BinderP a ~ Id, OutputablePass a) => Bool -> Bool -> String -> [GenStgTopBinding a] -> IO ()
+ stg_linter unarised tagged
| Just diag_opts <- stgPipeline_lint opts
= lintStgTopBindings
(stgPlatform opts) logger
diag_opts ppr_opts
- extra_vars this_mod unarised
+ extra_vars this_mod unarised tagged
| otherwise
= \ _whodunit _binds -> return ()
@@ -135,10 +135,10 @@ stg2stg logger extra_vars opts this_mod binds
StgUnarise -> do
us <- getUniqueSupplyM
- liftIO (stg_linter False "Pre-unarise" binds)
+ liftIO (stg_linter False False "Pre-unarise" binds)
let binds' = {-# SCC "StgUnarise" #-} unarise us binds
liftIO (dump_when Opt_D_dump_stg_unarised "Unarised STG:" binds')
- liftIO (stg_linter True "Unarise" binds')
+ liftIO (stg_linter True False "Unarise" binds')
return binds'
ppr_opts = stgPipeline_pprOpts opts
@@ -149,7 +149,7 @@ stg2stg logger extra_vars opts this_mod binds
= liftIO $ do -- report verbosely, if required
putDumpFileMaybe logger Opt_D_verbose_stg2stg what
FormatSTG (vcat (map (pprStgTopBinding ppr_opts) binds2))
- stg_linter False what binds2
+ stg_linter False False what binds2
return binds2
-- -----------------------------------------------------------------------------
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9511029dab79fdea03c80804745bf3e2595ed727
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9511029dab79fdea03c80804745bf3e2595ed727
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/20230814/d09bbf12/attachment-0001.html>
More information about the ghc-commits
mailing list