Qualify modules with their pkg, but unambiguous

Author: Saizan

haskell-debugger/GHC/Debugger/Monad.hs

@@ -41,7 +41,6 @@ import System.Process.Internals (mkProcessHandle)
 import Text.Read (readMaybe)
 
 import GHC
-import GHC.Data.FastString
 import GHC.Data.StringBuffer
 import GHC.Driver.Config.Diagnostic
 import GHC.Driver.Config.Logger
@@ -61,9 +60,7 @@ import GHC.Runtime.Interpreter as GHCi
 import GHC.Runtime.Loader as GHC
 import GHC.Runtime.Context as GHCi
 import GHC.Types.Error
-import GHC.Types.PkgQual
 import GHC.Types.SourceError
-import GHC.Types.SourceText
 import GHC.Types.Unique.Supply as GHC
 import GHC.Unit.Module.Graph
 import GHC.Unit.State
@@ -270,7 +267,7 @@ runDebuggerAction :: forall a. LogAction IO DebuggerLog
   -> Debugger a
   -> Ghc a
 runDebuggerAction l rootDir extraGhcArgs conf loadHomeUnit (Debugger action) = flip MC.finally cleanupInterp $ -- See Note [Shutting down the external interpreter]
-  do
+  annotateCallStackGhc $ do
 #ifdef MIN_VERSION_unix
   -- Workaround #4162
   -- FIXME: setup reasonable handlers to run cleanupSession for every debugger thread, because runGhc's `withSignalHandlers` is not it.
@@ -319,7 +316,7 @@ runDebuggerAction l rootDir extraGhcArgs conf loadHomeUnit (Debugger action) = f
     -- Override the logger to output to the given handle
     GHC.pushLogHook $ const $ ghcLogAction l
 
