X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnBinds.lhs;h=d7865f45c0ff76ea7b89941797e049ce1de9a461;hp=08b54c552218f66d65506aa55242ef441e0a63cc;hb=1e50fd4185479a62e02d987bdfcb1c62712859ca;hpb=f3878a2bd5371e2129062f12227380f6b9bbdceb diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 08b54c5..d7865f4 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -22,28 +22,27 @@ import HsSyn import RdrHsSyn import RnHsSyn import TcRnMonad -import RnTypes ( rnHsSigType, rnLHsType, rnHsTypeFVs,checkPrecMatch) +import RnTypes ( rnHsSigType, rnLHsType, checkPrecMatch) import RnPat (rnPatsAndThen_LocalRightwards, rnBindPat, - NameMaker, localRecNameMaker, topRecNameMaker, applyNameMaker, - patSigErr) + NameMaker, localRecNameMaker, topRecNameMaker, applyNameMaker + ) import RnEnv import DynFlags ( DynFlag(..) ) import Name import NameEnv import NameSet -import PrelNames ( isUnboundName ) import RdrName ( RdrName, rdrNameOcc ) import SrcLoc import ListSetOps ( findDupsEq ) import BasicTypes ( RecFlag(..) ) -import Digraph ( SCC(..), stronglyConnComp ) +import Digraph ( SCC(..), stronglyConnCompFromEdgedVertices ) import Bag import Outputable import FastString +import Data.List ( partition ) import Maybes ( orElse ) -import Util ( filterOut ) -import Monad ( foldM, unless ) +import Control.Monad \end{code} -- ToDo: Put the annotations into the monad, so that they arrive in the proper @@ -161,7 +160,7 @@ rnTopBindsLHS :: MiniFixityEnv rnTopBindsLHS fix_env binds = (uncurry $ rnValBindsLHSFromDoc (topRecNameMaker fix_env)) (bindersAndDoc binds) binds -rnTopBindsRHS :: [Name] -- the names bound by these binds +rnTopBindsRHS :: NameSet -- Names bound by these binds -> HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) rnTopBindsRHS bound_names binds = @@ -170,18 +169,17 @@ rnTopBindsRHS bound_names binds = then rnTopBindsBoot binds else rnValBindsRHSGen (\x -> x) -- don't trim free vars bound_names binds } - --- wrapper if we don't need to do anything in between the left and right, +-- Wrapper if we don't need to do anything in between the left and right, -- or anything else in the scope of the left -- --- never used when there are fixity declarations +-- Never used when there are fixity declarations rnTopBinds :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses) rnTopBinds b = do nl <- rnTopBindsLHS emptyFsEnv b let bound_names = map unLoc (collectHsValBinders nl) - bindLocalNames bound_names $ rnTopBindsRHS bound_names nl + bindLocalNames bound_names $ rnTopBindsRHS (mkNameSet bound_names) nl rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) @@ -189,7 +187,7 @@ rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) -- Return a single HsBindGroup with empty binds and renamed signatures rnTopBindsBoot (ValBindsIn mbinds sigs) = do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds) - ; sigs' <- renameSigs okHsBootSig sigs + ; sigs' <- renameSigs Nothing okHsBootSig sigs ; return (ValBindsOut [] sigs', usesOnly (hsSigsFVs sigs')) } rnTopBindsBoot b = pprPanic "rnTopBindsBoot" (ppr b) \end{code} @@ -299,31 +297,27 @@ rnValBindsLHSFromDoc topP _original_bndrs doc (ValBindsIn mbinds sigs) = do return $ ValBindsIn mbinds' sigs rnValBindsLHSFromDoc _ _ _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b) --- assumes the LHS vars are in scope --- general version used both from the top-level and for local things +-- General version used both from the top-level and for local things +-- Assumes the LHS vars are in scope -- --- does not bind the local fixity declarations +-- Does not bind the local fixity declarations rnValBindsRHSGen :: (FreeVars -> FreeVars) -- for trimming free var sets -- The trimming function trims the free vars we attach to a -- binding so that it stays reasonably small - -> [Name] -- names bound by the LHSes + -> NameSet -- Names bound by the LHSes -> HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) -rnValBindsRHSGen trim _bound_names (ValBindsIn mbinds sigs) = do +rnValBindsRHSGen trim bound_names (ValBindsIn mbinds sigs) = do -- rename the sigs - env <- getGblEnv - traceRn (ptext (sLit "Rename sigs") <+> ppr (tcg_rdr_env env)) - sigs' <- rename_sigs sigs + sigs' <- renameSigs (Just bound_names) okBindSig sigs -- rename the RHSes binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs') trim) mbinds - let (anal_binds, anal_dus) = depAnalBinds binds_w_dus - (valbind', valbind'_dus) = (ValBindsOut anal_binds sigs', - usesOnly (hsSigsFVs sigs') `plusDU` anal_dus) - -- We do the check-sigs after renaming the bindings, - -- so that we have convenient access to the binders - check_sigs (okBindSig (duDefs anal_dus)) sigs' - return (valbind', valbind'_dus) + case depAnalBinds binds_w_dus of + (anal_binds, anal_dus) -> + do let valbind' = ValBindsOut anal_binds sigs' + valbind'_dus = usesOnly (hsSigsFVs sigs') `plusDU` anal_dus + return (valbind', valbind'_dus) rnValBindsRHSGen _ _ b = pprPanic "rnValBindsRHSGen" (ppr b) @@ -333,12 +327,12 @@ rnValBindsRHSGen _ _ b = pprPanic "rnValBindsRHSGen" (ppr b) -- it doesn't (and can't: we don't have the thing inside the binds) happen here -- -- The client is also responsible for bringing the fixities into scope -rnValBindsRHS :: [Name] -- names bound by the LHSes +rnValBindsRHS :: NameSet -- names bound by the LHSes -> HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) rnValBindsRHS bound_names binds = rnValBindsRHSGen (\ fvs -> -- only keep the names the names from this group - intersectNameSet (mkNameSet bound_names) fvs) bound_names binds + intersectNameSet bound_names fvs) bound_names binds -- for local binds @@ -363,7 +357,7 @@ rnValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside ; bindLocalNamesFV_WithFixities bound_names new_fixities $ do { -- (C) Do the RHS and thing inside - (binds', dus) <- rnValBindsRHS bound_names new_lhs + (binds', dus) <- rnValBindsRHS (mkNameSet bound_names) new_lhs ; (result, result_fvs) <- thing_inside binds' -- Report unused bindings based on the (accurate) @@ -497,11 +491,13 @@ rnBind _ trim (L loc (PatBind { pat_lhs = pat, ; (grhss', fvs) <- rnGRHSs PatBindRhs grhss -- No scoped type variables for pattern bindings + ; let fvs' = trim fvs - ; return (L loc (PatBind { pat_lhs = pat, + ; fvs' `seq` -- See Note [Free-variable space leak] + return (L loc (PatBind { pat_lhs = pat, pat_rhs = grhss', pat_rhs_ty = placeHolderType, - bind_fvs = trim fvs }), + bind_fvs = fvs' }), bndrs, pat_fvs `plusFV` fvs) } rnBind sig_fn @@ -519,20 +515,35 @@ rnBind sig_fn ; (matches', fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ -- bindSigTyVars tests for Opt_ScopedTyVars rnMatchGroup (FunRhs plain_name inf) matches + ; let fvs' = trim fvs ; checkPrecMatch inf plain_name matches' - ; return (L loc (FunBind { fun_id = name, + ; fvs' `seq` -- See Note [Free-variable space leak] + return (L loc (FunBind { fun_id = name, fun_infix = inf, fun_matches = matches', - bind_fvs = trim fvs, + bind_fvs = fvs', fun_co_fn = idHsWrapper, fun_tick = Nothing }), [plain_name], fvs) } rnBind _ _ b = pprPanic "rnBind" (ppr b) - + +{- +Note [Free-variable space leak] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have + fvs' = trim fvs +and we seq fvs' before turning it as part of a record. + +The reason is that trim is sometimes something like + \xs -> intersectNameSet (mkNameSet bound_names) xs +and we don't want to retain the list bound_names. This showed up in +trac ticket #1136. +-} + --------------------- depAnalBinds :: Bag (LHsBind Name, [Name], Uses) -> ([(RecFlag, LHsBinds Name)], DefUses) @@ -541,7 +552,7 @@ depAnalBinds :: Bag (LHsBind Name, [Name], Uses) depAnalBinds binds_w_dus = (map get_binds sccs, map get_du sccs) where - sccs = stronglyConnComp edges + sccs = stronglyConnCompFromEdgedVertices edges keyd_nodes = bagToList binds_w_dus `zip` [0::Int ..] @@ -677,41 +688,26 @@ rnMethodBind _ _ _ b = pprPanic "rnMethodBind" (ppr b) \begin{enumerate} \item more than one sig for one thing; \item signatures given for things not bound here; -\item with suitably flaggery, that all top-level things have type signatures. \end{enumerate} % 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} -renameSigs :: (LSig Name -> Bool) -> [LSig RdrName] -> RnM [LSig Name] +renameSigs :: Maybe NameSet -- If (Just ns) complain if the sig isn't for one of ns + -> (Sig RdrName -> Bool) -- Complain about the wrong kind of signature if this is False + -> [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 = mapM (wrapLocM renameSig) sigs +renameSigs mb_names ok_sig sigs + = do { let (good_sigs, bad_sigs) = partition (ok_sig . unLoc) sigs + ; mapM_ unknownSigErr bad_sigs -- Misplaced + ; mapM_ dupSigDeclErr (findDupsEq eqHsSig sigs) -- Duplicate + ; sigs' <- mapM (wrapLocM (renameSig mb_names)) good_sigs + ; return sigs' } ---------------------- -check_sigs :: (LSig Name -> Bool) -> [LSig Name] -> RnM () --- Used for class and instance decls, as well as regular bindings -check_sigs ok_sig sigs = do - -- Check for (a) duplicate signatures - -- (b) signatures for things not in this group = do - traceRn (text "SIGS" <+> ppr sigs) - mapM_ unknownSigErr (filter (not . ok_sig) sigs') - mapM_ dupSigDeclErr (findDupsEq eqHsSig sigs') - where - -- Don't complain about an unbound name again - sigs' = filterOut bad_name sigs - bad_name sig = case sigName sig of - Just n -> isUnboundName n - _ -> False - --- We use lookupLocatedSigOccRn in the signatures, which is a little bit unsatisfactory +-- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory -- because this won't work for: -- instance Foo T where -- {-# INLINE op #-} @@ -720,73 +716,71 @@ check_sigs ok_sig sigs = do -- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.) -- Doesn't seem worth much trouble to sort this. -renameSig :: Sig RdrName -> RnM (Sig Name) --- FixitSig is renamed elsewhere. -renameSig (TypeSig v ty) = do - new_v <- lookupLocatedSigOccRn v - new_ty <- rnHsSigType (quotes (ppr v)) ty - return (TypeSig new_v new_ty) - -renameSig (SpecInstSig ty) = do - new_ty <- rnLHsType (text "A SPECIALISE instance pragma") ty - return (SpecInstSig new_ty) - -renameSig (SpecSig v ty inl) = do - new_v <- lookupLocatedSigOccRn v - new_ty <- rnHsSigType (quotes (ppr v)) ty - return (SpecSig new_v new_ty inl) - -renameSig (InlineSig v s) = do - new_v <- lookupLocatedSigOccRn v - return (InlineSig new_v s) - -renameSig (FixSig (FixitySig v f)) = do - new_v <- lookupLocatedSigOccRn v - return (FixSig (FixitySig new_v f)) +renameSig :: Maybe NameSet -> Sig RdrName -> RnM (Sig Name) +-- FixitySig is renamed elsewhere. +renameSig _ (IdSig x) + = return (IdSig x) -- Actually this never occurs +renameSig mb_names sig@(TypeSig v ty) + = do { new_v <- lookupSigOccRn mb_names sig v + ; new_ty <- rnHsSigType (quotes (ppr v)) ty + ; return (TypeSig new_v new_ty) } + +renameSig _ (SpecInstSig ty) + = do { new_ty <- rnLHsType (text "A SPECIALISE instance pragma") ty + ; return (SpecInstSig new_ty) } + +renameSig mb_names sig@(SpecSig v ty inl) + = do { new_v <- lookupSigOccRn mb_names sig v + ; new_ty <- rnHsSigType (quotes (ppr v)) ty + ; return (SpecSig new_v new_ty inl) } + +renameSig mb_names sig@(InlineSig v s) + = do { new_v <- lookupSigOccRn mb_names sig v + ; return (InlineSig new_v s) } + +renameSig mb_names sig@(FixSig (FixitySig v f)) + = do { new_v <- lookupSigOccRn mb_names sig v + ; return (FixSig (FixitySig new_v f)) } \end{code} -************************************************************************ -* * +%************************************************************************ +%* * \subsection{Match} -* * -************************************************************************ +%* * +%************************************************************************ \begin{code} rnMatchGroup :: HsMatchContext Name -> MatchGroup RdrName -> RnM (MatchGroup Name, FreeVars) -rnMatchGroup ctxt (MatchGroup ms _) = do - (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt) ms - return (MatchGroup new_ms placeHolderType, ms_fvs) +rnMatchGroup ctxt (MatchGroup ms _) + = do { (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt) ms + ; return (MatchGroup new_ms placeHolderType, ms_fvs) } rnMatch :: HsMatchContext Name -> LMatch RdrName -> RnM (LMatch Name, FreeVars) rnMatch ctxt = wrapLocFstM (rnMatch' ctxt) rnMatch' :: HsMatchContext Name -> Match RdrName -> RnM (Match Name, FreeVars) -rnMatch' ctxt (Match pats maybe_rhs_sig grhss) - = - -- Deal with the rhs type signature - bindPatSigTyVarsFV rhs_sig_tys $ do - opt_PatternSignatures <- doptM Opt_PatternSignatures - (maybe_rhs_sig', ty_fvs) <- - case maybe_rhs_sig of - Nothing -> return (Nothing, emptyFVs) - Just ty | opt_PatternSignatures -> do (ty', ty_fvs) <- rnHsTypeFVs doc_sig ty - return (Just ty', ty_fvs) - | otherwise -> do addLocErr ty patSigErr - return (Nothing, emptyFVs) - - -- Now the main event - -- note that there are no local ficity decls for matches - rnPatsAndThen_LocalRightwards ctxt pats $ \ pats' -> do - (grhss', grhss_fvs) <- rnGRHSs ctxt grhss - - return (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs) +rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss) + = do { -- Result type signatures are no longer supported + case maybe_rhs_sig of + Nothing -> return () + Just ty -> addLocErr ty (resSigErr ctxt match) + + + -- Now the main event + -- note that there are no local ficity decls for matches + ; rnPatsAndThen_LocalRightwards ctxt pats $ \ pats' -> do + { (grhss', grhss_fvs) <- rnGRHSs ctxt grhss + + ; return (Match pats' Nothing grhss', grhss_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" + +resSigErr :: HsMatchContext Name -> Match RdrName -> HsType RdrName -> SDoc +resSigErr ctxt match ty + = vcat [ ptext (sLit "Illegal result type signature") <+> quotes (ppr ty) + , nest 2 $ ptext (sLit "Result signatures are no longer supported in pattern matches") + , pprMatchInCtxt ctxt match ] \end{code} @@ -833,7 +827,7 @@ rnGRHS' ctxt (GRHS guards rhs) %************************************************************************ \begin{code} -dupSigDeclErr :: [LSig Name] -> RnM () +dupSigDeclErr :: [LSig RdrName] -> RnM () dupSigDeclErr sigs@(L loc sig : _) = addErrAt loc $ vcat [ptext (sLit "Duplicate") <+> what_it_is <> colon, @@ -843,22 +837,10 @@ dupSigDeclErr sigs@(L loc sig : _) ppr_sig (L loc sig) = ppr loc <> colon <+> ppr sig dupSigDeclErr [] = panic "dupSigDeclErr" -unknownSigErr :: LSig Name -> RnM () +unknownSigErr :: LSig RdrName -> RnM () unknownSigErr (L loc sig) - = do { mod <- getModule - ; addErrAt loc $ - vcat [sep [ptext (sLit "Misplaced") <+> what_it_is <> colon, ppr sig], - extra_stuff mod sig] } - where - what_it_is = hsSigDoc sig - extra_stuff mod (TypeSig (L _ n) _) - | nameIsLocalOrFrom mod n - = ptext (sLit "The type signature must be given where") - <+> quotes (ppr n) <+> ptext (sLit "is declared") - | otherwise - = ptext (sLit "You cannot give a type signature for an imported value") - - extra_stuff _ _ = empty + = addErrAt loc $ + sep [ptext (sLit "Misplaced") <+> hsSigDoc sig <> colon, ppr sig] methodBindErr :: HsBindLR RdrName RdrName -> SDoc methodBindErr mbind