summaryrefslogtreecommitdiff
path: root/compiler/coreSyn
diff options
context:
space:
mode:
authorNicolas Frisby <nicolas.frisby@gmail.com>2013-08-22 15:00:41 -0500
committerNicolas Frisby <nicolas.frisby@gmail.com>2013-08-22 15:00:54 -0500
commit84f9927c1a04b8e35b97101771d8f6d625643d9b (patch)
tree050d7265a24fa1ff9aecc4081bb01bc444520587 /compiler/coreSyn
parent2eaf46fb1bb8c661c03f3e5e80622207ef2509d9 (diff)
parentc24be4b761df558d9edc9c0b1554bb558c261b14 (diff)
downloadhaskell-late-dmd.tar.gz
merged master into late-dmdlate-dmd
Diffstat (limited to 'compiler/coreSyn')
-rw-r--r--compiler/coreSyn/CoreArity.lhs52
-rw-r--r--compiler/coreSyn/CoreFVs.lhs33
-rw-r--r--compiler/coreSyn/CoreLint.lhs148
-rw-r--r--compiler/coreSyn/CorePrep.lhs73
-rw-r--r--compiler/coreSyn/CoreSubst.lhs79
-rw-r--r--compiler/coreSyn/CoreSyn.lhs39
-rw-r--r--compiler/coreSyn/CoreTidy.lhs7
-rw-r--r--compiler/coreSyn/CoreUnfold.lhs37
-rw-r--r--compiler/coreSyn/CoreUtils.lhs125
-rw-r--r--compiler/coreSyn/ExternalCore.lhs29
-rw-r--r--compiler/coreSyn/MkCore.lhs48
-rw-r--r--compiler/coreSyn/MkExternalCore.lhs110
-rw-r--r--compiler/coreSyn/PprCore.lhs10
-rw-r--r--compiler/coreSyn/PprExternalCore.lhs60
-rw-r--r--compiler/coreSyn/TrieMap.lhs93
15 files changed, 518 insertions, 425 deletions
diff --git a/compiler/coreSyn/CoreArity.lhs b/compiler/coreSyn/CoreArity.lhs
index 6b9e3e8d9f..7bf15d8216 100644
--- a/compiler/coreSyn/CoreArity.lhs
+++ b/compiler/coreSyn/CoreArity.lhs
@@ -30,7 +30,7 @@ import Var
import VarEnv
import Id
import Type
-import TyCon ( isRecursiveTyCon, isClassTyCon )
+import TyCon ( initRecTc, checkRecTc )
import Coercion
import BasicTypes
import Unique
@@ -88,7 +88,7 @@ exprArity e = go e
go (Lam x e) | isId x = go e + 1
| otherwise = go e
go (Tick t e) | not (tickishIsCode t) = go e
- go (Cast e co) = go e `min` length (typeArity (pSnd (coercionKind co)))
+ go (Cast e co) = trim_arity (go e) (pSnd (coercionKind co))
-- Note [exprArity invariant]
go (App e (Type _)) = go e
go (App f a) | exprIsTrivial a = (go f - 1) `max` 0
@@ -97,6 +97,8 @@ exprArity e = go e
go _ = 0
+ trim_arity :: Arity -> Type -> Arity
+ trim_arity arity ty = arity `min` length (typeArity ty)
---------------
typeArity :: Type -> [OneShot]
@@ -104,24 +106,32 @@ typeArity :: Type -> [OneShot]
-- We look through foralls, and newtypes
-- See Note [exprArity invariant]
typeArity ty
- | Just (_, ty') <- splitForAllTy_maybe ty
- = typeArity ty'
-
- | Just (arg,res) <- splitFunTy_maybe ty
- = isStateHackType arg : typeArity res
-
- | Just (tc,tys) <- splitTyConApp_maybe ty
- , Just (ty', _) <- instNewTyCon_maybe tc tys
- , not (isRecursiveTyCon tc)
- , not (isClassTyCon tc) -- Do not eta-expand through newtype classes
- -- See Note [Newtype classes and eta expansion]
- = typeArity ty'
+ = go initRecTc ty
+ where
+ go rec_nts ty
+ | Just (_, ty') <- splitForAllTy_maybe ty
+ = go rec_nts ty'
+
+ | Just (arg,res) <- splitFunTy_maybe ty
+ = isStateHackType arg : go rec_nts res
+
+ | Just (tc,tys) <- splitTyConApp_maybe ty
+ , Just (ty', _) <- instNewTyCon_maybe tc tys
+ , Just rec_nts' <- checkRecTc rec_nts tc -- See Note [Expanding newtypes]
+ -- in TyCon
+-- , not (isClassTyCon tc) -- Do not eta-expand through newtype classes
+-- -- See Note [Newtype classes and eta expansion]
+-- (no longer required)
+ = go rec_nts' ty'
-- Important to look through non-recursive newtypes, so that, eg
-- (f x) where f has arity 2, f :: Int -> IO ()
-- Here we want to get arity 1 for the result!
+ --
+ -- AND through a layer of recursive newtypes
+ -- e.g. newtype Stream m a b = Stream (m (Either b (a, Stream m a b)))
- | otherwise
- = []
+ | otherwise
+ = []
---------------
exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, StrictSig)
@@ -168,6 +178,11 @@ in exprArity. That is a less local change, so I'm going to leave it for today!
Note [Newtype classes and eta expansion]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ NB: this nasty special case is no longer required, becuase
+ for newtype classes we don't use the class-op rule mechanism
+ at all. See Note [Single-method classes] in TcInstDcls. SLPJ May 2013
+
+-------- Old out of date comments, just for interest -----------
We have to be careful when eta-expanding through newtypes. In general
it's a good idea, but annoyingly it interacts badly with the class-op
rule mechanism. Consider
@@ -207,6 +222,7 @@ exprIsConApp_maybe won't hold of the argument to op. I considered
trying to *make* it hold, but it's tricky and I gave up.
The test simplCore/should_compile/T3722 is an excellent example.
+-------- End of old out of date comments, just for interest -----------
Note [exprArity for applications]
@@ -542,7 +558,7 @@ PAPSs
f = g d ==> f = \x. g d x
because that might in turn make g inline (if it has an inline pragma),
which we might not want. After all, INLINE pragmas say "inline only
-when saturate" so we don't want to be too gung-ho about saturating!
+when saturated" so we don't want to be too gung-ho about saturating!
\begin{code}
arityLam :: Id -> ArityType -> ArityType
@@ -726,7 +742,7 @@ The biggest reason for doing this is for cases like
True -> \y -> e1
False -> \y -> e2
-Here we want to get the lambdas together. A good exmaple is the nofib
+Here we want to get the lambdas together. A good example is the nofib
program fibheaps, which gets 25% more allocation if you don't do this
eta-expansion.
diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs
index 2a11723fa9..636c049c42 100644
--- a/compiler/coreSyn/CoreFVs.lhs
+++ b/compiler/coreSyn/CoreFVs.lhs
@@ -104,8 +104,17 @@ type InterestingVarFun = Var -> Bool
\begin{code}
type FV = InterestingVarFun
- -> VarSet -- In scope
+ -> VarSet -- Locally bound
-> VarSet -- Free vars
+ -- Return the vars that are both (a) interesting
+ -- and (b) not locally bound
+ -- See function keep_it
+
+keep_it :: InterestingVarFun -> VarSet -> Var -> Bool
+keep_it fv_cand in_scope var
+ | var `elemVarSet` in_scope = False
+ | fv_cand var = True
+ | otherwise = False
union :: FV -> FV -> FV
union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand in_scope
@@ -152,13 +161,6 @@ someVars :: VarSet -> FV
someVars vars fv_cand in_scope
= filterVarSet (keep_it fv_cand in_scope) vars
-keep_it :: InterestingVarFun -> VarSet -> Var -> Bool
-keep_it fv_cand in_scope var
- | var `elemVarSet` in_scope = False
- | fv_cand var = True
- | otherwise = False
-
-
addBndr :: CoreBndr -> FV -> FV
addBndr bndr fv fv_cand in_scope
= someVars (varTypeTyVars bndr) fv_cand in_scope
@@ -434,15 +436,18 @@ idUnfoldingVars :: Id -> VarSet
-- and we'll get exponential behaviour if we look at both unf and rhs!
-- But do look at the *real* unfolding, even for loop breakers, else
-- we might get out-of-scope variables
-idUnfoldingVars id = stableUnfoldingVars isLocalId (realIdUnfolding id) `orElse` emptyVarSet
+idUnfoldingVars id = stableUnfoldingVars (realIdUnfolding id) `orElse` emptyVarSet
-stableUnfoldingVars :: InterestingVarFun -> Unfolding -> Maybe VarSet
-stableUnfoldingVars fv_cand unf
+stableUnfoldingVars :: Unfolding -> Maybe VarSet
+stableUnfoldingVars unf
= case unf of
CoreUnfolding { uf_tmpl = rhs, uf_src = src }
- | isStableSource src -> Just (exprSomeFreeVars fv_cand rhs)
- DFunUnfolding _ _ args -> Just (exprsSomeFreeVars fv_cand (dfunArgExprs args))
- _other -> Nothing
+ | isStableSource src
+ -> Just (exprFreeVars rhs)
+ DFunUnfolding { df_bndrs = bndrs, df_args = args }
+ -> Just (exprs_fvs args isLocalVar (mkVarSet bndrs))
+ -- DFuns are top level, so no fvs from types of bndrs
+ _other -> Nothing
\end{code}
diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index 0e9bcce895..68aaea5b5c 100644
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -24,7 +24,6 @@ import Demand
import CoreSyn
import CoreFVs
import CoreUtils
-import Pair
import Bag
import Literal
import DataCon
@@ -199,21 +198,25 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
do { ty <- lintCoreExpr rhs
; lintBinder binder -- Check match to RHS type
; binder_ty <- applySubstTy binder_ty
- ; checkTys binder_ty ty (mkRhsMsg binder ty)
+ ; checkTys binder_ty ty (mkRhsMsg binder (ptext (sLit "RHS")) ty)
+
-- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
; checkL (not (isUnLiftedType binder_ty)
|| (isNonRec rec_flag && exprOkForSpeculation rhs))
(mkRhsPrimMsg binder rhs)
+
-- Check that if the binder is top-level or recursive, it's not demanded
; checkL (not (isStrictId binder)
|| (isNonRec rec_flag && not (isTopLevel top_lvl_flag)))
(mkStrictMsg binder)
+
-- Check that if the binder is local, it is not marked as exported
; checkL (not (isExportedId binder) || isTopLevel top_lvl_flag)
(mkNonTopExportedMsg binder)
-- Check that if the binder is local, it does not have an external name
; checkL (not (isExternalName (Var.varName binder)) || isTopLevel top_lvl_flag)
(mkNonTopExternalNameMsg binder)
+
-- Check whether binder's specialisations contain any out-of-scope variables
; mapM_ (checkBndrIdInScope binder) bndr_vars
@@ -225,7 +228,9 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
-- already happened)
; checkL (case dmdTy of
StrictSig dmd_ty -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs)
- (mkArityMsg binder) }
+ (mkArityMsg binder)
+
+ ; lintIdUnfolding binder binder_ty (idUnfolding binder) }
-- We should check the unfolding, if any, but this is tricky because
-- the unfolding is a SimplifiableCoreExpr. Give up for now.
@@ -238,6 +243,14 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
-- See Note [GHC Formalism]
lintBinder var | isId var = lintIdBndr var $ \_ -> (return ())
| otherwise = return ()
+
+lintIdUnfolding :: Id -> Type -> Unfolding -> LintM ()
+lintIdUnfolding bndr bndr_ty (CoreUnfolding { uf_tmpl = rhs, uf_src = src })
+ | isStableSource src
+ = do { ty <- lintCoreExpr rhs
+ ; checkTys bndr_ty ty (mkRhsMsg bndr (ptext (sLit "unfolding")) ty) }
+lintIdUnfolding _ _ _
+ = return () -- We could check more
\end{code}
%************************************************************************
@@ -292,7 +305,8 @@ lintCoreExpr (Lit lit)
lintCoreExpr (Cast expr co)
= do { expr_ty <- lintCoreExpr expr
; co' <- applySubstCo co
- ; (_, from_ty, to_ty) <- lintCoercion co'
+ ; (_, from_ty, to_ty, r) <- lintCoercion co'
+ ; checkRole co' Representational r
; checkTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty)
; return to_ty }
@@ -386,9 +400,8 @@ lintCoreExpr (Type ty)
= pprPanic "lintCoreExpr" (ppr ty)
lintCoreExpr (Coercion co)
- = do { co' <- lintInCo co
- ; let Pair ty1 ty2 = coercionKind co'
- ; return (mkCoercionType ty1 ty2) }
+ = do { (_kind, ty1, ty2, role) <- lintInCo co
+ ; return (mkCoercionType role ty1 ty2) }
\end{code}
@@ -790,49 +803,56 @@ lint_app doc kfn kas
%************************************************************************
\begin{code}
-lintInCo :: InCoercion -> LintM OutCoercion
+lintInCo :: InCoercion -> LintM (LintedKind, LintedType, LintedType, Role)
-- Check the coercion, and apply the substitution to it
-- See Note [Linting type lets]
lintInCo co
= addLoc (InCo co) $
do { co' <- applySubstCo co
- ; _ <- lintCoercion co'
- ; return co' }
+ ; lintCoercion co' }
-lintCoercion :: OutCoercion -> LintM (LintedKind, LintedType, LintedType)
+lintCoercion :: OutCoercion -> LintM (LintedKind, LintedType, LintedType, Role)
-- Check the kind of a coercion term, returning the kind
-- Post-condition: the returned OutTypes are lint-free
-- and have the same kind as each other
-- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism]
-lintCoercion (Refl ty)
+lintCoercion (Refl r ty)
= do { k <- lintType ty
- ; return (k, ty, ty) }
+ ; return (k, ty, ty, r) }
-lintCoercion co@(TyConAppCo tc cos)
+lintCoercion co@(TyConAppCo r tc cos)
| tc `hasKey` funTyConKey
, [co1,co2] <- cos
- = do { (k1,s1,t1) <- lintCoercion co1
- ; (k2,s2,t2) <- lintCoercion co2
+ = do { (k1,s1,t1,r1) <- lintCoercion co1
+ ; (k2,s2,t2,r2) <- lintCoercion co2
; rk <- lintArrow (ptext (sLit "coercion") <+> quotes (ppr co)) k1 k2
- ; return (rk, mkFunTy s1 s2, mkFunTy t1 t2) }
+ ; checkRole co1 r r1
+ ; checkRole co2 r r2
+ ; return (rk, mkFunTy s1 s2, mkFunTy t1 t2, r) }
| otherwise
- = do { (ks,ss,ts) <- mapAndUnzip3M lintCoercion cos
+ = do { (ks,ss,ts,rs) <- mapAndUnzip4M lintCoercion cos
; rk <- lint_co_app co (tyConKind tc) (ss `zip` ks)
- ; return (rk, mkTyConApp tc ss, mkTyConApp tc ts) }
+ ; _ <- zipWith3M checkRole cos (tyConRolesX r tc) rs
+ ; return (rk, mkTyConApp tc ss, mkTyConApp tc ts, r) }
lintCoercion co@(AppCo co1 co2)
- = do { (k1,s1,t1) <- lintCoercion co1
- ; (k2,s2,t2) <- lintCoercion co2
+ = do { (k1,s1,t1,r1) <- lintCoercion co1
+ ; (k2,s2,t2,r2) <- lintCoercion co2
; rk <- lint_co_app co k1 [(s2,k2)]
- ; return (rk, mkAppTy s1 s2, mkAppTy t1 t2) }
+ ; if r1 == Phantom
+ then checkL (r2 == Phantom || r2 == Nominal)
+ (ptext (sLit "Second argument in AppCo cannot be R:") $$
+ ppr co)
+ else checkRole co Nominal r2
+ ; return (rk, mkAppTy s1 s2, mkAppTy t1 t2, r1) }
lintCoercion (ForAllCo tv co)
= do { lintTyBndrKind tv
- ; (k, s, t) <- addInScopeVar tv (lintCoercion co)
- ; return (k, mkForAllTy tv s, mkForAllTy tv t) }
+ ; (k, s, t, r) <- addInScopeVar tv (lintCoercion co)
+ ; return (k, mkForAllTy tv s, mkForAllTy tv t, r) }
lintCoercion (CoVarCo cv)
| not (isCoVar cv)
@@ -843,52 +863,58 @@ lintCoercion (CoVarCo cv)
; cv' <- lookupIdInScope cv
; let (s,t) = coVarKind cv'
k = typeKind s
+ r = coVarRole cv'
; when (isSuperKind k) $
- checkL (s `eqKind` t) (hang (ptext (sLit "Non-refl kind equality"))
- 2 (ppr cv))
- ; return (k, s, t) }
+ do { checkL (r == Nominal) (hang (ptext (sLit "Non-nominal kind equality"))
+ 2 (ppr cv))
+ ; checkL (s `eqKind` t) (hang (ptext (sLit "Non-refl kind equality"))
+ 2 (ppr cv)) }
+ ; return (k, s, t, r) }
-lintCoercion (UnsafeCo ty1 ty2)
+lintCoercion (UnivCo r ty1 ty2)
= do { k1 <- lintType ty1
; _k2 <- lintType ty2
-- ; unless (k1 `eqKind` k2) $
-- failWithL (hang (ptext (sLit "Unsafe coercion changes kind"))
-- 2 (ppr co))
- ; return (k1, ty1, ty2) }
+ ; return (k1, ty1, ty2, r) }
lintCoercion (SymCo co)
- = do { (k, ty1, ty2) <- lintCoercion co
- ; return (k, ty2, ty1) }
+ = do { (k, ty1, ty2, r) <- lintCoercion co
+ ; return (k, ty2, ty1, r) }
lintCoercion co@(TransCo co1 co2)
- = do { (k1, ty1a, ty1b) <- lintCoercion co1
- ; (_, ty2a, ty2b) <- lintCoercion co2
+ = do { (k1, ty1a, ty1b, r1) <- lintCoercion co1
+ ; (_, ty2a, ty2b, r2) <- lintCoercion co2
; checkL (ty1b `eqType` ty2a)
(hang (ptext (sLit "Trans coercion mis-match:") <+> ppr co)
2 (vcat [ppr ty1a, ppr ty1b, ppr ty2a, ppr ty2b]))
- ; return (k1, ty1a, ty2b) }
+ ; checkRole co r1 r2
+ ; return (k1, ty1a, ty2b, r1) }
lintCoercion the_co@(NthCo n co)
- = do { (_,s,t) <- lintCoercion co
+ = do { (_,s,t,r) <- lintCoercion co
; case (splitTyConApp_maybe s, splitTyConApp_maybe t) of
(Just (tc_s, tys_s), Just (tc_t, tys_t))
| tc_s == tc_t
, tys_s `equalLength` tys_t
, n < length tys_s
- -> return (ks, ts, tt)
+ -> return (ks, ts, tt, tr)
where
ts = getNth tys_s n
tt = getNth tys_t n
+ tr = nthRole r tc_s n
ks = typeKind ts
_ -> failWithL (hang (ptext (sLit "Bad getNth:"))
2 (ppr the_co $$ ppr s $$ ppr t)) }
lintCoercion the_co@(LRCo lr co)
- = do { (_,s,t) <- lintCoercion co
+ = do { (_,s,t,r) <- lintCoercion co
+ ; checkRole co Nominal r
; case (splitAppTy_maybe s, splitAppTy_maybe t) of
(Just s_pr, Just t_pr)
- -> return (k, s_pick, t_pick)
+ -> return (k, s_pick, t_pick, Nominal)
where
s_pick = pickLR lr s_pr
t_pick = pickLR lr t_pr
@@ -898,13 +924,13 @@ lintCoercion the_co@(LRCo lr co)
2 (ppr the_co $$ ppr s $$ ppr t)) }
lintCoercion (InstCo co arg_ty)
- = do { (k,s,t) <- lintCoercion co
- ; arg_kind <- lintType arg_ty
+ = do { (k,s,t,r) <- lintCoercion co
+ ; arg_kind <- lintType arg_ty
; case (splitForAllTy_maybe s, splitForAllTy_maybe t) of
(Just (tv1,ty1), Just (tv2,ty2))
| arg_kind `isSubKind` tyVarKind tv1
-> return (k, substTyWith [tv1] [arg_ty] ty1,
- substTyWith [tv2] [arg_ty] ty2)
+ substTyWith [tv2] [arg_ty] ty2, r)
| otherwise
-> failWithL (ptext (sLit "Kind mis-match in inst coercion"))
_ -> failWithL (ptext (sLit "Bad argument of inst")) }
@@ -913,27 +939,29 @@ lintCoercion co@(AxiomInstCo con ind cos)
= do { unless (0 <= ind && ind < brListLength (coAxiomBranches con))
(bad_ax (ptext (sLit "index out of range")))
-- See Note [Kind instantiation in coercions]
- ; let CoAxBranch { cab_tvs = ktvs
- , cab_lhs = lhs
- , cab_rhs = rhs } = coAxiomNthBranch con ind
+ ; let CoAxBranch { cab_tvs = ktvs
+ , cab_roles = roles
+ , cab_lhs = lhs
+ , cab_rhs = rhs } = coAxiomNthBranch con ind
; unless (equalLength ktvs cos) (bad_ax (ptext (sLit "lengths")))
; in_scope <- getInScope
; let empty_subst = mkTvSubst in_scope emptyTvSubstEnv
; (subst_l, subst_r) <- foldlM check_ki
(empty_subst, empty_subst)
- (ktvs `zip` cos)
+ (zip3 ktvs roles cos)
; let lhs' = Type.substTys subst_l lhs
rhs' = Type.substTy subst_r rhs
; case checkAxInstCo co of
- Just bad_index -> bad_ax $ ptext (sLit "inconsistent with") <+> (ppr bad_index)
+ Just bad_branch -> bad_ax $ ptext (sLit "inconsistent with") <+> (pprCoAxBranch (coAxiomTyCon con) bad_branch)
Nothing -> return ()
- ; return (typeKind rhs', mkTyConApp (coAxiomTyCon con) lhs', rhs') }
+ ; return (typeKind rhs', mkTyConApp (coAxiomTyCon con) lhs', rhs', coAxiomRole con) }
where
bad_ax what = addErrL (hang (ptext (sLit "Bad axiom application") <+> parens what)
2 (ppr co))
- check_ki (subst_l, subst_r) (ktv, co)
- = do { (k, t1, t2) <- lintCoercion co
+ check_ki (subst_l, subst_r) (ktv, role, co)
+ = do { (k, t1, t2, r) <- lintCoercion co
+ ; checkRole co role r
; let ktv_kind = Type.substTy subst_l (tyVarKind ktv)
-- Using subst_l is ok, because subst_l and subst_r
-- must agree on kind equalities
@@ -941,6 +969,11 @@ lintCoercion co@(AxiomInstCo con ind cos)
(bad_ax (ptext (sLit "check_ki2") <+> vcat [ ppr co, ppr k, ppr ktv, ppr ktv_kind ] ))
; return (Type.extendTvSubst subst_l ktv t1,
Type.extendTvSubst subst_r ktv t2) }
+
+lintCoercion co@(SubCo co')
+ = do { (k,s,t,r) <- lintCoercion co'
+ ; checkRole co Nominal r
+ ; return (k,s,t,Representational) }
\end{code}
%************************************************************************
@@ -1117,6 +1150,17 @@ checkTys :: OutType -> OutType -> MsgDoc -> LintM ()
-- annotations need only be consistent, not equal)
-- Assumes ty1,ty2 are have alrady had the substitution applied
checkTys ty1 ty2 msg = checkL (ty1 `eqType` ty2) msg
+
+checkRole :: Coercion
+ -> Role -- expected
+ -> Role -- actual
+ -> LintM ()
+checkRole co r1 r2
+ = checkL (r1 == r2)
+ (ptext (sLit "Role incompatibility: expected") <+> ppr r1 <> comma <+>
+ ptext (sLit "got") <+> ppr r2 $$
+ ptext (sLit "in") <+> ppr co)
+
\end{code}
%************************************************************************
@@ -1263,10 +1307,10 @@ mkTyAppMsg ty arg_ty
hang (ptext (sLit "Arg type:"))
4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
-mkRhsMsg :: Id -> Type -> MsgDoc
-mkRhsMsg binder ty
+mkRhsMsg :: Id -> SDoc -> Type -> MsgDoc
+mkRhsMsg binder what ty
= vcat
- [hsep [ptext (sLit "The type of this binder doesn't match the type of its RHS:"),
+ [hsep [ptext (sLit "The type of this binder doesn't match the type of its") <+> what <> colon,
ppr binder],
hsep [ptext (sLit "Binder's type:"), ppr (idType binder)],
hsep [ptext (sLit "Rhs type:"), ppr ty]]
diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs
index 084c853382..d87fdfc197 100644
--- a/compiler/coreSyn/CorePrep.lhs
+++ b/compiler/coreSyn/CorePrep.lhs
@@ -8,7 +8,8 @@ Core pass to saturate constructors and PrimOps
{-# LANGUAGE BangPatterns #-}
module CorePrep (
- corePrepPgm, corePrepExpr, cvtLitInteger
+ corePrepPgm, corePrepExpr, cvtLitInteger,
+ lookupMkIntegerName,
) where
#include "HsVersions.h"
@@ -40,6 +41,7 @@ import TysWiredIn
import DataCon
import PrimOp
import BasicTypes
+import Module
import UniqSupply
import Maybes
import OrdList
@@ -343,12 +345,13 @@ cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind
-> UniqSM (CorePrepEnv, Floats)
cpeBind top_lvl env (NonRec bndr rhs)
= do { (_, bndr1) <- cpCloneBndr env bndr
- ; let is_strict = isStrictDmd (idDemandInfo bndr)
+ ; let dmd = idDemandInfo bndr
is_unlifted = isUnLiftedType (idType bndr)
; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive
- (is_strict || is_unlifted)
+ dmd
+ is_unlifted
env bndr1 rhs
- ; let new_float = mkFloat is_strict is_unlifted bndr2 rhs2
+ ; let new_float = mkFloat dmd is_unlifted bndr2 rhs2
-- We want bndr'' in the envt, because it records
-- the evaluated-ness of the binder
@@ -358,7 +361,7 @@ cpeBind top_lvl env (NonRec bndr rhs)
cpeBind top_lvl env (Rec pairs)
= do { let (bndrs,rhss) = unzip pairs
; (env', bndrs1) <- cpCloneBndrs env (map fst pairs)
- ; stuff <- zipWithM (cpePair top_lvl Recursive False env') bndrs1 rhss
+ ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env') bndrs1 rhss
; let (floats_s, bndrs2, rhss2) = unzip3 stuff
all_pairs = foldrOL add_float (bndrs2 `zip` rhss2)
@@ -373,11 +376,11 @@ cpeBind top_lvl env (Rec pairs)
add_float b _ = pprPanic "cpeBind" (ppr b)
---------------
-cpePair :: TopLevelFlag -> RecFlag -> RhsDemand
+cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool
-> CorePrepEnv -> Id -> CoreExpr
-> UniqSM (Floats, Id, CpeRhs)
-- Used for all bindings
-cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs
+cpePair top_lvl is_rec dmd is_unlifted env bndr rhs
= do { (floats1, rhs1) <- cpeRhsE env rhs
-- See if we are allowed to float this stuff out of the RHS
@@ -390,7 +393,7 @@ cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs
else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)
-- Note [Silly extra arguments]
(do { v <- newVar (idType bndr)
- ; let float = mkFloat False False v rhs2
+ ; let float = mkFloat topDmd False v rhs2
; return ( addFloat floats2 float
, cpeEtaExpand arity (Var v)) })
@@ -404,6 +407,8 @@ cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs
; return (floats3, bndr', rhs') }
where
+ is_strict_or_unlifted = (isStrictDmd dmd) || is_unlifted
+
platform = targetPlatform (cpe_dynFlags env)
arity = idArity bndr -- We must match this arity
@@ -648,9 +653,8 @@ cpeApp env expr
[] -> (topDmd, [])
(arg_ty, res_ty) = expectJust "cpeBody:collect_args" $
splitFunTy_maybe fun_ty
- is_strict = isStrictDmd ss1
- ; (fs, arg') <- cpeArg env is_strict arg arg_ty
+ ; (fs, arg') <- cpeArg env ss1 arg arg_ty
; return (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest) }
collect_args (Var v) depth
@@ -680,8 +684,8 @@ cpeApp env expr
-- N-variable fun, better let-bind it
collect_args fun depth
- = do { (fun_floats, fun') <- cpeArg env True fun ty
- -- The True says that it's sure to be evaluated,
+ = do { (fun_floats, fun') <- cpeArg env evalDmd fun ty
+ -- The evalDmd says that it's sure to be evaluated,
-- so we'll end up case-binding it
; return (fun', (fun', depth), ty, fun_floats, []) }
where
@@ -692,9 +696,9 @@ cpeApp env expr
-- ---------------------------------------------------------------------------
-- This is where we arrange that a non-trivial argument is let-bound
-cpeArg :: CorePrepEnv -> RhsDemand
+cpeArg :: CorePrepEnv -> Demand
-> CoreArg -> Type -> UniqSM (Floats, CpeTriv)
-cpeArg env is_strict arg arg_ty
+cpeArg env dmd arg arg_ty
= do { (floats1, arg1) <- cpeRhsE env arg -- arg1 can be a lambda
; (floats2, arg2) <- if want_float floats1 arg1
then return (floats1, arg1)
@@ -708,11 +712,12 @@ cpeArg env is_strict arg arg_ty
else do
{ v <- newVar arg_ty
; let arg3 = cpeEtaExpand (exprArity arg2) arg2
- arg_float = mkFloat is_strict is_unlifted v arg3
+ arg_float = mkFloat dmd is_unlifted v arg3
; return (addFloat floats2 arg_float, varToCoreExpr v) } }
where
is_unlifted = isUnLiftedType arg_ty
- want_float = wantFloatNested NonRecursive (is_strict || is_unlifted)
+ is_strict = isStrictDmd dmd
+ want_float = wantFloatNested NonRecursive (is_strict || is_unlifted)
\end{code}
Note [Floating unlifted arguments]
@@ -907,20 +912,16 @@ tryEtaReducePrep _ _ = Nothing
\end{code}
--- -----------------------------------------------------------------------------
--- Demands
--- -----------------------------------------------------------------------------
-
-\begin{code}
-type RhsDemand = Bool -- True => used strictly; hence not top-level, non-recursive
-\end{code}
-
%************************************************************************
%* *
Floats
%* *
%************************************************************************
+Note [Pin demand info on floats]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We pin demand info on floated lets so that we can see the one-shot thunks.
+
\begin{code}
data FloatingBind
= FloatLet CoreBind -- Rhs of bindings are CpeRhss
@@ -955,12 +956,16 @@ data OkToSpec
-- ok-to-speculate unlifted bindings
| NotOkToSpec -- Some not-ok-to-speculate unlifted bindings
-mkFloat :: Bool -> Bool -> Id -> CpeRhs -> FloatingBind
-mkFloat is_strict is_unlifted bndr rhs
+mkFloat :: Demand -> Bool -> Id -> CpeRhs -> FloatingBind
+mkFloat dmd is_unlifted bndr rhs
| use_case = FloatCase bndr rhs (exprOkForSpeculation rhs)
- | otherwise = FloatLet (NonRec bndr rhs)
+ | is_hnf = FloatLet (NonRec bndr rhs)
+ | otherwise = FloatLet (NonRec (setIdDemandInfo bndr dmd) rhs)
+ -- See Note [Pin demand info on floats]
where
- use_case = is_unlifted || is_strict && not (exprIsHNF rhs)
+ is_hnf = exprIsHNF rhs
+ is_strict = isStrictDmd dmd
+ use_case = is_unlifted || is_strict && not is_hnf
-- Don't make a case for a value binding,
-- even if it's strict. Otherwise we get
-- case (\x -> e) of ...!
@@ -1107,10 +1112,18 @@ data CorePrepEnv = CPE {
cpe_mkIntegerId :: Id
}
+lookupMkIntegerName :: DynFlags -> HscEnv -> IO Id
+lookupMkIntegerName dflags hsc_env
+ = if thisPackage dflags == primPackageId
+ then return $ panic "Can't use Integer in ghc-prim"
+ else if thisPackage dflags == integerPackageId
+ then return $ panic "Can't use Integer in integer"
+ else liftM tyThingId
+ $ initTcForLookup hsc_env (tcLookupGlobal mkIntegerName)
+
mkInitialCorePrepEnv :: DynFlags -> HscEnv -> IO CorePrepEnv
mkInitialCorePrepEnv dflags hsc_env
- = do mkIntegerId <- liftM tyThingId
- $ initTcForLookup hsc_env (tcLookupGlobal mkIntegerName)
+ = do mkIntegerId <- lookupMkIntegerName dflags hsc_env
return $ CPE {
cpe_dynFlags = dflags,
cpe_env = emptyVarEnv,
diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs
index 8023786cf7..2e6d907b51 100644
--- a/compiler/coreSyn/CoreSubst.lhs
+++ b/compiler/coreSyn/CoreSubst.lhs
@@ -59,7 +59,6 @@ import Type hiding ( substTy, extendTvSubst, extendTvSubstList
, isInScope, substTyVarBndr, cloneTyVarBndr )
import Coercion hiding ( substTy, substCo, extendTvSubst, substTyVarBndr, substCoVarBndr )
-import TcType ( tcSplitDFunTy )
import TyCon ( tyConArity )
import DataCon
import PrelNames ( eqBoxDataConKey )
@@ -78,7 +77,6 @@ import Maybes
import ErrUtils
import DynFlags
import BasicTypes ( isAlwaysActive )
-import ListSetOps
import Util
import Pair
import Outputable
@@ -656,10 +654,11 @@ substUnfoldingSC subst unf -- Short-cut version
| isEmptySubst subst = unf
| otherwise = substUnfolding subst unf
-substUnfolding subst (DFunUnfolding ar con args)
- = DFunUnfolding ar con (map subst_arg args)
+substUnfolding subst df@(DFunUnfolding { df_bndrs = bndrs, df_args = args })
+ = df { df_bndrs = bndrs', df_args = args' }
where
- subst_arg = fmap (substExpr (text "dfun-unf") subst)
+ (subst',bndrs') = substBndrs subst bndrs
+ args' = map (substExpr (text "subst-unf:dfun") subst') args
substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })
-- Retain an InlineRule!
@@ -896,12 +895,12 @@ type OutExpr = CoreExpr
-- In these functions the substitution maps InVar -> OutExpr
----------------------
-simple_opt_expr, simple_opt_expr' :: Subst -> InExpr -> OutExpr
-simple_opt_expr s e = simple_opt_expr' s e
-
-simple_opt_expr' subst expr
+simple_opt_expr :: Subst -> InExpr -> OutExpr
+simple_opt_expr subst expr
= go expr
where
+ in_scope_env = (substInScope subst, simpleUnfoldingFun)
+
go (Var v) = lookupIdSubst (text "simpleOptExpr") subst v
go (App e1 e2) = simple_app subst e1 [go e2]
go (Type ty) = Type (substTy subst ty)
@@ -921,7 +920,7 @@ simple_opt_expr' subst expr
go (Case e b ty as)
-- See Note [Optimise coercion boxes agressively]
| isDeadBinder b
- , Just (con, _tys, es) <- expr_is_con_app e'
+ , Just (con, _tys, es) <- exprIsConApp_maybe in_scope_env e'
, Just (altcon, bs, rhs) <- findAlt (DataAlt con) as
= case altcon of
DEFAULT -> go rhs
@@ -1088,8 +1087,10 @@ add_info subst old_bndr new_bndr
| otherwise = maybeModifyIdInfo mb_new_info new_bndr
where mb_new_info = substIdInfo subst new_bndr (idInfo old_bndr)
-expr_is_con_app :: OutExpr -> Maybe (DataCon, [Type], [OutExpr])
-expr_is_con_app = exprIsConApp_maybe (\id -> if isAlwaysActive (idInlineActivation id) then idUnfolding id else noUnfolding)
+simpleUnfoldingFun :: IdUnfoldingFun
+simpleUnfoldingFun id
+ | isAlwaysActive (idInlineActivation id) = idUnfolding id
+ | otherwise = noUnfolding
\end{code}
Note [Inline prag in simplOpt]
@@ -1137,12 +1138,10 @@ data ConCont = CC [CoreExpr] Coercion
-- | Returns @Just (dc, [t1..tk], [x1..xn])@ if the argument expression is
-- a *saturated* constructor application of the form @dc t1..tk x1 .. xn@,
-- where t1..tk are the *universally-qantified* type args of 'dc'
-exprIsConApp_maybe :: IdUnfoldingFun -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr])
-exprIsConApp_maybe id_unf expr
- = go (Left in_scope) expr (CC [] (mkReflCo (exprType expr)))
+exprIsConApp_maybe :: InScopeEnv -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr])
+exprIsConApp_maybe (in_scope, id_unf) expr
+ = go (Left in_scope) expr (CC [] (mkReflCo Representational (exprType expr)))
where
- in_scope = mkInScopeSet (exprFreeVars expr)
-
go :: Either InScopeSet Subst
-> CoreExpr -> ConCont
-> Maybe (DataCon, [Type], [CoreExpr])
@@ -1163,17 +1162,13 @@ exprIsConApp_maybe id_unf expr
go (Left in_scope) (Var fun) cont@(CC args co)
| Just con <- isDataConWorkId_maybe fun
, count isValArg args == idArity fun
- , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars con) args
- = dealWithCoercion co (con, stripTypeArgs univ_ty_args, rest_args)
+ = dealWithCoercion co con args
-- Look through dictionary functions; see Note [Unfolding DFuns]
- | DFunUnfolding dfun_nargs con ops <- unfolding
- , length args == dfun_nargs -- See Note [DFun arity check]
- , let (dfun_tvs, _theta, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun)
- subst = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args))
- mk_arg (DFunPolyArg e) = mkApps e args
- mk_arg (DFunLamArg i) = getNth args i
- = dealWithCoercion co (con, substTys subst dfun_res_tys, map mk_arg ops)
+ | DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = dfun_args } <- unfolding
+ , bndrs `equalLength` args -- See Note [DFun arity check]
+ , let subst = mkOpenSubst in_scope (bndrs `zip` args)
+ = dealWithCoercion co con (map (substExpr (text "exprIsConApp1") subst) dfun_args)
-- Look through unfoldings, but only arity-zero one;
-- if arity > 0 we are effectively inlining a function call,
@@ -1196,17 +1191,17 @@ exprIsConApp_maybe id_unf expr
subst_co (Right s) co = CoreSubst.substCo s co
subst_arg (Left {}) e = e
- subst_arg (Right s) e = substExpr (text "exprIsConApp") s e
+ subst_arg (Right s) e = substExpr (text "exprIsConApp2") s e
extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e)
extend (Right s) v e = Right (extendSubst s v e)
-dealWithCoercion :: Coercion
- -> (DataCon, [Type], [CoreExpr])
+dealWithCoercion :: Coercion -> DataCon -> [CoreExpr]
-> Maybe (DataCon, [Type], [CoreExpr])
-dealWithCoercion co stuff@(dc, _dc_univ_args, dc_args)
+dealWithCoercion co dc dc_args
| isReflCo co
- = Just stuff
+ , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args
+ = Just (dc, stripTypeArgs univ_ty_args, rest_args)
| Pair _from_ty to_ty <- coercionKind co
, Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty
@@ -1229,23 +1224,27 @@ dealWithCoercion co stuff@(dc, _dc_univ_args, dc_args)
dc_ex_tyvars = dataConExTyVars dc
arg_tys = dataConRepArgTys dc
- (ex_args, val_args) = splitAtList dc_ex_tyvars dc_args
+ non_univ_args = dropList dc_univ_tyvars dc_args
+ (ex_args, val_args) = splitAtList dc_ex_tyvars non_univ_args
-- Make the "theta" from Fig 3 of the paper
gammas = decomposeCo tc_arity co
- theta_subst = liftCoSubstWith
+ theta_subst = liftCoSubstWith Representational
(dc_univ_tyvars ++ dc_ex_tyvars)
- (gammas ++ map mkReflCo (stripTypeArgs ex_args))
+ -- existentials are at role N
+ (gammas ++ map (mkReflCo Nominal)
+ (stripTypeArgs ex_args))
-- Cast the value arguments (which include dictionaries)
new_val_args = zipWith cast_arg arg_tys val_args
cast_arg arg_ty arg = mkCast arg (theta_subst arg_ty)
dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tyvars,
- ppr arg_tys, ppr dc_args, ppr _dc_univ_args,
+ ppr arg_tys, ppr dc_args,
ppr ex_args, ppr val_args, ppr co, ppr _from_ty, ppr to_ty, ppr to_tc ]
in
- ASSERT2( eqType _from_ty (mkTyConApp to_tc _dc_univ_args), dump_doc )
+ ASSERT2( eqType _from_ty (mkTyConApp to_tc (stripTypeArgs $ takeList dc_univ_tyvars dc_args))
+ , dump_doc )
ASSERT2( all isTypeArg ex_args, dump_doc )
ASSERT2( equalLength val_args arg_tys, dump_doc )
Just (dc, to_tc_arg_tys, ex_args ++ new_val_args)
@@ -1278,16 +1277,16 @@ type args) matches what the dfun is expecting. This may be *less*
than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn
\begin{code}
-exprIsLiteral_maybe :: IdUnfoldingFun -> CoreExpr -> Maybe Literal
+exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal
-- Same deal as exprIsConApp_maybe, but much simpler
-- Nevertheless we do need to look through unfoldings for
-- Integer literals, which are vigorously hoisted to top level
-- and not subsequently inlined
-exprIsLiteral_maybe id_unf e
+exprIsLiteral_maybe env@(_, id_unf) e
= case e of
Lit l -> Just l
- Tick _ e' -> exprIsLiteral_maybe id_unf e' -- dubious?
+ Tick _ e' -> exprIsLiteral_maybe env e' -- dubious?
Var v | Just rhs <- expandUnfolding_maybe (id_unf v)
- -> exprIsLiteral_maybe id_unf rhs
+ -> exprIsLiteral_maybe env rhs
_ -> Nothing
\end{code}
diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index 010b6cb6de..dd7307d190 100644
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -49,7 +49,6 @@ module CoreSyn (
-- * Unfolding data types
Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..),
- DFunArg(..), dfunArgExprs,
-- ** Constructing 'Unfolding's
noUnfolding, evaldUnfolding, mkOtherCon,
@@ -78,7 +77,7 @@ module CoreSyn (
-- * Core rule data types
CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only
- RuleName, IdUnfoldingFun,
+ RuleName, RuleFun, IdUnfoldingFun, InScopeEnv,
-- ** Operations on 'CoreRule's
seqRules, ruleArity, ruleName, ruleIdName, ruleActivation,
@@ -92,6 +91,7 @@ module CoreSyn (
#include "HsVersions.h"
import CostCentre
+import VarEnv( InScopeSet )
import Var
import Type
import Coercion
@@ -577,13 +577,16 @@ data CoreRule
ru_fn :: Name, -- ^ As above
ru_nargs :: Int, -- ^ Number of arguments that 'ru_try' consumes,
-- if it fires, including type arguments
- ru_try :: DynFlags -> Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
+ ru_try :: RuleFun
-- ^ This function does the rewrite. It given too many
-- arguments, it simply discards them; the returned 'CoreExpr'
-- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args
}
-- See Note [Extra args in rule matching] in Rules.lhs
+type RuleFun = DynFlags -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr
+type InScopeEnv = (InScopeSet, IdUnfoldingFun)
+
type IdUnfoldingFun = Id -> Unfolding
-- A function that embodies how to unfold an Id if you need
-- to do that in the Rule. The reason we need to pass this info in
@@ -663,17 +666,15 @@ data Unfolding
--
-- Here, @f@ gets an @OtherCon []@ unfolding.
- | DFunUnfolding -- The Unfolding of a DFunId
+ | DFunUnfolding { -- The Unfolding of a DFunId
-- See Note [DFun unfoldings]
- -- df = /\a1..am. \d1..dn. MkD (op1 a1..am d1..dn)
+ -- df = /\a1..am. \d1..dn. MkD t1 .. tk
+ -- (op1 a1..am d1..dn)
-- (op2 a1..am d1..dn)
-
- Arity -- Arity = m+n, the *total* number of args
- -- (unusually, both type and value) to the dfun
-
- DataCon -- The dictionary data constructor (possibly a newtype datacon)
-
- [DFunArg CoreExpr] -- Specification of superclasses and methods, in positional order
+ df_bndrs :: [Var], -- The bound variables [a1..m],[d1..dn]
+ df_con :: DataCon, -- The dictionary data constructor (never a newtype datacon)
+ df_args :: [CoreExpr] -- Args of the data con: types, superclasses and methods,
+ } -- in positional order
| CoreUnfolding { -- An unfolding for an Id with no pragma,
-- or perhaps a NOINLINE pragma
@@ -710,20 +711,6 @@ data Unfolding
--
-- uf_guidance: Tells us about the /size/ of the unfolding template
-------------------------------------------------
-data DFunArg e -- Given (df a b d1 d2 d3)
- = DFunPolyArg e -- Arg is (e a b d1 d2 d3)
- | DFunLamArg Int -- Arg is one of [a,b,d1,d2,d3], zero indexed
- deriving( Functor )
-
- -- 'e' is often CoreExpr, which are usually variables, but can
- -- be trivial expressions instead (e.g. a type application).
-
-dfunArgExprs :: [DFunArg e] -> [e]
-dfunArgExprs [] = []
-dfunArgExprs (DFunPolyArg e : as) = e : dfunArgExprs as
-dfunArgExprs (DFunLamArg {} : as) = dfunArgExprs as
-
------------------------------------------------
data UnfoldingSource
diff --git a/compiler/coreSyn/CoreTidy.lhs b/compiler/coreSyn/CoreTidy.lhs
index 77e5f09faa..f0c947246a 100644
--- a/compiler/coreSyn/CoreTidy.lhs
+++ b/compiler/coreSyn/CoreTidy.lhs
@@ -206,8 +206,11 @@ tidyIdBndr env@(tidy_env, var_env) id
------------ Unfolding --------------
tidyUnfolding :: TidyEnv -> Unfolding -> Unfolding -> Unfolding
-tidyUnfolding tidy_env (DFunUnfolding ar con args) _
- = DFunUnfolding ar con (map (fmap (tidyExpr tidy_env)) args)
+tidyUnfolding tidy_env df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) _
+ = df { df_bndrs = bndrs', df_args = map (tidyExpr tidy_env') args }
+ where
+ (tidy_env', bndrs') = tidyBndrs tidy_env bndrs
+
tidyUnfolding tidy_env
unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })
unf_from_rhs
diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index 2198b36c64..bbf9e0eb40 100644
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -48,7 +48,6 @@ module CoreUnfold (
import DynFlags
import CoreSyn
import PprCore () -- Instances
-import TcType ( tcSplitDFunTy )
import OccurAnal ( occurAnalyseExpr )
import CoreSubst hiding( substTy )
import CoreArity ( manifestArity, exprBotStrictness_maybe )
@@ -98,13 +97,9 @@ mkImplicitUnfolding dflags expr
mkSimpleUnfolding :: DynFlags -> CoreExpr -> Unfolding
mkSimpleUnfolding dflags = mkUnfolding dflags InlineRhs False False
-mkDFunUnfolding :: Type -> [DFunArg CoreExpr] -> Unfolding
-mkDFunUnfolding dfun_ty ops
- = DFunUnfolding dfun_nargs data_con ops
- where
- (tvs, theta, cls, _) = tcSplitDFunTy dfun_ty
- dfun_nargs = length tvs + length theta
- data_con = classDataCon cls
+mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding
+mkDFunUnfolding bndrs con ops
+ = DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = ops }
mkWwInlineRule :: CoreExpr -> Arity -> Unfolding
mkWwInlineRule expr arity
@@ -952,6 +947,8 @@ tryUnfolding dflags id lone_variable
where
n_val_args = length arg_infos
saturated = n_val_args >= uf_arity
+ cont_info' | n_val_args > uf_arity = ValAppCtxt
+ | otherwise = cont_info
result | yes_or_no = Just unf_template
| otherwise = Nothing
@@ -969,12 +966,11 @@ tryUnfolding dflags id lone_variable
some_benefit
| not saturated = interesting_args -- Under-saturated
-- Note [Unsaturated applications]
- | n_val_args > uf_arity = True -- Over-saturated
- | otherwise = interesting_args -- Saturated
- || interesting_saturated_call
+ | otherwise = interesting_args -- Saturated or over-saturated
+ || interesting_call
- interesting_saturated_call
- = case cont_info of
+ interesting_call
+ = case cont_info' of
BoringCtxt -> not is_top && uf_arity > 0 -- Note [Nested functions]
CaseCtxt -> not (lone_variable && is_wf) -- Note [Lone variables]
ArgCtxt {} -> uf_arity > 0 -- Note [Inlining in ArgCtxt]
@@ -996,7 +992,7 @@ tryUnfolding dflags id lone_variable
discounted_size = size - discount
small_enough = discounted_size <= ufUseThreshold dflags
discount = computeDiscount dflags uf_arity arg_discounts
- res_discount arg_infos cont_info
+ res_discount arg_infos cont_info'
\end{code}
Note [RHS of lets]
@@ -1116,7 +1112,7 @@ AND
then we should not inline it (unless there is some other reason,
e.g. is is the sole occurrence). That is what is happening at
-the use of 'lone_variable' in 'interesting_saturated_call'.
+the use of 'lone_variable' in 'interesting_call'.
Why? At least in the case-scrutinee situation, turning
let x = (a,b) in case x of y -> ...
@@ -1187,9 +1183,9 @@ This kind of thing can occur if you have
which Roman did.
\begin{code}
-computeDiscount :: DynFlags -> Int -> [Int] -> Int -> [ArgSummary] -> CallCtxt
+computeDiscount :: DynFlags -> Arity -> [Int] -> Int -> [ArgSummary] -> CallCtxt
-> Int
-computeDiscount dflags n_vals_wanted arg_discounts res_discount arg_infos cont_info
+computeDiscount dflags uf_arity arg_discounts res_discount arg_infos cont_info
-- We multiple the raw discounts (args_discount and result_discount)
-- ty opt_UnfoldingKeenessFactor because the former have to do with
-- *size* whereas the discounts imply that there's some extra
@@ -1199,7 +1195,7 @@ computeDiscount dflags n_vals_wanted arg_discounts res_discount arg_infos cont_i
= 10 -- Discount of 1 because the result replaces the call
-- so we count 1 for the function itself
- + 10 * length (take n_vals_wanted arg_infos)
+ + 10 * length (take uf_arity arg_infos)
-- Discount of (un-scaled) 1 for each arg supplied,
-- because the result replaces the call
@@ -1214,8 +1210,9 @@ computeDiscount dflags n_vals_wanted arg_discounts res_discount arg_infos cont_i
res_discount' = case cont_info of
BoringCtxt -> 0
- CaseCtxt -> res_discount
- _other -> 40 `min` res_discount
+ CaseCtxt -> res_discount -- Presumably a constructor
+ ValAppCtxt -> res_discount -- Presumably a function
+ ArgCtxt {} -> 40 `min` res_discount
-- res_discount can be very large when a function returns
-- constructors; but we only want to invoke that large discount
-- when there's a case continuation.
diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 4e45da4b4b..ddf4406081 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -30,9 +30,6 @@ module CoreUtils (
coreBindsSize, exprSize,
CoreStats(..), coreBindsStats,
- -- * Hashing
- hashExpr,
-
-- * Equality
cheapEqExpr, eqExpr, eqExprX,
@@ -48,6 +45,7 @@ module CoreUtils (
import CoreSyn
import PprCore
+import CoreFVs( exprFreeVars )
import Var
import SrcLoc
import VarEnv
@@ -70,8 +68,6 @@ import Maybes
import Platform
import Util
import Pair
-import Data.Word
-import Data.Bits
import Data.List
\end{code}
@@ -192,9 +188,12 @@ mkCast (Coercion e_co) co
= Coercion (mkCoCast e_co co)
mkCast (Cast expr co2) co
- = ASSERT(let { Pair from_ty _to_ty = coercionKind co;
- Pair _from_ty2 to_ty2 = coercionKind co2} in
- from_ty `eqType` to_ty2 )
+ = WARN(let { Pair from_ty _to_ty = coercionKind co;
+ Pair _from_ty2 to_ty2 = coercionKind co2} in
+ not (from_ty `eqType` to_ty2),
+ vcat ([ ptext (sLit "expr:") <+> ppr expr
+ , ptext (sLit "co2:") <+> ppr co2
+ , ptext (sLit "co:") <+> ppr co ]) )
mkCast expr (mkTransCo co2 co)
mkCast expr co
@@ -567,8 +566,8 @@ getIdFromTrivialExpr e = go e
\end{code}
exprIsBottom is a very cheap and cheerful function; it may return
-False for bottoming expressions, but it never costs much to ask.
-See also CoreArity.exprBotStrictness_maybe, but that's a bit more
+False for bottoming expressions, but it never costs much to ask. See
+also CoreArity.exprBotStrictness_maybe, but that's a bit more
expensive.
\begin{code}
@@ -1519,81 +1518,6 @@ altSize (c,bs,e) = c `seq` bndrsSize bs + exprSize e
%************************************************************************
%* *
-\subsection{Hashing}
-%* *
-%************************************************************************
-
-\begin{code}
-hashExpr :: CoreExpr -> Int
--- ^ Two expressions that hash to the same @Int@ may be equal (but may not be)
--- Two expressions that hash to the different Ints are definitely unequal.
---
--- The emphasis is on a crude, fast hash, rather than on high precision.
---
--- But unequal here means \"not identical\"; two alpha-equivalent
--- expressions may hash to the different Ints.
---
--- We must be careful that @\\x.x@ and @\\y.y@ map to the same hash code,
--- (at least if we want the above invariant to be true).
-
-hashExpr e = fromIntegral (hash_expr (1,emptyVarEnv) e .&. 0x7fffffff)
- -- UniqFM doesn't like negative Ints
-
-type HashEnv = (Int, VarEnv Int) -- Hash code for bound variables
-
-hash_expr :: HashEnv -> CoreExpr -> Word32
--- Word32, because we're expecting overflows here, and overflowing
--- signed types just isn't cool. In C it's even undefined.
-hash_expr env (Tick _ e) = hash_expr env e
-hash_expr env (Cast e _) = hash_expr env e
-hash_expr env (Var v) = hashVar env v
-hash_expr _ (Lit lit) = fromIntegral (hashLiteral lit)
-hash_expr env (App f e) = hash_expr env f * fast_hash_expr env e
-hash_expr env (Let (NonRec b r) e) = hash_expr (extend_env env b) e * fast_hash_expr env r
-hash_expr env (Let (Rec ((b,_):_)) e) = hash_expr (extend_env env b) e
-hash_expr _ (Let (Rec []) _) = panic "hash_expr: Let (Rec []) _"
-hash_expr env (Case e _ _ _) = hash_expr env e
-hash_expr env (Lam b e) = hash_expr (extend_env env b) e
-hash_expr env (Coercion co) = fast_hash_co env co
-hash_expr _ (Type _) = WARN(True, text "hash_expr: type") 1
--- Shouldn't happen. Better to use WARN than trace, because trace
--- prevents the CPR optimisation kicking in for hash_expr.
-
-fast_hash_expr :: HashEnv -> CoreExpr -> Word32
-fast_hash_expr env (Var v) = hashVar env v
-fast_hash_expr env (Type t) = fast_hash_type env t
-fast_hash_expr env (Coercion co) = fast_hash_co env co
-fast_hash_expr _ (Lit lit) = fromIntegral (hashLiteral lit)
-fast_hash_expr env (Cast e _) = fast_hash_expr env e
-fast_hash_expr env (Tick _ e) = fast_hash_expr env e
-fast_hash_expr env (App _ a) = fast_hash_expr env a -- A bit idiosyncratic ('a' not 'f')!
-fast_hash_expr _ _ = 1
-
-fast_hash_type :: HashEnv -> Type -> Word32
-fast_hash_type env ty
- | Just tv <- getTyVar_maybe ty = hashVar env tv
- | Just (tc,tys) <- splitTyConApp_maybe ty = let hash_tc = fromIntegral (hashName (tyConName tc))
- in foldr (\t n -> fast_hash_type env t + n) hash_tc tys
- | otherwise = 1
-
-fast_hash_co :: HashEnv -> Coercion -> Word32
-fast_hash_co env co
- | Just cv <- getCoVar_maybe co = hashVar env cv
- | Just (tc,cos) <- splitTyConAppCo_maybe co = let hash_tc = fromIntegral (hashName (tyConName tc))
- in foldr (\c n -> fast_hash_co env c + n) hash_tc cos
- | otherwise = 1
-
-extend_env :: HashEnv -> Var -> (Int, VarEnv Int)
-extend_env (n,env) b = (n+1, extendVarEnv env b n)
-
-hashVar :: HashEnv -> Var -> Word32
-hashVar (_,env) v
- = fromIntegral (lookupVarEnv env v `orElse` hashName (idName v))
-\end{code}
-
-
-%************************************************************************
-%* *
Eta reduction
%* *
%************************************************************************
@@ -1606,6 +1530,11 @@ are going to avoid allocating this thing altogether.
There are some particularly delicate points here:
+* We want to eta-reduce if doing so leaves a trivial expression,
+ *including* a cast. For example
+ \x. f |> co --> f |> co
+ (provided co doesn't mention x)
+
* Eta reduction is not valid in general:
\x. bot /= bot
This matters, partly for old-fashioned correctness reasons but,
@@ -1622,7 +1551,7 @@ There are some particularly delicate points here:
Result: seg-fault because the boolean case actually gets a function value.
See Trac #1947.
- So it's important to to the right thing.
+ So it's important to do the right thing.
* Note [Arity care]: we need to be careful if we just look at f's
arity. Currently (Dec07), f's arity is visible in its own RHS (see
@@ -1682,7 +1611,7 @@ need to address that here.
\begin{code}
tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr
tryEtaReduce bndrs body
- = go (reverse bndrs) body (mkReflCo (exprType body))
+ = go (reverse bndrs) body (mkReflCo Representational (exprType body))
where
incoming_arity = count isId bndrs
@@ -1693,7 +1622,11 @@ tryEtaReduce bndrs body
-- See Note [Eta reduction with casted arguments]
-- for why we have an accumulating coercion
go [] fun co
- | ok_fun fun = Just (mkCast fun co)
+ | ok_fun fun
+ , let result = mkCast fun co
+ , not (any (`elemVarSet` exprFreeVars result) bndrs)
+ = Just result -- Check for any of the binders free in the result
+ -- including the accumulated coercion
go (b : bs) (App fun arg) co
| Just co' <- ok_arg b arg co
@@ -1703,13 +1636,10 @@ tryEtaReduce bndrs body
---------------
-- Note [Eta reduction conditions]
- ok_fun (App fun (Type ty))
- | not (any (`elemVarSet` tyVarsOfType ty) bndrs)
- = ok_fun fun
- ok_fun (Var fun_id)
- = not (fun_id `elem` bndrs)
- && (ok_fun_id fun_id || all ok_lam bndrs)
- ok_fun _fun = False
+ ok_fun (App fun (Type {})) = ok_fun fun
+ ok_fun (Cast fun _) = ok_fun fun
+ ok_fun (Var fun_id) = ok_fun_id fun_id || all ok_lam bndrs
+ ok_fun _fun = False
---------------
ok_fun_id fun = fun_arity fun >= incoming_arity
@@ -1739,9 +1669,10 @@ tryEtaReduce bndrs body
| Just tv <- getTyVar_maybe ty
, bndr == tv = Just (mkForAllCo tv co)
ok_arg bndr (Var v) co
- | bndr == v = Just (mkFunCo (mkReflCo (idType bndr)) co)
+ | bndr == v = Just (mkFunCo Representational
+ (mkReflCo Representational (idType bndr)) co)
ok_arg bndr (Cast (Var v) co_arg) co
- | bndr == v = Just (mkFunCo (mkSymCo co_arg) co)
+ | bndr == v = Just (mkFunCo Representational (mkSymCo co_arg) co)
-- The simplifier combines multiple casts into one,
-- so we can have a simple-minded pattern match here
ok_arg _ _ _ = Nothing
diff --git a/compiler/coreSyn/ExternalCore.lhs b/compiler/coreSyn/ExternalCore.lhs
index f002c3a3e5..ecc24b1155 100644
--- a/compiler/coreSyn/ExternalCore.lhs
+++ b/compiler/coreSyn/ExternalCore.lhs
@@ -34,7 +34,7 @@ data Exp
| Lam Bind Exp
| Let Vdefg Exp
| Case Exp Vbind Ty [Alt] {- non-empty list -}
- | Cast Exp Ty
+ | Cast Exp Coercion
| Tick String Exp {- XXX probably wrong -}
| External String String Ty {- target name, convention, and type -}
| DynExternal String Ty {- convention and type (incl. Addr# of target as first arg) -}
@@ -52,23 +52,30 @@ data Alt
type Vbind = (Var,Ty)
type Tbind = (Tvar,Kind)
--- Internally, we represent types and coercions separately; but for
--- the purposes of external core (at least for now) it's still
--- convenient to collapse them into a single type.
data Ty
= Tvar Tvar
| Tcon (Qual Tcon)
| Tapp Ty Ty
| Tforall Tbind Ty
+
+data Coercion
-- We distinguish primitive coercions because External Core treats
-- them specially, so we have to print them out with special syntax.
- | TransCoercion Ty Ty
- | SymCoercion Ty
- | UnsafeCoercion Ty Ty
- | InstCoercion Ty Ty
- | NthCoercion Int Ty
- | AxiomCoercion (Qual Tcon) Int [Ty]
- | LRCoercion LeftOrRight Ty
+ = ReflCoercion Role Ty
+ | SymCoercion Coercion
+ | TransCoercion Coercion Coercion
+ | TyConAppCoercion Role (Qual Tcon) [Coercion]
+ | AppCoercion Coercion Coercion
+ | ForAllCoercion Tbind Coercion
+ | CoVarCoercion Var
+ | UnivCoercion Role Ty Ty
+ | InstCoercion Coercion Ty
+ | NthCoercion Int Coercion
+ | AxiomCoercion (Qual Tcon) Int [Coercion]
+ | LRCoercion LeftOrRight Coercion
+ | SubCoercion Coercion
+
+data Role = Nominal | Representational | Phantom
data LeftOrRight = CLeft | CRight
diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs
index 4cc199853b..c6fc2be21f 100644
--- a/compiler/coreSyn/MkCore.lhs
+++ b/compiler/coreSyn/MkCore.lhs
@@ -53,7 +53,8 @@ module MkCore (
mkRuntimeErrorApp, mkImpossibleExpr, errorIds,
rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID,
nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,
- pAT_ERROR_ID, eRROR_ID, rEC_SEL_ERROR_ID, aBSENT_ERROR_ID
+ pAT_ERROR_ID, eRROR_ID, rEC_SEL_ERROR_ID, aBSENT_ERROR_ID,
+ uNDEFINED_ID, undefinedName
) where
#include "HsVersions.h"
@@ -659,6 +660,9 @@ errorIds
-- import its type from the interface file; we just get
-- the Id defined here. Which has an 'open-tyvar' type.
+ uNDEFINED_ID, -- Ditto for 'undefined'. The big deal is to give it
+ -- an 'open-tyvar' type.
+
rUNTIME_ERROR_ID,
iRREFUT_PAT_ERROR_ID,
nON_EXHAUSTIVE_GUARDS_ERROR_ID,
@@ -700,7 +704,7 @@ nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName
aBSENT_ERROR_ID = mkRuntimeErrorId absentErrorName
mkRuntimeErrorId :: Name -> Id
-mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy
+mkRuntimeErrorId name = pc_bottoming_Id1 name runtimeErrorTy
runtimeErrorTy :: Type
-- The runtime error Ids take a UTF8-encoded string as argument
@@ -712,15 +716,33 @@ errorName :: Name
errorName = mkWiredInIdName gHC_ERR (fsLit "error") errorIdKey eRROR_ID
eRROR_ID :: Id
-eRROR_ID = pc_bottoming_Id errorName errorTy
+eRROR_ID = pc_bottoming_Id1 errorName errorTy
-errorTy :: Type
+errorTy :: Type -- See Note [Error and friends have an "open-tyvar" forall]
errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
- -- Notice the openAlphaTyVar. It says that "error" can be applied
- -- to unboxed as well as boxed types. This is OK because it never
- -- returns, so the return type is irrelevant.
+
+undefinedName :: Name
+undefinedName = mkWiredInIdName gHC_ERR (fsLit "undefined") undefinedKey uNDEFINED_ID
+
+uNDEFINED_ID :: Id
+uNDEFINED_ID = pc_bottoming_Id0 undefinedName undefinedTy
+
+undefinedTy :: Type -- See Note [Error and friends have an "open-tyvar" forall]
+undefinedTy = mkSigmaTy [openAlphaTyVar] [] openAlphaTy
\end{code}
+Note [Error and friends have an "open-tyvar" forall]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+'error' and 'undefined' have types
+ error :: forall (a::OpenKind). String -> a
+ undefined :: forall (a::OpenKind). a
+Notice the 'OpenKind' (manifested as openAlphaTyVar in the code). This ensures that
+"error" can be instantiated at
+ * unboxed as well as boxed types
+ * polymorphic types
+This is OK because it never returns, so the return type is irrelevant.
+See Note [OpenTypeKind accepts foralls] in TcUnify.
+
%************************************************************************
%* *
@@ -729,9 +751,9 @@ errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy
%************************************************************************
\begin{code}
-pc_bottoming_Id :: Name -> Type -> Id
+pc_bottoming_Id1 :: Name -> Type -> Id
-- Function of arity 1, which diverges after being given one argument
-pc_bottoming_Id name ty
+pc_bottoming_Id1 name ty
= mkVanillaGlobalWithInfo name ty bottoming_info
where
bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig
@@ -749,5 +771,13 @@ pc_bottoming_Id name ty
strict_sig = mkStrictSig (mkTopDmdType [evalDmd] botRes)
-- These "bottom" out, no matter what their arguments
+
+pc_bottoming_Id0 :: Name -> Type -> Id
+-- Same but arity zero
+pc_bottoming_Id0 name ty
+ = mkVanillaGlobalWithInfo name ty bottoming_info
+ where
+ bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig
+ strict_sig = mkStrictSig (mkTopDmdType [] botRes)
\end{code}
diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs
index aa5e365be9..a0776af218 100644
--- a/compiler/coreSyn/MkExternalCore.lhs
+++ b/compiler/coreSyn/MkExternalCore.lhs
@@ -2,15 +2,8 @@
% (c) The University of Glasgow 2001-2006
%
\begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
module MkExternalCore (
- emitExternalCore
+ emitExternalCore
) where
#include "HsVersions.h"
@@ -18,7 +11,7 @@ module MkExternalCore (
import qualified ExternalCore as C
import Module
import CoreSyn
-import HscTypes
+import HscTypes
import TyCon
import CoAxiom
-- import Class
@@ -44,16 +37,15 @@ import qualified Data.ByteString as BS
import Data.Char
import System.IO
-emitExternalCore :: DynFlags -> CgGuts -> IO ()
-emitExternalCore dflags cg_guts
+emitExternalCore :: DynFlags -> FilePath -> CgGuts -> IO ()
+emitExternalCore dflags extCore_filename cg_guts
| gopt Opt_EmitExternalCore dflags
- = (do handle <- openFile corename WriteMode
+ = (do handle <- openFile extCore_filename WriteMode
hPutStrLn handle (show (mkExternalCore dflags cg_guts))
hClose handle)
`catchIO` (\_ -> pprPanic "Failed to open or write external core output file"
- (text corename))
- where corename = extCoreName dflags
-emitExternalCore _ _
+ (text extCore_filename))
+emitExternalCore _ _ _
| otherwise
= return ()
@@ -98,14 +90,14 @@ collect_tdefs :: DynFlags -> TyCon -> [C.Tdef] -> [C.Tdef]
collect_tdefs dflags tcon tdefs
| isAlgTyCon tcon = tdef: tdefs
where
- tdef | isNewTyCon tcon =
- C.Newtype (qtc dflags tcon)
+ tdef | isNewTyCon tcon =
+ C.Newtype (qtc dflags tcon)
(qcc dflags (newTyConCo tcon))
- (map make_tbind tyvars)
+ (map make_tbind tyvars)
(make_ty dflags (snd (newTyConRhs tcon)))
- | otherwise =
- C.Data (qtc dflags tcon) (map make_tbind tyvars)
- (map (make_cdef dflags) (tyConDataCons tcon))
+ | otherwise =
+ C.Data (qtc dflags tcon) (map make_tbind tyvars)
+ (map (make_cdef dflags) (tyConDataCons tcon))
tyvars = tyConTyVars tcon
collect_tdefs _ _ tdefs = tdefs
@@ -118,20 +110,20 @@ qcc dflags = make_con_qid dflags . co_ax_name
make_cdef :: DynFlags -> DataCon -> C.Cdef
make_cdef dflags dcon = C.Constr dcon_name existentials tys
- where
+ where
dcon_name = make_qid dflags False False (dataConName dcon)
existentials = map make_tbind ex_tyvars
ex_tyvars = dataConExTyVars dcon
- tys = map (make_ty dflags) (dataConRepArgTys dcon)
+ tys = map (make_ty dflags) (dataConRepArgTys dcon)
make_tbind :: TyVar -> C.Tbind
make_tbind tv = (make_var_id (tyVarName tv), make_kind (tyVarKind tv))
-
+
make_vbind :: DynFlags -> Var -> C.Vbind
make_vbind dflags v = (make_var_id (Var.varName v), make_ty dflags (varType v))
make_vdef :: Bool -> CoreBind -> CoreM C.Vdefg
-make_vdef topLevel b =
+make_vdef topLevel b =
case b of
NonRec v e -> f (v,e) >>= (return . C.Nonrec)
Rec ves -> mapM f ves >>= (return . C.Rec)
@@ -144,7 +136,7 @@ make_vdef topLevel b =
-- use local flag to determine where to add the module name
dflags <- getDynFlags
return (local, make_qid dflags local True vName, make_ty dflags (varType v),rhs)
- where vName = Var.varName v
+ where vName = Var.varName v
make_exp :: CoreExpr -> CoreM C.Exp
make_exp (Var v) = do
@@ -153,11 +145,11 @@ make_exp (Var v) = do
dflags <- getDynFlags
return $
case idDetails v of
- FCallId (CCall (CCallSpec (StaticTarget nm _ True) callconv _))
+ FCallId (CCall (CCallSpec (StaticTarget nm _ True) callconv _))
-> C.External (unpackFS nm) (showPpr dflags callconv) (make_ty dflags (varType v))
FCallId (CCall (CCallSpec (StaticTarget _ _ False) _ _)) ->
panic "make_exp: FFI values not supported"
- FCallId (CCall (CCallSpec DynamicTarget callconv _))
+ FCallId (CCall (CCallSpec DynamicTarget callconv _))
-> C.DynExternal (showPpr dflags callconv) (make_ty dflags (varType v))
-- Constructors are always exported, so make sure to declare them
-- with qualified names
@@ -175,7 +167,7 @@ make_exp (App e1 e2) = do
rator <- make_exp e1
rand <- make_exp e2
return $ C.App rator rand
-make_exp (Lam v e) | isTyVar v = make_exp e >>= (\ b ->
+make_exp (Lam v e) | isTyVar v = make_exp e >>= (\ b ->
return $ C.Lam (C.Tb (make_tbind v)) b)
make_exp (Lam v e) | otherwise = do b <- make_exp e
dflags <- getDynFlags
@@ -202,8 +194,8 @@ make_alt (DataAlt dcon, vs, e) = do
return $ C.Acon (make_con_qid dflags (dataConName dcon))
(map make_tbind tbs)
(map (make_vbind dflags) vbs)
- newE
- where (tbs,vbs) = span isTyVar vs
+ newE
+ where (tbs,vbs) = span isTyVar vs
make_alt (LitAlt l,_,e) = do x <- make_exp e
dflags <- getDynFlags
return $ C.Alit (make_lit dflags l) x
@@ -215,14 +207,14 @@ make_alt a@(DEFAULT,_ ,_) = pprPanic ("MkExternalCore: make_alt: DEFAULT "
make_lit :: DynFlags -> Literal -> C.Lit
-make_lit dflags l =
+make_lit dflags l =
case l of
-- Note that we need to check whether the character is "big".
-- External Core only allows character literals up to '\xff'.
MachChar i | i <= chr 0xff -> C.Lchar i t
-- For a character bigger than 0xff, we represent it in ext-core
-- as an int lit with a char type.
- MachChar i -> C.Lint (fromIntegral $ ord i) t
+ MachChar i -> C.Lint (fromIntegral $ ord i) t
MachStr s -> C.Lstring (BS.unpack s) t
MachNullAddr -> C.Lint 0 t
MachInt i -> C.Lint i t
@@ -233,7 +225,7 @@ make_lit dflags l =
MachDouble r -> C.Lrational r t
LitInteger i _ -> C.Lint i t
_ -> pprPanic "MkExternalCore died: make_lit" (ppr l)
- where
+ where
t = make_ty dflags (literalType l)
-- Expand type synonyms, then convert.
@@ -241,32 +233,32 @@ make_ty :: DynFlags -> Type -> C.Ty -- Be sure to expand types recursively!
-- example: FilePath ~> String ~> [Char]
make_ty dflags t | Just expanded <- tcView t = make_ty dflags expanded
make_ty dflags t = make_ty' dflags t
-
+
-- note calls to make_ty so as to expand types recursively
make_ty' :: DynFlags -> Type -> C.Ty
make_ty' _ (TyVarTy tv) = C.Tvar (make_var_id (tyVarName tv))
-make_ty' dflags (AppTy t1 t2) = C.Tapp (make_ty dflags t1) (make_ty dflags t2)
-make_ty' dflags (FunTy t1 t2) = make_ty dflags (TyConApp funTyCon [t1,t2])
+make_ty' dflags (AppTy t1 t2) = C.Tapp (make_ty dflags t1) (make_ty dflags t2)
+make_ty' dflags (FunTy t1 t2) = make_ty dflags (TyConApp funTyCon [t1,t2])
make_ty' dflags (ForAllTy tv t) = C.Tforall (make_tbind tv) (make_ty dflags t)
make_ty' dflags (TyConApp tc ts) = make_tyConApp dflags tc ts
make_ty' _ (LitTy {}) = panic "MkExernalCore can't do literal types yet"
-- Newtypes are treated just like any other type constructor; not expanded
-- Reason: predTypeRep does substitution and, while substitution deals
--- correctly with name capture, it's only correct if you see the uniques!
--- If you just see occurrence names, name capture may occur.
+-- correctly with name capture, it's only correct if you see the uniques!
+-- If you just see occurrence names, name capture may occur.
-- Example: newtype A a = A (forall b. b -> a)
--- test :: forall q b. q -> A b
--- test _ = undefined
--- Here the 'a' gets substituted by 'b', which is captured.
+-- test :: forall q b. q -> A b
+-- test _ = undefined
+-- Here the 'a' gets substituted by 'b', which is captured.
-- Another solution would be to expand newtypes before tidying; but that would
-- expose the representation in interface files, which definitely isn't right.
-- Maybe CoreTidy should know whether to expand newtypes or not?
make_tyConApp :: DynFlags -> TyCon -> [Type] -> C.Ty
make_tyConApp dflags tc ts =
- foldl C.Tapp (C.Tcon (qtc dflags tc))
- (map (make_ty dflags) ts)
+ foldl C.Tapp (C.Tcon (qtc dflags tc))
+ (map (make_ty dflags) ts)
make_kind :: Kind -> C.Kind
make_kind (FunTy k1 k2) = C.Karrow (make_kind k1) (make_kind k2)
@@ -303,13 +295,13 @@ make_mid dflags m
<> text ":"
<> (pprEncoded $ pprModuleName $ moduleName m)
where pprEncoded = pprCode CStyle
-
+
make_qid :: DynFlags -> Bool -> Bool -> Name -> C.Qual C.Id
make_qid dflags force_unqual is_var n = (mname,make_id is_var n)
- where mname =
+ where mname =
case nameModule_maybe n of
Just m | not force_unqual -> make_mid dflags m
- _ -> ""
+ _ -> ""
make_var_qid :: DynFlags -> Bool -> Name -> C.Qual C.Id
make_var_qid dflags force_unqual = make_qid dflags force_unqual True
@@ -317,29 +309,29 @@ make_var_qid dflags force_unqual = make_qid dflags force_unqual True
make_con_qid :: DynFlags -> Name -> C.Qual C.Id
make_con_qid dflags = make_qid dflags False False
-make_co :: DynFlags -> Coercion -> C.Ty
-make_co dflags (Refl ty) = make_ty dflags ty
-make_co dflags (TyConAppCo tc cos) = make_conAppCo dflags (qtc dflags tc) cos
-make_co dflags (AppCo c1 c2) = C.Tapp (make_co dflags c1) (make_co dflags c2)
-make_co dflags (ForAllCo tv co) = C.Tforall (make_tbind tv) (make_co dflags co)
-make_co _ (CoVarCo cv) = C.Tvar (make_var_id (coVarName cv))
+make_co :: DynFlags -> Coercion -> C.Coercion
+make_co dflags (Refl r ty) = C.ReflCoercion (make_role r) $ make_ty dflags ty
+make_co dflags (TyConAppCo r tc cos) = C.TyConAppCoercion (make_role r) (qtc dflags tc) (map (make_co dflags) cos)
+make_co dflags (AppCo c1 c2) = C.AppCoercion (make_co dflags c1) (make_co dflags c2)
+make_co dflags (ForAllCo tv co) = C.ForAllCoercion (make_tbind tv) (make_co dflags co)
+make_co _ (CoVarCo cv) = C.CoVarCoercion (make_var_id (coVarName cv))
make_co dflags (AxiomInstCo cc ind cos) = C.AxiomCoercion (qcc dflags cc) ind (map (make_co dflags) cos)
-make_co dflags (UnsafeCo t1 t2) = C.UnsafeCoercion (make_ty dflags t1) (make_ty dflags t2)
+make_co dflags (UnivCo r t1 t2) = C.UnivCoercion (make_role r) (make_ty dflags t1) (make_ty dflags t2)
make_co dflags (SymCo co) = C.SymCoercion (make_co dflags co)
make_co dflags (TransCo c1 c2) = C.TransCoercion (make_co dflags c1) (make_co dflags c2)
make_co dflags (NthCo d co) = C.NthCoercion d (make_co dflags co)
make_co dflags (LRCo lr co) = C.LRCoercion (make_lr lr) (make_co dflags co)
make_co dflags (InstCo co ty) = C.InstCoercion (make_co dflags co) (make_ty dflags ty)
+make_co dflags (SubCo co) = C.SubCoercion (make_co dflags co)
make_lr :: LeftOrRight -> C.LeftOrRight
make_lr CLeft = C.CLeft
make_lr CRight = C.CRight
--- Used for both tycon app coercions and axiom instantiations.
-make_conAppCo :: DynFlags -> C.Qual C.Tcon -> [Coercion] -> C.Ty
-make_conAppCo dflags con cos =
- foldl C.Tapp (C.Tcon con)
- (map (make_co dflags) cos)
+make_role :: Role -> C.Role
+make_role Nominal = C.Nominal
+make_role Representational = C.Representational
+make_role Phantom = C.Phantom
-------
isALocal :: Name -> CoreM Bool
diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs
index 10e8b2830a..64e7d63590 100644
--- a/compiler/coreSyn/PprCore.lhs
+++ b/compiler/coreSyn/PprCore.lhs
@@ -429,8 +429,10 @@ instance Outputable UnfoldingSource where
instance Outputable Unfolding where
ppr NoUnfolding = ptext (sLit "No unfolding")
ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs
- ppr (DFunUnfolding ar con ops) = ptext (sLit "DFun") <> parens (ptext (sLit "arity=") <> int ar)
- <+> ppr con <+> brackets (pprWithCommas ppr ops)
+ ppr (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args })
+ = hang (ptext (sLit "DFun:") <+> ptext (sLit "\\")
+ <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)
+ 2 (ppr con <+> sep (map ppr args))
ppr (CoreUnfolding { uf_src = src
, uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf
, uf_is_conlike=conlike, uf_is_work_free=wf
@@ -451,10 +453,6 @@ instance Outputable Unfolding where
| otherwise = empty
-- Don't print the RHS or we get a quadratic
-- blowup in the size of the printout!
-
-instance Outputable e => Outputable (DFunArg e) where
- ppr (DFunPolyArg e) = braces (ppr e)
- ppr (DFunLamArg i) = char '<' <> int i <> char '>'
\end{code}
-----------------------------------------------------
diff --git a/compiler/coreSyn/PprExternalCore.lhs b/compiler/coreSyn/PprExternalCore.lhs
index 24ee560cb1..7fd3ac1d65 100644
--- a/compiler/coreSyn/PprExternalCore.lhs
+++ b/compiler/coreSyn/PprExternalCore.lhs
@@ -102,22 +102,6 @@ pbty t = paty t
pty (Tapp(Tapp(Tcon tc) t1) t2) | tc == tcArrow = fsep [pbty t1, text "->",pty t2]
pty (Tforall tb t) = text "%forall" <+> pforall [tb] t
-pty (TransCoercion t1 t2) =
- sep [text "%trans", paty t1, paty t2]
-pty (SymCoercion t) =
- sep [text "%sym", paty t]
-pty (UnsafeCoercion t1 t2) =
- sep [text "%unsafe", paty t1, paty t2]
-pty (NthCoercion n t) =
- sep [text "%nth", int n, paty t]
-pty (LRCoercion CLeft t) =
- sep [text "%left", paty t]
-pty (LRCoercion CRight t) =
- sep [text "%right", paty t]
-pty (InstCoercion t1 t2) =
- sep [text "%inst", paty t1, paty t2]
-pty (AxiomCoercion tc i cos) =
- pqname tc <+> int i <+> sep (map paty cos)
pty ty@(Tapp {}) = pappty ty []
pty ty@(Tvar {}) = paty ty
pty ty@(Tcon {}) = paty ty
@@ -130,6 +114,48 @@ pforall :: [Tbind] -> Ty -> Doc
pforall tbs (Tforall tb t) = pforall (tbs ++ [tb]) t
pforall tbs t = hsep (map ptbind tbs) <+> char '.' <+> pty t
+paco, pbco, pco :: Coercion -> Doc
+paco (ReflCoercion r ty) = char '<' <> pty ty <> text ">_" <> prole r
+paco (TyConAppCoercion r qtc []) = pqname qtc <> char '_' <> prole r
+paco (AxiomCoercion qtc i []) = pqname qtc <> char '[' <> int i <> char ']'
+paco (CoVarCoercion cv) = pname cv
+paco c = parens (pco c)
+
+pbco (TyConAppCoercion _ arr [co1, co2])
+ | arr == tcArrow
+ = parens (fsep [pbco co1, text "->", pco co2])
+pbco co = paco co
+
+pco c@(ReflCoercion {}) = paco c
+pco (SymCoercion co) = sep [text "%sub", paco co]
+pco (TransCoercion co1 co2) = sep [text "%trans", paco co1, paco co2]
+pco (TyConAppCoercion _ arr [co1, co2])
+ | arr == tcArrow = fsep [pbco co1, text "->", pco co2]
+pco (TyConAppCoercion r qtc cos) = parens (pqname qtc <+> sep (map paco cos)) <> char '_' <> prole r
+pco co@(AppCoercion {}) = pappco co []
+pco (ForAllCoercion tb co) = text "%forall" <+> pforallco [tb] co
+pco co@(CoVarCoercion {}) = paco co
+pco (UnivCoercion r ty1 ty2) = sep [text "%univ", prole r, paty ty1, paty ty2]
+pco (InstCoercion co ty) = sep [text "%inst", paco co, paty ty]
+pco (NthCoercion i co) = sep [text "%nth", int i, paco co]
+pco (AxiomCoercion qtc i cos) = pqname qtc <> char '[' <> int i <> char ']' <+> sep (map paco cos)
+pco (LRCoercion CLeft co) = sep [text "%left", paco co]
+pco (LRCoercion CRight co) = sep [text "%right", paco co]
+pco (SubCoercion co) = sep [text "%sub", paco co]
+
+pappco :: Coercion -> [Coercion ] -> Doc
+pappco (AppCoercion co1 co2) cos = pappco co1 (co2:cos)
+pappco co cos = sep (map paco (co:cos))
+
+pforallco :: [Tbind] -> Coercion -> Doc
+pforallco tbs (ForAllCoercion tb co) = pforallco (tbs ++ [tb]) co
+pforallco tbs co = hsep (map ptbind tbs) <+> char '.' <+> pco co
+
+prole :: Role -> Doc
+prole Nominal = char 'N'
+prole Representational = char 'R'
+prole Phantom = char 'P'
+
pvdefg :: Vdefg -> Doc
pvdefg (Rec vdefs) = text "%rec" $$ braces (indent (vcat (punctuate (char ';') (map pvdef vdefs))))
pvdefg (Nonrec vdef) = pvdef vdef
@@ -172,7 +198,7 @@ pexp (Let vd e) = (text "%let" <+> pvdefg vd) $$ (text "%in" <+> pexp e)
pexp (Case e vb ty alts) = sep [text "%case" <+> paty ty <+> paexp e,
text "%of" <+> pvbind vb]
$$ (indent (braces (vcat (punctuate (char ';') (map palt alts)))))
-pexp (Cast e co) = (text "%cast" <+> parens (pexp e)) $$ paty co
+pexp (Cast e co) = (text "%cast" <+> parens (pexp e)) $$ paco co
pexp (Tick s e) = (text "%source" <+> pstring s) $$ pexp e
pexp (External n cc t) = (text "%external" <+> text cc <+> pstring n) $$ paty t
pexp (DynExternal cc t) = (text "%dynexternal" <+> text cc) $$ paty t
diff --git a/compiler/coreSyn/TrieMap.lhs b/compiler/coreSyn/TrieMap.lhs
index c013b5da7a..f8ad8da5f4 100644
--- a/compiler/coreSyn/TrieMap.lhs
+++ b/compiler/coreSyn/TrieMap.lhs
@@ -14,7 +14,7 @@
{-# LANGUAGE TypeFamilies #-}
module TrieMap(
CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap,
- TypeMap, foldTypeMap, -- lookupTypeMap_mod,
+ TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap, foldTypeMap,
CoercionMap,
MaybeMap,
ListMap,
@@ -458,27 +458,28 @@ fdA k m = foldTM k (am_deflt m)
\begin{code}
data CoercionMap a
= EmptyKM
- | KM { km_refl :: TypeMap a
- , km_tc_app :: NameEnv (ListMap CoercionMap a)
+ | KM { km_refl :: RoleMap (TypeMap a)
+ , km_tc_app :: RoleMap (NameEnv (ListMap CoercionMap a))
, km_app :: CoercionMap (CoercionMap a)
, km_forall :: CoercionMap (TypeMap a)
, km_var :: VarMap a
, km_axiom :: NameEnv (IntMap.IntMap (ListMap CoercionMap a))
- , km_unsafe :: TypeMap (TypeMap a)
+ , km_univ :: RoleMap (TypeMap (TypeMap a))
, km_sym :: CoercionMap a
, km_trans :: CoercionMap (CoercionMap a)
, km_nth :: IntMap.IntMap (CoercionMap a)
, km_left :: CoercionMap a
, km_right :: CoercionMap a
- , km_inst :: CoercionMap (TypeMap a) }
+ , km_inst :: CoercionMap (TypeMap a)
+ , km_sub :: CoercionMap a }
wrapEmptyKM :: CoercionMap a
-wrapEmptyKM = KM { km_refl = emptyTM, km_tc_app = emptyNameEnv
+wrapEmptyKM = KM { km_refl = emptyTM, km_tc_app = emptyTM
, km_app = emptyTM, km_forall = emptyTM
, km_var = emptyTM, km_axiom = emptyNameEnv
- , km_unsafe = emptyTM, km_sym = emptyTM, km_trans = emptyTM
+ , km_univ = emptyTM, km_sym = emptyTM, km_trans = emptyTM
, km_nth = emptyTM, km_left = emptyTM, km_right = emptyTM
- , km_inst = emptyTM }
+ , km_inst = emptyTM, km_sub = emptyTM }
instance TrieMap CoercionMap where
type Key CoercionMap = Coercion
@@ -493,34 +494,35 @@ mapC _ EmptyKM = EmptyKM
mapC f (KM { km_refl = krefl, km_tc_app = ktc
, km_app = kapp, km_forall = kforall
, km_var = kvar, km_axiom = kax
- , km_unsafe = kunsafe, km_sym = ksym, km_trans = ktrans
+ , km_univ = kuniv , km_sym = ksym, km_trans = ktrans
, km_nth = knth, km_left = kml, km_right = kmr
- , km_inst = kinst })
- = KM { km_refl = mapTM f krefl
- , km_tc_app = mapNameEnv (mapTM f) ktc
+ , km_inst = kinst, km_sub = ksub })
+ = KM { km_refl = mapTM (mapTM f) krefl
+ , km_tc_app = mapTM (mapNameEnv (mapTM f)) ktc
, km_app = mapTM (mapTM f) kapp
, km_forall = mapTM (mapTM f) kforall
, km_var = mapTM f kvar
, km_axiom = mapNameEnv (IntMap.map (mapTM f)) kax
- , km_unsafe = mapTM (mapTM f) kunsafe
+ , km_univ = mapTM (mapTM (mapTM f)) kuniv
, km_sym = mapTM f ksym
, km_trans = mapTM (mapTM f) ktrans
, km_nth = IntMap.map (mapTM f) knth
, km_left = mapTM f kml
, km_right = mapTM f kmr
- , km_inst = mapTM (mapTM f) kinst }
+ , km_inst = mapTM (mapTM f) kinst
+ , km_sub = mapTM f ksub }
lkC :: CmEnv -> Coercion -> CoercionMap a -> Maybe a
lkC env co m
| EmptyKM <- m = Nothing
| otherwise = go co m
where
- go (Refl ty) = km_refl >.> lkT env ty
- go (TyConAppCo tc cs) = km_tc_app >.> lkNamed tc >=> lkList (lkC env) cs
+ go (Refl r ty) = km_refl >.> lookupTM r >=> lkT env ty
+ go (TyConAppCo r tc cs) = km_tc_app >.> lookupTM r >=> lkNamed tc >=> lkList (lkC env) cs
go (AxiomInstCo ax ind cs) = km_axiom >.> lkNamed ax >=> lookupTM ind >=> lkList (lkC env) cs
go (AppCo c1 c2) = km_app >.> lkC env c1 >=> lkC env c2
go (TransCo c1 c2) = km_trans >.> lkC env c1 >=> lkC env c2
- go (UnsafeCo t1 t2) = km_unsafe >.> lkT env t1 >=> lkT env t2
+ go (UnivCo r t1 t2) = km_univ >.> lookupTM r >=> lkT env t1 >=> lkT env t2
go (InstCo c t) = km_inst >.> lkC env c >=> lkT env t
go (ForAllCo v c) = km_forall >.> lkC (extendCME env v) c >=> lkBndr env v
go (CoVarCo v) = km_var >.> lkVar env v
@@ -528,15 +530,16 @@ lkC env co m
go (NthCo n c) = km_nth >.> lookupTM n >=> lkC env c
go (LRCo CLeft c) = km_left >.> lkC env c
go (LRCo CRight c) = km_right >.> lkC env c
+ go (SubCo c) = km_sub >.> lkC env c
xtC :: CmEnv -> Coercion -> XT a -> CoercionMap a -> CoercionMap a
xtC env co f EmptyKM = xtC env co f wrapEmptyKM
-xtC env (Refl ty) f m = m { km_refl = km_refl m |> xtT env ty f }
-xtC env (TyConAppCo tc cs) f m = m { km_tc_app = km_tc_app m |> xtNamed tc |>> xtList (xtC env) cs f }
+xtC env (Refl r ty) f m = m { km_refl = km_refl m |> xtR r |>> xtT env ty f }
+xtC env (TyConAppCo r tc cs) f m = m { km_tc_app = km_tc_app m |> xtR r |>> xtNamed tc |>> xtList (xtC env) cs f }
xtC env (AxiomInstCo ax ind cs) f m = m { km_axiom = km_axiom m |> xtNamed ax |>> xtInt ind |>> xtList (xtC env) cs f }
xtC env (AppCo c1 c2) f m = m { km_app = km_app m |> xtC env c1 |>> xtC env c2 f }
xtC env (TransCo c1 c2) f m = m { km_trans = km_trans m |> xtC env c1 |>> xtC env c2 f }
-xtC env (UnsafeCo t1 t2) f m = m { km_unsafe = km_unsafe m |> xtT env t1 |>> xtT env t2 f }
+xtC env (UnivCo r t1 t2) f m = m { km_univ = km_univ m |> xtR r |>> xtT env t1 |>> xtT env t2 f }
xtC env (InstCo c t) f m = m { km_inst = km_inst m |> xtC env c |>> xtT env t f }
xtC env (ForAllCo v c) f m = m { km_forall = km_forall m |> xtC (extendCME env v) c
|>> xtBndr env v f }
@@ -544,23 +547,56 @@ xtC env (CoVarCo v) f m = m { km_var = km_var m |> xtVar env v f
xtC env (SymCo c) f m = m { km_sym = km_sym m |> xtC env c f }
xtC env (NthCo n c) f m = m { km_nth = km_nth m |> xtInt n |>> xtC env c f }
xtC env (LRCo CLeft c) f m = m { km_left = km_left m |> xtC env c f }
-xtC env (LRCo CRight c) f m = m { km_right = km_right m |> xtC env c f }
+xtC env (LRCo CRight c) f m = m { km_right = km_right m |> xtC env c f }
+xtC env (SubCo c) f m = m { km_sub = km_sub m |> xtC env c f }
fdC :: (a -> b -> b) -> CoercionMap a -> b -> b
fdC _ EmptyKM = \z -> z
-fdC k m = foldTM k (km_refl m)
- . foldTM (foldTM k) (km_tc_app m)
+fdC k m = foldTM (foldTM k) (km_refl m)
+ . foldTM (foldTM (foldTM k)) (km_tc_app m)
. foldTM (foldTM k) (km_app m)
. foldTM (foldTM k) (km_forall m)
. foldTM k (km_var m)
. foldTM (foldTM (foldTM k)) (km_axiom m)
- . foldTM (foldTM k) (km_unsafe m)
+ . foldTM (foldTM (foldTM k)) (km_univ m)
. foldTM k (km_sym m)
. foldTM (foldTM k) (km_trans m)
. foldTM (foldTM k) (km_nth m)
. foldTM k (km_left m)
. foldTM k (km_right m)
. foldTM (foldTM k) (km_inst m)
+ . foldTM k (km_sub m)
+
+\end{code}
+
+\begin{code}
+
+newtype RoleMap a = RM { unRM :: (IntMap.IntMap a) }
+
+instance TrieMap RoleMap where
+ type Key RoleMap = Role
+ emptyTM = RM emptyTM
+ lookupTM = lkR
+ alterTM = xtR
+ foldTM = fdR
+ mapTM = mapR
+
+lkR :: Role -> RoleMap a -> Maybe a
+lkR Nominal = lookupTM 1 . unRM
+lkR Representational = lookupTM 2 . unRM
+lkR Phantom = lookupTM 3 . unRM
+
+xtR :: Role -> XT a -> RoleMap a -> RoleMap a
+xtR Nominal f = RM . alterTM 1 f . unRM
+xtR Representational f = RM . alterTM 2 f . unRM
+xtR Phantom f = RM . alterTM 3 f . unRM
+
+fdR :: (a -> b -> b) -> RoleMap a -> b -> b
+fdR f (RM m) = foldTM f m
+
+mapR :: (a -> b) -> RoleMap a -> RoleMap b
+mapR f = RM . mapTM f . unRM
+
\end{code}
@@ -588,6 +624,15 @@ instance Outputable a => Outputable (TypeMap a) where
foldTypeMap :: (a -> b -> b) -> b -> TypeMap a -> b
foldTypeMap k z m = fdT k m z
+emptyTypeMap :: TypeMap a
+emptyTypeMap = EmptyTM
+
+lookupTypeMap :: TypeMap a -> Type -> Maybe a
+lookupTypeMap cm t = lkT emptyCME t cm
+
+extendTypeMap :: TypeMap a -> Type -> a -> TypeMap a
+extendTypeMap m t v = xtT emptyCME t (\_ -> Just v) m
+
wrapEmptyTypeMap :: TypeMap a
wrapEmptyTypeMap = TM { tm_var = emptyTM
, tm_app = EmptyTM
View Lorry Controller Status