Simon Peyton Jones pushed to branch wip/T26724 at Glasgow Haskell Compiler / GHC

Commits:

21 changed files:

Changes:

  • compiler/GHC/Core/Opt/SetLevels.hs
    ... ... @@ -91,6 +91,7 @@ import GHC.Core.Utils
    91 91 
     import GHC.Core.Opt.Arity   ( exprBotStrictness_maybe, isOneShotBndr )
    92 92 
     import GHC.Core.FVs     -- all of it
    93 93 
     import GHC.Core.Subst
    94 
    +import GHC.Core.TyCo.Subst( lookupTyVar )
    94 95 
     import GHC.Core.Make    ( sortQuantVars )
    95 96 
     import GHC.Core.Type    ( Type, tyCoVarsOfType
    96 97 
                             , mightBeUnliftedType, closeOverKindsDSet
    ... ... @@ -466,8 +467,8 @@ lvlCase env scrut_fvs scrut' case_bndr ty alts
    466 467 
         ty' = substTyUnchecked (le_subst env) ty
    467 468
    468 469 
         incd_lvl = incMinorLvl (le_ctxt_lvl env)
    469 
    -    dest_lvl = maxFvLevel (const True) env scrut_fvs
    470 
    -            -- Don't abstract over type variables, hence const True
    470 
    +    dest_lvl = maxFvLevel includeTyVars env scrut_fvs
    471 
    +            -- Don't abstract over type variables, hence includeTyVars
    471 472
    472 473 
         lvl_alt alts_env (AnnAlt con bs rhs)
    473 474 
           = do { rhs' <- lvlMFE new_env True rhs
    ... ... @@ -719,8 +720,11 @@ hasFreeJoin :: LevelEnv -> DVarSet -> Bool
    719 720 
     -- (In the latter case it won't be a join point any more.)
    720 721 
     -- Not treating top-level ones specially had a massive effect
    721 722 
     -- on nofib/minimax/Prog.prog
    722 
    -hasFreeJoin env fvs
    723 
    -  = not (maxFvLevel isJoinId env fvs == tOP_LEVEL)
    723 
    +hasFreeJoin env fvs = anyDVarSet bad_join fvs
    724 
    +  where
    725 
    +    bad_join v = isJoinId v &&
    726 
    +                 maxIn True env v tOP_LEVEL /= tOP_LEVEL
    727 
    +
    724 728
    725 729 
     {- Note [Saving work]
    726 730 
     ~~~~~~~~~~~~~~~~~~~~~
    ... ... @@ -1607,10 +1611,10 @@ destLevel env fvs fvs_ty is_function is_bot
    1607 1611
    1608 1612 
       | otherwise = max_fv_id_level
    1609 1613 
       where
    1610 
    -    max_fv_id_level = maxFvLevel isId env fvs -- Max over Ids only; the
    1611 
    -                                              -- tyvars will be abstracted
    1614 
    +    max_fv_id_level = maxFvLevel idsOnly env fvs -- Max over Ids only; the
    1615 
    +                                                 -- tyvars will be abstracted
    1612 1616
    1613 
    -    as_far_as_poss = maxFvLevel' isId env fvs_ty
    1617 
    +    as_far_as_poss = maxFvLevel' idsOnly env fvs_ty
    1614 1618 
                          -- See Note [Floating and kind casts]
    1615 1619
    1616 1620 
     {- Note [Floating and kind casts]
    ... ... @@ -1768,28 +1772,47 @@ extendCaseBndrEnv le@(LE { le_subst = subst, le_env = id_env })
    1768 1772 
            , le_env     = add_id id_env (case_bndr, scrut_var) }
    1769 1773 
     extendCaseBndrEnv env _ _ = env
    1770 1774
    1771 
    -maxFvLevel :: (Var -> Bool) -> LevelEnv -> DVarSet -> Level
    1772 
    -maxFvLevel max_me env var_set
    1773 
    -  = nonDetStrictFoldDVarSet (maxIn max_me env) tOP_LEVEL var_set
    1775 
    +includeTyVars, idsOnly :: Bool
    1776 
    +idsOnly       = False
    1777 
    +includeTyVars = True
    1778 
    +
    1779 
    +maxFvLevel :: Bool -> LevelEnv -> DVarSet -> Level
    1780 
    +maxFvLevel include_tyvars env var_set
    1781 
    +  = nonDetStrictFoldDVarSet (maxIn include_tyvars env) tOP_LEVEL var_set
    1774 1782 
         -- It's OK to use a non-deterministic fold here because maxIn commutes.
    1775 1783
    1776 
    -maxFvLevel' :: (Var -> Bool) -> LevelEnv -> TyCoVarSet -> Level
    1784 
    +maxFvLevel' :: Bool -> LevelEnv -> TyCoVarSet -> Level
    1777 1785 
     -- Same but for TyCoVarSet
    1778 
    -maxFvLevel' max_me env var_set
    1779 
    -  = nonDetStrictFoldUniqSet (maxIn max_me env) tOP_LEVEL var_set
    1786 
    +maxFvLevel' include_tyvars env var_set
    1787 
    +  = nonDetStrictFoldUniqSet (maxIn include_tyvars env) tOP_LEVEL var_set
    1780 1788 
         -- It's OK to use a non-deterministic fold here because maxIn commutes.
    1781 1789
    1782 
    -maxIn :: (Var -> Bool) -> LevelEnv -> InVar -> Level -> Level
    1783 
    -maxIn max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) in_var lvl
    1790 
    +maxIn :: Bool -> LevelEnv -> InVar -> Level -> Level
    1791 
    +-- True <=> include tyvars
    1792 
    +maxIn include_tyvars env@(LE { le_subst = subst, le_env = id_env }) in_var lvl
    1793 
    +  | isId in_var
    1784 1794 
       = case lookupVarEnv id_env in_var of
    1795 
    +      Nothing            -> maxOut env in_var lvl
    1785 1796 
           Just (abs_vars, _) -> foldr max_out lvl abs_vars
    1786 
    -      Nothing            -> max_out in_var lvl
    1787 
    -  where
    1788 
    -    max_out out_var lvl
    1789 
    -        | max_me out_var = case lookupVarEnv lvl_env out_var of
    1790 
    -                                Just lvl' -> maxLvl lvl' lvl
    1791 
    -                                Nothing   -> lvl
    1792 
    -        | otherwise = lvl       -- Ignore some vars depending on max_me
    1797 
    +          where
    1798 
    +            max_out out_var lvl
    1799 
    +              | isTyVar out_var && not include_tyvars
    1800 
    +                          = lvl
    1801 
    +              | otherwise = maxOut env out_var lvl
    1802 
    +
    1803 
    +  | include_tyvars -- TyVars
    1804 
    +  = case lookupTyVar subst in_var of
    1805 
    +      Just ty -> nonDetStrictFoldVarSet (maxOut env) lvl (tyCoVarsOfType ty)
    1806 
    +      Nothing -> maxOut env in_var lvl
    1807 
    +
    1808 
    +  | otherwise      -- Ignore free tyvars
    1809 
    +  = lvl
    1810 
    +
    1811 
    +maxOut :: LevelEnv -> OutVar -> Level -> Level
    1812 
    +maxOut (LE { le_lvl_env = lvl_env }) out_var lvl
    1813 
    +  = case lookupVarEnv lvl_env out_var of
    1814 
    +       Just lvl' -> maxLvl lvl' lvl
    1815 
    +       Nothing   -> lvl
    1793 1816
    1794 1817 
     lookupVar :: LevelEnv -> Id -> LevelledExpr
    1795 1818 
     lookupVar le v = case lookupVarEnv (le_env le) v of

  • compiler/GHC/Core/Subst.hs
    ... ... @@ -380,8 +380,10 @@ substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id
    380 380
    381 381 
         old_ty = idType old_id
    382 382 
         old_w = idMult old_id
    383 
    -    no_type_change = (isEmptyVarEnv tvs && isEmptyVarEnv cvs) ||
    383 
    +    no_type_change = isEmptyTCvSubst subst ||
    384 384 
                          (noFreeVarsOfType old_ty && noFreeVarsOfType old_w)
    385 
    +                     -- isEmptyTCvSubst: see Note [Keeping the substitution empty]
    386 
    +                     --                  in GHC.Core.TyCo.Subst
    385 387
    386 388 
             -- new_id has the right IdInfo
    387 389 
             -- The lazy-set is because we're in a loop here, with

  • compiler/GHC/Core/TyCo/Subst.hs
    ... ... @@ -960,7 +960,8 @@ substTyVarBndrUsing subst_fn subst@(Subst in_scope idenv tenv cenv) old_var
    960 960 
         -- Assertion check that we are not capturing something in the substitution
    961 961
    962 962 
         old_ki = tyVarKind old_var
    963 
    -    no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed
    963 
    +    no_kind_change = isEmptyTCvSubst subst || noFreeVarsOfType old_ki
    964 
    +                     -- isEmptyTCvSubst: see Note [Keeping the substitution empty]
    964 965 
         no_change = no_kind_change && (new_var == old_var)
    965 966 
             -- no_change means that the new_var is identical in
    966 967 
             -- all respects to the old_var (same unique, same kind)
    ... ... @@ -988,7 +989,8 @@ substCoVarBndrUsing subst_fn subst@(Subst in_scope idenv tenv cenv) old_var
    988 989 
         (Subst (in_scope `extendInScopeSet` new_var) idenv tenv new_cenv, new_var)
    989 990 
       where
    990 991 
         new_co         = mkCoVarCo new_var
    991 
    -    no_kind_change = noFreeVarsOfTypes [t1, t2]
    992 
    +    no_kind_change = isEmptyTCvSubst subst || noFreeVarsOfTypes [t1, t2]
    993 
    +                     -- isEmptyTCvSubst: see Note [Keeping the substitution empty]
    992 994 
         no_change      = new_var == old_var && no_kind_change
    993 995
    994 996 
         new_cenv | no_change = delVarEnv cenv old_var
    ... ... @@ -1034,3 +1036,22 @@ substTyCoBndr subst (Anon ty af) = (subst, Anon (substScaledTy subst ty
    1034 1036 
     substTyCoBndr subst (Named (Bndr tv vis)) = (subst', Named (Bndr tv' vis))
    1035 1037 
                                               where
    1036 1038 
                                                 (subst', tv') = substVarBndr subst tv
    1039 
    +
    1040 
    +{- Note [Keeping the substitution empty]
    1041 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    1042 
    +A very common situation is where we run over a term doing no cloning,
    1043 
    +no substitution, nothing.  In that case the TCvSubst will be empty, and
    1044 
    +it is /very/ valuable to /keep/ it empty:
    1045 
    +
    1046 
    +* It's wasted effort to build up an identity substitution mapping
    1047 
    +  [x:->x, y:->y].
    1048 
    +
    1049 
    +* When we come to a binder, if the incoming substitution is empty,
    1050 
    +  we can avoid substituting its type; and that in turn may mean that
    1051 
    +  the binder itself does not change and we don't need to extend the
    1052 
    +  substitution.
    1053 
    +
    1054 
    +* In the Simplifier we substitute over both types and coercions.
    1055 
    +  If the substitution is empty, this is a no-op -- but only if it
    1056 
    +  is empty!
    1057 
    +-}

  • compiler/GHC/Iface/Recomp.hs
    ... ... @@ -1797,7 +1797,9 @@ declExtras fix_fn ann_fn rule_env inst_env fi_env dm_env complete_env decl
    1797 1797 
           IfaceSynonym{} -> IfaceSynonymExtras (fix_fn n)
    1798 1798 
                                                (ann_fn (AnnOccName n))
    1799 1799 
           IfaceFamily{} -> IfaceFamilyExtras (fix_fn n)
    1800 
    -                        (map ifFamInstAxiom (lookupOccEnvL fi_env n))
    1800 
    +                        (map ifFamInstAxiom (lookupOccEnvL fi_env n)
    1801 
    +                        ++ map ifDFun (lookupOccEnvL inst_env n)
    1802 
    +                        )
    1801 1803 
                             (ann_fn (AnnOccName n))
    1802 1804 
           IfacePatSyn{} -> IfacePatSynExtras (fix_fn n) (lookup_complete_match n)
    1803 1805 
           _other -> IfaceOtherDeclExtras

  • hadrian/doc/flavours.md
    ... ... @@ -297,7 +297,11 @@ The supported transformers are listed below:
    297 297 
         </tr>
    298 298 
         <tr>
    299 299 
             <td><code>assertions</code></td>
    300 
    -        <td>Build the stage2 compiler with assertions enabled. </td>
    300 
    +        <td>Build the stage2 compiler with <code>-DDEBUG</code> assertions enabled. </td>
    301 
    +    </tr>
    302 
    +    <tr>
    303 
    +        <td><code>assertions_stage1</code></td>
    304 
    +        <td>Build the stage1 compiler with <code>-DDEBUG</code> assertions enabled. </td>
    301 305 
         </tr>
    302 306 
         <tr>
    303 307 
             <td><code>fully_static</code></td>

  • hadrian/src/Base.hs
    ... ... @@ -149,14 +149,10 @@ ghcLibDeps stage iplace = do
    149 149 
         ps <- mapM (\f -> stageLibPath stage <&> (-/- f))
    150 150 
             [ "llvm-targets"
    151 151 
             , "llvm-passes"
    152 
    -        , "ghc-interp.js"
    153 152 
             , "settings"
    154 153 
             , "targets" -/- "default.target"
    155 154 
             , "ghc-usage.txt"
    156 155 
             , "ghci-usage.txt"
    157 
    -        , "dyld.mjs"
    158 
    -        , "post-link.mjs"
    159 
    -        , "prelude.mjs"
    160 156 
             ]
    161 157 
         cxxStdLib <- systemCxxStdLibConfPath (PackageDbLoc stage iplace)
    162 158 
         return (cxxStdLib : ps)

  • hadrian/src/Builder.hs
    ... ... @@ -170,8 +170,6 @@ data Builder = Alex
    170 170 
                  | GhcPkg GhcPkgMode Stage
    171 171 
                  | Haddock HaddockMode
    172 172 
                  | Happy
    173 
    -             | Hp2Ps
    174 
    -             | Hpc
    175 173 
                  | HsCpp
    176 174 
                  | JsCpp
    177 175 
                  | Hsc2Hs Stage
    ... ... @@ -211,10 +209,6 @@ builderProvenance = \case
    211 209 
         Haddock _        -> context Stage1 haddock
    212 210 
         Hsc2Hs _         -> context stage0Boot hsc2hs
    213 211 
         Unlit            -> context stage0Boot unlit
    214 
    -
    215 
    -    -- Never used
    216 
    -    Hpc              -> context Stage1 hpcBin
    217 
    -    Hp2Ps            -> context stage0Boot hp2ps
    218 212 
         _                -> Nothing
    219 213 
       where
    220 214 
         context s p = Just $ vanillaContext s p

  • hadrian/src/Flavour.hs
    ... ... @@ -70,7 +70,8 @@ flavourTransformers = M.fromList
    70 70 
         , "fully_static"     =: fullyStatic
    71 71 
         , "host_fully_static" =: hostFullyStatic
    72 72 
         , "collect_timings"  =: collectTimings
    73 
    -    , "assertions"       =: enableAssertions
    73 
    +    , "assertions"        =: enableAssertions Stage2
    74 
    +    , "assertions_stage1" =: enableAssertions Stage1
    74 75 
         , "debug_ghc"        =: debugGhc Stage2
    75 76 
         , "debug_stage1_ghc" =: debugGhc Stage1
    76 77 
         , "lint"             =: enableLinting
    ... ... @@ -169,10 +170,10 @@ werror =
    169 170 
     -- | Build C and Haskell objects with debugging information.
    170 171 
     enableDebugInfo :: Flavour -> Flavour
    171 172 
     enableDebugInfo = addArgs $ notStage0 ? mconcat
    172 
    -    [ builder (Ghc CompileHs) ? pure ["-g3"]
    173 
    -    , builder (Ghc CompileCWithGhc) ? pure ["-optc-g3"]
    174 
    -    , builder (Ghc CompileCppWithGhc) ? pure ["-optcxx-g3"]
    175 
    -    , builder (Cc CompileC) ? arg "-g3"
    173 
    +    [ builder (Ghc CompileHs) ? pure ["-g3", "-optc-fno-omit-frame-pointer"]
    174 
    +    , builder (Ghc CompileCWithGhc) ? pure ["-optc-g3", "-optc-fno-omit-frame-pointer"]
    175 
    +    , builder (Ghc CompileCppWithGhc) ? pure ["-optcxx-g3", "-optcxx-fno-omit-frame-pointer"]
    176 
    +    , builder (Cc CompileC) ? pure ["-g3", "-fno-omit-frame-pointer"]
    176 177 
         , builder (Cabal Setup) ? arg "--disable-library-stripping"
    177 178 
         , builder (Cabal Setup) ? arg "--disable-executable-stripping"
    178 179 
         ]
    ... ... @@ -393,12 +394,12 @@ enableLateCCS = addArgs
    393 394 
       ? ((Profiling `wayUnit`) <$> getWay)
    394 395 
       ? arg "-fprof-late"
    395 396
    396 
    --- | Enable assertions for the stage2 compiler
    397 
    -enableAssertions :: Flavour -> Flavour
    398 
    -enableAssertions flav = flav { ghcDebugAssertions = f }
    397 
    +-- | Enable -DDEBUG assertions in the compiler, at a specified stage
    398 
    +enableAssertions :: Stage -> Flavour -> Flavour
    399 
    +enableAssertions stage flav = flav { ghcDebugAssertions = f }
    399 400 
       where
    400 
    -    f Stage2 = True
    401 
    -    f st = ghcDebugAssertions flav st
    401 
    +    f s | s == stage = True
    402 
    +        | otherwise  = ghcDebugAssertions flav s
    402 403
    403 404 
     -- | Build the stage3 compiler using the non-moving GC.
    404 405 
     enableBootNonmovingGc :: Flavour -> Flavour

  • hadrian/src/Hadrian/Haskell/Hash.hs
    ... ... @@ -84,7 +84,6 @@ data PackageHashConfigInputs = PackageHashConfigInputs {
    84 84 
            pkgHashDynExe              :: Bool,
    85 85 
            pkgHashProfLib             :: Bool,
    86 86 
            pkgHashProfExe             :: Bool,
    87 
    -       pkgHashSplitObjs           :: Bool,
    88 87 
            pkgHashSplitSections       :: Bool,
    89 88 
            pkgHashStripLibs           :: Bool,
    90 89 
            pkgHashStripExes           :: Bool,
    ... ... @@ -140,7 +139,6 @@ pkgHashOracle = void $ addOracleCache $ \(PkgHashKey (stag, pkg)) -> do
    140 139 
           pkgHashDynExe = dyn_ghc
    141 140 
           pkgHashProfLib = profiling `Set.member` libWays
    142 141 
           pkgHashProfExe = pkg == ghc && ghcProfiled flav stag
    143 
    -      pkgHashSplitObjs = False -- Deprecated
    144 142 
           pkgHashSplitSections = ghcSplitSections flav
    145 143 
           pkgHashStripExes = False
    146 144 
           pkgHashStripLibs = False
    ... ... @@ -239,7 +237,6 @@ renderPackageHashInputs PackageHashInputs{
    239 237 
           , opt   "dynamic-exe" False show pkgHashDynExe
    240 238 
           , opt   "prof-lib"    False show pkgHashProfLib
    241 239 
           , opt   "prof-exe"    False show pkgHashProfExe
    242 
    -      , opt   "split-objs"   False show pkgHashSplitObjs
    243 240 
           , opt   "split-sections" False show pkgHashSplitSections
    244 241 
           , opt   "stripped-lib" False show pkgHashStripLibs
    245 242 
           , opt   "stripped-exe" True  show pkgHashStripExes

  • hadrian/src/Oracles/Setting.hs
    ... ... @@ -9,7 +9,7 @@ module Oracles.Setting (
    9 9
    10 10 
         -- ** Target platform things
    11 11 
         anyTargetOs, anyTargetArch, anyHostOs,
    12 
    -    isElfTarget, isOsxTarget, isWinTarget, isJsTarget, isArmTarget,
    12 
    +    isElfTarget, isOsxTarget, isWinTarget, isJsTarget, isWasmTarget, isArmTarget,
    13 13 
         isWinHost,
    14 14 
         targetArmVersion
    15 15 
         ) where
    ... ... @@ -128,6 +128,9 @@ isWinTarget = anyTargetOs [OSMinGW32]
    128 128 
     isJsTarget :: Action Bool
    129 129 
     isJsTarget = anyTargetArch [ArchJavaScript]
    130 130
    131 
    +isWasmTarget :: Action Bool
    132 
    +isWasmTarget = anyTargetArch [ArchWasm32]
    133 
    +
    131 134 
     isOsxTarget :: Action Bool
    132 135 
     isOsxTarget = anyTargetOs [OSDarwin]
    133 136

  • hadrian/src/Rules/Register.hs
    ... ... @@ -118,7 +118,18 @@ registerPackageRules rs stage iplace = do
    118 118 
             pkgName <- getPackageNameFromConfFile conf
    119 119 
             let pkg = unsafeFindPackageByName pkgName
    120 120
    121 
    -        when (pkg == compiler) $ need =<< ghcLibDeps stage iplace
    121 
    +        when (pkg == compiler) $ do
    122 
    +            baseDeps <- ghcLibDeps stage iplace
    123 
    +            jsTarget <- isJsTarget
    124 
    +            wasmTarget <- isWasmTarget
    125 
    +            libPath <- stageLibPath stage
    126 
    +            let jsDeps
    127 
    +                  | jsTarget  = ["ghc-interp.js"]
    128 
    +                  | otherwise = []
    129 
    +                wasmDeps
    130 
    +                  | wasmTarget = ["dyld.mjs", "post-link.mjs", "prelude.mjs"]
    131 
    +                  | otherwise  = []
    132 
    +            need (baseDeps ++ map (libPath -/-) (jsDeps ++ wasmDeps))
    122 133
    123 134 
             -- Only used in guard when Stage0 {} but can be GlobalLibs or InTreeLibs
    124 135 
             isBoot <- (pkg `notElem`) <$> stagePackages stage

  • hadrian/src/Settings/Flavours/Validate.hs
    1 1 
     module Settings.Flavours.Validate (validateFlavour, slowValidateFlavour,
    2 2 
                                         quickValidateFlavour) where
    3 3
    4 
    -import qualified Data.Set as Set
    5 4
    6 5 
     import Expression
    7 6 
     import Flavour
    8 
    -import Oracles.Flag
    9 7 
     import {-# SOURCE #-} Settings.Default
    10 8
    11 9 
     -- Please update doc/flavours.md when changing this file.
    12 10 
     validateFlavour :: Flavour
    13 
    -validateFlavour = enableLinting $ werror $ defaultFlavour
    11 
    +validateFlavour = enableLinting $ quickValidateFlavour
    14 12 
         { name = "validate"
    15 13 
         , extraArgs = validateArgs <> defaultHaddockExtraArgs
    16 
    -    , libraryWays = Set.fromList <$>
    17 
    -                    mconcat [ pure [vanilla]
    18 
    -                            , notStage0 ? platformSupportsSharedLibs ? pure [dynamic]
    19 
    -                            ]
    20 
    -    , rtsWays = Set.fromList <$>
    21 
    -                mconcat [ pure [vanilla, debug]
    22 
    -                        , targetSupportsThreadedRts ? pure [threaded, threadedDebug]
    23 
    -                        , notStage0 ? platformSupportsSharedLibs ? pure
    24 
    -                            [ dynamic, debugDynamic
    25 
    -                            ]
    26 
    -                        , notStage0 ? platformSupportsSharedLibs ? targetSupportsThreadedRts ? pure
    27 
    -                            [ threadedDynamic, threadedDebugDynamic ]
    28 
    -                        ]
    29 14 
         , ghcDebugAssertions = (<= Stage1)
    30 15 
         }
    31 16
    ... ... @@ -59,6 +44,6 @@ quickValidateArgs = sourceArgs SourceArgs
    59 44 
         }
    60 45
    61 46 
     quickValidateFlavour :: Flavour
    62 
    -quickValidateFlavour = werror $ validateFlavour
    47 
    +quickValidateFlavour = werror $ disableProfiledLibs $ defaultFlavour
    63 48 
         { name               = "quick-validate"
    64 49 
         , extraArgs               = quickValidateArgs }

  • testsuite/tests/driver/recomp26705/M.hs
    1 
    +module M where
    2 
    +import M2
    3 
    +
    4 
    +x :: TD () -> String
    5 
    +x = show

  • testsuite/tests/driver/recomp26705/M2A.hs
    1 
    +{-# LANGUAGE TypeFamilies #-}
    2 
    +module M2 where
    3 
    +
    4 
    +data family TD a
    5 
    +
    6 
    +data instance TD () = TDI
    7 
    +  deriving Show

  • testsuite/tests/driver/recomp26705/M2B.hs
    1 
    +{-# LANGUAGE TypeFamilies #-}
    2 
    +module M2 where
    3 
    +
    4 
    +data family TD a
    5 
    +
    6 
    +data instance TD () = TDI

  • testsuite/tests/driver/recomp26705/Makefile
    1 
    +TOP=../../..
    2 
    +include $(TOP)/mk/boilerplate.mk
    3 
    +include $(TOP)/mk/test.mk
    4 
    +
    5 
    +# Recompilation tests
    6 
    +
    7 
    +recomp26705:
    8 
    +	cp M2A.hs M2.hs
    9 
    +	'$(TEST_HC)' $(TEST_HC_OPTS) --make M.hs
    10 
    +	sleep 1
    11 
    +	cp M2B.hs M2.hs
    12 
    +	# This should fail
    13 
    +	if '$(TEST_HC)' $(TEST_HC_OPTS) --make M.hs; then false; fi

  • testsuite/tests/driver/recomp26705/all.T
    1 
    +test('recomp26705', [extra_files(['M2A.hs', 'M.hs', 'M2B.hs']),
    2 
    +                   when(fast(), skip), ignore_stdout],
    3 
    +     makefile_test, [])

  • testsuite/tests/driver/recomp26705/recomp26705.stderr
    1 
    +M.hs:5:5: error: [GHC-39999]
    2 
    +    • No instance for ‘Show (TD ())’ arising from a use of ‘show’
    3 
    +    • In the expression: show
    4 
    +      In an equation for ‘x’: x = show
    5 
    +

  • testsuite/tests/simplCore/should_compile/T26681.hs
    1 
    +{-# LANGUAGE BangPatterns #-}
    2 
    +{-# LANGUAGE DataKinds #-}
    3 
    +{-# LANGUAGE GADTs #-}
    4 
    +{-# LANGUAGE PolyKinds #-}
    5 
    +{-# LANGUAGE ScopedTypeVariables #-}
    6 
    +{-# LANGUAGE StandaloneKindSignatures #-}
    7 
    +{-# LANGUAGE TypeApplications #-}
    8 
    +{-# LANGUAGE TypeFamilies #-}
    9 
    +{-# LANGUAGE TypeOperators #-}
    10 
    +
    11 
    +module T26681 where
    12 
    +
    13 
    +import Data.Kind (Type)
    14 
    +import Data.Type.Equality
    15 
    +import GHC.TypeLits
    16 
    +import qualified Unsafe.Coerce
    17 
    +
    18 
    +
    19 
    +{-# NOINLINE unsafeCoerceRefl #-}
    20 
    +unsafeCoerceRefl :: a :~: b
    21 
    +unsafeCoerceRefl = Unsafe.Coerce.unsafeCoerce Refl
    22 
    +
    23 
    +type family MapJust l where
    24 
    +  MapJust '[] = '[]
    25 
    +  MapJust (x : xs) = Just x : MapJust xs
    26 
    +
    27 
    +type family Tail l where
    28 
    +  Tail (_ : xs) = xs
    29 
    +
    30 
    +lemMapJustCons :: MapJust sh :~: Just n : sh' -> sh :~: n : Tail sh
    31 
    +lemMapJustCons Refl = unsafeCoerceRefl
    32 
    +
    33 
    +
    34 
    +type ListX :: [Maybe Nat] -> (Maybe Nat -> Type) -> Type
    35 
    +data ListX sh f where
    36 
    +  ConsX :: !(f n) -> ListX (n : sh) f
    37 
    +
    38 
    +
    39 
    +data JustN n where
    40 
    +  JustN :: JustN (Just n)
    41 
    +
    42 
    +data UnconsListSRes f sh1 = forall n sh. (n : sh ~ sh1) => UnconsListSRes
    43 
    +
    44 
    +listsUncons :: forall sh1 f. ListX (MapJust sh1) JustN -> UnconsListSRes f sh1
    45 
    +listsUncons (ConsX JustN)
    46 
    +  | Refl <- lemMapJustCons @sh1 Refl
    47 
    +  = UnconsListSRes

  • testsuite/tests/simplCore/should_compile/all.T
    ... ... @@ -563,3 +563,4 @@ test('T26115', [grep_errmsg(r'DFun')], compile, ['-O -ddump-simpl -dsuppress-uni
    563 563 
     test('T26116', normal, compile, ['-O -ddump-rules'])
    564 564 
     test('T26117', [grep_errmsg(r'==')], compile, ['-O -ddump-simpl -dsuppress-uniques'])
    565 565 
     test('T26349',  normal, compile, ['-O -ddump-rules'])
    566 
    +test('T26681',  normal, compile, ['-O'])

  • utils/deriveConstants/Main.hs
    ... ... @@ -397,7 +397,6 @@ wanteds os = concat
    397 397 
               ,fieldOffset Both "StgRegTable" "rHpAlloc"
    398 398 
               ,structField C    "StgRegTable" "rCurrentAlloc"
    399 399 
               ,structField C    "StgRegTable" "rRet"
    400 
    -          ,structField C    "StgRegTable" "rNursery"
    401 400
    402 401 
               ,defIntOffset Both "stgEagerBlackholeInfo"
    403 402 
                                  "FUN_OFFSET(stgEagerBlackholeInfo)"
    ... ... @@ -405,7 +404,6 @@ wanteds os = concat
    405 404 
               ,defIntOffset Both "stgGCFun"    "FUN_OFFSET(stgGCFun)"
    406 405
    407 406 
               ,fieldOffset Both "Capability" "r"
    408 
    -          ,fieldOffset C    "Capability" "lock"
    409 407 
               ,structField C    "Capability" "no"
    410 408 
               ,structField C    "Capability" "mut_lists"
    411 409 
               ,structField C    "Capability" "context_switch"
    ... ... @@ -424,18 +422,11 @@ wanteds os = concat
    424 422 
               ,structField C    "bdescr" "link"
    425 423 
               ,structField Both "bdescr" "flags"
    426 424
    427 
    -          ,structSize C  "generation"
    428 425 
               ,structField C "generation" "n_new_large_words"
    429 
    -          ,structField C "generation" "weak_ptr_list"
    430 426
    431 427 
               ,structSize Both   "CostCentreStack"
    432 
    -          ,structField C     "CostCentreStack" "ccsID"
    433 428 
               ,structFieldH Both "CostCentreStack" "mem_alloc"
    434 429 
               ,structFieldH Both "CostCentreStack" "scc_count"
    435 
    -          ,structField C     "CostCentreStack" "prevStack"
    436 
    -
    437 
    -          ,structField C "CostCentre" "ccID"
    438 
    -          ,structField C "CostCentre" "link"
    439 430
    440 431 
               ,structField C     "StgHeader" "info"
    441 432 
               ,structField_ Both "StgHeader_ccs" "StgHeader" "prof.ccs"
    ... ... @@ -472,18 +463,14 @@ wanteds os = concat
    472 463 
               ,closurePayload C    "StgArrBytes" "payload"
    473 464
    474 465 
               ,closureField  C    "StgTSO"      "_link"
    475 
    -          ,closureField  C    "StgTSO"      "global_link"
    476 466 
               ,closureField  C    "StgTSO"      "what_next"
    477 467 
               ,closureField  C    "StgTSO"      "why_blocked"
    478 468 
               ,closureField  C    "StgTSO"      "block_info"
    479 469 
               ,closureField  C    "StgTSO"      "blocked_exceptions"
    480 470 
               ,closureField  C    "StgTSO"      "id"
    481 471 
               ,closureField  C    "StgTSO"      "cap"
    482 
    -          ,closureField  C    "StgTSO"      "saved_errno"
    483 472 
               ,closureField  C    "StgTSO"      "trec"
    484 473 
               ,closureField  C    "StgTSO"      "flags"
    485 
    -          ,closureField  C    "StgTSO"      "dirty"
    486 
    -          ,closureField  C    "StgTSO"      "bq"
    487 474 
               ,closureField  C    "StgTSO"      "label"
    488 475 
               ,closureField  C    "StgTSO"      "bound"
    489 476 
               ,closureField  Both "StgTSO"      "alloc_limit"
    ... ... @@ -496,8 +483,6 @@ wanteds os = concat
    496 483 
               ,closureField       C    "StgStack" "dirty"
    497 484 
               ,closureField       C    "StgStack" "marking"
    498 485
    499 
    -          ,structSize C "StgTSOProfInfo"
    500 
    -
    501 486 
               ,closureField Both "StgUpdateFrame" "updatee"
    502 487 
               ,closureField Both "StgOrigThunkInfoFrame" "info_ptr"
    503 488
    ... ... @@ -519,19 +504,15 @@ wanteds os = concat
    519 504 
               ,closureFieldGcptr C "StgAP" "fun"
    520 505 
               ,closurePayload    C "StgAP" "payload"
    521 506
    522 
    -          ,thunkSize         C "StgAP_STACK"
    523 507 
               ,closureField      C "StgAP_STACK" "size"
    524 508 
               ,closureFieldGcptr C "StgAP_STACK" "fun"
    525 509 
               ,closurePayload    C "StgAP_STACK" "payload"
    526 510
    527 
    -          ,closureSize       C "StgContinuation"
    528 511 
               ,closureField      C "StgContinuation" "apply_mask_frame"
    529 512 
               ,closureField      C "StgContinuation" "mask_frame_offset"
    530 513 
               ,closureField      C "StgContinuation" "stack_size"
    531 514 
               ,closurePayload    C "StgContinuation" "stack"
    532 515
    533 
    -          ,thunkSize C "StgSelector"
    534 
    -
    535 516 
               ,closureFieldGcptr C "StgInd" "indirectee"
    536 517
    537 518 
               ,closureSize  C "StgMutVar"
    ... ... @@ -552,10 +533,6 @@ wanteds os = concat
    552 533 
               ,closureField C "StgCatchRetryFrame" "first_code"
    553 534 
               ,closureField C "StgCatchRetryFrame" "alt_code"
    554 535
    555 
    -          ,closureField C "StgTVarWatchQueue" "closure"
    556 
    -          ,closureField C "StgTVarWatchQueue" "next_queue_entry"
    557 
    -          ,closureField C "StgTVarWatchQueue" "prev_queue_entry"
    558 
    -
    559 536 
               ,closureSize  C "StgTVar"
    560 537 
               ,closureField C "StgTVar" "current_value"
    561 538 
               ,closureField C "StgTVar" "first_watch_queue_entry"
    ... ... @@ -595,29 +572,19 @@ wanteds os = concat
    595 572 
               ,closureSize  C "StgStableName"
    596 573 
               ,closureField C "StgStableName" "sn"
    597 574
    598 
    -          ,closureSize  C "StgBlockingQueue"
    599 
    -          ,closureField C "StgBlockingQueue" "bh"
    600 
    -          ,closureField C "StgBlockingQueue" "owner"
    601 
    -          ,closureField C "StgBlockingQueue" "queue"
    602 
    -          ,closureField C "StgBlockingQueue" "link"
    603 
    -
    604 575 
               ,closureSize  C "MessageBlackHole"
    605 576 
               ,closureField C "MessageBlackHole" "link"
    606 577 
               ,closureField C "MessageBlackHole" "tso"
    607 578 
               ,closureField C "MessageBlackHole" "bh"
    608 579
    609 
    -          ,closureSize  C "StgCompactNFData"
    610 580 
               ,closureField C "StgCompactNFData" "totalW"
    611 
    -          ,closureField C "StgCompactNFData" "autoBlockW"
    612 581 
               ,closureField C "StgCompactNFData" "nursery"
    613 
    -          ,closureField C "StgCompactNFData" "last"
    614 582 
               ,closureField C "StgCompactNFData" "hp"
    615 583 
               ,closureField C "StgCompactNFData" "hpLim"
    616 584 
               ,closureField C "StgCompactNFData" "hash"
    617 585 
               ,closureField C "StgCompactNFData" "result"
    618 586
    619 587 
               ,structSize   C "StgCompactNFDataBlock"
    620 
    -          ,structField  C "StgCompactNFDataBlock" "self"
    621 588 
               ,structField  C "StgCompactNFDataBlock" "owner"
    622 589 
               ,structField  C "StgCompactNFDataBlock" "next"
    623 590
    ... ... @@ -635,10 +602,7 @@ wanteds os = concat
    635 602 
                               "RTS_FLAGS" "DebugFlags.zero_on_gc"
    636 603 
               ,structField_ C "RtsFlags_GcFlags_initialStkSize"
    637 604 
                               "RTS_FLAGS" "GcFlags.initialStkSize"
    638 
    -          ,structField_ C "RtsFlags_MiscFlags_tickInterval"
    639 
    -                          "RTS_FLAGS" "MiscFlags.tickInterval"
    640 605
    641 
    -          ,structSize   C "StgFunInfoExtraFwd"
    642 606 
               ,structField  C "StgFunInfoExtraFwd" "slow_apply"
    643 607 
               ,structField  C "StgFunInfoExtraFwd" "fun_type"
    644 608 
               ,structFieldH Both "StgFunInfoExtraFwd" "arity"
    ... ... @@ -652,11 +616,9 @@ wanteds os = concat
    652 616 
               ,structField_ C    "StgFunInfoExtraRev_bitmap_offset" "StgFunInfoExtraRev" "b.bitmap_offset"
    653 617
    654 618 
               ,structField C "StgLargeBitmap" "size"
    655 
    -          ,fieldOffset C "StgLargeBitmap" "bitmap"
    656 619
    657 620 
               ,structSize  C "snEntry"
    658 621 
               ,structField C "snEntry" "sn_obj"
    659 
    -          ,structField C "snEntry" "addr"
    660 622
    661 623 
               ,structSize  C "spEntry"
    662 624 
               ,structField C "spEntry" "addr"
    ... ... @@ -672,51 +634,15 @@ wanteds os = concat
    672 634 
                else []
    673 635
    674 636 
                -- struct HsIface
    675 
    -          ,structField C "HsIface" "processRemoteCompletion_closure"
    676 
    -          ,structField C "HsIface" "runIO_closure"
    677 
    -          ,structField C "HsIface" "runNonIO_closure"
    678 637 
               ,structField C "HsIface" "Z0T_closure"
    679 638 
               ,structField C "HsIface" "True_closure"
    680 639 
               ,structField C "HsIface" "False_closure"
    681 
    -          ,structField C "HsIface" "unpackCString_closure"
    682 
    -          ,structField C "HsIface" "runFinalizzerBatch_closure"
    683 
    -          ,structField C "HsIface" "stackOverflow_closure"
    684 640 
               ,structField C "HsIface" "heapOverflow_closure"
    685 
    -          ,structField C "HsIface" "allocationLimitExceeded_closure"
    686 
    -          ,structField C "HsIface" "blockedIndefinitelyOnMVar_closure"
    687 
    -          ,structField C "HsIface" "blockedIndefinitelyOnSTM_closure"
    688 641 
               ,structField C "HsIface" "cannotCompactFunction_closure"
    689 642 
               ,structField C "HsIface" "cannotCompactPinned_closure"
    690 643 
               ,structField C "HsIface" "cannotCompactMutable_closure"
    691 
    -          ,structField C "HsIface" "nonTermination_closure"
    692 644 
               ,structField C "HsIface" "nestedAtomically_closure"
    693 645 
               ,structField C "HsIface" "noMatchingContinuationPrompt_closure"
    694 
    -          ,structField C "HsIface" "blockedOnBadFD_closure"
    695 
    -          ,structField C "HsIface" "runSparks_closure"
    696 
    -          ,structField C "HsIface" "ensureIOManagerIsRunning_closure"
    697 
    -          ,structField C "HsIface" "interruptIOManager_closure"
    698 
    -          ,structField C "HsIface" "ioManagerCapabilitiesChanged_closure"
    699 
    -          ,structField C "HsIface" "runHandlersPtr_closure"
    700 
    -          ,structField C "HsIface" "flushStdHandles_closure"
    701 
    -          ,structField C "HsIface" "runMainIO_closure"
    702 
    -          ,structField C "HsIface" "Czh_con_info"
    703 
    -          ,structField C "HsIface" "Izh_con_info"
    704 
    -          ,structField C "HsIface" "Fzh_con_info"
    705 
    -          ,structField C "HsIface" "Dzh_con_info"
    706 
    -          ,structField C "HsIface" "Wzh_con_info"
    707 
    -          ,structField C "HsIface" "runAllocationLimitHandler_closure"
    708 
    -          ,structField C "HsIface" "Ptr_con_info"
    709 
    -          ,structField C "HsIface" "FunPtr_con_info"
    710 
    -          ,structField C "HsIface" "I8zh_con_info"
    711 
    -          ,structField C "HsIface" "I16zh_con_info"
    712 
    -          ,structField C "HsIface" "I32zh_con_info"
    713 
    -          ,structField C "HsIface" "I64zh_con_info"
    714 
    -          ,structField C "HsIface" "W8zh_con_info"
    715 
    -          ,structField C "HsIface" "W16zh_con_info"
    716 
    -          ,structField C "HsIface" "W32zh_con_info"
    717 
    -          ,structField C "HsIface" "W64zh_con_info"
    718 
    -          ,structField C "HsIface" "StablePtr_con_info"
    719 
    -          ,structField C "HsIface" "StackSnapshot_closure"
    720 646 
               ,structField C "HsIface" "divZZeroException_closure"
    721 647 
               ,structField C "HsIface" "underflowException_closure"
    722 648 
               ,structField C "HsIface" "overflowException_closure"

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