Florian Ragwitz pushed to branch wip/rafl/hpc-instances at Glasgow Haskell Compiler / GHC

Commits:

28 changed files:

Changes:

  • changelog.d/26610
    1 
    +section: compiler
    2 
    +synopsis: Fix instance resolution for shadowed modules
    3 
    +description:
    4 
    +  Instances imported from modules with the same module name as the importing module
    5 
    +  were dropped accidentally since we didn't account for the unit id of the imported module.
    6 
    +mrs: !16648
    7 
    +issues: #26610

  • changelog.d/hpc-classinsts
    1 
    +section: compiler
    2 
    +synopsis: Improve coverage reporting for class instances and their methods
    3 
    +description:
    4 
    +
    5 
    +  Coverage reporting (:ghc-flag:`-fhpc`) now treats class instances more
    6 
    +  naturally.
    7 
    +
    8 
    +  Compiler-generated instance methods, such as inherited default methods, no
    9 
    +  longer receive separate top-level coverage boxes. Explicitly implemented
    10 
    +  instance methods retain their own declaration coverage.
    11 
    +
    12 
    +  This means that it is no longer necessary to exercise all of a class' methods
    13 
    +  in order for it to appear "covered".
    14 
    +
    15 
    +  Additionally, top-level coverage boxes are now created for all instances of
    16 
    +  classes with methods, and ticked by the use of *any* of the class' methods.
    17 
    +  This indicates that an instance was in fact used at run-time.
    18 
    +
    19 
    +  Note that classes without any instance methods are currently excluded from
    20 
    +  this, and won't have any coverage boxes created.
    21 
    +
    22 
    +mrs: !16632
    23 
    +issues: #17155 #15932

  • compiler/GHC/Core/Opt/WorkWrap/Utils.hs
    ... ... @@ -1367,13 +1367,8 @@ It's surprisingly subtle.
    1367 1367 
       application; see test `T27627f`.
    1368 1368
    1369 1369 
     TL;DR: we play safe: we never make an absent filler for any /constraint-kinded/ type,
    1370 
    -using `isPredTy` to decide.
    1371 
    -
    1372 
    -  * `mkAbsentFiller` returns `Nothing` for any constraint type, so worker/wrapper
    1373 
    -    keeps the real argument.
    1374 
    -
    1375 
    -  * `Specialise.specHeader` calls `mkAbsentFiller` too, so it likewise keeps the
    1376 
    -    dead dictionary argument rather than dropping it for a filler.
    1370 
    +using `isPredTy` to decide: `mkAbsentFiller` returns `Nothing` for any constraint
    1371 
    +type, so worker/wrapper keeps the real argument.
    1377 1372
    1378 1373 
     Prior failed approaches
    1379 1374

  • compiler/GHC/Driver/Env.hs
    ... ... @@ -263,13 +263,13 @@ hugCompleteSigsBelow hsc uid mn = foldr (++) [] <$>
    263 263 
     -- | Find instances visible from the given set of imports
    264 264 
     hugInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO (InstEnv, [FamInst])
    265 265 
     hugInstancesBelow hsc_env uid mnwib = do
    266 
    - let mn = gwib_mod mnwib
    266 
    + let mn = mkModule uid (gwib_mod mnwib)
    267 267 
      (insts, famInsts) <-
    268 268 
          unzip . concat <$>
    269 269 
            hugSomeThingsBelowUs (\mod_info ->
    270 270 
                                       let details = hm_details mod_info
    271 271 
                                       -- Don't include instances for the current module
    272 
    -                                  in if moduleName (mi_module (hm_iface mod_info)) == mn
    272 
    +                                  in if fmap toUnitId (mi_module (hm_iface mod_info)) == mn
    273 273 
                                            then []
    274 274 
                                            else [(md_insts details, md_fam_insts details)])
    275 275 
                               True -- Include -hi-boot

  • compiler/GHC/HsToCore.hs
    ... ... @@ -147,6 +147,7 @@ deSugar hsc_env
    147 147 
                                 tcg_tcs          = tcs,
    148 148 
                                 tcg_default_exports = defaults,
    149 149 
                                 tcg_insts        = insts,
    150 
    +                            tcg_inst_meths   = inst_meths,
    150 151 
                                 tcg_fam_insts    = fam_insts,
    151 152 
                                 tcg_complete_matches = complete_matches,
    152 153 
                                 tcg_self_boot    = self_boot
    ... ... @@ -170,7 +171,8 @@ deSugar hsc_env
    170 171 
                                            (hsc_logger hsc_env)
    171 172 
                                            (initTicksConfig (hsc_dflags hsc_env))
    172 173 
                                            mod mod_loc
    173 
    -                                       export_set (typeEnvTyCons type_env) binds
    174 
    +                                       export_set (typeEnvTyCons type_env)
    175 
    +                                       insts inst_meths binds
    174 176 
                                   else return (binds, Nothing)
    175 177 
             ; let modBreaks
    176 178 
                     | Just (_, _, breakpointSpecs) <- m_tickInfo

  • compiler/GHC/HsToCore/Ticks.hs
    ... ... @@ -5,7 +5,7 @@
    5 5 
     {-
    6 6 
     (c) Galois, 2006
    7 7 
     (c) University of Glasgow, 2007
    8 
    -(c) Florian Ragwitz, 2025
    8 
    +(c) Florian Ragwitz, 2025-2026
    9 9 
     -}
    10 10
    11 11 
     module GHC.HsToCore.Ticks
    ... ... @@ -24,6 +24,8 @@ import GHC.Unit
    24 24
    25 25 
     import GHC.Core.Type
    26 26 
     import GHC.Core.TyCon
    27 
    +import GHC.Core.InstEnv
    28 
    +import GHC.Core.Class
    27 29
    28 30 
     import GHC.Data.Maybe
    29 31 
     import GHC.Data.FastString
    ... ... @@ -56,6 +58,7 @@ import Data.Foldable (toList)
    56 58 
     import Trace.Hpc.Mix
    57 59
    58 60 
     import Data.Bifunctor (second)
    61 
    +import Data.Functor
    59 62 
     import Data.List.NonEmpty (NonEmpty (..))
    60 63 
     import Data.Set (Set)
    61 64 
     import qualified Data.Set as Set
    ... ... @@ -100,11 +103,15 @@ addTicksToBinds
    100 103 
                                     -- isExportedId doesn't work yet (the desugarer
    101 104 
                                     -- hasn't set it), so we have to work from this set.
    102 105 
             -> [TyCon]              -- ^ Type constructors in this module
    106 
    +        -> [ClsInst]            -- ^ Class instances in this module
    107 
    +        -> IdEnv DFunId         -- ^ Mapping from class method Ids to the DFunIds
    108 
    +                                -- of the class instance they belong to. See Note
    109 
    +                                -- [Instance Method Coverage].
    103 110 
             -> LHsBinds GhcTc
    104 111 
             -> IO (LHsBinds GhcTc, Maybe (FilePath, SizedSeq Tick, SizedSeq Tick))
    105 112
    106 113 
     addTicksToBinds logger cfg
    107 
    -                mod mod_loc exports tyCons binds
    114 
    +                mod mod_loc exports tyCons insts inst_meths binds
    108 115 
       | let passes = ticks_passes cfg
    109 116 
       , not (null passes)
    110 117 
       , Just orig_file <- ml_hs_file mod_loc = do
    ... ... @@ -129,8 +136,13 @@ addTicksToBinds logger cfg
    129 136 
                           , this_mod     = mod
    130 137 
                           , tickishType  = tickish
    131 138 
                           , recSelBinds  = emptyVarEnv
    139 
    +                      , instMeths    = inst_meths
    140 
    +                      , instTicks    = emptyVarEnv
    132 141 
                           }
    133 
    -                (binds',_,st') = unTM (addTickLHsBinds binds) env st
    142 
    +                addTick = do
    143 
    +                  instTicks <- allocInstTicks insts
    144 
    +                  withEnv (\e -> e{ instTicks }) $ addTickLHsBinds binds
    145 
    +                (binds',_,st') = unTM addTick env st
    134 146 
                 in (binds', st')
    135 147
    136 148 
               (binds1,st) = foldr tickPass (binds, initTTState) passes
    ... ... @@ -231,7 +243,7 @@ addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)
    231 243 
     addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds
    232 244 
                                                      , abs_exports = abs_exports
    233 245 
                                                      }))) =
    234 
    -  withEnv (add_rec_sels . add_inlines . add_exports) $ do
    246 
    +  withEnv (add_inst_meths . add_rec_sels . add_inlines . add_exports) $ do
    235 247 
           binds' <- addTickLHsBinds binds
    236 248 
           return $ L pos $ XHsBindsLR $ bind { abs_binds = binds' }
    237 249 
       where
    ... ... @@ -259,19 +271,24 @@ addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds
    259 271 
                               | ABE{ abe_poly, abe_mono } <- abs_exports
    260 272 
                               , RecSelId{} <- [idDetails abe_poly] ] }
    261 273
    274 
    +   add_inst_meths env =
    275 
    +     env{ instMeths = instMeths env `extendVarEnvList`
    276 
    +                        [ (abe_mono, dfun)
    277 
    +                        | ABE{ abe_poly, abe_mono } <- abs_exports
    278 
    +                        , Just dfun <- [lookupVarEnv (instMeths env) abe_poly] ] }
    279 
    +
    262 280 
     addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches }))) = do
    263 281 
       let name = getOccString id
    264 282 
       decl_path <- getPathEntry
    265 283 
       density <- getDensity
    284 
    +  env <- getEnv
    266 285
    267 
    -  inline_ids <- liftM inlines getEnv
    268 286 
       -- See Note [inline sccs]
    269 287 
       let inline   = isInlinePragma (idInlinePragma id)
    270 
    -                 || id `elemVarSet` inline_ids
    288 
    +                 || id `elemVarSet` inlines env
    271 289
    272 290 
       -- See Note [inline sccs]
    273 
    -  tickish <- tickishType `liftM` getEnv
    274 
    -  case tickish of { ProfNotes | inline -> return (L pos funBind); _ -> do
    291 
    +  case tickishType env of { ProfNotes | inline -> return (L pos funBind); _ -> do
    275 292
    276 293 
       -- See Note [Record-selector ticks]
    277 294 
       selTicks <- recSelTick id
    ... ... @@ -294,16 +311,26 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches
    294 311 
           toplev = null decl_path
    295 312 
           exported = idName id `elemNameSet` exported_names
    296 313
    297 
    -  tick <- if not blackListed &&
    298 
    -               shouldTickBind density toplev exported simple inline
    314 
    +  -- See Note [Instance Method Coverage].
    315 
    +  let generatedInstMeth = density == TickForCoverage
    316 
    +        && id `elemVarEnv` instMeths env
    317 
    +        && isGenerated (mg_origin (mg_ext matches))
    318 
    +
    319 
    +  tick <- if not generatedInstMeth
    320 
    +               && not blackListed
    321 
    +               && shouldTickBind density toplev exported simple inline
    299 322 
                  then
    300 323 
                     bindTick density name (locA pos) fvs
    301 324 
                  else
    302 325 
                     return Nothing
    303 326
    327 
    +  -- See Note [Instance Method Coverage].
    328 
    +  instTick <- instMethTick id
    329 
    +
    304 330 
       let mbCons = maybe Prelude.id (:)
    305 331 
       return $ L pos $ funBind { fun_matches = mg
    306 
    -                           , fun_ext = second (tick `mbCons`) (fun_ext funBind) }
    332 
    +                           , fun_ext = second ((instTick `mbCons`) . (tick `mbCons`))
    333 
    +                                              (fun_ext funBind) }
    307 334 
       } }
    308 335 
       where
    309 336 
         -- See Note [Record-selector ticks]
    ... ... @@ -338,6 +365,32 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches
    338 365 
     -- This scheme could be extended further in the future, making coverage for
    339 366 
     -- positional constructor fields mean that the field was accessed at run-time.
    340 367
    368 
    +-- Note [Instance Method Coverage]
    369 
    +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    370 
    +-- Users expect source-level semantics for coverage reports (see #17155,
    371 
    +-- #15932). That is, code they've written themselves should be marked as covered
    372 
    +-- iff it is evaluated at run-time. Given that the implementation of class
    373 
    +-- instances creates top-level bindings for all methods of an instance,
    374 
    +-- inherited and hand-written, we need to go out of our way to create top-level
    375 
    +-- tick boxes only for methods which correspond to user-written code.
    376 
    +--
    377 
    +-- To do so, 'addTicksToBinds' receives a mapping from class instance 'Id's to
    378 
    +-- the 'DFunId's of the dictionary backing the associated instance. When
    379 
    +-- creating tick boxes for top-level bindings, we can then decide if a given
    380 
    +-- 'FunBind' corresponds to an inherited/generated instance method of a class
    381 
    +-- and skip creating the tick box for it.
    382 
    +--
    383 
    +-- Additionally, we also want to inform the user whether or not their class
    384 
    +-- instance as a whole has been used at run-time. To do so, we create a single
    385 
    +-- tick box at the instance head and tick that box when any method of that
    386 
    +-- instance is evaluated.
    387 
    +--
    388 
    +-- As marker/tag-like class instances without any methods would always appear
    389 
    +-- as uncovered using the above mechanism, we exclude them when creating
    390 
    +-- instance tick boxes. This could potentially be improved in the future by
    391 
    +-- tracking if any functions requiring an instance of an empty class have been
    392 
    +-- evaluated.
    393 
    +
    341 394 
     -- TODO: Revisit this
    342 395 
     addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs
    343 396 
                                         , pat_rhs = rhs
    ... ... @@ -1098,6 +1151,8 @@ data TickTransEnv = TTE { fileName :: FastString
    1098 1151 
                             , this_mod     :: Module
    1099 1152 
                             , tickishType  :: TickishType
    1100 1153 
                             , recSelBinds  :: IdEnv DVarSet
    1154 
    +                        , instMeths    :: IdEnv DFunId
    1155 
    +                        , instTicks    :: IdEnv CoreTickish
    1101 1156 
                             }
    1102 1157
    1103 1158 
     --      deriving Show
    ... ... @@ -1238,6 +1293,18 @@ isBlackListed (RealSrcSpan pos _) = TM $ \ env st -> (Set.member pos (blackList
    1238 1293 
     isBlackListed GeneratedSrcSpan{} = return False
    1239 1294 
     isBlackListed UnhelpfulSpan{} = return False
    1240 1295
    1296 
    +allocInstTicks :: [ClsInst] -> TM (IdEnv CoreTickish)
    1297 
    +allocInstTicks insts =
    1298 
    +    ifDensity TickForCoverage (mkVarEnv . catMaybes <$> mapM alloc insts) (pure emptyVarEnv)
    1299 
    +  where
    1300 
    +    alloc ClsInst{ is_dfun, is_cls }
    1301 
    +      | null (classMethods is_cls) = pure Nothing
    1302 
    +      | otherwise = fmap (is_dfun,) <$> allocATickBox (TopLevelBox [getOccString is_dfun])
    1303 
    +                                                      False True (getSrcSpan is_dfun) noFVs
    1304 
    +
    1305 
    +instMethTick :: Id -> TM (Maybe CoreTickish)
    1306 
    +instMethTick id = getEnv <&> \e -> lookupVarEnv (instMeths e) id >>= lookupVarEnv (instTicks e)
    1307 
    +
    1241 1308 
     -- the tick application inherits the source position of its
    1242 1309 
     -- expression argument to support nested box allocations
    1243 1310 
     allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr GhcTc)

  • compiler/GHC/Tc/Module.hs
    ... ... @@ -1766,7 +1766,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
    1766 1766 
                     -- Second pass over class and instance declarations,
    1767 1767 
                     -- now using the kind-checked decls
    1768 1768 
             traceTc "Tc6" empty ;
    1769 
    -        inst_binds <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) inst_infos ;
    1769 
    +        (inst_binds, inst_meths) <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) inst_infos ;
    1770 1770
    1771 1771 
                     -- Foreign exports
    1772 1772 
             traceTc "Tc7" empty ;
    ... ... @@ -1798,8 +1798,9 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
    1798 1798 
                                      , tcg_anns    = tcg_anns tcg_env ++ annotations
    1799 1799 
                                      , tcg_ann_env = extendAnnEnvList (tcg_ann_env tcg_env) annotations
    1800 1800 
                                      , tcg_fords   = tcg_fords tcg_env ++ foe_decls ++ fi_decls
    1801 
    -                                 , tcg_dus     = tcg_dus tcg_env `plusDU` usesOnly fo_fvs } } ;
    1801 
    +                                 , tcg_dus     = tcg_dus tcg_env `plusDU` usesOnly fo_fvs
    1802 1802 
                                      -- tcg_dus: see Note [Newtype constructor usage in foreign declarations]
    1803 
    +                                 , tcg_inst_meths = tcg_inst_meths tcg_env `plusVarEnv` inst_meths } } ;
    1803 1804
    1804 1805 
             -- See Note [Newtype constructor usage in foreign declarations]
    1805 1806 
             addUsedGREs NoDeprecationWarnings (bagToList fo_gres) ;

  • compiler/GHC/Tc/TyCl/Instance.hs
    ... ... @@ -1285,7 +1285,7 @@ takes a slightly different approach.
    1285 1285 
     ********************************************************************* -}
    1286 1286
    1287 1287 
     tcInstDecls2 :: [LTyClDecl GhcRn] -> [InstInfo GhcRn]
    1288 
    -             -> TcM (LHsBinds GhcTc)
    1288 
    +             -> TcM (LHsBinds GhcTc, IdEnv DFunId)
    1289 1289 
     -- (a) From each class declaration,
    1290 1290 
     --      generate any default-method bindings
    1291 1291 
     -- (b) From each instance decl
    ... ... @@ -1302,11 +1302,11 @@ tcInstDecls2 tycl_decls inst_decls
    1302 1302 
                   -- Add the default method Ids (again)
    1303 1303 
                   -- (they were already added in GHC.Tc.TyCl.Utils.tcAddImplicits)
    1304 1304 
                   -- See Note [Default methods in the type environment]
    1305 
    -        ; inst_binds_s <- tcExtendGlobalValEnv dm_ids $
    1306 
    -                          mapM tcInstDecl2 inst_decls
    1305 
    +        ; (inst_binds_s, inst_meths_s) <- unzip <$> (tcExtendGlobalValEnv dm_ids $
    1306 
    +                                                     mapM tcInstDecl2 inst_decls)
    1307 1307
    1308 1308 
               -- Done
    1309 
    -        ; return (dm_binds ++ concat inst_binds_s) }
    1309 
    +        ; return (dm_binds ++ concat inst_binds_s, plusVarEnvList inst_meths_s) }
    1310 1310
    1311 1311 
     {- Note [Default methods in the type environment]
    1312 1312 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ... ... @@ -1322,12 +1322,12 @@ So right here in tcInstDecls2 we must re-extend the type envt with
    1322 1322 
     the default method Ids replete with their INLINE pragmas.  Urk.
    1323 1323 
     -}
    1324 1324
    1325 
    -tcInstDecl2 :: InstInfo GhcRn -> TcM (LHsBinds GhcTc)
    1325 
    +tcInstDecl2 :: InstInfo GhcRn -> TcM (LHsBinds GhcTc, IdEnv DFunId)
    1326 1326 
                 -- Returns a binding for the dfun
    1327 1327 
     tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
    1328 
    -  = recoverM (return emptyLHsBinds)    $
    1329 
    -    setSrcSpan loc                     $
    1330 
    -    addErrCtxt (instDeclCtxt2 dfun_ty) $
    1328 
    +  = recoverM (return (emptyLHsBinds, emptyVarEnv)) $
    1329 
    +    setSrcSpan loc                                 $
    1330 
    +    addErrCtxt (instDeclCtxt2 dfun_ty)             $
    1331 1331 
         do {  -- Instantiate the instance decl with skolem constants
    1332 1332 
              (skol_info, inst_tyvars, dfun_theta, clas, inst_tys) <- tcSkolDFunType dfun_ty
    1333 1333 
            ; dfun_ev_vars <- newEvVars dfun_theta
    ... ... @@ -1345,7 +1345,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
    1345 1345 
              -- See Note [Typechecking plan for instance declarations]
    1346 1346 
            ; dfun_ev_binds_var <- newTcEvBinds
    1347 1347 
            ; let dfun_ev_binds = TcEvBinds dfun_ev_binds_var
    1348 
    -       ; (tclvl, (sc_meth_ids, sc_meth_binds, sc_meth_implics))
    1348 
    +       ; (tclvl, (sc_meth_ids, sc_meth_binds, sc_meth_implics, meth_ids))
    1349 1349 
                  <- pushTcLevelM $
    1350 1350 
                     do { (sc_ids, sc_binds, sc_implics)
    1351 1351 
                             <- tcSuperClasses skol_info dfun_id clas inst_tyvars
    ... ... @@ -1359,7 +1359,8 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
    1359 1359
    1360 1360 
                        ; return ( sc_ids     ++          meth_ids
    1361 1361 
                                 , sc_binds   ++ meth_binds
    1362 
    -                            , sc_implics `unionBags` meth_implics ) }
    1362 
    +                            , sc_implics `unionBags` meth_implics
    1363 
    +                            , meth_ids ) }
    1363 1364
    1364 1365 
            ; imp <- newImplication
    1365 1366 
            ; emitImplication $
    ... ... @@ -1416,7 +1417,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
    1416 1417 
                                       , abs_binds = [dict_bind]
    1417 1418 
                                       , abs_sig = True }
    1418 1419
    1419 
    -       ; return (L loc' main_bind : sc_meth_binds)
    1420 
    +       ; return (L loc' main_bind : sc_meth_binds, mkVarEnv $ (,dfun_id) <$> meth_ids)
    1420 1421 
            }
    1421 1422 
      where
    1422 1423 
        dfun_id = instanceDFunId ispec

  • compiler/GHC/Tc/Types.hs
    ... ... @@ -157,6 +157,7 @@ import GHC.Types.Name.Env
    157 157 
     import GHC.Types.Name.Set
    158 158 
     import GHC.Types.Avail
    159 159 
     import GHC.Types.Var
    160 
    +import GHC.Types.Var.Env
    160 161 
     import GHC.Types.TypeEnv
    161 162 
     import GHC.Types.SourceFile
    162 163 
     import GHC.Types.SrcLoc
    ... ... @@ -530,6 +531,9 @@ data TcGblEnv
    530 531 
               -- NB. BangPattern is to fix a leak, see #15111
    531 532 
             tcg_fam_inst_env :: !FamInstEnv, -- ^ Ditto for family instances
    532 533 
               -- NB. BangPattern is to fix a leak, see #15111
    534 
    +        tcg_inst_meths   :: IdEnv DFunId,
    535 
    +          -- ^ Maps instance method Ids to the DFunId of the instance they belong to.
    536 
    +          -- See Note [Class Instance Coverage] in GHC.HsToCore.Ticks.
    533 537 
             tcg_ann_env      :: AnnEnv,     -- ^ And for annotations
    534 538 
             tcg_complete_match_env :: CompleteMatches,
    535 539 
             -- ^ 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 =
    409 409 
               , tcg_knot_vars          = hsc_type_env_vars hsc_env
    410 410 
               , tcg_known_key_maps     = known_key_maps_var
    411 411 
               , tcg_inst_env           = emptyInstEnv
    412 
    +          , tcg_inst_meths         = emptyVarEnv
    412 413 
               , tcg_fam_inst_env       = emptyFamInstEnv
    413 414 
               , tcg_ann_env            = emptyAnnEnv
    414 415 
               , tcg_complete_match_env = []

  • compiler/GHC/Unit/State.hs
    ... ... @@ -369,10 +369,15 @@ data UnitState = UnitState {
    369 369 
       -- is always mentioned before the units it depends on.
    370 370 
       preloadUnits      :: [UnitId],
    371 371
    372 
    -  -- | Units which we explicitly depend on (from a command line flag).
    373 
    -  -- We'll use this to generate version macros and the unused packages warning. The
    374 
    -  -- original flag which was used to bring the unit into scope is recorded for the
    375 
    -  -- -Wunused-packages warning.
    372 
    +  -- | The units that can be used by the respective home unit. Despite the
    373 
    +  -- identifier, this does not just cover units that are enabled explicitly
    374 
    +  -- using flags but also units from the package database that are enabled
    375 
    +  -- implicitly in case @-hide-all-packages@ is absent. The former are paired
    376 
    +  -- with 'Just' applied to the respective flags, the latter are paired with
    377 
    +  -- 'Nothing'.
    378 
    +  --
    379 
    +  -- This field is used for generating version macros and “unused packages”
    380 
    +  -- warnings.
    376 381 
       explicitUnits :: [(Unit, Maybe PackageArg)],
    377 382
    378 383 
       homeUnitDepends    :: Set UnitId,
    ... ... @@ -907,7 +912,7 @@ mkUnitState logger unit_index cfg = do
    907 912 
       let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
    908 913 
                                   | p <- pkgs2
    909 914 
                                   ]
    910 
    -  -- The explicitUnits accurately reflects the set of units we have turned
    915 
    +  -- The explicitUnits accurately reflects the set of units that are turned
    911 916 
       -- on; as such, it also is the only way one can come up with requirements.
    912 917 
       -- The requirement context is directly based off of this: we simply
    913 918 
       -- 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);
    59 59 
     StgWord64 hs_xchg64(StgWord x, StgWord64 val);
    60 60
    61 61 
     /* rts/prim/bswap.c */
    62 
    -StgWord16 hs_bswap16(StgWord16 x);
    63 
    -StgWord32 hs_bswap32(StgWord32 x);
    62 
    +StgWord hs_bswap16(StgWord x);
    63 
    +StgWord hs_bswap32(StgWord x);
    64 64 
     StgWord64 hs_bswap64(StgWord64 x);
    65 65
    66 66 
     /* rts/prim/bitrev.c
    67 67 
     This was done as part of issue #16164.
    68 68 
     See Note [Bit reversal primop] for more details about the implementation.*/
    69 69 
     StgWord hs_bitrev8(StgWord x);
    70 
    -StgWord16 hs_bitrev16(StgWord16 x);
    71 
    -StgWord32 hs_bitrev32(StgWord32 x);
    70 
    +StgWord hs_bitrev16(StgWord x);
    71 
    +StgWord hs_bitrev32(StgWord x);
    72 72 
     StgWord64 hs_bitrev64(StgWord64 x);
    73 73
    74 74 
     /* rts/prim/longlong.c */

  • rts/prim/bitrev.c
    ... ... @@ -36,8 +36,8 @@ hs_bitrev8(StgWord x)
    36 36 
       return x;
    37 37 
     }
    38 38
    39 
    -StgWord16
    40 
    -hs_bitrev16(StgWord16 x)
    39 
    +StgWord
    40 
    +hs_bitrev16(StgWord x)
    41 41 
     {
    42 42 
       x = ((x >> 1) & 0x5555) | ((x & 0x5555) << 1 );
    43 43 
       x = ((x >> 2) & 0x3333) | ((x & 0x3333) << 2 );
    ... ... @@ -46,14 +46,14 @@ hs_bitrev16(StgWord16 x)
    46 46 
       return x;
    47 47 
     }
    48 48
    49 
    -StgWord32
    50 
    -hs_bitrev32(StgWord32 x)
    49 
    +StgWord
    50 
    +hs_bitrev32(StgWord x)
    51 51 
     {
    52 
    -  x = ((x >> 1) & 0x55555555) | ((x & 0x55555555) << 1 );
    53 
    -  x = ((x >> 2) & 0x33333333) | ((x & 0x33333333) << 2 );
    54 
    -  x = ((x >> 4) & 0x0F0F0F0F) | ((x & 0x0F0F0F0F) << 4 );
    55 
    -  x = ((x >> 8) & 0x00FF00FF) | ((x & 0x00FF00FF) << 8 );
    56 
    -  x = ( x >> 16             ) | ( x << 16              );
    52 
    +  x = ((x >> 1)  & 0x55555555) | ((x & 0x55555555) << 1 );
    53 
    +  x = ((x >> 2)  & 0x33333333) | ((x & 0x33333333) << 2 );
    54 
    +  x = ((x >> 4)  & 0x0F0F0F0F) | ((x & 0x0F0F0F0F) << 4 );
    55 
    +  x = ((x >> 8)  & 0x00FF00FF) | ((x & 0x00FF00FF) << 8 );
    56 
    +  x = ((x >> 16) & 0x0000FFFF) | ((x & 0x0000FFFF) << 16);
    57 57 
       return x;
    58 58 
     }
    59 59

  • rts/prim/bswap.c
    1 1 
     #include "Rts.h"
    2 2
    3 
    -StgWord16
    4 
    -hs_bswap16(StgWord16 x)
    3 
    +StgWord
    4 
    +hs_bswap16(StgWord x)
    5 5 
     {
    6 
    -  return ((x >> 8) | (x << 8));
    6 
    +  x = (StgWord16)x;
    7 
    +  return (StgWord16)((x >> 8) | (x << 8));
    7 8 
     }
    8 9
    9 
    -StgWord32
    10 
    -hs_bswap32(StgWord32 x)
    10 
    +StgWord
    11 
    +hs_bswap32(StgWord x)
    11 12 
     {
    12 
    -  return ((x >> 24) | ((x >> 8) & 0xff00) |
    13 
    -          (x << 24) | ((x & 0xff00) << 8));
    13 
    +  x = (StgWord32)x;
    14 
    +  return (StgWord32)((x >> 24) | ((x >> 8) & 0xff00) |
    15 
    +                     (x << 24) | ((x & 0xff00) << 8));
    14 16 
     }
    15 17
    16 18 
     StgWord64

  • testsuite/tests/ghci/prog-mhu008/Makefile
    1 
    +TOP=../../..
    2 
    +include $(TOP)/mk/boilerplate.mk
    3 
    +include $(TOP)/mk/test.mk

  • testsuite/tests/ghci/prog-mhu008/a/M.hs
    1 
    +module M (T (..)) where
    2 
    +
    3 
    +newtype T = MkT Int
    4 
    +  deriving (Eq, Ord)

  • testsuite/tests/ghci/prog-mhu008/all.T
    1 
    +test('prog-mhu008',
    2 
    +     [extra_files(['a/', 'b/', 'unitA', 'unitB']),
    3 
    +     cmd_prefix('ghciWayFlags=' + config.ghci_way_flags),
    4 
    +     req_interp],
    5 
    +     ghci_multiunit_script, [['unitA', 'unitB'], 'prog-mhu008.script'])

  • testsuite/tests/ghci/prog-mhu008/b/M.hs
    1 
    +{-# LANGUAGE PackageImports #-}
    2 
    +
    3 
    +module M
    4 
    +  ( module Export
    5 
    +  , cmp
    6 
    +  ) where
    7 
    +
    8 
    +import "a" M as Export
    9 
    +
    10 
    +cmp :: T -> T -> Bool
    11 
    +cmp x y = x <= y

  • testsuite/tests/ghci/prog-mhu008/prog-mhu008.script
    1 
    +:set -XPackageImports
    2 
    +import "a" M qualified as MA
    3 
    +import "b" M qualified as MB
    4 
    +
    5 
    +MB.cmp (MA.MkT 1) (MA.MkT 2)

  • testsuite/tests/ghci/prog-mhu008/prog-mhu008.stdout
    1 
    +True

  • testsuite/tests/ghci/prog-mhu008/unitA
    1 
    +-this-unit-id a-0-inplace
    2 
    +-this-package-name a
    3 
    +-i
    4 
    +-ia
    5 
    +M

  • testsuite/tests/ghci/prog-mhu008/unitB
    1 
    +-this-unit-id b-0-inplace
    2 
    +-this-package-name b
    3 
    +-package-id a-0-inplace
    4 
    +-i
    5 
    +-ib
    6 
    +M

  • testsuite/tests/hpc/instmeths/instmeths.hs
    1 
    +import Data.List
    2 
    +import Data.Maybe
    3 
    +import Trace.Hpc.Mix
    4 
    +import Trace.Hpc.Reflect
    5 
    +import Trace.Hpc.Tix
    6 
    +import Trace.Hpc.Util
    7 
    +
    8 
    +class Foo a where
    9 
    +  defMeth, defMeth', reqMeth :: a -> String
    10 
    +  defMeth = const "class default"
    11 
    +  defMeth' = const "class default"
    12 
    +
    13 
    +newtype T a = T a deriving (Show, Eq, Functor)
    14 
    +instance Foo (T a) where
    15 
    +  reqMeth = const "Foo (T a) instance"
    16 
    +
    17 
    +newtype T' a = T' a
    18 
    +
    19 
    +instance Foo (T' a) where
    20 
    +  reqMeth = const "Foo (T' a) instance"
    21 
    +  defMeth = const "Foo (T' a) instance"
    22 
    +
    23 
    +-- no method use could "cover" this instance, so we (for now) omit the top-level box for it
    24 
    +class Marker a
    25 
    +instance Marker (T Bool)
    26 
    +
    27 
    +interesting :: (Int, MixEntry) -> Maybe (Int, HpcPos, String)
    28 
    +interesting (n, (pos, TopLevelBox [name])) | isInteresting name = Just (n, pos, name)
    29 
    +  where isInteresting = (||) <$> isInst <*> isMeth
    30 
    +        isInst = ("$f" `isPrefixOf`)
    31 
    +        isMeth = (||) <$> (`elem` ["(==)", "(/=)", "show", "showList", "showsPrec", "fmap", "(<$)"])
    32 
    +                      <*> ("Meth" `isSubsequenceOf`)
    33 
    +interesting _ = Nothing
    34 
    +
    35 
    +-- candidate for HPC.Utils, maybe?
    36 
    +sourceAt :: String -> HpcPos -> String
    37 
    +sourceAt src pos
    38 
    +  | l1 == l2 = take (c2 - c1 + 1) . drop (c1 - 1) $ ls !! (l1 - 1)
    39 
    +  | otherwise = intercalate "\n" $ first : (middle ++ [last])
    40 
    +  where
    41 
    +    (l1, c1, l2, c2) = fromHpcPos pos
    42 
    +    ls = lines src
    43 
    +    first = drop (c1 - 1) $ ls !! (l1 - 1)
    44 
    +    middle = take (l2 - l1 - 1) $ drop l1 ls
    45 
    +    last = take c2 $ ls !! (l2 - 1)
    46 
    +
    47 
    +main :: IO ()
    48 
    +main = do
    49 
    +  print (T 23 == (succ <$> T 22)) -- tick Eq and Functor by using any of their methods
    50 
    +  print (reqMeth (T' 1)) -- tick `Foo (T' a)` and that instance's `reqMeth`
    51 
    +
    52 
    +  Mix source _ _ _ mixEntries <- readMix [".hpc"] (Left "Main")
    53 
    +  src <- readFileUtf8 source
    54 
    +  let boxes = mapMaybe interesting $ zip [0 ..] mixEntries
    55 
    +  Tix [TixModule "Main" _ _ counts] <- examineTix
    56 
    +  mapM_ print [ (counts !! n, path, sourceAt src pos)
    57 
    +              | (n, pos, path) <- sortOn (\(_, _, s) -> s) boxes ]

  • testsuite/tests/hpc/instmeths/instmeths.stdout
    1 
    +True
    2 
    +"Foo (T' a) instance"
    3 
    +(1,"$fEqT","Eq")
    4 
    +(0,"$fFooT","Foo (T a)")
    5 
    +(1,"$fFooT'","Foo (T' a)")
    6 
    +(1,"$fFunctorT","Functor")
    7 
    +(0,"$fShowT","Show")
    8 
    +(0,"defMeth","defMeth = const \"class default\"")
    9 
    +(0,"defMeth","defMeth = const \"Foo (T' a) instance\"")
    10 
    +(0,"defMeth'","defMeth' = const \"class default\"")
    11 
    +(0,"reqMeth","reqMeth = const \"Foo (T a) instance\"")
    12 
    +(1,"reqMeth","reqMeth = const \"Foo (T' a) instance\"")

  • testsuite/tests/hpc/instmeths/test.T
    1 
    +setTestOpts([omit_ghci, when(fast(), skip), js_skip])
    2 
    +
    3 
    +test('instmeths',
    4 
    +     [ignore_extension],
    5 
    +     compile_and_run, ['-fhpc'])

  • testsuite/tests/primops/should_run/T27299.hs
    1 
    +{-# LANGUAGE MagicHash #-}
    2 
    +import GHC.Exts
    3 
    +import GHC.Word
    4 
    +import Numeric
    5 
    +
    6 
    +main :: IO ()
    7 
    +main = do
    8 
    +  putStrLn $ showHex (W# (bitReverse8# 0x55##)) ""
    9 
    +  putStrLn $ showHex (W# (bitReverse8# 0xAA##)) ""
    10 
    +  putStrLn $ showHex (W# (bitReverse16# 0x5555##)) ""
    11 
    +  putStrLn $ showHex (W# (bitReverse16# 0xAAAA##)) ""
    12 
    +  putStrLn $ showHex (W# (bitReverse32# 0x5555_5555##)) ""
    13 
    +  putStrLn $ showHex (W# (bitReverse32# 0xAAAA_AAAA##)) ""
    14 
    +  putStrLn $ showHex (W# (byteSwap16# 0xABCD##)) ""
    15 
    +  putStrLn $ showHex (W# (byteSwap32# 0xABCD_EF12##)) ""
    16 
    +  putStrLn $ showHex (W# (noinline bitReverse8# 0x55##)) ""
    17 
    +  putStrLn $ showHex (W# (noinline bitReverse8# 0xAA##)) ""
    18 
    +  putStrLn $ showHex (W# (noinline bitReverse16# 0x5555##)) ""
    19 
    +  putStrLn $ showHex (W# (noinline bitReverse16# 0xAAAA##)) ""
    20 
    +  putStrLn $ showHex (W# (noinline bitReverse32# 0x5555_5555##)) ""
    21 
    +  putStrLn $ showHex (W# (noinline bitReverse32# 0xAAAA_AAAA##)) ""
    22 
    +  putStrLn $ showHex (W# (noinline byteSwap16# 0xABCD##)) ""
    23 
    +  putStrLn $ showHex (W# (noinline byteSwap32# 0xABCD_EF12##)) ""

  • testsuite/tests/primops/should_run/T27299.stdout
    1 
    +aa
    2 
    +55
    3 
    +aaaa
    4 
    +5555
    5 
    +aaaaaaaa
    6 
    +55555555
    7 
    +cdab
    8 
    +12efcdab
    9 
    +aa
    10 
    +55
    11 
    +aaaa
    12 
    +5555
    13 
    +aaaaaaaa
    14 
    +55555555
    15 
    +cdab
    16 
    +12efcdab

  • testsuite/tests/primops/should_run/all.T
    ... ... @@ -91,3 +91,4 @@ test('T24496'
    91 91 
           ]
    92 92 
         , compile_and_run, ['-O'])
    93 93 
     test('T6026', normal, compile_and_run, [''])
    94 
    +test('T27299', normal, compile_and_run, [''])

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/compare/c97d7901a78d7237ac4e5c515542d1ec194f8e3e...edd502c98bb548558b5f19e1b75ddeae97ce4f98 at 1790334513