[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: Document ghc package's PVP-noncompliance
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Sat Dec 16 19:51:37 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
ed0e4099 by Bryan Richter at 2023-12-14T04:30:53-05:00
Document ghc package's PVP-noncompliance
This changes nothing, it just makes the status quo explicit.
- - - - -
8bef8d9f by Luite Stegeman at 2023-12-14T04:31:33-05:00
JS: Mark spurious CI failures js_fragile(24259)
This marks the spurious test failures on the JS platform as
js_fragile(24259), so we don't hold up merge requests while
fixing the underlying issues.
See #24259
- - - - -
bda87919 by Sylvain Henry at 2023-12-14T14:19:50+01:00
Bump time submodule (#23202)
- - - - -
055e9913 by Finley McIlwaine at 2023-12-16T14:51:28-05:00
Late plugins
- - - - -
496898fd by Finley McIlwaine at 2023-12-16T14:51:28-05:00
withTiming on LateCCs and late plugins
- - - - -
1d616f64 by Finley McIlwaine at 2023-12-16T14:51:28-05:00
add test for late plugins
- - - - -
72016b90 by Finley McIlwaine at 2023-12-16T14:51:28-05:00
Document late plugins
- - - - -
22 changed files:
- compiler/GHC/Core/LateCC.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Plugins.hs
- compiler/ghc.cabal.in
- docs/users_guide/9.10.1-notes.rst
- docs/users_guide/extending_ghc.rst
- hadrian/src/Rules/Dependencies.hs
- libraries/base/tests/all.T
- libraries/time
- rts/js/time.js
- testsuite/driver/testlib.py
- testsuite/tests/backpack/cabal/T20509/all.T
- testsuite/tests/backpack/cabal/bkpcabal02/all.T
- testsuite/tests/backpack/cabal/bkpcabal03/all.T
- testsuite/tests/concurrent/should_run/all.T
- testsuite/tests/ghc-api/downsweep/all.T
- testsuite/tests/numeric/should_run/all.T
- testsuite/tests/plugins/Makefile
- testsuite/tests/plugins/all.T
- + testsuite/tests/plugins/late-plugin/LatePlugin.hs
- + testsuite/tests/plugins/test-late-plugin.hs
- testsuite/tests/rts/all.T
Changes:
=====================================
compiler/GHC/Core/LateCC.hs
=====================================
@@ -71,34 +71,32 @@ addLateCostCentresMG guts = do
let env :: Env
env = Env
{ thisModule = mg_module guts
- , ccState = newCostCentreState
, countEntries = gopt Opt_ProfCountEntries dflags
, collectCCs = False -- See Note [Collecting late cost centres]
}
- let guts' = guts { mg_binds = fst (addLateCostCentres env (mg_binds guts))
+ let guts' = guts { mg_binds = fstOf3 (addLateCostCentres env (mg_binds guts))
}
return guts'
-addLateCostCentresPgm :: DynFlags -> Logger -> Module -> CoreProgram -> IO (CoreProgram, S.Set CostCentre)
+addLateCostCentresPgm :: DynFlags -> Logger -> Module -> CoreProgram -> IO (CoreProgram, S.Set CostCentre, CostCentreState)
addLateCostCentresPgm dflags logger mod binds =
withTiming logger
(text "LateCC"<+>brackets (ppr mod))
- (\(a,b) -> a `seqList` (b `seq` ())) $ do
+ (\(a,b,c) -> a `seqList` (b `seq` (c `seq` ()))) $ do
let env = Env
{ thisModule = mod
- , ccState = newCostCentreState
, countEntries = gopt Opt_ProfCountEntries dflags
, collectCCs = True -- See Note [Collecting late cost centres]
}
- (binds', ccs) = addLateCostCentres env binds
+ (binds', ccs, cc_state) = addLateCostCentres env binds
when (dopt Opt_D_dump_late_cc dflags || dopt Opt_D_verbose_core2core dflags) $
putDumpFileMaybe logger Opt_D_dump_late_cc "LateCC" FormatCore (vcat (map ppr binds'))
- return (binds', ccs)
+ return (binds', ccs, cc_state)
-addLateCostCentres :: Env -> CoreProgram -> (CoreProgram,S.Set CostCentre)
+addLateCostCentres :: Env -> CoreProgram -> (CoreProgram, S.Set CostCentre, CostCentreState)
addLateCostCentres env binds =
let (binds', state) = runState (mapM (doBind env) binds) initLateCCState
- in (binds',lcs_ccs state)
+ in (binds', lcs_ccs state, lcs_state state)
doBind :: Env -> CoreBind -> M CoreBind
@@ -161,7 +159,6 @@ addCC !env cc = do
data Env = Env
{ thisModule :: !Module
, countEntries:: !Bool
- , ccState :: !CostCentreState
, collectCCs :: !Bool
}
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -297,6 +297,7 @@ import GHC.StgToCmm.Utils (IPEStats)
import GHC.Types.Unique.FM
import GHC.Types.Unique.DFM
import GHC.Cmm.Config (CmmConfig)
+import GHC.Types.CostCentre.State (newCostCentreState)
{- **********************************************************************
@@ -1781,40 +1782,70 @@ hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath
-> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], Maybe StgCgInfos, Maybe CmmCgInfos )
-- ^ @Just f@ <=> _stub.c is f
hscGenHardCode hsc_env cgguts location output_filename = do
- let CgGuts{ -- This is the last use of the ModGuts in a compilation.
- -- From now on, we just use the bits we need.
- cg_module = this_mod,
+ let CgGuts{ cg_module = this_mod,
cg_binds = core_binds,
- cg_ccs = local_ccs,
- cg_tycons = tycons,
- cg_foreign = foreign_stubs0,
- cg_foreign_files = foreign_files,
- cg_dep_pkgs = dependencies,
- cg_hpc_info = hpc_info,
- cg_spt_entries = spt_entries
+ cg_ccs = local_ccs
} = cgguts
dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
- hooks = hsc_hooks hsc_env
- tmpfs = hsc_tmpfs hsc_env
- llvm_config = hsc_llvm_config hsc_env
- profile = targetProfile dflags
- data_tycons = filter isDataTyCon tycons
- -- cg_tycons includes newtypes, for the benefit of External Core,
- -- but we don't generate any code for newtypes
+
-------------------
-- Insert late cost centres if enabled.
-- If `-fprof-late-inline` is enabled we can skip this, as it will have added
-- a superset of cost centres we would add here already.
- (late_cc_binds, late_local_ccs) <-
+ (late_cc_binds, late_local_ccs, cc_state) <-
if gopt Opt_ProfLateCcs dflags && not (gopt Opt_ProfLateInlineCcs dflags)
- then {-# SCC lateCC #-} do
- (binds,late_ccs) <- addLateCostCentresPgm dflags logger this_mod core_binds
- return ( binds, (S.toList late_ccs `mappend` local_ccs ))
+ then
+ withTiming
+ logger
+ (text "LateCCs"<+>brackets (ppr this_mod))
+ (const ())
+ $ {-# SCC lateCC #-} do
+ (binds, late_ccs, cc_state) <- addLateCostCentresPgm dflags logger this_mod core_binds
+ return ( binds, (S.toList late_ccs `mappend` local_ccs ), cc_state)
else
- return (core_binds, local_ccs)
+ return (core_binds, local_ccs, newCostCentreState)
+
+ -------------------
+ -- Run late plugins
+ -- This is the last use of the ModGuts in a compilation.
+ -- From now on, we just use the bits we need.
+ ( CgGuts
+ { cg_tycons = tycons,
+ cg_foreign = foreign_stubs0,
+ cg_foreign_files = foreign_files,
+ cg_dep_pkgs = dependencies,
+ cg_hpc_info = hpc_info,
+ cg_spt_entries = spt_entries,
+ cg_binds = late_binds,
+ cg_ccs = late_local_ccs'
+ }
+ , _
+ ) <-
+ {-# SCC latePlugins #-}
+ withTiming
+ logger
+ (text "LatePlugins"<+>brackets (ppr this_mod))
+ (const ()) $
+ withPlugins (hsc_plugins hsc_env)
+ (($ hsc_env) . latePlugin)
+ ( cgguts
+ { cg_binds = late_cc_binds
+ , cg_ccs = late_local_ccs
+ }
+ , cc_state
+ )
+
+ let
+ hooks = hsc_hooks hsc_env
+ tmpfs = hsc_tmpfs hsc_env
+ llvm_config = hsc_llvm_config hsc_env
+ profile = targetProfile dflags
+ data_tycons = filter isDataTyCon tycons
+ -- cg_tycons includes newtypes, for the benefit of External Core,
+ -- but we don't generate any code for newtypes
@@ -1827,7 +1858,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do
(hsc_logger hsc_env)
cp_cfg
(initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC hsc_env))
- this_mod location late_cc_binds data_tycons
+ this_mod location late_binds data_tycons
----------------- Convert to STG ------------------
(stg_binds_with_deps, denv, (caf_ccs, caf_cc_stacks), stg_cg_infos)
@@ -1845,7 +1876,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do
let (stg_binds,_stg_deps) = unzip stg_binds_with_deps
let cost_centre_info =
- (late_local_ccs ++ caf_ccs, caf_cc_stacks)
+ (late_local_ccs' ++ caf_ccs, caf_cc_stacks)
platform = targetPlatform dflags
prof_init
| sccProfilingEnabled dflags = profilingInitCode platform this_mod cost_centre_info
=====================================
compiler/GHC/Driver/Plugins.hs
=====================================
@@ -58,6 +58,10 @@ module GHC.Driver.Plugins (
-- | hole fit plugins allow plugins to change the behavior of valid hole
-- fit suggestions
, HoleFitPluginR
+ -- ** Late plugins
+ -- | Late plugins can access and modify the core of a module after
+ -- optimizations have been applied and after interface creation.
+ , LatePlugin
-- * Internal
, PluginWithArgs(..), pluginsWithArgs, pluginRecompile'
@@ -89,8 +93,10 @@ import GHC.Core.Opt.Pipeline.Types ( CoreToDo )
import GHC.Hs
import GHC.Types.Error (Messages)
import GHC.Linker.Types
+import GHC.Types.CostCentre.State
import GHC.Types.Unique.DFM
+import GHC.Unit.Module.ModGuts (CgGuts)
import GHC.Utils.Fingerprint
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -157,6 +163,13 @@ data Plugin = Plugin {
--
-- @since 8.10.1
+ , latePlugin :: LatePlugin
+ -- ^ A plugin that runs after interface creation and after late cost centre
+ -- insertion. Useful for transformations that should not impact interfaces
+ -- or optimization at all.
+ --
+ -- @since 9.10.1
+
, pluginRecompile :: [CommandLineOption] -> IO PluginRecompile
-- ^ Specify how the plugin should affect recompilation.
, parsedResultAction :: [CommandLineOption] -> ModSummary
@@ -260,6 +273,7 @@ type CorePlugin = [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
type TcPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.TcPlugin
type DefaultingPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.DefaultingPlugin
type HoleFitPlugin = [CommandLineOption] -> Maybe HoleFitPluginR
+type LatePlugin = HscEnv -> [CommandLineOption] -> (CgGuts, CostCentreState) -> IO (CgGuts, CostCentreState)
purePlugin, impurePlugin, flagRecompile :: [CommandLineOption] -> IO PluginRecompile
purePlugin _args = return NoForceRecompile
@@ -280,6 +294,7 @@ defaultPlugin = Plugin {
, defaultingPlugin = const Nothing
, holeFitPlugin = const Nothing
, driverPlugin = const return
+ , latePlugin = \_ -> const return
, pluginRecompile = impurePlugin
, renamedResultAction = \_ env grp -> return (env, grp)
, parsedResultAction = \_ _ -> return
=====================================
compiler/ghc.cabal.in
=====================================
@@ -20,6 +20,11 @@ Description:
.
See <https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler>
for more information.
+ .
+ __This package is not PVP-compliant.__
+ .
+ This package directly exposes GHC internals, which can and do change with
+ every release.
Category: Development
Build-Type: Custom
=====================================
docs/users_guide/9.10.1-notes.rst
=====================================
@@ -126,6 +126,9 @@ Compiler
- The :ghc-flag:`-Wforall-identifier` flag is now deprecated and removed from :ghc-flag:`-Wdefault`,
as ``forall`` is no longer parsed as an identifier.
+- Late plugins have been added. These are plugins which can access and/or modify
+ the core of a module after optimization and after interface creation. See :ghc-ticket:`24254`.
+
GHCi
~~~~
=====================================
docs/users_guide/extending_ghc.rst
=====================================
@@ -510,6 +510,58 @@ in a module it compiles:
return bndr
printBind _ bndr = return bndr
+.. _late-plugins:
+
+Late Plugins
+^^^^^^^^^^^^
+
+If the ``CoreProgram`` of a module is modified in a normal core plugin, the
+modified bindings can end up in unfoldings the interface file for the module.
+This may be undesireable, as the plugin could make changes which affect inlining
+or optimization.
+
+Late plugins can be used to avoid introducing such changes into the interface
+file. Late plugins are a bit different from typical core plugins:
+
+1. They do not run in the ``CoreM`` monad. Instead, they are explicitly passed
+ the ``HscEnv`` and they run in ``IO``.
+2. They are given ``CgGuts`` instead of ``ModGuts``. ``CgGuts`` are a restricted
+ form of ``ModGuts`` intended for code generation. The ``CoreProgram`` held in
+ the ``CgGuts`` given to a late plugin will already be fully optimized.
+3. They must maintain a ``CostCentreState`` and track any cost centres they
+ introduce by adding them to the ``cg_ccs`` field of ``CgGuts``. This is
+ because the automatic collection of cost centres happens before the late
+ plugin stage. If a late plugin does not introduce any cost centres, it may
+ simply return the given cost centre state.
+
+Here is a very simply example of a late plugin that changes the value of a
+binding in a module. If it finds a non-recursive top-level binding named
+``testBinding`` with type ``Int``, it will change its value to the ``Int``
+expression ``111111``.
+
+::
+
+ plugin :: Plugin
+ plugin = defaultPlugin { latePlugin = lateP }
+
+ lateP :: LatePlugin
+ lateP _ _ (cg_guts, cc_state) = do
+ binds' <- editCoreBinding (cg_binds cg_guts)
+ return (cg_guts { cg_binds = binds' }, cc_state)
+
+ editCoreBinding :: CoreProgram -> IO CoreProgram
+ editCoreBinding pgm = pure . go
+ where
+ go :: [CoreBind] -> [CoreBind]
+ go (b@(NonRec v e) : bs)
+ | occNameString (getOccName v) == "testBinding" && exprType e `eqType` intTy =
+ NonRec v (mkUncheckedIntExpr 111111) : bs
+ go (b:bs) = b : go bs
+ go [] = []
+
+Since this is a late plugin, the changed binding value will not end up in the
+interface file.
+
.. _getting-annotations:
Using Annotations
=====================================
hadrian/src/Rules/Dependencies.hs
=====================================
@@ -24,16 +24,31 @@ import qualified Text.Parsec as Parsec
-- the dependency is implicit. ghc -M should emit this additional dependency but
-- until it does we need to add this dependency ourselves.
extra_dependencies :: M.Map Package (Stage -> Action [(FilePath, FilePath)])
-extra_dependencies =
- M.fromList [(containers, fmap (fmap concat . sequence) (sequence
- [dep (containers, "Data.IntSet.Internal") th_internal
- ,dep (containers, "Data.Set.Internal") th_internal
- ,dep (containers, "Data.Sequence.Internal") th_internal
- ,dep (containers, "Data.Graph") th_internal
- ]))
- ]
+extra_dependencies = M.fromList
+ [ deps containers th_internal
+ [ "Data.IntSet.Internal"
+ , "Data.Set.Internal"
+ , "Data.Sequence.Internal"
+ , "Data.Graph"
+ ]
+ , deps time th_internal
+ [ "Data.Time.Calendar.CalendarDiffDays"
+ , "Data.Time.Calendar.WeekDate"
+ , "Data.Time.Calendar.Quarter"
+ , "Data.Time.Calendar.Month"
+ , "Data.Time.Calendar.Week"
+ , "Data.Time.Calendar.Days"
+ , "Data.Time.Clock.Internal.UTCTime"
+ , "Data.Time.Clock.Internal.AbsoluteTime"
+ , "Data.Time.Clock.Internal.SystemTime"
+ , "Data.Time.Clock.Internal.DiffTime"
+ , "Data.Time.Clock.Internal.NominalDiffTime"
+ , "Data.Time.Clock.Internal.UniversalTime"
+ ]
+ ]
where
+ deps pkg to mods = (pkg, fmap (fmap concat . sequence) (sequence (map (\x -> dep (pkg, x) to) mods)))
th_internal = (templateHaskell, "Language.Haskell.TH.Lib.Internal")
dep (p1, m1) (p2, m2) s = do
let context = Context s p1 (error "extra_dependencies: way not set") (error "extra_dependencies: iplace not set")
=====================================
libraries/base/tests/all.T
=====================================
@@ -309,7 +309,7 @@ test('listThreads', normal, compile_and_run, [''])
test('listThreads1', omit_ghci, compile_and_run, [''])
test('inits1tails1', normal, compile_and_run, [''])
test('CLC149', normal, compile, [''])
-test('AtomicModifyIORef', normal, compile_and_run, [''])
+test('AtomicModifyIORef', js_fragile(24259), compile_and_run, [''])
test('AtomicSwapIORef', normal, compile_and_run, [''])
test('T23454', normal, compile_fail, [''])
test('T23687', normal, compile_and_run, [''])
=====================================
libraries/time
=====================================
@@ -1 +1 @@
-Subproject commit baab563ee2ce547f7b7f7e7069ed09db2d406941
+Subproject commit 97018e7574e561caa74060b115d530a004bd38db
=====================================
rts/js/time.js
=====================================
@@ -16,5 +16,3 @@ function h$clock_gettime(when, p_d, p_o) {
}
return 0;
}
-
-function h$CLOCK_REALTIME() { return 0; }
=====================================
testsuite/driver/testlib.py
=====================================
@@ -153,6 +153,13 @@ def js_broken( bug: IssueNumber ):
else:
return normal;
+# expect occasional failures for the JS backend
+def js_fragile( bug: IssueNumber ):
+ if js_arch():
+ return fragile(bug);
+ else:
+ return normal;
+
def expect_fail( name, opts ):
# The compiler, testdriver, OS or platform is missing a certain
# feature, and we don't plan to or can't fix it now or in the
=====================================
testsuite/tests/backpack/cabal/T20509/all.T
=====================================
@@ -1,6 +1,7 @@
test('T20509',
[extra_files(['p', 'q', 'T20509.cabal', 'Setup.hs'])
, run_timeout_multiplier(2)
+ , js_fragile(24259)
],
makefile_test,
[])
=====================================
testsuite/tests/backpack/cabal/bkpcabal02/all.T
=====================================
@@ -1,5 +1,6 @@
test('bkpcabal02',
[extra_files(['p', 'q', 'bkpcabal02.cabal', 'Setup.hs']),
- normalise_version('bkpcabal01')],
+ normalise_version('bkpcabal01'),
+ js_fragile(24259)],
makefile_test,
[])
=====================================
testsuite/tests/backpack/cabal/bkpcabal03/all.T
=====================================
@@ -1,4 +1,5 @@
test('bkpcabal03',
- [extra_files(['asig1', 'asig2', 'bkpcabal03.cabal.in1', 'bkpcabal03.cabal.in2', 'Setup.hs', 'Mod.hs'])],
+ [extra_files(['asig1', 'asig2', 'bkpcabal03.cabal.in1', 'bkpcabal03.cabal.in2', 'Setup.hs', 'Mod.hs']),
+ js_fragile(24259)],
makefile_test,
[])
=====================================
testsuite/tests/concurrent/should_run/all.T
=====================================
@@ -47,7 +47,7 @@ test('T3429', [ extra_run_opts('+RTS -C0.001 -RTS'),
# times out with ghci
test('T4030', omit_ghci, compile_and_run, ['-O'])
-test('throwto002', normal, compile_and_run, [''])
+test('throwto002', js_fragile(24259), compile_and_run, [''])
test('throwto003', normal, compile_and_run, [''])
test('mask001', normal, compile_and_run, [''])
=====================================
testsuite/tests/ghc-api/downsweep/all.T
=====================================
@@ -3,6 +3,7 @@ setTestOpts(when(arch('wasm32'), run_timeout_multiplier(2)))
test('PartialDownsweep',
[ extra_run_opts('"' + config.libdir + '"')
, ignore_stderr
+ , js_fragile(24259)
],
compile_and_run,
['-package ghc -package exceptions'])
=====================================
testsuite/tests/numeric/should_run/all.T
=====================================
@@ -79,6 +79,6 @@ test('IntegerToFloat', normal, compile_and_run, [''])
test('T20291', normal, compile_and_run, [''])
test('T22282', normal, compile_and_run, [''])
-test('T22671', normal, compile_and_run, [''])
-test('foundation', [when(js_arch(), run_timeout_multiplier(2))], compile_and_run, ['-O -package transformers'])
+test('T22671', js_fragile(24259), compile_and_run, [''])
+test('foundation', [when(js_arch(), run_timeout_multiplier(2)), js_fragile(24259)], compile_and_run, ['-O -package transformers'])
test('T24066', normal, compile_and_run, [''])
=====================================
testsuite/tests/plugins/Makefile
=====================================
@@ -224,3 +224,13 @@ plugins-external:
cp shared-plugin/pkg.plugins01/dist/build/$(call DLL,HSsimple-plugin*) $(call DLL,HSsimple-plugin)
"$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make -v0 -fplugin-library "$(PWD)/$(call DLL,HSsimple-plugin);simple-plugin-1234;Simple.Plugin;[\"Plugin\",\"loaded\",\"from\",\"a shared lib\"]" plugins-external.hs
./plugins-external
+
+# Runs a plugin that is both a core plugin and a late plugin, then makes sure
+# only the changes from the core plugin end up in the interface files.
+test-late-plugin:
+ "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) -O -package ghc $@.hs
+ SHOW_IFACE="$$($(TEST_HC) --show-iface $@.hi)" ; \
+ ContainsEarlyBinding=$$(echo $$SHOW_IFACE | grep -o 111111) ; \
+ ContainsLateBinding=$$(echo $$SHOW_IFACE | grep -o 222222) ; \
+ echo "$$ContainsLateBinding" ; \
+ [ "$$ContainsEarlyBinding" = "111111" ] && [ "$$ContainLateBinding" = "" ]
=====================================
testsuite/tests/plugins/all.T
=====================================
@@ -358,3 +358,8 @@ test('test-log-hooks-plugin',
pre_cmd('$MAKE -s --no-print-directory -C hooks-plugin package.test-log-hooks-plugin TOP={top}')],
compile_fail,
['-package-db hooks-plugin/pkg.test-log-hooks-plugin/local.package.conf -fplugin Hooks.LogPlugin -package hooks-plugin ' + config.plugin_way_flags])
+
+test('test-late-plugin',
+ [extra_files(['late-plugin/LatePlugin.hs']), ignore_stdout],
+ makefile_test,
+ [])
=====================================
testsuite/tests/plugins/late-plugin/LatePlugin.hs
=====================================
@@ -0,0 +1,50 @@
+module LatePlugin where
+
+import Data.Bool
+import GHC.Core
+import GHC.Core.TyCo.Compare
+import GHC.Driver.Monad
+import GHC.Plugins
+import GHC.Types.Avail
+import GHC.Types.Var
+import GHC.Types.Id
+import System.IO
+
+-- | Both a core plugin and a late plugin. The Core plugin edits the binding in
+-- the test file (testBinding) to be the integer "111111". The late plugin then
+-- edits the binding to be the integer "222222". Then we make sure the "222222"
+-- did not make it in the interface file and the "111111" did.
+plugin :: Plugin
+plugin =
+ defaultPlugin
+ { installCoreToDos = earlyP
+ , latePlugin = lateP
+ }
+
+earlyP :: CorePlugin
+earlyP _ todos = do
+ return
+ . (: todos)
+ $ CoreDoPluginPass "earlyP"
+ $ \mgs -> liftIO $ do
+ binds' <- editCoreBinding True (moduleName (mg_module mgs)) (mg_binds mgs)
+ return mgs { mg_binds = binds' }
+
+lateP :: LatePlugin
+lateP _ opts (cg_guts, cc_state) = do
+ binds' <- editCoreBinding False (moduleName (cg_module cg_guts)) (cg_binds cg_guts)
+ return (cg_guts { cg_binds = binds' }, cc_state)
+
+editCoreBinding :: Bool -> ModuleName -> CoreProgram -> IO CoreProgram
+editCoreBinding early modName pgm = do
+ putStrLn $
+ bool "late " "early " early ++ "plugin running on module " ++
+ moduleNameString modName
+ pure $ go pgm
+ where
+ go :: [CoreBind] -> [CoreBind]
+ go (b@(NonRec v e) : bs)
+ | occNameString (getOccName v) == "testBinding" && exprType e `eqType` intTy =
+ NonRec v (mkUncheckedIntExpr $ bool 222222 111111 early) : bs
+ go (b:bs) = b : go bs
+ go [] = []
=====================================
testsuite/tests/plugins/test-late-plugin.hs
=====================================
@@ -0,0 +1,15 @@
+{-# LANGUAGE MagicHash #-}
+{-# OPTIONS_GHC -fplugin=LatePlugin #-}
+
+module TestLatePlugin (testBinding) where
+
+import GHC.Exts
+
+-- This file is edited by a core plugin at the beginning of the core pipeline so
+-- that the value of testBinding becomes 111111. Then, a late plugin edits the
+-- binding to set testBinding to 222222. The test then checks that the early
+-- binding value is what makes it into the interface file, just to be sure that
+-- changes from late plugins do not end up in interface files.
+
+testBinding :: Int
+testBinding = -1
=====================================
testsuite/tests/rts/all.T
=====================================
@@ -302,6 +302,7 @@ test('T7919', [ when(fast(), skip)
, omit_ghci
, req_th
, when(platform('x86_64-unknown-linux'), fragile(22283))
+ , js_fragile(24259)
]
, compile_and_run, [config.ghc_th_way_flags])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/31360c805ea46423f3db0f7287bb2d4225f06d5b...72016b90d67e10b841fe89d635739274016c64b6
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/31360c805ea46423f3db0f7287bb2d4225f06d5b...72016b90d67e10b841fe89d635739274016c64b6
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/20231216/68710264/attachment-0001.html>
More information about the ghc-commits
mailing list