diff options
| author | Richard Eisenberg <eir@cis.upenn.edu> | 2015-12-17 12:18:47 +0100 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2015-12-17 12:54:33 +0100 |
| commit | cab131624ad0cdd54e2f3a70f93c1bd574ccf102 (patch) | |
| tree | c0058089855525ff94e5b1a1f41e78166ecb5b16 | |
| parent | 4f870f8481b2611619adf66d61eff06f02e3741f (diff) | |
| download | haskell-cab131624ad0cdd54e2f3a70f93c1bd574ccf102.tar.gz | |
Fix #11232.
I somehow forgot to propagate roles into UnivCos. Very
simple fix, happily.
Test Plan: simplCore/should_compile/T11232
Reviewers: bgamari, austin, simonpj
Reviewed By: simonpj
Subscribers: simonpj, thomie
Differential Revision: https://phabricator.haskell.org/D1645
GHC Trac Issues: #11232
| -rw-r--r-- | compiler/types/OptCoercion.hs | 37 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/T11232.hs | 15 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/all.T | 1 |
3 files changed, 36 insertions, 17 deletions
diff --git a/compiler/types/OptCoercion.hs b/compiler/types/OptCoercion.hs index f68bc8cb04..436b16ad4d 100644 --- a/compiler/types/OptCoercion.hs +++ b/compiler/types/OptCoercion.hs @@ -87,21 +87,24 @@ optCoercion :: TCvSubst -> Coercion -> NormalCo -- *and* optimises it to reduce its size optCoercion env co | opt_NoOptCoercion = substCo env co - | debugIsOn = let out_co = opt_co1 lc False co - Pair in_ty1 in_ty2 = coercionKind co - Pair out_ty1 out_ty2 = coercionKind out_co - in - ASSERT2( substTy env in_ty1 `eqType` out_ty1 && - substTy env in_ty2 `eqType` out_ty2 - , text "optCoercion changed types!" - $$ hang (text "in_co:") 2 (ppr co) - $$ hang (text "in_ty1:") 2 (ppr in_ty1) - $$ hang (text "in_ty2:") 2 (ppr in_ty2) - $$ hang (text "out_co:") 2 (ppr out_co) - $$ hang (text "out_ty1:") 2 (ppr out_ty1) - $$ hang (text "out_ty2:") 2 (ppr out_ty2) - $$ hang (text "subst:") 2 (ppr env) ) - out_co + | debugIsOn + = let out_co = opt_co1 lc False co + (Pair in_ty1 in_ty2, in_role) = coercionKindRole co + (Pair out_ty1 out_ty2, out_role) = coercionKindRole out_co + in + ASSERT2( substTy env in_ty1 `eqType` out_ty1 && + substTy env in_ty2 `eqType` out_ty2 && + in_role == out_role + , text "optCoercion changed types!" + $$ hang (text "in_co:") 2 (ppr co) + $$ hang (text "in_ty1:") 2 (ppr in_ty1) + $$ hang (text "in_ty2:") 2 (ppr in_ty2) + $$ hang (text "out_co:") 2 (ppr out_co) + $$ hang (text "out_ty1:") 2 (ppr out_ty1) + $$ hang (text "out_ty2:") 2 (ppr out_ty2) + $$ hang (text "subst:") 2 (ppr env) ) + out_co + | otherwise = opt_co1 lc False co where lc = mkSubstLiftingContext env @@ -230,9 +233,9 @@ opt_co4 env sym rep r (AxiomInstCo con ind cos) cos) -- Note that the_co does *not* have sym pushed into it -opt_co4 env sym _ r (UnivCo prov _r t1 t2) +opt_co4 env sym rep r (UnivCo prov _r t1 t2) = ASSERT( r == _r ) - opt_univ env sym prov r t1 t2 + opt_univ env sym prov (chooseRole rep r) t1 t2 opt_co4 env sym rep r (TransCo co1 co2) -- sym (g `o` h) = sym h `o` sym g diff --git a/testsuite/tests/simplCore/should_compile/T11232.hs b/testsuite/tests/simplCore/should_compile/T11232.hs new file mode 100644 index 0000000000..5b98d3988c --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T11232.hs @@ -0,0 +1,15 @@ +module T11232 where + +import Control.Monad +import Data.Data + +mkMp :: ( MonadPlus m + , Typeable a + , Typeable b + ) + => (b -> m b) + -> a + -> m a +mkMp ext = unM (maybe (M (const mzero)) id (gcast (M ext))) + +newtype M m x = M { unM :: x -> m x } diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index f9388c92ba..2ea15f6f60 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -228,3 +228,4 @@ test('T11155', normal, run_command, ['$MAKE -s --no-print-directory T11155']) +test('T11232', normal, compile, ['-O2']) |