[Git][ghc/ghc][wip/torsten.schmits/package-deps-bytecode-2024-09-23] Package deps bytecode linking

Torsten Schmits (@torsten.schmits) gitlab at gitlab.haskell.org
Mon Sep 23 19:02:48 UTC 2024



Torsten Schmits pushed to branch wip/torsten.schmits/package-deps-bytecode-2024-09-23 at Glasgow Haskell Compiler / GHC


Commits:
56f3fbe9 by Torsten Schmits at 2024-09-23T21:02:37+02:00
Package deps bytecode linking

- - - - -


20 changed files:

- compiler/GHC/Iface/Load.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Unit/Finder.hs
- + testsuite/tests/bytecode/T25090/Dep.hs
- + testsuite/tests/bytecode/T25090/DepApi.hs
- + testsuite/tests/bytecode/T25090/Local.hs
- testsuite/tests/bytecode/T25090/Makefile
- + testsuite/tests/bytecode/T25090/Num.hs
- + testsuite/tests/bytecode/T25090/Num.hs-boot
- + testsuite/tests/bytecode/T25090/Obj.hs
- + testsuite/tests/bytecode/T25090/PkgBytecode.hs
- + testsuite/tests/bytecode/T25090/PkgBytecode.stdout
- testsuite/tests/bytecode/T25090/all.T
- + testsuite/tests/bytecode/T25090/dep.conf
- + testsuite/tests/bytecode/T25090/obj.conf
- + testsuite/tests/bytecode/T25090/prep.bash
- + testsuite/tests/bytecode/T25090/run.bash
- + testsuite/tests/bytecode/T25090/unit1
- + testsuite/tests/bytecode/T25090/unit2


Changes:

=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -674,7 +674,11 @@ dontLeakTheHUG thing_inside = do
        in
        hsc_env {  hsc_targets      = panic "cleanTopEnv: hsc_targets"
                ,  hsc_mod_graph    = panic "cleanTopEnv: hsc_mod_graph"
-               ,  hsc_IC           = panic "cleanTopEnv: hsc_IC"
+               -- TODO this is needed for bytecode compilation of package deps
+               -- only. local EPS modules work fine.
+               -- Also it appears to work when the local modules use multiple
+               -- home units?!?!?
+               -- ,  hsc_IC           = panic "cleanTopEnv: hsc_IC"
                ,  hsc_type_env_vars = case maybe_type_vars of
                                           Just vars -> vars
                                           Nothing -> panic "cleanTopEnv: hsc_type_env_vars"


=====================================
compiler/GHC/Linker/Deps.hs
=====================================
@@ -6,6 +6,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
 
 module GHC.Linker.Deps
   ( LinkDepsOpts (..)
@@ -28,6 +29,7 @@ import GHC.Types.Unique.DSet
 import GHC.Types.Unique.DFM
 
 import GHC.Utils.Outputable
+import qualified GHC.Utils.Outputable as Outputable
 import GHC.Utils.Panic
 import GHC.Utils.Error
 
@@ -47,9 +49,11 @@ import GHC.Utils.Misc
 import GHC.Unit.Home
 import GHC.Data.Maybe
 
-import Control.Monad
 import Control.Applicative
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
 
+import Data.Foldable (traverse_)
 import qualified Data.Set as Set
 import qualified Data.Map as M
 import Data.List (isSuffixOf)
@@ -68,15 +72,16 @@ data LinkDepsOpts = LinkDepsOpts
   , ldWays        :: !Ways                          -- ^ Enabled ways
   , ldFinderCache :: !FinderCache
   , ldFinderOpts  :: !FinderOpts
-  , ldLoadIface   :: !(SDoc -> Module -> IO (MaybeErr MissingInterfaceError ModIface))
-  , ldLoadByteCode :: !(Module -> IO (Maybe Linkable))
+  , ldLoadIface :: !(SDoc -> Module -> IO (MaybeErr MissingInterfaceError (ModIface, ModLocation)))
+  , ldLoadByteCode :: !(Module -> IO (Maybe (IO Linkable)))
+  , ldDebugTrace :: !(SDoc -> IO ())
   }
 
 data LinkDeps = LinkDeps
   { ldNeededLinkables :: [Linkable]
   , ldAllLinkables    :: [Linkable]
-  , ldUnits           :: [UnitId]
-  , ldNeededUnits     :: UniqDSet UnitId
+  , ldNeededUnits     :: [UnitId]
+  , ldAllUnits        :: UniqDSet UnitId
   }
 
 -- | Find all the packages and linkables that a set of modules depends on
@@ -102,7 +107,6 @@ getLinkDeps opts interp pls span mods = do
 
       get_link_deps opts pls maybe_normal_osuf span mods
 
-
 get_link_deps
   :: LinkDepsOpts
   -> LoaderState
@@ -111,47 +115,48 @@ get_link_deps
   -> [Module]
   -> IO LinkDeps
 get_link_deps opts pls maybe_normal_osuf span mods = do
-        -- 1.  Find the dependent home-pkg-modules/packages from each iface
-        -- (omitting modules from the interactive package, which is already linked)
-      (mods_s, pkgs_s) <-
-          -- Why two code paths here? There is a significant amount of repeated work
-          -- performed calculating transitive dependencies
-          -- if --make uses the oneShot code path (see MultiLayerModulesTH_* tests)
-          if ldOneShotMode opts
-            then follow_deps (filterOut isInteractiveModule mods)
-                              emptyUniqDSet emptyUniqDSet;
-            else do
-              (pkgs, mmods) <- unzip <$> mapM get_mod_info all_home_mods
-              return (catMaybes mmods, unionManyUniqDSets (init_pkg_set : pkgs))
-
-      let
-        -- 2.  Exclude ones already linked
-        --      Main reason: avoid findModule calls in get_linkable
-            (mods_needed, links_got) = partitionWith split_mods mods_s
-            pkgs_needed = eltsUDFM $ getUniqDSet pkgs_s `minusUDFM` pkgs_loaded pls
-
-            split_mods mod =
-                let is_linked = lookupModuleEnv (objs_loaded pls) mod
-                                <|> lookupModuleEnv (bcos_loaded pls) mod
-                in case is_linked of
-                     Just linkable -> Right linkable
-                     Nothing -> Left mod
-
-        -- 3.  For each dependent module, find its linkable
-        --     This will either be in the HPT or (in the case of one-shot
-        --     compilation) we may need to use maybe_getFileLinkable
-      lnks_needed <- mapM (get_linkable (ldObjSuffix opts)) mods_needed
-
-      return $ LinkDeps
-        { ldNeededLinkables = lnks_needed
-        , ldAllLinkables    = links_got ++ lnks_needed
-        , ldUnits           = pkgs_needed
-        , ldNeededUnits     = pkgs_s
-        }
+  -- 1.  Find the dependent home-pkg-modules/packages from each iface
+  --     (omitting modules from the interactive package, which is already linked)
+  --     Why two code paths here? There is a significant amount of repeated work
+  --     performed calculating transitive dependencies
+  --     if --make uses the oneShot code path (see MultiLayerModulesTH_* tests)
+  deps <- if ldOneShotMode opts
+          then oneshot_deps opts (filterOut isInteractiveModule mods)
+          else make_deps
+
+  -- 2.  Exclude ones already linked
+  --     Main reason: avoid findModule calls in get_linkable
+  -- TODO outdated
+  let (loaded_modules, needed_modules, ldAllUnits, ldNeededUnits) =
+        classify_deps pls deps
+
+  -- 3.  For each dependent module, find its linkable
+  --     This will either be in the HPT or (in the case of one-shot
+  --     compilation) we may need to use maybe_getFileLinkable
+  -- TODO outdated
+  ldNeededLinkables <- mapM module_linkable needed_modules
+
+  pure LinkDeps {
+    ldNeededLinkables,
+    ldAllLinkables = loaded_modules ++ ldNeededLinkables,
+    ldNeededUnits,
+    ldAllUnits
+  }
   where
     mod_graph = ldModuleGraph opts
     unit_env  = ldUnitEnv     opts
 
+    make_deps = do
+      (pkgs, mmods) <- unzip <$> mapM get_mod_info all_home_mods
+      let
+        link_mods =
+          listToUDFM [(moduleName (mi_module (hm_iface m)), m) | m <- mmods]
+        link_libs =
+          uniqDSetToList (unionManyUniqDSets (init_pkg_set : pkgs))
+      pure $
+        LinkModules (LinkHomeModule <$> link_mods) :
+        (LinkLibrary <$> link_libs)
+
     -- This code is used in `--make` mode to calculate the home package and unit dependencies
     -- for a set of modules.
     --
@@ -183,73 +188,14 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
 
     get_mod_info (ModNodeKeyWithUid gwib uid) =
       case lookupHug (ue_home_unit_graph unit_env) uid (gwib_mod gwib) of
-        Just hmi ->
-          let iface = (hm_iface hmi)
-              mmod = case mi_hsc_src iface of
-                      HsBootFile -> link_boot_mod_error (mi_module iface)
-                      _          -> return $ Just (mi_module iface)
-
-          in (mkUniqDSet $ Set.toList $ dep_direct_pkgs (mi_deps iface),) <$>  mmod
+        Just hmi -> do
+          let iface = hm_iface hmi
+          case mi_hsc_src iface of
+            HsBootFile -> throwProgramError opts $ link_boot_mod_error (mi_module iface)
+            _ -> pure (mkUniqDSet $ Set.toList $ dep_direct_pkgs (mi_deps iface), hmi)
         Nothing -> throwProgramError opts $
           text "getLinkDeps: Home module not loaded" <+> ppr (gwib_mod gwib) <+> ppr uid
 
-
-       -- This code is used in one-shot mode to traverse downwards through the HPT
-       -- to find all link dependencies.
-       -- The ModIface contains the transitive closure of the module dependencies
-       -- within the current package, *except* for boot modules: if we encounter
-       -- a boot module, we have to find its real interface and discover the
-       -- dependencies of that.  Hence we need to traverse the dependency
-       -- tree recursively.  See bug #936, testcase ghci/prog007.
-    follow_deps :: [Module]             -- modules to follow
-                -> 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
-
-          when (mi_boot iface == IsBoot) $ link_boot_mod_error mod
-
-          let
-            pkg = moduleUnit mod
-            deps  = mi_deps iface
-
-            pkg_deps = dep_direct_pkgs deps
-            (boot_deps, mod_deps) = flip partitionWith (Set.toList (dep_direct_mods deps)) $
-              \case
-                (_, GWIB m IsBoot)  -> Left m
-                (_, GWIB m NotBoot) -> Right 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)
-
-          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"
-
-
-
-    link_boot_mod_error :: Module -> IO a
-    link_boot_mod_error mod = throwProgramError opts $
-            text "module" <+> ppr mod <+>
-            text "cannot be linked; it is only available as a boot module"
-
     no_obj :: Outputable a => a -> IO b
     no_obj mod = dieWith opts span $
                      text "cannot find object file for module " <>
@@ -258,6 +204,18 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
 
     while_linking_expr = text "while linking an interpreted expression"
 
+    module_linkable = \case
+      LinkHomeModule hmi ->
+        adjust_linkable (expectJust "getLinkDeps" (homeModLinkable hmi))
+
+      LinkObjectModule iface loc -> do
+        let mod = mi_module iface
+        findObjectLinkableMaybe mod loc >>= \case
+          Nothing  -> no_obj mod
+          Just lnk -> adjust_linkable lnk
+
+      LinkByteCodeModule _ load_bytecode ->
+        load_bytecode
 
     -- See Note [Using Byte Code rather than Object Code for Template Haskell]
     homeModLinkable :: HomeModInfo -> Maybe Linkable
@@ -266,57 +224,256 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
         then homeModInfoByteCode hmi <|> homeModInfoObject hmi
         else homeModInfoObject hmi   <|> homeModInfoByteCode hmi
 
-    get_linkable osuf mod      -- A home-package module
-        | Just mod_info <- lookupHugByModule mod (ue_home_unit_graph unit_env)
-        = adjust_linkable (expectJust "getLinkDeps" (homeModLinkable mod_info))
-        | otherwise
-        = do    -- It's not in the HPT because we are in one shot mode,
-                -- so use the Finder to get a ModLocation...
-             case ue_homeUnit unit_env of
-              Nothing -> no_obj mod
-              Just home_unit -> do
-                from_bc <- ldLoadByteCode opts mod
-                maybe (fallback_no_bytecode home_unit mod) pure from_bc
-        where
-
-            fallback_no_bytecode home_unit mod = do
-              let fc = ldFinderCache opts
-              let fopts = ldFinderOpts opts
-              mb_stuff <- findHomeModule fc fopts home_unit (moduleName mod)
-              case mb_stuff of
-                Found loc _ -> do
-                  mb_lnk <- findObjectLinkableMaybe mod loc
-                  case mb_lnk of
-                    Nothing  -> no_obj mod
-                    Just lnk -> adjust_linkable lnk
-                _ -> no_obj (moduleName mod)
-
-            adjust_linkable lnk
-                | Just new_osuf <- maybe_normal_osuf = do
-                        new_parts <- mapM (adjust_part new_osuf)
-                                        (linkableParts lnk)
-                        return lnk{ linkableParts=new_parts }
-                | otherwise =
-                        return lnk
-
-            adjust_part new_osuf part = case part of
-              DotO file ModuleObject -> do
-                massert (osuf `isSuffixOf` file)
-                let file_base = fromJust (stripExtension osuf file)
-                    new_file = file_base <.> new_osuf
-                ok <- doesFileExist new_file
-                if (not ok)
-                   then dieWith opts span $
-                          text "cannot find object file "
-                                <> quotes (text new_file) $$ while_linking_expr
-                   else return (DotO new_file ModuleObject)
-              DotO file ForeignObject -> pure (DotO file ForeignObject)
-              DotA fp    -> panic ("adjust_ul DotA " ++ show fp)
-              DotDLL fp  -> panic ("adjust_ul DotDLL " ++ show fp)
-              BCOs {}    -> pure part
-              LazyBCOs{} -> pure part
-              CoreBindings WholeCoreBindings {wcb_module} ->
-                pprPanic "Unhydrated core bindings" (ppr wcb_module)
+    adjust_linkable lnk
+        | Just new_osuf <- maybe_normal_osuf = do
+                new_uls <- mapM (adjust_part (ldObjSuffix opts) new_osuf)
+                                (linkableParts lnk)
+                return lnk {linkableParts = new_uls}
+        | otherwise =
+                return lnk
+
+    adjust_part osuf new_osuf part = case part of
+      DotO file ModuleObject -> do
+        massert (osuf `isSuffixOf` file)
+        let file_base = fromJust (stripExtension osuf file)
+            new_file = file_base <.> new_osuf
+        ok <- doesFileExist new_file
+        if (not ok)
+            then dieWith opts span $
+                  text "cannot find object file "
+                        <> quotes (text new_file) $$ while_linking_expr
+            else return (DotO new_file ModuleObject)
+      DotO file ForeignObject -> pure (DotO file ForeignObject)
+      DotA fp    -> panic ("adjust_part DotA " ++ show fp)
+      DotDLL fp  -> panic ("adjust_part DotDLL " ++ show fp)
+      BCOs {}    -> pure part
+      LazyBCOs{} -> pure part
+      CoreBindings WholeCoreBindings {wcb_module} ->
+        pprPanic "Unhydrated core bindings" (ppr wcb_module)
+
+    -- get_linkable osuf mod      -- A home-package module
+    --     | Just mod_info <- lookupHugByModule mod (ue_home_unit_graph unit_env)
+    --     = adjust_linkable (expectJust "getLinkDeps" (homeModLinkable mod_info))
+    --     | otherwise
+    --     = do    -- It's not in the HPT because we are in one shot mode,
+    --             -- so use the Finder to get a ModLocation...
+    --          case ue_homeUnit unit_env of
+    --           Nothing -> no_obj mod
+    --           Just home_unit -> do
+    --             from_bc <- ldLoadByteCode opts mod
+    --             maybe (fallback_no_bytecode home_unit mod) pure from_bc
+    --     where
+    --
+    --         fallback_no_bytecode home_unit mod = do
+    --           let fc = ldFinderCache opts
+    --           let fopts = ldFinderOpts opts
+    --           mb_stuff <- findHomeModule fc fopts home_unit (moduleName mod)
+    --           case mb_stuff of
+    --             Found loc _ -> do
+    --               mb_lnk <- findObjectLinkableMaybe mod loc
+    --               case mb_lnk of
+    --                 Nothing  -> no_obj mod
+    --                 Just lnk -> adjust_linkable lnk
+    --             _ -> no_obj (moduleName mod)
+
+data LinkModule =
+  LinkHomeModule HomeModInfo
+  |
+  LinkObjectModule ModIface ModLocation
+  |
+  LinkByteCodeModule ModIface (IO Linkable)
+
+link_module_iface :: LinkModule -> ModIface
+link_module_iface = \case
+  LinkHomeModule hmi -> hm_iface hmi
+  LinkObjectModule iface _ -> iface
+  LinkByteCodeModule iface _ -> iface
+
+instance Outputable LinkModule where
+  ppr = \case
+    LinkHomeModule hmi -> ppr (mi_module (hm_iface hmi)) <+> brackets (text "HMI")
+    LinkObjectModule iface _ -> ppr (mi_module iface)
+    LinkByteCodeModule iface _ -> ppr (mi_module iface) <+> brackets (text "BC")
+
+data LinkDep =
+  LinkModules (UniqDFM ModuleName LinkModule)
+  |
+  LinkLibrary UnitId
+
+instance Outputable LinkDep where
+  ppr = \case
+    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.
+-- The ModIface contains the transitive closure of the module dependencies
+-- within the current package, *except* for boot modules: if we encounter
+-- a boot module, we have to find its real interface and discover the
+-- dependencies of that.  Hence we need to traverse the dependency
+-- tree recursively.  See bug #936, testcase ghci/prog007.
+oneshot_deps ::
+  LinkDepsOpts ->
+  -- | Modules whose imports to follow
+  [Module] ->
+  IO [LinkDep]
+oneshot_deps opts mods =
+  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 ->
+  [Module] ->
+  UniqDFM UnitId LinkDep ->
+  ExceptT OneshotError IO (UniqDFM UnitId LinkDep)
+oneshot_deps_loop _ [] acc =
+  pure acc
+oneshot_deps_loop opts (mod : mods) acc = do
+  (new_acc, new_mods, action) <- process_module
+  traverse_ debug_log action
+  oneshot_deps_loop opts (new_mods ++ mods) new_acc
+  where
+    debug_log action =
+      liftIO $ ldDebugTrace opts $
+      text "TH dep" <+> ppr mod <+> brackets (sep [
+        if is_home then text "home" else Outputable.empty,
+        text action
+      ])
+
+    process_module
+      | already_seen = pure (acc, [], Nothing)
+      | is_home || bytecode = try_iface
+      | otherwise = add_library
+
+    already_seen
+      | Just (LinkModules mods) <- mod_dep
+      = elemUDFM mod_name mods
+      | Just (LinkLibrary _) <- mod_dep
+      = True
+      | otherwise
+      = False
+
+    try_iface =
+      liftIO (ldLoadIface opts load_reason mod) >>= \case
+        Failed err -> throwE (NoInterface err)
+        Succeeded (iface, loc) -> do
+          mb_load_bc <- liftIO (ldLoadByteCode opts (mi_module iface))
+          with_iface loc iface mb_load_bc
+
+    with_iface loc iface mb_load_bc
+      | IsBoot <- mi_boot iface
+      = throwE (LinkBootModule mod)
+
+      | bytecode
+      , Just load_bc <- mb_load_bc
+      = pure (add_module iface (LinkByteCodeModule iface load_bc) "bytecode")
+
+      | is_home
+      = pure (add_module iface (LinkObjectModule iface loc) "object")
+
+      | otherwise
+      = add_library
+
+    add_library =
+      pure (addToUDFM acc mod_unit_id (LinkLibrary mod_unit_id), [], Just "library")
+
+    add_module iface lmod action =
+      (addListToUDFM with_mod (direct_pkgs iface), new_deps iface, Just action)
+      where
+        with_mod = alterUDFM (add_package_module lmod) acc mod_unit_id
+
+    add_package_module lmod = \case
+      Just (LinkLibrary u) -> Just (LinkLibrary u)
+      Just (LinkModules old) -> Just (LinkModules (addToUDFM old mod_name lmod))
+      Nothing -> Just (LinkModules (unitUDFM mod_name lmod))
+
+    direct_pkgs iface
+      | bytecode
+      = []
+      | otherwise
+      = [(u, LinkLibrary u) | u <- Set.toList (dep_direct_pkgs (mi_deps iface))]
+
+    new_deps iface
+      | bytecode
+      -- TODO How can we better determine the external deps?
+      = [usg_mod | UsagePackageModule {usg_mod} <- mi_usages iface] ++ local
+      | is_home
+      = local
+      | otherwise
+      = []
+      where
+        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 <- mb_home
+      = homeUnitAsUnit home == mod_unit
+      | otherwise
+      = False
+
+    mod_dep = lookupUDFM acc mod_unit_id
+    mod_name = moduleName mod
+    mod_unit_id = moduleUnitId mod
+    mod_unit = moduleUnit mod
+    load_reason =
+      text "need to link module" <+> ppr mod <+>
+      text "due to use of Template Haskell"
+
+    bytecode = ldUseByteCode opts
+    mb_home = ue_homeUnit (ldUnitEnv opts)
+
+link_boot_mod_error :: Module -> SDoc
+link_boot_mod_error mod =
+  text "module" <+> ppr mod <+>
+  text "cannot be linked; it is only available as a boot module"
+
+classify_deps ::
+  LoaderState ->
+  [LinkDep] ->
+  ([Linkable], [LinkModule], UniqDSet UnitId, [UnitId])
+classify_deps pls deps =
+  (loaded_modules, needed_modules, all_packages, needed_packages)
+  where
+    (loaded_modules, needed_modules) =
+      partitionWith loaded_or_needed (concatMap eltsUDFM modules)
+
+    needed_packages =
+      eltsUDFM (getUniqDSet all_packages `minusUDFM` pkgs_loaded pls)
+
+    all_packages = mkUniqDSet packages
+
+    (modules, packages) = flip partitionWith deps $ \case
+      LinkModules mods -> Left mods
+      LinkLibrary lib -> Right lib
+
+    loaded_or_needed lm =
+      maybe (Right lm) Left (loaded_linkable (mi_module (link_module_iface lm)))
+
+    loaded_linkable mod =
+      lookupModuleEnv (objs_loaded pls) mod
+      <|>
+      lookupModuleEnv (bcos_loaded pls) mod
 
 {-
 Note [Using Byte Code rather than Object Code for Template Haskell]


=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -77,11 +77,13 @@ import GHC.Utils.TmpFs
 
 import GHC.Unit.Env
 import GHC.Unit.External (ExternalPackageState (EPS, eps_iface_bytecode))
+import GHC.Unit.Finder
 import GHC.Unit.Module
 import GHC.Unit.State as Packages
 
 import qualified GHC.Data.ShortText as ST
 import GHC.Data.FastString
+import qualified GHC.Data.Maybe as Maybe
 
 import GHC.Linker.Deps
 import GHC.Linker.MacOS
@@ -94,6 +96,7 @@ import Control.Monad
 import qualified Data.Set as Set
 import Data.Char (isSpace)
 import qualified Data.Foldable as Foldable
+import Data.Functor ((<&>))
 import Data.IORef
 import Data.List (intercalate, isPrefixOf, nub, partition)
 import Data.Maybe
@@ -231,10 +234,10 @@ loadDependencies interp hsc_env pls span needed_mods = do
    -- Find what packages and linkables are required
    deps <- getLinkDeps opts interp pls span needed_mods
 
-   let this_pkgs_needed = ldNeededUnits deps
+   let this_pkgs_needed = ldAllUnits deps
 
    -- Link the packages and modules required
-   pls1 <- loadPackages' interp hsc_env (ldUnits deps) pls
+   pls1 <- loadPackages' interp hsc_env (ldNeededUnits deps) pls
    (pls2, succ) <- loadModuleLinkables interp hsc_env pls1 (ldNeededLinkables deps)
    let this_pkgs_loaded = udfmRestrictKeys all_pkgs_loaded $ getUniqDSet trans_pkgs_needed
        all_pkgs_loaded = pkgs_loaded pls2
@@ -645,19 +648,40 @@ 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
             , ldLoadIface
             , ldLoadByteCode
+            , ldDebugTrace = debugTraceMsg (hsc_logger hsc_env) 3
             }
     dflags = hsc_dflags hsc_env
