GitLab

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC

Commits:

eb1dcd4d

by sheaf at 2026-08-07T17:50:40-04:00

mkWpFun_FRR: fix ordering of coercion composition

When the subsumption machinery generates an eta-expansion, we must
perform a representation polymorphism check to ensure the lambda binder
it introduces has a fixed runtime representation.
This is done in GHC.Tc.Utils.mkWpFun_FRR.

This check involves composing quite a few coercions, arising from
representation-polymorphism checks on both the actual and expected
argument types. These coercions are then chained using HsWrapper
composition, <.>. The ordering of composition was incorrect, leading to
the Core Lint failure reported in #27639. This commit fixes that.

Fixes #27639

4 changed files:

+ changelog.d/T27639
compiler/GHC/Tc/Utils/Unify.hs
+ testsuite/tests/rep-poly/T27639.hs
testsuite/tests/rep-poly/all.T

Changes:

changelog.d/T27639

 +section: compiler
 +issues: #27639
 +mrs: !16474
 +synopsis:
 +  Stop representation-polymorphism checks from producing a coercion that fails
 +  Core Lint.
 +description:
 +  The representation-polymorphism check that is done when subsumption performs
 +  eta-expansion now composes the coercions it builds in the correct order,
 +  avoiding a Core Lint failure.

compiler/GHC/Tc/Utils/Unify.hs

@@ -2359,7 +2359,7 @@ mkWpFun_FRR (mb_tc_fun, pos) sub_mult act_af act_mult act_arg act_res exp_af exp
                   act_arg_co
                   (mkNomReflCo act_res)
              arg_wrap_frr =    -- exp_arg_frr ~~> act_arg_frr
 -              mkWpCastN (mkSymCo exp_arg_co) <.> arg_wrap <.> mkWpCastN act_arg_co
 +              mkWpCastN act_arg_co <.> arg_wrap <.> mkWpCastN (mkSymCo exp_arg_co)
         ; traceTc "mkWpFun_FRR: WpFun" $
             vcat [ text "act_mult:" <+> ppr act_mult

testsuite/tests/rep-poly/T27639.hs

 +{-# LANGUAGE DeepSubsumption, RankNTypes, PolyKinds, DataKinds, GADTs, TypeOperators, ScopedTypeVariables #-}
 +module T27639 where
++
 +import GHC.Exts
 +import Data.Type.Equality
++
 +h :: forall r (a :: TYPE r) (b :: TYPE r).
 +     (r :~: LiftedRep) -> (a :~: b) -> ()
 +h Refl Refl =
 +  let
 +    v :: a -> (Int -> Int) -> Int
 +    v = undefined
 +    u :: b -> (forall c. c -> c) -> Int
 +    u = v
 +  in ()

testsuite/tests/rep-poly/all.T

@@ -43,6 +43,7 @@ test('T23883c', normal, compile_fail, [''])
  test('T23903', normal, compile_fail, [''])
  test('T26107', js_broken(22364), compile, ['-O'])
  test('T26528', normal, compile, [''])
 +test('T27639', normal, compile, [''])
  test('EtaExpandDataCon', normal, compile, ['-O'])
  test('EtaExpandStupid1', normal, compile, ['-Wno-deprecated-flags'])