[Git][ghc/ghc][wip/t24032] Add -ddump-specialisations, -ddump-specialization

Finley McIlwaine (@FinleyMcIlwaine) gitlab at gitlab.haskell.org
Wed Oct 4 04:08:03 UTC 2023



Finley McIlwaine pushed to branch wip/t24032 at Glasgow Haskell Compiler / GHC


Commits:
24f12d07 by Finley McIlwaine at 2023-10-03T21:07:31-07:00
Add -ddump-specialisations, -ddump-specialization

These flags will dump information about any specialisations generated as a
result of pragmas or the specialiser.

Resolves: #24032

- - - - -


7 changed files:

- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/HsToCore/Binds.hs
- + compiler/GHC/Types/DumpSpecInfo.hs
- compiler/ghc.cabal.in
- docs/users_guide/debugging.rst


Changes:

=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -1,5 +1,6 @@
 {-# LANGUAGE DerivingStrategies         #-}
 {-# LANGUAGE GeneralisedNewtypeDeriving #-}
+{-# LANGUAGE TypeApplications           #-}
 
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 
@@ -57,8 +58,11 @@ import GHC.Types.Var.Env
 import GHC.Types.Id
 import GHC.Types.Id.Info
 import GHC.Types.Error
+import GHC.Types.DumpSpecInfo
 
 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
@@ -646,6 +650,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]
 
@@ -660,7 +665,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 $ \_ ->
@@ -1171,6 +1177,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
@@ -1673,6 +1680,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]
 
@@ -1744,7 +1752,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
                  -- See Note [Specialisations Must Be Lifted]
                  -- C.f. GHC.Core.Opt.WorkWrap.Utils.needsVoidWorkerArg
                  add_void_arg = isUnliftedType spec_fn_ty1 && not (isJoinId fn)
-                 (spec_bndrs, spec_rhs, spec_fn_ty)
+                 (spec_bndrs, spec_rhs, spec_fn_type)
                    | add_void_arg = ( voidPrimId : spec_bndrs1
                                     , Lam voidArgId spec_rhs1
                                     , mkVisFunTyMany unboxedUnitTy spec_fn_ty1)
@@ -1788,7 +1796,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
                        DFunId is_nt        -> DFunId is_nt
                        _                   -> VanillaId
 
-           ; spec_fn <- newSpecIdSM (idName fn) spec_fn_ty spec_fn_details spec_fn_info
+           ; spec_fn <- newSpecIdSM (idName fn) spec_fn_type spec_fn_details spec_fn_info
            ; let
                 -- The rule to put in the function's specialisation is:
                 --      forall x @b d1' d2'.
@@ -1805,12 +1813,27 @@ 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_type
+
+                _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
+           ; dumpSpecialisationWithLogger @Module @Id @Type logger $
+               DumpSpecInfo
+                { dumpSpecInfo_module = this_mod
+                , dumpSpecInfo_fromPragma = False
+                , dumpSpecInfo_polyId = fn
+                , dumpSpecInfo_polyTy = fn_type
+                , dumpSpecInfo_specId = spec_fn
+                , dumpSpecInfo_specTy = spec_fn_type
+                , dumpSpecInfo_dicts = map varType rule_bndrs
+                }
+
            ; -- pprTrace "spec_call: rule" _rule_trace_doc
              return ( spec_rule                  : rules_acc
                     , (spec_f_w_arity, spec_rhs) : pairs_acc
@@ -3439,13 +3462,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
=====================================
@@ -1,6 +1,5 @@
-
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
 
 {-
 (c) The University of Glasgow 2006
@@ -66,6 +65,7 @@ import GHC.Types.Name
 import GHC.Types.Var.Set
 import GHC.Types.Var.Env
 import GHC.Types.Var( EvVar )
+import GHC.Types.DumpSpecInfo
 import GHC.Types.SrcLoc
 import GHC.Types.Basic
 import GHC.Types.Unique.Set( nonDetEltsUniqSet )
@@ -806,6 +806,18 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
 
        ; dsWarnOrphanRule rule
 
+         -- Dump the specialisation if -ddump-specialisations is enabled
+       ; dumpSpecialisation @Module @Id @Type $
+           DumpSpecInfo
+             { dumpSpecInfo_module = this_mod
+             , dumpSpecInfo_fromPragma = True
+             , dumpSpecInfo_polyId = poly_id
+             , dumpSpecInfo_polyTy = idType poly_id
+             , dumpSpecInfo_specId = spec_id
+             , dumpSpecInfo_specTy = spec_ty
+             , dumpSpecInfo_dicts = map varType rule_bndrs
+             }
+
        ; 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,7 +858,6 @@ 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
 
-
 dsWarnOrphanRule :: CoreRule -> DsM ()
 dsWarnOrphanRule rule
   = when (isOrphan (ru_orphan rule)) $


=====================================
compiler/GHC/Types/DumpSpecInfo.hs
=====================================
@@ -0,0 +1,106 @@
+{-# LANGUAGE FlexibleContexts   #-}
+{-# LANGUAGE FlexibleInstances  #-}
+{-# LANGUAGE RecordWildCards    #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+-- | A module for the DumpSpecInfo type whose values contain information about
+-- specialisations generated by GHC. Output by -ddump-specialisations flag.
+module GHC.Types.DumpSpecInfo
+  ( DumpSpecInfo(..)
+  , DumpSpecInfoTypes(..)
+  , dumpSpecialisation
+  , dumpSpecialisationWithLogger
+  ) where
+
+import GHC.Core.Type
+import GHC.Driver.Flags (DumpFlag(..))
+import GHC.Prelude
+import GHC.Types.Id
+import GHC.Unit.Module
+import GHC.Utils.Logger
+import GHC.Utils.Outputable
+
+import Control.Monad
+import Control.Monad.IO.Class
+
+data DumpSpecInfoTypes =
+    DumpSpecInfoCustom
+  | DumpSpecInfoString
+
+data DumpSpecInfo mod id ty = DumpSpecInfo
+  { -- | Module the specialisation was generated in ('Module' in GHC)
+    dumpSpecInfo_module :: !mod
+
+    -- | Was this specialisation the result of a pragma?
+  , dumpSpecInfo_fromPragma :: !Bool
+
+    -- | Overloaded function identifier ('Id' in GHC)
+  , dumpSpecInfo_polyId :: !id
+    -- | Overloaded function type ('Type' in GHC)
+  , dumpSpecInfo_polyTy :: !ty
+
+    -- | Specialised function identifier ('Identifier' in GHC)
+  , dumpSpecInfo_specId :: !id
+    -- | Specialised function type ('Type' in GHC)
+  , dumpSpecInfo_specTy :: !ty
+
+    -- | The types of the dictionaries the specialisation is for (list of 'Type'
+    -- in GHC)
+  , dumpSpecInfo_dicts :: ![ty]
+  }
+
+-- | This instance is intentionally written so the following composition
+-- succeeds:
+--
+-- @read \@(DumpSpecInfo String String String) . show \@(DumpSpecInfo Module Id Type)@
+instance Show (DumpSpecInfo Module Id Type) where
+  show DumpSpecInfo{..} =
+    renderWithContext
+      defaultSDocContext
+        { sdocLineLength = maxBound
+        }
+      $ withPprStyle (mkDumpStyle alwaysQualify)
+      $ vcat
+          [ text "Specialisation generated:"
+          , nest 2 $ text "DumpSpecInfo" <+>
+              ( braces . sep $
+                  [ text "dumpSpecInfo_module" <+> equals <+> doubleQuotes (ppr dumpSpecInfo_module) <> comma
+                  , text "dumpSpecInfo_fromPragma" <+> equals <+> ppr dumpSpecInfo_fromPragma <> comma
+                  , text "dumpSpecInfo_polyId" <+> equals <+> doubleQuotes (ppr dumpSpecInfo_polyId) <> comma
+                  , text "dumpSpecInfo_polyTy" <+> equals <+> doubleQuotes (ppr dumpSpecInfo_polyTy) <> comma
+                  , text "dumpSpecInfo_specId" <+> equals <+> doubleQuotes (ppr dumpSpecInfo_specId) <> comma
+                  , text "dumpSpecInfo_specTy" <+> equals <+> doubleQuotes (ppr dumpSpecInfo_specTy) <> comma
+                  , text "dumpSpecInfo_dicts" <+> equals <+> ppr (map (doubleQuotes . ppr) dumpSpecInfo_dicts)
+                  ]
+              )
+          ]
+
+deriving instance Show (DumpSpecInfo String String String)
+deriving instance Read (DumpSpecInfo String String String)
+deriving instance Eq (DumpSpecInfo String String String)
+
+dumpSpecialisation
+  :: forall mod id ty m. (MonadIO m, HasLogger m, Show (DumpSpecInfo mod id ty))
+  => DumpSpecInfo mod id ty
+  -> m ()
+dumpSpecialisation spec_info = do
+    logger <- getLogger
+    dumpSpecialisationWithLogger logger spec_info
+
+dumpSpecialisationWithLogger
+  :: forall mod id ty m. (MonadIO m, Show (DumpSpecInfo mod id ty))
+  => Logger
+  -> DumpSpecInfo mod id ty
+  -> m ()
+dumpSpecialisationWithLogger logger spec_info = do
+    when (logHasDumpFlag logger Opt_D_dump_specialisations) $
+      log_specialisation logger (text $ show spec_info)
+
+log_specialisation :: MonadIO m => Logger -> SDoc -> m ()
+log_specialisation logger doc =
+    liftIO $
+      putDumpFileMaybe logger
+        Opt_D_dump_specialisations
+            ""
+            FormatText
+            doc


=====================================
compiler/ghc.cabal.in
=====================================
@@ -813,6 +813,7 @@ Library
         GHC.Types.CostCentre.State
         GHC.Types.Cpr
         GHC.Types.Demand
+        GHC.Types.DumpSpecInfo
         GHC.Types.Error
         GHC.Types.Error.Codes
         GHC.Types.FieldLabel


=====================================
docs/users_guide/debugging.rst
=====================================
@@ -343,6 +343,19 @@ subexpression elimination pass.
 
     Dump output of the SpecConstr specialisation pass
 
+.. ghc-flag:: -ddump-specializations
+    :shortdesc: Dump information about generated specialisations
+    :type: dynamic
+
+    Equivalent to :ghc-flag:`-ddump-specialisations`
+
+.. ghc-flag:: -ddump-specialisations
+    :shortdesc: Dump information about generated specialisations
+    :type: dynamic
+
+    Dump information about any specialisations resulting from pragmas or the
+    specialiser logic.
+
 .. ghc-flag:: -ddump-rules
     :shortdesc: Dump rewrite rules
     :type: dynamic



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/24f12d076a5a1ccfa57f2ad3205ae08f5e4659c8

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/24f12d076a5a1ccfa57f2ad3205ae08f5e4659c8
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/20231004/9c2c615d/attachment-0001.html>


More information about the ghc-commits mailing list