-    ldLoadIface msg mod = initIfaceCheck (text "loader") hsc_env
-                          $ loadInterface msg mod (ImportByUser NotBoot)
+
+    ldLoadIface msg mod =
+      initIfaceCheck (text "loader") hsc_env (loadInterface msg mod (ImportByUser NotBoot)) >>= \case
+        Maybe.Failed err -> pure (Maybe.Failed err)
+        Maybe.Succeeded iface ->
+          find_location mod <&> \case
+            InstalledFound loc _ -> Maybe.Succeeded (iface, loc)
+            err -> Maybe.Failed $
+                   cannotFindInterface unit_state home_unit
+                   (targetProfile dflags) (moduleName mod) err
+
+    find_location mod =
+      liftIO $
+      findExactModule (hsc_FC hsc_env) (initFinderOpts dflags)
+      (initFinderOpts . homeUnitEnv_dflags <$> hsc_HUG hsc_env)
+      unit_state home_unit
+      (toUnitId <$> mod)
+
+    unit_state = hsc_units hsc_env
+
+    home_unit = ue_homeUnit (hsc_unit_env hsc_env)
 
     ldLoadByteCode mod = do
       EPS {eps_iface_bytecode} <- hscEPS hsc_env
-      sequence (lookupModuleEnv eps_iface_bytecode mod)
+      pure (lookupModuleEnv eps_iface_bytecode mod)
 
 
 
