[Git][ghc/ghc][wip/mpickering-hannes] 6 commits: Fix iface sharing
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Sat Mar 23 15:33:29 UTC 2024
Matthew Pickering pushed to branch wip/mpickering-hannes at Glasgow Haskell Compiler / GHC
Commits:
976e9697 by Matthew Pickering at 2024-03-21T14:11:59+00:00
Fix iface sharing
- - - - -
4cee1644 by Matthew Pickering at 2024-03-23T11:58:13+00:00
Wip:mp
- - - - -
e5238b19 by Fendor at 2024-03-23T11:58:27+00:00
Migrate Finder to OsPath
- - - - -
a02da988 by Matthew Pickering at 2024-03-23T15:09:56+00:00
Delay deserialising IfaceExpr
- - - - -
3d7910e5 by Matthew Pickering at 2024-03-23T15:11:36+00:00
lazyPutMaybe mi_extra_decls
This seems like an oversight in the original patch to me.
- - - - -
98269144 by Matthew Pickering at 2024-03-23T15:32:59+00:00
Missing nfdata
- - - - -
26 changed files:
- compiler/GHC.hs
- compiler/GHC/Data/Strict.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Driver/Config/Finder.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/MakeFile.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/Iface/Errors.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Recomp/Binary.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Finder/Types.hs
- compiler/GHC/Unit/Module/Location.hs
- compiler/GHC/Unit/Module/ModIface.hs
- compiler/GHC/Utils/Binary.hs
- ghc/GHCi/UI.hs
- ghc/ghc-bin.cabal.in
- hadrian/src/Settings/Packages.hs
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -76,6 +76,12 @@ module GHC (
ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries,
mgLookupModule,
ModSummary(..), ms_mod_name, ModLocation(..),
+ ml_hs_file,
+ ml_hi_file,
+ ml_dyn_hi_file,
+ ml_obj_file,
+ ml_dyn_obj_file,
+ ml_hie_file,
getModSummary,
getModuleGraph,
isLoaded,
=====================================
compiler/GHC/Data/Strict.hs
=====================================
@@ -9,8 +9,11 @@
module GHC.Data.Strict (
Maybe(Nothing, Just),
fromMaybe,
+ GHC.Data.Strict.maybe,
Pair(And),
-
+ expectJust,
+ fromLazy,
+ toLazy,
-- Not used at the moment:
--
-- Either(Left, Right),
@@ -18,9 +21,12 @@ module GHC.Data.Strict (
) where
import GHC.Prelude hiding (Maybe(..), Either(..))
+import GHC.Stack.Types
+
import Control.Applicative
import Data.Semigroup
import Data.Data
+import qualified Data.Maybe as Lazy
data Maybe a = Nothing | Just !a
deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Data)
@@ -29,6 +35,10 @@ fromMaybe :: a -> Maybe a -> a
fromMaybe d Nothing = d
fromMaybe _ (Just x) = x
+maybe :: b -> (a -> b) -> Maybe a -> b
+maybe d _ Nothing = d
+maybe _ f (Just x) = f x
+
apMaybe :: Maybe (a -> b) -> Maybe a -> Maybe b
apMaybe (Just f) (Just x) = Just (f x)
apMaybe _ _ = Nothing
@@ -37,6 +47,19 @@ altMaybe :: Maybe a -> Maybe a -> Maybe a
altMaybe Nothing r = r
altMaybe l _ = l
+fromLazy :: Lazy.Maybe a -> Maybe a
+fromLazy (Lazy.Just a) = Just a
+fromLazy Lazy.Nothing = Nothing
+
+toLazy :: Maybe a -> Lazy.Maybe a
+toLazy (Just a) = Lazy.Just a
+toLazy Nothing = Lazy.Nothing
+
+expectJust :: HasCallStack => String -> Maybe a -> a
+{-# INLINE expectJust #-}
+expectJust _ (Just x) = x
+expectJust err Nothing = error ("expectJust " ++ err)
+
instance Semigroup a => Semigroup (Maybe a) where
Nothing <> b = b
a <> Nothing = a
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -772,7 +772,7 @@ summariseRequirement pn mod_name = do
let PackageName pn_fs = pn
let location = mkHomeModLocation2 fopts mod_name
- (unpackFS pn_fs </> moduleNameSlashes mod_name) "hsig"
+ (unsafeEncodeUtf $ unpackFS pn_fs </> moduleNameSlashes mod_name) (unsafeEncodeUtf "hsig")
env <- getBkpEnv
src_hash <- liftIO $ getFileHash (bkp_filename env)
@@ -855,12 +855,12 @@ hsModuleToModSummary home_keys pn hsc_src modname
-- these filenames to figure out where the hi files go.
-- A travesty!
let location0 = mkHomeModLocation2 fopts modname
- (unpackFS unit_fs </>
+ (unsafeEncodeUtf $ unpackFS unit_fs </>
moduleNameSlashes modname)
(case hsc_src of
- HsigFile -> "hsig"
- HsBootFile -> "hs-boot"
- HsSrcFile -> "hs")
+ HsigFile -> unsafeEncodeUtf "hsig"
+ HsBootFile -> unsafeEncodeUtf "hs-boot"
+ HsSrcFile -> unsafeEncodeUtf "hs")
-- DANGEROUS: bootifying can POISON the module finder cache
let location = case hsc_src of
HsBootFile -> addBootSuffixLocnOut location0
=====================================
compiler/GHC/Driver/CodeOutput.hs
=====================================
@@ -259,7 +259,7 @@ outputForeignStubs
Maybe FilePath) -- C file created
outputForeignStubs logger tmpfs dflags unit_state mod location stubs
= do
- let stub_h = mkStubPaths (initFinderOpts dflags) (moduleName mod) location
+ let stub_h = unsafeDecodeUtf $ mkStubPaths (initFinderOpts dflags) (moduleName mod) location
stub_c <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c"
case stubs of
=====================================
compiler/GHC/Driver/Config/Finder.hs
=====================================
@@ -5,30 +5,32 @@ module GHC.Driver.Config.Finder (
import GHC.Prelude
+import qualified GHC.Data.Strict as Strict
import GHC.Driver.DynFlags
import GHC.Unit.Finder.Types
import GHC.Data.FastString
-
+-- TODO: this must not be here, replace with 'GHC.Data.OsPath'
+import GHC.Unit.Module.Location
-- | Create a new 'FinderOpts' from DynFlags.
initFinderOpts :: DynFlags -> FinderOpts
initFinderOpts flags = FinderOpts
- { finder_importPaths = importPaths flags
+ { finder_importPaths = fmap unsafeEncodeUtf $ importPaths flags
, finder_lookupHomeInterfaces = isOneShot (ghcMode flags)
, finder_bypassHiFileCheck = MkDepend == (ghcMode flags)
, finder_ways = ways flags
, finder_enableSuggestions = gopt Opt_HelpfulErrors flags
- , finder_workingDirectory = workingDirectory flags
+ , finder_workingDirectory = fmap unsafeEncodeUtf $ Strict.fromLazy $ workingDirectory flags
, finder_thisPackageName = mkFastString <$> thisPackageName flags
, finder_hiddenModules = hiddenModules flags
, finder_reexportedModules = reexportedModules flags
- , finder_hieDir = hieDir flags
- , finder_hieSuf = hieSuf flags
- , finder_hiDir = hiDir flags
- , finder_hiSuf = hiSuf_ flags
- , finder_dynHiSuf = dynHiSuf_ flags
- , finder_objectDir = objectDir flags
- , finder_objectSuf = objectSuf_ flags
- , finder_dynObjectSuf = dynObjectSuf_ flags
- , finder_stubDir = stubDir flags
+ , finder_hieDir = fmap unsafeEncodeUtf $ Strict.fromLazy $ hieDir flags
+ , finder_hieSuf = unsafeEncodeUtf $ hieSuf flags
+ , finder_hiDir = fmap unsafeEncodeUtf $ Strict.fromLazy $ hiDir flags
+ , finder_hiSuf = unsafeEncodeUtf $ hiSuf_ flags
+ , finder_dynHiSuf = unsafeEncodeUtf $ dynHiSuf_ flags
+ , finder_objectDir = fmap unsafeEncodeUtf $ Strict.fromLazy $ objectDir flags
+ , finder_objectSuf = unsafeEncodeUtf $ objectSuf_ flags
+ , finder_dynObjectSuf = unsafeEncodeUtf $ dynObjectSuf_ flags
+ , finder_stubDir = fmap unsafeEncodeUtf $ Strict.fromLazy $ stubDir flags
}
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -262,6 +262,7 @@ import qualified GHC.LanguageExtensions as LangExt
import GHC.Data.FastString
import GHC.Data.Bag
+import qualified GHC.Data.Strict as Strict
import GHC.Data.StringBuffer
import qualified GHC.Data.Stream as Stream
import GHC.Data.Stream (Stream)
@@ -286,6 +287,7 @@ import Data.List.NonEmpty (NonEmpty ((:|)))
import GHC.Unit.Module.WholeCoreBindings
import GHC.Types.TypeEnv
import System.IO
+import System.OsPath (OsPath)
import {-# SOURCE #-} GHC.Driver.Pipeline
import Data.Time
@@ -541,9 +543,9 @@ hscParse' mod_summary
$ filter (not . isPrefixOf "<")
$ map unpackFS
$ srcfiles pst
- srcs1 = case ml_hs_file (ms_location mod_summary) of
- Just f -> filter (/= FilePath.normalise f) srcs0
- Nothing -> srcs0
+ srcs1 = case ml_hs_file_ (ms_location mod_summary) of
+ Strict.Just f -> filter (/= FilePath.normalise (unsafeDecodeUtf f)) srcs0
+ Strict.Nothing -> srcs0
-- sometimes we see source files from earlier
-- preprocessing stages that cannot be found, so just
@@ -964,25 +966,13 @@ loadByteCode iface mod_sum = do
-- Compilers
--------------------------------------------------------------
-shareIface :: NameCache -> ModIface -> IO ModIface
-shareIface nc mi = do
- bh <- openBinMem (1024 * 1024)
- -- Todo, not quite right (See ext fields etc)
- start <- tellBin @() bh
- putWithUserData QuietBinIFace bh mi
- seekBin bh start
- res <- getWithUserData nc bh
- let resiface = res { mi_src_hash = mi_src_hash mi }
- forceModIface resiface
- return resiface
-- Knot tying! See Note [Knot-tying typecheckIface]
-- See Note [ModDetails and --make mode]
-initModDetails :: HscEnv -> ModIface -> IO (ModIface, ModDetails)
-initModDetails hsc_env raw_iface = do
- iface <- shareIface (hsc_NC hsc_env) raw_iface
- d <- fixIO $ \details' -> do
+initModDetails :: HscEnv -> ModIface -> IO ModDetails
+initModDetails hsc_env iface = do
+ fixIO $ \details' -> do
let act hpt = addToHpt hpt (moduleName $ mi_module iface)
(HomeModInfo iface details' emptyHomeModInfoLinkable)
let !hsc_env' = hscUpdateHPT act hsc_env
@@ -991,7 +981,6 @@ initModDetails hsc_env raw_iface = do
-- any further typechecking. It's much more useful
-- in make mode, since this HMI will go into the HPT.
genModDetails hsc_env' iface
- return (iface, d)
-- Hydrate any WholeCoreBindings linkables into BCOs
initWholeCoreBindings :: HscEnv -> ModIface -> ModDetails -> Linkable -> IO Linkable
@@ -2100,12 +2089,12 @@ hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hs
rawCmms
return stub_c_exists
where
- no_loc = ModLocation{ ml_hs_file = Just original_filename,
- ml_hi_file = panic "hscCompileCmmFile: no hi file",
- ml_obj_file = panic "hscCompileCmmFile: no obj file",
- ml_dyn_obj_file = panic "hscCompileCmmFile: no dyn obj file",
- ml_dyn_hi_file = panic "hscCompileCmmFile: no dyn obj file",
- ml_hie_file = panic "hscCompileCmmFile: no hie file"}
+ no_loc = ModLocation{ ml_hs_file_ = Strict.Just $ unsafeEncodeUtf original_filename,
+ ml_hi_file_ = panic "hscCompileCmmFile: no hi file",
+ ml_obj_file_ = panic "hscCompileCmmFile: no obj file",
+ ml_dyn_obj_file_ = panic "hscCompileCmmFile: no dyn obj file",
+ ml_dyn_hi_file_ = panic "hscCompileCmmFile: no dyn obj file",
+ ml_hie_file_ = panic "hscCompileCmmFile: no hie file"}
-------------------- Stuff for new code gen ---------------------
@@ -2340,12 +2329,12 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
{- Desugar it -}
-- We use a basically null location for iNTERACTIVE
- let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing,
- ml_hi_file = panic "hsDeclsWithLocation:ml_hi_file",
- ml_obj_file = panic "hsDeclsWithLocation:ml_obj_file",
- ml_dyn_obj_file = panic "hsDeclsWithLocation:ml_dyn_obj_file",
- ml_dyn_hi_file = panic "hsDeclsWithLocation:ml_dyn_hi_file",
- ml_hie_file = panic "hsDeclsWithLocation:ml_hie_file" }
+ let iNTERACTIVELoc = ModLocation{ ml_hs_file_ = Strict.Nothing,
+ ml_hi_file_ = panic "hsDeclsWithLocation:ml_hi_file",
+ ml_obj_file_ = panic "hsDeclsWithLocation:ml_obj_file",
+ ml_dyn_obj_file_ = panic "hsDeclsWithLocation:ml_dyn_obj_file",
+ ml_dyn_hi_file_ = panic "hsDeclsWithLocation:ml_dyn_hi_file",
+ ml_hie_file_ = panic "hsDeclsWithLocation:ml_hie_file" }
ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv
{- Simplify -}
@@ -2624,12 +2613,12 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr = do
{- Lint if necessary -}
lintInteractiveExpr (text "hscCompileCoreExpr") hsc_env prepd_expr
- let this_loc = ModLocation{ ml_hs_file = Nothing,
- ml_hi_file = panic "hscCompileCoreExpr':ml_hi_file",
- ml_obj_file = panic "hscCompileCoreExpr':ml_obj_file",
- ml_dyn_obj_file = panic "hscCompileCoreExpr': ml_obj_file",
- ml_dyn_hi_file = panic "hscCompileCoreExpr': ml_dyn_hi_file",
- ml_hie_file = panic "hscCompileCoreExpr':ml_hie_file" }
+ let this_loc = ModLocation{ ml_hs_file_ = Strict.Nothing,
+ ml_hi_file_ = panic "hscCompileCoreExpr':ml_hi_file",
+ ml_obj_file_ = panic "hscCompileCoreExpr':ml_obj_file",
+ ml_dyn_obj_file_ = panic "hscCompileCoreExpr': ml_obj_file",
+ ml_dyn_hi_file_ = panic "hscCompileCoreExpr': ml_dyn_hi_file",
+ ml_hie_file_ = panic "hscCompileCoreExpr':ml_hie_file" }
-- Ensure module uniqueness by giving it a name like "GhciNNNN".
-- This uniqueness is needed by the JS linker. Without it we break the 1-1
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -72,6 +72,7 @@ import GHC.Iface.Load ( cannotFindModule )
import GHC.IfaceToCore ( typecheckIface )
import GHC.Iface.Recomp ( RecompileRequired(..), CompileReason(..) )
+import qualified GHC.Data.Strict as Strict
import GHC.Data.Bag ( listToBag )
import GHC.Data.Graph.Directed
import GHC.Data.FastString
@@ -336,12 +337,15 @@ warnMissingHomeModules dflags targets mod_graph =
-> moduleName (ms_mod mod) == name
&& tuid == ms_unitid mod
TargetFile target_file _
- | Just mod_file <- ml_hs_file (ms_location mod)
+ | Strict.Just mod_file <- ml_hs_file_ (ms_location mod)
->
- augmentByWorkingDirectory dflags target_file == mod_file ||
+ let
+ target_os_file = unsafeEncodeUtf target_file
+ in
+ augmentByWorkingDirectory dflags target_file == unsafeDecodeUtf mod_file ||
-- Don't warn on B.hs-boot if B.hs is specified (#16551)
- addBootSuffix target_file == mod_file ||
+ addBootSuffix target_os_file == mod_file ||
-- We can get a file target even if a module name was
-- originally specified in a command line because it can
@@ -1830,7 +1834,7 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph =
tn <- newTempName logger tmpfs (tmpDir dflags) staticLife suf
let dyn_tn = tn -<.> dynsuf
addFilesToClean tmpfs dynLife [dyn_tn]
- return (tn, dyn_tn)
+ return (unsafeEncodeUtf tn, unsafeEncodeUtf dyn_tn)
-- We don't want to create .o or .hi files unless we have been asked
-- to by the user. But we need them, so we patch their locations in
-- the ModSummary with temporary files.
@@ -1839,8 +1843,8 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph =
-- If ``-fwrite-interface` is specified, then the .o and .hi files
-- are written into `-odir` and `-hidir` respectively. #16670
if gopt Opt_WriteInterface dflags
- then return ((ml_hi_file ms_location, ml_dyn_hi_file ms_location)
- , (ml_obj_file ms_location, ml_dyn_obj_file ms_location))
+ then return ((ml_hi_file_ ms_location, ml_dyn_hi_file_ ms_location)
+ , (ml_obj_file_ ms_location, ml_dyn_obj_file_ ms_location))
else (,) <$> (new_temp_file (hiSuf_ dflags) (dynHiSuf_ dflags))
<*> (new_temp_file (objectSuf_ dflags) (dynObjectSuf_ dflags))
let new_dflags = case enable_spec of
@@ -1849,10 +1853,10 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph =
EnableByteCodeAndObject -> (gopt_set dflags Opt_ByteCodeAndObjectCode) { backend = defaultBackendOf ms}
let ms' = ms
{ ms_location =
- ms_location { ml_hi_file = hi_file
- , ml_obj_file = o_file
- , ml_dyn_hi_file = dyn_hi_file
- , ml_dyn_obj_file = dyn_o_file }
+ ms_location { ml_hi_file_ = hi_file
+ , ml_obj_file_ = o_file
+ , ml_dyn_hi_file_ = dyn_hi_file
+ , ml_dyn_obj_file_ = dyn_o_file }
, ms_hspp_opts = updOptLevel 0 $ new_dflags
}
-- Recursive call to catch the other cases
@@ -2037,7 +2041,7 @@ summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf
let fopts = initFinderOpts (hsc_dflags hsc_env)
-- Make a ModLocation for this file
- let location = mkHomeModLocation fopts pi_mod_name src_fn
+ let location = mkHomeModLocation fopts pi_mod_name (unsafeEncodeUtf src_fn)
-- Tell the Finder cache where it is, so that subsequent calls
-- to findModule will find it, even if it's not on any search path
=====================================
compiler/GHC/Driver/MakeFile.hs
=====================================
@@ -297,7 +297,7 @@ findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do
Found loc _
-- Home package: just depend on the .hi or hi-boot file
| isJust (ml_hs_file loc) || include_pkg_deps
- -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc)))
+ -> return (Just (unsafeDecodeUtf $ addBootSuffix_maybe is_boot (ml_hi_file_ loc)))
-- Not in this package: we don't need a dependency
| otherwise
=====================================
compiler/GHC/Driver/Pipeline.hs
=====================================
@@ -244,9 +244,9 @@ compileOne' mHscMessage
let pipeline = hscPipeline pipe_env (setDumpPrefix pipe_env plugin_hsc_env, upd_summary, status)
(iface, linkable) <- runPipeline (hsc_hooks plugin_hsc_env) pipeline
-- See Note [ModDetails and --make mode]
- (shared_iface, details) <- initModDetails plugin_hsc_env iface
- linkable' <- traverse (initWholeCoreBindings plugin_hsc_env shared_iface details) (homeMod_bytecode linkable)
- return $! HomeModInfo shared_iface details (linkable { homeMod_bytecode = linkable' })
+ details <- initModDetails plugin_hsc_env iface
+ linkable' <- traverse (initWholeCoreBindings plugin_hsc_env iface details) (homeMod_bytecode linkable)
+ return $! HomeModInfo iface details (linkable { homeMod_bytecode = linkable' })
where lcl_dflags = ms_hspp_opts summary
location = ms_location summary
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -759,7 +759,7 @@ mkOneShotModLocation :: PipeEnv -> DynFlags -> HscSource -> ModuleName -> IO Mod
mkOneShotModLocation pipe_env dflags src_flavour mod_name = do
let PipeEnv{ src_basename=basename,
src_suffix=suff } = pipe_env
- let location1 = mkHomeModLocation2 fopts mod_name basename suff
+ let location1 = mkHomeModLocation2 fopts mod_name (unsafeEncodeUtf basename) (unsafeEncodeUtf suff)
-- Boot-ify it if necessary
let location2
@@ -771,11 +771,11 @@ mkOneShotModLocation pipe_env dflags src_flavour mod_name = do
-- This can't be done in mkHomeModuleLocation because
-- it only applies to the module being compiles
let ohi = outputHi dflags
- location3 | Just fn <- ohi = location2{ ml_hi_file = fn }
+ location3 | Just fn <- ohi = location2{ ml_hi_file_ = unsafeEncodeUtf fn }
| otherwise = location2
let dynohi = dynOutputHi dflags
- location4 | Just fn <- dynohi = location3{ ml_dyn_hi_file = fn }
+ location4 | Just fn <- dynohi = location3{ ml_dyn_hi_file_ = unsafeEncodeUtf fn }
| otherwise = location3
-- Take -o into account if present
@@ -789,10 +789,10 @@ mkOneShotModLocation pipe_env dflags src_flavour mod_name = do
location5 | Just ofile <- expl_o_file
, let dyn_ofile = fromMaybe (ofile -<.> dynObjectSuf_ dflags) expl_dyn_o_file
, isNoLink (ghcLink dflags)
- = location4 { ml_obj_file = ofile
- , ml_dyn_obj_file = dyn_ofile }
+ = location4 { ml_obj_file_ = unsafeEncodeUtf ofile
+ , ml_dyn_obj_file_ = unsafeEncodeUtf dyn_ofile }
| Just dyn_ofile <- expl_dyn_o_file
- = location4 { ml_dyn_obj_file = dyn_ofile }
+ = location4 { ml_dyn_obj_file_ = unsafeEncodeUtf dyn_ofile }
| otherwise = location4
return location5
where
=====================================
compiler/GHC/Iface/Binary.hs
=====================================
@@ -338,14 +338,15 @@ initReadIfaceTyConTable :: HasCallStack => IO (ReadIfaceTable (SymbolTable Iface
initReadIfaceTyConTable = do
pure $
ReadIfaceTable
- { getTable = getGenericSymbolTable getIfaceTyCon
+ { getTable = getGenericSymbolTable (\_ -> getIfaceTyCon)
}
initReadIfaceTypeTable :: HasCallStack => IO (ReadIfaceTable (SymbolTable IfaceType))
initReadIfaceTypeTable = do
pure $
ReadIfaceTable
- { getTable = getGenericSymbolTable getIfaceType
+ { getTable = getGenericSymbolTable (\optr bh -> IfaceSerialisedType <$> freezeBinHandle optr bh)
+
}
=====================================
compiler/GHC/Iface/Errors.hs
=====================================
@@ -55,13 +55,13 @@ cantFindInstalledErr unit_state mhome_unit profile mod_name find_result
InstalledNotFound files mb_pkg
| Just pkg <- mb_pkg
, notHomeUnitId mhome_unit pkg
- -> not_found_in_package pkg files
+ -> not_found_in_package pkg $ fmap unsafeDecodeUtf files
| null files
-> NotAModule
| otherwise
- -> CouldntFindInFiles files
+ -> CouldntFindInFiles $ fmap unsafeDecodeUtf files
_ -> panic "cantFindInstalledErr"
=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -69,10 +69,13 @@ import GHC.Types.HpcInfo
import GHC.Types.CompleteMatch
import GHC.Types.SourceText
import GHC.Types.SrcLoc ( unLoc )
+import GHC.Types.Name.Cache
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Logger
+import GHC.Utils.Binary
+import GHC.Iface.Binary
import GHC.Data.FastString
import GHC.Data.Maybe
@@ -147,8 +150,21 @@ mkFullIface hsc_env partial_iface mb_stg_infos mb_cmm_infos = do
let unit_state = hsc_units hsc_env
putDumpFileMaybe (hsc_logger hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText
(pprModIface unit_state full_iface)
+ final_iface <- shareIface (hsc_NC hsc_env) full_iface
+ return final_iface
+
+shareIface :: NameCache -> ModIface -> IO ModIface
+shareIface nc mi = do
+ bh <- openBinMem (1024 * 1024)
+ -- Todo, not quite right (See ext fields etc)
+ start <- tellBin @() bh
+ putWithUserData QuietBinIFace bh mi
+ seekBin bh start
+ res <- getWithUserData nc bh
+ let resiface = res { mi_src_hash = mi_src_hash mi }
+ forceModIface resiface
+ return resiface
- return full_iface
updateDecl :: [IfaceDecl] -> Maybe StgCgInfos -> Maybe CmmCgInfos -> [IfaceDecl]
updateDecl decls Nothing Nothing = decls
@@ -240,6 +256,7 @@ mkIfaceTc hsc_env safe_mode mod_details mod_summary mb_program
mkFullIface hsc_env partial_iface Nothing Nothing
+
mkIface_ :: HscEnv -> Module -> CoreProgram -> HscSource
-> Bool -> Dependencies -> GlobalRdrEnv
-> NameEnv FixItem -> Warnings GhcRn -> HpcInfo
@@ -300,7 +317,7 @@ mkIface_ hsc_env
trust_info = setSafeMode safe_mode
annotations = map mkIfaceAnnotation anns
icomplete_matches = map mkIfaceCompleteMatch complete_matches
- !rdrs = maybeGlobalRdrEnv rdr_env
+ _ = maybeGlobalRdrEnv rdr_env
ModIface {
mi_module = this_mod,
=====================================
compiler/GHC/Iface/Recomp/Binary.hs
=====================================
@@ -16,6 +16,7 @@ import GHC.Types.Name
import GHC.Utils.Panic.Plain
import GHC.Iface.Type
import Data.Proxy
+import GHC.Utils.Outputable
fingerprintBinMem :: BinHandle -> IO Fingerprint
fingerprintBinMem bh = withBinBuffer bh f
@@ -33,7 +34,9 @@ computeFingerprint :: (Binary a)
-> IO Fingerprint
computeFingerprint put_nonbinding_name a = do
bh <- fmap set_user_data $ openBinMem (3*1024) -- just less than a block
+ pprTraceM "comput" (text "abc")
put_ bh a
+ pprTraceM "comput" (text "cde")
fingerprintBinMem bh
where
set_user_data bh =
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -37,6 +37,8 @@ module GHC.Iface.Syntax (
fromIfaceWarnings,
fromIfaceWarningTxt,
+ getIfaceExpr,
+
-- Free Names
freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst,
freeNamesIfConDecls,
@@ -131,7 +133,9 @@ putIfaceTopBndr bh name =
data IfaceDecl
- = IfaceId { ifName :: IfaceTopBndr,
+ = IfaceSerialisedDecl { ifName :: IfaceTopBndr
+ , ifSerialisedDecl :: FullBinData }
+ | IfaceId { ifName :: IfaceTopBndr,
ifType :: IfaceType,
ifIdDetails :: IfaceIdDetails,
ifIdInfo :: IfaceIdInfo
@@ -615,7 +619,8 @@ fromIfaceStringLiteral (IfStringLiteral st fs) = StringLiteral st fs Nothing
-}
data IfaceExpr
- = IfaceLcl IfLclName
+ = IfaceSerialisedExpr FullBinData
+ | IfaceLcl IfLclName
| IfaceExt IfExtName
| IfaceType IfaceType
| IfaceCo IfaceCoercion
@@ -2478,6 +2483,10 @@ instance Binary IfaceAlt where
return (IfaceAlt a b c)
instance Binary IfaceExpr where
+
+ putNoStack_ bh (IfaceSerialisedExpr f) = do
+ deserialised <- getIfaceExpr =<< thawBinHandle f
+ putNoStack_ bh deserialised
putNoStack_ bh (IfaceLcl aa) = do
putByte bh 0
put_ bh aa
@@ -2537,7 +2546,19 @@ instance Binary IfaceExpr where
putNoStack_ bh (IfaceLitRubbish ConstraintLike r) = do
putByte bh 15
put_ bh r
+
get bh = do
+ start <- tellBin @() bh
+ _ <- getIfaceExpr bh
+ end <- tellBin @() bh
+ seekBinNoExpand bh start
+ frozen <- IfaceSerialisedExpr <$> freezeBinHandle end bh
+ seekBinNoExpand bh end
+ return frozen
+
+
+
+getIfaceExpr bh = do
h <- getByte bh
case h of
0 -> do aa <- get bh
@@ -2831,6 +2852,7 @@ instance NFData IfaceUnfolding where
instance NFData IfaceExpr where
rnf = \case
+ IfaceSerialisedExpr bd -> bd `seq` ()
IfaceLcl nm -> rnf nm
IfaceExt nm -> rnf nm
IfaceType ty -> rnf ty
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -97,6 +97,7 @@ import Control.DeepSeq
import Data.Proxy
import Control.Monad ((<$!>))
import Control.Arrow (first)
+import Data.ByteString (ByteString)
{-
************************************************************************
@@ -160,7 +161,8 @@ type IfaceKind = IfaceType
-- Any time a 'Type' is pretty-printed, it is first converted to an 'IfaceType'
-- before being printed. See Note [Pretty printing via Iface syntax] in "GHC.Types.TyThing.Ppr"
data IfaceType
- = IfaceFreeTyVar TyVar -- See Note [Free tyvars in IfaceType]
+ = IfaceSerialisedType FullBinData
+ | IfaceFreeTyVar TyVar -- See Note [Free tyvars in IfaceType]
| IfaceTyVar IfLclName -- Type/coercion variable only, not tycon
| IfaceLitTy IfaceTyLit
| IfaceAppTy IfaceType IfaceAppArgs
@@ -2004,7 +2006,7 @@ putIfaceTyCon bh (IfaceTyCon n i) = put_ bh n >> put_ bh i
getIfaceTyCon :: HasCallStack => BinHandle -> IO IfaceTyCon
getIfaceTyCon bh = do
n <- get bh
- i <- get bh
+ !i <- get bh
return (IfaceTyCon n i)
instance Binary IfaceTyConSort where
@@ -2128,6 +2130,11 @@ instance Binary IfaceType where
tbl -> getEntry tbl bh
+putIfaceType bh (IfaceSerialisedType fb) = do -- putFullBinData bh fb
+ deserialised <- getIfaceType =<< thawBinHandle fb
+ putIfaceType bh deserialised
+
+
putIfaceType _ (IfaceFreeTyVar tv)
= pprPanic "Can't serialise IfaceFreeTyVar" (ppr tv)
@@ -2378,6 +2385,7 @@ instance Binary (DefMethSpec IfaceType) where
instance NFData IfaceType where
rnf = \case
+ IfaceSerialisedType bh -> bh `seq` ()
IfaceFreeTyVar f1 -> f1 `seq` ()
IfaceTyVar f1 -> rnf f1
IfaceLitTy f1 -> rnf f1
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -131,6 +131,7 @@ import Data.Foldable
import GHC.Builtin.Names (ioTyConName, rOOT_MAIN)
import GHC.Iface.Errors.Types
import Language.Haskell.Syntax.Extension (NoExtField (NoExtField))
+import GHC.Utils.Binary
{-
This module takes
@@ -1384,6 +1385,12 @@ loop. See #19744.
tcIfaceType :: IfaceType -> IfL Type
tcIfaceType = go
where
+ go (IfaceSerialisedType bs) = do
+ pprTraceM "thawing" (text @SDoc "abc")
+ deserialised <- liftIO (getIfaceType =<< thawBinHandle bs)
+ go deserialised
+
+
go (IfaceTyVar n) = TyVarTy <$> tcIfaceTyVar n
go (IfaceFreeTyVar n) = pprPanic "tcIfaceType:IfaceFreeTyVar" (ppr n)
go (IfaceLitTy l) = LitTy <$> tcIfaceTyLit l
@@ -1502,6 +1509,10 @@ tcIfaceUnivCoProv (IfacePluginProv str) = return $ PluginProv str
-}
tcIfaceExpr :: IfaceExpr -> IfL CoreExpr
+tcIfaceExpr (IfaceSerialisedExpr fbh) = do
+ pprTraceM "thawing" (text @SDoc "e")
+ deserialised <- liftIO (getIfaceExpr =<< thawBinHandle fbh)
+ tcIfaceExpr deserialised
tcIfaceExpr (IfaceType ty)
= Type <$> tcIfaceType ty
=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -342,7 +342,7 @@ data IfLclEnv
-- Whether or not the IfaceDecl came from a boot
-- file or not; we'll use this to choose between
-- NoUnfolding and BootUnfolding
- if_boot :: IsBootInterface,
+ if_boot :: !IsBootInterface,
-- The field is used only for error reporting
-- if (say) there's a Lint error in it
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -42,6 +42,8 @@ import GHC.Platform.Ways
import GHC.Builtin.Names ( gHC_PRIM )
+import qualified GHC.Data.Strict as Strict
+
import GHC.Unit.Env
import GHC.Unit.Types
import GHC.Unit.Module
@@ -49,7 +51,6 @@ import GHC.Unit.Home
import GHC.Unit.State
import GHC.Unit.Finder.Types
-import GHC.Data.Maybe ( expectJust )
import qualified GHC.Data.ShortText as ST
import GHC.Utils.Misc
@@ -61,8 +62,7 @@ import GHC.Types.PkgQual
import GHC.Fingerprint
import Data.IORef
-import System.Directory
-import System.FilePath
+import System.Directory.OsPath
import Control.Monad
import Data.Time
import qualified Data.Map as M
@@ -70,9 +70,11 @@ import GHC.Driver.Env
( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env) )
import GHC.Driver.Config.Finder
import qualified Data.Set as Set
+import System.OsPath (OsPath, (</>), (<.>))
+import qualified System.OsPath as OsPath
-type FileExt = String -- Filename extension
-type BaseName = String -- Basename of file
+type FileExt = OsPath -- Filename extension
+type BaseName = OsPath -- Basename of file
-- -----------------------------------------------------------------------------
-- The Finder
@@ -286,7 +288,7 @@ findLookupResult fc fopts r = case r of
-- implicit locations from the instances
InstalledFound loc _ -> return (Found loc m)
InstalledNoPackage _ -> return (NoPackage (moduleUnit m))
- InstalledNotFound fp _ -> return (NotFound{ fr_paths = fp, fr_pkg = Just (moduleUnit m)
+ InstalledNotFound fp _ -> return (NotFound{ fr_paths = fmap unsafeDecodeUtf fp, fr_pkg = Just (moduleUnit m)
, fr_pkgs_hidden = []
, fr_mods_hidden = []
, fr_unusables = []
@@ -357,7 +359,7 @@ findHomeModule fc fopts home_unit mod_name = do
InstalledFound loc _ -> Found loc (mkHomeModule home_unit mod_name)
InstalledNoPackage _ -> NoPackage uid -- impossible
InstalledNotFound fps _ -> NotFound {
- fr_paths = fps,
+ fr_paths = fmap unsafeDecodeUtf fps,
fr_pkg = Just uid,
fr_mods_hidden = [],
fr_pkgs_hidden = [],
@@ -382,7 +384,7 @@ findHomePackageModule fc fopts home_unit mod_name = do
InstalledFound loc _ -> Found loc (mkModule uid mod_name)
InstalledNoPackage _ -> NoPackage uid -- impossible
InstalledNotFound fps _ -> NotFound {
- fr_paths = fps,
+ fr_paths = fmap unsafeDecodeUtf fps,
fr_pkg = Just uid,
fr_mods_hidden = [],
fr_pkgs_hidden = [],
@@ -413,22 +415,22 @@ findInstalledHomeModule fc fopts home_unit mod_name = do
let
maybe_working_dir = finder_workingDirectory fopts
home_path = case maybe_working_dir of
- Nothing -> finder_importPaths fopts
- Just fp -> augmentImports fp (finder_importPaths fopts)
+ Strict.Nothing -> finder_importPaths fopts
+ Strict.Just fp -> augmentImports fp (finder_importPaths fopts)
hi_dir_path =
case finder_hiDir fopts of
- Just hiDir -> case maybe_working_dir of
- Nothing -> [hiDir]
- Just fp -> [fp </> hiDir]
- Nothing -> home_path
+ Strict.Just hiDir -> case maybe_working_dir of
+ Strict.Nothing -> [hiDir]
+ Strict.Just fp -> [fp </> hiDir]
+ Strict.Nothing -> home_path
hisuf = finder_hiSuf fopts
mod = mkModule home_unit mod_name
source_exts =
- [ ("hs", mkHomeModLocationSearched fopts mod_name "hs")
- , ("lhs", mkHomeModLocationSearched fopts mod_name "lhs")
- , ("hsig", mkHomeModLocationSearched fopts mod_name "hsig")
- , ("lhsig", mkHomeModLocationSearched fopts mod_name "lhsig")
+ [ (unsafeEncodeUtf "hs", mkHomeModLocationSearched fopts mod_name $ unsafeEncodeUtf "hs")
+ , (unsafeEncodeUtf "lhs", mkHomeModLocationSearched fopts mod_name $ unsafeEncodeUtf "lhs")
+ , (unsafeEncodeUtf "hsig", mkHomeModLocationSearched fopts mod_name $ unsafeEncodeUtf "hsig")
+ , (unsafeEncodeUtf "lhsig", mkHomeModLocationSearched fopts mod_name $ unsafeEncodeUtf "lhsig")
]
-- we use mkHomeModHiOnlyLocation instead of mkHiOnlyModLocation so that
@@ -453,9 +455,9 @@ findInstalledHomeModule fc fopts home_unit mod_name = do
else searchPathExts search_dirs mod exts
-- | Prepend the working directory to the search path.
-augmentImports :: FilePath -> [FilePath] -> [FilePath]
+augmentImports :: OsPath -> [OsPath] -> [OsPath]
augmentImports _work_dir [] = []
-augmentImports work_dir (fp:fps) | isAbsolute fp = fp : augmentImports work_dir fps
+augmentImports work_dir (fp:fps) | OsPath.isAbsolute fp = fp : augmentImports work_dir fps
| otherwise = (work_dir </> fp) : augmentImports work_dir fps
-- | Search for a module in external packages only.
@@ -488,14 +490,14 @@ findPackageModule_ fc fopts mod pkg_conf = do
tag = waysBuildTag (finder_ways fopts)
-- hi-suffix for packages depends on the build tag.
- package_hisuf | null tag = "hi"
- | otherwise = tag ++ "_hi"
+ package_hisuf | null tag = unsafeEncodeUtf $ "hi"
+ | otherwise = unsafeEncodeUtf $ tag ++ "_hi"
- package_dynhisuf = waysBuildTag (addWay WayDyn (finder_ways fopts)) ++ "_hi"
+ package_dynhisuf = unsafeEncodeUtf $ waysBuildTag (addWay WayDyn (finder_ways fopts)) ++ "_hi"
mk_hi_loc = mkHiOnlyModLocation fopts package_hisuf package_dynhisuf
- import_dirs = map ST.unpack $ unitImportDirs pkg_conf
+ import_dirs = map (unsafeEncodeUtf . ST.unpack) $ unitImportDirs pkg_conf
-- we never look for a .hi-boot file in an external package;
-- .hi-boot files only make sense for the home package.
in
@@ -503,7 +505,7 @@ findPackageModule_ fc fopts mod pkg_conf = do
[one] | finder_bypassHiFileCheck fopts ->
-- there's only one place that this .hi file can be, so
-- don't bother looking for it.
- let basename = moduleNameSlashes (moduleName mod)
+ let basename = unsafeEncodeUtf $ moduleNameSlashes (moduleName mod)
loc = mk_hi_loc one basename
in return $ InstalledFound loc mod
_otherwise ->
@@ -512,24 +514,24 @@ findPackageModule_ fc fopts mod pkg_conf = do
-- -----------------------------------------------------------------------------
-- General path searching
-searchPathExts :: [FilePath] -- paths to search
+searchPathExts :: [OsPath] -- paths to search
-> InstalledModule -- module name
-> [ (
FileExt, -- suffix
- FilePath -> BaseName -> ModLocation -- action
+ OsPath -> BaseName -> ModLocation -- action
)
]
-> IO InstalledFindResult
searchPathExts paths mod exts = search to_search
where
- basename = moduleNameSlashes (moduleName mod)
+ basename = unsafeEncodeUtf $ moduleNameSlashes (moduleName mod)
- to_search :: [(FilePath, ModLocation)]
+ to_search :: [(OsPath, ModLocation)]
to_search = [ (file, fn path basename)
| path <- paths,
(ext,fn) <- exts,
- let base | path == "." = basename
+ let base | path == unsafeEncodeUtf "." = basename
| otherwise = path </> basename
file = base <.> ext
]
@@ -543,7 +545,7 @@ searchPathExts paths mod exts = search to_search
else search rest
mkHomeModLocationSearched :: FinderOpts -> ModuleName -> FileExt
- -> FilePath -> BaseName -> ModLocation
+ -> OsPath -> BaseName -> ModLocation
mkHomeModLocationSearched fopts mod suff path basename =
mkHomeModLocation2 fopts mod (path </> basename) suff
@@ -581,18 +583,18 @@ mkHomeModLocationSearched fopts mod suff path basename =
-- ext
-- The filename extension of the source file (usually "hs" or "lhs").
-mkHomeModLocation :: FinderOpts -> ModuleName -> FilePath -> ModLocation
+mkHomeModLocation :: FinderOpts -> ModuleName -> OsPath -> ModLocation
mkHomeModLocation dflags mod src_filename =
- let (basename,extension) = splitExtension src_filename
+ let (basename,extension) = OsPath.splitExtension src_filename
in mkHomeModLocation2 dflags mod basename extension
mkHomeModLocation2 :: FinderOpts
-> ModuleName
- -> FilePath -- Of source module, without suffix
- -> String -- Suffix
+ -> OsPath -- Of source module, without suffix
+ -> OsPath -- Suffix
-> ModLocation
mkHomeModLocation2 fopts mod src_basename ext =
- let mod_basename = moduleNameSlashes mod
+ let mod_basename = unsafeEncodeUtf $ moduleNameSlashes mod
obj_fn = mkObjPath fopts src_basename mod_basename
dyn_obj_fn = mkDynObjPath fopts src_basename mod_basename
@@ -600,72 +602,72 @@ mkHomeModLocation2 fopts mod src_basename ext =
dyn_hi_fn = mkDynHiPath fopts src_basename mod_basename
hie_fn = mkHiePath fopts src_basename mod_basename
- in (ModLocation{ ml_hs_file = Just (src_basename <.> ext),
- ml_hi_file = hi_fn,
- ml_dyn_hi_file = dyn_hi_fn,
- ml_obj_file = obj_fn,
- ml_dyn_obj_file = dyn_obj_fn,
- ml_hie_file = hie_fn })
+ in (ModLocation{ ml_hs_file_ = Strict.Just (src_basename <.> ext),
+ ml_hi_file_ = hi_fn,
+ ml_dyn_hi_file_ = dyn_hi_fn,
+ ml_obj_file_ = obj_fn,
+ ml_dyn_obj_file_ = dyn_obj_fn,
+ ml_hie_file_ = hie_fn })
mkHomeModHiOnlyLocation :: FinderOpts
-> ModuleName
- -> FilePath
+ -> OsPath
-> BaseName
-> ModLocation
mkHomeModHiOnlyLocation fopts mod path basename =
- let loc = mkHomeModLocation2 fopts mod (path </> basename) ""
- in loc { ml_hs_file = Nothing }
+ let loc = mkHomeModLocation2 fopts mod (path </> basename) mempty
+ in loc { ml_hs_file_ = Strict.Nothing }
-- This function is used to make a ModLocation for a package module. Hence why
-- we explicitly pass in the interface file suffixes.
-mkHiOnlyModLocation :: FinderOpts -> Suffix -> Suffix -> FilePath -> String
+mkHiOnlyModLocation :: FinderOpts -> OsPath -> OsPath -> OsPath -> OsPath
-> ModLocation
mkHiOnlyModLocation fopts hisuf dynhisuf path basename
= let full_basename = path </> basename
obj_fn = mkObjPath fopts full_basename basename
dyn_obj_fn = mkDynObjPath fopts full_basename basename
hie_fn = mkHiePath fopts full_basename basename
- in ModLocation{ ml_hs_file = Nothing,
- ml_hi_file = full_basename <.> hisuf,
+ in ModLocation{ ml_hs_file_ = Strict.Nothing,
+ ml_hi_file_ = full_basename <.> hisuf,
-- Remove the .hi-boot suffix from
-- hi_file, if it had one. We always
-- want the name of the real .hi file
-- in the ml_hi_file field.
- ml_dyn_obj_file = dyn_obj_fn,
+ ml_dyn_obj_file_ = dyn_obj_fn,
-- MP: TODO
- ml_dyn_hi_file = full_basename <.> dynhisuf,
- ml_obj_file = obj_fn,
- ml_hie_file = hie_fn
+ ml_dyn_hi_file_ = full_basename <.> dynhisuf,
+ ml_obj_file_ = obj_fn,
+ ml_hie_file_ = hie_fn
}
-- | Constructs the filename of a .o file for a given source file.
-- Does /not/ check whether the .o file exists
mkObjPath
:: FinderOpts
- -> FilePath -- the filename of the source file, minus the extension
- -> String -- the module name with dots replaced by slashes
- -> FilePath
-mkObjPath fopts basename mod_basename = obj_basename <.> osuf
+ -> OsPath -- the filename of the source file, minus the extension
+ -> OsPath -- the module name with dots replaced by slashes
+ -> OsPath
+mkObjPath fopts basename mod_basename = obj_basename OsPath.<.> osuf
where
odir = finder_objectDir fopts
osuf = finder_objectSuf fopts
- obj_basename | Just dir <- odir = dir </> mod_basename
+ obj_basename | Strict.Just dir <- odir = dir OsPath.</> mod_basename
| otherwise = basename
-- | Constructs the filename of a .dyn_o file for a given source file.
-- Does /not/ check whether the .dyn_o file exists
mkDynObjPath
:: FinderOpts
- -> FilePath -- the filename of the source file, minus the extension
- -> String -- the module name with dots replaced by slashes
- -> FilePath
+ -> OsPath -- the filename of the source file, minus the extension
+ -> OsPath -- the module name with dots replaced by slashes
+ -> OsPath
mkDynObjPath fopts basename mod_basename = obj_basename <.> dynosuf
where
odir = finder_objectDir fopts
dynosuf = finder_dynObjectSuf fopts
- obj_basename | Just dir <- odir = dir </> mod_basename
+ obj_basename | Strict.Just dir <- odir = dir </> mod_basename
| otherwise = basename
@@ -673,45 +675,45 @@ mkDynObjPath fopts basename mod_basename = obj_basename <.> dynosuf
-- Does /not/ check whether the .hi file exists
mkHiPath
:: FinderOpts
- -> FilePath -- the filename of the source file, minus the extension
- -> String -- the module name with dots replaced by slashes
- -> FilePath
+ -> OsPath -- the filename of the source file, minus the extension
+ -> OsPath -- the module name with dots replaced by slashes
+ -> OsPath
mkHiPath fopts basename mod_basename = hi_basename <.> hisuf
where
hidir = finder_hiDir fopts
hisuf = finder_hiSuf fopts
- hi_basename | Just dir <- hidir = dir </> mod_basename
+ hi_basename | Strict.Just dir <- hidir = dir </> mod_basename
| otherwise = basename
-- | Constructs the filename of a .dyn_hi file for a given source file.
-- Does /not/ check whether the .dyn_hi file exists
mkDynHiPath
:: FinderOpts
- -> FilePath -- the filename of the source file, minus the extension
- -> String -- the module name with dots replaced by slashes
- -> FilePath
+ -> OsPath -- the filename of the source file, minus the extension
+ -> OsPath -- the module name with dots replaced by slashes
+ -> OsPath
mkDynHiPath fopts basename mod_basename = hi_basename <.> dynhisuf
where
hidir = finder_hiDir fopts
dynhisuf = finder_dynHiSuf fopts
- hi_basename | Just dir <- hidir = dir </> mod_basename
+ hi_basename | Strict.Just dir <- hidir = dir </> mod_basename
| otherwise = basename
-- | Constructs the filename of a .hie file for a given source file.
-- Does /not/ check whether the .hie file exists
mkHiePath
:: FinderOpts
- -> FilePath -- the filename of the source file, minus the extension
- -> String -- the module name with dots replaced by slashes
- -> FilePath
+ -> OsPath -- the filename of the source file, minus the extension
+ -> OsPath -- the module name with dots replaced by slashes
+ -> OsPath
mkHiePath fopts basename mod_basename = hie_basename <.> hiesuf
where
hiedir = finder_hieDir fopts
hiesuf = finder_hieSuf fopts
- hie_basename | Just dir <- hiedir = dir </> mod_basename
+ hie_basename | Strict.Just dir <- hiedir = dir </> mod_basename
| otherwise = basename
@@ -726,23 +728,23 @@ mkStubPaths
:: FinderOpts
-> ModuleName
-> ModLocation
- -> FilePath
+ -> OsPath
mkStubPaths fopts mod location
= let
stubdir = finder_stubDir fopts
- mod_basename = moduleNameSlashes mod
- src_basename = dropExtension $ expectJust "mkStubPaths"
- (ml_hs_file location)
+ mod_basename = unsafeEncodeUtf $ moduleNameSlashes mod
+ src_basename = OsPath.dropExtension $ Strict.expectJust "mkStubPaths"
+ (ml_hs_file_ location)
stub_basename0
- | Just dir <- stubdir = dir </> mod_basename
+ | Strict.Just dir <- stubdir = dir </> mod_basename
| otherwise = src_basename
- stub_basename = stub_basename0 ++ "_stub"
+ stub_basename = stub_basename0 `mappend` unsafeEncodeUtf "_stub"
in
- stub_basename <.> "h"
+ stub_basename <.> unsafeEncodeUtf "h"
-- -----------------------------------------------------------------------------
-- findLinkable isn't related to the other stuff in here,
=====================================
compiler/GHC/Unit/Finder/Types.hs
=====================================
@@ -9,6 +9,7 @@ where
import GHC.Prelude
import GHC.Unit
+import qualified GHC.Data.Strict as Strict
import qualified Data.Map as M
import GHC.Fingerprint
import GHC.Platform.Ways
@@ -16,6 +17,7 @@ import GHC.Platform.Ways
import Data.IORef
import GHC.Data.FastString
import qualified Data.Set as Set
+import System.OsPath (OsPath)
-- | The 'FinderCache' maps modules to the result of
-- searching for that module. It records the results of searching for
@@ -31,7 +33,7 @@ data FinderCache = FinderCache { fcModuleCache :: (IORef FinderCacheState)
data InstalledFindResult
= InstalledFound ModLocation InstalledModule
| InstalledNoPackage UnitId
- | InstalledNotFound [FilePath] (Maybe UnitId)
+ | InstalledNotFound [OsPath] (Maybe UnitId)
-- | The result of searching for an imported module.
--
@@ -70,7 +72,7 @@ data FindResult
--
-- Should be taken from 'DynFlags' via 'initFinderOpts'.
data FinderOpts = FinderOpts
- { finder_importPaths :: [FilePath]
+ { finder_importPaths :: [OsPath]
-- ^ Where are we allowed to look for Modules and Source files
, finder_lookupHomeInterfaces :: Bool
-- ^ When looking up a home module:
@@ -88,17 +90,17 @@ data FinderOpts = FinderOpts
, finder_enableSuggestions :: Bool
-- ^ If we encounter unknown modules, should we suggest modules
-- that have a similar name.
- , finder_workingDirectory :: Maybe FilePath
+ , finder_workingDirectory :: Strict.Maybe OsPath
, finder_thisPackageName :: Maybe FastString
, finder_hiddenModules :: Set.Set ModuleName
, finder_reexportedModules :: Set.Set ModuleName
- , finder_hieDir :: Maybe FilePath
- , finder_hieSuf :: String
- , finder_hiDir :: Maybe FilePath
- , finder_hiSuf :: String
- , finder_dynHiSuf :: String
- , finder_objectDir :: Maybe FilePath
- , finder_objectSuf :: String
- , finder_dynObjectSuf :: String
- , finder_stubDir :: Maybe FilePath
+ , finder_hieDir :: Strict.Maybe OsPath
+ , finder_hieSuf :: OsPath
+ , finder_hiDir :: Strict.Maybe OsPath
+ , finder_hiSuf :: OsPath
+ , finder_dynHiSuf :: OsPath
+ , finder_objectDir :: Strict.Maybe OsPath
+ , finder_objectSuf :: OsPath
+ , finder_dynObjectSuf :: OsPath
+ , finder_stubDir :: Strict.Maybe OsPath
} deriving Show
=====================================
compiler/GHC/Unit/Module/Location.hs
=====================================
@@ -7,12 +7,23 @@ module GHC.Unit.Module.Location
, addBootSuffixLocn
, addBootSuffixLocnOut
, removeBootSuffix
+ , ml_hs_file
+ , ml_hi_file
+ , ml_dyn_hi_file
+ , ml_obj_file
+ , ml_dyn_obj_file
+ , ml_hie_file
+ , unsafeEncodeUtf
+ , unsafeDecodeUtf
)
where
+import Data.Either
import GHC.Prelude
import GHC.Unit.Types
import GHC.Utils.Outputable
+import qualified GHC.Data.Strict as Strict
+import System.OsPath
-- | Module Location
--
@@ -39,30 +50,30 @@ import GHC.Utils.Outputable
data ModLocation
= ModLocation {
- ml_hs_file :: Maybe FilePath,
+ ml_hs_file_ :: Strict.Maybe OsPath,
-- ^ The source file, if we have one. Package modules
-- probably don't have source files.
- ml_hi_file :: FilePath,
+ ml_hi_file_ :: !OsPath,
-- ^ Where the .hi file is, whether or not it exists
-- yet. Always of form foo.hi, even if there is an
-- hi-boot file (we add the -boot suffix later)
- ml_dyn_hi_file :: FilePath,
+ ml_dyn_hi_file_ :: !OsPath,
-- ^ Where the .dyn_hi file is, whether or not it exists
-- yet.
- ml_obj_file :: FilePath,
+ ml_obj_file_ :: !OsPath,
-- ^ Where the .o file is, whether or not it exists yet.
-- (might not exist either because the module hasn't
-- been compiled yet, or because it is part of a
-- unit with a .a file)
- ml_dyn_obj_file :: FilePath,
+ ml_dyn_obj_file_ :: !OsPath,
-- ^ Where the .dy file is, whether or not it exists
-- yet.
- ml_hie_file :: FilePath
+ ml_hie_file_ :: !OsPath
-- ^ Where the .hie file is, whether or not it exists
-- yet.
} deriving Show
@@ -70,9 +81,15 @@ data ModLocation
instance Outputable ModLocation where
ppr = text . show
+unsafeEncodeUtf :: FilePath -> OsPath
+unsafeEncodeUtf = fromRight (error "unsafeEncodeUtf: Internal error") . encodeUtf
+
+unsafeDecodeUtf :: OsPath -> FilePath
+unsafeDecodeUtf = fromRight (error "unsafeEncodeUtf: Internal error") . decodeUtf
+
-- | Add the @-boot@ suffix to .hs, .hi and .o files
-addBootSuffix :: FilePath -> FilePath
-addBootSuffix path = path ++ "-boot"
+addBootSuffix :: OsPath -> OsPath
+addBootSuffix path = path `mappend` unsafeEncodeUtf "-boot"
-- | Remove the @-boot@ suffix to .hs, .hi and .o files
removeBootSuffix :: FilePath -> FilePath
@@ -82,7 +99,7 @@ removeBootSuffix [] = error "removeBootSuffix: no -boot suffix"
-- | Add the @-boot@ suffix if the @Bool@ argument is @True@
-addBootSuffix_maybe :: IsBootInterface -> FilePath -> FilePath
+addBootSuffix_maybe :: IsBootInterface -> OsPath -> OsPath
addBootSuffix_maybe is_boot path = case is_boot of
IsBoot -> addBootSuffix path
NotBoot -> path
@@ -95,22 +112,38 @@ addBootSuffixLocn_maybe is_boot locn = case is_boot of
-- | Add the @-boot@ suffix to all file paths associated with the module
addBootSuffixLocn :: ModLocation -> ModLocation
addBootSuffixLocn locn
- = locn { ml_hs_file = fmap addBootSuffix (ml_hs_file locn)
- , ml_hi_file = addBootSuffix (ml_hi_file locn)
- , ml_dyn_hi_file = addBootSuffix (ml_dyn_hi_file locn)
- , ml_obj_file = addBootSuffix (ml_obj_file locn)
- , ml_dyn_obj_file = addBootSuffix (ml_dyn_obj_file locn)
- , ml_hie_file = addBootSuffix (ml_hie_file locn) }
+ = locn { ml_hs_file_ = fmap addBootSuffix (ml_hs_file_ locn)
+ , ml_hi_file_ = addBootSuffix (ml_hi_file_ locn)
+ , ml_dyn_hi_file_ = addBootSuffix (ml_dyn_hi_file_ locn)
+ , ml_obj_file_ = addBootSuffix (ml_obj_file_ locn)
+ , ml_dyn_obj_file_ = addBootSuffix (ml_dyn_obj_file_ locn)
+ , ml_hie_file_ = addBootSuffix (ml_hie_file_ locn) }
-- | Add the @-boot@ suffix to all output file paths associated with the
-- module, not including the input file itself
addBootSuffixLocnOut :: ModLocation -> ModLocation
addBootSuffixLocnOut locn
- = locn { ml_hi_file = addBootSuffix (ml_hi_file locn)
- , ml_dyn_hi_file = addBootSuffix (ml_dyn_hi_file locn)
- , ml_obj_file = addBootSuffix (ml_obj_file locn)
- , ml_dyn_obj_file = addBootSuffix (ml_dyn_obj_file locn)
- , ml_hie_file = addBootSuffix (ml_hie_file locn)
+ = locn { ml_hi_file_ = addBootSuffix (ml_hi_file_ locn)
+ , ml_dyn_hi_file_ = addBootSuffix (ml_dyn_hi_file_ locn)
+ , ml_obj_file_ = addBootSuffix (ml_obj_file_ locn)
+ , ml_dyn_obj_file_ = addBootSuffix (ml_dyn_obj_file_ locn)
+ , ml_hie_file_ = addBootSuffix (ml_hie_file_ locn)
}
+ml_hs_file :: ModLocation -> Maybe FilePath
+ml_hs_file = fmap unsafeDecodeUtf . Strict.toLazy . ml_hs_file_
+
+ml_hi_file :: ModLocation -> FilePath
+ml_hi_file = unsafeDecodeUtf . ml_hi_file_
+
+ml_dyn_hi_file :: ModLocation -> FilePath
+ml_dyn_hi_file = unsafeDecodeUtf . ml_dyn_hi_file_
+
+ml_obj_file :: ModLocation -> FilePath
+ml_obj_file = unsafeDecodeUtf . ml_obj_file_
+
+ml_dyn_obj_file :: ModLocation -> FilePath
+ml_dyn_obj_file = unsafeDecodeUtf . ml_dyn_obj_file_
+ml_hie_file :: ModLocation -> FilePath
+ml_hie_file = unsafeDecodeUtf . ml_hie_file_
=====================================
compiler/GHC/Unit/Module/ModIface.hs
=====================================
@@ -414,7 +414,8 @@ instance Binary ModIface where
lazyPut bh warns
lazyPut bh anns
put_ bh decls
- put_ bh extra_decls
+ lazyPutMaybe bh extra_decls
+-- put_ bh extra_decls
put_ bh insts
put_ bh fam_insts
lazyPut bh rules
@@ -446,7 +447,8 @@ instance Binary ModIface where
warns <- {-# SCC "bin_warns" #-} lazyGet bh
anns <- {-# SCC "bin_anns" #-} lazyGet bh
decls <- {-# SCC "bin_tycldecls" #-} get bh
- extra_decls <- get bh
+ extra_decls <- lazyGetMaybe bh
+-- extra_decls <- get bh
insts <- {-# SCC "bin_insts" #-} get bh
fam_insts <- {-# SCC "bin_fam_insts" #-} get bh
rules <- {-# SCC "bin_rules" #-} lazyGet bh
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -31,7 +31,7 @@ module GHC.Utils.Binary
openBinMem,
-- closeBin,
- seekBin,
+ seekBin, seekBinNoExpand,
tellBin,
castBin,
withBinBuffer,
@@ -86,7 +86,9 @@ module GHC.Utils.Binary
addDecoder,
-- * Newtype wrappers
- BinSpan(..), BinSrcSpan(..), BinLocated(..)
+ BinSpan(..), BinSrcSpan(..), BinLocated(..),
+
+ FullBinData, freezeBinHandle, thawBinHandle, putFullBinData,
) where
import GHC.Prelude
@@ -182,6 +184,42 @@ dataHandle (BinData size bin) = do
handleData :: BinHandle -> IO BinData
handleData (BinMem _ ixr _ binr _) = BinData <$> readFastMutInt ixr <*> readIORef binr
+---
+-- FullBinData
+-- -- Frozen BinHandle
+
+data FullBinData = FullBinData UserData {-# UNPACK #-} !Int -- start offset
+ {-# UNPACK #-} !Int -- end offset
+ {-# UNPACK #-} !Int -- total buffer size
+ {-# UNPACK #-} !BinArray
+
+-- Equality and Ord assume that two distinct buffers are different, even if they compare the same things.
+instance Eq FullBinData where
+ (FullBinData a b c d e) == (FullBinData a1 b1 c1 d1 e1) = b == b1 && c == c1 && d == d1 && e == e1
+
+instance Ord FullBinData where
+ compare (FullBinData _ b c d e) (FullBinData _ b1 c1 d1 e1) =
+ compare b b1 `mappend` compare c c1 `mappend` compare d d1 `mappend` compare e e1
+
+putFullBinData bh (FullBinData _ o1 o2 _sz ba) = do
+ let sz = o2 - o1
+ putPrim bh sz $ \dest ->
+ unsafeWithForeignPtr (ba `plusForeignPtr` o1) $ \orig ->
+ copyBytes dest orig sz
+
+freezeBinHandle :: Bin () -> BinHandle -> IO FullBinData
+freezeBinHandle (BinPtr len) (BinMem user_data ixr sz binr _) =
+ FullBinData user_data <$> readFastMutInt ixr <*> pure len <*> readFastMutInt sz <*> readIORef binr
+
+thawBinHandle :: FullBinData -> IO BinHandle
+thawBinHandle (FullBinData user_data ix _end sz ba) = do
+ ixr <- newFastMutInt ix
+ szr <- newFastMutInt sz
+ binr <- newIORef ba
+ bp <- initBinProf
+ return $ BinMem user_data ixr szr binr bp
+
+
---------------------------------------------------------------
-- BinHandle
---------------------------------------------------------------
@@ -251,6 +289,7 @@ unsafeUnpackBinBuffer (BS.BS arr len) = do
newtype Bin a = BinPtr Int
deriving (Eq, Ord, Show, Bounded)
+
castBin :: Bin a -> Bin b
castBin (BinPtr i) = BinPtr i
@@ -1089,7 +1128,7 @@ forwardGet bh get_A = do
lazyPut :: Binary a => BinHandle -> a -> IO ()
lazyPut = lazyPut' putNoStack_
lazyGet :: Binary a => BinHandle -> IO a
-lazyGet = lazyGet' Nothing get
+lazyGet = lazyGet' Nothing (\_ -> get)
lazyPut' :: HasCallStack => (BinHandle -> a -> IO ()) -> BinHandle -> a -> IO ()
lazyPut' f bh a = do
@@ -1101,7 +1140,7 @@ lazyPut' f bh a = do
putAt bh pre_a q -- fill in slot before a with ptr to q
seekBin bh q -- finally carry on writing at q
-lazyGet' :: HasCallStack => Maybe (IORef BinHandle) -> (BinHandle -> IO a) -> BinHandle -> IO a
+lazyGet' :: HasCallStack => Maybe (IORef BinHandle) -> (Bin () -> BinHandle -> IO a) -> BinHandle -> IO a
lazyGet' mbh f bh = do
p <- get @(Bin ()) bh -- a BinPtr
p_a <- tellBin bh
@@ -1112,7 +1151,7 @@ lazyGet' mbh f bh = do
off_r <- newFastMutInt 0
let bh' = inner_bh { _off_r = off_r }
seekBin bh' p_a
- f bh'
+ f p bh'
seekBin bh p -- skip over the object for now
return a
@@ -1239,7 +1278,7 @@ putGenericSymbolTable gen_sym_tab serialiser bh = do
(forwardPut bh (const $ readFastMutInt symtab_next >>= put_ bh) $
loop 0)
-getGenericSymbolTable :: forall a. (BinHandle -> IO a) -> IORef BinHandle -> BinHandle -> IO (SymbolTable a)
+getGenericSymbolTable :: forall a. (Bin () -> BinHandle -> IO a) -> IORef BinHandle -> BinHandle -> IO (SymbolTable a)
getGenericSymbolTable deserialiser bhRef bh = do
sz <- forwardGet bh (get bh) :: IO Int
mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int a)
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -171,6 +171,7 @@ import GHC.TopHandler ( topHandler )
import GHCi.Leak
import qualified GHC.Unit.Module.Graph as GHC
+import GHC.Profiling.Eras
-----------------------------------------------------------------------------
@@ -2159,6 +2160,7 @@ reloadModuleDefer = wrapDeferTypeErrors . reloadModule
-- sessions.
doLoadAndCollectInfo :: GhciMonad m => LoadType -> LoadHowMuch -> m SuccessFlag
doLoadAndCollectInfo load_type howmuch = do
+ liftIO $ incrementUserEra 1
doCollectInfo <- isOptionSet CollectInfo
doLoad load_type howmuch >>= \case
=====================================
ghc/ghc-bin.cabal.in
=====================================
@@ -45,7 +45,8 @@ Executable ghc
containers >= 0.5 && < 0.8,
transformers >= 0.5 && < 0.7,
ghc-boot == @ProjectVersionMunged@,
- ghc == @ProjectVersionMunged@
+ ghc == @ProjectVersionMunged@,
+ ghc-experimental
if flag(ghc-debug)
build-depends: ghc-debug-stub
=====================================
hadrian/src/Settings/Packages.hs
=====================================
@@ -100,7 +100,7 @@ packageArgs = do
, builder (Cabal Flags) ? mconcat
[ andM [expr ghcWithInterpreter, notStage0] `cabalFlag` "internal-interpreter"
, notStage0 `cabalFlag` "ghc-debug"
- , stage0 `cabalFlag` "ghc-debug"
+-- , stage0 `cabalFlag` "ghc-debug"
, ifM stage0
-- We build a threaded stage 1 if the bootstrapping compiler
-- supports it.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2b8cbe10266f7ea9b25a544175ff4bae9afcc29d...9826914441cbc41108903a6d230e8e58a339e5fd
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2b8cbe10266f7ea9b25a544175ff4bae9afcc29d...9826914441cbc41108903a6d230e8e58a339e5fd
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/20240323/e269d3cd/attachment-0001.html>
More information about the ghc-commits
mailing list