From e87d56ce33f663da1c445f37e95c40d814caa384 Mon Sep 17 00:00:00 2001 From: lewie 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 54e776c..814fcb7 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 d3ede0e..41bf807 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 7aecdaa..6ac44b1 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 e2ba970..d4bd29b 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 -- 1.7.10.4