@@ -1347,6 +1371,14 @@ locateLib interp hsc_env is_hs lib_dirs gcc_dirs lib0
   | loading_dynamic_hs_libs -- search for .so libraries first.
   = findHSDll     `orElse`
     findDynObject `orElse`
+    -- TODO Added the next two because static archives would be ignored when
+    -- linking bytecode.
+    -- Not sure if this is expected, but the condition for this branch is just
+    -- that ghc is _capable_ of dynamic linking, so maybe this function was just
+    -- never used when linking TH before this patch?
+    -- Add a test to the oneshot base MR that uses archives to compare.
+    findObject  `orElse`
+    findArchive `orElse`
     assumeDll
 
   | otherwise


=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -734,7 +734,7 @@ mkStubPaths fopts mod location
         stub_basename <.> os "h"
 
 -- -----------------------------------------------------------------------------
--- findLinkable isn't related to the other stuff in here,
+-- findObjectLinkable isn't related to the other stuff in here,
 -- but there's no other obvious place for it
 
 findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable)


=====================================
testsuite/tests/bytecode/T25090/Dep.hs
=====================================
@@ -0,0 +1,15 @@
+module Dep 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/bytecode/T25090/DepApi.hs
=====================================
@@ -0,0 +1,7 @@
+module DepApi (A (A), dep) where
+
+import Dep (A (A))
+import qualified Dep
+
+dep :: A
+dep = Dep.dep


