From a7ecdf96844404b7bc8273d4ff6d85759278427c Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 19 Jul 2005 16:45:02 +0000 Subject: [PATCH] [project @ 2005-07-19 16:44:50 by simonpj] WARNING: this is a big commit. You might want to wait a few days before updating, in case I've broken something. However, if any of the changes are what you wanted, please check it out and test! This commit does three main things: 1. A re-organisation of the way that GHC handles bindings in HsSyn. This has been a bit of a mess for quite a while. The key new types are -- Bindings for a let or where clause data HsLocalBinds id = HsValBinds (HsValBinds id) | HsIPBinds (HsIPBinds id) | EmptyLocalBinds -- Value bindings (not implicit parameters) data HsValBinds id = ValBindsIn -- Before typechecking (LHsBinds id) [LSig id] -- Not dependency analysed -- Recursive by default | ValBindsOut -- After typechecking [(RecFlag, LHsBinds id)]-- Dependency analysed 2. Implement Mark Jones's idea of increasing polymoprhism by using type signatures to cut the strongly-connected components of a recursive group. As a consequence, GHC no longer insists on the contexts of the type signatures of a recursive group being identical. This drove a significant change: the renamer no longer does dependency analysis. Instead, it attaches a free-variable set to each binding, so that the type checker can do the dep anal. Reason: the typechecker needs to do *two* analyses: one to find the true mutually-recursive groups (which we need so we can build the right CoreSyn) one to find the groups in which to typecheck, taking account of type signatures 3. Implement non-ground SPECIALISE pragmas, as promised, and as requested by Remi and Ross. Certainly, this should fix the current problem with GHC, namely that if you have g :: Eq a => a -> b -> b then you can now specialise thus SPECIALISE g :: Int -> b -> b (This didn't use to work.) However, it goes further than that. For example: f :: (Eq a, Ix b) => a -> b -> b then you can make a partial specialisation SPECIALISE f :: (Eq a) => a -> Int -> Int In principle, you can specialise f to *any* type that is "less polymorphic" (in the sense of subsumption) than f's actual type. Such as SPECIALISE f :: Eq a => [a] -> Int -> Int But I haven't tested that. I implemented this by doing the specialisation in the typechecker and desugarer, rather than leaving around the strange SpecPragmaIds, for the specialiser to find. Indeed, SpecPragmaIds have vanished altogether (hooray). Pragmas in general are handled more tidily. There's a new data type HsBinds.Prag, which lives in an AbsBinds, and carries pragma info from the typechecker to the desugarer. Smaller things - The loop in the renamer goes via RnExpr, instead of RnSource. (That makes it more like the type checker.) - I fixed the thing that was causing 'check_tc' warnings to be emitted. --- ghc/compiler/basicTypes/BasicTypes.lhs | 11 +- ghc/compiler/basicTypes/Id.lhs | 28 +- ghc/compiler/basicTypes/IdInfo.lhs | 3 + ghc/compiler/basicTypes/NameEnv.lhs | 6 +- ghc/compiler/basicTypes/Var.lhs | 31 +- ghc/compiler/coreSyn/CoreUnfold.lhs | 6 +- ghc/compiler/coreSyn/PprCore.lhs | 3 +- ghc/compiler/deSugar/Desugar.lhs | 72 +-- ghc/compiler/deSugar/DsArrows.lhs | 10 +- ghc/compiler/deSugar/DsBinds.lhs | 249 ++++++--- ghc/compiler/deSugar/DsExpr.hi-boot-6 | 3 +- ghc/compiler/deSugar/DsExpr.lhs | 64 ++- ghc/compiler/deSugar/DsExpr.lhs-boot | 4 +- ghc/compiler/deSugar/DsForeign.lhs | 18 +- ghc/compiler/deSugar/DsGRHSs.lhs | 6 +- ghc/compiler/deSugar/DsListComp.lhs | 10 +- ghc/compiler/deSugar/DsMeta.hs | 71 ++- ghc/compiler/deSugar/DsMonad.lhs | 14 +- ghc/compiler/deSugar/Match.lhs | 34 +- ghc/compiler/deSugar/MatchCon.lhs | 4 +- ghc/compiler/hsSyn/Convert.lhs | 19 +- ghc/compiler/hsSyn/HsBinds.lhs | 293 +++++++---- ghc/compiler/hsSyn/HsDecls.lhs | 26 +- ghc/compiler/hsSyn/HsExpr.lhs | 16 +- ghc/compiler/hsSyn/HsUtils.lhs | 89 ++-- ghc/compiler/iface/IfaceSyn.lhs | 11 +- ghc/compiler/iface/IfaceType.lhs | 31 +- ghc/compiler/iface/MkIface.lhs | 1 - ghc/compiler/main/CodeOutput.lhs | 4 +- ghc/compiler/main/GHC.hs | 7 +- ghc/compiler/main/HscStats.lhs | 6 +- ghc/compiler/main/Main.hs | 4 +- ghc/compiler/parser/Parser.y.pp | 14 +- ghc/compiler/parser/RdrHsSyn.lhs | 34 +- ghc/compiler/rename/RnBinds.lhs | 495 ++++++++++-------- ghc/compiler/rename/RnEnv.lhs | 45 +- ghc/compiler/rename/RnExpr.hi-boot-6 | 11 + ghc/compiler/rename/RnExpr.lhs | 351 ++----------- ghc/compiler/rename/RnHsSyn.lhs | 13 +- ghc/compiler/rename/RnNames.lhs | 14 +- ghc/compiler/rename/RnSource.hi-boot-6 | 16 - ghc/compiler/rename/RnSource.lhs | 96 +--- ghc/compiler/rename/RnTypes.lhs | 296 ++++++++--- ghc/compiler/simplCore/OccurAnal.lhs | 10 +- ghc/compiler/simplCore/SimplCore.lhs | 6 +- ghc/compiler/simplCore/SimplUtils.lhs | 5 +- ghc/compiler/specialise/Rules.lhs | 9 +- ghc/compiler/specialise/Specialise.lhs | 10 +- ghc/compiler/stgSyn/CoreToStg.lhs | 2 +- ghc/compiler/typecheck/Inst.lhs | 6 +- ghc/compiler/typecheck/TcArrows.lhs | 21 +- ghc/compiler/typecheck/TcBinds.lhs | 885 ++++++++++++++++---------------- ghc/compiler/typecheck/TcClassDcl.lhs | 79 +-- ghc/compiler/typecheck/TcDeriv.lhs | 16 +- ghc/compiler/typecheck/TcEnv.lhs | 54 +- ghc/compiler/typecheck/TcExpr.lhs | 13 +- ghc/compiler/typecheck/TcHsSyn.lhs | 77 +-- ghc/compiler/typecheck/TcHsType.lhs | 8 +- ghc/compiler/typecheck/TcInstDcls.lhs | 42 +- ghc/compiler/typecheck/TcMatches.lhs | 59 +-- ghc/compiler/typecheck/TcRnDriver.lhs | 22 +- ghc/compiler/typecheck/TcRnMonad.lhs | 7 +- ghc/compiler/typecheck/TcRules.lhs | 6 +- ghc/compiler/typecheck/TcSplice.lhs | 4 +- ghc/compiler/typecheck/TcUnify.lhs | 4 +- ghc/compiler/types/Generics.lhs | 6 +- ghc/compiler/types/TyCon.lhs | 5 + ghc/compiler/utils/IOEnv.hs | 6 +- ghc/compiler/utils/ListSetOps.lhs | 27 +- ghc/compiler/utils/UniqFM.lhs | 16 +- ghc/compiler/utils/Util.lhs | 5 +- 71 files changed, 2044 insertions(+), 1905 deletions(-) create mode 100644 ghc/compiler/rename/RnExpr.hi-boot-6 delete mode 100644 ghc/compiler/rename/RnSource.hi-boot-6 diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs index b0b3bc1..94dfc84 100644 --- a/ghc/compiler/basicTypes/BasicTypes.lhs +++ b/ghc/compiler/basicTypes/BasicTypes.lhs @@ -22,7 +22,7 @@ module BasicTypes( Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence, - negateFixity, + negateFixity, funTyFixity, compareFixity, IPName(..), ipNameName, mapIPName, @@ -155,11 +155,10 @@ instance Outputable FixityDirection where maxPrecedence = (9::Int) defaultFixity = Fixity maxPrecedence InfixL -negateFixity :: Fixity -negateFixity = Fixity negatePrecedence InfixL -- Precedence of unary negate is wired in as infixl 6! - -negatePrecedence :: Int -negatePrecedence = 6 +negateFixity, funTyFixity :: Fixity +-- Wired-in fixities +negateFixity = Fixity 6 InfixL -- Fixity of unary negate +funTyFixity = Fixity 0 InfixR -- Fixity of '->' \end{code} Consider diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 62c722a..85c474d 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -8,7 +8,7 @@ module Id ( Id, DictId, -- Simple construction - mkGlobalId, mkLocalId, mkSpecPragmaId, mkLocalIdWithInfo, + mkGlobalId, mkLocalId, mkLocalIdWithInfo, mkSysLocal, mkSysLocalUnencoded, mkUserLocal, mkVanillaGlobal, mkTemplateLocals, mkTemplateLocalsNum, mkWildId, mkTemplateLocal, mkWorkerId, mkExportedLocalId, @@ -24,8 +24,8 @@ module Id ( zapLamIdInfo, zapDemandIdInfo, -- Predicates - isImplicitId, isDeadBinder, - isSpecPragmaId, isExportedId, isLocalId, isGlobalId, + isImplicitId, isDeadBinder, isDictId, + isExportedId, isLocalId, isGlobalId, isRecordSelector, isClassOpId_maybe, isPrimOpId, isPrimOpId_maybe, @@ -83,7 +83,7 @@ module Id ( import CoreSyn ( Unfolding, CoreRule ) import BasicTypes ( Arity ) import Var ( Id, DictId, - isId, isExportedId, isSpecPragmaId, isLocalId, + isId, isExportedId, isLocalId, idName, idType, idUnique, idInfo, isGlobalId, setIdName, setIdType, setIdUnique, setIdExported, setIdNotExported, @@ -91,10 +91,11 @@ import Var ( Id, DictId, maybeModifyIdInfo, globalIdDetails ) -import qualified Var ( mkLocalId, mkGlobalId, mkSpecPragmaId, mkExportedLocalId ) +import qualified Var ( mkLocalId, mkGlobalId, mkExportedLocalId ) import TyCon ( FieldLabel, TyCon ) import Type ( Type, typePrimRep, addFreeTyVars, seqType, splitTyConApp_maybe, PrimRep ) +import TcType ( isDictTy ) import TysPrim ( statePrimTyCon ) import IdInfo @@ -147,9 +148,6 @@ where it can easily be found. mkLocalIdWithInfo :: Name -> Type -> IdInfo -> Id mkLocalIdWithInfo name ty info = Var.mkLocalId name (addFreeTyVars ty) info -mkSpecPragmaId :: Name -> Type -> Id -mkSpecPragmaId name ty = Var.mkSpecPragmaId name (addFreeTyVars ty) vanillaIdInfo - mkExportedLocalId :: Name -> Type -> Id mkExportedLocalId name ty = Var.mkExportedLocalId name (addFreeTyVars ty) vanillaIdInfo @@ -229,17 +227,6 @@ idPrimRep id = typePrimRep (idType id) %* * %************************************************************************ -The @SpecPragmaId@ exists only to make Ids that are -on the *LHS* of bindings created by SPECIALISE pragmas; -eg: s = f Int d -The SpecPragmaId is never itself mentioned; it -exists solely so that the specialiser will find -the call to f, and make specialised version of it. -The SpecPragmaId binding is discarded by the specialiser -when it gathers up overloaded calls. -Meanwhile, it is not discarded as dead code. - - \begin{code} recordSelectorFieldLabel :: Id -> (TyCon, FieldLabel) recordSelectorFieldLabel id = case globalIdDetails id of @@ -278,6 +265,9 @@ isDataConWorkId_maybe id = case globalIdDetails id of DataConWorkId con -> Just con other -> Nothing +isDictId :: Id -> Bool +isDictId id = isDictTy (idType id) + idDataCon :: Id -> DataCon -- Get from either the worker or the wrapper to the DataCon -- Currently used only in the desugarer diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 5f223e5..20dcbe2 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -442,6 +442,9 @@ type InlinePragInfo = Activation -- -- If there was an INLINE pragma, then as a separate matter, the -- RHS will have been made to look small with a CoreSyn Inline Note + + -- The default InlinePragInfo is AlwaysActive, so the info serves + -- entirely as a way to inhibit inlining until we want it \end{code} diff --git a/ghc/compiler/basicTypes/NameEnv.lhs b/ghc/compiler/basicTypes/NameEnv.lhs index a125f61..ff63701 100644 --- a/ghc/compiler/basicTypes/NameEnv.lhs +++ b/ghc/compiler/basicTypes/NameEnv.lhs @@ -7,7 +7,7 @@ module NameEnv ( NameEnv, mkNameEnv, emptyNameEnv, unitNameEnv, nameEnvElts, - extendNameEnv_C, extendNameEnvList_C, extendNameEnv, extendNameEnvList, + extendNameEnv_C, extendNameEnv_Acc, extendNameEnv, extendNameEnvList, foldNameEnv, filterNameEnv, plusNameEnv, plusNameEnv_C, lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv, @@ -34,7 +34,7 @@ emptyNameEnv :: NameEnv a mkNameEnv :: [(Name,a)] -> NameEnv a nameEnvElts :: NameEnv a -> [a] extendNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a -extendNameEnvList_C:: (a->a->a) -> NameEnv a -> [(Name,a)] -> NameEnv a +extendNameEnv_Acc :: (a->b->b) -> (a->b) -> NameEnv b -> Name -> a -> NameEnv b extendNameEnv :: NameEnv a -> Name -> a -> NameEnv a plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a @@ -54,7 +54,7 @@ foldNameEnv = foldUFM mkNameEnv = listToUFM nameEnvElts = eltsUFM extendNameEnv_C = addToUFM_C -extendNameEnvList_C = addListToUFM_C +extendNameEnv_Acc = addToUFM_Acc extendNameEnv = addToUFM plusNameEnv = plusUFM plusNameEnv_C = plusUFM_C diff --git a/ghc/compiler/basicTypes/Var.lhs b/ghc/compiler/basicTypes/Var.lhs index c3f626e..948b910 100644 --- a/ghc/compiler/basicTypes/Var.lhs +++ b/ghc/compiler/basicTypes/Var.lhs @@ -19,15 +19,14 @@ module Var ( Id, DictId, idName, idType, idUnique, idInfo, modifyIdInfo, maybeModifyIdInfo, setIdName, setIdUnique, setIdType, setIdInfo, lazySetIdInfo, - setIdExported, setIdNotExported, zapSpecPragmaId, + setIdExported, setIdNotExported, globalIdDetails, globaliseId, - mkLocalId, mkExportedLocalId, mkSpecPragmaId, - mkGlobalId, + mkLocalId, mkExportedLocalId, mkGlobalId, isTyVar, isTcTyVar, isId, isLocalVar, isLocalId, - isGlobalId, isExportedId, isSpecPragmaId, + isGlobalId, isExportedId, mustHaveLocalBinding ) where @@ -91,9 +90,7 @@ data Var data LocalIdDetails = NotExported -- Not exported | Exported -- Exported - | SpecPragma -- Not exported, but not to be discarded either - -- It's unclean that this is so deeply built in - -- Exported and SpecPragma Ids are kept alive; + -- Exported Ids are kept alive; -- NotExported things may be discarded as dead code. \end{code} @@ -225,11 +222,6 @@ setIdNotExported :: Id -> Id -- We can only do this to LocalIds setIdNotExported id = ASSERT( isLocalId id ) id { lclDetails = NotExported } -zapSpecPragmaId :: Id -> Id -zapSpecPragmaId id - | isSpecPragmaId id = id {lclDetails = NotExported} - | otherwise = id - globaliseId :: GlobalIdDetails -> Id -> Id -- If it's a local, make it global globaliseId details id = GlobalId { varName = varName id, @@ -287,16 +279,13 @@ mkLocalId name ty info = mk_local_id name ty NotExported info mkExportedLocalId :: Name -> Type -> IdInfo -> Id mkExportedLocalId name ty info = mk_local_id name ty Exported info - -mkSpecPragmaId :: Name -> Type -> IdInfo -> Id -mkSpecPragmaId name ty info = mk_local_id name ty SpecPragma info \end{code} \begin{code} -isTyVar, isTcTyVar :: Var -> Bool -isId, isLocalVar, isLocalId :: Var -> Bool -isGlobalId, isExportedId, isSpecPragmaId :: Var -> Bool -mustHaveLocalBinding :: Var -> Bool +isTyVar, isTcTyVar :: Var -> Bool +isId, isLocalVar, isLocalId :: Var -> Bool +isGlobalId, isExportedId :: Var -> Bool +mustHaveLocalBinding :: Var -> Bool isTyVar (TyVar {}) = True isTyVar (TcTyVar {}) = True @@ -333,12 +322,8 @@ isExportedId (GlobalId {}) = True isExportedId (LocalId {lclDetails = details}) = case details of Exported -> True - SpecPragma -> True other -> False isExportedId other = False - -isSpecPragmaId (LocalId {lclDetails = SpecPragma}) = True -isSpecPragmaId other = False \end{code} \begin{code} diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index e7e7da3..044841f 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -37,7 +37,7 @@ import StaticFlags ( opt_UF_CreationThreshold, opt_UF_UseThreshold, import DynFlags ( DynFlags, DynFlag(..), dopt ) import CoreSyn import PprCore ( pprCoreExpr ) -import OccurAnal ( occurAnalyseGlobalExpr ) +import OccurAnal ( occurAnalyseExpr ) import CoreUtils ( exprIsValue, exprIsCheap, exprIsTrivial ) import Id ( Id, idType, isId, idUnfolding, globalIdDetails @@ -69,7 +69,7 @@ import GLAEXTS ( Int# ) mkTopUnfolding expr = mkUnfolding True {- Top level -} expr mkUnfolding top_lvl expr - = CoreUnfolding (occurAnalyseGlobalExpr expr) + = CoreUnfolding (occurAnalyseExpr expr) top_lvl (exprIsValue expr) @@ -89,7 +89,7 @@ mkUnfolding top_lvl expr -- it gets fixed up next round mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded - = CompulsoryUnfolding (occurAnalyseGlobalExpr expr) + = CompulsoryUnfolding (occurAnalyseExpr expr) \end{code} diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index a1515a0..84e7810 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -22,7 +22,7 @@ import Var ( Var ) import Id ( Id, idType, isDataConWorkId_maybe, idLBVarInfo, idArity, idInfo, idInlinePragma, idOccInfo, globalIdDetails, isGlobalId, isExportedId, - isSpecPragmaId, idNewDemandInfo + idNewDemandInfo ) import Var ( TyVar, isTyVar, tyVarKind ) import IdInfo ( IdInfo, megaSeqIdInfo, @@ -317,7 +317,6 @@ pprIdBndr id = ppr id <+> pprIdDetails :: Id -> SDoc pprIdDetails id | isGlobalId id = ppr (globalIdDetails id) | isExportedId id = ptext SLIT("[Exported]") - | isSpecPragmaId id = ptext SLIT("[SpecPrag]") | otherwise = empty ppIdInfo :: Id -> IdInfo -> SDoc diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index b117104..be5ad1e 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -13,27 +13,24 @@ import StaticFlags ( opt_SccProfilingOn ) import DriverPhases ( isHsBoot ) import HscTypes ( ModGuts(..), HscEnv(..), Dependencies(..), TypeEnv, IsBootInterface ) -import HsSyn ( RuleDecl(..), RuleBndr(..), HsExpr(..), LHsExpr, - HsBindGroup(..), LRuleDecl, HsBind(..) ) +import HsSyn ( RuleDecl(..), RuleBndr(..), LHsExpr, LRuleDecl ) import TcRnTypes ( TcGblEnv(..), ImportAvails(..) ) import MkIface ( mkUsageInfo ) import Id ( Id, setIdExported, idName ) import Name ( Name, isExternalName, nameIsLocalOrFrom, nameOccName ) import CoreSyn import PprCore ( pprRules, pprCoreExpr ) -import CoreSubst ( substExpr, mkSubst ) import DsMonad import DsExpr ( dsLExpr ) -import DsBinds ( dsHsBinds, AutoScc(..) ) +import DsBinds ( dsTopLHsBinds, decomposeRuleLhs, AutoScc(..) ) import DsForeign ( dsForeigns ) import DsExpr () -- Forces DsExpr to be compiled; DsBinds only -- depends on DsExpr.hi-boot. import Module ( Module, moduleEnvElts, delModuleEnv, moduleFS ) import RdrName ( GlobalRdrEnv ) import NameSet -import VarEnv import VarSet -import Bag ( Bag, isEmptyBag, emptyBag, bagToList ) +import Bag ( Bag, isEmptyBag, emptyBag ) import Rules ( roughTopNames ) import CoreLint ( showPass, endPass ) import CoreFVs ( ruleRhsFreeVars, exprsFreeNames ) @@ -43,8 +40,9 @@ import ErrUtils ( doIfSet, dumpIfSet_dyn, pprBagOfWarnings, import ListSetOps ( insertList ) import Outputable import UniqSupply ( mkSplitUniqSupply ) -import SrcLoc ( Located(..), unLoc ) +import SrcLoc ( Located(..) ) import DATA_IOREF ( readIORef ) +import Maybes ( catMaybes ) import FastString import Util ( sortLe ) \end{code} @@ -82,14 +80,12 @@ deSugar hsc_env -- Desugar the program ; ((all_prs, ds_rules, ds_fords), warns) <- initDs hsc_env mod rdr_env type_env $ do - { core_prs <- dsHsBinds auto_scc binds [] + { core_prs <- dsTopLHsBinds auto_scc binds ; (ds_fords, foreign_prs) <- dsForeigns fords ; let all_prs = foreign_prs ++ core_prs local_bndrs = mkVarSet (map fst all_prs) ; ds_rules <- mappM (dsRule mod local_bndrs) rules - ; return (all_prs, ds_rules, ds_fords) } - - + ; return (all_prs, catMaybes ds_rules, ds_fords) } -- If warnings are considered errors, leave. ; if errorsFound dflags (warns, emptyBag) @@ -263,49 +259,37 @@ ppr_ds_rules rules %************************************************************************ \begin{code} -dsRule :: Module -> IdSet -> LRuleDecl Id -> DsM CoreRule +dsRule :: Module -> IdSet -> LRuleDecl Id -> DsM (Maybe CoreRule) dsRule mod in_scope (L loc (HsRule name act vars lhs rhs)) = putSrcSpanDs loc $ - do { let (dict_binds, body) - = case unLoc lhs of - (HsLet [HsBindGroup dbs _ _] body) -> (dbs, body) - other -> (emptyBag, lhs) - - ds_dict_bind (L _ (VarBind id rhs)) - = do { rhs' <- dsLExpr rhs ; returnDs (id,rhs') } - - ; dict_binds' <- mappM ds_dict_bind (bagToList dict_binds) - ; body' <- dsLExpr body - ; rhs' <- dsLExpr rhs + do { let bndrs = [var | RuleBndr (L _ var) <- vars] + ; lhs' <- dsLExpr lhs + ; rhs' <- dsLExpr rhs + ; case decomposeRuleLhs bndrs lhs' of { + Nothing -> do { dsWarn msg; return Nothing } ; + Just (bndrs', fn_id, args) -> do + -- Substitute the dict bindings eagerly, -- and take the body apart into a (f args) form - ; let bndrs = [var | RuleBndr (L _ var) <- vars] - in_scope' = mkInScopeSet (extendVarSetList in_scope bndrs) - subst = mkSubst in_scope' emptyVarEnv (mkVarEnv id_pairs) - id_pairs = [(id, substExpr subst rhs) | (id,rhs) <- dict_binds'] - -- Note recursion here... substitution won't terminate - -- if there is genuine recursion... which there isn't - - body'' = substExpr subst body' - - (fn, args) = case collectArgs body'' of - (Var fn_id, args) -> (idName fn_id, args) - other -> pprPanic "dsRule" (ppr lhs) - - local_rule = nameIsLocalOrFrom mod fn + { let local_rule = nameIsLocalOrFrom mod fn_name -- NB we can't use isLocalId in the orphan test, -- because isLocalId isn't true of class methods - lhs_names = fn : nameSetToList (exprsFreeNames args) + fn_name = idName fn_id + lhs_names = fn_name : nameSetToList (exprsFreeNames args) -- No need to delete bndrs, because - -- exprsFreeNams finds only External names + -- exprsFreeNames finds only External names orph = case filter (nameIsLocalOrFrom mod) lhs_names of (n:ns) -> Just (nameOccName n) [] -> Nothing - ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act, - ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs', - ru_rough = roughTopNames args, - ru_local = local_rule, ru_orph = orph }) - } + rule = Rule { ru_name = name, ru_fn = fn_name, ru_act = act, + ru_bndrs = bndrs', ru_args = args, ru_rhs = rhs', + ru_rough = roughTopNames args, + ru_local = local_rule, ru_orph = orph } + ; return (Just rule) + } } } + where + msg = hang (ptext SLIT("RULE left-hand side too complicated to desugar; ignored")) + 2 (ppr lhs) \end{code} diff --git a/ghc/compiler/deSugar/DsArrows.lhs b/ghc/compiler/deSugar/DsArrows.lhs index 43df99c..a5d797d 100644 --- a/ghc/compiler/deSugar/DsArrows.lhs +++ b/ghc/compiler/deSugar/DsArrows.lhs @@ -24,7 +24,7 @@ import TcHsSyn ( hsPatType ) -- So WATCH OUT; check each use of split*Ty functions. -- Sigh. This is a pain. -import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLet ) +import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds ) import TcType ( Type, tcSplitAppTy, mkFunTy ) import Type ( mkTyConApp, funArgTy ) @@ -555,14 +555,14 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) = let - defined_vars = mkVarSet (map unLoc (collectGroupBinders binds)) + defined_vars = mkVarSet (map unLoc (collectLocalBinders binds)) local_vars' = local_vars `unionVarSet` defined_vars in dsfixCmd ids local_vars' stack res_ty body `thenDs` \ (core_body, free_vars, env_ids') -> mappM newSysLocalDs stack `thenDs` \ stack_ids -> -- build a new environment, plus the stack, using the let bindings - dsLet binds (buildEnvStack env_ids' stack_ids) + dsLocalBinds binds (buildEnvStack env_ids' stack_ids) `thenDs` \ core_binds -> -- match the old environment and stack against the input matchEnvStack env_ids stack_ids core_binds @@ -798,7 +798,7 @@ dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _) dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds) -- build a new environment using the let bindings - = dsLet binds (mkTupleExpr out_ids) `thenDs` \ core_binds -> + = dsLocalBinds binds (mkTupleExpr out_ids) `thenDs` \ core_binds -> -- match the old environment against the input matchEnvStack env_ids [] core_binds `thenDs` \ core_map -> returnDs (do_arr ids @@ -1009,7 +1009,7 @@ leavesMatch (L _ (Match pats _ (GRHSs grhss binds))) = let defined_vars = mkVarSet (collectPatsBinders pats) `unionVarSet` - mkVarSet (map unLoc (collectGroupBinders binds)) + mkVarSet (map unLoc (collectLocalBinders binds)) in [(expr, mkVarSet (map unLoc (collectLStmtsBinders stmts)) diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index 70e5d16..fe3276f 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -8,12 +8,12 @@ in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at lower levels it is preserved with @let@/@letrec@s). \begin{code} -module DsBinds ( dsHsBinds, dsHsNestedBinds, AutoScc(..) ) where +module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, AutoScc(..) ) where #include "HsVersions.h" -import {-# SOURCE #-} DsExpr( dsLExpr ) +import {-# SOURCE #-} DsExpr( dsLExpr, dsExpr ) import {-# SOURCE #-} Match( matchWrapper ) import DsMonad @@ -26,17 +26,23 @@ import CoreUtils ( exprType, mkInlineMe, mkSCC ) import StaticFlags ( opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs ) +import OccurAnal ( occurAnalyseExpr ) import CostCentre ( mkAutoCC, IsCafCC(..) ) -import Id ( idType, idName, isExportedId, isSpecPragmaId, Id ) -import NameSet -import VarSet +import Id ( Id, idType, idName, isExportedId, mkLocalId, setInlinePragma ) +import Rules ( addIdSpecialisations, mkLocalRule ) +import Var ( Var, isGlobalId ) +import VarEnv import Type ( mkTyVarTy, substTyWith ) import TysWiredIn ( voidTy ) import Outputable import SrcLoc ( Located(..) ) -import Maybe ( isJust ) +import Maybes ( isJust, catMaybes, orElse ) import Bag ( bagToList ) +import BasicTypes ( Activation(..), isAlwaysActive ) import Monad ( foldM ) +import FastString ( mkFastString ) +import List ( (\\) ) +import Util ( mapSnd ) \end{code} %************************************************************************ @@ -46,16 +52,17 @@ import Monad ( foldM ) %************************************************************************ \begin{code} -dsHsNestedBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)] -dsHsNestedBinds binds = dsHsBinds NoSccs binds [] +dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)] +dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds -dsHsBinds :: AutoScc -- scc annotation policy (see below) - -> LHsBinds Id - -> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append) - -> DsM [(Id,CoreExpr)] -- Result +dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)] +dsLHsBinds binds = ds_lhs_binds NoSccs binds -dsHsBinds auto_scc binds rest - = foldM (dsLHsBind auto_scc) rest (bagToList binds) + +------------------------ +ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)] + -- scc annotation policy (see below) +ds_lhs_binds auto_scc binds = foldM (dsLHsBind auto_scc) [] (bagToList binds) dsLHsBind :: AutoScc -> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append) @@ -75,25 +82,14 @@ dsHsBind auto_scc rest (VarBind var expr) -- Dictionary bindings are always VarMonoBinds, so -- we only need do this here addDictScc var core_expr `thenDs` \ core_expr' -> + returnDs ((var, core_expr') : rest) - let - -- Gross hack to prevent inlining into SpecPragmaId rhss - -- Consider fromIntegral = fromInteger . toInteger - -- spec1 = fromIntegral Int Float - -- Even though fromIntegral is small we don't want to inline - -- it inside spec1, so that we collect the specialised call - -- Solution: make spec1 an INLINE thing. - core_expr'' = mkInline (isSpecPragmaId var) core_expr' - in - - returnDs ((var, core_expr'') : rest) - -dsHsBind auto_scc rest (FunBind (L _ fun) _ matches) +dsHsBind auto_scc rest (FunBind (L _ fun) _ matches _) = matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, body) -> addAutoScc auto_scc (fun, mkLams args body) `thenDs` \ pair -> returnDs (pair : rest) -dsHsBind auto_scc rest (PatBind pat grhss ty) +dsHsBind auto_scc rest (PatBind pat grhss ty _) = dsGuarded grhss ty `thenDs` \ body_expr -> mkSelectorBinds pat body_expr `thenDs` \ sel_binds -> mappM (addAutoScc auto_scc) sel_binds `thenDs` \ sel_binds -> @@ -103,67 +99,133 @@ dsHsBind auto_scc rest (PatBind pat grhss ty) -- For the (rare) case when there are some mixed-up -- dictionary bindings (for which a Rec is convenient) -- we reply on the enclosing dsBind to wrap a Rec around. -dsHsBind auto_scc rest (AbsBinds [] [] exports inlines binds) - = dsHsBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs -> +dsHsBind auto_scc rest (AbsBinds [] [] exports binds) + = ds_lhs_binds (addSccs auto_scc exports) binds `thenDs` \ core_prs -> let - core_prs' = addLocalInlines exports inlines core_prs - exports' = [(global, Var local) | (_, global, local) <- exports] + core_prs' = addLocalInlines exports core_prs + exports' = [(global, Var local) | (_, global, local, _) <- exports] in returnDs (core_prs' ++ exports' ++ rest) -- Another common case: one exported variable -- Non-recursive bindings come through this way dsHsBind auto_scc rest - (AbsBinds all_tyvars dicts exps@[(tyvars, global, local)] inlines binds) + (AbsBinds all_tyvars dicts exports@[(tyvars, global, local, prags)] binds) = ASSERT( all (`elem` tyvars) all_tyvars ) - dsHsBinds (addSccs auto_scc exps) binds [] `thenDs` \ core_prs -> + ds_lhs_binds (addSccs auto_scc exports) binds `thenDs` \ core_prs -> let -- Always treat the binds as recursive, because the typechecker -- makes rather mixed-up dictionary bindings core_bind = Rec core_prs - - -- The mkInline does directly what the - -- addLocalInlines do in the other cases - export' = (global, mkInline (idName global `elemNameSet` inlines) $ - mkLams tyvars $ mkLams dicts $ - Let core_bind (Var local)) + inline_env = mkVarEnv [(global, prag) | prag <- prags, isInlinePrag prag] in - returnDs (export' : rest) + mappM (dsSpec all_tyvars dicts tyvars global local core_bind) + prags `thenDs` \ mb_specs -> + let + (spec_binds, rules) = unzip (catMaybes mb_specs) + global' = addIdSpecialisations global rules + rhs' = mkLams tyvars $ mkLams dicts $ Let core_bind (Var local) + in + returnDs (addInlineInfo inline_env (global', rhs') : spec_binds ++ rest) -dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports inlines binds) - = dsHsBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs -> - let +dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds) + = ds_lhs_binds (addSccs auto_scc exports) binds `thenDs` \ core_prs -> + let -- Rec because of mixed-up dictionary bindings - core_bind = Rec (addLocalInlines exports inlines core_prs) + core_bind = Rec (addLocalInlines exports core_prs) tup_expr = mkTupleExpr locals tup_ty = exprType tup_expr poly_tup_expr = mkLams all_tyvars $ mkLams dicts $ Let core_bind tup_expr - locals = [local | (_, _, local) <- exports] + locals = [local | (_, _, local, _) <- exports] local_tys = map idType locals in newSysLocalDs (exprType poly_tup_expr) `thenDs` \ poly_tup_id -> let dict_args = map Var dicts - mk_bind ((tyvars, global, local), n) -- locals !! n == local + mk_bind ((tyvars, global, local, prags), n) -- locals !! n == local = -- Need to make fresh locals to bind in the selector, because -- some of the tyvars will be bound to voidTy newSysLocalsDs (map substitute local_tys) `thenDs` \ locals' -> newSysLocalDs (substitute tup_ty) `thenDs` \ tup_id -> - returnDs (global, mkLams tyvars $ mkLams dicts $ - mkTupleSelector locals' (locals' !! n) tup_id $ - mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args) + mapM (dsSpec all_tyvars dicts tyvars global local core_bind) + prags `thenDs` \ mb_specs -> + let + (spec_binds, rules) = unzip (catMaybes mb_specs) + global' = addIdSpecialisations global rules + rhs = mkLams tyvars $ mkLams dicts $ + mkTupleSelector locals' (locals' !! n) tup_id $ + mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args + in + returnDs ((global', rhs) : spec_binds) where mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar | otherwise = voidTy ty_args = map mk_ty_arg all_tyvars substitute = substTyWith all_tyvars ty_args in - mappM mk_bind (exports `zip` [0..]) `thenDs` \ export_binds -> + mappM mk_bind (exports `zip` [0..]) `thenDs` \ export_binds_s -> -- don't scc (auto-)annotate the tuple itself. - returnDs ((poly_tup_id, poly_tup_expr) : (export_binds ++ rest)) + + returnDs ((poly_tup_id, poly_tup_expr) : (concat export_binds_s ++ rest)) + +-- Example: +-- f :: (Eq a, Ix b) => a -> b -> b +-- +-- AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds +-- +-- SpecPrag (/\b.\(d:Ix b). f Int b dInt d) +-- (forall b. Ix b => Int -> b -> b) +-- +-- Rule: forall b,(d:Ix b). f Int b dInt d = f_spec b d +-- +-- Spec bind: f_spec = Let f = /\ab \(d1:Eq a)(d2:Ix b). let binds in f_mono +-- /\b.\(d:Ix b). in f Int b dInt d + +dsSpec all_tvs dicts tvs poly_id mono_id mono_bind (InlinePrag {}) + = return Nothing + +dsSpec all_tvs dicts tvs poly_id mono_id mono_bind + (SpecPrag spec_expr spec_ty const_dicts) + = do { let poly_name = idName poly_id + ; spec_name <- newLocalName (idName poly_id) + ; ds_spec_expr <- dsExpr spec_expr + ; let (bndrs, body) = collectBinders ds_spec_expr + mb_lhs = decomposeRuleLhs (bndrs ++ const_dicts) body + + ; case mb_lhs of + Nothing -> do { dsWarn msg; return Nothing } + + Just (bndrs', var, args) -> return (Just ((spec_id, spec_rhs), rule)) + where + spec_id = mkLocalId spec_name spec_ty + spec_rhs = Let (NonRec poly_id poly_f_body) ds_spec_expr + poly_f_body = mkLams (tvs ++ dicts) $ + fix_up (Let mono_bind (Var mono_id)) + + -- Quantify over constant dicts on the LHS, since + -- their value depends only on their type + -- The ones we are interested in may even be imported + -- e.g. GHC.Base.dEqInt + + rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name))) + AlwaysActive poly_name + bndrs' -- Includes constant dicts + args + (mkVarApps (Var spec_id) bndrs) + } + where + -- Bind to voidTy any of all_ptvs that aren't + -- relevant for this particular function + fix_up body | null void_tvs = body + | otherwise = mkTyApps (mkLams void_tvs body) + (map (const voidTy) void_tvs) + void_tvs = all_tvs \\ tvs + + msg = hang (ptext SLIT("Specialisation too complicated to desugar; ignored")) + 2 (ppr spec_expr) \end{code} @@ -174,15 +236,78 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports inlines binds) %************************************************************************ \begin{code} -mkInline :: Bool -> CoreExpr -> CoreExpr -mkInline True body = mkInlineMe body -mkInline False body = body +decomposeRuleLhs :: [Var] -> CoreExpr -> Maybe ([Var], Id, [CoreExpr]) +-- Returns Nothing if the LHS isn't of the expected shape +-- The argument 'all_bndrs' includes the "constant dicts" of the LHS, +-- and they may be GlobalIds, which we can't forall-ify. +-- So we substitute them out instead +decomposeRuleLhs all_bndrs lhs + = go init_env (occurAnalyseExpr lhs) -- Occurrence analysis sorts out the dict + -- bindings so we know if they are recursive + where -addLocalInlines :: [(a, Id, Id)] -> NameSet -> [(Id,CoreExpr)] -> [(Id,CoreExpr)] -addLocalInlines exports inlines pairs - = [(bndr, mkInline (bndr `elemVarSet` local_inlines) rhs) | (bndr,rhs) <- pairs] + -- all_bndrs may include top-level imported dicts, + -- imported things with a for-all. + -- So we localise them and subtitute them out + bndr_prs = [ (id, Var (localise id)) | id <- all_bndrs, isGlobalId id ] + localise d = mkLocalId (idName d) (idType d) + + init_env = mkVarEnv bndr_prs + all_bndrs' = map subst_bndr all_bndrs + subst_bndr bndr = case lookupVarEnv init_env bndr of + Just (Var bndr') -> bndr' + Just other -> panic "decomposeRuleLhs" + Nothing -> bndr + + -- Substitute dicts in the LHS args, so that there + -- aren't any lets getting in the way + go env (Let (NonRec dict rhs) body) + = go (extendVarEnv env dict (simpleSubst env rhs)) body + go env body + = case collectArgs body of + (Var fn, args) -> Just (all_bndrs', fn, map (simpleSubst env) args) + other -> Nothing + +simpleSubst :: IdEnv CoreExpr -> CoreExpr -> CoreExpr +-- Similar to CoreSubst.substExpr, except that +-- (a) takes no account of capture; dictionary bindings use new names +-- (b) can have a GlobalId (imported) in its domain +-- (c) Ids only; no types are substituted + +simpleSubst subst expr + = go expr + where + go (Var v) = lookupVarEnv subst v `orElse` Var v + go (Type ty) = Type ty + go (Lit lit) = Lit lit + go (App fun arg) = App (go fun) (go arg) + go (Note note e) = Note note (go e) + go (Lam bndr body) = Lam bndr (go body) + go (Let (NonRec bndr rhs) body) = Let (NonRec bndr (go rhs)) (go body) + go (Let (Rec pairs) body) = Let (Rec (mapSnd go pairs)) (go body) + go (Case scrut bndr ty alts) = Case (go scrut) bndr ty + [(c,bs,go r) | (c,bs,r) <- alts] + +addLocalInlines exports core_prs + = map (addInlineInfo inline_env) core_prs where - local_inlines = mkVarSet [l | (_,g,l) <- exports, idName g `elemNameSet` inlines] + inline_env = mkVarEnv [(mono_id, prag) + | (_, _, mono_id, prags) <- exports, + prag <- prags, isInlinePrag prag] + +addInlineInfo :: IdEnv Prag -> (Id,CoreExpr) -> (Id,CoreExpr) +addInlineInfo inline_env (bndr,rhs) + | Just (InlinePrag is_inline phase) <- lookupVarEnv inline_env bndr + = (attach_phase bndr phase, wrap_inline is_inline rhs) + | otherwise + = (bndr, rhs) + where + attach_phase bndr phase + | isAlwaysActive phase = bndr -- Default phase + | otherwise = bndr `setInlinePragma` phase + + wrap_inline True body = mkInlineMe body + wrap_inline False body = body \end{code} @@ -198,11 +323,11 @@ data AutoScc | TopLevelAddSccs (Id -> Maybe Id) | NoSccs -addSccs :: AutoScc -> [(a,Id,Id)] -> AutoScc +addSccs :: AutoScc -> [(a,Id,Id,[Prag])] -> AutoScc addSccs auto_scc@(TopLevelAddSccs _) exports = auto_scc addSccs NoSccs exports = NoSccs addSccs TopLevel exports - = TopLevelAddSccs (\id -> case [ exp | (_,exp,loc) <- exports, loc == id ] of + = TopLevelAddSccs (\id -> case [ exp | (_,exp,loc,_) <- exports, loc == id ] of (exp:_) | opt_AutoSccsOnAllToplevs || (isExportedId exp && opt_AutoSccsOnExportedToplevs) @@ -233,7 +358,7 @@ addDictScc var rhs = returnDs rhs {- DISABLED for now (need to somehow make up a name for the scc) -- SDM | not ( opt_SccProfilingOn && opt_AutoSccsOnDicts) - || not (isDictTy (idType var)) + || not (isDictId var) = returnDs rhs -- That's easy: do nothing | otherwise diff --git a/ghc/compiler/deSugar/DsExpr.hi-boot-6 b/ghc/compiler/deSugar/DsExpr.hi-boot-6 index 9a9a2d2..c7ddb2d 100644 --- a/ghc/compiler/deSugar/DsExpr.hi-boot-6 +++ b/ghc/compiler/deSugar/DsExpr.hi-boot-6 @@ -2,4 +2,5 @@ module DsExpr where dsExpr :: HsExpr.HsExpr Var.Id -> DsMonad.DsM CoreSyn.CoreExpr dsLExpr :: HsExpr.LHsExpr Var.Id -> DsMonad.DsM CoreSyn.CoreExpr -dsLet :: [HsBinds.HsBindGroup Var.Id] -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr +dsLocalBinds :: HsBinds.HsLocalBinds Var.Id -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr +dsValBinds :: HsBinds.HsValBinds Var.Id -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 6dc8f22..2e21538 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -4,14 +4,14 @@ \section[DsExpr]{Matching expressions (Exprs)} \begin{code} -module DsExpr ( dsExpr, dsLExpr, dsLet, dsLit ) where +module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where #include "HsVersions.h" import Match ( matchWrapper, matchSimply, matchSinglePat ) import MatchLit ( dsLit, dsOverLit ) -import DsBinds ( dsHsNestedBinds ) +import DsBinds ( dsLHsBinds ) import DsGRHSs ( dsGuarded ) import DsListComp ( dsListComp, dsPArrComp ) import DsUtils ( mkErrorAppDs, mkStringExpr, mkConsExpr, mkNilExpr, @@ -76,24 +76,34 @@ This must be transformed to a case expression and, if the type has more than one constructor, may fail. \begin{code} -dsLet :: [HsBindGroup Id] -> CoreExpr -> DsM CoreExpr -dsLet groups body = foldlDs dsBindGroup body (reverse groups) - -dsBindGroup :: CoreExpr -> HsBindGroup Id -> DsM CoreExpr -dsBindGroup body (HsIPBinds binds) - = foldlDs dsIPBind body binds +dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr +dsLocalBinds EmptyLocalBinds body = return body +dsLocalBinds (HsValBinds binds) body = dsValBinds binds body +dsLocalBinds (HsIPBinds binds) body = dsIPBinds binds body + +------------------------- +dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr +dsValBinds (ValBindsOut binds) body = foldrDs ds_val_bind body binds + +------------------------- +dsIPBinds (IPBinds ip_binds dict_binds) body + = do { prs <- dsLHsBinds dict_binds + ; let inner = foldr (\(x,r) e -> Let (NonRec x r) e) body prs + ; foldrDs ds_ip_bind inner ip_binds } where - dsIPBind body (L _ (IPBind n e)) - = dsLExpr e `thenDs` \ e' -> - returnDs (Let (NonRec (ipNameName n) e') body) + ds_ip_bind (L _ (IPBind n e)) body + = dsLExpr e `thenDs` \ e' -> + returnDs (Let (NonRec (ipNameName n) e') body) +------------------------- +ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr -- Special case for bindings which bind unlifted variables -- We need to do a case right away, rather than building -- a tuple and doing selections. --- Silently ignore INLINE pragmas... -dsBindGroup body bind@(HsBindGroup hsbinds sigs is_rec) - | [L _ (AbsBinds [] [] exports inlines binds)] <- bagToList hsbinds, - or [isUnLiftedType (idType g) | (_, g, l) <- exports] +-- Silently ignore INLINE and SPECIALISE pragmas... +ds_val_bind (is_rec, hsbinds) body + | [L _ (AbsBinds [] [] exports binds)] <- bagToList hsbinds, + or [isUnLiftedType (idType g) | (_, g, _, _) <- exports] = ASSERT (case is_rec of {NonRecursive -> True; other -> False}) -- Unlifted bindings are always non-recursive -- and are always a Fun or Pat monobind @@ -102,32 +112,32 @@ dsBindGroup body bind@(HsBindGroup hsbinds sigs is_rec) -- could be dict binds in the 'binds'. (See the notes -- below. Then pattern-match would fail. Urk.) let - body_w_exports = foldr bind_export body exports - bind_export (tvs, g, l) body = ASSERT( null tvs ) - bindNonRec g (Var l) body + body_w_exports = foldr bind_export body exports + bind_export (tvs, g, l, _) body = ASSERT( null tvs ) + bindNonRec g (Var l) body mk_error_app pat = mkErrorAppDs iRREFUT_PAT_ERROR_ID (exprType body) (showSDoc (ppr pat)) in case bagToList binds of - [L loc (FunBind (L _ fun) _ matches)] + [L loc (FunBind (L _ fun) _ matches _)] -> putSrcSpanDs loc $ matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, rhs) -> ASSERT( null args ) -- Functions aren't lifted returnDs (bindNonRec fun rhs body_w_exports) - [L loc (PatBind pat grhss ty)] + [L loc (PatBind pat grhss ty _)] -> putSrcSpanDs loc $ dsGuarded grhss ty `thenDs` \ rhs -> mk_error_app pat `thenDs` \ error_expr -> matchSimply rhs PatBindRhs pat body_w_exports error_expr - other -> pprPanic "dsLet: unlifted" (ppr bind $$ ppr body) + other -> pprPanic "dsLet: unlifted" (pprLHsBinds hsbinds $$ ppr body) -- Ordinary case for bindings -dsBindGroup body (HsBindGroup binds sigs is_rec) - = dsHsNestedBinds binds `thenDs` \ prs -> +ds_val_bind (is_rec, binds) body + = dsLHsBinds binds `thenDs` \ prs -> returnDs (Let (Rec prs) body) -- Use a Rec regardless of is_rec. -- Why? Because it allows the binds to be all @@ -263,7 +273,7 @@ dsExpr (HsCase discrim matches) dsExpr (HsLet binds body) = dsLExpr body `thenDs` \ body' -> - dsLet binds body' + dsLocalBinds binds body' -- We need the `ListComp' form to use `deListComp' (rather than the "do" form) -- because the interpretation of `stmts' depends on what sort of thing it is. @@ -589,7 +599,7 @@ dsDo stmts body result_ty go (LetStmt binds : stmts) = do { rest <- go stmts - ; dsLet binds rest } + ; dsLocalBinds binds rest } go (BindStmt pat rhs bind_op fail_op : stmts) = do { body <- go stmts @@ -644,7 +654,7 @@ dsMDo tbl stmts body result_ty go (LetStmt binds : stmts) = do { rest <- go stmts - ; dsLet binds rest } + ; dsLocalBinds binds rest } go (ExprStmt rhs _ rhs_ty : stmts) = do { rhs2 <- dsLExpr rhs @@ -670,7 +680,7 @@ dsMDo tbl stmts body result_ty go (new_bind_stmt : let_stmt : stmts) where new_bind_stmt = mkBindStmt (mk_tup_pat later_pats) mfix_app - let_stmt = LetStmt [HsBindGroup binds [] Recursive] + let_stmt = LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)])) -- Remove the later_ids that appear (without fancy coercions) diff --git a/ghc/compiler/deSugar/DsExpr.lhs-boot b/ghc/compiler/deSugar/DsExpr.lhs-boot index b3380a9..c65e99d 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs-boot +++ b/ghc/compiler/deSugar/DsExpr.lhs-boot @@ -1,11 +1,11 @@ \begin{code} module DsExpr where -import HsSyn ( HsExpr, LHsExpr, HsBindGroup ) +import HsSyn ( HsExpr, LHsExpr, HsLocalBinds ) import Var ( Id ) import DsMonad ( DsM ) import CoreSyn ( CoreExpr ) dsExpr :: HsExpr Id -> DsM CoreExpr dsLExpr :: LHsExpr Id -> DsM CoreExpr -dsLet :: [HsBindGroup Id] -> CoreExpr -> DsM CoreExpr +dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr \end{code} diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index 9f0758a..1523d83 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -80,11 +80,13 @@ dsForeigns [] dsForeigns fos = foldlDs combine (ForeignStubs empty empty [] [], []) fos where - combine (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f) - (L loc (ForeignImport id _ spec depr)) + combine stubs (L loc decl) = putSrcSpanDs loc (combine1 stubs decl) + + combine1 (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f) + (ForeignImport id _ spec depr) = traceIf (text "fi start" <+> ppr id) `thenDs` \ _ -> dsFImport (unLoc id) spec `thenDs` \ (bs, h, c, mbhd) -> - warnDepr depr loc `thenDs` \ _ -> + warnDepr depr `thenDs` \ _ -> traceIf (text "fi end" <+> ppr id) `thenDs` \ _ -> returnDs (ForeignStubs (h $$ acc_h) (c $$ acc_c) @@ -92,11 +94,11 @@ dsForeigns fos acc_feb, bs ++ acc_f) - combine (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f) - (L loc (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv)) depr)) + combine1 (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f) + (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv)) depr) = dsFExport id (idType id) ext_nm cconv False `thenDs` \(h, c, _, _) -> - warnDepr depr loc `thenDs` \_ -> + warnDepr depr `thenDs` \_ -> returnDs (ForeignStubs (h $$ acc_h) (c $$ acc_c) acc_hdrs (id:acc_feb), acc_f) @@ -105,8 +107,8 @@ dsForeigns fos | e `elem` ls = ls | otherwise = e:ls - warnDepr False _ = returnDs () - warnDepr True loc = dsWarn (loc, msg) + warnDepr False = returnDs () + warnDepr True = dsWarn msg where msg = ptext SLIT("foreign declaration uses deprecated non-standard syntax") \end{code} diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs index d934b7c..33f86ed 100644 --- a/ghc/compiler/deSugar/DsGRHSs.lhs +++ b/ghc/compiler/deSugar/DsGRHSs.lhs @@ -8,7 +8,7 @@ module DsGRHSs ( dsGuarded, dsGRHSs ) where #include "HsVersions.h" -import {-# SOURCE #-} DsExpr ( dsLExpr, dsLet ) +import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds ) import {-# SOURCE #-} Match ( matchSinglePat ) import HsSyn ( Stmt(..), HsExpr(..), GRHSs(..), GRHS(..), @@ -59,7 +59,7 @@ dsGRHSs hs_ctx pats (GRHSs grhss binds) rhs_ty = mappM (dsGRHS hs_ctx pats rhs_ty) grhss `thenDs` \ match_results -> let match_result1 = foldr1 combineMatchResults match_results - match_result2 = adjustMatchResultDs (dsLet binds) match_result1 + match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1 -- NB: nested dsLet inside matchResult in returnDs match_result2 @@ -105,7 +105,7 @@ matchGuards (ExprStmt expr _ _ : stmts) ctx rhs rhs_ty matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty = matchGuards stmts ctx rhs rhs_ty `thenDs` \ match_result -> - returnDs (adjustMatchResultDs (dsLet binds) match_result) + returnDs (adjustMatchResultDs (dsLocalBinds binds) match_result) -- NB the dsLet occurs inside the match_result -- Reason: dsLet takes the body expression as its argument -- so we can't desugar the bindings without the diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index 643ba2e..7eb62ff 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -8,7 +8,7 @@ module DsListComp ( dsListComp, dsPArrComp ) where #include "HsVersions.h" -import {-# SOURCE #-} DsExpr ( dsLExpr, dsLet ) +import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds ) import BasicTypes ( Boxity(..) ) import HsSyn @@ -183,7 +183,7 @@ deListComp (ExprStmt guard _ _ : quals) body list -- rule B above -- [e | let B, qs] = let B in [e | qs] deListComp (LetStmt binds : quals) body list = deListComp quals body list `thenDs` \ core_rest -> - dsLet binds core_rest + dsLocalBinds binds core_rest deListComp (BindStmt pat list1 _ _ : quals) body core_list2 -- rule A' above = dsLExpr list1 `thenDs` \ core_list1 -> @@ -307,7 +307,7 @@ dfListComp c_id n_id (ExprStmt guard _ _ : quals) body dfListComp c_id n_id (LetStmt binds : quals) body -- new in 1.3, local bindings = dfListComp c_id n_id quals body `thenDs` \ core_rest -> - dsLet binds core_rest + dsLocalBinds binds core_rest dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) body -- evaluate the two lists @@ -420,11 +420,11 @@ dePArrComp (BindStmt p e _ _ : qs) body pa cea = -- dePArrComp (LetStmt ds : qs) body pa cea = dsLookupGlobalId mapPName `thenDs` \mapP -> - let xs = map unLoc (collectGroupBinders ds) + let xs = map unLoc (collectLocalBinders ds) ty'cea = parrElemType cea in newSysLocalDs ty'cea `thenDs` \v -> - dsLet ds (mkCoreTup (map Var xs)) `thenDs` \clet -> + dsLocalBinds ds (mkCoreTup (map Var xs)) `thenDs` \clet -> newSysLocalDs (exprType clet) `thenDs` \let'v -> let projBody = mkDsLet (NonRec let'v clet) $ mkCoreTup [Var v, Var let'v] diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index 35e9677..9785cdb 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -56,8 +56,7 @@ import BasicTypes ( isBoxed ) import Outputable import Bag ( bagToList ) import FastString ( unpackFS ) -import ForeignCall ( Safety(..), ForeignCall(..), CCallConv(..), - CCallTarget(..) ) +import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..) ) import Monad ( zipWithM ) import List ( sortBy ) @@ -112,12 +111,12 @@ repTopDs group decls <- addBinds ss (do { - val_ds <- mapM rep_bind_group (hs_valds group) ; + val_ds <- rep_val_binds (hs_valds group) ; tycl_ds <- mapM repTyClD (hs_tyclds group) ; inst_ds <- mapM repInstD' (hs_instds group) ; for_ds <- mapM repForD (hs_fords group) ; -- more needed - return (de_loc $ sort_by_loc $ concat val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ; + return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ; decl_ty <- lookupType decQTyConName ; let { core_list = coreList' decl_ty decls } ; @@ -132,7 +131,7 @@ repTopDs group groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, hs_fords = foreign_decls }) -- Collect the binders of a Group - = collectGroupBinders val_decls ++ + = collectHsValBinders val_decls ++ [n | d <- tycl_decls, n <- tyClDeclNames (unLoc d)] ++ [n | L _ (ForeignImport n _ _ _) <- foreign_decls] @@ -205,16 +204,16 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, cxt1 <- repLContext cxt ; sigs1 <- rep_sigs sigs ; binds1 <- rep_binds meth_binds ; - fds1 <- repLFunDeps fds; + fds1 <- repLFunDeps fds; decls1 <- coreList decQTyConName (sigs1 ++ binds1) ; bndrs1 <- coreList nameTyConName bndrs ; repClass cxt1 cls1 bndrs1 fds1 decls1 } ; return $ Just (loc, dec) } -- Un-handled cases -repTyClD (L loc d) = do { dsWarn (loc, hang ds_msg 4 (ppr d)) ; - return Nothing - } +repTyClD (L loc d) = putSrcSpanDs loc $ + do { dsWarn (hang ds_msg 4 (ppr d)) + ; return Nothing } -- represent fundeps -- @@ -298,11 +297,10 @@ repC (L loc (ConDecl con tvs (L cloc ctxt) details)) } } repC (L loc con_decl) - = do { dsWarn (loc, hang ds_msg 4 (ppr con_decl)) + = putSrcSpanDs loc $ + do { dsWarn (hang ds_msg 4 (ppr con_decl)) ; return (panic "DsMeta:repC") } --- gaw 2004 FIX! Need a case for GadtDecl - repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ)) repBangTy ty= do MkC s <- rep2 str [] @@ -677,38 +675,39 @@ repSts other = panic "Exotic Stmt in meta brackets" -- Bindings ----------------------------------------------------------- -repBinds :: [HsBindGroup Name] -> DsM ([GenSymBind], Core [TH.DecQ]) -repBinds decs - = do { let { bndrs = map unLoc (collectGroupBinders decs) } +repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ]) +repBinds EmptyLocalBinds + = do { core_list <- coreList decQTyConName [] + ; return ([], core_list) } + +repBinds (HsIPBinds _) + = panic "DsMeta:repBinds: can't do implicit parameters" + +repBinds (HsValBinds decs) + = do { let { bndrs = map unLoc (collectHsValBinders decs) } -- No need to worrry about detailed scopes within -- the binding group, because we are talking Names -- here, so we can safely treat it as a mutually -- recursive group ; ss <- mkGenSyms bndrs - ; core <- addBinds ss (rep_bind_groups decs) - ; core_list <- coreList decQTyConName core + ; prs <- addBinds ss (rep_val_binds decs) + ; core_list <- coreList decQTyConName + (de_loc (sort_by_loc prs)) ; return (ss, core_list) } -rep_bind_groups :: [HsBindGroup Name] -> DsM [Core TH.DecQ] +rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)] -- Assumes: all the binders of the binding are alrady in the meta-env -rep_bind_groups binds = do - locs_cores_s <- mapM rep_bind_group binds - return $ de_loc $ sort_by_loc (concat locs_cores_s) - -rep_bind_group :: HsBindGroup Name -> DsM [(SrcSpan, Core TH.DecQ)] --- Assumes: all the binders of the binding are alrady in the meta-env -rep_bind_group (HsBindGroup bs sigs _) - = do { core1 <- mapM rep_bind (bagToList bs) +rep_val_binds (ValBindsIn binds sigs) + = do { core1 <- rep_binds' binds ; core2 <- rep_sigs' sigs ; return (core1 ++ core2) } -rep_bind_group (HsIPBinds _) - = panic "DsMeta:repBinds: can't do implicit parameters" rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ] --- Assumes: all the binders of the binding are alrady in the meta-env -rep_binds binds = do - locs_cores <- mapM rep_bind (bagToList binds) - return $ de_loc $ sort_by_loc locs_cores +rep_binds binds = do { binds_w_locs <- rep_binds' binds + ; return (de_loc (sort_by_loc binds_w_locs)) } + +rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)] +rep_binds' binds = mapM rep_bind (bagToList binds) rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ) -- Assumes: all the binders of the binding are alrady in the meta-env @@ -716,7 +715,7 @@ rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ) -- Note GHC treats declarations of a variable (not a pattern) -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match -- with an empty list of patterns -rep_bind (L loc (FunBind fn infx (MatchGroup [L _ (Match [] ty (GRHSs guards wheres))] _))) +rep_bind (L loc (FunBind fn infx (MatchGroup [L _ (Match [] ty (GRHSs guards wheres))] _) _)) = do { (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) ; fn' <- lookupLBinder fn @@ -725,13 +724,13 @@ rep_bind (L loc (FunBind fn infx (MatchGroup [L _ (Match [] ty (GRHSs guards whe ; ans' <- wrapGenSyns ss ans ; return (loc, ans') } -rep_bind (L loc (FunBind fn infx (MatchGroup ms _))) +rep_bind (L loc (FunBind fn infx (MatchGroup ms _) _)) = do { ms1 <- mapM repClauseTup ms ; fn' <- lookupLBinder fn ; ans <- repFun fn' (nonEmptyCoreList ms1) ; return (loc, ans) } -rep_bind (L loc (PatBind pat (GRHSs guards wheres) ty2)) +rep_bind (L loc (PatBind pat (GRHSs guards wheres) ty2 _)) = do { patcore <- repLP pat ; (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) @@ -773,7 +772,7 @@ rep_bind (L loc (VarBind v e)) -- (\ p1 .. pn -> exp) by causing an error. repLambda :: LMatch Name -> DsM (Core TH.ExpQ) -repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] []))) +repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds))) = do { let bndrs = collectPatsBinders ps ; ; ss <- mkGenSyms bndrs ; lam <- addBinds ss ( diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index 2dbe8b1..75fd45b 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -5,10 +5,11 @@ \begin{code} module DsMonad ( - DsM, mappM, - initDs, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs, foldlDs, + DsM, mappM, mapAndUnzipM, + initDs, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs, + foldlDs, foldrDs, - newTyVarsDs, + newTyVarsDs, newLocalName, duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId, newFailLocalDs, getSrcSpanDs, putSrcSpanDs, @@ -119,6 +120,7 @@ thenDs = thenM returnDs = returnM listDs = sequenceM foldlDs = foldlM +foldrDs = foldrM mapAndUnzipDs = mapAndUnzipM @@ -239,8 +241,10 @@ getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) } putSrcSpanDs :: SrcSpan -> DsM a -> DsM a putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside -dsWarn :: DsWarning -> DsM () -dsWarn (loc,warn) = do { env <- getGblEnv; updMutVar (ds_warns env) (`snocBag` (loc,msg)) } +dsWarn :: SDoc -> DsM () +dsWarn warn = do { env <- getGblEnv + ; loc <- getSrcSpanDs + ; updMutVar (ds_warns env) (`snocBag` (loc,msg)) } where msg = ptext SLIT("Warning:") <+> warn \end{code} diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index fe5b95b..bd1a5c6 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -15,7 +15,7 @@ import Check ( check, ExhaustivePat ) import CoreSyn import CoreUtils ( bindNonRec, exprType ) import DsMonad -import DsBinds ( dsHsNestedBinds ) +import DsBinds ( dsLHsBinds ) import DsGRHSs ( dsGRHSs ) import DsUtils import Id ( idName, idType, Id ) @@ -90,19 +90,21 @@ The next two functions create the warning message. \begin{code} dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM () -dsShadowWarn ctx@(DsMatchContext kind _ _) qs = dsWarn warn - where - warn | qs `lengthExceeds` maximum_output - = pp_context ctx (ptext SLIT("are overlapped")) - (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$ - ptext SLIT("...")) - | otherwise - = pp_context ctx (ptext SLIT("are overlapped")) - (\ f -> vcat $ map (ppr_eqn f kind) qs) +dsShadowWarn ctx@(DsMatchContext kind _ loc) qs + = putSrcSpanDs loc (dsWarn warn) + where + warn | qs `lengthExceeds` maximum_output + = pp_context ctx (ptext SLIT("are overlapped")) + (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$ + ptext SLIT("...")) + | otherwise + = pp_context ctx (ptext SLIT("are overlapped")) + (\ f -> vcat $ map (ppr_eqn f kind) qs) dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM () -dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn +dsIncompleteWarn ctx@(DsMatchContext kind _ loc) pats + = putSrcSpanDs loc (dsWarn warn) where warn = pp_context ctx (ptext SLIT("are non-exhaustive")) (\f -> hang (ptext SLIT("Patterns not matched:")) @@ -113,9 +115,9 @@ dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn dots | pats `lengthExceeds` maximum_output = ptext SLIT("...") | otherwise = empty -pp_context (DsMatchContext kind pats loc) msg rest_of_msg_fun - = (loc, vcat [ptext SLIT("Pattern match(es)") <+> msg, - sep [ptext SLIT("In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]]) +pp_context (DsMatchContext kind pats _loc) msg rest_of_msg_fun + = vcat [ptext SLIT("Pattern match(es)") <+> msg, + sep [ptext SLIT("In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]] where (ppr_match, pref) = case kind of @@ -341,7 +343,7 @@ Float, Double, at least) are converted to unboxed form; e.g., \begin{code} tidyEqnInfo :: Id -> EquationInfo -> DsM EquationInfo - -- DsM'd because of internal call to dsHsNestedBinds + -- DsM'd because of internal call to dsLHsBinds -- and mkSelectorBinds. -- "tidy1" does the interesting stuff, looking at -- one pattern and fiddling the list of bindings. @@ -399,7 +401,7 @@ tidy1 v wrap (VarPat var) = returnDs (wrap . wrapBind var v, WildPat (idType var)) tidy1 v wrap (VarPatOut var binds) - = do { prs <- dsHsNestedBinds binds + = do { prs <- dsLHsBinds binds ; return (wrap . wrapBind var v . mkDsLet (Rec prs), WildPat (idType var)) } diff --git a/ghc/compiler/deSugar/MatchCon.lhs b/ghc/compiler/deSugar/MatchCon.lhs index c76b748..da59300 100644 --- a/ghc/compiler/deSugar/MatchCon.lhs +++ b/ghc/compiler/deSugar/MatchCon.lhs @@ -11,7 +11,7 @@ module MatchCon ( matchConFamily ) where import {-# SOURCE #-} Match ( match ) import HsSyn ( Pat(..), HsConDetails(..) ) -import DsBinds ( dsHsNestedBinds ) +import DsBinds ( dsLHsBinds ) import DataCon ( isVanillaDataCon, dataConTyVars, dataConOrigArgTys ) import TcType ( tcTyConAppArgs ) import Type ( substTys, zipTopTvSubst, mkTyVarTys ) @@ -125,7 +125,7 @@ match_con vars ty eqns shift eqn@(EqnInfo { eqn_wrap = wrap, eqn_pats = ConPatOut _ tvs ds bind (PrefixCon arg_pats) _ : pats }) - = do { prs <- dsHsNestedBinds bind + = do { prs <- dsLHsBinds bind ; return (eqn { eqn_wrap = wrap . wrapBinds (tvs `zip` tvs1) . wrapBinds (ds `zip` dicts1) . mkDsLet (Rec prs), diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs index 7d5653c..751623d 100644 --- a/ghc/compiler/hsSyn/Convert.lhs +++ b/ghc/compiler/hsSyn/Convert.lhs @@ -23,7 +23,7 @@ import qualified OccName import SrcLoc ( unLoc, Located(..), SrcSpan ) import Type ( Type ) import TysWiredIn ( unitTyCon, tupleTyCon, trueDataCon ) -import BasicTypes( Boxity(..), RecFlag(Recursive) ) +import BasicTypes( Boxity(..) ) import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..), CExportSpec(..)) import Char ( isAscii, isAlphaNum, isAlpha ) @@ -221,9 +221,9 @@ cvtHsDo loc do_or_lc stmts body = case last stmts' of L _ (ExprStmt body _ _) -> body -cvtdecs :: SrcSpan -> [TH.Dec] -> [HsBindGroup RdrName] -cvtdecs loc [] = [] -cvtdecs loc ds = [HsBindGroup binds sigs Recursive] +cvtdecs :: SrcSpan -> [TH.Dec] -> HsLocalBinds RdrName +cvtdecs loc [] = EmptyLocalBinds +cvtdecs loc ds = HsValBinds (ValBindsIn binds sigs) where (binds, sigs) = cvtBindsAndSigs loc ds @@ -242,11 +242,16 @@ cvtd :: SrcSpan -> TH.Dec -> LHsBind RdrName -- Used only for declarations in a 'let/where' clause, -- not for top level decls cvtd loc (TH.ValD (TH.VarP s) body ds) - = L loc $ FunBind (L loc (vName s)) False (mkMatchGroup [cvtclause loc (Clause [] body ds)]) + = L loc $ FunBind (L loc (vName s)) False + (mkMatchGroup [cvtclause loc (Clause [] body ds)]) + placeHolderNames cvtd loc (FunD nm cls) - = L loc $ FunBind (L loc (vName nm)) False (mkMatchGroup (map (cvtclause loc) cls)) + = L loc $ FunBind (L loc (vName nm)) False + (mkMatchGroup (map (cvtclause loc) cls)) + placeHolderNames cvtd loc (TH.ValD p body ds) - = L loc $ PatBind (cvtlp loc p) (GRHSs (cvtguard loc body) (cvtdecs loc ds)) void + = L loc $ PatBind (cvtlp loc p) (GRHSs (cvtguard loc body) (cvtdecs loc ds)) + void placeHolderNames cvtd loc d = cvtPanic "Illegal kind of declaration in where clause" (text (TH.pprint d)) diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index 47302c5..0646b23 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -17,12 +17,12 @@ import {-# SOURCE #-} HsPat ( LPat ) import HsTypes ( LHsType, PostTcType ) import Name ( Name ) -import NameSet ( NameSet, elemNameSet, nameSetToList ) +import NameSet ( NameSet, elemNameSet ) import BasicTypes ( IPName, RecFlag(..), Activation(..), Fixity ) import Outputable import SrcLoc ( Located(..), unLoc ) -import Var ( TyVar ) -import Bag ( Bag, emptyBag, isEmptyBag, bagToList ) +import Var ( TyVar, DictId, Id ) +import Bag ( Bag, emptyBag, isEmptyBag, bagToList, unionBags ) \end{code} %************************************************************************ @@ -34,65 +34,25 @@ import Bag ( Bag, emptyBag, isEmptyBag, bagToList ) Global bindings (where clauses) \begin{code} -data HsBindGroup id - = HsBindGroup -- A mutually recursive group - (LHsBinds id) - [LSig id] -- Empty on typechecker output, Type Signatures - RecFlag - - | HsIPBinds - [LIPBind id] -- Not allowed at top level - -instance OutputableBndr id => Outputable (HsBindGroup id) where - ppr (HsBindGroup binds sigs is_rec) - = vcat [ppr_isrec, - vcat (map ppr sigs), - vcat (map ppr (bagToList binds)) - -- *not* pprLHsBinds because we don't want braces; 'let' and - -- 'where' include a list of HsBindGroups and we don't want - -- several groups of bindings each with braces around. - ] - where - ppr_isrec = getPprStyle $ \ sty -> - if userStyle sty then empty else - case is_rec of - Recursive -> ptext SLIT("{- rec -}") - NonRecursive -> ptext SLIT("{- nonrec -}") - - ppr (HsIPBinds ipbinds) - = vcat (map ppr ipbinds) +data HsLocalBinds id -- Bindings in a 'let' expression + -- or a 'where' clause + = HsValBinds (HsValBinds id) + | HsIPBinds (HsIPBinds id) + | EmptyLocalBinds --- ----------------------------------------------------------------------------- --- Implicit parameter bindings - -type LIPBind id = Located (IPBind id) - --- | Implicit parameter bindings. -data IPBind id - = IPBind - (IPName id) - (LHsExpr id) +data HsValBinds id -- Value bindings (not implicit parameters) + = ValBindsIn -- Before typechecking + (LHsBinds id) [LSig id] -- Not dependency analysed + -- Recursive by default -instance (OutputableBndr id) => Outputable (IPBind id) where - ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs) + | ValBindsOut -- After typechecking + [(RecFlag, LHsBinds id)] -- Dependency analysed --- ----------------------------------------------------------------------------- type LHsBinds id = Bag (LHsBind id) type DictBinds id = LHsBinds id -- Used for dictionary or method bindings type LHsBind id = Located (HsBind id) -emptyLHsBinds :: LHsBinds id -emptyLHsBinds = emptyBag - -isEmptyLHsBinds :: LHsBinds id -> Bool -isEmptyLHsBinds = isEmptyBag - -pprLHsBinds :: OutputableBndr id => LHsBinds id -> SDoc -pprLHsBinds binds - | isEmptyLHsBinds binds = empty - | otherwise = lbrace <+> vcat (map ppr (bagToList binds)) <+> rbrace - data HsBind id = FunBind (Located id) -- Used for both functions f x = e @@ -105,28 +65,102 @@ data HsBind id -- change e.g. rnMethodBinds Bool -- True => infix declaration (MatchGroup id) + NameSet -- After the renamer, this contains a superset of the + -- Names of the other binders in this binding group that + -- are free in the RHS of the defn + -- Before renaming, and after typechecking, + -- the field is unused; it's just an error thunk | PatBind (LPat id) -- The pattern is never a simple variable; -- That case is done by FunBind (GRHSs id) PostTcType -- Type of the GRHSs - - | VarBind id (Located (HsExpr id)) -- Dictionary binding and suchlike; - -- located only for consistency - - | AbsBinds -- Binds abstraction; TRANSLATION - [TyVar] -- Type variables - [id] -- Dicts - [([TyVar], id, id)] -- (type variables, polymorphic, momonmorphic) triples - NameSet -- Set of *polymorphic* variables that have an INLINE pragma - (LHsBinds id) -- The "business end" - - -- Creates bindings for *new* (polymorphic, overloaded) locals - -- in terms of *old* (monomorphic, non-overloaded) ones. + NameSet -- Same as for FunBind + + | VarBind id (Located (HsExpr id)) -- Dictionary binding and suchlike + -- All VarBinds are introduced by the type checker + -- Located only for consistency + + | AbsBinds -- Binds abstraction; TRANSLATION + [TyVar] -- Type variables + [DictId] -- Dicts + [([TyVar], id, id, [Prag])] -- (tvs, poly_id, mono_id, prags) + (LHsBinds id) -- The dictionary bindings and typechecked user bindings + -- mixed up together; you can tell the dict bindings because + -- they are all VarBinds + + -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds] + -- + -- Creates bindings for (polymorphic, overloaded) poly_f + -- in terms of monomorphic, non-overloaded mono_f + -- + -- Invariants: + -- 1. 'binds' binds mono_f + -- 2. ftvs is a subset of tvs + -- 3. ftvs includes all tyvars free in ds -- -- See section 9 of static semantics paper for more details. -- (You can get a PhD for explaining the True Meaning -- of this last construct.) + +placeHolderNames :: NameSet +-- Used for the NameSet in FunBind and PatBind prior to the renamer +placeHolderNames = panic "placeHolderNames" + +------------ +instance OutputableBndr id => Outputable (HsLocalBinds id) where + ppr (HsValBinds bs) = ppr bs + ppr (HsIPBinds bs) = ppr bs + ppr EmptyLocalBinds = empty + +instance OutputableBndr id => Outputable (HsValBinds id) where + ppr (ValBindsIn binds sigs) + = vcat [vcat (map ppr sigs), + vcat (map ppr (bagToList binds)) + -- *not* pprLHsBinds because we don't want braces; 'let' and + -- 'where' include a list of HsBindGroups and we don't want + -- several groups of bindings each with braces around. + ] + ppr (ValBindsOut sccs) = vcat (map ppr_scc sccs) + where + ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds + pp_rec Recursive = ptext SLIT("rec") + pp_rec NonRecursive = ptext SLIT("nonrec") + +pprLHsBinds :: OutputableBndr id => LHsBinds id -> SDoc +pprLHsBinds binds + | isEmptyLHsBinds binds = empty + | otherwise = lbrace <+> vcat (map ppr (bagToList binds)) <+> rbrace + +------------ +emptyLocalBinds :: HsLocalBinds a +emptyLocalBinds = EmptyLocalBinds + +isEmptyLocalBinds :: HsLocalBinds a -> Bool +isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds +isEmptyLocalBinds (HsIPBinds ds) = isEmptyIPBinds ds +isEmptyLocalBinds EmptyLocalBinds = True + +isEmptyValBinds :: HsValBinds a -> Bool +isEmptyValBinds (ValBindsIn ds sigs) = isEmptyLHsBinds ds && null sigs +isEmptyValBinds (ValBindsOut ds) = null ds + +emptyValBindsIn, emptyValBindsOut :: HsValBinds a +emptyValBindsIn = ValBindsIn emptyBag [] +emptyValBindsOut = ValBindsOut [] + +emptyLHsBinds :: LHsBinds id +emptyLHsBinds = emptyBag + +isEmptyLHsBinds :: LHsBinds id -> Bool +isEmptyLHsBinds = isEmptyBag + +------------ +plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a +plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2) + = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2) +plusHsValBinds (ValBindsOut ds1) (ValBindsOut ds2) + = ValBindsOut (ds1 ++ ds2) \end{code} What AbsBinds means @@ -159,26 +193,61 @@ instance OutputableBndr id => Outputable (HsBind id) where ppr_monobind :: OutputableBndr id => HsBind id -> SDoc -ppr_monobind (PatBind pat grhss ty) = pprPatBind pat grhss -ppr_monobind (VarBind var rhs) = ppr var <+> equals <+> pprExpr (unLoc rhs) -ppr_monobind (FunBind fun inf matches) = pprFunBind (unLoc fun) matches +ppr_monobind (PatBind pat grhss _ _) = pprPatBind pat grhss +ppr_monobind (VarBind var rhs) = ppr var <+> equals <+> pprExpr (unLoc rhs) +ppr_monobind (FunBind fun inf matches _) = pprFunBind (unLoc fun) matches -- ToDo: print infix if appropriate -ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds) +ppr_monobind (AbsBinds tyvars dictvars exports val_binds) = sep [ptext SLIT("AbsBinds"), brackets (interpp'SP tyvars), brackets (interpp'SP dictvars), - brackets (sep (punctuate comma (map ppr exports))), - brackets (interpp'SP (nameSetToList inlines))] + brackets (sep (punctuate comma (map ppr_exp exports)))] $$ - nest 4 ( vcat [pprBndr LetBind x | (_,x,_) <- exports] + nest 2 ( vcat [pprBndr LetBind x | (_,x,_,_) <- exports] -- Print type signatures - $$ - pprLHsBinds val_binds ) + $$ pprLHsBinds val_binds ) + where + ppr_exp (tvs, gbl, lcl, prags) + = vcat [ppr gbl <+> ptext SLIT("<=") <+> ppr tvs <+> ppr lcl, + nest 2 (vcat (map (pprPrag gbl) prags))] \end{code} %************************************************************************ %* * + Implicit parameter bindings +%* * +%************************************************************************ + +\begin{code} +data HsIPBinds id + = IPBinds + [LIPBind id] + (DictBinds id) -- Only in typechecker output; binds + -- uses of the implicit parameters + +isEmptyIPBinds :: HsIPBinds id -> Bool +isEmptyIPBinds (IPBinds is ds) = null is && isEmptyBag ds + +type LIPBind id = Located (IPBind id) + +-- | Implicit parameter bindings. +data IPBind id + = IPBind + (IPName id) + (LHsExpr id) + +instance (OutputableBndr id) => Outputable (HsIPBinds id) where + ppr (IPBinds bs ds) = vcat (map ppr bs) + $$ pprLHsBinds ds + +instance (OutputableBndr id) => Outputable (IPBind id) where + ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs) +\end{code} + + +%************************************************************************ +%* * \subsection{@Sig@: type signatures and value-modifying user pragmas} %* * %************************************************************************ @@ -209,12 +278,34 @@ data Sig name type LFixitySig name = Located (FixitySig name) data FixitySig name = FixitySig (Located name) Fixity + +-- A Prag conveys pragmas from the type checker to the desugarer +data Prag + = InlinePrag + Bool -- True <=> INLINE, False <=> NOINLINE + Activation + + | SpecPrag + (HsExpr Id) -- An expression, of the given specialised type, which + PostTcType -- specialises the polymorphic function + [Id] -- Dicts mentioned free in the expression + +isInlinePrag (InlinePrag _ _) = True +isInlinePrag prag = False + +isSpecPrag (SpecPrag _ _ _) = True +isSpecPrag prag = False \end{code} \begin{code} okBindSig :: NameSet -> LSig Name -> Bool okBindSig ns sig = sigForThisGroup ns sig +okHsBootSig :: LSig Name -> Bool +okHsBootSig (L _ (Sig _ _)) = True +okHsBootSig (L _ (FixSig _)) = True +okHsBootSig sig = False + okClsDclSig :: LSig Name -> Bool okClsDclSig (L _ (SpecInstSig _)) = False okClsDclSig sig = True -- All others OK @@ -250,11 +341,17 @@ isVanillaLSig :: LSig name -> Bool isVanillaLSig (L _(Sig name _)) = True isVanillaLSig sig = False +isSpecLSig :: LSig name -> Bool +isSpecLSig (L _(SpecSig name _)) = True +isSpecLSig sig = False + +isSpecInstLSig (L _ (SpecInstSig _)) = True +isSpecInstLSig sig = False + isPragLSig :: LSig name -> Bool -- Identifies pragmas isPragLSig (L _ (SpecSig _ _)) = True isPragLSig (L _ (InlineSig _ _ _)) = True -isPragLSig (L _ (SpecInstSig _)) = True isPragLSig other = False hsSigDoc (Sig _ _) = ptext SLIT("type signature") @@ -268,10 +365,10 @@ hsSigDoc (FixSig (FixitySig _ _)) = ptext SLIT("fixity declaration") Signature equality is used when checking for duplicate signatures \begin{code} -eqHsSig :: Sig Name -> Sig Name -> Bool -eqHsSig (FixSig (FixitySig n1 _)) (FixSig (FixitySig n2 _)) = unLoc n1 == unLoc n2 -eqHsSig (Sig n1 _) (Sig n2 _) = unLoc n1 == unLoc n2 -eqHsSig (InlineSig b1 n1 _) (InlineSig b2 n2 _) = b1 == b2 && unLoc n1 == unLoc n2 +eqHsSig :: LSig Name -> LSig Name -> Bool +eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2 +eqHsSig (L _ (Sig n1 _)) (L _ (Sig n2 _)) = unLoc n1 == unLoc n2 +eqHsSig (L _ (InlineSig b1 n1 _)) (L _ (InlineSig b2 n2 _)) = b1 == b2 && unLoc n1 == unLoc n2 -- For specialisations, we don't have equality over -- HsType, so it's not convenient to spot duplicate -- specialisations here. Check for this later, when we're in Type land @@ -283,25 +380,29 @@ instance (OutputableBndr name) => Outputable (Sig name) where ppr sig = ppr_sig sig ppr_sig :: OutputableBndr name => Sig name -> SDoc -ppr_sig (Sig var ty) - = sep [ppr var <+> dcolon, nest 4 (ppr ty)] +ppr_sig (Sig var ty) = pprVarSig (unLoc var) ty +ppr_sig (FixSig fix_sig) = ppr fix_sig +ppr_sig (SpecSig var ty) = pragBrackets (pprSpec var ty) +ppr_sig (InlineSig inl var phase) = pragBrackets (pprInline var inl phase) +ppr_sig (SpecInstSig ty) = pragBrackets (ptext SLIT("SPECIALIZE instance") <+> ppr ty) -ppr_sig (SpecSig var ty) - = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon], - nest 4 (ppr ty <+> text "#-}") - ] +instance Outputable name => Outputable (FixitySig name) where + ppr (FixitySig name fixity) = sep [ppr fixity, ppr name] -ppr_sig (InlineSig True var phase) - = hsep [text "{-# INLINE", ppr phase, ppr var, text "#-}"] +pragBrackets :: SDoc -> SDoc +pragBrackets doc = ptext SLIT("{-#") <+> doc <+> ptext SLIT("#-}") -ppr_sig (InlineSig False var phase) - = hsep [text "{-# NOINLINE", ppr phase, ppr var, text "#-}"] +pprInline :: Outputable id => id -> Bool -> Activation -> SDoc +pprInline var True phase = hsep [ptext SLIT("INLINE"), ppr phase, ppr var] +pprInline var False phase = hsep [ptext SLIT("NOINLINE"), ppr phase, ppr var] -ppr_sig (SpecInstSig ty) - = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"] +pprVarSig :: (Outputable id, Outputable ty) => id -> ty -> SDoc +pprVarSig var ty = sep [ppr var <+> dcolon, nest 2 (ppr ty)] -ppr_sig (FixSig fix_sig) = ppr fix_sig +pprSpec :: (Outputable id, Outputable ty) => id -> ty -> SDoc +pprSpec var ty = sep [ptext SLIT("SPECIALIZE") <+> pprVarSig var ty] -instance Outputable name => Outputable (FixitySig name) where - ppr (FixitySig name fixity) = sep [ppr fixity, ppr name] +pprPrag :: Outputable id => id -> Prag -> SDoc +pprPrag var (InlinePrag inl act) = pprInline var inl act +pprPrag var (SpecPrag expr ty _) = pprSpec var ty \end{code} diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 807a2bb..1cf7c85 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -16,7 +16,7 @@ module HsDecls ( CImportSpec(..), FoType(..), ConDecl(..), LConDecl, DeprecDecl(..), LDeprecDecl, - HsGroup(..), emptyGroup, appendGroups, + HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups, tcdName, tyClDeclNames, tyClDeclTyVars, isClassDecl, isSynDecl, isDataDecl, countTyClDecls, @@ -30,15 +30,16 @@ module HsDecls ( import {-# SOURCE #-} HsExpr( HsExpr, pprExpr ) -- Because Expr imports Decls via HsBracket -import HsBinds ( HsBindGroup(..), HsBind, LHsBinds, - Sig(..), LSig, LFixitySig, pprLHsBinds ) +import HsBinds ( HsValBinds(..), HsBind, LHsBinds, plusHsValBinds, + Sig(..), LSig, LFixitySig, pprLHsBinds, + emptyValBindsIn, emptyValBindsOut ) import HsPat ( HsConDetails(..), hsConArgs ) import HsImpExp ( pprHsVar ) import HsTypes import HscTypes ( DeprecTxt ) import CoreSyn ( RuleName ) import Kind ( Kind, pprKind ) -import BasicTypes ( Activation(..), RecFlag(..) ) +import BasicTypes ( Activation(..) ) import ForeignCall ( CCallTarget(..), DNCallSpec, CCallConv, Safety, CExportSpec(..), CLabelString ) @@ -47,7 +48,6 @@ import FunDeps ( pprFundeps ) import Class ( FunDep ) import Outputable import Util ( count ) -import Bag ( emptyBag ) import SrcLoc ( Located(..), unLoc ) import FastString \end{code} @@ -90,12 +90,7 @@ data HsDecl id -- fed to the renamer. data HsGroup id = HsGroup { - hs_valds :: [HsBindGroup id], - -- Before the renamer, this is a single big HsBindGroup, - -- with all the bindings, and all the signatures. - -- The renamer does dependency analysis, splitting it up - -- into several HsBindGroups. - + hs_valds :: HsValBinds id, hs_tyclds :: [LTyClDecl id], hs_instds :: [LInstDecl id], @@ -109,8 +104,11 @@ data HsGroup id hs_ruleds :: [LRuleDecl id] } -emptyGroup = HsGroup { hs_valds = [], - hs_tyclds = [], hs_instds = [], +emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a +emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn } +emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut } + +emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], hs_fixds = [], hs_defds = [], hs_fords = [], hs_depds = [] ,hs_ruleds = [] } @@ -136,7 +134,7 @@ appendGroups hs_ruleds = rulds2 } = HsGroup { - hs_valds = val_groups1 ++ val_groups2, + hs_valds = val_groups1 `plusHsValBinds` val_groups2, hs_tyclds = tyclds1 ++ tyclds2, hs_instds = instds1 ++ instds2, hs_fixds = fixds1 ++ fixds2, diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 4ae6ce4..86c4190 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -14,7 +14,7 @@ import HsPat ( LPat ) import HsLit ( HsLit(..), HsOverLit ) import HsTypes ( LHsType, PostTcType ) import HsImpExp ( isOperator, pprHsVar ) -import HsBinds ( HsBindGroup, DictBinds ) +import HsBinds ( HsLocalBinds, DictBinds, isEmptyLocalBinds ) -- others: import Type ( Type, pprParendType ) @@ -121,7 +121,7 @@ data HsExpr id (LHsExpr id) -- then part (LHsExpr id) -- else part - | HsLet [HsBindGroup id] -- let(rec) + | HsLet (HsLocalBinds id) -- let(rec) (LHsExpr id) | HsDo (HsStmtContext Name) -- The parameterisation is unimportant @@ -274,8 +274,8 @@ pprExpr :: OutputableBndr id => HsExpr id -> SDoc pprExpr e = pprDeeper (ppr_expr e) -pprBinds :: OutputableBndr id => [HsBindGroup id] -> SDoc -pprBinds b = pprDeeper (vcat (map ppr b)) +pprBinds :: OutputableBndr id => HsLocalBinds id -> SDoc +pprBinds b = pprDeeper (ppr b) ppr_lexpr :: OutputableBndr id => LHsExpr id -> SDoc ppr_lexpr e = ppr_expr (unLoc e) @@ -528,7 +528,7 @@ The legal constructors for commands are: (HsCmd id) -- else part SrcLoc - | HsLet (HsBinds id) -- let(rec) + | HsLet (HsLocalBinds id) -- let(rec) (HsCmd id) | HsDo (HsStmtContext Name) -- The parameterisation is unimportant @@ -619,7 +619,7 @@ hsLMatchPats (L _ (Match pats _ _)) = pats -- GRHSs are used both for pattern bindings and for Matches data GRHSs id = GRHSs [LGRHS id] -- Guarded RHSs - [HsBindGroup id] -- The where clause + (HsLocalBinds id) -- The where clause type LGRHS id = Located (GRHS id) @@ -663,7 +663,7 @@ pprGRHSs :: OutputableBndr id => HsMatchContext id -> GRHSs id -> SDoc pprGRHSs ctxt (GRHSs grhss binds) = vcat (map (pprGRHS ctxt . unLoc) grhss) $$ - (if null binds then empty + (if isEmptyLocalBinds binds then empty else text "where" $$ nest 4 (pprBinds binds)) pprGRHS :: OutputableBndr id => HsMatchContext id -> GRHS id -> SDoc @@ -700,7 +700,7 @@ data Stmt id (SyntaxExpr id) -- The (>>) operator PostTcType -- Element type of the RHS (used for arrows) - | LetStmt [HsBindGroup id] + | LetStmt (HsLocalBinds id) -- ParStmts only occur in a list comprehension | ParStmt [([LStmt id], [id])] -- After renaming, the ids are the binders diff --git a/ghc/compiler/hsSyn/HsUtils.lhs b/ghc/compiler/hsSyn/HsUtils.lhs index d2e757e..8019f36 100644 --- a/ghc/compiler/hsSyn/HsUtils.lhs +++ b/ghc/compiler/hsSyn/HsUtils.lhs @@ -27,9 +27,9 @@ import RdrName ( RdrName, getRdrName, mkRdrUnqual ) import Var ( Id ) import Type ( Type ) import DataCon ( DataCon, dataConWrapId, dataConSourceArity ) -import BasicTypes ( RecFlag(..) ) import OccName ( mkVarOcc ) import Name ( Name ) +import BasicTypes ( RecFlag(..) ) import SrcLoc import FastString ( mkFastString ) import Outputable @@ -56,7 +56,7 @@ mkHsPar e = L (getLoc e) (HsPar e) mkSimpleMatch :: [LPat id] -> LHsExpr id -> LMatch id mkSimpleMatch pats rhs = L loc $ - Match pats Nothing (GRHSs (unguardedRHS rhs) []) + Match pats Nothing (GRHSs (unguardedRHS rhs) emptyLocalBinds) where loc = case pats of [] -> getLoc rhs @@ -93,10 +93,14 @@ mkHsTyLam tyvars expr = L (getLoc expr) (TyLam tyvars expr) mkHsDictLam [] expr = expr mkHsDictLam dicts expr = L (getLoc expr) (DictLam dicts expr) -mkHsLet :: LHsBinds name -> LHsExpr name -> LHsExpr name -mkHsLet binds expr +mkHsDictLet :: LHsBinds Id -> LHsExpr Id -> LHsExpr Id +-- Used for the dictionary bindings gotten from TcSimplify +-- We make them recursive to be on the safe side +mkHsDictLet binds expr | isEmptyLHsBinds binds = expr - | otherwise = L (getLoc expr) (HsLet [HsBindGroup binds [] Recursive] expr) + | otherwise = L (getLoc expr) (HsLet (HsValBinds val_binds) expr) + where + val_binds = ValBindsOut [(Recursive, binds)] mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id -- Used for constructing dictinoary terms etc, so no locations @@ -110,10 +114,6 @@ mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id mkSimpleHsAlt pat expr = mkSimpleMatch [pat] expr -glueBindsOnGRHSs :: HsBindGroup id -> GRHSs id -> GRHSs id -glueBindsOnGRHSs binds1 (GRHSs grhss binds2) - = GRHSs grhss (binds1 : binds2) - ------------------------------- -- These are the bits of syntax that contain rebindable names -- See RnEnv.lookupSyntaxName @@ -224,34 +224,35 @@ nlHsFunTy a b = noLoc (HsFunTy a b) mkVarBind :: SrcSpan -> name -> LHsExpr name -> LHsBind name mkVarBind loc var rhs = mk_easy_FunBind loc var [] emptyLHsBinds rhs +------------ mk_easy_FunBind :: SrcSpan -> name -> [LPat name] - -> LHsBinds name -> LHsExpr name - -> LHsBind name + -> LHsBinds name -> LHsExpr name + -> LHsBind name mk_easy_FunBind loc fun pats binds expr - = L loc (FunBind (L loc fun) False{-not infix-} - (mkMatchGroup [mk_easy_Match pats binds expr])) - -mk_easy_Match pats binds expr - = mkMatch pats expr [HsBindGroup binds [] Recursive] - -- The renamer expects everything in its input to be a - -- "recursive" MonoBinds, and it is its job to sort things out - -- from there. + = L loc (FunBind (L loc fun) False{-not infix-} matches placeHolderNames) + where + matches = mkMatchGroup [mk_easy_Match pats binds expr] -mk_FunBind :: SrcSpan - -> RdrName - -> [([LPat RdrName], LHsExpr RdrName)] - -> LHsBind RdrName +------------ +mk_FunBind :: SrcSpan -> RdrName + -> [([LPat RdrName], LHsExpr RdrName)] + -> LHsBind RdrName mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind" mk_FunBind loc fun pats_and_exprs - = L loc (FunBind (L loc fun) False{-not infix-} - (mkMatchGroup [mkMatch p e [] | (p,e) <-pats_and_exprs])) + = L loc (FunBind (L loc fun) False{-not infix-} matches placeHolderNames) + where + matches = mkMatchGroup [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs] + +------------ +mk_easy_Match pats binds expr + = mkMatch pats expr (HsValBinds (ValBindsIn binds [])) -mkMatch :: [LPat id] -> LHsExpr id -> [HsBindGroup id] -> LMatch id +------------ +mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id mkMatch pats expr binds = noLoc (Match (map paren pats) Nothing --- gaw 2004 (GRHSs (unguardedRHS expr) binds)) where paren p = case p of @@ -277,29 +278,30 @@ where it should return [x, y, f, a, b] (remember, order important). \begin{code} -collectGroupBinders :: [HsBindGroup name] -> [Located name] -collectGroupBinders groups = foldr collect_group [] groups - where - collect_group (HsBindGroup bag sigs is_rec) acc - = foldrBag (collectAcc . unLoc) acc bag - collect_group (HsIPBinds _) acc = acc +collectLocalBinders :: HsLocalBinds name -> [Located name] +collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds +collectLocalBinders (HsIPBinds _) = [] +collectLocalBinders EmptyLocalBinds = [] +collectHsValBinders :: HsValBinds name -> [Located name] +collectHsValBinders (ValBindsIn binds sigs) = collectHsBindLocatedBinders binds +collectHsValBinders (ValBindsOut binds) = panic "collectHsValBinders" collectAcc :: HsBind name -> [Located name] -> [Located name] -collectAcc (PatBind pat _ _) acc = collectLocatedPatBinders pat ++ acc -collectAcc (FunBind f _ _) acc = f : acc -collectAcc (VarBind f _) acc = noLoc f : acc -collectAcc (AbsBinds _ _ dbinds _ binds) acc - = [noLoc dp | (_,dp,_) <- dbinds] ++ acc +collectAcc (PatBind pat _ _ _) acc = collectLocatedPatBinders pat ++ acc +collectAcc (FunBind f _ _ _) acc = f : acc +collectAcc (VarBind f _) acc = noLoc f : acc +collectAcc (AbsBinds _ _ dbinds binds) acc + = [noLoc dp | (_,dp,_,_) <- dbinds] ++ acc -- ++ foldr collectAcc acc binds -- I don't think we want the binders from the nested binds -- The only time we collect binders from a typechecked -- binding (hence see AbsBinds) is in zonking in TcHsSyn -collectHsBindBinders :: Bag (LHsBind name) -> [name] +collectHsBindBinders :: LHsBinds name -> [name] collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds) -collectHsBindLocatedBinders :: Bag (LHsBind name) -> [Located name] +collectHsBindLocatedBinders :: LHsBinds name -> [Located name] collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds \end{code} @@ -320,13 +322,14 @@ collectSigTysFromHsBind :: LHsBind name -> [LHsType name] collectSigTysFromHsBind bind = go (unLoc bind) where - go (PatBind pat _ _) + go (PatBind pat _ _ _) = collectSigTysFromPat pat - go (FunBind f _ (MatchGroup ms _)) + go (FunBind f _ (MatchGroup ms _) _) = [sig | L _ (Match [] (Just sig) _) <- ms] -- A binding like x :: a = f y -- is parsed as FunMonoBind, but for this purpose we -- want to treat it as a pattern binding + go out_bind = panic "collectSigTysFromHsBind" \end{code} %************************************************************************ @@ -348,7 +351,7 @@ collectLStmtBinders = collectStmtBinders . unLoc collectStmtBinders :: Stmt id -> [Located id] -- Id Binders for a Stmt... [but what about pattern-sig type vars]? collectStmtBinders (BindStmt pat _ _ _) = collectLocatedPatBinders pat -collectStmtBinders (LetStmt binds) = collectGroupBinders binds +collectStmtBinders (LetStmt binds) = collectLocalBinders binds collectStmtBinders (ExprStmt _ _ _) = [] collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss collectStmtBinders other = panic "collectStmtBinders" diff --git a/ghc/compiler/iface/IfaceSyn.lhs b/ghc/compiler/iface/IfaceSyn.lhs index a15f224..4434c5d 100644 --- a/ghc/compiler/iface/IfaceSyn.lhs +++ b/ghc/compiler/iface/IfaceSyn.lhs @@ -59,9 +59,7 @@ import Class ( FunDep, DefMeth, classExtraBigSig, classTyCon ) import OccName ( OccName, OccEnv, emptyOccEnv, lookupOccEnv, extendOccEnv, parenSymOcc, OccSet, unionOccSets, unitOccSet ) -import Name ( Name, NamedThing(..), nameOccName, isExternalName, - wiredInNameTyThing_maybe ) -import NameSet ( NameSet, elemNameSet ) +import Name ( Name, NamedThing(..), nameOccName, isExternalName ) import CostCentre ( CostCentre, pprCostCentreCore ) import Literal ( Literal ) import ForeignCall ( ForeignCall ) @@ -562,11 +560,8 @@ instanceToIfaceInst ext_lhs ispec@(Instance { is_dfun = dfun_id, is_flag = oflag ifInstTys = map do_rough mb_tcs, ifInstOrph = orph } where - do_rough Nothing = Nothing - do_rough (Just n) | Just (ATyCon tc) <- wiredInNameTyThing_maybe n - = Just (toIfaceTyCon ext_lhs tc) - | otherwise - = Just (IfaceTc (ext_lhs n)) + do_rough Nothing = Nothing + do_rough (Just n) = Just (toIfaceTyCon_name ext_lhs n) -------------------------- toIfaceIdInfo :: (Name -> IfaceExtName) -> IdInfo -> [IfaceInfoItem] diff --git a/ghc/compiler/iface/IfaceType.lhs b/ghc/compiler/iface/IfaceType.lhs index e13f77b..e6471eb 100644 --- a/ghc/compiler/iface/IfaceType.lhs +++ b/ghc/compiler/iface/IfaceType.lhs @@ -14,7 +14,8 @@ module IfaceType ( -- Conversion from Type -> IfaceType toIfaceType, toIfacePred, toIfaceContext, - toIfaceBndr, toIfaceIdBndr, toIfaceTvBndrs, toIfaceTyCon, + toIfaceBndr, toIfaceIdBndr, toIfaceTvBndrs, + toIfaceTyCon, toIfaceTyCon_name, -- Printing pprIfaceType, pprParendIfaceType, pprIfaceContext, @@ -26,12 +27,13 @@ module IfaceType ( #include "HsVersions.h" import Kind ( Kind(..) ) -import TypeRep ( Type(..), TyNote(..), PredType(..), ThetaType ) -import TyCon ( TyCon, isTupleTyCon, tyConArity, tupleTyConBoxity ) +import TypeRep ( TyThing(..), Type(..), TyNote(..), PredType(..), ThetaType ) +import TyCon ( TyCon, isTupleTyCon, tyConArity, tupleTyConBoxity, tyConName ) import Var ( isId, tyVarKind, idType ) import TysWiredIn ( listTyConName, parrTyConName, tupleTyCon, intTyConName, charTyConName, boolTyConName ) import OccName ( OccName, parenSymOcc ) -import Name ( Name, getName, getOccName, nameModule, nameOccName ) +import Name ( Name, getName, getOccName, nameModule, nameOccName, + wiredInNameTyThing_maybe ) import Module ( Module ) import BasicTypes ( IPName(..), Arity, Version, mapIPName, tupleParens, Boxity ) import Outputable @@ -345,8 +347,27 @@ toIfaceType ext (NoteTy (SynNote tc_app) ty) = toIfaceType ext tc_app -- Retain toIfaceType ext (NoteTy other_note ty) = toIfaceType ext ty ---------------- +-- A little bit of (perhaps optional) trickiness here. When +-- compiling Data.Tuple, the tycons are not TupleTyCons, although +-- they have a wired-in name. But we'd like to dump them into the Iface +-- as a tuple tycon, to save lookups when reading the interface +-- Hence a tuple tycon may 'miss' in toIfaceTyCon, but then +-- toIfaceTyCon_name will still catch it. + toIfaceTyCon :: (Name -> IfaceExtName) -> TyCon -> IfaceTyCon toIfaceTyCon ext tc + | isTupleTyCon tc = IfaceTupTc (tupleTyConBoxity tc) (tyConArity tc) + | otherwise = toIfaceTyCon_name ext (tyConName tc) + +toIfaceTyCon_name :: (Name -> IfaceExtName) -> Name -> IfaceTyCon +toIfaceTyCon_name ext nm + | Just (ATyCon tc) <- wiredInNameTyThing_maybe nm + = toIfaceWiredInTyCon ext tc nm + | otherwise + = IfaceTc (ext nm) + +toIfaceWiredInTyCon :: (Name -> IfaceExtName) -> TyCon -> Name -> IfaceTyCon +toIfaceWiredInTyCon ext tc nm | isTupleTyCon tc = IfaceTupTc (tupleTyConBoxity tc) (tyConArity tc) | nm == intTyConName = IfaceIntTc | nm == boolTyConName = IfaceBoolTc @@ -354,8 +375,6 @@ toIfaceTyCon ext tc | nm == listTyConName = IfaceListTc | nm == parrTyConName = IfacePArrTc | otherwise = IfaceTc (ext nm) - where - nm = getName tc ---------------- toIfaceTypes ext ts = map (toIfaceType ext) ts diff --git a/ghc/compiler/iface/MkIface.lhs b/ghc/compiler/iface/MkIface.lhs index 5c32a29..8757279 100644 --- a/ghc/compiler/iface/MkIface.lhs +++ b/ghc/compiler/iface/MkIface.lhs @@ -657,7 +657,6 @@ mk_usage_info pit hsc_env hmods dir_imp_mods dep_mods proto_used_names = mapCatMaybes mkUsage dep_mods -- ToDo: do we need to sort into canonical order? where - dflags = hsc_dflags hsc_env hpt = hsc_HPT hsc_env used_names = mkNameSet $ -- Eliminate duplicates diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs index fbda3f1..24d6791 100644 --- a/ghc/compiler/main/CodeOutput.lhs +++ b/ghc/compiler/main/CodeOutput.lhs @@ -36,7 +36,7 @@ import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit ) import Outputable import Pretty ( Mode(..), printDoc ) import Module ( Module ) -import ListSetOps ( removeDupsEq ) +import List ( nub ) import Maybes ( firstJust ) import Directory ( doesFileExist ) @@ -131,7 +131,7 @@ outputC dflags filenm flat_absC ffi_decl_headers = case foreign_stubs of NoStubs -> [] - ForeignStubs _ _ fdhs _ -> map unpackFS (fst (removeDupsEq fdhs)) + ForeignStubs _ _ fdhs _ -> map unpackFS (nub fdhs) -- Remove duplicates, because distinct foreign import decls -- may cite the same #include. Order doesn't matter. diff --git a/ghc/compiler/main/GHC.hs b/ghc/compiler/main/GHC.hs index 77195f3..d8c2975 100644 --- a/ghc/compiler/main/GHC.hs +++ b/ghc/compiler/main/GHC.hs @@ -89,7 +89,7 @@ module GHC ( -- ** Identifiers Id, idType, isImplicitId, isDeadBinder, - isSpecPragmaId, isExportedId, isLocalId, isGlobalId, + isExportedId, isLocalId, isGlobalId, isRecordSelector, isPrimOpId, isFCallId, isClassOpId_maybe, isDataConWorkId, idDataCon, @@ -176,7 +176,7 @@ import VarEnv ( emptyTidyEnv ) import GHC.Exts ( unsafeCoerce# ) #endif -import Packages ( PackageIdH(..), initPackages ) +import Packages ( initPackages ) import NameSet ( NameSet, nameSetToList, elemNameSet ) import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName, globalRdrEnvElts ) @@ -185,7 +185,7 @@ import Type ( Kind, Type, dropForAlls, PredType, ThetaType, pprThetaArrow, pprParendType, splitForAllTys, funResultTy ) import Id ( Id, idType, isImplicitId, isDeadBinder, - isSpecPragmaId, isExportedId, isLocalId, isGlobalId, + isExportedId, isLocalId, isGlobalId, isRecordSelector, recordSelectorFieldLabel, isPrimOpId, isFCallId, isClassOpId_maybe, isDataConWorkId, idDataCon, @@ -235,7 +235,6 @@ import FastString ( mkFastString ) import Directory ( getModificationTime, doesFileExist ) import Maybe ( isJust, isNothing, fromJust ) import Maybes ( orElse, expectJust, mapCatMaybes ) -import qualified Maybes (MaybeErr(..)) import List ( partition, nub ) import qualified List import Monad ( unless, when ) diff --git a/ghc/compiler/main/HscStats.lhs b/ghc/compiler/main/HscStats.lhs index 85e692b..b213764 100644 --- a/ghc/compiler/main/HscStats.lhs +++ b/ghc/compiler/main/HscStats.lhs @@ -99,9 +99,9 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _)) (inst_method_ds, method_specs, method_inlines) = foldr add3 (0,0,0) (map inst_info inst_decls) - count_bind (PatBind (L _ (VarPat n)) r _) = (1,0) - count_bind (PatBind p r _) = (0,1) - count_bind (FunBind f _ m) = (0,1) + count_bind (PatBind (L _ (VarPat n)) r _ _) = (1,0) + count_bind (PatBind p r _ _) = (0,1) + count_bind (FunBind f _ m _) = (0,1) count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs) diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index 0e9711f..f38bcc4 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -29,7 +29,7 @@ import InteractiveUI ( ghciWelcomeMsg, interactiveUI ) -- Various other random stuff that we need import Config ( cProjectVersion, cBooterVersion, cProjectName ) import Packages ( dumpPackages, initPackages ) -import DriverPhases ( Phase(..), isSourceSuffix, isSourceFilename, anyHsc, +import DriverPhases ( Phase(..), isSourceFilename, anyHsc, startPhase, isHaskellSrcFilename ) import StaticFlags ( staticFlags, v_Ld_inputs ) import BasicTypes ( failed ) @@ -39,7 +39,7 @@ import Panic -- Standard Haskell libraries import EXCEPTION ( throwDyn ) import IO -import Directory ( doesFileExist, doesDirectoryExist ) +import Directory ( doesDirectoryExist ) import System ( getArgs, exitWith, ExitCode(..) ) import Monad import List diff --git a/ghc/compiler/parser/Parser.y.pp b/ghc/compiler/parser/Parser.y.pp index 4e670c6..3de3793 100644 --- a/ghc/compiler/parser/Parser.y.pp +++ b/ghc/compiler/parser/Parser.y.pp @@ -508,14 +508,14 @@ where :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed : 'where' decllist { LL (unLoc $2) } | {- empty -} { noLoc nilOL } -binds :: { Located [HsBindGroup RdrName] } -- May have implicit parameters - : decllist { L1 [cvBindGroup (unLoc $1)] } - | '{' dbinds '}' { LL [HsIPBinds (unLoc $2)] } - | vocurly dbinds close { L (getLoc $2) [HsIPBinds (unLoc $2)] } +binds :: { Located (HsLocalBinds RdrName) } -- May have implicit parameters + : decllist { L1 (HsValBinds (cvBindGroup (unLoc $1))) } + | '{' dbinds '}' { LL (HsIPBinds (IPBinds (unLoc $2) emptyLHsBinds)) } + | vocurly dbinds close { L (getLoc $2) (HsIPBinds (IPBinds (unLoc $2) emptyLHsBinds)) } -wherebinds :: { Located [HsBindGroup RdrName] } -- May have implicit parameters +wherebinds :: { Located (HsLocalBinds RdrName) } -- May have implicit parameters : 'where' binds { LL (unLoc $2) } - | {- empty -} { noLoc [] } + | {- empty -} { noLoc emptyLocalBinds } ----------------------------------------------------------------------------- @@ -1001,7 +1001,7 @@ exp10 :: { LHsExpr RdrName } : '\\' aexp aexps opt_asig '->' exp {% checkPatterns ($2 : reverse $3) >>= \ ps -> return (LL $ HsLam (mkMatchGroup [LL $ Match ps $4 - (GRHSs (unguardedRHS $6) [] + (GRHSs (unguardedRHS $6) emptyLocalBinds )])) } | 'let' binds 'in' exp { LL $ HsLet (unLoc $2) $4 } | 'if' exp 'then' exp 'else' exp { LL $ HsIf $2 $4 $6 } diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index b49c869..8ba09c0 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -52,7 +52,7 @@ import HsSyn -- Lots of it import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc, isRdrDataCon, isUnqual, getRdrName, isQual, setRdrNameSpace ) -import BasicTypes ( RecFlag(..), maxPrecedence ) +import BasicTypes ( maxPrecedence ) import Lexer ( P, failSpanMsgP ) import TysWiredIn ( unitTyCon ) import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..), @@ -125,8 +125,8 @@ extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName] extractGenericPatTyVars binds = nubBy eqLocated (foldrBag get [] binds) where - get (L _ (FunBind _ _ (MatchGroup ms _))) acc = foldr (get_m.unLoc) acc ms - get other acc = acc + get (L _ (FunBind _ _ (MatchGroup ms _) _)) acc = foldr (get_m.unLoc) acc ms + get other acc = acc get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc get_m other acc = acc @@ -197,10 +197,10 @@ cvTopDecls decls = go (fromOL decls) where (L l' b', ds') = getMonoBind (L l b) ds go (d : ds) = d : go ds -cvBindGroup :: OrdList (LHsDecl RdrName) -> HsBindGroup RdrName +cvBindGroup :: OrdList (LHsDecl RdrName) -> HsValBinds RdrName cvBindGroup binding = case (cvBindsAndSigs binding) of { (mbs, sigs) -> - HsBindGroup mbs sigs Recursive -- just one big group for now + ValBindsIn mbs sigs } cvBindsAndSigs :: OrdList (LHsDecl RdrName) @@ -230,17 +230,16 @@ getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName] -- -- No AndMonoBinds or EmptyMonoBinds here; just single equations --- gaw 2004 -getMonoBind (L loc (FunBind lf@(L _ f) inf (MatchGroup mtchs _))) binds +getMonoBind (L loc (FunBind lf@(L _ f) inf (MatchGroup mtchs _) _)) binds | has_args mtchs = go mtchs loc binds where - go mtchs1 loc1 (L loc2 (ValD (FunBind f2 inf2 (MatchGroup mtchs2 _))) : binds) + go mtchs1 loc1 (L loc2 (ValD (FunBind f2 inf2 (MatchGroup mtchs2 _) _)) : binds) | f == unLoc f2 = go (mtchs2++mtchs1) loc binds where loc = combineSrcSpans loc1 loc2 go mtchs1 loc binds - = (L loc (FunBind lf inf (mkMatchGroup (reverse mtchs1))), binds) - -- reverse the final matches, to get it back in the right order + = (L loc (FunBind lf inf (mkMatchGroup (reverse mtchs1)) placeHolderNames), binds) + -- Reverse the final matches, to get it back in the right order getMonoBind bind binds = (bind, binds) @@ -253,12 +252,10 @@ has_args ((L _ (Match args _ _)) : _) = not (null args) \begin{code} findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a])) -findSplice ds = addl oneEmptyBindGroup ds +findSplice ds = addl emptyRdrGroup ds mkGroup :: [LHsDecl a] -> HsGroup a -mkGroup ds = addImpDecls oneEmptyBindGroup ds - -oneEmptyBindGroup = emptyGroup{ hs_valds = [HsBindGroup emptyBag [] Recursive] } +mkGroup ds = addImpDecls emptyRdrGroup ds addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a -- The decls are imported, and should not have a splice @@ -309,8 +306,8 @@ add gp@(HsGroup {hs_depds = ts}) l (DeprecD d) ds add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds = addl (gp { hs_ruleds = L l d : ts }) ds -add_bind b [HsBindGroup bs sigs r] = [HsBindGroup (bs `snocBag` b) sigs r] -add_sig s [HsBindGroup bs sigs r] = [HsBindGroup bs (s:sigs) r] +add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs +add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) \end{code} %************************************************************************ @@ -591,12 +588,13 @@ checkValDef lhs opt_sig (L rhs_span grhss) showRdrName (unLoc f)) else do ps <- checkPatterns es let match_span = combineSrcSpans (getLoc lhs) rhs_span - return (FunBind f inf (mkMatchGroup [L match_span (Match ps opt_sig grhss)])) + matches = mkMatchGroup [L match_span (Match ps opt_sig grhss)] + return (FunBind f inf matches placeHolderNames) -- The span of the match covers the entire equation. -- That isn't quite right, but it'll do for now. | otherwise = do lhs <- checkPattern lhs - return (PatBind lhs grhss placeHolderType) + return (PatBind lhs grhss placeHolderType placeHolderNames) checkValSig :: LHsExpr RdrName diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index 94ae27f..cbba768 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -10,37 +10,40 @@ they may be affected by renaming (which isn't fully worked out yet). \begin{code} module RnBinds ( - rnTopBinds, rnBinds, rnBindsAndThen, - rnMethodBinds, renameSigs, checkSigs + rnTopBinds, + rnLocalBindsAndThen, rnValBindsAndThen, rnValBinds, trimWith, + rnMethodBinds, renameSigs, + rnMatchGroup, rnGRHSs ) where #include "HsVersions.h" +import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts ) import HsSyn import HsBinds ( hsSigDoc, eqHsSig ) import RdrHsSyn import RnHsSyn import TcRnMonad -import RnTypes ( rnHsSigType, rnLHsType, rnLPat ) -import RnExpr ( rnMatchGroup, rnMatch, rnGRHSs, checkPrecMatch ) +import RnTypes ( rnHsSigType, rnLHsType, rnHsTypeFVs, + rnLPat, rnPatsAndThen, patSigErr, checkPrecMatch ) import RnEnv ( bindLocatedLocalsRn, lookupLocatedBndrRn, - lookupLocatedInstDeclBndr, + lookupLocatedInstDeclBndr, newIPNameRn, lookupLocatedSigOccRn, bindPatSigTyVars, bindPatSigTyVarsFV, bindLocalFixities, bindSigTyVarsFV, warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn, ) import DynFlags ( DynFlag(..) ) -import Digraph ( SCC(..), stronglyConnComp ) import Name ( Name, nameOccName, nameSrcLoc ) +import NameEnv import NameSet import PrelNames ( isUnboundName ) import RdrName ( RdrName, rdrNameOcc ) -import BasicTypes ( RecFlag(..), TopLevelFlag(..), isTopLevel ) -import List ( unzip4 ) import SrcLoc ( mkSrcSpan, Located(..), unLoc ) +import ListSetOps ( findDupsEq ) import Bag import Outputable +import Maybes ( orElse ) import Monad ( foldM ) \end{code} @@ -154,53 +157,102 @@ it expects the global environment to contain bindings for the binders contains bindings for the binders of this particular binding. \begin{code} -rnTopBinds :: LHsBinds RdrName - -> [LSig RdrName] - -> RnM ([HsBindGroup Name], DefUses) +rnTopBinds :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses) -- The binders of the binding are in scope already; -- the top level scope resolution does that -rnTopBinds mbinds sigs +rnTopBinds binds = do { is_boot <- tcIsHsBoot - ; if is_boot then - rnHsBoot mbinds sigs - else bindPatSigTyVars (collectSigTysFromHsBinds (bagToList mbinds)) $ \ _ -> - -- Hmm; by analogy with Ids, this doesn't look right - -- Top-level bound type vars should really scope over - -- everything, but we only scope them over the other bindings - rnBinds TopLevel mbinds sigs } - -rnHsBoot :: LHsBinds RdrName - -> [LSig RdrName] - -> RnM ([HsBindGroup Name], DefUses) + ; if is_boot then rnTopBindsBoot binds + else rnTopBindsSrc binds } + +rnTopBindsBoot :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses) -- A hs-boot file has no bindings. -- Return a single HsBindGroup with empty binds and renamed signatures -rnHsBoot mbinds sigs +rnTopBindsBoot (ValBindsIn mbinds sigs) = do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds) - ; sigs' <- renameSigs sigs - ; return ([HsBindGroup emptyLHsBinds sigs' NonRecursive], - usesOnly (hsSigsFVs sigs')) } + ; sigs' <- renameSigs okHsBootSig sigs + ; return (ValBindsIn emptyLHsBinds sigs', usesOnly (hsSigsFVs sigs')) } + +rnTopBindsSrc :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses) +rnTopBindsSrc binds@(ValBindsIn mbinds _) + = bindPatSigTyVars (collectSigTysFromHsBinds (bagToList mbinds)) $ \ _ -> + -- Hmm; by analogy with Ids, this doesn't look right + -- Top-level bound type vars should really scope over + -- everything, but we only scope them over the other bindings + + do { (binds', dus) <- rnValBinds noTrim binds + + -- Warn about missing signatures, + ; let { ValBindsIn _ sigs' = binds' + ; ty_sig_vars = mkNameSet [ unLoc n | L _ (Sig n _) <- sigs'] + ; un_sigd_bndrs = duDefs dus `minusNameSet` ty_sig_vars } + + ; warn_missing_sigs <- doptM Opt_WarnMissingSigs + ; ifM (warn_missing_sigs) + (mappM_ missingSigWarn (nameSetToList un_sigd_bndrs)) + + ; return (binds', dus) + } +\end{code} + + + +%********************************************************* +%* * + HsLocalBinds +%* * +%********************************************************* + +\begin{code} +rnLocalBindsAndThen + :: HsLocalBinds RdrName + -> (HsLocalBinds Name -> RnM (result, FreeVars)) + -> RnM (result, FreeVars) +-- This version (a) assumes that the binding vars are not already in scope +-- (b) removes the binders from the free vars of the thing inside +-- The parser doesn't produce ThenBinds +rnLocalBindsAndThen EmptyLocalBinds thing_inside + = thing_inside EmptyLocalBinds + +rnLocalBindsAndThen (HsValBinds val_binds) thing_inside + = rnValBindsAndThen val_binds $ \ val_binds' -> + thing_inside (HsValBinds val_binds') + +rnLocalBindsAndThen (HsIPBinds binds) thing_inside + = rnIPBinds binds `thenM` \ (binds',fv_binds) -> + thing_inside (HsIPBinds binds') `thenM` \ (thing, fvs_thing) -> + returnM (thing, fvs_thing `plusFV` fv_binds) + +------------- +rnIPBinds (IPBinds ip_binds _no_dict_binds) + = do { (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds + ; return (IPBinds ip_binds' emptyLHsBinds, plusFVs fvs_s) } + +rnIPBind (IPBind n expr) + = newIPNameRn n `thenM` \ name -> + rnLExpr expr `thenM` \ (expr',fvExpr) -> + return (IPBind name expr', fvExpr) \end{code} %************************************************************************ %* * -%* Nested binds + ValBinds %* * %************************************************************************ \begin{code} -rnBindsAndThen :: Bag (LHsBind RdrName) - -> [LSig RdrName] - -> ([HsBindGroup Name] -> RnM (result, FreeVars)) - -> RnM (result, FreeVars) +rnValBindsAndThen :: HsValBinds RdrName + -> (HsValBinds Name -> RnM (result, FreeVars)) + -> RnM (result, FreeVars) -rnBindsAndThen mbinds sigs thing_inside +rnValBindsAndThen binds@(ValBindsIn mbinds sigs) thing_inside = -- Extract all the binders in this group, and extend the -- current scope, inventing new names for the new binders -- This also checks that the names form a set - bindLocatedLocalsRn doc mbinders_w_srclocs $ \ _ -> + bindLocatedLocalsRn doc mbinders_w_srclocs $ \ bndrs -> bindPatSigTyVarsFV (collectSigTysFromHsBinds (bagToList mbinds)) $ -- Then install local fixity declarations @@ -208,7 +260,7 @@ rnBindsAndThen mbinds sigs thing_inside bindLocalFixities [sig | L _ (FixSig sig) <- sigs ] $ -- Do the business - rnBinds NotTopLevel mbinds sigs `thenM` \ (binds, bind_dus) -> + rnValBinds (trimWith bndrs) binds `thenM` \ (binds, bind_dus) -> -- Now do the "thing inside" thing_inside binds `thenM` \ (result,result_fvs) -> @@ -216,14 +268,13 @@ rnBindsAndThen mbinds sigs thing_inside -- Final error checking let all_uses = duUses bind_dus `plusFV` result_fvs - bndrs = duDefs bind_dus - unused_bndrs = nameSetToList (bndrs `minusNameSet` all_uses) + unused_bndrs = [ b | b <- bndrs, not (b `elemNameSet` all_uses)] in warnUnusedLocalBinds unused_bndrs `thenM_` - returnM (result, all_uses `minusNameSet` bndrs) - -- duUses: It's important to return all the uses, not the 'real uses' used for - -- warning about unused bindings. Otherwise consider: + returnM (result, delListFromNameSet all_uses bndrs) + -- duUses: It's important to return all the uses, not the 'real uses' + -- used for warning about unused bindings. Otherwise consider: -- x = 3 -- y = let p = x in 'x' -- NB: p not used -- If we don't "see" the dependency of 'y' on 'x', we may put the @@ -233,120 +284,96 @@ rnBindsAndThen mbinds sigs thing_inside mbinders_w_srclocs = collectHsBindLocatedBinders mbinds doc = text "In the binding group for:" <+> pprWithCommas ppr (map unLoc mbinders_w_srclocs) -\end{code} - - -%************************************************************************ -%* * -\subsubsection{rnBinds -- the main work is done here} -%* * -%************************************************************************ - -@rnMonoBinds@ is used by {\em both} top-level and nested bindings. -It assumes that all variables bound in this group are already in scope. -This is done {\em either} by pass 3 (for the top-level bindings), -{\em or} by @rnMonoBinds@ (for the nested ones). - -\begin{code} -rnBinds :: TopLevelFlag - -> LHsBinds RdrName - -> [LSig RdrName] - -> RnM ([HsBindGroup Name], DefUses) +--------------------- +rnValBinds :: (FreeVars -> FreeVars) + -> HsValBinds RdrName + -> RnM (HsValBinds Name, DefUses) -- Assumes the binders of the binding are in scope already -rnBinds top_lvl mbinds sigs - = renameSigs sigs `thenM` \ siglist -> - - -- Rename the bindings, returning a [HsBindVertex] - -- which is a list of indivisible vertices so far as - -- the strongly-connected-components (SCC) analysis is concerned - mkBindVertices siglist mbinds `thenM` \ mbinds_info -> - - -- Do the SCC analysis - let - scc_result = rnSCC mbinds_info - (groups, bind_dus_s) = unzip (map reconstructCycle scc_result) - bind_dus = mkDUs bind_dus_s - binders = duDefs bind_dus - in - -- Check for duplicate or mis-placed signatures - checkSigs (okBindSig binders) siglist `thenM_` - - -- Warn about missing signatures, - -- but only at top level, and not in interface mode - -- (The latter is important when renaming bindings from 'deriving' clauses.) - doptM Opt_WarnMissingSigs `thenM` \ warn_missing_sigs -> - (if isTopLevel top_lvl && - warn_missing_sigs - then let - type_sig_vars = [ unLoc n | L _ (Sig n _) <- siglist] - un_sigd_binders = filter (not . (`elem` type_sig_vars)) - (nameSetToList binders) - in - mappM_ missingSigWarn un_sigd_binders - else - returnM () - ) `thenM_` - - returnM (groups, bind_dus `plusDU` usesOnly (hsSigsFVs siglist)) -\end{code} - -@mkBindVertices@ is ever-so-slightly magical in that it sticks -unique ``vertex tags'' on its output; minor plumbing required. - -\begin{code} -mkBindVertices :: [LSig Name] -- Signatures - -> LHsBinds RdrName - -> RnM [BindVertex] -mkBindVertices sigs = mapM (mkBindVertex sigs) . bagToList - -mkBindVertex :: [LSig Name] -> LHsBind RdrName -> RnM BindVertex -mkBindVertex sigs (L loc (PatBind pat grhss ty)) - = setSrcSpan loc $ - rnLPat pat `thenM` \ (pat', pat_fvs) -> - - -- Find which things are bound in this group - let - names_bound_here = mkNameSet (collectPatBinders pat') - in - sigsForMe names_bound_here sigs `thenM` \ sigs_for_me -> - bindSigTyVarsFV sigs_for_me ( - rnGRHSs PatBindRhs grhss - ) `thenM` \ (grhss', fvs) -> - returnM - (names_bound_here, fvs `plusFV` pat_fvs, - L loc (PatBind pat' grhss' ty), sigs_for_me - ) - -mkBindVertex sigs (L loc (FunBind name inf matches)) - = setSrcSpan loc $ - lookupLocatedBndrRn name `thenM` \ new_name -> - let - plain_name = unLoc new_name - names_bound_here = unitNameSet plain_name - in - sigsForMe names_bound_here sigs `thenM` \ sigs_for_me -> - bindSigTyVarsFV sigs_for_me ( - rnMatchGroup (FunRhs plain_name) matches - ) `thenM` \ (new_matches, fvs) -> - checkPrecMatch inf plain_name new_matches `thenM_` - returnM - (unitNameSet plain_name, fvs, - L loc (FunBind new_name inf new_matches), sigs_for_me - ) - -sigsForMe names_bound_here sigs - = foldlM check [] (filter (sigForThisGroup names_bound_here) sigs) +rnValBinds trim (ValBindsIn mbinds sigs) + = do { sigs' <- rename_sigs sigs + + ; let { rn_bind = wrapLocFstM (rnBind sig_fn trim) + ; sig_fn = mkSigTvFn sigs' } + + ; (mbinds', du_bag) <- mapAndUnzipBagM rn_bind mbinds + + ; let defs, uses :: NameSet + (defs, uses) = foldrBag plus (emptyNameSet, emptyNameSet) du_bag + plus (ds1,us1) (ds2,us2) = (ds1 `unionNameSets` ds2, + us1 `unionNameSets` us2) + + ; check_sigs (okBindSig defs) sigs' + + ; traceRn (text "rnValBind" <+> (ppr defs $$ ppr uses)) + ; return (ValBindsIn mbinds' sigs', + [(Just defs, uses `plusFV` hsSigsFVs sigs')]) } + +--------------------- +-- Bind the top-level forall'd type variables in the sigs. +-- E.g f :: a -> a +-- f = rhs +-- The 'a' scopes over the rhs +-- +-- NB: there'll usually be just one (for a function binding) +-- but if there are many, one may shadow the rest; too bad! +-- e.g x :: [a] -> [a] +-- y :: [(a,a)] -> a +-- (x,y) = e +-- In e, 'a' will be in scope, and it'll be the one from 'y'! + +mkSigTvFn :: [LSig Name] -> (Name -> [Name]) +-- Return a lookup function that maps an Id Name to the names +-- of the type variables that should scope over its body.. +mkSigTvFn sigs + = \n -> lookupNameEnv env n `orElse` [] where - -- sigForThisGroup only returns signatures for - -- which sigName returns a Just - eq sig1 sig2 = eqHsSig (unLoc sig1) (unLoc sig2) - - check sigs sig = case filter (eq sig) sigs of - [] -> returnM (sig:sigs) - other -> dupSigDeclErr sig other `thenM_` - returnM sigs + env :: NameEnv [Name] + env = mkNameEnv [ (name, map hsLTyVarName ltvs) + | L _ (Sig (L _ name) + (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs] + -- Note the pattern-match on "Explicit"; we only bind + -- type variables from signatures with an explicit top-level for-all + +-- The trimming function trims the free vars we attach to a +-- binding so that it stays reasonably small +noTrim :: FreeVars -> FreeVars +noTrim fvs = fvs -- Used at top level + +trimWith :: [Name] -> FreeVars -> FreeVars +-- Nested bindings; trim by intersection with the names bound here +trimWith bndrs = intersectNameSet (mkNameSet bndrs) + +--------------------- +rnBind :: (Name -> [Name]) -- Signature tyvar function + -> (FreeVars -> FreeVars) -- Trimming function for rhs free vars + -> HsBind RdrName + -> RnM (HsBind Name, (Defs, Uses)) +rnBind sig_fn trim (PatBind pat grhss ty _) + = do { (pat', pat_fvs) <- rnLPat pat + + ; let bndrs = collectPatBinders pat' + + ; (grhss', fvs) <- bindSigTyVarsFV (concatMap sig_fn bndrs) $ + rnGRHSs PatBindRhs grhss + + ; return (PatBind pat' grhss' ty (trim fvs), + (mkNameSet bndrs, pat_fvs `plusFV` fvs)) } + +rnBind sig_fn trim (FunBind name inf matches _) + = do { new_name <- lookupLocatedBndrRn name + ; let { plain_name = unLoc new_name + ; bndrs = unitNameSet plain_name } + + ; (matches', fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ + rnMatchGroup (FunRhs plain_name) matches + + ; checkPrecMatch inf plain_name matches' + + ; return (FunBind new_name inf matches' (trim fvs), + (bndrs, fvs)) + } \end{code} @@ -377,7 +404,7 @@ rnMethodBinds cls gen_tyvars binds (bind', fvs_bind) <- rnMethodBind cls gen_tyvars bind return (bind' `unionBags` binds, fvs_bind `plusFV` fvs) -rnMethodBind cls gen_tyvars (L loc (FunBind name inf (MatchGroup matches _))) +rnMethodBind cls gen_tyvars (L loc (FunBind name inf (MatchGroup matches _) _)) = setSrcSpan loc $ lookupLocatedInstDeclBndr cls name `thenM` \ sel_name -> let plain_name = unLoc sel_name in @@ -388,7 +415,8 @@ rnMethodBind cls gen_tyvars (L loc (FunBind name inf (MatchGroup matches _))) new_group = MatchGroup new_matches placeHolderType in checkPrecMatch inf plain_name new_group `thenM_` - returnM (unitBag (L loc (FunBind sel_name inf new_group)), fvs `addOneFV` plain_name) + returnM (unitBag (L loc (FunBind sel_name inf new_group fvs)), fvs `addOneFV` plain_name) + -- The 'fvs' field isn't used for method binds where -- Truly gruesome; bring into scope the correct members of the generic -- type variables. See comments in RnSource.rnSourceDecl(ClassDecl) @@ -403,7 +431,7 @@ rnMethodBind cls gen_tyvars (L loc (FunBind name inf (MatchGroup matches _))) -- Can't handle method pattern-bindings which bind multiple methods. -rnMethodBind cls gen_tyvars mbind@(L loc (PatBind other_pat _ _)) +rnMethodBind cls gen_tyvars mbind@(L loc (PatBind other_pat _ _ _)) = addLocErr mbind methodBindErr `thenM_` returnM (emptyBag, emptyFVs) \end{code} @@ -411,50 +439,6 @@ rnMethodBind cls gen_tyvars mbind@(L loc (PatBind other_pat _ _)) %************************************************************************ %* * - Strongly connected components -%* * -%************************************************************************ - -\begin{code} -type BindVertex = (Defs, Uses, LHsBind Name, [LSig Name]) - -- Signatures, if any, for this vertex - -rnSCC :: [BindVertex] -> [SCC BindVertex] -rnSCC nodes = stronglyConnComp (mkEdges nodes) - -type VertexTag = Int - -mkEdges :: [BindVertex] -> [(BindVertex, VertexTag, [VertexTag])] - -- We keep the uses with the binding, - -- so we can track unused bindings better -mkEdges nodes - = [ (thing, tag, dest_vertices uses) - | (thing@(_, uses, _, _), tag) <- tagged_nodes - ] - where - tagged_nodes = nodes `zip` [0::VertexTag ..] - - -- An edge (v,v') indicates that v depends on v' - dest_vertices uses = [ target_vertex - | ((defs, _, _, _), target_vertex) <- tagged_nodes, - defs `intersectsNameSet` uses - ] - -reconstructCycle :: SCC BindVertex -> (HsBindGroup Name, (Defs,Uses)) -reconstructCycle (AcyclicSCC (defs, uses, bind, sigs)) - = (HsBindGroup (unitBag bind) sigs NonRecursive, (defs, uses)) -reconstructCycle (CyclicSCC cycle) - = (HsBindGroup this_gp_binds this_gp_sigs Recursive, - (unionManyNameSets defs_s, unionManyNameSets uses_s)) - where - (defs_s, uses_s, binds_s, sigs_s) = unzip4 cycle - this_gp_binds = listToBag binds_s - this_gp_sigs = foldr1 (++) sigs_s -\end{code} - - -%************************************************************************ -%* * \subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)} %* * %************************************************************************ @@ -470,22 +454,34 @@ At the moment we don't gather free-var info from the types in signatures. We'd only need this if we wanted to report unused tyvars. \begin{code} -checkSigs :: (LSig Name -> Bool) -- OK-sig predicbate - -> [LSig Name] - -> RnM () -checkSigs ok_sig sigs +renameSigs :: (LSig Name -> Bool) -> [LSig RdrName] -> RnM [LSig Name] +-- Renames the signatures and performs error checks +renameSigs ok_sig sigs + = do { sigs' <- rename_sigs sigs + ; check_sigs ok_sig sigs' + ; return sigs' } + +---------------------- +rename_sigs :: [LSig RdrName] -> RnM [LSig Name] +rename_sigs sigs = mappM (wrapLocM renameSig) + (filter (not . isFixityLSig) sigs) + -- Remove fixity sigs which have been dealt with already + +---------------------- +check_sigs :: (LSig Name -> Bool) -> [LSig Name] -> RnM () +-- Used for class and instance decls, as well as regular bindings +check_sigs ok_sig sigs -- Check for (a) duplicate signatures -- (b) signatures for things not in this group - -- Well, I can't see the check for (a)... ToDo! - = mappM_ unknownSigErr (filter bad sigs) + = do { mappM_ unknownSigErr (filter bad sigs) + ; mappM_ dupSigDeclErr (findDupsEq eqHsSig sigs) } where bad sig = not (ok_sig sig) && case sigName sig of Just n | isUnboundName n -> False -- Don't complain about an unbound name again other -> True - --- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory +-- We use lookupLocatedSigOccRn in the signatures, which is a little bit unsatisfactory -- because this won't work for: -- instance Foo T where -- {-# INLINE op #-} @@ -494,10 +490,6 @@ checkSigs ok_sig sigs -- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.) -- Doesn't seem worth much trouble to sort this. -renameSigs :: [LSig RdrName] -> RnM [LSig Name] -renameSigs sigs = mappM (wrapLocM renameSig) (filter (not . isFixityLSig) sigs) - -- Remove fixity sigs which have been dealt with already - renameSig :: Sig RdrName -> RnM (Sig Name) -- FixitSig is renamed elsewhere. renameSig (Sig v ty) @@ -520,6 +512,82 @@ renameSig (InlineSig b v p) \end{code} +************************************************************************ +* * +\subsection{Match} +* * +************************************************************************ + +\begin{code} +rnMatchGroup :: HsMatchContext Name -> MatchGroup RdrName -> RnM (MatchGroup Name, FreeVars) +rnMatchGroup ctxt (MatchGroup ms _) + = mapFvRn (rnMatch ctxt) ms `thenM` \ (new_ms, ms_fvs) -> + returnM (MatchGroup new_ms placeHolderType, ms_fvs) + +rnMatch :: HsMatchContext Name -> LMatch RdrName -> RnM (LMatch Name, FreeVars) +rnMatch ctxt = wrapLocFstM (rnMatch' ctxt) + +rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss) + = + -- Deal with the rhs type signature + bindPatSigTyVarsFV rhs_sig_tys $ + doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts -> + (case maybe_rhs_sig of + Nothing -> returnM (Nothing, emptyFVs) + Just ty | opt_GlasgowExts -> rnHsTypeFVs doc_sig ty `thenM` \ (ty', ty_fvs) -> + returnM (Just ty', ty_fvs) + | otherwise -> addLocErr ty patSigErr `thenM_` + returnM (Nothing, emptyFVs) + ) `thenM` \ (maybe_rhs_sig', ty_fvs) -> + + -- Now the main event + rnPatsAndThen ctxt pats $ \ pats' -> + rnGRHSs ctxt grhss `thenM` \ (grhss', grhss_fvs) -> + + returnM (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs) + -- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs + where + rhs_sig_tys = case maybe_rhs_sig of + Nothing -> [] + Just ty -> [ty] + doc_sig = text "In a result type-signature" +\end{code} + + +%************************************************************************ +%* * +\subsubsection{Guarded right-hand sides (GRHSs)} +%* * +%************************************************************************ + +\begin{code} +rnGRHSs :: HsMatchContext Name -> GRHSs RdrName -> RnM (GRHSs Name, FreeVars) + +rnGRHSs ctxt (GRHSs grhss binds) + = rnLocalBindsAndThen binds $ \ binds' -> + mapFvRn (rnGRHS ctxt) grhss `thenM` \ (grhss', fvGRHSs) -> + returnM (GRHSs grhss' binds', fvGRHSs) + +rnGRHS :: HsMatchContext Name -> LGRHS RdrName -> RnM (LGRHS Name, FreeVars) +rnGRHS ctxt = wrapLocFstM (rnGRHS' ctxt) + +rnGRHS' ctxt (GRHS guards rhs) + = do { opt_GlasgowExts <- doptM Opt_GlasgowExts + ; checkM (opt_GlasgowExts || is_standard_guard guards) + (addWarn (nonStdGuardErr guards)) + + ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) guards $ + rnLExpr rhs + ; return (GRHS guards' rhs', fvs) } + where + -- Standard Haskell 1.4 guards are just a single boolean + -- expression, rather than a list of qualifiers as in the + -- Glasgow extension + is_standard_guard [] = True + is_standard_guard [L _ (ExprStmt _ _ _)] = True + is_standard_guard other = False +\end{code} + %************************************************************************ %* * \subsection{Error messages} @@ -527,10 +595,10 @@ renameSig (InlineSig b v p) %************************************************************************ \begin{code} -dupSigDeclErr (L loc sig) sigs +dupSigDeclErr sigs@(L loc sig : _) = addErrAt loc $ vcat [ptext SLIT("Duplicate") <+> what_it_is <> colon, - nest 2 (vcat (map ppr_sig (L loc sig:sigs)))] + nest 2 (vcat (map ppr_sig sigs))] where what_it_is = hsSigDoc sig ppr_sig (L loc sig) = ppr loc <> colon <+> ppr sig @@ -554,4 +622,9 @@ methodBindErr mbind bindsInHsBootFile mbinds = hang (ptext SLIT("Bindings in hs-boot files are not allowed")) 2 (ppr mbinds) + +nonStdGuardErr guard + = hang (ptext + SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)") + ) 4 (ppr guard) \end{code} diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index bdaa9f1..e0d08fd 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -11,7 +11,7 @@ module RnEnv ( lookupLocatedOccRn, lookupOccRn, lookupLocatedGlobalOccRn, lookupGlobalOccRn, lookupLocalDataTcNames, lookupSrcOcc_maybe, - lookupFixityRn, lookupLocatedSigOccRn, + lookupFixityRn, lookupTyFixityRn, lookupLocatedSigOccRn, lookupLocatedInstDeclBndr, lookupSyntaxName, lookupSyntaxTable, lookupImportedName, @@ -47,7 +47,7 @@ import RdrName ( RdrName, rdrNameModule, isQual, isUnqual, isOrig, ) import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity ) import TcRnMonad -import Name ( Name, nameIsLocalOrFrom, mkInternalName, +import Name ( Name, nameIsLocalOrFrom, mkInternalName, isWiredInName, nameSrcLoc, nameOccName, nameModule, nameParent, isExternalName ) import NameSet import OccName ( tcName, isDataOcc, occNameFlavour, reportIfUnused ) @@ -61,6 +61,7 @@ import Outputable import Util ( sortLe ) import ListSetOps ( removeDups ) import List ( nubBy ) +import Monad ( when ) import DynFlags \end{code} @@ -439,6 +440,15 @@ lookupFixityRn name where doc = ptext SLIT("Checking fixity for") <+> ppr name +--------------- +lookupTyFixityRn :: Located Name -> RnM Fixity +lookupTyFixityRn (L loc n) + = doptM Opt_GlasgowExts `thenM` \ glaExts -> + when (not glaExts) + (setSrcSpan loc $ addWarn (infixTyConWarn n)) `thenM_` + lookupFixityRn n + +--------------- dataTcOccs :: RdrName -> [RdrName] -- If the input is a data constructor, return both it and a type -- constructor. This is useful when we aren't sure which we are @@ -632,32 +642,15 @@ bindPatSigTyVarsFV tys thing_inside thing_inside `thenM` \ (result,fvs) -> returnM (result, fvs `delListFromNameSet` tvs) -bindSigTyVarsFV :: [LSig Name] +bindSigTyVarsFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) --- Bind the top-level forall'd type variables in the sigs. --- E.g f :: a -> a --- f = rhs --- The 'a' scopes over the rhs --- --- NB: there'll usually be just one (for a function binding) --- but if there are many, one may shadow the rest; too bad! --- e.g x :: [a] -> [a] --- y :: [(a,a)] -> a --- (x,y) = e --- In e, 'a' will be in scope, and it'll be the one from 'y'! -bindSigTyVarsFV sigs thing_inside +bindSigTyVarsFV tvs thing_inside = do { scoped_tyvars <- doptM Opt_ScopedTypeVariables ; if not scoped_tyvars then thing_inside else bindLocalNamesFV tvs thing_inside } - where - tvs = [ hsLTyVarName ltv - | L _ (Sig _ (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs, ltv <- ltvs ] - -- Note the pattern-match on "Explicit"; we only bind - -- type variables from signatures with an explicit top-level for-all - extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) -- This function is used only in rnSourceDecl on InstDecl @@ -739,7 +732,11 @@ warnUnusedLocals names warnUnusedBinds :: [(Name,Maybe Provenance)] -> RnM () warnUnusedBinds names = mappM_ warnUnusedName (filter reportable names) - where reportable (name,_) = reportIfUnused (nameOccName name) + where reportable (name,_) + | isWiredInName name = False -- Don't report unused wired-in names + -- Otherwise we get a zillion warnings + -- from Data.Tuple + | otherwise = reportIfUnused (nameOccName name) ------------------------- @@ -801,4 +798,8 @@ dupNamesErr descriptor located_names locations | one_line = empty | otherwise = ptext SLIT("Bound at:") <+> vcat (map ppr (sortLe (<=) locs)) + +infixTyConWarn op + = vcat [ftext FSLIT("Accepting non-standard infix type constructor") <+> quotes (ppr op), + ftext FSLIT("Use -fglasgow-exts to avoid this warning")] \end{code} diff --git a/ghc/compiler/rename/RnExpr.hi-boot-6 b/ghc/compiler/rename/RnExpr.hi-boot-6 new file mode 100644 index 0000000..8f6c7f1 --- /dev/null +++ b/ghc/compiler/rename/RnExpr.hi-boot-6 @@ -0,0 +1,11 @@ +module RnExpr where + +rnLExpr :: HsExpr.LHsExpr RdrName.RdrName + -> TcRnTypes.RnM (HsExpr.LHsExpr Name.Name, NameSet.FreeVars) + +rnStmts :: forall thing. + HsExpr.HsStmtContext Name.Name -> [HsExpr.LStmt RdrName.RdrName] + -> TcRnTypes.RnM (thing, NameSet.FreeVars) + -> TcRnTypes.RnM (([HsExpr.LStmt Name.Name], thing), NameSet.FreeVars) + + diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 561de22..0bf40e6 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -11,18 +11,14 @@ free variables. \begin{code} module RnExpr ( - rnMatchGroup, rnMatch, rnGRHSs, rnLExpr, rnExpr, rnStmts, - checkPrecMatch, checkTH + rnLExpr, rnExpr, rnStmts ) where #include "HsVersions.h" -import {-# SOURCE #-} RnSource ( rnSrcDecls, rnBindGroupsAndThen, rnBindGroups, rnSplice ) - --- RnSource imports RnBinds.rnTopMonoBinds, RnExpr.rnExpr --- RnBinds imports RnExpr.rnMatch, etc --- RnExpr imports [boot] RnSource.rnSrcDecls, RnSource.rnBinds - +import RnSource ( rnSrcDecls, rnSplice, checkTH ) +import RnBinds ( rnLocalBindsAndThen, rnValBinds, + rnMatchGroup, trimWith ) import HsSyn import RnHsSyn import TcRnMonad @@ -30,10 +26,10 @@ import RnEnv import OccName ( plusOccEnv ) import RnNames ( getLocalDeclBinders, extendRdrEnvRn ) import RnTypes ( rnHsTypeFVs, rnLPat, rnOverLit, rnPatsAndThen, rnLit, - dupFieldErr, precParseErr, sectionPrecErr, patSigErr, - checkTupSize ) -import DynFlags ( DynFlag(..) ) -import BasicTypes ( Fixity(..), FixityDirection(..), negateFixity, compareFixity ) + mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec, + dupFieldErr, checkTupSize ) +import DynFlags ( DynFlag(..) ) +import BasicTypes ( FixityDirection(..) ) import PrelNames ( hasKey, assertIdKey, assertErrorName, loopAName, choiceAName, appAName, arrAName, composeAName, firstAName, negateName, thenMName, bindMName, failMName ) @@ -48,90 +44,13 @@ import Util ( isSingleton ) import ListSetOps ( removeDups ) import Maybes ( fromJust ) import Outputable -import SrcLoc ( Located(..), unLoc, getLoc, combineLocs, cmpLocated ) +import SrcLoc ( Located(..), unLoc, getLoc, cmpLocated ) import FastString import List ( unzip4 ) \end{code} -************************************************************************ -* * -\subsection{Match} -* * -************************************************************************ - -\begin{code} -rnMatchGroup :: HsMatchContext Name -> MatchGroup RdrName -> RnM (MatchGroup Name, FreeVars) -rnMatchGroup ctxt (MatchGroup ms _) - = mapFvRn (rnMatch ctxt) ms `thenM` \ (new_ms, ms_fvs) -> - returnM (MatchGroup new_ms placeHolderType, ms_fvs) - -rnMatch :: HsMatchContext Name -> LMatch RdrName -> RnM (LMatch Name, FreeVars) -rnMatch ctxt = wrapLocFstM (rnMatch' ctxt) - -rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss) - = - -- Deal with the rhs type signature - bindPatSigTyVarsFV rhs_sig_tys $ - doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts -> - (case maybe_rhs_sig of - Nothing -> returnM (Nothing, emptyFVs) - Just ty | opt_GlasgowExts -> rnHsTypeFVs doc_sig ty `thenM` \ (ty', ty_fvs) -> - returnM (Just ty', ty_fvs) - | otherwise -> addLocErr ty patSigErr `thenM_` - returnM (Nothing, emptyFVs) - ) `thenM` \ (maybe_rhs_sig', ty_fvs) -> - - -- Now the main event - rnPatsAndThen ctxt pats $ \ pats' -> - rnGRHSs ctxt grhss `thenM` \ (grhss', grhss_fvs) -> - - returnM (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs) - -- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs - where - rhs_sig_tys = case maybe_rhs_sig of - Nothing -> [] - Just ty -> [ty] - doc_sig = text "In a result type-signature" -\end{code} - - -%************************************************************************ -%* * -\subsubsection{Guarded right-hand sides (GRHSs)} -%* * -%************************************************************************ - -\begin{code} -rnGRHSs :: HsMatchContext Name -> GRHSs RdrName -> RnM (GRHSs Name, FreeVars) - --- gaw 2004 -rnGRHSs ctxt (GRHSs grhss binds) - = rnBindGroupsAndThen binds $ \ binds' -> - mapFvRn (rnGRHS ctxt) grhss `thenM` \ (grhss', fvGRHSs) -> - returnM (GRHSs grhss' binds', fvGRHSs) - -rnGRHS :: HsMatchContext Name -> LGRHS RdrName -> RnM (LGRHS Name, FreeVars) -rnGRHS ctxt = wrapLocFstM (rnGRHS' ctxt) - -rnGRHS' ctxt (GRHS guards rhs) - = do { opt_GlasgowExts <- doptM Opt_GlasgowExts - ; checkM (opt_GlasgowExts || is_standard_guard guards) - (addWarn (nonStdGuardErr guards)) - - ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) guards $ - rnLExpr rhs - ; return (GRHS guards' rhs', fvs) } - where - -- Standard Haskell 1.4 guards are just a single boolean - -- expression, rather than a list of qualifiers as in the - -- Glasgow extension - is_standard_guard [] = True - is_standard_guard [L _ (ExprStmt _ _ _)] = True - is_standard_guard other = False -\end{code} - %************************************************************************ %* * \subsubsection{Expressions} @@ -266,7 +185,7 @@ rnExpr (HsCase expr matches) returnM (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs) rnExpr (HsLet binds expr) - = rnBindGroupsAndThen binds $ \ binds' -> + = rnLocalBindsAndThen binds $ \ binds' -> rnLExpr expr `thenM` \ (expr',fvExpr) -> returnM (HsLet binds' expr', fvExpr) @@ -391,36 +310,6 @@ rnExpr (HsArrForm op fixity cmds) rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other) -- DictApp, DictLam, TyApp, TyLam - ---------------------------- --- Deal with fixity (cf mkOpAppRn for the method) - -mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged - -> LHsExpr Name -> Fixity -- Operator and fixity - -> LHsCmdTop Name -- Right operand (not an infix) - -> RnM (HsCmd Name) - ---------------------------- --- (e11 `op1` e12) `op2` e2 -mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsArrForm op1 (Just fix1) [a11,a12])) _ _ _)) - op2 fix2 a2 - | nofix_error - = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_` - returnM (HsArrForm op2 (Just fix2) [a1, a2]) - - | associate_right - = mkOpFormRn a12 op2 fix2 a2 `thenM` \ new_c -> - returnM (HsArrForm op1 (Just fix1) - [a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])]) - -- TODO: locs are wrong - where - (nofix_error, associate_right) = compareFixity fix1 fix2 - ---------------------------- --- Default case -mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment - = returnM (HsArrForm op (Just fix) [arg1, arg2]) - \end{code} @@ -721,22 +610,20 @@ rnStmt ctxt (BindStmt pat expr _ _) thing_inside -- but it does not matter because the names are unique rnStmt ctxt (LetStmt binds) thing_inside - = do { checkErr (ok ctxt binds) (badIpBinds binds) - ; rnBindGroupsAndThen binds $ \ binds' -> do + = do { checkErr (ok ctxt binds) + (badIpBinds (ptext SLIT("a parallel list comprehension:")) binds) + ; rnLocalBindsAndThen binds $ \ binds' -> do { (thing, fvs) <- thing_inside ; return ((LetStmt binds', thing), fvs) }} where -- We do not allow implicit-parameter bindings in a parallel -- list comprehension. I'm not sure what it might mean. - ok (ParStmtCtxt _) binds = not (any is_ip_bind binds) - ok _ _ = True - - is_ip_bind (HsIPBinds _) = True - is_ip_bind _ = False + ok (ParStmtCtxt _) (HsIPBinds _) = False + ok _ _ = True rnStmt ctxt (RecStmt rec_stmts _ _ _ _) thing_inside - = bindLocatedLocalsRn doc (collectLStmtsBinders rec_stmts) $ \ _ -> - rn_rec_stmts rec_stmts `thenM` \ segs -> + = bindLocatedLocalsRn doc (collectLStmtsBinders rec_stmts) $ \ bndrs -> + rn_rec_stmts bndrs rec_stmts `thenM` \ segs -> thing_inside `thenM` \ (thing, fvs) -> let segs_w_fwd_refs = addFwdRefs segs @@ -829,7 +716,7 @@ rnMDoStmts stmts thing_inside = -- Step1: bring all the binders of the mdo into scope -- Remember that this also removes the binders from the -- finally-returned free-vars - bindLocatedLocalsRn doc (collectLStmtsBinders stmts) $ \ _ -> + bindLocatedLocalsRn doc (collectLStmtsBinders stmts) $ \ bndrs -> do { -- Step 2: Rename each individual stmt, making a -- singleton segment. At this stage the FwdRefs field @@ -837,7 +724,7 @@ rnMDoStmts stmts thing_inside -- for which it's the fwd refs within the bind itself -- (This set may not be empty, because we're in a recursive -- context.) - segs <- rn_rec_stmts stmts + segs <- rn_rec_stmts bndrs stmts ; (thing, fvs_later) <- thing_inside @@ -864,20 +751,24 @@ rnMDoStmts stmts thing_inside where doc = text "In a recursive mdo-expression" +--------------------------------------------- +rn_rec_stmts :: [Name] -> [LStmt RdrName] -> RnM [Segment (LStmt Name)] +rn_rec_stmts bndrs stmts = mappM (rn_rec_stmt bndrs) stmts `thenM` \ segs_s -> + returnM (concat segs_s) ---------------------------------------------------- -rn_rec_stmt :: LStmt RdrName -> RnM [Segment (LStmt Name)] +rn_rec_stmt :: [Name] -> LStmt RdrName -> RnM [Segment (LStmt Name)] -- Rename a Stmt that is inside a RecStmt (or mdo) -- Assumes all binders are already in scope -- Turns each stmt into a singleton Stmt -rn_rec_stmt (L loc (ExprStmt expr _ _)) +rn_rec_stmt all_bndrs (L loc (ExprStmt expr _ _)) = rnLExpr expr `thenM` \ (expr', fvs) -> lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) -> returnM [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet, L loc (ExprStmt expr' then_op placeHolderType))] -rn_rec_stmt (L loc (BindStmt pat expr _ _)) +rn_rec_stmt all_bndrs (L loc (BindStmt pat expr _ _)) = rnLExpr expr `thenM` \ (expr', fv_expr) -> rnLPat pat `thenM` \ (pat', fv_pat) -> lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) -> @@ -889,24 +780,22 @@ rn_rec_stmt (L loc (BindStmt pat expr _ _)) returnM [(bndrs, fvs, bndrs `intersectNameSet` fvs, L loc (BindStmt pat' expr' bind_op fail_op))] -rn_rec_stmt (L loc (LetStmt binds)) - = rnBindGroups binds `thenM` \ (binds', du_binds) -> +rn_rec_stmt all_bndrs (L loc (LetStmt binds@(HsIPBinds _))) + = do { addErr (badIpBinds (ptext SLIT("an mdo expression")) binds) + ; failM } + +rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds))) + = rnValBinds (trimWith all_bndrs) binds `thenM` \ (binds', du_binds) -> returnM [(duDefs du_binds, duUses du_binds, - emptyNameSet, L loc (LetStmt binds'))] + emptyNameSet, L loc (LetStmt (HsValBinds binds')))] -rn_rec_stmt (L loc (RecStmt stmts _ _ _ _)) -- Flatten Rec inside Rec - = rn_rec_stmts stmts +rn_rec_stmt all_bndrs (L loc (RecStmt stmts _ _ _ _)) -- Flatten Rec inside Rec + = rn_rec_stmts all_bndrs stmts -rn_rec_stmt stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo +rn_rec_stmt all_bndrs stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo = pprPanic "rn_rec_stmt" (ppr stmt) --------------------------------------------- -rn_rec_stmts :: [LStmt RdrName] -> RnM [Segment (LStmt Name)] -rn_rec_stmts stmts = mappM rn_rec_stmt stmts `thenM` \ segs_s -> - returnM (concat segs_s) - - ---------------------------------------------- addFwdRefs :: [Segment a] -> [Segment a] -- So far the segments only have forward refs *within* the Stmt -- (which happens for bind: x <- ...x...) @@ -1009,151 +898,6 @@ segsToStmts ((defs, uses, fwds, ss) : segs) fvs_later %************************************************************************ %* * -\subsubsection{Precedence Parsing} -%* * -%************************************************************************ - -@mkOpAppRn@ deals with operator fixities. The argument expressions -are assumed to be already correctly arranged. It needs the fixities -recorded in the OpApp nodes, because fixity info applies to the things -the programmer actually wrote, so you can't find it out from the Name. - -Furthermore, the second argument is guaranteed not to be another -operator application. Why? Because the parser parses all -operator appications left-associatively, EXCEPT negation, which -we need to handle specially. - -\begin{code} -mkOpAppRn :: LHsExpr Name -- Left operand; already rearranged - -> LHsExpr Name -> Fixity -- Operator and fixity - -> LHsExpr Name -- Right operand (not an OpApp, but might - -- be a NegApp) - -> RnM (HsExpr Name) - ---------------------------- --- (e11 `op1` e12) `op2` e2 -mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2 - | nofix_error - = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_` - returnM (OpApp e1 op2 fix2 e2) - - | associate_right - = mkOpAppRn e12 op2 fix2 e2 `thenM` \ new_e -> - returnM (OpApp e11 op1 fix1 (L loc' new_e)) - where - loc'= combineLocs e12 e2 - (nofix_error, associate_right) = compareFixity fix1 fix2 - ---------------------------- --- (- neg_arg) `op` e2 -mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2 - | nofix_error - = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenM_` - returnM (OpApp e1 op2 fix2 e2) - - | associate_right - = mkOpAppRn neg_arg op2 fix2 e2 `thenM` \ new_e -> - returnM (NegApp (L loc' new_e) neg_name) - where - loc' = combineLocs neg_arg e2 - (nofix_error, associate_right) = compareFixity negateFixity fix2 - ---------------------------- --- e1 `op` - neg_arg -mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp neg_arg _)) -- NegApp can occur on the right - | not associate_right -- We *want* right association - = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenM_` - returnM (OpApp e1 op1 fix1 e2) - where - (_, associate_right) = compareFixity fix1 negateFixity - ---------------------------- --- Default case -mkOpAppRn e1 op fix e2 -- Default case, no rearrangment - = ASSERT2( right_op_ok fix (unLoc e2), - ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2 - ) - returnM (OpApp e1 op fix e2) - --- Parser left-associates everything, but --- derived instances may have correctly-associated things to --- in the right operarand. So we just check that the right operand is OK -right_op_ok fix1 (OpApp _ _ fix2 _) - = not error_please && associate_right - where - (error_please, associate_right) = compareFixity fix1 fix2 -right_op_ok fix1 other - = True - --- Parser initially makes negation bind more tightly than any other operator --- And "deriving" code should respect this (use HsPar if not) -mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id) -mkNegAppRn neg_arg neg_name - = ASSERT( not_op_app (unLoc neg_arg) ) - returnM (NegApp neg_arg neg_name) - -not_op_app (OpApp _ _ _ _) = False -not_op_app other = True -\end{code} - -\begin{code} -checkPrecMatch :: Bool -> Name -> MatchGroup Name -> RnM () - -- True indicates an infix lhs - -- See comments with rnExpr (OpApp ...) about "deriving" - -checkPrecMatch False fn match - = returnM () -checkPrecMatch True op (MatchGroup ms _) - = mapM_ check ms - where - check (L _ (Match (p1:p2:_) _ _)) - = checkPrec op (unLoc p1) False `thenM_` - checkPrec op (unLoc p2) True - - check _ = panic "checkPrecMatch" - -checkPrec op (ConPatIn op1 (InfixCon _ _)) right - = lookupFixityRn op `thenM` \ op_fix@(Fixity op_prec op_dir) -> - lookupFixityRn (unLoc op1) `thenM` \ op1_fix@(Fixity op1_prec op1_dir) -> - let - inf_ok = op1_prec > op_prec || - (op1_prec == op_prec && - (op1_dir == InfixR && op_dir == InfixR && right || - op1_dir == InfixL && op_dir == InfixL && not right)) - - info = (ppr_op op, op_fix) - info1 = (ppr_op op1, op1_fix) - (infol, infor) = if right then (info, info1) else (info1, info) - in - checkErr inf_ok (precParseErr infol infor) - -checkPrec op pat right - = returnM () - --- Check precedence of (arg op) or (op arg) respectively --- If arg is itself an operator application, then either --- (a) its precedence must be higher than that of op --- (b) its precedency & associativity must be the same as that of op -checkSectionPrec :: FixityDirection -> HsExpr RdrName - -> LHsExpr Name -> LHsExpr Name -> RnM () -checkSectionPrec direction section op arg - = case unLoc arg of - OpApp _ op fix _ -> go_for_it (ppr_op op) fix - NegApp _ _ -> go_for_it pp_prefix_minus negateFixity - other -> returnM () - where - L _ (HsVar op_name) = op - go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc) - = lookupFixityRn op_name `thenM` \ op_fix@(Fixity op_prec _) -> - checkErr (op_prec < arg_prec - || op_prec == arg_prec && direction == assoc) - (sectionPrecErr (ppr_op op_name, op_fix) - (pp_arg_op, arg_fix) section) -\end{code} - - -%************************************************************************ -%* * \subsubsection{Assertion utils} %* * %************************************************************************ @@ -1177,30 +921,13 @@ mkAssertErrorExpr %************************************************************************ \begin{code} -ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name -pp_prefix_minus = ptext SLIT("prefix `-'") - -nonStdGuardErr guard - = hang (ptext - SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)") - ) 4 (ppr guard) - patSynErr e = sep [ptext SLIT("Pattern syntax in expression context:"), nest 4 (ppr e)] -#ifdef GHCI -checkTH e what = returnM () -- OK -#else -checkTH e what -- Raise an error in a stage-1 compiler - = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+> - ptext SLIT("illegal in a stage-1 compiler"), - nest 2 (ppr e)]) -#endif - parStmtErr = addErr (ptext SLIT("Illegal parallel list comprehension: use -fglasgow-exts")) -badIpBinds binds - = hang (ptext SLIT("Implicit-parameter bindings illegal in a parallel list comprehension:")) 4 - (ppr binds) +badIpBinds what binds + = hang (ptext SLIT("Implicit-parameter bindings illegal in") <+> what) + 2 (ppr binds) \end{code} diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 9ff40d5..22f75ae 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -4,7 +4,17 @@ \section[RnHsSyn]{Specialisations of the @HsSyn@ syntax for the renamer} \begin{code} -module RnHsSyn where +module RnHsSyn( + -- Names + charTyCon_name, listTyCon_name, parrTyCon_name, tupleTyCon_name, + extractHsTyVars, extractHsTyNames, extractHsTyNames_s, + extractFunDepNames, extractHsCtxtTyNames, extractHsPredTyNames, + + -- Free variables + hsSigsFVs, hsSigFVs, conDeclFVs, bangTyFVs, + + maybeGenericMatch + ) where #include "HsVersions.h" @@ -14,7 +24,6 @@ import TysWiredIn ( tupleTyCon, listTyCon, parrTyCon, charTyCon ) import Name ( Name, getName, isTyVarName ) import NameSet import BasicTypes ( Boxity ) --- gaw 2004 import SrcLoc ( Located(..), unLoc ) \end{code} diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 7101c48..5b888b7 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -16,8 +16,8 @@ module RnNames ( import DynFlags ( DynFlag(..), GhcMode(..) ) import HsSyn ( IE(..), ieName, ImportDecl(..), LImportDecl, - ForeignDecl(..), HsGroup(..), HsBindGroup(..), - Sig(..), collectGroupBinders, tyClDeclNames + ForeignDecl(..), HsGroup(..), HsValBinds(..), + Sig(..), collectHsBindLocatedBinders, tyClDeclNames ) import RnEnv import IfaceEnv ( ifaceExportNames ) @@ -338,7 +338,7 @@ used for source code. \begin{code} getLocalDeclBinders :: TcGblEnv -> HsGroup RdrName -> RnM [Name] -getLocalDeclBinders gbl_env (HsGroup {hs_valds = val_decls, +getLocalDeclBinders gbl_env (HsGroup {hs_valds = ValBindsIn val_decls val_sigs, hs_tyclds = tycl_decls, hs_fords = foreign_decls }) = do { tc_names_s <- mappM new_tc tycl_decls @@ -354,9 +354,8 @@ getLocalDeclBinders gbl_env (HsGroup {hs_valds = val_decls, new_simple rdr_name = newTopSrcBinder mod Nothing rdr_name - sig_hs_bndrs = [nm | HsBindGroup _ lsigs _ <- val_decls, - L _ (Sig nm _) <- lsigs] - val_hs_bndrs = collectGroupBinders val_decls + sig_hs_bndrs = [nm | L _ (Sig nm _) <- val_sigs] + val_hs_bndrs = collectHsBindLocatedBinders val_decls for_hs_bndrs = [nm | L _ (ForeignImport nm _ _ _) <- foreign_decls] new_tc tc_decl @@ -735,7 +734,8 @@ gre_is_used used_names gre = gre_name gre `elemNameSet` used_names reportUnusedNames :: Maybe [Located (IE RdrName)] -- Export list -> TcGblEnv -> RnM () reportUnusedNames export_decls gbl_env - = do { warnUnusedTopBinds unused_locals + = do { traceRn ((text "RUN") <+> (ppr (tcg_dus gbl_env))) + ; warnUnusedTopBinds unused_locals ; warnUnusedModules unused_imp_mods ; warnUnusedImports unused_imports ; warnDuplicateImports defined_and_used diff --git a/ghc/compiler/rename/RnSource.hi-boot-6 b/ghc/compiler/rename/RnSource.hi-boot-6 deleted file mode 100644 index e4d5e3b..0000000 --- a/ghc/compiler/rename/RnSource.hi-boot-6 +++ /dev/null @@ -1,16 +0,0 @@ -module RnSource where - -rnBindGroupsAndThen :: forall b . [HsBinds.HsBindGroup RdrName.RdrName] - -> ([HsBinds.HsBindGroup Name.Name] - -> TcRnTypes.RnM (b, NameSet.FreeVars)) - -> TcRnTypes.RnM (b, NameSet.FreeVars) ; - -rnBindGroups :: [HsBinds.HsBindGroup RdrName.RdrName] - -> TcRnTypes.RnM ([HsBinds.HsBindGroup Name.Name], NameSet.DefUses) ; - -rnSrcDecls :: HsDecls.HsGroup RdrName.RdrName - -> TcRnTypes.RnM (TcRnTypes.TcGblEnv, HsDecls.HsGroup Name.Name) ; - -rnSplice :: HsExpr.HsSplice RdrName.RdrName - -> TcRnTypes.RnM (HsExpr.HsSplice Name.Name, NameSet.FreeVars) - diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 8d60be1..337b3d2 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -7,31 +7,28 @@ module RnSource ( rnSrcDecls, addTcgDUs, rnTyClDecls, checkModDeprec, - rnBindGroups, rnBindGroupsAndThen, rnSplice + rnSplice, checkTH ) where #include "HsVersions.h" +import {-# SOURCE #-} RnExpr( rnLExpr ) + import HsSyn -import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, elemLocalRdrEnv ) +import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv ) import RdrHsSyn ( extractGenericPatTyVars ) import RnHsSyn -import RnExpr ( rnLExpr, checkTH ) import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext ) -import RnBinds ( rnTopBinds, rnBinds, rnMethodBinds, - rnBindsAndThen, renameSigs, checkSigs ) -import RnEnv ( lookupTopBndrRn, lookupLocalDataTcNames, +import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs ) +import RnEnv ( lookupLocalDataTcNames, lookupLocatedTopBndrRn, lookupLocatedOccRn, lookupOccRn, newLocalsRn, bindLocatedLocalsFV, bindPatSigTyVarsFV, bindTyVarsRn, extendTyVarEnvFVRn, - bindLocalNames, newIPNameRn, - checkDupNames, mapFvRn, - unknownNameErr + bindLocalNames, checkDupNames, mapFvRn ) import TcRnMonad -import BasicTypes ( TopLevelFlag(..) ) import HscTypes ( FixityEnv, FixItem(..), Deprecations, Deprecs(..), DeprecTxt, plusDeprecs ) import Class ( FunDep ) @@ -42,7 +39,7 @@ import Outputable import SrcLoc ( Located(..), unLoc, getLoc, noLoc ) import DynFlags ( DynFlag(..) ) import Maybes ( seqMaybe ) -import Maybe ( catMaybes, isNothing ) +import Maybe ( isNothing ) \end{code} @rnSourceDecl@ `renames' declarations. @@ -64,7 +61,7 @@ Checks the @(..)@ etc constraints in the export list. \begin{code} rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name) -rnSrcDecls (HsGroup { hs_valds = [HsBindGroup binds sigs _], +rnSrcDecls (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, hs_instds = inst_decls, hs_fixds = fix_decls, @@ -86,7 +83,7 @@ rnSrcDecls (HsGroup { hs_valds = [HsBindGroup binds sigs _], -- Rename other declarations traceRn (text "Start rnmono") ; - (rn_val_decls, bind_dus) <- rnTopBinds binds sigs ; + (rn_val_decls, bind_dus) <- rnTopBinds val_decls ; traceRn (text "finish rnmono" <+> ppr rn_val_decls) ; -- You might think that we could build proper def/use information @@ -233,63 +230,6 @@ rnDefaultDecl (DefaultDecl tys) %********************************************************* %* * - Bindings -%* * -%********************************************************* - -These chaps are here, rather than in TcBinds, so that there -is just one hi-boot file (for RnSource). rnSrcDecls is part -of the loop too, and it must be defined in this module. - -\begin{code} -rnBindGroups :: [HsBindGroup RdrName] -> RnM ([HsBindGroup Name], DefUses) --- This version assumes that the binders are already in scope --- It's used only in 'mdo' -rnBindGroups [] - = returnM ([], emptyDUs) -rnBindGroups [HsBindGroup bind sigs _] - = rnBinds NotTopLevel bind sigs -rnBindGroups b@[HsIPBinds bind] - = do addErr (badIpBinds b) - returnM ([], emptyDUs) -rnBindGroups _ - = panic "rnBindGroups" - -rnBindGroupsAndThen - :: [HsBindGroup RdrName] - -> ([HsBindGroup Name] -> RnM (result, FreeVars)) - -> RnM (result, FreeVars) --- This version (a) assumes that the binding vars are not already in scope --- (b) removes the binders from the free vars of the thing inside --- The parser doesn't produce ThenBinds -rnBindGroupsAndThen [] thing_inside - = thing_inside [] -rnBindGroupsAndThen [HsBindGroup bind sigs _] thing_inside - = rnBindsAndThen bind sigs $ \ groups -> thing_inside groups -rnBindGroupsAndThen [HsIPBinds binds] thing_inside - = rnIPBinds binds `thenM` \ (binds',fv_binds) -> - thing_inside [HsIPBinds binds'] `thenM` \ (thing, fvs_thing) -> - returnM (thing, fvs_thing `plusFV` fv_binds) - -rnIPBinds [] = returnM ([], emptyFVs) -rnIPBinds (bind : binds) - = wrapLocFstM rnIPBind bind `thenM` \ (bind', fvBind) -> - rnIPBinds binds `thenM` \ (binds',fvBinds) -> - returnM (bind' : binds', fvBind `plusFV` fvBinds) - -rnIPBind (IPBind n expr) - = newIPNameRn n `thenM` \ name -> - rnLExpr expr `thenM` \ (expr',fvExpr) -> - return (IPBind name expr', fvExpr) - -badIpBinds binds - = hang (ptext SLIT("Implicit-parameter bindings illegal in 'mdo':")) 4 - (ppr binds) -\end{code} - - -%********************************************************* -%* * \subsection{Foreign declarations} %* * %********************************************************* @@ -346,9 +286,9 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags) -- But the (unqualified) method names are in scope let binders = collectHsBindBinders mbinds' + ok_sig = okInstDclSig (mkNameSet binders) in - bindLocalNames binders (renameSigs uprags) `thenM` \ uprags' -> - checkSigs (okInstDclSig (mkNameSet binders)) uprags' `thenM_` + bindLocalNames binders (renameSigs ok_sig uprags) `thenM` \ uprags' -> returnM (InstDecl inst_ty' mbinds' uprags', meth_fvs `plusFV` hsSigsFVs uprags' @@ -555,7 +495,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, bindTyVarsRn cls_doc tyvars ( \ tyvars' -> rnContext cls_doc context `thenM` \ context' -> rnFds cls_doc fds `thenM` \ fds' -> - renameSigs sigs `thenM` \ sigs' -> + renameSigs okClsDclSig sigs `thenM` \ sigs' -> returnM (tyvars', context', fds', sigs') ) `thenM` \ (tyvars', context', fds', sigs') -> @@ -565,7 +505,6 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, sig_rdr_names_w_locs = [op | L _ (Sig op _) <- sigs] in checkDupNames sig_doc sig_rdr_names_w_locs `thenM_` - checkSigs okClsDclSig sigs' `thenM_` -- Typechecker is responsible for checking that we only -- give default-method bindings for things in this class. -- The renamer *could* check this for class decls, but can't @@ -710,4 +649,13 @@ rnSplice (HsSplice n expr) newLocalsRn [L loc n] `thenM` \ [n'] -> rnLExpr expr `thenM` \ (expr', fvs) -> returnM (HsSplice n' expr', fvs) + +#ifdef GHCI +checkTH e what = returnM () -- OK +#else +checkTH e what -- Raise an error in a stage-1 compiler + = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+> + ptext SLIT("illegal in a stage-1 compiler"), + nest 2 (ppr e)]) +#endif \end{code} diff --git a/ghc/compiler/rename/RnTypes.lhs b/ghc/compiler/rename/RnTypes.lhs index dcdfe4e..31279ff 100644 --- a/ghc/compiler/rename/RnTypes.lhs +++ b/ghc/compiler/rename/RnTypes.lhs @@ -4,11 +4,21 @@ \section[RnSource]{Main pass of renamer} \begin{code} -module RnTypes ( rnHsType, rnLHsType, rnLHsTypes, rnContext, - rnHsSigType, rnHsTypeFVs, - rnLPat, rnPat, rnPatsAndThen, -- Here because it's not part - rnLit, rnOverLit, -- of any mutual recursion - precParseErr, sectionPrecErr, dupFieldErr, patSigErr, checkTupSize +module RnTypes ( + -- Type related stuff + rnHsType, rnLHsType, rnLHsTypes, rnContext, + rnHsSigType, rnHsTypeFVs, + + -- Patterns and literals + rnLPat, rnPat, rnPatsAndThen, -- Here because it's not part + rnLit, rnOverLit, -- of any mutual recursion + + -- Precence related stuff + mkOpAppRn, mkNegAppRn, mkOpFormRn, + checkPrecMatch, checkSectionPrec, + + -- Error messages + dupFieldErr, patSigErr, checkTupSize ) where import DynFlags ( DynFlag(Opt_WarnUnusedMatches, Opt_GlasgowExts) ) @@ -20,7 +30,8 @@ import RnHsSyn ( extractHsTyNames, parrTyCon_name, tupleTyCon_name, ) import RnEnv ( lookupOccRn, lookupBndrRn, lookupSyntaxName, lookupLocatedOccRn, lookupLocatedBndrRn, - lookupLocatedGlobalOccRn, bindTyVarsRn, lookupFixityRn, + lookupLocatedGlobalOccRn, bindTyVarsRn, + lookupFixityRn, lookupTyFixityRn, mapFvRn, warnUnusedMatches, newIPNameRn, bindPatSigTyVarsFV, bindLocatedLocalsFV ) import TcRnMonad @@ -32,14 +43,14 @@ import PrelNames ( eqClassName, integralClassName, geName, eqName, import TypeRep ( funTyCon ) import Constants ( mAX_TUPLE_SIZE ) import Name ( Name ) -import SrcLoc ( SrcSpan, Located(..), unLoc, noLoc ) +import SrcLoc ( SrcSpan, Located(..), unLoc, noLoc, combineLocs ) import NameSet import Literal ( inIntRange, inCharRange ) -import BasicTypes ( compareFixity, Fixity(..), FixityDirection(..) ) +import BasicTypes ( compareFixity, funTyFixity, negateFixity, compareFixity, + Fixity(..), FixityDirection(..) ) import ListSetOps ( removeDups ) import Outputable -import Monad ( when ) #include "HsVersions.h" \end{code} @@ -201,12 +212,21 @@ rnForAll doc exp forall_tyvars ctxt ty \end{code} -%********************************************************* -%* * -\subsection{Fixities} -%* * -%********************************************************* +%************************************************************************ +%* * + Fixities and precedence parsing +%* * +%************************************************************************ +@mkOpAppRn@ deals with operator fixities. The argument expressions +are assumed to be already correctly arranged. It needs the fixities +recorded in the OpApp nodes, because fixity info applies to the things +the programmer actually wrote, so you can't find it out from the Name. + +Furthermore, the second argument is guaranteed not to be another +operator application. Why? Because the parser parses all +operator appications left-associatively, EXCEPT negation, which +we need to handle specially. Infix types are read in a *right-associative* way, so that a `op` b `op` c is always read in as @@ -254,15 +274,202 @@ mk_hs_op_ty mk1 pp_op1 fix1 ty1 where (nofix_error, associate_right) = compareFixity fix1 fix2 ---------------- -lookupTyFixityRn (L loc n) - = doptM Opt_GlasgowExts `thenM` \ glaExts -> - when (not glaExts) - (setSrcSpan loc $ addWarn (infixTyConWarn n)) `thenM_` - lookupFixityRn n ---------------- -funTyFixity = Fixity 0 InfixR -- Fixity of '->' +--------------------------- +mkOpAppRn :: LHsExpr Name -- Left operand; already rearranged + -> LHsExpr Name -> Fixity -- Operator and fixity + -> LHsExpr Name -- Right operand (not an OpApp, but might + -- be a NegApp) + -> RnM (HsExpr Name) + +-- (e11 `op1` e12) `op2` e2 +mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2 + | nofix_error + = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_` + returnM (OpApp e1 op2 fix2 e2) + + | associate_right + = mkOpAppRn e12 op2 fix2 e2 `thenM` \ new_e -> + returnM (OpApp e11 op1 fix1 (L loc' new_e)) + where + loc'= combineLocs e12 e2 + (nofix_error, associate_right) = compareFixity fix1 fix2 + +--------------------------- +-- (- neg_arg) `op` e2 +mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2 + | nofix_error + = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenM_` + returnM (OpApp e1 op2 fix2 e2) + + | associate_right + = mkOpAppRn neg_arg op2 fix2 e2 `thenM` \ new_e -> + returnM (NegApp (L loc' new_e) neg_name) + where + loc' = combineLocs neg_arg e2 + (nofix_error, associate_right) = compareFixity negateFixity fix2 + +--------------------------- +-- e1 `op` - neg_arg +mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp neg_arg _)) -- NegApp can occur on the right + | not associate_right -- We *want* right association + = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenM_` + returnM (OpApp e1 op1 fix1 e2) + where + (_, associate_right) = compareFixity fix1 negateFixity + +--------------------------- +-- Default case +mkOpAppRn e1 op fix e2 -- Default case, no rearrangment + = ASSERT2( right_op_ok fix (unLoc e2), + ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2 + ) + returnM (OpApp e1 op fix e2) + +-- Parser left-associates everything, but +-- derived instances may have correctly-associated things to +-- in the right operarand. So we just check that the right operand is OK +right_op_ok fix1 (OpApp _ _ fix2 _) + = not error_please && associate_right + where + (error_please, associate_right) = compareFixity fix1 fix2 +right_op_ok fix1 other + = True + +-- Parser initially makes negation bind more tightly than any other operator +-- And "deriving" code should respect this (use HsPar if not) +mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id) +mkNegAppRn neg_arg neg_name + = ASSERT( not_op_app (unLoc neg_arg) ) + returnM (NegApp neg_arg neg_name) + +not_op_app (OpApp _ _ _ _) = False +not_op_app other = True + +--------------------------- +mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged + -> LHsExpr Name -> Fixity -- Operator and fixity + -> LHsCmdTop Name -- Right operand (not an infix) + -> RnM (HsCmd Name) + +-- (e11 `op1` e12) `op2` e2 +mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsArrForm op1 (Just fix1) [a11,a12])) _ _ _)) + op2 fix2 a2 + | nofix_error + = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_` + returnM (HsArrForm op2 (Just fix2) [a1, a2]) + + | associate_right + = mkOpFormRn a12 op2 fix2 a2 `thenM` \ new_c -> + returnM (HsArrForm op1 (Just fix1) + [a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])]) + -- TODO: locs are wrong + where + (nofix_error, associate_right) = compareFixity fix1 fix2 + +-- Default case +mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment + = returnM (HsArrForm op (Just fix) [arg1, arg2]) + + +-------------------------------------- +mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name + -> RnM (Pat Name) + +mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2 + = lookupFixityRn (unLoc op1) `thenM` \ fix1 -> + let + (nofix_error, associate_right) = compareFixity fix1 fix2 + in + if nofix_error then + addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_` + returnM (ConPatIn op2 (InfixCon p1 p2)) + else + if associate_right then + mkConOpPatRn op2 fix2 p12 p2 `thenM` \ new_p -> + returnM (ConPatIn op1 (InfixCon p11 (L loc new_p))) -- XXX loc right? + else + returnM (ConPatIn op2 (InfixCon p1 p2)) + +mkConOpPatRn op fix p1 p2 -- Default case, no rearrangment + = ASSERT( not_op_pat (unLoc p2) ) + returnM (ConPatIn op (InfixCon p1 p2)) + +not_op_pat (ConPatIn _ (InfixCon _ _)) = False +not_op_pat other = True + +-------------------------------------- +checkPrecMatch :: Bool -> Name -> MatchGroup Name -> RnM () + -- True indicates an infix lhs + -- See comments with rnExpr (OpApp ...) about "deriving" + +checkPrecMatch False fn match + = returnM () +checkPrecMatch True op (MatchGroup ms _) + = mapM_ check ms + where + check (L _ (Match (p1:p2:_) _ _)) + = checkPrec op (unLoc p1) False `thenM_` + checkPrec op (unLoc p2) True + + check _ = panic "checkPrecMatch" + +checkPrec op (ConPatIn op1 (InfixCon _ _)) right + = lookupFixityRn op `thenM` \ op_fix@(Fixity op_prec op_dir) -> + lookupFixityRn (unLoc op1) `thenM` \ op1_fix@(Fixity op1_prec op1_dir) -> + let + inf_ok = op1_prec > op_prec || + (op1_prec == op_prec && + (op1_dir == InfixR && op_dir == InfixR && right || + op1_dir == InfixL && op_dir == InfixL && not right)) + + info = (ppr_op op, op_fix) + info1 = (ppr_op op1, op1_fix) + (infol, infor) = if right then (info, info1) else (info1, info) + in + checkErr inf_ok (precParseErr infol infor) + +checkPrec op pat right + = returnM () + +-- Check precedence of (arg op) or (op arg) respectively +-- If arg is itself an operator application, then either +-- (a) its precedence must be higher than that of op +-- (b) its precedency & associativity must be the same as that of op +checkSectionPrec :: FixityDirection -> HsExpr RdrName + -> LHsExpr Name -> LHsExpr Name -> RnM () +checkSectionPrec direction section op arg + = case unLoc arg of + OpApp _ op fix _ -> go_for_it (ppr_op op) fix + NegApp _ _ -> go_for_it pp_prefix_minus negateFixity + other -> returnM () + where + L _ (HsVar op_name) = op + go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc) + = lookupFixityRn op_name `thenM` \ op_fix@(Fixity op_prec _) -> + checkErr (op_prec < arg_prec + || op_prec == arg_prec && direction == assoc) + (sectionPrecErr (ppr_op op_name, op_fix) + (pp_arg_op, arg_fix) section) +\end{code} + +Precedence-related error messages + +\begin{code} +precParseErr op1 op2 + = hang (ptext SLIT("precedence parsing error")) + 4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"), + ppr_opfix op2, + ptext SLIT("in the same infix expression")]) + +sectionPrecErr op arg_op section + = vcat [ptext SLIT("The operator") <+> ppr_opfix op <+> ptext SLIT("of a section"), + nest 4 (ptext SLIT("must have lower precedence than the operand") <+> ppr_opfix arg_op), + nest 4 (ptext SLIT("in the section:") <+> quotes (ppr section))] + +pp_prefix_minus = ptext SLIT("prefix `-'") +ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name +ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity) \end{code} %********************************************************* @@ -462,33 +669,6 @@ rnRpats rpats rnLPat pat `thenM` \ (pat', fvs) -> returnM ((fieldname, pat'), fvs `addOneFV` unLoc fieldname) --- ----------------------------------------------------------------------------- --- mkConOpPatRn - -mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name - -> RnM (Pat Name) - -mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2 - = lookupFixityRn (unLoc op1) `thenM` \ fix1 -> - let - (nofix_error, associate_right) = compareFixity fix1 fix2 - in - if nofix_error then - addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_` - returnM (ConPatIn op2 (InfixCon p1 p2)) - else - if associate_right then - mkConOpPatRn op2 fix2 p12 p2 `thenM` \ new_p -> - returnM (ConPatIn op1 (InfixCon p11 (L loc new_p))) -- XXX loc right? - else - returnM (ConPatIn op2 (InfixCon p1 p2)) - -mkConOpPatRn op fix p1 p2 -- Default case, no rearrangment - = ASSERT( not_op_pat (unLoc p2) ) - returnM (ConPatIn op (InfixCon p1 p2)) - -not_op_pat (ConPatIn _ (InfixCon _ _)) = False -not_op_pat other = True \end{code} @@ -566,21 +746,6 @@ forAllWarn doc ty (L loc tyvar) bogusCharError c = ptext SLIT("character literal out of range: '\\") <> char c <> char '\'' -precParseErr op1 op2 - = hang (ptext SLIT("precedence parsing error")) - 4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"), - ppr_opfix op2, - ptext SLIT("in the same infix expression")]) - -sectionPrecErr op arg_op section - = vcat [ptext SLIT("The operator") <+> ppr_opfix op <+> ptext SLIT("of a section"), - nest 4 (ptext SLIT("must have lower precedence than the operand") <+> ppr_opfix arg_op), - nest 4 (ptext SLIT("in the section:") <+> quotes (ppr section))] - -infixTyConWarn op - = vcat [ftext FSLIT("Accepting non-standard infix type constructor") <+> quotes (ppr op), - ftext FSLIT("Use -fglasgow-exts to avoid this warning")] - patSigErr ty = (ptext SLIT("Illegal signature in pattern:") <+> ppr ty) $$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it")) @@ -589,7 +754,4 @@ dupFieldErr str dup = hsep [ptext SLIT("duplicate field name"), quotes (ppr dup), ptext SLIT("in record"), text str] - -ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name -ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity) \end{code} diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index 29d138e..f8915c7 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -12,7 +12,7 @@ core expression with (hopefully) improved usage information. \begin{code} module OccurAnal ( - occurAnalysePgm, occurAnalyseGlobalExpr + occurAnalysePgm, occurAnalyseExpr ) where #include "HsVersions.h" @@ -64,11 +64,9 @@ occurAnalysePgm binds (bs_usage, binds') = go env binds (final_usage, bind') = occAnalBind env bind bs_usage -occurAnalyseGlobalExpr :: CoreExpr -> CoreExpr -occurAnalyseGlobalExpr expr - = -- Top level expr, so no interesting free vars, and - -- discard occurence info returned - snd (occAnal initOccEnv expr) +occurAnalyseExpr :: CoreExpr -> CoreExpr + -- Do occurrence analysis, and discard occurence info returned +occurAnalyseExpr expr = snd (occAnal initOccEnv expr) \end{code} diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 97cc14c..8e3139e 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -20,7 +20,7 @@ import Rules ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase, extendRuleBaseList, pprRuleBase, ruleCheckProgram, mkSpecInfo, addSpecInfo ) import PprCore ( pprCoreBindings, pprCoreExpr, pprRules ) -import OccurAnal ( occurAnalysePgm, occurAnalyseGlobalExpr ) +import OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) import IdInfo ( setNewStrictnessInfo, newStrictnessInfo, setWorkerInfo, workerInfo, setSpecInfo, specInfo, specInfoRules ) @@ -311,8 +311,8 @@ simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr -- enforce that; it just simplifies the expression twice simplExprGently env expr - = simplExpr env (occurAnalyseGlobalExpr expr) `thenSmpl` \ expr1 -> - simplExpr env (occurAnalyseGlobalExpr expr1) + = simplExpr env (occurAnalyseExpr expr) `thenSmpl` \ expr1 -> + simplExpr env (occurAnalyseExpr expr1) \end{code} diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 105c521..0b58495 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -34,7 +34,7 @@ import CoreUtils ( cheapEqExpr, exprType, exprIsTrivial, etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce2, findDefault, exprOkForSpeculation, exprIsValue ) -import Id ( idType, isDataConWorkId, idOccInfo, +import Id ( idType, isDataConWorkId, idOccInfo, isDictId, mkSysLocal, isDeadBinder, idNewDemandInfo, isExportedId, idUnfolding, idNewStrictness, idInlinePragma, ) @@ -43,7 +43,6 @@ import SimplMonad import Type ( Type, splitFunTys, dropForAlls, isStrictType, splitTyConApp_maybe, tyConAppArgs, mkTyVarTys ) -import TcType ( isDictTy ) import Name ( mkSysTvName ) import TyCon ( tyConDataCons_maybe, isAlgTyCon, isNewTyCon ) import DataCon ( dataConRepArity, dataConTyVars, dataConArgTys, isVanillaDataCon ) @@ -770,7 +769,7 @@ tryEtaReduce bndrs body ok_fun fun = exprIsTrivial fun && not (any (`elemVarSet` (exprFreeVars fun)) bndrs) && (exprIsValue fun || all ok_lam bndrs) - ok_lam v = isTyVar v || isDictTy (idType v) + ok_lam v = isTyVar v || isDictId v -- The exprIsValue is because eta reduction is not -- valid in general: \x. bot /= bot -- So we need to be sure that the "fun" is a value. diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs index 4728920..9220604 100644 --- a/ghc/compiler/specialise/Rules.lhs +++ b/ghc/compiler/specialise/Rules.lhs @@ -17,7 +17,7 @@ module Rules ( #include "HsVersions.h" import CoreSyn -- All of it -import OccurAnal ( occurAnalyseGlobalExpr ) +import OccurAnal ( occurAnalyseExpr ) import CoreFVs ( exprFreeVars, exprsFreeVars, rulesRhsFreeVars ) import CoreUnfold ( isCheapUnfolding, unfoldingTemplate ) import CoreUtils ( tcEqExprX ) @@ -44,6 +44,7 @@ import Outputable import FastString import Maybe ( isJust ) import Bag +import Util ( singleton ) import List ( isPrefixOf ) \end{code} @@ -176,9 +177,7 @@ unionRuleBase rb1 rb2 = plusNameEnv_C (++) rb1 rb2 extendRuleBase :: RuleBase -> CoreRule -> RuleBase extendRuleBase rule_base rule - = extendNameEnv_C add rule_base (ruleIdName rule) [rule] - where - add rules _ = rule : rules + = extendNameEnv_Acc (:) singleton rule_base (ruleIdName rule) rule pprRuleBase :: RuleBase -> SDoc pprRuleBase rules = vcat [ pprRules (tidyRules emptyTidyEnv rs) @@ -303,7 +302,7 @@ matchRule is_active in_scope args rough_args `mkApps` tpl_vals `mkApps` leftovers) where - rule_fn = occurAnalyseGlobalExpr (mkLams tpl_vars rhs) + rule_fn = occurAnalyseExpr (mkLams tpl_vars rhs) -- We could do this when putting things into the rulebase, I guess \end{code} diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index baca12c..0e66b0b 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -18,7 +18,6 @@ import CoreSubst ( Subst, mkEmptySubst, extendTvSubstList, lookupIdSubst, substBndr, substBndrs, substTy, substInScope, cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs ) -import Var ( zapSpecPragmaId ) import VarSet import VarEnv import CoreSyn @@ -801,7 +800,7 @@ specDefn subst calls (fn, rhs) let (spec_defns, spec_uds, spec_rules) = unzip3 stuff - fn' = addIdSpecialisations zapped_fn spec_rules + fn' = addIdSpecialisations fn spec_rules in returnSM ((fn',rhs'), spec_defns, @@ -809,14 +808,9 @@ specDefn subst calls (fn, rhs) | otherwise -- No calls or RHS doesn't fit our preconceptions = specExpr subst rhs `thenSM` \ (rhs', rhs_uds) -> - returnSM ((zapped_fn, rhs'), [], rhs_uds) + returnSM ((fn, rhs'), [], rhs_uds) where - zapped_fn = zapSpecPragmaId fn - -- If the fn is a SpecPragmaId, make it discardable - -- It's role as a holder for a call instance is o'er - -- But it might be alive for some other reason by now. - fn_type = idType fn (tyvars, theta, _) = tcSplitSigmaTy fn_type n_tyvars = length tyvars diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index d241e58..781d6ed 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -433,7 +433,7 @@ mkStgAltType scrut_ty alts ASSERT(null data_alts) PolyAlt where - (data_alts, deflt) = findDefault alts + (data_alts, _deflt) = findDefault alts \end{code} diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 21466a8..c2927bc 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -59,12 +59,12 @@ import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zonkTcThetaType, import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcTyVar, TcPredType, PredType(..), SkolemInfo(..), typeKind, mkSigmaTy, tcSplitForAllTys, mkFunTy, - tcSplitPhiTy, tcIsTyVarTy, tcSplitDFunHead, + tcSplitPhiTy, tcSplitDFunHead, isIntTy,isFloatTy, isIntegerTy, isDoubleTy, mkPredTy, mkTyVarTy, mkTyVarTys, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred, isClassPred, isTyVarClassPred, isLinearPred, - getClassPredTys, getClassPredTys_maybe, mkPredName, + getClassPredTys, mkPredName, isInheritablePred, isIPPred, tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy, pprPred, pprParendType, pprTheta @@ -78,7 +78,7 @@ import HscTypes ( ExternalPackageState(..) ) import CoreFVs ( idFreeTyVars ) import DataCon ( DataCon, dataConTyVars, dataConStupidTheta, dataConName, dataConWrapId ) import Id ( Id, idName, idType, mkUserLocal, mkLocalId ) -import PrelInfo ( isStandardClass, isNoDictClass ) +import PrelInfo ( isNoDictClass ) import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule, isInternalName, setNameUnique, mkSystemVarNameEncoded ) import NameSet ( addOneToNameSet ) diff --git a/ghc/compiler/typecheck/TcArrows.lhs b/ghc/compiler/typecheck/TcArrows.lhs index b02eb2b..38ca1f6 100644 --- a/ghc/compiler/typecheck/TcArrows.lhs +++ b/ghc/compiler/typecheck/TcArrows.lhs @@ -11,7 +11,7 @@ module TcArrows ( tcProc ) where import {-# SOURCE #-} TcExpr( tcCheckRho, tcInferRho ) import HsSyn -import TcHsSyn ( mkHsLet ) +import TcHsSyn ( mkHsDictLet ) import TcMatches ( tcMatchPats, matchCtxt, tcStmts, tcMDoStmt, tcGuardStmt, TcMatchCtxt(..), tcMatchesCase ) @@ -20,7 +20,7 @@ import TcType ( TcType, TcTauType, TcRhoType, mkFunTys, mkTyConApp, mkTyVarTy, mkAppTys, tcSplitTyConApp_maybe, tcEqType, SkolemInfo(..) ) import TcMType ( newTyFlexiVarTy, newTyFlexiVarTys, tcSkolTyVars, zonkTcType ) -import TcBinds ( tcBindsAndThen ) +import TcBinds ( tcLocalBinds ) import TcSimplify ( tcSimplifyCheck ) import TcUnify ( Expected(..), checkSigTyVarsWrt, zapExpectedTo ) import TcRnMonad @@ -111,11 +111,10 @@ tc_cmd env (HsPar cmd) res_ty ; return (HsPar cmd') } tc_cmd env (HsLet binds (L body_loc body)) res_ty - = tcBindsAndThen glue binds $ - setSrcSpan body_loc $ - tc_cmd env body res_ty - where - glue binds expr = HsLet [binds] (L body_loc expr) + = do { (binds', body') <- tcLocalBinds binds $ + setSrcSpan body_loc $ + tc_cmd env body res_ty + ; return (HsLet binds' (L body_loc body')) } tc_cmd env in_cmd@(HsCase scrut matches) (stk, res_ty) = addErrCtxt (cmdCtxt in_cmd) $ @@ -201,9 +200,9 @@ tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats maybe_rhs_sig g pg_ctxt = PatGuard match_ctxt tc_grhss (GRHSs grhss binds) - = tcBindsAndThen glueBindsOnGRHSs binds $ - do { grhss' <- mappM (wrapLocM tc_grhs) grhss - ; return (GRHSs grhss' []) } + = do { (binds', grhss') <- tcLocalBinds binds $ + mappM (wrapLocM tc_grhs) grhss + ; return (GRHSs grhss' binds') } tc_grhs (GRHS guards body) = do { (guards', rhs') <- tcStmts pg_ctxt @@ -264,7 +263,7 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty) -- the s1..sm and check each cmd ; cmds' <- mapM (tc_cmd w_tv) cmds_w_tys - ; returnM (HsArrForm (mkHsTyLam [w_tv] (mkHsLet inst_binds expr')) fixity cmds') + ; returnM (HsArrForm (mkHsTyLam [w_tv] (mkHsDictLet inst_binds expr')) fixity cmds') } where -- Make the types diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 26e5fc5..ce1c48a 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -4,33 +4,36 @@ \section[TcBinds]{TcBinds} \begin{code} -module TcBinds ( tcBindsAndThen, tcTopBinds, - tcHsBootSigs, tcMonoBinds, tcSpecSigs, +module TcBinds ( tcLocalBinds, tcTopBinds, + tcHsBootSigs, tcMonoBinds, + TcPragFun, tcSpecPrag, tcPrags, mkPragFun, badBootDeclErr ) where #include "HsVersions.h" import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) -import {-# SOURCE #-} TcExpr ( tcCheckSigma, tcCheckRho ) +import {-# SOURCE #-} TcExpr ( tcCheckRho ) import DynFlags ( DynFlag(Opt_MonomorphismRestriction) ) -import HsSyn ( HsExpr(..), HsBind(..), LHsBinds, Sig(..), - LSig, Match(..), HsBindGroup(..), IPBind(..), - HsType(..), HsExplicitForAll(..), hsLTyVarNames, isVanillaLSig, - LPat, GRHSs, MatchGroup(..), emptyLHsBinds, isEmptyLHsBinds, +import HsSyn ( HsExpr(..), HsBind(..), LHsBinds, LHsBind, Sig(..), + HsLocalBinds(..), HsValBinds(..), HsIPBinds(..), + LSig, Match(..), IPBind(..), Prag(..), + HsType(..), LHsType, HsExplicitForAll(..), hsLTyVarNames, + isVanillaLSig, sigName, placeHolderNames, isPragLSig, + LPat, GRHSs, MatchGroup(..), isEmptyLHsBinds, collectHsBindBinders, collectPatBinders, pprPatBind ) -import TcHsSyn ( zonkId, mkHsLet ) +import TcHsSyn ( zonkId, (<$>) ) import TcRnMonad import Inst ( newDictsAtLoc, newIPDict, instToId ) import TcEnv ( tcExtendIdEnv, tcExtendIdEnv2, tcExtendTyVarEnv2, newLocalName, tcLookupLocalIds, pprBinders, tcGetGlobalTyVars ) -import TcUnify ( Expected(..), tcInfer, unifyTheta, +import TcUnify ( Expected(..), tcInfer, unifyTheta, tcSub, bleatEscapedTvs, sigCtxt ) -import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted, - tcSimplifyToDicts, tcSimplifyIPs ) +import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, + tcSimplifyRestricted, tcSimplifyIPs ) import TcHsType ( tcHsSigType, UserTypeCtxt(..), tcAddLetBoundTyVars, TcSigInfo(..), TcSigFun, lookupSig ) @@ -38,7 +41,7 @@ import TcPat ( tcPat, PatCtxt(..) ) import TcSimplify ( bindInstsOfLocalFuns ) import TcMType ( newTyFlexiVarTy, zonkQuantifiedTyVar, tcInstSigType, zonkTcType, zonkTcTypes, zonkTcTyVar ) -import TcType ( TcTyVar, SkolemInfo(SigSkol), +import TcType ( TcType, TcTyVar, SkolemInfo(SigSkol), TcTauType, TcSigmaType, isUnboxedTupleType, mkTyVarTy, mkForAllTys, mkFunTys, tyVarsOfType, mkForAllTy, isUnLiftedType, tcGetTyVar, @@ -46,19 +49,21 @@ import TcType ( TcTyVar, SkolemInfo(SigSkol), import Kind ( argTypeKind ) import VarEnv ( TyVarEnv, emptyVarEnv, lookupVarEnv, extendVarEnv, emptyTidyEnv ) import TysPrim ( alphaTyVar ) -import Id ( Id, mkLocalId, mkVanillaGlobal, mkSpecPragmaId, setInlinePragma ) +import Id ( Id, mkLocalId, mkVanillaGlobal ) import IdInfo ( vanillaIdInfo ) -import Var ( idType, idName ) +import Var ( TyVar, idType, idName ) import Name ( Name ) import NameSet +import NameEnv import VarSet -import SrcLoc ( Located(..), unLoc, noLoc, getLoc ) +import SrcLoc ( Located(..), unLoc, getLoc ) import Bag import ErrUtils ( Message ) -import Util ( isIn ) -import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNonRec, isRec, - isNotTopLevel, isAlwaysActive ) -import FiniteMap ( listToFM, lookupFM ) +import Digraph ( SCC(..), stronglyConnComp, flattenSCC ) +import Maybes ( fromJust, isJust, orElse ) +import Util ( singleton ) +import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel, + RecFlag(..), isNonRec ) import Outputable \end{code} @@ -95,25 +100,20 @@ At the top-level the LIE is sure to contain nothing but constant dictionaries, which we resolve at the module level. \begin{code} -tcTopBinds :: [HsBindGroup Name] -> TcM (LHsBinds TcId, TcLclEnv) +tcTopBinds :: HsValBinds Name -> TcM (LHsBinds TcId, TcLclEnv) -- Note: returning the TcLclEnv is more than we really -- want. The bit we care about is the local bindings -- and the free type variables thereof tcTopBinds binds - = tc_binds_and_then TopLevel glue binds $ - do { env <- getLclEnv - ; return (emptyLHsBinds, env) } - where + = do { (ValBindsOut prs, env) <- tcValBinds TopLevel binds getLclEnv + ; return (foldr (unionBags . snd) emptyBag prs, env) } -- The top level bindings are flattened into a giant - -- implicitly-mutually-recursive MonoBinds - glue (HsBindGroup binds1 _ _) (binds2, env) = (binds1 `unionBags` binds2, env) - glue (HsIPBinds _) _ = panic "Top-level HsIpBinds" - -- Can't have a HsIPBinds at top level + -- implicitly-mutually-recursive LHsBinds -tcHsBootSigs :: [HsBindGroup Name] -> TcM [Id] +tcHsBootSigs :: HsValBinds Name -> TcM [Id] -- A hs-boot file has only one BindGroup, and it only has type -- signatures in it. The renamer checked all this -tcHsBootSigs [HsBindGroup binds sigs _] +tcHsBootSigs (ValBindsIn binds sigs) = do { checkTc (isEmptyLHsBinds binds) badBootDeclErr ; mapM (addLocM tc_boot_sig) (filter isVanillaLSig sigs) } where @@ -126,30 +126,26 @@ tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups) badBootDeclErr :: Message badBootDeclErr = ptext SLIT("Illegal declarations in an hs-boot file") -tcBindsAndThen - :: (HsBindGroup TcId -> thing -> thing) -- Combinator - -> [HsBindGroup Name] - -> TcM thing - -> TcM thing +------------------------ +tcLocalBinds :: HsLocalBinds Name -> TcM thing + -> TcM (HsLocalBinds TcId, thing) -tcBindsAndThen = tc_binds_and_then NotTopLevel +tcLocalBinds EmptyLocalBinds thing_inside + = do { thing <- thing_inside + ; return (EmptyLocalBinds, thing) } -tc_binds_and_then top_lvl combiner [] do_next - = do_next -tc_binds_and_then top_lvl combiner (group : groups) do_next - = tc_bind_and_then top_lvl combiner group $ - tc_binds_and_then top_lvl combiner groups do_next +tcLocalBinds (HsValBinds binds) thing_inside + = do { (binds', thing) <- tcValBinds NotTopLevel binds thing_inside + ; return (HsValBinds binds', thing) } -tc_bind_and_then top_lvl combiner (HsIPBinds binds) do_next - = getLIE do_next `thenM` \ (result, expr_lie) -> - mapAndUnzipM (wrapLocSndM tc_ip_bind) binds `thenM` \ (avail_ips, binds') -> +tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside + = do { (thing, lie) <- getLIE thing_inside + ; (avail_ips, ip_binds') <- mapAndUnzipM (wrapLocSndM tc_ip_bind) ip_binds -- If the binding binds ?x = E, we must now -- discharge any ?x constraints in expr_lie - tcSimplifyIPs avail_ips expr_lie `thenM` \ dict_binds -> - - returnM (combiner (HsIPBinds binds') $ - combiner (HsBindGroup dict_binds [] Recursive) result) + ; dict_binds <- tcSimplifyIPs avail_ips lie + ; return (HsIPBinds (IPBinds ip_binds' dict_binds), thing) } where -- I wonder if we should do these one at at time -- Consider ?x = 4 @@ -160,122 +156,189 @@ tc_bind_and_then top_lvl combiner (HsIPBinds binds) do_next tcCheckRho expr ty `thenM` \ expr' -> returnM (ip_inst, (IPBind ip' expr')) -tc_bind_and_then top_lvl combiner (HsBindGroup binds sigs is_rec) do_next - | isEmptyLHsBinds binds - = do_next - | otherwise - = -- BRING ANY SCOPED TYPE VARIABLES INTO SCOPE +------------------------ +mkEdges :: (Name -> Bool) -> [LHsBind Name] + -> [(LHsBind Name, BKey, [BKey])] + +type BKey = Int -- Just number off the bindings + +mkEdges exclude_fn binds + = [ (bind, key, [fromJust mb_key | n <- nameSetToList (bind_fvs (unLoc bind)), + let mb_key = lookupNameEnv key_map n, + isJust mb_key, + not (exclude_fn n) ]) + | (bind, key) <- keyd_binds + ] + where + keyd_binds = binds `zip` [0::BKey ..] + + bind_fvs (FunBind _ _ _ fvs) = fvs + bind_fvs (PatBind _ _ _ fvs) = fvs + bind_fvs bind = pprPanic "mkEdges" (ppr bind) + + key_map :: NameEnv BKey -- Which binding it comes from + key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds + , bndr <- bindersOfHsBind bind ] + +bindersOfHsBind :: HsBind Name -> [Name] +bindersOfHsBind (PatBind pat _ _ _) = collectPatBinders pat +bindersOfHsBind (FunBind (L _ f) _ _ _) = [f] + +------------------------ +tcValBinds :: TopLevelFlag + -> HsValBinds Name -> TcM thing + -> TcM (HsValBinds TcId, thing) + +tcValBinds top_lvl (ValBindsIn binds sigs) thing_inside + = tcAddLetBoundTyVars binds $ + -- BRING ANY SCOPED TYPE VARIABLES INTO SCOPE -- Notice that they scope over -- a) the type signatures in the binding group -- b) the bindings in the group -- c) the scope of the binding group (the "in" part) - tcAddLetBoundTyVars binds $ - - case top_lvl of - TopLevel -- For the top level don't bother will all this - -- bindInstsOfLocalFuns stuff. All the top level - -- things are rec'd together anyway, so it's fine to - -- leave them to the tcSimplifyTop, and quite a bit faster too - -> tcBindWithSigs top_lvl binds sigs is_rec `thenM` \ (poly_binds, poly_ids) -> - tc_body poly_ids `thenM` \ (prag_binds, thing) -> - returnM (combiner (HsBindGroup - (poly_binds `unionBags` prag_binds) - [] -- no sigs - Recursive) - thing) - - NotTopLevel -- For nested bindings we must do the bindInstsOfLocalFuns thing. - | not (isRec is_rec) -- Non-recursive group - -> -- We want to keep non-recursive things non-recursive - -- so that we desugar unlifted bindings correctly - tcBindWithSigs top_lvl binds sigs is_rec `thenM` \ (poly_binds, poly_ids) -> - getLIE (tc_body poly_ids) `thenM` \ ((prag_binds, thing), lie) -> - - -- Create specialisations of functions bound here - bindInstsOfLocalFuns lie poly_ids `thenM` \ lie_binds -> - - returnM ( - combiner (HsBindGroup poly_binds [] NonRecursive) $ - combiner (HsBindGroup prag_binds [] NonRecursive) $ - combiner (HsBindGroup lie_binds [] Recursive) $ - -- NB: the binds returned by tcSimplify and - -- bindInstsOfLocalFuns aren't guaranteed in - -- dependency order (though we could change that); - -- hence the Recursive marker. - thing) - - | otherwise - -> -- NB: polymorphic recursion means that a function - -- may use an instance of itself, we must look at the LIE arising - -- from the function's own right hand side. Hence the getLIE - -- encloses the tcBindWithSigs. - - getLIE ( - tcBindWithSigs top_lvl binds sigs is_rec `thenM` \ (poly_binds, poly_ids) -> - tc_body poly_ids `thenM` \ (prag_binds, thing) -> - returnM (poly_ids, poly_binds `unionBags` prag_binds, thing) - ) `thenM` \ ((poly_ids, extra_binds, thing), lie) -> - bindInstsOfLocalFuns lie poly_ids `thenM` \ lie_binds -> + do { -- Typecheck the signature + tc_ty_sigs <- recoverM (returnM []) (tcTySigs sigs) - returnM (combiner (HsBindGroup - (extra_binds `unionBags` lie_binds) - [] Recursive) thing - ) - where - tc_body poly_ids -- Type check the pragmas and "thing inside" - = -- Extend the environment to bind the new polymorphic Ids - tcExtendIdEnv poly_ids $ - - -- Build bindings and IdInfos corresponding to user pragmas - tcSpecSigs sigs `thenM` \ prag_binds -> + -- Do the basic strongly-connected component thing + ; let { sccs :: [SCC (LHsBind Name)] + ; sccs = stronglyConnComp (mkEdges (\n -> False) (bagToList binds)) + ; prag_fn = mkPragFun sigs + ; sig_fn = lookupSig tc_ty_sigs + ; sig_ids = map sig_id tc_ty_sigs } - -- Now do whatever happens next, in the augmented envt - do_next `thenM` \ thing -> - - returnM (prag_binds, thing) -\end{code} + -- Extend the envt right away with all + -- the Ids declared with type signatures + ; (binds', thing) <- tcExtendIdEnv sig_ids $ + tc_val_binds top_lvl sig_fn prag_fn + sccs thing_inside + ; return (ValBindsOut binds', thing) } -%************************************************************************ -%* * -\subsection{tcBindWithSigs} -%* * -%************************************************************************ - -@tcBindWithSigs@ deals with a single binding group. It does generalisation, -so all the clever stuff is in here. +------------------------ +tc_val_binds :: TopLevelFlag -> TcSigFun -> TcPragFun + -> [SCC (LHsBind Name)] -> TcM thing + -> TcM ([(RecFlag, LHsBinds TcId)], thing) +-- Typecheck a whole lot of value bindings, +-- one strongly-connected component at a time + +tc_val_binds top_lvl sig_fn prag_fn [] thing_inside + = do { thing <- thing_inside + ; return ([], thing) } + +tc_val_binds top_lvl sig_fn prag_fn (scc : sccs) thing_inside + = do { (group', (groups', thing)) + <- tc_group top_lvl sig_fn prag_fn scc $ + tc_val_binds top_lvl sig_fn prag_fn sccs thing_inside + ; return (group' ++ groups', thing) } -* binder_names and mbind must define the same set of Names +------------------------ +tc_group :: TopLevelFlag -> TcSigFun -> TcPragFun + -> SCC (LHsBind Name) -> TcM thing + -> TcM ([(RecFlag, LHsBinds TcId)], thing) + +-- Typecheck one strongly-connected component of the original program. +-- We get a list of groups back, because there may +-- be specialisations etc as well + +tc_group top_lvl sig_fn prag_fn scc@(AcyclicSCC bind) thing_inside + = -- A single non-recursive binding + -- We want to keep non-recursive things non-recursive + -- so that we desugar unlifted bindings correctly + do { (binds, thing) <- tcPolyBinds top_lvl NonRecursive + sig_fn prag_fn scc thing_inside + ; return ([(NonRecursive, b) | b <- binds], thing) } + +tc_group top_lvl sig_fn prag_fn (CyclicSCC binds) thing_inside + = -- A recursive strongly-connected component + -- To maximise polymorphism, we do a new strongly-connected + -- component analysis, this time omitting any references to + -- variables with type signatures. + -- + -- Then we bring into scope all the variables with type signatures + do { traceTc (text "tc_group rec" <+> vcat [ppr b $$ text "--and--" | b <- binds]) + ; let { sccs :: [SCC (LHsBind Name)] + ; sccs = stronglyConnComp (mkEdges has_sig binds) } + ; (binds, thing) <- go sccs + ; return ([(Recursive, unionManyBags binds)], thing) } + -- Rec them all together + where +-- go :: SCC (LHsBind Name) -> TcM ([LHsBind TcId], thing) + go (scc:sccs) = do { (binds1, (binds2, thing)) <- go1 scc (go sccs) + ; return (binds1 ++ binds2, thing) } + go [] = do { thing <- thing_inside; return ([], thing) } -* The Names in tc_ty_sigs must be a subset of binder_names + go1 scc thing_inside = tcPolyBinds top_lvl Recursive + sig_fn prag_fn scc thing_inside -* The Ids in tc_ty_sigs don't necessarily have to have the same name - as the Name in the tc_ty_sig + has_sig :: Name -> Bool + has_sig n = isJust (sig_fn n) -\begin{code} -tcBindWithSigs :: TopLevelFlag - -> LHsBinds Name - -> [LSig Name] - -> RecFlag - -> TcM (LHsBinds TcId, [TcId]) - -- The returned TcIds are guaranteed zonked - -tcBindWithSigs top_lvl mbind sigs is_rec = do - { -- TYPECHECK THE SIGNATURES - tc_ty_sigs <- recoverM (returnM []) $ - tcTySigs (filter isVanillaLSig sigs) - ; let lookup_sig = lookupSig tc_ty_sigs +------------------------ +tcPolyBinds :: TopLevelFlag -> RecFlag + -> TcSigFun -> TcPragFun + -> SCC (LHsBind Name) + -> TcM thing + -> TcM ([LHsBinds TcId], thing) + +-- Typechecks a single bunch of bindings all together, +-- and generalises them. The bunch may be only part of a recursive +-- group, because we use type signatures to maximise polymorphism +-- +-- Deals with the bindInstsOfLocalFuns thing too + +tcPolyBinds top_lvl is_rec sig_fn prag_fn scc thing_inside + = -- NB: polymorphic recursion means that a function + -- may use an instance of itself, we must look at the LIE arising + -- from the function's own right hand side. Hence the getLIE + -- encloses the tc_poly_binds. + do { traceTc (text "tcPolyBinds" <+> ppr scc) + ; ((binds1, poly_ids, thing), lie) <- getLIE $ + do { (binds1, poly_ids) <- tc_poly_binds top_lvl is_rec + sig_fn prag_fn scc + ; thing <- tcExtendIdEnv poly_ids thing_inside + ; return (binds1, poly_ids, thing) } + + ; if isTopLevel top_lvl + then -- For the top level don't bother will all this + -- bindInstsOfLocalFuns stuff. All the top level + -- things are rec'd together anyway, so it's fine to + -- leave them to the tcSimplifyTop, + -- and quite a bit faster too + do { extendLIEs lie; return (binds1, thing) } + + else do -- Nested case + { lie_binds <- bindInstsOfLocalFuns lie poly_ids + ; return (binds1 ++ [lie_binds], thing) }} +------------------------ +tc_poly_binds :: TopLevelFlag -> RecFlag + -> TcSigFun -> TcPragFun + -> SCC (LHsBind Name) + -> TcM ([LHsBinds TcId], [TcId]) +-- Typechecks the bindings themselves +-- Knows nothing about the scope of the bindings + +tc_poly_binds top_lvl is_rec sig_fn prag_fn bind_scc + = let + non_rec = case bind_scc of { AcyclicSCC _ -> True; CyclicSCC _ -> False } + binds = flattenSCC bind_scc + binder_names = collectHsBindBinders (listToBag binds) + + loc = getLoc (head binds) + -- TODO: location a bit awkward, but the mbinds have been + -- dependency analysed and may no longer be adjacent + in -- SET UP THE MAIN RECOVERY; take advantage of any type sigs - ; recoverM (recoveryCode mbind lookup_sig) $ do + setSrcSpan loc $ + recoverM (recoveryCode binder_names sig_fn) $ do - { traceTc (ptext SLIT("--------------------------------------------------------")) - ; traceTc (ptext SLIT("Bindings for") <+> ppr (collectHsBindBinders mbind)) + { traceTc (ptext SLIT("------------------------------------------------")) + ; traceTc (ptext SLIT("Bindings for") <+> ppr binder_names) -- TYPECHECK THE BINDINGS - ; ((mbind', mono_bind_infos), lie_req) - <- getLIE (tcMonoBinds mbind lookup_sig is_rec) + ; ((binds', mono_bind_infos), lie_req) + <- getLIE (tcMonoBinds binds sig_fn non_rec) -- CHECK FOR UNLIFTED BINDINGS -- These must be non-recursive etc, and are not generalised @@ -283,23 +346,21 @@ tcBindWithSigs top_lvl mbind sigs is_rec = do ; zonked_mono_tys <- zonkTcTypes (map getMonoType mono_bind_infos) ; if any isUnLiftedType zonked_mono_tys then do { -- Unlifted bindings - checkUnliftedBinds top_lvl is_rec mbind + checkUnliftedBinds top_lvl is_rec binds' mono_bind_infos ; extendLIEs lie_req ; let exports = zipWith mk_export mono_bind_infos zonked_mono_tys - mk_export (name, Nothing, mono_id) mono_ty = ([], mkLocalId name mono_ty, mono_id) - mk_export (name, Just sig, mono_id) mono_ty = ([], sig_id sig, mono_id) + mk_export (name, Nothing, mono_id) mono_ty = ([], mkLocalId name mono_ty, mono_id, []) + mk_export (name, Just sig, mono_id) mono_ty = ([], sig_id sig, mono_id, []) + -- ToDo: prags - ; return ( unitBag $ noLoc $ AbsBinds [] [] exports emptyNameSet mbind', - [poly_id | (_, poly_id, _) <- exports]) } -- Guaranteed zonked + ; return ( [unitBag $ L loc $ AbsBinds [] [] exports binds'], + [poly_id | (_, poly_id, _, _) <- exports]) } -- Guaranteed zonked else do -- The normal lifted case: GENERALISE - { is_unres <- isUnRestrictedGroup mbind tc_ty_sigs + { is_unres <- isUnRestrictedGroup binds sig_fn ; (tyvars_to_gen, dict_binds, dict_ids) - <- setSrcSpan (getLoc (head (bagToList mbind))) $ - -- TODO: location a bit awkward, but the mbinds have been - -- dependency analysed and may no longer be adjacent - addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $ - generalise top_lvl is_unres mono_bind_infos tc_ty_sigs lie_req + <- addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $ + generalise top_lvl is_unres mono_bind_infos lie_req -- FINALISE THE QUANTIFIED TYPE VARIABLES -- The quantified type variables often include meta type variables @@ -308,158 +369,129 @@ tcBindWithSigs top_lvl mbind sigs is_rec = do ; tyvars_to_gen' <- mappM zonkQuantifiedTyVar tyvars_to_gen -- BUILD THE POLYMORPHIC RESULT IDs - ; let - exports = map mk_export mono_bind_infos - poly_ids = [poly_id | (_, poly_id, _) <- exports] - dict_tys = map idType dict_ids - - inlines = mkNameSet [ name - | L _ (InlineSig True (L _ name) _) <- sigs] - -- Any INLINE sig (regardless of phase control) - -- makes the RHS look small - inline_phases = listToFM [ (name, phase) - | L _ (InlineSig _ (L _ name) phase) <- sigs, - not (isAlwaysActive phase)] - -- Set the IdInfo field to control the inline phase - -- AlwaysActive is the default, so don't bother with them - add_inlines id = attachInlinePhase inline_phases id - - mk_export (binder_name, mb_sig, mono_id) - = case mb_sig of - Just sig -> (sig_tvs sig, add_inlines (sig_id sig), mono_id) - Nothing -> (tyvars_to_gen', add_inlines new_poly_id, mono_id) - where - new_poly_id = mkLocalId binder_name poly_ty - poly_ty = mkForAllTys tyvars_to_gen' - $ mkFunTys dict_tys - $ idType mono_id + ; exports <- mapM (mkExport prag_fn tyvars_to_gen' (map idType dict_ids)) + mono_bind_infos -- ZONK THE poly_ids, because they are used to extend the type -- environment; see the invariant on TcEnv.tcExtendIdEnv + ; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports] ; zonked_poly_ids <- mappM zonkId poly_ids ; traceTc (text "binding:" <+> ppr ((dict_ids, dict_binds), - exports, map idType zonked_poly_ids)) - - ; return ( - unitBag $ noLoc $ - AbsBinds tyvars_to_gen' - dict_ids - exports - inlines - (dict_binds `unionBags` mbind'), - zonked_poly_ids - ) - } } } + map idType zonked_poly_ids)) + + ; let abs_bind = L loc $ AbsBinds tyvars_to_gen' + dict_ids exports + (dict_binds `unionBags` binds') + + ; return ([unitBag abs_bind], zonked_poly_ids) + } } + + +-------------- +mkExport :: TcPragFun -> [TyVar] -> [TcType] -> MonoBindInfo + -> TcM ([TyVar], Id, Id, [Prag]) +mkExport prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id) + = do { prags <- tcPrags poly_id (prag_fn poly_name) + ; return (tvs, poly_id, mono_id, prags) } + where + (tvs, poly_id) = case mb_sig of + Just sig -> (sig_tvs sig, sig_id sig) + Nothing -> (inferred_tvs, mkLocalId poly_name poly_ty) + where + poly_ty = mkForAllTys inferred_tvs + $ mkFunTys dict_tys + $ idType mono_id + +------------------------ +type TcPragFun = Name -> [LSig Name] + +mkPragFun :: [LSig Name] -> TcPragFun +mkPragFun sigs = \n -> lookupNameEnv env n `orElse` [] + where + prs = [(fromJust (sigName sig), sig) | sig <- sigs, isPragLSig sig] + env = foldl add emptyNameEnv prs + add env (n,p) = extendNameEnv_Acc (:) singleton env n p + +tcPrags :: Id -> [LSig Name] -> TcM [Prag] +tcPrags poly_id prags = mapM tc_prag prags + where + tc_prag (L loc prag) = setSrcSpan loc $ + addErrCtxt (pragSigCtxt prag) $ + tcPrag poly_id prag + +pragSigCtxt prag = hang (ptext SLIT("In the pragma")) 2 (ppr prag) + +tcPrag :: TcId -> Sig Name -> TcM Prag +tcPrag poly_id (SpecSig orig_name hs_ty) = tcSpecPrag poly_id hs_ty +tcPrag poly_id (SpecInstSig hs_ty) = tcSpecPrag poly_id hs_ty +tcPrag poly_id (InlineSig inl _ act) = return (InlinePrag inl act) + +tcSpecPrag :: TcId -> LHsType Name -> TcM Prag +tcSpecPrag poly_id hs_ty + = do { spec_ty <- tcHsSigType (FunSigCtxt (idName poly_id)) hs_ty + ; (co_fn, lie) <- getLIE (tcSub spec_ty (idType poly_id)) + ; extendLIEs lie + ; let const_dicts = map instToId lie + ; return (SpecPrag (co_fn <$> (HsVar poly_id)) spec_ty const_dicts) } + +-------------- -- If typechecking the binds fails, then return with each -- signature-less binder given type (forall a.a), to minimise -- subsequent error messages -recoveryCode mbind lookup_sig +recoveryCode binder_names sig_fn = do { traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names) - ; return (emptyLHsBinds, poly_ids) } + ; return ([], poly_ids) } where forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar) - binder_names = collectHsBindBinders mbind poly_ids = map mk_dummy binder_names - mk_dummy name = case lookup_sig name of + mk_dummy name = case sig_fn name of Just sig -> sig_id sig -- Signature Nothing -> mkLocalId name forall_a_a -- No signature -attachInlinePhase inline_phases bndr - = case lookupFM inline_phases (idName bndr) of - Just prag -> bndr `setInlinePragma` prag - Nothing -> bndr - -- Check that non-overloaded unlifted bindings are -- a) non-recursive, -- b) not top level, -- c) not a multiple-binding group (more or less implied by (a)) -checkUnliftedBinds top_lvl is_rec mbind - = checkTc (isNotTopLevel top_lvl) - (unliftedBindErr "Top-level" mbind) `thenM_` - checkTc (isNonRec is_rec) - (unliftedBindErr "Recursive" mbind) `thenM_` - checkTc (isSingletonBag mbind) - (unliftedBindErr "Multiple" mbind) +checkUnliftedBinds :: TopLevelFlag -> RecFlag + -> LHsBinds TcId -> [MonoBindInfo] -> TcM () +checkUnliftedBinds top_lvl is_rec mbind infos + = do { checkTc (isNotTopLevel top_lvl) + (unliftedBindErr "Top-level" mbind) + ; checkTc (isNonRec is_rec) + (unliftedBindErr "Recursive" mbind) + ; checkTc (isSingletonBag mbind) + (unliftedBindErr "Multiple" mbind) + ; mapM_ check_sig infos } + where + check_sig (_, Just sig, _) = checkTc (null (sig_tvs sig) && null (sig_theta sig)) + (badUnliftedSig sig) + check_sig other = return () \end{code} -Polymorphic recursion -~~~~~~~~~~~~~~~~~~~~~ -The game plan for polymorphic recursion in the code above is - - * Bind any variable for which we have a type signature - to an Id with a polymorphic type. Then when type-checking - the RHSs we'll make a full polymorphic call. - -This fine, but if you aren't a bit careful you end up with a horrendous -amount of partial application and (worse) a huge space leak. For example: - - f :: Eq a => [a] -> [a] - f xs = ...f... - -If we don't take care, after typechecking we get - - f = /\a -> \d::Eq a -> let f' = f a d - in - \ys:[a] -> ...f'... - -Notice the the stupid construction of (f a d), which is of course -identical to the function we're executing. In this case, the -polymorphic recursion isn't being used (but that's a very common case). -We'd prefer - - f = /\a -> \d::Eq a -> letrec - fm = \ys:[a] -> ...fm... - in - fm - -This can lead to a massive space leak, from the following top-level defn -(post-typechecking) - - ff :: [Int] -> [Int] - ff = f Int dEqInt - -Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but -f' is another thunk which evaluates to the same thing... and you end -up with a chain of identical values all hung onto by the CAF ff. - - ff = f Int dEqInt - - = let f' = f Int dEqInt in \ys. ...f'... - - = let f' = let f' = f Int dEqInt in \ys. ...f'... - in \ys. ...f'... - -Etc. -Solution: when typechecking the RHSs we always have in hand the -*monomorphic* Ids for each binding. So we just need to make sure that -if (Method f a d) shows up in the constraints emerging from (...f...) -we just use the monomorphic Id. We achieve this by adding monomorphic Ids -to the "givens" when simplifying constraints. That's what the "lies_avail" -is doing. - - %************************************************************************ %* * \subsection{tcMonoBind} %* * %************************************************************************ -@tcMonoBinds@ deals with a single @MonoBind@. +@tcMonoBinds@ deals with a perhaps-recursive group of HsBinds. The signatures have been dealt with already. \begin{code} -tcMonoBinds :: LHsBinds Name - -> TcSigFun -> RecFlag +tcMonoBinds :: [LHsBind Name] + -> TcSigFun + -> Bool -- True <=> either the binders are not mentioned + -- in their RHSs or they have type sigs -> TcM (LHsBinds TcId, [MonoBindInfo]) -tcMonoBinds binds lookup_sig is_rec - | isNonRec is_rec, -- Non-recursive, single function binding - [L b_loc (FunBind (L nm_loc name) inf matches)] <- bagToList binds, - Nothing <- lookup_sig name -- ...with no type signature +tcMonoBinds [L b_loc (FunBind (L nm_loc name) inf matches fvs)] + sig_fn -- Single function binding, + True -- binder isn't mentioned in RHS, + | Nothing <- sig_fn name -- ...with no type signature = -- In this very special case we infer the type of the -- right hand side first (it may have a higher-rank type) -- and *then* make the monomorphic Id for the LHS @@ -467,6 +499,7 @@ tcMonoBinds binds lookup_sig is_rec -- We want to infer a higher-rank type for f setSrcSpan b_loc $ do { (matches', rhs_ty) <- tcInfer (tcMatchesFun name matches) + -- Check for an unboxed tuple type -- f = (# True, False #) -- Zonk first just in case it's hidden inside a meta type variable @@ -475,13 +508,14 @@ tcMonoBinds binds lookup_sig is_rec ; zonked_rhs_ty <- zonkTcType rhs_ty ; checkTc (not (isUnboxedTupleType zonked_rhs_ty)) (unboxedTupleErr name zonked_rhs_ty) + ; mono_name <- newLocalName name ; let mono_id = mkLocalId mono_name zonked_rhs_ty - ; return (unitBag (L b_loc (FunBind (L nm_loc mono_id) inf matches')), + ; return (unitBag (L b_loc (FunBind (L nm_loc mono_id) inf matches' fvs)), [(name, Nothing, mono_id)]) } - | otherwise - = do { tc_binds <- mapBagM (wrapLocM (tcLhs lookup_sig)) binds +tcMonoBinds binds sig_fn non_rec + = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn)) binds -- Bring (a) the scoped type variables, and (b) the Ids, into scope for the RHSs -- For (a) it's ok to bring them all into scope at once, even @@ -495,9 +529,10 @@ tcMonoBinds binds lookup_sig is_rec ; binds' <- tcExtendTyVarEnv2 rhs_tvs $ tcExtendIdEnv2 rhs_id_env $ - traceTc (text "tcMonoBinds" <+> vcat [ppr n <+> ppr id <+> ppr (idType id) | (n,id) <- rhs_id_env]) `thenM_` - mapBagM (wrapLocM tcRhs) tc_binds - ; return (binds', mono_info) } + traceTc (text "tcMonoBinds" <+> vcat [ ppr n <+> ppr id <+> ppr (idType id) + | (n,id) <- rhs_id_env]) `thenM_` + mapM (wrapLocM tcRhs) tc_binds + ; return (listToBag binds', mono_info) } where mk (name, Just sig, _) = (name, sig_id sig) -- Use the type sig if there is one mk (name, Nothing, mono_id) = (name, mono_id) -- otherwise use a monomorphic version @@ -533,8 +568,8 @@ getMonoType :: MonoBindInfo -> TcTauType getMonoType (_,_,mono_id) = idType mono_id tcLhs :: TcSigFun -> HsBind Name -> TcM TcMonoBind -tcLhs lookup_sig (FunBind (L nm_loc name) inf matches) - = do { let mb_sig = lookup_sig name +tcLhs sig_fn (FunBind (L nm_loc name) inf matches _) + = do { let mb_sig = sig_fn name ; mono_name <- newLocalName name ; mono_ty <- mk_mono_ty mb_sig ; let mono_id = mkLocalId mono_name mono_ty @@ -543,8 +578,8 @@ tcLhs lookup_sig (FunBind (L nm_loc name) inf matches) mk_mono_ty (Just sig) = return (sig_tau sig) mk_mono_ty Nothing = newTyFlexiVarTy argTypeKind -tcLhs lookup_sig bind@(PatBind pat grhss _) - = do { let tc_pat exp_ty = tcPat (LetPat lookup_sig) pat exp_ty lookup_infos +tcLhs sig_fn bind@(PatBind pat grhss _ _) + = do { let tc_pat exp_ty = tcPat (LetPat sig_fn) pat exp_ty lookup_infos ; ((pat', ex_tvs, infos), pat_ty) <- addErrCtxt (patMonoBindsCtxt pat grhss) (tcInfer tc_pat) @@ -560,10 +595,10 @@ tcLhs lookup_sig bind@(PatBind pat grhss _) -- names, which the pattern has brought into scope. lookup_infos :: TcM [MonoBindInfo] lookup_infos = do { mono_ids <- tcLookupLocalIds names - ; return [ (name, lookup_sig name, mono_id) + ; return [ (name, sig_fn name, mono_id) | (name, mono_id) <- names `zip` mono_ids] } -tcLhs lookup_sig other_bind = pprPanic "tcLhs" (ppr other_bind) +tcLhs sig_fn other_bind = pprPanic "tcLhs" (ppr other_bind) -- AbsBind, VarBind impossible ------------------- @@ -571,18 +606,18 @@ tcRhs :: TcMonoBind -> TcM (HsBind TcId) tcRhs (TcFunBind info fun'@(L _ mono_id) inf matches) = do { matches' <- tcMatchesFun (idName mono_id) matches (Check (idType mono_id)) - ; return (FunBind fun' inf matches') } + ; return (FunBind fun' inf matches' placeHolderNames) } tcRhs bind@(TcPatBind _ pat' grhss pat_ty) = do { grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $ tcGRHSsPat grhss (Check pat_ty) - ; return (PatBind pat' grhss' pat_ty) } + ; return (PatBind pat' grhss' pat_ty placeHolderNames) } --------------------- -getMonoBindInfo :: Bag (Located TcMonoBind) -> [MonoBindInfo] +getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo] getMonoBindInfo tc_binds - = foldrBag (get_info . unLoc) [] tc_binds + = foldr (get_info . unLoc) [] tc_binds where get_info (TcFunBind info _ _ _) rest = info : rest get_info (TcPatBind infos _ _ _) rest = infos ++ rest @@ -591,68 +626,23 @@ getMonoBindInfo tc_binds %************************************************************************ %* * -\subsection{getTyVarsToGen} + Generalisation %* * %************************************************************************ -Type signatures are tricky. See Note [Signature skolems] in TcType - \begin{code} -tcTySigs :: [LSig Name] -> TcM [TcSigInfo] --- The trick here is that all the signatures should have the same --- context, and we want to share type variables for that context, so that --- all the right hand sides agree a common vocabulary for their type --- constraints -tcTySigs [] = return [] - -tcTySigs sigs - = do { (tc_sig1 : tc_sigs) <- mappM tcTySig sigs - ; mapM (check_ctxt tc_sig1) tc_sigs - ; return (tc_sig1 : tc_sigs) } - where - -- Check tha all the signature contexts are the same - -- The type signatures on a mutually-recursive group of definitions - -- must all have the same context (or none). - -- - -- We unify them because, with polymorphic recursion, their types - -- might not otherwise be related. This is a rather subtle issue. - check_ctxt :: TcSigInfo -> TcSigInfo -> TcM () - check_ctxt sig1@(TcSigInfo { sig_theta = theta1 }) sig@(TcSigInfo { sig_theta = theta }) - = setSrcSpan (instLocSrcSpan (sig_loc sig)) $ - addErrCtxt (sigContextsCtxt sig1 sig) $ - unifyTheta theta1 theta - - -tcTySig :: LSig Name -> TcM TcSigInfo -tcTySig (L span (Sig (L _ name) ty)) - = setSrcSpan span $ - do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty - ; (tvs, theta, tau) <- tcInstSigType name scoped_names sigma_ty - ; loc <- getInstLoc (SigOrigin (SigSkol name)) - ; return (TcSigInfo { sig_id = mkLocalId name sigma_ty, - sig_tvs = tvs, sig_theta = theta, sig_tau = tau, - sig_scoped = scoped_names, sig_loc = loc }) } - where - -- The scoped names are the ones explicitly mentioned - -- in the HsForAll. (There may be more in sigma_ty, because - -- of nested type synonyms. See Note [Scoped] with TcSigInfo.) - scoped_names = case ty of - L _ (HsForAllTy Explicit tvs _ _) -> hsLTyVarNames tvs - other -> [] -\end{code} - -\begin{code} -generalise :: TopLevelFlag -> Bool -> [MonoBindInfo] -> [TcSigInfo] -> [Inst] +generalise :: TopLevelFlag -> Bool + -> [MonoBindInfo] -> [Inst] -> TcM ([TcTyVar], TcDictBinds, [TcId]) -generalise top_lvl is_unrestricted mono_infos sigs lie_req +generalise top_lvl is_unrestricted mono_infos lie_req | not is_unrestricted -- RESTRICTED CASE = -- Check signature contexts are empty do { checkTc (all is_mono_sig sigs) - (restrictedBindCtxtErr bndr_names) + (restrictedBindCtxtErr bndrs) -- Now simplify with exactly that set of tyvars -- We have to squash those Methods - ; (qtvs, binds) <- tcSimplifyRestricted doc top_lvl bndr_names + ; (qtvs, binds) <- tcSimplifyRestricted doc top_lvl bndrs tau_tvs lie_req -- Check that signature type variables are OK @@ -664,11 +654,10 @@ generalise top_lvl is_unrestricted mono_infos sigs lie_req = tcSimplifyInfer doc tau_tvs lie_req | otherwise -- UNRESTRICTED CASE, WITH TYPE SIGS - = do { let sig1 = head sigs - ; sig_lie <- newDictsAtLoc (sig_loc sig1) (sig_theta sig1) + = do { sig_lie <- unifyCtxts sigs -- sigs is non-empty ; let -- The "sig_avails" is the stuff available. We get that from -- the context of the type signature, BUT ALSO the lie_avail - -- so that polymorphic recursion works right (see comments at end of fn) + -- so that polymorphic recursion works right (see Note [Polymorphic recursion]) local_meths = [mkMethInst sig mono_id | (_, Just sig, mono_id) <- mono_infos] sig_avails = sig_lie ++ local_meths @@ -680,17 +669,41 @@ generalise top_lvl is_unrestricted mono_infos sigs lie_req ; final_qtvs <- checkSigsTyVars forall_tvs sigs ; returnM (final_qtvs, dict_binds, map instToId sig_lie) } - where - bndr_names = bndrNames mono_infos + bndrs = bndrNames mono_infos + sigs = [sig | (_, Just sig, _) <- mono_infos] tau_tvs = foldr (unionVarSet . tyVarsOfType . getMonoType) emptyVarSet mono_infos is_mono_sig sig = null (sig_theta sig) - doc = ptext SLIT("type signature(s) for") <+> pprBinders bndr_names + doc = ptext SLIT("type signature(s) for") <+> pprBinders bndrs mkMethInst (TcSigInfo { sig_id = poly_id, sig_tvs = tvs, sig_theta = theta, sig_tau = tau, sig_loc = loc }) mono_id = Method mono_id poly_id (mkTyVarTys tvs) theta tau loc + +-- Check that all the signature contexts are the same +-- The type signatures on a mutually-recursive group of definitions +-- must all have the same context (or none). +-- +-- The trick here is that all the signatures should have the same +-- context, and we want to share type variables for that context, so that +-- all the right hand sides agree a common vocabulary for their type +-- constraints +-- +-- We unify them because, with polymorphic recursion, their types +-- might not otherwise be related. This is a rather subtle issue. +unifyCtxts :: [TcSigInfo] -> TcM [Inst] +unifyCtxts (sig1 : sigs) -- Argument is always non-empty + = do { mapM unify_ctxt sigs + ; newDictsAtLoc (sig_loc sig1) (sig_theta sig1) } + where + theta1 = sig_theta sig1 + unify_ctxt :: TcSigInfo -> TcM () + unify_ctxt sig@(TcSigInfo { sig_theta = theta }) + = setSrcSpan (instLocSrcSpan (sig_loc sig)) $ + addErrCtxt (sigContextsCtxt sig1 sig) $ + unifyTheta theta1 theta + checkSigsTyVars :: [TcTyVar] -> [TcSigInfo] -> TcM [TcTyVar] checkSigsTyVars qtvs sigs = do { gbl_tvs <- tcGetGlobalTyVars @@ -795,104 +808,111 @@ So we are careful, and do a complete simplification just to find the constrained tyvars. We don't use any of the results, except to find which tyvars are constrained. -\begin{code} -isUnRestrictedGroup :: LHsBinds Name -> [TcSigInfo] -> TcM Bool -isUnRestrictedGroup binds sigs - = do { mono_restriction <- doptM Opt_MonomorphismRestriction - ; return (not mono_restriction || all_unrestricted) } - where - all_unrestricted = all (unrestricted . unLoc) (bagToList binds) - tysig_names = map (idName . sig_id) sigs +Note [Polymorphic recursion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The game plan for polymorphic recursion in the code above is - unrestricted (PatBind other _ _) = False - unrestricted (VarBind v _) = v `is_elem` tysig_names - unrestricted (FunBind v _ matches) = unrestricted_match matches - || unLoc v `is_elem` tysig_names + * Bind any variable for which we have a type signature + to an Id with a polymorphic type. Then when type-checking + the RHSs we'll make a full polymorphic call. - unrestricted_match (MatchGroup (L _ (Match [] _ _) : _) _) = False - -- No args => like a pattern binding - unrestricted_match other = True - -- Some args => a function binding +This fine, but if you aren't a bit careful you end up with a horrendous +amount of partial application and (worse) a huge space leak. For example: -is_elem v vs = isIn "isUnResMono" v vs -\end{code} + f :: Eq a => [a] -> [a] + f xs = ...f... + +If we don't take care, after typechecking we get + + f = /\a -> \d::Eq a -> let f' = f a d + in + \ys:[a] -> ...f'... + +Notice the the stupid construction of (f a d), which is of course +identical to the function we're executing. In this case, the +polymorphic recursion isn't being used (but that's a very common case). +We'd prefer + + f = /\a -> \d::Eq a -> letrec + fm = \ys:[a] -> ...fm... + in + fm + +This can lead to a massive space leak, from the following top-level defn +(post-typechecking) + + ff :: [Int] -> [Int] + ff = f Int dEqInt + +Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but +f' is another thunk which evaluates to the same thing... and you end +up with a chain of identical values all hung onto by the CAF ff. + + ff = f Int dEqInt + + = let f' = f Int dEqInt in \ys. ...f'... + + = let f' = let f' = f Int dEqInt in \ys. ...f'... + in \ys. ...f'... + +Etc. +Solution: when typechecking the RHSs we always have in hand the +*monomorphic* Ids for each binding. So we just need to make sure that +if (Method f a d) shows up in the constraints emerging from (...f...) +we just use the monomorphic Id. We achieve this by adding monomorphic Ids +to the "givens" when simplifying constraints. That's what the "lies_avail" +is doing. %************************************************************************ %* * -\subsection{SPECIALIZE pragmas} + Signatures %* * %************************************************************************ -@tcSpecSigs@ munches up the specialisation "signatures" that arise through *user* -pragmas. It is convenient for them to appear in the @[RenamedSig]@ -part of a binding because then the same machinery can be used for -moving them into place as is done for type signatures. - -They look like this: - -\begin{verbatim} - f :: Ord a => [a] -> b -> b - {-# SPECIALIZE f :: [Int] -> b -> b #-} -\end{verbatim} - -For this we generate: -\begin{verbatim} - f* = /\ b -> let d1 = ... - in f Int b d1 -\end{verbatim} - -where f* is a SpecPragmaId. The **sole** purpose of SpecPragmaIds is to -retain a right-hand-side that the simplifier will otherwise discard as -dead code... the simplifier has a flag that tells it not to discard -SpecPragmaId bindings. - -In this case the f* retains a call-instance of the overloaded -function, f, (including appropriate dictionaries) so that the -specialiser will subsequently discover that there's a call of @f@ at -Int, and will create a specialisation for @f@. After that, the -binding for @f*@ can be discarded. - -We used to have a form - {-# SPECIALISE f :: = g #-} -which promised that g implemented f at , but we do that with -a RULE now: - {-# RULES (f::) = g #-} +Type signatures are tricky. See Note [Signature skolems] in TcType \begin{code} -tcSpecSigs :: [LSig Name] -> TcM (LHsBinds TcId) -tcSpecSigs (L loc (SpecSig (L nm_loc name) poly_ty) : sigs) - = -- SPECIALISE f :: forall b. theta => tau = g - setSrcSpan loc $ - addErrCtxt (valSpecSigCtxt name poly_ty) $ - - -- Get and instantiate its alleged specialised type - tcHsSigType (FunSigCtxt name) poly_ty `thenM` \ sig_ty -> - - -- Check that f has a more general type, and build a RHS for - -- the spec-pragma-id at the same time - getLIE (tcCheckSigma (L nm_loc (HsVar name)) sig_ty) `thenM` \ (spec_expr, spec_lie) -> - - -- Squeeze out any Methods (see comments with tcSimplifyToDicts) - tcSimplifyToDicts spec_lie `thenM` \ spec_binds -> - - -- Just specialise "f" by building a SpecPragmaId binding - -- It is the thing that makes sure we don't prematurely - -- dead-code-eliminate the binding we are really interested in. - newLocalName name `thenM` \ spec_name -> - let - spec_bind = VarBind (mkSpecPragmaId spec_name sig_ty) - (mkHsLet spec_binds spec_expr) - in +tcTySigs :: [LSig Name] -> TcM [TcSigInfo] +tcTySigs sigs = mappM tcTySig (filter isVanillaLSig sigs) - -- Do the rest and combine - tcSpecSigs sigs `thenM` \ binds_rest -> - returnM (binds_rest `snocBag` L loc spec_bind) +tcTySig :: LSig Name -> TcM TcSigInfo +tcTySig (L span (Sig (L _ name) ty)) + = setSrcSpan span $ + do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty + ; (tvs, theta, tau) <- tcInstSigType name scoped_names sigma_ty + ; loc <- getInstLoc (SigOrigin (SigSkol name)) + ; return (TcSigInfo { sig_id = mkLocalId name sigma_ty, + sig_tvs = tvs, sig_theta = theta, sig_tau = tau, + sig_scoped = scoped_names, sig_loc = loc }) } + where + -- The scoped names are the ones explicitly mentioned + -- in the HsForAll. (There may be more in sigma_ty, because + -- of nested type synonyms. See Note [Scoped] with TcSigInfo.) + scoped_names = case ty of + L _ (HsForAllTy Explicit tvs _ _) -> hsLTyVarNames tvs + other -> [] -tcSpecSigs (other_sig : sigs) = tcSpecSigs sigs -tcSpecSigs [] = returnM emptyLHsBinds +isUnRestrictedGroup :: [LHsBind Name] -> TcSigFun -> TcM Bool +isUnRestrictedGroup binds sig_fn + = do { mono_restriction <- doptM Opt_MonomorphismRestriction + ; return (not mono_restriction || all_unrestricted) } + where + all_unrestricted = all (unrestricted . unLoc) binds + has_sig n = isJust (sig_fn n) + + unrestricted (PatBind other _ _ _) = False + unrestricted (VarBind v _) = has_sig v + unrestricted (FunBind v _ matches _) = unrestricted_match matches + || has_sig (unLoc v) + + unrestricted_match (MatchGroup (L _ (Match [] _ _) : _) _) = False + -- No args => like a pattern binding + unrestricted_match other = True + -- Some args => a function binding \end{code} + %************************************************************************ %* * \subsection[TcBinds-errors]{Error contexts and messages} @@ -907,11 +927,6 @@ patMonoBindsCtxt pat grhss = hang (ptext SLIT("In a pattern binding:")) 4 (pprPatBind pat grhss) ----------------------------------------------- -valSpecSigCtxt v ty - = sep [ptext SLIT("In a SPECIALIZE pragma for a value:"), - nest 4 (ppr v <+> dcolon <+> ppr ty)] - ------------------------------------------------ sigContextsCtxt sig1 sig2 = vcat [ptext SLIT("When matching the contexts of the signatures for"), nest 2 (vcat [ppr id1 <+> dcolon <+> ppr (idType id1), @@ -927,6 +942,10 @@ unliftedBindErr flavour mbind = hang (text flavour <+> ptext SLIT("bindings for unlifted types aren't allowed:")) 4 (ppr mbind) +badUnliftedSig sig + = hang (ptext SLIT("Illegal polymorphic signature in an unlifted binding")) + 4 (ppr sig) + ----------------------------------------------- unboxedTupleErr name ty = hang (ptext SLIT("Illegal binding of unboxed tuple")) diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index d5ab178..22dc9b2 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -13,21 +13,20 @@ module TcClassDcl ( tcClassSigs, tcClassDecl2, #include "HsVersions.h" import HsSyn -import BasicTypes ( RecFlag(..) ) import RnHsSyn ( maybeGenericMatch, extractHsTyVars ) import RnExpr ( rnLExpr ) import RnEnv ( lookupTopBndrRn, lookupImportedName ) import Inst ( instToId, newDicts, newDictsAtLoc, newMethod, getOverlapFlag ) import InstEnv ( mkLocalInstance ) -import TcEnv ( tcLookupLocatedClass, tcExtendIdEnv2, +import TcEnv ( tcLookupLocatedClass, tcExtendTyVarEnv, InstInfo(..), pprInstInfoDetails, simpleInstInfoTyCon, simpleInstInfoTy, InstBindings(..), newDFunName ) -import TcBinds ( tcMonoBinds, tcSpecSigs ) +import TcBinds ( TcPragFun, tcMonoBinds, tcPrags, mkPragFun ) import TcHsType ( TcSigInfo(..), tcHsKindedType, tcHsSigType ) -import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns ) +import TcSimplify ( tcSimplifyCheck ) import TcUnify ( checkSigTyVars, sigCtxt ) import TcMType ( tcSkolSigTyVars, UserTypeCtxt( GenPatCtxt ), tcSkolType ) import TcType ( Type, SkolemInfo(ClsSkol, InstSkol, SigSkol), @@ -44,10 +43,10 @@ import Class ( classTyVars, classBigSig, import TyCon ( TyCon, tyConName, tyConHasGenerics ) import Type ( substTyWith ) import MkId ( mkDefaultMethodId, mkDictFunId ) -import Id ( Id, idType, idName, mkUserLocal, setInlinePragma ) +import Id ( Id, idType, idName, mkUserLocal ) import Name ( Name, NamedThing(..) ) import NameEnv ( NameEnv, lookupNameEnv, mkNameEnv ) -import NameSet ( emptyNameSet, unitNameSet, nameSetToList ) +import NameSet ( nameSetToList ) import OccName ( reportIfUnused, mkDefaultMethodOcc ) import RdrName ( RdrName, mkDerivedRdrName ) import Outputable @@ -132,7 +131,7 @@ checkDefaultBinds clas ops binds = do dm_infos <- mapM (addLocM (checkDefaultBind clas ops)) (bagToList binds) return (mkNameEnv dm_infos) -checkDefaultBind clas ops (FunBind (L _ op) _ (MatchGroup matches _)) +checkDefaultBind clas ops (FunBind (L _ op) _ (MatchGroup matches _) _) = do { -- Check that the op is from this class checkTc (op `elem` ops) (badMethodErr clas op) @@ -246,8 +245,8 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, -- default methods. Better to make separate AbsBinds for each let (tyvars, _, _, op_items) = classBigSig clas - prags = filter isPragLSig sigs - tc_dm = tcDefMeth clas tyvars default_binds prags + prag_fn = mkPragFun sigs + tc_dm = tcDefMeth clas tyvars default_binds prag_fn dm_sel_ids = [sel_id | (sel_id, DefMeth) <- op_items] -- Generate code for polymorphic default methods only @@ -260,7 +259,7 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, mapAndUnzipM tc_dm dm_sel_ids `thenM` \ (defm_binds, dm_ids_s) -> returnM (listToBag defm_binds, concat dm_ids_s) -tcDefMeth clas tyvars binds_in prags sel_id +tcDefMeth clas tyvars binds_in prag_fn sel_id = do { dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_id) ; let rigid_info = ClsSkol clas clas_tyvars = tcSkolSigTyVars rigid_info tyvars @@ -273,7 +272,7 @@ tcDefMeth clas tyvars binds_in prags sel_id ; (_, meth_info) <- mkMethodBind origin clas inst_tys binds_in (sel_id, DefMeth) ; [this_dict] <- newDicts origin theta ; (defm_bind, insts_needed) <- getLIE (tcMethodBind clas_tyvars theta - [this_dict] prags meth_info) + [this_dict] prag_fn meth_info) ; addErrCtxt (defltMethCtxt clas) $ do @@ -292,8 +291,8 @@ tcDefMeth clas tyvars binds_in prags sel_id full_bind = AbsBinds clas_tyvars [instToId this_dict] - [(clas_tyvars, local_dm_id, dm_inst_id)] - emptyNameSet -- No inlines (yet) + [(clas_tyvars, local_dm_id, dm_inst_id, [])] + -- No inlines (yet) (dict_binds `unionBags` defm_bind) ; returnM (noLoc full_bind, [local_dm_id]) }} @@ -328,11 +327,11 @@ tcMethodBind -> TcThetaType -- Available theta; it's just used for the error message -> [Inst] -- Available from context, used to simplify constraints -- from the method body - -> [LSig Name] -- Pragmas (e.g. inline pragmas) + -> TcPragFun -- Pragmas (e.g. inline pragmas) -> MethodSpec -- Details of this method -> TcM (LHsBinds Id) -tcMethodBind inst_tyvars inst_theta avail_insts prags +tcMethodBind inst_tyvars inst_theta avail_insts prag_fn (sel_id, meth_id, meth_bind) = recoverM (returnM emptyLHsBinds) $ -- If anything fails, recover returning no bindings. @@ -357,8 +356,8 @@ tcMethodBind inst_tyvars inst_theta avail_insts prags tcExtendTyVarEnv inst_tyvars ( addErrCtxt (methodCtxt sel_id) $ getLIE $ - tcMonoBinds (unitBag meth_bind) lookup_sig NonRecursive - ) `thenM` \ ((meth_bind, mono_bind_infos), meth_lie) -> + tcMonoBinds [meth_bind] lookup_sig True + ) `thenM` \ ((meth_bind, mono_bind_infos), meth_lie) -> -- Now do context reduction. We simplify wrt both the local tyvars -- and the ones of the class/instance decl, so that there is @@ -374,6 +373,7 @@ tcMethodBind inst_tyvars inst_theta avail_insts prags meth_tvs = sig_tvs meth_sig all_tyvars = meth_tvs ++ inst_tyvars all_insts = avail_insts ++ meth_dicts + sel_name = idName sel_id in tcSimplifyCheck (ptext SLIT("class or instance method") <+> quotes (ppr sel_id)) @@ -381,43 +381,15 @@ tcMethodBind inst_tyvars inst_theta avail_insts prags checkSigTyVars all_tyvars `thenM_` + tcPrags meth_id (prag_fn sel_name) `thenM` \ prags -> let - sel_name = idName sel_id - inline_prags = [ (is_inl, phase) - | L _ (InlineSig is_inl (L _ name) phase) <- prags, - name == sel_name ] - spec_prags = [ prag - | prag@(L _ (SpecSig (L _ name) _)) <- prags, - name == sel_name] - - -- Attach inline pragmas as appropriate - (final_meth_id, inlines) - | ((is_inline, phase) : _) <- inline_prags - = (meth_id `setInlinePragma` phase, - if is_inline then unitNameSet (idName meth_id) else emptyNameSet) - | otherwise - = (meth_id, emptyNameSet) - [(_,_,local_meth_id)] = mono_bind_infos poly_meth_bind = noLoc $ AbsBinds meth_tvs (map instToId meth_dicts) - [(meth_tvs, final_meth_id, local_meth_id)] - inlines + [(meth_tvs, meth_id, local_meth_id, prags)] (lie_binds `unionBags` meth_bind) - in - -- Deal with specialisation pragmas - -- The sel_name is what appears in the pragma - tcExtendIdEnv2 [(sel_name, final_meth_id)] ( - getLIE (tcSpecSigs spec_prags) `thenM` \ (spec_binds1, prag_lie) -> - - -- The prag_lie for a SPECIALISE pragma will mention the function itself, - -- so we have to simplify them away right now lest they float outwards! - bindInstsOfLocalFuns prag_lie [final_meth_id] `thenM` \ spec_binds2 -> - returnM (spec_binds1 `unionBags` spec_binds2) - ) `thenM` \ spec_binds -> - - returnM (poly_meth_bind `consBag` spec_binds) + returnM (unitBag poly_meth_bind) mkMethodBind :: InstOrigin @@ -443,7 +415,8 @@ mkMethodBind origin clas inst_tys meth_binds (sel_id, dm_info) mkDefMethRhs origin clas inst_tys sel_id loc dm_info `thenM` \ rhs -> -- Not infix decl returnM (noLoc $ FunBind (noLoc meth_name) False - (mkMatchGroup [mkSimpleMatch [] rhs])) + (mkMatchGroup [mkSimpleMatch [] rhs]) + placeHolderNames) ) `thenM` \ meth_bind -> returnM (mb_inst, (sel_id, meth_id, meth_bind)) @@ -582,8 +555,8 @@ isInstDecl (SigOrigin (ClsSkol _)) = False find_bind sel_name meth_name binds = foldlBag seqMaybe Nothing (mapBag f binds) where - f (L loc1 (FunBind (L loc2 op_name) fix matches)) | op_name == sel_name - = Just (L loc1 (FunBind (L loc2 meth_name) fix matches)) + f (L loc1 (FunBind (L loc2 op_name) fix matches fvs)) | op_name == sel_name + = Just (L loc1 (FunBind (L loc2 meth_name) fix matches fvs)) f _other = Nothing \end{code} @@ -683,10 +656,10 @@ getGenericBinds :: LHsBinds Name -> [(HsType Name, LHsBind Name)] -- them in finite map indexed by the type parameter in the definition. getGenericBinds binds = concat (map getGenericBind (bagToList binds)) -getGenericBind (L loc (FunBind id infixop (MatchGroup matches ty))) +getGenericBind (L loc (FunBind id infixop (MatchGroup matches ty) fvs)) = groupWith wrap (mapCatMaybes maybeGenericMatch matches) where - wrap ms = L loc (FunBind id infixop (MatchGroup ms ty)) + wrap ms = L loc (FunBind id infixop (MatchGroup ms ty) fvs) getGenericBind _ = [] diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 36b980f..c7526a4 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -206,10 +206,10 @@ And then translate it to: \begin{code} tcDeriving :: [LTyClDecl Name] -- All type constructors -> TcM ([InstInfo], -- The generated "instance decls" - [HsBindGroup Name]) -- Extra generated top-level bindings + HsValBinds Name) -- Extra generated top-level bindings tcDeriving tycl_decls - = recoverM (returnM ([], [])) $ + = recoverM (returnM ([], emptyValBindsIn)) $ do { -- Fish the "deriving"-related information out of the TcEnv -- and make the necessary "equations". overlap_flag <- getOverlapFlag @@ -227,7 +227,7 @@ tcDeriving tycl_decls -- don't generate any derived bindings ; is_boot <- tcIsHsBoot ; if is_boot then - return (inst_info, []) + return (inst_info, emptyValBindsIn) else do { @@ -239,11 +239,11 @@ tcDeriving tycl_decls -- which is used in the generic binds ; rn_binds <- discardWarnings $ setOptM Opt_GlasgowExts $ do - { (rn_deriv, _dus1) <- rnTopBinds deriv_binds [] - ; (rn_gen, dus_gen) <- rnTopBinds gen_binds [] + { (rn_deriv, _dus1) <- rnTopBinds (ValBindsIn deriv_binds []) + ; (rn_gen, dus_gen) <- rnTopBinds (ValBindsIn gen_binds []) ; keepAliveSetTc (duDefs dus_gen) -- Mark these guys to -- be kept alive - ; return (rn_deriv ++ rn_gen) } + ; return (rn_deriv `plusHsValBinds` rn_gen) } ; dflags <- getDOpts @@ -253,9 +253,9 @@ tcDeriving tycl_decls ; returnM (inst_info, rn_binds) }} where - ddump_deriving :: [InstInfo] -> [HsBindGroup Name] -> SDoc + ddump_deriving :: [InstInfo] -> HsValBinds Name -> SDoc ddump_deriving inst_infos extra_binds - = vcat (map pprInstInfoDetails inst_infos) $$ vcat (map ppr extra_binds) + = vcat (map pprInstInfoDetails inst_infos) $$ ppr extra_binds ----------------------------------------- deriveOrdinaryStuff overlap_flag [] -- Short cut diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 8657a85..06b79f7 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -64,7 +64,7 @@ import InstEnv ( Instance, DFunId, instanceDFunId, instanceHead ) import DataCon ( DataCon ) import TyCon ( TyCon ) import Class ( Class ) -import Name ( Name, NamedThing(..), getSrcLoc, mkInternalName, nameIsLocalOrFrom ) +import Name ( Name, NamedThing(..), getSrcLoc, nameIsLocalOrFrom ) import NameEnv import OccName ( mkDFunOcc, occNameString ) import HscTypes ( extendTypeEnvList, lookupType, @@ -486,40 +486,6 @@ tcMetaTy tc_name %************************************************************************ %* * -\subsection{Making new Ids} -%* * -%************************************************************************ - -Constructing new Ids - -\begin{code} -newLocalName :: Name -> TcM Name -newLocalName name -- Make a clone - = newUnique `thenM` \ uniq -> - returnM (mkInternalName uniq (getOccName name) (getSrcLoc name)) -\end{code} - -Make a name for the dict fun for an instance decl. It's an *external* -name, like otber top-level names, and hence must be made with newGlobalBinder. - -\begin{code} -newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name -newDFunName clas (ty:_) loc - = do { index <- nextDFunIndex - ; is_boot <- tcIsHsBoot - ; mod <- getModule - ; let info_string = occNameString (getOccName clas) ++ - occNameString (getDFunTyKey ty) - dfun_occ = mkDFunOcc info_string is_boot index - - ; newGlobalBinder mod dfun_occ Nothing loc } - -newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc) -\end{code} - - -%************************************************************************ -%* * \subsection{The InstInfo type} %* * %************************************************************************ @@ -576,6 +542,24 @@ simpleInstInfoTyCon :: InstInfo -> TyCon simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst) \end{code} +Make a name for the dict fun for an instance decl. It's an *external* +name, like otber top-level names, and hence must be made with newGlobalBinder. + +\begin{code} +newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name +newDFunName clas (ty:_) loc + = do { index <- nextDFunIndex + ; is_boot <- tcIsHsBoot + ; mod <- getModule + ; let info_string = occNameString (getOccName clas) ++ + occNameString (getDFunTyKey ty) + dfun_occ = mkDFunOcc info_string is_boot index + + ; newGlobalBinder mod dfun_occ Nothing loc } + +newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc) +\end{code} + %************************************************************************ %* * diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index ebe95e4..406ca02 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -31,7 +31,7 @@ import TcUnify ( Expected(..), tcInfer, zapExpectedType, zapExpectedTo, import BasicTypes ( isMarkedStrict ) import Inst ( tcOverloadedLit, newMethodFromName, newIPDict, newDicts, newMethodWithGivenTy, tcInstStupidTheta, tcInstCall ) -import TcBinds ( tcBindsAndThen ) +import TcBinds ( tcLocalBinds ) import TcEnv ( tcLookup, tcLookupId, tcLookupDataCon, tcLookupGlobalId ) @@ -270,13 +270,10 @@ tcExpr in_expr@(OpApp arg1 op fix arg2) res_ty \end{code} \begin{code} -tcExpr (HsLet binds (L loc expr)) res_ty - = tcBindsAndThen - glue - binds -- Bindings to check - (setSrcSpan loc $ tcExpr expr res_ty) - where - glue bind expr = HsLet [bind] (L loc expr) +tcExpr (HsLet binds expr) res_ty + = do { (binds', expr') <- tcLocalBinds binds $ + tcMonoExpr expr res_ty + ; return (HsLet binds' expr') } tcExpr in_expr@(HsCase scrut matches) exp_ty = -- We used to typecheck the case alternatives first. diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index d10e3c0..ec51813 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -9,9 +9,9 @@ checker. \begin{code} module TcHsSyn ( mkHsTyApp, mkHsDictApp, mkHsConApp, - mkHsTyLam, mkHsDictLam, mkHsLet, mkHsApp, + mkHsTyLam, mkHsDictLam, mkHsDictLet, mkHsApp, hsLitType, hsPatType, mkHsAppTy, mkSimpleHsAlt, - nlHsIntLit, glueBindsOnGRHSs, + nlHsIntLit, -- Coercions @@ -252,30 +252,40 @@ zonkTopDecls binds rules fords ; return (zonkEnvIds env, binds', fords', rules') } --------------------------------------------- -zonkGroup :: ZonkEnv -> HsBindGroup TcId -> TcM (ZonkEnv, HsBindGroup Id) -zonkGroup env (HsBindGroup bs sigs is_rec) - = ASSERT( null sigs ) - do { (env1, bs') <- zonkRecMonoBinds env bs - ; return (env1, HsBindGroup bs' [] is_rec) } - -zonkGroup env (HsIPBinds binds) +zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id) +zonkLocalBinds env EmptyLocalBinds + = return (env, EmptyLocalBinds) + +zonkLocalBinds env (HsValBinds binds) + = do { (env1, new_binds) <- zonkValBinds env binds + ; return (env1, HsValBinds new_binds) } + +zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) = mappM (wrapLocM zonk_ip_bind) binds `thenM` \ new_binds -> let env1 = extendZonkEnv env [ipNameName n | L _ (IPBind n _) <- new_binds] in - returnM (env1, HsIPBinds new_binds) + zonkRecMonoBinds env1 dict_binds `thenM` \ (env2, new_dict_binds) -> + returnM (env2, HsIPBinds (IPBinds new_binds new_dict_binds)) where zonk_ip_bind (IPBind n e) = mapIPNameTc (zonkIdBndr env) n `thenM` \ n' -> zonkLExpr env e `thenM` \ e' -> returnM (IPBind n' e') + --------------------------------------------- -zonkNestedBinds :: ZonkEnv -> [HsBindGroup TcId] -> TcM (ZonkEnv, [HsBindGroup Id]) -zonkNestedBinds env [] = return (env, []) -zonkNestedBinds env (b:bs) = do { (env1, b') <- zonkGroup env b - ; (env2, bs') <- zonkNestedBinds env1 bs - ; return (env2, b':bs') } +zonkValBinds :: ZonkEnv -> HsValBinds TcId -> TcM (ZonkEnv, HsValBinds Id) +zonkValBinds env bs@(ValBindsIn _ _) + = panic "zonkValBinds" -- Not in typechecker output +zonkValBinds env (ValBindsOut binds) + = do { (env1, new_binds) <- go env binds + ; return (env1, ValBindsOut new_binds) } + where + go env [] = return (env, []) + go env ((r,b):bs) = do { (env1, b') <- zonkRecMonoBinds env b + ; (env2, bs') <- go env1 bs + ; return (env2, (r,b'):bs') } --------------------------------------------- zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id) @@ -285,41 +295,42 @@ zonkRecMonoBinds env binds ; binds' <- zonkMonoBinds env1 binds ; return (env1, binds') }) +--------------------------------------------- zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id) zonkMonoBinds env binds = mapBagM (wrapLocM (zonk_bind env)) binds zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id) -zonk_bind env (PatBind pat grhss ty) +zonk_bind env (PatBind pat grhss ty fvs) = do { (_env, new_pat) <- zonkPat env pat -- Env already extended ; new_grhss <- zonkGRHSs env grhss ; new_ty <- zonkTcTypeToType env ty - ; return (PatBind new_pat new_grhss new_ty) } + ; return (PatBind new_pat new_grhss new_ty fvs) } zonk_bind env (VarBind var expr) = zonkIdBndr env var `thenM` \ new_var -> zonkLExpr env expr `thenM` \ new_expr -> returnM (VarBind new_var new_expr) -zonk_bind env (FunBind var inf ms) +zonk_bind env (FunBind var inf ms fvs) = wrapLocM (zonkIdBndr env) var `thenM` \ new_var -> zonkMatchGroup env ms `thenM` \ new_ms -> - returnM (FunBind new_var inf new_ms) + returnM (FunBind new_var inf new_ms fvs) -zonk_bind env (AbsBinds tyvars dicts exports inlines val_binds) +zonk_bind env (AbsBinds tyvars dicts exports val_binds) = ASSERT( all isImmutableTyVar tyvars ) zonkIdBndrs env dicts `thenM` \ new_dicts -> fixM (\ ~(new_val_binds, _) -> let - env1 = extendZonkEnv (extendZonkEnv env new_dicts) - (collectHsBindBinders new_val_binds) + env1 = extendZonkEnv env new_dicts + env2 = extendZonkEnv env1 (collectHsBindBinders new_val_binds) in - zonkMonoBinds env1 val_binds `thenM` \ new_val_binds -> - mappM (zonkExport env1) exports `thenM` \ new_exports -> + zonkMonoBinds env2 val_binds `thenM` \ new_val_binds -> + mappM (zonkExport env2) exports `thenM` \ new_exports -> returnM (new_val_binds, new_exports) ) `thenM` \ (new_val_bind, new_exports) -> - returnM (AbsBinds tyvars new_dicts new_exports inlines new_val_bind) + returnM (AbsBinds tyvars new_dicts new_exports new_val_bind) where - zonkExport env (tyvars, global, local) + zonkExport env (tyvars, global, local, prags) = zonkTcTyVars tyvars `thenM` \ tys -> let new_tyvars = map (tcGetTyVar "zonkExport") tys @@ -327,7 +338,13 @@ zonk_bind env (AbsBinds tyvars dicts exports inlines val_binds) -- but they should *be* tyvars. Hence tcGetTyVar. in zonkIdBndr env global `thenM` \ new_global -> - returnM (new_tyvars, new_global, zonkIdOcc env local) + mapM zonk_prag prags `thenM` \ new_prags -> + returnM (new_tyvars, new_global, zonkIdOcc env local, new_prags) + zonk_prag prag@(InlinePrag _ _) = return prag + zonk_prag (SpecPrag expr ty ds) = do { expr' <- zonkExpr env expr + ; ty' <- zonkTcTypeToType env ty + ; let ds' = zonkIdOccs env ds + ; return (SpecPrag expr' ty' ds') } \end{code} %************************************************************************ @@ -353,7 +370,7 @@ zonkMatch env (L loc (Match pats _ grhss)) zonkGRHSs :: ZonkEnv -> GRHSs TcId -> TcM (GRHSs Id) zonkGRHSs env (GRHSs grhss binds) - = zonkNestedBinds env binds `thenM` \ (new_env, new_binds) -> + = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) -> let zonk_grhs (GRHS guarded rhs) = zonkStmts new_env guarded `thenM` \ (env2, new_guarded) -> @@ -451,7 +468,7 @@ zonkExpr env (HsIf e1 e2 e3) returnM (HsIf new_e1 new_e2 new_e3) zonkExpr env (HsLet binds expr) - = zonkNestedBinds env binds `thenM` \ (new_env, new_binds) -> + = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) -> zonkLExpr new_env expr `thenM` \ new_expr -> returnM (HsLet new_binds new_expr) @@ -643,7 +660,7 @@ zonkStmt env (ExprStmt expr then_op ty) returnM (env, ExprStmt new_expr new_then new_ty) zonkStmt env (LetStmt binds) - = zonkNestedBinds env binds `thenM` \ (env1, new_binds) -> + = zonkLocalBinds env binds `thenM` \ (env1, new_binds) -> returnM (env1, LetStmt new_binds) zonkStmt env (BindStmt pat expr bind_op fail_op) diff --git a/ghc/compiler/typecheck/TcHsType.lhs b/ghc/compiler/typecheck/TcHsType.lhs index 54a909e..800fc8d 100644 --- a/ghc/compiler/typecheck/TcHsType.lhs +++ b/ghc/compiler/typecheck/TcHsType.lhs @@ -51,6 +51,7 @@ import Class ( Class, classTyCon ) import Name ( Name, mkInternalName ) import OccName ( mkOccName, tvName ) import NameSet +import NameEnv import PrelNames ( genUnitTyConName ) import TysWiredIn ( mkListTy, listTyCon, mkPArrTy, parrTyCon, tupleTyCon ) import Bag ( bagToList ) @@ -835,9 +836,8 @@ instance Outputable TcSigInfo where = ppr id <+> ptext SLIT("::") <+> ppr tyvars <+> ppr theta <+> ptext SLIT("=>") <+> ppr tau lookupSig :: [TcSigInfo] -> TcSigFun -- Search for a particular signature -lookupSig [] name = Nothing -lookupSig (sig : sigs) name - | name == idName (sig_id sig) = Just sig - | otherwise = lookupSig sigs name +lookupSig sigs = lookupNameEnv env + where + env = mkNameEnv [(idName (sig_id sig), sig) | sig <- sigs] \end{code} diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 8366dad..45117c2 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -9,7 +9,7 @@ module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where #include "HsVersions.h" import HsSyn -import TcBinds ( tcSpecSigs, badBootDeclErr ) +import TcBinds ( mkPragFun, tcPrags, badBootDeclErr ) import TcClassDcl ( tcMethodBind, mkMethodBind, badMethodErr, tcClassDecl2, getGenericInstances ) import TcRnMonad @@ -22,8 +22,7 @@ import Inst ( tcInstClassOp, newDicts, instToId, showLIE, getOverlapFlag, tcExtendLocalInstEnv ) import InstEnv ( mkLocalInstance, instanceDFunId ) import TcDeriv ( tcDeriving ) -import TcEnv ( tcExtendGlobalValEnv, tcExtendTyVarEnv, - InstInfo(..), InstBindings(..), +import TcEnv ( InstInfo(..), InstBindings(..), newDFunName, tcExtendIdEnv ) import TcHsType ( kcHsSigType, tcHsKindedType ) @@ -36,13 +35,13 @@ import Var ( Id, idName, idType ) import MkId ( mkDictFunId, rUNTIME_ERROR_ID ) import FunDeps ( checkInstFDs ) import Name ( Name, getSrcLoc ) -import NameSet ( unitNameSet, emptyNameSet ) import UnicodeUtil ( stringToUtf8 ) import Maybe ( catMaybes ) import SrcLoc ( srcLocSpan, unLoc, noLoc, Located(..), srcSpanStart ) import ListSetOps ( minusList ) import Outputable import Bag +import BasicTypes ( Activation( AlwaysActive ) ) import FastString \end{code} @@ -135,7 +134,7 @@ tcInstDecls1 -- Deal with both source-code and imported instance decls -> TcM (TcGblEnv, -- The full inst env [InstInfo], -- Source-code instance decls to process; -- contains all dfuns for this module - [HsBindGroup Name]) -- Supporting bindings for derived instances + HsValBinds Name) -- Supporting bindings for derived instances tcInstDecls1 tycl_decls inst_decls = checkNoErrs $ @@ -370,27 +369,21 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = binds }) -- of the inst_tyavars' with something in the envt checkSigTyVars inst_tyvars' `thenM_` - -- Deal with 'SPECIALISE instance' pragmas by making them - -- look like SPECIALISE pragmas for the dfun + -- Deal with 'SPECIALISE instance' pragmas let - uprags = case binds of - VanillaInst _ uprags -> uprags - other -> [] - spec_prags = [ L loc (SpecSig (L loc (idName dfun_id)) ty) - | L loc (SpecInstSig ty) <- uprags ] + specs = case binds of + VanillaInst _ prags -> filter isSpecInstLSig prags + other -> [] in - tcExtendGlobalValEnv [dfun_id] ( - tcExtendTyVarEnv inst_tyvars' $ - tcSpecSigs spec_prags - ) `thenM` \ prag_binds -> - + tcPrags dfun_id specs `thenM` \ prags -> + -- Create the result bindings let dict_constr = classDataCon clas scs_and_meths = map instToId sc_dicts ++ meth_ids this_dict_id = instToId this_dict - inlines | null dfun_arg_dicts = emptyNameSet - | otherwise = unitNameSet (idName dfun_id) + inline_prag | null dfun_arg_dicts = [] + | otherwise = [InlinePrag True AlwaysActive] -- Always inline the dfun; this is an experimental decision -- because it makes a big performance difference sometimes. -- Often it means we can do the method selection, and then @@ -432,12 +425,12 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = binds }) main_bind = noLoc $ AbsBinds inst_tyvars' (map instToId dfun_arg_dicts) - [(inst_tyvars', dfun_id, this_dict_id)] - inlines all_binds + [(inst_tyvars', dfun_id, this_dict_id, + inline_prag ++ prags)] + all_binds in showLIE (text "instance") `thenM_` - returnM (unitBag main_bind `unionBags` - prag_binds ) + returnM (unitBag main_bind) tcMethods origin clas inst_tyvars' dfun_theta' inst_tys' @@ -485,8 +478,9 @@ tcMethods origin clas inst_tyvars' dfun_theta' inst_tys' -- The trouble is that the 'meth_inst' for op, which is 'available', also -- looks like 'op at Int'. But they are not the same. let + prag_fn = mkPragFun uprags all_insts = avail_insts ++ catMaybes meth_insts - tc_method_bind = tcMethodBind inst_tyvars' dfun_theta' all_insts uprags + tc_method_bind = tcMethodBind inst_tyvars' dfun_theta' all_insts prag_fn meth_ids = [meth_id | (_,meth_id,_) <- meth_infos] in diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index d7cbd78..f29d89a 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -20,7 +20,7 @@ import HsSyn ( HsExpr(..), LHsExpr, MatchGroup(..), Stmt(..), LStmt, HsMatchContext(..), HsStmtContext(..), LPat, pprMatch, isIrrefutableHsPat, pprMatchContext, pprStmtContext, pprMatchRhsContext, - collectPatsBinders, glueBindsOnGRHSs, noSyntaxExpr + collectPatsBinders, noSyntaxExpr ) import TcHsSyn ( ExprCoFn, isIdCoercion, (<$>), (<.>) ) @@ -34,7 +34,7 @@ import TcMType ( newTyFlexiVarTy, newTyFlexiVarTys, zonkTcType ) import TcType ( TcType, TcTyVar, TcSigmaType, TcRhoType, mkFunTys, tyVarsOfTypes, tidyOpenTypes, isSigmaTy, liftedTypeKind, openTypeKind, mkFunTy, mkAppTy ) -import TcBinds ( tcBindsAndThen ) +import TcBinds ( tcLocalBinds ) import TcUnify ( Expected(..), zapExpectedType, readExpectedType, unifyTauTy, subFunTys, unifyTyConApp, checkSigTyVarsWrt, zapExpectedBranches, tcSubExp, tcGen, @@ -209,28 +209,33 @@ tcGRHSs :: TcMatchCtxt -> GRHSs Name -- This is a consequence of the fact that tcStmts takes a TcType, -- not a Expected TcType, a decision we could revisit if necessary tcGRHSs ctxt (GRHSs [L loc1 (GRHS [] rhs)] binds) exp_ty - = tcBindsAndThen glueBindsOnGRHSs binds $ - mc_body ctxt rhs exp_ty `thenM` \ rhs' -> - returnM (GRHSs [L loc1 (GRHS [] rhs')] []) + = do { (binds', rhs') <- tcLocalBinds binds $ + mc_body ctxt rhs exp_ty + ; returnM (GRHSs [L loc1 (GRHS [] rhs')] binds') } tcGRHSs ctxt (GRHSs grhss binds) exp_ty - = tcBindsAndThen glueBindsOnGRHSs binds $ - do { exp_ty' <- zapExpectedType exp_ty openTypeKind - -- Even if there is only one guard, we zap the RHS type to - -- a monotype. Reason: it makes tcStmts much easier, - -- and even a one-armed guard has a notional second arm - - ; let match_ctxt = mc_what ctxt - stmt_ctxt = PatGuard match_ctxt - tc_grhs (GRHS guards rhs) - = do { (guards', rhs') - <- tcStmts stmt_ctxt (tcGuardStmt exp_ty') guards $ - addErrCtxt (grhsCtxt match_ctxt rhs) $ - tcCheckRho rhs exp_ty' - ; return (GRHS guards' rhs') } - - ; grhss' <- mappM (wrapLocM tc_grhs) grhss - ; returnM (GRHSs grhss' []) } + = do { exp_ty' <- zapExpectedType exp_ty openTypeKind + -- Even if there is only one guard, we zap the RHS type to + -- a monotype. Reason: it makes tcStmts much easier, + -- and even a one-armed guard has a notional second arm + + ; (binds', grhss') <- tcLocalBinds binds $ + mappM (wrapLocM (tcGRHS ctxt exp_ty')) grhss + + ; returnM (GRHSs grhss' binds') } + +------------- +tcGRHS :: TcMatchCtxt -> TcRhoType + -> GRHS Name -> TcM (GRHS TcId) + +tcGRHS ctxt exp_ty' (GRHS guards rhs) + = do { (guards', rhs') <- tcStmts stmt_ctxt (tcGuardStmt exp_ty') guards $ + addErrCtxt (grhsCtxt match_ctxt rhs) $ + tcCheckRho rhs exp_ty' + ; return (GRHS guards' rhs') } + where + match_ctxt = mc_what ctxt + stmt_ctxt = PatGuard match_ctxt \end{code} @@ -386,13 +391,9 @@ tcStmts ctxt stmt_chk [] thing_inside -- LetStmts are handled uniformly, regardless of context tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) thing_inside - = tcBindsAndThen -- No error context, but a binding group is - glue_binds -- rather a large thing for an error context anyway - binds - (tcStmts ctxt stmt_chk stmts thing_inside) - where - glue_binds binds (stmts, thing) = (L loc (LetStmt [binds]) : stmts, thing) - + = do { (binds', (stmts',thing)) <- tcLocalBinds binds $ + tcStmts ctxt stmt_chk stmts thing_inside + ; return (L loc (LetStmt binds') : stmts', thing) } -- For the vanilla case, handle the location-setting part tcStmts ctxt stmt_chk (L loc stmt : stmts) thing_inside diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 74484b0..8e427fe 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -29,7 +29,7 @@ import StaticFlags ( opt_PprStyle_Debug ) import Packages ( checkForPackageConflicts, mkHomeModules ) import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl, SpliceDecl(..), HsBind(..), LHsBinds, - emptyGroup, appendGroups, + emptyRdrGroup, emptyRnGroup, appendGroups, plusHsValBinds, nlHsApp, nlHsVar, pprLHsBinds ) import RdrHsSyn ( findSplice ) @@ -81,14 +81,15 @@ import HscTypes ( ModGuts(..), ModDetails(..), emptyModDetails, import Outputable #ifdef GHCI -import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..), +import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), + HsLocalBinds(..), HsValBinds(..), LStmt, LHsExpr, LHsType, mkVarBind, collectLStmtsBinders, collectLStmtBinders, nlVarPat, placeHolderType, noSyntaxExpr ) import RdrName ( GlobalRdrElt(..), globalRdrEnvElts, unQualOK, lookupLocalRdrEnv, extendLocalRdrEnv ) import RnSource ( addTcgDUs ) -import TcHsSyn ( mkHsLet, zonkTopLExpr, zonkTopBndrs ) +import TcHsSyn ( mkHsDictLet, zonkTopLExpr, zonkTopBndrs ) import TcHsType ( kcHsType ) import TcMType ( zonkTcType, zonkQuantifiedTyVar ) import TcMatches ( tcStmts, tcDoStmt ) @@ -119,7 +120,7 @@ import PrelNames ( iNTERACTIVE, ioTyConName, printName, itName, import HscTypes ( InteractiveContext(..), ModIface(..), icPrintUnqual, Dependencies(..) ) -import BasicTypes ( RecFlag(..), Fixity ) +import BasicTypes ( Fixity ) import SrcLoc ( unLoc, noSrcSpan ) #endif @@ -188,7 +189,7 @@ tcRnModule hsc_env hsc_src save_rn_decls tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts, tcg_imports = tcg_imports gbl `plusImportAvails` imports, tcg_rn_decls = if save_rn_decls then - Just emptyGroup + Just emptyRnGroup else Nothing }) $ do { @@ -340,10 +341,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) }}}} mkFakeGroup decls -- Rather clumsy; lots of unused fields - = HsGroup { hs_tyclds = decls, -- This is the one we want - hs_valds = [], hs_fords = [], - hs_instds = [], hs_fixds = [], hs_depds = [], - hs_ruleds = [], hs_defds = [] } + = emptyRdrGroup { hs_tyclds = decls } \end{code} @@ -687,7 +685,7 @@ tcTopSrcDecls boot_details -- We also typecheck any extra binds that came out -- of the "deriving" process (deriv_binds) traceTc (text "Tc5") ; - (tc_val_binds, tcl_env) <- tcTopBinds (val_binds ++ deriv_binds) ; + (tc_val_binds, tcl_env) <- tcTopBinds (val_binds `plusHsValBinds` deriv_binds) ; setLclTypeEnv tcl_env $ do { -- Second pass over class and instance declarations, @@ -937,7 +935,7 @@ mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt = do { uniq <- newUnique -- is treated very specially ; let fresh_it = itName uniq the_bind = mkVarBind noSrcSpan fresh_it expr - let_stmt = L loc $ LetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive] + let_stmt = L loc $ LetStmt (HsValBinds (ValBindsIn (unitBag the_bind) [])) bind_stmt = L loc $ BindStmt (nlVarPat fresh_it) expr (HsVar bindIOName) noSyntaxExpr print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it)) @@ -1024,7 +1022,7 @@ tcGhciStmts stmts const_binds <- checkNoErrs (tcSimplifyInteractive lie) ; -- checkNoErrs ensures that the plan fails if context redn fails - return (ids, mkHsLet const_binds $ + return (ids, mkHsDictLet const_binds $ noLoc (HsDo DoExpr tc_stmts (mk_return ids) io_ret_ty)) } \end{code} diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index 86b2fbe..6d2c64a 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -20,7 +20,7 @@ import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..), import Module ( Module, unitModuleEnv ) import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv, LocalRdrEnv, emptyLocalRdrEnv ) -import Name ( Name, isInternalName ) +import Name ( Name, isInternalName, mkInternalName, getOccName, getSrcLoc ) import Type ( Type ) import NameEnv ( extendNameEnvList ) import InstEnv ( emptyInstEnv ) @@ -316,6 +316,11 @@ newUniqueSupply let { (us1, us2) = splitUniqSupply us } ; writeMutVar u_var us1 ; return us2 } + +newLocalName :: Name -> TcRnIf gbl lcl Name +newLocalName name -- Make a clone + = newUnique `thenM` \ uniq -> + returnM (mkInternalName uniq (getOccName name) (getSrcLoc name)) \end{code} diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs index 5365922..704f2f9 100644 --- a/ghc/compiler/typecheck/TcRules.lhs +++ b/ghc/compiler/typecheck/TcRules.lhs @@ -8,7 +8,7 @@ module TcRules ( tcRules ) where #include "HsVersions.h" -import HsSyn ( RuleDecl(..), LRuleDecl, RuleBndr(..), mkHsLet ) +import HsSyn ( RuleDecl(..), LRuleDecl, RuleBndr(..), mkHsDictLet ) import TcRnMonad import TcSimplify ( tcSimplifyToDicts, tcSimplifyInferCheck ) import TcMType ( newTyFlexiVarTy, zonkQuantifiedTyVar ) @@ -84,8 +84,8 @@ tcRule (HsRule name act vars lhs rhs) returnM (HsRule name act (map (RuleBndr . noLoc) (forall_tvs2 ++ tpl_ids)) -- yuk - (mkHsLet lhs_binds lhs') - (mkHsLet rhs_binds rhs')) + (mkHsDictLet lhs_binds lhs') + (mkHsDictLet rhs_binds rhs')) where tcRuleBndrs [] thing_inside = thing_inside [] diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs index 24bb40c..93a3a49 100644 --- a/ghc/compiler/typecheck/TcSplice.lhs +++ b/ghc/compiler/typecheck/TcSplice.lhs @@ -26,7 +26,7 @@ import RnEnv ( lookupFixityRn, lookupSrcOcc_maybe, lookupImportedName ) import RdrName ( RdrName, mkRdrQual, mkRdrUnqual, lookupLocalRdrEnv, isSrcRdrName ) import RnTypes ( rnLHsType ) import TcExpr ( tcCheckRho, tcMonoExpr ) -import TcHsSyn ( mkHsLet, zonkTopLExpr ) +import TcHsSyn ( mkHsDictLet, zonkTopLExpr ) import TcSimplify ( tcSimplifyTop, tcSimplifyBracket ) import TcUnify ( Expected, zapExpectedTo, zapExpectedType ) import TcType ( TcType, TcKind, liftedTypeKind, mkAppTy, tcSplitSigmaTy ) @@ -252,7 +252,7 @@ tcTopSpliceExpr expr meta_ty ; const_binds <- tcSimplifyTop lie -- And zonk it - ; zonkTopLExpr (mkHsLet const_binds expr') } + ; zonkTopLExpr (mkHsDictLet const_binds expr') } \end{code} diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs index dd9d229..eaeddd5 100644 --- a/ghc/compiler/typecheck/TcUnify.lhs +++ b/ghc/compiler/typecheck/TcUnify.lhs @@ -28,7 +28,7 @@ module TcUnify ( import HsSyn ( HsExpr(..) , MatchGroup(..), HsMatchContext(..), hsLMatchPats, pprMatches, pprMatchContext ) -import TcHsSyn ( mkHsLet, mkHsDictLam, +import TcHsSyn ( mkHsDictLet, mkHsDictLam, ExprCoFn, idCoercion, isIdCoercion, mkCoercion, (<.>), (<$>) ) import TypeRep ( Type(..), PredType(..), TyNote(..) ) @@ -670,7 +670,7 @@ tcGen expected_ty extra_tvs thing_inside -- We expect expected_ty to be a forall -- It's a bit out of place here, but using AbsBind involves inventing -- a couple of new names which seems worse. dict_ids = map instToId dicts - co_fn e = TyLam forall_tvs (mkHsDictLam dict_ids (mkHsLet inst_binds (noLoc e))) + co_fn e = TyLam forall_tvs (mkHsDictLam dict_ids (mkHsDictLet inst_binds (noLoc e))) ; returnM (mkCoercion co_fn, result) } where free_tvs = tyVarsOfType expected_ty `unionVarSet` extra_tvs diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs index aa7ccf2..d6a4278 100644 --- a/ghc/compiler/types/Generics.lhs +++ b/ghc/compiler/types/Generics.lhs @@ -256,12 +256,14 @@ type FromAlt = (LPat RdrName, LHsExpr RdrName) mkTyConGenericBinds :: TyCon -> LHsBinds RdrName mkTyConGenericBinds tycon = unitBag (L loc (FunBind (L loc from_RDR) False {- Not infix -} - (mkMatchGroup [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]))) + from_matches placeHolderNames)) `unionBags` unitBag (L loc (FunBind (L loc to_RDR) False - (mkMatchGroup [mkSimpleHsAlt to_pat to_body]))) + to_matches placeHolderNames)) where + from_matches = mkMatchGroup [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts] + to_matches = mkMatchGroup [mkSimpleHsAlt to_pat to_body] loc = srcLocSpan (getSrcLoc tycon) datacons = tyConDataCons tycon (from_RDR, to_RDR) = mkGenericNames tycon diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index ffad3ce..7d42e1a 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -437,6 +437,11 @@ isTupleTyCon :: TyCon -> Bool -- The unit tycon didn't used to be classed as a tuple tycon -- but I thought that was silly so I've undone it -- If it can't be for some reason, it should be a AlgTyCon +-- +-- NB: when compiling Data.Tuple, the tycons won't reply True to +-- isTupleTyCon, becuase they are built as AlgTyCons. However they +-- get spat into the interface file as tuple tycons, so I don't think +-- it matters. isTupleTyCon (TupleTyCon {}) = True isTupleTyCon other = False diff --git a/ghc/compiler/utils/IOEnv.hs b/ghc/compiler/utils/IOEnv.hs index 6f383b2..f937f6a 100644 --- a/ghc/compiler/utils/IOEnv.hs +++ b/ghc/compiler/utils/IOEnv.hs @@ -9,7 +9,7 @@ module IOEnv ( -- Standard combinators, specialised returnM, thenM, thenM_, failM, failWithM, mappM, mappM_, mapSndM, sequenceM, sequenceM_, - foldlM, + foldlM, foldrM, mapAndUnzipM, mapAndUnzip3M, checkM, ifM, zipWithM, zipWithM_, @@ -154,6 +154,7 @@ mapSndM :: (b -> IOEnv env c) -> [(a,b)] -> IOEnv env [(a,c)] sequenceM :: [IOEnv env a] -> IOEnv env [a] sequenceM_ :: [IOEnv env a] -> IOEnv env () foldlM :: (a -> b -> IOEnv env a) -> a -> [b] -> IOEnv env a +foldrM :: (b -> a -> IOEnv env a) -> a -> [b] -> IOEnv env a mapAndUnzipM :: (a -> IOEnv env (b,c)) -> [a] -> IOEnv env ([b],[c]) mapAndUnzip3M :: (a -> IOEnv env (b,c,d)) -> [a] -> IOEnv env ([b],[c],[d]) checkM :: Bool -> IOEnv env () -> IOEnv env () -- Perform arg if bool is False @@ -187,6 +188,9 @@ sequenceM_ (x:xs) = do { x; sequenceM_ xs } foldlM k z [] = return z foldlM k z (x:xs) = do { r <- k z x; foldlM k r xs } +foldrM k z [] = return z +foldrM k z (x:xs) = do { r <- foldrM k z xs; k x r } + mapAndUnzipM f [] = return ([],[]) mapAndUnzipM f (x:xs) = do { (r,s) <- f x; (rs,ss) <- mapAndUnzipM f xs; diff --git a/ghc/compiler/utils/ListSetOps.lhs b/ghc/compiler/utils/ListSetOps.lhs index b93a045..0295072 100644 --- a/ghc/compiler/utils/ListSetOps.lhs +++ b/ghc/compiler/utils/ListSetOps.lhs @@ -10,10 +10,10 @@ module ListSetOps ( -- Association lists Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing, emptyAssoc, unitAssoc, mapAssoc, plusAssoc_C, extendAssoc_C, - mkLookupFun, assocElts, + mkLookupFun, findInList, assocElts, -- Duplicate handling - hasNoDups, runs, removeDups, removeDupsEq, + hasNoDups, runs, removeDups, findDupsEq, equivClasses, equivClassesByUniq ) where @@ -24,7 +24,7 @@ import Outputable import Unique ( Unique ) import UniqFM ( eltsUFM, emptyUFM, addToUFM_C ) import Util ( isn'tIn, isIn, mapAccumR, sortLe ) -import List ( union ) +import List ( partition ) \end{code} @@ -125,6 +125,11 @@ mkLookupFun eq alist s = case [a | (s',a) <- alist, s' `eq` s] of [] -> Nothing (a:_) -> Just a + +findInList :: (a -> Bool) -> [a] -> Maybe a +findInList p [] = Nothing +findInList p (x:xs) | p x = Just x + | otherwise = findInList p xs \end{code} @@ -195,16 +200,12 @@ removeDups cmp xs collect_dups dups_so_far [x] = (dups_so_far, x) collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x) -removeDupsEq :: Eq a => [a] -> ([a], [[a]]) --- Same, but with only equality --- It's worst case quadratic, but we only use it on short lists -removeDupsEq [] = ([], []) -removeDupsEq (x:xs) | x `elem` xs = (ys, (x : filter (== x) xs) : zs) - where - (ys,zs) = removeDupsEq (filter (/= x) xs) -removeDupsEq (x:xs) | otherwise = (x:ys, zs) - where - (ys,zs) = removeDupsEq xs +findDupsEq :: (a->a->Bool) -> [a] -> [[a]] +findDupsEq eq [] = [] +findDupsEq eq (x:xs) | null eq_xs = findDupsEq eq xs + | otherwise = (x:eq_xs) : findDupsEq eq neq_xs + where + (eq_xs, neq_xs) = partition (eq x) xs \end{code} diff --git a/ghc/compiler/utils/UniqFM.lhs b/ghc/compiler/utils/UniqFM.lhs index 52d34d9..d2676bf 100644 --- a/ghc/compiler/utils/UniqFM.lhs +++ b/ghc/compiler/utils/UniqFM.lhs @@ -19,7 +19,7 @@ module UniqFM ( unitDirectlyUFM, listToUFM, listToUFM_Directly, - addToUFM,addToUFM_C, + addToUFM,addToUFM_C,addToUFM_Acc, addListToUFM,addListToUFM_C, addToUFM_Directly, addListToUFM_Directly, @@ -82,6 +82,13 @@ addToUFM_C :: Uniquable key => (elt -> elt -> elt) -- old -> new -> result -> key -> elt -- new -> UniqFM elt -- result +addToUFM_Acc :: Uniquable key => + (elt -> elts -> elts) -- Add to existing + -> (elt -> elts) -- New element + -> UniqFM elts -- old + -> key -> elt -- new + -> UniqFM elts -- result + addListToUFM_C :: Uniquable key => (elt -> elt -> elt) -> UniqFM elt -> [(key,elt)] -> UniqFM elt @@ -245,6 +252,11 @@ addToUFM_Directly fm u elt = insert_ele use_snd fm (getKey# u) elt addToUFM_C combiner fm key elt = insert_ele combiner fm (getKey# (getUnique key)) elt +addToUFM_Acc add unit fm key item + = insert_ele combiner fm (getKey# (getUnique key)) (unit item) + where + combiner old _unit_item = add item old + addListToUFM fm key_elt_pairs = addListToUFM_C use_snd fm key_elt_pairs addListToUFM_Directly fm uniq_elt_pairs = addListToUFM_directly_C use_snd fm uniq_elt_pairs @@ -659,7 +671,7 @@ and if necessary do $\lambda$ lifting on our functions that are bound. \begin{code} insert_ele - :: (a -> a -> a) + :: (a -> a -> a) -- old -> new -> result -> UniqFM a -> FastInt -> a diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index b16f6eb..0911dba 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -13,7 +13,7 @@ module Util ( mapAndUnzip, mapAndUnzip3, nOfThem, filterOut, lengthExceeds, lengthIs, lengthAtLeast, listLengthCmp, atLength, - isSingleton, only, + isSingleton, only, singleton, notNull, snocView, isIn, isn'tIn, @@ -299,6 +299,9 @@ listLengthCmp = atLength atLen atEnd atLen [] = EQ atLen _ = GT +singleton :: a -> [a] +singleton x = [x] + isSingleton :: [a] -> Bool isSingleton [x] = True isSingleton _ = False -- 1.7.10.4