| ... |
... |
@@ -26,6 +26,7 @@ import GHC.Core.Subst |
|
26
|
26
|
import GHC.Core.Utils
|
|
27
|
27
|
import GHC.Core.FVs
|
|
28
|
28
|
import GHC.Core.Unfold
|
|
|
29
|
+import GHC.Core.TyCo.Compare( eqTypeIgnoringMultiplicity )
|
|
29
|
30
|
import GHC.Core.Unfold.Make
|
|
30
|
31
|
import GHC.Core.Make ( FloatBind(..), mkWildValBinder )
|
|
31
|
32
|
import GHC.Core.Opt.OccurAnal( occurAnalyseExpr, occurAnalysePgm, zapLambdaBndrs )
|
| ... |
... |
@@ -215,11 +216,15 @@ simpleOptPgm opts this_mod binds rules = |
|
215
|
216
|
----------------------
|
|
216
|
217
|
type SimpleClo = (SimpleOptEnv, InExpr)
|
|
217
|
218
|
|
|
218
|
|
-data SimpleContItem = ApplyToArg SimpleClo | CastIt OutCoercion
|
|
|
219
|
+data SimpleContItem
|
|
|
220
|
+ = ApplyToArg SimpleClo
|
|
|
221
|
+ | CastIt OutCoercion OutType
|
|
|
222
|
+ -- The OutType is the corecionRKind of the coercion
|
|
|
223
|
+ -- Used to make reflexivity checking more efficient
|
|
219
|
224
|
|
|
220
|
225
|
instance Outputable SimpleContItem where
|
|
221
|
226
|
ppr (ApplyToArg (_, arg)) = text "ARG" <+> ppr arg
|
|
222
|
|
- ppr (CastIt co) = text "CAST" <+> ppr co
|
|
|
227
|
+ ppr (CastIt co _) = text "CAST" <+> ppr co
|
|
223
|
228
|
|
|
224
|
229
|
data SimpleOptEnv
|
|
225
|
230
|
= SOE { soe_opts :: {-# UNPACK #-} !SimpleOpts
|
| ... |
... |
@@ -392,7 +397,7 @@ simple_app env e0@(Lam {}) as0@(_:_) |
|
392
|
397
|
where (env', b') = subst_opt_bndr env b
|
|
393
|
398
|
|
|
394
|
399
|
-- See Note [Eliminate casts in function position]
|
|
395
|
|
- do_beta env e@(Lam b _) as@(CastIt out_co:rest)
|
|
|
400
|
+ do_beta env e@(Lam b _) as@(CastIt out_co _ : rest)
|
|
396
|
401
|
| isNonCoVarId b
|
|
397
|
402
|
-- Optimise the inner lambda to make it an 'OutExpr', which makes it
|
|
398
|
403
|
-- possible to call 'pushCoercionIntoLambda' with the 'OutCoercion' 'co'.
|
| ... |
... |
@@ -467,8 +472,11 @@ add_cast env co1 as |
|
467
|
472
|
= as
|
|
468
|
473
|
| otherwise
|
|
469
|
474
|
= case as of
|
|
470
|
|
- CastIt co2:rest -> CastIt (co1' `mkTransCo` co2):rest
|
|
471
|
|
- _ -> CastIt co1':as
|
|
|
475
|
+ CastIt co2 ty2 : rest
|
|
|
476
|
+ | ty2 `eqTypeIgnoringMultiplicity` coercionLKind co1'
|
|
|
477
|
+ -> rest
|
|
|
478
|
+ | otherwise -> CastIt (co1' `mkTransCo` co2) ty2 : rest
|
|
|
479
|
+ _ -> CastIt co1' (coercionRKind co1') : as
|
|
472
|
480
|
where
|
|
473
|
481
|
co1' = simple_opt_co env co1
|
|
474
|
482
|
|
| ... |
... |
@@ -479,7 +487,7 @@ rebuild_app env fun args = foldl mk_app fun args |
|
479
|
487
|
in_scope = soeInScope env
|
|
480
|
488
|
mk_app out_fun = \case
|
|
481
|
489
|
ApplyToArg arg -> App out_fun (simple_opt_clo in_scope arg)
|
|
482
|
|
- CastIt co -> mkCast out_fun co
|
|
|
490
|
+ CastIt co _ -> mkCast out_fun co
|
|
483
|
491
|
|
|
484
|
492
|
{- Note [Desugaring unlifted newtypes]
|
|
485
|
493
|
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|