=====================================
testsuite/tests/bytecode/T25090/Local.hs
=====================================
@@ -0,0 +1,16 @@
+{-# language PackageImports #-}
+
+module Local 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" DepApi (dep, A (A))
+import {-# source #-} Num (num)
+import Obj (numo)
+
+splc :: ExpQ
+splc = lift @_ @Int (num + d + numo)
+  where
+    A d = dep


=====================================
testsuite/tests/bytecode/T25090/Makefile
=====================================
@@ -19,3 +19,37 @@ T25090a:
 T25090b:
 	$(TEST_HC) -fbyte-code-and-object-code -fprefer-byte-code A -o exe -v0
 	./exe
+
+# TODO it works even without -package obj, but it should complain about the package not being exposed
+DB := -package-db db -package dep
+BASIC := $(TEST_HC_OPTS) $(DB) -this-unit-id=pkgdep -v0
+BC := -fprefer-byte-code -fbyte-code-and-object-code
+ARGS := $(BASIC) $(BC)
+
+.PHONY: PkgArchive
+PkgArchive:
+	./prep.bash "$(TEST_HC)" "$(TEST_HC_OPTS)" "$(GHC_PKG)" 1
+	./run.bash "$(TEST_HC)" "$(ARGS)"
+
+.PHONY: PkgEmptyArchive
+PkgEmptyArchive:
+	./prep.bash "$(TEST_HC)" "$(TEST_HC_OPTS)" "$(GHC_PKG)" 2
+	./run.bash "$(TEST_HC)" "$(ARGS)"
+
+.PHONY: PkgNoArchive
+PkgNoArchive:
+	./prep.bash "$(TEST_HC)" "$(TEST_HC_OPTS)" "$(GHC_PKG)" 3
+	./run.bash "$(TEST_HC)" "$(ARGS)"
+
+.PHONY: PkgArchiveObjCode
+PkgArchiveObjCode:
+	./prep.bash "$(TEST_HC)" "$(TEST_HC_OPTS)" "$(GHC_PKG)" 1
+	./run.bash "$(TEST_HC)" "$(BASIC) -fbyte-code-and-object-code"
+
+.PHONY: PkgMultiUnit
+PkgMultiUnit:
+	./prep.bash "$(TEST_HC)" "$(TEST_HC_OPTS)" "$(GHC_PKG)" 1
+	mkdir -p unit2-src/
+	mv Local.hs Num.hs Num.hs-boot unit2-src/
+	"$(TEST_HC)" $(TEST_HC_OPTS) $(ARGS) -unit @unit1 -unit @unit2
+	./PkgBytecode


=====================================
testsuite/tests/bytecode/T25090/Num.hs
=====================================
@@ -0,0 +1,4 @@
+module Num where
+
+num :: Int
+num = 48332


=====================================
testsuite/tests/bytecode/T25090/Num.hs-boot
=====================================
@@ -0,0 +1,3 @@
+module Num where
+
+num :: Int


=====================================
testsuite/tests/bytecode/T25090/Obj.hs
=====================================
@@ -0,0 +1,4 @@
+module Obj where
+
+numo :: Int
+numo = 0


=====================================
testsuite/tests/bytecode/T25090/PkgBytecode.hs
=====================================
@@ -0,0 +1,12 @@
+{-# language TemplateHaskell #-}
+
+module Main where
+
+import GHC.Prim
+import Local (splc)
+
+a :: Int
+a = $(splc)
+
+main :: IO ()
+main = putStrLn (show a)


=====================================
testsuite/tests/bytecode/T25090/PkgBytecode.stdout
=====================================
@@ -0,0 +1 @@
+58013


=====================================
testsuite/tests/bytecode/T25090/all.T
=====================================
@@ -16,3 +16,34 @@ def test_T25090(name):
 
 test_T25090('T25090a')
 test_T25090('T25090b')
+
+def test_pkg(suf, files = []):
+    name = f'Pkg{suf}'
+    test(
+        name,
+        [
+            extra_files([
+                'PkgBytecode.hs',
+                'Local.hs',
+                'Dep.hs',
+                'DepApi.hs',
+                'Num.hs',
+                'Num.hs-boot',
+                'Obj.hs',
+                'dep.conf',
+                'obj.conf',
+                'prep.bash',
+                'run.bash',
+            ] + files),
+            use_specs({'stdout': 'PkgBytecode.stdout'}),
+        ],
+        makefile_test,
+        [name],
+    )
+
+test_pkg('Archive')
+test_pkg('EmptyArchive')
+test_pkg('NoArchive')
+# TODO broken
+# test_pkg('ArchiveObjCode')
+test_pkg('MultiUnit', ['unit1', 'unit2'])


=====================================
testsuite/tests/bytecode/T25090/dep.conf
=====================================
@@ -0,0 +1,8 @@
+name: dep
+version: 1.0
+id: dep-1.0
+key: dep-1.0
+exposed: True
+exposed-modules: DepApi
+import-dirs: ${pkgroot}/dep
+library-dirs: ${pkgroot}/dep


=====================================
testsuite/tests/bytecode/T25090/obj.conf
=====================================
@@ -0,0 +1,8 @@
+name: obj
+version: 1.0
+id: obj-1.0
+key: obj-1.0
+exposed: True
+exposed-modules: Obj
+import-dirs: ${pkgroot}/obj
+library-dirs: ${pkgroot}/obj


=====================================
testsuite/tests/bytecode/T25090/prep.bash
=====================================
@@ -0,0 +1,52 @@
+#!/usr/bin/env bash
+
+set -eu
+
+ghc_cmd="$1"
+ghc_opts="$2"
+ghc_pkg_cmd="$3"
+archive="$4"
+
+base="$PWD"
+db="$base/db"
+dep="$base/dep"
+conf_dep="${dep}/dep.conf"
+obj="$base/obj"
+conf_obj="${obj}/obj.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 "$dep" "$obj" "$db"
+mv Dep.hs DepApi.hs "$dep/"
+cp dep.conf "$dep/"
+mv Obj.hs "$obj/"
+cp obj.conf "$obj/"
+
+ghc_pkg recache
+
+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}/Dep.hs ${dep at Q}/DepApi.hs"
+
+ghc "-package-db ${db at Q} -hidir ${obj at Q} -O0 -this-unit-id obj-1.0 -c ${obj at Q}/Obj.hs"
+$AR cqs "${obj}/libHSobj-1.0.a" "${obj}/Obj.o"
+echo 'hs-libraries: HSobj-1.0' >> "$conf_obj"
+
+if [[ "$archive" == 1 ]]
+then
+  $AR cqs "${dep}/libHSdep-1.0.a" "${dep}/Dep.o" "${dep}/DepApi.o"
+  echo 'hs-libraries: HSdep-1.0' >> "$conf_dep"
+elif [[ "$archive" == 2 ]]
+then
+  $AR cqs "${dep}/libHSdep-1.0.a"
+  echo 'hs-libraries: HSdep-1.0' >> "$conf_dep"
+fi
+
+ghc_pkg -v0 register "${conf_dep at Q}"
+ghc_pkg -v0 register "${conf_obj at Q}"


=====================================
testsuite/tests/bytecode/T25090/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 Num.hs-boot Num.hs Local.hs
+ghc -c PkgBytecode.hs
+ghc PkgBytecode.o -o PkgBytecode
+./PkgBytecode


=====================================
testsuite/tests/bytecode/T25090/unit1
=====================================
@@ -0,0 +1 @@
+-i -i. PkgBytecode -this-unit-id unit1 -package-id unit2


=====================================
testsuite/tests/bytecode/T25090/unit2
=====================================
@@ -0,0 +1 @@
+-i -i./unit2-src Local Num -this-unit-id unit2



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/56f3fbe9f747725dca63fc7420868fcb7fe9ee4a

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/56f3fbe9f747725dca63fc7420868fcb7fe9ee4a
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/20240923/e2f69850/attachment-0001.html>


More information about the ghc-commits mailing list