[Git][ghc/ghc][wip/torsten.schmits/oneshot-bytecode-pkgdeps] more refactoring
Torsten Schmits (@torsten.schmits)
gitlab at gitlab.haskell.org
Mon Jul 8 21:30:32 UTC 2024
Torsten Schmits pushed to branch wip/torsten.schmits/oneshot-bytecode-pkgdeps at Glasgow Haskell Compiler / GHC
Commits:
f5b6dfcb by Torsten Schmits at 2024-07-08T23:29:37+02:00
more refactoring
- - - - -
11 changed files:
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Linker/Loader.hs
- testsuite/tests/th/cross-package/Cross.hs
- testsuite/tests/th/cross-package/CrossLocal.hs
- + testsuite/tests/th/cross-package/CrossNum.hs-boot
- + testsuite/tests/th/cross-package/CrossObj.hs
- testsuite/tests/th/cross-package/Makefile
- testsuite/tests/th/cross-package/all.T
- + testsuite/tests/th/cross-package/obj.conf
- testsuite/tests/th/cross-package/prep.bash
- testsuite/tests/th/cross-package/run.bash
Changes:
=====================================
compiler/GHC/Linker/Deps.hs
=====================================
@@ -57,6 +57,8 @@ import System.Directory
import GHC.Driver.Env
import {-# SOURCE #-} GHC.Driver.Main
import Data.Time.Clock
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
data LinkDepsOpts = LinkDepsOpts
@@ -67,6 +69,7 @@ data LinkDepsOpts = LinkDepsOpts
, ldPprOpts :: !SDocContext -- ^ Rendering options for error messages
, ldFinderCache :: !FinderCache -- ^ Finder cache
, ldFinderOpts :: !FinderOpts -- ^ Finder options
+ , ldHugFinderOpts :: !(UnitEnvGraph FinderOpts)
, ldUseByteCode :: !Bool -- ^ Use bytecode rather than objects
, ldMsgOpts :: !(DiagnosticOpts IfaceMessage) -- ^ Options for diagnostics
, ldWays :: !Ways -- ^ Enabled ways
@@ -287,8 +290,15 @@ data LinkDep =
instance Outputable LinkDep where
ppr = \case
- LinkModules mods -> text "link modules:" <+> ppr mods
- LinkLibrary uid -> text "link library:" <+> ppr uid
+ LinkModules mods -> text "modules:" <+> ppr (eltsUDFM mods)
+ LinkLibrary uid -> text "library:" <+> ppr uid
+
+data OneshotError =
+ NoLocation Module
+ |
+ NoInterface MissingInterfaceError
+ |
+ LinkBootModule Module
-- This code is used in one-shot mode to traverse downwards through the HPT
-- to find all link dependencies.
@@ -303,26 +313,33 @@ oneshot_deps ::
[Module] ->
IO [LinkDep]
oneshot_deps opts mods =
- eltsUDFM <$> oneshot_deps_loop opts [GWIB m NotBoot | m <- mods] emptyUDFM
+ runExceptT (oneshot_deps_loop opts mods emptyUDFM) >>= \case
+ Right a -> pure (eltsUDFM a)
+ Left err -> throwProgramError opts (message err)
+ where
+ message = \case
+ NoLocation mod ->
+ pprPanic "found iface but no location" (ppr mod)
+ NoInterface err ->
+ missingInterfaceErrorDiagnostic (ldMsgOpts opts) err
+ LinkBootModule mod ->
+ link_boot_mod_error mod
oneshot_deps_loop ::
LinkDepsOpts ->
- [ModuleWithIsBoot] ->
+ [Module] ->
UniqDFM UnitId LinkDep ->
- IO (UniqDFM UnitId LinkDep)
+ ExceptT OneshotError IO (UniqDFM UnitId LinkDep)
oneshot_deps_loop _ [] acc =
pure acc
-oneshot_deps_loop opts (GWIB mod is_boot : mods) acc = do
+oneshot_deps_loop opts (mod : mods) acc = do
(new_acc, new_mods) <- process_module
oneshot_deps_loop opts (new_mods ++ mods) new_acc
where
process_module
- | already_seen
- = pure (acc, [])
- | is_home || oe_bytecode
- = try_add_module
- | otherwise
- = add_library
+ | already_seen = pure (acc, [])
+ | is_home || bytecode = try_iface
+ | otherwise = add_library
already_seen
| Just (LinkModules mods) <- mod_dep
@@ -332,52 +349,30 @@ oneshot_deps_loop opts (GWIB mod is_boot : mods) acc = do
| otherwise
= False
- try_add_module = do
- -- TODO use finder as well here to get ModLocation right away
- ldLoadIface opts load_reason mod >>= \case
- Failed err
- -- Interfaces can be missing, e.g. from ghc-prim
- -- TODO ???
- | not is_home
- , oe_bytecode
- -> do
- add_library
- | otherwise
- -> throwProgramError opts $
- missingInterfaceErrorDiagnostic (ldMsgOpts opts) err
- Succeeded iface
- | mi_boot iface == IsBoot
- -> throwProgramError opts $ link_boot_mod_error mod
- | oe_bytecode
- , Just core_bindings <- mi_extra_decls iface
- -> pure (add_bytecode iface (WholeCoreBindings core_bindings mod undefined))
- | is_home
- , Just home <- oe_home
- -> do
- let fc = ldFinderCache opts
- fopts = ldFinderOpts opts
- findHomeModule fc fopts home (moduleName mod) >>= \case
- Found loc _ -> do
- pure (add_home_module iface loc)
- _ ->
- throwProgramError opts $
- text "No home module for matching unit in module" <+> ppr mod
- | otherwise
- -> add_library
+ try_iface =
+ liftIO (ldLoadIface opts load_reason mod) >>= \case
+ Failed err -> throwE (NoInterface err)
+ Succeeded iface ->
+ location >>= \case
+ InstalledFound loc _ -> with_iface loc iface
+ _ -> throwE (NoLocation mod)
+
+ with_iface loc iface
+ | mi_boot iface == IsBoot
+ = throwE (LinkBootModule mod)
+ | bytecode
+ , Just core_bindings <- mi_extra_decls iface
+ , let wcb = WholeCoreBindings core_bindings mod loc
+ = pure (add_module iface (LinkByteCodeModule iface wcb))
+ | is_home
+ = pure (add_module iface (LinkObjectModule iface loc))
+ | otherwise
+ = add_library
add_library = pure (addToUDFM acc mod_unit_id (LinkLibrary mod_unit_id), [])
- add_bytecode iface core_bindings = add_module iface (LinkByteCodeModule iface core_bindings)
-
- add_home_module iface loc = add_module iface (LinkObjectModule iface loc)
-
- add_module iface lmod = (new_acc lmod, new_deps iface)
-
- new_acc iface
- | IsBoot <- is_boot
- = acc
- | otherwise
- = alterUDFM (add_package_module iface) acc mod_unit_id
+ add_module iface lmod =
+ (alterUDFM (add_package_module lmod) acc mod_unit_id, new_deps iface)
add_package_module lmod = \case
Just (LinkLibrary u) -> Just (LinkLibrary u)
@@ -385,21 +380,34 @@ oneshot_deps_loop opts (GWIB mod is_boot : mods) acc = do
Nothing -> Just (LinkModules (unitUDFM mod_name lmod))
new_deps iface
- | oe_bytecode
- = [GWIB usg_mod NotBoot | UsagePackageModule {usg_mod} <- mi_usages iface] ++ local
- | Just _ <- oe_home
+ | bytecode
+ -- TODO How can we better determine the external deps?
+ = [usg_mod | UsagePackageModule {usg_mod} <- mi_usages iface] ++ local
+ | Just _ <- mb_home
= local
| otherwise
= []
where
- local = [GWIB (mkModule mod_unit n) b | (_, GWIB n b) <- Set.toList (dep_direct_mods (mi_deps iface))]
+ local =
+ [
+ mkModule mod_unit m
+ -- TODO Somehow this just works, no idea what the deal was in the
+ -- old code with boot modules.
+ | (_, GWIB m _) <- Set.toList (dep_direct_mods (mi_deps iface))
+ ]
is_home
- | Just home <- oe_home
+ | Just home <- mb_home
= homeUnitAsUnit home == mod_unit
| otherwise
= False
+ location =
+ liftIO $
+ findExactModule (ldFinderCache opts) (ldFinderOpts opts)
+ (ldHugFinderOpts opts) (hsc_units (ldHscEnv opts)) mb_home
+ (toUnitId <$> mod)
+
mod_dep = lookupUDFM acc mod_unit_id
mod_name = moduleName mod
mod_unit_id = moduleUnitId mod
@@ -408,8 +416,8 @@ oneshot_deps_loop opts (GWIB mod is_boot : mods) acc = do
text "need to link module" <+> ppr mod <+>
text "due to use of Template Haskell"
- oe_bytecode = ldUseByteCode opts
- oe_home = ue_homeUnit (ldUnitEnv opts)
+ bytecode = ldUseByteCode opts
+ mb_home = ue_homeUnit (ldUnitEnv opts)
link_boot_mod_error :: Module -> SDoc
link_boot_mod_error mod =
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -645,6 +645,7 @@ initLinkDepsOpts hsc_env = opts
, ldPprOpts = initSDocContext dflags defaultUserStyle
, ldFinderCache = hsc_FC hsc_env
, ldFinderOpts = initFinderOpts dflags
+ , ldHugFinderOpts = initFinderOpts . homeUnitEnv_dflags <$> hsc_HUG hsc_env
, ldUseByteCode = gopt Opt_UseBytecodeRatherThanObjects dflags
, ldMsgOpts = initIfaceMessageOpts dflags
, ldWays = ways dflags
=====================================
testsuite/tests/th/cross-package/Cross.hs
=====================================
@@ -2,6 +2,7 @@
module Main where
+import GHC.Prim
import CrossLocal (splc)
a :: Int
=====================================
testsuite/tests/th/cross-package/CrossLocal.hs
=====================================
@@ -2,13 +2,15 @@
module CrossLocal where
+import GHC.Prim
import Language.Haskell.TH (ExpQ)
import Language.Haskell.TH.Syntax (lift)
-- just to be sure that the file isn't accidentally picked up locally
import "dep" CrossDepApi (dep, A (A))
-import CrossNum (num)
+import {-# source #-} CrossNum (num)
+import CrossObj (numo)
splc :: ExpQ
-splc = lift @_ @Int (num + d)
+splc = lift @_ @Int (num + d + numo)
where
A d = dep
=====================================
testsuite/tests/th/cross-package/CrossNum.hs-boot
=====================================
@@ -0,0 +1,3 @@
+module CrossNum where
+
+num :: Int
=====================================
testsuite/tests/th/cross-package/CrossObj.hs
=====================================
@@ -0,0 +1,4 @@
+module CrossObj where
+
+numo :: Int
+numo = 0
=====================================
testsuite/tests/th/cross-package/Makefile
=====================================
@@ -2,7 +2,8 @@ TOP=../../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
-BASIC := $(TEST_HC_OPTS) -this-unit-id=cross -package-db db -package dep -v0
+# TODO check error without -package obj (especially for ObjCode, it appears to fail at link time)
+BASIC := $(TEST_HC_OPTS) -this-unit-id=cross -package-db db -package dep -package obj -v0
ARGS := $(BASIC) -fprefer-byte-code -fbyte-code-and-object-code
.PHONY: CrossPackageArchive
=====================================
testsuite/tests/th/cross-package/all.T
=====================================
@@ -9,7 +9,10 @@ def cross_test(suf):
'CrossDep.hs',
'CrossDepApi.hs',
'CrossNum.hs',
+ 'CrossNum.hs-boot',
+ 'CrossObj.hs',
'dep.conf',
+ 'obj.conf',
'prep.bash',
'run.bash',
]),
=====================================
testsuite/tests/th/cross-package/obj.conf
=====================================
@@ -0,0 +1,8 @@
+name: obj
+version: 1.0
+id: obj-1.0
+key: obj-1.0
+exposed: True
+exposed-modules: CrossObj
+import-dirs: ${pkgroot}/obj
+library-dirs: ${pkgroot}/obj
=====================================
testsuite/tests/th/cross-package/prep.bash
=====================================
@@ -8,10 +8,11 @@ ghc_pkg_cmd="$3"
archive="$4"
base="$PWD"
-lib="$base/dep"
-# TODO see if this can just be stored in pwd. $lib as well
db="$base/db"
-conf="${lib}/dep.conf"
+dep="$base/dep"
+conf_dep="${dep}/dep.conf"
+obj="$base/obj"
+conf_obj="${obj}/obj.conf"
ghc_pkg()
{
@@ -23,22 +24,29 @@ ghc()
eval "${ghc_cmd at Q} $ghc_opts $@"
}
-mkdir -p "$lib" "$db"
-mv CrossDep.hs CrossDepApi.hs "$lib/"
-cp dep.conf "$lib/"
+mkdir -p "$dep" "$obj" "$db"
+mv CrossDep.hs CrossDepApi.hs "$dep/"
+cp dep.conf "$dep/"
+mv CrossObj.hs "$obj/"
+cp obj.conf "$obj/"
ghc_pkg recache
-ghc "-package-db ${db at Q} -hidir ${lib at Q} -O0 -this-unit-id dep-1.0 -fbyte-code-and-object-code -c ${lib at Q}/CrossDep.hs ${lib at Q}/CrossDepApi.hs"
+ghc "-package-db ${db at Q} -hidir ${dep at Q} -O0 -this-unit-id dep-1.0 -fbyte-code-and-object-code -c ${dep at Q}/CrossDep.hs ${dep at Q}/CrossDepApi.hs"
+
+ghc "-package-db ${db at Q} -hidir ${obj at Q} -O0 -this-unit-id obj-1.0 -c ${obj at Q}/CrossObj.hs"
+$AR cqs "${obj}/libHSobj-1.0.a" "${obj}/CrossObj.o"
+echo 'hs-libraries: HSobj-1.0' >> "$conf_obj"
if [[ "$archive" == 1 ]]
then
- $AR cqs "${lib}/libHSdep-1.0.a" "${lib}/CrossDep.o" "${lib}/CrossDepApi.o"
- echo 'hs-libraries: HSdep-1.0' >> "$conf"
+ $AR cqs "${dep}/libHSdep-1.0.a" "${dep}/CrossDep.o" "${dep}/CrossDepApi.o"
+ echo 'hs-libraries: HSdep-1.0' >> "$conf_dep"
elif [[ "$archive" == 2 ]]
then
- $AR cqs "${lib}/libHSdep-1.0.a"
- echo 'hs-libraries: HSdep-1.0' >> "$conf"
+ $AR cqs "${dep}/libHSdep-1.0.a"
+ echo 'hs-libraries: HSdep-1.0' >> "$conf_dep"
fi
-ghc_pkg -v0 register "${conf at Q}"
+ghc_pkg -v0 register "${conf_dep at Q}"
+ghc_pkg -v0 register "${conf_obj at Q}"
=====================================
testsuite/tests/th/cross-package/run.bash
=====================================
@@ -10,7 +10,7 @@ ghc()
eval "${ghc_cmd at Q} $ghc_opts $@"
}
-ghc -c CrossNum.hs CrossLocal.hs
+ghc -c CrossNum.hs-boot CrossNum.hs CrossLocal.hs
ghc -c Cross.hs
ghc Cross.o -o Cross
./Cross
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f5b6dfcb0d18e7331aa09c10700f4e1709eb3551
--
This project does not include diff previews in email notifications.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f5b6dfcb0d18e7331aa09c10700f4e1709eb3551
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/20240708/b526f31f/attachment-0001.html>
More information about the ghc-commits
mailing list