[Git][ghc/ghc][wip/t24032] Add -ddump-specialisations, -ddump-specializations
Finley McIlwaine (@FinleyMcIlwaine)
gitlab at gitlab.haskell.org
Fri Sep 29 19:40:37 UTC 2023
Finley McIlwaine pushed to branch wip/t24032 at Glasgow Haskell Compiler / GHC
Commits:
d797260c by Finley McIlwaine at 2023-09-29T12:40:25-07:00
Add -ddump-specialisations, -ddump-specializations
These flags will dump information about any specialisations generated as a
result of pragmas or the specialiser.
Resolves: #24032
- - - - -
6 changed files:
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/HsToCore/Binds.hs
- docs/users_guide/9.10.1-notes.rst
- docs/users_guide/debugging.rst
Changes:
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -59,6 +59,8 @@ import GHC.Types.Id.Info
import GHC.Types.Error
import GHC.Utils.Error ( mkMCDiagnostic )
+import GHC.Utils.Logger (Logger)
+import qualified GHC.Utils.Logger as Logger
import GHC.Utils.Monad ( foldlM, MonadIO )
import GHC.Utils.Misc
import GHC.Utils.Outputable
@@ -68,6 +70,7 @@ import GHC.Unit.Module( Module )
import GHC.Unit.Module.ModGuts
import GHC.Core.Unfold
+import Control.Monad (when)
import Data.List( partition )
import Data.List.NonEmpty ( NonEmpty (..) )
@@ -645,6 +648,7 @@ specProgram guts@(ModGuts { mg_module = this_mod
, mg_rules = local_rules
, mg_binds = binds })
= do { dflags <- getDynFlags
+ ; logger <- Logger.getLogger
; rule_env <- initRuleEnv guts
-- See Note [Fire rules in the specialiser]
@@ -659,7 +663,8 @@ specProgram guts@(ModGuts { mg_module = this_mod
-- bindersOfBinds binds
, se_module = this_mod
, se_rules = rule_env
- , se_dflags = dflags }
+ , se_dflags = dflags
+ , se_logger = logger }
go [] = return ([], emptyUDs)
go (bind:binds) = do (bind', binds', uds') <- specBind TopLevel top_env bind $ \_ ->
@@ -1170,6 +1175,7 @@ data SpecEnv
, se_module :: Module
, se_rules :: RuleEnv -- From the home package and this module
, se_dflags :: DynFlags
+ , se_logger :: Logger
}
instance Outputable SpecEnv where
@@ -1676,6 +1682,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
is_dfun = isDFunId fn
dflags = se_dflags env
this_mod = se_module env
+ logger = se_logger env
-- Figure out whether the function has an INLINE pragma
-- See Note [Inline specialisations]
@@ -1808,18 +1815,37 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
spec_f_w_arity = spec_fn
- _rule_trace_doc = vcat [ ppr fn <+> dcolon <+> ppr fn_type
- , ppr spec_fn <+> dcolon <+> ppr spec_fn_ty
+ unspec_fn_doc = ppr fn <+> dcolon <+> ppr fn_type
+ spec_fn_doc = ppr spec_fn <+> dcolon <+> ppr spec_fn_ty
+
+ _rule_trace_doc = vcat [ unspec_fn_doc
+ , spec_fn_doc
, ppr rhs_bndrs, ppr call_args
, ppr spec_rule
]
+ -- Dump the specialisation if -ddump-specialisations is enabled
+ ; dump_spec unspec_fn_doc spec_fn_doc
+
; -- pprTrace "spec_call: rule" _rule_trace_doc
return ( spec_rule : rules_acc
, (spec_f_w_arity, spec_rhs) : pairs_acc
, spec_uds `thenUDs` uds_acc
) } }
+ dump_spec :: SDoc -> SDoc -> SpecM ()
+ dump_spec unspec_fn_doc spec_fn_doc =
+ when (Logger.logHasDumpFlag logger Opt_D_dump_specialisations) $
+ log_specialisation $
+ sep [text "Specialisation generated:",
+ nest 4 (vcat [text "Function: " <+> unspec_fn_doc,
+ text "Specialised function: " <+> spec_fn_doc])]
+
+ log_specialisation doc
+ = liftIO $ Logger.logDumpFile logger (mkDumpStyle alwaysQualify)
+ Opt_D_dump_specialisations
+ "" Logger.FormatText doc
+
-- Convenience function for invoking lookupRule from Specialise
-- The SpecEnv's InScopeSet should include all the Vars in the [CoreExpr]
specLookupRule :: SpecEnv -> Id -> [CoreExpr]
@@ -3442,13 +3468,13 @@ newtype SpecM result
}
deriving newtype (Functor, Applicative, Monad, MonadIO)
--- See Note [Uniques for wired-in prelude things and known masks] in GHC.Builtin.Uniques
-specMask :: Char
-specMask = 't'
+-- See Note [Uniques for wired-in prelude things and known tags] in GHC.Builtin.Uniques
+specTag :: Char
+specTag = 't'
instance MonadUnique SpecM where
- getUniqueSupplyM = liftIO $ mkSplitUniqSupply specMask
- getUniqueM = liftIO $ uniqFromMask specMask
+ getUniqueSupplyM = liftIO $ mkSplitUniqSupply specTag
+ getUniqueM = liftIO $ uniqFromTag specTag
runSpecM :: SpecM a -> CoreM a
runSpecM = liftIO . unSpecM
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -109,6 +109,7 @@ data DumpFlag
| Opt_D_dump_simpl_iterations
| Opt_D_dump_spec
| Opt_D_dump_spec_constr
+ | Opt_D_dump_specialisations
| Opt_D_dump_prep
| Opt_D_dump_late_cc
| Opt_D_dump_stg_from_core -- ^ Initial STG (CoreToStg output)
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -1440,6 +1440,10 @@ dynamic_flags_deps = [
(setDumpFlag Opt_D_dump_spec)
, make_ord_flag defGhcFlag "ddump-spec-constr"
(setDumpFlag Opt_D_dump_spec_constr)
+ , make_ord_flag defGhcFlag "ddump-specialisations"
+ (setDumpFlag Opt_D_dump_specialisations)
+ , make_ord_flag defGhcFlag "ddump-specializations"
+ (setDumpFlag Opt_D_dump_specialisations)
, make_ord_flag defGhcFlag "ddump-prep"
(setDumpFlag Opt_D_dump_prep)
, make_ord_flag defGhcFlag "ddump-late-cc"
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -77,6 +77,8 @@ import GHC.Data.Bag
import qualified Data.Set as S
import GHC.Utils.Constants (debugIsOn)
+import GHC.Utils.Logger (Logger)
+import qualified GHC.Utils.Logger as Logger
import GHC.Utils.Misc
import GHC.Utils.Monad
import GHC.Utils.Outputable
@@ -782,7 +784,8 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
; dsHsWrapper spec_app $ \core_app -> do
{ let ds_lhs = core_app (Var poly_id)
- spec_ty = mkLamTypes spec_bndrs (exprType ds_lhs)
+ poly_ty = exprType ds_lhs
+ spec_ty = mkLamTypes spec_bndrs poly_ty
; -- pprTrace "dsRule" (vcat [ text "Id:" <+> ppr poly_id
-- , text "spec_co:" <+> ppr spec_co
-- , text "ds_rhs:" <+> ppr ds_lhs ]) $
@@ -792,6 +795,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
Right (rule_bndrs, _fn, rule_lhs_args) -> do
{ this_mod <- getModule
+ ; logger <- Logger.getLogger
; let fn_unf = realIdUnfolding poly_id
simpl_opts = initSimpleOpts dflags
spec_unf = specUnfolding simpl_opts spec_bndrs core_app rule_lhs_args fn_unf
@@ -806,6 +810,11 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
; dsWarnOrphanRule rule
+ -- Dump the specialisation if -ddump-specialisations is enabled
+ ; dump_spec logger
+ (ppr poly_id <+> dcolon <+> ppr poly_ty)
+ (ppr spec_id <+> dcolon <+> ppr spec_ty)
+
; return (Just (unitOL (spec_id, spec_rhs), rule))
-- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because
-- makeCorePair overwrites the unfolding, which we have
@@ -846,6 +855,19 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
rule_act | no_act_spec = inlinePragmaActivation id_inl -- Inherit
| otherwise = spec_prag_act -- Specified by user
+ dump_spec :: Logger -> SDoc -> SDoc -> DsM ()
+ dump_spec logger unspec_fn_doc spec_fn_doc =
+ when (Logger.logHasDumpFlag logger Opt_D_dump_specialisations) $
+ log_specialisation logger $
+ sep [text "Specialisation resulted from a pragma:",
+ nest 4 (vcat [text "Function: " <+> unspec_fn_doc,
+ text "Specialised function: " <+> spec_fn_doc])]
+
+ log_specialisation logger doc
+ = liftIO $ Logger.logDumpFile logger (mkDumpStyle alwaysQualify)
+ Opt_D_dump_specialisations
+ "" Logger.FormatText doc
+
dsWarnOrphanRule :: CoreRule -> DsM ()
dsWarnOrphanRule rule
=====================================
docs/users_guide/9.10.1-notes.rst
=====================================
@@ -54,6 +54,10 @@ Compiler
- Defaulting plugins can now propose solutions to entangled sets of type variables. This allows defaulting
of multi-parameter type classes. See :ghc-ticket:`23832`.
+- The :ghc-flag:`-ddump-specialisations` / :ghc-flag:`-ddump-specializations`
+ flag has been added, which allows information about specialisations generated
+ as a result of a pragma or the specialiser to be dumped.
+
GHCi
~~~~
=====================================
docs/users_guide/debugging.rst
=====================================
@@ -343,6 +343,15 @@ subexpression elimination pass.
Dump output of the SpecConstr specialisation pass
+.. ghc-flag:: -ddump-specialisations
+ -ddump-specializations
+ :shortdesc: Dump information about generated specialisations
+ :type: dynamic
+
+ Dump information about any specialisations resulting from pragmas or the
+ specialiser logic. Currently, the identifiers and types of the unspecialised
+ function and the generated specialised function are dumped.
+
.. ghc-flag:: -ddump-rules
:shortdesc: Dump rewrite rules
:type: dynamic
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d797260cf699bd3e1cfa9e430619b8cfa38fe151
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d797260cf699bd3e1cfa9e430619b8cfa38fe151
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/20230929/048ed454/attachment-0001.html>
More information about the ghc-commits
mailing list