Magnus pushed to branch wip/mangoiv/9.12.5-rc3-fixes at Glasgow Haskell Compiler / GHC

Commits:

22 changed files:

Changes:

  • changelog.d/T27123.md
    1 
    +section: compiler
    2 
    +synopsis: Fix two crashes that could happen in a multithreaded setting when profiling.
    3 
    +description: There were two bugs that could cause occasional segfaults or crashes with
    4 
    +an `PAP object entered` error when profiling. They only happened when two threads
    5 
    +where racing to evaluate the same thunk, and specific GC timings.
    6 
    +mrs: !16214
    7 
    +issues: #27123

  • changelog.d/fix-absent-dict-projection
    1 
    +section: compiler
    2 
    +synopsis: Fix a miscompilation that could project a field out of an absent dictionary, resulting in a segfault.
    3 
    +issues: #25924
    4 
    +mrs: !16219
    5 
    +description:
    6 
    +  We no longer make an absent filler (a rubbish literal or error thunk) for an
    7 
    +  absent dictionary or other terminating type. We also no longer speculatively
    8 
    +  evaluate a binding once we have discovered that it is absent.

  • changelog.d/semaphore-v2
    ... ... @@ -2,7 +2,7 @@ section: compiler
    2 2 
     issues: #25087
    3 3 
     mrs: !15729
    4 4 
     synopsis:
    5 
    -  Update to semaphore-compat 2.0.0 (``-jsem`` protocol v2)
    5 
    +  Update to semaphore-compat 2.0.1 (``-jsem`` protocol v2)
    6 6 
     description:
    7 7 
       On Linux and other POSIX platforms, GHC's ``-jsem`` jobserver client
    8 8 
       now speaks v2 of the semaphore-compat protocol, which uses Unix

  • compiler/GHC/Core/Make.hs
    ... ... @@ -219,13 +219,16 @@ mkLitRubbish :: Type -> Maybe CoreExpr
    219 219 
     -- Fail (returning Nothing) if
    220 220 
     --    * the RuntimeRep of the Type is not monomorphic;
    221 221 
     --    * the type is (a ~# b), the type of coercion
    222 
    --- See INVARIANT 1 and 2 of item (2) in Note [Rubbish literals]
    222 
    +--    * the type is terminating (isTerminatingType), e.g. a dictionary
    223 
    +-- See INVARIANT 1, 2 and 3 of item (2) in Note [Rubbish literals]
    223 224 
     -- in GHC.Types.Literal
    224 225 
     mkLitRubbish ty
    225 226 
       | not (noFreeVarsOfType rep)
    226 227 
       = Nothing   -- Satisfy INVARIANT 1
    227 228 
       | isCoVarType ty
    228 229 
       = Nothing   -- Satisfy INVARIANT 2
    230 
    +  | isTerminatingType ty
    231 
    +  = Nothing   -- Satisfy INVARIANT 3
    229 232 
       | otherwise
    230 233 
       = Just (Lit (LitRubbish torc rep) `mkTyApps` [ty])
    231 234 
       where

  • compiler/GHC/Core/Opt/Specialise.hs
    ... ... @@ -20,11 +20,13 @@ import GHC.Core.Multiplicity
    20 20 
     import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith )
    21 21 
     import GHC.Core.Predicate
    22 22 
     import GHC.Core.Coercion( Coercion )
    23 
    +import GHC.Core.DataCon ( StrictnessMark (..) )
    23 24 
     import GHC.Core.Opt.Monad
    25 
    +
    24 26 
     import qualified GHC.Core.Subst as Core
    25 27 
     import GHC.Core.Unfold.Make
    26 28 
     import GHC.Core
    27 
    -import GHC.Core.Make      ( mkLitRubbish )
    29 
    +import GHC.Core.Opt.WorkWrap.Utils ( mkAbsentFiller )
    28 30 
     import GHC.Core.Unify     ( tcMatchTy )
    29 31 
     import GHC.Core.Rules
    30 32 
     import GHC.Core.Utils     ( exprIsTrivial, exprIsTopLevelBindable
    ... ... @@ -1711,7 +1713,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
    1711 1713
    1712 1714 
                ; ( useful, rhs_env2, leftover_bndrs
    1713 1715 
                  , rule_bndrs, rule_lhs_args
    1714 
    -             , spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args
    1716 
    +             , spec_bndrs1, dx_binds, spec_args) <- specHeader this_mod env rhs_bndrs all_call_args
    1715 1717
    1716 1718 
     --           ; pprTrace "spec_call" (vcat
    1717 1719 
     --                [ text "fun:       "  <+> ppr fn
    ... ... @@ -2562,7 +2564,8 @@ isSpecDict _ = False
    2562 2564 
     --    , [T1, T2, c, i, dEqT1, dShow1]
    2563 2565 
     --    )
    2564 2566 
     specHeader
    2565 
    -     :: SpecEnv
    2567 
    +     :: Module      -- The module being compiled, for mkAbsentFiller
    2568 
    +     -> SpecEnv
    2566 2569 
          -> [InBndr]    -- The binders from the original function 'f'
    2567 2570 
          -> [SpecArg]   -- From the CallInfo
    2568 2571 
          -> SpecM ( Bool     -- True <=> some useful specialisation happened
    ... ... @@ -2588,7 +2591,7 @@ specHeader
    2588 2591 
     -- We want to specialise on type 'T1', and so we must construct a substitution
    2589 2592 
     -- 'a->T1', as well as a LHS argument for the resulting RULE and unfolding
    2590 2593 
     -- details.
    2591 
    -specHeader env (bndr : bndrs) (SpecType ty : args)
    2594 
    +specHeader mod env (bndr : bndrs) (SpecType ty : args)
    2592 2595 
       = do { -- Find qvars, the type variables to add to the binders for the rule
    2593 2596 
              -- Namely those free in `ty` that aren't in scope
    2594 2597 
              -- See (MP2) in Note [Specialising polymorphic dictionaries]
    ... ... @@ -2600,7 +2603,7 @@ specHeader env (bndr : bndrs) (SpecType ty : args)
    2600 2603 
                  ty'            = substTy env1 ty
    2601 2604 
                  env2           = extendTvSubst env1 bndr ty'
    2602 2605 
            ; (useful, env3, leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)
    2603 
    -            <- specHeader env2 bndrs args
    2606 
    +            <- specHeader mod env2 bndrs args
    2604 2607 
            ; pure ( useful
    2605 2608 
                   , env3
    2606 2609 
                   , leftover_bndrs
    ... ... @@ -2616,10 +2619,10 @@ specHeader env (bndr : bndrs) (SpecType ty : args)
    2616 2619 
     -- a substitution on it (in case the type refers to 'a'). Additionally, we need
    2617 2620 
     -- to produce a binder, LHS argument and RHS argument for the resulting rule,
    2618 2621 
     -- /and/ a binder for the specialised body.
    2619 
    -specHeader env (bndr : bndrs) (UnspecType : args)
    2622 
    +specHeader mod env (bndr : bndrs) (UnspecType : args)
    2620 2623 
       = do { let (env', bndr') = substBndr env bndr
    2621 2624 
            ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)
    2622 
    -            <- specHeader env' bndrs args
    2625 
    +            <- specHeader mod env' bndrs args
    2623 2626 
            ; pure ( useful
    2624 2627 
                   , env''
    2625 2628 
                   , leftover_bndrs
    ... ... @@ -2630,18 +2633,17 @@ specHeader env (bndr : bndrs) (UnspecType : args)
    2630 2633 
                   , varToCoreExpr bndr' : spec_args
    2631 2634 
                   )
    2632 2635 
            }
    2633 
    -
    2634 2636 
     -- Next we want to specialise the 'Eq a' dict away. We need to construct
    2635 2637 
     -- a wildcard binder to match the dictionary (See Note [Specialising Calls] for
    2636 2638 
     -- the nitty-gritty), as a LHS rule and unfolding details.
    2637 
    -specHeader env (bndr : bndrs) (SpecDict d : args)
    2639 
    +specHeader mod env (bndr : bndrs) (SpecDict d : args)
    2638 2640 
       | not (isDeadBinder bndr)
    2639 2641 
       , allVarSet (`elemInScopeSet` in_scope) (exprFreeVars d)
    2640 2642 
         -- See Note [Weird special case for SpecDict]
    2641 2643 
       = do { (env1, bndr') <- newDictBndr env bndr -- See Note [Zap occ info in rule binders]
    2642 2644 
            ; let (env2, dx_bind, spec_dict) = bindAuxiliaryDict env1 bndr bndr' d
    2643 2645 
            ; (_, env3, leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)
    2644 
    -             <- specHeader env2 bndrs args
    2646 
    +             <- specHeader mod env2 bndrs args
    2645 2647 
            ; pure ( True      -- Ha!  A useful specialisation!
    2646 2648 
                   , env3
    2647 2649 
                   , leftover_bndrs
    ... ... @@ -2666,21 +2668,24 @@ specHeader env (bndr : bndrs) (SpecDict d : args)
    2666 2668 
     -- why 'i' doesn't appear in our RULE above. But we have no guarantee that
    2667 2669 
     -- there aren't 'UnspecArg's which come /before/ all of the dictionaries, so
    2668 2670 
     -- this case must be here.
    2669 
    -specHeader env (bndr : bndrs) (_ : args)
    2671 
    +specHeader mod env (bndr : bndrs) (_ : args)
    2670 2672 
         -- The "_" can be UnSpecArg, or SpecDict where the bndr is dead
    2671 2673 
       = do { -- see Note [Zap occ info in rule binders]
    2672 2674 
              let (env', bndr') = substBndr env (zapIdOccInfo bndr)
    2673 2675 
            ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)
    2674 
    -             <- specHeader env' bndrs args
    2675 
    -
    2676 
    -       ; let bndr_ty = idType bndr'
    2676 
    +             <- specHeader mod env' bndrs args
    2677 2677
    2678 
    -             -- See Note [Drop dead args from specialisations]
    2678 
    +       ; let -- See Note [Drop dead args from specialisations]
    2679 2679 
                  -- C.f. GHC.Core.Opt.WorkWrap.Utils.mk_absent_let
    2680 2680 
                  (mb_spec_bndr, spec_arg)
    2681 2681 
                     | isDeadBinder bndr
    2682 
    -                , Just lit_expr <- mkLitRubbish bndr_ty
    2683 
    -                = (Nothing, lit_expr)
    2682 
    +                , Just filler <- mkAbsentFiller mod bndr' NotMarkedStrict
    2683 
    +                     -- NB: mkAbsentFiller returns Nothing for a terminating type (e.g. a
    2684 
    +                     -- dictionary), so this guard fails and we fall through, keeping the
    2685 
    +                     -- argument instead of dropping it.
    2686 
    +                     -- See Note [Don't make fillers for terminating types]
    2687 
    +                     -- in GHC.Core.Opt.WorkWrap.Utils
    2688 
    +                = (Nothing, filler)
    2684 2689 
                     | otherwise
    2685 2690 
                     = (Just bndr', varToCoreExpr bndr')
    2686 2691
    ... ... @@ -2699,12 +2704,12 @@ specHeader env (bndr : bndrs) (_ : args)
    2699 2704
    2700 2705 
     -- If we run out of binders, stop immediately
    2701 2706 
     -- See Note [Specialisation Must Preserve Sharing]
    2702 
    -specHeader env [] _ = pure (False, env, [], [], [], [], [], [])
    2707 
    +specHeader _ env [] _ = pure (False, env, [], [], [], [], [], [])
    2703 2708
    2704 2709 
     -- Return all remaining binders from the original function. These have the
    2705 2710 
     -- invariant that they should all correspond to unspecialised arguments, so
    2706 2711 
     -- it's safe to stop processing at this point.
    2707 
    -specHeader env bndrs []
    2712 
    +specHeader _ env bndrs []
    2708 2713 
       = pure (False, env', bndrs', [], [], [], [], [])
    2709 2714 
       where
    2710 2715 
         (env', bndrs') = substBndrs env bndrs

  • compiler/GHC/Core/Opt/WorkWrap.hs
    ... ... @@ -550,7 +550,7 @@ tryWW ww_opts is_rec fn_id rhs
    550 550 
       -- See Note [Drop absent bindings]
    551 551 
       | isAbsDmd (demandInfo fn_info)
    552 552 
       , not (isJoinId fn_id)
    553 
    -  , Just filler <- mkAbsentFiller ww_opts fn_id NotMarkedStrict
    553 
    +  , Just filler <- mkAbsentFiller (wo_module ww_opts) fn_id NotMarkedStrict
    554 554 
       = return [(new_fn_id, filler)]
    555 555
    556 556 
       -- See Note [Don't w/w INLINE things]

  • compiler/GHC/Core/Opt/WorkWrap/Utils.hs
    ... ... @@ -29,7 +29,6 @@ import GHC.Core.Subst
    29 29 
     import GHC.Core.Type
    30 30 
     import GHC.Core.Multiplicity
    31 31 
     import GHC.Core.Coercion
    32 
    -import GHC.Core.Predicate( isDictTy )
    33 32 
     import GHC.Core.Reduction
    34 33 
     import GHC.Core.FamInstEnv
    35 34 
     import GHC.Core.TyCon
    ... ... @@ -936,7 +935,7 @@ mkWWstr_one opts arg str_mark =
    936 935 
         _ | isTyVar arg -> do_nothing
    937 936
    938 937 
         DropAbsent
    939 
    -      | Just absent_filler <- mkAbsentFiller opts arg str_mark
    938 
    +      | Just absent_filler <- mkAbsentFiller (wo_module opts) arg str_mark
    940 939 
              -- Absent case.  Drop the argument from the worker.
    941 940 
              -- We can't always handle absence for arbitrary
    942 941 
              -- unlifted types, so we need to choose just the cases we can
    ... ... @@ -1007,14 +1006,20 @@ unbox_one_arg opts arg_var
    1007 1006 
     --
    1008 1007 
     -- If @mkAbsentFiller _ id == Just e@, then @e@ is an absent filler with the
    1009 1008 
     -- same type as @id@. Otherwise, no suitable filler could be found.
    1010 
    -mkAbsentFiller :: WwOpts -> Id -> StrictnessMark -> Maybe CoreExpr
    1011 
    -mkAbsentFiller opts arg str
    1009 
    +mkAbsentFiller :: Module -> Id -> StrictnessMark -> Maybe CoreExpr
    1010 
    +mkAbsentFiller mod arg str
    1011 
    +  -- We never make a filler for a terminating type: it might be speculatively
    1012 
    +  -- evaluated or have a field projected out of it.
    1013 
    +  -- See (AF4) in Note [Absent fillers], and
    1014 
    +  -- Note [Don't make fillers for terminating types].
    1015 
    +  | isTerminatingType arg_ty
    1016 
    +  = Nothing
    1017 
    +
    1012 1018 
       -- The lifted case: bind 'absentError'. See (AF1) in Note [Absent fillers]
    1013 1019 
       -- We want to use this case if possible, because we get a nice runtime panic message
    1014 1020 
       -- if we are wrong (like we were in #11126).  Otherwise we fall through to the
    1015 1021 
       -- less-desirable mkLitRubbish case.
    1016 1022 
       | mightBeLiftedType arg_ty
    1017 
    -  , not (isDictTy arg_ty)                 -- See (AF4) in Note [Absent fillers]
    1018 1023 
       , not (isStrictDmd (idDemandInfo arg))  -- See (AF2)
    1019 1024 
       , not (isMarkedStrict str)              --    in Note [Absent fillers]
    1020 1025 
       = Just (mkAbsentErrorApp arg_ty msg)
    ... ... @@ -1041,7 +1046,7 @@ mkAbsentFiller opts arg str
    1041 1046 
                   -- will have different lengths and hence different costs for
    1042 1047 
                   -- the inliner leading to different inlining.
    1043 1048 
                   -- See also Note [Unique Determinism] in GHC.Types.Unique
    1044 
    -    file_msg = text "In module" <+> quotes (ppr $ wo_module opts)
    1049 
    +    file_msg = text "In module" <+> quotes (ppr mod)
    1045 1050
    1046 1051 
     {- Note [Worker/wrapper for Strictness and Absence]
    1047 1052 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ... ... @@ -1234,27 +1239,8 @@ Needless to say, there are some wrinkles:
    1234 1239 
          have to be representation monomorphic. But in the future, we might allow
    1235 1240 
          levity polymorphism, e.g. a polymorphic levity variable in 'BoxedRep'.
    1236 1241
    1237 
    -(AF4) Consider (#24934)
    1238 
    -         f :: (a~b) => blah {-# INLINE f #-}
    1239 
    -         f d x = case eq_sel d of co -> body
    1240 
    -     In #24934 it turned out that `co` was unused; and we discarded the
    1241 
    -     entire case-scrutinisation via the `exprOkToDiscard` test in
    1242 
    -     `GHC.Core.Opt.Simplify.Iteration.rebuildCase`.  So now `d` is absent.
    1243 
    -     But in the /unfolding/ for some reason we did not discard the `case`;
    1244 
    -     so when we inline `f` we end up evaluating that `d` argument.  So we had
    1245 
    -     better not replace it with an error thunk!
    1246 
    -
    1247 
    -     The root of it is this: `exprOkToDiscard` assumes that a dictionary is
    1248 
    -     non-bottom (Note [exprOkForSpeculation and type classes]); but then we replace
    1249 
    -     the (a~b) dictionary with an error thunk, breaking the invariant that every
    1250 
    -     dictionary is non-bottom.  (If -XDictsStrict is on, the invariant is even
    1251 
    -     more important.)
    1252 
    -
    1253 
    -     Simple solution: never use an error thunk for a dictionary; instead fall
    1254 
    -     through to mkRubbishLit.  (The only downside is that we lose the compiler
    1255 
    -     debugging advantages of (AF1).)
    1256 
    -
    1257 
    -     This is quite delicate.
    1242 
    +(AF4) We never make an absent filler for a terminating type.
    1243 
    +      See Note [Don't make fillers for terminating types].
    1258 1244
    1259 1245 
     While (AF1) and (AF2) are simply an optimisation in terms of compiler debugging
    1260 1246 
     experience, (AF3) should be irrelevant in most programs, if not all.
    ... ... @@ -1276,6 +1262,47 @@ fragile
    1276 1262 
        because `MkT` is strict in its Int# argument, so we get an absentError
    1277 1263 
        exception when we shouldn't.  Very annoying!
    1278 1264
    1265 
    +Note [Don't make fillers for terminating types]
    1266 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    1267 
    +We never make an absent filler, error thunk or rubbish literal, for a terminating
    1268 
    +type (isTerminatingType): a non-unary class dictionary, a boxed equality, or a
    1269 
    +constraint tuple.
    1270 
    +
    1271 
    +GHC relies on a dictionary value never being bottom (see
    1272 
    +Note [NON-BOTTOM-DICTS invariant] in GHC.Core).  GHC uses "speculation" to
    1273 
    +evaluated guaranteed-non-bottom values: see Note [Speculative evaluation] in
    1274 
    +GHC.CoreToStg.Prep. This speculative evaluation is fundamentally incompatible
    1275 
    +with replacing a dictionary with an absent filler.  Attempts to to do so gave
    1276 
    +rise to a succession of bugs including:
    1277 
    +
    1278 
    +  * #24934: we evaluated an absent dictionary
    1279 
    +  * #25924: we selected a superclass from an absent dictionary
    1280 
    +
    1281 
    +A terminating type is exactly what speculation will force: see
    1282 
    +Note [exprOkForSpeculation and type classes] in GHC.Core.Utils. So we refuse to
    1283 
    +make a filler for precisely those types.
    1284 
    +
    1285 
    +So the safe thing is to make no filler at all for a terminating type. Then there
    1286 
    +is no bogus dictionary to evaluate or project from.  Specifically
    1287 
    +
    1288 
    +  * `mkAbsentFiller` returns `Nothing` for a terminating type, so worker/wrapper
    1289 
    +    keeps the real argument.
    1290 
    +
    1291 
    +  * `Specialise.specHeader` calls `mkAbsentFiller` too, so it likewise keeps the
    1292 
    +    dead dictionary argument rather than dropping it for a filler.
    1293 
    +
    1294 
    +Prior failed approaches
    1295 
    +
    1296 
    +We used to paper over this. !13233 replaced the error thunk for an absent
    1297 
    +dictionary with a rubbish literal, so that it could at least be evaluated
    1298 
    +without complaint. But #25924 showed that this is not enough, because we do not
    1299 
    +only evaluate the absent dictionary, we also select a superclass from it.
    1300 
    +
    1301 
    +We could instead teach speculation to leave absent bindings alone, and we do
    1302 
    +that too (see Note [Speculative evaluation] in GHC.CoreToStg.Prep). But that is
    1303 
    +not a guarantee. After optimisation a binding that holds an absent filler may no
    1304 
    +longer be marked absent, so we cannot rely on the demand to protect us.
    1305 
    +
    1279 1306 
     Note [Unboxing through unboxed tuples]
    1280 1307 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    1281 1308 
     We should not to a worker/wrapper split just for unboxing the components of

  • compiler/GHC/CoreToStg/Prep.hs
    ... ... @@ -1960,6 +1960,20 @@ It is also similar to Note [Do not strictify a DFun's parameter dictionaries],
    1960 1960 
     where marking recursive DFuns (of undecidable *instances*) strict in dictionary
    1961 1961 
     *parameters* leads to quite the same change in termination as above.
    1962 1962
    1963 
    +Belt and braces: do not speculate absent bindings
    1964 
    +
    1965 
    +In 'decideFloatInfo' we decline to speculate a binding whose demand is absent.
    1966 
    +There is no point in speculating an absent binding, since its value is
    1967 
    +(presumably) not needed.
    1968 
    +
    1969 
    +This used to matter more. Worker/wrapper would bind an absent dictionary to a
    1970 
    +rubbish literal filler, and speculation could force a superclass selection out
    1971 
    +of that rubbish literal, causing a segfault (#25924). Nowadays we never make a
    1972 
    +filler for a dictionary in the first place, so this can no longer happen and
    1973 
    +the guard is merely belt and braces.
    1974 
    +See Note [Don't make fillers for terminating types]
    1975 
    +in GHC.Core.Opt.WorkWrap.Utils.
    1976 
    +
    1963 1977 
     Note [BindInfo and FloatInfo]
    1964 1978 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    1965 1979 
     The `BindInfo` of a `Float` describes whether it will be case-bound or
    ... ... @@ -2204,12 +2218,16 @@ mkNonRecFloat env is_unlifted bndr rhs
    2204 2218 
           | exprIsTickedString rhs   = (CaseBound, TopLvlFloatable)
    2205 2219 
               -- String literals are unboxed (so must be case-bound) and float to
    2206 2220 
               -- the top-level
    2207 
    -      | is_unlifted, ok_for_spec = (CaseBound, LazyContextFloatable)
    2208 
    -      | is_lifted,   ok_for_spec = (CaseBound, TopLvlFloatable)
    2221 
    +      | is_unlifted, ok_for_spec, not (isAbsDmd dmd) = (CaseBound, LazyContextFloatable)
    2222 
    +      | is_lifted,   ok_for_spec, not (isAbsDmd dmd) = (CaseBound, TopLvlFloatable)
    2209 2223 
               -- See Note [Speculative evaluation]
    2210 2224 
               -- Ok-for-spec-eval things will be case-bound, lifted or not.
    2211 2225 
               -- But when it's lifted we are ok with floating it to top-level
    2212 2226 
               -- (where it is actually bound lazily).
    2227 
    +          --
    2228 
    +          -- Don't speculate an absent binding. See #25924 and
    2229 
    +          -- "Belt and braces" in Note [Speculative evaluation].
    2230 
    +
    2213 2231 
           | is_unlifted || is_strict = (CaseBound, StrictContextFloatable)
    2214 2232 
               -- These will never be floated out of a lazy RHS context
    2215 2233 
           | otherwise                = assertPpr is_lifted (ppr rhs) $

  • compiler/GHC/StgToCmm/Bind.hs
    ... ... @@ -587,9 +587,8 @@ closureCodeBody top_lvl bndr cl_info cc args@(arg0:_) body fv_details
    587 587 
                     -- ticky after heap check to avoid double counting
    588 588 
                     ; tickyEnterFun cl_info
    589 589 
                     ; enterCostCentreFun cc
    590 
    -                    (CmmMachOp (mo_wordSub platform)
    591 
    -                         [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification]
    592 
    -                         , mkIntExpr platform (funTag platform cl_info) ])
    590 
    +                    (cmmUntag platform (CmmReg (CmmLocal node))) -- See [NodeReg clobbered with loopification]
    591 
    +
    593 592 
                     ; fv_bindings <- mapM bind_fv fv_details
    594 593 
                     -- Load free vars out of closure *after*
    595 594 
                     -- heap check, to reduce live vars over check

  • compiler/GHC/Types/Literal.hs
    ... ... @@ -988,6 +988,14 @@ data type. Here are the moving parts:
    988 988
    989 989 
        This is sad, though: see #18983.
    990 990
    991 
    +   INVARIANT 3: we never make a rubbish literal of a terminating type
    992 
    +   (isTerminatingType), such as a class dictionary. GHC relies on a value of
    993 
    +   a terminating type never being bottom, and so may speculatively evaluate
    994 
    +   a dictionary or select a superclass from it. Either would crash on a
    995 
    +   rubbish literal (#24934, #25924).
    996 
    +   See Note [Don't make fillers for terminating types]
    997 
    +   in GHC.Core.Opt.WorkWrap.Utils.
    998 
    +
    991 999 
     3. STG: The type app in `RUBBISH[IntRep] @Int# :: Int#` is erased and we get
    992 1000 
        the (untyped) 'StgLit' `RUBBISH[IntRep] :: Int#` in STG.
    993 1001

  • hadrian/src/Settings/Warnings.hs
    ... ... @@ -89,4 +89,6 @@ ghcWarningsArgs = do
    89 89 
                                           , "-Wno-deprecations" -- https://gitlab.haskell.org/ghc/ghc/-/issues/24240
    90 90 
                                           , "-Wno-deriving-typeable"
    91 91 
                                           ]
    92 
    -        , package xhtml        ? pure [ "-Wno-unused-imports" ] ] ]
    92 
    +        , package xhtml        ? pure [ "-Wno-unused-imports" ]
    93 
    +        , package semaphoreCompat ? pure [ "-Wno-unused-imports" ]
    94 
    +        ] ]

  • libraries/semaphore-compat
    1 
    -Subproject commit 44e7488dd93cbf333ceca1319a60146898f6224f
    1 
    +Subproject commit ebcb68506e67de9c8190c0394e10c913593d85da

  • rts/Apply.cmm
    ... ... @@ -99,12 +99,14 @@ again:
    99 99 
         W_  info;
    100 100 
         P_ untaggedfun;
    101 101 
         W_ arity;
    102 
    +    W_ closure_type;
    102 103 
         // We must obey the correct heap object observation pattern in
    103 104 
         // Note [Heap memory barriers] in SMP.h.
    104 105 
         untaggedfun = UNTAG(fun);
    105 106 
         info = %INFO_PTR(untaggedfun);
    107 
    +    closure_type = TO_W_( %INFO_TYPE(%STD_INFO(info)) );
    106 108 
         switch [INVALID_OBJECT .. N_CLOSURE_TYPES]
    107 
    -        (TO_W_( %INFO_TYPE(%STD_INFO(info)) )) {
    109 
    +        (closure_type) {
    108 110 
             case
    109 111 
                 IND,
    110 112 
                 IND_STATIC:
    ... ... @@ -212,10 +214,17 @@ again:
    212 214 
                 // We can't use the value of 'info' any more, because if
    213 215 
                 // STK_CHK_GEN() did a GC then the closure we're looking
    214 216 
                 // at may have changed, e.g. a THUNK_SELECTOR may have
    215 
    -            // been evaluated by the GC.  So we reload the info
    216 
    -            // pointer now.
    217 
    +            // been evaluated by the GC.
    218 
    +            // We always reload the info pointer now. And if
    219 
    +            // the closure type changed we need to take a different case
    220 
    +            // alt altogether so we retry from the start in that case.
    221 
    +
    217 222 
                 untaggedfun = UNTAG(fun);
    218 223 
                 info = %INFO_PTR(untaggedfun);
    224 
    +            if(closure_type != TO_W_( %INFO_TYPE(%STD_INFO(info)) ) )
    225 
    +            {
    226 
    +              goto again;
    227 
    +            }
    219 228
    220 229 
                 jump %ENTRY_CODE(info)
    221 230 
                     (stg_restore_cccs_eval_info, CCCS)

  • testsuite/tests/core-to-stg/T25924/B.hs
    1 
    +{-# LANGUAGE AllowAmbiguousTypes, TypeFamilies, QuantifiedConstraints, TypeAbstractions #-}
    2 
    +module B where
    3 
    +
    4 
    +import Data.Kind
    5 
    +
    6 
    +class ABITypeable a where
    7 
    +  abiTypeInfo :: String
    8 
    +  abiTypeInfo = ""
    9 
    +
    10 
    +  unused :: a -> a
    11 
    +  unused x = x
    12 
    +
    13 
    +data REF a
    14 
    +
    15 
    +instance ABITypeable () where
    16 
    +instance ABITypeable a => ABITypeable (REF a) where
    17 
    +
    18 
    +class (ABITypeable a, ABITypeable a) => YulCatObj a where -- crash stops without duplicate constraint
    19 
    +instance YulCatObj ()
    20 
    +instance YulCatObj a => YulCatObj (REF a)
    21 
    +
    22 
    +type YulO1 a = YulCatObj a
    23 
    +type YulO2 a b = (YulCatObj a, YulCatObj b)
    24 
    +
    25 
    +
    26 
    +type YulCat :: Type -> Type -> Type
    27 
    +data YulCat a b where
    28 
    +  YulExtendType :: forall b. (YulO2 () b) => YulCat () b
    29 
    +  YulComp :: forall a b c. YulCat c b -> YulCat a c -> YulCat a b
    30 
    +  YulJmpB :: forall a b. (YulO2 a b) =>  YulCat a b
    31 
    +
    32 
    +data Trie  a b where
    33 
    +  Z :: Trie  a a
    34 
    +  (:.) :: (YulCatObj a, YulCatObj b) => YulCat a b -> Trie b c -> Trie a c
    35 
    +
    36 
    +type Cat a b = forall c. Trie b c -> Trie a c
    37 
    +
    38 
    +normalize :: forall a b unused  ξ. (Int ~ unused,  YulCatObj a, YulCatObj b)
    39 
    +  => Trie a b -> (forall c. YulCatObj c => Trie a c -> YulCat c b -> ξ) -> ξ
    40 
    +normalize t0 k = case t0 of
    41 
    +  Z -> k Z undefined
    42 
    +  φ :. f -> normalize f $ \f' s -> case f' of
    43 
    +                                     Z -> k Z (s `YulComp` φ)
    44 
    +                                     _ -> undefined
    45 
    +
    46 
    +
    47 
    +toSMC :: forall a b . (YulCatObj a, YulCatObj b) => Cat a b -> YulCat a b
    48 
    +toSMC t = normalize (t Z) $ \f g -> case f of
    49 
    +  Z -> g
    50 
    +  _ -> error "toSMC: normalisation process failed"
    51 
    +
    52 
    +
    53 
    +encode   :: (YulCatObj r, YulCatObj a, YulCatObj b) => (a `YulCat` b) -> (P r a -> P r b)
    54 
    +encode φ (Y f)    = Y (\x -> f (φ :. x))
    55 
    +
    56 
    +
    57 
    +type P :: Type -> Type -> Type
    58 
    +data P r a = Y (Cat r a)
    59 
    +
    60 
    +fromP :: P r a -> Cat r a
    61 
    +fromP (Y f) = f
    62 
    +
    63 
    +
    64 
    +decode :: (YulCatObj a, YulCatObj b) => (P a a -> P a b) -> YulCat a b
    65 
    +decode f  = toSMC (extract f)
    66 
    +
    67 
    +extract ::(YulCatObj a, YulCatObj b) => (P a a -> P a b) -> Cat a b
    68 
    +extract f = fromP (f (Y id))
    69 
    +
    70 
    +
    71 
    +yulShow :: YulCat a' b' -> String
    72 
    +yulShow (YulExtendType @b) = "Te" <> abiTypeInfo @b
    73 
    +yulShow (YulComp cb ac)    = yulShow ac <> yulShow cb
    74 
    +yulShow YulJmpB            = "Jb"
    75 
    +
    76 
    +
    77 
    +lfn' :: forall b unused.
    78 
    +  ( YulO1 (REF b)
    79 
    +  , () ~ unused
    80 
    +  ) =>
    81 
    +  (forall r. YulO1 r => P r () -> P r (REF b)) -> String
    82 
    +lfn' f = yulShow (decode f)
    83 
    +
    84 
    +
    85 
    +extendType'l :: forall a r. (YulO1 a, YulO1 r) => P r () -> P r a
    86 
    +extendType'l = encode YulExtendType
    87 
    +
    88 
    +keccak256'l :: forall a r. YulO2 r a => P r a -> P r ()
    89 
    +keccak256'l = encode YulJmpB

  • testsuite/tests/core-to-stg/T25924/Main.hs
    1 
    +module Main where
    2 
    +import B
    3 
    +
    4 
    +getCounterRef' :: forall b r.
    5 
    +  ( YulO1 b
    6 
    +  , YulO1 r
    7 
    +  -- , YulO1 (REF b)
    8 
    +  ) =>
    9 
    +  P r ()  -> P r (REF b)
    10 
    +getCounterRef' a = extendType'l (keccak256'l a)
    11 
    +{-# NOINLINE getCounterRef' #-}
    12 
    +
    13 
    +main :: IO ()
    14 
    +main = putStrLn $ lfn' @() getCounterRef'

  • testsuite/tests/core-to-stg/T25924/all.T
    1 
    +test('T25924',
    2 
    +     [exit_code(1), ignore_stderr, extra_files(['Main.hs', 'B.hs'])],
    3 
    +     multimod_compile_and_run,
    4 
    +     ['Main', '-O'])

  • testsuite/tests/core-to-stg/T25924a.hs
    1 
    +{-# LANGUAGE GADTs, TypeApplications, ScopedTypeVariables, AllowAmbiguousTypes #-}
    2 
    +module Main where
    3 
    +
    4 
    +class D a where
    5 
    +  m :: a -> Int
    6 
    +  m _ = 0
    7 
    +  n :: a -> Int
    8 
    +  n _ = 0
    9 
    +
    10 
    +class (D a, D a) => C a
    11 
    +
    12 
    +data T a
    13 
    +
    14 
    +instance D a => D (T a)
    15 
    +instance C a => C (T a)
    16 
    +
    17 
    +instance D ()
    18 
    +instance C ()
    19 
    +
    20 
    +data G where
    21 
    +  MkG :: forall a. C (T a) => T a -> G
    22 
    +
    23 
    +sh :: G -> Int
    24 
    +sh (MkG x) = m x
    25 
    +
    26 
    +f :: forall b. C b => G
    27 
    +f = MkG (undefined :: T b)
    28 
    +{-# NOINLINE f #-}
    29 
    +
    30 
    +main :: IO ()
    31 
    +main = print (sh (f @()))

  • testsuite/tests/core-to-stg/T25924a.stdout
    1 
    +0

  • testsuite/tests/core-to-stg/all.T
    ... ... @@ -7,3 +7,4 @@ test('T14895', normal, compile, ['-O -ddump-stg-final -dno-typeable-binds -dsupp
    7 7 
     test('T24124', normal, compile, ['-O -ddump-stg-final -dno-typeable-binds -dsuppress-uniques'])
    8 8 
     test('T24334', normal, compile_and_run, ['-O'])
    9 9 
     test('T24463', normal, compile, ['-O'])
    10 
    +test('T25924a', [ignore_stderr], compile_and_run, ['-O'])

  • testsuite/tests/dmdanal/should_compile/T18982.stderr
    1 1
    2 2 
     ==================== Tidy Core ====================
    3 
    -Result size of Tidy Core = {terms: 295, types: 206, coercions: 4, joins: 0/0}
    3 
    +Result size of Tidy Core = {terms: 297, types: 214, coercions: 4, joins: 0/0}
    4 4
    5 5 
     -- RHS size: {terms: 8, types: 9, coercions: 1, joins: 0/0}
    6 6 
     T18982.$WExGADT :: forall e. (e ~ Int) => e %1 -> Int %1 -> ExGADT Int
    ... ... @@ -194,13 +194,13 @@ T18982.$tc'ExGADT2 = GHC.Types.TrNameS T18982.$tc'ExGADT3
    194 194 
     T18982.$tc'ExGADT :: GHC.Types.TyCon
    195 195 
     T18982.$tc'ExGADT = GHC.Types.TyCon 8468257409157161049#Word64 5503123603717080600#Word64 T18982.$trModule T18982.$tc'ExGADT2 1# T18982.$tc'ExGADT1
    196 196
    197 
    --- RHS size: {terms: 11, types: 10, coercions: 0, joins: 0/0}
    198 
    -T18982.$wi :: forall a e. (a GHC.Prim.~# Int) => e -> GHC.Prim.Int# -> GHC.Prim.Int#
    199 
    -T18982.$wi = \ (@a) (@e) (ww :: a GHC.Prim.~# Int) (ww1 :: e) (ww2 :: GHC.Prim.Int#) -> case ww1 of { __DEFAULT -> GHC.Prim.+# ww2 1# }
    197 
    +-- RHS size: {terms: 12, types: 14, coercions: 0, joins: 0/0}
    198 
    +T18982.$wi :: forall a e. (a GHC.Prim.~# Int, e ~ Int) => e -> GHC.Prim.Int# -> GHC.Prim.Int#
    199 
    +T18982.$wi = \ (@a) (@e) (ww :: a GHC.Prim.~# Int) _ (ww2 :: e) (ww3 :: GHC.Prim.Int#) -> case ww2 of { __DEFAULT -> GHC.Prim.+# ww3 1# }
    200 200
    201 
    --- RHS size: {terms: 15, types: 22, coercions: 1, joins: 0/0}
    201 
    +-- RHS size: {terms: 16, types: 22, coercions: 1, joins: 0/0}
    202 202 
     i :: forall a. ExGADT a -> Int
    203 
    -i = \ (@a) (ds :: ExGADT a) -> case ds of { ExGADT @e ww ww1 ww2 ww3 -> case ww3 of { GHC.Types.I# ww4 -> case T18982.$wi @a @e @~(ww :: a GHC.Prim.~# Int) ww2 ww4 of ww5 { __DEFAULT -> GHC.Types.I# ww5 } } }
    203 
    +i = \ (@a) (ds :: ExGADT a) -> case ds of { ExGADT @e ww ww1 ww2 ww3 -> case ww3 of { GHC.Types.I# ww4 -> case T18982.$wi @a @e @~(ww :: a GHC.Prim.~# Int) ww1 ww2 ww4 of ww5 { __DEFAULT -> GHC.Types.I# ww5 } } }
    204 204
    205 205 
     -- RHS size: {terms: 6, types: 7, coercions: 0, joins: 0/0}
    206 206 
     T18982.$wh :: forall a. (a GHC.Prim.~# Int) => GHC.Prim.Int# -> GHC.Prim.Int#

  • testsuite/tests/rts/T27123.hs
    1 
    +{-# OPTIONS_GHC -fno-full-laziness -fno-worker-wrapper #-}
    2 
    +{-# LANGUAGE MagicHash, UnboxedTuples #-}
    3 
    +
    4 
    +-- This test checks that the auto-apply code (stg_ap_0_fast, stg_ap_p) is robust
    5 
    +-- against another thread or the GC evaluating a closure at the same time.
    6 
    +
    7 
    +module Main
    8 
    +    -- (main)
    9 
    +where
    10 
    +
    11 
    +import Control.Monad
    12 
    +import Control.Concurrent
    13 
    +import System.IO
    14 
    +import GHC.Data.SmallArray
    15 
    +import GHC.Exts
    16 
    +import GHC.IO
    17 
    +
    18 
    +type Arr = SmallMutableArray RealWorld (Int->Int)
    19 
    +
    20 
    +io :: (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
    21 
    +io f = IO f
    22 
    +
    23 
    +io_ :: (State# RealWorld -> State# RealWorld ) -> IO ()
    24 
    +io_ f = IO (\s -> case f s of s2 -> (# s2, () #))
    25 
    +
    26 
    +{-# NOINLINE readSmallArray #-}
    27 
    +readSmallArray (SmallMutableArray arr) (I# idx) = IO $ \s -> case readSmallArray# arr idx s of
    28 
    +    (# s2, r #) -> (# s2, r #)
    29 
    +
    30 
    +-- Continually overwrites the array with unevaluated thunks that will evaluated to
    31 
    +-- a PAP under profiling.
    32 
    +{-# NOINLINE mkThunks #-}
    33 
    +mkThunks :: Arr -> IO ()
    34 
    +mkThunks arr = do
    35 
    +    forever $ do
    36 
    +      yield
    37 
    +      forM_ [0..100] $ \_j -> do
    38 
    +        forM_ [0..5 :: Int] $ \i -> do
    39 
    +            -- With profiling results in a thunk that will evaluate to a PAP capturing the SCC
    40 
    +            let g = {-# SCC g #-} succ
    41 
    +            io_ (writeSmallArray arr i g)
    42 
    +
    43 
    +-- Evaluate the array repeatedly in the given order.
    44 
    +{-# NOINLINE evaluateThunks #-}
    45 
    +evaluateThunks :: Arr -> [Int] -> IO ()
    46 
    +evaluateThunks arr idxs = do
    47 
    +    forever $ do
    48 
    +        yield
    49 
    +        -- putStr "." >> hFlush stdout
    50 
    +        forM [0..5000::Int] $ \j -> do
    51 
    +            forM_ idxs $ \i -> do
    52 
    +                !g <- readSmallArray arr i
    53 
    +                seq (g i) (pure ())
    54 
    +
    55 
    +main :: IO ()
    56 
    +main = do
    57 
    +    -- We spawn three threads.
    58 
    +    -- * Two are evaluating the thunks in the array in opposite directions
    59 
    +    -- * One thread is writing thunks to the array.
    60 
    +    -- The reading threads will race to evaluate the same thunk triggering potential
    61 
    +    -- race conditions.
    62 
    +    arr <- io (newSmallArray 6 (id))
    63 
    +    _ <- forkIO $ do
    64 
    +        evaluateThunks arr [0..5]
    65 
    +    _ <- forkIO $ do
    66 
    +        evaluateThunks arr [5,4..0]
    67 
    +    forkIO $ mkThunks arr
    68 
    +    threadDelay 10_000_000

  • testsuite/tests/rts/all.T
    ... ... @@ -639,3 +639,5 @@ test('T25280', [unless(opsys('linux'),skip),req_process,js_skip], compile_and_ru
    639 639 
     test('T25560', [req_c_rts, ignore_stderr], compile_and_run, [''])
    640 640
    641 641 
     test('TestProddableBlockSet', [req_c_rts], multimod_compile_and_run, ['TestProddableBlockSet.c', '-no-hs-main'])
    642 
    +
    643 
    +test('T27123', [when(have_profiling(), extra_ways(['prof']))], compile_and_run, ['-O -package ghc'])

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