diff options
71 files changed, 2044 insertions, 1905 deletions
diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs index b0b3bc18ed..94dfc84139 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 62c722a352..85c474d1c3 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 5f223e5ec4..20dcbe291b 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 a125f61e60..ff637010aa 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 c3f626e54f..948b910f8b 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 e7e7da3557..044841f65f 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 a1515a0f3a..84e7810fe5 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 b1171041c8..be5ad1e544 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 43df99ce8d..a5d797de93 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 70e5d16f73..fe3276fd23 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 9a9a2d20f8..c7ddb2ddfd 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 6dc8f22d22..2e21538001 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 b3380a9bb6..c65e99d80d 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 9f0758a4cf..1523d83652 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 d934b7c1a2..33f86edcf9 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 643ba2ea01..7eb62ffa38 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 35e96773f1..9785cdb2e9 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 2dbe8b1598..75fd45b46a 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 fe5b95b94a..bd1a5c6057 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 c76b74872b..da5930074a 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 7d5653cb7a..751623da35 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 47302c5050..0646b23634 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 807a2bb307..1cf7c85860 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 4ae6ce40b5..86c41906bf 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 d2e757e373..8019f36282 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 a15f224c8c..4434c5dc10 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 e13f77b763..e6471eb94d 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 5c32a291fe..8757279ac5 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 fbda3f181c..24d67910a4 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 77195f3f4b..d8c2975f7f 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 85e692b57b..b213764aa1 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 0e9711f78b..f38bcc48de 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 4e670c6bed..3de37937ba 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 b49c869bc9..8ba09c0a04 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 94ae27f913..cbba768811 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 bdaa9f156e..e0d08fdcac 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 0000000000..8f6c7f154b --- /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 561de22a3d..0bf40e64de 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 9ff40d5f22..22f75ae2b2 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 7101c48ca8..5b888b7d37 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 e4d5e3bdcc..0000000000 --- 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 8d60be1eea..337b3d20c0 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 dcdfe4ef6b..31279ff1ec 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 29d138e4a6..f8915c72f5 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 97cc14cfec..8e3139e041 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 105c5210cd..0b584954eb 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 47289205bb..9220604801 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 baca12c7cd..0e66b0bc78 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 d241e5862b..781d6ed8d6 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 21466a8f2f..c2927bcc5c 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 b02eb2b9bb..38ca1f6341 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 26e5fc5903..ce1c48aeeb 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 :: <type> = g #-} -which promised that g implemented f at <type>, but we do that with -a RULE now: - {-# RULES (f::<type>) = 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 d5ab1781fd..22dc9b2bac 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 36b980f408..c7526a4bf4 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 8657a85130..06b79f7c22 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 ebe95e4e66..406ca02535 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 d10e3c0deb..ec51813c63 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 54a909e8a8..800fc8d113 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 8366dad296..45117c2954 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 d7cbd78262..f29d89a741 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 74484b0a18..8e427fe1e6 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 86b2fbeaa1..6d2c64af08 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 5365922aef..704f2f90c8 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 24bb40cfbb..93a3a49055 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 dd9d229413..eaeddd53a8 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 aa7ccf208f..d6a4278a37 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 ffad3ce23d..7d42e1a6e6 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 6f383b2150..f937f6a27e 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 b93a045832..02950722a2 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 52d34d9983..d2676bf1af 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 b16f6eb969..0911dba841 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 |