[Git][ghc/ghc][wip/t24032] Add -ddump-specialisations, -ddump-specialization
Finley McIlwaine (@FinleyMcIlwaine)
gitlab at gitlab.haskell.org
Tue Oct 3 21:17:51 UTC 2023
Finley McIlwaine pushed to branch wip/t24032 at Glasgow Haskell Compiler / GHC
Commits:
f7ced925 by Finley McIlwaine at 2023-10-03T14:17:40-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,15 @@ subexpression elimination pass.
Dump output of the SpecConstr specialisation pass
+.. ghc-flag:: -ddump-specializations
+.. ghc-flag:: -ddump-specialisations
+ :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/f7ced925d284b34fdd73fab65273fdd358489434
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f7ced925d284b34fdd73fab65273fdd358489434
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/20231003/8f5c2cff/attachment-0001.html>
More information about the ghc-commits
mailing list