[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