projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Don't inline a loop breaker, even if it has an INLINE pragma
[ghc-hetmet.git]
/
compiler
/
simplCore
/
Simplify.lhs
diff --git
a/compiler/simplCore/Simplify.lhs
b/compiler/simplCore/Simplify.lhs
index
f8462be
..
6ae9587
100644
(file)
--- a/
compiler/simplCore/Simplify.lhs
+++ b/
compiler/simplCore/Simplify.lhs
@@
-942,14
+942,19
@@
simplCast env body co0 cont0
add_coerce co (s1s2, _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont)
-- (f |> g) ty ---> (f ty) |> (g @ ty)
add_coerce co (s1s2, _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont)
-- (f |> g) ty ---> (f ty) |> (g @ ty)
- -- This implements the PushT rule from the paper
+ -- This implements the PushT and PushC rules from the paper
| Just (tyvar,_) <- splitForAllTy_maybe s1s2
| Just (tyvar,_) <- splitForAllTy_maybe s1s2
- , not (isCoVar tyvar)
- = ApplyTo dup (Type ty') (zapSubstEnv env) (addCoerce (mkInstCoercion co ty') cont)
+ = let
+ (new_arg_ty, new_cast)
+ | isCoVar tyvar = (new_arg_co, mkCselRCoercion co) -- PushC rule
+ | otherwise = (ty', mkInstCoercion co ty') -- PushT rule
+ in
+ ApplyTo dup (Type new_arg_ty) (zapSubstEnv env) (addCoerce new_cast cont)
where
ty' = substTy (arg_se `setInScope` env) arg_ty
where
ty' = substTy (arg_se `setInScope` env) arg_ty
-
- -- ToDo: the PushC rule is not implemented at all
+ new_arg_co = mkCsel1Coercion co `mkTransCoercion`
+ ty' `mkTransCoercion`
+ mkSymCoercion (mkCsel2Coercion co)
add_coerce co (s1s2, _t1t2) (ApplyTo dup arg arg_se cont)
| not (isTypeArg arg) -- This implements the Push rule from the paper
add_coerce co (s1s2, _t1t2) (ApplyTo dup arg arg_se cont)
| not (isTypeArg arg) -- This implements the Push rule from the paper