projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Fix some small things broken with the last merge.
[ghc-hetmet.git]
/
compiler
/
coreSyn
/
CorePrep.lhs
diff --git
a/compiler/coreSyn/CorePrep.lhs
b/compiler/coreSyn/CorePrep.lhs
index
42379b4
..
0405716
100644
(file)
--- a/
compiler/coreSyn/CorePrep.lhs
+++ b/
compiler/coreSyn/CorePrep.lhs
@@
-37,6
+37,7
@@
import OrdList
import ErrUtils
import DynFlags
import Util
import ErrUtils
import DynFlags
import Util
+import Pair
import Outputable
import MonadUtils
import FastString
import Outputable
import MonadUtils
import FastString
@@
-78,9
+79,9
@@
The goal of this pass is to prepare for code generation.
weaker guarantee of no clashes which the simplifier provides.
And that is what the code generator needs.
weaker guarantee of no clashes which the simplifier provides.
And that is what the code generator needs.
- We don't clone TyVars. The code gen doesn't need that,
+ We don't clone TyVars or CoVars. The code gen doesn't need that,
and doing so would be tiresome because then we'd need
and doing so would be tiresome because then we'd need
- to substitute in types.
+ to substitute in types and coercions.
7. Give each dynamic CCall occurrence a fresh unique; this is
7. Give each dynamic CCall occurrence a fresh unique; this is
@@
-104,19
+105,21
@@
Invariants
Here is the syntax of the Core produced by CorePrep:
Trivial expressions
Here is the syntax of the Core produced by CorePrep:
Trivial expressions
- triv ::= lit | var | triv ty | /\a. triv | triv |> co
+ triv ::= lit | var
+ | triv ty | /\a. triv
+ | truv co | /\c. triv | triv |> co
Applications
Applications
- app ::= lit | var | app triv | app ty | app |> co
+ app ::= lit | var | app triv | app ty | app co | app |> co
Expressions
body ::= app
| let(rec) x = rhs in body -- Boxed only
| case body of pat -> body
Expressions
body ::= app
| let(rec) x = rhs in body -- Boxed only
| case body of pat -> body
- | /\a. body
+ | /\a. body | /\c. body
| body |> co
| body |> co
- Right hand sides (only place where lambdas can occur)
+ Right hand sides (only place where value lambdas can occur)
rhs ::= /\a.rhs | \x.rhs | body
We define a synonym for each of these non-terminals. Functions
rhs ::= /\a.rhs | \x.rhs | body
We define a synonym for each of these non-terminals. Functions
@@
-440,9
+443,10
@@
cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
-- For example
-- f (g x) ===> ([v = g x], f v)
-- For example
-- f (g x) ===> ([v = g x], f v)
-cpeRhsE _env expr@(Type _) = return (emptyFloats, expr)
-cpeRhsE _env expr@(Lit _) = return (emptyFloats, expr)
-cpeRhsE env expr@(Var {}) = cpeApp env expr
+cpeRhsE _env expr@(Type {}) = return (emptyFloats, expr)
+cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr)
+cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr)
+cpeRhsE env expr@(Var {}) = cpeApp env expr
cpeRhsE env (Var f `App` _ `App` arg)
| f `hasKey` lazyIdKey -- Replace (lazy a) by a
cpeRhsE env (Var f `App` _ `App` arg)
| f `hasKey` lazyIdKey -- Replace (lazy a) by a
@@
-528,7
+532,7
@@
rhsToBody (Cast e co)
rhsToBody expr@(Lam {})
| Just no_lam_result <- tryEtaReducePrep bndrs body
= return (emptyFloats, no_lam_result)
rhsToBody expr@(Lam {})
| Just no_lam_result <- tryEtaReducePrep bndrs body
= return (emptyFloats, no_lam_result)
- | all isTyCoVar bndrs -- Type lambdas are ok
+ | all isTyVar bndrs -- Type lambdas are ok
= return (emptyFloats, expr)
| otherwise -- Some value lambdas
= do { fn <- newVar (exprType expr)
= return (emptyFloats, expr)
| otherwise -- Some value lambdas
= do { fn <- newVar (exprType expr)
@@
-579,6
+583,10
@@
cpeApp env expr
= do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
; return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss) }
= do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
; return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss) }
+ collect_args (App fun arg@(Coercion arg_co)) depth
+ = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
+ ; return (App fun' arg, hd, applyCo fun_ty arg_co, floats, ss) }
+
collect_args (App fun arg) depth
= do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
; let
collect_args (App fun arg) depth
= do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
; let
@@
-608,7
+616,7
@@
cpeApp env expr
-- partial application might be seq'd
collect_args (Cast fun co) depth
-- partial application might be seq'd
collect_args (Cast fun co) depth
- = do { let (_ty1,ty2) = coercionKind co
+ = do { let Pair _ty1 ty2 = coercionKind co
; (fun', hd, _, floats, ss) <- collect_args fun depth
; return (Cast fun' co, hd, ty2, floats, ss) }
; (fun', hd, _, floats, ss) <- collect_args fun depth
; return (Cast fun' co, hd, ty2, floats, ss) }
@@
-751,11
+759,12
@@
cpe_ExprIsTrivial :: CoreExpr -> Bool
-- Version that doesn't consider an scc annotation to be trivial.
cpe_ExprIsTrivial (Var _) = True
cpe_ExprIsTrivial (Type _) = True
-- Version that doesn't consider an scc annotation to be trivial.
cpe_ExprIsTrivial (Var _) = True
cpe_ExprIsTrivial (Type _) = True
+cpe_ExprIsTrivial (Coercion _) = True
cpe_ExprIsTrivial (Lit _) = True
cpe_ExprIsTrivial (App e arg) = isTypeArg arg && cpe_ExprIsTrivial e
cpe_ExprIsTrivial (Note n e) = notSccNote n && cpe_ExprIsTrivial e
cpe_ExprIsTrivial (Cast e _) = cpe_ExprIsTrivial e
cpe_ExprIsTrivial (Lit _) = True
cpe_ExprIsTrivial (App e arg) = isTypeArg arg && cpe_ExprIsTrivial e
cpe_ExprIsTrivial (Note n e) = notSccNote n && cpe_ExprIsTrivial e
cpe_ExprIsTrivial (Cast e _) = cpe_ExprIsTrivial e
-cpe_ExprIsTrivial (Lam b body) | isTyCoVar b = cpe_ExprIsTrivial body
+cpe_ExprIsTrivial (Lam b body) | isTyVar b = cpe_ExprIsTrivial body
cpe_ExprIsTrivial _ = False
\end{code}
cpe_ExprIsTrivial _ = False
\end{code}
@@
-1070,7
+1079,7
@@
cloneBndrs env bs = mapAccumLM cloneBndr env bs
cloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
cloneBndr env bndr
cloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
cloneBndr env bndr
- | isLocalId bndr
+ | isLocalId bndr, not (isCoVar bndr)
= do bndr' <- setVarUnique bndr <$> getUniqueM
-- We are going to OccAnal soon, so drop (now-useless) rules/unfoldings
= do bndr' <- setVarUnique bndr <$> getUniqueM
-- We are going to OccAnal soon, so drop (now-useless) rules/unfoldings
@@
-1082,7
+1091,7
@@
cloneBndr env bndr
| otherwise -- Top level things, which we don't want
-- to clone, have become GlobalIds by now
| otherwise -- Top level things, which we don't want
-- to clone, have become GlobalIds by now
- -- And we don't clone tyvars
+ -- And we don't clone tyvars, or coercion variables
= return (env, bndr)
= return (env, bndr)