X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnExpr.lhs;h=992e5c19740a8273da6c6470a7eaf2e2f2312ee3;hb=710e207487929c4a5977b5ee3bc6e539091953db;hp=e1125a91f94e863ba27ce8ea32af0fa3b2e097a2;hpb=180097ce1628a67c97f54b313268600ed1756652;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index e1125a9..992e5c1 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -27,32 +27,27 @@ import RnMonad import RnEnv import RnIfaces ( lookupFixityRn ) import CmdLineOpts ( opt_GlasgowExts, opt_IgnoreAsserts ) -import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity, negatePrecedence ) -import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, +import Literal ( inIntRange ) +import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity ) +import PrelNames ( hasKey, assertIdKey, + eqClass_RDR, foldr_RDR, build_RDR, eqString_RDR, ccallableClass_RDR, creturnableClass_RDR, monadClass_RDR, enumClass_RDR, ordClass_RDR, ratioDataCon_RDR, negate_RDR, assertErr_RDR, - ioDataCon_RDR, addr2Integer_RDR, - foldr_RDR, build_RDR + ioDataCon_RDR, plusInteger_RDR, timesInteger_RDR ) import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon ) -import Name ( nameUnique, isLocallyDefined, NamedThing(..) - , mkSysLocalName, nameSrcLoc - ) +import TysWiredIn ( intTyCon, integerTyCon ) +import Name ( NamedThing(..), mkSysLocalName, nameSrcLoc ) import NameSet import UniqFM ( isNullUFM ) import FiniteMap ( elemFM ) -import UniqSet ( emptyUniqSet, UniqSet ) -import Unique ( hasKey, assertIdKey ) -import Util ( removeDups ) -import ListSetOps ( unionLists ) +import UniqSet ( emptyUniqSet ) +import ListSetOps ( unionLists, removeDups ) import Maybes ( maybeToBool ) import Outputable -import Literal ( inIntRange, tARGET_MAX_INT ) -import RdrName ( mkSrcUnqual ) -import OccName ( varName ) \end{code} @@ -83,10 +78,25 @@ rnPat (SigPatIn pat ty) where doc = text "a pattern type-signature" +rnPat (LitPatIn s@(HsString _)) + = lookupOrigName eqString_RDR `thenRn` \ eq -> + returnRn (LitPatIn s, unitFV eq) + rnPat (LitPatIn lit) - = litOccurrence lit `thenRn` \ fvs1 -> - lookupImplicitOccRn eqClass_RDR `thenRn` \ eq -> -- Needed to find equality on pattern - returnRn (LitPatIn lit, fvs1 `addOneFV` eq) + = litFVs lit `thenRn` \ fvs -> + returnRn (LitPatIn lit, fvs) + +rnPat (NPatIn lit) + = rnOverLit lit `thenRn` \ (lit', fvs1) -> + lookupOrigName eqClass_RDR `thenRn` \ eq -> -- Needed to find equality on pattern + returnRn (NPatIn lit', fvs1 `addOneFV` eq) + +rnPat (NPlusKPatIn name lit minus) + = rnOverLit lit `thenRn` \ (lit', fvs) -> + lookupOrigName ordClass_RDR `thenRn` \ ord -> + lookupBndrRn name `thenRn` \ name' -> + lookupOccRn minus `thenRn` \ minus' -> + returnRn (NPlusKPatIn name' lit' minus', fvs `addOneFV` ord `addOneFV` minus') rnPat (LazyPatIn pat) = rnPat pat `thenRn` \ (pat', fvs) -> @@ -116,33 +126,10 @@ rnPat (ConOpPatIn pat1 con _ pat2) ) `thenRn` \ pat' -> returnRn (pat', fvs1 `plusFV` fvs2 `addOneFV` con') --- Negated patters can only be literals, and they are dealt with --- by negating the literal at compile time, not by using the negation --- operation in Num. So we don't need to make an implicit reference --- to negate_RDR. -rnPat neg@(NegPatIn pat) - = checkRn (valid_neg_pat pat) (negPatErr neg) - `thenRn_` - rnPat pat `thenRn` \ (pat', fvs) -> - returnRn (NegPatIn pat', fvs) - where - valid_neg_pat (LitPatIn (HsInt _)) = True - valid_neg_pat (LitPatIn (HsIntPrim _)) = True - valid_neg_pat (LitPatIn (HsFrac _)) = True - valid_neg_pat (LitPatIn (HsFloatPrim _)) = True - valid_neg_pat (LitPatIn (HsDoublePrim _)) = True - valid_neg_pat _ = False - rnPat (ParPatIn pat) = rnPat pat `thenRn` \ (pat', fvs) -> returnRn (ParPatIn pat', fvs) -rnPat (NPlusKPatIn name lit) - = litOccurrence lit `thenRn` \ fvs -> - lookupImplicitOccRn ordClass_RDR `thenRn` \ ord -> - lookupBndrRn name `thenRn` \ name' -> - returnRn (NPlusKPatIn name' lit, fvs `addOneFV` ord) - rnPat (ListPatIn pats) = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) -> returnRn (ListPatIn patslist, fvs `addOneFV` listTyCon_name) @@ -157,6 +144,9 @@ rnPat (RecPatIn con rpats) = lookupOccRn con `thenRn` \ con' -> rnRpats rpats `thenRn` \ (rpats', fvs) -> returnRn (RecPatIn con' rpats', fvs `addOneFV` con') +rnPat (TypePatIn name) = + (rnHsType (text "type pattern") name) `thenRn` \ (name', fvs) -> + returnRn (TypePatIn name', fvs) \end{code} ************************************************************************ @@ -184,7 +174,7 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss) doc_sig = text "a pattern type-signature" doc_pats = text "in a pattern match" in - bindTyVarsFVRn doc_sig (map UserTyVar forall_tyvars) $ \ sig_tyvars -> + bindNakedTyVarsFVRn doc_sig forall_tyvars $ \ sig_tyvars -> -- Note that we do a single bindLocalsRn for all the -- matches together, so that we spot the repeated variable in @@ -288,19 +278,17 @@ rnExpr (HsVar v) returnRn (HsVar name, unitFV name) rnExpr (HsIPVar v) - = getIPName v `thenRn` \ name -> + = newIPName v `thenRn` \ name -> returnRn (HsIPVar name, emptyFVs) --- Special case for integral literals with a large magnitude: --- They are transformed into an expression involving only smaller --- integral literals. This improves constant folding. -rnExpr (HsLit (HsInt i)) - | not (inIntRange i) = rnExpr (horner tARGET_MAX_INT i) - rnExpr (HsLit lit) - = litOccurrence lit `thenRn` \ fvs -> + = litFVs lit `thenRn` \ fvs -> returnRn (HsLit lit, fvs) +rnExpr (HsOverLit lit) + = rnOverLit lit `thenRn` \ (lit', fvs) -> + returnRn (HsOverLit lit', fvs) + rnExpr (HsLam match) = rnMatch match `thenRn` \ (match', fvMatch) -> returnRn (HsLam match', fvMatch) @@ -330,16 +318,10 @@ rnExpr (OpApp e1 op _ e2) returnRn (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) --- constant-fold some negate applications on unboxed literals. Since --- negate is a polymorphic function, we have to do these here. -rnExpr (NegApp (HsLit (HsIntPrim i)) _) = rnExpr (HsLit (HsIntPrim (-i))) -rnExpr (NegApp (HsLit (HsFloatPrim i)) _) = rnExpr (HsLit (HsFloatPrim (-i))) -rnExpr (NegApp (HsLit (HsDoublePrim i)) _) = rnExpr (HsLit (HsDoublePrim (-i))) - rnExpr (NegApp e n) - = rnExpr e `thenRn` \ (e', fv_e) -> - lookupImplicitOccRn negate_RDR `thenRn` \ neg -> - mkNegAppRn e' (HsVar neg) `thenRn` \ final_e -> + = rnExpr e `thenRn` \ (e', fv_e) -> + lookupOrigName negate_RDR `thenRn` \ neg -> + mkNegAppRn e' neg `thenRn` \ final_e -> returnRn (final_e, fv_e `addOneFV` neg) rnExpr (HsPar e) @@ -360,7 +342,7 @@ rnExpr section@(SectionR op expr) rnExpr (HsCCall fun args may_gc is_casm fake_result_ty) -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls - = lookupImplicitOccsRn [ccallableClass_RDR, + = lookupOrigNames [ccallableClass_RDR, creturnableClass_RDR, ioDataCon_RDR] `thenRn` \ implicit_fvs -> rnExprs args `thenRn` \ (args', fvs_args) -> @@ -389,7 +371,7 @@ rnExpr (HsWith expr binds) rnExpr e@(HsDo do_or_lc stmts src_loc) = pushSrcLocRn src_loc $ - lookupImplicitOccsRn implicit_rdr_names `thenRn` \ implicit_fvs -> + lookupOrigNames implicit_rdr_names `thenRn` \ implicit_fvs -> rnStmts rnExpr stmts `thenRn` \ (stmts', fvs) -> -- check the statement list ends in an expression case last stmts' of { @@ -437,8 +419,13 @@ rnExpr (HsIf p b1 b2 src_loc) rnExpr b2 `thenRn` \ (b2', fvB2) -> returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2]) +rnExpr (HsType a) = + (rnHsType doc a) `thenRn` \ (t, fvT) -> returnRn (HsType t, fvT) + where doc = text "renaming a type pattern" + + rnExpr (ArithSeqIn seq) - = lookupImplicitOccRn enumClass_RDR `thenRn` \ enum -> + = lookupOrigName enumClass_RDR `thenRn` \ enum -> rn_seq seq `thenRn` \ (new_seq, fvs) -> returnRn (ArithSeqIn new_seq, fvs `addOneFV` enum) where @@ -477,19 +464,10 @@ rnExpr e@(EAsPat _ _) = addErrRn (patSynErr e) `thenRn_` rnExpr e@(ELazyPat _) = addErrRn (patSynErr e) `thenRn_` returnRn (EWildPat, emptyFVs) - --- Transform i into (x1 + (x2 + (x3 + (...) * b) * b) * b) with abs xi <= b -horner :: Integer -> Integer -> RdrNameHsExpr -horner b i | abs q <= 1 = if r == 0 || r == i then mkInt i else mkInt r `plus` mkInt (i-r) - | r == 0 = horner b q `times` mkInt b - | otherwise = mkInt r `plus` (horner b q `times` mkInt b) - where (q,r) = i `quotRem` b - mkInt i = HsLit (HsInt i) - plus = mkOp "+" - times = mkOp "*" - mkOp op = \x y -> HsPar (OpApp x (HsVar (mkSrcUnqual varName (_PK_ op))) (panic "fixity") y) \end{code} + + %************************************************************************ %* * \subsubsection{@Rbinds@s and @Rpats@s: in record expressions} @@ -535,7 +513,7 @@ rnRpats rpats \begin{code} rnIPBinds [] = returnRn ([], emptyFVs) rnIPBinds ((n, expr) : binds) - = getIPName n `thenRn` \ name -> + = newIPName n `thenRn` \ name -> rnExpr expr `thenRn` \ (expr',fvExpr) -> rnIPBinds binds `thenRn` \ (binds',fvBinds) -> returnRn ((name, expr') : binds', fvExpr `plusFV` fvBinds) @@ -715,14 +693,6 @@ mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12) where (nofix_error, associate_right) = compareFixity fix1 fix2 -mkConOpPatRn p1@(NegPatIn neg_arg) - op2 - fix2@(Fixity prec2 dir2) - p2 - | prec2 > negatePrecedence -- Precedence of unary - is wired in - = addErrRn (precParseNegPatErr (ppr_op op2,fix2)) `thenRn_` - returnRn (ConOpPatIn p1 op2 fix2 p2) - mkConOpPatRn p1 op fix p2 -- Default case, no rearrangment = ASSERT( not_op_pat p2 ) returnRn (ConOpPatIn p1 op fix p2) @@ -763,10 +733,6 @@ checkPrec op (ConOpPatIn _ op1 _ _) right in checkRn inf_ok (precParseErr infol infor) -checkPrec op (NegPatIn _) right - = lookupFixityRn op `thenRn` \ op_fix@(Fixity op_prec op_dir) -> - checkRn (op_prec <= negatePrecedence) (precParseNegPatErr (ppr_op op,op_fix)) - checkPrec op pat right = returnRn () @@ -776,7 +742,7 @@ checkPrec op pat right checkSectionPrec left_or_right section op arg = case arg of OpApp _ op fix _ -> go_for_it (ppr_op op) fix - NegApp _ op -> go_for_it pp_prefix_minus negateFixity + NegApp _ _ -> go_for_it pp_prefix_minus negateFixity other -> returnRn () where HsVar op_name = op @@ -822,42 +788,39 @@ that the types and classes they involve are made available. \begin{code} -litOccurrence (HsChar _) - = returnRn (unitFV charTyCon_name) - -litOccurrence (HsCharPrim _) - = returnRn (unitFV (getName charPrimTyCon)) - -litOccurrence (HsString _) - = returnRn (unitFV listTyCon_name `plusFV` unitFV charTyCon_name) - -litOccurrence (HsStringPrim _) - = returnRn (unitFV (getName addrPrimTyCon)) - -litOccurrence (HsInt _) - = lookupImplicitOccsRn [numClass_RDR, addr2Integer_RDR] - -- Int and Integer are forced in by Num +litFVs (HsChar c) = returnRn (unitFV charTyCon_name) +litFVs (HsCharPrim c) = returnRn (unitFV (getName charPrimTyCon)) +litFVs (HsString s) = returnRn (mkFVs [listTyCon_name, charTyCon_name]) +litFVs (HsStringPrim s) = returnRn (unitFV (getName addrPrimTyCon)) +litFVs (HsInt i) = returnRn (unitFV (getName intTyCon)) +litFVs (HsIntPrim i) = returnRn (unitFV (getName intPrimTyCon)) +litFVs (HsFloatPrim f) = returnRn (unitFV (getName floatPrimTyCon)) +litFVs (HsDoublePrim d) = returnRn (unitFV (getName doublePrimTyCon)) +litFVs (HsLitLit l bogus_ty) = lookupOrigName ccallableClass_RDR `thenRn` \ cc -> + returnRn (unitFV cc) +litFVs lit = pprPanic "RnExpr.litFVs" (ppr lit) -- HsInteger and HsRat only appear + -- in post-typechecker translations + +rnOverLit (HsIntegral i from_integer) + = lookupOccRn from_integer `thenRn` \ from_integer' -> + (if inIntRange i then + returnRn emptyFVs + else + lookupOrigNames [plusInteger_RDR, timesInteger_RDR] + ) `thenRn` \ ns -> + returnRn (HsIntegral i from_integer', ns `addOneFV` from_integer') -litOccurrence (HsFrac _) - = lookupImplicitOccsRn [fractionalClass_RDR,ratioDataCon_RDR,addr2Integer_RDR] +rnOverLit (HsFractional i n) + = lookupOccRn n `thenRn` \ n' -> + lookupOrigNames [ratioDataCon_RDR, plusInteger_RDR, timesInteger_RDR] `thenRn` \ ns' -> -- 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. -- The Rational type is needed too, but that will come in -- when fractionalClass does. - -litOccurrence (HsIntPrim _) - = returnRn (unitFV (getName intPrimTyCon)) - -litOccurrence (HsFloatPrim _) - = returnRn (unitFV (getName floatPrimTyCon)) - -litOccurrence (HsDoublePrim _) - = returnRn (unitFV (getName doublePrimTyCon)) - -litOccurrence (HsLitLit _) - = lookupImplicitOccRn ccallableClass_RDR `thenRn` \ cc -> - returnRn (unitFV cc) + -- The plus/times integer operations may be needed to construct the numerator + -- and denominator (see DsUtils.mkIntegerLit) + returnRn (HsFractional i n', ns' `addOneFV` n') \end{code} %************************************************************************ @@ -869,8 +832,8 @@ litOccurrence (HsLitLit _) \begin{code} mkAssertExpr :: RnMS (RenamedHsExpr, FreeVars) mkAssertExpr = - mkImportedGlobalFromRdrName assertErr_RDR `thenRn` \ name -> - getSrcLocRn `thenRn` \ sloc -> + lookupOrigName assertErr_RDR `thenRn` \ name -> + getSrcLocRn `thenRn` \ sloc -> -- if we're ignoring asserts, return (\ _ e -> e) -- if not, return (assertError "src-loc") @@ -913,16 +876,6 @@ dupFieldErr str (dup:rest) quotes (ppr dup), ptext SLIT("in record"), text str] -negPatErr pat - = sep [pp_prefix_minus <+> ptext SLIT("not applied to literal in pattern"), - quotes (ppr pat)] - -precParseNegPatErr op - = hang (ptext SLIT("precedence parsing error")) - 4 (hsep [pp_prefix_minus <+> ptext SLIT("has lower precedence than"), - ppr_opfix op, - ptext SLIT("in pattern")]) - precParseErr op1 op2 = hang (ptext SLIT("precedence parsing error")) 4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"),