[Git][ghc/ghc][wip/torsten.schmits/oneshot-bytecode-pkgdeps] PoC for package dep hydration
Torsten Schmits (@torsten.schmits)
gitlab at gitlab.haskell.org
Thu Jul 4 14:02:41 UTC 2024
Torsten Schmits pushed to branch wip/torsten.schmits/oneshot-bytecode-pkgdeps at Glasgow Haskell Compiler / GHC
Commits:
d1f5e96f by Torsten Schmits at 2024-07-04T16:02:29+02:00
PoC for package dep hydration
- - - - -
12 changed files:
- compiler/GHC/Linker/Deps.hs
- + testsuite/tests/th/cross-package/Cross.hs
- + testsuite/tests/th/cross-package/CrossDep.hs
- + testsuite/tests/th/cross-package/CrossDepApi.hs
- + testsuite/tests/th/cross-package/CrossLocal.hs
- + testsuite/tests/th/cross-package/CrossNum.hs
- + testsuite/tests/th/cross-package/CrossPackage.stdout
- + testsuite/tests/th/cross-package/Makefile
- + testsuite/tests/th/cross-package/all.T
- + testsuite/tests/th/cross-package/dep.conf
- + testsuite/tests/th/cross-package/prep.bash
- + testsuite/tests/th/cross-package/run.bash
Changes:
=====================================
compiler/GHC/Linker/Deps.hs
=====================================
@@ -58,8 +58,6 @@ import System.Directory
import GHC.Driver.Env
import {-# SOURCE #-} GHC.Driver.Main
import Data.Time.Clock
-import GHC.Driver.Flags
-import GHC.Driver.Session
data LinkDepsOpts = LinkDepsOpts
@@ -211,16 +209,22 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
-> UniqDSet Module -- accum. module dependencies
-> UniqDSet UnitId -- accum. package dependencies
-> IO ([Module], UniqDSet UnitId) -- result
- follow_deps [] acc_mods acc_pkgs
- = return (uniqDSetToList acc_mods, acc_pkgs)
- follow_deps (mod:mods) acc_mods acc_pkgs
- = do
- mb_iface <- ldLoadIface opts msg mod
- iface <- case mb_iface of
- Failed err -> throwProgramError opts $
- missingInterfaceErrorDiagnostic (ldMsgOpts opts) err
- Succeeded iface -> return iface
-
+ follow_deps [] acc_mods acc_pkgs =
+ pure (uniqDSetToList acc_mods, acc_pkgs)
+ follow_deps (mod : mods) acc_mods acc_pkgs = do
+ ldLoadIface opts msg mod >>= \case
+ Failed err
+ | ldUseByteCode opts
+ -> follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs (moduleUnitId mod))
+ | otherwise
+ -> throwProgramError opts $
+ missingInterfaceErrorDiagnostic (ldMsgOpts opts) err
+ Succeeded iface -> follow_deps_iface iface mod mods acc_mods acc_pkgs
+ where
+ msg = text "need to link module" <+> ppr mod <+>
+ text "due to use of Template Haskell"
+
+ follow_deps_iface iface mod mods acc_mods acc_pkgs = do
when (mi_boot iface == IsBoot) $ link_boot_mod_error mod
let
@@ -228,28 +232,43 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
deps = mi_deps iface
pkg_deps = dep_direct_pkgs deps
- (boot_deps, mod_deps) = flip partitionWith (Set.toList (dep_direct_mods deps)) $
+ (boot_deps_home, mod_deps_home) = flip partitionWith (Set.toList (dep_direct_mods deps)) $
\case
- (_, GWIB m IsBoot) -> Left m
- (_, GWIB m NotBoot) -> Right m
+ (_, GWIB m IsBoot) -> Left (mkModule pkg m)
+ (_, GWIB m NotBoot) -> Right (mkModule pkg m)
- mod_deps' = case ue_homeUnit unit_env of
- Nothing -> []
- Just home_unit -> filter (not . (`elementOfUniqDSet` acc_mods)) (map (mkHomeModule home_unit) $ (boot_deps ++ mod_deps))
- acc_mods' = case ue_homeUnit unit_env of
- Nothing -> acc_mods
- Just home_unit -> addListToUniqDSet acc_mods (mod : map (mkHomeModule home_unit) mod_deps)
- acc_pkgs' = addListToUniqDSet acc_pkgs (Set.toList pkg_deps)
+ has_core_bindings = isJust (mi_extra_decls iface)
- case ue_homeUnit unit_env of
- Just home_unit | isHomeUnit home_unit pkg -> follow_deps (mod_deps' ++ mods)
- acc_mods' acc_pkgs'
- _ -> follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg))
- where
- msg = text "need to link module" <+> ppr mod <+>
- text "due to use of Template Haskell"
+ acc_pkgs'
+ | ldUseByteCode opts
+ = if has_core_bindings
+ then acc_pkgs
+ else addOneToUniqDSet acc_pkgs (moduleUnitId mod)
+ | otherwise
+ = addListToUniqDSet acc_pkgs (Set.toList pkg_deps)
+ mod_deps_pkg
+ | ldUseByteCode opts
+ = [usg_mod | UsagePackageModule {usg_mod} <- mi_usages iface]
+ | otherwise
+ = []
+ mod_deps' = filterOut (`elementOfUniqDSet` acc_mods) (boot_deps_home ++ mod_deps_home ++ mod_deps_pkg)
+
+ acc_mods'
+ | ldUseByteCode opts
+ = addOneToUniqDSet acc_mods mod
+ | otherwise
+ = addListToUniqDSet acc_mods (mod : mod_deps')
+
+ case ue_homeUnit unit_env of
+ _ | ldUseByteCode opts && has_core_bindings ->
+ follow_deps (mod_deps' ++ mods) acc_mods' acc_pkgs'
+ Just home_unit | isHomeUnit home_unit pkg ->
+ follow_deps (mod_deps' ++ mods) acc_mods' acc_pkgs'
+ _ ->
+ follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg))
+ where
link_boot_mod_error :: Module -> IO a
link_boot_mod_error mod = throwProgramError opts $
@@ -287,29 +306,28 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
mb_stuff <- findHomeModule fc fopts home_unit (moduleName mod)
case mb_stuff of
Found loc mod -> found loc mod
- _ -> no_obj (moduleName mod)
+ _ | ldUseByteCode opts -> hydrate (no_obj mod) mod
+ | otherwise -> no_obj (moduleName mod)
where
found loc mod
- | prefer_bytecode = do
- Succeeded iface <- ldLoadIface opts (text "makima") mod
- case mi_extra_decls iface of
- Just extra_decls -> do
- details <- initModDetails hsc_env iface
- t <- getCurrentTime
- initWholeCoreBindings hsc_env iface details $ LM t mod [CoreBindings $ WholeCoreBindings extra_decls mod undefined]
- _ -> fallback_no_bytecode loc mod
+ | ldUseByteCode opts = hydrate (fallback_no_bytecode loc mod) mod
| otherwise = fallback_no_bytecode loc mod
+ hydrate alt mod = do
+ Succeeded iface <- ldLoadIface opts (text "makima") mod
+ case mi_extra_decls iface of
+ Just extra_decls -> do
+ details <- initModDetails hsc_env iface
+ t <- getCurrentTime
+ initWholeCoreBindings hsc_env iface details $ LM t mod [CoreBindings $ WholeCoreBindings extra_decls mod undefined]
+ _ -> alt
+
fallback_no_bytecode loc mod = do
mb_lnk <- findObjectLinkableMaybe mod loc
case mb_lnk of
Nothing -> no_obj mod
Just lnk -> adjust_linkable lnk
- prefer_bytecode = gopt Opt_UseBytecodeRatherThanObjects dflags
-
- dflags = hsc_dflags hsc_env
-
hsc_env = ldHscEnv opts
adjust_linkable lnk
=====================================
testsuite/tests/th/cross-package/Cross.hs
=====================================
@@ -0,0 +1,11 @@
+{-# language TemplateHaskell #-}
+
+module Main where
+
+import CrossLocal (splc)
+
+a :: Int
+a = $(splc)
+
+main :: IO ()
+main = putStrLn (show a)
=====================================
testsuite/tests/th/cross-package/CrossDep.hs
=====================================
@@ -0,0 +1,15 @@
+module CrossDep where
+
+data A = A Int
+
+used :: Int
+used = 9681
+
+dep :: A
+dep = A used
+
+unused1 :: A
+unused1 = A 1
+
+unused2 :: A
+unused2 = unused1
=====================================
testsuite/tests/th/cross-package/CrossDepApi.hs
=====================================
@@ -0,0 +1,7 @@
+module CrossDepApi (A (A), dep) where
+
+import CrossDep (A (A))
+import qualified CrossDep
+
+dep :: A
+dep = CrossDep.dep
=====================================
testsuite/tests/th/cross-package/CrossLocal.hs
=====================================
@@ -0,0 +1,14 @@
+{-# language PackageImports #-}
+
+module CrossLocal where
+
+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)
+
+splc :: ExpQ
+splc = lift @_ @Int (num + d)
+ where
+ A d = dep
=====================================
testsuite/tests/th/cross-package/CrossNum.hs
=====================================
@@ -0,0 +1,4 @@
+module CrossNum where
+
+num :: Int
+num = 48332
=====================================
testsuite/tests/th/cross-package/CrossPackage.stdout
=====================================
@@ -0,0 +1 @@
+58013
=====================================
testsuite/tests/th/cross-package/Makefile
=====================================
@@ -0,0 +1,20 @@
+TOP=../../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+ARGS := $(TEST_HC_OPTS) -package-db db -fprefer-byte-code -fbyte-code-and-object-code -package dep -v0
+
+.PHONY: CrossPackageArchive
+CrossPackageArchive:
+ ./prep.bash "$(TEST_HC)" "$(TEST_HC_OPTS)" "$(GHC_PKG)" 1
+ ./run.bash "$(TEST_HC)" "$(ARGS)"
+
+.PHONY: CrossPackageEmptyArchive
+CrossPackageEmptyArchive:
+ ./prep.bash "$(TEST_HC)" " $(TEST_HC_OPTS)" "$(GHC_PKG)" 2
+ ./run.bash "$(TEST_HC)" "$(ARGS)"
+
+.PHONY: CrossPackageNoArchive
+CrossPackageNoArchive:
+ ./prep.bash "$(TEST_HC)" " $(TEST_HC_OPTS)" "$(GHC_PKG)" 3
+ ./run.bash "$(TEST_HC)" "$(ARGS)"
=====================================
testsuite/tests/th/cross-package/all.T
=====================================
@@ -0,0 +1,23 @@
+def cross_test(suf):
+ name = f'CrossPackage{suf}'
+ test(
+ name,
+ [
+ extra_files([
+ 'Cross.hs',
+ 'CrossLocal.hs',
+ 'CrossDep.hs',
+ 'CrossDepApi.hs',
+ 'CrossNum.hs',
+ 'dep.conf',
+ 'prep.bash',
+ 'run.bash',
+ ]),
+ ],
+ makefile_test,
+ [name],
+ )
+
+cross_test('Archive')
+cross_test('EmptyArchive')
+cross_test('NoArchive')
=====================================
testsuite/tests/th/cross-package/dep.conf
=====================================
@@ -0,0 +1,8 @@
+name: dep
+version: 1.0
+id: dep-1.0
+key: dep-1.0
+exposed: True
+exposed-modules: CrossDepApi
+import-dirs: ${pkgroot}/dep
+library-dirs: ${pkgroot}/dep
=====================================
testsuite/tests/th/cross-package/prep.bash
=====================================
@@ -0,0 +1,44 @@
+#!/usr/bin/env bash
+
+set -eu
+
+ghc_cmd="$1"
+ghc_opts="$2"
+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"
+
+ghc_pkg()
+{
+ eval "${ghc_pkg_cmd at Q} --no-user-package-db --package-db=${db at Q} $@"
+}
+
+ghc()
+{
+ eval "${ghc_cmd at Q} $ghc_opts $@"
+}
+
+mkdir -p "$lib" "$db"
+mv CrossDep.hs CrossDepApi.hs "$lib/"
+cp dep.conf "$lib/"
+
+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"
+
+if [[ "$archive" == 1 ]]
+then
+ $AR cqs "${lib}/libHSdep-1.0.a" "${lib}/CrossDep.o" "${lib}/CrossDepApi.o"
+ echo 'hs-libraries: HSdep-1.0' >> "$conf"
+elif [[ "$archive" == 2 ]]
+then
+ $AR cqs "${lib}/libHSdep-1.0.a"
+ echo 'hs-libraries: HSdep-1.0' >> "$conf"
+fi
+
+ghc_pkg -v0 register "${conf at Q}"
=====================================
testsuite/tests/th/cross-package/run.bash
=====================================
@@ -0,0 +1,16 @@
+#!/usr/bin/env bash
+
+set -eu
+
+ghc_cmd="$1"
+ghc_opts="$2"
+
+ghc()
+{
+ eval "${ghc_cmd at Q} $ghc_opts $@"
+}
+
+ghc -c 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/d1f5e96fc6de619f7842786fcab63314fe79d0e2
--
This project does not include diff previews in email notifications.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d1f5e96fc6de619f7842786fcab63314fe79d0e2
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/20240704/25417f7e/attachment-0001.html>
More information about the ghc-commits
mailing list