3de51c36c0dede1c12eef20b67a445ef8a7f00e9
[ghc.git] / compiler / types / OptCoercion.hs
1 -- (c) The University of Glasgow 2006
2
3 {-# LANGUAGE CPP #-}
4
5 -- The default iteration limit is a bit too low for the definitions
6 -- in this module.
7 {-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-}
8
9 module OptCoercion ( optCoercion, checkAxInstCo ) where
10
11 #include "HsVersions.h"
12
13 import GhcPrelude
14
15 import DynFlags
16 import TyCoRep
17 import Coercion
18 import Type hiding( substTyVarBndr, substTy )
19 import TcType ( exactTyCoVarsOfType )
20 import TyCon
21 import CoAxiom
22 import VarSet
23 import VarEnv
24 import Outputable
25 import FamInstEnv ( flattenTys )
26 import Pair
27 import ListSetOps ( getNth )
28 import Util
29 import Unify
30 import InstEnv
31 import Control.Monad ( zipWithM )
32
33 {-
34 %************************************************************************
35 %* *
36 Optimising coercions
37 %* *
38 %************************************************************************
39
40 Note [Optimising coercion optimisation]
41 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
42 Looking up a coercion's role or kind is linear in the size of the
43 coercion. Thus, doing this repeatedly during the recursive descent
44 of coercion optimisation is disastrous. We must be careful to avoid
45 doing this if at all possible.
46
47 Because it is generally easy to know a coercion's components' roles
48 from the role of the outer coercion, we pass down the known role of
49 the input in the algorithm below. We also keep functions opt_co2
50 and opt_co3 separate from opt_co4, so that the former two do Phantom
51 checks that opt_co4 can avoid. This is a big win because Phantom coercions
52 rarely appear within non-phantom coercions -- only in some TyConAppCos
53 and some AxiomInstCos. We handle these cases specially by calling
54 opt_co2.
55
56 Note [Optimising InstCo]
57 ~~~~~~~~~~~~~~~~~~~~~~~~
58 When we have (InstCo (ForAllCo tv h g) g2), we want to optimise.
59
60 Let's look at the typing rules.
61
62 h : k1 ~ k2
63 tv:k1 |- g : t1 ~ t2
64 -----------------------------
65 ForAllCo tv h g : (all tv:k1.t1) ~ (all tv:k2.t2[tv |-> tv |> sym h])
66
67 g1 : (all tv:k1.t1') ~ (all tv:k2.t2')
68 g2 : s1 ~ s2
69 --------------------
70 InstCo g1 g2 : t1'[tv |-> s1] ~ t2'[tv |-> s2]
71
72 We thus want some coercion proving this:
73
74 (t1[tv |-> s1]) ~ (t2[tv |-> s2 |> sym h])
75
76 If we substitute the *type* tv for the *coercion*
77 (g2 `mkCoherenceRightCo` sym h) in g, we'll get this result exactly.
78 This is bizarre,
79 though, because we're substituting a type variable with a coercion. However,
80 this operation already exists: it's called *lifting*, and defined in Coercion.
81 We just need to enhance the lifting operation to be able to deal with
82 an ambient substitution, which is why a LiftingContext stores a TCvSubst.
83
84 -}
85
86 optCoercion :: TCvSubst -> Coercion -> NormalCo
87 -- ^ optCoercion applies a substitution to a coercion,
88 -- *and* optimises it to reduce its size
89 optCoercion env co
90 | hasNoOptCoercion unsafeGlobalDynFlags = substCo env co
91 | debugIsOn
92 = let out_co = opt_co1 lc False co
93 (Pair in_ty1 in_ty2, in_role) = coercionKindRole co
94 (Pair out_ty1 out_ty2, out_role) = coercionKindRole out_co
95 in
96 ASSERT2( substTy env in_ty1 `eqType` out_ty1 &&
97 substTy env in_ty2 `eqType` out_ty2 &&
98 in_role == out_role
99 , text "optCoercion changed types!"
100 $$ hang (text "in_co:") 2 (ppr co)
101 $$ hang (text "in_ty1:") 2 (ppr in_ty1)
102 $$ hang (text "in_ty2:") 2 (ppr in_ty2)
103 $$ hang (text "out_co:") 2 (ppr out_co)
104 $$ hang (text "out_ty1:") 2 (ppr out_ty1)
105 $$ hang (text "out_ty2:") 2 (ppr out_ty2)
106 $$ hang (text "subst:") 2 (ppr env) )
107 out_co
108
109 | otherwise = opt_co1 lc False co
110 where
111 lc = mkSubstLiftingContext env
112
113 type NormalCo = Coercion
114 -- Invariants:
115 -- * The substitution has been fully applied
116 -- * For trans coercions (co1 `trans` co2)
117 -- co1 is not a trans, and neither co1 nor co2 is identity
118
119 type NormalNonIdCo = NormalCo -- Extra invariant: not the identity
120
121 -- | Do we apply a @sym@ to the result?
122 type SymFlag = Bool
123
124 -- | Do we force the result to be representational?
125 type ReprFlag = Bool
126
127 -- | Optimize a coercion, making no assumptions. All coercions in
128 -- the lifting context are already optimized (and sym'd if nec'y)
129 opt_co1 :: LiftingContext
130 -> SymFlag
131 -> Coercion -> NormalCo
132 opt_co1 env sym co = opt_co2 env sym (coercionRole co) co
133
134 -- See Note [Optimising coercion optimisation]
135 -- | Optimize a coercion, knowing the coercion's role. No other assumptions.
136 opt_co2 :: LiftingContext
137 -> SymFlag
138 -> Role -- ^ The role of the input coercion
139 -> Coercion -> NormalCo
140 opt_co2 env sym Phantom co = opt_phantom env sym co
141 opt_co2 env sym r co = opt_co3 env sym Nothing r co
142
143 -- See Note [Optimising coercion optimisation]
144 -- | Optimize a coercion, knowing the coercion's non-Phantom role.
145 opt_co3 :: LiftingContext -> SymFlag -> Maybe Role -> Role -> Coercion -> NormalCo
146 opt_co3 env sym (Just Phantom) _ co = opt_phantom env sym co
147 opt_co3 env sym (Just Representational) r co = opt_co4_wrap env sym True r co
148 -- if mrole is Just Nominal, that can't be a downgrade, so we can ignore
149 opt_co3 env sym _ r co = opt_co4_wrap env sym False r co
150
151 -- See Note [Optimising coercion optimisation]
152 -- | Optimize a non-phantom coercion.
153 opt_co4, opt_co4_wrap :: LiftingContext -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo
154
155 opt_co4_wrap = opt_co4
156 {-
157 opt_co4_wrap env sym rep r co
158 = pprTrace "opt_co4_wrap {"
159 ( vcat [ text "Sym:" <+> ppr sym
160 , text "Rep:" <+> ppr rep
161 , text "Role:" <+> ppr r
162 , text "Co:" <+> ppr co ]) $
163 ASSERT( r == coercionRole co )
164 let result = opt_co4 env sym rep r co in
165 pprTrace "opt_co4_wrap }" (ppr co $$ text "---" $$ ppr result) $
166 result
167 -}
168
169 opt_co4 env _ rep r (Refl _r ty)
170 = ASSERT2( r == _r, text "Expected role:" <+> ppr r $$
171 text "Found role:" <+> ppr _r $$
172 text "Type:" <+> ppr ty )
173 liftCoSubst (chooseRole rep r) env ty
174
175 opt_co4 env sym rep r (SymCo co) = opt_co4_wrap env (not sym) rep r co
176 -- surprisingly, we don't have to do anything to the env here. This is
177 -- because any "lifting" substitutions in the env are tied to ForAllCos,
178 -- which treat their left and right sides differently. We don't want to
179 -- exchange them.
180
181 opt_co4 env sym rep r g@(TyConAppCo _r tc cos)
182 = ASSERT( r == _r )
183 case (rep, r) of
184 (True, Nominal) ->
185 mkTyConAppCo Representational tc
186 (zipWith3 (opt_co3 env sym)
187 (map Just (tyConRolesRepresentational tc))
188 (repeat Nominal)
189 cos)
190 (False, Nominal) ->
191 mkTyConAppCo Nominal tc (map (opt_co4_wrap env sym False Nominal) cos)
192 (_, Representational) ->
193 -- must use opt_co2 here, because some roles may be P
194 -- See Note [Optimising coercion optimisation]
195 mkTyConAppCo r tc (zipWith (opt_co2 env sym)
196 (tyConRolesRepresentational tc) -- the current roles
197 cos)
198 (_, Phantom) -> pprPanic "opt_co4 sees a phantom!" (ppr g)
199
200 opt_co4 env sym rep r (AppCo co1 co2)
201 = mkAppCo (opt_co4_wrap env sym rep r co1)
202 (opt_co4_wrap env sym False Nominal co2)
203
204 opt_co4 env sym rep r (ForAllCo tv k_co co)
205 = case optForAllCoBndr env sym tv k_co of
206 (env', tv', k_co') -> mkForAllCo tv' k_co' $
207 opt_co4_wrap env' sym rep r co
208 -- Use the "mk" functions to check for nested Refls
209
210 opt_co4 env sym rep r (FunCo _r co1 co2)
211 = ASSERT( r == _r )
212 if rep
213 then mkFunCo Representational co1' co2'
214 else mkFunCo r co1' co2'
215 where
216 co1' = opt_co4_wrap env sym rep r co1
217 co2' = opt_co4_wrap env sym rep r co2
218
219 opt_co4 env sym rep r (CoVarCo cv)
220 | Just co <- lookupCoVar (lcTCvSubst env) cv
221 = opt_co4_wrap (zapLiftingContext env) sym rep r co
222
223 | ty1 `eqType` ty2 -- See Note [Optimise CoVarCo to Refl]
224 = Refl (chooseRole rep r) ty1
225
226 | otherwise
227 = ASSERT( isCoVar cv1 )
228 wrapRole rep r $ wrapSym sym $
229 CoVarCo cv1
230
231 where
232 Pair ty1 ty2 = coVarTypes cv1
233
234 cv1 = case lookupInScope (lcInScopeSet env) cv of
235 Just cv1 -> cv1
236 Nothing -> WARN( True, text "opt_co: not in scope:"
237 <+> ppr cv $$ ppr env)
238 cv
239 -- cv1 might have a substituted kind!
240
241 opt_co4 _ _ _ _ (HoleCo h)
242 = pprPanic "opt_univ fell into a hole" (ppr h)
243
244 opt_co4 env sym rep r (AxiomInstCo con ind cos)
245 -- Do *not* push sym inside top-level axioms
246 -- e.g. if g is a top-level axiom
247 -- g a : f a ~ a
248 -- then (sym (g ty)) /= g (sym ty) !!
249 = ASSERT( r == coAxiomRole con )
250 wrapRole rep (coAxiomRole con) $
251 wrapSym sym $
252 -- some sub-cos might be P: use opt_co2
253 -- See Note [Optimising coercion optimisation]
254 AxiomInstCo con ind (zipWith (opt_co2 env False)
255 (coAxBranchRoles (coAxiomNthBranch con ind))
256 cos)
257 -- Note that the_co does *not* have sym pushed into it
258
259 opt_co4 env sym rep r (UnivCo prov _r t1 t2)
260 = ASSERT( r == _r )
261 opt_univ env sym prov (chooseRole rep r) t1 t2
262
263 opt_co4 env sym rep r (TransCo co1 co2)
264 -- sym (g `o` h) = sym h `o` sym g
265 | sym = opt_trans in_scope co2' co1'
266 | otherwise = opt_trans in_scope co1' co2'
267 where
268 co1' = opt_co4_wrap env sym rep r co1
269 co2' = opt_co4_wrap env sym rep r co2
270 in_scope = lcInScopeSet env
271
272
273 opt_co4 env sym rep r co@(NthCo {})
274 = opt_nth_co env sym rep r co
275
276 opt_co4 env sym rep r (LRCo lr co)
277 | Just pr_co <- splitAppCo_maybe co
278 = ASSERT( r == Nominal )
279 opt_co4_wrap env sym rep Nominal (pick_lr lr pr_co)
280 | Just pr_co <- splitAppCo_maybe co'
281 = ASSERT( r == Nominal )
282 if rep
283 then opt_co4_wrap (zapLiftingContext env) False True Nominal (pick_lr lr pr_co)
284 else pick_lr lr pr_co
285 | otherwise
286 = wrapRole rep Nominal $ LRCo lr co'
287 where
288 co' = opt_co4_wrap env sym False Nominal co
289
290 pick_lr CLeft (l, _) = l
291 pick_lr CRight (_, r) = r
292
293 -- See Note [Optimising InstCo]
294 opt_co4 env sym rep r (InstCo co1 arg)
295 -- forall over type...
296 | Just (tv, kind_co, co_body) <- splitForAllCo_maybe co1
297 = opt_co4_wrap (extendLiftingContext env tv
298 (arg' `mkCoherenceRightCo` mkSymCo kind_co))
299 sym rep r co_body
300
301 -- See if it is a forall after optimization
302 -- If so, do an inefficient one-variable substitution, then re-optimize
303
304 -- forall over type...
305 | Just (tv', kind_co', co_body') <- splitForAllCo_maybe co1'
306 = opt_co4_wrap (extendLiftingContext (zapLiftingContext env) tv'
307 (arg' `mkCoherenceRightCo` mkSymCo kind_co'))
308 False False r' co_body'
309
310 | otherwise = InstCo co1' arg'
311 where
312 co1' = opt_co4_wrap env sym rep r co1
313 r' = chooseRole rep r
314 arg' = opt_co4_wrap env sym False Nominal arg
315
316 opt_co4 env sym rep r (CoherenceCo co1 co2)
317 | TransCo col1 cor1 <- co1
318 = opt_co4_wrap env sym rep r (mkTransCo (mkCoherenceCo col1 co2) cor1)
319
320 | TransCo col1' cor1' <- co1'
321 = if sym then opt_trans in_scope col1'
322 (optCoercion (zapTCvSubst (lcTCvSubst env))
323 (mkCoherenceRightCo cor1' co2'))
324 else opt_trans in_scope (mkCoherenceCo col1' co2') cor1'
325
326 | otherwise
327 = wrapSym sym $ mkCoherenceCo (opt_co4_wrap env False rep r co1) co2'
328 where co1' = opt_co4_wrap env sym rep r co1
329 co2' = opt_co4_wrap env False False Nominal co2
330 in_scope = lcInScopeSet env
331
332 opt_co4 env sym _rep r (KindCo co)
333 = ASSERT( r == Nominal )
334 let kco' = promoteCoercion co in
335 case kco' of
336 KindCo co' -> promoteCoercion (opt_co1 env sym co')
337 _ -> opt_co4_wrap env sym False Nominal kco'
338 -- This might be able to be optimized more to do the promotion
339 -- and substitution/optimization at the same time
340
341 opt_co4 env sym _ r (SubCo co)
342 = ASSERT( r == Representational )
343 opt_co4_wrap env sym True Nominal co
344
345 -- This could perhaps be optimized more.
346 opt_co4 env sym rep r (AxiomRuleCo co cs)
347 = ASSERT( r == coaxrRole co )
348 wrapRole rep r $
349 wrapSym sym $
350 AxiomRuleCo co (zipWith (opt_co2 env False) (coaxrAsmpRoles co) cs)
351
352 {- Note [Optimise CoVarCo to Refl]
353 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
354 If we have (c :: t~t) we can optimise it to Refl. That increases the
355 chances of floating the Refl upwards; e.g. Maybe c --> Refl (Maybe t)
356
357 We do so here in optCoercion, not in mkCoVarCo; see Note [mkCoVarCo]
358 in Coercion.
359 -}
360
361 -------------
362 -- | Optimize a phantom coercion. The input coercion may not necessarily
363 -- be a phantom, but the output sure will be.
364 opt_phantom :: LiftingContext -> SymFlag -> Coercion -> NormalCo
365 opt_phantom env sym co
366 = opt_univ env sym (PhantomProv (mkKindCo co)) Phantom ty1 ty2
367 where
368 Pair ty1 ty2 = coercionKind co
369
370 {- Note [Differing kinds]
371 ~~~~~~~~~~~~~~~~~~~~~~
372 The two types may not have the same kind (although that would be very unusual).
373 But even if they have the same kind, and the same type constructor, the number
374 of arguments in a `CoTyConApp` can differ. Consider
375
376 Any :: forall k. k
377
378 Any * Int :: *
379 Any (*->*) Maybe Int :: *
380
381 Hence the need to compare argument lengths; see Trac #13658
382 -}
383
384 opt_univ :: LiftingContext -> SymFlag -> UnivCoProvenance -> Role
385 -> Type -> Type -> Coercion
386 opt_univ env sym (PhantomProv h) _r ty1 ty2
387 | sym = mkPhantomCo h' ty2' ty1'
388 | otherwise = mkPhantomCo h' ty1' ty2'
389 where
390 h' = opt_co4 env sym False Nominal h
391 ty1' = substTy (lcSubstLeft env) ty1
392 ty2' = substTy (lcSubstRight env) ty2
393
394 opt_univ env sym prov role oty1 oty2
395 | Just (tc1, tys1) <- splitTyConApp_maybe oty1
396 , Just (tc2, tys2) <- splitTyConApp_maybe oty2
397 , tc1 == tc2
398 , equalLength tys1 tys2 -- see Note [Differing kinds]
399 -- NB: prov must not be the two interesting ones (ProofIrrel & Phantom);
400 -- Phantom is already taken care of, and ProofIrrel doesn't relate tyconapps
401 = let roles = tyConRolesX role tc1
402 arg_cos = zipWith3 (mkUnivCo prov) roles tys1 tys2
403 arg_cos' = zipWith (opt_co4 env sym False) roles arg_cos
404 in
405 mkTyConAppCo role tc1 arg_cos'
406
407 -- can't optimize the AppTy case because we can't build the kind coercions.
408
409 | Just (tv1, ty1) <- splitForAllTy_maybe oty1
410 , Just (tv2, ty2) <- splitForAllTy_maybe oty2
411 -- NB: prov isn't interesting here either
412 = let k1 = tyVarKind tv1
413 k2 = tyVarKind tv2
414 eta = mkUnivCo prov Nominal k1 k2
415 -- eta gets opt'ed soon, but not yet.
416 ty2' = substTyWith [tv2] [TyVarTy tv1 `mkCastTy` eta] ty2
417
418 (env', tv1', eta') = optForAllCoBndr env sym tv1 eta
419 in
420 mkForAllCo tv1' eta' (opt_univ env' sym prov role ty1 ty2')
421
422 | otherwise
423 = let ty1 = substTyUnchecked (lcSubstLeft env) oty1
424 ty2 = substTyUnchecked (lcSubstRight env) oty2
425 (a, b) | sym = (ty2, ty1)
426 | otherwise = (ty1, ty2)
427 in
428 mkUnivCo prov' role a b
429
430 where
431 prov' = case prov of
432 UnsafeCoerceProv -> prov
433 PhantomProv kco -> PhantomProv $ opt_co4_wrap env sym False Nominal kco
434 ProofIrrelProv kco -> ProofIrrelProv $ opt_co4_wrap env sym False Nominal kco
435 PluginProv _ -> prov
436
437 -------------
438 -- NthCo must be handled separately, because it's the one case where we can't
439 -- tell quickly what the component coercion's role is from the containing
440 -- coercion. To avoid repeated coercionRole calls as opt_co1 calls opt_co2,
441 -- we just look for nested NthCo's, which can happen in practice.
442 opt_nth_co :: LiftingContext -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo
443 opt_nth_co env sym rep r = go []
444 where
445 go ns (NthCo n co) = go (n:ns) co
446 -- previous versions checked if the tycon is decomposable. This
447 -- is redundant, because a non-decomposable tycon under an NthCo
448 -- is entirely bogus. See docs/core-spec/core-spec.pdf.
449 go ns co
450 = opt_nths ns co
451
452 -- try to resolve 1 Nth
453 push_nth n (Refl r1 ty)
454 | Just (tc, args) <- splitTyConApp_maybe ty
455 = Just (Refl (nthRole r1 tc n) (args `getNth` n))
456 | n == 0
457 , Just (tv, _) <- splitForAllTy_maybe ty
458 = Just (Refl Nominal (tyVarKind tv))
459 push_nth n (TyConAppCo _ _ cos)
460 = Just (cos `getNth` n)
461 push_nth 0 (ForAllCo _ eta _)
462 = Just eta
463 push_nth _ _ = Nothing
464
465 -- input coercion is *not* yet sym'd or opt'd
466 opt_nths [] co = opt_co4_wrap env sym rep r co
467 opt_nths (n:ns) co
468 | Just co' <- push_nth n co
469 = opt_nths ns co'
470
471 -- here, the co isn't a TyConAppCo, so we opt it, hoping to get
472 -- a TyConAppCo as output. We don't know the role, so we use
473 -- opt_co1. This is slightly annoying, because opt_co1 will call
474 -- coercionRole, but as long as we don't have a long chain of
475 -- NthCo's interspersed with some other coercion former, we should
476 -- be OK.
477 opt_nths ns co = opt_nths' ns (opt_co1 env sym co)
478
479 -- input coercion *is* sym'd and opt'd
480 opt_nths' [] co
481 = if rep && (r == Nominal)
482 -- propagate the SubCo:
483 then opt_co4_wrap (zapLiftingContext env) False True r co
484 else co
485 opt_nths' (n:ns) co
486 | Just co' <- push_nth n co
487 = opt_nths' ns co'
488 opt_nths' ns co = wrapRole rep r (mk_nths ns co)
489
490 mk_nths [] co = co
491 mk_nths (n:ns) co = mk_nths ns (mkNthCo n co)
492
493 -------------
494 opt_transList :: InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo]
495 opt_transList is = zipWith (opt_trans is)
496
497 opt_trans :: InScopeSet -> NormalCo -> NormalCo -> NormalCo
498 opt_trans is co1 co2
499 | isReflCo co1 = co2
500 | otherwise = opt_trans1 is co1 co2
501
502 opt_trans1 :: InScopeSet -> NormalNonIdCo -> NormalCo -> NormalCo
503 -- First arg is not the identity
504 opt_trans1 is co1 co2
505 | isReflCo co2 = co1
506 | otherwise = opt_trans2 is co1 co2
507
508 opt_trans2 :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> NormalCo
509 -- Neither arg is the identity
510 opt_trans2 is (TransCo co1a co1b) co2
511 -- Don't know whether the sub-coercions are the identity
512 = opt_trans is co1a (opt_trans is co1b co2)
513
514 opt_trans2 is co1 co2
515 | Just co <- opt_trans_rule is co1 co2
516 = co
517
518 opt_trans2 is co1 (TransCo co2a co2b)
519 | Just co1_2a <- opt_trans_rule is co1 co2a
520 = if isReflCo co1_2a
521 then co2b
522 else opt_trans1 is co1_2a co2b
523
524 opt_trans2 _ co1 co2
525 = mkTransCo co1 co2
526
527 ------
528 -- Optimize coercions with a top-level use of transitivity.
529 opt_trans_rule :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo
530
531 -- Push transitivity through matching destructors
532 opt_trans_rule is in_co1@(NthCo d1 co1) in_co2@(NthCo d2 co2)
533 | d1 == d2
534 , co1 `compatible_co` co2
535 = fireTransRule "PushNth" in_co1 in_co2 $
536 mkNthCo d1 (opt_trans is co1 co2)
537
538 opt_trans_rule is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2)
539 | d1 == d2
540 , co1 `compatible_co` co2
541 = fireTransRule "PushLR" in_co1 in_co2 $
542 mkLRCo d1 (opt_trans is co1 co2)
543
544 -- Push transitivity inside instantiation
545 opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2)
546 | ty1 `eqCoercion` ty2
547 , co1 `compatible_co` co2
548 = fireTransRule "TrPushInst" in_co1 in_co2 $
549 mkInstCo (opt_trans is co1 co2) ty1
550
551 opt_trans_rule is in_co1@(UnivCo p1 r1 tyl1 _tyr1)
552 in_co2@(UnivCo p2 r2 _tyl2 tyr2)
553 | Just prov' <- opt_trans_prov p1 p2
554 = ASSERT( r1 == r2 )
555 fireTransRule "UnivCo" in_co1 in_co2 $
556 mkUnivCo prov' r1 tyl1 tyr2
557 where
558 -- if the provenances are different, opt'ing will be very confusing
559 opt_trans_prov UnsafeCoerceProv UnsafeCoerceProv = Just UnsafeCoerceProv
560 opt_trans_prov (PhantomProv kco1) (PhantomProv kco2)
561 = Just $ PhantomProv $ opt_trans is kco1 kco2
562 opt_trans_prov (ProofIrrelProv kco1) (ProofIrrelProv kco2)
563 = Just $ ProofIrrelProv $ opt_trans is kco1 kco2
564 opt_trans_prov (PluginProv str1) (PluginProv str2) | str1 == str2 = Just p1
565 opt_trans_prov _ _ = Nothing
566
567 -- Push transitivity down through matching top-level constructors.
568 opt_trans_rule is in_co1@(TyConAppCo r1 tc1 cos1) in_co2@(TyConAppCo r2 tc2 cos2)
569 | tc1 == tc2
570 = ASSERT( r1 == r2 )
571 fireTransRule "PushTyConApp" in_co1 in_co2 $
572 mkTyConAppCo r1 tc1 (opt_transList is cos1 cos2)
573
574 opt_trans_rule is in_co1@(FunCo r1 co1a co1b) in_co2@(FunCo r2 co2a co2b)
575 = ASSERT( r1 == r2 ) -- Just like the TyConAppCo/TyConAppCo case
576 fireTransRule "PushFun" in_co1 in_co2 $
577 mkFunCo r1 (opt_trans is co1a co2a) (opt_trans is co1b co2b)
578
579 opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b)
580 -- Must call opt_trans_rule_app; see Note [EtaAppCo]
581 = opt_trans_rule_app is in_co1 in_co2 co1a [co1b] co2a [co2b]
582
583 -- Eta rules
584 opt_trans_rule is co1@(TyConAppCo r tc cos1) co2
585 | Just cos2 <- etaTyConAppCo_maybe tc co2
586 = ASSERT( cos1 `equalLength` cos2 )
587 fireTransRule "EtaCompL" co1 co2 $
588 mkTyConAppCo r tc (opt_transList is cos1 cos2)
589
590 opt_trans_rule is co1 co2@(TyConAppCo r tc cos2)
591 | Just cos1 <- etaTyConAppCo_maybe tc co1
592 = ASSERT( cos1 `equalLength` cos2 )
593 fireTransRule "EtaCompR" co1 co2 $
594 mkTyConAppCo r tc (opt_transList is cos1 cos2)
595
596 opt_trans_rule is co1@(AppCo co1a co1b) co2
597 | Just (co2a,co2b) <- etaAppCo_maybe co2
598 = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b]
599
600 opt_trans_rule is co1 co2@(AppCo co2a co2b)
601 | Just (co1a,co1b) <- etaAppCo_maybe co1
602 = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b]
603
604 -- Push transitivity inside forall
605 opt_trans_rule is co1 co2
606 | ForAllCo tv1 eta1 r1 <- co1
607 , Just (tv2,eta2,r2) <- etaForAllCo_maybe co2
608 = push_trans tv1 eta1 r1 tv2 eta2 r2
609
610 | ForAllCo tv2 eta2 r2 <- co2
611 , Just (tv1,eta1,r1) <- etaForAllCo_maybe co1
612 = push_trans tv1 eta1 r1 tv2 eta2 r2
613
614 where
615 push_trans tv1 eta1 r1 tv2 eta2 r2
616 = fireTransRule "EtaAllTy" co1 co2 $
617 mkForAllCo tv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2')
618 where
619 is' = is `extendInScopeSet` tv1
620 r2' = substCoWithUnchecked [tv2] [TyVarTy tv1] r2
621
622 -- Push transitivity inside axioms
623 opt_trans_rule is co1 co2
624
625 -- See Note [Why call checkAxInstCo during optimisation]
626 -- TrPushSymAxR
627 | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe
628 , True <- sym
629 , Just cos2 <- matchAxiom sym con ind co2
630 , let newAxInst = AxiomInstCo con ind (opt_transList is (map mkSymCo cos2) cos1)
631 , Nothing <- checkAxInstCo newAxInst
632 = fireTransRule "TrPushSymAxR" co1 co2 $ SymCo newAxInst
633
634 -- TrPushAxR
635 | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe
636 , False <- sym
637 , Just cos2 <- matchAxiom sym con ind co2
638 , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2)
639 , Nothing <- checkAxInstCo newAxInst
640 = fireTransRule "TrPushAxR" co1 co2 newAxInst
641
642 -- TrPushSymAxL
643 | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe
644 , True <- sym
645 , Just cos1 <- matchAxiom (not sym) con ind co1
646 , let newAxInst = AxiomInstCo con ind (opt_transList is cos2 (map mkSymCo cos1))
647 , Nothing <- checkAxInstCo newAxInst
648 = fireTransRule "TrPushSymAxL" co1 co2 $ SymCo newAxInst
649
650 -- TrPushAxL
651 | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe
652 , False <- sym
653 , Just cos1 <- matchAxiom (not sym) con ind co1
654 , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2)
655 , Nothing <- checkAxInstCo newAxInst
656 = fireTransRule "TrPushAxL" co1 co2 newAxInst
657
658 -- TrPushAxSym/TrPushSymAx
659 | Just (sym1, con1, ind1, cos1) <- co1_is_axiom_maybe
660 , Just (sym2, con2, ind2, cos2) <- co2_is_axiom_maybe
661 , con1 == con2
662 , ind1 == ind2
663 , sym1 == not sym2
664 , let branch = coAxiomNthBranch con1 ind1
665 qtvs = coAxBranchTyVars branch ++ coAxBranchCoVars branch
666 lhs = coAxNthLHS con1 ind1
667 rhs = coAxBranchRHS branch
668 pivot_tvs = exactTyCoVarsOfType (if sym2 then rhs else lhs)
669 , all (`elemVarSet` pivot_tvs) qtvs
670 = fireTransRule "TrPushAxSym" co1 co2 $
671 if sym2
672 -- TrPushAxSym
673 then liftCoSubstWith role qtvs (opt_transList is cos1 (map mkSymCo cos2)) lhs
674 -- TrPushSymAx
675 else liftCoSubstWith role qtvs (opt_transList is (map mkSymCo cos1) cos2) rhs
676 where
677 co1_is_axiom_maybe = isAxiom_maybe co1
678 co2_is_axiom_maybe = isAxiom_maybe co2
679 role = coercionRole co1 -- should be the same as coercionRole co2!
680
681 opt_trans_rule is co1 co2
682 | Just (lco, lh) <- isCohRight_maybe co1
683 , Just (rco, rh) <- isCohLeft_maybe co2
684 , (coercionType lh) `eqType` (coercionType rh)
685 = opt_trans_rule is lco rco
686
687 opt_trans_rule _ co1 co2 -- Identity rule
688 | (Pair ty1 _, r) <- coercionKindRole co1
689 , Pair _ ty2 <- coercionKind co2
690 , ty1 `eqType` ty2
691 = fireTransRule "RedTypeDirRefl" co1 co2 $
692 Refl r ty2
693
694 opt_trans_rule _ _ _ = Nothing
695
696 -- See Note [EtaAppCo]
697 opt_trans_rule_app :: InScopeSet
698 -> Coercion -- original left-hand coercion (printing only)
699 -> Coercion -- original right-hand coercion (printing only)
700 -> Coercion -- left-hand coercion "function"
701 -> [Coercion] -- left-hand coercion "args"
702 -> Coercion -- right-hand coercion "function"
703 -> [Coercion] -- right-hand coercion "args"
704 -> Maybe Coercion
705 opt_trans_rule_app is orig_co1 orig_co2 co1a co1bs co2a co2bs
706 | AppCo co1aa co1ab <- co1a
707 , Just (co2aa, co2ab) <- etaAppCo_maybe co2a
708 = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs)
709
710 | AppCo co2aa co2ab <- co2a
711 , Just (co1aa, co1ab) <- etaAppCo_maybe co1a
712 = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs)
713
714 | otherwise
715 = ASSERT( co1bs `equalLength` co2bs )
716 fireTransRule ("EtaApps:" ++ show (length co1bs)) orig_co1 orig_co2 $
717 let Pair _ rt1a = coercionKind co1a
718 Pair lt2a _ = coercionKind co2a
719
720 Pair _ rt1bs = traverse coercionKind co1bs
721 Pair lt2bs _ = traverse coercionKind co2bs
722
723 kcoa = mkKindCo $ buildCoercion lt2a rt1a
724 kcobs = map mkKindCo $ zipWith buildCoercion lt2bs rt1bs
725
726 co2a' = mkCoherenceLeftCo co2a kcoa
727 co2bs' = zipWith mkCoherenceLeftCo co2bs kcobs
728 in
729 mkAppCos (opt_trans is co1a co2a')
730 (zipWith (opt_trans is) co1bs co2bs')
731
732 fireTransRule :: String -> Coercion -> Coercion -> Coercion -> Maybe Coercion
733 fireTransRule _rule _co1 _co2 res
734 = Just res
735
736 {-
737 Note [Conflict checking with AxiomInstCo]
738 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
739 Consider the following type family and axiom:
740
741 type family Equal (a :: k) (b :: k) :: Bool
742 type instance where
743 Equal a a = True
744 Equal a b = False
745 --
746 Equal :: forall k::*. k -> k -> Bool
747 axEqual :: { forall k::*. forall a::k. Equal k a a ~ True
748 ; forall k::*. forall a::k. forall b::k. Equal k a b ~ False }
749
750 We wish to disallow (axEqual[1] <*> <Int> <Int). (Recall that the index is
751 0-based, so this is the second branch of the axiom.) The problem is that, on
752 the surface, it seems that (axEqual[1] <*> <Int> <Int>) :: (Equal * Int Int ~
753 False) and that all is OK. But, all is not OK: we want to use the first branch
754 of the axiom in this case, not the second. The problem is that the parameters
755 of the first branch can unify with the supplied coercions, thus meaning that
756 the first branch should be taken. See also Note [Apartness] in
757 types/FamInstEnv.hs.
758
759 Note [Why call checkAxInstCo during optimisation]
760 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
761 It is possible that otherwise-good-looking optimisations meet with disaster
762 in the presence of axioms with multiple equations. Consider
763
764 type family Equal (a :: *) (b :: *) :: Bool where
765 Equal a a = True
766 Equal a b = False
767 type family Id (a :: *) :: * where
768 Id a = a
769
770 axEq :: { [a::*]. Equal a a ~ True
771 ; [a::*, b::*]. Equal a b ~ False }
772 axId :: [a::*]. Id a ~ a
773
774 co1 = Equal (axId[0] Int) (axId[0] Bool)
775 :: Equal (Id Int) (Id Bool) ~ Equal Int Bool
776 co2 = axEq[1] <Int> <Bool>
777 :: Equal Int Bool ~ False
778
779 We wish to optimise (co1 ; co2). We end up in rule TrPushAxL, noting that
780 co2 is an axiom and that matchAxiom succeeds when looking at co1. But, what
781 happens when we push the coercions inside? We get
782
783 co3 = axEq[1] (axId[0] Int) (axId[0] Bool)
784 :: Equal (Id Int) (Id Bool) ~ False
785
786 which is bogus! This is because the type system isn't smart enough to know
787 that (Id Int) and (Id Bool) are Surely Apart, as they're headed by type
788 families. At the time of writing, I (Richard Eisenberg) couldn't think of
789 a way of detecting this any more efficient than just building the optimised
790 coercion and checking.
791
792 Note [EtaAppCo]
793 ~~~~~~~~~~~~~~~
794 Suppose we're trying to optimize (co1a co1b ; co2a co2b). Ideally, we'd
795 like to rewrite this to (co1a ; co2a) (co1b ; co2b). The problem is that
796 the resultant coercions might not be well kinded. Here is an example (things
797 labeled with x don't matter in this example):
798
799 k1 :: Type
800 k2 :: Type
801
802 a :: k1 -> Type
803 b :: k1
804
805 h :: k1 ~ k2
806
807 co1a :: x1 ~ (a |> (h -> <Type>)
808 co1b :: x2 ~ (b |> h)
809
810 co2a :: a ~ x3
811 co2b :: b ~ x4
812
813 First, convince yourself of the following:
814
815 co1a co1b :: x1 x2 ~ (a |> (h -> <Type>)) (b |> h)
816 co2a co2b :: a b ~ x3 x4
817
818 (a |> (h -> <Type>)) (b |> h) `eqType` a b
819
820 That last fact is due to Note [Non-trivial definitional equality] in TyCoRep,
821 where we ignore coercions in types as long as two types' kinds are the same.
822 In our case, we meet this last condition, because
823
824 (a |> (h -> <Type>)) (b |> h) :: Type
825 and
826 a b :: Type
827
828 So the input coercion (co1a co1b ; co2a co2b) is well-formed. But the
829 suggested output coercions (co1a ; co2a) and (co1b ; co2b) are not -- the
830 kinds don't match up.
831
832 The solution here is to twiddle the kinds in the output coercions. First, we
833 need to find coercions
834
835 ak :: kind(a |> (h -> <Type>)) ~ kind(a)
836 bk :: kind(b |> h) ~ kind(b)
837
838 This can be done with mkKindCo and buildCoercion. The latter assumes two
839 types are identical modulo casts and builds a coercion between them.
840
841 Then, we build (co1a ; co2a |> sym ak) and (co1b ; co2b |> sym bk) as the
842 output coercions. These are well-kinded. (We cast the right-hand coercion
843 because mkCoherenceLeftCo is smaller than mkCoherenceRightCo.)
844
845 Also, note that all of this is done after accumulated any nested AppCo
846 parameters. This step is to avoid quadratic behavior in calling coercionKind.
847
848 The problem described here was first found in dependent/should_compile/dynamic-paper.
849
850 -}
851
852 -- | Check to make sure that an AxInstCo is internally consistent.
853 -- Returns the conflicting branch, if it exists
854 -- See Note [Conflict checking with AxiomInstCo]
855 checkAxInstCo :: Coercion -> Maybe CoAxBranch
856 -- defined here to avoid dependencies in Coercion
857 -- If you edit this function, you may need to update the GHC formalism
858 -- See Note [GHC Formalism] in CoreLint
859 checkAxInstCo (AxiomInstCo ax ind cos)
860 = let branch = coAxiomNthBranch ax ind
861 tvs = coAxBranchTyVars branch
862 cvs = coAxBranchCoVars branch
863 incomps = coAxBranchIncomps branch
864 (tys, cotys) = splitAtList tvs (map (pFst . coercionKind) cos)
865 co_args = map stripCoercionTy cotys
866 subst = zipTvSubst tvs tys `composeTCvSubst`
867 zipCvSubst cvs co_args
868 target = Type.substTys subst (coAxBranchLHS branch)
869 in_scope = mkInScopeSet $
870 unionVarSets (map (tyCoVarsOfTypes . coAxBranchLHS) incomps)
871 flattened_target = flattenTys in_scope target in
872 check_no_conflict flattened_target incomps
873 where
874 check_no_conflict :: [Type] -> [CoAxBranch] -> Maybe CoAxBranch
875 check_no_conflict _ [] = Nothing
876 check_no_conflict flat (b@CoAxBranch { cab_lhs = lhs_incomp } : rest)
877 -- See Note [Apartness] in FamInstEnv
878 | SurelyApart <- tcUnifyTysFG instanceBindFun flat lhs_incomp
879 = check_no_conflict flat rest
880 | otherwise
881 = Just b
882 checkAxInstCo _ = Nothing
883
884
885 -----------
886 wrapSym :: SymFlag -> Coercion -> Coercion
887 wrapSym sym co | sym = mkSymCo co
888 | otherwise = co
889
890 -- | Conditionally set a role to be representational
891 wrapRole :: ReprFlag
892 -> Role -- ^ current role
893 -> Coercion -> Coercion
894 wrapRole False _ = id
895 wrapRole True current = downgradeRole Representational current
896
897 -- | If we require a representational role, return that. Otherwise,
898 -- return the "default" role provided.
899 chooseRole :: ReprFlag
900 -> Role -- ^ "default" role
901 -> Role
902 chooseRole True _ = Representational
903 chooseRole _ r = r
904
905 -----------
906 isAxiom_maybe :: Coercion -> Maybe (Bool, CoAxiom Branched, Int, [Coercion])
907 isAxiom_maybe (SymCo co)
908 | Just (sym, con, ind, cos) <- isAxiom_maybe co
909 = Just (not sym, con, ind, cos)
910 isAxiom_maybe (AxiomInstCo con ind cos)
911 = Just (False, con, ind, cos)
912 isAxiom_maybe _ = Nothing
913
914 matchAxiom :: Bool -- True = match LHS, False = match RHS
915 -> CoAxiom br -> Int -> Coercion -> Maybe [Coercion]
916 matchAxiom sym ax@(CoAxiom { co_ax_tc = tc }) ind co
917 | CoAxBranch { cab_tvs = qtvs
918 , cab_cvs = [] -- can't infer these, so fail if there are any
919 , cab_roles = roles
920 , cab_lhs = lhs
921 , cab_rhs = rhs } <- coAxiomNthBranch ax ind
922 , Just subst <- liftCoMatch (mkVarSet qtvs)
923 (if sym then (mkTyConApp tc lhs) else rhs)
924 co
925 , all (`isMappedByLC` subst) qtvs
926 = zipWithM (liftCoSubstTyVar subst) roles qtvs
927
928 | otherwise
929 = Nothing
930
931 -------------
932 -- destruct a CoherenceCo
933 isCohLeft_maybe :: Coercion -> Maybe (Coercion, Coercion)
934 isCohLeft_maybe (CoherenceCo co1 co2) = Just (co1, co2)
935 isCohLeft_maybe _ = Nothing
936
937 -- destruct a (sym (co1 |> co2)).
938 -- if isCohRight_maybe co = Just (co1, co2), then (sym co1) `mkCohRightCo` co2 = co
939 isCohRight_maybe :: Coercion -> Maybe (Coercion, Coercion)
940 isCohRight_maybe (SymCo (CoherenceCo co1 co2)) = Just (mkSymCo co1, co2)
941 isCohRight_maybe _ = Nothing
942
943 -------------
944 compatible_co :: Coercion -> Coercion -> Bool
945 -- Check whether (co1 . co2) will be well-kinded
946 compatible_co co1 co2
947 = x1 `eqType` x2
948 where
949 Pair _ x1 = coercionKind co1
950 Pair x2 _ = coercionKind co2
951
952 -------------
953 {-
954 etaForAllCo_maybe
955 ~~~~~~~~~~~~~~~~~
956 Suppose we have
957
958 g : all a1:k1.t1 ~ all a2:k2.t2
959
960 but g is *not* a ForAllCo. We want to eta-expand it. So, we do this:
961
962 g' = all a1:(ForAllKindCo g).(InstCo g (a1 `mkCoherenceRightCo` ForAllKindCo g))
963
964 Call the kind coercion h1 and the body coercion h2. We can see that
965
966 h2 : t1 ~ t2[a2 |-> (a1 |> h2)]
967
968 According to the typing rule for ForAllCo, we get that
969
970 g' : all a1:k1.t1 ~ all a1:k2.(t2[a2 |-> (a1 |> h2)][a1 |-> a1 |> sym h2])
971
972 or
973
974 g' : all a1:k1.t1 ~ all a1:k2.(t2[a2 |-> a1])
975
976 as desired.
977 -}
978 etaForAllCo_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion)
979 -- Try to make the coercion be of form (forall tv:kind_co. co)
980 etaForAllCo_maybe co
981 | ForAllCo tv kind_co r <- co
982 = Just (tv, kind_co, r)
983
984 | Pair ty1 ty2 <- coercionKind co
985 , Just (tv1, _) <- splitForAllTy_maybe ty1
986 , isForAllTy ty2
987 , let kind_co = mkNthCo 0 co
988 = Just ( tv1, kind_co
989 , mkInstCo co (mkNomReflCo (TyVarTy tv1) `mkCoherenceRightCo` kind_co) )
990
991 | otherwise
992 = Nothing
993
994 etaAppCo_maybe :: Coercion -> Maybe (Coercion,Coercion)
995 -- If possible, split a coercion
996 -- g :: t1a t1b ~ t2a t2b
997 -- into a pair of coercions (left g, right g)
998 etaAppCo_maybe co
999 | Just (co1,co2) <- splitAppCo_maybe co
1000 = Just (co1,co2)
1001 | (Pair ty1 ty2, Nominal) <- coercionKindRole co
1002 , Just (_,t1) <- splitAppTy_maybe ty1
1003 , Just (_,t2) <- splitAppTy_maybe ty2
1004 , let isco1 = isCoercionTy t1
1005 , let isco2 = isCoercionTy t2
1006 , isco1 == isco2
1007 = Just (LRCo CLeft co, LRCo CRight co)
1008 | otherwise
1009 = Nothing
1010
1011 etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion]
1012 -- If possible, split a coercion
1013 -- g :: T s1 .. sn ~ T t1 .. tn
1014 -- into [ Nth 0 g :: s1~t1, ..., Nth (n-1) g :: sn~tn ]
1015 etaTyConAppCo_maybe tc (TyConAppCo _ tc2 cos2)
1016 = ASSERT( tc == tc2 ) Just cos2
1017
1018 etaTyConAppCo_maybe tc co
1019 | mightBeUnsaturatedTyCon tc
1020 , (Pair ty1 ty2, r) <- coercionKindRole co
1021 , Just (tc1, tys1) <- splitTyConApp_maybe ty1
1022 , Just (tc2, tys2) <- splitTyConApp_maybe ty2
1023 , tc1 == tc2
1024 , isInjectiveTyCon tc r -- See Note [NthCo and newtypes] in TyCoRep
1025 , let n = length tys1
1026 , tys2 `lengthIs` n -- This can fail in an erroneous progam
1027 -- E.g. T a ~# T a b
1028 -- Trac #14607
1029 = ASSERT( tc == tc1 )
1030 Just (decomposeCo n co)
1031 -- NB: n might be <> tyConArity tc
1032 -- e.g. data family T a :: * -> *
1033 -- g :: T a b ~ T c d
1034
1035 | otherwise
1036 = Nothing
1037
1038 {-
1039 Note [Eta for AppCo]
1040 ~~~~~~~~~~~~~~~~~~~~
1041 Suppose we have
1042 g :: s1 t1 ~ s2 t2
1043
1044 Then we can't necessarily make
1045 left g :: s1 ~ s2
1046 right g :: t1 ~ t2
1047 because it's possible that
1048 s1 :: * -> * t1 :: *
1049 s2 :: (*->*) -> * t2 :: * -> *
1050 and in that case (left g) does not have the same
1051 kind on either side.
1052
1053 It's enough to check that
1054 kind t1 = kind t2
1055 because if g is well-kinded then
1056 kind (s1 t2) = kind (s2 t2)
1057 and these two imply
1058 kind s1 = kind s2
1059
1060 -}
1061
1062 optForAllCoBndr :: LiftingContext -> Bool
1063 -> TyVar -> Coercion -> (LiftingContext, TyVar, Coercion)
1064 optForAllCoBndr env sym
1065 = substForAllCoBndrCallbackLC sym (opt_co4_wrap env sym False Nominal) env