Wolfgang Jeltsch pushed to branch wip/jeltsch/improve-closure-property-check at Glasgow Haskell Compiler / GHC

Commits:

24 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

  • compiler/GHC/Driver/Downsweep.hs
    ... ... @@ -6,6 +6,8 @@
    6 6 
     {-# LANGUAGE BlockArguments #-}
    7 7 
     {-# LANGUAGE ViewPatterns #-}
    8 8
    9 
    +{-# OPTIONS_GHC -Wno-invalid-haddock #-}
    10 
    +
    9 11 
     -- | See Note [The ModuleGraph]
    10 12 
     module GHC.Driver.Downsweep
    11 13 
       ( downsweep
    ... ... @@ -54,7 +56,6 @@ import GHC.Runtime.Context
    54 56 
     import Language.Haskell.Syntax.ImpExp
    55 57 
     import GHC.Types.UnresolvedImport
    56 58
    57 
    -import GHC.Data.Graph.Directed
    58 59 
     import GHC.Data.FastString
    59 60 
     import GHC.Data.Maybe      ( expectJust )
    60 61 
     import qualified GHC.Data.Maybe as M
    ... ... @@ -71,12 +72,15 @@ import GHC.Utils.Logger
    71 72 
     import GHC.Utils.Fingerprint
    72 73 
     import GHC.Utils.TmpFs
    73 74 
     import GHC.Utils.Constants
    75 
    +import GHC.Utils.Monad (concatMapM)
    76 
    +import GHC.Utils.Monad.State.Strict
    74 77
    75 78 
     import GHC.Types.Error
    76 79 
     import GHC.Types.Target
    77 80 
     import GHC.Types.SourceFile
    78 81 
     import GHC.Types.SourceError
    79 82 
     import GHC.Types.SrcLoc
    83 
    +import GHC.Types.Unique.Set
    80 84 
     import GHC.Types.Unique.Map
    81 85 
     import GHC.Types.PkgQual
    82 86 
     import GHC.Types.Basic
    ... ... @@ -91,9 +95,12 @@ import GHC.Unit.Module.Graph
    91 95 
     import GHC.Unit.Module.Deps
    92 96 
     import qualified GHC.Unit.Home.Graph as HUG
    93 97 
     import GHC.Unit.Module.Stage
    98 
    +import GHC.Unit.External.Index (UnitAbiHash)
    94 99
    95 100 
     import Data.Either ( partitionEithers, lefts )
    101 
    +import Data.Map (Map)
    96 102 
     import qualified Data.Map as Map
    103 
    +import Data.Set (Set)
    97 104 
     import qualified Data.Set as Set
    98 105
    99 106 
     import Control.Concurrent.MVar
    ... ... @@ -101,7 +108,7 @@ import Control.Monad
    101 108 
     import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )
    102 109 
     import qualified Control.Monad.Catch as MC
    103 110 
     import Data.Maybe
    104 
    -import Data.List (partition)
    111 
    +import Data.List (sort, partition)
    105 112 
     import Data.Time
    106 113 
     import Data.List (unfoldr)
    107 114 
     import Data.Bifunctor (first, bimap)
    ... ... @@ -933,52 +940,175 @@ rootSummariesParallel n_jobs hsc_env diag_wrapper msg get_summary = do
    933 940 
     -- * Check/validate properties and error out
    934 941 
     --------------------------------------------------------------------------------
    935 942
    936 
    --- | This function checks then important property that if both p and q are home units
    937 
    --- then any dependency of p, which transitively depends on q is also a home unit.
    943 
    +-- | Checks whether the given 'UnitEnv' has the closure property.
    938 944 
     --
    939 
    --- See Note [Multiple Home Units], section 'Closure Property'.
    940 
    -checkHomeUnitsClosed ::  UnitEnv -> [DriverMessages]
    941 
    -checkHomeUnitsClosed ue
    942 
    -    | Set.null bad_unit_ids = []
    943 
    -    | otherwise = [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)]
    945 
    +--   See the section “Closure Property” in @Note [Multiple Home Units]@ for the
    946 
    +--   definition of the closure property and
    947 
    +--   @Note [Home unit closure property check]@ below for a discussion of the
    948 
    +--   algorithm used for this check, its justification, and a potential
    949 
    +--   alternative.
    950 
    +checkHomeUnitsClosed :: UnitEnv -> [DriverMessages]
    951 
    +checkHomeUnitsClosed unit_env
    952 
    +  | null offenders = []
    953 
    +  | otherwise      = [
    954 
    +                        singleMessage                                $
    955 
    +                        mkPlainErrorMsgEnvelope error_source_span    $
    956 
    +                        DriverHomePackagesNotClosed (sort offenders)
    957 
    +                     ]
    944 958 
       where
    945 
    -    home_id_set = HUG.allUnits $ ue_home_unit_graph ue
    946 
    -    bad_unit_ids = upwards_closure Set.\\ home_id_set {- Remove all home units reached, keep only bad nodes -}
    947 
    -    rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
    948 959
    949 
    -    downwards_closure :: Graph (Node UnitId UnitId)
    950 
    -    downwards_closure = graphFromEdgedVerticesUniq graphNodes
    960 
    +  -- | The 'UnitId' and 'HomeUnitEnv' of each home unit.
    961 
    +  home_unit_data :: [(UnitId, HomeUnitEnv)]
    962 
    +  home_unit_data = HUG.unitEnv_assocs (ue_home_unit_graph unit_env)
    963 
    +
    964 
    +  -- | The 'UnitId's of all home units.
    965 
    +  home_units :: UniqSet UnitId
    966 
    +  home_units = mkUniqSet (map fst home_unit_data)
    967 
    +
    968 
    +  -- | All offending dependencies. A dependency of a unit /u/ on a unit /v/ is
    969 
    +  --   offending exactly if /u/ is an external unit reachable from a home unit
    970 
    +  --   and /v/ is a home unit. Each such dependency is represented in this list
    971 
    +  --   by the pair of the 'UnitId' of /u/ and the 'UnitId' of /v/.
    972 
    +  offenders :: [(UnitId, UnitId)]
    973 
    +  offenders
    974 
    +    = evalState (collect (map (homeUnitEnv_units . snd) home_unit_data))
    975 
    +                emptyUniqMap
    976 
    +    where
    951 977
    952 
    -    inverse_closure = graphReachability $ transposeG downwards_closure
    978 
    +    -- | Collects offending dependencies.
    979 
    +    collect :: [UnitState]
    980 
    +               -- ^ The 'UnitState's of the home units from which to traverse
    981 
    +               --   the dependency graph.
    982 
    +            -> State (UniqMap UnitId (Set UnitAbiHash)) [(UnitId, UnitId)]
    983 
    +               -- ^ A stateful computation that collects offending dependencies
    984 
    +               --   that have not yet been found. It uses its state, which is an
    985 
    +               --   efficent representation of a set of 'GlobalUnitKey's, to
    986 
    +               --   keep track of which units have already been considered as
    987 
    +               --   sources of offending dependencies.
    988 
    +    collect = concatMapM $ \ unit_state ->
    989 
    +              collect_for_home_unit
    990 
    +                (unitInfoMap unit_state)
    991 
    +                (map (toUnitId . fst) $ explicitUnits $ unit_state)
    992 
    +      where
    953 993
    954 
    -    upwards_closure = Set.fromList $ map node_key $ allReachableMany inverse_closure [DigraphNode uid uid [] | uid <- Set.toList home_id_set]
    994 
    +      -- | Collects offending dependencies that are reachable from a particular
    995 
    +      --   home unit.
    996 
    +      collect_for_home_unit
    997 
    +        :: UnitInfoMap
    998 
    +           -- ^ The 'UnitInfoMap' of the home unit.
    999 
    +        -> [UnitId]
    1000 
    +           -- ^ The 'UnitId's of the units from which to traverse the dependency
    1001 
    +           --   graph.
    1002 
    +        -> State (UniqMap UnitId (Set UnitAbiHash)) [(UnitId, UnitId)]
    1003 
    +           -- ^ A stateful computation that collects offending dependencies that
    1004 
    +           --   have not yet been found. It uses its state, which is an efficent
    1005 
    +           --   representation of a set of 'GlobalUnitKey's, to keep track of
    1006 
    +           --   which units have already been considered as sources of offending
    1007 
    +           --   dependencies.
    1008 
    +      collect_for_home_unit _ []
    1009 
    +        = return []
    1010 
    +      collect_for_home_unit unit_info_map (current_unit : remaining_units) = do
    1011 
    +        let
    1012 
    +
    1013 
    +          -- | The 'UnitInfo' of the current unit.
    1014 
    +          unit_info :: UnitInfo
    1015 
    +          unit_info
    1016 
    +            = fromMaybe (pprPanic unit_not_found_msg (ppr current_unit)) $
    1017 
    +              lookupUniqMap unit_info_map current_unit
    1018 
    +            where
    1019 
    +
    1020 
    +            -- | The message that says that a unit was not found.
    1021 
    +            unit_not_found_msg :: String
    1022 
    +            unit_not_found_msg = "Unit not found during closure property check"
    1023 
    +
    1024 
    +          -- | The ABI hash of the current unit.
    1025 
    +          unit_abi_hash :: UnitAbiHash
    1026 
    +          unit_abi_hash = unitAbiHash unit_info
    1027 
    +
    1028 
    +        has_been_processed <- gets $ maybe False (Set.member unit_abi_hash) .
    1029 
    +                                     (`lookupUniqMap` current_unit)
    1030 
    +        if has_been_processed
    1031 
    +          then collect_for_home_unit unit_info_map remaining_units
    1032 
    +          else do
    1033 
    +            modify $ \ processed -> addToUniqMap_C Set.union
    1034 
    +                                                   processed
    1035 
    +                                                   current_unit
    1036 
    +                                                   (Set.singleton unit_abi_hash)
    1037 
    +            let
    1038 
    +
    1039 
    +              -- | The 'UnitId's of the units that the current unit depends on.
    1040 
    +              needed_units :: [UnitId]
    1041 
    +              needed_units = unitDepends unit_info
    1042 
    +
    1043 
    +              -- | The offending dependencies of the current unit.
    1044 
    +              current_offenders :: [(UnitId, UnitId)]
    1045 
    +              current_offenders
    1046 
    +                | current_unit `elementOfUniqSet` home_units
    1047 
    +                  = []
    1048 
    +                | otherwise
    1049 
    +                  = map ((,) current_unit) $
    1050 
    +                    nonDetEltsUniqSet $
    1051 
    +                    mkUniqSet needed_units `intersectUniqSets` home_units
    1052 
    +
    1053 
    +            remaining_offenders <- collect_for_home_unit unit_info_map $
    1054 
    +                                   needed_units ++ remaining_units
    1055 
    +            return $ current_offenders ++ remaining_offenders
    1056 
    +
    1057 
    +  -- | A fake source span used for reporting violations of the closure property.
    1058 
    +  error_source_span :: SrcSpan
    1059 
    +  error_source_span = mkGeneralSrcSpan (fsLit "<command line>")
    955 1060
    956 
    -    all_unit_direct_deps :: UniqMap UnitId (Set.Set UnitId)
    957 
    -    all_unit_direct_deps
    958 
    -      = HUG.unitEnv_foldWithKey go emptyUniqMap $ ue_home_unit_graph ue
    959 
    -      where
    960 
    -        go rest this this_uis =
    961 
    -           plusUniqMap_C Set.union
    962 
    -             (addToUniqMap_C Set.union external_depends this (Set.fromList $ this_deps))
    963 
    -             rest
    964 
    -           where
    965 
    -             external_depends = mapUniqMap (Set.fromList . unitDepends) (unitInfoMap this_units)
    966 
    -             this_units = homeUnitEnv_units this_uis
    967 
    -             this_deps = [ toUnitId unit | (unit,Just _) <- explicitUnits this_units]
    968 
    -
    969 
    -    graphNodes :: [Node UnitId UnitId]
    970 
    -    graphNodes = go Set.empty home_id_set
    971 
    -      where
    972 
    -        go done todo
    973 
    -          = case Set.minView todo of
    974 
    -              Nothing -> []
    975 
    -              Just (uid, todo')
    976 
    -                | Set.member uid done -> go done todo'
    977 
    -                | otherwise -> case lookupUniqMap all_unit_direct_deps uid of
    978 
    -                    Nothing -> pprPanic "uid not found" (ppr (uid, all_unit_direct_deps))
    979 
    -                    Just depends ->
    980 
    -                      let todo'' = (depends Set.\\ done) `Set.union` todo'
    981 
    -                      in DigraphNode uid uid (Set.toList depends) : go (Set.insert uid done) todo''
    1061 
    +{-
    1062 
    +
    1063 
    +Note [Home unit closure property check]
    1064 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    1065 
    +
    1066 
    +Per the definition in Note [Multiple Home Units], a unit environment has the
    1067 
    +closure property exactly if there are no paths /h/₁ →* /e/ →* /h/₂ in the
    1068 
    +dependency graph, where /h/₁ and /h/₂ are home units and /e/ is an external
    1069 
    +unit. However, the algorithm used by 'checkHomeUnitsClosed' searches for
    1070 
    +so-called offending dependencies, which are dependencies /e/ → /h/₂ that are
    1071 
    +part of a path /h/₁ →* /e/ → /h/₂ in the dependency graph. To see that this is a
    1072 
    +viable approach, consider the following:
    1073 
    +
    1074 
    +  * A path /h/₁ →* /e/ → /h/₂ is also a path /h/₁ →* /e/ →* /h/₂.
    1075 
    +
    1076 
    +  * For each path /h/₁ →* /e/ →* /h/₂, there exists a path /h/₁ →* /e/′ → /h/₂′,
    1077 
    +    where /e/′ is an external unit and /h/₂′ is a home unit. Such a path can be
    1078 
    +    constructed by taking as /h/₂′ the first home unit on the path /e/ →* /h/₂
    1079 
    +    and as /e/′ the, necessarily external, unit preceding it.
    1080 
    +
    1081 
    +Concretely, the algorithm picks one home unit after the other, determines what
    1082 
    +units it directly depends on, and, starting from them, follows unit dependencies
    1083 
    +to search for offending dependencies. It does not follow dependencies that have
    1084 
    +been followed before, possibly when processing another home unit. To achieve
    1085 
    +this, the algorithm tracks, across home units, from which units it has already
    1086 
    +followed dependencies. For this tracking, it identifies each unit by a 'UnitId'
    1087 
    +and an ABI hash. Using only a 'UnitId' would not work, because 'UnitId's are not
    1088 
    +always globally unique. Also using only an ABI hash is not an option, because an
    1089 
    +ABI hash is not necessarily an ABI hash: it can also be the string @"inline"@.
    1090 
    +
    1091 
    +The correctness of this algorithm rests on the, likely correct, assumption that,
    1092 
    +among the units mentioned in the 'UnitState' of a particular home unit, any unit
    1093 
    +can be uniquely identified by its 'UnitId' and thus 'UnitId' clashes can only
    1094 
    +occur across the 'UnitState's of different home units.
    1095 
    +
    1096 
    +An alternative approach to finding offending dependencies would be to follow
    1097 
    +dependencies starting from all units that /any/ home unit directly depends on
    1098 
    +instead of considering the different home units separately. A corresponding
    1099 
    +algorithm could in principle find the dependencies of a particular unit
    1100 
    +independently of any home unit by fetching the 'UnitInfo' of that unit from the
    1101 
    +'GlobalUnitInfoMap'. However, for such a lookup the algorithm would need not
    1102 
    +only the 'UnitId' but also the ABI hash of the unit in question. Therefore,
    1103 
    +whenever following a dependency of a unit /u/ on a unit /v/, it would have to
    1104 
    +determine the ABI hash of /v/, so that it could later look up /v/’s
    1105 
    +dependencies. The ABI hashes of all units that /u/ depends on should be
    1106 
    +available in the 'unitAbiDepends' field of /u/’s 'UnitInfo'. However, at the
    1107 
    +time of writing, 'unitAbiDepends' never contained anything other than the empty
    1108 
    +list during GHC test runs, which indicated that this alternative solution was
    1109 
    +impossible to realize.
    1110 
    +
    1111 
    +-}
    982 1112
    983 1113 
     --------------------------------------------------------------------------------
    984 1114 
     -- * Enable Code Gen for Template Haskell
    ... ... @@ -1763,7 +1893,7 @@ data NodeRes v
    1763 1893 
     --
    1764 1894 
     -- See also Note [Downsweep Control Flow and Caching]
    1765 1895 
     dfsBuild :: (Ord k, Monad m)
    1766 
    -         => Maybe (Map.Map k (NodeRes v))
    1896 
    +         => Maybe (Map k (NodeRes v))
    1767 1897 
              -- ^ Base map, existing results. We won't re-expand any of the nodes
    1768 1898 
              -- already present in this map.
    1769 1899 
              -> [n]
    ... ... @@ -1773,7 +1903,7 @@ dfsBuild :: (Ord k, Monad m)
    1773 1903 
              -> (n -> m (NodeRes (v,[n])))
    1774 1904 
              -- ^ Expand this node into its payload result and into the list of
    1775 1905 
              -- children nodes to visit next.
    1776 
    -         -> m (Map.Map k (NodeRes v))
    1906 
    +         -> m (Map k (NodeRes v))
    1777 1907 
              -- ^ The result accumulates the payload of expanding the root nodes
    1778 1908 
              -- and all nodes transitively reachable from those roots.
    1779 1909 
     dfsBuild base_map roots key expand = go roots (fromMaybe Map.empty base_map)

  • 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/Driver/Errors/Ppr.hs
    ... ... @@ -235,10 +235,17 @@ instance Diagnostic DriverMessage where
    235 235 
                            "but no output will be generated.") $$
    236 236 
                            (text "There is no module named" <+>
    237 237 
                            quotes (ppr mod_name) <> text "."))
    238 
    -    DriverHomePackagesNotClosed needed_unit_ids
    239 
    -      -> mkSimpleDecorated $ vcat ([text "Home units are not closed."
    240 
    -                                  , text "It is necessary to also load the following units:" ]
    241 
    -                                  ++ map (\uid -> text "-" <+> ppr uid) needed_unit_ids)
    238 
    +    DriverHomePackagesNotClosed offending_dependencies
    239 
    +      -> mkSimpleDecorated $
    240 
    +         hang (text "Some units are not loaded but depend on loaded units.")
    241 
    +              4
    242 
    +              (vcat (map pprDependency offending_dependencies))
    243 
    +      where
    244 
    +
    245 
    +        pprDependency :: (UnitId, UnitId) -> SDoc
    246 
    +        pprDependency (external_unit, home_unit)
    247 
    +          = ppr external_unit <+> arrow <+> ppr home_unit
    248 
    +
    242 249 
         DriverInterfaceError reason -> diagnosticMessage (ifaceDiagnosticOpts opts) reason
    243 250
    244 251 
         DriverInconsistentDynFlags msg

  • compiler/GHC/Driver/Errors/Types.hs
    ... ... @@ -369,7 +369,7 @@ data DriverMessage where
    369 369
    370 370 
       DriverRedirectedNoMain :: !ModuleName -> DriverMessage
    371 371
    372 
    -  DriverHomePackagesNotClosed :: ![UnitId] -> DriverMessage
    372 
    +  DriverHomePackagesNotClosed :: ![(UnitId, UnitId)] -> DriverMessage
    373 373
    374 374 
       DriverInterfaceError :: !IfaceMessage -> DriverMessage
    375 375

  • compiler/GHC/Unit/Env.hs
    ... ... @@ -443,13 +443,14 @@ The flow:
    443 443 
     Closure Property
    444 444 
     ----------------
    445 445
    446 
    -You must perform a clean cut of the dependency graph.
    446 
    +A unit environment must have the closure property:
    447 447
    448 
    -> Any dependency which is not a home unit must not (transitively) depend on a home unit.
    448 
    +    No used external unit depends on a home unit.
    449 449
    450 
    -For example, if you have three packages p, q and r, then if p depends on q which
    451 
    -depends on r then it is illegal to load both p and r as home units but not q,
    452 
    -because q is a dependency of the home unit p which depends on another home unit r.
    450 
    +More concretely, a unit environment has the closure property exactly if no home
    451 
    +unit directly or indirectly depends on an external unit that directly or
    452 
    +indirectly depends on a home unit. 'GHC.Driver.Downsweep.checkHomeUnitsClosed'
    453 
    +checks whether a given unit environment indeed has this property.
    453 454
    454 455 
     Offsetting Paths
    455 456 
     ----------------

  • hadrian/ghci-multi-cabal.in
    ... ... @@ -10,4 +10,4 @@ export TOOL_OUTPUT=.hadrian_ghci_multi/ghci_args
    10 10 
     # Replace newlines with spaces, as these otherwise break the ghci invocation on windows.
    11 11 
     CABFLAGS=-v0 "hadrian/build-cabal" multi --build-root=.hadrian_ghci_multi --flavour=ghc-in-ghci $HADRIAN_ARGS
    12 12 
     GHC_FLAGS="$GHC_FLAGS $(cat $TOOL_OUTPUT | tr '\n\r' ' ')"
    13 
    -$RUN_GHC --interactive $GHC_FLAGS $@ -fno-code -fwrite-interface -O0 +RTS -A128m
    13 
    +$RUN_GHC --interactive $GHC_FLAGS $@ -hide-all-packages -fno-code -fwrite-interface -O0 +RTS -A128m

  • 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/driver/multipleHomeUnits/mhu-closure/Makefile
    ... ... @@ -3,39 +3,47 @@ include $(TOP)/mk/boilerplate.mk
    3 3 
     include $(TOP)/mk/test.mk
    4 4
    5 5 
     SETUP=../Setup -v0
    6 
    +CONFIGURE=configure \
    7 
    +	  $(CABAL_MINIMAL_BUILD) \
    8 
    +	  --with-ghc='$(TEST_HC)' \
    9 
    +	  --with-hc-pkg='$(GHC_PKG)' \
    10 
    +	  --ghc-options='$(TEST_HC_OPTS)' \
    11 
    +	  --package-db=../tmp.d
    12 
    +TEST_BUILD='$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp
    13 
    +ONLY_BASE=-hide-all-packages -package base
    6 14
    7 
    -mhu-closure: clean
    8 
    -	$(MAKE) -s --no-print-directory clean
    15 
    +mhu-closure: clean pkg-database
    16 
    +	! $(TEST_BUILD) -unit @unitP
    17 
    +	! $(TEST_BUILD) -unit @unitP -unit @unitQ
    18 
    +	! $(TEST_BUILD) -unit @unitP -unit @unitR
    19 
    +	! $(TEST_BUILD) -unit @unitP -unit @unitR1
    20 
    +	$(TEST_BUILD) -unit @unitP -unit @unitQ -unit @unitR
    21 
    +	! $(TEST_BUILD) -unit @unitP -unit @unitQ -unit @unitR1
    22 
    +	$(TEST_BUILD) $(ONLY_BASE) -unit @unitP
    23 
    +	$(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitQ
    24 
    +	! $(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitR
    25 
    +	! $(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitR1
    26 
    +	$(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitQ -unit @unitR
    27 
    +	$(TEST_BUILD) $(ONLY_BASE) -unit @unitP -unit @unitQ -unit @unitR1
    28 
    +
    29 
    +.PHONY: pkg-database
    30 
    +pkg-database:
    9 31 
     	'$(GHC_PKG)' init tmp.d
    10 32 
     	'$(TEST_HC)' $(TEST_HC_OPTS) -v0 --make Setup
    11 
    -	cd p && $(SETUP) clean
    12 
    -	cd p && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --ipid=p-0.1.0.0 --with-ghc='$(TEST_HC)' --with-hc-pkg='$(GHC_PKG)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d
    33 
    +	cd p && $(SETUP) $(CONFIGURE) --ipid=p-0.1.0.0
    13 34 
     	cd p && $(SETUP) build
    14 35 
     	cd p && $(SETUP) register --inplace
    15 
    -	cd q && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --ipid=q-0.1.0.0 --with-ghc='$(TEST_HC)' --with-hc-pkg='$(GHC_PKG)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d
    36 
    +	cd q && $(SETUP) $(CONFIGURE) --ipid=q-0.1.0.0
    16 37 
     	cd q && $(SETUP) build
    17 38 
     	cd q && $(SETUP) register --inplace
    18 
    -	cd r && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --ipid=r-0.1.0.0 --with-ghc='$(TEST_HC)' --with-hc-pkg='$(GHC_PKG)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d
    39 
    +	cd r && $(SETUP) $(CONFIGURE) --ipid=r-0.1.0.0
    19 40 
     	cd r && $(SETUP) build
    20 41 
     	cd r && $(SETUP) register --inplace
    21 
    -	# This should work
    22 
    -	'$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP
    23 
    -	# So should this
    24 
    -	'$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitQ
    25 
    -	# So should this
    26 
    -	'$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitQ -unit @unitR
    27 
    -	# This should error with a closure message
    28 
    -	! '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitR
    29 
    -	# This should work, even though r1 is not in the package db
    30 
    -	'$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitQ -unit @unitR1
    31 
    -	# This should fail, even though r1 is not in the package db
    32 
    -	! '$(TEST_HC)' $(TEST_HC_OPTS) -fhide-source-paths -fforce-recomp -unit @unitP -unit @unitR1
    33 42
    43 
    +.PHONY: clean
    44 
    +clean:
    45 
    +	$(RM) -r tmp.d Setup$(exeext) */dist* *.hi *.o */*.hi */*.o
    34 46
    35 47 
     ifeq "$(CLEANUP)" "1"
    36 48 
     	$(MAKE) -s --no-print-directory clean
    37 49 
     endif
    38 
    -
    39 
    -clean :
    40 
    -	 $(RM) -r tmp*.d inst-* *.o *.hi */*.o */*.hi */Setup$(exeext) */dist Setup$(exeext)
    41 
    -

  • testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stderr
    1 1
    2 2 
     <command line>: error: [GHC-03271]
    3 
    -    Home units are not closed.
    4 
    -    It is necessary to also load the following units:
    5 
    -    - q-0.1.0.0
    3 
    +    Some units are not loaded but depend on loaded units.
    4 
    +        q-0.1.0.0 -> p-0.1.0.0
    6 5
    7 6 
     <command line>: error: [GHC-03271]
    8 
    -    Home units are not closed.
    9 
    -    It is necessary to also load the following units:
    10 
    -    - q-0.1.0.0
    7 
    +    Some units are not loaded but depend on loaded units.
    8 
    +        r-0.1.0.0 -> q-0.1.0.0
    9 
    +
    10 
    +<command line>: error: [GHC-03271]
    11 
    +    Some units are not loaded but depend on loaded units.
    12 
    +        q-0.1.0.0 -> p-0.1.0.0
    13 
    +
    14 
    +<command line>: error: [GHC-03271]
    15 
    +    Some units are not loaded but depend on loaded units.
    16 
    +        q-0.1.0.0 -> p-0.1.0.0
    17 
    +
    18 
    +<command line>: error: [GHC-03271]
    19 
    +    Some units are not loaded but depend on loaded units.
    20 
    +        r-0.1.0.0 -> q-0.1.0.0
    21 
    +
    22 
    +<command line>: error: [GHC-03271]
    23 
    +    Some units are not loaded but depend on loaded units.
    24 
    +        q-0.1.0.0 -> p-0.1.0.0
    25 
    +
    26 
    +<command line>: error: [GHC-03271]
    27 
    +    Some units are not loaded but depend on loaded units.
    28 
    +        q-0.1.0.0 -> p-0.1.0.0

  • testsuite/tests/driver/multipleHomeUnits/mhu-closure/mhu-closure.stdout
    1 
    +[1 of 3] Compiling P[p-0.1.0.0]
    2 
    +[2 of 3] Compiling Q[q-0.1.0.0]
    3 
    +[3 of 3] Compiling R[r-0.1.0.0]
    1 4 
     [1 of 1] Compiling P
    2 5 
     [1 of 2] Compiling P[p-0.1.0.0]
    3 6 
     [2 of 2] Compiling Q[q-0.1.0.0]

  • 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/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/db612ab3a3809cbd7c53526cd9d5803cae7b86fc...aacc2e142a3057a5878ba3360e6727f30067ad87 at 1790196181