From e87d56ce33f663da1c445f37e95c40d814caa384 Mon Sep 17 00:00:00 2001
From: lewie <unknown>
Date: Wed, 23 Feb 2000 19:41:51 +0000
Subject: [PATCH] [project @ 2000-02-23 19:41:50 by lewie] Handle `with' more
cleverly. I was generating partially applied methods for the case where the
`with' expression was also overloaded, but this was buggy, and completely
unnecessary. Instead, simply force the method binding at the point of the
`with' expression (we reap no benefits from pushing the sharing further out
anyway), and release the remainder of the method's context into the LIE.
---
ghc/compiler/basicTypes/Id.lhs | 8 ++++++--
ghc/compiler/typecheck/Inst.lhs | 31 +++++++++++++++++++-----------
ghc/compiler/typecheck/TcExpr.lhs | 16 ++++++++++++---
ghc/compiler/typecheck/TcHsSyn.lhs | 4 ++--
4 files changed, 41 insertions(+), 18 deletions(-)
diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index 54e776c5cdf9..814fcb7ee4f7 100644
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -25,7 +25,8 @@ module Id (
omitIfaceSigForId,
exportWithOrigOccName,
externallyVisibleId,
- idFreeTyVars,
+ idFreeTyVars,
+ isIP,
-- Inline pragma stuff
getInlinePragma, setInlinePragma, modifyInlinePragma,
@@ -84,7 +85,8 @@ import IdInfo
import Demand ( Demand, isStrict, wwLazy )
import Name ( Name, OccName,
mkSysLocalName, mkLocalName,
- isWiredInName, isUserExportedName
+ isWiredInName, isUserExportedName,
+ getOccName, isIPOcc
)
import OccName ( UserFS )
import Const ( Con(..) )
@@ -273,6 +275,8 @@ omitIfaceSigForId id
-- or an explicit user export.
exportWithOrigOccName :: Id -> Bool
exportWithOrigOccName id = omitIfaceSigForId id || isUserExportedId id
+
+isIP id = isIPOcc (getOccName id)
\end{code}
diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index d3ede0e2909c..41bf80701d4f 100644
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -39,7 +39,7 @@ module Inst (
import HsSyn ( HsLit(..), HsExpr(..) )
import RnHsSyn ( RenamedArithSeqInfo, RenamedHsExpr, RenamedPat )
import TcHsSyn ( TcExpr, TcId,
- mkHsTyApp, mkHsDictApp, zonkId
+ mkHsTyApp, mkHsDictApp, mkHsDictLam, zonkId
)
import TcMonad
import TcEnv ( TcIdSet, tcLookupValueByKey, tcLookupTyConByKey )
@@ -276,18 +276,24 @@ partitionLIEbyMeth pred lie
= foldlTc (partMethod pred) (emptyLIE, emptyLIE) insts
where insts = lieToList lie
-partMethod pred (ips, lie) m@(Method u id tys theta tau loc)
- = if null ips_ then
+partMethod pred (ips, lie) d@(Dict _ p _)
+ = if pred p then
+ returnTc (consLIE d ips, lie)
+ else
+ returnTc (ips, consLIE d lie)
+
+partMethod pred (ips, lie) m@(Method u id tys theta tau loc@(_,sloc,_))
+ = let (ips_, theta_) = partition pred theta in
+ if null ips_ then
returnTc (ips, consLIE m lie)
else if null theta_ then
returnTc (consLIE m ips, lie)
else
- newMethodWith id tys theta_ tau loc `thenTc` \ new_m2 ->
- let id_m1 = instToIdBndr new_m2
- new_m1 = Method u id_m1 {- tys -} [] ips_ tau loc in
- -- newMethodWith id_m1 tys ips_ tau loc `thenTc` \ new_m1 ->
- returnTc (consLIE new_m1 ips, consLIE new_m2 lie)
- where (ips_, theta_) = partition pred theta
+ zonkPreds theta_ `thenTc` \ theta_' ->
+ newDictsAtLoc loc theta_' `thenTc` \ (new_dicts, _) ->
+ returnTc (consLIE m ips,
+ plusLIE (listToLIE new_dicts) lie)
+
partMethod pred (ips, lie) inst@(LitInst u lit ty loc)
= returnTc (ips, consLIE inst lie)
@@ -547,6 +553,7 @@ zonkInst (FunDep clas fds loc)
= zonkFunDeps fds `thenNF_Tc` \ fds' ->
returnNF_Tc (FunDep clas fds' loc)
+zonkPreds preds = mapNF_Tc zonkPred preds
zonkInsts insts = mapNF_Tc zonkInst insts
zonkFunDeps fds = mapNF_Tc zonkFd fds
@@ -584,10 +591,12 @@ pprInst (LitInst u lit ty loc)
pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
-pprInst (Method u id tys _ _ loc)
+pprInst m@(Method u id tys theta tau loc)
= hsep [ppr id, ptext SLIT("at"),
brackets (interppSP tys),
- show_uniq u]
+ ppr theta, ppr tau,
+ show_uniq u,
+ ppr (instToId m)]
pprInst (FunDep clas fds loc)
= hsep [ppr clas, ppr fds]
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 7aecdaaf8106..6ac44b1235e6 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -9,7 +9,7 @@ module TcExpr ( tcApp, tcExpr, tcPolyExpr, tcId ) where
#include "HsVersions.h"
import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
- HsBinds(..), Stmt(..), StmtCtxt(..),
+ HsBinds(..), MonoBinds(..), Stmt(..), StmtCtxt(..),
mkMonoBind, nullMonoBinds
)
import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds )
@@ -733,10 +733,13 @@ tcMonoExpr (HsWith expr binds) res_ty
tcIPBinds binds `thenTc` \ (binds', types, lie2) ->
partitionLIEbyMeth isBound lie `thenTc` \ (ips, lie') ->
zonkLIE ips `thenTc` \ ips' ->
- tcSimplify (text "With!") (tyVarsOfLIE ips') ips' `thenTc` \ res@(_, dict_binds, _) ->
+ tcSimplify (text "tcMonoExpr With") (tyVarsOfLIE ips') ips'
+ `thenTc` \ res@(_, dict_binds, _) ->
let expr'' = if nullMonoBinds dict_binds
then expr'
- else HsLet (MonoBind dict_binds [] NonRecursive) expr' in
+ else HsLet (mkMonoBind (revBinds dict_binds) [] NonRecursive)
+ expr'
+ in
tcCheckIPBinds binds' types ips' `thenTc_`
returnTc (HsWith expr'' binds', lie' `plusLIE` lie2)
where isBound p
@@ -744,6 +747,13 @@ tcMonoExpr (HsWith expr binds) res_ty
Just n -> n `elem` names
Nothing -> False
names = map fst binds
+ -- revBinds is used because tcSimplify outputs the bindings
+ -- out-of-order. it's not a problem elsewhere because these
+ -- bindings are normally used in a recursive let
+ -- ZZ probably need to find a better solution
+ revBinds (b1 `AndMonoBinds` b2) =
+ (revBinds b2) `AndMonoBinds` (revBinds b1)
+ revBinds b = b
tcIPBinds ((name, expr) : binds)
= newTyVarTy_OpenKind `thenTc` \ ty ->
diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index e2ba97018c64..d4bd29b563f1 100644
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -40,7 +40,7 @@ module TcHsSyn (
import HsSyn -- oodles of it
-- others:
-import Id ( idName, idType, setIdType, omitIfaceSigForId, Id )
+import Id ( idName, idType, setIdType, omitIfaceSigForId, isIP, Id )
import DataCon ( DataCon, splitProductType_maybe )
import TcEnv ( tcLookupValueMaybe, tcExtendGlobalValEnv, tcGetValueEnv,
ValueEnv, TcId, tcInstId
@@ -184,7 +184,7 @@ zonkIdBndr id
zonkIdOcc :: TcId -> NF_TcM s Id
zonkIdOcc id
- | not (isLocallyDefined id) || omitIfaceSigForId id
+ | not (isLocallyDefined id) || omitIfaceSigForId id || isIP id
-- The omitIfaceSigForId thing may look wierd but it's quite
-- sensible really. We're avoiding looking up superclass selectors
-- and constructors; zonking them is a no-op anyway, and the
--
GitLab