Florian Ragwitz pushed to branch wip/rafl/hpc-instances at Glasgow Haskell Compiler / GHC Commits: 545fd4fb by ARATA Mizuki at 2026-09-22T15:03:24-04:00 Change the C types of hs_{bitrev,bswap}{16,32} to match the Haskell types bitReverse{16,32}# and byteSwap{16,32}# have the type Word# -> Word#, but their C correspondents took and returned StgWord{16,32}. The mismatch on bitReverse16# led to the problem reported in #27299. Although no similar issue is reported for bitReverse32# and byteSwap{16,32}#, it seemed wise to change them proactively. This commit fixes the mismatch by changing the C type. Fixes #27299 - - - - - bf17f289 by fendor at 2026-09-22T15:04:05-04:00 Don't lose instances from shadowed imported modules with the same name When we look for instances below the current module, we need to check the unit id as well when we check for whether the module is the current module, otherwise we ignore modules we import that have the same name as the import module. Adds regression test. - - - - - 53eead15 by Wolfgang Jeltsch at 2026-09-24T20:12:03-04:00 Correct the documentation of `explicitUnits` Resolves #27787. - - - - - 35bf6f4b by Simon Jakobi at 2026-09-24T20:12:49-04:00 Remove stale specHeader bullet from Note [Don't make fillers for constraint types] The Note said that Specialise.specHeader also calls mkAbsentFiller. abfc224a27c removed that call: the specialiser no longer drops dead arguments at all, see Note [Do not drop dead args from specialisations] in GHC.Core.Opt.Specialise. Assisted-by: Claude Fable 5.1 - - - - - 5cace21b by Florian Ragwitz at 2026-09-25T03:35:29-07:00 hpc: Test desired HPC behaviour for class instances - - - - - 526e0adf by Florian Ragwitz at 2026-09-25T03:35:29-07:00 Extend TcGblEnv with a mapping from instance method Ids to DFunIds We want to use this in HPC to provide better support for instance methods. This is working towards #17155. - - - - - bd9f26ce by Florian Ragwitz at 2026-09-25T03:35:29-07:00 hpc: Do not create top-level boxes for generated instance methods Users care about which of their written methods are or aren't covered, not whether all of the inherited methods are covered as well. Those should be covered where they are implemented. We achieve that by stopping to generate top-level boxes which will often appear as uncovered with no clear indication as to why, and no way to fix other than excercising code the user has not written. Fixes #17155, #15932. - - - - - 32c257cf by Florian Ragwitz at 2026-09-25T03:35:29-07:00 hpc: Provide coverage information for class instances After fixing #17155, we no longer create top-level boxes for the source spans of instance heads (previously that was the source span used for inherited/generated instance methods). With those boxes gone, we can introduce a new top-level box for each class instance with that instance head source span, and provide more meaningful coverage semantics for it. We make the use of any of the instance's methods (user-written or generated) tick this box, providing the programmer with useful information about whether or not the instance was exercised at run-time, and whether the instance might be unnecessary. - - - - - 9c854b13 by Florian Ragwitz at 2026-09-25T03:35:29-07:00 hpc: Don't allocate boxes for methodless classes With the plumbing we currently have, these could never be covered, which is not helpful to hpc users. This could be improved upon further. - - - - - edd502c9 by Florian Ragwitz at 2026-09-25T03:35:29-07:00 Add a changelog entry for new HPC features - - - - - 28 changed files: - + changelog.d/26610 - + changelog.d/hpc-classinsts - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Unit/State.hs - rts/include/stg/Prim.h - rts/prim/bitrev.c - rts/prim/bswap.c - + testsuite/tests/ghci/prog-mhu008/Makefile - + testsuite/tests/ghci/prog-mhu008/a/M.hs - + testsuite/tests/ghci/prog-mhu008/all.T - + testsuite/tests/ghci/prog-mhu008/b/M.hs - + testsuite/tests/ghci/prog-mhu008/prog-mhu008.script - + testsuite/tests/ghci/prog-mhu008/prog-mhu008.stdout - + testsuite/tests/ghci/prog-mhu008/unitA - + testsuite/tests/ghci/prog-mhu008/unitB - + testsuite/tests/hpc/instmeths/instmeths.hs - + testsuite/tests/hpc/instmeths/instmeths.stdout - + testsuite/tests/hpc/instmeths/test.T - + testsuite/tests/primops/should_run/T27299.hs - + testsuite/tests/primops/should_run/T27299.stdout - testsuite/tests/primops/should_run/all.T Changes: ===================================== changelog.d/26610 ===================================== @@ -0,0 +1,7 @@ +section: compiler +synopsis: Fix instance resolution for shadowed modules +description: + Instances imported from modules with the same module name as the importing module + were dropped accidentally since we didn't account for the unit id of the imported module. +mrs: !16648 +issues: #26610 ===================================== changelog.d/hpc-classinsts ===================================== @@ -0,0 +1,23 @@ +section: compiler +synopsis: Improve coverage reporting for class instances and their methods +description: + + Coverage reporting (:ghc-flag:`-fhpc`) now treats class instances more + naturally. + + Compiler-generated instance methods, such as inherited default methods, no + longer receive separate top-level coverage boxes. Explicitly implemented + instance methods retain their own declaration coverage. + + This means that it is no longer necessary to exercise all of a class' methods + in order for it to appear "covered". + + Additionally, top-level coverage boxes are now created for all instances of + classes with methods, and ticked by the use of *any* of the class' methods. + This indicates that an instance was in fact used at run-time. + + Note that classes without any instance methods are currently excluded from + this, and won't have any coverage boxes created. + +mrs: !16632 +issues: #17155 #15932 ===================================== compiler/GHC/Core/Opt/WorkWrap/Utils.hs ===================================== @@ -1367,13 +1367,8 @@ It's surprisingly subtle. application; see test `T27627f`. TL;DR: we play safe: we never make an absent filler for any /constraint-kinded/ type, -using `isPredTy` to decide. - - * `mkAbsentFiller` returns `Nothing` for any constraint type, so worker/wrapper - keeps the real argument. - - * `Specialise.specHeader` calls `mkAbsentFiller` too, so it likewise keeps the - dead dictionary argument rather than dropping it for a filler. +using `isPredTy` to decide: `mkAbsentFiller` returns `Nothing` for any constraint +type, so worker/wrapper keeps the real argument. Prior failed approaches ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -263,13 +263,13 @@ hugCompleteSigsBelow hsc uid mn = foldr (++) [] <$> -- | Find instances visible from the given set of imports hugInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO (InstEnv, [FamInst]) hugInstancesBelow hsc_env uid mnwib = do - let mn = gwib_mod mnwib + let mn = mkModule uid (gwib_mod mnwib) (insts, famInsts) <- unzip . concat <$> hugSomeThingsBelowUs (\mod_info -> let details = hm_details mod_info -- Don't include instances for the current module - in if moduleName (mi_module (hm_iface mod_info)) == mn + in if fmap toUnitId (mi_module (hm_iface mod_info)) == mn then [] else [(md_insts details, md_fam_insts details)]) True -- Include -hi-boot ===================================== compiler/GHC/HsToCore.hs ===================================== @@ -147,6 +147,7 @@ deSugar hsc_env tcg_tcs = tcs, tcg_default_exports = defaults, tcg_insts = insts, + tcg_inst_meths = inst_meths, tcg_fam_insts = fam_insts, tcg_complete_matches = complete_matches, tcg_self_boot = self_boot @@ -170,7 +171,8 @@ deSugar hsc_env (hsc_logger hsc_env) (initTicksConfig (hsc_dflags hsc_env)) mod mod_loc - export_set (typeEnvTyCons type_env) binds + export_set (typeEnvTyCons type_env) + insts inst_meths binds else return (binds, Nothing) ; let modBreaks | Just (_, _, breakpointSpecs) <- m_tickInfo ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -5,7 +5,7 @@ {- (c) Galois, 2006 (c) University of Glasgow, 2007 -(c) Florian Ragwitz, 2025 +(c) Florian Ragwitz, 2025-2026 -} module GHC.HsToCore.Ticks @@ -24,6 +24,8 @@ import GHC.Unit import GHC.Core.Type import GHC.Core.TyCon +import GHC.Core.InstEnv +import GHC.Core.Class import GHC.Data.Maybe import GHC.Data.FastString @@ -56,6 +58,7 @@ import Data.Foldable (toList) import Trace.Hpc.Mix import Data.Bifunctor (second) +import Data.Functor import Data.List.NonEmpty (NonEmpty (..)) import Data.Set (Set) import qualified Data.Set as Set @@ -100,11 +103,15 @@ addTicksToBinds -- isExportedId doesn't work yet (the desugarer -- hasn't set it), so we have to work from this set. -> [TyCon] -- ^ Type constructors in this module + -> [ClsInst] -- ^ Class instances in this module + -> IdEnv DFunId -- ^ Mapping from class method Ids to the DFunIds + -- of the class instance they belong to. See Note + -- [Instance Method Coverage]. -> LHsBinds GhcTc -> IO (LHsBinds GhcTc, Maybe (FilePath, SizedSeq Tick, SizedSeq Tick)) addTicksToBinds logger cfg - mod mod_loc exports tyCons binds + mod mod_loc exports tyCons insts inst_meths binds | let passes = ticks_passes cfg , not (null passes) , Just orig_file <- ml_hs_file mod_loc = do @@ -129,8 +136,13 @@ addTicksToBinds logger cfg , this_mod = mod , tickishType = tickish , recSelBinds = emptyVarEnv + , instMeths = inst_meths + , instTicks = emptyVarEnv } - (binds',_,st') = unTM (addTickLHsBinds binds) env st + addTick = do + instTicks <- allocInstTicks insts + withEnv (\e -> e{ instTicks }) $ addTickLHsBinds binds + (binds',_,st') = unTM addTick env st in (binds', st') (binds1,st) = foldr tickPass (binds, initTTState) passes @@ -231,7 +243,7 @@ addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc) addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds , abs_exports = abs_exports }))) = - withEnv (add_rec_sels . add_inlines . add_exports) $ do + withEnv (add_inst_meths . add_rec_sels . add_inlines . add_exports) $ do binds' <- addTickLHsBinds binds return $ L pos $ XHsBindsLR $ bind { abs_binds = binds' } where @@ -259,19 +271,24 @@ addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds | ABE{ abe_poly, abe_mono } <- abs_exports , RecSelId{} <- [idDetails abe_poly] ] } + add_inst_meths env = + env{ instMeths = instMeths env `extendVarEnvList` + [ (abe_mono, dfun) + | ABE{ abe_poly, abe_mono } <- abs_exports + , Just dfun <- [lookupVarEnv (instMeths env) abe_poly] ] } + addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches }))) = do let name = getOccString id decl_path <- getPathEntry density <- getDensity + env <- getEnv - inline_ids <- liftM inlines getEnv -- See Note [inline sccs] let inline = isInlinePragma (idInlinePragma id) - || id `elemVarSet` inline_ids + || id `elemVarSet` inlines env -- See Note [inline sccs] - tickish <- tickishType `liftM` getEnv - case tickish of { ProfNotes | inline -> return (L pos funBind); _ -> do + case tickishType env of { ProfNotes | inline -> return (L pos funBind); _ -> do -- See Note [Record-selector ticks] selTicks <- recSelTick id @@ -294,16 +311,26 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches toplev = null decl_path exported = idName id `elemNameSet` exported_names - tick <- if not blackListed && - shouldTickBind density toplev exported simple inline + -- See Note [Instance Method Coverage]. + let generatedInstMeth = density == TickForCoverage + && id `elemVarEnv` instMeths env + && isGenerated (mg_origin (mg_ext matches)) + + tick <- if not generatedInstMeth + && not blackListed + && shouldTickBind density toplev exported simple inline then bindTick density name (locA pos) fvs else return Nothing + -- See Note [Instance Method Coverage]. + instTick <- instMethTick id + let mbCons = maybe Prelude.id (:) return $ L pos $ funBind { fun_matches = mg - , fun_ext = second (tick `mbCons`) (fun_ext funBind) } + , fun_ext = second ((instTick `mbCons`) . (tick `mbCons`)) + (fun_ext funBind) } } } where -- See Note [Record-selector ticks] @@ -338,6 +365,32 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches -- This scheme could be extended further in the future, making coverage for -- positional constructor fields mean that the field was accessed at run-time. +-- Note [Instance Method Coverage] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Users expect source-level semantics for coverage reports (see #17155, +-- #15932). That is, code they've written themselves should be marked as covered +-- iff it is evaluated at run-time. Given that the implementation of class +-- instances creates top-level bindings for all methods of an instance, +-- inherited and hand-written, we need to go out of our way to create top-level +-- tick boxes only for methods which correspond to user-written code. +-- +-- To do so, 'addTicksToBinds' receives a mapping from class instance 'Id's to +-- the 'DFunId's of the dictionary backing the associated instance. When +-- creating tick boxes for top-level bindings, we can then decide if a given +-- 'FunBind' corresponds to an inherited/generated instance method of a class +-- and skip creating the tick box for it. +-- +-- Additionally, we also want to inform the user whether or not their class +-- instance as a whole has been used at run-time. To do so, we create a single +-- tick box at the instance head and tick that box when any method of that +-- instance is evaluated. +-- +-- As marker/tag-like class instances without any methods would always appear +-- as uncovered using the above mechanism, we exclude them when creating +-- instance tick boxes. This could potentially be improved in the future by +-- tracking if any functions requiring an instance of an empty class have been +-- evaluated. + -- TODO: Revisit this addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs , pat_rhs = rhs @@ -1098,6 +1151,8 @@ data TickTransEnv = TTE { fileName :: FastString , this_mod :: Module , tickishType :: TickishType , recSelBinds :: IdEnv DVarSet + , instMeths :: IdEnv DFunId + , instTicks :: IdEnv CoreTickish } -- deriving Show @@ -1238,6 +1293,18 @@ isBlackListed (RealSrcSpan pos _) = TM $ \ env st -> (Set.member pos (blackList isBlackListed GeneratedSrcSpan{} = return False isBlackListed UnhelpfulSpan{} = return False +allocInstTicks :: [ClsInst] -> TM (IdEnv CoreTickish) +allocInstTicks insts = + ifDensity TickForCoverage (mkVarEnv . catMaybes <$> mapM alloc insts) (pure emptyVarEnv) + where + alloc ClsInst{ is_dfun, is_cls } + | null (classMethods is_cls) = pure Nothing + | otherwise = fmap (is_dfun,) <$> allocATickBox (TopLevelBox [getOccString is_dfun]) + False True (getSrcSpan is_dfun) noFVs + +instMethTick :: Id -> TM (Maybe CoreTickish) +instMethTick id = getEnv <&> \e -> lookupVarEnv (instMeths e) id >>= lookupVarEnv (instTicks e) + -- the tick application inherits the source position of its -- expression argument to support nested box allocations allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr GhcTc) ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -1766,7 +1766,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, -- Second pass over class and instance declarations, -- now using the kind-checked decls traceTc "Tc6" empty ; - inst_binds <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) inst_infos ; + (inst_binds, inst_meths) <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) inst_infos ; -- Foreign exports traceTc "Tc7" empty ; @@ -1798,8 +1798,9 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, , tcg_anns = tcg_anns tcg_env ++ annotations , tcg_ann_env = extendAnnEnvList (tcg_ann_env tcg_env) annotations , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls - , tcg_dus = tcg_dus tcg_env `plusDU` usesOnly fo_fvs } } ; + , tcg_dus = tcg_dus tcg_env `plusDU` usesOnly fo_fvs -- tcg_dus: see Note [Newtype constructor usage in foreign declarations] + , tcg_inst_meths = tcg_inst_meths tcg_env `plusVarEnv` inst_meths } } ; -- See Note [Newtype constructor usage in foreign declarations] addUsedGREs NoDeprecationWarnings (bagToList fo_gres) ; ===================================== compiler/GHC/Tc/TyCl/Instance.hs ===================================== @@ -1285,7 +1285,7 @@ takes a slightly different approach. ********************************************************************* -} tcInstDecls2 :: [LTyClDecl GhcRn] -> [InstInfo GhcRn] - -> TcM (LHsBinds GhcTc) + -> TcM (LHsBinds GhcTc, IdEnv DFunId) -- (a) From each class declaration, -- generate any default-method bindings -- (b) From each instance decl @@ -1302,11 +1302,11 @@ tcInstDecls2 tycl_decls inst_decls -- Add the default method Ids (again) -- (they were already added in GHC.Tc.TyCl.Utils.tcAddImplicits) -- See Note [Default methods in the type environment] - ; inst_binds_s <- tcExtendGlobalValEnv dm_ids $ - mapM tcInstDecl2 inst_decls + ; (inst_binds_s, inst_meths_s) <- unzip <$> (tcExtendGlobalValEnv dm_ids $ + mapM tcInstDecl2 inst_decls) -- Done - ; return (dm_binds ++ concat inst_binds_s) } + ; return (dm_binds ++ concat inst_binds_s, plusVarEnvList inst_meths_s) } {- Note [Default methods in the type environment] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1322,12 +1322,12 @@ So right here in tcInstDecls2 we must re-extend the type envt with the default method Ids replete with their INLINE pragmas. Urk. -} -tcInstDecl2 :: InstInfo GhcRn -> TcM (LHsBinds GhcTc) +tcInstDecl2 :: InstInfo GhcRn -> TcM (LHsBinds GhcTc, IdEnv DFunId) -- Returns a binding for the dfun tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) - = recoverM (return emptyLHsBinds) $ - setSrcSpan loc $ - addErrCtxt (instDeclCtxt2 dfun_ty) $ + = recoverM (return (emptyLHsBinds, emptyVarEnv)) $ + setSrcSpan loc $ + addErrCtxt (instDeclCtxt2 dfun_ty) $ do { -- Instantiate the instance decl with skolem constants (skol_info, inst_tyvars, dfun_theta, clas, inst_tys) <- tcSkolDFunType dfun_ty ; dfun_ev_vars <- newEvVars dfun_theta @@ -1345,7 +1345,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) -- See Note [Typechecking plan for instance declarations] ; dfun_ev_binds_var <- newTcEvBinds ; let dfun_ev_binds = TcEvBinds dfun_ev_binds_var - ; (tclvl, (sc_meth_ids, sc_meth_binds, sc_meth_implics)) + ; (tclvl, (sc_meth_ids, sc_meth_binds, sc_meth_implics, meth_ids)) <- pushTcLevelM $ do { (sc_ids, sc_binds, sc_implics) <- tcSuperClasses skol_info dfun_id clas inst_tyvars @@ -1359,7 +1359,8 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) ; return ( sc_ids ++ meth_ids , sc_binds ++ meth_binds - , sc_implics `unionBags` meth_implics ) } + , sc_implics `unionBags` meth_implics + , meth_ids ) } ; imp <- newImplication ; emitImplication $ @@ -1416,7 +1417,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) , abs_binds = [dict_bind] , abs_sig = True } - ; return (L loc' main_bind : sc_meth_binds) + ; return (L loc' main_bind : sc_meth_binds, mkVarEnv $ (,dfun_id) <$> meth_ids) } where dfun_id = instanceDFunId ispec ===================================== compiler/GHC/Tc/Types.hs ===================================== @@ -157,6 +157,7 @@ import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Avail import GHC.Types.Var +import GHC.Types.Var.Env import GHC.Types.TypeEnv import GHC.Types.SourceFile import GHC.Types.SrcLoc @@ -530,6 +531,9 @@ data TcGblEnv -- NB. BangPattern is to fix a leak, see #15111 tcg_fam_inst_env :: !FamInstEnv, -- ^ Ditto for family instances -- NB. BangPattern is to fix a leak, see #15111 + tcg_inst_meths :: IdEnv DFunId, + -- ^ Maps instance method Ids to the DFunId of the instance they belong to. + -- See Note [Class Instance Coverage] in GHC.HsToCore.Ticks. tcg_ann_env :: AnnEnv, -- ^ And for annotations tcg_complete_match_env :: CompleteMatches, -- ^ The complete matches for all /home-package/ modules; ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -409,6 +409,7 @@ initTcGblEnv hsc_env hsc_src keep_rn_syntax mod loc = , tcg_knot_vars = hsc_type_env_vars hsc_env , tcg_known_key_maps = known_key_maps_var , tcg_inst_env = emptyInstEnv + , tcg_inst_meths = emptyVarEnv , tcg_fam_inst_env = emptyFamInstEnv , tcg_ann_env = emptyAnnEnv , tcg_complete_match_env = [] ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -369,10 +369,15 @@ data UnitState = UnitState { -- is always mentioned before the units it depends on. preloadUnits :: [UnitId], - -- | Units which we explicitly depend on (from a command line flag). - -- We'll use this to generate version macros and the unused packages warning. The - -- original flag which was used to bring the unit into scope is recorded for the - -- -Wunused-packages warning. + -- | The units that can be used by the respective home unit. Despite the + -- identifier, this does not just cover units that are enabled explicitly + -- using flags but also units from the package database that are enabled + -- implicitly in case @-hide-all-packages@ is absent. The former are paired + -- with 'Just' applied to the respective flags, the latter are paired with + -- 'Nothing'. + -- + -- This field is used for generating version macros and “unused packages” + -- warnings. explicitUnits :: [(Unit, Maybe PackageArg)], homeUnitDepends :: Set UnitId, @@ -907,7 +912,7 @@ mkUnitState logger unit_index cfg = do let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p) | p <- pkgs2 ] - -- The explicitUnits accurately reflects the set of units we have turned + -- The explicitUnits accurately reflects the set of units that are turned -- on; as such, it also is the only way one can come up with requirements. -- The requirement context is directly based off of this: we simply -- look for nested unit IDs that are directly fed holes: the requirements ===================================== rts/include/stg/Prim.h ===================================== @@ -59,16 +59,16 @@ StgWord hs_xchg32(StgWord x, StgWord val); StgWord64 hs_xchg64(StgWord x, StgWord64 val); /* rts/prim/bswap.c */ -StgWord16 hs_bswap16(StgWord16 x); -StgWord32 hs_bswap32(StgWord32 x); +StgWord hs_bswap16(StgWord x); +StgWord hs_bswap32(StgWord x); StgWord64 hs_bswap64(StgWord64 x); /* rts/prim/bitrev.c This was done as part of issue #16164. See Note [Bit reversal primop] for more details about the implementation.*/ StgWord hs_bitrev8(StgWord x); -StgWord16 hs_bitrev16(StgWord16 x); -StgWord32 hs_bitrev32(StgWord32 x); +StgWord hs_bitrev16(StgWord x); +StgWord hs_bitrev32(StgWord x); StgWord64 hs_bitrev64(StgWord64 x); /* rts/prim/longlong.c */ ===================================== rts/prim/bitrev.c ===================================== @@ -36,8 +36,8 @@ hs_bitrev8(StgWord x) return x; } -StgWord16 -hs_bitrev16(StgWord16 x) +StgWord +hs_bitrev16(StgWord x) { x = ((x >> 1) & 0x5555) | ((x & 0x5555) << 1 ); x = ((x >> 2) & 0x3333) | ((x & 0x3333) << 2 ); @@ -46,14 +46,14 @@ hs_bitrev16(StgWord16 x) return x; } -StgWord32 -hs_bitrev32(StgWord32 x) +StgWord +hs_bitrev32(StgWord x) { - x = ((x >> 1) & 0x55555555) | ((x & 0x55555555) << 1 ); - x = ((x >> 2) & 0x33333333) | ((x & 0x33333333) << 2 ); - x = ((x >> 4) & 0x0F0F0F0F) | ((x & 0x0F0F0F0F) << 4 ); - x = ((x >> 8) & 0x00FF00FF) | ((x & 0x00FF00FF) << 8 ); - x = ( x >> 16 ) | ( x << 16 ); + x = ((x >> 1) & 0x55555555) | ((x & 0x55555555) << 1 ); + x = ((x >> 2) & 0x33333333) | ((x & 0x33333333) << 2 ); + x = ((x >> 4) & 0x0F0F0F0F) | ((x & 0x0F0F0F0F) << 4 ); + x = ((x >> 8) & 0x00FF00FF) | ((x & 0x00FF00FF) << 8 ); + x = ((x >> 16) & 0x0000FFFF) | ((x & 0x0000FFFF) << 16); return x; } ===================================== rts/prim/bswap.c ===================================== @@ -1,16 +1,18 @@ #include "Rts.h" -StgWord16 -hs_bswap16(StgWord16 x) +StgWord +hs_bswap16(StgWord x) { - return ((x >> 8) | (x << 8)); + x = (StgWord16)x; + return (StgWord16)((x >> 8) | (x << 8)); } -StgWord32 -hs_bswap32(StgWord32 x) +StgWord +hs_bswap32(StgWord x) { - return ((x >> 24) | ((x >> 8) & 0xff00) | - (x << 24) | ((x & 0xff00) << 8)); + x = (StgWord32)x; + return (StgWord32)((x >> 24) | ((x >> 8) & 0xff00) | + (x << 24) | ((x & 0xff00) << 8)); } StgWord64 ===================================== testsuite/tests/ghci/prog-mhu008/Makefile ===================================== @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk ===================================== testsuite/tests/ghci/prog-mhu008/a/M.hs ===================================== @@ -0,0 +1,4 @@ +module M (T (..)) where + +newtype T = MkT Int + deriving (Eq, Ord) ===================================== testsuite/tests/ghci/prog-mhu008/all.T ===================================== @@ -0,0 +1,5 @@ +test('prog-mhu008', + [extra_files(['a/', 'b/', 'unitA', 'unitB']), + cmd_prefix('ghciWayFlags=' + config.ghci_way_flags), + req_interp], + ghci_multiunit_script, [['unitA', 'unitB'], 'prog-mhu008.script']) ===================================== testsuite/tests/ghci/prog-mhu008/b/M.hs ===================================== @@ -0,0 +1,11 @@ +{-# LANGUAGE PackageImports #-} + +module M + ( module Export + , cmp + ) where + +import "a" M as Export + +cmp :: T -> T -> Bool +cmp x y = x <= y ===================================== testsuite/tests/ghci/prog-mhu008/prog-mhu008.script ===================================== @@ -0,0 +1,5 @@ +:set -XPackageImports +import "a" M qualified as MA +import "b" M qualified as MB + +MB.cmp (MA.MkT 1) (MA.MkT 2) ===================================== testsuite/tests/ghci/prog-mhu008/prog-mhu008.stdout ===================================== @@ -0,0 +1 @@ +True ===================================== testsuite/tests/ghci/prog-mhu008/unitA ===================================== @@ -0,0 +1,5 @@ +-this-unit-id a-0-inplace +-this-package-name a +-i +-ia +M ===================================== testsuite/tests/ghci/prog-mhu008/unitB ===================================== @@ -0,0 +1,6 @@ +-this-unit-id b-0-inplace +-this-package-name b +-package-id a-0-inplace +-i +-ib +M ===================================== testsuite/tests/hpc/instmeths/instmeths.hs ===================================== @@ -0,0 +1,57 @@ +import Data.List +import Data.Maybe +import Trace.Hpc.Mix +import Trace.Hpc.Reflect +import Trace.Hpc.Tix +import Trace.Hpc.Util + +class Foo a where + defMeth, defMeth', reqMeth :: a -> String + defMeth = const "class default" + defMeth' = const "class default" + +newtype T a = T a deriving (Show, Eq, Functor) +instance Foo (T a) where + reqMeth = const "Foo (T a) instance" + +newtype T' a = T' a + +instance Foo (T' a) where + reqMeth = const "Foo (T' a) instance" + defMeth = const "Foo (T' a) instance" + +-- no method use could "cover" this instance, so we (for now) omit the top-level box for it +class Marker a +instance Marker (T Bool) + +interesting :: (Int, MixEntry) -> Maybe (Int, HpcPos, String) +interesting (n, (pos, TopLevelBox [name])) | isInteresting name = Just (n, pos, name) + where isInteresting = (||) <$> isInst <*> isMeth + isInst = ("$f" `isPrefixOf`) + isMeth = (||) <$> (`elem` ["(==)", "(/=)", "show", "showList", "showsPrec", "fmap", "(<$)"]) + <*> ("Meth" `isSubsequenceOf`) +interesting _ = Nothing + +-- candidate for HPC.Utils, maybe? +sourceAt :: String -> HpcPos -> String +sourceAt src pos + | l1 == l2 = take (c2 - c1 + 1) . drop (c1 - 1) $ ls !! (l1 - 1) + | otherwise = intercalate "\n" $ first : (middle ++ [last]) + where + (l1, c1, l2, c2) = fromHpcPos pos + ls = lines src + first = drop (c1 - 1) $ ls !! (l1 - 1) + middle = take (l2 - l1 - 1) $ drop l1 ls + last = take c2 $ ls !! (l2 - 1) + +main :: IO () +main = do + print (T 23 == (succ <$> T 22)) -- tick Eq and Functor by using any of their methods + print (reqMeth (T' 1)) -- tick `Foo (T' a)` and that instance's `reqMeth` + + Mix source _ _ _ mixEntries <- readMix [".hpc"] (Left "Main") + src <- readFileUtf8 source + let boxes = mapMaybe interesting $ zip [0 ..] mixEntries + Tix [TixModule "Main" _ _ counts] <- examineTix + mapM_ print [ (counts !! n, path, sourceAt src pos) + | (n, pos, path) <- sortOn (\(_, _, s) -> s) boxes ] ===================================== testsuite/tests/hpc/instmeths/instmeths.stdout ===================================== @@ -0,0 +1,12 @@ +True +"Foo (T' a) instance" +(1,"$fEqT","Eq") +(0,"$fFooT","Foo (T a)") +(1,"$fFooT'","Foo (T' a)") +(1,"$fFunctorT","Functor") +(0,"$fShowT","Show") +(0,"defMeth","defMeth = const \"class default\"") +(0,"defMeth","defMeth = const \"Foo (T' a) instance\"") +(0,"defMeth'","defMeth' = const \"class default\"") +(0,"reqMeth","reqMeth = const \"Foo (T a) instance\"") +(1,"reqMeth","reqMeth = const \"Foo (T' a) instance\"") ===================================== testsuite/tests/hpc/instmeths/test.T ===================================== @@ -0,0 +1,5 @@ +setTestOpts([omit_ghci, when(fast(), skip), js_skip]) + +test('instmeths', + [ignore_extension], + compile_and_run, ['-fhpc']) ===================================== testsuite/tests/primops/should_run/T27299.hs ===================================== @@ -0,0 +1,23 @@ +{-# LANGUAGE MagicHash #-} +import GHC.Exts +import GHC.Word +import Numeric + +main :: IO () +main = do + putStrLn $ showHex (W# (bitReverse8# 0x55##)) "" + putStrLn $ showHex (W# (bitReverse8# 0xAA##)) "" + putStrLn $ showHex (W# (bitReverse16# 0x5555##)) "" + putStrLn $ showHex (W# (bitReverse16# 0xAAAA##)) "" + putStrLn $ showHex (W# (bitReverse32# 0x5555_5555##)) "" + putStrLn $ showHex (W# (bitReverse32# 0xAAAA_AAAA##)) "" + putStrLn $ showHex (W# (byteSwap16# 0xABCD##)) "" + putStrLn $ showHex (W# (byteSwap32# 0xABCD_EF12##)) "" + putStrLn $ showHex (W# (noinline bitReverse8# 0x55##)) "" + putStrLn $ showHex (W# (noinline bitReverse8# 0xAA##)) "" + putStrLn $ showHex (W# (noinline bitReverse16# 0x5555##)) "" + putStrLn $ showHex (W# (noinline bitReverse16# 0xAAAA##)) "" + putStrLn $ showHex (W# (noinline bitReverse32# 0x5555_5555##)) "" + putStrLn $ showHex (W# (noinline bitReverse32# 0xAAAA_AAAA##)) "" + putStrLn $ showHex (W# (noinline byteSwap16# 0xABCD##)) "" + putStrLn $ showHex (W# (noinline byteSwap32# 0xABCD_EF12##)) "" ===================================== testsuite/tests/primops/should_run/T27299.stdout ===================================== @@ -0,0 +1,16 @@ +aa +55 +aaaa +5555 +aaaaaaaa +55555555 +cdab +12efcdab +aa +55 +aaaa +5555 +aaaaaaaa +55555555 +cdab +12efcdab ===================================== testsuite/tests/primops/should_run/all.T ===================================== @@ -91,3 +91,4 @@ test('T24496' ] , compile_and_run, ['-O']) test('T6026', normal, compile_and_run, ['']) +test('T27299', normal, compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c97d7901a78d7237ac4e5c515542d1e... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c97d7901a78d7237ac4e5c515542d1e... 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