On Thu, 16 Jun 2022, Erdi, Gergo via ghc-devs wrote:
Is there a migration guide for GHC API clients for the new “multiple home units”
feature?
OK so in concrete terms, please see my attached program which is a heavily
cut-down, standalone version of my real program. On commit
fd42ab5fa1df847a6b595dfe4b63d9c7eecbf400^ (i.e.
3219610e3ba6cb6a5cd1f4e32e2b4befea5bd384) it compiles and works as
expected. On commit fd42ab5fa1df847a6b595dfe4b63d9c7eecbf400 onwards, two
problems pop up:
1. `extendMG` has changed and now requires manually specifying outgoing
dependency edges. I thought the whole point of `summariseFile` was to
collect this information? The reason I need to `extendMG` at that point is
to get intra-unit orphan instances working.
2. `modifyUnitState` and its two uses (`addUnit` and `registerModule`)
need to be updated to the new API. I think it makes sense that these need
changing, since they touch exactly on the issue of which units are being
compiled right now. However, I don't know how to update these. Also, I
guess `setHomeUnit` should change the `CurrentUnit` instead of the
`HomeUnit` now?
Thanks,
Gergo{-# LANGUAGE BlockArguments, RecordWildCards #-}
module Main where
import qualified Paths_ghc_lib as GHC
import GHC
import GHC.Core
import GHC.Core.FamInstEnv
import GHC.Core.InstEnv
import GHC.Core.Rules
import GHC.Core.TyCon
import GHC.CoreToStg.Prep
import GHC.Data.FastString
import GHC.Data.IOEnv
import GHC.Data.StringBuffer
import GHC.Driver.Env
import GHC.Driver.Errors.Types
import GHC.Driver.Main (hscSimplify)
import GHC.Driver.Make
import GHC.Driver.Monad
import GHC.Driver.Phases
import GHC.Driver.Session
import GHC.Iface.Make
import GHC.Iface.Tidy (tidyProgram)
import GHC.Tc.Types
import GHC.Tc.Utils.Monad
import GHC.Types.Annotations
import GHC.Types.Error
import GHC.Types.SourceError
import GHC.Types.SourceFile
import GHC.Types.TypeEnv
import GHC.Types.Unique.FM
import GHC.Unit.Env
import GHC.Unit.External
import GHC.Unit.Home
import GHC.Unit.Home.ModInfo
import GHC.Unit.Info
import GHC.Unit.Module.Env
import GHC.Unit.Module.Graph
import GHC.Unit.Module.ModDetails
import GHC.Unit.Module.ModGuts
import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.Name
import GHC.Unit.State
import GHC.Unit.Types
import Data.Version
import qualified Data.Map as M
import Data.Foldable (for_)
import Control.Monad.Writer hiding ((<>))
import System.FilePath
import Data.Time
fooUnitId, barUnitId :: UnitId
fooUnitId = UnitId $ fsLit "foo"
barUnitId = UnitId $ fsLit "bar"
fooUnit, barUnit :: Unit
fooUnit = RealUnit $ Definite fooUnitId
barUnit = RealUnit $ Definite barUnitId
fooUnitInfo, barUnitInfo :: UnitInfo
fooUnitInfo = fakeUnitInfo fooUnitId []
barUnitInfo = fakeUnitInfo barUnitId []
main :: IO ()
main = do
let mods = [ (fooUnitId, mkModuleName "A")
, (barUnitId, mkModuleName "B")
, (mainUnitId, mkModuleName "C")
]
libDir <- liftIO $ GHC.getDataDir
runGhcT (Just libDir) do
setup
mapM_ (modifySession . addUnit)
[ fooUnitInfo
, barUnitInfo
]
for_ mods \(unitId, modName) -> do
target <- mkTarget unitId $ "input" </> moduleNameSlashes modName <.> "mu"
(ms, deps) <- prepareModule modName target
liftIO $ print (modName, deps)
let mod = ms_mod ms
modifySession $ setHomeUnit $ toUnitId . moduleUnit $ mod
(core, details, iface) <- compileToCore ms
registerModule details iface
return ()
compileToCore
:: (GhcMonad m)
=> ModSummary
-> m (CoreProgram, ModDetails, ModIface)
compileToCore ms = do
dmod <- desugarModule =<< typecheckModule =<< parseModule ms
let mguts = coreModule dmod
env <- getSession
mguts' <- liftIO $ hscSimplify env [] mguts
(cg_guts, details) <- liftIO $ tidyProgram env mguts'
let types = md_types details
tycons = typeEnvTyCons types
data_tycons = filter isDataTyCon tycons
let partial_iface = mkPartialIface env details ms mguts'
iface <- liftIO $ mkFullIface env partial_iface Nothing
let tidy_binds = cg_binds cg_guts
binds <- liftIO $ corePrepPgm env mod modLoc tidy_binds data_tycons
return (binds, details, iface)
where
mod = ms_mod ms
modLoc = ms_location ms
prepareModule :: (GhcMonad m) => ModuleName -> Target -> m (ModSummary, [ModuleName])
prepareModule modName target = do
env <- getSession
env <- return $ setHomeUnit (toUnitId unit) env
mems <- liftIO $ summariseFile env [] file mb_phase fileContents
case mems of
Left err -> do
reportErrors [fmap GhcDriverMessage err]
error $ unwords ["prepareModule/lookupModuleEnv", unitString unit, moduleNameString . moduleName $ mod]
Right ems -> do
let ms = emsModSummary ems
deps = ms_textual_imps ms
when (unit == mainUnit) $ registerModSummary ems
let deps = map (unLoc . snd) deps
return (ms, deps)
where
unit = RealUnit . Definite $ targetUnitId target
mod = mkModule unit modName
Target
{ targetId = TargetFile file mb_phase
, targetContents = fileContents
} = target
registerModSummary :: (GhcMonad m) => ExtendedModSummary -> m ()
registerModSummary ems = modifySession \env ->
let mg = hsc_mod_graph env
mg' = extendMG mg ems
in env{ hsc_mod_graph = mg' }
modifyUnitState :: (UnitState -> UnitState) -> HscEnv -> HscEnv
modifyUnitState f env = env
{ hsc_unit_env = let ue = hsc_unit_env env in ue
{ ue_units = f (ue_units ue)
}
}
mkTarget :: (MonadIO m) => UnitId -> FilePath -> m Target
mkTarget unitId filePath = do
contents <- liftIO $ hGetStringBuffer filePath
timestamp <- liftIO getCurrentTime
return $ Target
{ targetId = TargetFile filePath (Just $ Cpp HsSrcFile)
, targetAllowObjCode = False
, targetContents = Just (contents, timestamp)
, targetUnitId = unitId
}
setup :: (GhcMonad m) => m ()
setup = do
let primPkgDb = "ghc-lib/ghc-lib/stage1/lib/package.conf.d"
dflags <- getSessionDynFlags
dflags <- return $ dflags
{ backend = NoBackend
, mainModuleNameIs = mkModuleName "No/Main"
, packageDBFlags = [PackageDB $ PkgDbPath primPkgDb, ClearPackageDBs]
}
setSessionDynFlags dflags
reportErrors :: (GhcMonad m) => [ErrorMessages] -> m ()
reportErrors errs = do
errs <- return $ unionManyMessages errs
unless (isEmptyMessages errs) $ throwErrors errs
setHomeUnit :: UnitId -> HscEnv -> HscEnv
setHomeUnit unitId env = env
{ hsc_unit_env = let ue = hsc_unit_env env in ue
{ ue_home_unit = Just $ DefiniteHomeUnit unitId Nothing
}
}
mkModIface :: HscEnv -> TcGblEnv -> ModDetails -> ModSummary -> IO ModIface
mkModIface env tcg mod_details mod_summary = mkIfaceTc env Sf_Ignore mod_details mod_summary tcg
fakeUnitInfo :: UnitId -> [ModuleName] -> UnitInfo
fakeUnitInfo unit mods = GenericUnitInfo
{ unitId = unit
, unitInstanceOf = unit
, unitInstantiations = []
, unitPackageId = pkgId
, unitPackageName = pkgName
, unitPackageVersion = makeVersion [0, 0]
, unitComponentName = Nothing
, unitAbiHash = mempty
, unitDepends = []
, unitAbiDepends = []
, unitImportDirs = []
, unitLibraries = []
, unitExtDepLibsSys = []
, unitExtDepLibsGhc = []
, unitLibraryDirs = []
, unitLibraryDynDirs = []
, unitExtDepFrameworks = []
, unitExtDepFrameworkDirs = []
, unitLinkerOptions = []
, unitCcOptions = []
, unitIncludes = []
, unitIncludeDirs = []
, unitHaddockInterfaces = []
, unitHaddockHTMLs = []
, unitExposedModules = [(mod, Nothing) | mod <- mods]
, unitHiddenModules = []
, unitIsIndefinite = False
, unitIsExposed = True
, unitIsTrusted = True
}
where
pkg = fsLit $ unitIdString unit <> "-pkg"
pkgId = PackageId pkg
pkgName = PackageName pkg
addUnit :: UnitInfo -> HscEnv -> HscEnv
addUnit unitInfo@GenericUnitInfo{..}<mailto:unitInfo@GenericUnitInfo%7b..%7d> = modifyUnitState $ \us -> us
{ packageNameMap = addToUFM (packageNameMap us) unitPackageName unitId
, unitInfoMap = M.insert unitId unitInfo $ unitInfoMap us
}
registerToEps :: (GhcMonad m) => ModDetails -> ModIface -> m ()
registerToEps details@ModDetails{..}<mailto:details@ModDetails%7b..%7d> iface = do
env <- getSession
liftIO $ runIOEnv (Env env '\0' () ()) $ updateEps_ extendEps
where
mod = mi_module iface
extendEps :: ExternalPackageState -> ExternalPackageState
extendEps eps = eps
{ eps_PIT = extendModuleEnv (eps_PIT eps) mod iface
, eps_PTE = plusTypeEnv (eps_PTE eps) md_types
, eps_rule_base = extendRuleBaseList (eps_rule_base eps) md_rules
, eps_inst_env = extendInstEnvList (eps_inst_env eps) md_insts
, eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps) md_fam_insts
, eps_ann_env = extendAnnEnvList (eps_ann_env eps) md_anns
, eps_mod_fam_inst_env =
let fam_inst_env = extendFamInstEnvList emptyFamInstEnv md_fam_insts
in extendModuleEnv (eps_mod_fam_inst_env eps) mod fam_inst_env
, eps_stats = addEpsInStats (eps_stats eps) (length $ typeEnvElts md_types) (length md_insts) (length md_rules)
}
registerModule :: (GhcMonad m) => ModDetails -> ModIface -> m ()
registerModule details iface = modifySession $ extendHpt . addModule
where
hmi = HomeModInfo iface details Nothing
mod = mi_module iface
modOrig = ModOrigin (Just True) [] [] True
addModule = modifyUnitState $ \us -> us
{ moduleNameProvidersMap = M.insert (moduleName mod) (M.singleton mod modOrig) $ moduleNameProvidersMap us
}
extendHpt env = env
{ hsc_unit_env = let ue = hsc_unit_env env in ue
{ ue_hpt = addHomeModInfoToHpt hmi (hsc_HPT env)
}
}
_______________________________________________
ghc-devs mailing list
ghc-devs@haskell.org
http://mail.haskell.org/cgi-bin/mailman/listinfo/ghc-devs
