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

Commits:

14 changed files:

Changes:

  • 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.

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

  • 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}
    4 
    -
    5 
    --- RHS size: {terms: 8, types: 9, coercions: 1, joins: 0/0}
    6 
    -T18982.$WExGADT :: forall e. (e ~ Int) => e %1 -> Int %1 -> ExGADT Int
    7 
    -T18982.$WExGADT = \ (@e) (conrep :: e ~ Int) (conrep1 :: e) (conrep2 :: Int) -> T18982.ExGADT @Int @e @~(<Int>_N :: Int GHC.Prim.~# Int) conrep conrep1 conrep2
    8 
    -
    9 
    --- RHS size: {terms: 3, types: 2, coercions: 1, joins: 0/0}
    10 
    -T18982.$WGADT :: Int %1 -> GADT Int
    11 
    -T18982.$WGADT = \ (conrep :: Int) -> T18982.GADT @Int @~(<Int>_N :: Int GHC.Prim.~# Int) conrep
    12 
    -
    13 
    --- RHS size: {terms: 7, types: 6, coercions: 0, joins: 0/0}
    14 
    -T18982.$WEx :: forall e a. e %1 -> a %1 -> Ex a
    15 
    -T18982.$WEx = \ (@e) (@a) (conrep :: e) (conrep1 :: a) -> T18982.Ex @a @e conrep conrep1
    3 
    +Result size of Tidy Core = {terms: 276, types: 179, coercions: 2, joins: 0/0}
    16 4
    17 5 
     -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
    18 
    -T18982.$trModule4 :: GHC.Prim.Addr#
    19 
    -T18982.$trModule4 = "main"#
    6 
    +$trModule1 :: GHC.Internal.Prim.Addr#
    7 
    +$trModule1 = "main"#
    20 8
    21 9 
     -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
    22 
    -T18982.$trModule3 :: GHC.Types.TrName
    23 
    -T18982.$trModule3 = GHC.Types.TrNameS T18982.$trModule4
    10 
    +$trModule2 :: GHC.Internal.Types.TrName
    11 
    +$trModule2 = GHC.Internal.Types.TrNameS $trModule1
    24 12
    25 13 
     -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
    26 
    -T18982.$trModule2 :: GHC.Prim.Addr#
    27 
    -T18982.$trModule2 = "T18982"#
    14 
    +$trModule3 :: GHC.Internal.Prim.Addr#
    15 
    +$trModule3 = "T18982"#
    28 16
    29 17 
     -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
    30 
    -T18982.$trModule1 :: GHC.Types.TrName
    31 
    -T18982.$trModule1 = GHC.Types.TrNameS T18982.$trModule2
    18 
    +$trModule4 :: GHC.Internal.Types.TrName
    19 
    +$trModule4 = GHC.Internal.Types.TrNameS $trModule3
    32 20
    33 21 
     -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
    34 
    -T18982.$trModule :: GHC.Types.Module
    35 
    -T18982.$trModule = GHC.Types.Module T18982.$trModule3 T18982.$trModule1
    22 
    +T18982.$trModule :: GHC.Internal.Types.Module
    23 
    +T18982.$trModule = GHC.Internal.Types.Module $trModule2 $trModule4
    36 24
    37 25 
     -- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0}
    38 26 
     $krep :: GHC.Types.KindRep
    ... ... @@ -47,16 +35,16 @@ $krep2 :: GHC.Types.KindRep
    47 35 
     $krep2 = GHC.Types.KindRepVar 0#
    48 36
    49 37 
     -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
    50 
    -T18982.$tcBox2 :: GHC.Prim.Addr#
    51 
    -T18982.$tcBox2 = "Box"#
    38 
    +$tcBox1 :: GHC.Internal.Prim.Addr#
    39 
    +$tcBox1 = "Box"#
    52 40
    53 41 
     -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
    54 
    -T18982.$tcBox1 :: GHC.Types.TrName
    55 
    -T18982.$tcBox1 = GHC.Types.TrNameS T18982.$tcBox2
    42 
    +$tcBox2 :: GHC.Internal.Types.TrName
    43 
    +$tcBox2 = GHC.Internal.Types.TrNameS $tcBox1
    56 44
    57 45 
     -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
    58 
    -T18982.$tcBox :: GHC.Types.TyCon
    59 
    -T18982.$tcBox = GHC.Types.TyCon 16948648223906549518#Word64 2491460178135962649#Word64 T18982.$trModule T18982.$tcBox1 0# GHC.Types.krep$*Arr*
    46 
    +T18982.$tcBox :: GHC.Internal.Types.TyCon
    47 
    +T18982.$tcBox = GHC.Internal.Types.TyCon 16948648223906549518#Word64 2491460178135962649#Word64 T18982.$trModule $tcBox2 0# GHC.Internal.Types.krep$*Arr*
    60 48
    61 49 
     -- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
    62 50 
     $krep3 :: [GHC.Types.KindRep]
    ... ... @@ -67,140 +55,140 @@ $krep4 :: GHC.Types.KindRep
    67 55 
     $krep4 = GHC.Types.KindRepTyConApp T18982.$tcBox $krep3
    68 56
    69 57 
     -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
    70 
    -T18982.$tc'Box1 :: GHC.Types.KindRep
    71 
    -T18982.$tc'Box1 = GHC.Types.KindRepFun $krep2 $krep4
    58 
    +$krep5 :: GHC.Internal.Types.KindRep
    59 
    +$krep5 = GHC.Internal.Types.KindRepFun $krep2 $krep4
    72 60
    73 61 
     -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
    74 
    -T18982.$tc'Box3 :: GHC.Prim.Addr#
    75 
    -T18982.$tc'Box3 = "'Box"#
    62 
    +$tc'Box1 :: GHC.Internal.Prim.Addr#
    63 
    +$tc'Box1 = "'Box"#
    76 64
    77 65 
     -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
    78 
    -T18982.$tc'Box2 :: GHC.Types.TrName
    79 
    -T18982.$tc'Box2 = GHC.Types.TrNameS T18982.$tc'Box3
    66 
    +$tc'Box2 :: GHC.Internal.Types.TrName
    67 
    +$tc'Box2 = GHC.Internal.Types.TrNameS $tc'Box1
    80 68
    81 69 
     -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
    82 
    -T18982.$tc'Box :: GHC.Types.TyCon
    83 
    -T18982.$tc'Box = GHC.Types.TyCon 1412068769125067428#Word64 8727214667407894081#Word64 T18982.$trModule T18982.$tc'Box2 1# T18982.$tc'Box1
    70 
    +T18982.$tc'Box :: GHC.Internal.Types.TyCon
    71 
    +T18982.$tc'Box = GHC.Internal.Types.TyCon 1412068769125067428#Word64 8727214667407894081#Word64 T18982.$trModule $tc'Box2 1# $krep5
    84 72
    85 73 
     -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
    86 
    -T18982.$tcEx2 :: GHC.Prim.Addr#
    87 
    -T18982.$tcEx2 = "Ex"#
    74 
    +$tcEx1 :: GHC.Internal.Prim.Addr#
    75 
    +$tcEx1 = "Ex"#
    88 76
    89 77 
     -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
    90 
    -T18982.$tcEx1 :: GHC.Types.TrName
    91 
    -T18982.$tcEx1 = GHC.Types.TrNameS T18982.$tcEx2
    78 
    +$tcEx2 :: GHC.Internal.Types.TrName
    79 
    +$tcEx2 = GHC.Internal.Types.TrNameS $tcEx1
    92 80
    93 81 
     -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
    94 
    -T18982.$tcEx :: GHC.Types.TyCon
    95 
    -T18982.$tcEx = GHC.Types.TyCon 4376661818164435927#Word64 18005417598910668817#Word64 T18982.$trModule T18982.$tcEx1 0# GHC.Types.krep$*Arr*
    82 
    +T18982.$tcEx :: GHC.Internal.Types.TyCon
    83 
    +T18982.$tcEx = GHC.Internal.Types.TyCon 4376661818164435927#Word64 18005417598910668817#Word64 T18982.$trModule $tcEx2 0# GHC.Internal.Types.krep$*Arr*
    96 84
    97 85 
     -- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
    98 
    -$krep5 :: [GHC.Types.KindRep]
    99 
    -$krep5 = GHC.Types.: @GHC.Types.KindRep $krep1 (GHC.Types.[] @GHC.Types.KindRep)
    86 
    +$krep6 :: [GHC.Internal.Types.KindRep]
    87 
    +$krep6 = GHC.Internal.Types.: @GHC.Internal.Types.KindRep $krep1 (GHC.Internal.Types.[] @GHC.Internal.Types.KindRep)
    100 88
    101 89 
     -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
    102 
    -$krep6 :: GHC.Types.KindRep
    103 
    -$krep6 = GHC.Types.KindRepTyConApp T18982.$tcEx $krep5
    90 
    +$krep7 :: GHC.Internal.Types.KindRep
    91 
    +$krep7 = GHC.Internal.Types.KindRepTyConApp T18982.$tcEx $krep6
    104 92
    105 93 
     -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
    106 
    -$krep7 :: GHC.Types.KindRep
    107 
    -$krep7 = GHC.Types.KindRepFun $krep1 $krep6
    94 
    +$krep8 :: GHC.Internal.Types.KindRep
    95 
    +$krep8 = GHC.Internal.Types.KindRepFun $krep1 $krep7
    108 96
    109 97 
     -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
    110 
    -T18982.$tc'Ex1 :: GHC.Types.KindRep
    111 
    -T18982.$tc'Ex1 = GHC.Types.KindRepFun $krep2 $krep7
    98 
    +$krep9 :: GHC.Internal.Types.KindRep
    99 
    +$krep9 = GHC.Internal.Types.KindRepFun $krep2 $krep8
    112 100
    113 101 
     -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
    114 
    -T18982.$tc'Ex3 :: GHC.Prim.Addr#
    115 
    -T18982.$tc'Ex3 = "'Ex"#
    102 
    +$tc'Ex1 :: GHC.Internal.Prim.Addr#
    103 
    +$tc'Ex1 = "'Ex"#
    116 104
    117 105 
     -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
    118 
    -T18982.$tc'Ex2 :: GHC.Types.TrName
    119 
    -T18982.$tc'Ex2 = GHC.Types.TrNameS T18982.$tc'Ex3
    106 
    +$tc'Ex2 :: GHC.Internal.Types.TrName
    107 
    +$tc'Ex2 = GHC.Internal.Types.TrNameS $tc'Ex1
    120 108
    121 109 
     -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
    122 
    -T18982.$tc'Ex :: GHC.Types.TyCon
    123 
    -T18982.$tc'Ex = GHC.Types.TyCon 14609381081172201359#Word64 3077219645053200509#Word64 T18982.$trModule T18982.$tc'Ex2 2# T18982.$tc'Ex1
    110 
    +T18982.$tc'Ex :: GHC.Internal.Types.TyCon
    111 
    +T18982.$tc'Ex = GHC.Internal.Types.TyCon 14609381081172201359#Word64 3077219645053200509#Word64 T18982.$trModule $tc'Ex2 2# $krep9
    124 112
    125 113 
     -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
    126 
    -T18982.$tcGADT2 :: GHC.Prim.Addr#
    127 
    -T18982.$tcGADT2 = "GADT"#
    114 
    +$tcGADT1 :: GHC.Internal.Prim.Addr#
    115 
    +$tcGADT1 = "GADT"#
    128 116
    129 117 
     -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
    130 
    -T18982.$tcGADT1 :: GHC.Types.TrName
    131 
    -T18982.$tcGADT1 = GHC.Types.TrNameS T18982.$tcGADT2
    118 
    +$tcGADT2 :: GHC.Internal.Types.TrName
    119 
    +$tcGADT2 = GHC.Internal.Types.TrNameS $tcGADT1
    132 120
    133 121 
     -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
    134 
    -T18982.$tcGADT :: GHC.Types.TyCon
    135 
    -T18982.$tcGADT = GHC.Types.TyCon 9243924476135839950#Word64 5096619276488416461#Word64 T18982.$trModule T18982.$tcGADT1 0# GHC.Types.krep$*Arr*
    122 
    +T18982.$tcGADT :: GHC.Internal.Types.TyCon
    123 
    +T18982.$tcGADT = GHC.Internal.Types.TyCon 9243924476135839950#Word64 5096619276488416461#Word64 T18982.$trModule $tcGADT2 0# GHC.Internal.Types.krep$*Arr*
    136 124
    137 125 
     -- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
    138 
    -$krep8 :: [GHC.Types.KindRep]
    139 
    -$krep8 = GHC.Types.: @GHC.Types.KindRep $krep (GHC.Types.[] @GHC.Types.KindRep)
    126 
    +$krep10 :: [GHC.Internal.Types.KindRep]
    127 
    +$krep10 = GHC.Internal.Types.: @GHC.Internal.Types.KindRep $krep (GHC.Internal.Types.[] @GHC.Internal.Types.KindRep)
    140 128
    141 129 
     -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
    142 
    -$krep9 :: GHC.Types.KindRep
    143 
    -$krep9 = GHC.Types.KindRepTyConApp T18982.$tcGADT $krep8
    130 
    +$krep11 :: GHC.Internal.Types.KindRep
    131 
    +$krep11 = GHC.Internal.Types.KindRepTyConApp T18982.$tcGADT $krep10
    144 132
    145 133 
     -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
    146 
    -T18982.$tc'GADT1 :: GHC.Types.KindRep
    147 
    -T18982.$tc'GADT1 = GHC.Types.KindRepFun $krep $krep9
    134 
    +$krep12 :: GHC.Internal.Types.KindRep
    135 
    +$krep12 = GHC.Internal.Types.KindRepFun $krep $krep11
    148 136
    149 137 
     -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
    150 
    -T18982.$tc'GADT3 :: GHC.Prim.Addr#
    151 
    -T18982.$tc'GADT3 = "'GADT"#
    138 
    +$tc'GADT1 :: GHC.Internal.Prim.Addr#
    139 
    +$tc'GADT1 = "'GADT"#
    152 140
    153 141 
     -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
    154 
    -T18982.$tc'GADT2 :: GHC.Types.TrName
    155 
    -T18982.$tc'GADT2 = GHC.Types.TrNameS T18982.$tc'GADT3
    142 
    +$tc'GADT2 :: GHC.Internal.Types.TrName
    143 
    +$tc'GADT2 = GHC.Internal.Types.TrNameS $tc'GADT1
    156 144
    157 145 
     -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
    158 
    -T18982.$tc'GADT :: GHC.Types.TyCon
    159 
    -T18982.$tc'GADT = GHC.Types.TyCon 2077850259354179864#Word64 16731205864486799217#Word64 T18982.$trModule T18982.$tc'GADT2 0# T18982.$tc'GADT1
    146 
    +T18982.$tc'GADT :: GHC.Internal.Types.TyCon
    147 
    +T18982.$tc'GADT = GHC.Internal.Types.TyCon 2077850259354179864#Word64 16731205864486799217#Word64 T18982.$trModule $tc'GADT2 0# $krep12
    160 148
    161 149 
     -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
    162 
    -T18982.$tcExGADT2 :: GHC.Prim.Addr#
    163 
    -T18982.$tcExGADT2 = "ExGADT"#
    150 
    +$tcExGADT1 :: GHC.Internal.Prim.Addr#
    151 
    +$tcExGADT1 = "ExGADT"#
    164 152
    165 153 
     -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
    166 
    -T18982.$tcExGADT1 :: GHC.Types.TrName
    167 
    -T18982.$tcExGADT1 = GHC.Types.TrNameS T18982.$tcExGADT2
    154 
    +$tcExGADT2 :: GHC.Internal.Types.TrName
    155 
    +$tcExGADT2 = GHC.Internal.Types.TrNameS $tcExGADT1
    168 156
    169 157 
     -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
    170 
    -T18982.$tcExGADT :: GHC.Types.TyCon
    171 
    -T18982.$tcExGADT = GHC.Types.TyCon 6470898418160489500#Word64 10361108917441214060#Word64 T18982.$trModule T18982.$tcExGADT1 0# GHC.Types.krep$*Arr*
    158 
    +T18982.$tcExGADT :: GHC.Internal.Types.TyCon
    159 
    +T18982.$tcExGADT = GHC.Internal.Types.TyCon 6470898418160489500#Word64 10361108917441214060#Word64 T18982.$trModule $tcExGADT2 0# GHC.Internal.Types.krep$*Arr*
    172 160
    173 161 
     -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
    174 
    -$krep10 :: GHC.Types.KindRep
    175 
    -$krep10 = GHC.Types.KindRepTyConApp T18982.$tcExGADT $krep8
    162 
    +$krep13 :: GHC.Internal.Types.KindRep
    163 
    +$krep13 = GHC.Internal.Types.KindRepTyConApp T18982.$tcExGADT $krep10
    176 164
    177 165 
     -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
    178 
    -$krep11 :: GHC.Types.KindRep
    179 
    -$krep11 = GHC.Types.KindRepFun $krep $krep10
    166 
    +$krep14 :: GHC.Internal.Types.KindRep
    167 
    +$krep14 = GHC.Internal.Types.KindRepFun $krep $krep13
    180 168
    181 169 
     -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
    182 
    -T18982.$tc'ExGADT1 :: GHC.Types.KindRep
    183 
    -T18982.$tc'ExGADT1 = GHC.Types.KindRepFun $krep2 $krep11
    170 
    +$krep15 :: GHC.Internal.Types.KindRep
    171 
    +$krep15 = GHC.Internal.Types.KindRepFun $krep2 $krep14
    184 172
    185 173 
     -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
    186 
    -T18982.$tc'ExGADT3 :: GHC.Prim.Addr#
    187 
    -T18982.$tc'ExGADT3 = "'ExGADT"#
    174 
    +$tc'ExGADT1 :: GHC.Internal.Prim.Addr#
    175 
    +$tc'ExGADT1 = "'ExGADT"#
    188 176
    189 177 
     -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
    190 
    -T18982.$tc'ExGADT2 :: GHC.Types.TrName
    191 
    -T18982.$tc'ExGADT2 = GHC.Types.TrNameS T18982.$tc'ExGADT3
    178 
    +$tc'ExGADT2 :: GHC.Internal.Types.TrName
    179 
    +$tc'ExGADT2 = GHC.Internal.Types.TrNameS $tc'ExGADT1
    192 180
    193 181 
     -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
    194 
    -T18982.$tc'ExGADT :: GHC.Types.TyCon
    195 
    -T18982.$tc'ExGADT = GHC.Types.TyCon 8468257409157161049#Word64 5503123603717080600#Word64 T18982.$trModule T18982.$tc'ExGADT2 1# T18982.$tc'ExGADT1
    182 
    +T18982.$tc'ExGADT :: GHC.Internal.Types.TyCon
    183 
    +T18982.$tc'ExGADT = GHC.Internal.Types.TyCon 8468257409157161049#Word64 5503123603717080600#Word64 T18982.$trModule $tc'ExGADT2 1# $krep15
    196 184
    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# }
    185 
    +-- RHS size: {terms: 12, types: 14, coercions: 0, joins: 0/0}
    186 
    +T18982.$wi :: forall a e. (a GHC.Internal.Prim.~# Int, e ~ Int) => e -> GHC.Internal.Prim.Int# -> GHC.Internal.Prim.Int#
    187 
    +T18982.$wi = \ (@a) (@e) (ww :: a GHC.Internal.Prim.~# Int) (ww1 :: e ~ Int) (ww2 :: e) (ww3 :: GHC.Internal.Prim.Int#) -> case ww2 of { __DEFAULT -> GHC.Internal.Prim.+# ww3 1# }
    200 188
    201 
    --- RHS size: {terms: 15, types: 22, coercions: 1, joins: 0/0}
    189 
    +-- RHS size: {terms: 16, types: 22, coercions: 1, joins: 0/0}
    202 190 
     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 } } }
    191 
    +i = \ (@a) (ds :: ExGADT a) -> case ds of { ExGADT @e ww ww1 ww2 ww3 -> case ww3 of { GHC.Internal.Types.I# ww4 -> case T18982.$wi @a @e @~(ww :: a GHC.Internal.Prim.~# Int) ww1 ww2 ww4 of ww5 { __DEFAULT -> GHC.Internal.Types.I# ww5 } } }
    204 192
    205 193 
     -- RHS size: {terms: 6, types: 7, coercions: 0, joins: 0/0}
    206 194 
     T18982.$wh :: forall a. (a GHC.Prim.~# Int) => GHC.Prim.Int# -> GHC.Prim.Int#

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