Hannes Siebenhandl pushed to branch wip/fendor/homeunit-is-just at Glasgow Haskell Compiler / GHC Commits: 234bab08 by Vladislav Zavialov at 2026-09-29T17:22:54-04:00 Add regression test for #7803 Commit 2effe18ab5, first shipped with GHC 8.2.1, fixed #7803 "Superclass methods are left unspecialized". This change turns the example from the ticket description into a regression test, checking that foo1 is fully specialised at Double, with no calls to the overloaded exp5Tail. Closes #7803 Assisted-by: Claude Opus 5 - - - - - 718deaad by fendor at 2026-10-01T11:42:09+02:00 `HomeUnitEnv` should always have a concrete `HomeUnit` The `HomeUnit` describes what kind of home unit a particular `HomeUnitEnv` is and its `UnitId`. To get a `HomeUnit`, we need to initialise the `UnitState` via `initUnits` otherwise, we can't tell whether the `HomeUnit` is a definite one, or an indefinite one, for example a backpack signature file. That's why previously we maintained a `Maybe HomeUnit`. However, a `HomeUnitEnv` always has at least a `UnitId` (accessible via `DynFlags`). We can fake a `HomeUnit` until we have actually initialised the home unit and assume it is not a backpack unit. Once the `UnitState` is created using `initUnits`, we store the corrected `HomeUnit` in the `HomeUnitEnv` again. This avoids many partial functions that should have never been partial in the first case. Closes #27632 - - - - - 26 changed files: - + changelog.d/home-unit - compiler/GHC.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Main/Hsc.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Session/Units.hs - compiler/GHC/HsToCore/Usage.hs - compiler/GHC/Iface/Errors.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Linker/Deps.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/StgToJS/Linker/Linker.hs - compiler/GHC/Tc/Utils/Backpack.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Unit/Env.hs - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Home.hs - compiler/GHC/Unit/Home/Graph.hs - ghc/GHCi/UI.hs - + testsuite/tests/simplCore/should_compile/T7803.hs - + testsuite/tests/simplCore/should_compile/T7803.stderr - + testsuite/tests/simplCore/should_compile/T7803a.hs - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== changelog.d/home-unit ===================================== @@ -0,0 +1,26 @@ +section: compiler +synopsis: The compiler session always requires a `HomeUnit`. +description: { + We change `HomeUnitEnv` to always require a `HomeUnit` value. + Most parts of the compiler simply `panic` when the `HomeUnit` is missing, + and GHC API users are often forced to create dummy `HomeUnit` values for the API any way. + Thus, by demanding a `HomeUnit` in the `HomeUnitEnv`, we can avoid many sources of `panic`s, and simplify + multiple code paths and some APIs. + + We can always create a dummy `HomeUnit` value based on the `UnitId` of the + `HomeUnitEnv.homeUnitEnv_dflags.homeUnitId_`. + This `HomeUnit` might be wrong, as we don't know exactly what kind of `HomeUnit` it is until we have called + `initUnits` on the `HomeUnitEnv` contents themselves. + Once `initUnits` is called, we store the corrected `HomeUnit` in the `HomeUnitEnv`. + + From an API perspective, very little changes, since when users didn't have a real `HomeUnit` value, they needed to create + a dummy value already for most GHC API functions. + + The reason the `HomeUnit` used to be optional is to indicate which parts of the GHC API require certain initialisation steps, + such as calling `initUnits` on the `HomeUnitEnv`. The `HomeUnit` is a poor reflection of this requirement, which is why + we decided to make it mandatory whenever there is a `HomeUnitEnv`. + In the future, we might want to reflect this information based on the existence of a `HomeUnitEnv`, which we should only create + if the compiler session actually needs it. +} +mrs: !15885 +issues: #27632 ===================================== compiler/GHC.hs ===================================== @@ -678,7 +678,7 @@ setUnitDynFlagsNoCheck uid dflags1 = do hue { homeUnitEnv_units = unit_state , homeUnitEnv_dflags = updated_dflags - , homeUnitEnv_home_unit = Just home_unit + , homeUnitEnv_home_unit = home_unit } let unit_env = UnitEnv.ue_updateHomeUnitEnv upd uid (hsc_unit_env hsc_env) @@ -767,7 +767,7 @@ setProgramDynFlags_ invalidate_needed dflags = do { homeUnitEnv_units = unit_state , homeUnitEnv_dflags = updated_dflags , homeUnitEnv_hpt = old_hpt - , homeUnitEnv_home_unit = Just home_unit + , homeUnitEnv_home_unit = home_unit } let dflags1 = homeUnitEnv_dflags $ HUG.unitEnv_lookup (ue_currentUnit old_unit_env) home_unit_graph @@ -891,7 +891,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do { homeUnitEnv_units = unit_state , homeUnitEnv_dflags = updated_dflags , homeUnitEnv_hpt = old_hpt - , homeUnitEnv_home_unit = Just home_unit + , homeUnitEnv_home_unit = home_unit } -- When changing the DynFlags, we want the changes to apply to future @@ -1684,7 +1684,7 @@ findQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module findQualifiedModule pkgqual mod_name = withSession $ \hsc_env -> do let logger = hsc_logger hsc_env liftIO $ trace_if logger (text "findQualifiedModule" <+> ppr mod_name <+> ppr pkgqual) - let mhome_unit = hsc_home_unit_maybe hsc_env + let home_unit = hsc_home_unit hsc_env let dflags = hsc_dflags hsc_env let sec = initSourceErrorContext dflags case pkgqual of @@ -1695,7 +1695,7 @@ findQualifiedModule pkgqual mod_name = withSession $ \hsc_env -> do Nothing -> liftIO $ do res <- findImportedModule hsc_env LookupUser mod_name pkgqual case res of - Found loc m | notHomeModuleMaybe mhome_unit m -> return m + Found loc m | notHomeModule home_unit m -> return m | otherwise -> modNotLoadedError dflags m loc err -> throwOneError sec $ noModError hsc_env noSrcSpan mod_name err ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -470,7 +470,7 @@ addUnit u = do , ue_home_unit_graph = HUG.unitEnv_singleton (homeUnitId home_unit) - (HUG.mkHomeUnitEnv unit_state dflags (ue_hpt old_unit_env) (Just home_unit)) + (HUG.mkHomeUnitEnv unit_state dflags (ue_hpt old_unit_env) home_unit) , ue_eps = ue_eps old_unit_env , ue_module_graph = ue_module_graph old_unit_env , ue_uic = ue_uic old_unit_env ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -7,7 +7,6 @@ module GHC.Driver.Env , hscUpdateFlags , hscSetFlags , hsc_home_unit - , hsc_home_unit_maybe , hsc_units , hsc_HPT , hsc_HUE @@ -122,10 +121,7 @@ runInteractiveHsc :: HscEnv -> Hsc a -> IO a runInteractiveHsc hsc_env = runHsc (mkInteractiveHscEnv hsc_env) hsc_home_unit :: HscEnv -> HomeUnit -hsc_home_unit = ue_unsafeHomeUnit . hsc_unit_env - -hsc_home_unit_maybe :: HscEnv -> Maybe HomeUnit -hsc_home_unit_maybe = ue_homeUnit . hsc_unit_env +hsc_home_unit = ue_homeUnit . hsc_unit_env hsc_units :: HasDebugCallStack => HscEnv -> UnitState hsc_units = ue_homeUnitState . hsc_unit_env @@ -390,7 +386,7 @@ lookupIfaceByModuleHsc hsc_env mod = do lookupIfaceByModule (hsc_HUG hsc_env) (eps_PIT eps) mod mainModIs :: HomeUnitEnv -> Module -mainModIs hue = mkHomeModule (expectJust $ homeUnitEnv_home_unit hue) (mainModuleNameIs (homeUnitEnv_dflags hue)) +mainModIs hue = mkHomeModule (homeUnitEnv_home_unit hue) (mainModuleNameIs (homeUnitEnv_dflags hue)) -- | Retrieve the target code interpreter -- ===================================== compiler/GHC/Driver/Main/Hsc.hs ===================================== @@ -112,7 +112,7 @@ newHscEnv top_dir dflags = do where home_unit_graph hpt = HUG.unitEnv_singleton (homeUnitId_ dflags) - (HUG.mkHomeUnitEnv emptyUnitState dflags hpt Nothing) + (HUG.mkHomeUnitEnv emptyUnitState dflags hpt (DefiniteHomeUnit (homeUnitId_ dflags) Nothing)) newHscEnvWithHUG :: FilePath -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -1672,7 +1672,7 @@ maybeRehydrateBefore hsc_env mni (Just mns) = do where initialise_knot_var hsc_env = liftIO $ - let mod_name = homeModuleInstantiation (hsc_home_unit_maybe hsc_env) (moduleNodeInfoModule mni) + let mod_name = homeModuleInstantiation (hsc_home_unit hsc_env) (moduleNodeInfoModule mni) in mkModuleEnv . (:[]) . (mod_name,) <$> newIORef emptyTypeEnv rehydrateAfter :: HscEnv ===================================== compiler/GHC/Driver/Pipeline/Execute.hs ===================================== @@ -373,7 +373,7 @@ runCcPhase cc_phase pipe_env hsc_env location input_fn = do let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env let unit_env = hsc_unit_env hsc_env - let home_unit = hsc_home_unit_maybe hsc_env + let home_unit = hsc_home_unit hsc_env let tmpfs = hsc_tmpfs hsc_env let tmpdir = tmpDir dflags let platform = ue_platform unit_env @@ -473,12 +473,11 @@ runCcPhase cc_phase pipe_env hsc_env location input_fn = do -- These symbols are imported into the stub.c file via RtsAPI.h, and the -- way we do the import depends on whether we're currently compiling -- the base package or not. - ++ (case home_unit of - Just hu - | isHomeUnitId hu ghcInternalUnitId - , platformOS platform == OSMinGW32 - -> ["-DCOMPILING_GHC_INTERNAL_PACKAGE"] - _ -> []) + ++ (if + | isHomeUnitId home_unit ghcInternalUnitId + , platformOS platform == OSMinGW32 + -> ["-DCOMPILING_GHC_INTERNAL_PACKAGE"] + | otherwise -> []) -- GCC 4.6+ doesn't like -Wimplicit when compiling C++. ++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx) ===================================== compiler/GHC/Driver/Session/Units.hs ===================================== @@ -17,9 +17,9 @@ import GHC.Driver.Config.Diagnostic import GHC.Unit.Env import GHC.Unit (UnitId) +import GHC.Unit.Home (homeUnitId) import GHC.Unit.Home.PackageTable import qualified GHC.Unit.Home.Graph as HUG -import GHC.Unit.State ( emptyUnitState ) import qualified GHC.Unit.State as State import GHC.Types.SrcLoc @@ -125,23 +125,24 @@ initMulti unitArgsFiles lintDynFlagsAndSrcs = do checkDuplicateUnits initial_dflags (NE.toList (NE.zip unitArgsFiles unitDflags)) - (initial_home_graph, mainUnitId) <- liftIO $ createUnitEnvFromFlags unitDflags - let home_units = HUG.allUnits initial_home_graph + let home_units = Set.fromList $ map homeUnitId_ $ NE.toList unitDflags - home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do - let hue_flags = homeUnitEnv_dflags homeUnitEnv - dflags = homeUnitEnv_dflags homeUnitEnv - (unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags (hscUIC hsc_env) home_units + home_unit_envs <- forM unitDflags $ \dflags -> do + emptyHpt <- liftIO $ emptyHomePackageTable + (unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger dflags (hscUIC hsc_env) home_units updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants - emptyHpt <- liftIO $ emptyHomePackageTable pure $ HomeUnitEnv { homeUnitEnv_units = unit_state , homeUnitEnv_dflags = updated_dflags , homeUnitEnv_hpt = emptyHpt - , homeUnitEnv_home_unit = Just home_unit + , homeUnitEnv_home_unit = home_unit } + + let mainUnitId = homeUnitId $ homeUnitEnv_home_unit $ NE.head home_unit_envs + let home_unit_graph = HUG.hugFromHomeUnitEnvs $ NE.toList home_unit_envs + checkUnitCycles initial_dflags home_unit_graph let dflags = homeUnitEnv_dflags $ HUG.unitEnv_lookup mainUnitId home_unit_graph @@ -237,16 +238,3 @@ offsetDynFlags dflags = augment_maybe (Just f) = Just (augment f) augment f | isRelative f, Just offset <- workingDirectory dflags = offset </> f | otherwise = f - - -createUnitEnvFromFlags :: NE.NonEmpty DynFlags -> IO (HomeUnitGraph, UnitId) -createUnitEnvFromFlags unitDflags = do - unitEnvList <- forM unitDflags $ \dflags -> do - emptyHpt <- emptyHomePackageTable - let newInternalUnitEnv = - HUG.mkHomeUnitEnv emptyUnitState dflags emptyHpt Nothing - return (homeUnitId_ dflags, newInternalUnitEnv) - let activeUnit = fst $ NE.head unitEnvList - return (HUG.hugFromList (NE.toList unitEnvList), activeUnit) - - ===================================== compiler/GHC/HsToCore/Usage.hs ===================================== @@ -82,7 +82,7 @@ mkUsageInfo uc plugins fc unit_env = do file_hashes <- liftIO $ mapM getFileHash dependent_files dirs_hashes <- liftIO $ mapM getDirHash dependent_dirs - let hu = ue_unsafeHomeUnit unit_env + let hu = ue_homeUnit unit_env -- Dependencies on object files due to TH and plugins object_usages <- liftIO $ mkObjectUsage plugins fc needed_links needed_pkgs let all_home_ids = HUG.allUnits (ue_home_unit_graph unit_env) ===================================== compiler/GHC/Iface/Errors.hs ===================================== @@ -27,20 +27,20 @@ badIfaceFile file err = vcat [text "Bad interface file:" <+> text file, nest 4 err] -cannotFindInterface :: UnitState -> Maybe HomeUnit -> Profile +cannotFindInterface :: UnitState -> HomeUnit -> Profile -> ModuleName -> InstalledFindResult -> MissingInterfaceError -cannotFindInterface us mhu p mn ifr = +cannotFindInterface us hu p mn ifr = CantFindErr us FindingInterface $ - cantFindInstalledErr us mhu p mn ifr + cantFindInstalledErr us hu p mn ifr cantFindInstalledErr :: UnitState - -> Maybe HomeUnit + -> HomeUnit -> Profile -> ModuleName -> InstalledFindResult -> CantFindInstalled -cantFindInstalledErr unit_state mhome_unit profile mod_name find_result +cantFindInstalledErr unit_state home_unit profile mod_name find_result = CantFindInstalled mod_name more_info where build_tag = waysBuildTag (profileWays profile) @@ -52,7 +52,7 @@ cantFindInstalledErr unit_state mhome_unit profile mod_name find_result InstalledNotFound files mb_pkg | Just pkg <- mb_pkg - , notHomeUnitId mhome_unit pkg + , not (isHomeUnitId home_unit pkg) -> not_found_in_package pkg $ fmap unsafeDecodeUtf files | null files @@ -102,7 +102,7 @@ cantFindErr _ _ mod_name (FoundMultiple mods) cantFindErr unit_env profile mod_name find_result = CantFindInstalled mod_name more_info where - mhome_unit = ue_homeUnit unit_env + home_unit = ue_homeUnit unit_env more_info = case find_result of NoPackage pkg @@ -111,12 +111,7 @@ cantFindErr unit_env profile mod_name find_result , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens , fr_unusables = unusables, fr_suggestions = suggest } | Just pkg <- mb_pkg - , Nothing <- mhome_unit -- no home-unit - -> not_found_in_package (toUnitId pkg) files - - | Just pkg <- mb_pkg - , Just home_unit <- mhome_unit -- there is a home-unit but the - , not (isHomeUnit home_unit pkg) -- module isn't from it + , not (isHomeUnit home_unit pkg) -- module isn't from this home unit -> not_found_in_package (toUnitId pkg) files | not (null suggest) ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -782,14 +782,14 @@ loadInterface doc_str mod from -- Check whether we have the interface already ; hsc_env <- getTopEnv - ; let mhome_unit = ue_homeUnit (hsc_unit_env hsc_env) + ; let home_unit = ue_homeUnit (hsc_unit_env hsc_env) ; liftIO (lookupIfaceByModule hug (eps_PIT eps) mod) >>= \case { Just iface -> return (Succeeded iface) ; -- Already loaded _ -> do { -- READ THE MODULE IN - ; read_result <- case wantHiBootFile mhome_unit eps mod from of + ; read_result <- case wantHiBootFile home_unit eps mod from of Failed err -> return (Failed err) Succeeded hi_boot_file -> do hsc_env <- getTopEnv @@ -885,7 +885,7 @@ loadInterface doc_str mod from ; warnPprTrace bad_boot "loadInterface" (ppr mod) $ updateEps_ $ \ eps -> - if elemModuleEnv mod (eps_PIT eps) || is_external_sig mhome_unit iface + if elemModuleEnv mod (eps_PIT eps) || is_external_sig home_unit iface then eps else if bad_boot -- See Note [Loading your own hi-boot file] @@ -1050,12 +1050,12 @@ dontLeakTheHUG thing_inside = do -- | Returns @True@ if a 'ModIface' comes from an external package. -- In this case, we should NOT load it into the EPS; the entities -- should instead come from the local merged signature interface. -is_external_sig :: Maybe HomeUnit -> ModIface -> Bool -is_external_sig mhome_unit iface = +is_external_sig :: HomeUnit -> ModIface -> Bool +is_external_sig home_unit iface = -- It's a signature iface... mi_semantic_module iface /= mi_module iface && -- and it's not from the local package - notHomeModuleMaybe mhome_unit (mi_module iface) + notHomeModule home_unit (mi_module iface) -- | This is an improved version of 'findAndReadIface' which can also -- handle the case when a user requests @p[A=<B>]:M@ but we only @@ -1079,13 +1079,12 @@ computeInterface -> IO (MaybeErr MissingInterfaceError (ModIface, ModLocation)) computeInterface hsc_env doc_str hi_boot_file mod0 = do massert (not (isHoleModule mod0)) - let mhome_unit = hsc_home_unit_maybe hsc_env + let home_unit = hsc_home_unit hsc_env let find_iface m = findAndReadIface hsc_env doc_str m mod0 hi_boot_file case getModuleInstantiation mod0 of (imod, Just indef) - | Just home_unit <- mhome_unit - , isHomeUnitIndefinite home_unit -> + | isHomeUnitIndefinite home_unit -> find_iface imod >>= \case Succeeded (iface0, path) -> rnModIface hsc_env (instUnitInsts (moduleUnit indef)) Nothing iface0 >>= \case @@ -1142,13 +1141,13 @@ moduleFreeHolesPrecise doc_str mod return (Succeeded (renameFreeHoles ifhs insts)) Failed err -> return (Failed err) -wantHiBootFile :: Maybe HomeUnit -> ExternalPackageState -> Module -> WhereFrom +wantHiBootFile :: HomeUnit -> ExternalPackageState -> Module -> WhereFrom -> MaybeErr MissingInterfaceError IsBootInterface -- Figure out whether we want Foo.hi or Foo.hi-boot -wantHiBootFile mhome_unit eps mod from +wantHiBootFile home_unit eps mod from = case from of ImportByUser usr_boot - | usr_boot == IsBoot && notHomeModuleMaybe mhome_unit mod + | usr_boot == IsBoot && notHomeModule home_unit mod -> Failed (BadSourceImport mod) | otherwise -> Succeeded usr_boot @@ -1156,7 +1155,7 @@ wantHiBootFile mhome_unit eps mod from -> Succeeded NotBoot ImportBySystem - | notHomeModuleMaybe mhome_unit mod + | notHomeModule home_unit mod -> Succeeded NotBoot -- If the module to be imported is not from this package -- don't look it up in eps_is_boot, because that is keyed @@ -1230,7 +1229,7 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do let profile = targetProfile dflags unit_state = hsc_units hsc_env name_cache = hsc_NC hsc_env - mhome_unit = hsc_home_unit_maybe hsc_env + home_unit = hsc_home_unit hsc_env dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env hooks = hsc_hooks hsc_env @@ -1269,7 +1268,7 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do trace_if logger (text "...not found") return $ Failed $ cannotFindInterface unit_state - mhome_unit + home_unit profile (moduleName mod) err ===================================== compiler/GHC/Linker/Deps.hs ===================================== @@ -160,22 +160,18 @@ get_link_deps opts pls maybe_normal_osuf span mods = do = HUG.lookupHugByModule mod (ue_home_unit_graph unit_env) >>= \case Just mod_info -> adjust_linkable (expectJust (homeModLinkable mod_info)) Nothing -> 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 - - let fc = ldFinderCache opts - let fopts = ldFinderOpts opts - mb_stuff <- findHomeModule fc fopts home_unit (moduleName mod) - case mb_stuff of - Found loc _ -> do - from_bc <- ldLoadByteCode opts mod loc - maybe (fallback_no_bytecode home_unit mod) pure from_bc - _ -> fallback_no_bytecode home_unit mod + -- It's not in the HPT because we are in one shot mode, + -- so use the Finder to get a ModLocation... + let fc = ldFinderCache opts + let fopts = ldFinderOpts opts + mb_stuff <- findHomeModule fc fopts hu (moduleName mod) + case mb_stuff of + Found loc _ -> do + from_bc <- ldLoadByteCode opts mod loc + maybe (fallback_no_bytecode hu mod) pure from_bc + _ -> fallback_no_bytecode hu mod where - + hu = ue_homeUnit unit_env fallback_no_bytecode home_unit mod = do let fc = ldFinderCache opts let fopts = ldFinderOpts opts ===================================== compiler/GHC/Rename/Names.hs ===================================== @@ -487,7 +487,7 @@ renamePkgQual :: UnitEnv -> ModuleName -> Maybe FastString -> PkgQual renamePkgQual unit_env mn mb_pkg = case mb_pkg of Nothing -> NoPkgQual Just pkg_fs - | Just uid <- homeUnitId <$> ue_homeUnit unit_env + | uid <- homeUnitId (ue_homeUnit unit_env) , pkg_fs == fsLit "this" -> ThisPkg uid ===================================== compiler/GHC/StgToJS/Linker/Linker.hs ===================================== @@ -485,17 +485,15 @@ computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache ar_cache let load_info mod = do -- Adapted from the tangled code in GHC.Linker.Loader.getLinkDeps. linkable <- HUG.lookupHugByModule mod (ue_home_unit_graph unit_env) >>= \case - Nothing -> + Nothing -> 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 -> pprPanic "getDeps: No home-unit: " (pprModule mod) - Just home_unit -> do - mb_stuff <- findHomeModule finder_cache finder_opts home_unit (moduleName mod) - case mb_stuff of - Found loc mod -> found loc mod - _ -> pprPanic "getDeps: Couldn't find home-module: " (pprModule mod) + mb_stuff <- findHomeModule finder_cache finder_opts home_unit (moduleName mod) + case mb_stuff of + Found loc mod -> found loc mod + _ -> pprPanic "getDeps: Couldn't find home-module: " (pprModule mod) where + home_unit = ue_homeUnit unit_env found loc mod = do { mb_lnk <- findObjectLinkableMaybe mod loc ; case mb_lnk of { ===================================== compiler/GHC/Tc/Utils/Backpack.hs ===================================== @@ -286,11 +286,11 @@ implicitRequirements hsc_env normal_imports forM normal_imports $ \e -> do found <- resolveImport hsc_env e case found of - Found _ mod | notHomeModuleMaybe mhome_unit mod -> + Found _ mod | notHomeModule home_unit mod -> return (uniqDSetToList (moduleFreeHoles mod)) _ -> return [] where - mhome_unit = hsc_home_unit_maybe hsc_env + home_unit = hsc_home_unit hsc_env -- | Like @implicitRequirements'@, but returns the instantiated unit the -- imported module is from, so that that instantiated unit can be processed and @@ -302,13 +302,13 @@ implicitRequirementsShallow -> IO [InstantiatedUnit] implicitRequirementsShallow hsc_env normal_imports = go [] normal_imports where - mhome_unit = hsc_home_unit_maybe hsc_env + home_unit = hsc_home_unit hsc_env go acc [] = pure acc go accR (e:imports) = do found <- resolveImport hsc_env e let acc' = case found of - Found _ mod | notHomeModuleMaybe mhome_unit mod -> + Found _ mod | notHomeModule home_unit mod -> case moduleUnit mod of HoleUnit -> panic "implicitRequirementsShallow: HoleUnit is unreachable through findImportedModule!" RealUnit _ -> accR ===================================== compiler/GHC/Tc/Utils/Env.hs ===================================== @@ -180,8 +180,8 @@ lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr (Either Name IfaceMessage) lookupGlobal_maybe hsc_env name = do { -- Try local envt let mod = icInteractiveModule (hsc_IC hsc_env) - mhome_unit = hsc_home_unit_maybe hsc_env - tcg_semantic_mod = homeModuleInstantiation mhome_unit mod + home_unit = hsc_home_unit hsc_env + tcg_semantic_mod = homeModuleInstantiation home_unit mod ; if nameIsLocalOrFrom tcg_semantic_mod name then return $ Failed $ Left name ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -371,7 +371,7 @@ initTcGblEnv hsc_env hsc_src keep_rn_syntax mod loc = ; let -- bangs to avoid leaking the env (#19356) !dflags = hsc_dflags hsc_env - !mhome_unit = hsc_home_unit_maybe hsc_env + !home_unit = hsc_home_unit hsc_env !logger = hsc_logger hsc_env maybe_rn_syntax :: forall a. a -> Maybe a ; @@ -399,7 +399,7 @@ initTcGblEnv hsc_env hsc_src keep_rn_syntax mod loc = , tcg_th_docs = th_docs_var , tcg_mod = mod - , tcg_semantic_mod = homeModuleInstantiation mhome_unit mod + , tcg_semantic_mod = homeModuleInstantiation home_unit mod , tcg_src = hsc_src , tcg_rdr_env = emptyGlobalRdrEnv , tcg_fix_env = emptyNameEnv @@ -2574,11 +2574,11 @@ initIfaceTcRn thing_inside = do { tcg_env <- getGblEnv ; hsc_env <- getTopEnv -- bangs to avoid leaking the envs (#19356) - ; let !mhome_unit = hsc_home_unit_maybe hsc_env + ; let !home_unit = hsc_home_unit hsc_env !knot_vars = tcg_knot_vars tcg_env -- When we are instantiating a signature, -- we DEFINITELY do not want to knot tie. - is_instantiate = fromMaybe False (isHomeUnitInstantiating <$> mhome_unit) + is_instantiate = isHomeUnitInstantiating home_unit if_env = IfGblEnv { if_doc = text "initIfaceTcRn" , if_rec_types = if is_instantiate ===================================== compiler/GHC/Unit/Env.hs ===================================== @@ -53,7 +53,6 @@ module GHC.Unit.Env , ue_unitHomeUnit_maybe , ue_updateHomeUnitEnv , ue_all_home_unit_ids - , ue_unsafeHomeUnit -- * HUG Re-export , HomeUnitGraph @@ -235,14 +234,13 @@ preloadUnitsInfo' unit_env ids0 = all_infos where unit_state = HUG.homeUnitEnv_units (ue_currentHomeUnitEnv unit_env) ids = ids0 ++ inst_ids - inst_ids = case ue_homeUnit unit_env of - Nothing -> [] - Just home_unit - -- An indefinite package will have insts to HOLE, - -- which is not a real package. Don't look it up. - -- Fixes #14525 - | isHomeUnitIndefinite home_unit -> [] - | otherwise -> map (toUnitId . moduleUnit . snd) (homeUnitInstantiations home_unit) + home_unit = ue_homeUnit unit_env + inst_ids + -- An indefinite package will have insts to HOLE, + -- which is not a real package. Don't look it up. + -- Fixes #14525 + | isHomeUnitIndefinite home_unit = [] + | otherwise = map (toUnitId . moduleUnit . snd) (homeUnitInstantiations home_unit) pkg_map = unitInfoMap unit_state preload = preloadUnits unit_state @@ -320,20 +318,15 @@ ue_setFlags dflags env = -- Query and modify home units in HomeUnitEnv -- ------------------------------------------------------- -ue_homeUnit :: UnitEnv -> Maybe HomeUnit +ue_homeUnit :: UnitEnv -> HomeUnit ue_homeUnit = HUG.homeUnitEnv_home_unit . ue_currentHomeUnitEnv -ue_unsafeHomeUnit :: UnitEnv -> HomeUnit -ue_unsafeHomeUnit ue = case ue_homeUnit ue of - Nothing -> panic "ue_unsafeHomeUnit: No home unit" - Just h -> h - ue_unitHomeUnit :: UnitId -> UnitEnv -> HomeUnit ue_unitHomeUnit uid = expectJust . ue_unitHomeUnit_maybe uid ue_unitHomeUnit_maybe :: UnitId -> UnitEnv -> Maybe HomeUnit ue_unitHomeUnit_maybe uid ue_env = - HUG.homeUnitEnv_home_unit =<< HUG.lookupHugUnitId uid (ue_home_unit_graph ue_env) + HUG.homeUnitEnv_home_unit <$> HUG.lookupHugUnitId uid (ue_home_unit_graph ue_env) -- ------------------------------------------------------- -- Query and modify the currently active unit ===================================== compiler/GHC/Unit/Finder.hs ===================================== @@ -5,6 +5,7 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE MultiWayIf #-} -- | Module finder module GHC.Unit.Finder ( @@ -210,7 +211,7 @@ findImportedModule -> IO FindResult findImportedModule hsc_env scope mod pkg_qual = let fc = hsc_FC hsc_env - mb_home_unit = hsc_home_unit_maybe hsc_env + home_unit = hsc_home_unit hsc_env dflags = hsc_dflags hsc_env fopts = initFinderOpts dflags providers = mgHomeModuleNameProvidersMap (hsc_mod_graph hsc_env) @@ -220,7 +221,7 @@ findImportedModule hsc_env scope mod pkg_qual = fopts (hsc_unit_env hsc_env) providers - mb_home_unit + home_unit scope mod pkg_qual @@ -230,33 +231,30 @@ findImportedModuleNoHsc -> FinderOpts -> UnitEnv -> HomeModuleNameProvidersMap - -> Maybe HomeUnit + -> HomeUnit -> ModuleLookupScope -> ModuleName -> PkgQual -> IO FindResult -findImportedModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit scope mod_name mb_pkg = +findImportedModuleNoHsc fc fopts ue home_module_name_providers_map home_unit scope mod_name mb_pkg = case mb_pkg of NoPkgQual -> unqual_import - ThisPkg uid | (homeUnitId <$> mb_home_unit) == Just uid -> home_import + ThisPkg uid | homeUnitId home_unit == uid -> home_import | Just os <- lookup uid other_fopts -> home_pkg_import (uid, os) - | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mb_home_unit) $$ ppr uid $$ ppr (map fst all_opts)) + | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr home_unit_id $$ ppr uid $$ ppr (map fst all_opts)) OtherPkg _ -> pkg_import where - mb_home_unit_id :: Maybe UnitId - mb_home_unit_id = homeUnitId <$> mb_home_unit + home_unit_id :: UnitId + home_unit_id = homeUnitId home_unit all_opts :: [(UnitId, FinderOpts)] - all_opts = case mb_home_unit_id of - Nothing -> other_fopts - Just home_unit_id -> (home_unit_id, fopts) : other_fopts + all_opts = + (home_unit_id, fopts) : other_fopts home_import :: IO FindResult - home_import = case mb_home_unit of - Just home_unit -> findHomeModule fc fopts home_unit mod_name - Nothing -> pure $ - NoPackage (panic "findImportedModule: no home-unit") + home_import = + findHomeModule fc fopts home_unit mod_name home_pkg_import :: (UnitId, FinderOpts) -> IO FindResult home_pkg_import = findHomeUnitDepModule fc ue home_module_name_providers_map scope mod_name @@ -266,13 +264,11 @@ findImportedModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit unqual_import :: IO FindResult unqual_import = findHomeOrRegularPackageModule fc fopts ue - home_module_name_providers_map mb_home_unit scope mod_name + home_module_name_providers_map home_unit scope mod_name unit_state :: UnitState - unit_state = case mb_home_unit_id of - Nothing -> ue_homeUnitState ue - Just home_unit_id -> HUG.homeUnitEnv_units $ - ue_findHomeUnitEnv home_unit_id ue + unit_state = HUG.homeUnitEnv_units $ + ue_findHomeUnitEnv home_unit_id ue other_fopts :: [(UnitId, FinderOpts)] other_fopts = homeUnitDepsFinderOpts ue home_module_name_providers_map @@ -287,28 +283,26 @@ findPluginModuleNoHsc -> FinderOpts -> UnitEnv -> HomeModuleNameProvidersMap - -> Maybe HomeUnit + -> HomeUnit -> ModuleName -> IO FindResult -findPluginModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit@(Just home_unit) mod_name = +findPluginModuleNoHsc fc fopts ue home_module_name_providers_map home_unit mod_name = findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map - mb_home_unit LookupUser mod_name + home_unit LookupUser mod_name `orIfNotFound` findExposedPluginPackageModule fc fopts unit_state mod_name where unit_state = HUG.homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue -findPluginModuleNoHsc fc fopts ue _ Nothing mod_name = - findExposedPluginPackageModule fc fopts (ue_homeUnitState ue) mod_name findPluginModule :: HscEnv -> ModuleName -> IO FindResult findPluginModule hsc_env mod_name = do let fc = hsc_FC hsc_env - mb_home_unit = hsc_home_unit_maybe hsc_env + home_unit = hsc_home_unit hsc_env home_module_name_providers_map = mgHomeModuleNameProvidersMap (hsc_mod_graph hsc_env) findPluginModuleNoHsc fc (initFinderOpts (hsc_dflags hsc_env)) - (hsc_unit_env hsc_env) home_module_name_providers_map mb_home_unit mod_name + (hsc_unit_env hsc_env) home_module_name_providers_map home_unit mod_name -- ----------------------------------------------------------------------------- -- Home Module Finder Helpers @@ -380,7 +374,7 @@ findHomeUnitDepModule fc ue home_module_name_providers_map scope mod_name (uid, | Just real_mod_name <- lookupUniqMap (finder_reexportedModules opts) mod_name = findHomeOrRegularPackageModule fc opts ue home_module_name_providers_map - (Just $ DefiniteHomeUnit uid Nothing) + (DefiniteHomeUnit uid Nothing) scope real_mod_name | elementOfUniqSet mod_name (finder_hiddenModules opts) , LookupUser <- scope -- A system lookup is allowed to find hidden modules. @@ -397,27 +391,22 @@ findHomeModuleAmongDeps -> FinderOpts -> UnitEnv -> HomeModuleNameProvidersMap - -> Maybe HomeUnit + -> HomeUnit -> ModuleLookupScope -> ModuleName -> IO FindResult -findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map mb_home_unit scope mod_name = +findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map home_unit scope mod_name = foldr1 orIfNotFound (home_import :| map home_pkg_import other_fopts) -- Do not try to be smart and change this to `foldr orIfNotFound home_import -- (map home_pkg_import other_fopts)`, as that would not be the same. -- `home_import` is first because we need to first look within the current -- unit before looking at the other units in order. where - home_import = case mb_home_unit of - Just home_unit -> findHomeModule fc fopts home_unit mod_name - Nothing -> pure $ - NoPackage (panic "findHomeModuleAmongDeps: no home-unit") + home_import = findHomeModule fc fopts home_unit mod_name + home_pkg_import = findHomeUnitDepModule fc ue home_module_name_providers_map scope mod_name - unit_state = case homeUnitId <$> mb_home_unit of - Nothing -> ue_homeUnitState ue - Just home_unit_id -> HUG.homeUnitEnv_units $ - ue_findHomeUnitEnv home_unit_id ue + unit_state = HUG.homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue other_fopts = homeUnitDepsFinderOpts ue home_module_name_providers_map unit_state mod_name @@ -428,33 +417,31 @@ findHomeOrRegularPackageModule -> FinderOpts -> UnitEnv -> HomeModuleNameProvidersMap - -> Maybe HomeUnit + -> HomeUnit -> ModuleLookupScope -> ModuleName -> IO FindResult -findHomeOrRegularPackageModule fc fopts ue home_module_name_providers_map mb_home_unit scope mod_name = +findHomeOrRegularPackageModule fc fopts ue home_module_name_providers_map home_unit scope mod_name = findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map - mb_home_unit scope mod_name + home_unit scope mod_name `orIfNotFound` findExposedPackageModule fc fopts unit_state scope mod_name NoPkgQual where - unit_state = case homeUnitId <$> mb_home_unit of - Nothing -> ue_homeUnitState ue - Just home_unit_id -> HUG.homeUnitEnv_units $ - ue_findHomeUnitEnv home_unit_id ue + unit_state = HUG.homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue -- | A version of findExactModule which takes the exact parts of the HscEnv it needs -- directly. -findExactModuleNoHsc :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IsBootInterface -> IO InstalledFindResult -findExactModuleNoHsc fc fopts other_fopts unit_state mb_home_unit mod is_boot = do - res <- case mb_home_unit of - Just home_unit +findExactModuleNoHsc :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> HomeUnit -> InstalledModule -> IsBootInterface -> IO InstalledFindResult +findExactModuleNoHsc fc fopts other_fopts unit_state home_unit mod is_boot = do + res <- + if | isHomeInstalledModule home_unit mod -> findInstalledHomeModule fc fopts (homeUnitId home_unit) (moduleName mod) | Just home_fopts <- HUG.unitEnv_lookup_maybe (moduleUnit mod) other_fopts -> findInstalledHomeModule fc home_fopts (moduleUnit mod) (moduleName mod) - _ -> findPackageModule fc unit_state fopts mod + | otherwise + -> findPackageModule fc unit_state fopts mod case (res, is_boot) of (InstalledFound loc, IsBoot) -> return (InstalledFound (addBootSuffixLocn loc)) _ -> return res @@ -470,7 +457,7 @@ findExactModule hsc_env mod is_boot = do let dflags = hsc_dflags hsc_env let fc = hsc_FC hsc_env let unit_state = hsc_units hsc_env - let home_unit = hsc_home_unit_maybe hsc_env + let home_unit = hsc_home_unit hsc_env let other_fopts = initFinderOpts . homeUnitEnv_dflags <$> (hsc_HUG hsc_env) findExactModuleNoHsc fc (initFinderOpts dflags) other_fopts unit_state home_unit mod is_boot ===================================== compiler/GHC/Unit/Home.hs ===================================== @@ -18,9 +18,7 @@ module GHC.Unit.Home , isHomeUnitInstanceOf , isHomeModule , isHomeInstalledModule - , notHomeUnitId , notHomeModule - , notHomeModuleMaybe , notHomeInstalledModule , notHomeInstalledModuleMaybe -- * Helpers @@ -144,11 +142,6 @@ isHomeUnit hu u = u == homeUnitAsUnit hu isHomeUnitId :: GenHomeUnit u -> UnitId -> Bool isHomeUnitId hu uid = uid == homeUnitId hu --- | Test if the unit-id is not the home unit-id -notHomeUnitId :: Maybe (GenHomeUnit u) -> UnitId -> Bool -notHomeUnitId Nothing _ = True -notHomeUnitId (Just hu) uid = not (isHomeUnitId hu uid) - -- | Test if the home unit is an instance of the given unit-id isHomeUnitInstanceOf :: HomeUnit -> UnitId -> Bool isHomeUnitInstanceOf hu u = homeUnitInstanceOf hu == u @@ -175,10 +168,6 @@ notHomeInstalledModuleMaybe mh m = fromMaybe True $ fmap (`notHomeInstalledModul notHomeModule :: HomeUnit -> Module -> Bool notHomeModule hu m = not (isHomeModule hu m) --- | Test if a module doesn't come from the given home unit -notHomeModuleMaybe :: Maybe HomeUnit -> Module -> Bool -notHomeModuleMaybe mh m = fromMaybe True $ fmap (`notHomeModule` m) mh - ---------------------------- -- helpers ---------------------------- @@ -211,9 +200,8 @@ homeModuleNameInstantiation hu mod_name = -- the instantiating module of @r:A@ in @p[A=q[]:B]@ is @r:A@. -- the instantiating module of @p:A@ in @p@ is @p:A@. -- the instantiating module of @r:A@ in @p@ is @r:A@. -homeModuleInstantiation :: Maybe HomeUnit -> Module -> Module -homeModuleInstantiation mhu mod - | Just hu <- mhu - , isHomeModule hu mod = homeModuleNameInstantiation hu (moduleName mod) +homeModuleInstantiation :: HomeUnit -> Module -> Module +homeModuleInstantiation hu mod + | isHomeModule hu mod = homeModuleNameInstantiation hu (moduleName mod) | otherwise = mod ===================================== compiler/GHC/Unit/Home/Graph.hs ===================================== @@ -50,6 +50,7 @@ module GHC.Unit.Home.Graph -- * Utilities , hugSCCs , hugFromList + , hugFromHomeUnitEnvs -- ** Printing , pprHomeUnitGraph @@ -150,11 +151,11 @@ data HomeUnitEnv = HomeUnitEnv -- -- (This changes a previous invariant: changed Jan 05.) - , homeUnitEnv_home_unit :: !(Maybe HomeUnit) + , homeUnitEnv_home_unit :: !HomeUnit -- ^ Home-unit } -mkHomeUnitEnv :: UnitState -> DynFlags -> HomePackageTable -> Maybe HomeUnit -> HomeUnitEnv +mkHomeUnitEnv :: UnitState -> DynFlags -> HomePackageTable -> HomeUnit -> HomeUnitEnv mkHomeUnitEnv us dflags hpt home_unit = HomeUnitEnv { homeUnitEnv_units = us , homeUnitEnv_dflags = dflags @@ -363,6 +364,9 @@ hugSCCs hug = sccs where hugFromList :: [(UnitId, HomeUnitEnv)] -> HomeUnitGraph hugFromList = UnitEnvGraph . Map.fromList +hugFromHomeUnitEnvs :: [HomeUnitEnv] -> HomeUnitGraph +hugFromHomeUnitEnvs = hugFromList . fmap (\hue -> (homeUnitId $ homeUnitEnv_home_unit hue, hue)) + pprHomeUnitGraph :: HomeUnitGraph -> IO SDoc pprHomeUnitGraph unitEnv = do docs <- mapM (\(k, v) -> pprHomeUnitEnv k v) $ Map.assocs $ unitEnv_graph unitEnv @@ -372,6 +376,6 @@ pprHomeUnitEnv :: UnitId -> HomeUnitEnv -> IO SDoc pprHomeUnitEnv uid env = do hptDoc <- pprHPT $ homeUnitEnv_hpt env return $ - ppr uid <+> text "(flags:" <+> ppr (homeUnitId_ $ homeUnitEnv_dflags env) <> text "," <+> ppr (fmap homeUnitId $ homeUnitEnv_home_unit env) <> text ")" <+> text "->" + ppr uid <+> text "(flags:" <+> ppr (homeUnitId_ $ homeUnitEnv_dflags env) <> text "," <+> ppr (homeUnitId $ homeUnitEnv_home_unit env) <> text ")" <+> text "->" $$ nest 4 hptDoc ===================================== ghc/GHCi/UI.hs ===================================== @@ -861,7 +861,7 @@ installInteractiveHomeUnits dflags = do (unit_state,home_unit,_mconstants) <- liftIO $ initUnits logger dflags unit_index all_home_units hpt <- liftIO emptyHomePackageTable - pure (HUG.mkHomeUnitEnv unit_state dflags hpt (Just home_unit)) + pure (HUG.mkHomeUnitEnv unit_state dflags hpt home_unit) concatPackageDbStacksUsingLongestCommonPrefix :: [[PackageDBFlag]] -> [PackageDBFlag] concatPackageDbStacksUsingLongestCommonPrefix stacks' = ===================================== testsuite/tests/simplCore/should_compile/T7803.hs ===================================== @@ -0,0 +1,23 @@ +{-# OPTIONS_GHC -ddump-simpl #-} + +-- #7803: foo1 should be fully specialised at Double. In the bug report +-- it ended up calling the overloaded exp5Tail (with a dictionary argument), +-- because the specialiser ran before the overloaded call was floated to +-- the top level. So the dumped Core for this module must mention no +-- exp5Tail at all. +module T7803 (foo1) where + +import T7803a + +bar :: Floating a => a -> a -> a +bar z = subtract (evaluate integ z) . evaluate integ + where + integ = indefinite (Piecewise [Poly4 1]) +{-# SPECIALIZE bar :: Double -> Double -> Double #-} + +foo :: Floating a => a -> a -> a +foo x = bar x +{-# SPECIALIZE foo :: Double -> Double -> Double #-} + +foo1 :: Double -> Double -> Double +foo1 x = foo x ===================================== testsuite/tests/simplCore/should_compile/T7803.stderr ===================================== @@ -0,0 +1 @@ +foo1 ===================================== testsuite/tests/simplCore/should_compile/T7803a.hs ===================================== @@ -0,0 +1,73 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module T7803a + ( Evaluate (..) + , HasIntegral (..) + , Poly4 (..) + , Domain + , IntOfLogPoly4 (..) + , Piecewise (..) + ) where + +import Data.Kind (Constraint, Type) + +class Evaluate poly where + evaluate :: (Domain' poly a) => poly a -> a -> a + +class Evaluate (IntegralOf poly) => HasIntegral poly where + type IntegralOf poly :: Type -> Type + indefinite :: (Domain' poly a, Domain' (IntegralOf poly) a) + => poly a -> IntegralOf poly a + +type family Domain (f :: Type -> Type) a :: Constraint + +class Domain f a => Domain' f a +instance Domain f a => Domain' f a + +newtype Poly4 a = Poly4 { poly4_a :: a } + +type instance Domain Poly4 a = Fractional a + +data IntOfLogPoly4 a = IntOfLogPoly4 { ilp4_k :: !a, ilp4_u :: !a } + +type instance Domain IntOfLogPoly4 a = Floating a + +instance Evaluate IntOfLogPoly4 where + evaluate (IntOfLogPoly4 k _) x = k + x * exp5Tail (- log x) + {-# INLINE evaluate #-} + +{-# RULES "exp5Tail/Double" exp5Tail = exp5TailDouble #-} +{-# NOINLINE exp5Tail #-} + +exp5Tail :: (Floating a) => a -> a +exp5Tail x = x / 120 + +exp5TailDouble :: Double -> Double +exp5TailDouble x = x / 120 + +instance HasIntegral Poly4 where + type IntegralOf Poly4 = IntOfLogPoly4 + indefinite = \ (Poly4 a) -> IntOfLogPoly4 0 a + {-# INLINE indefinite #-} + +newtype Piecewise poly a = Piecewise { unPiecewise :: [poly a] } + +type instance Domain (Piecewise poly) a = (Domain poly a, Num a) + +instance (Evaluate poly) => Evaluate (Piecewise poly) where + evaluate = \ (Piecewise pp) x -> + case pp of + p : _ -> evaluate p x + [] -> error "evaluate: empty Piecewise" + {-# INLINE evaluate #-} + +instance (HasIntegral poly) => HasIntegral (Piecewise poly) where + type IntegralOf (Piecewise poly) = Piecewise (IntegralOf poly) + indefinite (Piecewise m) = Piecewise $ map indefinite m + {-# INLINE indefinite #-} ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -148,6 +148,13 @@ test('T7785', [ only_ways(['optasm']), grep_errmsg(r'SPEC') ], compile, ['-ddump-cse']) +# T7803: we expect NO calls to the overloaded 'exp5Tail' in T7803.hs +# In the bug report #7803, the unspecialised call was signalled by 'exp5Tail' +# in foo1's Core, so we grep for that; also for 'foo1', lest we dump nothing +# One module, T7803.hs, has OPTIONS_GHC -ddump-simpl +test('T7803', [ grep_errmsg(r'exp5Tail|foo1') ], + multimod_compile, ['T7803', '-O2 -v0 -dsuppress-all -dsuppress-uniques -dno-typeable-binds']) + test('T7702', [extra_files(['T7702plugin']), pre_cmd('$MAKE -s --no-print-directory -C T7702plugin package.T7702 TOP={top}'), View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/82b7467cd1a20919bc6c24c1b99b421... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/82b7467cd1a20919bc6c24c1b99b421... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help