X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnExpr.lhs;h=87ac92ddc38d952cd1ba54f4aab0231d103ad6af;hb=d4f1ad72f0c3c7a1f4747336c86f7d0a179e68cd;hp=ac323aca0589e85aa01fcfc8d41499fd3408d431;hpb=38db229302890403037c5de7453299b3538bb404;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index ac323ac..87ac92d 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -10,20 +10,15 @@ general, all of these functions return a renamed thing, and a set of free variables. \begin{code} -#include "HsVersions.h" - module RnExpr ( rnMatch, rnGRHSsAndBinds, rnPat, checkPrecMatch ) where -IMP_Ubiq() -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 -IMPORT_DELOOPER(RnLoop) -- break the RnPass/RnExpr/RnBinds loops -#else +#include "HsVersions.h" + import {-# SOURCE #-} RnBinds import {-# SOURCE #-} RnSource ( rnHsSigType ) -#endif import HsSyn import RdrHsSyn @@ -31,27 +26,22 @@ import RnHsSyn import RnMonad import RnEnv import CmdLineOpts ( opt_GlasgowExts ) -import BasicTypes ( Fixity(..), FixityDirection(..) ) -import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR, - creturnableClass_RDR, monadZeroClass_RDR, enumClass_RDR, ordClass_RDR, - ratioDataCon_RDR, negate_RDR +import BasicTypes ( Fixity(..), FixityDirection(..), IfaceFlavour(..) ) +import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, + ccallableClass_RDR, creturnableClass_RDR, + monadZeroClass_RDR, enumClass_RDR, ordClass_RDR, + ratioDataCon_RDR, negate_RDR, assertErr_RDR, + ioDataCon_RDR, ioOkDataCon_RDR ) import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon ) -import TyCon ( TyCon ) -import Id ( GenId ) -import ErrUtils ( addErrLoc, addShortErrLocLine ) import Name -import Pretty -import UniqFM ( lookupUFM{-, ufmToList ToDo:rm-} ) -import UniqSet ( emptyUniqSet, unitUniqSet, - unionUniqSets, unionManyUniqSets, - SYN_IE(UniqSet) - ) -import Util ( Ord3(..), removeDups, panic, pprPanic, assertPanic ) +import UniqFM ( isNullUFM ) +import UniqSet ( emptyUniqSet, unionManyUniqSets, UniqSet ) +import Unique ( assertIdKey ) +import Util ( removeDups ) import Outputable - \end{code} @@ -151,9 +141,17 @@ rnMatch, rnMatch1 :: RdrNameMatch -> RnMS s (RenamedMatch, FreeVars) -- f x x = 1 rnMatch match - = bindLocalsRn "pattern" (get_binders match) $ \ new_binders -> + = pushSrcLocRn (getMatchLoc match) $ + bindLocalsRn "pattern" (get_binders match) $ \ new_binders -> rnMatch1 match `thenRn` \ (match', fvs) -> - returnRn (match', fvs `minusNameSet` mkNameSet new_binders) + let + binder_set = mkNameSet new_binders + unused_binders = binder_set `minusNameSet` fvs + net_fvs = fvs `minusNameSet` binder_set + in + warnUnusedMatches unused_binders `thenRn_` + + returnRn (match', net_fvs) where get_binders (GRHSMatch _) = [] get_binders (PatMatch pat match) = collectPatBinders pat ++ get_binders match @@ -205,14 +203,10 @@ rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds) rnExpr expr `thenRn` \ (expr', fvse) -> returnRn (GRHS guard' expr' locn, fvse)) - rnGRHS (OtherwiseGRHS expr locn) - = pushSrcLocRn locn $ - rnExpr expr `thenRn` \ (expr', fvs) -> - returnRn (GRHS [] expr' locn, fvs) - -- 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 [GuardStmt _ _] = True is_standard_guard other = False \end{code} @@ -225,15 +219,23 @@ rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds) \begin{code} rnExprs :: [RdrNameHsExpr] -> RnMS s ([RenamedHsExpr], FreeVars) -rnExprs ls = - rnExprs' ls [] `thenRn` \ (exprs, fvExprs) -> - returnRn (exprs, unionManyNameSets fvExprs) - -rnExprs' [] acc = returnRn ([], acc) -rnExprs' (expr:exprs) acc - = rnExpr expr `thenRn` \ (expr', fvExpr) -> - rnExprs' exprs (fvExpr:acc) `thenRn` \ (exprs', fvExprs) -> +rnExprs ls = rnExprs' ls emptyUniqSet + where + rnExprs' [] acc = returnRn ([], acc) + rnExprs' (expr:exprs) acc + = rnExpr expr `thenRn` \ (expr', fvExpr) -> + + -- Now we do a "seq" on the free vars because typically it's small + -- or empty, especially in very long lists of constants + let + acc' = acc `unionNameSets` fvExpr + in + (grubby_seqNameSet acc' rnExprs') exprs acc' `thenRn` \ (exprs', fvExprs) -> returnRn (expr':exprs', fvExprs) + +-- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq +grubby_seqNameSet ns result | isNullUFM ns = result + | otherwise = result \end{code} Variables. We look up the variable and return the resulting name. The @@ -247,10 +249,16 @@ free-var set iff if it's a LocallyDefined Name. rnExpr :: RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars) rnExpr (HsVar v) - = lookupOccRn v `thenRn` \ vname -> - returnRn (HsVar vname, if isLocallyDefined vname - then unitNameSet vname - else emptyUniqSet) + = lookupOccRn v `thenRn` \ name -> + if nameUnique name == assertIdKey then + -- We expand it to (GHCerr.assert__ location) + mkAssertExpr `thenRn` \ expr -> + returnRn (expr, emptyUniqSet) + else + -- The normal case + returnRn (HsVar name, if isLocallyDefined name + then unitNameSet name + else emptyUniqSet) rnExpr (HsLit lit) = litOccurrence lit `thenRn_` @@ -277,8 +285,8 @@ rnExpr (OpApp e1 op@(HsVar op_name) _ e2) lookupFixity op_name `thenRn` \ fixity -> getModeRn `thenRn` \ mode -> (case mode of - SourceMode -> mkOpAppRn e1' op' fixity e2' - InterfaceMode _ -> returnRn (OpApp e1' op' fixity e2') + SourceMode -> mkOpAppRn e1' op' fixity e2' + InterfaceMode _ _ -> returnRn (OpApp e1' op' fixity e2') ) `thenRn` \ final_e -> returnRn (final_e, @@ -305,8 +313,11 @@ rnExpr (SectionR op expr) returnRn (SectionR op' expr', fvs_op `unionNameSets` fvs_expr) rnExpr (CCall fun args may_gc is_casm fake_result_ty) + -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls = lookupImplicitOccRn ccallableClass_RDR `thenRn_` lookupImplicitOccRn creturnableClass_RDR `thenRn_` + lookupImplicitOccRn ioDataCon_RDR `thenRn_` + lookupImplicitOccRn ioOkDataCon_RDR `thenRn_` rnExprs args `thenRn` \ (args', fvs_args) -> returnRn (CCall fun args' may_gc is_casm fake_result_ty, fvs_args) @@ -341,10 +352,10 @@ rnExpr (ExplicitTuple exps) rnExprs exps `thenRn` \ (exps', fvExps) -> returnRn (ExplicitTuple exps', fvExps) -rnExpr (RecordCon (HsVar con) rbinds) - = lookupOccRn con `thenRn` \ conname -> +rnExpr (RecordCon con_id _ rbinds) + = lookupOccRn con_id `thenRn` \ conname -> rnRbinds "construction" rbinds `thenRn` \ (rbinds', fvRbinds) -> - returnRn (RecordCon (HsVar conname) rbinds', fvRbinds) + returnRn (RecordCon conname (error "rnExpr:RecordCon") rbinds', fvRbinds) rnExpr (RecordUpd expr rbinds) = rnExpr expr `thenRn` \ (expr', fvExpr) -> @@ -352,8 +363,8 @@ rnExpr (RecordUpd expr rbinds) returnRn (RecordUpd expr' rbinds', fvExpr `unionNameSets` fvRbinds) rnExpr (ExprWithTySig expr pty) - = rnExpr expr `thenRn` \ (expr', fvExpr) -> - rnHsSigType (\ sty -> text "an expression") pty `thenRn` \ pty' -> + = rnExpr expr `thenRn` \ (expr', fvExpr) -> + rnHsSigType (text "an expression") pty `thenRn` \ pty' -> returnRn (ExprWithTySig expr' pty', fvExpr) rnExpr (HsIf p b1 b2 src_loc) @@ -402,7 +413,7 @@ rnRbinds str rbinds mapAndUnzipRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind_s) -> returnRn (rbinds', unionManyNameSets fvRbind_s) where - (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rbinds ] + (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rbinds ] field_dup_err dups = addErrRn (dupFieldErr str dups) @@ -415,7 +426,7 @@ rnRpats rpats = mapRn field_dup_err dup_fields `thenRn_` mapRn rn_rpat rpats where - (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rpats ] + (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rpats ] field_dup_err dups = addErrRn (dupFieldErr "pattern" dups) @@ -538,7 +549,9 @@ mkOpAppRn e1@(NegApp neg_arg neg_op) (nofix_error, rearrange_me) = compareFixity fix_neg fix2 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment - = ASSERT( right_op_ok fix e2 ) + = ASSERT( if right_op_ok fix e2 then True + else pprPanic "mkOpAppRn" (vcat [ppr e1, text "---", ppr op, text "---", ppr fix, text "---", ppr e2]) + ) returnRn (OpApp e1 op fix e2) get (HsVar n) = n @@ -644,10 +657,10 @@ compareFixity :: Fixity -> Fixity -> (Bool, -- Error please Bool) -- Associate to the right: a op1 (b op2 c) compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2) - = case prec1 `cmp` prec2 of - GT_ -> left - LT_ -> right - EQ_ -> case (dir1, dir2) of + = case prec1 `compare` prec2 of + GT -> left + LT -> right + EQ -> case (dir1, dir2) of (InfixR, InfixR) -> right (InfixL, InfixL) -> left _ -> error_please @@ -688,7 +701,9 @@ litOccurrence (HsFrac _) lookupImplicitOccRn ratioDataCon_RDR -- We have to make sure that the Ratio type is imported with -- its constructor, because literals of type Ratio t are - -- built with that constructor. + -- built with that constructor. + -- The Rational type is needed too, but that will come in + -- when fractionalClass does. litOccurrence (HsIntPrim _) = addImplicitOccRn (getName intPrimTyCon) @@ -703,6 +718,28 @@ litOccurrence (HsLitLit _) = lookupImplicitOccRn ccallableClass_RDR \end{code} +%************************************************************************ +%* * +\subsubsection{Assertion utils} +%* * +%************************************************************************ + +\begin{code} +mkAssertExpr :: RnMS s RenamedHsExpr +mkAssertExpr = + newImportedGlobalName mod occ HiFile `thenRn` \ name -> + addOccurrenceName name `thenRn_` + getSrcLocRn `thenRn` \ sloc -> + let + expr = HsApp (HsVar name) + (HsLit (HsString (_PK_ (showSDoc (ppr sloc))))) + in + returnRn expr + + where + mod = rdrNameModule assertErr_RDR + occ = rdrNameOcc assertErr_RDR +\end{code} %************************************************************************ %* * @@ -711,28 +748,29 @@ litOccurrence (HsLitLit _) %************************************************************************ \begin{code} -dupFieldErr str (dup:rest) sty - = hcat [ptext SLIT("duplicate field name `"), - ppr sty dup, - ptext SLIT("' in record "), text str] +dupFieldErr str (dup:rest) + = hsep [ptext SLIT("duplicate field name"), + quotes (ppr dup), + ptext SLIT("in record"), text str] -negPatErr pat sty - = sep [ptext SLIT("prefix `-' not applied to literal in pattern"), ppr sty pat] +negPatErr pat + = sep [ptext SLIT("prefix `-' not applied to literal in pattern"), quotes (ppr pat)] -precParseNegPatErr op sty +precParseNegPatErr op = hang (ptext SLIT("precedence parsing error")) - 4 (hcat [ptext SLIT("prefix `-' has lower precedence than "), - pp_op sty op, - ptext SLIT(" in pattern")]) + 4 (hsep [ptext SLIT("prefix `-' has lower precedence than"), + quotes (pp_op op), + ptext SLIT("in pattern")]) -precParseErr op1 op2 sty +precParseErr op1 op2 = hang (ptext SLIT("precedence parsing error")) - 4 (hcat [ptext SLIT("cannot mix "), pp_op sty op1, ptext SLIT(" and "), pp_op sty op2, - ptext SLIT(" in the same infix expression")]) + 4 (hsep [ptext SLIT("cannot mix"), quotes (pp_op op1), ptext SLIT("and"), + quotes (pp_op op2), + ptext SLIT("in the same infix expression")]) -nonStdGuardErr guard sty +nonStdGuardErr guard = hang (ptext SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")) - 4 (ppr sty guard) + 4 (ppr guard) -pp_op sty (op, fix) = hcat [ppr sty op, space, parens (ppr sty fix)] +pp_op (op, fix) = hcat [ppr op, space, parens (ppr fix)] \end{code}