-  dflags2 <- getLogger >>= \logger -> do
+  dflags2 <- getLogger >>= \logger -> annotateCallStackGhc $ do
     -- Set the extra GHC arguments for ALL units by setting them early in
     -- dynflags. This is important to make sure unfoldings for interfaces
     -- loaded because of the built-in loaded classes (like
@@ -338,7 +335,7 @@ runDebuggerAction l rootDir extraGhcArgs conf loadHomeUnit (Debugger action) = f
   -- Make sure to override the function which creates the external
   -- interpreter, because we need to keep track of the standard handles
   iserv_handles <- liftIO newEmptyMVar
-  case conf.externalInterpreterCustomProc of
+  annotateCallStackGhc $ case conf.externalInterpreterCustomProc of
     -- Left: GHC will launch the external interpreter itself on demand if
     -- using external interpreter, and we just provide the stdin stream
     Left givenStdStream ->
@@ -387,7 +384,7 @@ runDebuggerAction l rootDir extraGhcArgs conf loadHomeUnit (Debugger action) = f
           (forwardHandleToLogger serv_out (contramap LogDebuggeeOut l))
 
     mainGhcThread :: Ghc a
-    mainGhcThread = do
+    mainGhcThread = annotateCallStackGhc $ do
       -- Initializes interpreter!
       _ <- GHC.setSessionDynFlags dflags2
 
@@ -398,9 +395,7 @@ runDebuggerAction l rootDir extraGhcArgs conf loadHomeUnit (Debugger action) = f
       GHC.getSessionDynFlags >>= \df -> liftIO $
         GHC.initUniqSupply (GHC.initialUnique df) (GHC.uniqueIncrement df)
 
-      loadHomeUnit
-      -- See Note [Must explicitly expose module graph units]
-      setExposedInUnit interactiveGhcDebuggerUnitId . graphUnits . hsc_mod_graph =<< getSession
+      annotateCallStackGhc $ loadHomeUnit
 
       -- Ensure all the home units are built with same Ways and return them.
       buildWays       <- do
@@ -411,37 +406,41 @@ runDebuggerAction l rootDir extraGhcArgs conf loadHomeUnit (Debugger action) = f
 
       -- Find haskell-debugger-view in (deps of) home units, or load one from
       -- in-memory sources.
-      (hdv_uid, loadedBuiltinModNames) <- findOrLoadHaskellDebuggerView l buildWays
+      (hdv_uid, loadedBuiltinModNames) <- annotateCallStackGhc $ findOrLoadHaskellDebuggerView l buildWays
 
+      -- See Note [Must explicitly expose module graph units]
+      setExposedInUnit interactiveGhcDebuggerUnitId . graphUnits . hsc_mod_graph =<< getSession
 
       -- Set interactive context to import all loaded modules
       let preludeImp = GHC.IIDecl . GHC.simpleImportDecl $ GHC.mkModuleName "Prelude"
+
+      hsc_env_new <- getSession
+
       -- dbgView should always be available, either because we manually loaded it
       -- or because it's in the transitive closure.
-      hug <- hsc_HUG <$> getSession
       let dbgViewImps
-            -- If hs-dbg-view is a home-unit, refer to it directly
-            -- See Note [Do not package-qualify imports for home units]
-            | memberHugUnitId hdv_uid hug
-            = map (GHC.IIModule . mkModule (RealUnit (Definite hdv_uid))) loadedBuiltinModNames
-            -- It's available in an exposed unit in the transitive closure. Resolve it
-            | otherwise
-            = map (\mn ->
-                GHC.IIDecl (GHC.simpleImportDecl mn)
-                { ideclPkgQual = RawPkgQual
-                    StringLiteral
-                      { sl_st = NoSourceText
-                      , sl_fs = mkFastString (unitIdString hdv_uid)
-                      , sl_tc = Nothing
-                      }
-                }) loadedBuiltinModNames
+            = map (packageImportDecl hvd_pkgName) loadedBuiltinModNames
+            where
+              hvd_pkgName = fromMaybe (error $ "No package name for: " ++ unitIdString hdv_uid) $
+                lookupUnitPackageName hsc_env_new hdv_uid
+
+      -- See Note [Must explicitly expose module graph units]
+      setExposedInUnit interactiveGhcDebuggerUnitId . graphUnits . hsc_mod_graph =<< getSession
 
       mss <- getAllLoadedModules
 
-      GHC.setContext
-        (preludeImp :
-          dbgViewImps ++
-          map (GHC.IIModule . GHC.ms_mod) mss)
+      let
+        imports
+          = preludeImp :
+            dbgViewImps ++
+            [ packageImportDecl pkgName (moduleName modl)
+            | modl <- map GHC.ms_mod mss
+            , let uid = moduleUnitId modl
+            , let pkgName = fromMaybe (error $ "No package name for: " ++ unitIdString uid) $ lookupUnitPackageName hsc_env_new uid
+            ]
+
+
+      GHC.setContext imports
 
       -- See Note [External interpreter buffering]
       setBufferings <- compileExprRemote """
@@ -462,16 +461,16 @@ runDebuggerAction l rootDir extraGhcArgs conf loadHomeUnit (Debugger action) = f
               then Nothing
               else Just hdv_uid)
 
-  case conf.externalInterpreterCustomProc of
+  annotateCallStackGhc $ case conf.externalInterpreterCustomProc of
     Left _ -> do
       -- We launched the external interpreter ourselves, so forward its output to the logger.
-      withUnliftGhc $ \ unlift -> do
-        withAsync (void externalInterpFwdThread) $ \ fwd_thr -> do
-          liftIO $ link fwd_thr
-          unlift mainGhcThread
+      withUnliftGhc $ \ unlift -> annotateCallStackIO $ do
+        withAsync (annotateCallStackIO $ void externalInterpFwdThread) $ \ fwd_thr -> do
+          liftIO $ annotateCallStackIO $ link fwd_thr
+          annotateCallStackIO $ unlift mainGhcThread
     Right _ ->
       -- Ext interp is running in user terminal, no need to forward output to logger
-      mainGhcThread
+      annotateCallStackGhc $ mainGhcThread
 
 findOrLoadHaskellDebuggerView :: LogAction IO DebuggerLog
              -> Ways
@@ -581,6 +580,7 @@ Note [Do not package-qualify imports for home units]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 A package-qualified module import will be looked up directly in the exposed
 packages, IGNORING the home units modules.
+-- FIXME: PackageImport expects a PackageName, it only works with unit-ids with external packages by a quirk of the implementation, for home units though you can set your own package names and get around the problem.
 
 This can lead to two scenarios:
 
@@ -623,10 +623,6 @@ cleanupInterp = do
             sendMessage i Shutdown
             pure InterpPending
 
--- | WARNING: callback is not to be used from other threads.
-withUnliftGhc :: ((Ghc b -> IO b) -> IO a) -> Ghc a
-withUnliftGhc k = reifyGhc $ \ s -> k (flip reflectGhc s)
-
 annotateDebuggerStackString :: String -> Debugger a -> Debugger a
 annotateDebuggerStackString s (Debugger m) = Debugger $ do
   r <- ReaderT $ \val -> do
@@ -857,20 +853,20 @@ doLoad if_cache how_much mg = do
 
 
 loadInMemoryModules ::
-  GhcMonad m
-  => LogAction IO DebuggerLog
+  LogAction IO DebuggerLog
   -> UnitId
-  -> [(ModuleName,StringBuffer)] -> m [SuccessFlag]
-loadInMemoryModules l uid ts = do
+  -> [(ModuleName,StringBuffer)] -> Ghc [SuccessFlag]
+loadInMemoryModules l uid ts = annotateCallStackGhc $ do
   old_targets <- GHC.getTargets
   tgts <- forM ts $  \(modName,modContents) ->
     liftIO $ makeInMemoryTarget uid modName modContents
+  -- liftIO $ putStrLn $ "SETTING TARGETS"
   GHC.setTargets (tgts ++ old_targets)
   mod_graph <- hsc_mod_graph <$> GHC.getSession
   -- TODO: use [incremental API](https://gitlab.haskell.org/ghc/ghc/-/issues/27054) when ready.
   dvc_mod_graph <- doDownsweep (Just mod_graph)
   modifySession $ GHC.setModuleGraph dvc_mod_graph
-
+  -- liftIO $ putStrLn $ (++) "MODULEGRAPH" $ showPprUnsafe $ withPprStyle (PprDump alwaysQualify) $ ppr $ mg_mss dvc_mod_graph
   restore_logger <- GHC.getLogger
   dflags <- getSessionDynFlags
   GHC.modifyLogger $

haskell-debugger/GHC/Debugger/Run.hs

@@ -262,8 +262,11 @@ withCurrentBreakExtensions m = do
     Just breakModule -> do
       ic_dyn_flags <- getInteractiveDebuggerDynFlags
       break_dyn_flags <- ms_hspp_opts <$> GHC.getModSummary breakModule
+      old_context <- GHC.getContext
       setInteractiveDebuggerDynFlags $ adjustFlags ic_dyn_flags break_dyn_flags
+      GHC.setContext (IIModule breakModule : old_context)
       x <- m
+      GHC.setContext old_context
       setInteractiveDebuggerDynFlags ic_dyn_flags
       return x
   where

haskell-debugger/GHC/Debugger/Session.hs

@@ -33,12 +33,19 @@ module GHC.Debugger.Session (
   setExposedInUnit,
   graphUnits,
   compileModuleWithDepsInHpt,
+  home_unit_dflags,
+  packageImportDecl,
+  withUnliftGhc,
+  annotateCallStackGhc,
+  lookupUnitPackageName,
   )
   where
 
 #if MIN_VERSION_ghc(9,14,2)
 import Data.Function ((&))
 #endif
+import Control.Applicative ((<|>))
+import Control.Exception (assert)
 import Control.Monad
 import Control.Monad.IO.Class
 import qualified Crypto.Hash.SHA1                    as H
@@ -75,7 +82,7 @@ import qualified GHC.Unit.Home.Graph as HUG
 import qualified Data.Set as Set
 import Data.Maybe
 import GHC.Types.Target (InputFileBuffer)
-import GHC (SingleStep, ExecResult, ModSummary (ms_hspp_opts))
+import GHC (SingleStep, ExecResult, ModSummary (ms_hspp_opts), ideclPkgQual)
 import Data.Set (Set)
 import qualified GHC.Unit as GHC
 import GHC.Unit.Module.Graph (mg_mss, ModuleGraphNode (..), mnKey)
@@ -89,7 +96,10 @@ import GHC.Driver.Pipeline (compileOne)
 import qualified GHC.Unit.Home.ModInfo as GHC
 import GHC.Utils.TmpFs
 import Data.Foldable (for_)
-import GHC.Plugins (SourceError, try)
+import GHC.Plugins (SourceError, try, RawPkgQual (..), HasCallStack, PackageName (..), mkFastString, lookupUnitId, GenericUnitInfo (unitPackageName))
+import GHC.Types.SourceText (StringLiteral(..), SourceText (..))
+import GHC.Stack.Annotation
+import GHC.Stack (callStack)
 
 -- | Throws if package flags are unsatisfiable
 parseHomeUnitArguments :: GhcMonad m
@@ -161,13 +171,24 @@ setupHomeUnitGraph flagsAndTargets = do
 -- | Set up the 'HomeUnitGraph' with empty 'HomeUnitEnv's.
 -- The first 'DynFlags' are the 'DynFlags' for the interactive session.
 createHomeUnitGraph :: GHC.Logger -> [DynFlags] -> IO HomeUnitGraph
-createHomeUnitGraph logger unitDflags = do
+createHomeUnitGraph logger unitDflags0 = do
+  -- See Note [ Ambiguous Package Qualified Imports Workaround ]
+  let unitDflags = fixFlagsForIIDecl unitDflags0
   let home_units = Set.fromList $ map homeUnitId_ unitDflags
+
   unitEnvList <- flip traverse unitDflags $ \ dflags -> do
+    let uid = homeUnitId_ dflags
     hue <- setupNewHomeUnitEnv logger dflags Nothing home_units
-    pure (homeUnitId_ dflags, hue)
+    assert (homeUnitId_ (homeUnitEnv_dflags hue) == uid) $
+      pure (uid, hue)
 
   pure $ unitEnv_new (Map.fromList unitEnvList)
+  where
+    -- | Makes package names of home units unique and removes hidden modules.
+    fixFlagsForIIDecl [df] | Just{} <- thisPackageName df = [df {hiddenModules = Set.empty}]
+    -- TODO #288: pick more user-friendly names.
+    fixFlagsForIIDecl dfss = map (\ dflags -> dflags { thisPackageName = Just (unitIdString (homeUnitId_ dflags))
+    , hiddenModules = Set.empty}) dfss
 
 setupNewHomeUnitEnv :: GHC.Logger -> DynFlags -> Maybe [GHC.UnitDatabase UnitId] -> Set UnitId -> IO HomeUnitEnv
 setupNewHomeUnitEnv logger dflags cached_dbs other_home_units = do
@@ -225,11 +246,18 @@ graphUnits mod_graph = L.nubOrd .
          InstantiationNode uid _ -> Just uid
          LinkNode _ _ -> Nothing
 
+-- | WARNING: callback is not to be used from other threads.
+withUnliftGhc :: ((Ghc b -> IO b) -> IO a) -> Ghc a
+withUnliftGhc k = reifyGhc $ \ s -> k (flip reflectGhc s)
+
+annotateCallStackGhc :: HasCallStack => Ghc a -> Ghc a
+annotateCallStackGhc m = let x = callStack in withUnliftGhc $ \k -> annotateStackShowIO x $ k m
+
 -- | Rebuilds the UnitState of the unit, exposing the given packages.
 --
 --   Takes care of updating hsc_dflags, ue_platform, and ue_namever if this is the ue_currentUnit.
 setExposedInUnit :: UnitId -> [UnitId] -> Ghc ()
-setExposedInUnit unitId exposed = do
+setExposedInUnit unitId exposed = annotateCallStackGhc $ do
   env <- GHC.getSession
   let old_ie = case lookupHugUnitId unitId (hsc_HUG env) of
         Just hue -> hue
@@ -280,7 +308,7 @@ setupMultiHomeUnitGhcSession
          -> HscEnv             -- ^ An empty HscEnv that we can use the setup the session.
          -> [(DynFlags, [GHC.Target])]    -- ^ New components to be loaded. Expected to be non-empty.
          -> IO (HscEnv, [TargetDetails])
-setupMultiHomeUnitGhcSession exts hsc_env cis = do
+setupMultiHomeUnitGhcSession exts hsc_env cis = annotateCallStackIO $ do
     let dfs = map fst cis
 
     hscEnv' <- initHomeUnitEnv dfs hsc_env
@@ -353,6 +381,31 @@ fromTargetId _ _ unitId (GHC.TargetFile f _) ctts = do
           | otherwise = (f ++ "-boot")
     return [TargetDetails (TargetFile f) [f, other] unitId ctts]
 
+{-
+Note [ Ambiguous Package Qualified Imports Workaround ]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Source level package qualified imports `import "foo" A` interpret "foo" as a package name.
+
+When one manually builds a `RawPkgQual` for an `ImportDecl` one can get away with using a unit-id, but only for external (i.e. not home) units.
+That it works does not seem entirely intended (see quoted snippet below), the code is in `renamePkgQual`: If a package qualifier is not found among packages it's looked up as an external unit. This is already in the code path for `OtherPkg` though, which is why Home Units are excluded.
+```
+    | otherwise
+    -> OtherPkg (UnitId pkg_fs)
+       -- not really correct as pkg_fs is unlikely to be a valid unit-id but
+       -- we will report the failure later...
+```
+
+Home units will only be found if the qualifier matches their dflags' `thisPackageName`. However that's bugged because the lookup doesn't bother considering there can be multiple units in the same package (library, sublibraries and exe units), and just picks the first found, leading to an import error if e.g. the library unit is picked but the module was in the exe one.
+Related GHC issue: https://gitlab.haskell.org/ghc/ghc/-/issues/24227
+
+Turns out that the package name of a home unit is pretty meaningless though, so we can update the dflags to replace it with anything that's actually unique so we can dodge the bug.
+
+Another stumbling block is that the `IIDecl` mode of an `InteractiveImport` does not allow importing hidden modules, but again for home units we can alter the DynFlags so all modules are exposed.
+
+See issue #288 for what can we do for users at the repl.
+-}
+
 -- ----------------------------------------------------------------------------
 -- GHC Utils that should likely be exposed by GHC
 -- ----------------------------------------------------------------------------
@@ -363,6 +416,30 @@ mkSimpleTarget df fp = GHC.Target (GHC.TargetFile fp Nothing) True (homeUnitId_
 hscSetUnitEnv :: UnitEnv -> HscEnv -> HscEnv
 hscSetUnitEnv ue env = env { hsc_unit_env = ue }
 
+home_unit_dflags :: HscEnv -> UnitId -> Maybe DynFlags
+home_unit_dflags hsc_env uid
+  = fmap homeUnitEnv_dflags
+  . HUG.lookupHugUnitId uid . ue_home_unit_graph
+  . hsc_unit_env
+  $ hsc_env
+
+
+lookupUnitPackageName :: HscEnv -> UnitId -> Maybe PackageName
+lookupUnitPackageName env uid = home_unit_name <|> ext_unit_name
+          where
+            home_unit_name = PackageName . mkFastString <$> (thisPackageName =<< home_unit_dflags env uid)
+            ext_unit_name = unitPackageName <$> lookupUnitId (hsc_units env) uid
+
+packageImportDecl :: PackageName -> ModuleName -> GHC.InteractiveImport
+packageImportDecl (PackageName pkgName) mn =
+  GHC.IIDecl (GHC.simpleImportDecl $ mn)
+    { ideclPkgQual = RawPkgQual
+        StringLiteral
+          { sl_st = NoSourceText
+          , sl_fs = pkgName
+          , sl_tc = Nothing
+          }
+    }
 -- ----------------------------------------------------------------------------
 -- Session cache directory
 -- ----------------------------------------------------------------------------
@@ -417,10 +494,10 @@ getTargetFileSummary hsc_env target
       home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env)
       dflags = homeUnitEnv_dflags (ue_findHomeUnitEnv uid (hsc_unit_env hsc_env))
 
-compileModuleWithDepsInHpt :: GhcMonad m =>
+compileModuleWithDepsInHpt ::
   GHC.Target ->
-  m (Maybe SourceError)
-compileModuleWithDepsInHpt target@GHC.Target{targetUnitId = uid} = do
+  Ghc (Maybe SourceError)
+compileModuleWithDepsInHpt target@GHC.Target{targetUnitId = uid} = annotateCallStackGhc $ do
   hsc_env0 <- getSession
   let !old_active = hscActiveUnitId hsc_env0
   let !hsc_env = hscSetActiveUnitId uid hsc_env0

haskell-debugger/GHC/Debugger/Session/Builtin.hs

@@ -107,6 +107,7 @@ addInMemoryHsDebuggerViewUnit base_uids initialDynFlags = do
           , unitId /= rtsUnitId
           , unitId /= ghcInternalUnitId
           ]
+        , thisPackageName = Just "haskell-debugger-view"
         }
         & setGeneralFlag' Opt_HideAllPackages
   hsc_env <- getSession