Commit d63e81b8 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Use fresh uniques when unboxing coercions in the desugarer

This is kosher, and turns out to be vital when we have
more complicate evidence terms.
parent a6069053
......@@ -18,7 +18,7 @@ lower levels it is preserved with @let@/@letrec@s).
-- for details
module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
dsHsWrapper, dsTcEvBinds, dsEvBinds, dsTcCoercion
dsHsWrapper, dsTcEvBinds, dsEvBinds
) where
#include "HsVersions.h"
......@@ -32,7 +32,6 @@ import DsUtils
import HsSyn -- lots of things
import CoreSyn -- lots of things
import HscTypes ( MonadThings )
import Literal ( Literal(MachStr) )
import CoreSubst
import MkCore
......@@ -40,6 +39,8 @@ import CoreUtils
import CoreArity ( etaExpand )
import CoreUnfold
import CoreFVs
import UniqSupply
import Unique( Unique )
import Digraph
......@@ -52,7 +53,7 @@ import TysWiredIn ( eqBoxDataCon, tupleCon )
import Id
import Class
import DataCon ( dataConWorkId )
import Name ( Name, localiseName )
import Name
import MkId ( seqId )
import Var
import VarSet
......@@ -662,7 +663,7 @@ but it seems better to reject the program because it's almost certainly
a mistake. That's what the isDeadBinder call detects.
Note [Constant rule dicts]
~~~~~~~~~~~~~~~~~~~~~~~
~~~~~~~~~~~~~~~~~~~~~~~~~~
When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
which is presumably in scope at the function definition site, we can quantify
over it too. *Any* dict with that type will do.
......@@ -695,23 +696,23 @@ as the old one, but with an Internal name and no IdInfo.
\begin{code}
dsHsWrapper :: MonadThings m => HsWrapper -> CoreExpr -> m CoreExpr
dsHsWrapper :: HsWrapper -> CoreExpr -> DsM CoreExpr
dsHsWrapper WpHole e = return e
dsHsWrapper (WpTyApp ty) e = return $ App e (Type ty)
dsHsWrapper (WpLet ev_binds) e = do bs <- dsTcEvBinds ev_binds
return (mkCoreLets bs e)
dsHsWrapper (WpCompose c1 c2) e = dsHsWrapper c1 =<< dsHsWrapper c2 e
dsHsWrapper (WpCast co) e = return $ dsTcCoercion co (mkCast e)
dsHsWrapper (WpCast co) e = dsTcCoercion co (mkCast e)
dsHsWrapper (WpEvLam ev) e = return $ Lam ev e
dsHsWrapper (WpTyLam tv) e = return $ Lam tv e
dsHsWrapper (WpEvApp evtrm) e = liftM (App e) (dsEvTerm evtrm)
--------------------------------------
dsTcEvBinds :: MonadThings m => TcEvBinds -> m [CoreBind]
dsTcEvBinds :: TcEvBinds -> DsM [CoreBind]
dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this
dsTcEvBinds (EvBinds bs) = dsEvBinds bs
dsEvBinds :: MonadThings m => Bag EvBind -> m [CoreBind]
dsEvBinds :: Bag EvBind -> DsM [CoreBind]
dsEvBinds bs = mapM ds_scc (sccEvBinds bs)
where
ds_scc (AcyclicSCC (EvBind v r)) = liftM (NonRec v) (dsEvTerm r)
......@@ -730,22 +731,22 @@ sccEvBinds bs = stronglyConnCompFromEdgedVertices edges
---------------------------------------
dsEvTerm :: MonadThings m => EvTerm -> m CoreExpr
dsEvTerm :: EvTerm -> DsM CoreExpr
dsEvTerm (EvId v) = return (Var v)
dsEvTerm (EvCast tm co)
= do { tm' <- dsEvTerm tm
; return $ dsTcCoercion co $ mkCast tm' }
; dsTcCoercion co $ mkCast tm' }
-- 'v' is always a lifted evidence variable so it is
-- unnecessary to call varToCoreExpr v here.
dsEvTerm (EvKindCast v co)
= do { v' <- dsEvTerm v
; return $ dsTcCoercion co $ (\_ -> v') }
; dsTcCoercion co $ (\_ -> v') }
dsEvTerm (EvDFunApp df tys tms) = do { tms' <- mapM dsEvTerm tms
; return (Var df `mkTyApps` tys `mkApps` tms') }
dsEvTerm (EvCoercion co) = return $ dsTcCoercion co mkEqBox
dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox
dsEvTerm (EvTupleSel v n)
= do { tm' <- dsEvTerm v
; let scrut_ty = exprType tm'
......@@ -782,7 +783,7 @@ dsEvTerm (EvLit l) =
EvStr s -> mkStringExprFS s
---------------------------------------
dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> CoreExpr
dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr
-- This is the crucial function that moves
-- from TcCoercions to Coercions; see Note [TcCoercions] in Coercion
-- e.g. dsTcCoercion (trans g1 g2) k
......@@ -790,22 +791,28 @@ dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> CoreExpr
-- case g2 of EqBox g2# ->
-- k (trans g1# g2#)
dsTcCoercion co thing_inside
= foldr wrap_in_case result_expr eqvs_covs
where
result_expr = thing_inside (ds_tc_coercion subst co)
result_ty = exprType result_expr
= do { us <- newUniqueSupply
; let eqvs_covs :: [(EqVar,CoVar)]
eqvs_covs = zipWith mk_co_var (varSetElems (coVarsOfTcCo co))
(uniqsFromSupply us)
-- We use the same uniques for the EqVars and the CoVars, and just change
-- the type. So the CoVars shadow the EqVars
subst = mkCvSubst emptyInScopeSet [(eqv, mkCoVarCo cov) | (eqv, cov) <- eqvs_covs]
result_expr = thing_inside (ds_tc_coercion subst co)
result_ty = exprType result_expr
eqvs_covs :: [(EqVar,CoVar)]
eqvs_covs = [(eqv, eqv `setIdType` mkCoercionType ty1 ty2)
| eqv <- varSetElems (coVarsOfTcCo co)
, let (ty1, ty2) = getEqPredTys (evVarPred eqv)]
subst = mkCvSubst emptyInScopeSet [(eqv, mkCoVarCo cov) | (eqv, cov) <- eqvs_covs]
wrap_in_case (eqv, cov) body
; return (foldr (wrap_in_case result_ty) result_expr eqvs_covs) }
where
mk_co_var :: Id -> Unique -> (Id, Id)
mk_co_var eqv uniq = (eqv, mkUserLocal occ uniq ty loc)
where
eq_nm = idName eqv
occ = nameOccName eq_nm
loc = nameSrcSpan eq_nm
ty = mkCoercionType ty1 ty2
(ty1, ty2) = getEqPredTys (evVarPred eqv)
wrap_in_case result_ty (eqv, cov) body
= Case (Var eqv) eqv result_ty [(DataAlt eqBoxDataCon, [cov], body)]
ds_tc_coercion :: CvSubst -> TcCoercion -> Coercion
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment