[Git][ghc/ghc][wip/pluginExtFields] 5 commits: hadrian: depend on boot compiler version #18001
Josh Meredith
gitlab at gitlab.haskell.org
Mon Aug 10 03:54:30 UTC 2020
Josh Meredith pushed to branch wip/pluginExtFields at Glasgow Haskell Compiler / GHC
Commits:
a11c9678 by Adam Sandberg Ericsson at 2020-08-09T11:32:25+02:00
hadrian: depend on boot compiler version #18001
- - - - -
c8873b52 by Alan Zimmerman at 2020-08-09T21:17:54-04:00
Api Annotations : Adjust SrcSpans for prefix bang (!).
And prefix ~
(cherry picked from commit 8dbee2c578b1f642d45561be3f416119863e01eb)
- - - - -
77398b67 by Sylvain Henry at 2020-08-09T21:18:34-04:00
Avoid allocations in `splitAtList` (#18535)
As suspected by @simonpj in #18535, avoiding allocations in
`GHC.Utils.Misc.splitAtList` when there are no leftover arguments is
beneficial for performance:
On CI validate-x86_64-linux-deb9-hadrian:
T12227 -7%
T12545 -12.3%
T5030 -10%
T9872a -2%
T9872b -2.1%
T9872c -2.5%
Metric Decrease:
T12227
T12545
T5030
T9872a
T9872b
T9872c
- - - - -
a74b1cf3 by Josh Meredith at 2020-08-09T23:54:28-04:00
Add machinery for plugins to write data to extensible interface fields
- - - - -
95eb22d7 by Josh Meredith at 2020-08-09T23:54:28-04:00
Add function to remove plugin interface fields
- - - - -
9 changed files:
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Types.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Utils/Misc.hs
- hadrian/src/Builder.hs
- testsuite/tests/ghc-api/annotations/Makefile
- testsuite/tests/ghc-api/annotations/T10358.stdout
Changes:
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -198,6 +198,7 @@ newHscEnv dflags = do
us <- mkSplitUniqSupply 'r'
nc_var <- newIORef (initNameCache us knownKeyNames)
fc_var <- newIORef emptyInstalledModuleEnv
+ ext_fs <- newIORef emptyExtensibleFields
emptyDynLinker <- uninitializedLinker
return HscEnv { hsc_dflags = dflags
, hsc_targets = []
@@ -207,6 +208,7 @@ newHscEnv dflags = do
, hsc_EPS = eps_var
, hsc_NC = nc_var
, hsc_FC = fc_var
+ , hsc_ext_fields = ext_fs
, hsc_type_env_var = Nothing
, hsc_interp = Nothing
, hsc_dynLinker = emptyDynLinker
@@ -810,11 +812,10 @@ finish summary tc_result mb_old_hash = do
(cg_guts, details) <- {-# SCC "CoreTidy" #-}
liftIO $ tidyProgram hsc_env simplified_guts
- let !partial_iface =
- {-# SCC "GHC.Driver.Main.mkPartialIface" #-}
+ !partial_iface <- {-# SCC "GHC.Driver.Main.mkPartialIface" #-}
-- This `force` saves 2M residency in test T10370
-- See Note [Avoiding space leaks in toIface*] for details.
- force (mkPartialIface hsc_env details simplified_guts)
+ liftIO $ force <$> (mkPartialIface hsc_env details simplified_guts)
return HscRecomp { hscs_guts = cg_guts,
hscs_mod_location = ms_location summary,
=====================================
compiler/GHC/Driver/Types.hs
=====================================
@@ -155,6 +155,8 @@ module GHC.Driver.Types (
readField, readIfaceField, readIfaceFieldWith,
writeField, writeIfaceField, writeIfaceFieldWith,
deleteField, deleteIfaceField,
+ registerInterfaceData, registerInterfaceDataWith,
+ unregisterInterfaceData,
) where
#include "HsVersions.h"
@@ -475,6 +477,10 @@ data HscEnv
hsc_FC :: {-# UNPACK #-} !(IORef FinderCache),
-- ^ The cached result of performing finding in the file system
+ hsc_ext_fields :: {-# UNPACK #-} !(IORef ExtensibleFields),
+ -- ^ Extensible interface field data stored by plugins to be later
+ -- output in the `.hi` file.
+
hsc_type_env_var :: Maybe (Module, IORef TypeEnv)
-- ^ Used for one-shot compilation only, to initialise
-- the 'IfGblEnv'. See 'GHC.Tc.Utils.tcg_type_env_var' for
@@ -3404,3 +3410,17 @@ deleteField name (ExtensibleFields fs) = ExtensibleFields $ Map.delete name fs
deleteIfaceField :: FieldName -> ModIface -> ModIface
deleteIfaceField name iface = iface { mi_ext_fields = deleteField name (mi_ext_fields iface) }
+
+registerInterfaceData :: Binary a => FieldName -> HscEnv -> a -> IO ()
+registerInterfaceData name env x = registerInterfaceDataWith name env (`put_` x)
+
+registerInterfaceDataWith :: FieldName -> HscEnv -> (BinHandle -> IO ()) -> IO ()
+registerInterfaceDataWith name env write = do
+ ext_fs <- readIORef (hsc_ext_fields env)
+ ext_fs' <- writeFieldWith name write ext_fs
+ writeIORef (hsc_ext_fields env) ext_fs'
+
+unregisterInterfaceData :: FieldName -> HscEnv -> IO ()
+unregisterInterfaceData name env = do
+ ext_fs <- readIORef (hsc_ext_fields env)
+ writeIORef (hsc_ext_fields env) (deleteField name ext_fs)
=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -82,7 +82,7 @@ import GHC.Driver.Plugins (LoadedPlugin(..))
mkPartialIface :: HscEnv
-> ModDetails
-> ModGuts
- -> PartialModIface
+ -> IO PartialModIface
mkPartialIface hsc_env mod_details
ModGuts{ mg_module = this_mod
, mg_hsc_src = hsc_src
@@ -99,8 +99,11 @@ mkPartialIface hsc_env mod_details
, mg_decl_docs = decl_docs
, mg_arg_docs = arg_docs
}
- = mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust
- safe_mode usages doc_hdr decl_docs arg_docs mod_details
+ = do ext_fs <- readIORef $ hsc_ext_fields hsc_env
+ return iface{mi_ext_fields = ext_fs}
+ where
+ iface = mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust
+ safe_mode usages doc_hdr decl_docs arg_docs mod_details
-- | Fully instantiate an interface. Adds fingerprints and potentially code
-- generator produced information.
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -20,7 +20,9 @@ module GHC.IfaceToCore (
tcIfaceAnnotations, tcIfaceCompleteSigs,
tcIfaceExpr, -- Desired by HERMIT (#7683)
tcIfaceGlobal,
- tcIfaceOneShot
+ tcIfaceOneShot,
+ tcIfaceType,
+ tcJoinInfo,
) where
#include "HsVersions.h"
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -1201,13 +1201,14 @@ makeFunBind fn ms
checkPatBind :: LPat GhcPs
-> Located (a,GRHSs GhcPs (LHsExpr GhcPs))
-> P ([AddAnn],HsBind GhcPs)
-checkPatBind lhs (L match_span (_,grhss))
+checkPatBind lhs (L rhs_span (_,grhss))
| BangPat _ p <- unLoc lhs
, VarPat _ v <- unLoc p
= return ([], makeFunBind v [L match_span (m v)])
where
+ match_span = combineSrcSpans (getLoc lhs) rhs_span
m v = Match { m_ext = noExtField
- , m_ctxt = FunRhs { mc_fun = L (getLoc lhs) (unLoc v)
+ , m_ctxt = FunRhs { mc_fun = v
, mc_fixity = Prefix
, mc_strictness = SrcStrict }
, m_pats = []
=====================================
compiler/GHC/Utils/Misc.hs
=====================================
@@ -774,12 +774,15 @@ dropList _ xs@[] = xs
dropList (_:xs) (_:ys) = dropList xs ys
+-- | Given two lists xs=x0..xn and ys=y0..ym, return `splitAt n ys`.
splitAtList :: [b] -> [a] -> ([a], [a])
-splitAtList [] xs = ([], xs)
-splitAtList _ xs@[] = (xs, xs)
-splitAtList (_:xs) (y:ys) = (y:ys', ys'')
- where
- (ys', ys'') = splitAtList xs ys
+splitAtList xs ys = go 0 xs ys
+ where
+ -- we are careful to avoid allocating when there are no leftover
+ -- arguments: in this case we can return "ys" directly (cf #18535)
+ go _ _ [] = (ys, []) -- len(ys) <= len(xs)
+ go n [] bs = (take n ys, bs) -- = splitAt n ys
+ go n (_:as) (_:bs) = go (n+1) as bs
-- drop from the end of a list
dropTail :: Int -> [a] -> [a]
=====================================
hadrian/src/Builder.hs
=====================================
@@ -30,6 +30,7 @@ import Hadrian.Utilities
import Base
import Context
import Oracles.Flag
+import Oracles.Setting (setting, Setting(..))
import Packages
-- | C compiler can be used in two different modes:
@@ -180,7 +181,11 @@ instance H.Builder Builder where
Autoreconf dir -> return [dir -/- "configure.ac"]
Configure dir -> return [dir -/- "configure"]
- Ghc _ Stage0 -> includesDependencies Stage0
+ Ghc _ Stage0 -> do
+ -- Read the boot GHC version here to make sure we rebuild when it
+ -- changes (#18001).
+ _bootGhcVersion <- setting GhcVersion
+ includesDependencies Stage0
Ghc _ stage -> do
root <- buildRoot
touchyPath <- programPath (vanillaContext Stage0 touchy)
=====================================
testsuite/tests/ghc-api/annotations/Makefile
=====================================
@@ -39,7 +39,8 @@ listcomps:
.PHONY: T10358
T10358:
- $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10358.hs
+ # Ignore result code, we have an unattached (superfluous) AnnBang
+ - $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test10358.hs
.PHONY: T10396
T10396:
=====================================
testsuite/tests/ghc-api/annotations/T10358.stdout
=====================================
@@ -1,5 +1,5 @@
---Unattached Annotation Problems (should be empty list)---
-[]
+[(AnnBang, Test10358.hs:5:19)]
---Ann before enclosing span problem (should be empty list)---
[
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1a68c2a3db5dbd89431474a9ded0f47050eb5410...95eb22d7fdfacf5dd6d7271368decde2c89f4d19
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1a68c2a3db5dbd89431474a9ded0f47050eb5410...95eb22d7fdfacf5dd6d7271368decde2c89f4d19
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/20200809/25bb9894/attachment-0001.html>
More information about the ghc-commits
mailing list