Simon Jakobi pushed to branch wip/sjakobi/T27296-stable-simpl at Glasgow Haskell Compiler / GHC

Commits:

21 changed files:

Changes:

  • boot
    ... ... @@ -52,9 +52,8 @@ def autoreconf():
    52 52 
         # Run autoreconf on everything that needs it.
    53 53 
         processes = {}
    54 54 
         if os.name == 'nt':
    55 
    -        # Get the normalized ACLOCAL_PATH for Windows
    56 
    -        # This is necessary since on Windows this will be a Windows
    57 
    -        # path, which autoreconf doesn't know doesn't know how to handle.
    55 
    +        # Convert ACLOCAL_PATH env variable to unix style paths on Windows
    56 
    +        # See Note [Autoreconf unix paths from ACLOCAL_PATH]
    58 57 
             ac_local = os.getenv('ACLOCAL_PATH', '')
    59 58 
             ac_local_arg = re.sub(r';', r':', ac_local)
    60 59 
             ac_local_arg = re.sub(r'\\', r'/', ac_local_arg)

  • changelog.d/stable-core-dump-order-27296
    1 
    +section: compiler
    2 
    +synopsis: Add :ghc-flag:`-dstable-core-dump-order`, a debugging flag that prints top-level Core bindings in a stable, source-location-based order that does not depend on uniques, making intermediate-compiler dumps (e.g. with :ghc-flag:`-ddump-simpl` or :ghc-flag:`-dverbose-core2core`) easier to diff. This affects only the compiler's intermediate output; it does not change generated code.
    3 
    +issues: #27296
    4 
    +mrs: !16143

  • compiler/GHC/Core/Lint.hs
    ... ... @@ -327,12 +327,17 @@ dumpPassResult logger dump_core_sizes name_ppr_ctx mb_flag hdr extra_info binds
    327 327 
       where
    328 328 
         size_doc = sep [text "Result size of" <+> text hdr, nest 2 (equals <+> ppr (coreBindsStats binds))]
    329 329
    330 
    +    -- See Note [Stable Core dump order] in GHC.Core.Ppr
    331 
    +    binds' | sdocStableCoreDumpOrder (log_default_dump_context (logFlags logger))
    332 
    +                        = sortCoreBindingsForDump binds
    333 
    +           | otherwise  = binds
    334 
    +
    330 335 
         dump_doc  = vcat [ nest 2 extra_info
    331 336 
                          , size_doc
    332 337 
                          , blankLine
    333 338 
                          , if dump_core_sizes
    334 
    -                        then pprCoreBindingsWithSize binds
    335 
    -                        else pprCoreBindings         binds
    339 
    +                        then pprCoreBindingsWithSize binds'
    340 
    +                        else pprCoreBindings         binds'
    336 341 
                          , ppUnless (null rules) pp_rules ]
    337 342 
         pp_rules = vcat [ blankLine
    338 343 
                         , text "------ Local rules for imported ids --------"

  • compiler/GHC/Core/Ppr.hs
    ... ... @@ -19,6 +19,7 @@ module GHC.Core.Ppr (
    19 19 
             pprCoreExpr, pprParendExpr,
    20 20 
             pprCoreBinding, pprCoreBindings, pprCoreAlt,
    21 21 
             pprCoreBindingWithSize, pprCoreBindingsWithSize,
    22 
    +        sortCoreBindingsForDump,
    22 23 
             pprCoreBinder, pprCoreBinders, pprId, pprIds,
    23 24 
             pprRule, pprRules, pprOptCo,
    24 25 
             pprOcc, pprOccWithTick
    ... ... @@ -27,10 +28,10 @@ module GHC.Core.Ppr (
    27 28 
     import GHC.Prelude
    28 29
    29 30 
     import GHC.Core
    30 
    -import GHC.Core.Stats (exprStats)
    31 
    +import GHC.Core.Stats (CoreStats(..), exprStats)
    31 32 
     import GHC.Types.Fixity (LexicalFixity(..))
    32 
    -import GHC.Types.Literal( pprLiteral )
    33 
    -import GHC.Types.Name( pprInfixName, pprPrefixName )
    33 
    +import GHC.Types.Literal( Literal, pprLiteral )
    34 
    +import GHC.Types.Name( getOccString, getSrcSpan, pprInfixName, pprPrefixName )
    34 35 
     import GHC.Types.Var
    35 36 
     import GHC.Types.Id
    36 37 
     import GHC.Types.Id.Info
    ... ... @@ -44,9 +45,13 @@ import GHC.Core.Coercion
    44 45 
     import GHC.Types.Basic
    45 46 
     import GHC.Utils.Misc
    46 47 
     import GHC.Utils.Outputable
    47 
    -import GHC.Types.SrcLoc ( pprUserRealSpan )
    48 
    +import GHC.Utils.Panic (panic)
    49 
    +import GHC.Types.SrcLoc ( SrcSpan(..), pprUserRealSpan, srcSpanStartCol
    50 
    +                        , srcSpanStartLine )
    48 51 
     import GHC.Types.Tickish
    49 52
    53 
    +import Data.List ( sortOn )
    54 
    +
    50 55 
     {-
    51 56 
     ************************************************************************
    52 57 
     *                                                                      *
    ... ... @@ -71,6 +76,115 @@ pprCoreBindingWithSize :: CoreBind -> SDoc
    71 76 
     pprCoreBindingsWithSize = pprTopBinds sizeAnn
    72 77 
     pprCoreBindingWithSize = pprTopBind sizeAnn
    73 78
    79 
    +{- Note [Stable Core dump order]
    80 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    81 
    +The order of top-level bindings in a Core dump (-ddump-simpl etc.) is the
    82 
    +compiler's internal processing order, which is sensitive to Uniques. Uniques
    83 
    +can shift whenever an unrelated upstream module changes, so the bindings get
    84 
    +re-ordered and a textual diff of two dumps fails to line up the real changes
    85 
    +(#27296).
    86 
    +
    87 
    +With -dstable-core-dump-order we reorder the top-level bindings at dump time into
    88 
    +a stable order. 'sortCoreBindingsForDump' sorts by a key that is *independent of
    89 
    +Uniques*, so two dumps line up across rebuilds. The sort key is:
    90 
    +
    91 
    +  1. the binder's source span (real spans in source order; noSrcSpan last).
    92 
    +     Workers and specialisations inherit their origin's source span (see
    93 
    +     'mkWorkerId' and 'newSpecIdSM'), so they cluster next to the binding they
    94 
    +     come from.
    95 
    +  2. a "$-rank" so that within one source span the compiler-derived binders sort
    96 
    +     *before* the origin they come from (e.g. @$wfoo@ before @foo@), mirroring
    97 
    +     GHC's default dependency order (the wrapper calls the worker, so the worker
    98 
    +     comes first; specialisations likewise precede their origin). We rank by
    99 
    +     whether the OccName *contains* a '$', which marks a derived binder: a worker
    100 
    +     is @$wfoo@, but a call-site specialisation is tidied to @bar_$sfoo@ (no
    101 
    +     leading '$'), so a leading-'$' test would miss it.
    102 
    +  3. the OccName string, as a lexical, deterministic tie-break.
    103 
    +  4. a content-based tie-break on the right-hand side ('rhsKey'): the floated
    104 
    +     literal, if any, then the RHS size statistics. This matters for the
    105 
    +     anonymous floats: 'newLvlVar' builds them all with OccName "lvl" and
    106 
    +     noSrcSpan, so keys 1-3 are identical and without it their order would fall
    107 
    +     back to the Unique-driven input order -- the churn we set out to remove.
    108 
    +     (Tidied dumps like -ddump-simpl give the floats distinct names lvl,
    109 
    +     lvl1, ...; this additionally stabilises untidied dumps such as
    110 
    +     -ddump-simpl-iterations.) It is only a best-effort tie-break -- RHSs
    111 
    +     agreeing on both components keep their input order -- and Unique-independent
    112 
    +     for the numeric CAFs we target (a rubbish literal is the exception: its
    113 
    +     'cmpLit' falls back to the Unique-dependent 'nonDetCmpType').
    114 
    +
    115 
    +Recursive groups are never split: a 'Rec' is one 'CoreBind', placed as a unit by
    116 
    +its earliest-source member, with its members sorted by the same key.
    117 
    +
    118 
    +Only *top-level* bindings (and the members of a top-level 'Rec') are reordered.
    119 
    +Bindings nested inside a right-hand side (a 'let'/'letrec' within an expression)
    120 
    +are left in their original order: their position in the dump is fixed by the
    121 
    +surrounding expression rather than chosen by a Unique-keyed sort, so they don't
    122 
    +suffer the cross-module churn this flag addresses.
    123 
    +
    124 
    +-dstable-core-dump-order is opt-in; the default order is retained because it is
    125 
    +useful for debugging the compiler itself.
    126 
    +-}
    127 
    +
    128 
    +-- | The sort key for one top-level binder. The trailing 'RhsKey' is a
    129 
    +-- content-based tiebreak, used only when two binders agree on everything
    130 
    +-- before it. See Note [Stable Core dump order].
    131 
    +type DumpSortKey =
    132 
    +  ( Int     -- source-span bucket: 0 = real span, 1 = noSrcSpan (sorts last)
    133 
    +  , Int     -- source-span start line
    134 
    +  , Int     -- source-span start column
    135 
    +  , Int     -- dollar-rank: 0 = derived ($w/$s) binder, 1 = its origin
    136 
    +  , String  -- the OccName string, a lexical tiebreak
    137 
    +  , RhsKey  -- content-based tiebreak (see 'rhsKey')
    138 
    +  )
    139 
    +
    140 
    +-- | Reorder a 'CoreProgram' into a stable, source-location-driven order for
    141 
    +-- dumping. See Note [Stable Core dump order]. Used by 'dumpPassResult' when
    142 
    +-- -dstable-core-dump-order is enabled.
    143 
    +sortCoreBindingsForDump :: CoreProgram -> CoreProgram
    144 
    +sortCoreBindingsForDump = sortOn bindKey . map sortRecMembers
    145 
    +  where
    146 
    +    sortRecMembers (Rec prs) = Rec (sortOn (uncurry elemKey) prs)
    147 
    +    sortRecMembers b         = b
    148 
    +
    149 
    +    -- 'sortRecMembers' runs first, so a 'Rec' is already sorted by 'elemKey'
    150 
    +    -- when 'bindKey' sees it; its first member is therefore the minimum key.
    151 
    +    bindKey :: CoreBind -> DumpSortKey
    152 
    +    bindKey (NonRec b rhs)     = elemKey b rhs
    153 
    +    bindKey (Rec ((b,rhs):_))  = elemKey b rhs
    154 
    +    bindKey (Rec [])           = panic "sortCoreBindingsForDump: empty Rec"
    155 
    +
    156 
    +    elemKey :: CoreBndr -> CoreExpr -> DumpSortKey
    157 
    +    elemKey b rhs = (bucket, line, col, dollar_rank, s, rhsKey rhs)
    158 
    +      where
    159 
    +        s = getOccString b
    160 
    +        (bucket, line, col) = case getSrcSpan b of
    161 
    +          RealSrcSpan rs _ -> (0, srcSpanStartLine rs, srcSpanStartCol rs)
    162 
    +          _                -> (1, 0, 0)  -- noSrcSpan: sort last
    163 
    +        -- A '$' anywhere in a tidied top-level OccName marks a compiler-derived
    164 
    +        -- binder ($wfoo, but also call-site specialisations tidied to
    165 
    +        -- bar_$sfoo); rank those before their origin within a shared source span,
    166 
    +        -- mirroring GHC's default dependency order (the wrapper calls the worker,
    167 
    +        -- so the worker comes first).
    168 
    +        dollar_rank | '$' `elem` s = 0
    169 
    +                    | otherwise    = 1
    170 
    +
    171 
    +-- | A content-based tie-break on a binder's right-hand side: see point 4 of
    172 
    +-- Note [Stable Core dump order].
    173 
    +type RhsKey =
    174 
    +  ( Maybe Literal              -- the floated literal, if any (Nothing sorts first)
    175 
    +  , (Int, Int, Int, Int, Int)  -- exprStats counts: terms, types, coercions, value binds, join binds
    176 
    +  )
    177 
    +
    178 
    +rhsKey :: CoreExpr -> RhsKey
    179 
    +rhsKey rhs = (litOf rhs, statsTuple (exprStats rhs))
    180 
    +  where
    181 
    +    statsTuple (CS tm ty co vb jb) = (tm, ty, co, vb, jb)
    182 
    +    litOf (Lit l)    = Just l
    183 
    +    litOf (App f a)  = case a of { Lit l -> Just l; _ -> litOf f }
    184 
    +    litOf (Cast e _) = litOf e
    185 
    +    litOf (Tick _ e) = litOf e
    186 
    +    litOf _          = Nothing
    187 
    +
    74 188 
     instance OutputableBndr b => Outputable (Bind b) where
    75 189 
         ppr bind = ppr_bind noAnn bind
    76 190

  • compiler/GHC/Driver/DynFlags.hs
    ... ... @@ -1594,6 +1594,7 @@ initSDocContext dflags style = SDC
    1594 1594 
       , sdocSuppressModulePrefixes      = gopt Opt_SuppressModulePrefixes dflags
    1595 1595 
       , sdocSuppressStgExts             = gopt Opt_SuppressStgExts dflags
    1596 1596 
       , sdocSuppressStgReps             = gopt Opt_SuppressStgReps dflags
    1597 
    +  , sdocStableCoreDumpOrder         = gopt Opt_StableCoreDumpOrder dflags
    1597 1598 
       , sdocErrorSpans                  = gopt Opt_ErrorSpans dflags
    1598 1599 
       , sdocStarIsType                  = xopt LangExt.StarIsType dflags
    1599 1600 
       , sdocLinearTypes                 = xopt LangExt.LinearTypes dflags

  • compiler/GHC/Driver/Flags.hs
    ... ... @@ -859,6 +859,10 @@ data GeneralFlag
    859 859 
        | Opt_SuppressTimestamps -- ^ Suppress timestamps in dumps
    860 860 
        | Opt_SuppressCoreSizes  -- ^ Suppress per binding Core size stats in dumps
    861 861
    862 
    +   -- | Reorder top-level bindings in Core dumps into a stable, diffable order.
    863 
    +   -- See Note [Stable Core dump order] in GHC.Core.Ppr.
    864 
    +   | Opt_StableCoreDumpOrder
    865 
    +
    862 866 
        -- Error message suppression
    863 867 
        | Opt_ShowErrorContext
    864 868

  • compiler/GHC/Driver/Session.hs
    ... ... @@ -2468,6 +2468,7 @@ dFlagsDeps = [
    2468 2468 
       flagSpec "ppr-case-as-let"            Opt_PprCaseAsLet,
    2469 2469 
       depFlagSpec' "ppr-ticks"              Opt_PprShowTicks
    2470 2470 
          (\turn_on -> useInstead "-d" "suppress-ticks" (not turn_on)),
    2471 
    +  flagSpec "stable-core-dump-order"     Opt_StableCoreDumpOrder,
    2471 2472 
       flagSpec "suppress-ticks"             Opt_SuppressTicks,
    2472 2473 
       depFlagSpec' "suppress-stg-free-vars" Opt_SuppressStgExts
    2473 2474 
          (useInstead "-d" "suppress-stg-exts"),

  • compiler/GHC/Utils/Outputable.hs
    ... ... @@ -422,6 +422,7 @@ data SDocContext = SDC
    422 422 
       , sdocSuppressModulePrefixes      :: !Bool
    423 423 
       , sdocSuppressStgExts             :: !Bool
    424 424 
       , sdocSuppressStgReps             :: !Bool
    425 
    +  , sdocStableCoreDumpOrder         :: !Bool
    425 426 
       , sdocErrorSpans                  :: !Bool
    426 427 
       , sdocStarIsType                  :: !Bool
    427 428 
       , sdocLinearTypes                 :: !Bool
    ... ... @@ -490,6 +491,7 @@ defaultSDocContext = SDC
    490 491 
       , sdocSuppressModulePrefixes      = False
    491 492 
       , sdocSuppressStgExts             = False
    492 493 
       , sdocSuppressStgReps             = True
    494 
    +  , sdocStableCoreDumpOrder         = False
    493 495 
       , sdocErrorSpans                  = False
    494 496 
       , sdocStarIsType                  = False
    495 497 
       , sdocLinearTypes                 = False

  • docs/users_guide/debugging.rst
    ... ... @@ -959,6 +959,33 @@ parts that you are not interested in.
    959 959 
         has shown you where to look, you can try again without
    960 960 
         :ghc-flag:`-dsuppress-uniques`
    961 961
    962 
    +.. ghc-flag:: -dstable-core-dump-order
    963 
    +    :shortdesc: Reorder top-level bindings in Core dumps into a stable,
    964 
    +        diffable order
    965 
    +    :type: dynamic
    966 
    +    :reverse: -dno-stable-core-dump-order
    967 
    +    :category: verbosity
    968 
    +
    969 
    +    :since: 10.2.1
    970 
    +
    971 
    +    Normally the order of top-level bindings in a Core dump (such as the
    972 
    +    output of :ghc-flag:`-ddump-simpl`) reflects the compiler's internal
    973 
    +    processing order, which depends on ``Unique`` values. Those uniques can
    974 
    +    shift whenever an unrelated upstream module changes, so the bindings get
    975 
    +    re-ordered and a textual ``diff`` of two dumps fails to line up the real
    976 
    +    changes.
    977 
    +
    978 
    +    This flag is opt-in and reorders the top-level bindings of Core dumps that
    979 
    +    go through the pass-result printer (e.g. :ghc-flag:`-ddump-simpl`,
    980 
    +    :ghc-flag:`-ddump-prep`, :ghc-flag:`-ddump-ds`,
    981 
    +    :ghc-flag:`-ddump-simpl-iterations`) into a stable, source-location-driven
    982 
    +    order that does not depend on uniques.
    983 
    +
    984 
    +    It is intended to be combined with :ghc-flag:`-dsuppress-uniques` when
    985 
    +    diffing two dumps, but because the ordering does not depend on uniques the
    986 
    +    output is also more diffable without it. The default (in-compiler) order is
    987 
    +    retained because it is useful when debugging the compiler itself.
    988 
    +
    962 989 
     .. ghc-flag:: -dsuppress-idinfo
    963 990 
         :shortdesc: Suppress extended information about identifiers where they
    964 991 
             are bound

  • hadrian/src/Hadrian/Oracles/Path.hs
    1 1 
     {-# LANGUAGE TypeFamilies #-}
    2 2 
     module Hadrian.Oracles.Path (
    3 
    -    lookupInPath, fixAbsolutePathOnWindows, pathOracle
    3 
    +    lookupInPath, fixAbsolutePathOnWindows, fixUnixPathsOnWindows,
    4 
    +    pathOracle
    4 5 
         ) where
    5 6
    6 7 
     import Control.Monad
    ... ... @@ -33,6 +34,14 @@ fixAbsolutePathOnWindows path =
    33 34 
         else
    34 35 
             return path
    35 36
    37 
    +-- | Fix a unix path list on Windows:
    38 
    +-- * "C:\\foo\\bar;C:\\msys2\\bin" => "/c/foo/bar:/c/msys2/bin"
    39 
    +fixUnixPathsOnWindows :: FilePath -> Action FilePath
    40 
    +fixUnixPathsOnWindows paths =
    41 
    +    if isWindows
    42 
    +    then askOracle $ UnixPathList paths
    43 
    +    else return paths
    44 
    +
    36 45 
     newtype LookupInPath = LookupInPath String
    37 46 
         deriving (Binary, Eq, Hashable, NFData, Show)
    38 47 
     type instance RuleResult LookupInPath = String
    ... ... @@ -41,6 +50,10 @@ newtype WindowsPath = WindowsPath FilePath
    41 50 
         deriving (Binary, Eq, Hashable, NFData, Show)
    42 51 
     type instance RuleResult WindowsPath = String
    43 52
    53 
    +newtype UnixPathList = UnixPathList FilePath
    54 
    +    deriving (Binary, Eq, Hashable, NFData, Show)
    55 
    +type instance RuleResult UnixPathList = String
    56 
    +
    44 57 
     -- | Oracles for looking up paths. These are slow and require caching.
    45 58 
     pathOracle :: Rules ()
    46 59 
     pathOracle = do
    ... ... @@ -50,6 +63,12 @@ pathOracle = do
    50 63 
             putVerbose $ "| Windows path mapping: " ++ path ++ " => " ++ windowsPath
    51 64 
             return windowsPath
    52 65
    66 
    +    void $ addOracleCache $ \(UnixPathList paths) -> do
    67 
    +        Stdout out <- quietly $ cmd ["cygpath", "-p", "-u", paths]
    68 
    +        let unixPaths = unifyPath $ dropWhileEnd isSpace out
    69 
    +        putVerbose $ "| Unix path mapping: " ++ paths ++ " => " ++ unixPaths
    70 
    +        return unixPaths
    71 
    +
    53 72 
         void $ addOracleCache $ \(LookupInPath name) -> do
    54 73 
             path <- liftIO getSearchPath
    55 74 
             exes <- liftIO (findExecutablesInDirectories path name)

  • hadrian/src/Rules/BinaryDist.hs
    ... ... @@ -3,18 +3,19 @@ module Rules.BinaryDist where
    3 3
    4 4 
     import CommandLine
    5 5 
     import Context
    6 
    +import Data.Either
    7 
    +import qualified Data.Set as Set
    6 8 
     import Expression
    9 
    +import Hadrian.Oracles.Path (fixUnixPathsOnWindows)
    10 
    +import Oracles.Flavour
    7 11 
     import Oracles.Setting
    8 12 
     import Packages
    13 
    +import Rules.Generate (generateSettings)
    9 14 
     import Settings
    15 
    +import qualified System.Directory.Extra as IO
    10 16 
     import Settings.Program (programContext)
    11 17 
     import Target
    12 18 
     import Utilities
    13 
    -import qualified System.Directory.Extra as IO
    14 
    -import Data.Either
    15 
    -import qualified Data.Set as Set
    16 
    -import Oracles.Flavour
    17 
    -import Rules.Generate (generateSettings)
    18 19
    19 20 
     {-
    20 21 
     Note [Binary distributions]
    ... ... @@ -343,7 +344,25 @@ bindistRules = do
    343 344 
             ghcRoot <- topDirectory
    344 345 
             copyFile (ghcRoot -/- "aclocal.m4") (ghcRoot -/- "distrib" -/- "aclocal.m4")
    345 346 
             copyDirectory (ghcRoot -/- "m4") (ghcRoot -/- "distrib")
    346 
    -        buildWithCmdOptions [] $
    347 
    +
    348 
    +        -- Note [Autoreconf unix paths from ACLOCAL_PATH]
    349 
    +        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    350 
    +        -- On Windows, autoreconf fails when the ACLOCAL_PATH env variable contains Windows-
    351 
    +        -- style paths. This happens because MSYS2 automatically converts env variables to
    352 
    +        -- Windows-style paths. To fix this, we convert ACLOCAL_PATH back to Unix style.
    353 
    +        -- This is done both in the boot Python script and here when building a bindist.
    354 
    +        win_host <- isWinHost
    355 
    +        env <- if not win_host
    356 
    +          then pure []
    357 
    +          else do
    358 
    +            aclocalPathMay <- getEnv "ACLOCAL_PATH"
    359 
    +            case aclocalPathMay of
    360 
    +              Nothing -> pure []
    361 
    +              Just aclocalPath -> do
    362 
    +                unixAclocalPath <- fixUnixPathsOnWindows aclocalPath
    363 
    +                pure [AddEnv "ACLOCAL_PATH" unixAclocalPath]
    364 
    +
    365 
    +        buildWithCmdOptions env $
    347 366 
                 target (vanillaContext Stage1 ghc) (Autoreconf $ ghcRoot -/- "distrib") [] []
    348 367 
             -- We clean after ourselves, moving the configure script we generated in
    349 368 
             -- our bindist dir

  • testsuite/driver/runtests.py
    ... ... @@ -133,7 +133,7 @@ if args.unexpected_output_dir:
    133 133 
         config.unexpected_output_dir = Path(args.unexpected_output_dir)
    134 134
    135 135 
     if args.only:
    136 
    -    config.only = args.only
    136 
    +    config.only = set(args.only)
    137 137 
         config.run_only_some_tests = True
    138 138
    139 139 
     if args.skip:

  • testsuite/mk/test.mk
    ... ... @@ -109,9 +109,11 @@ endif
    109 109 
     HAVE_GDB := $(shell if gdb --version > /dev/null 2> /dev/null; then echo YES; else echo NO; fi)
    110 110 
     HAVE_READELF := $(shell if readelf --version > /dev/null 2> /dev/null; then echo YES; else echo NO; fi)
    111 111
    112 
    -# we need a better way to find which backend is selected and if --check flag is
    113 
    -# used
    114 
    -BIGNUM_GMP := $(shell "$(GHC_PKG)" field ghc-bignum exposed-modules | grep GMP)
    112 
    +# Detect whether the fast (GMP) bignum backend is in use. The GMP backend module
    113 
    +# in ghc-internal is hidden, so we look instead for the gmp library it links
    114 
    +# against: GMP_LIBS adds gmp to ghc-internal's extra-libraries only on a GMP
    115 
    +# build.
    116 
    +BIGNUM_GMP := $(shell "$(GHC_PKG)" field ghc-internal extra-libraries 2>/dev/null | grep gmp)
    115 117
    116 118 
     ifeq "$(filter thr, $(GhcRTSWays))" "thr"
    117 119 
     RUNTEST_OPTS += -e config.ghc_with_threaded_rts=True

  • testsuite/tests/simplCore/should_compile/Makefile
    ... ... @@ -298,3 +298,36 @@ T17901:
    298 298 
     	$(RM) -f T17901.o T17901.hi
    299 299 
     	'$(TEST_HC)' $(TEST_HC_OPTS) -O -c -ddump-simpl -dsuppress-uniques T17901.hs | grep 'wombat'
    300 300 
             # All three functions should get their case alternatives combined
    301 
    +
    302 
    +# Check -dstable-core-dump-order on a small Data.Map-style module. The
    303 
    +# sed allow-list prints, deduplicated, the top-level binders we care about in
    304 
    +# dump order. It inspects names only, so it is insensitive to unrelated
    305 
    +# Core-format churn.
    306 
    +#
    307 
    +# The allow-list covers one binder of each interesting category, so the test
    308 
    +# exercises the clustering of generated binders next to their origin:
    309 
    +#   * derived instances ($fEqKey/$fOrdKey/$fOrdKey_$ccompare),
    310 
    +#   * a call-site specialisation (findI_$slookupG, from lookupG's SPECIALISE), and
    311 
    +#   * a recursive worker ($wrotate).
    312 
    +T27296:
    313 
    +	$(RM) -f T27296.o T27296.hi
    314 
    +	'$(TEST_HC)' $(TEST_HC_OPTS) -O -c -ddump-simpl -dsuppress-uniques \
    315 
    +	    -dsuppress-idinfo -dsuppress-module-prefixes -dno-typeable-binds \
    316 
    +	    -dstable-core-dump-order T27296.hs 2> /dev/null \
    317 
    +	    | sed -nE 's/^(\$$fEqKey|\$$fOrdKey|\$$fOrdKey_\$$ccompare|size|findI_\$$slookupG|lookupG|member|findI|\$$wrotate|rotate|insertG|insertManyI|insertTwoI|weight|balance|ratios|fromAscI)( .*)?$$/\1/p' \
    318 
    +	    | uniq
    319 
    +
    320 
    +# See T27296b.hs for what this pins and why. -ddump-float-out is an untidied
    321 
    +# dump, so the sed normalises it down to just the bindings: it collapses each
    322 
    +# pass header to a bare "Float out" separator (dropping the noisy FOS config)
    323 
    +# and drops the "Result size" and "-- RHS size" lines.
    324 
    +T27296b:
    325 
    +	$(RM) -f T27296b.o T27296b.hi
    326 
    +	'$(TEST_HC)' $(TEST_HC_OPTS) -O -c -ddump-float-out -dsuppress-uniques \
    327 
    +	    -dsuppress-idinfo -dsuppress-module-prefixes -dno-typeable-binds \
    328 
    +	    -dstable-core-dump-order T27296b.hs 2> /dev/null \
    329 
    +	    | sed -E \
    330 
    +	        -e '/^=+ Float out/,/=+$$/c\==================== Float out ====================' \
    331 
    +	        -e '/^Result size of Float out/,/^  = \{terms/d' \
    332 
    +	        -e '/^-- RHS size:/d' \
    333 
    +	    | cat -s

  • testsuite/tests/simplCore/should_compile/T27296.hs
    1 
    +{-# LANGUAGE BangPatterns #-}
    2 
    +
    3 
    +-- See Note [Stable Core dump order] in GHC.Core.Ppr.
    4 
    +--
    5 
    +-- A small Data.Map-style module exercising the trickier parts of the stable
    6 
    +-- dump ordering. Under -O it produces, alongside the user functions:
    7 
    +--   * derived Eq/Ord instances for a custom Key type ($fEqKey/$fOrdKey/...),
    8 
    +--   * a call-site specialisation of lookupG (findI_$slookupG), and
    9 
    +--   * a worker/wrapper split of the recursive, strict rotate ($wrotate).
    10 
    +-- Each generated binder inherits its origin's source span, so the stable order
    11 
    +-- clusters it next to that origin. The source order is deliberately neither
    12 
    +-- alphabetical nor the default dump order (insertG forward-references balance),
    13 
    +-- so the test pins source-position ordering specifically.
    14 
    +module T27296
    15 
    +  ( Key(..), size, lookupG, member, findI, rotate, insertG, insertManyI
    16 
    +  , insertTwoI, weight, balance, ratios, fromAscI )
    17 
    +  where
    18 
    +
    19 
    +-- A custom key with a derived Ord instance: the derived $fEqKey/$fOrdKey
    20 
    +-- binders inherit this declaration's source span, so they cluster here.
    21 
    +data Key = Key Int deriving (Eq, Ord)
    22 
    +
    23 
    +data Map k a = Tip | Bin !Int k a !(Map k a) !(Map k a)
    24 
    +
    25 
    +data Sizes = Sizes !Int !Int
    26 
    +
    27 
    +size :: Map k a -> Int
    28 
    +size Tip              = 0
    29 
    +size (Bin sz _ _ _ _) = sz
    30 
    +
    31 
    +lookupG :: Ord k => k -> Map k a -> Maybe a
    32 
    +lookupG _ Tip = Nothing
    33 
    +lookupG k (Bin _ kx x l r) = case compare k kx of
    34 
    +  LT -> lookupG k l
    35 
    +  GT -> lookupG k r
    36 
    +  EQ -> Just x
    37 
    +{-# SPECIALISE lookupG :: Key -> Map Key a -> Maybe a #-}
    38 
    +
    39 
    +member :: Key -> Map Key a -> Bool
    40 
    +member k m = case lookupG k m of
    41 
    +  Nothing -> False
    42 
    +  Just _  -> True
    43 
    +
    44 
    +findI :: Key -> Map Key a -> a -> a
    45 
    +findI k m def = case lookupG k m of
    46 
    +  Nothing -> def
    47 
    +  Just v  -> v
    48 
    +
    49 
    +-- rotate is recursive and strict in the product 'Sizes', so worker/wrapper
    50 
    +-- unboxes it into a recursive worker ($wrotate). The loop only repackages the
    51 
    +-- fields (no arithmetic), so the worker is stable across build flavours.
    52 
    +rotate :: Sizes -> [a] -> Sizes
    53 
    +rotate s []               = s
    54 
    +rotate (Sizes a b) (_:xs) = rotate (Sizes b a) xs
    55 
    +
    56 
    +-- insertG references 'balance', which is defined further down (forward ref).
    57 
    +insertG :: Ord k => k -> a -> Map k a -> Map k a
    58 
    +insertG k x Tip = Bin 1 k x Tip Tip
    59 
    +insertG k x (Bin sz kx kv l r) = case compare k kx of
    60 
    +  LT -> balance kx kv (insertG k x l) r
    61 
    +  GT -> balance kx kv l (insertG k x r)
    62 
    +  EQ -> Bin sz k x l r
    63 
    +{-# SPECIALISE insertG :: Key -> a -> Map Key a -> Map Key a #-}
    64 
    +
    65 
    +insertManyI :: [(Key, a)] -> Map Key a -> Map Key a
    66 
    +insertManyI xs m0 = foldr (\(k, x) m -> insertG k x m) m0 xs
    67 
    +
    68 
    +insertTwoI :: Key -> Key -> a -> Map Key a
    69 
    +insertTwoI k1 k2 x = insertG k1 x (insertG k2 x Tip)
    70 
    +
    71 
    +-- weight unboxes the strict fields of Sizes -> worker/wrapper $wweight.
    72 
    +weight :: Sizes -> Int
    73 
    +weight (Sizes a b) = a * a + 3 * b * b + a * b + 1
    74 
    +
    75 
    +balance :: k -> a -> Map k a -> Map k a -> Map k a
    76 
    +balance k x l r = Bin (weight (Sizes sl sr)) k x l r
    77 
    +  where
    78 
    +    sl = size l
    79 
    +    sr = size r
    80 
    +
    81 
    +-- baseRatios is a closed constant under a lambda -> floated to a top-level lvl.
    82 
    +ratios :: Int -> [Int]
    83 
    +ratios n = map (n +) baseRatios
    84 
    +  where baseRatios = [2, 3, 5, 7, 11, 13]
    85 
    +
    86 
    +fromAscI :: [(Key, a)] -> Map Key a
    87 
    +fromAscI = foldr (\(k, x) m -> insertG k x m) Tip

  • testsuite/tests/simplCore/should_compile/T27296.stdout
    1 
    +$fEqKey
    2 
    +$fOrdKey
    3 
    +$fOrdKey_$ccompare
    4 
    +size
    5 
    +findI_$slookupG
    6 
    +lookupG
    7 
    +member
    8 
    +findI
    9 
    +$wrotate
    10 
    +rotate
    11 
    +insertG
    12 
    +insertManyI
    13 
    +insertTwoI
    14 
    +weight
    15 
    +balance
    16 
    +ratios
    17 
    +fromAscI

  • testsuite/tests/simplCore/should_compile/T27296b.hs
    1 
    +-- See Note [Stable Core dump order] in GHC.Core.Ppr.
    2 
    +--
    3 
    +-- Companion to T27296 that pins the ordering of *anonymous* top-level floats.
    4 
    +-- Under -O the boxed Int constants in sel's branches are floated to top level
    5 
    +-- as separate CAFs, all of which the compiler names "lvl" with noSrcSpan (see
    6 
    +-- newLvlVar). Before -dstable-core-dump-order their dump order was the
    7 
    +-- unique-driven processing order; the flag's content-based tie-break (rhsKey)
    8 
    +-- now orders them by literal value -- here 1000..6000, despite the scrambled
    9 
    +-- source order. This dump is intentionally *untidied* (-ddump-float-out), the
    10 
    +-- only place the "lvl" collision is observable; tidied dumps like -ddump-simpl
    11 
    +-- already give the floats distinct names (lvl, lvl1, ...).
    12 
    +module T27296b (sel) where
    13 
    +
    14 
    +{-# NOINLINE sel #-}
    15 
    +sel :: Int -> Int
    16 
    +sel 0 = 5000
    17 
    +sel 1 = 1000
    18 
    +sel 2 = 4000
    19 
    +sel 3 = 2000
    20 
    +sel 4 = 3000
    21 
    +sel _ = 6000

  • testsuite/tests/simplCore/should_compile/T27296b.stdout
    1 
    +
    2 
    +==================== Float out ====================
    3 
    +
    4 
    +sel :: Int -> Int
    5 
    +sel
    6 
    +  = \ (ds :: Int) ->
    7 
    +      case ds of { I# ds ->
    8 
    +      case ds of {
    9 
    +        __DEFAULT -> lvl;
    10 
    +        0# -> lvl;
    11 
    +        1# -> lvl;
    12 
    +        2# -> lvl;
    13 
    +        3# -> lvl;
    14 
    +        4# -> lvl
    15 
    +      }
    16 
    +      }
    17 
    +
    18 
    +lvl :: Int
    19 
    +lvl = I# 1000#
    20 
    +
    21 
    +lvl :: Int
    22 
    +lvl = I# 2000#
    23 
    +
    24 
    +lvl :: Int
    25 
    +lvl = I# 3000#
    26 
    +
    27 
    +lvl :: Int
    28 
    +lvl = I# 4000#
    29 
    +
    30 
    +lvl :: Int
    31 
    +lvl = I# 5000#
    32 
    +
    33 
    +lvl :: Int
    34 
    +lvl = I# 6000#
    35 
    +
    36 
    +==================== Float out ====================
    37 
    +
    38 
    +$wsel :: Int# -> Int#
    39 
    +$wsel
    40 
    +  = \ (ww :: Int#) ->
    41 
    +      case ww of {
    42 
    +        __DEFAULT -> 6000#;
    43 
    +        0# -> 5000#;
    44 
    +        1# -> 1000#;
    45 
    +        2# -> 4000#;
    46 
    +        3# -> 2000#;
    47 
    +        4# -> 3000#
    48 
    +      }
    49 
    +
    50 
    +sel :: Int -> Int
    51 
    +sel
    52 
    +  = \ (ds :: Int) ->
    53 
    +      case ds of { I# ww -> case $wsel ww of ww { __DEFAULT -> I# ww } }
    54 
    +

  • testsuite/tests/simplCore/should_compile/all.T
    ... ... @@ -602,3 +602,5 @@ test('T25718b', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress
    602 602 
     test('T25718c', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all -dno-typeable-binds'])
    603 603 
     test('T19166', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all -dno-typeable-binds'])
    604 604 
     test('T27261', [extra_files(['T27261_aux.hs'])], multimod_compile, ['T27261', '-v0 -O'])
    605 
    +test('T27296', [], makefile_test, ['T27296'])
    606 
    +test('T27296b', [], makefile_test, ['T27296b'])

  • utils/check-exact/Main.hs
    ... ... @@ -646,7 +646,7 @@ addLocaLDecl3 :: Changer
    646 646 
     addLocaLDecl3 libdir top = do
    647 647 
       Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
    648 648 
       let
    649 
    -      doAddLocal = replaceDecls (anchorEof lp) [parent',d2']
    649 
    +      doAddLocal = replaceDecls (addModuleCommentOrigDeltas lp) [parent',d2']
    650 650 
             where
    651 651 
              lp = top
    652 652 
              (de1:d2:_) = hsDecls lp
    ... ... @@ -667,7 +667,7 @@ addLocaLDecl4 libdir lp = do
    667 667 
       Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")
    668 668 
       Right newSig  <- withDynFlags libdir (\df -> parseDecl df "sig"  "nn :: Int")
    669 669 
       let
    670 
    -      doAddLocal = replaceDecls (anchorEof lp) (parent':ds)
    670 
    +      doAddLocal = replaceDecls (addModuleCommentOrigDeltas lp) (parent':ds)
    671 671 
             where
    672 672 
               (parent:ds) = hsDecls (makeDeltaAst lp)
    673 673
    ... ... @@ -781,7 +781,7 @@ rmDecl3 _libdir lp = do
    781 781 
     rmDecl4 :: Changer
    782 782 
     rmDecl4 _libdir lp = do
    783 783 
       let
    784 
    -      doRmDecl = replaceDecls (anchorEof lp) [de1',sd1]
    784 
    +      doRmDecl = replaceDecls (addModuleCommentOrigDeltas lp) [de1',sd1]
    785 785 
             where
    786 786 
              [de1] = hsDecls lp
    787 787 
              (de1',Just sd1) = modifyValD (getLocA de1) de1 $ \_m [sd1a,sd2] ->

  • utils/check-exact/Transform.hs
    ... ... @@ -65,7 +65,7 @@ module Transform
    65 65 
             , balanceComments
    66 66 
             , balanceCommentsList
    67 67 
             , balanceCommentsListA
    68 
    -        , anchorEof
    68 
    +        , addModuleCommentOrigDeltas
    69 69
    70 70 
             -- ** Managing lists, pure functions
    71 71 
             , captureOrderBinds
    ... ... @@ -724,8 +724,8 @@ balanceSameLineComments (L la (Match anm mctxt pats (GRHSs x grhss lb)))
    724 724
    725 725 
     -- ---------------------------------------------------------------------
    726 726
    727 
    -anchorEof :: ParsedSource -> ParsedSource
    728 
    -anchorEof (L l m@(HsModule (XModulePs an _lo _ _) _mn _exps _imps _decls)) = L l (m { hsmodExt = (hsmodExt m){ hsmodAnn = an' } })
    727 
    +addModuleCommentOrigDeltas :: ParsedSource -> ParsedSource
    728 
    +addModuleCommentOrigDeltas (L l m@(HsModule (XModulePs an _lo _ _) _mn _exps _imps _decls)) = L l (m { hsmodExt = (hsmodExt m){ hsmodAnn = an' } })
    729 729 
       where
    730 730 
         an' = addCommentOrigDeltasAnn an
    731 731

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help